very assertive

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 :: (Code -> IR.Id -> PrlgEnv ()) -> InterpFn
-assertFact =
+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]
+        addClause (head ++ [NoGoal]) s
-        return Nothing
+        continue
       _ -> prlgError "assert fact failure"
 
-assertClause :: InterpFn
+assertRule :: (Code -> IR.Id -> PrlgEnv ()) -> InterpFn
-assertClause =
+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
+         in do addClause cs s
-               return Nothing
+               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 _ (Atom a) ->
-      BoundRef _ (Struct id) -> dropProcedure id
+        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 =
+modDef :: ([Code] -> Maybe [Code]) -> IR.Id -> PrlgEnv ()
-  modify $ \s ->
+modDef fn struct =
-    s {defs = M.alter (Just . maybe [code] (\hs -> code : hs)) struct $ defs s}
+  modify $ \s -> s {defs = M.alter (maybe (fn []) fn) struct $ defs s}
 
-addProcedure struct heads =
+addClauseZ :: Code -> IR.Id -> PrlgEnv ()
-  modify $ \s -> s {defs = M.insert struct heads $ defs s}
+addClauseZ code = modDef $ Just . ([code] ++)
 
-dropProcedure struct = do
+addClauseA :: Code -> IR.Id -> PrlgEnv ()
-  d <- gets defs
+addClauseA code = modDef $ Just . (code :)
-  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
+addProcedure :: [Code] -> IR.Id -> PrlgEnv ()
-  sym <- findStruct n a
+addProcedure heads = modDef $ Just . const heads
-  addProcedure sym c
 
-addBi n i b =
+dropProcedure :: IR.Id -> PrlgEnv ()
-  addProc n i [[U (LocalRef $ r - 1) | r <- [1 .. i]] ++ [Invoke $ bi b]]
+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 (pure Nothing) "true" 0
-  addBi "fail" 0 backtrack
+  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
+  let assertCode ac =
-  addProc
+        [ [ U (Struct horn2)
-    "assert"
+          , U (LocalRef 0)
-    1
+          , U (LocalRef 1)
-    [ [ U (Struct horn2)
+          , Cut
-      , U (LocalRef 0)
+          , Invoke . bi $ assertRule ac
-      , U (LocalRef 1)
+          ]
-      , Cut
+        , [U (Struct horn1), U (LocalRef 0), Cut, Invoke $ bi exec]
-      , Invoke (bi assertClause)
+        , [U (LocalRef 0), Invoke . bi $ assertFact ac]
-      ]
+        ]
-    , [U (LocalRef 0), Invoke (bi assertFact)]
+   in do addProc (assertCode addClauseA) "asserta" 1
-    ]
+         addProc (assertCode addClauseZ) "assertz" 1
-  addBi "retractall" 1 retractall
+         addProc (assertCode addClauseZ) "assert" 1
-  addBi "call" 1 call
+  addBi retractall "retractall" 1
-  addBi "struct" 3 struct
+  addBi call "call" 1
+  addBi struct "struct" 3
   {- operators -}
-  addBi "op" 3 op
+  addBi op "op" 3
-  addBi "stash_operators" 0 stashOps
+  addBi stashOps "stash_operators" 0
-  addBi "pop_operators" 0 popOps
+  addBi popOps "pop_operators" 0
   {- query tools -}
-  addBi "print_locals" 0 printLocals
+  addBi printLocals "print_locals" 0
-  addBi "prompt_retry" 0 promptRetry'
+  addBi promptRetry' "prompt_retry" 0
-  addBi "query" 0 (printLocals >> promptRetry)
+  addBi (printLocals >> promptRetry) "query" 0
   {- IO -}
-  addBi "write" 1 write
+  addBi write "write" 1
-  addBi "writeln" 1 writeln
+  addBi writeln "writeln" 1
-  addBi "nl" 0 nl
+  addBi nl "nl" 0
   {- debug -}
-  addBi "interpreter_trace" 0 (get >>= liftIO . print >> pure Nothing)
+  addBi (get >>= liftIO . print >> pure Nothing) "interpreter_trace" 0

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