diagrams

Makefile_happysrcs

@@ -1,16 +1,14 @@
-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 = $(shell ./find-build.clj)
+CABAL_BUILD = dist-newstyle/build/x86_64-osx/ghc-9.6.2/rlp-0.1.0.0/build
 
 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

app.old/CoreDriver.hs

@@ -1,24 +0,0 @@
-module CoreDriver
-    ( driver
-    )
-    where
---------------------------------------------------------------------------------
-import Compiler.RLPC
-import Control.Monad
-import Data.Text                    qualified as T
-import Control.Lens.Combinators
-
-import Core.Lex
-import Core.Parse
-import GM
---------------------------------------------------------------------------------
-
-driver :: RLPCIO ()
-driver = forFiles_ $ \f ->
-    withSource f (lexCoreR >=> parseCoreProgR >=> evalProgR)
-
-driverSource :: T.Text -> RLPCIO ()
-driverSource = lexCoreR >=> parseCoreProgR >=> evalProgR >=> printRes
-    where
-        printRes = liftIO . print . view _1
-

app.old/Main.hs

@@ -1,140 +0,0 @@
-{-# LANGUAGE BlockArguments, LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Main where
-----------------------------------------------------------------------------------
-import Compiler.RLPC
-import Compiler.RlpcError
-import Control.Exception
-import Options.Applicative      hiding (ParseError)
-import Control.Monad
-import Control.Monad.Reader
-import Data.HashSet             qualified as S
-import Data.Text                (Text)
-import Data.Text                qualified as T
-import Data.Text.IO             qualified as TIO
-import Data.List
-import Data.Maybe               (listToMaybe)
-import System.IO
-import System.Exit              (exitSuccess)
-import Core
-import TI
-import GM
-import Control.Lens.Combinators hiding (argument)
-
-import CoreDriver               qualified
-import RlpDriver                qualified
-----------------------------------------------------------------------------------
-
-optParser :: ParserInfo RLPCOptions
-optParser = info (helper <*> options)
-    (  fullDesc
-    <> progDesc "Compile rl' programs"
-    <> header "rlpc - The Inglorious rl' Compiler"
-    )
-
-options :: Parser RLPCOptions
-options = RLPCOptions
-    {- --log, -l -}
-    <$> optional # strOption
-        (  long "log"
-        <> short 'l'
-        <> metavar "FILE"
-        <> help "output dumps to FILE. stderr is used if unset"
-        )
-    {- -d -}
-    <*> fmap S.fromList # many # option debugFlagReader
-        (  short 'd'
-        <> help "pass debug flags"
-        <> metavar "DEBUG FLAG"
-        )
-    {- -f -}
-    <*> fmap S.fromList # many # option compilerFlagReader
-        (  short 'f'
-        <> help "pass compilation flags"
-        <> metavar "COMPILATION FLAG"
-        )
-    {- --evaluator, -e -}
-    <*> option evaluatorReader
-        (  long "evaluator"
-        <> short 'e'
-        <> metavar "gm|ti"
-        <> value EvaluatorGM
-        <> help "the intermediate layer used to model evaluation"
-        )
-    <*> option auto
-        (  long "heap-trigger"
-        <> metavar "INT"
-        <> help "the number of nodes allowed on the heap before\
-                \triggering the garbage collector"
-        <> value 50
-        )
-    <*> optional # option languageReader
-        (  long "language"
-        <> short 'x'
-        <> metavar "rlp|core"
-        <> help "the language to be compiled -- see README"
-        )
-    <*> some (argument str $ metavar "FILES...")
-    where
-        infixr 9 #
-        f # x = f x
-
-languageReader :: ReadM Language
-languageReader = maybeReader $ \case
-    "rlp"   -> Just LanguageRlp
-    "core"  -> Just LanguageCore
-    "rl"    -> Just LanguageRlp
-    "cr"    -> Just LanguageCore
-    _       -> Nothing
-
-debugFlagReader :: ReadM DebugFlag
-debugFlagReader = str
-
-compilerFlagReader :: ReadM CompilerFlag
-compilerFlagReader = str
-
-evaluatorReader :: ReadM Evaluator
-evaluatorReader = maybeReader $ \case
-    "gm"  -> Just EvaluatorGM
-    "ti"  -> Just EvaluatorTI
-    _     -> Nothing
-
-mmany :: (Alternative f, Monoid m) => f m -> f m
-mmany v = liftA2 (<>) v (mmany v)
-
-----------------------------------------------------------------------------------
-
-main :: IO ()
-main = do
-    opts <- execParser optParser
-    void $ evalRLPCIO opts dispatch
-
-dispatch :: RLPCIO ()
-dispatch = getLang >>= \case
-    Just LanguageCore -> CoreDriver.driver
-    Just LanguageRlp  -> RlpDriver.driver
-    Nothing           -> addFatal err
-        where
-            -- TODO: why didn't i make the srcspan optional LOL
-            err = errorMsg (SrcSpan 0 0 0 0) $ Text
-                [ "Could not determine source language from filetype."
-                , "Possible Solutions:\n\
-                  \  Suffix the file with `.cr' for Core, or `.rl' for rl'\n\
-                  \  Specify a language with `rlpc -x core' or `rlpc -x rlp'"
-                ]
-  where
-    getLang = liftA2 (<|>)
-        (view rlpcLanguage)
-        -- TODO: we only check the first file lol
-        ((listToMaybe >=> inferLanguage) <$> view rlpcInputFiles)
-
-
-driver :: RLPCIO ()
-driver = undefined
-
-inferLanguage :: FilePath -> Maybe Language
-inferLanguage fp
-    | ".rl" `isSuffixOf` fp     = Just LanguageRlp
-    | ".cr" `isSuffixOf` fp     = Just LanguageCore
-    | otherwise                 = Nothing
-

app.old/RlpDriver.hs

@@ -1,19 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module RlpDriver
-    ( driver
-    )
-    where
---------------------------------------------------------------------------------
-import Compiler.RLPC
-import Control.Monad
-
-import Rlp.Lex
-import Rlp.Parse
-import Rlp2Core
-import GM
---------------------------------------------------------------------------------
-
-driver :: RLPCIO ()
-driver = forFiles_ $ \f ->
-    withSource f (parseRlpProgR >=> desugarRlpProgR >=> evalProgR)
-

app/CoreDriver.hs

@@ -10,7 +10,6 @@ import Control.Lens.Combinators
 
 import Core.Lex
 import Core.Parse
--- import Core.SystemF
 import GM
 --------------------------------------------------------------------------------
 
@@ -19,8 +18,7 @@ driver = forFiles_ $ \f ->
     withSource f (lexCoreR >=> parseCoreProgR >=> evalProgR)
 
 driverSource :: T.Text -> RLPCIO ()
-driverSource = lexCoreR >=> parseCoreProgR
+driverSource = lexCoreR >=> parseCoreProgR >=> evalProgR >=> printRes
-           >=> evalProgR >=> printRes
     where
         printRes = liftIO . print . view _1
 

app/Main.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Main where
 ----------------------------------------------------------------------------------
-import Control.Lens             hiding (argument)
 import Compiler.RLPC
 import Compiler.RlpcError
 import Control.Exception
@@ -24,7 +23,6 @@ import Control.Lens.Combinators hiding (argument)
 
 import CoreDriver               qualified
 import RlpDriver                qualified
-import Server                   qualified
 ----------------------------------------------------------------------------------
 
 optParser :: ParserInfo RLPCOptions
@@ -76,11 +74,12 @@ options = RLPCOptions
         <> metavar "rlp|core"
         <> help "the language to be compiled -- see README"
         )
-    <*> switch
+    <*> flag False True
-        (  long "server"
+        (  long "render"
-        <> short 's'
+        <> short 'r'
+        <> help "render a diagram of each GM state"
         )
-    <*> many (argument str $ metavar "FILES...")
+    <*> some (argument str $ metavar "FILES...")
     where
         infixr 9 #
         f # x = f x
@@ -113,9 +112,7 @@ mmany v = liftA2 (<>) v (mmany v)
 main :: IO ()
 main = do
     opts <- execParser optParser
-    if opts ^. rlpcServer
+    void $ evalRLPCIO opts dispatch
-    then Server.server
-    else void $ evalRLPCIO opts dispatch
 
 dispatch :: RLPCIO ()
 dispatch = getLang >>= \case

app/RlpDriver.hs

@@ -15,5 +15,5 @@ import GM
 
 driver :: RLPCIO ()
 driver = forFiles_ $ \f ->
-    withSource f (parseRlpProgR >=> undefined >=> desugarRlpProgR >=> evalProgR)
+    withSource f (parseRlpProgR >=> desugarRlpProgR >=> evalProgR)
 

app/Server.hs

@@ -1,92 +0,0 @@
-{-# LANGUAGE LambdaCase, BlockArguments #-}
-{-# LANGUAGE DerivingVia #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Server
-    ( server
-    )
-    where
---------------------------------------------------------------------------------
-import GHC.Generics                 (Generic, Generically(..))
-import Data.Text.Encoding           qualified as T
-import Data.Text                    (Text)
-import Data.Text                    qualified as T
-import Data.Text.IO                 qualified as T
-import Data.Pretty                  hiding (annotate, empty)
-import Data.Aeson                   ( ToJSON(..), Value, (.:)
-                                    , FromJSON(..), encode, withObject
-                                    , decodeStrictText)
-import Data.Function
-import Control.Arrow
-import Control.Applicative
-import Control.Monad
-import Control.Concurrent
-import Network.WebSockets           qualified as WS
-import Control.Exception
-import GHC.IO
-import Control.Lens                 hiding ((.=))
-
--- import Control.Comonad
--- import Data.Functor.Foldable
-
-import Compiler.RLPC
-import Compiler.JustRun
-import GM
-
--- import Misc.CofreeF
--- import Rlp.AltSyntax
--- import Rlp.HindleyMilner
--- import Rlp.AltParse
---------------------------------------------------------------------------------
-
-server :: IO ()
-server = do
-    T.putStrLn "rlpc server started at 127.0.0.1:9002"
-    WS.runServer "127.0.0.1" 9002 application
-
-application :: WS.ServerApp
-application pending = do
-    WS.acceptRequest pending >>= talk
-
-data Command = Annotate Text
-             | PartiallyAnnotate Text
-             | Evaluate Text
-             deriving Show
-
-instance FromJSON Command where
-    parseJSON = withObject "command object" $ \v -> do
-        cmd :: Text <- v .: "command"
-        case cmd of
-            "evaluate"           -> Evaluate <$> v .: "source"
-            "annotate"           -> Annotate <$> v .: "source"
-            "partially-annotate" -> PartiallyAnnotate <$> v .: "source"
-            _                    -> empty
-
-data Response = Annotated Value
-              | PartiallyAnnotated Value
-              | Evaluated [GmState]
-              | Error Value
-              deriving (Generic)
-              deriving (ToJSON)
-                via Generically Response
-
-talk :: WS.Connection -> IO ()
-talk conn = (`catchAny` print) . forever $ do
-    msg <- WS.receiveData @Text conn
-    T.putStrLn $ "received: " <> msg
-    doCommand conn `traverse` decodeStrictText msg
-
-doCommand :: WS.Connection -> Command -> IO ()
-doCommand conn c = do
-    putStr "sending: "
-    let r = encode . respond $ c
-    print r
-    WS.sendTextData conn r
-
-respond :: Command -> Response
-respond (Annotate s)
-    = error "i'm a shitty programmer! try again with the dev branch lmfao"
-
-respond (Evaluate s)
-    = justLexParseGmEval (T.unpack s)
-    & either (Error . toJSON) Evaluated
-

find-build.clj

@@ -1,13 +0,0 @@
-#!/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

@@ -22,6 +22,9 @@ library
     exposed-modules:  Core
                     , TI
                     , GM
+                    , GM.Visual
+                    , GM.Types
+                    , GM.Print
                     , Compiler.RLPC
                     , Compiler.RlpcError
                     , Compiler.JustRun
@@ -50,17 +53,17 @@ library
     build-tool-depends: happy:happy, alex:alex
 
     -- other-extensions:
-    build-depends:    base >=4.17 && <4.21
+    build-depends:    base >=4.17 && <4.20
                     -- required for happy
                     , array >= 0.5.5 && < 0.6
                     , containers >= 0.6.7 && < 0.7
-                    , template-haskell >= 2.20.0 && < 2.23
+                    , template-haskell >= 2.20.0 && < 2.21
                     , pretty >= 1.1.3 && < 1.2
                     , data-default >= 0.7.1 && < 0.8
                     , data-default-class >= 0.1.2 && < 0.2
                     , hashable >= 1.4.3 && < 1.5
                     , mtl >= 2.3.1 && < 2.4
-                    , text >= 2.0.2 && < 2.3
+                    , text >= 2.0.2 && < 2.1
                     , unordered-containers >= 0.2.20 && < 0.3
                     , recursion-schemes >= 5.2.2 && < 5.3
                     , data-fix >= 0.3.2 && < 0.4
@@ -73,14 +76,13 @@ library
                     , effectful-core ^>=2.3.0.0
                     , deriving-compat ^>=0.6.0
                     , these >=0.2 && <2.0
-                    , aeson
+                    , diagrams
+                    , diagrams-lib
+                    , diagrams-cairo
 
     hs-source-dirs:   src
     default-language: GHC2021
 
-    ghc-options:
-        -fdefer-typed-holes
-
     default-extensions:
         OverloadedStrings
         TypeFamilies
@@ -90,14 +92,12 @@ library
         DerivingVia
         StandaloneDeriving
         DerivingStrategies
-        PartialTypeSignatures
 
 executable rlpc
     import:           warnings
     main-is:          Main.hs
     other-modules:    RlpDriver
                     , CoreDriver
-                    , Server
 
     build-depends: base >=4.17.0.0 && <4.20.0.0
                  , rlp
@@ -105,9 +105,7 @@ executable rlpc
                  , mtl >= 2.3.1 && < 2.4
                  , unordered-containers >= 0.2.20 && < 0.3
                  , lens >=5.2.3 && <6.0
-                 , text >= 2.0.2 && < 2.3
+                 , text >= 2.0.2 && < 2.1
-                 , aeson
-                 , websockets
 
     hs-source-dirs:   app
     default-language: GHC2021

src/Compiler/JustRun.hs

@@ -12,7 +12,6 @@ module Compiler.JustRun
     , justParseCore
     , justTypeCheckCore
     , justHdbg
-    , justLexParseGmEval
     )
     where
 ----------------------------------------------------------------------------------
@@ -48,10 +47,6 @@ justParseCore s = parse (T.pack s)
                 & rlpcToEither
     where parse = lexCoreR >=> parseCoreProgR
 
-justLexParseGmEval :: String -> Either [MsgEnvelope RlpcError] [GmState]
-justLexParseGmEval = parse >>> fmap (compile >>> eval) >>> rlpcToEither
-    where parse = (T.pack >>> lexCoreR) >=> parseCoreProgR
-
 justTypeCheckCore :: String -> Either [MsgEnvelope RlpcError] Program'
 justTypeCheckCore s = typechk (T.pack s)
                     & rlpcToEither

src/Compiler/RLPC.hs

@@ -26,7 +26,6 @@ module Compiler.RLPC
     , DebugFlag(..), CompilerFlag(..)
     -- ** Lenses
     , rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage
-    , rlpcServer
     -- * Misc. MTL-style functions
     , liftErrorful, hoistRlpcT
     -- * Misc. Rlpc Monad -related types
@@ -121,7 +120,7 @@ data RLPCOptions = RLPCOptions
     , _rlpcEvaluator   :: Evaluator
     , _rlpcHeapTrigger :: Int
     , _rlpcLanguage    :: Maybe Language
-    , _rlpcServer      :: Bool
+    , _rlpcRender      :: Bool
     , _rlpcInputFiles  :: [FilePath]
     }
     deriving Show
@@ -143,7 +142,7 @@ instance Default RLPCOptions where
         , _rlpcHeapTrigger = 200
         , _rlpcInputFiles = []
         , _rlpcLanguage = Nothing
-        , _rlpcServer = False
+        , _rlpcRender = False
         }
 
 -- debug flags are passed with -dFLAG

src/Compiler/RlpcError.hs

@@ -23,9 +23,6 @@ import Data.Text                qualified as T
 import GHC.Exts                 (IsString(..))
 import Control.Lens
 import Compiler.Types
-import GHC.Generics             ( Generic, Generic1
-                                , Generically(..), Generically1(..) )
-import Data.Aeson               (ToJSON1(..), ToJSON(..))
 ----------------------------------------------------------------------------------
 
 data MsgEnvelope e = MsgEnvelope
@@ -33,18 +30,10 @@ data MsgEnvelope e = MsgEnvelope
    , _msgDiagnostic  :: e
    , _msgSeverity    :: Severity
    }
-   deriving (Functor, Show, Generic, Generic1)
+   deriving (Functor, Show)
 
 newtype RlpcError = Text [Text]
-               deriving (Show, Generic)
+               deriving Show
-
-deriving via Generically1 MsgEnvelope
-    instance ToJSON1 MsgEnvelope
-deriving via Generically (MsgEnvelope e)
-    instance ToJSON e => ToJSON (MsgEnvelope e)
-
-deriving via Generically RlpcError
-    instance ToJSON RlpcError
 
 instance IsString RlpcError where
     fromString = Text . pure . T.pack
@@ -58,10 +47,7 @@ instance IsRlpcError RlpcError where
 data Severity = SevWarning
               | SevError
               | SevDebug Text -- ^ Tag
-              deriving (Show, Generic)
+              deriving Show
-
-deriving via Generically Severity
-    instance ToJSON Severity
 
 makeLenses ''MsgEnvelope
 

src/Compiler/Types.hs

@@ -20,9 +20,6 @@ import Data.Functor.Apply
 import Data.Functor.Bind
 import Control.Lens             hiding ((<<~))
 import Language.Haskell.TH.Syntax   (Lift)
-import GHC.Generics             ( Generic, Generic1
-                                , Generically(..), Generically1(..) )
-import Data.Aeson               (ToJSON1(..), ToJSON(..))
 --------------------------------------------------------------------------------
 
 -- | Token wrapped with a span (line, column, absolute, length)
@@ -50,10 +47,7 @@ data SrcSpan = SrcSpan
     !Int -- ^ Column
     !Int -- ^ Absolute
     !Int -- ^ Length
-    deriving (Show, Lift, Generic)
+    deriving (Show, Lift)
-
-deriving via Generically SrcSpan
-    instance ToJSON SrcSpan
 
 tupling :: Iso' SrcSpan (Int, Int, Int, Int)
 tupling = iso (\ (SrcSpan a b c d) -> (a,b,c,d))

src/Data/Heap.hs

@@ -28,27 +28,10 @@ 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, Generic, Generic1)
+    deriving Show
-    deriving (ToJSON1, FromJSON1)
-      via Generically1 Heap
-
-instance ToJSON a => ToJSON (Heap a) where
-    toJSON (Heap as m) = toJSON m
-
-instance FromJSON (Heap a) where
-    parseJSON = _
-
--- 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

@@ -11,6 +11,11 @@ module GM
     , evalProgR
     , GmState(..)
     , gmCode, gmStack, gmDump, gmHeap, gmEnv, gmStats
+    , stsReductions
+    , stsPrimReductions
+    , stsAllocations
+    , stsDereferences
+    , stsGCCycles
     , Node(..)
     , showState
     , gmEvalProg
@@ -18,8 +23,6 @@ module GM
     , finalStateOf
     , resultOf
     , resultOfExpr
-    , compile
-    , eval
     )
     where
 ----------------------------------------------------------------------------------
@@ -31,10 +34,9 @@ import Data.Tuple                   (swap)
 import Control.Lens
 import Data.Text.Lens               (IsText, packed, unpacked)
 import Text.Printf
-import Text.PrettyPrint             hiding ((<>))
-import Text.PrettyPrint.HughesPJ    (maybeParens)
 import Data.Foldable                (traverse_)
 import System.IO                    (Handle, hPutStrLn)
+import Text.PrettyPrint             (render)
 -- TODO: an actual output system
 -- TODO: an actual output system
 -- TODO: an actual output system
@@ -43,15 +45,12 @@ import System.IO.Unsafe             (unsafePerformIO)
 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
+import GM.Types
+import GM.Print
 ----------------------------------------------------------------------------------
 
 tag_Unit_unit :: Int
@@ -63,105 +62,19 @@ tag_Bool_True = 1
 tag_Bool_False :: Int
 tag_Bool_False = 0
 
-{-}
-
-hdbgProg = undefined
-evalProg = undefined
-
-data Node = NNum Int
-          | NAp Addr Addr
-          | NInd Addr
-          | NUninitialised
-          | NConstr Tag [Addr] -- NConstr Tag Components
-          | NMarked Node
-          deriving (Show, Eq)
-
---}
-
-data GmState = GmState
-    { _gmCode   :: Code
-    , _gmStack  :: Stack
-    , _gmDump   :: Dump
-    , _gmHeap   :: GmHeap
-    , _gmEnv    :: Env
-    , _gmStats  :: Stats
-    }
-    deriving (Show, Generic)
-
-type Code = [Instr]
-type Stack = [Addr]
-type Dump = [(Code, Stack)]
-type Env = [(Key, Addr)]
-type GmHeap = Heap Node
-
-data Key = NameKey Name
-         | ConstrKey Tag Int
-         deriving (Show, Eq, Generic)
-
--- >> [ref/Instr]
-data Instr = Unwind
-           | PushGlobal Name
-           | PushConstr Tag Int
-           | PushInt Int
-           | Push Int
-           | MkAp
-           | Slide Int
-           | Update Int
-           | Pop Int
-           | Alloc Int
-           | Eval
-           -- arith
-           | Neg | Add | Sub | Mul | Div
-           -- comparison
-           | Equals | Lesser | GreaterEq
-           | Pack Tag Int -- Pack Tag Arity
-           | CaseJump [(Tag, Code)]
-           | Split Int
-           | Print
-           | Halt
-           deriving (Show, Eq, Generic)
--- << [ref/Instr]
-
-data Node = NNum Int
-          | NAp Addr Addr
-          -- NGlobal is the GM equivalent of NSupercomb. rather than storing a
-          -- template to be instantiated, NGlobal holds the global's arity and
-          -- the pre-compiled code :3
-          | NGlobal Int Code
-          | NInd Addr
-          | NUninitialised
-          | NConstr Tag [Addr] -- NConstr Tag Components
-          | NMarked Node
-          deriving (Show, Eq, Generic)
-
--- TODO: log executed instructions
-data Stats = Stats
-    { _stsReductions     :: Int
-    , _stsPrimReductions :: Int
-    , _stsAllocations    :: Int
-    , _stsDereferences   :: Int
-    , _stsGCCycles       :: Int
-    }
-    deriving (Show, Generic)
-
-instance Default Stats where
-    def = Stats 0 0 0 0 0
-
--- TODO: _gmGlobals should not have a setter
-makeLenses ''GmState
-makeLenses ''Stats
-pure []
-
 ----------------------------------------------------------------------------------
 
-evalProg :: Program' -> Maybe (Node, Stats)
+evalProg :: Program' -> [GmState]
-evalProg p = res <&> (,sts)
+evalProg = eval . compile
-    where
+
-        final = eval (compile p) & last
+-- evalProg :: Program' -> Maybe (Node, Stats)
-        h = final ^. gmHeap
+-- evalProg p = res <&> (,sts)
-        sts = final ^. gmStats
+--     where
-        resAddr = final ^. gmStack ^? _head
+--         final = eval (compile p) & last
-        res = resAddr >>= flip hLookup h
+--         h = final ^. gmHeap
+--         sts = final ^. gmStats
+--         resAddr = final ^. gmStack ^? _head
+--         res = resAddr >>= flip hLookup h
 
 hdbgProg :: Program' -> Handle -> IO GmState
 hdbgProg p hio = do
@@ -186,48 +99,18 @@ hdbgProg p hio = do
 
 evalProgR :: (Monad m) => Program' -> RLPCT m (Node, Stats)
 evalProgR p = do
-    putState `traverse_` states
+    (renderOut . showState) `traverse_` states
-    putStats sts
+    renderOut . showStats $ sts
-    pure res
+    pure (res, sts)
-  where
+    where
-    states = eval . compile $ p
+        renderOut r = addDebugMsg "dump-eval" $ render r ++ "\n"
-    res@(_, sts) = results states
+        states = eval . compile $ p
+        final = last states
 
-putState :: Monad m => GmState -> RLPCT m ()
+        sts = final ^. gmStats
-putState st = do
+        -- the address of the result should be the one and only stack entry
-    addDebugMsg "dump-eval" $ render (showState st) ++ "\n"
+        [resAddr] = final ^. gmStack
-    addDebugMsg "dump-eval-json" $
+        res = hLookupUnsafe resAddr (final ^. gmHeap)
-        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
@@ -853,185 +736,8 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
         argOffset :: Int -> Env -> Env
         argOffset n = each . _2 %~ (+n)
 
-showCon :: (IsText a) => Tag -> Int -> a
-showCon t n = printf "Pack{%d %d}" t n ^. packed
-
 ----------------------------------------------------------------------------------
 
-pprTabstop :: Int
-pprTabstop = 4
-
-qquotes :: Doc -> Doc
-qquotes d = "`" <> d <> "'"
-
-showStats :: Stats -> Doc
-showStats sts = "==== Stats ============" $$ stats
-    where
-        stats = text $ printf
-            "Reductions      : %5d\n\
-            \Prim Reductions : %5d\n\
-            \Allocations     : %5d\n\
-            \GC Cycles       : %5d"
-            (sts ^. stsReductions)
-            (sts ^. stsPrimReductions)
-            (sts ^. stsAllocations)
-            (sts ^. stsGCCycles)
-
-showState :: GmState -> Doc
-showState st = vcat
-        [ "==== GmState " <> int stnum <> " "
-            <> text (replicate (28 - 13 - 1 - digitalWidth stnum) '=')
-        , "-- Next instructions -------"
-        , info $ showCodeShort c
-        , "-- Stack -------------------"
-        , info $ showStack st
-        , "-- Heap --------------------"
-        , info $ showHeap st
-        , "-- Dump --------------------"
-        , info $ showDump st
-        ]
-    where
-        stnum = st ^. (gmStats . stsReductions)
-        c = st ^. gmCode
-
-        -- indent data
-        info = nest pprTabstop
-
-showCodeShort :: Code -> Doc
-showCodeShort c = braces c'
-    where
-        c' | length c > 3 = list (showInstr <$> take 3 c) <> "; ..."
-           | otherwise    = list (showInstr <$> c)
-        list = hcat . punctuate "; "
-
-showStackShort :: Stack -> Doc
-showStackShort s = brackets s'
-    where
-           -- no access to heap, otherwise we'd use showNodeAt
-        s' | length s > 3 = list (showEntry <$> take 3 s) <> ", ..."
-           | otherwise    = list (showEntry <$> s)
-        list = hcat . punctuate ", "
-        showEntry = text . show
-
-showStack :: GmState -> Doc
-showStack st = vcat $ uncurry showEntry <$> si
-    where
-        h = st ^. gmHeap
-        s = st ^. gmStack
-
-        -- stack with labeled indices
-        si = [0..] `zip` s
-
-        w = maxWidth (addresses h)
-        showIndex n = padInt w n <> ": "
-
-        showEntry :: Int -> Addr -> Doc
-        showEntry n a = showIndex n <> showNodeAt st a
-
-showDump :: GmState -> Doc
-showDump st = vcat $ uncurry showEntry <$> di
-    where
-        d = st ^. gmDump
-        di = [0..] `zip` d
-
-        showIndex n = padInt w n <> ": "
-        w = maxWidth (fst <$> di)
-
-        showEntry :: Int -> (Code, Stack) -> Doc
-        showEntry n (c,s) = showIndex n <> nest pprTabstop entry
-            where
-                entry = ("Stack : " <> showCodeShort c)
-                     $$ ("Code  : " <> showStackShort s)
-
-padInt :: Int -> Int -> Doc
-padInt m n = text (replicate (m - digitalWidth n) ' ') <> int n
-
-maxWidth :: [Int] -> Int
-maxWidth ns = digitalWidth $ maximum ns
-
-digitalWidth :: Int -> Int
-digitalWidth = length . show
-
-showHeap :: GmState -> Doc
-showHeap st = vcat $ showEntry <$> addrs
-    where
-        showAddr n = padInt w n <> ": "
-
-        w = maxWidth addrs
-        h = st ^. gmHeap
-        addrs = addresses h
-
-        showEntry :: Addr -> Doc
-        showEntry a = showAddr a <> showNodeAt st a
-
-showNodeAt :: GmState -> Addr -> Doc
-showNodeAt = showNodeAtP 0
-
-showNodeAtP :: Int -> GmState -> Addr -> Doc
-showNodeAtP p st a = case hLookup a h of
-    Just (NNum n)        -> int n <> "#"
-    Just (NGlobal _ _)   -> textt name
-        where
-            g = st ^. gmEnv
-            name = case lookup a (swap <$> g) of
-                Just (NameKey n)     -> n
-                Just (ConstrKey t n) -> showCon t n
-                _                    -> errTxtInvalidAddress
-    -- TODO: left-associativity
-    Just (NAp f x)       -> pprec $ showNodeAtP (p+1) st f
-                                <+> showNodeAtP (p+1) st x
-    Just (NInd a')       -> pprec $ "NInd -> " <> showNodeAtP (p+1) st a'
-    Just (NConstr t as)  -> pprec $ "NConstr"
-                                <+> int t
-                                <+> brackets (list $ showNodeAtP 0 st <$> as)
-        where list = hcat . punctuate ", "
-    Just NUninitialised  -> "<uninitialised>"
-    Nothing              -> errTxtInvalidAddress
-    where
-        h = st ^. gmHeap
-        pprec = maybeParens (p > 0)
-
-showSc :: GmState -> (Name, Addr) -> Doc
-showSc st (k,a) = "Supercomb " <> qquotes (textt k) <> colon
-               $$ code
-    where
-        code = case hLookup a (st ^. gmHeap) of
-            Just (NGlobal _ c) -> showCode c
-            Just _             -> errTxtInvalidObject
-            Nothing            -> errTxtInvalidAddress
-
-errTxtInvalidObject, errTxtInvalidAddress :: (IsString a) => a
-errTxtInvalidObject = "<invalid object>"
-errTxtInvalidAddress = "<invalid address>"
-
-showCode :: Code -> Doc
-showCode c = "Code" <+> braces instrs
-    where instrs = vcat $ showInstr <$> c
-
-showInstr :: Instr -> Doc
-showInstr (CaseJump alts) = "CaseJump" $$ nest pprTabstop alternatives
-    where
-        showAlt (t,c) = "<" <> int t <> ">" <> showCodeShort c
-        alternatives = foldr (\a acc -> showAlt a $$ acc) mempty alts
-showInstr i = text $ show i
-
-textt :: (IsText a) => a -> Doc
-textt t = t ^. unpacked & text
-
-----------------------------------------------------------------------------------
-
-lookupN :: Name -> Env -> Maybe Addr
-lookupN k = lookup (NameKey k)
-
-lookupC :: Tag -> Int -> Env -> Maybe Addr
-lookupC t n = lookup (ConstrKey t n)
-
-----------------------------------------------------------------------------------
-
-gc :: GmState -> GmState
-gc st = (sweepNodes . markNodes $ st)
-      & gmStats . stsGCCycles %~ succ
-
 markNodes :: GmState -> GmState
 markNodes st = st & gmHeap %~ thread (markFrom <$> roots)
     where
@@ -1074,6 +780,18 @@ sweepNodes st = st & gmHeap %~ thread (f <$> addresses h)
 thread :: [a -> a] -> (a -> a)
 thread = appEndo . foldMap Endo
 
+gc :: GmState -> GmState
+gc st = (sweepNodes . markNodes $ st)
+      & gmStats . stsGCCycles %~ succ
+
+--------------------------------------------------------------------------------
+
+lookupN :: Name -> Env -> Maybe Addr
+lookupN k = lookup (NameKey k)
+
+lookupC :: Tag -> Int -> Env -> Maybe Addr
+lookupC t n = lookup (ConstrKey t n)
+
 ----------------------------------------------------------------------------------
 
 gmEvalProg :: Program' -> GmState
@@ -1085,12 +803,11 @@ finalStateOf f = f . gmEvalProg
 resultOf :: Program' -> Maybe Node
 resultOf p = do
     a <- res
-    n <- hLookup a h
+    hLookup a h
-    pure n
+  where
-    where
+    res = st ^? gmStack . _head
-        res = st ^? gmStack . _head
+    st = gmEvalProg p
-        st = gmEvalProg p
+    h = st ^. gmHeap
-        h = st ^. gmHeap
 
 resultOfExpr :: Expr' -> Maybe Node
 resultOfExpr e = resultOf $
@@ -1098,17 +815,3 @@ 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
-

src/GM/Print.hs

@@ -0,0 +1,186 @@
+module GM.Print
+    ( showState
+    , showStats
+    , showNodeAt
+    )
+    where
+--------------------------------------------------------------------------------
+import Data.Monoid
+import Data.String              (IsString(..))
+import Data.Text.Lens           (IsText, packed, unpacked)
+import Text.Printf
+
+import Text.PrettyPrint             hiding ((<>))
+import Text.PrettyPrint.HughesPJ    (maybeParens)
+import Control.Lens
+
+import Data.Heap
+import Core.Syntax
+import GM.Types
+--------------------------------------------------------------------------------
+
+pprTabstop :: Int
+pprTabstop = 4
+
+qquotes :: Doc -> Doc
+qquotes d = "`" <> d <> "'"
+
+showStats :: Stats -> Doc
+showStats sts = "==== Stats ============" $$ stats
+    where
+        stats = text $ printf
+            "Reductions      : %5d\n\
+            \Prim Reductions : %5d\n\
+            \Allocations     : %5d\n\
+            \GC Cycles       : %5d"
+            (sts ^. stsReductions)
+            (sts ^. stsPrimReductions)
+            (sts ^. stsAllocations)
+            (sts ^. stsGCCycles)
+
+showState :: GmState -> Doc
+showState st = vcat
+        [ "==== GmState " <> int stnum <> " "
+            <> text (replicate (28 - 13 - 1 - digitalWidth stnum) '=')
+        , "-- Next instructions -------"
+        , info $ showCodeShort c
+        , "-- Stack -------------------"
+        , info $ showStack st
+        , "-- Heap --------------------"
+        , info $ showHeap st
+        , "-- Dump --------------------"
+        , info $ showDump st
+        ]
+    where
+        stnum = st ^. (gmStats . stsReductions)
+        c = st ^. gmCode
+
+        -- indent data
+        info = nest pprTabstop
+
+showCodeShort :: Code -> Doc
+showCodeShort c = braces c'
+    where
+        c' | length c > 3 = list (showInstr <$> take 3 c) <> "; ..."
+           | otherwise    = list (showInstr <$> c)
+        list = hcat . punctuate "; "
+
+showStackShort :: Stack -> Doc
+showStackShort s = brackets s'
+    where
+           -- no access to heap, otherwise we'd use showNodeAt
+        s' | length s > 3 = list (showEntry <$> take 3 s) <> ", ..."
+           | otherwise    = list (showEntry <$> s)
+        list = hcat . punctuate ", "
+        showEntry = text . show
+
+showStack :: GmState -> Doc
+showStack st = vcat $ uncurry showEntry <$> si
+    where
+        h = st ^. gmHeap
+        s = st ^. gmStack
+
+        -- stack with labeled indices
+        si = [0..] `zip` s
+
+        w = maxWidth (addresses h)
+        showIndex n = padInt w n <> ": "
+
+        showEntry :: Int -> Addr -> Doc
+        showEntry n a = showIndex n <> showNodeAt st a
+
+showDump :: GmState -> Doc
+showDump st = vcat $ uncurry showEntry <$> di
+    where
+        d = st ^. gmDump
+        di = [0..] `zip` d
+
+        showIndex n = padInt w n <> ": "
+        w = maxWidth (fst <$> di)
+
+        showEntry :: Int -> (Code, Stack) -> Doc
+        showEntry n (c,s) = showIndex n <> nest pprTabstop entry
+            where
+                entry = ("Stack : " <> showCodeShort c)
+                     $$ ("Code  : " <> showStackShort s)
+
+padInt :: Int -> Int -> Doc
+padInt m n = text (replicate (m - digitalWidth n) ' ') <> int n
+
+maxWidth :: [Int] -> Int
+maxWidth ns = digitalWidth $ maximum ns
+
+digitalWidth :: Int -> Int
+digitalWidth = length . show
+
+showHeap :: GmState -> Doc
+showHeap st = vcat $ showEntry <$> addrs
+    where
+        showAddr n = padInt w n <> ": "
+
+        w = maxWidth addrs
+        h = st ^. gmHeap
+        addrs = addresses h
+
+        showEntry :: Addr -> Doc
+        showEntry a = showAddr a <> showNodeAt st a
+
+showNodeAt :: GmState -> Addr -> Doc
+showNodeAt = showNodeAtP 0
+
+showNodeAtP :: Int -> GmState -> Addr -> Doc
+showNodeAtP p st a = case hLookup a h of
+    Just (NNum n)        -> int n <> "#"
+    Just (NGlobal _ _)   -> textt name
+        where
+            g = st ^. gmEnv
+            name = case lookup a (view swapped <$> g) of
+                Just (NameKey n)     -> n
+                Just (ConstrKey t n) -> showCon t n
+                _                    -> errTxtInvalidAddress
+    -- TODO: left-associativity
+    Just (NAp f x)       -> pprec $ showNodeAtP (p+1) st f
+                                <+> showNodeAtP (p+1) st x
+    Just (NInd a')       -> pprec $ "NInd -> " <> showNodeAtP (p+1) st a'
+    Just (NConstr t as)  -> pprec $ "NConstr"
+                                <+> int t
+                                <+> brackets (list $ showNodeAtP 0 st <$> as)
+        where list = hcat . punctuate ", "
+    Just NUninitialised  -> "<uninitialised>"
+    Nothing              -> errTxtInvalidAddress
+    where
+        h = st ^. gmHeap
+        pprec = maybeParens (p > 0)
+
+showSc :: GmState -> (Name, Addr) -> Doc
+showSc st (k,a) = "Supercomb " <> qquotes (textt k) <> colon
+               $$ code
+    where
+        code = case hLookup a (st ^. gmHeap) of
+            Just (NGlobal _ c) -> showCode c
+            Just _             -> errTxtInvalidObject
+            Nothing            -> errTxtInvalidAddress
+
+errTxtInvalidObject, errTxtInvalidAddress :: (IsString a) => a
+errTxtInvalidObject = "<invalid object>"
+errTxtInvalidAddress = "<invalid address>"
+
+showCode :: Code -> Doc
+showCode c = "Code" <+> braces instrs
+    where instrs = vcat $ showInstr <$> c
+
+showInstr :: Instr -> Doc
+showInstr (CaseJump alts) = "CaseJump" $$ nest pprTabstop alternatives
+    where
+        showAlt (t,c) = "<" <> int t <> ">" <> showCodeShort c
+        alternatives = foldr (\a acc -> showAlt a $$ acc) mempty alts
+showInstr i = text $ show i
+
+textt :: (IsText a) => a -> Doc
+textt t = t ^. unpacked & text
+
+----------------------------------------------------------------------------------
+
+showCon :: (IsText a) => Tag -> Int -> a
+showCon t n = printf "Pack{%d %d}" t n ^. packed
+

src/GM/Types.hs

@@ -0,0 +1,83 @@
+{-# LANGUAGE TemplateHaskell #-}
+module GM.Types where
+--------------------------------------------------------------------------------
+import Control.Lens.Combinators
+import Data.Heap
+import Data.Default
+
+import Core.Syntax
+--------------------------------------------------------------------------------
+
+data GmState = GmState
+    { _gmCode   :: Code
+    , _gmStack  :: Stack
+    , _gmDump   :: Dump
+    , _gmHeap   :: GmHeap
+    , _gmEnv    :: Env
+    , _gmStats  :: Stats
+    }
+    deriving Show
+
+type Code = [Instr]
+type Stack = [Addr]
+type Dump = [(Code, Stack)]
+type Env = [(Key, Addr)]
+type GmHeap = Heap Node
+
+data Key = NameKey Name
+         | ConstrKey Tag Int
+         deriving (Show, Eq)
+
+-- >> [ref/Instr]
+data Instr = Unwind
+           | PushGlobal Name
+           | PushConstr Tag Int
+           | PushInt Int
+           | Push Int
+           | MkAp
+           | Slide Int
+           | Update Int
+           | Pop Int
+           | Alloc Int
+           | Eval
+           -- arith
+           | Neg | Add | Sub | Mul | Div
+           -- comparison
+           | Equals | Lesser | GreaterEq
+           | Pack Tag Int -- Pack Tag Arity
+           | CaseJump [(Tag, Code)]
+           | Split Int
+           | Print
+           | Halt
+           deriving (Show, Eq)
+-- << [ref/Instr]
+
+data Node = NNum Int
+          | NAp Addr Addr
+          -- NGlobal is the GM equivalent of NSupercomb. rather than storing a
+          -- template to be instantiated, NGlobal holds the global's arity and
+          -- the pre-compiled code :3
+          | NGlobal Int Code
+          | NInd Addr
+          | NUninitialised
+          | NConstr Tag [Addr] -- NConstr Tag Components
+          | NMarked Node
+          deriving (Show, Eq)
+
+-- TODO: log executed instructions
+data Stats = Stats
+    { _stsReductions     :: Int
+    , _stsPrimReductions :: Int
+    , _stsAllocations    :: Int
+    , _stsDereferences   :: Int
+    , _stsGCCycles       :: Int
+    }
+    deriving Show
+
+instance Default Stats where
+    def = Stats 0 0 0 0 0
+
+-- TODO: _gmGlobals should not have a setter
+makeLenses ''GmState
+makeLenses ''Stats
+

src/GM/Visual.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+module GM.Visual
+    ( renderGmState
+    )
+    where
+--------------------------------------------------------------------------------
+import Text.Printf
+import Data.Function            ((&), on)
+import Text.PrettyPrint         qualified as P
+
+import Diagrams.Prelude
+import Diagrams.Backend.Cairo
+
+import GM.Types
+import GM.Print
+--------------------------------------------------------------------------------
+
+renderGmState :: GmState -> IO ()
+renderGmState st = renderCairo path size (drawState st)
+    where
+        size = mkSizeSpec2D (Just 1000) (Just 1000)
+        path = printf "/tmp/render/%04d.png" n
+        n = st ^. gmStats . stsReductions
+
+drawState :: GmState -> Diagram B
+drawState = drawStack
+
+drawStack :: GmState -> Diagram B
+drawStack st = st & vcatOf (gmStack . each . to cell)
+    where
+        cell a = rect 10 5
+              <> text (printf "%04x: %s" a (P.render . showNodeAt st $ a))
+
+vcatOf :: (InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a, Monoid' a)
+       => Getting (Endo [a]) s a -> s -> a
+vcatOf l = vcat . (^.. l)
+
+newtype Vap a = Vap { getVap :: a }
+
+instance (InSpace V2 n a, Juxtaposable a, Semigroup a)
+         => Semigroup (Vap a) where (<>) = (Vap .) . ((===) `on` getVap)
+instance (InSpace V2 n a, Juxtaposable a, Monoid a)
+         => Monoid (Vap a) where mempty = Vap mempty
+
+newtype Hap a = Hap { getHap :: a }
+
+instance (InSpace V2 n a, Juxtaposable a, Semigroup a)
+         => Semigroup (Hap a) where (<>) = (Hap .) . ((|||) `on` getHap)
+instance (InSpace V2 n a, Juxtaposable a, Monoid a)
+         => Monoid (Hap a) where mempty = Hap mempty
+

visualisers/gmvis/.gitignore

@@ -1,21 +0,0 @@
-node_modules/
-public/js
-
-/target
-/checkouts
-/src/gen
-
-pom.xml
-pom.xml.asc
-*.iml
-*.jar
-*.log
-.shadow-cljs
-.idea
-.lein-*
-.nrepl-*
-.DS_Store
-
-.hgignore
-.hg/
-

visualisers/gmvis/package.json

@@ -1 +0,0 @@
-{"name":"gmvis","version":"0.0.1","private":true,"devDependencies":{"shadow-cljs":"2.28.3"},"dependencies":{"ace-builds":"^1.32.7","react":"^18.3.0","react-ace":"11.0.1","react-dom":"18.3.0","react-resplit":"^1.3.1","react-tooltip":"^5.26.3"}}

visualisers/gmvis/public/css/main.css

@@ -1,156 +0,0 @@
-@import "solarized-light.css";
-
-html, body, #mount
-{ height: 100%
-; width: 100%
-}
-
-body
-{ max-width: 90%
-; margin: 0 auto
-; padding: 0
-}
-
-.split-root
-{ height: 100%
-}
-
-.split-splitter
-{ width: 100%
-; height: 100%
-; background: #ccc
-}
-
-.split-pane
-{ margin: 0
-; padding: 0
-; overflow: scroll
-; display: flex
-; flex-direction: column
-}
-
-.pane-content
-{ margin: 0.5em
-}
-
-.view-header
-{ margin: 0
-; flex-shrink: 0
-}
-
-.stack-view
-{ display: flex
-; flex-direction: column
-; justify-content: space-between
-
-/* to fill the container */
-; flex-grow: 1
-}
-
-.stack-entry-container
-{ display: flex
-; flex-direction: column-reverse
-; align-content: flex-end
-}
-
-.stack-entry-container.even > .stack-entry:nth-of-type(even)
-{ background: #0000007f
-; color: white
-}
-
-.stack-entry-container.odd > .stack-entry:nth-of-type(odd)
-{ background: #0000007f
-; color: white
-}
-
-.stack-entry
-{ display: flex
-; flex-direction: row
-; justify-content: space-between
-; font-family: monospace;
-}
-
-.stack-entry-addr
-{ align-self: flex-end
-; opacity: 70%
-}
-
-.dump-view
-{}
-
-.heap-view
-{}
-
-/* .split-pane:has(> .code-view) */
-/* { overflow: hidden */
-/* } */
-
-.code-view
-{ display: flex
-; flex-direction: column
-; align-items: stretch
-; align-content: stretch
-; justify-content: flex-start
-; flex-grow: 1
-}
-
-.code-view .code-instr-container
-{ display: grid
-; overflow: scroll
-; flex-shrink: 4
-; min-height: 0
-}
-
-.code-view .instr
-{ font-family: monospace;
-}
-
-.code-instr-container.even > .instr:nth-of-type(even)
-{ background: #0000007f
-; color: white
-}
-
-.code-instr-container.odd > .instr:nth-of-type(odd)
-{ background: #0000007f
-; color: white
-}
-
-.code-view .code-button-container
-{ display: flex
-; flex-direction: row
-/* ; align-self: flex-end */
-; justify-content: space-between
-; margin-top: auto
-; flex-shrink: 0
-}
-
-.heap-view
-{
-}
-
-.heap-entry-container
-{ display: flex
-; flex-direction: column
-}
-
-.heap-entry-container > .heap-entry:nth-of-type(even)
-{ background: #0000007f
-; color: white
-}
-
-.heap-entry
-{ display: flex
-; flex-direction: row
-; justify-content: space-between
-; font-family: monospace;
-}
-
-.heap-entry-addr
-{ white-space: nowrap
-}
-
-/* .heap-entry-container.odd > .heap-entry:nth-of-type(odd) */
-/* { background: #0000007f */
-/* ; color: white */
-/* } */
-

visualisers/gmvis/public/css/solarized-light.css

@@ -1,304 +0,0 @@
-@import url(http://fonts.googleapis.com/css?family=Inconsolata);
-@import url(http://fonts.googleapis.com/css?family=PT+Sans);
-@import url(http://fonts.googleapis.com/css?family=PT+Sans+Narrow:400,700);
-article,
-aside,
-details,
-figcaption,
-figure,
-footer,
-header,
-hgroup,
-nav,
-section,
-summary {
-  display: block;
-}
-audio,
-canvas,
-video {
-  display: inline-block;
-}
-audio:not([controls]) {
-  display: none;
-  height: 0;
-}
-[hidden] {
-  display: none;
-}
-html {
-  font-family: sans-serif;
-  -webkit-text-size-adjust: 100%;
-  -ms-text-size-adjust: 100%;
-}
-body {
-  margin: 0;
-}
-a:focus {
-  outline: thin dotted;
-}
-a:active,
-a:hover {
-  outline: 0;
-}
-h1 {
-  font-size: 2em;
-}
-abbr[title] {
-  border-bottom: 1px dotted;
-}
-b,
-strong {
-  font-weight: bold;
-}
-dfn {
-  font-style: italic;
-}
-mark {
-  background: #ff0;
-  color: #000;
-}
-code,
-kbd,
-pre,
-samp {
-  font-family: monospace, serif;
-  font-size: 1em;
-}
-pre {
-  white-space: pre-wrap;
-  word-wrap: break-word;
-}
-q {
-  quotes: "\201C" "\201D" "\2018" "\2019";
-}
-small {
-  font-size: 80%;
-}
-sub,
-sup {
-  font-size: 75%;
-  line-height: 0;
-  position: relative;
-  vertical-align: baseline;
-}
-sup {
-  top: -0.5em;
-}
-sub {
-  bottom: -0.25em;
-}
-img {
-  border: 0;
-  width: 100%;
-}
-svg:not(:root) {
-  overflow: hidden;
-}
-figure {
-  margin: 0;
-}
-fieldset {
-  border: 1px solid #c0c0c0;
-  margin: 0 2px;
-  padding: 0.35em 0.625em 0.75em;
-}
-legend {
-  border: 0;
-  padding: 0;
-}
-button,
-input,
-select,
-textarea {
-  font-family: inherit;
-  font-size: 100%;
-  margin: 0;
-}
-button,
-input {
-  line-height: normal;
-}
-button,
-html input[type="button"],
-input[type="reset"],
-input[type="submit"] {
-  -webkit-appearance: button;
-  cursor: pointer;
-}
-button[disabled],
-input[disabled] {
-  cursor: default;
-}
-input[type="checkbox"],
-input[type="radio"] {
-  box-sizing: border-box;
-  padding: 0;
-}
-input[type="search"] {
-  -webkit-appearance: textfield;
-  -moz-box-sizing: content-box;
-  -webkit-box-sizing: content-box;
-  box-sizing: content-box;
-}
-input[type="search"]::-webkit-search-cancel-button,
-input[type="search"]::-webkit-search-decoration {
-  -webkit-appearance: none;
-}
-button::-moz-focus-inner,
-input::-moz-focus-inner {
-  border: 0;
-  padding: 0;
-}
-textarea {
-  overflow: auto;
-  vertical-align: top;
-}
-table {
-  border-collapse: collapse;
-  border-spacing: 0;
-}
-html {
-  font-family: 'PT Sans', sans-serif;
-}
-pre,
-code {
-  font-family: 'Inconsolata', sans-serif;
-}
-h1,
-h2,
-h3,
-h4,
-h5,
-h6 {
-  font-family: 'PT Sans Narrow', sans-serif;
-  font-weight: 700;
-}
-html {
-  background-color: #eee8d5;
-  color: #657b83;
-  margin: 1em;
-}
-body {
-  background-color: #fdf6e3;
-  margin: 0 auto;
-  max-width: 23cm;
-  border: 1pt solid #93a1a1;
-  padding: 1em;
-}
-code {
-  background-color: #eee8d5;
-  padding: 2px;
-}
-a {
-  color: #b58900;
-}
-a:visited {
-  color: #cb4b16;
-}
-a:hover {
-  color: #cb4b16;
-}
-h1 {
-  color: #d33682;
-}
-h2,
-h3,
-h4,
-h5,
-h6 {
-  color: #859900;
-}
-pre {
-  background-color: #fdf6e3;
-  color: #657b83;
-  border: 1pt solid #93a1a1;
-  padding: 1em;
-  box-shadow: 5pt 5pt 8pt #eee8d5;
-}
-pre code {
-  background-color: #fdf6e3;
-}
-h1 {
-  font-size: 2.8em;
-}
-h2 {
-  font-size: 2.4em;
-}
-h3 {
-  font-size: 1.8em;
-}
-h4 {
-  font-size: 1.4em;
-}
-h5 {
-  font-size: 1.3em;
-}
-h6 {
-  font-size: 1.15em;
-}
-.tag {
-  background-color: #eee8d5;
-  color: #d33682;
-  padding: 0 0.2em;
-}
-.todo,
-.next,
-.done {
-  color: #fdf6e3;
-  background-color: #dc322f;
-  padding: 0 0.2em;
-}
-.tag {
-  -webkit-border-radius: 0.35em;
-  -moz-border-radius: 0.35em;
-  border-radius: 0.35em;
-}
-.TODO {
-  -webkit-border-radius: 0.2em;
-  -moz-border-radius: 0.2em;
-  border-radius: 0.2em;
-  background-color: #2aa198;
-}
-.NEXT {
-  -webkit-border-radius: 0.2em;
-  -moz-border-radius: 0.2em;
-  border-radius: 0.2em;
-  background-color: #268bd2;
-}
-.ACTIVE {
-  -webkit-border-radius: 0.2em;
-  -moz-border-radius: 0.2em;
-  border-radius: 0.2em;
-  background-color: #268bd2;
-}
-.DONE {
-  -webkit-border-radius: 0.2em;
-  -moz-border-radius: 0.2em;
-  border-radius: 0.2em;
-  background-color: #859900;
-}
-.WAITING {
-  -webkit-border-radius: 0.2em;
-  -moz-border-radius: 0.2em;
-  border-radius: 0.2em;
-  background-color: #cb4b16;
-}
-.HOLD {
-  -webkit-border-radius: 0.2em;
-  -moz-border-radius: 0.2em;
-  border-radius: 0.2em;
-  background-color: #d33682;
-}
-.NOTE {
-  -webkit-border-radius: 0.2em;
-  -moz-border-radius: 0.2em;
-  border-radius: 0.2em;
-  background-color: #d33682;
-}
-.CANCELLED {
-  -webkit-border-radius: 0.2em;
-  -moz-border-radius: 0.2em;
-  border-radius: 0.2em;
-  background-color: #859900;
-}

visualisers/gmvis/public/index.html

@@ -1,19 +0,0 @@
-<!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>
-        <div id="mount">
-        </div>
-        <script src="/js/main.js"></script>
-    </body>
-</html>
-

visualisers/gmvis/shadow-cljs.edn

@@ -1,25 +0,0 @@
-{: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

@@ -1,63 +0,0 @@
-(ns main
-    (:require
-      [ui :as ui]
-      [wscljs.client :as ws]
-      [wscljs.format :as fmt]
-      [clojure.string :as str]
-      [cljs.core.match :refer-macros [match]]
-      [reagent.dom :as rdom]))
-
-;------------------------------------------------------------------------------;
-
-(def *rlp-socket nil)
-
-;------------------------------------------------------------------------------;
-
-(defn on-message [e]
-  (let [r (js->clj (js/JSON.parse (.-data e)) :keywordize-keys true)]
-    (match r
-           {:tag "Evaluated" :contents c}
-             (reset! ui/current-evaluation c)
-           :else
-             (js/console.warn "unrecognised response from rlp"))))
-
-(defn send [msg]
-  (ws/send *rlp-socket msg fmt/json))
-
-(defn on-open []
-  (println "socket opened")
-  (send {:command "evaluate"
-         :source (str/join "\n"
-                           ["fac n = case (==#) n 0 of"
-                            "  { <1> -> 1"
-                            "  ; <0> -> *# n (fac (-# n 1))"
-                            "  };"
-                            ""
-                            "main = fac 3;"])}))
-
-(defn init-rlp-socket []
-  (set! *rlp-socket (ws/create "ws://127.0.0.1:9002"
-                                {:on-message on-message
-                                 :on-open on-open
-                                 :on-close #(println "socket closed")
-                                 :on-error #(println "error: " %)})))
-
-;; this is called before any code is reloaded
-(defn ^:dev/before-load stop []
-  (ws/close *rlp-socket)
-  (js/console.log "stop"))
-
-;; start is called by init and after code reloading finishes
-(defn ^:dev/after-load start []
-  (js/console.log "start")
-  (rdom/render [ui/Main]
-               (js/document.getElementById "mount"))
-  (init-rlp-socket))
-
-;; 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))
-

visualisers/gmvis/src/ui.cljs

@@ -1,230 +0,0 @@
-(ns ui
-    (:require
-      [clojure.pprint :refer (cl-format)]
-      [wscljs.client :as ws]
-      [wscljs.format :as fmt]
-      [clojure.string :as str]
-      [cljs.core.match :refer-macros [match]]
-      ["react-ace$default" :as AceEditor]
-      ["react-resplit" :refer (Resplit)]
-      ["ace-builds/src-noconflict/mode-haskell"]
-      ["ace-builds/src-noconflict/theme-solarized_light"]
-      ["ace-builds/src-noconflict/keybinding-vim"]
-      [reagent.core :as r]
-      [reagent.dom :as rdom]))
-
-;------------------------------------------------------------------------------;
-
-(def current-evaluation (r/atom []))
-; (def current-index (r/atom 5))
-(defonce current-index (r/atom 0))
-
-(def +split-width+ "4px")
-
-;------------------------------------------------------------------------------;
-
-(defn gen-key []
-  (js/self.crypto.randomUUID))
-
-(defn add-key [e]
-  (let [uuid (js/self.crypto.randomUUID)]
-    (match e
-      [tag props & children] (concat [tag (assoc props :key uuid)] children))))
-
-;------------------------------------------------------------------------------;
-
-(declare ppr-node)
-(declare ppr-node*)
-
-;------------------------------------------------------------------------------;
-
-(defn Root [props & children]
-  [:> Resplit.Root (assoc props :class "split-root")
-   [:<> children]])
-
-(defn Pane [props & children]
-  [:> Resplit.Pane (assoc props :class "split-pane")
-   [:<> children]])
-
-(defn Splitter [props & children]
-  [:> Resplit.Splitter (assoc props :class "split-splitter")
-   [:<> children]])
-
-(defn Header [text]
-  [:h5 {:class "view-header"}
-   text])
-
-;------------------------------------------------------------------------------;
-
-(defn Dump []
-  [:div {:class "pane-content dump-view"}
-   [Header "Dump"]])
-
-;------------------------------------------------------------------------------;
-
-(defn HeapEntry [heap addr-key]
-  (let [addr (js/Number (name addr-key))]
-    [:div {:class "heap-entry"
-           :key (gen-key)}
-     [:div {:class "heap-entry-addr"}
-      (cl-format nil "&~3D" addr)]
-     [:div {:class "heap-entry-node"}
-      (ppr-node heap addr)]]))
-
-(defn Heap [heap]
-  [:div {:class "pane-content heap-view"}
-   [Header "Heap"]
-   [:div {:class "heap-entry-container"}
-    [:<> (map (partial HeapEntry heap) (keys heap))]]])
-
-;------------------------------------------------------------------------------;
-
-(defn deref-addr [heap addr]
-  (get heap
-       (keyword (str addr))
-       nil))
-
-(defn words [& ws]
-  (->> ws
-       (map str)
-       (str/join \space)))
-
-(defn maybe-parens [c s]
-  (if c
-      (str "(" s ")")
-      s))
-
-(def app-prec 10)
-(def app-prec+1 11)
-(def app-prec-1 9)
-
-(defn ppr-list [heap addrs]
-  (match addrs
-         [] "[]"
-         _ (str "[" (->> addrs
-                         (map (partial ppr-node* 0 heap))
-                         (interpose ", ")
-                         (concat)) "]")))
-
-(defn ppr-node* [p heap addr]
-  (match (deref-addr heap addr)
-    {:tag "NGlobal" :contents [arity code]}
-    (maybe-parens (> p 0)
-                  (words "Global" arity "<code>"))
-
-    {:tag "NNum" :contents k}
-    (maybe-parens (> p 0)
-                  (words "Number" k))
-
-    {:tag "NAp" :contents [f x]}
-    (maybe-parens (> p app-prec)
-                  (words (ppr-node* app-prec heap f)
-                         "@"
-                         (ppr-node* app-prec+1 heap x)))
-
-    {:tag "NConstr" :contents [tag as]}
-    (maybe-parens (> p 0)
-                  (words "Constructor"
-                         tag
-                         (ppr-list heap as)))
-
-    {:tag "NInd" :contents addr*}
-    (maybe-parens (> p 0)
-                  (words "Indirection"
-                         (ppr-node* app-prec+1 heap addr*)))
-
-    {:tag "NUninitialised"}
-    "<Uninitialised>"
-
-    {:tag "NMarked" :contents node*}
-    (maybe-parens (> p 0)
-                  (words "Marked"
-                         "<node>"))
-    
-    nil (str "<broken pointer: &" addr ">")
-
-    a (str "other" a)))
-
-(defn ppr-node [heap addr]
-  (ppr-node* 0 heap addr))
-
-(defn StackEntry [heap addr]
-  [:div {:class "stack-entry"
-         :key (gen-key)}
-   (ppr-node heap addr)
-   [:div {:class "stack-entry-addr"}
-    (str "&" addr)]])
-
-(defn StackEntryContainer [children]
-  [:div {:class "stack-entry-container even"}
-   [:<> children]])
-
-(defn Stack [heap s]
-  [:div {:class "pane-content stack-view"}
-   [Header "Stack"]
-   [StackEntryContainer (map (partial StackEntry heap) (reverse s))]])
-
-#_ (swap! current-index #(+ % 1))
-#_ (swap! current-index #(- % 1))
-
-;------------------------------------------------------------------------------;
-
-(defn ppr-instr [{op :tag c :contents}]
-  (match op
-    "CaseJump" (words op "<cases>")
-    _ (words op c)))
-
-(defn Instr [instr]
-  [:code {:class "instr"
-          :key (gen-key)}
-   (ppr-instr instr)])
-
-(defn CodeButtons []
-  [:div {:class "code-button-container"}
-   [:button {:onClick #(swap! current-index dec)}
-    "<"]
-   [:code @current-index]
-   [:button {:onClick #(swap! current-index inc)}
-    ">"]])
-
-(defn CodeInstrContainer [children]
-  [:div {:class (if (even? (count children))
-                    "code-instr-container even"
-                    "code-instr-container odd")}
-   [:<> children]])
-
-(defn Code [code]
-  [:div {:class "pane-content code-view"}
-   [Header "Next instructions"]
-   [CodeInstrContainer (map Instr code)]
-   [CodeButtons]])
-
-;------------------------------------------------------------------------------;
-
-(defn GM [{code :_gmCode
-           stack :_gmStack
-           heap :_gmHeap}]
-  [Root {:direction "horizontal"}
-   [Pane {:order 0 :initialSize "0.333fr"}
-    [Heap heap]]
-   [Splitter {:order 1 :size +split-width+}]
-   [Pane {:order 2 :initialSize "0.333fr"}
-    [Root {:direction "vertical"}
-     [Pane {:order 0 :initialSize "0.5fr"}
-      [Stack heap stack]]
-     [Splitter {:order 1 :size +split-width+}]
-     [Pane {:order 2 :initialSize "0.5fr"}
-      [Code code]]]]
-   [Splitter {:order 3 :size +split-width+}]
-   [Pane {:order 4 :initialSize "0.333fr"}
-    [Dump]]])
-
-(defn Main []
-  (prn @current-evaluation)
-  (prn @current-index)
-  (if-let [st (nth @current-evaluation
-                   @current-index
-                   nil)]
-    [GM st]
-    [:h1 "no evaluation"]))
-