summaryrefslogtreecommitdiff
path: root/app/Builtins.hs
diff options
context:
space:
mode:
Diffstat (limited to 'app/Builtins.hs')
-rw-r--r--app/Builtins.hs171
1 files changed, 100 insertions, 71 deletions
diff --git a/app/Builtins.hs b/app/Builtins.hs
index 0cdd7cd..2b7f08e 100644
--- a/app/Builtins.hs
+++ b/app/Builtins.hs
@@ -46,9 +46,9 @@ printLocals = do
scope <- gets (gvar . cur)
heap <- gets (heap . cur)
IR.StrTable _ _ itos <- gets strtable
- flip traverse (M.elems scope) $ \(ref, name) ->
+ flip traverse (M.assocs scope) $ \(local, ref) ->
lift . outputStrLn $
- (maybe "_" id $ itos M.!? name) ++ " = " ++ showTerm itos heap ref
+ "_Local" ++ show local ++ " = " ++ showTerm itos heap ref
return Nothing
promptRetry :: InterpFn
@@ -65,15 +65,22 @@ promptRetry' = do
Just ';' -> backtrack
_ -> return Nothing
-write :: InterpFn
-write
- --TODO: prlgError on write(Unbound)
- = do
+withArgs :: [Int] -> ([Int] -> InterpFn) -> InterpFn
+withArgs as f = 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
+ if all (`M.member` scope) as
+ then f $ map (scope M.!) as
+ else prlgError "arguments not bound"
+
+write' :: InterpFn -> InterpFn
+write' c =
+ withArgs [0] $ \[arg] -> do
+ heap <- gets (heap . cur)
+ IR.StrTable _ _ itos <- gets strtable
+ lift . outputStr $ showTerm itos heap arg
+ c --this now allows error fallthrough but we might like EitherT
+
+write = write' $ return Nothing
nl :: InterpFn
nl = do
@@ -81,59 +88,71 @@ nl = do
return Nothing
writeln :: InterpFn
-writeln = write >> nl
+writeln = write' nl
assertFact :: InterpFn
-assertFact = do
- scope <- gets (hvar . cur)
- heap <- gets (heap . cur)
- case Co.compileGoal . Co.squashVars <$>
- Co.heapStructPrlgInt Nothing heap (fst $ scope M.! 0) of
- Just (U (Struct s):head) -> do
- addClause s $ head ++ [NoGoal]
- return Nothing
- _ -> prlgError "assert fact failure"
+assertFact =
+ withArgs [0] $ \[arg] -> do
+ heap <- gets (heap . cur)
+ case Co.compileGoal . Co.squashVars <$>
+ Co.heapStructPrlgInt Nothing heap arg of
+ Just (U (Struct s):head) -> do
+ addClause s $ head ++ [NoGoal]
+ return Nothing
+ _ -> prlgError "assert fact failure"
assertClause :: InterpFn
-assertClause = do
- scope <- gets (hvar . cur)
- heap <- gets (heap . cur)
- commaId <- findStruct "," 2
- cut <- findAtom "!"
- case Co.squashVars . IR.CallI (IR.Id 0 0) <$>
- traverse (Co.heapStructPrlgInt Nothing heap . fst . (M.!) scope) [0, 1] of
- Just (IR.CallI (IR.Id 0 0) [hs, gs]) ->
- let (U (Struct s):cs) =
- Co.compileGoal hs ++ Co.seqGoals (Co.compileGoals commaId cut gs)
- in do addClause s cs
- return Nothing
- _ -> prlgError "assert clause failure"
+assertClause =
+ withArgs [0, 1] $ \args -> do
+ scope <- gets (hvar . cur)
+ heap <- gets (heap . cur)
+ comma <- findAtom ","
+ cut <- findAtom "!"
+ case Co.squashVars . IR.CallI 0 <$>
+ traverse (Co.heapStructPrlgInt Nothing heap) args of
+ Just (IR.CallI 0 [hs, gs]) ->
+ let (U (Struct s):cs) =
+ Co.compileGoal hs ++ Co.seqGoals (Co.compileGoals comma cut gs)
+ in do addClause s cs
+ return Nothing
+ _ -> prlgError "assert clause failure"
retractall :: InterpFn
-retractall = prlgError "no retractall yet"
+retractall =
+ withArgs [0] $ \[arg] -> do
+ heap <- gets (heap . cur)
+ case derefHeap heap arg of
+ BoundRef _ (Atom a) -> dropProcedure (IR.Id {IR.arity = 0, IR.str = a})
+ BoundRef _ (Struct id) -> dropProcedure id
+ _ -> prlgError "retractall needs a struct"
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"
+call =
+ withArgs [0] $ \[arg] -> do
+ 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 arg 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"
+
+struct :: InterpFn
+struct = do
+ scope <- gets (hvar . cur)
+ prlgError "not yet"
{- adding the builtins -}
addOp op = modify $ \s -> s {ops = op : ops s}
@@ -145,20 +164,29 @@ addClause struct code =
addProcedure struct heads =
modify $ \s -> s {defs = M.insert struct heads $ defs s}
+dropProcedure struct = do
+ d <- gets defs
+ if struct `M.member` d
+ then do
+ modify $ \s -> s {defs = M.delete struct d}
+ return Nothing
+ else prlgError "no such definition" -- this should backtrack?
+
addProc n a c = do
sym <- findStruct n a
addProcedure sym c
-addBi0 n b = addProc n 0 [[Invoke $ bi b]]
+addBi n i b =
+ addProc n i [[U (LocalRef $ r - 1) | r <- [1 .. i]] ++ [Invoke $ bi b]]
addPrelude :: PrlgEnv ()
addPrelude = do
pure undefined
{- primitives -}
- addBi0 "true" (pure Nothing)
- addBi0 "fail" backtrack
+ addBi "true" 0 (pure Nothing)
+ addBi "fail" 0 backtrack
addOp $ O.xfx "=" 700
- addProc "=" 2 [[U (LocalRef 0 0), U (LocalRef 0 0), NoGoal]]
+ addProc "=" 2 [[U (LocalRef 0), U (LocalRef 0), NoGoal]]
{- clauses -}
addOp $ O.xfy "," 1000
addOp $ O.xfx ":-" 1200
@@ -168,22 +196,23 @@ addPrelude = do
"assert"
1
[ [ U (Struct horn2)
- , U (LocalRef 0 0)
- , U (LocalRef 1 0)
+ , U (LocalRef 0)
+ , U (LocalRef 1)
, Cut
, Invoke (bi assertClause)
]
- , [U (LocalRef 0 0), Invoke (bi assertFact)]
+ , [U (LocalRef 0), Invoke (bi assertFact)]
]
- addProc "retractall" 1 [[U (LocalRef 0 0), Invoke (bi retractall)]]
- addProc "call" 1 [[U (LocalRef 0 0), Invoke (bi call)]]
+ addBi "retractall" 1 retractall
+ addBi "call" 1 call
+ addBi "struct" 3 struct
{- query tools -}
- addBi0 "print_locals" printLocals
- addBi0 "prompt_retry" promptRetry'
- addBi0 "query" (printLocals >> promptRetry)
+ addBi "print_locals" 0 printLocals
+ addBi "prompt_retry" 0 promptRetry'
+ addBi "query" 0 (printLocals >> 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
+ addBi "write" 1 write
+ addBi "writeln" 1 writeln
+ addBi "nl" 0 nl
{- debug -}
- addBi0 "interpreter_trace" (get >>= liftIO . print >> pure Nothing)
+ addBi "interpreter_trace" 0 (get >>= liftIO . print >> pure Nothing)
generated by cgit v1.2.3 (git 2.39.1) at 2025-11-08 23:17:51 +0100