diff options
Diffstat (limited to 'app/Code.hs')
| -rw-r--r-- | app/Code.hs | 74 |
1 files changed, 23 insertions, 51 deletions
diff --git a/app/Code.hs b/app/Code.hs index 9e1f453..4473287 100644 --- a/app/Code.hs +++ b/app/Code.hs @@ -19,13 +19,11 @@ data Datum 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 + = U Datum -- unify/resolve something + | Invoke Builtin -- give control to a builtin (invoked from head) + | Done -- all done, can return + | Cut -- remove choicepoints of the current goal + | Choices [[Code]] -- split off several possibilities (push choicepoints) deriving (Show) type Code = [Instr] @@ -45,30 +43,32 @@ 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 + { _hed :: Code -- head pointer + , _hvar :: Scope -- variables unified in head (so far) + , _gol :: Code -- goal pointer + , _gvar :: Scope -- variables unified in the goal + , _unis :: Int -- items left to unify + , _retcut :: Bool -- cut after this goal succeeds + , _heap :: Heap -- a snapshot of the heap (there's no trail; we rely on CoW copies in other choicepoints) + , _stk :: [(Code, Scope, [Cho], Bool)] -- remaining goals together with their vars, cuts, and ret-cut flag + , _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 - , opstash :: [Ops] -- saved operators - , macrostash :: [(Maybe [Code], Maybe [Code])] -- saved expansion defs (load, query) - , strtable :: StrTable -- string table - , cmdq :: [(Bool, PAST)] -- isQuery, lexemes + { _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 + , _opstash :: [Ops] -- saved operators + , _macrostash :: [(Maybe [Code], Maybe [Code])] -- saved expansion defs (load, query) + , _strtable :: StrTable -- string table + , _cmdq :: [(Bool, PAST)] -- isQuery, lexemes } deriving (Show) -type PrlgEnv a = StateT Interp (InputT IO) a +type PrlgEnv = StateT Interp (InputT IO) type InterpFn = PrlgEnv (Maybe (Either String Bool)) @@ -114,34 +114,6 @@ withNewHeapStruct addr s@(Struct Id {arity = arity}) heap cont = m'' = M.insert addr (HeapRef $ head addrs) . M.insert (head addrs) s $ m' in cont (map HeapRef $ tail addrs) (Heap nxt' m'') --- 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) |