diff --git a/app/Builtins.hs b/app/Builtins.hs index 555623c..0cdd7cd 100644 --- a/app/Builtins.hs +++ b/app/Builtins.hs @@ -2,11 +2,15 @@ module Builtins where import Code ( Builtin(..) - , BuiltinFn , Cho(..) , Datum(..) + , Dereferenced(..) + , Heap(..) , Instr(..) , Interp(..) + , InterpFn + , InterpFn + , derefHeap , heapStruct ) import qualified Compiler as Co @@ -16,7 +20,7 @@ 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(..), findAtom, findStruct) +import Env (PrlgEnv(..), findAtom, findStruct, prlgError) import qualified IR import Interpreter (backtrack) import qualified Operators as O @@ -37,7 +41,7 @@ showTerm itos heap = runIdentity . heapStruct atom struct hrec heap else "_Rec") ++ show hr -printLocals :: BuiltinFn +printLocals :: InterpFn printLocals = do scope <- gets (gvar . cur) heap <- gets (heap . cur) @@ -47,37 +51,39 @@ printLocals = do (maybe "_" id $ itos M.!? name) ++ " = " ++ showTerm itos heap ref return Nothing -promptRetry :: BuiltinFn +promptRetry :: InterpFn promptRetry = do last <- gets (null . cho) if last then return Nothing else promptRetry' -promptRetry' :: BuiltinFn +promptRetry' :: InterpFn promptRetry' = do x <- lift $ getInputChar "? " case x of Just ';' -> backtrack _ -> return Nothing -write :: BuiltinFn -write = do +write :: InterpFn +write + --TODO: prlgError on write(Unbound) + = 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 :: InterpFn nl = do lift $ outputStrLn "" return Nothing -writeln :: BuiltinFn +writeln :: InterpFn writeln = write >> nl -assertFact :: BuiltinFn +assertFact :: InterpFn assertFact = do scope <- gets (hvar . cur) heap <- gets (heap . cur) @@ -86,9 +92,9 @@ assertFact = do Just (U (Struct s):head) -> do addClause s $ head ++ [NoGoal] return Nothing - _ -> backtrack --TODO actually throw + _ -> prlgError "assert fact failure" -assertClause :: BuiltinFn +assertClause :: InterpFn assertClause = do scope <- gets (hvar . cur) heap <- gets (heap . cur) @@ -101,11 +107,33 @@ assertClause = do Co.compileGoal hs ++ Co.seqGoals (Co.compileGoals commaId cut gs) in do addClause s cs return Nothing - _ -> backtrack + _ -> prlgError "assert clause failure" -retractall :: BuiltinFn -retractall = do - return Nothing +retractall :: InterpFn +retractall = prlgError "no retractall yet" + +call :: InterpFn +call = do + ref <- gets (fst . (M.! 0) . hvar . cur) + heap@(Heap _ hmap) <- gets (heap . cur) + let exec base struct arity = do + cur <- gets cur + modify $ \s -> + s + { cur = + cur + { gol = + [Call, Goal, U struct] ++ + [U $ hmap M.! (base + i) | i <- [1 .. arity]] ++ gol cur + } + } + return Nothing + case derefHeap heap ref of + BoundRef addr struct@(Struct IR.Id {IR.arity = arity}) -> + exec addr struct arity + BoundRef addr (Atom a) -> + exec addr (Struct IR.Id {IR.arity = 0, IR.str = a}) 0 + _ -> prlgError "not callable" {- adding the builtins -} addOp op = modify $ \s -> s {ops = op : ops s} @@ -148,6 +176,7 @@ addPrelude = do , [U (LocalRef 0 0), Invoke (bi assertFact)] ] addProc "retractall" 1 [[U (LocalRef 0 0), Invoke (bi retractall)]] + addProc "call" 1 [[U (LocalRef 0 0), Invoke (bi call)]] {- query tools -} addBi0 "print_locals" printLocals addBi0 "prompt_retry" promptRetry' diff --git a/app/Code.hs b/app/Code.hs index 8bea782..0556415 100644 --- a/app/Code.hs +++ b/app/Code.hs @@ -65,14 +65,30 @@ data Interp = type PrlgEnv a = StateT Interp (InputT IO) a -type BuiltinFn = PrlgEnv (Maybe (Either String Bool)) +type InterpFn = PrlgEnv (Maybe (Either String Bool)) data Builtin = - Builtin BuiltinFn + Builtin InterpFn instance Show Builtin where show _ = "Builtin _" +data Dereferenced + = FreeRef Int + | BoundRef Int Datum + | NoRef + +-- TRICKY: HeapRefs alone must not form a cycle other than the FreeRef case. +derefHeap :: Heap -> Int -> Dereferenced +derefHeap h@(Heap _ hmap) x = + case hmap M.!? x of + Just (HeapRef x') -> + if x == x' + then FreeRef x' + else derefHeap h x' + Just x' -> BoundRef x x' + _ -> NoRef + -- TODO are we actually going to use this? codeStruct :: Monad m diff --git a/app/Env.hs b/app/Env.hs index e873711..82bf9d0 100644 --- a/app/Env.hs +++ b/app/Env.hs @@ -1,6 +1,6 @@ module Env where -import Code (Interp(..), PrlgEnv) +import Code (Interp(..), InterpFn, PrlgEnv) import Control.Monad.Trans.State.Lazy (gets, modify) import qualified IR @@ -20,3 +20,6 @@ findAtom :: String -> Env.PrlgEnv Int findAtom = withStrTable . flip IR.strtablize type PrlgEnv a = Code.PrlgEnv a + +prlgError :: String -> InterpFn +prlgError = pure . pure . Left diff --git a/app/IR.hs b/app/IR.hs index 8507a3e..631cd16 100644 --- a/app/IR.hs +++ b/app/IR.hs @@ -16,7 +16,7 @@ data Id = deriving (Show, Eq, Ord) data PrlgInt - = CallI Id [PrlgInt] + = CallI Id [PrlgInt] --TODO this should be Int | LiteralI Int | VarI Int Int -- VarI localIndex strTableString | VoidI diff --git a/app/Interpreter.hs b/app/Interpreter.hs index 21340ef..7192c7b 100644 --- a/app/Interpreter.hs +++ b/app/Interpreter.hs @@ -6,9 +6,12 @@ import Code , Cho(..) , Code , Datum(..) + , Dereferenced(..) , Heap(..) , Instr(..) , Interp(..) + , InterpFn + , derefHeap , emptyHeap , emptyScope ) @@ -43,13 +46,8 @@ prove g = do Nothing -> loop -- not finished yet Just x -> return x -data Dereferenced - = FreeRef Int - | BoundRef Int Datum - | NoRef - {- Simple "fail" backtracking -} -backtrack :: PrlgEnv (Maybe (Either String Bool)) +backtrack :: InterpFn backtrack = do chos <- St.gets cho case chos @@ -61,7 +59,7 @@ backtrack = do {- if there's no other choice, answer no -} _ -> pure . Just $ Right False -proveStep :: PrlgEnv (Maybe (Either String Bool)) +proveStep :: InterpFn proveStep = St.get >>= go where finish = pure . Just @@ -76,23 +74,14 @@ proveStep = St.get >>= go Just d -> cont d _ -> ifail $ "no definition: " ++ show fn {- Unification -} - go i@Interp {cur = cur@Cho { hed = U h:hs - , gol = U g:gs - , heap = heap@(Heap _ hmap) - }} = unify h g + go i@Interp {cur = cur@Cho {hed = U h:hs, gol = U g:gs, heap = heap}} = + unify h g where uok = c i {cur = cur {hed = hs, gol = gs}} setHeap r x = c i {cur = cur {hed = hs, gol = gs, heap = writeHeap r x heap}} {- heap tools -} - deref x = - case hmap M.!? x of - Just (HeapRef x') -> - if x == x' - then FreeRef x' - else deref x' - Just x' -> BoundRef x x' - _ -> NoRef + deref = derefHeap heap writeHeap addr x (Heap nxt m) = Heap nxt (M.adjust (const x) addr m) newHeapVar h = head <$> newHeapVars 1 h newHeapVars n (Heap nxt m) =