{-# LANGUAGE CPP #-}
module Control.Instances.Package.Haskell2010 () where
#ifdef MIN_VERSION_haskell2010
#if MIN_VERSION_haskell2010(1,1,2)
import Prelude ()
import Control.Monad ()
import Data.Array ()
import Data.Bits ()
import Data.Char ()
import Data.Complex ()
import Data.Int ()
import Data.Ix ()
import Data.List ()
import Data.Maybe ()
import Data.Ratio ()
import Data.Word ()
import Foreign ()
import Foreign.C ()
import Foreign.C.Error ()
import Foreign.C.String ()
import Foreign.C.Types ()
import Foreign.ForeignPtr ()
import Foreign.Marshal ()
import Foreign.Marshal.Alloc ()
import Foreign.Marshal.Array ()
import Foreign.Marshal.Error ()
import Foreign.Marshal.Utils ()
import Foreign.Ptr ()
import Foreign.StablePtr ()
import Foreign.Storable ()
import Numeric ()
import System.Environment ()
import System.Exit ()
import System.IO ()
import System.IO.Error ()
#elif MIN_VERSION_haskell2010(1,1,1)
import Data.Array ()
import Data.Char ()
import Data.Complex ()
import System.IO ()
import System.IO.Error ()
import Data.Ix ()
import Data.List ()
import Data.Maybe ()
import Control.Monad ()
import Data.Ratio ()
import System.Environment ()
import System.Exit ()
import Numeric ()
import Prelude ()
import Data.Int ()
import Data.Word ()
import Data.Bits ()
import Foreign ()
import Foreign.Ptr ()
import Foreign.ForeignPtr ()
import Foreign.StablePtr ()
import Foreign.Storable ()
import Foreign.C ()
import Foreign.C.Error ()
import Foreign.C.String ()
import Foreign.C.Types ()
import Foreign.Marshal ()
import Foreign.Marshal.Alloc ()
import Foreign.Marshal.Array ()
import Foreign.Marshal.Error ()
import Foreign.Marshal.Utils ()
#elif MIN_VERSION_haskell2010(1,1,0)
import Data.Array ()
import Data.Char ()
import Data.Complex ()
import System.IO ()
import System.IO.Error ()
import Data.Ix ()
import Data.List ()
import Data.Maybe ()
import Control.Monad ()
import Data.Ratio ()
import System.Environment ()
import System.Exit ()
import Numeric ()
import Prelude ()
import Data.Int ()
import Data.Word ()
import Data.Bits ()
import Foreign ()
import Foreign.Ptr ()
import Foreign.ForeignPtr ()
import Foreign.StablePtr ()
import Foreign.Storable ()
import Foreign.C ()
import Foreign.C.Error ()
import Foreign.C.String ()
import Foreign.C.Types ()
import Foreign.Marshal ()
import Foreign.Marshal.Alloc ()
import Foreign.Marshal.Array ()
import Foreign.Marshal.Error ()
import Foreign.Marshal.Utils ()
#elif MIN_VERSION_haskell2010(1,1,0)
import Data.Array ()
import Data.Char ()
import Data.Complex ()
import System.IO ()
import System.IO.Error ()
import Data.Ix ()
import Data.List ()
import Data.Maybe ()
import Control.Monad ()
import Data.Ratio ()
import System.Environment ()
import System.Exit ()
import Numeric ()
import Prelude ()
import Data.Int ()
import Data.Word ()
import Data.Bits ()
import Foreign ()
import Foreign.Ptr ()
import Foreign.ForeignPtr ()
import Foreign.StablePtr ()
import Foreign.Storable ()
import Foreign.C ()
import Foreign.C.Error ()
import Foreign.C.String ()
import Foreign.C.Types ()
import Foreign.Marshal ()
import Foreign.Marshal.Alloc ()
import Foreign.Marshal.Array ()
import Foreign.Marshal.Error ()
import Foreign.Marshal.Utils ()
#elif MIN_VERSION_haskell2010(1,0,0)
import Data.Array ()
import Data.Char ()
import Data.Complex ()
import System.IO ()
import System.IO.Error ()
import Data.Ix ()
import Data.List ()
import Data.Maybe ()
import Control.Monad ()
import Data.Ratio ()
import System.Environment ()
import System.Exit ()
import Numeric ()
import Prelude ()
import Data.Int ()
import Data.Word ()
import Data.Bits ()
import Foreign ()
import Foreign.Ptr ()
import Foreign.ForeignPtr ()
import Foreign.StablePtr ()
import Foreign.Storable ()
import Foreign.C ()
import Foreign.C.Error ()
import Foreign.C.String ()
import Foreign.C.Types ()
import Foreign.Marshal ()
import Foreign.Marshal.Alloc ()
import Foreign.Marshal.Array ()
import Foreign.Marshal.Error ()
import Foreign.Marshal.Utils ()
#endif
#endif


module Hasql.Private.Prelude
(
  module Exports,
  LazyByteString,
  ByteStringBuilder,
  LazyText,
  TextBuilder,
  forMToZero_,
  forMFromZero_,
  strictCons,
  mapLeft,
)
where

-- base
-------------------------
import Control.Applicative as Exports hiding (WrappedArrow(..))
import Control.Arrow as Exports hiding (first, second)
import Control.Category as Exports
import Control.Concurrent as Exports
import Control.Exception as Exports
import Control.Monad as Exports hiding (fail, mapM_, sequence_, forM_, msum, mapM, sequence, forM)
import Control.Monad.IO.Class as Exports
import Control.Monad.Fail as Exports
import Control.Monad.Fix as Exports hiding (fix)
import Control.Monad.ST as Exports
import Data.Bifunctor as Exports
import Data.Bits as Exports
import Data.Bool as Exports
import Data.Char as Exports
import Data.Coerce as Exports
import Data.Complex as Exports
import Data.Data as Exports
import Data.Dynamic as Exports
import Data.Either as Exports
import Data.Fixed as Exports
import Data.Foldable as Exports hiding (toList)
import Data.Function as Exports hiding (id, (.))
import Data.Functor as Exports
import Data.Functor.Compose as Exports
import Data.Functor.Contravariant as Exports
import Data.Int as Exports
import Data.IORef as Exports
import Data.Ix as Exports
import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')
import Data.List.NonEmpty as Exports (NonEmpty(..))
import Data.Maybe as Exports
import Data.Monoid as Exports hiding (Alt, (<>))
import Data.Ord as Exports
import Data.Proxy as Exports
import Data.Ratio as Exports
import Data.Semigroup as Exports hiding (First(..), Last(..))
import Data.STRef as Exports
import Data.String as Exports
import Data.Traversable as Exports
import Data.Tuple as Exports
import Data.Unique as Exports
import Data.Version as Exports
import Data.Void as Exports
import Data.Word as Exports
import Debug.Trace as Exports
import Foreign.ForeignPtr as Exports
import Foreign.Ptr as Exports
import Foreign.StablePtr as Exports
import Foreign.Storable as Exports
import GHC.Conc as Exports hiding (orElse, withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)
import GHC.Exts as Exports (IsList(..), lazy, inline, sortWith, groupWith)
import GHC.Generics as Exports (Generic)
import GHC.IO.Exception as Exports
import GHC.OverloadedLabels as Exports
import Numeric as Exports
import Prelude as Exports hiding (Read, fail, concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.))
import System.Environment as Exports
import System.Exit as Exports
import System.IO as Exports (Handle, hClose)
import System.IO.Error as Exports
import System.IO.Unsafe as Exports
import System.Mem as Exports
import System.Mem.StableName as Exports
import System.Timeout as Exports
import Text.ParserCombinators.ReadP as Exports (ReadP, readP_to_S, readS_to_P)
import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)
import Text.Printf as Exports (printf, hPrintf)
import Unsafe.Coerce as Exports

-- transformers
-------------------------
import Control.Monad.IO.Class as Exports
import Control.Monad.Trans.Class as Exports
import Control.Monad.Trans.Cont as Exports hiding (shift, callCC)
import Control.Monad.Trans.Except as Exports (ExceptT(ExceptT), Except, except, runExcept, runExceptT, mapExcept, mapExceptT, withExcept, withExceptT, throwE, catchE)
import Control.Monad.Trans.Maybe as Exports
import Control.Monad.Trans.Reader as Exports (Reader, ask, runReader, mapReader, withReader, ReaderT(ReaderT), runReaderT, mapReaderT, withReaderT)
import Control.Monad.Trans.State.Strict as Exports (State, runState, evalState, execState, mapState, withState, StateT(StateT), runStateT, evalStateT, execStateT, mapStateT, withStateT)
import Control.Monad.Trans.Writer.Strict as Exports (Writer, runWriter, execWriter, mapWriter, WriterT(..), execWriterT, mapWriterT)
import Data.Functor.Compose as Exports
import Data.Functor.Identity as Exports

-- mtl
-------------------------
import Control.Monad.Error.Class as Exports (MonadError (..))

-- profunctors
-------------------------
import Data.Profunctor.Unsafe as Exports

-- contravariant
-------------------------
import Data.Functor.Contravariant.Divisible as Exports

-- hashable
-------------------------
import Data.Hashable as Exports (Hashable(..))

-- text
-------------------------
import Data.Text as Exports (Text)

-- bytestring
-------------------------
import Data.ByteString as Exports (ByteString)

-- vector
-------------------------
import Data.Vector as Exports (Vector)

-- dlist
-------------------------
import Data.DList as Exports (DList)

-- postgresql-binary
-------------------------
import PostgreSQL.Binary.Data as Exports (UUID)

-- custom
-------------------------
import qualified Data.Text.Lazy
import qualified Data.Text.Lazy.Builder
import qualified Data.ByteString.Lazy
import qualified Data.ByteString.Builder

type LazyByteString =
  Data.ByteString.Lazy.ByteString

type ByteStringBuilder =
  Data.ByteString.Builder.Builder

type LazyText =
  Data.Text.Lazy.Text

type TextBuilder =
  Data.Text.Lazy.Builder.Builder

{-# INLINE forMToZero_ #-}
forMToZero_ :: Applicative m => Int -> (Int -> m a) -> m ()
forMToZero_ !startN f =
  ($ pred startN) $ fix $ \loop !n -> if n >= 0 then f n *> loop (pred n) else pure ()

{-# INLINE forMFromZero_ #-}
forMFromZero_ :: Applicative m => Int -> (Int -> m a) -> m ()
forMFromZero_ !endN f =
  ($ 0) $ fix $ \loop !n -> if n < endN then f n *> loop (succ n) else pure ()

{-# INLINE strictCons #-}
strictCons :: a -> [a] -> [a]
strictCons !a b =
  let !c = a : b in c

{-# INLINE mapLeft #-}
mapLeft :: (a -> c) -> Either a b -> Either c b
mapLeft f =
  either (Left . f) Right


module Fibon.Run.BenchmarkRunner (
    RunResult(..)
  , RunFailure(..)
  , Fibon.Run.BenchmarkRunner.run
)
where

import Control.Concurrent
import Control.Monad
import Control.Exception
import qualified Data.ByteString as B
import Data.Maybe
import Data.Time.Clock
import qualified Data.Vector.Unboxed as Vector
import Fibon.BenchmarkInstance
import Fibon.Result
import Fibon.Run.BenchmarkBundle
import Fibon.Run.Log as Log
import qualified Fibon.Run.SysTools as SysTools
import Statistics.Sample
import System.Directory
import System.FilePath
import System.IO
import System.Process
import Text.Printf

data RunResult =
    Success {runSummary :: RunSummary, runDetails :: [RunDetail]}
  | Failure [RunFailure]
  deriving (Read, Show)

data RunFailure =
    MissingOutput FilePath
  | DiffError     String
  | Timeout
  | ExitError     {exitExpected :: ExitCode, exitActual :: ExitCode}
  deriving (Read, Show)

run :: BenchmarkBundle -> IO RunResult
run bb = do
  let bmk = (bundleName bb)
      pwd = (pathToExeBuildDir bb)
      cmd = (prettyRunCommand bb)
  Log.info $ "Running Benchmark "
  Log.info $ "   BMK: " ++ bmk
  Log.info $ "   PWD: " ++ pwd
  Log.info $ "   CMD: " ++ cmd
  Log.info $ printf "\n@%s|%s|%s" bmk pwd cmd
  runDirect bb

checkResult :: BenchmarkBundle -> ExitCode -> IO (Maybe [RunFailure])
checkResult bb exitCode = do
  outputs <- mapM (checkOutput bb) (output . benchDetails $ bb)
  let results = checkExit bb exitCode : outputs
      errs    = filter isJust results
  case errs of
    [] -> return $ Nothing
    es -> return $ Just (catMaybes es)

checkExit :: BenchmarkBundle -> ExitCode -> Maybe RunFailure
checkExit bb actual = if actual == expected then Nothing else Just ee
  where expected = expectedExit . benchDetails $ bb
        ee       = ExitError {exitExpected = expected, exitActual = actual}

checkOutput :: BenchmarkBundle -> OutputDescription -> IO (Maybe RunFailure)
checkOutput bb (o, Exists) = do
  let f = (destinationToRealFile bb o)
  e <- doesFileExist f
  if e then return   Nothing
       else return $ Just $ MissingOutput ("File "++f++" does not exist")
checkOutput bb (o, Diff diffFile) = do
  e1 <- checkOutput bb (o, Exists)
  e2 <- checkOutput bb (d, Exists)
  e3 <- runDiff f1 f2
  return $ msum [e1, e2, e3]
  where
  d  = OutputFile diffFile
  f1 = (destinationToRealFile bb o)
  f2 = (destinationToRealFile bb d)

runDiff :: FilePath -> FilePath -> IO (Maybe RunFailure)
runDiff f1 f2 = do
  Log.info $ "Diffing files: "++f1++" "++f2
  (r, o, _) <- readProcessWithExitCode (SysTools.diff) [f1, f2] ""
  if r == ExitSuccess then Log.info "No diff error" >>
                           return   Nothing
                      else Log.info "Diff error" >>
                           (return $ Just $ DiffError o)

destinationToRealFile :: BenchmarkBundle -> OutputDestination -> FilePath
destinationToRealFile bb (OutputFile f) = (pathToExeRunDir bb)  </> f
destinationToRealFile bb  Stdout        = (pathToStdoutFile bb)
destinationToRealFile bb  Stderr        = (pathToStderrFile bb)

readExtraStats :: BenchmarkBundle -> IO ExtraStats
readExtraStats bb = do
  let mbStatsFile   = extraStats bb
      statsFile     = fromJust mbStatsFile
      logReadE :: IOException -> IO ExtraStats
      logReadE e =
        Log.warn ("Error reading stats file: "++statsFile++"\n  "++show e)
        >> return B.empty
  case mbStatsFile of
    Nothing -> return B.empty
    Just f  -> do
      handle logReadE $
        bracket (openFile ((pathToExeRunDir bb) </> f) ReadMode)
                (hClose)
                (\h -> B.hGetContents h >>= \s -> B.length s `seq` return s)

type RunStepResult = IO (Either [RunFailure] RunDetail)

runDirect :: BenchmarkBundle -> IO RunResult
runDirect bb = do
  mbDetails <- go count []
  case mbDetails of
    Left e   -> return $ Failure e
    Right ds -> return $ Success (summarize ds) ds
  where
  go 0 ds = return $ Right (reverse ds)
  go n ds = do
    res <- runB bb
    case res of
      Right d -> go (n-1) (d:ds)
      Left e  -> return $ Left e
  runB    = maybe runBenchmarkWithoutTimeout runBenchmarkWithTimeout limit
  limit   = timeout bb
  count   = (iters bb)

summarize :: [RunDetail] -> RunSummary
summarize ds = RunSummary {
      meanTime     = mean times
    , stdDevTime   = stdDev times
    , statsSummary = stats
  }
  where
    times = (Vector.fromList $ map runTime ds)
    stats = case ds of (x:_) -> runStats x; _ -> B.empty

type TimeoutLength = Int
runBenchmarkWithTimeout :: TimeoutLength -> BenchmarkBundle -> RunStepResult
runBenchmarkWithTimeout us bb = do
  resMVar <- newEmptyMVar
  pidMVar <- newEmptyMVar
  tid1 <- forkIO $ (putMVar resMVar . Just) =<< timeBenchmarkExe bb (Just pidMVar)
  _    <- forkIO $ threadDelay us >> putMVar resMVar Nothing
  res <- takeMVar resMVar
  case res of
    Nothing -> do
      Log.info $ "benchmark timed out after "++(show us)++" us"
      -- try to kill the subprocess
      pid <- tryTakeMVar pidMVar
      maybe pass terminateProcess pid
      -- kill the haskell thread
      killThread tid1
      return $ Left [Timeout]
    Just (runDetail, exitCode) -> do
       maybe (Right runDetail) Left `liftM` checkResult bb exitCode

runBenchmarkWithoutTimeout :: BenchmarkBundle -> RunStepResult
runBenchmarkWithoutTimeout bb = do
  (runDetail, exitCode) <- timeBenchmarkExe bb Nothing
  maybe (Right runDetail) Left `liftM` checkResult bb exitCode

timeBenchmarkExe :: BenchmarkBundle            -- benchmark to run
                 -> Maybe (MVar ProcessHandle) -- in case we need to kill it
                 -> IO (RunDetail, ExitCode)
timeBenchmarkExe bb pidMVar = do
  p     <- bundleProcessSpec bb
  start <- getCurrentTime
  (_, _, _, pid) <- createProcess p
  maybe pass (flip putMVar pid) pidMVar
  exit  <- waitForProcess pid
  end   <- getCurrentTime
  mapM_ closeStdIO [std_in  p, std_out p, std_err p]
  stats <- readExtraStats bb
  return $ (RunDetail (realToFrac (diffUTCTime end start)) stats, exit)

closeStdIO :: StdStream -> IO ()
closeStdIO (UseHandle h) = hClose h
closeStdIO _             = return ()

pass :: IO ()
pass = return()


{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLabels #-}

module NotificationCenter where

import Config
  (replaceColors,getConfig,Config(..))
import NotificationCenter.NotificationInCenter
  (DisplayingNotificationInCenter(..), showNotification, updateNoti)
import NotificationCenter.Notifications
  (NotifyState(..), startNotificationDaemon, hideAllNotis)
import NotificationCenter.Notifications.Data (Notification(..))
import NotificationCenter.Glade (glade, style)
import NotificationCenter.Button
  (Button(..), createButton, setButtonState)
import TransparentWindow
import Helpers

import Prelude

import Text.I18N.GetText
import System.Locale.SetLocale
import System.IO.Unsafe

import Data.Int (Int32(..))
import Data.Tuple.Sequence (sequenceT)
import Data.Maybe
import Data.IORef
import Data.List
import Data.Time
import Data.Time.LocalTime
import qualified Data.Text as Text
import qualified Data.ByteString.Char8 as BS
import qualified Data.Map as Map
import Data.Complex
import Data.Monoid ((<>))

import Control.Monad
import Control.Applicative
import Control.Concurrent (forkIO, threadDelay, ThreadId(..))
import Control.Concurrent.STM
  ( readTVarIO, modifyTVar', TVar(..), atomically, newTVarIO )

import System.Process (runCommand)
import System.Locale.Read
import System.Posix.Signals (sigUSR1)
import System.Posix.Daemonize (serviced, daemonize)
import System.Directory (getXdgDirectory, XdgDirectory(..))

import DBus ( fromVariant )

import GI.Gtk
       (buttonSetLabel, widgetSetHalign, widgetSetHexpand, buttonNew, setWidgetMargin, buttonSetRelief, widgetSetSizeRequest, widgetShowAll, widgetShow, widgetHide, onWidgetDestroy
       , windowSetDefaultSize, setWindowTitle, boxPackStart, boxNew
       , setWindowWindowPosition, WindowPosition(..), windowMove
       , frameSetShadowType, aspectFrameNew
       , widgetGetAllocatedHeight, widgetGetAllocatedWidth, onWidgetDraw
       , onWidgetLeaveNotifyEvent, onWidgetMotionNotifyEvent
       , widgetAddEvents, alignmentSetPadding, alignmentNew, rangeSetValue
       , scaleSetDigits, scaleSetValuePos, rangeGetValue
       , afterScaleButtonValueChanged, scaleNewWithRange, containerAdd
       , buttonBoxNew, mainQuit, onButtonActivate
       , toggleButtonGetActive, onToggleButtonToggled, buttonSetUseStock
       , toggleButtonNewWithLabel, onButtonClicked
       , buttonNewWithLabel, widgetQueueDraw, drawingAreaNew
       , windowNew, widgetDestroy, dialogRun, setAboutDialogComments
       , setAboutDialogAuthors, setAboutDialogVersion
       , setAboutDialogProgramName, aboutDialogNew, labelNew, get
       , afterWindowSetFocus, labelSetText
       , onWidgetFocusOutEvent, onWidgetKeyReleaseEvent, widgetGetParentWindow
       , onButtonClicked, windowGetScreen, boxNew, widgetSetValign)
import qualified GI.Gtk as Gtk (containerAdd, Window(..), Box(..), Label(..), Button(..))

import qualified GI.Gtk as GI (init, main)
import GI.GLib (sourceRemove, timeoutAdd, unixSignalAdd)
import GI.GLib.Constants
import GI.Gdk.Constants
import GI.Gdk.Flags (EventMask(..))
import GI.Gtk.Enums
       (Orientation(..), WindowType(..), ShadowType(..)
       , PositionType(..), ReliefStyle(..), Align(..))
import Data.GI.Base.BasicConversions (gflagsToWord)
import qualified GI.Gdk.Objects.Window

data State = State
  { stMainWindow :: Gtk.Window
  , stNotiBox :: Gtk.Box
  , stTimeLabel :: Gtk.Label
  , stDateLabel :: Gtk.Label
  , stDeleteAll :: Gtk.Button
  , stUserButtons :: [ Button ]
  , stNotiState :: TVar NotifyState
  , stDisplayingNotiList :: [ DisplayingNotificationInCenter ]
  , stNotisForMe :: [ Notification ]
  , stCenterShown :: Bool
  }

setTime :: TVar State -> IO Bool
setTime tState = do
  state <- readTVarIO tState
  now <- zonedTimeToLocalTime <$> getZonedTime
  zone <- System.Locale.Read.getCurrentLocale
  let format = Text.pack . flip (formatTime zone) now
  labelSetText (stTimeLabel state) $ format "%H:%M"
  labelSetText (stDateLabel state) $ format "%A, %x"
  return False

startSetTimeThread :: TVar State -> IO ()
startSetTimeThread tState = do
  runAfterDelay 1000 (startSetTimeThread' tState)
  return ()

startSetTimeThread' :: TVar State -> IO ()
startSetTimeThread' tState = do
  addSource (setTime tState)
  time <- fromIntegral <$> diffTimeToPicoseconds <$> utctDayTime <$> getCurrentTime
  let delay = (60 * 1000000) - ((ceiling (time / 1000000)) `mod` (1000000 * 60))
  runAfterDelay delay (startSetTimeThread' tState)
  return ()

createNotiCenter :: TVar State -> Config -> IO ()
createNotiCenter tState config = do
  (objs, _) <- createTransparentWindow (Text.pack glade)
    [ "main_window"
    , "label_time"
    , "label_date"
    , "box_notis"
    , "box_buttons"
    , "button_deleteAll" ]
    (Just "Notification area")

  mainWindow <- window objs "main_window"
  notiBox <- box objs "box_notis"
  buttonBox <- box objs "box_buttons"
  timeL <- label objs "label_time"
  timeD <- label objs "label_date"
  deleteButton <- button objs "button_deleteAll"

  screen <- windowGetScreen mainWindow
  setStyle screen $ BS.pack $
    replaceColors config style
--  (Just mainWindowGDK) <- widgetGetParentWindow mainWindow

  onButtonClicked deleteButton $ do
    displayList <- stDisplayingNotiList <$> readTVarIO tState
    mapM (removeNoti tState) displayList
    return ()
  buttonSetLabel deleteButton $ Text.pack $ translate "Delete all"

  let buttons = zip
        (split $ removeOuterLetters $ configLabels config)
        (split $ removeOuterLetters $ configCommands config)
      (buttonLabels, buttonCommands) = unzip buttons
      margin = fromIntegral $ configButtonMargin config
      width = fromIntegral (((configWidth config) - 20)
                            `div` (configButtonsPerRow config))
              - margin * 2
      height = fromIntegral $ configButtonHeight config
      linesNeeded = fromIntegral $ ceiling
        $ ((fromIntegral $ length buttons) / (fromIntegral $ configButtonsPerRow config))
  lines' <- sequence $ take linesNeeded $ repeat $ boxNew OrientationHorizontal 0
  buttons' <- sequence $ map
    (\(label, command) -> createButton config width height command label)
    buttons

  sequence $ map (\(box, buttons'') ->
                    sequence $ Gtk.containerAdd box <$> buttons'')
    $ zip (reverse lines') (splitEvery (configButtonsPerRow config)
                            $ (buttonButton <$> buttons'))
  sequence $ Gtk.containerAdd buttonBox <$> lines'
  sequence $ widgetShowAll <$> lines'

  atomically $ modifyTVar' tState $
    \state -> state { stMainWindow = mainWindow
                      , stNotiBox = notiBox
                      , stTimeLabel = timeL
                      , stDateLabel = timeD
                      , stDeleteAll = deleteButton
                      , stNotisForMe = []
                      , stUserButtons = buttons' }

  startSetTimeThread tState

  onWidgetLeaveNotifyEvent mainWindow $ \(_) -> do
    hideNotiCenter tState
    return True

  setNotificationCenterPosition mainWindow config

  onWidgetDestroy mainWindow mainQuit

  return ()

setNotificationCenterPosition mainWindow config = do
  (screenW, screenY, screenH) <- getScreenPos mainWindow
    (fromIntegral $ configNotiCenterMonitor config)

  windowSetDefaultSize mainWindow
    width -- w
    (screenH - barHeightTop - barHeightBottom) -- h
  windowMove mainWindow
    (screenW - width - marginRight) -- x
    (screenY + barHeightTop)  -- y
  return ()
    where
      barHeightTop = fromIntegral $ configBarHeight config
      barHeightBottom = fromIntegral $ configBottomBarHeight config
      marginRight = fromIntegral $ configRightMargin config
      width = fromIntegral $ configWidth config

parseNotisForMe tState = do
  state <- readTVarIO tState
  -- do stuff
  let buttons = stUserButtons state
      notisForMe = stNotisForMe state
      myNotiHints = notiHints <$> notisForMe
      maybeIds = Map.lookup "id" <$> myNotiHints
      ids = join <$> map (\id' -> fromVariant <$> id') maybeIds :: [ Maybe Int32 ]
      ids' = map checkId ids
        where
          checkId (Just id)
            | id < (fromIntegral $ length buttons) = Just id
            | otherwise = Nothing
          checkId Nothing = Nothing
      maybeStates = Map.lookup "state" <$> myNotiHints
      states = join <$> map (\id' -> fromVariant <$> id') maybeStates :: [ Maybe Bool ]
      comb = sequenceT <$> (zip
                            (map
                             (\id -> (!!) buttons <$> (fromIntegral <$> id))
                             ids') states) :: [ Maybe (Button, Bool) ]
  sequence $ map (\comb' -> sequence $
                    (\(button, state) ->
                           setButtonState button state) <$> comb') comb
  atomically $ modifyTVar' tState
    (\state -> state { stNotisForMe = [] })
  return False

hideNotiCenter tState = do
  state <- readTVarIO tState
  mainWindow <- stMainWindow <$> readTVarIO tState
  widgetHide mainWindow
  atomically $ modifyTVar' tState
    (\state -> state { stCenterShown = False })

showNotiCenter tState notiState config = do
  state <- readTVarIO tState
  mainWindow <- stMainWindow <$> readTVarIO tState
  setNotificationCenterPosition mainWindow config
  newShown <- if stCenterShown state then
    do
      widgetHide mainWindow
      return False
    else
    do
      hideAllNotis $ stNotiState state
      widgetShow mainWindow
      return True
  atomically $ modifyTVar' tState
    (\state -> state {stCenterShown = newShown })
  return True

updateNotisForMe :: TVar State -> IO()
updateNotisForMe tState = do
  state <- readTVarIO tState
  notiState <- readTVarIO $ stNotiState state
  atomically $ modifyTVar' (stNotiState state) (
    \state -> state { notiForMeList = [] })
  atomically $ modifyTVar' tState (
    \state -> state { stNotisForMe = notiForMeList notiState
                                     ++ stNotisForMe state})

  addSource (parseNotisForMe tState)
  return ()

updateNotis :: Config -> TVar State -> IO()
updateNotis config tState = do
  state <- readTVarIO tState
  notiState <- readTVarIO $ stNotiState state

  let newNotis = filter (
        \n -> (find (\nd -> _dNotiId nd == notiId n )
               (stDisplayingNotiList state))
              == Nothing
              && ((configIgnoreTransient config) || (not $ notiTransient n)))
                 $ notiStList notiState
  newNotis' <- mapM (
    \n -> do
      let newNoti = DisplayingNotificationInCenter
                    { _dNotiId = notiId n }
      showNotification config
        (stNotiBox state) newNoti
        (stNotiState state) $ removeNoti tState
    ) newNotis

  let delNotis = filter (\nd -> (find (\n -> _dNotiId nd == notiId n)
                                $ notiStList notiState) == Nothing)
                 $ stDisplayingNotiList state
  atomically $ modifyTVar' tState (
    \state -> state { stDisplayingNotiList =
                      newNotis' ++ stDisplayingNotiList state
                    })
  setDeleteAllState tState
  mapM (removeNoti tState) $ delNotis
  when (stCenterShown state) $
    do
      hideAllNotis $ stNotiState state
  return ()

removeNoti :: TVar State -> DisplayingNotificationInCenter -> IO ()
removeNoti tState dNoti = do
  state <- readTVarIO tState
  atomically $ modifyTVar' tState $ \state ->
    state { stDisplayingNotiList =
            filter ((/=) dNoti) $ stDisplayingNotiList state}
  setDeleteAllState tState
  atomically $ modifyTVar' (stNotiState state) $ \state ->
    state { notiStList = filter
                         (\n -> notiId n /= _dNotiId dNoti) $
                         notiStList state }
  addSource $ do
    _dNotiDestroy dNoti
    return False
  return ()

setDeleteAllState tState = do
  addSource $ do
    state <- readTVarIO tState
    if (length $ stDisplayingNotiList state) > 1 then
      widgetShow $ stDeleteAll state
      else
      widgetHide $ stDeleteAll state
    return False
  return ()

getInitialState = do
  newTVarIO $ State
    { stDisplayingNotiList = []
    , stCenterShown = False}

main' :: IO ()
main' = do
  GI.init Nothing

  homeDir <- getXdgDirectory XdgConfig ""
  config <- getConfig <$> (readConfigFile
                            (homeDir ++ "/deadd/deadd.conf"))

  initI18n

  istate <- getInitialState
  notiState <- startNotificationDaemon config
    (updateNotis config istate) (updateNotisForMe istate)

  atomically $ modifyTVar' istate $
    \istate' -> istate' { stNotiState = notiState }
  createNotiCenter istate config

  unixSignalAdd PRIORITY_HIGH (fromIntegral sigUSR1)
    (showNotiCenter istate notiState config)

  runCommand $ configStartupCommand config

  GI.main

main :: IO ()
main = do
--  daemonize main'
  main'


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

-- |
-- Module      :  Pact.Repl.Lib
-- Copyright   :  (C) 2016 Stuart Popejoy
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Stuart Popejoy <stuart@kadena.io>
--
-- Built-ins for repl functionality. Not part of standard library
-- for blockchain execution, but instead for testing and dev.
--

module Pact.Repl.Lib where

import Control.Arrow ((&&&))
import Control.Concurrent.MVar
import Control.Lens
import Control.Monad.Catch
import Control.Monad.Reader
import Control.Monad.State.Strict (get,put)

import Data.Aeson (eitherDecode,toJSON)
import qualified Data.ByteString.Lazy as BSL
import Data.Default
import Data.Foldable
import qualified Data.Map.Strict as M
import Data.Semigroup (Endo(..))
import qualified Data.Set as S
import Data.Text (Text, unpack)
import Data.Text.Encoding
import Pact.Time
import qualified Data.Vector as V
import Data.List (isInfixOf)

#if defined(ghcjs_HOST_OS)
import qualified Pact.Analyze.Remote.Client as RemoteClient
import Data.Maybe
#else

import Criterion
import Criterion.Types

import Statistics.Types (Estimate(..))

# ifdef BUILD_TOOL
import qualified Pact.Analyze.Check as Check
# endif
import qualified Pact.Types.Crypto as Crypto
#endif

import Pact.Typechecker
import qualified Pact.Types.Typecheck as TC
import Pact.Native
-- intentionally hidden unused functions to prevent lib functions from consuming gas
import Pact.Native.Internal hiding (defRNative,defGasRNative,defNative)
import qualified Pact.Native.Internal as Native
import Pact.Types.Runtime
import Pact.Eval
import Pact.Persist.Pure
import Pact.PersistPactDb
import Pact.Types.Logger
import Pact.Types.Pretty
import Pact.Repl.Types
import Pact.Native.Capabilities (evalCap)
import Pact.Gas.Table
import Pact.Types.PactValue
import Pact.Types.Capability
import Pact.Runtime.Utils

initLibState :: Loggers -> Maybe String -> IO LibState
initLibState loggers verifyUri = do
  m <- newMVar (DbEnv (def :: PureDb) persister
                (newLogger loggers "Repl")
                def 0 def)
  initLibState' (LibDb m) verifyUri

initLibState' :: LibDb -> Maybe String -> IO LibState
initLibState' ldb@(LibDb db') verifyUri = do
  createSchema db'
  return (LibState ldb Noop def def verifyUri M.empty def)

-- | Native function with no gas consumption.
type ZNativeFun e = FunApp -> [Term Ref] -> Eval e (Term Name)

zeroGas :: Eval e a -> Eval e (Gas,a)
zeroGas = fmap (0,)

defZNative :: NativeDefName -> ZNativeFun e -> FunTypes (Term Name) -> [Example] -> Text -> NativeDef
defZNative name fun = Native.defNative name $ \fi as -> zeroGas $ fun fi as

defZRNative :: NativeDefName -> RNativeFun e -> FunTypes (Term Name) -> [Example] -> Text -> NativeDef
defZRNative name fun = Native.defNative name (reduced fun)
    where reduced f fi as = mapM reduce as >>= zeroGas . f fi

replDefs :: NativeModule
replDefs = ("Repl",
     [
      defZRNative "load" load (funType tTyString [("file",tTyString)] <>
                              funType tTyString [("file",tTyString),("reset",tTyBool)])
      [LitExample "(load \"accounts.repl\")"]
      "Load and evaluate FILE, resetting repl state beforehand if optional RESET is true."
     ,defZRNative "format-address" formatAddr (funType tTyString [("scheme", tTyString), ("public-key", tTyString)])
      []
      "Transform PUBLIC-KEY into an address (i.e. a Pact Runtime Public Key) depending on its SCHEME."
     ,defZRNative "env-keys" setsigs (funType tTyString [("keys",TyList tTyString)])
      ["(env-keys [\"my-key\" \"admin-key\"])"]
      ("DEPRECATED in favor of 'set-sigs'. Set transaction signer KEYS. "<>
       "See 'env-sigs' for setting keys with associated capabilities.")
     ,defZNative "env-sigs" setsigs' (funType tTyString [("sigs",TyList (tTyObject TyAny))])
      [LitExample $ "(env-sigs [{'key: \"my-key\", 'caps: [(accounts.USER_GUARD \"my-account\")]}, " <>
        "{'key: \"admin-key\", 'caps: []}"]
      ("Set transaction signature keys and capabilities. SIGS is a list of objects with \"key\" " <>
       "specifying the signer key, and \"caps\" specifying a list of associated capabilities.")

     ,defZRNative "env-data" setmsg (funType tTyString [("json",json)])
      ["(env-data { \"keyset\": { \"keys\": [\"my-key\" \"admin-key\"], \"pred\": \"keys-any\" } })"]
      "Set transaction JSON data, either as encoded string, or as pact types coerced to JSON."

     ,defZRNative "continue-pact" continuePact
      (funType tTyString [("step",tTyInteger)] <>
       funType tTyString [("step",tTyInteger),("rollback",tTyBool)] <>
       funType tTyString [("step",tTyInteger),("rollback",tTyBool),("pact-id",tTyString)] <>
       funType tTyString [("step",tTyInteger),("rollback",tTyBool),("pact-id",tTyString),("yielded",tTyObject (mkSchemaVar "y"))])
      [LitExample "(continue-pact 1)", LitExample "(continue-pact 1 true)",
       LitExample "(continue-pact 1 false \"[pact-id-hash]\"))",
       LitExample "(continue-pact 2 1 false \"[pact-id-hash]\" { \"rate\": 0.9 })"]
      ("Continue previously-initiated pact identified STEP, " <>
       "optionally specifying ROLLBACK (default is false), " <>
       "PACT-ID of the pact to be continued (defaults to the pact initiated in the current transaction, if one is present), and " <>
       "YIELDED value to be read with 'resume' (if not specified, uses yield in most recent pact exec, if any).")

     ,defZRNative "pact-state" pactState
      (funType (tTyObject TyAny) [] <> funType (tTyObject TyAny) [("clear",tTyBool)])
      [LitExample "(pact-state)", LitExample "(pact-state true)"]
      ("Inspect state from most recent pact execution. Returns object with fields " <>
      "'pactId': pact ID; 'yield': yield result or 'false' if none; 'step': executed step; " <>
      "'executed': indicates if step was skipped because entity did not match. " <>
      "With CLEAR argument, erases pact from repl state.")

     ,defZRNative "env-entity" setentity
      (funType tTyString [] <> funType tTyString [("entity",tTyString)])
      [LitExample "(env-entity \"my-org\")", LitExample "(env-entity)"]
      ("Set environment confidential ENTITY id, or unset with no argument.")
     ,defZRNative "begin-tx" (tx Begin) (funType tTyString [] <>
                                        funType tTyString [("name",tTyString)])
      [ExecExample "(begin-tx \"load module\")"] "Begin transaction with optional NAME."
     ,defZRNative "commit-tx" (tx Commit) (funType tTyString [])
      [ExecExample "(begin-tx) (commit-tx)"] "Commit transaction."
     ,defZRNative "rollback-tx" (tx Rollback) (funType tTyString [])
      [ExecExample "(begin-tx \"Third Act\") (rollback-tx)"] "Rollback transaction."
     ,defZNative "expect" expect
      (funType tTyString [("doc",tTyString),("expected",a),("actual",a)])
      ["(expect \"Sanity prevails.\" 4 (+ 2 2))"]
      "Evaluate ACTUAL and verify that it equals EXPECTED."

     ,defZNative "expect-failure" expectFail
      (funType tTyString [("doc",tTyString),("exp",a)] <>
       funType tTyString [("doc",tTyString),("err",tTyString),("exp",a)])
      ["(expect-failure \"Enforce fails on false\" (enforce false \"Expected error\"))"
      ,"(expect-failure \"Enforce fails with message\" \"Expected error\" (enforce false \"Expected error\"))"
      ]
      "Evaluate EXP and succeed only if it throws an error."

     ,defZNative "expect-that" expectThat
      (funType tTyString
       [("doc",tTyString)
       ,("pred",TyFun (funType' tTyBool [("value",a)]))
       ,("exp",a)])
      [ExecExample "(expect-that \"addition\" (< 2) (+ 1 2))"
      ,ExecErrExample "(expect-that \"addition\" (> 2) (+ 1 2))"]
      "Evaluate EXP and succeed if value passes predicate PRED."
     ,defZNative "bench" bench' (funType tTyString [("exprs",TyAny)])
      [LitExample "(bench (+ 1 2))"] "Benchmark execution of EXPRS."
     ,defZRNative "typecheck" tc (funType tTyString [("module",tTyString)] <>
                                 funType tTyString [("module",tTyString),("debug",tTyBool)])
       []
       "Typecheck MODULE, optionally enabling DEBUG output."
     ,defZRNative "env-gaslimit" setGasLimit (funType tTyString [("limit",tTyInteger)])
       []
       "Set environment gas limit to LIMIT."
     ,defZRNative "env-gas" envGas (funType tTyInteger [] <> funType tTyString [("gas",tTyInteger)])
       ["(env-gasmodel \"table\") (env-gaslimit 10) (env-gas 0) (map (+ 1) [1 2 3]) (env-gas)"]
       ("Query gas state, or set it to GAS. Note that certain plaforms may charge additional gas that is not captured " <>
        "by the interpreter gas model, such as an overall transaction-size cost.")
     ,defZRNative "env-gasprice" setGasPrice (funType tTyString [("price",tTyDecimal)])
       []
       "Set environment gas price to PRICE."
     ,defZRNative "env-gasrate" setGasRate (funType tTyString [("rate",tTyInteger)])
       []
       "Update gas model to charge constant RATE."
     ,defZRNative "env-gasmodel" setGasModel
      (funType tTyString [("model",tTyString)] <>
       funType tTyString [] <>
       funType tTyString [("model",tTyString),("rate",tTyInteger)])
      [ExecExample "(env-gasmodel)",ExecExample "(env-gasmodel 'table)",ExecExample "(env-gasmodel 'fixed 1)"]
      ("Update or query current gas model. With just MODEL, \"table\" is supported; " <>
       "with MODEL and RATE, 'fixed' is supported. With no args, output current model.")
     ,defZRNative "env-gaslog" gasLog (funType tTyString [])
       ["(env-gasmodel \"table\") (env-gaslimit 10) (env-gaslog) (map (+ 1) [1 2 3]) (env-gaslog)"]
       "Enable and obtain gas logging. Bracket around the code whose gas logs you want to inspect."
     ,defZRNative "env-exec-config" envExecConfig
      (funType (TyList tTyString) [("flags",TyList tTyString)] <>
       funType (TyList tTyString) [])
      ["(env-exec-config ['DisableHistoryInTransactionalMode]) (env-exec-config)"]
      ("Queries, or with arguments, sets execution config flags. Valid flags: " <>
       tShow (M.keys flagReps))
     ,defZRNative "verify" verify (funType tTyString [("module",tTyString)])
       []
       "Verify MODULE, checking that all properties hold."
     ,defZRNative "sig-keyset" sigKeyset (funType tTyKeySet [])
       []
       "Convenience function to build a keyset from keys present in message signatures, using 'keys-all' as the predicate."
     ,defZRNative "print" print' (funType tTyString [("value",a)])
       []
       "Output VALUE to terminal as unquoted, unescaped text."
     ,defZRNative "env-hash" envHash (funType tTyString [("hash",tTyString)])
       ["(env-hash (hash \"hello\"))"]
       "Set current transaction hash. HASH must be an unpadded base64-url encoded BLAKE2b 256-bit hash."
     ,defZNative "test-capability" testCapability
      (funType tTyString [("capability", TyFun $ funType' tTyBool [])])
      [LitExample "(test-capability (MY-CAP))"] $
     "Acquire (if unmanaged) or install (if managed) CAPABILITY. CAPABILITY and any composed capabilities are in scope " <>
     "for the rest of the transaction."
     ,defZRNative "mock-spv" mockSPV
       (funType tTyString [("type",tTyString),("payload",tTyObject TyAny),("output",tTyObject TyAny)])
      [LitExample "(mock-spv \"TXOUT\" { 'proof: \"a54f54de54c54d89e7f\" } { 'amount: 10.0, 'account: \"Dave\", 'chainId: \"1\" })"]
       "Mock a successful call to 'spv-verify' with TYPE and PAYLOAD to return OUTPUT."
     , envChainDataDef
     ,defZNative "env-namespace-policy" envNamespacePolicy
      (funType tTyString
       [("allow-root", tTyBool),
        ("ns-policy-fun",TyFun $ funType' tTyBool [("ns",tTyString),("ns-admin",tTyGuard Nothing)])])
      [LitExample "(env-namespace-policy (my-ns-policy-fun))"]
      "Install a managed namespace policy specifying ALLOW-ROOT and NS-POLICY-FUN."
     ,defZRNative "env-events" envEvents
      (funType (TyList (tTyObject TyAny)) [("clear",tTyBool)])
      [LitExample "(env-events true)"]
      ("Retreive any accumulated events and optionally clear event state. " <>
       "Object returned has fields 'name' (fully-qualified event name), " <>
       "'params' (event parameters), 'module-hash' (hash of emitting module).")
     ,defZRNative "env-enable-repl-natives" enableReplNatives
      (funType tTyString [("enable",tTyBool)])
      [ExecExample "(env-enable-repl-natives true)"]
      ("Control whether REPL native functions are allowed in module code. " <>
       "When enabled, fixture functions like 'env-sigs' are allowed in module code.")
     ,defZNative "with-applied-env" withEnv
      (funType a [("exec",a)])
      [ExecExample "(let ((a 1)) (env-data { 'b: 1 }) (with-applied-env (+ a (read-integer 'b))))"]
      ("Evaluate EXEC with any pending environment changes applied. " <>
       "Normally, environment changes must execute at top-level for the change to take effect. " <>
       "This allows scoped application of non-toplevel environment changes.")
     ,defZRNative "env-dynref" envDynRef
      (funType tTyString [("iface",TyModule Nothing),("impl",TyModule (Just []))] <>
       funType tTyString [])
      [LitExample "(env-dynref fungible-v2 coin)"]
      ("Substitute module IMPL in any dynamic usages of IFACE in typechecking and analysis. " <>
       "With no arguments, remove all substitutions.")
     ])
     where
       json = mkTyVar "a" [tTyInteger,tTyString,tTyTime,tTyDecimal,tTyBool,
                         TyList (mkTyVar "l" []),TySchema TyObject (mkSchemaVar "o") def,tTyKeySet]
       a = mkTyVar "a" []

invokeEnv :: (LibDb -> IO b) -> MVar LibState -> IO b
invokeEnv f e = withMVar e $ \ls -> f $! (_rlsDb ls)
{-# INLINE invokeEnv #-}

repldb :: PactDb LibState
repldb = PactDb {

    _readRow = \d k -> invokeEnv $ \(LibDb e) -> _readRow pactdb d k e
  , _writeRow = \wt d k v -> invokeEnv $ \(LibDb e) ->  _writeRow pactdb wt d k v e
  , _keys = \t -> invokeEnv $ \(LibDb e) ->  _keys pactdb t e
  , _txids = \t tid -> invokeEnv $ \(LibDb e) ->  _txids pactdb t tid e
  , _createUserTable = \t m -> invokeEnv $ \(LibDb e) ->  _createUserTable pactdb t m e
  , _getUserTableInfo = \t -> invokeEnv $ \(LibDb e) ->  _getUserTableInfo pactdb t e
  , _beginTx = \tid -> invokeEnv $ \(LibDb e) ->  _beginTx pactdb tid e
  , _commitTx = invokeEnv $ \(LibDb e) ->  _commitTx pactdb e
  , _rollbackTx = invokeEnv $ \(LibDb e) ->  _rollbackTx pactdb e
  , _getTxLog = \d t -> invokeEnv $ \(LibDb e) ->  _getTxLog pactdb d t e

}

load :: RNativeFun LibState
load _ [TLitString fn] = setop (Load (unpack fn) False) >> return (tStr $ "Loading " <> fn <> "...")
load _ [TLitString fn, TLiteral (LBool r) _] = setop (Load (unpack fn) r) >> return (tStr $ "Loading " <> fn <> "...")
load i as = argsError i as

modifyLibState :: (LibState -> (LibState,a)) -> Eval LibState a
modifyLibState f = view eePactDbVar >>= \m -> liftIO $ modifyMVar m (return . f)

setLibState :: (LibState -> LibState) -> Eval LibState ()
setLibState f = modifyLibState (f &&& const ())

viewLibState :: (LibState -> a) -> Eval LibState a
viewLibState f = modifyLibState (id &&& f)

setop :: LibOp -> Eval LibState ()
setop v = setLibState $ over rlsOp (<> v)

setenv :: Setter' (EvalEnv LibState) a -> a -> Eval LibState ()
setenv l v = setop $ UpdateEnv $ Endo (set l v)

envDynRef :: RNativeFun LibState
envDynRef i [TModRef iface _,TModRef impl _] =
  lookupModule i (_modRefName impl) >>= \r -> case r of
    Nothing -> evalError' i "Unable to resolve impl module"
    Just md -> do
      setLibState $ over rlsDynEnv $ M.insert (_modRefName iface) md
      return $ tStr "Added dynamic ref to environment."
envDynRef _i [] = do
  setLibState $ set rlsDynEnv def
  return $ tStr "Cleared dynamic ref environment."
envDynRef i as = argsError i as

mockSPV :: RNativeFun LibState
mockSPV i as = case as of
  [TLitString spvType, TObject payload _, TObject out _] -> do
    setLibState $ over rlsMockSPV (M.insert (SPVMockKey (spvType,payload)) out)
    return $ tStr $ "Added mock SPV for " <> spvType
  _ -> argsError i as

formatAddr :: RNativeFun LibState
#if !defined(ghcjs_HOST_OS)
formatAddr i [TLitString scheme, TLitString cryptoPubKey] = do
  let eitherEvalErr :: Either String a -> String -> (a -> b) -> Eval LibState b
      eitherEvalErr res effectStr transformFunc =
        case res of
          Left e  -> evalError' i $ prettyString effectStr <> ": " <> prettyString e
          Right v -> return (transformFunc v)
  sppk  <- eitherEvalErr (fromText' scheme)
           "Invalid PPKScheme"
           Crypto.toScheme
  pubBS <- eitherEvalErr (parseB16TextOnly cryptoPubKey)
           "Invalid Public Key format"
           Crypto.PubBS
  addr  <- eitherEvalErr (Crypto.formatPublicKeyBS sppk pubBS)
           "Unable to convert Public Key to Address"
           toB16Text
  return (tStr addr)
formatAddr i as = argsError i as
#else
formatAddr i _ = evalError' i "Address formatting not supported in GHCJS"
#endif

setsigs :: RNativeFun LibState
setsigs i [TList ts _ _] = do
  ks <- forM ts $ \t -> case t of
          (TLitString s) -> return s
          _ -> argsError i (V.toList ts)
  setenv eeMsgSigs $ M.fromList ((,mempty) . PublicKey . encodeUtf8 <$> V.toList ks)
  return $ tStr "Setting transaction keys"
setsigs i as = argsError i as

setsigs' :: ZNativeFun LibState
setsigs' _ [TList ts _ _] = do
  sigs <- forM ts $ \t -> case t of
    (TObject (Object (ObjectMap om) _ _ _) _) -> do
      case (M.lookup "key" om,M.lookup "caps" om) of
        (Just k'',Just (TList clist _ _)) -> do
          reduce k'' >>= \k' -> case k' of
            TLitString k -> do
              caps <- forM clist $ \cap -> case cap of
                (TApp a _) -> view _1 <$> appToCap a
                o -> evalError' o $ "Expected capability invocation"
              return (PublicKey $ encodeUtf8 k,S.fromList (V.toList caps))
            _ -> evalError' k' "Expected string value"
        _ -> evalError' t "Expected object with 'key': string, 'caps': [capability]"
    _ -> evalError' t $ "Expected object"
  setenv eeMsgSigs $ M.fromList $ V.toList sigs
  return $ tStr "Setting transaction signatures/caps"
setsigs' i as = argsError' i as

setmsg :: RNativeFun LibState
setmsg i as = case as of
  [TLitString j] ->
    case eitherDecode (BSL.fromStrict $ encodeUtf8 j) of
      Left f -> evalError' i ("Invalid JSON: " <> prettyString f)
      Right v -> go v
  [TObject (Object om _ _ _) _] -> go (toJSON (fmap toPactValueLenient om))
  [a] -> go (toJSON a)
  _ -> argsError i as
  where go v = setenv eeMsgBody v >> return (tStr "Setting transaction data")

continuePact :: RNativeFun LibState
continuePact i as = case as of
  [TLitInteger step] ->
    go step False Nothing Nothing
  [TLitInteger step,TLitBool rollback] ->
    go step rollback Nothing Nothing
  [TLitInteger step,TLitBool rollback,TLitString pid] ->
    go step rollback (Just pid) Nothing
  [TLitInteger step,TLitBool rollback,TLitString pid,TObject (Object o _ _ _) _] ->
    go step rollback (Just pid) (Just o)
  _ -> argsError i as
  where
    go :: Integer -> Bool -> Maybe Text -> Maybe (ObjectMap (Term Name)) -> Eval LibState (Term Name)
    go step rollback pid userResume = do
      pe <- use evalPactExec
      (pactId, y) <- unwrapExec pid userResume pe

      let pactStep = PactStep (fromIntegral step) rollback pactId y
      evalPactExec .= Nothing
      local (set eePactStep $ Just pactStep) $ resumePact (_faInfo i) Nothing

    unwrapExec mpid mobj Nothing = do
      pid <- case mpid of
        Nothing -> evalError' i
          "continue-pact: No pact id supplied and no pact exec in context"
        Just pid -> return $ PactId pid
      y <- maybe (return Nothing) (toYield Nothing) mobj
      return (pid, y)
    unwrapExec mpid mobj (Just ex) = do
      let pid = maybe (_pePactId ex) PactId mpid
      y <- case mobj of
        Nothing -> return $ _peYield ex
        Just o -> case _peYield ex of
          Just (Yield _ p _) -> toYield p o
          Nothing -> toYield Nothing o
      return (pid, y)

    toYield p = fmap (Just . (\v -> Yield v p Nothing)) . enforcePactValue'

setentity :: RNativeFun LibState
setentity i as = case as of
  [TLitString s] -> do
    setenv eeEntity $ Just (EntityName s)
    return (tStr $ "Set entity to " <> s)
  [] -> do
    setenv eeEntity Nothing
    return (tStr "Unset entity")
  _ -> argsError i as

pactState :: RNativeFun LibState
pactState i as = case as of
  [] -> go False
  [TLitBool clear] -> go clear
  _ -> argsError i as
  where
    go clear = do
      e <- use evalPactExec
      when clear $ evalPactExec .= Nothing
      case e of
        Nothing -> evalError' i "pact-state: no pact exec in context"
        Just PactExec{..} -> return $ toTObject TyAny def $
          [("yield",maybe (toTerm False) (toTObjectMap TyAny def . fmap fromPactValue . _yData) _peYield)
          ,("executed",toTerm (_peExecuted /= Just False))
          ,("step",toTerm _peStep)
          ,("pactId",toTerm _pePactId)]

tx :: Tx -> RNativeFun LibState
tx t fi as = do

  (tid,tname) <- case (t,as) of
    (Begin,[TLitString n]) -> doBegin (Just n)
    (Begin,[]) -> doBegin Nothing
    (Commit,[]) -> evalCommitTx i >> resetTx
    (Rollback,[]) -> evalRollbackTx i >> resetTx
    _ -> argsError fi as

  -- reset to repl lib, preserve call stack
  cs <- use evalCallStack
  put $ set (evalRefs.rsLoaded) (moduleToMap replDefs) $ set evalCallStack cs def
  return $ tStr $ tShow t <> " Tx"
      <> maybeDelim " " tid <> maybeDelim ": " tname

  where

    i = getInfo fi

    doBegin tname = do
      tid <- evalBeginTx i
      setLibState $ set rlsTx (tid,tname)
      return (tid,tname)

    resetTx = modifyLibState
      (set rlsTx (Nothing,Nothing) &&& view rlsTx)

recordTest :: Text -> Maybe (FunApp,Text) -> Eval LibState ()
recordTest name failure = setLibState $ over rlsTests (++ [TestResult name failure])

testSuccess :: Text -> Text -> Eval LibState (Term Name)
testSuccess doc msg = do
  recordTest doc Nothing
  return $ tStr $ msg <> ": success: " <> doc

testFailure :: FunApp -> Text -> Doc -> Eval LibState (Term Name)
testFailure i doc msg = recordTest doc (Just (i,rmsg)) >> return (tStr rmsg)
  where
    rmsg = "FAILURE: " <> doc <> ": " <> renderCompactText' msg

testDoc :: FunApp -> [Term Ref] -> Eval e Text
testDoc _ (doc'':_) = reduce doc'' >>= \doc' -> case doc' of
  TLitString doc -> enrichTestName doc
  _ -> evalError' doc'' "Expected string"
  where
    -- | Use stack frames for 'FunApp's to enrich test name, using
    -- presence of module name as a heuristic of the "user stack".
    enrichTestName :: Text -> Eval e Text
    enrichTestName msg = use evalCallStack >>= return . foldl' go msg

    go m StackFrame{..} = case preview (_Just . _1 . faModule . _Just) _sfApp of
      Just {} -> _sfName <> "." <> m
      _ -> m
testDoc i as = argsError' i as

testCatch :: FunApp -> Text -> Eval LibState a -> Doc ->
             (a -> Eval LibState (Term Name)) -> Eval LibState (Term Name)
testCatch i doc expr errMsg cont = catchesPactError expr >>= \r -> case r of
  Right v -> cont v
  Left e -> testFailure i doc $ errMsg <> ": " <> prettyErr e
  where
    prettyErr e = prettyInfo (peInfo e) <> peDoc e
    prettyInfo a
        | a == def = ""
        | otherwise = pretty (renderInfo a) <> ": "

expect :: ZNativeFun LibState
expect i as@[_,b',c'] = do
  doc <- testDoc i as
  testCatch i doc (reduce c') "evaluation of actual failed" $ \c ->
    testCatch i doc (reduce b') "evaluation of expected failed" $ \b ->
      if b `termEq` c
      then testSuccess doc "Expect"
      else testFailure i doc $
           "expected " <> pretty b <> ":" <> pretty (typeof' b) <>
           ", received " <> pretty c <> ":" <> pretty (typeof' c)
expect i as = argsError' i as

expectFail :: ZNativeFun LibState
expectFail i as = case as of
  [_,expr] -> go Nothing expr
  [_,err,expr] -> reduce err >>= \e -> case e of
    TLitString errmsg -> go (Just $ unpack errmsg) expr
    _ -> argsError' i as
  _ -> argsError' i as
  where
    tsuccess msg = testSuccess msg "Expect failure"
    go errM expr = do
      msg' <- testDoc i as
      r <- catch (Right <$> reduce expr) (\(e :: SomeException) -> return $ Left (show e))
      case r of
        Right v -> testFailure i msg' $ "expected failure, got result = " <> pretty v
        Left e -> case errM of
          Nothing -> tsuccess msg'
          Just err
              | err `isInfixOf` e -> tsuccess msg'
              | otherwise ->
                  testFailure i msg' $ "expected error message to contain '" <> pretty err
                  <> "', got '" <> pretty e <> "'"

expectThat :: ZNativeFun LibState
expectThat i as@[_,tLamToApp -> TApp pred' predi,expr'] = do
  doc <- testDoc i as
  testCatch i doc (reduce expr') "evaluation of expression failed" $ \v ->
    testCatch i doc (apply pred' [v]) "evaluation of predicate failed" $ \p -> case p of
      TLitBool b
          | b -> testSuccess doc $ "Expect-that"
          | otherwise ->
              testFailure i doc $ "did not satisfy"
              <> prettyPred predi <> ": " <> pretty v <> ":" <> pretty (typeof' v)
      t -> testFailure i doc $ "predicate did not return boolean: " <> pretty t
  where
    prettyPred (Info (Just (c,_))) = " " <> pretty c
    prettyPred _ = ""
expectThat i as = argsError' i as

bench' :: ZNativeFun LibState
#if !defined(ghcjs_HOST_OS)
bench' i as = do
  e <- ask
  s <- get
  (r :: Either SomeException Report) <-
      try $ liftIO $ benchmark' $ whnfIO $ runEval s e $ do
                !ts <- mapM reduce as
                return $! toTerm (length ts)
  case r of
    Left ex -> evalError' i (viaShow ex)
    Right rpt -> do
           let mean = estPoint (anMean (reportAnalysis rpt))
               sd = estPoint (anStdDev (reportAnalysis rpt))
               (reg,_) = splitAt 1 $ anRegress (reportAnalysis rpt)
               val = case reg of
                       [] -> mean
                       (r':_) -> case M.lookup "iters" (regCoeffs r') of
                                  Nothing -> mean
                                  Just t -> estPoint t
               tps = 1/val
               tperr = (1/(val - (sd/2))) - (1/(val + (sd/2)))
           liftIO $ putStrLn $ show (round tps :: Integer) ++ "/s, +-" ++ show (round tperr :: Integer) ++ "/s"
           return (tStr "Done")
#else
bench' i _ = evalError' i "Benchmarking not supported in GHCJS"
#endif

tc :: RNativeFun LibState
tc i as = case as of
  [TLitString s] -> go s False
  [TLitString s,TLiteral (LBool d) _] -> go s d
  _ -> argsError i as
  where
    go modname dbg = do
      md <- getModule i (ModuleName modname Nothing)
      de <- viewLibState _rlsDynEnv
      r :: Either TC.CheckerException ([TC.TopLevel TC.Node],[TC.Failure]) <-
        try $ liftIO $ typecheckModule dbg de md
      case r of
        Left (TC.CheckerException ei e) -> evalError ei ("Typechecker Internal Error: " <> prettyString e)
        Right (_,fails) -> case fails of
          [] -> return $ tStr $ "Typecheck " <> modname <> ": success"
          _ -> do
            setop $ Output $ map TC.renderTcFailure fails
            return $ tStr $ "Typecheck " <> modname <> ": Unable to resolve all types"

verify :: RNativeFun LibState
verify i _as@[TLitString modName] = do
#if defined(ghcjs_HOST_OS)
    -- ghcjs: use remote server
    (md,modules) <- _loadModules
    uri <- fromMaybe "localhost" <$> viewLibState (view rlsVerifyUri)
    renderedLines <- liftIO $
                     RemoteClient.verifyModule modules md uri
    setop $ Output renderedLines
    return _failureMessage
#elif defined(BUILD_TOOL)
    -- ghc + build-tool: run verify
    (md,modules) <- _loadModules
    de <- viewLibState _rlsDynEnv
    modResult <- liftIO $ Check.verifyModule de modules md
    let renderedLines = Check.renderVerifiedModule modResult
    setop $ Output renderedLines
    if any ((== OutputFailure) . _roType) renderedLines
      then return _failureMessage
      else return $ tStr $ "Verification of " <> modName <> " succeeded"
#else
    -- ghc - build-tool: typecheck only
    tc i _as
#endif
  where
    _failureMessage = tStr $ "Verification of " <> modName <> " failed"
    _loadModules = (,)
        <$> getModule i (ModuleName modName Nothing)
        <*> getAllModules i
verify i as = argsError i as

sigKeyset :: RNativeFun LibState
sigKeyset _ _ = view eeMsgSigs >>= \ss ->
  return $ toTerm $ mkKeySet (M.keys ss) (asString KeysAll)

print' :: RNativeFun LibState
print' _ [v] = setop (Print v) >> return (tStr "")
print' i as = argsError i as

envHash :: RNativeFun LibState
envHash i [TLitString s] = case fromText' s of
  Left err -> evalError' i $ "Bad hash value: " <> pretty s <> ": " <> prettyString err
  Right h -> do
    setenv eeHash h
    return $ tStr $ "Set tx hash to " <> s
envHash i as = argsError i as

setGasLimit :: RNativeFun LibState
setGasLimit _ [TLitInteger l] = do
  setenv (eeGasEnv . geGasLimit) (fromIntegral l)
  return $ tStr $ "Set gas limit to " <> tShow l
setGasLimit i as = argsError i as

envGas :: RNativeFun LibState
envGas _ [] = use evalGas >>= \g -> return (tLit $ LInteger $ fromIntegral g)
envGas _ [TLitInteger g] = do
  evalGas .= fromIntegral g
  return $ tStr $ "Set gas to " <> tShow g
envGas i as = argsError i as

gasLog :: RNativeFun LibState
gasLog _ _ = do
  gl <- use evalLogGas
  evalLogGas .= Just []
  case gl of
    Nothing -> return $ tStr $ "Enabled gas log"
    Just logs -> let total = sum (map snd logs) in
      return $ toTList tTyString def $ (tStr ("TOTAL: " <> tShow total):) $
        reverse $ flip map logs $ \(n,g) ->
        tStr $ renderCompactText' $ pretty n <> ": " <> pretty g

setGasPrice :: RNativeFun LibState
setGasPrice _ [TLiteral (LDecimal d) _] = do
  setenv (eeGasEnv . geGasPrice) (wrap (wrap d))
  return $ tStr $ "Set gas price to " <> tShow d
setGasPrice i as = argsError i as

envExecConfig :: RNativeFun LibState
envExecConfig i as = case as of
  [TList reps _ _] -> do
    fs <- forM reps $ \s -> case s of
      TLitString r -> case M.lookup r flagReps of
        Nothing -> evalError' i $ "Invalid flag, allowed: " <> viaShow (M.keys flagReps)
        Just f -> return f
      _ -> argsError i as
    let ec = ExecutionConfig $ S.fromList $ V.toList fs
    setenv eeExecutionConfig ec
    report ec
  [] -> view eeExecutionConfig >>= report
  _ -> argsError i as
  where
    report ExecutionConfig{..} = return $ toTList tTyString def $
      map (tStr . flagRep) $ S.toList _ecFlags

setGasRate :: RNativeFun LibState
setGasRate _ [TLitInteger r] = do
  let model = constGasModel $ fromIntegral r
  setenv (eeGasEnv . geGasModel) model
  return $ tStr $ "Set gas model to " <> gasModelDesc model
setGasRate i as = argsError i as

setGasModel :: RNativeFun LibState
setGasModel _ [] = do
  model <- asks (_geGasModel . _eeGasEnv)
  return $ tStr $ "Current gas model is '" <> gasModelName model <> "': " <> gasModelDesc model
setGasModel _ as = do
  let mMod = case as of
        [TLitString "table"] -> Just $ tableGasModel defaultGasConfig
        [TLitString "fixed", TLitInteger r] -> Just $ constGasModel (fromIntegral r)
        _ -> Nothing
  case mMod of
    Nothing -> return $ tStr "Unrecognized model, perhaps try (env-gasmodel \"table\") or (env-gasmodel \"fixed\" 1)"
    Just model -> do
      setenv (eeGasEnv . geGasModel) model
      return $ tStr $ "Set gas model to " <> gasModelDesc model

-- | This is the only place we can do an external call to a capability,
-- using 'evalCap False'.
testCapability :: ZNativeFun ReplState
testCapability i [ (TApp app _) ] = do
  (_,d,_) <- appToCap app
  let scope = maybe CapCallStack (const CapManaged) (_dDefMeta d)
  r <- evalCap i scope False $ app
  return . tStr $ case r of
    AlreadyAcquired -> "Capability already acquired"
    NewlyAcquired -> "Capability acquired"
    NewlyInstalled _ -> "Capability installed"
testCapability i as = argsError' i as

-- | Modify existing env chain data with new data, replacing just those
-- environment items only.
envChainDataDef :: NativeDef
envChainDataDef = defZRNative "env-chain-data" envChainData
    (funType tTyString [("new-data", objectType)])
    ["(env-chain-data { \"chain-id\": \"TestNet00/2\", \"block-height\": 20 })"]
    "Update existing entries of 'chain-data' with NEW-DATA, replacing those items only."
  where
    objectType = TySchema
      TyObject
      (TyUser $ snd chainDataSchema)
      AnySubschema

    envChainData :: RNativeFun LibState
    envChainData i as = case as of
      [TObject (Object (ObjectMap ks) _ _ _) _] -> do
        pd <- view eePublicData

        ud <- foldM (go (_faInfo i)) pd (M.toList ks)
        setenv eePublicData ud
        return $ tStr "Updated public metadata"
      _ -> argsError i as

    go _i pd (k, (TLiteral (LInteger l) _))
      | k == cdGasLimit = pure $ set (pdPublicMeta . pmGasLimit) (wrap (wrap l)) pd
      | k == cdBlockHeight = pure $ set pdBlockHeight (fromIntegral l) pd

    go _i pd (k, (TLiteral (LDecimal l) _))
      | k == cdGasPrice = pure $ set (pdPublicMeta . pmGasPrice) (wrap (wrap l)) pd

    go _i pd (k, (TLiteral (LTime l) _))
      | k == cdBlockTime = pure $ set pdBlockTime (toPosixTimestampMicros l) pd

    go _i pd (k, (TLiteral (LString l) _))
      | k == cdChainId = pure $ set (pdPublicMeta . pmChainId) (ChainId l) pd
      | k == cdSender = pure $ set (pdPublicMeta . pmSender) l pd
      | k == cdPrevBlockHash = pure $ set pdPrevBlockHash l pd

    go i _ as = evalError i $ "envChainData: bad public metadata values: " <> pretty as

envNamespacePolicy :: ZNativeFun LibState
envNamespacePolicy i as@[ar,TApp app _] = reduce ar >>= \ar' -> case ar' of
  (TLiteral (LBool allowRoot) _) -> requireDefApp Defun app >>= \d -> do
    setenv eeNamespacePolicy (SmartNamespacePolicy allowRoot (toQName d))
    return $ tStr $ "Installed namespace policy"
  _ -> argsError' i as
  where
    toQName Def{..} = QualifiedName _dModule (asString _dDefName) _dInfo
envNamespacePolicy i as = argsError' i as

envEvents :: RNativeFun LibState
envEvents _i [TLiteral (LBool clear) _] = do
  es <- use evalEvents
  when clear $ evalEvents .= []
  return $ toTList TyAny def $ (`map` es) $ \PactEvent{..} -> toTObject TyAny def $
    [("name",toTerm (renderCompactText _eventModule <> "." <> _eventName))
    ,("params",toTList TyAny def $ map fromPactValue _eventParams)
    ,("module-hash",toTerm $ asString _eventModuleHash)]
envEvents i as = argsError i as

enableReplNatives :: RNativeFun LibState
enableReplNatives _i [TLiteral (LBool enable) _] = do
  let (msg,defs) | enable = ("enabled",nativeDefs <> moduleToMap replDefs)
                 | otherwise = ("disabled",nativeDefs)
  setenv ( eeRefStore . rsNatives ) defs
  return $ tStr $ "Repl natives " <> msg
enableReplNatives i as = argsError i as

withEnv :: ZNativeFun LibState
withEnv _ [exec] = do
  updates <- modifyLibState $ \ls -> case _rlsOp ls of
    UpdateEnv e -> (set rlsOp Noop ls,e)
    _ -> (ls,Endo id)
  local (appEndo updates) $ reduce exec
withEnv i as = argsError' i as


{-# LANGUAGE ScopedTypeVariables #-}
module Language.Haskell.Repl
    ( Repl
    -- * Construction
    , newRepl
    , repl'
    , defaultFlags
    , defaultImports
    , defaultLineLength
    , defaultPatience
    , defaultBuildExpr
    , defaultProcessOutput
    -- * Stopping
    , stopRepl
    -- * Interaction
    , Input(..)
    , ReplOutput(..)
    , Output(..)
    , prompt
    , prompt_
    , send
    , result
    , prettyOutput
    , parseInput
    ) where

import Control.Concurrent
import Control.Applicative ((<$>))
import Control.Exception (catch, SomeException(..), ErrorCall(..), fromException, Exception(..), evaluate)
import Control.Monad
import Control.Arrow
import Data.Dynamic
import Data.IORef
import Data.Char (isAscii)
import Data.Maybe
import Text.Parsec hiding (newline)
import Text.Parsec.String
import qualified Language.Haskell.Exts as H
import GHC
import GHC.Paths
import GhcMonad
import Outputable (showSDocForUser, Outputable, ppr, neverQualify)
import HscTypes
import OccName
import System.IO.Unsafe

data Repl a = Repl
    { inputChan         :: Chan Input
    , outputChan        :: Chan (ReplOutput a)
    , interpreter       :: ThreadId
    , config            :: Config a
    }

data Config a = Config
    { imports           :: [String]
    , compilerFlags     :: [String]
    , buildExpr         :: String  -> String
    , process           :: Dynamic -> IO a
    , patience          :: Double
    , lineLength        :: Int
    }

data Input
    = Type     String
    | Kind     String
    | Info     String
    | Decl     String
    | Stmt     String
    | Expr     String
    | Undefine String
    | Clear
  deriving Show

data ReplOutput a
    = ReplError String
    | GhcError  String
    | Output    [String]
    | Result    a
  deriving Show

data Output
    = OK        [String]
    | Exception [String] String
    | Errors    [String]
    | Partial   [String]
    | Timeout   [String]
  deriving Show

prefix :: String -> Parser ()
prefix (x:xs) = do
    _ <- string [':',x]
    forM_ xs (optional . char)
    spaces
prefix [] = fail "empty prefix"

simpl :: String -> (String -> a) -> Parser a
simpl pfix f = do
    prefix pfix
    f <$> getInput

parseType, parseKind, parseInfo, parseDecl, parseStmt, parseExpr, parseUndefine, parseClear, parseInput :: Parser Input
parseType     = simpl "type"  Type
parseKind     = simpl "kind"  Kind
parseInfo     = simpl "info"  Info
parseUndefine = simpl "undef" Undefine
parseClear    = simpl "clear" (const Clear)
parseDecl     = do
    -- from InteractiveUI.hs
    p <- single ["class ","type ","data ","newtype ","instance ","deriving ","foreign ","default(","default "]
    r <- getInput
    return (Decl (p ++ r))
  where single = foldr1 (<|>) . map (try . string)

parseStmt = do
    -- Problem: a Stmt is automatically ran if it is :: IO a
    -- So we have to make sure it is a let binding.
    -- BUT haskell-src-exts can't handle Unicode in let bindings, so valid
    -- let bindings like "let あ = 0" get obliterated. Therefore, short of
    -- actually parsing the binding ourselves, we replaceanything not ASCII
    -- with an ASCII character ('x').
    stmt <- getInput
    case H.parseStmt stmt of
        H.ParseOk H.LetStmt{}
          -> return (Stmt stmt)
        _ -> case H.parseStmt (mangle stmt) of
            H.ParseOk H.LetStmt{}
              -> return (Stmt stmt)
            _ -> fail "Not a let binding."
  where
    mangle = map $ \c -> if isAscii c then c else 'x'

parseExpr = Expr <$> getInput

-- | Used by 'prompt'
parseInput   = foldr1 (\l r -> Text.Parsec.try l <|> r)
    [ parseClear
    , parseUndefine
    , parseType
    , parseKind
    , parseInfo
    , parseStmt
    , parseDecl
    , parseExpr ]

unsafeCatch :: Exception e => a -> (e -> a) -> a
unsafeCatch a f = unsafePerformIO (catch (evaluate a) (return . f))

cripple :: a -> a -> a
cripple x y = unsafeCatch x (\SomeException{} -> y)

-- | Used by 'prompt'.
prettyOutput :: Repl a -> Output -> [String]
prettyOutput _ (OK s)          = s
prettyOutput _ (Partial s)     = s
prettyOutput _ (Errors errs)   = errs
prettyOutput r (Exception s e) = map
    (take (lineLength (config r)))
    (overLast (++ ("*** Exception: " ++ cripple e "*** Exception: that's enough exceptions for you.")) s)
prettyOutput _ (Timeout [])    = ["*** Timed out"]
prettyOutput _ (Timeout s)     = overLast (++ "*** Timed out") s

-- | Send input.
send :: Repl a -> Input -> IO ()
send = writeChan . inputChan

-- | Naiively get the next set of results. This /does not/ take into account
-- 'patiences', 'patienceForErrors', or 'lineLength'. However, due
-- to laziness, this may not matter.
result :: Repl a -> IO (ReplOutput a)
result = readChan . outputChan

{-# INLINE index #-}
index :: Int -> [a] -> Maybe a
i `index` ys
    | i >= 0    = go 0 ys
    | otherwise = Nothing
  where
    go _ [] = Nothing
    go j (x:xs)
        | j == i    = Just x
        | otherwise = go (j+1) xs

{-# INLINE overHead #-}
overHead :: (a -> a) -> [a] -> [a]
overHead f xs' = case xs' of
    x:xs -> f x : xs
    _    -> []

{-# INLINE overLast #-}
overLast :: (a -> a) -> [a] -> [a]
overLast f = go
  where
    go []     = []
    go [x]    = [f x]
    go (x:xs) = x : go xs

{-# INLINE lengthAt #-}
lengthAt :: Int -> [[a]] -> Int
lengthAt i = maybe 0 length . index i

-- | Same as 'prompt_', except it parses the input, and pretty prints the results.
prompt
    :: Repl [String]
    -> String
    -> IO [String]
prompt repl x = prettyOutput repl <$> prompt_ repl (case runParser parseInput () "" x of
    Right a -> a
    -- Should be impossible to reach. parseExpr gobbles up everything.
    _       -> error "Cannot parse input!")

-- | Enter commands and an expression to a 'Repl', and immediately consume results.
-- However, truncate input to the given length, and stop the computation after the
-- given amount of time in seconds.
prompt_
    :: Repl [String]
    -> Input
    -> IO Output
prompt_ repl x = do
    send repl x
    results' <- result repl

    unlessRedundant results' $ \ results -> do
        -- outputs is used iff an exception is raised by the compiled input.
        -- This was a DList, but I didn't find any real advantage of it over
        -- [String] -- snoc was cheap but toList very expensive.
        outputs :: IORef [String]   <- newIORef []
        threads :: IORef [ThreadId] <- newIORef []
        final   :: MVar Output      <- newEmptyMVar
        let push    c   = do
                output <- readIORef outputs
                if lengthAt (length output - 1) output > lineLength (config repl)
                  then putMVar final (Partial (unreverse output))
                  else writeIORef outputs (overHead (c:) output)
            newline     = modifyIORef outputs ([]:)
            readOutput  = unreverse <$> readIORef outputs
            fork f      = do
                thread <- forkIO $ f `catch` \e@SomeException{} -> do
                    output <- readOutput
                    putMVar final (Exception output (show e))
                modifyIORef threads (thread:)

        -- Time out
        -- This can return only Timeout <what was consumed so far>
        fork $ do
            threadDelay (floor (patience (config repl) * 1000000))
            output <- readOutput
            putMVar final (Timeout output)

        -- Read characters off of results, and "push" them to outputs.
        fork $ do
            forM_ results $ \l -> do
                newline
                forM_ l push
            putMVar final . OK =<< readOutput

        output <- takeMVar final
        mapM_ killThread =<< readIORef threads
        return output
  where
    unreverse = reverse . map reverse
    trim      = take (lineLength (config repl))

    -- | Don't bother with things other than an actual result from an expression -- they will be loaded "instantly"
    unlessRedundant (ReplError s) _ = return . Errors . map trim . lines $ s
    unlessRedundant (GhcError  s) _ = return . Errors . map trim . lines $ s
    unlessRedundant (Output s) _    = return . OK . map trim $ s
    unlessRedundant (Result s) f    = f s

stopRepl :: Repl a -> IO ()
stopRepl = killThread . interpreter

-- | Default GHCi-like 'Repl'
newRepl :: IO (Repl [String])
newRepl = do
    inp <- newChan
    out <- newChan
    repl' inp out defaultConfig

defaultConfig :: Config [String]
defaultConfig = Config
    defaultImports
    defaultFlags
    defaultBuildExpr
    defaultProcessOutput
    defaultPatience
    defaultLineLength

defaultImports :: [String]
defaultImports
  = ["import Prelude hiding ((.), id, catch)"
    ,"import GHC.TypeLits"
    ,"import qualified Data.Map as M"
    ,"import qualified Data.Foldable as F"
    ,"import qualified Data.Traversable as T"
    ,"import qualified Control.Exception (catch)"
    ,"import Control.Monad.Reader"
    ,"import Control.Monad.State"
    ,"import Control.Monad.Writer"
    ,"import Control.Monad.RWS"
    ,"import Control.Monad.Identity"
    ,"import Control.Monad.ST"
    ,"import Control.Comonad"
    ,"import Control.Category"
    ,"import Control.Monad"
    ,"import Control.Monad.Fix"
    ,"import Control.Applicative"
    ,"import Control.Lens"
    ,"import Control.Arrow"
    ,"import Data.Function hiding ((.), id)"
    ,"import Data.Either"
    ,"import Data.Int"
    ,"import Data.Word"
    ,"import Data.List"
    ,"import Data.List.Split"
    ,"import Data.Maybe"
    ,"import Data.Bits"
    ,"import Data.Array"
    ,"import Data.Ix"
    ,"import Data.Functor"
    ,"import Data.Typeable"
    ,"import Data.Monoid"
    ,"import Data.Ratio"
    ,"import Data.Complex"
    ,"import Data.Char"
    ,"import Data.Bits.Lens"
    ,"import Data.List.Lens"
    ,"import Data.List.Split.Lens"
    ]

defaultFlags :: [String]
defaultFlags = map ("-X"++)
    ["DataKinds"
    ,"PolyKinds"
    ,"KindSignatures"
    ,"TypeOperators"
    ,"DeriveFunctor"
    ,"DeriveTraversable"
    ,"DeriveFoldable"
    ,"DeriveDataTypeable"
    ,"DeriveGeneric"
    ,"OverloadedStrings"
    ,"ImplicitParams"
    ,"BangPatterns"
    ,"PatternGuards"
    ,"MultiWayIf"
    ,"LambdaCase"
    ,"FlexibleInstances"
    ,"FlexibleContexts"
    ,"FunctionalDependencies"
    ,"StandaloneDeriving"
    ,"MultiParamTypeClasses"
    ,"UnicodeSyntax"
    ,"RankNTypes"
    ,"ExistentialQuantification"
    ,"GADTs"
    ,"TypeFamilies"
    ,"Safe"
    ] ++
    [ "-dcore-lint" ]

-- | defaultLineLength = 512
defaultLineLength :: Int
defaultLineLength = 512

-- | defaultPatience = 5
defaultPatience :: Double
defaultPatience = 5

defaultBuildExpr :: String -> String
defaultBuildExpr x = "show (" ++ x ++ ")"

defaultProcessOutput :: Dynamic -> IO [String]
defaultProcessOutput d = return (lines (fromDyn d ""))

-- | 'Repl' smart constructor.
repl'
    :: Chan Input           -- ^ Input channel
    -> Chan (ReplOutput a)  -- ^ Output channel
    -> Config a
    -> IO (Repl a)
repl' inp out cfg = do
    interp <- forkIO $
        runGhc (Just libdir) $ do
            initialDynFlags <- getProgramDynFlags
            (dflags',_,_)   <- parseDynamicFlags initialDynFlags (map (mkGeneralLocated "flag") (compilerFlags cfg))
            _pkgs           <- setSessionDynFlags dflags'
            dflags          <- getSessionDynFlags

            let sdoc :: Outputable a => a -> String
                sdoc = showSDocForUser dflags neverQualify . ppr

                formatType
                    = splitForAllTys
                  >>> snd
                  >>> sdoc
                  >>> lines
                  >>> Output

            forever $ do
                import_ (imports cfg)
                i'   <- liftIO (readChan inp)
                liftIO . writeChan out =<< case i' of
                    Clear      -> do
                        setTargets []
                        void (load LoadAllTargets)
                        return (Output ["Cleared memory."])

                    Undefine s' -> fmap Output $
                        forM (words s') $ \s -> do
                            let eqs :: NamedThing a => a -> Bool
                                eqs n = occNameString (getOccName n) == s
                            session <- getSession
                            setSession session
                                { hsc_IC = (hsc_IC session)
                                    { ic_tythings = filter (not . eqs) (ic_tythings (hsc_IC session)) }
                                }
                            return "OK."

                    Type s -> errors $ formatType <$> exprType s
                    Kind s -> errors $ formatType . snd <$> typeKind True s
                    Decl s -> errors $ do _names <- runDecls s; return (Output ["OK."]) --  ["OK."]
                    Stmt s -> errors $ do void (runStmt s SingleStep); return (Output ["OK."])
                    Expr s -> errors $ do
                        compiled <- dynCompileExpr (buildExpr cfg s)
                        built    <- liftIO (process cfg compiled)
                        return (Result built)
                    Info s -> errors $ do
                        names <- parseName s
                        infos <- concatMap (\(t,f,cs) -> sdoc t : sdoc f : map sdoc cs)
                               . catMaybes
                             <$> mapM getInfo names
                        return $ Output infos
    return Repl
        { inputChan      = inp
        , outputChan     = out
        , interpreter    = interp
        , config         = cfg
        }
  where
    errors x = x `gcatch` \ e@SomeException{} ->
        return $! case fromException e :: Maybe ErrorCall of
            Just _ -> ReplError (show e)
            _      -> GhcError  (show e)

    import_ = mapM (fmap IIDecl . parseImportDecl) >=> setContext