strings and a few other small nice changes

1 files changed, 71 insertions, 59 deletions

diff --git a/app/Builtins.hs b/app/Builtins.hs
index 8df703c..7996926 100644
--- a/app/Builtins.hs
+++ b/app/Builtins.hs
@@ -2,9 +2,10 @@ module Builtins where
 
 import Paths_prlg
 
-import Code (Builtin(..), Code, Datum(..), Instr(..), InterpFn)
+import Code (Builtin(..), Code, Datum(..), Id(..), Instr(..), InterpFn)
 import CodeLens
 import qualified Compiler as Co
+import Constant
 import Control.Exception (IOException, catch)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Class (lift)
@@ -16,7 +17,7 @@ import qualified Data.Map as M
 import Data.Maybe (fromJust)
 import Env (PrlgEnv(..), findAtom, findStruct, prlgError)
 import Heap (Dereferenced(..), derefHeap, heapStruct, newHeapVars, writeHeap)
-import qualified IR
+import IR (PrlgInt(..), StrTable(..))
 import Interpreter (backtrack)
 import Lens.Micro.Mtl
 import Load (processInput)
@@ -29,10 +30,11 @@ continue = pure Nothing
 
 showTerm itos heap = runIdentity . heapStruct atom struct hrec heap
   where
-    atom (Atom a) = pure $ "'" ++ itos M.! a ++ "'"
-    atom (Number n) = pure (show n)
+    atom (C (Atom a)) = pure $ "'" ++ itos M.! a ++ "'"
+    atom (C (Number n)) = pure (show n)
+    atom (C (Str str)) = pure (show str)
     atom VoidRef = pure "_"
-    struct (Struct (IR.Id h _)) args =
+    struct (Struct (Id h _)) args =
       pure $ "'" ++ itos M.! h ++ "'(" ++ intercalate "," args ++ ")"
     hrec (HeapRef hr) ref =
       pure $
@@ -45,7 +47,7 @@ printLocals :: InterpFn
 printLocals = do
   scope <- use (cur . gvar)
   heap <- use (cur . heap)
-  IR.StrTable _ _ itos <- use strtable
+  StrTable _ _ itos <- use strtable
   flip traverse (M.assocs scope) $ \(local, ref) ->
     lift . outputStrLn $ "_Local" ++ show local ++ " = " ++
     showTerm itos heap ref
@@ -76,7 +78,7 @@ write' :: InterpFn -> InterpFn
 write' c =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
-    IR.StrTable _ _ itos <- use strtable
+    StrTable _ _ itos <- use strtable
     lift . outputStr $ showTerm itos heap arg
     c --this now allows error fallthrough but we might like EitherT
 
@@ -90,7 +92,7 @@ nl = do
 writeln :: InterpFn
 writeln = write' nl
 
-assertFact :: (Code -> IR.Id -> PrlgEnv ()) -> InterpFn
+assertFact :: (Code -> Id -> PrlgEnv ()) -> InterpFn
 assertFact addClause =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
@@ -101,7 +103,7 @@ assertFact addClause =
         continue
       _ -> prlgError "assert fact failure"
 
-assertRule :: (Code -> IR.Id -> PrlgEnv ()) -> InterpFn
+assertRule :: (Code -> Id -> PrlgEnv ()) -> InterpFn
 assertRule addClause =
   withArgs [0, 1] $ \args -> do
     scope <- use (cur . hvar)
@@ -123,8 +125,8 @@ retractall =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
     case derefHeap heap arg of
-      BoundRef _ (Atom a) ->
-        dropProcedure (IR.Id {IR.arity = 0, IR.str = a}) >> continue
+      BoundRef _ (C (Atom a)) ->
+        dropProcedure (Id {arity = 0, str = a}) >> continue
       BoundRef _ (Struct id) -> dropProcedure id >> continue
       _ -> prlgError "retractall needs a struct"
 
@@ -153,7 +155,7 @@ exec = exec' (const [Done])
 stop :: InterpFn
 stop =
   withArgs [0] $ \[arg] -> do
-    IR.StrTable _ _ itos <- use strtable
+    StrTable _ _ itos <- use strtable
     heap <- use (cur . heap)
     prlgError $ "stop: " ++ showTerm itos heap arg
 
@@ -163,17 +165,17 @@ struct = do
   heap <- use (cur . heap)
   scope <- use (cur . hvar)
   case derefHeap heap <$> scope M.!? 0 of
-    Just (BoundRef addr (Struct IR.Id {IR.arity = arity, IR.str = str})) ->
+    Just (BoundRef addr (Struct Id {arity = arity, str = str})) ->
       structUnify arity str
     _ -> structAssemble
 
 heapListLength listAtom heap ref = go 0 ref ref (id, fromJust . step)
   where
     nil r
-      | BoundRef _ str <- derefHeap heap r = str == Atom listAtom
+      | BoundRef _ str <- derefHeap heap r = str == C (Atom listAtom)
       | otherwise = False
     step r
-      | BoundRef addr (Struct IR.Id {IR.arity = 2, IR.str = listAtom'}) <-
+      | BoundRef addr (Struct Id {arity = 2, str = listAtom'}) <-
          derefHeap heap r
       , listAtom == listAtom' = Just (addr + 2)
       | otherwise = Nothing
@@ -190,7 +192,7 @@ structAssemble = do
   heap <- use (cur . heap)
   scope <- use (cur . hvar)
   case derefHeap heap <$> scope M.!? 1 of
-    Just (BoundRef addr (Atom str)) -> do
+    Just (BoundRef addr (C (Atom str))) -> do
       listAtom <- findAtom "[]"
       case scope M.!? 2 >>= heapListLength listAtom heap of
         Just arity -> structUnify arity str
@@ -203,14 +205,13 @@ structUnify arity str = do
   listAtom <- findAtom "[]"
   pvars <- newHeapVars arity
   let hcode = map U $ maybe VoidRef HeapRef . (scope M.!?) <$> [0 .. 2]
-      structData =
-        Struct IR.Id {IR.arity = arity, IR.str = str} : map HeapRef pvars
+      structData = Struct Id {arity = arity, str = str} : map HeapRef pvars
       paramsData =
         concatMap
-          (\pv -> [Struct IR.Id {IR.arity = 2, IR.str = listAtom}, HeapRef pv])
+          (\pv -> [Struct Id {arity = 2, str = listAtom}, HeapRef pv])
           pvars ++
-        [Atom listAtom]
-      gcode = map U $ structData ++ [Atom str] ++ paramsData
+        [C $ Atom listAtom]
+      gcode = map U $ structData ++ [C $ Atom str] ++ paramsData
   zoom cur $ do
     gol %= (gcode ++)
     hed %= (hcode ++)
@@ -231,7 +232,16 @@ number = do
   heap <- use (cur . heap)
   scope <- use (cur . hvar)
   case derefHeap heap <$> scope M.!? 0 of
-    Just (BoundRef _ (Number _)) -> continue
+    Just (BoundRef _ (C (Number _))) -> continue
+    _ -> backtrack
+
+string :: InterpFn
+string = do
+  heap <- use (cur . heap)
+  scope <- use (cur . hvar)
+  --TODO unify with number/var/...
+  case derefHeap heap <$> scope M.!? 0 of
+    Just (BoundRef _ (C (Str _))) -> continue
     _ -> backtrack
 
 sameTerm :: InterpFn
@@ -260,9 +270,9 @@ op :: InterpFn
 op =
   withArgs [0, 1, 2] $ \args -> do
     heap <- use (cur . heap)
-    IR.StrTable _ _ itos <- use strtable
+    StrTable _ _ itos <- use strtable
     case map (derefHeap heap) args of
-      [BoundRef _ (Number prio), BoundRef _ (Atom fixityAtom), BoundRef _ (Atom opatom)]
+      [BoundRef _ (C (Number prio)), BoundRef _ (C (Atom fixityAtom)), BoundRef _ (C (Atom opatom))]
         | Just op <-
            (,) <$> itos M.!? opatom <*>
            (O.Op prio <$> ((itos M.!? fixityAtom) >>= O.fixity)) -> do
@@ -274,9 +284,9 @@ deop :: InterpFn
 deop =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
-    IR.StrTable _ _ itos <- use strtable
+    StrTable _ _ itos <- use strtable
     case derefHeap heap arg of
-      BoundRef _ (Atom opatom)
+      BoundRef _ (C (Atom opatom))
         | Just op <- itos M.!? opatom -> do
           ops %= filter ((/= op) . fst)
           continue
@@ -326,7 +336,8 @@ intBinary op =
   withArgs [0, 1] $ \[arg1, arg2] -> do
     heap <- use (cur . heap)
     case derefHeap heap <$> [arg1, arg2] of
-      [BoundRef _ (Number n1), BoundRef _ (Number n2)] -> putInt (op n1 n2) 2
+      [BoundRef _ (C (Number n1)), BoundRef _ (C (Number n2))] ->
+        putInt (op n1 n2) 2
       _ -> prlgError "int binary needs numbers"
 
 intBinPred :: (Int -> Int -> Bool) -> InterpFn
@@ -334,7 +345,7 @@ intBinPred op =
   withArgs [0, 1] $ \args -> do
     heap <- use (cur . heap)
     case derefHeap heap <$> args of
-      [BoundRef _ (Number n1), BoundRef _ (Number n2)] ->
+      [BoundRef _ (C (Number n1)), BoundRef _ (C (Number n2))] ->
         if op n1 n2
           then continue
           else backtrack
@@ -345,7 +356,7 @@ intUnary op =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
     case derefHeap heap arg of
-      BoundRef _ (Number n) -> putInt (op n) 1
+      BoundRef _ (C (Number n)) -> putInt (op n) 1
       _ -> prlgError "int unary needs number"
 
 intUnPred :: (Int -> Bool) -> InterpFn
@@ -353,7 +364,7 @@ intUnPred op =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
     case derefHeap heap arg of
-      BoundRef _ (Number n) ->
+      BoundRef _ (C (Number n)) ->
         if op n
           then continue
           else backtrack
@@ -366,28 +377,28 @@ putInt val sc = do
     Nothing -> continue
     Just a ->
       case derefHeap heap a of
-        BoundRef _ (Number val')
+        BoundRef _ (C (Number val'))
           | val == val' -> continue
-        FreeRef a' -> writeHeap a' (Number val) >> continue
+        FreeRef a' -> writeHeap a' (C (Number val)) >> continue
         _ -> backtrack
 
 {- adding the builtins -}
 addOp :: (String, O.Op) -> PrlgEnv ()
 addOp op = ops %= (op :)
 
-modDef :: ([Code] -> Maybe [Code]) -> IR.Id -> PrlgEnv ()
+modDef :: ([Code] -> Maybe [Code]) -> Id -> PrlgEnv ()
 modDef fn struct = defs %= M.alter (maybe (fn []) fn) struct
 
-addClauseA :: Code -> IR.Id -> PrlgEnv ()
+addClauseA :: Code -> Id -> PrlgEnv ()
 addClauseA code = modDef $ Just . (code :)
 
-addClauseZ :: Code -> IR.Id -> PrlgEnv ()
+addClauseZ :: Code -> Id -> PrlgEnv ()
 addClauseZ code = modDef $ Just . (++ [code])
 
-addProcedure :: [Code] -> IR.Id -> PrlgEnv ()
+addProcedure :: [Code] -> Id -> PrlgEnv ()
 addProcedure heads = modDef $ Just . const heads
 
-dropProcedure :: IR.Id -> PrlgEnv ()
+dropProcedure :: Id -> PrlgEnv ()
 dropProcedure = modDef $ const Nothing
 
 addProc :: [Code] -> String -> Int -> PrlgEnv ()
@@ -413,9 +424,9 @@ load :: Bool -> InterpFn
 load queryMode =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
-    IR.StrTable _ _ itos <- use strtable --TODO the argument here should preferably be a string, right?
+    StrTable _ _ itos <- use strtable --TODO the argument here should preferably be a string, right?
     case derefHeap heap arg of
-      BoundRef _ (Atom a) -> do
+      BoundRef _ (C (Atom a)) -> do
         let fn = itos M.! a
         doLoad queryMode (itos M.! a)
       _ -> prlgError "load needs an atom"
@@ -425,7 +436,7 @@ addPrelude :: PrlgEnv ()
 addPrelude = do
   pure undefined
   {- absolute primitives -}
-  addBi (pure Nothing) "true" 0
+  addProc [[Done]] "true" 0
   addBi backtrack "fail" 0
   addBi stop "stop" 1
   addOp $ O.xfx "=" 700
@@ -456,6 +467,7 @@ addPrelude = do
   addBi struct "struct" 3
   addBi var "var" 1
   addBi number "number" 1
+  addBi string "string" 1
   addBi sameTerm "same_term" 2
   addBi currentPredicate "current_predicate" 1
   {- code loading -}
@@ -489,30 +501,30 @@ addPrelude = do
           ]
           ("expand_" ++ q)
           2
-  expandCode "load"
-  expandCode "query"
+   in do expandCode "load"
+         expandCode "query"
   {- int primops -}
   let add2IntOp nm op = addBi (intBinary op) ("int2_" ++ nm) 3
       add1IntOp nm op = addBi (intUnary op) ("int1_" ++ nm) 2
       add2IntPred nm op = addBi (intBinPred op) ("int2p_" ++ nm) 2
       add1IntPred nm op = addBi (intUnPred op) ("int1p_" ++ nm) 1
-  add2IntOp "add" (+)
-  add2IntOp "sub" (-)
-  add1IntOp "neg" negate
-  add1IntOp "abs" abs
-  add2IntOp "mul" (*)
-  add2IntOp "div" div
-  add2IntOp "mod" mod
-  add2IntOp "bitand" (.&.)
-  add2IntOp "bitor" (.|.)
-  add2IntOp "bitxor" xor
-  add2IntOp "shl" shiftL
-  add2IntOp "shr" shiftR
-  add1IntPred "zero" (== 0)
-  add2IntPred "eq" (==)
-  add2IntPred "lt" (<)
-  add2IntPred "leq" (<=)
-  add2IntPred "neq" (/=)
+   in do add2IntOp "add" (+)
+         add2IntOp "sub" (-)
+         add1IntOp "neg" negate
+         add1IntOp "abs" abs
+         add2IntOp "mul" (*)
+         add2IntOp "div" div
+         add2IntOp "mod" mod
+         add2IntOp "bitand" (.&.)
+         add2IntOp "bitor" (.|.)
+         add2IntOp "bitxor" xor
+         add2IntOp "shl" shiftL
+         add2IntOp "shr" shiftR
+         add1IntPred "zero" (== 0)
+         add2IntPred "eq" (==)
+         add2IntPred "lt" (<)
+         add2IntPred "leq" (<=)
+         add2IntPred "neq" (/=)
   {- query tools -}
   addBi printLocals "print_locals" 0
   addBi promptRetry' "prompt_retry" 0