assert v0

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)

app/Code.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE TupleSections #-}
+
 module Code where
 
 import Control.Monad.Trans.State.Lazy
@@ -32,7 +34,7 @@ data Heap =
   Heap Int (M.Map Int Datum)
   deriving (Show)
 
-emptyHeap = Heap 0 M.empty
+emptyHeap = Heap 1 M.empty
 
 type Scope = M.Map Int (Int, Int)
 
@@ -70,3 +72,50 @@ data Builtin =
 
 instance Show Builtin where
   show _ = "Builtin _"
+
+codeStruct ::
+     Monad m
+  => (Datum -> m a)
+  -> (Datum -> [a] -> m a)
+  -> (Datum -> m (Either Int a))
+  -> (Datum -> Int -> m a)
+  -> m a
+  -> Heap
+  -> Code
+  -> m (Code, a)
+codeStruct atom struct local rec end heap = go
+  where
+    go [] = ([], ) <$> end
+    go (U lr@(LocalRef _ _):cs) = do
+      x <- local lr
+      case x of
+        Left ref -> (cs, ) <$> heapStruct atom struct rec heap ref
+        Right a -> pure (cs, a)
+    go (U s@(Struct (IR.Id _ arity)):cs) = eat arity cs >>= traverse (struct s)
+    go (U x:cs) = (cs, ) <$> atom x
+    go cs = (cs, ) <$> end
+    eat n cs
+      | n <= 0 = pure (cs, [])
+      | otherwise = do
+        (rest, a) <- go cs
+        fmap (a :) <$> eat (n - 1) rest
+
+heapStruct ::
+     Monad m
+  => (Datum -> m a)
+  -> (Datum -> [a] -> m a)
+  -> (Datum -> Int -> m a)
+  -> Heap
+  -> Int
+  -> m a
+heapStruct atom struct rec (Heap _ heap) hr = go [hr] hr
+  where
+    go visited ref
+      | rr@(HeapRef r) <- heap M.! ref =
+        if r == ref || r `elem` visited
+          then rec rr ref
+          else go (r : visited) r
+      | s@(Struct (IR.Id _ arity)) <- heap M.! ref =
+        sequence [go (ref + i : visited) (ref + i) | i <- [1 .. arity]] >>=
+        struct s
+      | x <- heap M.! ref = atom x

app/Frontend.hs

@@ -68,12 +68,12 @@ interpret = (>> return True) . lex
 
 interpreterStart :: PrlgEnv ()
 interpreterStart = do
-  addBuiltins
+  addPrelude
   interpreterLoop
 
 interpreterLoop :: PrlgEnv ()
 interpreterLoop = do
-  minput <- lift $ getInputLine "prlg> "
+  minput <- lift $ getInputLine "prlg? " --TODO switch with plain .
   case minput of
     Nothing -> return ()
     Just input -> do

app/IR.hs

@@ -25,7 +25,7 @@ data StrTable =
   StrTable Int (M.Map String Int) (M.Map Int String)
   deriving (Show)
 
-emptystrtable = StrTable 0 M.empty M.empty
+emptystrtable = StrTable 1 M.empty M.empty
 
 strtablize t@(StrTable nxt fwd rev) str =
   case fwd M.!? str of