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
|
module Builtins where
import Code
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Lazy
import Data.List (intercalate)
import qualified Data.Map as M
import Env hiding (PrlgEnv)
import qualified IR
import Interpreter (backtrack)
import qualified Operators as O
import System.Console.Haskeline
bi = Builtin
showTerm itos heap visited ref
| ref `elem` visited = "_Rec" ++ show ref
| HeapRef r <- heap M.! ref =
if r == ref
then "_X" ++ show ref
else showTerm itos heap (ref : visited) r
| Struct (IR.Id h arity) <- heap M.! ref =
itos M.! h ++
"(" ++
intercalate
","
[showTerm itos heap (ref : visited) (ref + i) | i <- [1 .. arity]] ++
")"
| Atom a <- heap M.! ref = itos M.! a
printLocals :: BuiltinFn
printLocals = do
scope <- gets (gvar . cur)
Heap _ heap <- gets (heap . cur)
IR.StrTable _ _ itos <- gets strtable
flip traverse (M.elems scope) $ \(ref, name) ->
lift . outputStrLn $ (itos M.! name) ++ " = " ++ showTerm itos heap [] ref
return Nothing
promptRetry :: BuiltinFn
promptRetry = do
x <- lift $ getInputChar "? "
case x of
Just ';' -> backtrack
_ -> return Nothing
write :: BuiltinFn
write = do
scope <- gets (hvar . cur)
Heap _ heap <- gets (heap . cur)
IR.StrTable _ _ itos <- gets strtable
lift . outputStr $ showTerm itos heap [] (fst $ scope M.! 0)
return Nothing
nl :: BuiltinFn
nl = do
lift $ outputStrLn ""
return Nothing
writeln :: BuiltinFn
writeln = write >> nl
addBuiltins :: PrlgEnv ()
addBuiltins = do
a1 <- findStruct "a" 1
a <- findAtom "a"
b <- findAtom "b"
c <- findAtom "c"
varX <- findAtom "X"
b0 <- findStruct "b" 0
any1 <- findStruct "any" 1
eq2 <- findStruct "=" 2
hello0 <- findStruct "hello" 0
fail0 <- findStruct "fail" 0
true0 <- findStruct "true" 0
printlocals0 <- findStruct "print_locals" 0
debugprint0 <- findStruct "interpreter_state" 0
promptretry0 <- findStruct "prompt_retry" 0
write1 <- findStruct "write" 1
writeln1 <- findStruct "writeln" 1
nl0 <- findStruct "nl" 0
modify $ \s ->
s
{ defs =
M.fromList
[ (eq2, [[U (LocalRef 0 varX), U (LocalRef 0 varX), NoGoal]])
, (any1, [[U VoidRef, NoGoal]])
, (fail0, [[Invoke $ bi backtrack]])
, (true0, [[Invoke $ bi (pure Nothing)]])
, ( debugprint0
, [[Invoke $ bi (get >>= liftIO . print >> pure Nothing)]])
, (printlocals0, [[Invoke $ bi printLocals]])
, (promptretry0, [[Invoke $ bi promptRetry]])
, (write1, [[U (LocalRef 0 varX), Invoke $ bi write]])
, (writeln1, [[U (LocalRef 0 varX), Invoke $ bi writeln]])
, (nl0, [[Invoke $ bi nl]])
, (a1, [[U (Atom a), NoGoal], [U (Atom b), NoGoal]])
, ( b0
, [ [Goal, U (Struct a1), U (Atom c), LastCall]
, [Goal, U (Struct a1), U (Atom b), LastCall]
])
]
, ops = [(O.xfy "," 1000), (O.xfx "=" 700)]
}
|
