assert v0

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)