msyds/rlp
1
0
Fork 0
Code Issues 4 Pull Requests Actions Packages Projects Releases 2 Wiki Activity

Compare commits

base: msyds:gm-visualiser-2
Branches Tags
msyds:main msyds:gm-visualiser-2 msyds:dev msyds:bottom-up-hm msyds:functor-sum-test msyds:sysf msyds:no-ttg msyds:gm-visualiser msyds:ugh msyds:errorful msyds:ttg msyds:errorful-everything msyds:named-core-case msyds:frontend-parser msyds:hm msyds:rlp2core msyds:happy-frontend msyds:test-syntax msyds:test-example-programs
msyds:v0.1.0 msyds:v0.0.0-alpha
..
compare: msyds:ugh
Branches Tags
msyds:gm-visualiser-2 msyds:dev msyds:main msyds:bottom-up-hm msyds:functor-sum-test msyds:sysf msyds:no-ttg msyds:gm-visualiser msyds:ugh msyds:errorful msyds:ttg msyds:errorful-everything msyds:named-core-case msyds:frontend-parser msyds:hm msyds:rlp2core msyds:happy-frontend msyds:test-syntax msyds:test-example-programs
msyds:v0.1.0 msyds:v0.0.0-alpha

2 Commits
gm-visuali ... ugh

Author SHA1 Message Date
crumbtoo
8283826846 love when writing d instead of d-1 causes hours of stress 2024-02-13 09:28:36 -07:00
crumbtoo
514abe802b ugh 2024-02-12 15:49:02 -07:00
52 changed files with 88414 additions and 2695 deletions
Expand all files Collapse all files

6
Makefile_happysrcs
View File

@@ -1,16 +1,14 @@
GHC_VERSION = $(shell ghc --numeric-version)
HAPPY = happy HAPPY = happy
HAPPY_OPTS = -a -g -c -i/tmp/t.info HAPPY_OPTS = -a -g -c -i/tmp/t.info
ALEX = alex ALEX = alex
ALEX_OPTS = -g ALEX_OPTS = -g
SRC = src 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 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 lexers: $(CABAL_BUILD)/Rlp/Lex.hs $(CABAL_BUILD)/Core/Lex.hs
$(CABAL_BUILD)/Rlp/Parse.hs: $(SRC)/Rlp/Parse.y $(CABAL_BUILD)/Rlp/Parse.hs: $(SRC)/Rlp/Parse.y

15
README.md
View File

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

24
app.old/CoreDriver.hs
View File

@@ -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

140
app.old/Main.hs
View File

@@ -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

19
app.old/RlpDriver.hs
View File

@@ -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)

6
app/CoreDriver.hs
View File

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

14
app/Main.hs
View File

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

2
app/RlpDriver.hs
View File

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

92
app/Server.hs
View File

@@ -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

8
cabal.project.local Normal file
View File

@@ -0,0 +1,8 @@
profiling: True
ignore-project: False
library-profiling: True
executable-profiling: True
profiling-detail: all-functions
tests: True
benchmarks: True

5
cabal.project.local~ Normal file
View File

@@ -0,0 +1,5 @@
ignore-project: False
library-profiling: True
executable-profiling: True
tests: True
benchmarks: True

49
doc/src/commentary/gm.rst
View File

@@ -63,13 +63,52 @@ 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 sequence of instructions* which, **when executed**, build up a graph
representing the code. representing the code.
************* **************************
The G-Machine 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.
.. literalinclude:: /../../src/GM.hs .. literalinclude:: /../../src/GM.hs
:dedent: :dedent:
:start-after: -- >> [ref/Instr] :start-after: -- >> [ref/compileSc]
:end-before: -- << [ref/Instr] :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]
:caption: src/GM.hs :caption: src/GM.hs

153
doc/src/commentary/layout-lexing.rst
View File

@@ -62,6 +62,159 @@ braces and semicolons. In developing our *layout* rules, we will follow in the
pattern of translating the whitespace-sensitive source language to an explicitly pattern of translating the whitespace-sensitive source language to an explicitly
sectioned language. 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 References
---------- ----------

10
examples/rlp/Help.rl Normal file
View File

@@ -0,0 +1,10 @@
id x = x
thing = Identity 3
data Identity a = Identity a
main = case thing of
Identity x -> let y = x
in y

13
examples/rlp/MapList.rl Normal file
View File

@@ -0,0 +1,13 @@
data List a = Nil | Cons a (List a)
map :: (a -> b) -> List a -> List b
map f l = case l of
Nil -> Nil
Cons a as -> Cons (f a) (map f as)
list = Cons 1 (Cons 2 (Cons 3 Nil))
lam x = *# x x
main = print# (map lam list)

13
examples/rlp/QuickSort.rl
View File

@@ -23,9 +23,18 @@ qsort l = case l of
greater = filter (<# a) as greater = filter (<# a) as
in append (append (qsort lesser) (Cons a Nil)) (qsort greater) in append (append (qsort lesser) (Cons a Nil)) (qsort greater)
list :: List Int#
list = Cons 9 (Cons 2 (Cons 3 (Cons 2 list = Cons 9 (Cons 2 (Cons 3 (Cons 2
(Cons 5 (Cons 2 (Cons 12 (Cons 89 Nil))))))) (Cons 5 (Cons 2 (Cons 12 (Cons 89 Nil)))))))
main = print# (qsort list) list2 = Cons 2 (Cons 3 Nil)
lt :: Int# -> Int# -> Bool
lt a = (>=# a)
id x = x
main = case list of
Nil -> Nil
Cons a as -> let lesser = filter (lt a) as
in lesser

13
find-build.clj
View File

@@ -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)))

85264
instrs Normal file
View File

File diff suppressed because it is too large Load Diff

35
rlp.cabal
View File

@@ -50,37 +50,42 @@ library
build-tool-depends: happy:happy, alex:alex build-tool-depends: happy:happy, alex:alex
-- other-extensions: -- other-extensions:
build-depends: base >=4.17 && <4.21 build-depends: base >=4.17 && <4.20
-- required for happy -- required for happy
, array >= 0.5.5 && < 0.6 , array >= 0.5.5 && < 0.6
, containers >= 0.6.7 && < 0.7 , 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 , pretty >= 1.1.3 && < 1.2
, data-default >= 0.7.1 && < 0.8 , data-default >= 0.7.1 && < 0.8
, data-default-class >= 0.1.2 && < 0.2 , data-default-class >= 0.1.2 && < 0.2
, hashable >= 1.4.3 && < 1.5 , hashable >= 1.4.3 && < 1.5
, mtl >= 2.3.1 && < 2.4 , mtl >= 2.3.1 && < 2.4
, text >= 2.0.2 && < 2.3 , 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
, unordered-containers >= 0.2.20 && < 0.3 , unordered-containers >= 0.2.20 && < 0.3
, recursion-schemes >= 5.2.2 && < 5.3 , recursion-schemes >= 5.2.2 && < 5.3
, data-fix >= 0.3.2 && < 0.4 , data-fix >= 0.3.2 && < 0.4
, utf8-string >= 1.0.2 && < 1.1 , utf8-string >= 1.0.2 && < 1.1
, extra >= 1.7.0 && < 2 , extra >= 1.7.0 && < 2
, semigroupoids >=6.0 && <6.1 , semigroupoids
, comonad >=5.0.0 && <6 , comonad
, lens >=5.2.3 && <6.0 , lens
, text-ansi >=0.2.0 && <0.4 , text-ansi
, microlens-pro ^>=0.2.0
, effectful-core ^>=2.3.0.0 , effectful-core ^>=2.3.0.0
, deriving-compat ^>=0.6.0 , deriving-compat ^>=0.6.0
, these >=0.2 && <2.0 , these >=0.2 && <2.0
, aeson
ghc-options:
-fprof-auto
hs-source-dirs: src hs-source-dirs: src
default-language: GHC2021 default-language: GHC2021
ghc-options:
-fdefer-typed-holes
default-extensions: default-extensions:
OverloadedStrings OverloadedStrings
TypeFamilies TypeFamilies
@@ -90,24 +95,20 @@ library
DerivingVia DerivingVia
StandaloneDeriving StandaloneDeriving
DerivingStrategies DerivingStrategies
PartialTypeSignatures
executable rlpc executable rlpc
import: warnings import: warnings
main-is: Main.hs main-is: Main.hs
other-modules: RlpDriver other-modules: RlpDriver
, CoreDriver , CoreDriver
, Server
build-depends: base >=4.17.0.0 && <4.20.0.0 build-depends: base >=4.17.0.0 && <4.20.0.0
, rlp , rlp
, optparse-applicative >= 0.18.1 && < 0.19 , optparse-applicative >= 0.18.1 && < 0.19
, microlens-platform
, mtl >= 2.3.1 && < 2.4 , mtl >= 2.3.1 && < 2.4
, unordered-containers >= 0.2.20 && < 0.3 , unordered-containers >= 0.2.20 && < 0.3
, lens >=5.2.3 && <6.0 , text >= 2.0.2 && < 2.1
, text >= 2.0.2 && < 2.3
, aeson
, websockets
hs-source-dirs: app hs-source-dirs: app
default-language: GHC2021 default-language: GHC2021

2764
rlpc.prof Normal file
View File

File diff suppressed because it is too large Load Diff

1
rlpc.tix Normal file
View File

File diff suppressed because one or more lines are too long

16
src/Compiler/JustRun.hs
View File

@@ -11,8 +11,6 @@ module Compiler.JustRun
( justLexCore ( justLexCore
, justParseCore , justParseCore
, justTypeCheckCore , justTypeCheckCore
, justHdbg
, justLexParseGmEval
) )
where where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
@@ -22,22 +20,14 @@ import Core.HindleyMilner
import Core.Syntax (Program') import Core.Syntax (Program')
import Compiler.RLPC import Compiler.RLPC
import Control.Arrow ((>>>)) import Control.Arrow ((>>>))
import Control.Monad ((>=>), void) import Control.Monad ((>=>))
import Control.Comonad import Control.Comonad
import Control.Lens import Control.Lens
import Data.Text qualified as T import Data.Text qualified as T
import Data.Function ((&)) import Data.Function ((&))
import System.IO
import GM 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 :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
justLexCore s = lexCoreR (T.pack s) justLexCore s = lexCoreR (T.pack s)
& mapped . each %~ extract & mapped . each %~ extract
@@ -48,10 +38,6 @@ justParseCore s = parse (T.pack s)
& rlpcToEither & rlpcToEither
where parse = lexCoreR >=> parseCoreProgR 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 :: String -> Either [MsgEnvelope RlpcError] Program'
justTypeCheckCore s = typechk (T.pack s) justTypeCheckCore s = typechk (T.pack s)
& rlpcToEither & rlpcToEither

7
src/Compiler/RLPC.hs
View File

@@ -26,7 +26,6 @@ module Compiler.RLPC
, DebugFlag(..), CompilerFlag(..) , DebugFlag(..), CompilerFlag(..)
-- ** Lenses -- ** Lenses
, rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage , rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage
, rlpcServer
-- * Misc. MTL-style functions -- * Misc. MTL-style functions
, liftErrorful, hoistRlpcT , liftErrorful, hoistRlpcT
-- * Misc. Rlpc Monad -related types -- * Misc. Rlpc Monad -related types
@@ -65,8 +64,8 @@ import Data.Text.IO qualified as T
import System.IO import System.IO
import Text.ANSI qualified as Ansi import Text.ANSI qualified as Ansi
import Text.PrettyPrint hiding ((<>)) import Text.PrettyPrint hiding ((<>))
import Control.Lens import Lens.Micro.Platform
import Data.Text.Lens (packed, unpacked, IsText) import Lens.Micro.Platform.Internal
import System.Exit import System.Exit
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
@@ -121,7 +120,6 @@ data RLPCOptions = RLPCOptions
, _rlpcEvaluator :: Evaluator , _rlpcEvaluator :: Evaluator
, _rlpcHeapTrigger :: Int , _rlpcHeapTrigger :: Int
, _rlpcLanguage :: Maybe Language , _rlpcLanguage :: Maybe Language
, _rlpcServer :: Bool
, _rlpcInputFiles :: [FilePath] , _rlpcInputFiles :: [FilePath]
} }
deriving Show deriving Show
@@ -143,7 +141,6 @@ instance Default RLPCOptions where
, _rlpcHeapTrigger = 200 , _rlpcHeapTrigger = 200
, _rlpcInputFiles = [] , _rlpcInputFiles = []
, _rlpcLanguage = Nothing , _rlpcLanguage = Nothing
, _rlpcServer = False
} }
-- debug flags are passed with -dFLAG -- debug flags are passed with -dFLAG

23
src/Compiler/RlpcError.hs
View File

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

8
src/Compiler/Types.hs
View File

@@ -20,9 +20,6 @@ import Data.Functor.Apply
import Data.Functor.Bind import Data.Functor.Bind
import Control.Lens hiding ((<<~)) import Control.Lens hiding ((<<~))
import Language.Haskell.TH.Syntax (Lift) 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) -- | Token wrapped with a span (line, column, absolute, length)
@@ -50,10 +47,7 @@ data SrcSpan = SrcSpan
!Int -- ^ Column !Int -- ^ Column
!Int -- ^ Absolute !Int -- ^ Absolute
!Int -- ^ Length !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 (Int, Int, Int, Int)
tupling = iso (\ (SrcSpan a b c d) -> (a,b,c,d)) tupling = iso (\ (SrcSpan a b c d) -> (a,b,c,d))

2
src/Control/Monad/Errorful.hs
View File

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

15
src/Core/Examples.hs
View File

@@ -8,6 +8,7 @@ module Core.Examples where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
import Core.Syntax import Core.Syntax
import Core.TH import Core.TH
import Rlp.TH
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
-- fac3 = undefined -- fac3 = undefined
@@ -244,3 +245,17 @@ namedConsCase = [coreProg|
--} --}
qsort = [rlpProg|
data List a = Nil | Cons a (List a)
list = Cons 9 (Cons 2 (Cons 3 (Cons 2
(Cons 5 (Cons 2 (Cons 12 (Cons 89 Nil)))))))
id x = x
main = case list of
Nil -> Nil
Cons a as -> let lesser = as
in print# lesser
|]

4
src/Core/HindleyMilner.hs
View File

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

3
src/Core/Lex.x
View File

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

2
src/Core/Parse.y
View File

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

2
src/Core/Syntax.hs
View File

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

2
src/Core/Utils.hs
View File

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

2
src/Core2Core.hs
View File

@@ -20,10 +20,12 @@ import Control.Monad.State.Lazy
import Control.Arrow ((>>>)) import Control.Arrow ((>>>))
import Data.Text qualified as T import Data.Text qualified as T
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Debug.Trace
import Numeric (showHex) import Numeric (showHex)
import Data.Pretty import Data.Pretty
import Compiler.RLPC import Compiler.RLPC
-- import Lens.Micro.Platform
import Control.Lens import Control.Lens
import Core.Syntax import Core.Syntax
import Core.Utils import Core.Utils

39
src/Data/Heap.hs
View File

@@ -1,3 +1,4 @@
{-# LANGUAGE ImplicitParams #-}
{- {-
Module : Data.Heap Module : Data.Heap
Description : A model heap used by abstract machine Description : A model heap used by abstract machine
@@ -26,29 +27,15 @@ import Data.Map (Map, (!?))
import Debug.Trace import Debug.Trace
import Data.Map.Strict qualified as M import Data.Map.Strict qualified as M
import Data.List (intersect) import Data.List (intersect)
import GHC.Stack (HasCallStack) import Data.IORef
import System.IO.Unsafe
import Control.Monad
import GHC.Stack
import Control.Lens import Control.Lens
import Data.Aeson
import GHC.Generics ( Generic1, Generic
, Generically1(..), Generically(..))
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
data Heap a = Heap [Addr] (Map Addr a) 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 type Addr = Int
@@ -91,13 +78,19 @@ instance Traversable Heap where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
alloc :: Heap a -> a -> (Heap a, Addr) godhelpme :: IORef Int
alloc (Heap (u:us) m) v = (Heap us (M.insert u v m), u) godhelpme = unsafePerformIO $ newIORef 0
alloc :: HasCallStack => Heap a -> a -> (Heap a, Addr)
alloc (Heap (u:us) m) v = unsafePerformIO $ do
-- i <- readIORef godhelpme
-- when (i >= 60000) $ error "fuck"
-- modifyIORef godhelpme succ
pure (Heap us (M.insert u v m), u)
alloc (Heap [] _) _ = error "heap model ran out of memory..." alloc (Heap [] _) _ = error "heap model ran out of memory..."
update :: Addr -> a -> Heap a -> Heap a update :: HasCallStack => Addr -> a -> Heap a -> Heap a
update k v (Heap u m) = Heap u (M.adjust (const v) k m) update k v (Heap u m) = Heap u (M.adjust (const v) k m)
-- update k v (Heap u m) = Heap u (M.adjust (undefined) k m)
adjust :: Addr -> (a -> a) -> Heap a -> Heap a adjust :: Addr -> (a -> a) -> Heap a -> Heap a
adjust k f (Heap u m) = Heap u (M.adjust f k m) adjust k f (Heap u m) = Heap u (M.adjust f k m)

122
src/GM.hs
View File

@@ -9,17 +9,11 @@ module GM
( hdbgProg ( hdbgProg
, evalProg , evalProg
, evalProgR , evalProgR
, GmState(..)
, gmCode, gmStack, gmDump, gmHeap, gmEnv, gmStats
, Node(..) , Node(..)
, showState
, gmEvalProg , gmEvalProg
, Stats(..)
, finalStateOf , finalStateOf
, resultOf , resultOf
, resultOfExpr , resultOfExpr
, compile
, eval
) )
where where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
@@ -28,13 +22,18 @@ import Data.List (mapAccumL)
import Data.Maybe (fromMaybe, mapMaybe) import Data.Maybe (fromMaybe, mapMaybe)
import Data.Monoid (Endo(..)) import Data.Monoid (Endo(..))
import Data.Tuple (swap) import Data.Tuple (swap)
import Control.Lens import Lens.Micro
import Data.Text.Lens (IsText, packed, unpacked) import Lens.Micro.Extras (view)
import Lens.Micro.TH
import Lens.Micro.Platform (packed, unpacked)
import Lens.Micro.Platform.Internal (IsText(..))
import Text.Printf import Text.Printf
import Text.PrettyPrint hiding ((<>)) import Text.PrettyPrint hiding ((<>))
import Text.PrettyPrint.HughesPJ (maybeParens) import Text.PrettyPrint.HughesPJ (maybeParens)
import Data.Foldable (traverse_) import Data.Foldable (traverse_)
import System.IO (Handle, hPutStrLn) import Control.Concurrent
import System.Exit
import System.IO (Handle, hPutStrLn, stderr)
-- TODO: an actual output system -- TODO: an actual output system
-- TODO: an actual output system -- TODO: an actual output system
-- TODO: an actual output system -- TODO: an actual output system
@@ -44,12 +43,6 @@ import Data.String (IsString)
import Data.Heap import Data.Heap
import Debug.Trace import Debug.Trace
import Compiler.RLPC import Compiler.RLPC
-- for visualisation
import Data.Aeson hiding (Key)
import Data.Aeson.Text
import GHC.Generics (Generic, Generically(..))
import Core2Core import Core2Core
import Core import Core
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
@@ -86,7 +79,7 @@ data GmState = GmState
, _gmEnv :: Env , _gmEnv :: Env
, _gmStats :: Stats , _gmStats :: Stats
} }
deriving (Show, Generic) deriving Show
type Code = [Instr] type Code = [Instr]
type Stack = [Addr] type Stack = [Addr]
@@ -96,9 +89,8 @@ type GmHeap = Heap Node
data Key = NameKey Name data Key = NameKey Name
| ConstrKey Tag Int | ConstrKey Tag Int
deriving (Show, Eq, Generic) deriving (Show, Eq)
-- >> [ref/Instr]
data Instr = Unwind data Instr = Unwind
| PushGlobal Name | PushGlobal Name
| PushConstr Tag Int | PushConstr Tag Int
@@ -119,8 +111,7 @@ data Instr = Unwind
| Split Int | Split Int
| Print | Print
| Halt | Halt
deriving (Show, Eq, Generic) deriving (Show, Eq)
-- << [ref/Instr]
data Node = NNum Int data Node = NNum Int
| NAp Addr Addr | NAp Addr Addr
@@ -132,7 +123,7 @@ data Node = NNum Int
| NUninitialised | NUninitialised
| NConstr Tag [Addr] -- NConstr Tag Components | NConstr Tag [Addr] -- NConstr Tag Components
| NMarked Node | NMarked Node
deriving (Show, Eq, Generic) deriving (Show, Eq)
-- TODO: log executed instructions -- TODO: log executed instructions
data Stats = Stats data Stats = Stats
@@ -142,7 +133,7 @@ data Stats = Stats
, _stsDereferences :: Int , _stsDereferences :: Int
, _stsGCCycles :: Int , _stsGCCycles :: Int
} }
deriving (Show, Generic) deriving Show
instance Default Stats where instance Default Stats where
def = Stats 0 0 0 0 0 def = Stats 0 0 0 0 0
@@ -163,7 +154,7 @@ evalProg p = res <&> (,sts)
resAddr = final ^. gmStack ^? _head resAddr = final ^. gmStack ^? _head
res = resAddr >>= flip hLookup h res = resAddr >>= flip hLookup h
hdbgProg :: Program' -> Handle -> IO GmState hdbgProg :: Program' -> Handle -> IO (Node, Stats)
hdbgProg p hio = do hdbgProg p hio = do
(renderOut . showState) `traverse_` states (renderOut . showState) `traverse_` states
-- TODO: i'd like the statistics to be at the top of the file, but `sts` -- TODO: i'd like the statistics to be at the top of the file, but `sts`
@@ -171,7 +162,7 @@ hdbgProg p hio = do
-- *can't* get partial logs in the case of a crash. this is in opposition to -- *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 -- the above traversal which *will* produce partial logs. i love laziness :3
renderOut . showStats $ sts renderOut . showStats $ sts
pure final pure (res, sts)
where where
renderOut r = hPutStrLn hio $ render r ++ "\n" renderOut r = hPutStrLn hio $ render r ++ "\n"
@@ -184,61 +175,34 @@ hdbgProg p hio = do
[resAddr] = final ^. gmStack [resAddr] = final ^. gmStack
res = hLookupUnsafe resAddr h res = hLookupUnsafe resAddr h
evalProgR :: (Monad m) => Program' -> RLPCT m (Node, Stats) evalProgR :: Program' -> RLPCIO (Node, Stats)
evalProgR p = do evalProgR p = do
putState `traverse_` states -- me <- liftIO myThreadId
putStats sts -- liftIO $ forkIO $ threadDelay (5 * 10^6) *> throwTo me ExitSuccess *> exitSuccess
pure res -- states & traverseOf_ (each . gmCode) (liftIO . print)
(renderOut . showState) `traverse_` states
renderOut . showStats $ sts
pure (res, sts)
where where
renderOut r = addDebugMsg "dump-eval" $ render r ++ "\n"
states = eval . compile $ p states = eval . compile $ p
res@(_, sts) = results states
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 final = last states
sts = final ^. gmStats sts = final ^. gmStats
-- the address of the result should be the one and only stack entry -- the address of the result should be the one and only stack entry
[resAddr] = final ^. gmStack [resAddr] = final ^. gmStack
res = hLookupUnsafe resAddr (final ^. gmHeap) 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 :: GmState -> [GmState]
eval st = st : rest eval st = st : rest
where where
rest | isFinal st = [] rest | isFinal st = []
| otherwise = eval next | otherwise = eval next
next = doAdmin (step st) next = doAdmin (step . (\a -> (unsafePerformIO . hPutStrLn stderr . ('\n':) . render . showState $ a) `seq` a) $ st)
doAdmin :: GmState -> GmState doAdmin :: GmState -> GmState
doAdmin st = st & gmStats . stsReductions %~ succ doAdmin st = st & gmStats . stsReductions %~ succ
& doGC -- & doGC
where where
-- TODO: use heapTrigger option in RLPCOptions -- TODO: use heapTrigger option in RLPCOptions
heapTrigger = 50 heapTrigger = 50
@@ -448,7 +412,8 @@ step st = case head (st ^. gmCode) of
(e:s) = st ^. gmStack (e:s) = st ^. gmStack
an = s !! n an = s !! n
h = st ^. gmHeap h = st ^. gmHeap
h' = h `seq` update an (NInd e) h -- PROBLEM HERE:
h' = update an (NInd e) h
popI :: Int -> GmState popI :: Int -> GmState
popI n = st popI n = st
@@ -697,7 +662,7 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
-- note that we don't count sc allocations in the stats -- note that we don't count sc allocations in the stats
allocateSc :: GmHeap -> CompiledSC -> (GmHeap, (Key, Addr)) allocateSc :: GmHeap -> CompiledSC -> (GmHeap, (Key, Addr))
allocateSc h (n,d,c) = (h', (NameKey n, a)) allocateSc h (n,d,c) = traceShow a (h', (NameKey n, a))
where (h',a) = alloc h $ NGlobal d c where (h',a) = alloc h $ NGlobal d c
-- >> [ref/compileSc] -- >> [ref/compileSc]
@@ -784,17 +749,19 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
compileE _ (Lit l) = compileEL l compileE _ (Lit l) = compileEL l
compileE g (Let NonRec bs e) = compileE g (Let NonRec bs e) =
-- we use compileE instead of compileC -- we use compileE instead of compileC
mconcat binders <> compileE g' e <> [Slide d] traceShowId $ mconcat binders <> compileE g' e <> [Slide d]
where where
d = length bs d = length bs
(g',binders) = mapAccumL compileBinder g bs (g',binders) = mapAccumL compileBinder (argOffset (d-1) g) addressed
-- kinda gross. revisit this
addressed = bs `zip` reverse [0 .. d-1]
compileBinder :: Env -> Binding' -> (Env, Code) compileBinder :: Env -> (Binding', Int) -> (Env, Code)
compileBinder m (k := v) = (m',c) compileBinder m (k := v, a) = (m',c)
where where
m' = (NameKey k, 0) : argOffset 1 m m' = (NameKey k, a) : m
-- make note that we use m rather than m'! -- make note that we use m rather than m'!
c = compileC m v c = trace (printf "compileC %s %s" (show m) (show v)) $ compileC m v
compileE g (Let Rec bs e) = compileE g (Let Rec bs e) =
Alloc d : initialisers <> body <> [Slide d] Alloc d : initialisers <> body <> [Slide d]
@@ -821,7 +788,6 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
compileE g ("/#" :$ a :$ b) = inlineOp2 g Div a b compileE g ("/#" :$ a :$ b) = inlineOp2 g Div a b
compileE g ("==#" :$ a :$ b) = inlineOp2 g Equals 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 Lesser a b
compileE g (">=#" :$ a :$ b) = inlineOp2 g GreaterEq a b
compileE g (Case e as) = compileE g e <> [CaseJump (compileD g as)] compileE g (Case e as) = compileE g e <> [CaseJump (compileD g as)]
@@ -1098,17 +1064,3 @@ resultOfExpr e = resultOf $
[ ScDef "main" [] e [ 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

3
src/Rlp/Lex.x
View File

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

2
src/Rlp/Parse.y
View File

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

2
src/Rlp/Parse/Associate.hs
View File

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

3
src/Rlp/Parse/Types.hs
View File

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

3
src/Rlp/Syntax.hs
View File

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

2
src/Rlp2Core.hs
View File

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

3
src/TI.hs
View File

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

1
tst/Arith.hs
View File

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

21
visualisers/gmvis/.gitignore vendored
View File

@@ -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/

1362
visualisers/gmvis/package-lock.json generated
View File

File diff suppressed because it is too large Load Diff

1
visualisers/gmvis/package.json
View File

@@ -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"}}

156
visualisers/gmvis/public/css/main.css
View File

@@ -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 */
/* } */

304
visualisers/gmvis/public/css/solarized-light.css
View File

@@ -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;
}

19
visualisers/gmvis/public/index.html
View File

@@ -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>

25
visualisers/gmvis/shadow-cljs.edn
View File

@@ -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}}}}}

63
visualisers/gmvis/src/main.cljs
View File

@@ -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))

230
visualisers/gmvis/src/ui.cljs
View File

@@ -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"]))