fuck you

src/GM.hs

@@ -42,6 +42,12 @@ import Data.String                  (IsString)
 import Data.Heap
 import Debug.Trace
 import Compiler.RLPC
+
+-- for visualisation
+import Data.Aeson                   hiding (Key)
+import Data.Aeson.Text
+import GHC.Generics                 (Generic, Generically(..))
+
 import Core2Core
 import Core
 ----------------------------------------------------------------------------------
@@ -78,7 +84,7 @@ data GmState = GmState
     , _gmEnv    :: Env
     , _gmStats  :: Stats
     }
-    deriving Show
+    deriving (Show, Generic)
 
 type Code = [Instr]
 type Stack = [Addr]
@@ -88,7 +94,7 @@ type GmHeap = Heap Node
 
 data Key = NameKey Name
          | ConstrKey Tag Int
-         deriving (Show, Eq)
+         deriving (Show, Eq, Generic)
 
 -- >> [ref/Instr]
 data Instr = Unwind
@@ -111,7 +117,7 @@ data Instr = Unwind
            | Split Int
            | Print
            | Halt
-           deriving (Show, Eq)
+           deriving (Show, Eq, Generic)
 -- << [ref/Instr]
 
 data Node = NNum Int
@@ -124,7 +130,7 @@ data Node = NNum Int
           | NUninitialised
           | NConstr Tag [Addr] -- NConstr Tag Components
           | NMarked Node
-          deriving (Show, Eq)
+          deriving (Show, Eq, Generic)
 
 -- TODO: log executed instructions
 data Stats = Stats
@@ -134,7 +140,7 @@ data Stats = Stats
     , _stsDereferences   :: Int
     , _stsGCCycles       :: Int
     }
-    deriving Show
+    deriving (Show, Generic)
 
 instance Default Stats where
     def = Stats 0 0 0 0 0
@@ -178,18 +184,48 @@ hdbgProg p hio = do
 
 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
+    putState `traverse_` states
+    putStats sts
+    pure res
+  where
+    states = eval . compile $ p
+    res@(_, sts) = results 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)
+putState :: Monad m => GmState -> RLPCT m ()
+putState st = do
+    addDebugMsg "dump-eval" $ render (showState st) ++ "\n"
+    addDebugMsg "dump-eval-json" $
+        view strict . encodeToLazyText $ st
+
+putStats :: Monad m => Stats -> RLPCT m ()
+putStats sts = do
+    addDebugMsg "dump-eval" $ render (showStats sts) ++ "\n"
+
+results :: [GmState] -> (Node, Stats)
+results states = (res, sts) where
+    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)
+
+-- evalProgR :: (Monad m) => Program' -> RLPCT m (Node, Stats)
+-- evalProgR p = do
+--     (renderOut . showState) `traverse_` states
+--     renderOut . showStats $ sts
+--     pure (res, sts)
+--     where
+--         renderOut r = do
+--             addDebugMsg "dump-eval" $ render r ++ "\n"
+--             addDebugMsg "dump-eval-json" $
+--                 view strict . encodeToLazyText $ r
+--         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
@@ -1060,3 +1096,17 @@ resultOfExpr e = resultOf $
                 [ ScDef "main" [] e
                 ]
 
+--------------------------------------------------------------------------------
+-- visualisation
+
+deriving via Generically Instr instance FromJSON Instr
+deriving via Generically Instr instance ToJSON Instr
+deriving via Generically Node instance FromJSON Node
+deriving via Generically Node instance ToJSON Node
+deriving via Generically Stats instance FromJSON Stats
+deriving via Generically Stats instance ToJSON Stats
+deriving via Generically Key instance FromJSON Key
+deriving via Generically Key instance ToJSON Key
+deriving via Generically GmState instance FromJSON GmState
+deriving via Generically GmState instance ToJSON GmState
+