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
|
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Minilang.REPL.Run where
import Control.Monad.Catch
import Data.Bifunctor (second)
import Data.Text hiding (replicate)
import Minilang.Lambda (loadProgram)
import Minilang.Lambda.DeBruijn (eval, eval', fromDeBruijn, toDeBruijn)
import Minilang.Lambda.Eval (newEnv)
import Minilang.Lambda.Infer (infer, newContext)
import qualified Minilang.Lambda.Infer as Infer
import Minilang.Lambda.Parser (AST (..), desugar, parse, parseProgram, resugar)
import Minilang.Lambda.Unify (Type (TyVar))
import Minilang.REPL.Types
-- | Run a REPL session
runREPL ::
(MonadCatch m, MonadREPL m) => m ()
runREPL = go
where
go = do
prompt
raw <- input
case raw of
EOF -> output Bye
In txt -> handleUserInput txt >> go
Com cmd -> handleCommand cmd >> go
handleUserInput ::
(MonadCatch m, MonadREPL m) =>
Text ->
m ()
handleUserInput txt = do
repl@REPLEnv {language, env} <- getEnv
case parse txt of
Left err -> output (Msg $ pack $ show err)
Right (Def ident body) -> do
let term = desugar body
case language of
Typed ->
case infer term of
Left typeError -> output (Msg $ Infer.render typeError)
Right typ -> do
setEnv $ repl {env = (ident, term) : env}
output (Defined ident typ)
Untyped -> do
setEnv $ repl {env = (ident, term) : env}
output (Defined ident (TyVar "<?>"))
Right expr -> do
let term = desugar expr
env' = second toDeBruijn <$> env
v = fromDeBruijn $ eval' env' (toDeBruijn term)
ast = resugar v
case language of
Typed ->
case infer term of
Left typeError -> output (Msg $ Infer.render typeError)
Right typ -> do
let
output (Evaluated ast v typ)
Untyped ->
output (Evaluated ast v (TyVar "<?>"))
handleCommand ::
(MonadCatch m, MonadREPL m) =>
Command ->
m ()
handleCommand ClearEnv = getEnv >>= \e -> setEnv (e {env = newEnv, context = newContext})
handleCommand DumpEnv =
getEnv >>= \REPLEnv {..} ->
output (CurrentEnv env context language)
handleCommand (Load (File file)) = do
t <- load file
case t of
Left err -> output (Msg $ pack $ show err)
Right prog -> loadProgramInEnv prog
handleCommand (Load (Data prog)) = loadProgramInEnv prog
handleCommand (Set (StepTypeChecker st)) = getEnv >>= \e -> setEnv (e {stepTypeCheck = st})
handleCommand (Set (DebugParser st)) = getEnv >>= \e -> setEnv (e {debugParser = st})
handleCommand (Set (SelectLanguage lang)) =
getEnv >>= \e ->
setEnv (e {language = lang})
>> output (Msg $ "Language set to " <> pack (show lang))
handleCommand Help =
output (Msg helpText)
loadProgramInEnv ::
(MonadCatch m, MonadREPL m) =>
Text ->
m ()
loadProgramInEnv prog = do
repl@REPLEnv {env, context, language} <- getEnv
case parseProgram prog of
Left err -> output (Msg $ pack $ show err)
Right exprs -> do
case loadProgram language env context exprs of
Left typeError -> output (Msg $ pack $ show typeError)
Right (results, env', context') -> do
setEnv (repl {env = env', context = context'})
mapM_ (\(term, typ) -> output (Evaluated (resugar term) term typ)) results
|
