1 files changed, 57 insertions, 1 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}