fuck you

.nrepl-port

@@ -0,0 +1 @@
+53855

Makefile_happysrcs

@@ -1,14 +1,16 @@
+GHC_VERSION = $(shell ghc --numeric-version)
 HAPPY = happy
 HAPPY_OPTS = -a -g -c -i/tmp/t.info
 ALEX = alex
 ALEX_OPTS = -g
 
 SRC = src
-CABAL_BUILD = dist-newstyle/build/x86_64-osx/ghc-9.6.2/rlp-0.1.0.0/build
+CABAL_BUILD = $(shell ./find-build.clj)
 
 all: parsers lexers
 
-parsers: $(CABAL_BUILD)/Rlp/Parse.hs $(CABAL_BUILD)/Core/Parse.hs
+parsers: $(CABAL_BUILD)/Rlp/Parse.hs $(CABAL_BUILD)/Core/Parse.hs \
+		$(CABAL_BUILD)/Rlp/AltParse.hs
 lexers: $(CABAL_BUILD)/Rlp/Lex.hs $(CABAL_BUILD)/Core/Lex.hs
 
 $(CABAL_BUILD)/Rlp/Parse.hs: $(SRC)/Rlp/Parse.y

find-build.clj

@@ -0,0 +1,13 @@
+#!/usr/bin/env bb
+
+(defn die [& msgs]
+  (binding [*out* *err*]
+    (run! println msgs))
+  (System/exit 1))
+
+(let [paths (map str (fs/glob "." "dist-newstyle/build/*/*/rlp-*/build"))
+      n (count paths)]
+  (cond (< 1 n) (die ">1 build directories found. run `cabal clean`.")
+        (< n 1) (die "no build directories found. this shouldn't happen lol")
+        :else   (-> paths first fs/real-path str println)))
+

rlp.cabal

@@ -73,6 +73,7 @@ library
                     , effectful-core ^>=2.3.0.0
                     , deriving-compat ^>=0.6.0
                     , these >=0.2 && <2.0
+                    , aeson
 
     hs-source-dirs:   src
     default-language: GHC2021

src/Data/Heap.hs

@@ -28,10 +28,21 @@ import Data.Map.Strict              qualified as M
 import Data.List                    (intersect)
 import GHC.Stack                    (HasCallStack)
 import Control.Lens
+
+import Data.Aeson
+import GHC.Generics                 ( Generic1, Generic
+                                    , Generically1(..), Generically(..))
 ----------------------------------------------------------------------------------
 
 data Heap a = Heap [Addr] (Map Addr a)
-    deriving Show
+    deriving (Show, Generic, Generic1)
+    deriving (ToJSON1, FromJSON1)
+      via Generically1 Heap
+
+deriving via Generically (Heap a)
+    instance ToJSON a => ToJSON (Heap a)
+deriving via Generically (Heap a)
+    instance FromJSON a => FromJSON (Heap a)
 
 type Addr = Int
 

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
+    putState `traverse_` states
-    renderOut . showStats $ sts
+    putStats sts
-    pure (res, sts)
+    pure res
-    where
+  where
-        renderOut r = addDebugMsg "dump-eval" $ render r ++ "\n"
+    states = eval . compile $ p
-        states = eval . compile $ p
+    res@(_, sts) = results states
-        final = last states
 
-        sts = final ^. gmStats
+putState :: Monad m => GmState -> RLPCT m ()
-        -- the address of the result should be the one and only stack entry
+putState st = do
-        [resAddr] = final ^. gmStack
+    addDebugMsg "dump-eval" $ render (showState st) ++ "\n"
-        res = hLookupUnsafe resAddr (final ^. gmHeap)
+    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
+

visualisers/gmvis/package.json

@@ -0,0 +1,12 @@
+{ "name": "gmvis"
+, "version": "0.0.1"
+, "private": true
+, "devDependencies":
+    { "shadow-cljs": "2.28.3"
+    }
+, "dependencies":
+    { "react": "16.13.0"
+    , "react-dom": "16.13.0"
+    }
+}
+

visualisers/gmvis/public/index.html

@@ -0,0 +1,17 @@
+<!DOCTYPE html>
+<html lang="en">
+    <head>
+        <meta charset="UTF-8">
+        <meta http-equiv="X-UA-Compatible" content="IE=edge">
+        <meta name="viewport" content="width=device-width, initial-scale=1.0">
+        <link rel="stylesheet" href="/css/main.css">
+        <title>The G-Machine</title>
+
+        <style type="text/css" media="screen">
+        </style>
+    </head>
+    <body>
+        <script src="/js/main.js"></script>
+    </body>
+</html>
+

visualisers/gmvis/shadow-cljs.edn

@@ -0,0 +1,25 @@
+{:source-paths
+ ["src"]
+
+ :dependencies
+ [[cider/cider-nrepl "0.24.0"]
+  [nilenso/wscljs "0.2.0"]
+  [org.clojure/core.match "1.1.0"]
+  [reagent "0.10.0"]
+  [cljsjs/react "17.0.2-0"]
+  [cljsjs/react-dom "17.0.2-0"]
+  [cljsx "1.0.0"]]
+
+ :dev-http
+ {8020 "public"}
+
+ :builds
+ {:app
+  {:target :browser
+   :output-dir "public/js"
+   :asset-path "/js"
+
+   :modules
+   {:main ; becomes public/js/main.js
+    {:init-fn main/init}}}}}
+

visualisers/gmvis/src/main.cljs

@@ -0,0 +1,17 @@
+(ns main)
+
+;; this is called before any code is reloaded
+(defn ^:dev/before-load stop []
+  (js/console.log "stop"))
+
+;; start is called by init and after code reloading finishes
+(defn ^:dev/after-load start []
+  (js/console.log "start"))
+
+;; init is called ONCE when the page loads
+;; this is called in the index.html and must be exported
+;; so it is available even in :advanced release builds
+(defn init []
+  (js/console.log "init")
+  (start))
+