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
|
{-# LANGUAGE TupleSections #-}
module Code where
import Control.Monad.Trans.State.Lazy (StateT)
import qualified Data.Map as M
import IR (Id(..), StrTable)
import Operators (Ops)
import System.Console.Haskeline (InputT)
data Datum
= Atom Int -- unifies a constant
| Struct Id -- unifies a structure with arity
| VoidRef -- unifies with anything
| LocalRef Int Int -- code-local variable idx (should never occur on heap)
| HeapRef Int -- something further on the heap
deriving (Show, Eq, Ord)
data Instr
= U Datum -- something unifiable
| NoGoal -- trivial goal (directly after head)
| Invoke Builtin -- also directly after head
| Goal -- a new goal (set head)
| Call -- all seems okay, call the head's hoal
| LastCall -- tail call the head's goal
| Cut -- remove all alternative clauses of the current goal
deriving (Show)
type Code = [Instr]
type Defs = M.Map Id [Code]
data Heap =
Heap Int (M.Map Int Datum)
deriving (Show)
emptyHeap = Heap 1 M.empty
type Scope = M.Map Int (Int, Int)
emptyScope :: Scope
emptyScope = M.empty
data Cho =
Cho
{ hed :: Code -- head pointer
, hvar :: Scope -- variables unified in head (so far)
, gol :: Code -- goal pointer
, gvar :: Scope -- variables unified in the goal
, heap :: Heap -- a snapshot of the heap (there's no trail; we rely on CoW copies in other choicepoints)
, stk :: [(Code, Scope, [Cho])] -- remaining goals together with their vars and cuts
, cut :: [Cho] -- snapshot of choicepoints before entering
}
deriving (Show)
data Interp =
Interp
{ defs :: Defs -- global definitions for lookup
, cur :: Cho -- the choice that is being evaluated right now
, cho :: [Cho] -- remaining choice points
, ops :: Ops -- currently defined operators
, strtable :: StrTable -- string table
}
deriving (Show)
type PrlgEnv a = StateT Interp (InputT IO) a
type BuiltinFn = PrlgEnv (Maybe (Either String Bool))
data Builtin =
Builtin BuiltinFn
instance Show Builtin where
show _ = "Builtin _"
-- TODO are we actually going to use this?
codeStruct ::
Monad m
=> (Datum -> m a)
-> (Datum -> [a] -> m a)
-> (Datum -> m (Either Int a))
-> (Datum -> Int -> m a)
-> m a
-> Heap
-> Code
-> m (Code, a)
codeStruct atom struct local rec end heap = go
where
go [] = ([], ) <$> end
go (U lr@(LocalRef _ _):cs) = do
x <- local lr
case x of
Left ref -> (cs, ) <$> heapStruct atom struct rec heap ref
Right a -> pure (cs, a)
go (U s@(Struct (IR.Id _ arity)):cs) = eat arity cs >>= traverse (struct s)
go (U x:cs) = (cs, ) <$> atom x
go cs = (cs, ) <$> end
eat n cs
| n <= 0 = pure (cs, [])
| otherwise = do
(rest, a) <- go cs
fmap (a :) <$> eat (n - 1) rest
heapStruct ::
Monad m
=> (Datum -> m a)
-> (Datum -> [a] -> m a)
-> (Datum -> Int -> m a)
-> Heap
-> Int
-> m a
heapStruct atom struct rec (Heap _ heap) hr = go [hr] hr
where
go visited ref
| rr@(HeapRef r) <- heap M.! ref =
if r == ref || r `elem` visited
then rec rr ref
else go (r : visited) r
| s@(Struct (IR.Id _ arity)) <- heap M.! ref =
sequence [go (ref + i : visited) (ref + i) | i <- [1 .. arity]] >>=
struct s
| x <- heap M.! ref = atom x
|
