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
119
120
121
122
123
124
125
126
|
module Builtins where
import Code
( Builtin(..)
, BuiltinFn
, Cho(..)
, Datum(..)
, Instr(..)
, Interp(..)
, heapStruct
)
import qualified Compiler as Co
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Lazy (get, gets, modify)
import Data.Functor.Identity (runIdentity)
import Data.List (intercalate)
import qualified Data.Map as M
import Env (PrlgEnv(..), findStruct)
import qualified IR
import Interpreter (backtrack)
import qualified Operators as O
import System.Console.Haskeline (getInputChar, outputStr, outputStrLn)
bi = Builtin
showTerm itos heap = runIdentity . heapStruct atom struct hrec heap
where
atom (Atom a) = pure $ itos M.! a
atom VoidRef = pure "_"
struct (Struct (IR.Id h _)) args =
pure $ itos M.! h ++ "(" ++ intercalate "," args ++ ")"
hrec (HeapRef hr) ref =
pure $
(if hr == ref
then "_X"
else "_Rec") ++
show hr
printLocals :: BuiltinFn
printLocals = do
scope <- gets (gvar . cur)
heap <- gets (heap . cur)
IR.StrTable _ _ itos <- gets strtable
flip traverse (M.elems scope) $ \(ref, name) ->
lift . outputStrLn $
(maybe "_" id $ 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 <- 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
assertFact :: BuiltinFn
assertFact = do
scope <- gets (hvar . cur)
heap <- gets (heap . cur)
case Co.compileGoal . Co.struct2goal . Co.squashVars <$>
Co.heapStructPrlgInt Nothing heap (fst $ scope M.! 0) of
Just (U (Struct s):head) -> do
addClause s $ head ++ [NoGoal]
return Nothing
_ -> backtrack
retractall :: BuiltinFn
retractall = do
return Nothing
{- adding the builtins -}
addOp op = modify $ \s -> s {ops = op : ops s}
addClause struct head =
modify $ \s ->
s {defs = M.alter (Just . maybe [head] (\hs -> head : hs)) struct $ defs s}
addProcedure struct heads =
modify $ \s -> s {defs = M.insert struct heads $ defs s}
addProc n a c = do
sym <- findStruct n a
addProcedure sym c
addBi0 n b = addProc n 0 [[Invoke $ bi b]]
addPrelude :: PrlgEnv ()
addPrelude = do
pure undefined
{- primitives -}
addBi0 "true" (pure Nothing)
addBi0 "fail" backtrack
addOp $ O.xfx "=" 700
addProc "=" 2 [[U (LocalRef 0 0), U (LocalRef 0 0), NoGoal]]
{- clauses -}
addOp $ O.xfy "," 1000
addOp $ O.xfx ":-" 1200
addOp $ O.fx ":-" 1200
addProc "assert" 1 [[U (LocalRef 0 0), Invoke (bi assertFact)]]
addProc "retractall" 1 [[U (LocalRef 0 0), Invoke (bi retractall)]]
{- query tools -}
addBi0 "print_locals" printLocals
addBi0 "prompt_retry" promptRetry
{- IO -}
addProc "write" 1 [[U (LocalRef 0 0), Invoke (bi write)]]
addProc "writeln" 1 [[U (LocalRef 0 0), Invoke (bi writeln)]]
addBi0 "nl" nl
{- debug -}
addBi0 "interpreter_trace" (get >>= liftIO . print >> pure Nothing)
|
