slight cleanup, metacall

5 files changed, 77 insertions, 40 deletions

diff --git a/app/Builtins.hs b/app/Builtins.hs
index 555623c..0cdd7cd 100644
--- a/app/Builtins.hs
+++ b/app/Builtins.hs
@@ -2,11 +2,15 @@ module Builtins where
 
 import Code
   ( Builtin(..)
-  , BuiltinFn
   , Cho(..)
   , Datum(..)
+  , Dereferenced(..)
+  , Heap(..)
   , Instr(..)
   , Interp(..)
+  , InterpFn
+  , InterpFn
+  , derefHeap
   , heapStruct
   )
 import qualified Compiler as Co
@@ -16,7 +20,7 @@ import Control.Monad.Trans.State.Lazy (get, gets, modify)
 import Data.Functor.Identity (runIdentity)
 import Data.List (intercalate)
 import qualified Data.Map as M
-import Env (PrlgEnv(..), findAtom, findStruct)
+import Env (PrlgEnv(..), findAtom, findStruct, prlgError)
 import qualified IR
 import Interpreter (backtrack)
 import qualified Operators as O
@@ -37,7 +41,7 @@ showTerm itos heap = runIdentity . heapStruct atom struct hrec heap
          else "_Rec") ++
       show hr
 
-printLocals :: BuiltinFn
+printLocals :: InterpFn
 printLocals = do
   scope <- gets (gvar . cur)
   heap <- gets (heap . cur)
@@ -47,37 +51,39 @@ printLocals = do
     (maybe "_" id $ itos M.!? name) ++ " = " ++ showTerm itos heap ref
   return Nothing
 
-promptRetry :: BuiltinFn
+promptRetry :: InterpFn
 promptRetry = do
   last <- gets (null . cho)
   if last
     then return Nothing
     else promptRetry'
 
-promptRetry' :: BuiltinFn
+promptRetry' :: InterpFn
 promptRetry' = do
   x <- lift $ getInputChar "? "
   case x of
     Just ';' -> backtrack
     _ -> return Nothing
 
-write :: BuiltinFn
-write = do
+write :: InterpFn
+write
+  --TODO: prlgError on write(Unbound)
+ = 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
 
-nl :: BuiltinFn
+nl :: InterpFn
 nl = do
   lift $ outputStrLn ""
   return Nothing
 
-writeln :: BuiltinFn
+writeln :: InterpFn
 writeln = write >> nl
 
-assertFact :: BuiltinFn
+assertFact :: InterpFn
 assertFact = do
   scope <- gets (hvar . cur)
   heap <- gets (heap . cur)
@@ -86,9 +92,9 @@ assertFact = do
     Just (U (Struct s):head) -> do
       addClause s $ head ++ [NoGoal]
       return Nothing
-    _ -> backtrack --TODO actually throw
+    _ -> prlgError "assert fact failure"
 
-assertClause :: BuiltinFn
+assertClause :: InterpFn
 assertClause = do
   scope <- gets (hvar . cur)
   heap <- gets (heap . cur)
@@ -101,11 +107,33 @@ assertClause = do
             Co.compileGoal hs ++ Co.seqGoals (Co.compileGoals commaId cut gs)
        in do addClause s cs
              return Nothing
-    _ -> backtrack
-
-retractall :: BuiltinFn
-retractall = do
-  return Nothing
+    _ -> prlgError "assert clause failure"
+
+retractall :: InterpFn
+retractall = prlgError "no retractall yet"
+
+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"
 
 {- adding the builtins -}
 addOp op = modify $ \s -> s {ops = op : ops s}
@@ -148,6 +176,7 @@ addPrelude = do
     , [U (LocalRef 0 0), Invoke (bi assertFact)]
     ]
   addProc "retractall" 1 [[U (LocalRef 0 0), Invoke (bi retractall)]]
+  addProc "call" 1 [[U (LocalRef 0 0), Invoke (bi call)]]
   {- query tools -}
   addBi0 "print_locals" printLocals
   addBi0 "prompt_retry" promptRetry'
diff --git a/app/Code.hs b/app/Code.hs
index 8bea782..0556415 100644
--- a/app/Code.hs
+++ b/app/Code.hs
@@ -65,14 +65,30 @@ data Interp =
 
 type PrlgEnv a = StateT Interp (InputT IO) a
 
-type BuiltinFn = PrlgEnv (Maybe (Either String Bool))
+type InterpFn = PrlgEnv (Maybe (Either String Bool))
 
 data Builtin =
-  Builtin BuiltinFn
+  Builtin InterpFn
 
 instance Show Builtin where
   show _ = "Builtin _"
 
+data Dereferenced
+  = FreeRef Int
+  | BoundRef Int Datum
+  | NoRef
+
+-- TRICKY: HeapRefs alone must not form a cycle other than the FreeRef case.
+derefHeap :: Heap -> Int -> Dereferenced
+derefHeap h@(Heap _ hmap) x =
+  case hmap M.!? x of
+    Just (HeapRef x') ->
+      if x == x'
+        then FreeRef x'
+        else derefHeap h x'
+    Just x' -> BoundRef x x'
+    _ -> NoRef
+
 -- TODO are we actually going to use this?
 codeStruct ::
      Monad m
diff --git a/app/Env.hs b/app/Env.hs
index e873711..82bf9d0 100644
--- a/app/Env.hs
+++ b/app/Env.hs
@@ -1,6 +1,6 @@
 module Env where
 
-import Code (Interp(..), PrlgEnv)
+import Code (Interp(..), InterpFn, PrlgEnv)
 import Control.Monad.Trans.State.Lazy (gets, modify)
 import qualified IR
 
@@ -20,3 +20,6 @@ findAtom :: String -> Env.PrlgEnv Int
 findAtom = withStrTable . flip IR.strtablize
 
 type PrlgEnv a = Code.PrlgEnv a
+
+prlgError :: String -> InterpFn
+prlgError = pure . pure . Left
diff --git a/app/IR.hs b/app/IR.hs
index 8507a3e..631cd16 100644
--- a/app/IR.hs
+++ b/app/IR.hs
@@ -16,7 +16,7 @@ data Id =
   deriving (Show, Eq, Ord)
 
 data PrlgInt
-  = CallI Id [PrlgInt]
+  = CallI Id [PrlgInt] --TODO this should be Int
   | LiteralI Int
   | VarI Int Int -- VarI localIndex strTableString
   | VoidI
diff --git a/app/Interpreter.hs b/app/Interpreter.hs
index 21340ef..7192c7b 100644
--- a/app/Interpreter.hs
+++ b/app/Interpreter.hs
@@ -6,9 +6,12 @@ import Code
   , Cho(..)
   , Code
   , Datum(..)
+  , Dereferenced(..)
   , Heap(..)
   , Instr(..)
   , Interp(..)
+  , InterpFn
+  , derefHeap
   , emptyHeap
   , emptyScope
   )
@@ -43,13 +46,8 @@ prove g = do
         Nothing -> loop -- not finished yet
         Just x -> return x
 
-data Dereferenced
-  = FreeRef Int
-  | BoundRef Int Datum
-  | NoRef
-
 {- Simple "fail" backtracking -}
-backtrack :: PrlgEnv (Maybe (Either String Bool))
+backtrack :: InterpFn
 backtrack = do
   chos <- St.gets cho
   case chos
@@ -61,7 +59,7 @@ backtrack = do
     {- if there's no other choice, answer no -}
     _ -> pure . Just $ Right False
 
-proveStep :: PrlgEnv (Maybe (Either String Bool))
+proveStep :: InterpFn
 proveStep = St.get >>= go
   where
     finish = pure . Just
@@ -76,23 +74,14 @@ proveStep = St.get >>= go
         Just d -> cont d
         _ -> ifail $ "no definition: " ++ show fn
     {- Unification -}
-    go i@Interp {cur = cur@Cho { hed = U h:hs
-                               , gol = U g:gs
-                               , heap = heap@(Heap _ hmap)
-                               }} = unify h g
+    go i@Interp {cur = cur@Cho {hed = U h:hs, gol = U g:gs, heap = heap}} =
+      unify h g
       where
         uok = c i {cur = cur {hed = hs, gol = gs}}
         setHeap r x =
           c i {cur = cur {hed = hs, gol = gs, heap = writeHeap r x heap}}
         {- heap tools -}
-        deref x =
-          case hmap M.!? x of
-            Just (HeapRef x') ->
-              if x == x'
-                then FreeRef x'
-                else deref x'
-            Just x' -> BoundRef x x'
-            _ -> NoRef
+        deref = derefHeap heap
         writeHeap addr x (Heap nxt m) = Heap nxt (M.adjust (const x) addr m)
         newHeapVar h = head <$> newHeapVars 1 h
         newHeapVars n (Heap nxt m) =