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
105
106
107
108
109
110
111
112
113
114
115
116
117
118
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC "-fno-warn-orphans" #-}
{-# LANGUAGE LambdaCase #-}
module Minilang.REPL.Haskeline where
import Control.Exception (throw)
import Control.Monad.Catch
import Control.Monad.Reader
import Control.Monad.State
import Data.Bifunctor
import Data.List
( isPrefixOf,
isSuffixOf,
)
import Data.Text (pack, unpack)
import Data.Text.IO as Text
import Minilang.REPL.Run (handleCommand)
import Minilang.REPL.Types
import System.Console.Haskeline
( Completion (Completion, replacement),
CompletionFunc,
InputT,
getInputLineWithInitial,
outputStrLn,
)
import System.Directory (listDirectory)
import Minilang.Lambda.Parser (resugar, pretty)
import qualified Minilang.Lambda.Unify as Unify
-- * Haskeline REPL
newtype Haskeline a = Haskeline {runHaskeline :: StateT REPLEnv (InputT IO) a}
deriving (Functor, Applicative, Monad, MonadIO, MonadState REPLEnv)
hoist :: InputT IO a -> Haskeline a
hoist m = Haskeline $ StateT $ \s -> m >>= \a -> pure (a, s)
instance MonadREPL Haskeline where
input = do
i <- hoist (getInputLineWithInitial "λΠ> " ("", ""))
case i of
Nothing -> pure EOF
Just (pack -> t) -> pure $ interpret t
output = hoist . outputStrLn . render
prompt = pure ()
load = fmap (first FileError) . hoist . lift . try . Text.readFile . unpack
getEnv = get
setEnv = put
render :: Out -> String
render = \case
Msg t -> unpack t
Evaluated term typ -> unpack $ pretty (resugar term) <> " : " <> Unify.pretty typ
other -> show other
completion :: CompletionFunc IO
completion = completion' . first reverse
data CompleteWith
= SetUnset String
| LoadFile
| AllCommands
completion' :: CompletionFunc IO
completion' (inputString, _) =
case matchedCompletionRule inputString of
SetUnset com : _ -> setUnsetCompletion com
LoadFile : _ -> completeLoadWithFiles (drop 6 inputString)
_ -> allCommandCompletions
where
matchedCompletionRule prefix =
snd
<$> filter
(($ prefix) . fst)
[ ((":set" `isPrefixOf`), SetUnset ":set"),
((":unset" `isPrefixOf`), SetUnset ":unset"),
((":load" `isPrefixOf`), LoadFile),
(const True, AllCommands)
]
completeLoadWithFiles prefix = do
files <- filter (prefix `isPrefixOf`) . filter (".mtt" `isSuffixOf`) <$> listDirectory "."
pure ("", fmap (\fp -> Completion (":load " <> fp) fp True) files)
setUnsetCompletion com =
pure
( "",
filter
((inputString `isPrefixOf`) . replacement)
[ Completion (com <> " step") "step - Step through evaluation process, displaying each rule application" True,
Completion (com <> " debug") "debug - Debug parsing of input" True
]
)
allCommandCompletions =
pure
( "",
filter
((inputString `isPrefixOf`) . replacement)
[ Completion ":quit" ":quit - Quit minilang REPL" False,
Completion ":env" ":env - Dump current environment and context (types and values)" False,
Completion ":clear" ":clear - Clear environment" False,
Completion ":load" ":load - Load a file into the REPL" True,
Completion ":set" ":set - Set some properties of the REPL" True,
Completion ":unset" ":unset - Unset some properties of the REPL" True,
Completion ":help" ":help - Provide help on commands" True
]
)
instance MonadCatch Haskeline where
Haskeline m `catch` f = Haskeline $ m `catch` \e -> runHaskeline (f e)
instance MonadThrow Haskeline where
throwM = throw
|
