From f578b16d06d715f9e131442fa8a0f74e24ddfa54 Mon Sep 17 00:00:00 2001
From: crumbtoo <crumb@disroot.org>
Date: Tue, 14 Nov 2023 14:52:21 -0700
Subject: [PATCH] constructed data things

---
 docs/src/commentary/stg.rst | 121 ++++++++++++++++++++++++++++++++++--
 src/Core.hs                 |   2 +
 src/TIM.hs                  |  27 ++++++--
 3 files changed, 142 insertions(+), 8 deletions(-)

diff --git a/docs/src/commentary/stg.rst b/docs/src/commentary/stg.rst
index 8fdac9b..bf22ac2 100644
--- a/docs/src/commentary/stg.rst
+++ b/docs/src/commentary/stg.rst
@@ -1,7 +1,7 @@
 The *Spineless Tagless G-Machine*
 =================================
 
-WIP. This will hopefully be expanded into a thorough explanation of the state
+WIP. This will hopefully be expanded into a thorough walkthrough of the state
 machine.
 
 Evaluation is complete when a single \texttt{NNum} remains on the stack and the
@@ -65,8 +65,8 @@ Perform a unary operation :math:`o(n)` with internal :code:`Prim` constructor
         & g
         }
 
-Perform a unary operation :math:`o(n)` with internal :code:`Prim` constructor
-:code:`O` on an unevaluated argument.
+Evaluate the argument of a unary operation with internal :code:`Prim`
+constructor :code:`O`.
 
 .. math::
    \transrule
@@ -79,7 +79,7 @@ Perform a unary operation :math:`o(n)` with internal :code:`Prim` constructor
         \end{bmatrix}
         & g
         }
-        { b : \nillist
+        { x : \nillist
         & (f : a : \nillist) : d
         & h
         & g
@@ -124,3 +124,116 @@ Reduce a supercombinator and update the root with the :math:`\beta`-reduced form
    \text{where } h' = \mathtt{instantiateU} \; e \; a_n \; h \; g
    }
 
+Perform a binary operation :math:`o(x,y)` associated with internal :code:`Prim`
+constructor :code:`O` on two :code:`NNum` s both in normal form.
+
+.. math::
+   \transrule
+   { f : a_1 : a_2 : s
+   & d
+   & h
+   \begin{bmatrix}
+        f : \mathtt{NPrim} \; \mathtt{O} \\
+        a_1 : \mathtt{NAp} \; f \; (\mathtt{NNum} \; x) \\
+        a_2 : \mathtt{NAp} \; a_1 \; (\mathtt{NNum} \; y)
+   \end{bmatrix}
+   & g
+   }
+   { a_2 : s
+   & d
+   & h
+   \begin{bmatrix}
+        a_2 : \mathtt{NNum} \; (o(x,y))
+   \end{bmatrix}
+   & g
+   }
+
+In a conditional primitive, perform the reduction if the condition has been
+evaluated as True (:code:`ConP 2 0`).
+
+.. math::
+   \transrule
+   { f : a_1 : a_2 : a_3 : s
+   & d
+   & h
+   \begin{bmatrix}
+        f : \mathtt{NPrim} \; \mathtt{IfP} \\
+        c : \mathtt{NPrim} \; (\mathtt{ConP} \; 2 \; 0) \\
+        a_1 : \mathtt{NAp} \; f \; c \\
+        a_2 : \mathtt{NAp} \; a_1 \; x \\
+        a_3 : \mathtt{NAp} \; a_2 \; y
+   \end{bmatrix}
+   & g
+   }
+   { x : s
+   & d
+   & h
+   & g
+   }
+
+In a conditional primitive, perform the reduction if the condition has been
+evaluated as False (:code:`ConP 1 0`).
+
+.. math::
+   \transrule
+   { f : a_1 : a_2 : a_3 : s
+   & d
+   & h
+   \begin{bmatrix}
+        f : \mathtt{NPrim} \; \mathtt{IfP} \\
+        c : \mathtt{NPrim} \; (\mathtt{ConP} \; 1 \; 0) \\
+        a_1 : \mathtt{NAp} \; f \; c \\
+        a_2 : \mathtt{NAp} \; a_1 \; x \\
+        a_3 : \mathtt{NAp} \; a_2 \; y
+   \end{bmatrix}
+   & g
+   }
+   { y : s
+   & d
+   & h
+   & g
+   }
+
+
+In a conditional primitive, evaluate the condition.
+
+.. math::
+   \transrule
+   { f : a_1 : \nillist
+   & d
+   & h
+   \begin{bmatrix}
+        f : \mathtt{NPrim} \; \mathtt{IfP} \\
+        a_1 : \mathtt{NAp} \; f \; x
+   \end{bmatrix}
+   & g
+   }
+   { x : \nillist
+   & (f : a_1 : \nillist) : d
+   & h
+   & g
+   }
+
+Construct :code:`NData` out of a constructor and its arguments
+
+.. math::
+   \transrule
+   { c : a_1 : \ldots : a_n : \nillist
+   & d
+   & h
+   \begin{bmatrix}
+        c : \mathtt{NPrim} \; (\mathtt{ConP} \; t \; n) \\
+        a_1 : \mathtt{NAp} \; c \; x_1 \\
+        \vdots \\
+        a_n : \mathtt{NAp} \; a_{n-1} \; x_n
+   \end{bmatrix}
+   & g
+   }
+   { a_n : \nillist
+   & d
+   & h
+   \begin{bmatrix}
+        a_n : \mathtt{NData} \; t \; [x_1, \ldots, x_n]
+   \end{bmatrix}
+   & g
+   }
diff --git a/src/Core.hs b/src/Core.hs
index cd80d8d..8acec6c 100644
--- a/src/Core.hs
+++ b/src/Core.hs
@@ -129,5 +129,7 @@ corePrelude = Program
     , ScDef "S" ["f", "g", "x"] (Var "f" :$ Var "x" :$ (Var "g" :$ Var "x"))
     , ScDef "compose" ["f", "g", "x"] (Var "f" :$ (Var "g" :$ Var "x"))
     , ScDef "twice" ["f", "x"] (Var "f" :$ (Var "f" :$ Var "x"))
+    , ScDef "False" [] $ Con 0 0
+    , ScDef "True" [] $ Con 1 0
     ]
 
diff --git a/src/TIM.hs b/src/TIM.hs
index 4ad4fc1..801dc0d 100644
--- a/src/TIM.hs
+++ b/src/TIM.hs
@@ -9,7 +9,7 @@ import Data.Map qualified as M
 import Data.Set                 (Set)
 import Data.Set qualified as S
 import Data.Maybe               (fromJust, fromMaybe)
-import Data.List                (mapAccumL)
+import Data.List                (mapAccumL, intersperse)
 import Control.Monad            (guard)
 import Data.Foldable            (traverse_)
 import Data.Function            ((&))
@@ -30,6 +30,7 @@ data Node = NAp Addr Addr
           | NPrim Name Prim
           | NNum Int
           | NInd Addr
+          | NData Int [Addr] -- NData Tag [Component]
           deriving Show
 
 type Dump = [[Addr]]
@@ -38,7 +39,7 @@ type Stats = Int
 
 ----------------------------------------------------------------------------------
 
-data Prim = PrimConstr Int Int -- PrimConstr Tag Arity
+data Prim = ConP Int Int -- ConP Tag Arity
           | IntP Int
           | IntAddP
           | IntSubP
@@ -108,6 +109,8 @@ instantiate (Var k)      h g =
     (h, fromMaybe (error $ "variable `" <> k <> "' not in scope") v)
     where v = lookup k g
 
+instantiate (Con t a) h _ = alloc h $ NPrim "Pack" (ConP t a)
+
 instantiate (Case _ _)   _ _ = error "cannot instantiate case expressions"
 
 instantiate (Let NonRec bs e) h g = instantiate e h' (g' ++ g)
@@ -143,6 +146,10 @@ instantiateU (App f x) root h g = update h'' root (NAp f' x')
 
 instantiateU (Case _ _) _ _ _ = error "cannot instantiate case expressions"
 
+instantiateU (Con t a) root h g = update h root c
+    where
+        c = NPrim "Pack" (ConP t a)
+
 instantiateU (Var k) root h g = update h' root (NInd a)
     where (h',a) = instantiate (Var k) h g
 
@@ -245,6 +252,8 @@ step st =
         primStep _ IntMulP st = primBinOp (*) st
         primStep _ IntDivP st = primBinOp (div) st
 
+        -- primStep _ 
+
 primBinOp :: (Int -> Int -> Int) -> TiState -> TiState
 primBinOp f (TiState s d h g sts) =
     case isDataNode xarg of
@@ -289,8 +298,9 @@ isFinal (TiState [] _ _ _ _) = error "empty stack..."
 isFinal _ = False
 
 isDataNode :: Node -> Bool
-isDataNode (NNum _) = True
-isDataNode _        = False
+isDataNode (NNum _)    = True
+isDataNode (NData _ _) = True
+isDataNode _           = False
 
 doAdmin :: TiState -> TiState
 doAdmin (TiState s d h g sts) = TiState s d h g (sts+1)
@@ -410,5 +420,14 @@ instance Pretty TiState where
 
             pnode (NSupercomb n _ _) _ = IStr n
 
+            pnode (NPrim n (ConP t a)) _ = IStr $ printf "%s{%d,%d}" n t a
+
             pnode (NPrim n _) _ = IStr n
 
+            pnode (NData t cs) p = "NData{" <> IStr (show t) <> "}" <> m
+                where
+                    m = cs
+                      & fmap (\a -> pnode (hLookupUnsafe a h) (succ p))
+                      & intersperse " "
+                      & mconcat
+