From 3aa85f6a93b6ebec7beb7e590e6385754d60e920 Mon Sep 17 00:00:00 2001 From: Mirek Kratochvil Date: Sat, 7 Jan 2023 16:24:45 +0100 Subject: [PATCH] very assertive --- app/Builtins.hs | 163 ++++++++++++++++++++++++++++-------------------- app/Compiler.hs | 1 + 2 files changed, 98 insertions(+), 66 deletions(-) diff --git a/app/Builtins.hs b/app/Builtins.hs index 9db5386..34cc665 100644 --- a/app/Builtins.hs +++ b/app/Builtins.hs @@ -3,6 +3,7 @@ module Builtins where import Code ( Builtin(..) , Cho(..) + , Code , Datum(..) , Dereferenced(..) , Heap(..) @@ -30,6 +31,8 @@ import System.Console.Haskeline (getInputChar, outputStr, outputStrLn) bi = Builtin +continue = pure Nothing + showTerm itos heap = runIdentity . heapStruct atom struct hrec heap where atom (Atom a) = pure $ "'" ++ itos M.! a ++ "'" @@ -52,13 +55,13 @@ printLocals = do flip traverse (M.assocs scope) $ \(local, ref) -> lift . outputStrLn $ "_Local" ++ show local ++ " = " ++ showTerm itos heap ref - return Nothing + continue promptRetry :: InterpFn promptRetry = do last <- gets (null . cho) if last - then return Nothing + then continue else promptRetry' promptRetry' :: InterpFn @@ -66,7 +69,7 @@ promptRetry' = do x <- lift $ getInputChar "? " case x of Just ';' -> backtrack - _ -> return Nothing + _ -> continue withArgs :: [Int] -> ([Int] -> InterpFn) -> InterpFn withArgs as f = do @@ -83,29 +86,29 @@ write' c = lift . outputStr $ showTerm itos heap arg c --this now allows error fallthrough but we might like EitherT -write = write' $ return Nothing +write = write' continue nl :: InterpFn nl = do lift $ outputStrLn "" - return Nothing + continue writeln :: InterpFn writeln = write' nl -assertFact :: InterpFn -assertFact = +assertFact :: (Code -> IR.Id -> PrlgEnv ()) -> InterpFn +assertFact addClause = 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 + addClause (head ++ [NoGoal]) s + continue _ -> prlgError "assert fact failure" -assertClause :: InterpFn -assertClause = +assertRule :: (Code -> IR.Id -> PrlgEnv ()) -> InterpFn +assertRule addClause = withArgs [0, 1] $ \args -> do scope <- gets (hvar . cur) heap <- gets (heap . cur) @@ -116,8 +119,8 @@ assertClause = 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 + in do addClause cs s + continue _ -> prlgError "assert clause failure" retractall :: InterpFn @@ -125,8 +128,9 @@ 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 + BoundRef _ (Atom a) -> + dropProcedure (IR.Id {IR.arity = 0, IR.str = a}) >> continue + BoundRef _ (Struct id) -> dropProcedure id >> continue _ -> prlgError "retractall needs a struct" call :: InterpFn @@ -144,7 +148,7 @@ call = [U $ hmap M.! (base + i) | i <- [1 .. arity]] ++ gol cur } } - return Nothing + continue case derefHeap heap arg of BoundRef addr struct@(Struct IR.Id {IR.arity = arity}) -> exec addr struct arity @@ -152,7 +156,28 @@ call = exec addr (Struct IR.Id {IR.arity = 0, IR.str = a}) 0 _ -> prlgError "not callable" -{- struct building -} +exec :: InterpFn +exec = + withArgs [0] $ \[arg] -> do + heap <- gets (heap . cur) + case Co.squashVars <$> Co.heapStructPrlgInt Nothing heap arg of + Just gs -> do + cur <- gets cur + comma <- findAtom "," + cut <- findAtom "!" + modify $ \s -> + s + { cur = + cur + { hvar = M.empty + , hed = Co.seqGoals (Co.compileGoals comma cut gs) + , gol = [LastCall] + } + } + continue + _ -> prlgError "goal exec failure" + +{- struct assembly/disassembly -} struct :: InterpFn struct = do heap <- gets (heap . cur) @@ -209,7 +234,7 @@ structUnify arity str = do gcode = map U $ structData ++ [Atom str] ++ paramsData modify $ \s -> s {cur = cur {heap = h', gol = gcode ++ gol cur, hed = hcode ++ hed cur}} - return Nothing + continue {- operator management -} op :: InterpFn @@ -223,14 +248,14 @@ op = do (,) <$> itos M.!? opatom <*> (O.Op prio <$> ((itos M.!? fixityAtom) >>= O.fixity)) -> do modify $ \s -> s {ops = op : ops s} - return Nothing + continue _ -> prlgError "bad op spec" stashOps :: InterpFn stashOps = do currentOps <- gets ops modify $ \s -> s {opstash = currentOps : opstash s} - return Nothing + continue popOps :: InterpFn popOps = do @@ -239,71 +264,77 @@ popOps = do [] -> prlgError "no op stash to pop" (ops':opss) -> do modify $ \s -> s {ops = ops', opstash = opss} - return Nothing + continue {- adding the builtins -} +addOp :: (String, O.Op) -> PrlgEnv () addOp op = modify $ \s -> s {ops = op : ops s} -addClause struct code = - modify $ \s -> - s {defs = M.alter (Just . maybe [code] (\hs -> code : hs)) struct $ defs s} +modDef :: ([Code] -> Maybe [Code]) -> IR.Id -> PrlgEnv () +modDef fn struct = + modify $ \s -> s {defs = M.alter (maybe (fn []) fn) struct $ defs s} -addProcedure struct heads = - modify $ \s -> s {defs = M.insert struct heads $ defs s} +addClauseZ :: Code -> IR.Id -> PrlgEnv () +addClauseZ code = modDef $ Just . ([code] ++) -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? +addClauseA :: Code -> IR.Id -> PrlgEnv () +addClauseA code = modDef $ Just . (code :) -addProc n a c = do - sym <- findStruct n a - addProcedure sym c +addProcedure :: [Code] -> IR.Id -> PrlgEnv () +addProcedure heads = modDef $ Just . const heads -addBi n i b = - addProc n i [[U (LocalRef $ r - 1) | r <- [1 .. i]] ++ [Invoke $ bi b]] +dropProcedure :: IR.Id -> PrlgEnv () +dropProcedure = modDef $ const Nothing +addProc :: [Code] -> String -> Int -> PrlgEnv () +addProc c n a = findStruct n a >>= addProcedure c + +addBi :: InterpFn -> String -> Int -> PrlgEnv () +addBi b n a = + addProc [[U (LocalRef $ r - 1) | r <- [1 .. a]] ++ [Invoke $ bi b]] n a + +{- actual prlgude -} addPrelude :: PrlgEnv () addPrelude = do pure undefined {- primitives -} - addBi "true" 0 (pure Nothing) - addBi "fail" 0 backtrack + addBi (pure Nothing) "true" 0 + addBi backtrack "fail" 0 addOp $ O.xfx "=" 700 - addProc "=" 2 [[U (LocalRef 0), U (LocalRef 0), NoGoal]] + addProc [[U (LocalRef 0), U (LocalRef 0), NoGoal]] "=" 2 {- clauses -} addOp $ O.xfy "," 1000 addOp $ O.xfx ":-" 1200 + addOp $ O.fx ":-" 1200 + horn1 <- findStruct ":-" 1 horn2 <- findStruct ":-" 2 - --addOp $ O.fx ":-" 1200 - addProc - "assert" - 1 - [ [ U (Struct horn2) - , U (LocalRef 0) - , U (LocalRef 1) - , Cut - , Invoke (bi assertClause) - ] - , [U (LocalRef 0), Invoke (bi assertFact)] - ] - addBi "retractall" 1 retractall - addBi "call" 1 call - addBi "struct" 3 struct + let assertCode ac = + [ [ U (Struct horn2) + , U (LocalRef 0) + , U (LocalRef 1) + , Cut + , Invoke . bi $ assertRule ac + ] + , [U (Struct horn1), U (LocalRef 0), Cut, Invoke $ bi exec] + , [U (LocalRef 0), Invoke . bi $ assertFact ac] + ] + in do addProc (assertCode addClauseA) "asserta" 1 + addProc (assertCode addClauseZ) "assertz" 1 + addProc (assertCode addClauseZ) "assert" 1 + addBi retractall "retractall" 1 + addBi call "call" 1 + addBi struct "struct" 3 {- operators -} - addBi "op" 3 op - addBi "stash_operators" 0 stashOps - addBi "pop_operators" 0 popOps + addBi op "op" 3 + addBi stashOps "stash_operators" 0 + addBi popOps "pop_operators" 0 {- query tools -} - addBi "print_locals" 0 printLocals - addBi "prompt_retry" 0 promptRetry' - addBi "query" 0 (printLocals >> promptRetry) + addBi printLocals "print_locals" 0 + addBi promptRetry' "prompt_retry" 0 + addBi (printLocals >> promptRetry) "query" 0 {- IO -} - addBi "write" 1 write - addBi "writeln" 1 writeln - addBi "nl" 0 nl + addBi write "write" 1 + addBi writeln "writeln" 1 + addBi nl "nl" 0 {- debug -} - addBi "interpreter_trace" 0 (get >>= liftIO . print >> pure Nothing) + addBi (get >>= liftIO . print >> pure Nothing) "interpreter_trace" 0 diff --git a/app/Compiler.hs b/app/Compiler.hs index 206bc40..c510535 100644 --- a/app/Compiler.hs +++ b/app/Compiler.hs @@ -85,6 +85,7 @@ heapStructPrlgInt :: Monad m => m PrlgInt -> Heap -> Int -> m PrlgInt heapStructPrlgInt heaperr heap ref = heapStruct atom struct hrec heap ref where atom (Atom s) = pure $ AtomI s + atom (Number n) = pure $ NumI n atom VoidRef = pure $ VoidI struct (Struct s) args = pure $ CallI (str s) args hrec (HeapRef r) ref