real tests!

src/GM.hs

@@ -9,6 +9,10 @@ module GM
     ( hdbgProg
     , evalProg
     , Node(..)
+    , gmEvalProg
+    , finalStateOf
+    , resultOf
+    , resultOfExpr
     )
     where
 ----------------------------------------------------------------------------------
@@ -701,17 +705,12 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
                 compileBinder (_ := v, a) = compileC g' v <> [Update a]
 
         -- special cases for prim functions; essentially inlining
-        compileE g ("negate#" :$ a) = compileE g a <>                  [Neg]
-        compileE g ("+#" :$ a :$ b) = compileE g a <> compileE g b  <> [Add]
-        -- note that we only bother offsetting the environment and evaluationg
-        -- in the "correct" order with non-commutative operations. if we
-        -- implemented Sub the same way as Add, (-#) 3 2 would evaluate to -1.
-        compileE g ("-#" :$ a :$ b) = compileE g b <> compileE g' a <> [Sub]
-            where g' = argOffset 1 g
-        compileE g ("*#" :$ a :$ b) = compileE g a <> compileE g b  <> [Mul]
-        compileE g ("/#" :$ a :$ b) = compileE g a <> compileE g' b <> [Div]
-            where g' = argOffset 1 g
-        compileE g ("==#" :$ a :$ b) = compileE g a <> compileE g b <> [Equals]
+        compileE g ("negate#" :$ a)  = inlineOp1 g Neg    a
+        compileE g ("+#" :$ a :$ b)  = inlineOp2 g Add    a b
+        compileE g ("-#" :$ a :$ b)  = inlineOp2 g Sub    a b
+        compileE g ("*#" :$ a :$ b)  = inlineOp2 g Mul    a b
+        compileE g ("/#" :$ a :$ b)  = inlineOp2 g Div    a b
+        compileE g ("==#" :$ a :$ b) = inlineOp2 g Equals a b
 
         compileE g (Case e as) = compileE g e <> [CaseJump (compileD g as)]
 
@@ -728,6 +727,13 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
                 g' = binds ++ argOffset n g
                 c = compileE g' e
 
+        inlineOp1 :: Env -> Instr -> Expr' -> Code
+        inlineOp1 g i a = compileE g a <> [i]
+
+        inlineOp2 :: Env -> Instr -> Expr' -> Expr' -> Code
+        inlineOp2 g i a b = compileE g b <> compileE g' a <> [i]
+            where g' = argOffset 1 g
+
         -- | offset each address in the environment by n
         argOffset :: Int -> Env -> Env
         argOffset n = each . _2 %~ (+n)
@@ -855,7 +861,7 @@ showNodeAtP p st a = case hLookup a h of
             name = case lookup a (swap <$> g) of
                 Just (NameKey n)     -> n
                 Just (ConstrKey t n) -> idPack t n
-                _                     -> errTxtInvalidAddress
+                _                    -> errTxtInvalidAddress
     -- TODO: left-associativity
     Just (NAp f x)       -> pprec $ showNodeAtP (p+1) st f
                                 <+> showNodeAtP (p+1) st x
@@ -950,4 +956,26 @@ sweepNodes st = st & gmHeap %~ thread (f <$> addresses h)
 thread :: [a -> a] -> (a -> a)
 thread = appEndo . foldMap Endo
 
---}
+----------------------------------------------------------------------------------
+
+gmEvalProg :: Program' -> GmState
+gmEvalProg p = compile p & eval & last
+
+finalStateOf :: (GmState -> r) -> Program' -> r
+finalStateOf f = f . gmEvalProg
+
+resultOf :: Program' -> Maybe Node
+resultOf p = do
+    a <- res
+    n <- hLookup a h
+    pure n
+    where
+        res = st ^? gmStack . _head
+        st = gmEvalProg p
+        h = st ^. gmHeap
+
+resultOfExpr :: Expr' -> Maybe Node
+resultOfExpr e = resultOf $ Program
+    [ ScDef "main" [] e
+    ]
+