diff options
Diffstat (limited to 'app/Builtins.hs')
| -rw-r--r-- | app/Builtins.hs | 139 |
1 files changed, 80 insertions, 59 deletions
diff --git a/app/Builtins.hs b/app/Builtins.hs index 8ad94ef..4c08884 100644 --- a/app/Builtins.hs +++ b/app/Builtins.hs @@ -4,6 +4,7 @@ import Code import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.State.Lazy +import Data.Functor.Identity import Data.List (intercalate) import qualified Data.Map as M import Env hiding (PrlgEnv) @@ -14,28 +15,27 @@ 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 +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 _ heap <- gets (heap . cur) + 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 + lift . outputStrLn $ + (maybe "_" id $ itos M.!? name) ++ " = " ++ showTerm itos heap ref return Nothing promptRetry :: BuiltinFn @@ -48,9 +48,9 @@ promptRetry = do write :: BuiltinFn write = do scope <- gets (hvar . cur) - Heap _ heap <- gets (heap . cur) + heap <- gets (heap . cur) IR.StrTable _ _ itos <- gets strtable - lift . outputStr $ showTerm itos heap [] (fst $ scope M.! 0) + lift . outputStr . showTerm itos heap . fst $ scope M.! 0 return Nothing nl :: BuiltinFn @@ -61,45 +61,66 @@ nl = do 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 +assertFact :: BuiltinFn +assertFact = do + scope <- gets (hvar . cur) + heap <- gets (heap . cur) + {- TODO this needs to go through PrlgInt because of cuts in assertClause -} + let atom a = Just [U a] + struct s args = Just (U s : concat args) + hrec (HeapRef tgt) src + | src == tgt = Just [U (LocalRef tgt 0)] + | otherwise = Nothing + code = heapStruct atom struct hrec heap . fst $ scope M.! 0 + case code of + Just (U (Struct s):head) -> do + addClause s (head ++ [NoGoal]) + return Nothing + Just [U (Atom a)] -> do + addClause (IR.Id a 0) [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.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)] - } + 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) |