struct structs

3 files changed, 87 insertions, 20 deletions

diff --git a/app/Builtins.hs b/app/Builtins.hs
index 2b7f08e..e547bd0 100644
--- a/app/Builtins.hs
+++ b/app/Builtins.hs
@@ -12,6 +12,7 @@ import Code
   , InterpFn
   , derefHeap
   , heapStruct
+  , newHeapVars
   )
 import qualified Compiler as Co
 import Control.Monad.IO.Class (liftIO)
@@ -20,6 +21,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 Data.Maybe (fromJust)
 import Env (PrlgEnv(..), findAtom, findStruct, prlgError)
 import qualified IR
 import Interpreter (backtrack)
@@ -149,10 +151,64 @@ call =
         exec addr (Struct IR.Id {IR.arity = 0, IR.str = a}) 0
       _ -> prlgError "not callable"
 
+{- struct building -}
 struct :: InterpFn
 struct = do
+  heap <- gets (heap . cur)
   scope <- gets (hvar . cur)
-  prlgError "not yet"
+  case derefHeap heap <$> scope M.!? 0 of
+    Just (BoundRef addr (Struct IR.Id {IR.arity = arity, IR.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
+      | otherwise = False
+    step r
+      | BoundRef addr (Struct IR.Id {IR.arity = 2, IR.str = listAtom'}) <-
+         derefHeap heap r
+      , listAtom == listAtom' = Just (addr + 2)
+      | otherwise = Nothing
+    go n fast slow (f1, f2)
+      | nil fast = Just n
+      | Just fast' <- step fast =
+        if slow == fast'
+          then Nothing
+          else go (n + 1) fast' (f1 slow) (f2, f1)
+      | otherwise = Nothing
+
+structAssemble :: InterpFn
+structAssemble = do
+  heap <- gets (heap . cur)
+  scope <- gets (hvar . cur)
+  case derefHeap heap <$> scope M.!? 1 of
+    Just (BoundRef addr (Atom str)) -> do
+      listAtom <- findAtom "[]"
+      case scope M.!? 2 >>= heapListLength listAtom heap of
+        Just arity -> structUnify arity str
+        _ -> prlgError "struct arity unknown"
+    _ -> prlgError "struct id unknown"
+
+structUnify arity str = do
+  cur <- gets cur
+  let h = heap cur
+      scope = hvar cur
+  listAtom <- findAtom "[]"
+  let hcode = map U $ maybe VoidRef HeapRef . (scope M.!?) <$> [0 .. 2]
+      (h', pvars) = newHeapVars arity h
+      structData =
+        Struct IR.Id {IR.arity = arity, IR.str = str} : map HeapRef pvars
+      paramsData =
+        concatMap
+          (\pv -> [Struct IR.Id {IR.arity = 2, IR.str = listAtom}, HeapRef pv])
+          pvars ++
+        [Atom listAtom]
+      gcode = map U $ structData ++ [Atom str] ++ paramsData
+  modify $ \s ->
+    s {cur = cur {heap = h', gol = gcode ++ gol cur, hed = hcode ++ hed cur}}
+  return Nothing
 
 {- adding the builtins -}
 addOp op = modify $ \s -> s {ops = op : ops s}
diff --git a/app/Code.hs b/app/Code.hs
index eecd5b6..eb5149c 100644
--- a/app/Code.hs
+++ b/app/Code.hs
@@ -77,6 +77,7 @@ data Dereferenced
   = FreeRef Int
   | BoundRef Int Datum
   | NoRef
+  deriving (Show)
 
 -- TRICKY: HeapRefs alone must not form a cycle other than the FreeRef case.
 derefHeap :: Heap -> Int -> Dereferenced
@@ -89,6 +90,25 @@ derefHeap h@(Heap _ hmap) x =
     Just x' -> BoundRef x x'
     _ -> NoRef
 
+writeHeap :: Int -> Datum -> Heap -> Heap
+writeHeap addr x (Heap nxt m) = Heap nxt (M.adjust (const x) addr m)
+
+newHeapVar :: Heap -> (Heap, Int)
+newHeapVar heap = head <$> newHeapVars 1 heap
+
+newHeapVars :: Int -> Heap -> (Heap, [Int])
+newHeapVars n (Heap nxt m) =
+  let addrs = [nxt + i - 1 | i <- [1 .. n]]
+   in ( Heap (nxt + n) $
+        foldr (uncurry M.insert) m [(a, HeapRef a) | a <- addrs]
+      , addrs)
+
+withNewHeapStruct :: Int -> Datum -> Heap -> ([Datum] -> Heap -> a) -> a
+withNewHeapStruct addr s@(Struct Id {arity = arity}) heap cont =
+  let (Heap nxt' m', addrs) = newHeapVars (arity + 1) heap
+      m'' = M.insert addr (HeapRef $ head addrs) . M.insert (head addrs) s $ m'
+   in cont (map HeapRef $ tail addrs) (Heap nxt' m'')
+
 -- TODO are we actually going to use this?
 codeStruct ::
      Monad m
diff --git a/app/Interpreter.hs b/app/Interpreter.hs
index 15ab1e5..d82793b 100644
--- a/app/Interpreter.hs
+++ b/app/Interpreter.hs
@@ -7,13 +7,15 @@ import Code
   , Code
   , Datum(..)
   , Dereferenced(..)
-  , Heap(..)
   , Instr(..)
   , Interp(..)
   , InterpFn
   , derefHeap
   , emptyHeap
   , emptyScope
+  , newHeapVar
+  , withNewHeapStruct
+  , writeHeap
   )
 import qualified Control.Monad.Trans.State.Lazy as St
 import Env (PrlgEnv)
@@ -82,23 +84,10 @@ proveStep = St.get >>= go
           c i {cur = cur {hed = hs, gol = gs, heap = writeHeap r x heap}}
         {- heap tools -}
         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) =
-          let addrs = [nxt + i - 1 | i <- [1 .. n]]
-           in ( Heap (nxt + n) $
-                foldr (uncurry M.insert) m [(a, HeapRef a) | a <- addrs]
-              , addrs)
-        allocLocal (LocalRef reg) scope cont
+        withNewLocal (LocalRef reg) scope cont
           | Just addr <- scope M.!? reg = cont scope heap addr
           | (heap', addr) <- newHeapVar heap =
             cont (M.insert reg addr scope) heap' addr
-        newHeapStruct addr s@(Struct Id {arity = arity}) cont =
-          let (Heap nxt' m', addrs) = newHeapVars (arity + 1) heap
-              m'' =
-                M.insert addr (HeapRef $ head addrs) . M.insert (head addrs) s $
-                m'
-           in cont (map HeapRef $ tail addrs) (Heap nxt' m'')
         {- simple cases first -}
         unify VoidRef VoidRef = uok
         unify (Atom a) (Atom b)
@@ -117,7 +106,7 @@ proveStep = St.get >>= go
         unify VoidRef (LocalRef _) = uok
         {- allocate heap for LocalRefs and retry with HeapRefs -}
         unify lr@(LocalRef _) _ =
-          allocLocal lr (hvar cur) $ \hvar' heap' addr ->
+          withNewLocal lr (hvar cur) $ \hvar' heap' addr ->
             c
               i
                 { cur =
@@ -125,7 +114,7 @@ proveStep = St.get >>= go
                       {hed = U (HeapRef addr) : hs, hvar = hvar', heap = heap'}
                 }
         unify _ lr@(LocalRef _) =
-          allocLocal lr (gvar cur) $ \gvar' heap' addr ->
+          withNewLocal lr (gvar cur) $ \gvar' heap' addr ->
             c
               i
                 { cur =
@@ -142,9 +131,10 @@ proveStep = St.get >>= go
               case g of
                 atom@(Atom _) -> setHeap hr atom
                 s@(Struct _) ->
-                  newHeapStruct
+                  withNewHeapStruct
                     hr
                     s
+                    heap
                     (\nhs nheap ->
                        c
                          i
@@ -176,9 +166,10 @@ proveStep = St.get >>= go
               case h of
                 atom@(Atom _) -> setHeap gr atom
                 s@(Struct _) ->
-                  newHeapStruct
+                  withNewHeapStruct
                     gr
                     s
+                    heap
                     (\ngs nheap ->
                        c
                          i