heap

i still love you microlens..

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

README.md

@@ -26,12 +26,14 @@ $ cabal test --test-show-details=direct
 #### TLDR
 
 ```sh
-# Compile and evaluate examples/factorial.cr, with evaluation info dumped to stderr
-$ rlpc -ddump-eval examples/factorial.cr
+# Compile and evaluate examples/rlp/QuickSort.rl
+$ rlpc examples/QuickSort.rl
 # Compile and evaluate t.cr, with evaluation info dumped to t.log
 $ rlpc -ddump-eval -l t.log t.cr
 # Compile and evaluate t.rl, dumping the desugared Core
 $ rlpc -ddump-desugared t.rl
+# Compile and evaluate t.rl with all compiler messages enabled
+$ rlpc -dALL t.rl
 ```
 
 #### Options
@@ -126,7 +128,7 @@ parsing remains.
     - [x] Garbage Collection
 - [ ] Stable documentation for the evaluation model
 
-### February Release Plan
+### ~~February Release Plan~~
 - [x] Beta rl' to Core
 - [x] UX improvements
     - [x] Actual compiler errors -- no more unexceptional `error` calls
@@ -134,12 +136,14 @@ parsing remains.
     - [x] Annotate the AST with token positions for errors (NOTE: As of Feb. 1,
       this has been done, but the locational info is not yet used in error messages)
 - [x] Compiler architecture diagram
-- [ ] More examples
+- [x] More examples
 
 ### March Release Plan
 - [ ] Tests
     - [ ] rl' parser
     - [ ] rl' lexer
+- [ ] Ditch TTG in favour of a simpler AST focusing on extendability via Fix, Free, 
+  Cofree, etc. rather than boilerplate-heavy type families
 
 ### Indefinite Release Plan
 
@@ -150,8 +154,6 @@ than the other release plans.
     - [ ] Complete all TODOs
     - [ ] Replace mtl with effectful
 - [ ] rl' type-checker
-- [ ] Ditch TTG in favour of a simpler AST focusing on extendability via Fix, Free, 
-  Cofree, etc. rather than boilerplate-heavy type families
 - [ ] Stable rl' to Core
 - [ ] Core polish
     - [ ] Better, stable parser
@@ -160,3 +162,4 @@ than the other release plans.
     - [ ] Less hacky pragmas
 - [ ] Choose a target. LLVM, JS, C, and WASM are currently top contenders
 - [ ] https://proglangdesign.net/wiki/challenges
+

app.old/CoreDriver.hs

@@ -0,0 +1,24 @@
+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

@@ -0,0 +1,140 @@
+{-# 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

@@ -0,0 +1,19 @@
+{-# 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

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

app/Main.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Main where
 ----------------------------------------------------------------------------------
+import Control.Lens             hiding (argument)
 import Compiler.RLPC
 import Compiler.RlpcError
 import Control.Exception
@@ -19,10 +20,11 @@ import System.Exit              (exitSuccess)
 import Core
 import TI
 import GM
-import Lens.Micro.Platform
+import Control.Lens.Combinators hiding (argument)
 
 import CoreDriver               qualified
 import RlpDriver                qualified
+import Server                   qualified
 ----------------------------------------------------------------------------------
 
 optParser :: ParserInfo RLPCOptions
@@ -74,7 +76,11 @@ options = RLPCOptions
         <> metavar "rlp|core"
         <> help "the language to be compiled -- see README"
         )
-    <*> some (argument str $ metavar "FILES...")
+    <*> switch
+        (  long "server"
+        <> short 's'
+        )
+    <*> many (argument str $ metavar "FILES...")
     where
         infixr 9 #
         f # x = f x
@@ -107,7 +113,9 @@ mmany v = liftA2 (<>) v (mmany v)
 main :: IO ()
 main = do
     opts <- execParser optParser
-    void $ evalRLPCIO opts dispatch
+    if opts ^. rlpcServer
+    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 >=> desugarRlpProgR >=> evalProgR)
+    withSource f (parseRlpProgR >=> undefined >=> desugarRlpProgR >=> evalProgR)
 

app/Server.hs

@@ -0,0 +1,92 @@
+{-# 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
+

doc/src/commentary/gm.rst

@@ -63,52 +63,13 @@ an assembly target. The goal of our new G-Machine is to compile a *linear
 sequence of instructions* which, **when executed**, build up a graph
 representing the code.
 
-**************************
-Trees and Vines, in Theory
-**************************
-
-Rather than instantiating an expression at runtime -- traversing the AST and
-building a graph -- we want to compile all expressions at compile-time,
-generating a linear sequence of instructions which may be executed to build the
-graph.
-
-**************************
-Evaluation: Slurping Vines
-**************************
-
-WIP.
-
-Laziness
---------
-
-WIP.
-
-* Instead of :code:`Slide (n+1); Unwind`, do :code:`Update n; Pop n; Unwind`
-
-****************************
-Compilation: Squashing Trees
-****************************
-
-WIP.
-
-Notice that we do not keep a (local) environment at run-time. The environment
-only exists at compile-time to map local names to stack indices. When compiling
-a supercombinator, the arguments are enumerated from zero (the top of the
-stack), and passed to :code:`compileR` as an environment.
+*************
+The G-Machine
+*************
 
 .. literalinclude:: /../../src/GM.hs
    :dedent:
-   :start-after: -- >> [ref/compileSc]
-   :end-before: -- << [ref/compileSc]
-   :caption: src/GM.hs
-
-Of course, variables being indexed relative to the top of the stack means that
-they will become inaccurate the moment we push or pop the stack a single time.
-The way around this is quite simple: simply offset the stack when w
-
-.. literalinclude:: /../../src/GM.hs
-   :dedent:
-   :start-after: -- >> [ref/compileC]
-   :end-before: -- << [ref/compileC]
+   :start-after: -- >> [ref/Instr]
+   :end-before: -- << [ref/Instr]
    :caption: src/GM.hs
 

doc/src/commentary/layout-lexing.rst

@@ -62,159 +62,6 @@ braces and semicolons. In developing our *layout* rules, we will follow in the
 pattern of translating the whitespace-sensitive source language to an explicitly
 sectioned language.
 
-But What About Haskell?
-***********************
-
-Parsing Haskell -- and thus rl' -- is only slightly more complex than Python,
-but the design is certainly more sensitive. 
-
-.. code-block:: haskell
-
-   -- line folds
-   something = this is a
-       single expression
-
-   -- an extremely common style found in haskell
-   data Some = Data
-       { is    :: Presented
-       , in    :: This
-       , silly :: Style
-       }
-
-   -- another style oddity
-   -- note that this is not a single
-   -- continued line! `look at`,
-   -- `this odd`, and `alignment` are all
-   -- discrete items!
-   anotherThing = do look at
-                     this odd
-                     alignment
-
-But enough fear, lets actually think about implementation. Firstly, some
-formality: what do we mean when we say layout? We will define layout as the
-rules we apply to an implicitly-sectioned language in order to yield one that is
-explicitly-sectioned. We will also define indentation of a lexeme as the column
-number of its first character.
-
-Thankfully for us, our entry point is quite clear; layouts only appear after a
-select few keywords, (with a minor exception; TODO: elaborate) being :code:`let`
-(followed by supercombinators), :code:`where` (followed by supercombinators),
-:code:`do` (followed by expressions), and :code:`of` (followed by alternatives)
-(TODO: all of these terms need linked glossary entries). In order to manage the
-cascade of layout contexts, our lexer will record a stack for which each element
-is either :math:`\varnothing`, denoting an explicit layout written with braces
-and semicolons, or a :math:`\langle n \rangle`, denoting an implicitly laid-out
-layout where the start of each item belonging to the layout is indented
-:math:`n` columns.
-
-.. code-block:: haskell
-
-    -- layout stack: []
-    module M where -- layout stack: [∅]
-
-    f x = let -- layout keyword; remember indentation of next token
-              y = w * w -- layout stack: [∅, <10>]
-              w = x + x
-              -- layout ends here
-          in do -- layout keyword; next token is a brace!
-              { -- layout stack: [∅]
-                  print y;
-                  print x;
-              }
-
-Finally, we also need the concept of "virtual" brace tokens, which as far as
-we're concerned at this moment are exactly like normal brace tokens, except
-implicitly inserted by the compiler. With the presented ideas in mind, we may
-begin to introduce a small set of informal rules describing the lexer's handling
-of layouts, the first being:
-
-1. If a layout keyword is followed by the token '{', push :math:`\varnothing`
-   onto the layout context stack. Otherwise, push :math:`\langle n \rangle` onto
-   the layout context stack where :math:`n` is the indentation of the token
-   following the layout keyword. Additionally, the lexer is to insert a virtual
-   opening brace after the token representing the layout keyword.
-
-Consider the following observations from that previous code sample:
-
-* Function definitions should belong to a layout, each of which may start at
-  column 1.
-
-* A layout can enclose multiple bodies, as seen in the :code:`let`-bindings and
-  the :code:`do`-expression.
-
-* Semicolons should *terminate* items, rather than *separate* them.
-
-Our current focus is the semicolons. In an implicit layout, items are on
-separate lines each aligned with the previous. A naïve implementation would be
-to insert the semicolon token when the EOL is reached, but this proves unideal
-when you consider the alignment requirement. In our implementation, our lexer
-will wait until the first token on a new line is reached, then compare
-indentation and insert a semicolon if appropriate. This comparison -- the
-nondescript measurement of "more, less, or equal indentation" rather than a
-numeric value -- is referred to as *offside* by myself internally and the
-Haskell report describing layouts. We informally formalise this rule as follows:
-
-2. When the first token on a line is preceeded only by whitespace, if the
-   token's first grapheme resides on a column number :math:`m` equal to the
-   indentation level of the enclosing context -- i.e. the :math:`\langle n
-   \rangle` on top of the layout stack. Should no such context exist on the
-   stack, assume :math:`m > n`.
-
-We have an idea of how to begin layouts, delimit the enclosed items, and last
-we'll need to end layouts. This is where the distinction between virtual and
-non-virtual brace tokens comes into play. The lexer needs only partial concern
-towards closing layouts; the complete responsibility is shared with the parser.
-This will be elaborated on in the next section. For now, we will be content with
-naïvely inserting a virtual closing brace when a token is indented right of the
-layout.
-
-3. Under the same conditions as rule 2., when :math:`m < n` the lexer shall
-   insert a virtual closing brace and pop the layout stack.
-
-This rule covers some cases including the top-level, however, consider
-tokenising the :code:`in` in a :code:`let`-expression. If our lexical analysis
-framework only allows for lexing a single token at a time, we cannot return both
-a virtual right-brace and a :code:`in`. Under this model, the lexer may simply
-pop the layout stack and return the :code:`in` token. As we'll see in the next
-section, as long as the lexer keeps track of its own context (i.e. the stack),
-the parser will cope just fine without the virtual end-brace.
-
-Parsing Lonely Braces
-*********************
-
-When viewed in the abstract, parsing and tokenising are near-identical tasks yet
-the two are very often decomposed into discrete systems with very different
-implementations. Lexers operate on streams of text and tokens, while parsers
-are typically far less linear, using a parse stack or recursing top-down. A
-big reason for this separation is state management: the parser aims to be as
-context-free as possible, while the lexer tends to burden the necessary
-statefulness. Still, the nature of a stream-oriented lexer makes backtracking
-difficult and quite inelegant.
-
-However, simply declaring a parse error to be not an error at all
-counterintuitively proves to be an elegant solution our layout problem which
-minimises backtracking and state in both the lexer and the parser. Consider the
-following definitions found in rlp's BNF:
-
-.. productionlist:: rlp
-   VOpen   : `vopen`
-   VClose  : `vclose` | `error`
-
-A parse error is recovered and treated as a closing brace. Another point of note
-in the BNF is the difference between virtual and non-virtual braces (TODO: i
-don't like that the BNF is formatted without newlines :/):
-
-.. productionlist:: rlp
-   LetExpr : `let` VOpen Bindings VClose `in` Expr | `let` `{` Bindings `}` `in` Expr
-
-This ensures that non-virtual braces are closed explicitly.
-
-This set of rules is adequete enough to satisfy our basic concerns about line
-continations and layout lists. For a more pedantic description of the layout
-system, see `chapter 10
-<https://www.haskell.org/onlinereport/haskell2010/haskellch10.html>`_ of the
-2010 Haskell Report, which I heavily referenced here.
-
 References
 ----------
 

examples/rlp/QuickSort.rl

@@ -0,0 +1,31 @@
+data List a = Nil | Cons a (List a)
+
+data Bool = False | True
+
+filter :: (a -> Bool) -> List a -> List a
+filter p l = case l of
+    Nil -> Nil
+    Cons a as ->
+        case p a of
+            True -> Cons a (filter p as)
+            False -> filter p as
+
+append :: List a -> List a -> List a
+append p q = case p of
+    Nil -> q
+    Cons a as -> Cons a (append as q)
+
+qsort :: List Int# -> List Int#
+qsort l = case l of
+    Nil -> Nil
+    Cons a as ->
+        let lesser = filter (>=# a) as
+            greater = filter (<# a) as
+        in append (append (qsort lesser) (Cons a Nil)) (qsort greater)
+
+list :: List Int#
+list = Cons 9 (Cons 2 (Cons 3 (Cons 2
+            (Cons 5 (Cons 2 (Cons 12 (Cons 89 Nil)))))))
+
+main = print# (qsort list)
+

examples/rlp/SumList.rl

@@ -7,5 +7,5 @@ foldr f z l = case l of
 
 list = Cons 1 (Cons 2 (Cons 3 Nil))
 
-main = foldr (+#) 0 list
+main = print# (foldr (+#) 0 list)
 

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

@@ -50,39 +50,37 @@ library
     build-tool-depends: happy:happy, alex:alex
 
     -- other-extensions:
-    build-depends:    base >=4.17 && <4.20
+    build-depends:    base >=4.17 && <4.21
                     -- required for happy
                     , array >= 0.5.5 && < 0.6
                     , containers >= 0.6.7 && < 0.7
-                    , template-haskell >= 2.20.0 && < 2.21
+                    , template-haskell >= 2.20.0 && < 2.23
                     , 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.1
-                    , megaparsec >= 9.6.1 && < 9.7
-                    , microlens >= 0.4.13 && < 0.5
-                    , microlens-mtl >= 0.2.0 && < 0.3
-                    , microlens-platform >= 0.4.3 && < 0.5
-                    , microlens-th >= 0.4.3 && < 0.5
+                    , text >= 2.0.2 && < 2.3
                     , unordered-containers >= 0.2.20 && < 0.3
                     , recursion-schemes >= 5.2.2 && < 5.3
                     , data-fix >= 0.3.2 && < 0.4
                     , utf8-string >= 1.0.2 && < 1.1
-                    , extra >= 1.7.0 && < 2
-                    , semigroupoids
-                    , comonad
-                    , lens
-                    , text-ansi
-                    , microlens-pro ^>=0.2.0
+                    , extra >= 1.7.0 && <2
+                    , semigroupoids >=6.0 && <6.1
+                    , comonad >=5.0.0 && <6
+                    , lens >=5.2.3 && <6.0
+                    , text-ansi >=0.2.0 && <0.4
                     , effectful-core ^>=2.3.0.0
                     , deriving-compat ^>=0.6.0
                     , these >=0.2 && <2.0
+                    , aeson
 
     hs-source-dirs:   src
     default-language: GHC2021
 
+    ghc-options:
+        -fdefer-typed-holes
+
     default-extensions:
         OverloadedStrings
         TypeFamilies
@@ -92,20 +90,24 @@ 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
                  , optparse-applicative >= 0.18.1 && < 0.19
-                 , microlens-platform
                  , mtl >= 2.3.1 && < 2.4
                  , unordered-containers >= 0.2.20 && < 0.3
-                 , text >= 2.0.2 && < 2.1
+                 , lens >=5.2.3 && <6.0
+                 , text >= 2.0.2 && < 2.3
+                 , aeson
+                 , websockets
 
     hs-source-dirs:   app
     default-language: GHC2021

src/Compiler/JustRun.hs

@@ -11,6 +11,8 @@ module Compiler.JustRun
     ( justLexCore
     , justParseCore
     , justTypeCheckCore
+    , justHdbg
+    , justLexParseGmEval
     )
     where
 ----------------------------------------------------------------------------------
@@ -20,14 +22,22 @@ import Core.HindleyMilner
 import Core.Syntax                      (Program')
 import Compiler.RLPC
 import Control.Arrow                    ((>>>))
-import Control.Monad                    ((>=>))
+import Control.Monad                    ((>=>), void)
 import Control.Comonad
 import Control.Lens
 import Data.Text                        qualified as T
 import Data.Function                    ((&))
+import System.IO
 import GM
+import Rlp.Parse
+import Rlp2Core
 ----------------------------------------------------------------------------------
 
+justHdbg :: String -> IO GmState
+justHdbg s = do
+    p <- evalRLPCIO def (parseRlpProgR >=> desugarRlpProgR $ T.pack s)
+    withFile "/tmp/t.log" WriteMode $ hdbgProg p
+
 justLexCore :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
 justLexCore s = lexCoreR (T.pack s)
               & mapped . each %~ extract
@@ -38,6 +48,10 @@ 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,6 +26,7 @@ module Compiler.RLPC
     , DebugFlag(..), CompilerFlag(..)
     -- ** Lenses
     , rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage
+    , rlpcServer
     -- * Misc. MTL-style functions
     , liftErrorful, hoistRlpcT
     -- * Misc. Rlpc Monad -related types
@@ -64,8 +65,8 @@ import Data.Text.IO             qualified as T
 import System.IO
 import Text.ANSI                qualified as Ansi
 import Text.PrettyPrint         hiding ((<>))
-import Lens.Micro.Platform
-import Lens.Micro.Platform.Internal
+import Control.Lens
+import Data.Text.Lens           (packed, unpacked, IsText)
 import System.Exit
 ----------------------------------------------------------------------------------
 
@@ -120,6 +121,7 @@ data RLPCOptions = RLPCOptions
     , _rlpcEvaluator   :: Evaluator
     , _rlpcHeapTrigger :: Int
     , _rlpcLanguage    :: Maybe Language
+    , _rlpcServer      :: Bool
     , _rlpcInputFiles  :: [FilePath]
     }
     deriving Show
@@ -141,6 +143,7 @@ instance Default RLPCOptions where
         , _rlpcHeapTrigger = 200
         , _rlpcInputFiles = []
         , _rlpcLanguage = Nothing
+        , _rlpcServer = False
         }
 
 -- debug flags are passed with -dFLAG

src/Compiler/RlpcError.hs

@@ -21,9 +21,11 @@ import Control.Monad.Errorful
 import Data.Text                (Text)
 import Data.Text                qualified as T
 import GHC.Exts                 (IsString(..))
-import Lens.Micro.Platform
-import Lens.Micro.Platform.Internal
+import Control.Lens
 import Compiler.Types
+import GHC.Generics             ( Generic, Generic1
+                                , Generically(..), Generically1(..) )
+import Data.Aeson               (ToJSON1(..), ToJSON(..))
 ----------------------------------------------------------------------------------
 
 data MsgEnvelope e = MsgEnvelope
@@ -31,10 +33,18 @@ data MsgEnvelope e = MsgEnvelope
    , _msgDiagnostic  :: e
    , _msgSeverity    :: Severity
    }
-   deriving (Functor, Show)
+   deriving (Functor, Show, Generic, Generic1)
 
 newtype RlpcError = Text [Text]
-               deriving Show
+               deriving (Show, Generic)
+
+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
@@ -48,7 +58,10 @@ instance IsRlpcError RlpcError where
 data Severity = SevWarning
               | SevError
               | SevDebug Text -- ^ Tag
-              deriving Show
+              deriving (Show, Generic)
+
+deriving via Generically Severity
+    instance ToJSON Severity
 
 makeLenses ''MsgEnvelope
 

src/Compiler/Types.hs

@@ -20,6 +20,9 @@ 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)
@@ -47,7 +50,10 @@ data SrcSpan = SrcSpan
     !Int -- ^ Column
     !Int -- ^ Absolute
     !Int -- ^ Length
-    deriving (Show, Lift)
+    deriving (Show, Lift, Generic)
+
+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/Control/Monad/Errorful.hs

@@ -20,7 +20,7 @@ import Data.Functor.Identity
 import Data.Coerce
 import Data.HashSet                 (HashSet)
 import Data.HashSet                 qualified as H
-import Lens.Micro
+import Control.Lens
 ----------------------------------------------------------------------------------
 
 newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Maybe a, [e]) }

src/Core/HindleyMilner.hs

@@ -16,9 +16,7 @@ module Core.HindleyMilner
     )
     where
 ----------------------------------------------------------------------------------
-import Lens.Micro
-import Lens.Micro.Mtl
-import Lens.Micro.Platform
+import Control.Lens             hiding (Context', Context)
 import Data.Maybe               (fromMaybe)
 import Data.Text                qualified as T
 import Data.Pretty              (rpretty)

src/Core/Lex.x

@@ -26,8 +26,7 @@ import Compiler.RLPC
 import Compiler.Types
 -- TODO: unify Located definitions
 import Compiler.RlpcError
-import Lens.Micro
-import Lens.Micro.TH
+import Control.Lens
 }
 
 %wrapper "monad-strict-text"

src/Core/Parse.y

@@ -24,7 +24,7 @@ import Core.Syntax
 import Core.Lex
 import Compiler.RLPC
 import Control.Monad
-import Lens.Micro
+import Control.Lens         hiding (snoc)
 import Data.Default.Class   (def)
 import Data.Hashable        (Hashable)
 import Data.List.Extra

src/Core/Syntax.hs

@@ -60,8 +60,6 @@ import Data.Bifoldable              (bifoldr)
 import GHC.Generics                 (Generic, Generically(..))
 -- Lift instances for the Core quasiquoters
 import Language.Haskell.TH.Syntax   (Lift)
--- import Lens.Micro.TH                (makeLenses)
--- import Lens.Micro
 import Control.Lens
 ----------------------------------------------------------------------------------
 

src/Core/Utils.hs

@@ -13,7 +13,7 @@ import Data.Functor.Foldable
 import Data.Set                     (Set)
 import Data.Set                     qualified as S
 import Core.Syntax
-import Lens.Micro
+import Control.Lens
 import GHC.Exts                     (IsList(..))
 ----------------------------------------------------------------------------------
 

src/Core2Core.hs

@@ -24,7 +24,6 @@ import Numeric                  (showHex)
 
 import Data.Pretty
 import Compiler.RLPC
--- import Lens.Micro.Platform
 import Control.Lens
 import Core.Syntax
 import Core.Utils
@@ -70,7 +69,7 @@ tagData p = let ?dt = p ^. programDataTags
     go x                = embed x
 
     tagAlts :: (?dt :: HashMap Name (Tag, Int)) => Alter' -> Alter'
-    tagAlts (Alter (AltData c) bs e) = Alter (AltTag tag) bs e
+    tagAlts (Alter (AltData c) bs e) = Alter (AltTag tag) bs (cata go e)
         where tag = case ?dt ^. at c of
                 Just (t,_) -> t
                 -- TODO: errorful

src/Data/Heap.hs

@@ -28,10 +28,27 @@ 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
+
+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

@@ -9,11 +9,17 @@ module GM
     ( hdbgProg
     , evalProg
     , evalProgR
+    , GmState(..)
+    , gmCode, gmStack, gmDump, gmHeap, gmEnv, gmStats
     , Node(..)
+    , showState
     , gmEvalProg
+    , Stats(..)
     , finalStateOf
     , resultOf
     , resultOfExpr
+    , compile
+    , eval
     )
     where
 ----------------------------------------------------------------------------------
@@ -22,11 +28,8 @@ import Data.List                    (mapAccumL)
 import Data.Maybe                   (fromMaybe, mapMaybe)
 import Data.Monoid                  (Endo(..))
 import Data.Tuple                   (swap)
-import Lens.Micro
-import Lens.Micro.Extras            (view)
-import Lens.Micro.TH
-import Lens.Micro.Platform          (packed, unpacked)
-import Lens.Micro.Platform.Internal (IsText(..))
+import Control.Lens
+import Data.Text.Lens               (IsText, packed, unpacked)
 import Text.Printf
 import Text.PrettyPrint             hiding ((<>))
 import Text.PrettyPrint.HughesPJ    (maybeParens)
@@ -41,6 +44,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
 ----------------------------------------------------------------------------------
@@ -77,7 +86,7 @@ data GmState = GmState
     , _gmEnv    :: Env
     , _gmStats  :: Stats
     }
-    deriving Show
+    deriving (Show, Generic)
 
 type Code = [Instr]
 type Stack = [Addr]
@@ -87,8 +96,9 @@ type GmHeap = Heap Node
 
 data Key = NameKey Name
          | ConstrKey Tag Int
-         deriving (Show, Eq)
+         deriving (Show, Eq, Generic)
 
+-- >> [ref/Instr]
 data Instr = Unwind
            | PushGlobal Name
            | PushConstr Tag Int
@@ -103,13 +113,14 @@ data Instr = Unwind
            -- arith
            | Neg | Add | Sub | Mul | Div
            -- comparison
-           | Equals | Lesser
+           | Equals | Lesser | GreaterEq
            | Pack Tag Int -- Pack Tag Arity
            | CaseJump [(Tag, Code)]
            | Split Int
            | Print
            | Halt
-           deriving (Show, Eq)
+           deriving (Show, Eq, Generic)
+-- << [ref/Instr]
 
 data Node = NNum Int
           | NAp Addr Addr
@@ -121,7 +132,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
@@ -131,7 +142,7 @@ data Stats = Stats
     , _stsDereferences   :: Int
     , _stsGCCycles       :: Int
     }
-    deriving Show
+    deriving (Show, Generic)
 
 instance Default Stats where
     def = Stats 0 0 0 0 0
@@ -152,7 +163,7 @@ evalProg p = res <&> (,sts)
         resAddr = final ^. gmStack ^? _head
         res = resAddr >>= flip hLookup h
 
-hdbgProg :: Program' -> Handle -> IO (Node, Stats)
+hdbgProg :: Program' -> Handle -> IO GmState
 hdbgProg p hio = do
     (renderOut . showState) `traverse_` states
     -- TODO: i'd like the statistics to be at the top of the file, but `sts`
@@ -160,7 +171,7 @@ hdbgProg p hio = do
     -- *can't* get partial logs in the case of a crash. this is in opposition to
     -- the above traversal which *will* produce partial logs. i love laziness :3
     renderOut . showStats $ sts
-    pure (res, sts)
+    pure final
     where
         renderOut r = hPutStrLn hio $ render r ++ "\n"
 
@@ -175,18 +186,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
@@ -228,6 +269,7 @@ step st = case head (st ^. gmCode) of
     Div            -> divI
     Equals         -> equalsI
     Lesser         -> lesserI
+    GreaterEq      -> greaterEqI
     Split      n   -> splitI        n
     Pack       t n -> packI       t n
     CaseJump    as -> caseJumpI    as
@@ -451,9 +493,10 @@ step st = case head (st ^. gmCode) of
         mulI = primitive2 boxInt unboxInt (*) st
         divI = primitive2 boxInt unboxInt div st
 
-        lesserI, equalsI :: GmState
+        lesserI, greaterEqI, equalsI :: GmState
         equalsI = primitive2 boxBool unboxInt (==) st
         lesserI = primitive2 boxBool unboxInt (<) st
+        greaterEqI = primitive2 boxBool unboxInt (>=) st
 
         splitI :: Int -> GmState
         splitI n = st
@@ -638,8 +681,9 @@ compiledPrims =
     , binop "/#" Div
     , binop "==#" Equals
     , binop "<#" Lesser
+    , binop ">=#" GreaterEq
     , ("print#", 1, [ Push 0, Eval, Print, Pack tag_Unit_unit 0, Update 1, Pop 1
-                    , Unwind])
+                    , Unwind ])
     ]
     where
         unop k i = (k, 1, [Push 0, Eval, i, Update 1, Pop 1, Unwind])
@@ -743,14 +787,12 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
                 mconcat binders <> compileE g' e <> [Slide d]
             where
                 d = length bs
-                (g',binders) = mapAccumL compileBinder (argOffset d g) addressed
-                -- kinda gross. revisit this
-                addressed = bs `zip` reverse [0 .. d-1]
+                (g',binders) = mapAccumL compileBinder g bs
 
-                compileBinder :: Env -> (Binding', Int) -> (Env, Code)
-                compileBinder m (k := v, a) = (m',c)
+                compileBinder :: Env -> Binding' -> (Env, Code)
+                compileBinder m (k := v) = (m',c)
                     where
-                        m' = (NameKey k, a) : m
+                        m' = (NameKey k, 0) : argOffset 1 m
                         -- make note that we use m rather than m'!
                         c = compileC m v
 
@@ -779,6 +821,7 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
         compileE g ("/#" :$ a :$ b)  = inlineOp2 g Div    a b
         compileE g ("==#" :$ a :$ b) = inlineOp2 g Equals a b
         compileE g ("<#" :$ a :$ b)  = inlineOp2 g Lesser a b
+        compileE g (">=#" :$ a :$ b)  = inlineOp2 g GreaterEq a b
 
         compileE g (Case e as) = compileE g e <> [CaseJump (compileD g as)]
 
@@ -1055,3 +1098,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
+

src/Rlp/Lex.x

@@ -27,8 +27,7 @@ import Data.Text                (Text)
 import Data.Text                qualified as T
 import Data.Word
 import Data.Default
-import Lens.Micro.Mtl
-import Lens.Micro
+import Control.Lens
 
 import Debug.Trace
 import Rlp.Parse.Types

src/Rlp/Parse.y

@@ -13,7 +13,7 @@ import Rlp.Lex
 import Rlp.Syntax
 import Rlp.Parse.Types
 import Rlp.Parse.Associate
-import Lens.Micro.Platform
+import Control.Lens                 hiding (snoc, (.>), (<.), (<<~))
 import Data.List.Extra
 import Data.Fix
 import Data.Functor.Const

src/Rlp/Parse/Associate.hs

@@ -11,7 +11,7 @@ import Data.Functor.Const
 import Data.Functor
 import Data.Text                        qualified as T
 import Text.Printf
-import Lens.Micro
+import Control.Lens
 import Rlp.Parse.Types
 import Rlp.Syntax
 --------------------------------------------------------------------------------

src/Rlp/Parse/Types.hs

@@ -44,8 +44,7 @@ import Data.HashMap.Strict          qualified as H
 import Data.Void
 import Data.Word                    (Word8)
 import Data.Text                    qualified as T
-import Lens.Micro.TH
-import Lens.Micro
+import Control.Lens                 hiding ((<<~))
 import Rlp.Syntax
 import Compiler.Types
 --------------------------------------------------------------------------------

src/Rlp/Syntax.hs

@@ -57,8 +57,7 @@ import Data.Functor.Identity
 import Data.Kind                    (Type)
 import GHC.Generics
 import Language.Haskell.TH.Syntax   (Lift)
-import Lens.Micro.Pro
-import Lens.Micro.Pro.TH
+import Control.Lens
 import Core.Syntax                  hiding (Lit, Type, Binding, Binding')
 import Core                         (HasRHS(..), HasLHS(..))
 ----------------------------------------------------------------------------------

src/Rlp2Core.hs

@@ -13,8 +13,6 @@ import Control.Monad.Utils
 import Control.Arrow
 import Control.Applicative
 import Control.Comonad
--- import Lens.Micro
--- import Lens.Micro.Internal
 import Control.Lens
 import Compiler.RLPC
 import Data.List                        (mapAccumL, partition)

src/TI.hs

@@ -20,8 +20,7 @@ import System.IO                (Handle, hPutStr)
 import Text.Printf              (printf, hPrintf)
 import Data.Proxy               (Proxy(..))
 import Data.Monoid              (Endo(..))
-import Lens.Micro
-import Lens.Micro.TH
+import Control.Lens
 import Data.Pretty
 import Data.Heap
 import Core.Examples

tst/Arith.hs

@@ -41,6 +41,7 @@ evalArith (a ::* b)   = evalArith a * evalArith b
 evalArith (a ::- b)   = evalArith a - evalArith b
 
 instance Arbitrary ArithExpr where
+    -- TODO: implement shrink
     arbitrary = gen 4
         where
             gen :: Int -> Gen ArithExpr

visualisers/gmvis/.gitignore

@@ -0,0 +1,21 @@
+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

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

@@ -0,0 +1,156 @@
+@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

@@ -0,0 +1,304 @@
+@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

@@ -0,0 +1,19 @@
+<!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

@@ -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,63 @@
+(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

@@ -0,0 +1,230 @@
+(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"]))
+