1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
|
{-# LANGUAGE TypeFamilies #-}
module Hsm.Repl
( Repl
, repl
, runRepl
) where
import Control.Monad (forM_)
import Data.Typeable (Proxy(Proxy), Typeable, typeRep)
import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>), liftIO)
import Effectful.Dispatch.Static (SideEffects(WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unsafeEff_)
import Effectful.Exception (bracket)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Generic.Data.Function.Common.Generic.Meta (KnownSymbols, symbolVals)
import Hsm.Log (Log, Severity(Attention, Info, Trace), logMsg)
import Language.Haskell.Interpreter (GhcError(errMsg), InterpreterError(WontCompile), as, interpret, runInterpreter, setImports)
import System.Console.Haskeline (defaultSettings, getInputLine, handleInterrupt, withInterrupt)
import System.Console.Haskeline.IO (InputState, cancelInput, initializeInput, queryInput)
data Repl (p :: Symbol) (ms :: [Symbol]) (t :: *) (a :: * -> *) (b :: *)
type instance DispatchOf (Repl p ms t) = Static WithSideEffects
newtype instance StaticRep (Repl p ms t) =
Repl InputState
repl ::
forall p ms t es. (KnownSymbol p, KnownSymbols ms, Log "repl" :> es, Repl p ms t :> es, Show t, Typeable t)
=> Eff es (Maybe t)
repl = query >>= maybe (return Nothing) parse
where
query = do
Repl inputState <- getStaticRep
logMsg Trace $ "Expecting a value of type: " <> show (typeRep $ Proxy @t)
unsafeEff_ . queryInput inputState . handleInterrupt (return Nothing) . withInterrupt . getInputLine $ symbolVal (Proxy @p)
parse string = do
logMsg Trace $ "Parsing string: " <> string
eitherValue <-
unsafeEff_ . runInterpreter $ do
setImports $ symbolVals @ms
interpret string as
case eitherValue of
Right value -> do
logMsg Trace $ "Parsed value: " <> show value
return $ Just value
Left (WontCompile errors) -> do
forM_ errors $ logMsg Attention . errMsg
repl
Left err -> do
logMsg Attention $ show err
repl
runRepl ::
forall p ms t es a. (IOE :> es, Log "repl" :> es)
=> Eff (Repl p ms t : es) a
-> Eff es a
runRepl action = bracket inputStateAlloc inputStateDealloc $ \inputState -> evalStaticRep (Repl inputState) action
where
inputStateAlloc = do
logMsg Info "Initializing input"
liftIO $ initializeInput defaultSettings
inputStateDealloc inputState = do
logMsg Info "Cancelling input"
liftIO $ cancelInput inputState
|
