From ff5a5af9bc3de4f2d0cc12304fed4abe118e347b Mon Sep 17 00:00:00 2001
From: crumbtoo <crumb@disroot.org>
Date: Thu, 1 Feb 2024 12:14:43 -0700
Subject: [PATCH] -ddump-eval

---
 src/Compiler/RLPC.hs |  4 ++--
 src/GM.hs            | 17 +++++++++++++++++
 2 files changed, 19 insertions(+), 2 deletions(-)

diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs
index f7ed654..54719a9 100644
--- a/src/Compiler/RLPC.hs
+++ b/src/Compiler/RLPC.hs
@@ -187,9 +187,9 @@ prettyRlpcMsg m                                  = render $ docRlpcErr m
 
 prettyRlpcDebugMsg :: MsgEnvelope RlpcError -> String
 prettyRlpcDebugMsg msg =
-        T.unpack . foldMap mkLine $ ts
+        T.unpack . foldMap mkLine $ [ t' | t <- ts, t' <- T.lines t ]
     where
-        mkLine s = tag <> ": " <> s <> "\n"
+        mkLine s = "-d" <> tag <> ": " <> s <> "\n"
         Text ts = msg ^. msgDiagnostic
         SevDebug tag = msg ^. msgSeverity
 
diff --git a/src/GM.hs b/src/GM.hs
index 065cb08..216672d 100644
--- a/src/GM.hs
+++ b/src/GM.hs
@@ -8,6 +8,7 @@ Description : The G-Machine
 module GM
     ( hdbgProg
     , evalProg
+    , evalProgR
     , Node(..)
     , gmEvalProg
     , finalStateOf
@@ -34,6 +35,7 @@ import System.IO                    (Handle, hPutStrLn)
 import Data.String                  (IsString)
 import Data.Heap
 import Debug.Trace
+import Compiler.RLPC
 import Core2Core
 import Core
 ----------------------------------------------------------------------------------
@@ -156,6 +158,21 @@ hdbgProg p hio = do
         [resAddr] = final ^. gmStack
         res = hLookupUnsafe resAddr h
 
+evalProgR :: (Monad m) => Program' -> RLPCT m (Node, Stats)
+evalProgR p = do
+    (renderOut . showState) `traverse_` states
+    renderOut . showStats $ sts
+    pure (res, sts)
+    where
+        renderOut r = addDebugMsg "dump-eval" $ render r ++ "\n"
+        states = eval . compile $ p
+        final = last states
+
+        sts = final ^. gmStats
+        -- the address of the result should be the one and only stack entry
+        [resAddr] = final ^. gmStack
+        res = hLookupUnsafe resAddr (final ^. gmHeap)
+
 eval :: GmState -> [GmState]
 eval st = st : rest
     where