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
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
|
{-# 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.Resource (Resource, allocateEff)
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, Resource :> es)
=> Eff (Repl p ms t : es) a
-> Eff es a
runRepl action = do
inputState <- snd <$> allocateEff inputStateAlloc inputStateDealloc
evalStaticRep (Repl inputState) action
where
inputStateAlloc = do
logMsg Info "Initializing input"
liftIO $ initializeInput defaultSettings
inputStateDealloc inputState = do
logMsg Info "Cancelling input"
liftIO $ cancelInput inputState
|
