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

rc #13

Merged
crumbtoo merged 196 commits from dev into main 2024-02-13 13:22:23 -07:00
Conversation 0 Commits 196 Files Changed 55 +4117 -1380
55 changed files with 4117 additions and 1380 deletions
Download Patch File Download Diff File Expand all files Collapse all files

24
.ghci Normal file
View File

@@ -0,0 +1,24 @@
-- repl extensions
:set -XOverloadedStrings
--------------------------------------------------------------------------------
-- happy/alex: override :r to rebuild parsers
:set -package process
:{
import System.Exit qualified
import System.Process qualified
_reload_and_make _ = do
p <- System.Process.spawnCommand "make -f Makefile_happysrcs"
r <- System.Process.waitForProcess p
case r of
System.Exit.ExitSuccess -> pure ":reload"
_ -> pure ""
:}
:def! r _reload_and_make
--------------------------------------------------------------------------------

19
CHANGELOG.md Normal file
View File

@@ -0,0 +1,19 @@
# unreleased
* New tag syntax:
```hs
case x of
{ 1 -> something
; 2 -> another
}
```
is now written as
```hs
case x of
{ <1> -> something
; <2> -> another
}
```
# Release 1.0.0

25
Makefile_happysrcs Normal file
View File

@@ -0,0 +1,25 @@
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
all: parsers lexers
parsers: $(CABAL_BUILD)/Rlp/Parse.hs $(CABAL_BUILD)/Core/Parse.hs
lexers: $(CABAL_BUILD)/Rlp/Lex.hs $(CABAL_BUILD)/Core/Lex.hs
$(CABAL_BUILD)/Rlp/Parse.hs: $(SRC)/Rlp/Parse.y
$(HAPPY) $(HAPPY_OPTS) $< -o $@
$(CABAL_BUILD)/Rlp/Lex.hs: $(SRC)/Rlp/Lex.x
$(ALEX) $(ALEX_OPTS) $< -o $@
$(CABAL_BUILD)/Core/Parse.hs: $(SRC)/Core/Parse.y
$(HAPPY) $(HAPPY_OPTS) $< -o $@
$(CABAL_BUILD)/Core/Lex.hs: $(SRC)/Core/Lex.x
$(ALEX) $(ALEX_OPTS) $< -o $@

128
README.md
View File

@@ -3,6 +3,10 @@
`rlp` (ruelang') will be a lazily-evaluated purely-functional language heavily
imitating Haskell.
### Architecture
![rlpc architecture diagram](/rlpc.drawio.svg)
### Build Info
* rlp is built using [Cabal](https://www.haskell.org/ghcup/)
* rlp's documentation is built using [Sphinx](https://www.sphinx-doc.org/en/master/)
@@ -18,32 +22,57 @@ $ cabal test --test-show-details=direct
```
### Use
#### TLDR
```sh
# Compile and evaluate t.hs
$ rlpc t.hs
# Compile and evaluate t.hs, with evaluation info dumped to stderr
$ rlpc -ddump-eval t.hs
# Compile and evaluate t.hs, with evaluation info dumped to t.log
$ rlpc -ddump-eval -l t.log t.hs
# Print the raw structure describing the compiler options and die
# (option parsing still must succeed in order to print)
$ rlpc -ddump-opts t.hs
# 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
```sh
Usage: rlpc [-l|--log FILE] [-d DEBUG FLAG] [-f COMPILATION FLAG]
[-e|--evaluator gm|ti] [--heap-trigger INT] [-x|--language rlp|core]
FILES...
```
Available debug flags include:
* `-ddump-desugared`: dump Core generated from rl'
* `-ddump-parsed-core`: dump raw Core AST
* `-ddump-parsed`: dump raw rl' AST
* `-ddump-eval`: dump evaluation logs
* `-dALL`: disable debug message filtering. enables **all** debug messages
### Potential Features
Listed in order of importance.
- [ ] ADTs
- [ ] First-class functions
- [ ] Higher-kinded types
- [x] ADTs
- [x] First-class functions
- [x] Higher-kinded types
- [ ] Typeclasses
- [ ] Parametric polymorphism
- [ ] Hindley-Milner type inference
- [x] Parametric polymorphism
- [x] Hindley-Milner type inference
- [ ] Newtype coercion
- [ ] Parallelism
### Milestones
(This list is incomplete.)
Items are marked off not as they are 100% implemented, but rather once I
consider them stable enough that completion is soley a matter of getting
around to it -- no tough design decisions, theorising, etc. remain. For
example, as of writing this, the rl' frontend parser is not fully featured,
yet it is marked off on this list; finishing it would require cranking out
the remaining grammatical rules, and no work on complex tasks like layout
parsing remains.
- [ ] Backend
- [x] Core language
- [x] AST
@@ -59,41 +88,78 @@ Listed in order of importance.
- [x] Garbage Collection
- [ ] Emitter
- [ ] Code-gen (target yet to be decided)
- [ ] Core language emitter
- [ ] Core linter (Type-checker)
- [ ] Core2Core pass
- [x] Core linter (Type-checker)
- [ ] Core2Core pass (optimisations and misc. preprocessing)
- [x] GM prep
- [x] Non-strict case-floating
- [ ] Let-floating
- [ ] TCO
- [ ] DCE
- [ ] Frontend
- [ ] High-level language
- [ ] AST
- [ ] Lexer
- [ ] Parser
- [ ] Translation to the core language
- [x] High-level language
- [x] AST
- [x] Lexer
- [x] Parser
- [x] Translation to the core language
- [ ] Constraint solver
- [ ] `do`-notation
- [x] CLI
- [ ] Documentation
- [ ] State transition rules
- [x] State transition rules
- [ ] How does the evaluation model work?
- [ ] The Hindley-Milner type system
- [ ] CLI usage
- [ ] Tail call optimisation
- [x] Parsing rlp
- [ ] Parsing rlp
- [ ] Trees That Grow
- [ ] Tests
- [x] Generic example programs
- [ ] Parser
### December Release Plan
- [ ] Tests
### ~~December Release Plan~~
- [x] Tests
- [ ] Core lexer
- [ ] Core parser
- [ ] Evaluation model
- [x] Evaluation model
- [ ] Benchmarks
- [ ] Stable Core lexer
- [ ] Stable Core parser
- [ ] Stable evaluation model
- [ ] Garbage Collection
- [x] Stable Core lexer
- [x] Stable Core parser
- [x] Stable evaluation model
- [x] Garbage Collection
- [ ] Stable documentation for the evaluation model
### ~~February Release Plan~~
- [x] Beta rl' to Core
- [x] UX improvements
- [x] Actual compiler errors -- no more unexceptional `error` calls
- [x] Better CLI dump flags
- [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
- [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
This list is more concrete than the milestones, but likely further in the future
than the other release plans.
- [ ] Overall codebase cleaning
- [ ] Complete all TODOs
- [ ] Replace mtl with effectful
- [ ] rl' type-checker
- [ ] Stable rl' to Core
- [ ] Core polish
- [ ] Better, stable parser
- [ ] Better, stable lexer
- [ ] Less hacky handling of named data
- [ ] Less hacky pragmas
- [ ] Choose a target. LLVM, JS, C, and WASM are currently top contenders
- [ ] https://proglangdesign.net/wiki/challenges

24
app/CoreDriver.hs Normal file
View File

@@ -0,0 +1,24 @@
module CoreDriver
( driver
)
where
--------------------------------------------------------------------------------
import Compiler.RLPC
import Control.Monad
import Data.Text qualified as T
import Lens.Micro.Platform
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

137
app/Main.hs
View File

@@ -1,18 +1,28 @@
{-# 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 Lens.Micro.Mtl
import Lens.Micro.Platform
import CoreDriver qualified
import RlpDriver qualified
----------------------------------------------------------------------------------
optParser :: ParserInfo RLPCOptions
@@ -34,9 +44,15 @@ options = RLPCOptions
{- -d -}
<*> fmap S.fromList # many # option debugFlagReader
( short 'd'
<> help "dump evaluation logs"
<> 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"
@@ -52,96 +68,73 @@ options = RLPCOptions
\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
"tim" -> Just EvaluatorTI
"ti" -> Just EvaluatorTI
_ -> Nothing
mmany :: (Alternative f, Monoid m) => f m -> f m
mmany v = liftA2 (<>) v (mmany v)
debugFlagReader :: ReadM DebugFlag
debugFlagReader = maybeReader $ \case
"dump-eval" -> Just DDumpEval
"dump-opts" -> Just DDumpOpts
"dump-ast" -> Just DDumpAST
_ -> Nothing
----------------------------------------------------------------------------------
-- temp
data CompilerError = CompilerError String
deriving Show
instance Exception CompilerError
main :: IO ()
main = do
opts <- execParser optParser
(_, es) <- evalRLPCIO opts driver
forM_ es $ \ (CompilerError e) -> print $ "warning: " <> e
pure ()
void $ evalRLPCIO opts dispatch
driver :: RLPCIO CompilerError ()
driver = sequence_
[ dshowFlags
, ddumpAST
, ddumpEval
]
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)
dshowFlags :: RLPCIO CompilerError ()
dshowFlags = whenFlag flagDDumpOpts do
ask >>= liftIO . print
ddumpAST :: RLPCIO CompilerError ()
ddumpAST = whenFlag flagDDumpAST $ forFiles_ \o f -> do
liftIO $ withFile f ReadMode $ \h -> do
s <- hGetContents h
case parseProg o s of
Right (a,_) -> hPutStrLn stderr $ show a
Left e -> error "todo errors lol"
driver :: RLPCIO ()
driver = undefined
ddumpEval :: RLPCIO CompilerError ()
ddumpEval = whenFlag flagDDumpEval do
fs <- view rlpcInputFiles
forM_ fs $ \f -> liftIO (readFile f) >>= doProg
where
doProg :: String -> RLPCIO CompilerError ()
doProg s = ask >>= \o -> case parseProg o s of
-- TODO: error handling
Left e -> addFatal . CompilerError $ show e
Right (a,_) -> do
log <- view rlpcLogFile
dumpEval <- chooseEval
case log of
Just f -> liftIO $ withFile f WriteMode $ dumpEval a
Nothing -> liftIO $ dumpEval a stderr
-- choose the appropriate model based on the compiler opts
chooseEval = do
ev <- view rlpcEvaluator
pure $ case ev of
EvaluatorGM -> v GM.hdbgProg
EvaluatorTI -> v TI.hdbgProg
where v f p h = f p h *> pure ()
parseProg :: RLPCOptions
-> String
-> Either SrcError (Program', [SrcError])
parseProg o = evalRLPC o . (lexCore >=> parseCoreProg)
forFiles_ :: (Monad m)
=> (RLPCOptions -> FilePath -> RLPCT e m a)
-> RLPCT e m ()
forFiles_ k = do
fs <- view rlpcInputFiles
o <- ask
forM_ fs (k o)
inferLanguage :: FilePath -> Maybe Language
inferLanguage fp
| ".rl" `isSuffixOf` fp = Just LanguageRlp
| ".cr" `isSuffixOf` fp = Just LanguageCore
| otherwise = Nothing

19
app/RlpDriver.hs Normal file
View File

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

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

@@ -1,16 +1,24 @@
The *G-Machine*
===============
The G-Machine (graph machine) is the current heart of rlpc, until we potentially
move onto a STG (spineless tagless graph machine) or a TIM (three-instruction
machine). rl' source code is desugared into Core; a dumbed-down subset of rl',
and then compiled to G-Machine code, which is then finally translated to the
desired target.
**********
Motivation
**********
Our initial model, the *Template Instantiator* (TI) was a very
straightforward solution to compilation, but its core design has a major
Achilles' heel, being that Compilation is interleaved with evaluation -- The
heap nodes for supercombinators hold uninstantiated expressions, i.e. raw ASTs
straight from the parser. When a supercombinator is found on the stack during
evaluation, the template expression is instantiated (compiled) on the spot.
Our initial model, the *Template Instantiator* (TI) was a very straightforward
solution to compilation, but its core design has a major Achilles' heel, being
that compilation is interleaved with evaluation -- The heap nodes for
supercombinators hold uninstantiated expressions, i.e. raw ASTs straight from
the parser. When a supercombinator is found on the stack during evaluation, the
template expression is instantiated (compiled) on the spot. This makes
translation to an assembly difficult, undermining the point of an intermediate
language.
.. math::
\transrule
@@ -31,7 +39,7 @@ evaluation, the template expression is instantiated (compiled) on the spot.
\text{where } h' = \mathtt{instantiateU} \; e \; a_n \; h \; g
}
The process of instantiating a supercombinator goes something like this
The process of instantiating a supercombinator goes something like this:
1. Augment the environment with bindings to the arguments.
@@ -52,53 +60,16 @@ The process of instantiating a supercombinator goes something like this
Instantiating the supercombinator's body in this way is the root of our
Achilles' heel. Traversing a tree structure is a very non-linear task unfit for
an assembly target. The goal of our new G-Machine is to compile a *linear
sequence of instructions* which instantiate the expression at execution.
sequence of instructions* which, **when executed**, build up a graph
representing the code.
**************************
Trees and Vines, in Theory
**************************
WIP.
**************************
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]
:start-after: -- >> [ref/Instr]
:end-before: -- << [ref/Instr]
: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

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

@@ -2,16 +2,21 @@ Lexing, Parsing, and Layouts
============================
The C-style languages of my previous experiences have all had quite trivial
lexical analysis stages, peaking in complexity when I streamed tokens lazily in
C. The task of tokenising a C-style language is very simple in description: you
ignore all whitespace and point out what you recognise. If you don't recognise
something, check if it's a literal or an identifier. Should it be neither,
return an error.
lexical analysis stages: you ignore all whitespace and point out the symbols you
recognise. If you don't recognise something, check if it's a literal or an
identifier. Should it be neither, return an error.
On paper, both lexing and parsing a Haskell-like language seem to pose a few
In contrast, both lexing and parsing a Haskell-like language poses a number of
greater challenges. Listed by ascending intimidation factor, some of the
potential roadblocks on my mind before making an attempt were:
* Context-sensitive keywords; Haskell allows for some words to be used as
identifiers in appropriate contexts, such as :code:`family`, :code:`role`,
:code:`as`. Reading a note_ found in `GHC's lexer`_, it appears that keywords
are only considered in bodies for which their use is relevant, e.g.
:code:`family` and :code:`role` in type declarations, :code:`as` after
:code:`case`; :code:`if`, :code:`then`, and :code:`else` in expressions, etc.
* Operators; Haskell has not only user-defined infix operators, but user-defined
precedence levels and associativities. I recall using an algorithm that looked
up infix, prefix, postfix, and even mixfix operators up in a global table to
@@ -19,17 +24,9 @@ potential roadblocks on my mind before making an attempt were:
stored in the table). I never modified the table at runtime, however this
could be a very nice solution for Haskell.
* Context-sensitive keywords; Haskell allows for some words to be used as identifiers in
appropriate contexts, such as :code:`family`, :code:`role`, :code:`as`.
Reading a note_ found in `GHC's lexer`_,
it appears that keywords are only considered in bodies for which their use is
relevant, e.g. :code:`family` and :code:`role` in type declarations,
:code:`as` after :code:`case`; :code:`if`, :code:`then`, and :code:`else` in
expressions, etc.
* Whitespace sensitivity; While I was comfortable with the idea of a system
similar to Python's INDENT/DEDENT tokens, Haskell seemed to use whitespace to
section code in a way that *felt* different.
similar to Python's INDENT/DEDENT tokens, Haskell's layout system is based on
alignment and is very generous with line-folding.
.. _note: https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/coding-style#2-using-notes
.. _GHC's lexer: https://gitlab.haskell.org/ghc/ghc/-/blob/master/compiler/GHC/Parser/Lexer.x#L1133
@@ -45,9 +42,9 @@ We will compare and contrast with Python's lexical analysis. Much to my dismay,
Python uses newlines and indentation to separate statements and resolve scope
instead of the traditional semicolons and braces found in C-style languages (we
may generally refer to these C-style languages as *explicitly-sectioned*).
Internally during tokenisation, when the Python lexer begins a new line, they
compare the indentation of the new line with that of the previous and apply the
following rules:
Internally during tokenisation, when the Python lexer encounters a new line, the
indentation of the new line is compared with that of the previous and the
following rules are applied:
1. If the new line has greater indentation than the previous, insert an INDENT
token and push the new line's indentation level onto the indentation stack
@@ -60,170 +57,10 @@ following rules:
3. If the indentation is equal, insert a NEWLINE token to terminate the previous
line, and leave it at that!
Parsing Python with the INDENT, DEDENT, and NEWLINE tokens is identical to
parsing a language with braces and semicolons. This is a solution pretty in line
with Python's philosophy of the "one correct answer" (TODO: this needs a
source). 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?
***********************
We saw that Python, the most notable example of an implicitly sectioned
language, is pretty simple to lex. Why then am I so afraid of Haskell's layouts?
To be frank, I'm far less scared after asking myself this -- however there are
certainly some new complexities that Python needn't concern. Haskell has
implicit line *continuation*: forms written over multiple lines; indentation
styles often seen in Haskell are somewhat esoteric compared to Python's
"s/[{};]//".
.. code-block:: haskell
-- line continuation
something = this is a
single expression
-- an extremely common style found in haskell
data Python = Users
{ are :: Crying
, right :: About
, now :: Sorry
}
-- another formatting oddity
-- note that this is not a single
-- continued line! `look at`,
-- `this`, and `alignment` are all
-- separate expressions!
anotherThing = do look at
this
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.
On the parser's end, the INDENT, DEDENT, and NEWLINE tokens are identical to
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.
References
----------
@@ -233,3 +70,4 @@ References
* `Haskell syntax reference
<https://www.haskell.org/onlinereport/haskell2010/haskellch10.html>`_

6
doc/src/commentary/ti.rst
View File

@@ -1,6 +0,0 @@
The *Template Instantiator*
====================================
WIP. This will hopefully be expanded into a thorough walkthrough of the state
machine.

5
doc/src/commentary/type-inference.rst Normal file
View File

@@ -0,0 +1,5 @@
Type Inference in rl'
=====================
rl' implements type inference via the Hindley-Milner type system.

3
doc/src/conf.py
View File

@@ -13,7 +13,7 @@ author = 'madeleine sydney slaga'
# -- General configuration ---------------------------------------------------
# https://www.sphinx-doc.org/en/master/usage/configuration.html#general-configuration
extensions = ['sphinx.ext.imgmath']
extensions = ['sphinx.ext.imgmath', 'sphinx.ext.graphviz']
# templates_path = ['_templates']
exclude_patterns = []
@@ -32,6 +32,7 @@ html_theme = 'alabaster'
imgmath_latex_preamble = r'''
\usepackage{amsmath}
\usepackage{tabularray}
\usepackage{syntax}
\newcommand{\transrule}[2]
{\begin{tblr}{|rrrlc|}

67
doc/src/references/rlp-grammar.rst Normal file
View File

@@ -0,0 +1,67 @@
The Complete Syntax of rl'
==========================
WIP.
Provided is the complete syntax of rl' in (pseudo) EBNF. {A} represents zero or
more A's, [A] means optional A, and terminals are wrapped in 'single-quotes'.
.. math
:nowrap:
\setlength{\grammarparsep}{20pt plus 1pt minus 1pt}
\setlength{\grammarindent}{12em}
\begin{grammar}
<Decl> ::= <InfixDecl>
\alt <DataDecl>
\alt <TypeSig>
\alt <FunDef>
<InfixDecl> ::= <InfixWord> `litint' <Name>
<InfixWord> ::= `infix'
\alt `infixl'
\alt `infixr'
<DataDecl> ::= `data' `conname' {}
\end{grammar}
.. code-block:: bnf
Decl ::= InfixDecl
| DataDecl
| TypeSig
| FunDef
InfixDecl ::= InfixWord 'litint' Operator
InfixWord ::= 'infix'
| 'infixl'
| 'infixr'
DataDecl ::= 'data' 'conname' {'name'} '=' Data
DataCons ::= 'conname' {Type1} ['|' DataCons]
TypeSig ::= Var '::' Type
FunDef ::= Var {Pat1} '=' Expr
Type ::= Type1 {Type1}
-- note that (->) is right-associative,
-- and extends as far as possible
| Type '->' Type
Type1 ::= '(' Type ')'
| 'conname'
Pat ::= 'conname' Pat1 {Pat1}
| Pat 'consym' Pat
Pat1 ::= Literal
| 'conname'
| '(' Pat ')'
Literal ::= 'litint'
Var ::= 'varname'
| '(' 'varsym' ')'
Con ::= 'conname'
| '(' 'consym' ')'

17
doc/src/references/rlp-inference-rules.rst Normal file
View File

@@ -0,0 +1,17 @@
rl' Inference Rules
===================
.. rubric::
[Var]
.. math::
\frac{x : \tau \in \Gamma}
{\Gamma \vdash x : \tau}
.. rubric::
[App]
.. math::
\frac{\Gamma \vdash f : \alpha \to \beta \qquad \Gamma \vdash x : \alpha}
{\Gamma \vdash f x : \beta}

3
examples/Core/constDivZero.cr Normal file
View File

@@ -0,0 +1,3 @@
k x y = x;
main = k 3 (/# 1 0);

4
examples/factorial.hs → examples/Core/factorial.cr
View File

@@ -1,6 +1,6 @@
fac n = case (==#) n 0 of
{ 1 -> 1
; 0 -> (*#) n (fac ((-#) n 1))
{ <1> -> 1
; <0> -> *# n (fac (-# n 1))
};
main = fac 3;

12
examples/Core/sumList.cr Normal file
View File

@@ -0,0 +1,12 @@
{-# PackData Nil 0 0 #-}
{-# PackData Cons 1 2 #-}
foldr f z l = case l of
{ Nil -> z
; Cons x xs -> f x (foldr f z xs)
};
list = Cons 1 (Cons 2 (Cons 3 Nil));
main = foldr (+#) 0 list;

3
examples/constDivZero.hs
View File

@@ -1,3 +0,0 @@
k x y = x;
main = k 3 ((/#) 1 0);

31
examples/rlp/QuickSort.rl Normal file
View File

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

11
examples/rlp/SumList.rl Normal file
View File

@@ -0,0 +1,11 @@
data List a = Nil | Cons a (List a)
foldr :: (a -> b -> b) -> b -> List a -> b
foldr f z l = case l of
Nil -> z
Cons a as -> f a (foldr f z as)
list = Cons 1 (Cons 2 (Cons 3 Nil))
main = print# (foldr (+#) 0 list)

9
examples/sumList.hs
View File

@@ -1,9 +0,0 @@
nil = Pack{0 0};
cons x y = Pack{1 2} x y;
list = cons 1 (cons 2 (cons 3 nil));
sum l = case l of
{ 0 -> 0
; 1 x xs -> (+#) x (sum xs)
};
main = sum list;

105
programming-language-checklist Normal file
View File

@@ -0,0 +1,105 @@
Programming Language Checklist
by Colin McMillen, Jason Reed, and Elly Fong-Jones, 2011-10-10.
You appear to be advocating a new:
[x] functional [ ] imperative [ ] object-oriented [ ] procedural [ ] stack-based
[ ] "multi-paradigm" [x] lazy [ ] eager [x] statically-typed [ ] dynamically-typed
[x] pure [ ] impure [ ] non-hygienic [ ] visual [x] beginner-friendly
[ ] non-programmer-friendly [ ] completely incomprehensible
programming language. Your language will not work. Here is why it will not work.
You appear to believe that:
[ ] Syntax is what makes programming difficult
[x] Garbage collection is free [x] Computers have infinite memory
[x] Nobody really needs:
[x] concurrency [x] a REPL [x] debugger support [x] IDE support [x] I/O
[x] to interact with code not written in your language
[ ] The entire world speaks 7-bit ASCII
[ ] Scaling up to large software projects will be easy
[ ] Convincing programmers to adopt a new language will be easy
[ ] Convincing programmers to adopt a language-specific IDE will be easy
[ ] Programmers love writing lots of boilerplate
[ ] Specifying behaviors as "undefined" means that programmers won't rely on them
[ ] "Spooky action at a distance" makes programming more fun
Unfortunately, your language (has/lacks):
[x] comprehensible syntax [ ] semicolons [x] significant whitespace [ ] macros
[ ] implicit type conversion [ ] explicit casting [x] type inference
[ ] goto [ ] exceptions [x] closures [x] tail recursion [ ] coroutines
[ ] reflection [ ] subtyping [ ] multiple inheritance [x] operator overloading
[x] algebraic datatypes [x] recursive types [x] polymorphic types
[ ] covariant array typing [x] monads [ ] dependent types
[x] infix operators [x] nested comments [ ] multi-line strings [ ] regexes
[ ] call-by-value [x] call-by-name [ ] call-by-reference [ ] call-cc
The following philosophical objections apply:
[ ] Programmers should not need to understand category theory to write "Hello, World!"
[ ] Programmers should not develop RSI from writing "Hello, World!"
[ ] The most significant program written in your language is its own compiler
[x] The most significant program written in your language isn't even its own compiler
[x] No language spec
[x] "The implementation is the spec"
[ ] The implementation is closed-source [ ] covered by patents [ ] not owned by you
[ ] Your type system is unsound [ ] Your language cannot be unambiguously parsed
[ ] a proof of same is attached
[ ] invoking this proof crashes the compiler
[x] The name of your language makes it impossible to find on Google
[x] Interpreted languages will never be as fast as C
[ ] Compiled languages will never be "extensible"
[ ] Writing a compiler that understands English is AI-complete
[ ] Your language relies on an optimization which has never been shown possible
[ ] There are less than 100 programmers on Earth smart enough to use your language
[ ] ____________________________ takes exponential time
[ ] ____________________________ is known to be undecidable
Your implementation has the following flaws:
[ ] CPUs do not work that way
[ ] RAM does not work that way
[ ] VMs do not work that way
[ ] Compilers do not work that way
[ ] Compilers cannot work that way
[ ] Shift-reduce conflicts in parsing seem to be resolved using rand()
[ ] You require the compiler to be present at runtime
[ ] You require the language runtime to be present at compile-time
[ ] Your compiler errors are completely inscrutable
[ ] Dangerous behavior is only a warning
[ ] The compiler crashes if you look at it funny
[x] The VM crashes if you look at it funny
[x] You don't seem to understand basic optimization techniques
[x] You don't seem to understand basic systems programming
[ ] You don't seem to understand pointers
[ ] You don't seem to understand functions
Additionally, your marketing has the following problems:
[x] Unsupported claims of increased productivity
[x] Unsupported claims of greater "ease of use"
[ ] Obviously rigged benchmarks
[ ] Graphics, simulation, or crypto benchmarks where your code just calls
handwritten assembly through your FFI
[ ] String-processing benchmarks where you just call PCRE
[ ] Matrix-math benchmarks where you just call BLAS
[x] Noone really believes that your language is faster than:
[x] assembly [x] C [x] FORTRAN [x] Java [x] Ruby [ ] Prolog
[ ] Rejection of orthodox programming-language theory without justification
[x] Rejection of orthodox systems programming without justification
[ ] Rejection of orthodox algorithmic theory without justification
[ ] Rejection of basic computer science without justification
Taking the wider ecosystem into account, I would like to note that:
[x] Your complex sample code would be one line in: examples/
[ ] We already have an unsafe imperative language
[ ] We already have a safe imperative OO language
[x] We already have a safe statically-typed eager functional language
[ ] You have reinvented Lisp but worse
[ ] You have reinvented Javascript but worse
[ ] You have reinvented Java but worse
[ ] You have reinvented C++ but worse
[ ] You have reinvented PHP but worse
[ ] You have reinvented PHP better, but that's still no justification
[ ] You have reinvented Brainfuck but non-ironically
In conclusion, this is what I think of you:
[ ] You have some interesting ideas, but this won't fly.
[x] This is a bad language, and you should feel bad for inventing it.
[ ] Programming in this language is an adequate punishment for inventing it.

93
rlp.cabal
View File

@@ -7,11 +7,12 @@ license: GPL-2.0-only
-- license-file: LICENSE
author: crumbtoo
maintainer: crumb@disroot.org
-- copyright:
copyright: Madeleine Sydney Ślaga
category: Language
build-type: Simple
extra-doc-files: README.md
-- extra-source-files:
tested-with: GHC==9.6.2
common warnings
-- ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-unused-top-binds
@@ -22,53 +23,89 @@ library
, TI
, GM
, Compiler.RLPC
, Compiler.RlpcError
, Compiler.JustRun
, Core.Syntax
, Core.Examples
, Core.Utils
, Core.TH
other-modules: Data.Heap
, Core.HindleyMilner
, Control.Monad.Errorful
, Rlp.Syntax
-- , Rlp.Parse.Decls
, Rlp.Parse
, Rlp.Parse.Associate
, Rlp.Lex
, Rlp.Parse.Types
, Rlp.TH
, Compiler.Types
, Data.Heap
, Data.Pretty
, Core.Parse
, Core.Lex
, Control.Monad.Errorful
, Core2Core
, RLP.Syntax
, Rlp2Core
, Control.Monad.Utils
build-tool-depends: happy:happy, alex:alex
-- other-extensions:
build-depends: base ^>=4.18.0.0
, containers
, microlens
, microlens-th
, mtl
, template-haskell
build-depends: base >=4.17 && <4.20
-- required for happy
, array
, data-default-class
, unordered-containers
, hashable
, pretty
, recursion-schemes
, megaparsec
, text
, array >= 0.5.5 && < 0.6
, containers >= 0.6.7 && < 0.7
, template-haskell >= 2.20.0 && < 2.21
, pretty >= 1.1.3 && < 1.2
, data-default >= 0.7.1 && < 0.8
, data-default-class >= 0.1.2 && < 0.2
, hashable >= 1.4.3 && < 1.5
, mtl >= 2.3.1 && < 2.4
, text >= 2.0.2 && < 2.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
, 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
, effectful-core ^>=2.3.0.0
, deriving-compat ^>=0.6.0
, these >=0.2 && <2.0
hs-source-dirs: src
default-language: GHC2021
default-extensions:
OverloadedStrings
TypeFamilies
LambdaCase
ViewPatterns
DataKinds
DerivingVia
StandaloneDeriving
DerivingStrategies
executable rlpc
import: warnings
main-is: Main.hs
-- other-modules:
-- other-extensions:
build-depends: base ^>=4.18.0.0
other-modules: RlpDriver
, CoreDriver
build-depends: base >=4.17.0.0 && <4.20.0.0
, rlp
, optparse-applicative
, microlens
, microlens-mtl
, mtl
, unordered-containers
, 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
hs-source-dirs: app
default-language: GHC2021
@@ -84,7 +121,9 @@ test-suite rlp-test
, rlp
, QuickCheck
, hspec ==2.*
, microlens
other-modules: Arith
, GMSpec
, Core.HindleyMilnerSpec
build-tool-depends: hspec-discover:hspec-discover

253
rlpc.drawio Normal file
View File

@@ -0,0 +1,253 @@
<mxfile host="app.diagrams.net" modified="2024-02-08T07:33:52.268Z" agent="Mozilla/5.0 (Macintosh; Intel Mac OS X 10.15; rv:122.0) Gecko/20100101 Firefox/122.0" etag="_2ex2NLQLCDMU70EmKFT" version="23.0.2" type="device">
<diagram name="Page-1" id="ijVUcW-Be2043inOeyM6">
<mxGraphModel dx="1629" dy="2189" grid="1" gridSize="10" guides="1" tooltips="1" connect="1" arrows="1" fold="1" page="1" pageScale="1" pageWidth="827" pageHeight="1169" math="0" shadow="0">
<root>
<mxCell id="0" />
<mxCell id="1" parent="0" />
<mxCell id="l7NxJpuHm0Jx_7flO9iA-64" value="&lt;div&gt;&lt;font face=&quot;Helvetica&quot;&gt;rl&#39; source code&lt;/font&gt;&lt;/div&gt;" style="rounded=0;whiteSpace=wrap;html=1;fillColor=#fff2cc;strokeColor=#d6b656;fontFamily=Courier New;" parent="1" vertex="1">
<mxGeometry x="10" y="154.92" width="120" height="60" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-72" value="" style="group;fontFamily=Courier New;" parent="1" vertex="1" connectable="0">
<mxGeometry x="150" y="-60" width="1440" height="780" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-2" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-72" vertex="1">
<mxGeometry width="1440" height="780" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-3" value="&lt;div&gt;&lt;font face=&quot;Helvetica&quot;&gt;RLPC&lt;/font&gt;&lt;/div&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-2" vertex="1">
<mxGeometry width="1440" height="76.09756097560975" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-56" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-2" vertex="1">
<mxGeometry x="38.4" y="68.42" width="431.6" height="221.58" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-57" value="&lt;div&gt;&lt;font face=&quot;Helvetica&quot;&gt;Parser&lt;/font&gt;&lt;/div&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-56" vertex="1">
<mxGeometry width="431.6" height="27.6975" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-58" value="Rlp.Parse&lt;br&gt;&lt;div&gt;(src/Rlp/Parse.y)&lt;/div&gt;" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;whiteSpace=wrap;points=[];strokeColor=#6c8ebf;fillColor=#dae8fc;glass=0;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-56" vertex="1">
<mxGeometry x="26.980533333333334" y="27.6975" width="371.43053333333336" height="55.395" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-59" value="&lt;div&gt;Rlp.Lex&lt;/div&gt;&lt;div&gt;&lt;br&gt;&lt;/div&gt;&lt;div&gt;(src/Rlp/Lex.x)&lt;br&gt;&lt;/div&gt;" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-56" vertex="1">
<mxGeometry x="26.98606666666666" y="147.72" width="170.33402285714286" height="55.395" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-61" value="" style="endArrow=classic;html=1;rounded=0;fontFamily=Courier New;exitX=0.25;exitY=0;exitDx=0;exitDy=0;" parent="l7NxJpuHm0Jx_7flO9iA-56" edge="1" source="l7NxJpuHm0Jx_7flO9iA-59">
<mxGeometry relative="1" as="geometry">
<mxPoint x="111.49666666666668" y="147.72" as="sourcePoint" />
<mxPoint x="69.26631355932203" y="83.84879190161169" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-62" value="&lt;div&gt;RlpToken&lt;/div&gt;" style="edgeLabel;resizable=0;html=1;align=center;verticalAlign=middle;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-61" connectable="0" vertex="1">
<mxGeometry relative="1" as="geometry">
<mxPoint x="-33" y="5" as="offset" />
</mxGeometry>
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-74" value="&lt;div&gt;Rlp.Parse.Associate&lt;/div&gt;" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-56" vertex="1">
<mxGeometry x="244.26979047619054" y="147.72" width="154.14285714285714" height="55.395" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-75" value="" style="endArrow=classic;html=1;rounded=0;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-56" source="l7NxJpuHm0Jx_7flO9iA-58" target="l7NxJpuHm0Jx_7flO9iA-74" edge="1">
<mxGeometry relative="1" as="geometry">
<mxPoint x="271.29142857142864" y="175.4175" as="sourcePoint" />
<mxPoint x="394.60571428571427" y="175.4175" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-77" value="&lt;div&gt;RlpProgram&#39; RlpcPs&lt;/div&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-75" vertex="1" connectable="0">
<mxGeometry x="0.0677" y="5" relative="1" as="geometry">
<mxPoint x="39" y="6" as="offset" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-3" value="" style="endArrow=classic;html=1;rounded=0;exitX=0.368;exitY=1.014;exitDx=0;exitDy=0;exitPerimeter=0;entryX=0.811;entryY=-0.021;entryDx=0;entryDy=0;entryPerimeter=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-56" source="l7NxJpuHm0Jx_7flO9iA-58" target="l7NxJpuHm0Jx_7flO9iA-59">
<mxGeometry width="50" height="50" relative="1" as="geometry">
<mxPoint x="168.70805084745763" y="201.9041131288017" as="sourcePoint" />
<mxPoint x="225.8584745762712" y="152.71439595080588" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-4" value="&lt;p style=&quot;line-height: 60%;&quot;&gt;&lt;font style=&quot;font-size: 7px;&quot;&gt;(lexer &amp;amp; parser threaded w/ CPS)&lt;/font&gt;&lt;/p&gt;" style="text;html=1;strokeColor=none;fillColor=none;align=center;verticalAlign=middle;whiteSpace=wrap;rounded=0;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-56">
<mxGeometry x="88.69745762711862" y="103.52467877281002" width="68.58050847457626" height="29.513830306797498" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-69" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-2" vertex="1">
<mxGeometry x="38.4" y="531.8231578947368" width="431.6" height="230.4557894736842" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-70" value="&lt;div&gt;&lt;font face=&quot;Helvetica&quot;&gt;Desugarer&lt;/font&gt;&lt;/div&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-69" vertex="1">
<mxGeometry width="431.6" height="46.091157894736845" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-1" value="&lt;div&gt;Rlp2Core&lt;/div&gt;" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-69">
<mxGeometry x="22.122266666666665" y="46.088669843028626" width="387.34440000000006" height="159.17559608494923" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-6" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
<mxGeometry x="904" y="68.42105263157895" width="186.6" height="697.8947368421053" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-7" value="&lt;font face=&quot;Helvetica&quot;&gt;Evaluation Model&lt;br&gt;&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
<mxGeometry width="186.6" height="107.07065060420568" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-8" value="GM" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
<mxGeometry x="9.568013810372213" y="356.90796215152363" width="167.46559322033886" height="82.98740890928475" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-9" value="TM" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
<mxGeometry x="9.562261652542377" y="263.9548629430177" width="167.46559322033886" height="82.98740890928475" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-10" value="TIM" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
<mxGeometry x="9.56226165254238" y="168.9311122835313" width="167.46559322033886" height="82.98740890928475" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-11" value="STG" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
<mxGeometry x="9.56720338983051" y="73.90736162404495" width="167.46559322033886" height="82.98740890928475" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-12" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
<mxGeometry x="530" y="68.42" width="281.6" height="314.74" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-13" value="&lt;div&gt;&lt;font face=&quot;Helvetica&quot;&gt;Preprocessing&lt;/font&gt;&lt;/div&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-12">
<mxGeometry width="281.5999999999999" height="24.68549019607843" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-15" value="Core2Core" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;verticalAlign=top;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-12">
<mxGeometry x="22.25077720207253" y="49.37098039215686" width="237.09844559585483" height="259.1976470588235" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-16" value="&lt;font face=&quot;Courier New&quot;&gt;tagData&lt;/font&gt;" style="rounded=1;whiteSpace=wrap;html=1;fillColor=#d5e8d4;strokeColor=#82b366;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-12">
<mxGeometry x="31.36994818652857" y="74.0564705882353" width="218.860103626943" height="37.02823529411765" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-18" value="&lt;font face=&quot;Courier New&quot;&gt;defineData&lt;/font&gt;" style="rounded=1;whiteSpace=wrap;html=1;fillColor=#d5e8d4;strokeColor=#82b366;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-12">
<mxGeometry x="31.36994818652857" y="160.45568627450984" width="218.860103626943" height="37.02823529411765" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-17" value="&lt;font face=&quot;Courier New&quot;&gt;liftNonStrictCases&lt;/font&gt;" style="rounded=1;whiteSpace=wrap;html=1;fillColor=#d5e8d4;strokeColor=#82b366;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-12">
<mxGeometry x="31.369948186528582" y="118.66932274509804" width="218.860103626943" height="37.02823529411765" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-20" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
<mxGeometry x="1240" y="68.42105263157895" width="186.6" height="697.8947368421053" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-21" value="&lt;font face=&quot;Helvetica&quot;&gt;Some target&lt;br&gt;&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-20">
<mxGeometry width="186.6" height="107.07065060420568" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-27" value="" style="endArrow=classic;html=1;rounded=0;entryX=-0.019;entryY=0.844;entryDx=0;entryDy=0;entryPerimeter=0;exitX=0.98;exitY=0.066;exitDx=0;exitDy=0;exitPerimeter=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-2" source="MMc0v0DIyy0xya0iXp__-1" target="MMc0v0DIyy0xya0iXp__-12">
<mxGeometry width="50" height="50" relative="1" as="geometry">
<mxPoint x="450" y="684.2105263157895" as="sourcePoint" />
<mxPoint x="500" y="615.7894736842105" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-28" value="&lt;font face=&quot;Courier New&quot;&gt;Program&#39;&lt;/font&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];" vertex="1" connectable="0" parent="MMc0v0DIyy0xya0iXp__-27">
<mxGeometry x="-0.1473" y="1" relative="1" as="geometry">
<mxPoint x="7" y="1" as="offset" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-30" value="" style="endArrow=classic;html=1;rounded=0;entryX=-0.013;entryY=0.321;entryDx=0;entryDy=0;exitX=1;exitY=0.5;exitDx=0;exitDy=0;entryPerimeter=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-2" source="MMc0v0DIyy0xya0iXp__-12" target="MMc0v0DIyy0xya0iXp__-6">
<mxGeometry width="50" height="50" relative="1" as="geometry">
<mxPoint x="810" y="588.421052631579" as="sourcePoint" />
<mxPoint x="860" y="520" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-31" value="&lt;font face=&quot;Courier New&quot;&gt;Program&#39;&lt;/font&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];" vertex="1" connectable="0" parent="MMc0v0DIyy0xya0iXp__-30">
<mxGeometry x="0.0097" y="-1" relative="1" as="geometry">
<mxPoint x="-1" as="offset" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-32" value="" style="endArrow=classic;html=1;rounded=0;entryX=0;entryY=0.5;entryDx=0;entryDy=0;exitX=1;exitY=0.5;exitDx=0;exitDy=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-2" source="MMc0v0DIyy0xya0iXp__-6" target="MMc0v0DIyy0xya0iXp__-20">
<mxGeometry width="50" height="50" relative="1" as="geometry">
<mxPoint x="810" y="588.421052631579" as="sourcePoint" />
<mxPoint x="860" y="520" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-33" value="&lt;font face=&quot;Courier New&quot;&gt;[Instr]&lt;/font&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];" vertex="1" connectable="0" parent="MMc0v0DIyy0xya0iXp__-32">
<mxGeometry x="0.0406" y="1" relative="1" as="geometry">
<mxPoint as="offset" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-35" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
<mxGeometry x="530" y="630" width="281.6" height="131.32" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-36" value="&lt;font face=&quot;Helvetica&quot;&gt;Core Parser&lt;br&gt;&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-35">
<mxGeometry width="281.59999999999997" height="10.299607843137254" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-41" value="Core.Lex" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-35">
<mxGeometry x="10.140518134715029" y="16.369019607843132" width="87.1306390328152" height="106.24535947712415" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-42" value="Core.Parse" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-35">
<mxGeometry x="182.3834196891192" y="16.369019607843146" width="87.1306390328152" height="106.24535947712415" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-43" value="&lt;font face=&quot;Courier New&quot;&gt;CoreToken&lt;/font&gt;" style="endArrow=classic;html=1;rounded=0;entryX=0;entryY=0.5;entryDx=0;entryDy=0;exitX=1;exitY=0.5;exitDx=0;exitDy=0;" edge="1" parent="MMc0v0DIyy0xya0iXp__-35" source="MMc0v0DIyy0xya0iXp__-41" target="MMc0v0DIyy0xya0iXp__-42">
<mxGeometry width="50" height="50" relative="1" as="geometry">
<mxPoint x="-72.95336787564769" y="39.35921568627452" as="sourcePoint" />
<mxPoint x="-12.15889464594128" y="1.0422222222222326" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-51" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
<mxGeometry x="530" y="440" width="281.6" height="131.32" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-52" value="&lt;font face=&quot;Helvetica&quot;&gt;Core Type-checker&lt;br&gt;&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-51">
<mxGeometry width="281.59999999999997" height="10.299607843137254" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-46" value="(currently unimplemented)" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-72">
<mxGeometry x="40" y="360" width="431.6" height="90.46" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-47" value="&lt;font face=&quot;Verdana&quot;&gt;Type-checker&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-46">
<mxGeometry width="431.6" height="18.092000000000002" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-80" value="" style="endArrow=classic;html=1;rounded=0;" parent="l7NxJpuHm0Jx_7flO9iA-72" source="l7NxJpuHm0Jx_7flO9iA-74" target="MMc0v0DIyy0xya0iXp__-46" edge="1">
<mxGeometry relative="1" as="geometry">
<mxPoint x="537.6" y="424.2105263157895" as="sourcePoint" />
<mxPoint x="-40" y="490" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-81" value="&lt;font face=&quot;Courier New&quot;&gt;RlpProgram&#39; RlpcPs&lt;br&gt;&lt;/font&gt;" style="edgeLabel;resizable=0;html=1;align=center;verticalAlign=middle;" parent="l7NxJpuHm0Jx_7flO9iA-80" connectable="0" vertex="1">
<mxGeometry relative="1" as="geometry">
<mxPoint x="6" as="offset" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-49" value="" style="endArrow=classic;html=1;rounded=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-72" source="MMc0v0DIyy0xya0iXp__-46" target="l7NxJpuHm0Jx_7flO9iA-69">
<mxGeometry relative="1" as="geometry">
<mxPoint x="352" y="282" as="sourcePoint" />
<mxPoint x="295" y="370" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-50" value="&lt;font face=&quot;Courier New&quot;&gt;RlpProgram&#39; RlpcTc&lt;/font&gt;" style="edgeLabel;resizable=0;html=1;align=center;verticalAlign=middle;" connectable="0" vertex="1" parent="MMc0v0DIyy0xya0iXp__-49">
<mxGeometry relative="1" as="geometry">
<mxPoint x="6" as="offset" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-57" value="Core.HindleyMilner" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-72">
<mxGeometry x="540" y="460" width="260" height="106.24" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-58" value="" style="endArrow=classic;html=1;rounded=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-72" source="MMc0v0DIyy0xya0iXp__-42" target="MMc0v0DIyy0xya0iXp__-57">
<mxGeometry width="50" height="50" relative="1" as="geometry">
<mxPoint x="530" y="550" as="sourcePoint" />
<mxPoint x="580" y="500" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-59" value="Program&#39;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];fontFamily=Courier New;" vertex="1" connectable="0" parent="MMc0v0DIyy0xya0iXp__-58">
<mxGeometry x="-0.0188" y="-3" relative="1" as="geometry">
<mxPoint y="-1" as="offset" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-60" value="" style="endArrow=classic;html=1;rounded=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-72" source="MMc0v0DIyy0xya0iXp__-57" target="MMc0v0DIyy0xya0iXp__-15">
<mxGeometry width="50" height="50" relative="1" as="geometry">
<mxPoint x="741" y="656" as="sourcePoint" />
<mxPoint x="704" y="576" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-61" value="Program&#39;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];fontFamily=Courier New;" vertex="1" connectable="0" parent="MMc0v0DIyy0xya0iXp__-60">
<mxGeometry x="-0.0188" y="-3" relative="1" as="geometry">
<mxPoint y="-1" as="offset" />
</mxGeometry>
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-65" value="" style="endArrow=classic;html=1;rounded=0;fontFamily=Courier New;" parent="1" source="l7NxJpuHm0Jx_7flO9iA-64" target="l7NxJpuHm0Jx_7flO9iA-59" edge="1">
<mxGeometry width="50" height="50" relative="1" as="geometry">
<mxPoint x="290" y="400" as="sourcePoint" />
<mxPoint x="340" y="350" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-26" value="&lt;font face=&quot;Helvetica&quot;&gt;Core source code&lt;br&gt;&lt;/font&gt;" style="rounded=0;whiteSpace=wrap;html=1;fillColor=#fff2cc;strokeColor=#d6b656;fontFamily=Courier New;" vertex="1" parent="1">
<mxGeometry x="673.7099999999999" y="740" width="120" height="60" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-29" value="&lt;div&gt;&lt;font face=&quot;Helvetica&quot;&gt;???&lt;/font&gt;&lt;/div&gt;" style="rounded=0;whiteSpace=wrap;html=1;fillColor=#fff2cc;strokeColor=#d6b656;fontFamily=Courier New;" vertex="1" parent="1">
<mxGeometry x="1420" y="730" width="120" height="60" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-34" value="" style="endArrow=classic;html=1;rounded=0;exitX=0.5;exitY=0;exitDx=0;exitDy=0;" edge="1" parent="1" source="MMc0v0DIyy0xya0iXp__-26" target="MMc0v0DIyy0xya0iXp__-41">
<mxGeometry width="50" height="50" relative="1" as="geometry">
<mxPoint x="960" y="370" as="sourcePoint" />
<mxPoint x="690" y="570" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-62" value="" style="endArrow=classic;html=1;rounded=0;" edge="1" parent="1" source="MMc0v0DIyy0xya0iXp__-20" target="MMc0v0DIyy0xya0iXp__-29">
<mxGeometry width="50" height="50" relative="1" as="geometry">
<mxPoint x="1060" y="650" as="sourcePoint" />
<mxPoint x="1110" y="600" as="targetPoint" />
</mxGeometry>
</mxCell>
</root>
</mxGraphModel>
</diagram>
</mxfile>

4
rlpc.drawio.svg Normal file
View File

File diff suppressed because one or more lines are too long
Side by Side

After

Width:  |  Height:  |  Size: 390 KiB

59
src/Compiler/JustRun.hs Normal file
View File

@@ -0,0 +1,59 @@
{-|
Module : Compiler.JustRun
Description : No-BS, high-level wrappers for major pipeline pieces.
A collection of wrapper functions to demo processes such as lexing, parsing,
type-checking, and evaluation. This module intends to export "no-BS" functions
that use Prelude types such as @Either@ and @String@ rather than more complex
types such as @RLPC@ or @Text@.
-}
module Compiler.JustRun
( justLexCore
, justParseCore
, justTypeCheckCore
, justHdbg
)
where
----------------------------------------------------------------------------------
import Core.Lex
import Core.Parse
import Core.HindleyMilner
import Core.Syntax (Program')
import Compiler.RLPC
import Control.Arrow ((>>>))
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
& rlpcToEither
justParseCore :: String -> Either [MsgEnvelope RlpcError] Program'
justParseCore s = parse (T.pack s)
& rlpcToEither
where parse = lexCoreR >=> parseCoreProgR
justTypeCheckCore :: String -> Either [MsgEnvelope RlpcError] Program'
justTypeCheckCore s = typechk (T.pack s)
& rlpcToEither
where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR
rlpcToEither :: RLPC a -> Either [MsgEnvelope RlpcError] a
rlpcToEither r = case evalRLPC def r of
(Just a, _) -> Right a
(Nothing, es) -> Left es

274
src/Compiler/RLPC.hs
View File

@@ -10,96 +10,116 @@ errors and the family of RLPC monads.
{-# LANGUAGE TemplateHaskell #-}
-- only used for mtl instances
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia #-}
{-# LANGUAGE BlockArguments, ViewPatterns #-}
module Compiler.RLPC
( RLPC
, RLPCT
, RLPCIO
, RLPCOptions(RLPCOptions)
, addFatal
, addWound
, MonadErrorful
, Severity(..)
, Evaluator(..)
, evalRLPCT
, evalRLPCIO
, evalRLPC
, rlpcLogFile
, rlpcDebugOpts
, rlpcEvaluator
, rlpcInputFiles
, DebugFlag(..)
, whenFlag
, flagDDumpEval
, flagDDumpOpts
, flagDDumpAST
, def
(
-- * Rlpc Monad transformer
RLPCT(RLPCT),
-- ** Special cases
RLPC, RLPCIO
, liftIO
-- ** Running
, runRLPCT
, evalRLPCT, evalRLPCIO, evalRLPC
-- * Rlpc options
, Language(..), Evaluator(..)
, DebugFlag(..), CompilerFlag(..)
-- ** Lenses
, rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage
-- * Misc. MTL-style functions
, liftErrorful, hoistRlpcT
-- * Misc. Rlpc Monad -related types
, RLPCOptions(RLPCOptions), IsRlpcError(..), RlpcError(..)
, MsgEnvelope(..), Severity(..)
, addDebugMsg
, whenDFlag, whenFFlag
-- * Misc. Utilities
, forFiles_, withSource
-- * Convenient re-exports
, addFatal, addWound, def
)
where
----------------------------------------------------------------------------------
import Control.Arrow ((>>>))
import Control.Exception
import Control.Monad
import Control.Monad.Reader
import Control.Monad.State (MonadState(state))
import Control.Monad.Errorful
import Control.Monad.IO.Class
import Compiler.RlpcError
import Compiler.Types
import Data.Functor.Identity
import Data.Default.Class
import Data.Foldable
import GHC.Generics (Generic)
import Data.Maybe
import Data.Hashable (Hashable)
import Data.HashSet (HashSet)
import Data.HashSet qualified as S
import Data.Coerce
import Lens.Micro
import Lens.Micro.TH
import Data.Text (Text)
import Data.Text qualified as T
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 System.Exit
----------------------------------------------------------------------------------
-- TODO: fancy errors
newtype RLPCT e m a = RLPCT {
runRLPCT :: ReaderT RLPCOptions (ErrorfulT e m) a
newtype RLPCT m a = RLPCT {
runRLPCT :: ReaderT RLPCOptions (ErrorfulT (MsgEnvelope RlpcError) m) a
}
-- TODO: incorrect ussage of MonadReader. RLPC should have its own
-- environment access functions
deriving (Functor, Applicative, Monad, MonadReader RLPCOptions)
deriving ( Functor, Applicative, Monad
, MonadReader RLPCOptions, MonadErrorful (MsgEnvelope RlpcError))
deriving instance (MonadIO m) => MonadIO (RLPCT e m)
rlpc :: (IsRlpcError e, Monad m)
=> (RLPCOptions -> (Maybe a, [MsgEnvelope e]))
-> RLPCT m a
rlpc f = RLPCT . ReaderT $ \opt ->
ErrorfulT . pure $ f opt & _2 . each . mapped %~ liftRlpcError
instance MonadTrans (RLPCT e) where
type RLPC = RLPCT Identity
type RLPCIO = RLPCT IO
instance MonadTrans RLPCT where
lift = RLPCT . lift . lift
instance (MonadState s m) => MonadState s (RLPCT e m) where
state = lift . state
type RLPC e = RLPCT e Identity
type RLPCIO e = RLPCT e IO
evalRLPCT :: RLPCOptions
-> RLPCT e m a
-> m (Either e (a, [e]))
evalRLPCT o = runRLPCT >>> flip runReaderT o >>> runErrorfulT
instance (MonadIO m) => MonadIO (RLPCT m) where
liftIO = lift . liftIO
evalRLPC :: RLPCOptions
-> RLPC e a
-> Either e (a, [e])
evalRLPC o m = coerce $ evalRLPCT o m
-> RLPC a
-> (Maybe a, [MsgEnvelope RlpcError])
evalRLPC opt r = runRLPCT r
& flip runReaderT opt
& runErrorful
evalRLPCIO :: (Exception e)
=> RLPCOptions
-> RLPCIO e a
-> IO (a, [e])
evalRLPCIO o m = do
m' <- evalRLPCT o m
case m' of
-- TODO: errors
Left e -> throwIO e
Right a -> pure a
evalRLPCT :: RLPCOptions
-> RLPCT m a
-> m (Maybe a, [MsgEnvelope RlpcError])
evalRLPCT opt r = runRLPCT r
& flip runReaderT opt
& runErrorfulT
liftErrorful :: (Monad m, IsRlpcError e) => ErrorfulT (MsgEnvelope e) m a -> RLPCT m a
liftErrorful e = RLPCT $ lift (fmap liftRlpcError `mapErrorful` e)
hoistRlpcT :: (forall a. m a -> n a)
-> RLPCT m a -> RLPCT n a
hoistRlpcT f rma = RLPCT $ ReaderT $ \opt ->
ErrorfulT $ f $ evalRLPCT opt rma
data RLPCOptions = RLPCOptions
{ _rlpcLogFile :: Maybe FilePath
, _rlpcDebugOpts :: DebugOpts
, _rlpcDFlags :: HashSet DebugFlag
, _rlpcFFlags :: HashSet CompilerFlag
, _rlpcEvaluator :: Evaluator
, _rlpcHeapTrigger :: Int
, _rlpcLanguage :: Maybe Language
, _rlpcInputFiles :: [FilePath]
}
deriving Show
@@ -107,58 +127,126 @@ data RLPCOptions = RLPCOptions
data Evaluator = EvaluatorGM | EvaluatorTI
deriving Show
data Severity = Error
| Warning
| Debug
deriving Show
-- temporary until we have a new doc building system
type ErrorDoc = String
class Diagnostic e where
errorDoc :: e -> ErrorDoc
instance (Monad m) => MonadErrorful e (RLPCT e m) where
addWound = RLPCT . lift . addWound
addFatal = RLPCT . lift . addFatal
data Language = LanguageRlp | LanguageCore
deriving Show
----------------------------------------------------------------------------------
instance Default RLPCOptions where
def = RLPCOptions
{ _rlpcLogFile = Nothing
, _rlpcDebugOpts = mempty
, _rlpcDFlags = mempty
, _rlpcFFlags = mempty
, _rlpcEvaluator = EvaluatorGM
, _rlpcHeapTrigger = 200
, _rlpcInputFiles = []
, _rlpcLanguage = Nothing
}
type DebugOpts = HashSet DebugFlag
-- debug flags are passed with -dFLAG
type DebugFlag = Text
data DebugFlag = DDumpEval
| DDumpOpts
| DDumpAST
deriving (Show, Eq, Generic)
instance Hashable DebugFlag
type CompilerFlag = Text
makeLenses ''RLPCOptions
pure []
whenFlag :: (MonadReader s m) => SimpleGetter s Bool -> m () -> m ()
whenFlag l m = asks (^. l) >>= \a -> if a then m else pure ()
addDebugMsg :: (Monad m, IsText e) => Text -> e -> RLPCT m ()
addDebugMsg tag e = addWound . debugMsg tag $ Text [e ^. unpacked . packed]
-- there's probably a better way to write this. my current knowledge of lenses
-- is too weak.
flagGetter :: DebugFlag -> SimpleGetter RLPCOptions Bool
flagGetter d = to $ \s -> s ^. rlpcDebugOpts & S.member d
-- TODO: rewrite this with prisms once microlens-pro drops :3
whenDFlag :: (Monad m) => DebugFlag -> RLPCT m () -> RLPCT m ()
whenDFlag f m = do
-- mfw no `At` instance for HashSet
fs <- view rlpcDFlags
let a = S.member f fs
when a m
flagDDumpEval :: SimpleGetter RLPCOptions Bool
flagDDumpEval = flagGetter DDumpEval
whenFFlag :: (Monad m) => CompilerFlag -> RLPCT m () -> RLPCT m ()
whenFFlag f m = do
-- mfw no `At` instance for HashSet
fs <- view rlpcFFlags
let a = S.member f fs
when a m
flagDDumpOpts :: SimpleGetter RLPCOptions Bool
flagDDumpOpts = flagGetter DDumpOpts
--------------------------------------------------------------------------------
flagDDumpAST :: SimpleGetter RLPCOptions Bool
flagDDumpAST = flagGetter DDumpAST
evalRLPCIO :: RLPCOptions -> RLPCIO a -> IO a
evalRLPCIO opt r = do
(ma,es) <- evalRLPCT opt r
putRlpcErrs opt es
case ma of
Just x -> pure x
Nothing -> die "Failed, no code compiled."
putRlpcErrs :: RLPCOptions -> [MsgEnvelope RlpcError] -> IO ()
putRlpcErrs opt es = case opt ^. rlpcLogFile of
Just lf -> withFile lf WriteMode putter
Nothing -> putter stderr
where
putter h = hPutStrLn h `traverse_` renderRlpcErrs opt es
renderRlpcErrs :: RLPCOptions -> [MsgEnvelope RlpcError] -> [String]
renderRlpcErrs opts = (if don'tBother then id else filter byTag)
>>> fmap prettyRlpcMsg
where
dflags = opts ^. rlpcDFlags
don'tBother = "ALL" `S.member` (opts ^. rlpcDFlags)
byTag :: MsgEnvelope RlpcError -> Bool
byTag (view msgSeverity -> SevDebug t) =
t `S.member` dflags
byTag _ = True
prettyRlpcMsg :: MsgEnvelope RlpcError -> String
prettyRlpcMsg m@(view msgSeverity -> SevDebug _) = prettyRlpcDebugMsg m
prettyRlpcMsg m = render $ docRlpcErr m
prettyRlpcDebugMsg :: MsgEnvelope RlpcError -> String
prettyRlpcDebugMsg msg =
T.unpack . foldMap mkLine $ [ t' | t <- ts, t' <- T.lines t ]
where
mkLine s = "-d" <> tag <> ": " <> s <> "\n"
Text ts = msg ^. msgDiagnostic
SevDebug tag = msg ^. msgSeverity
docRlpcErr :: MsgEnvelope RlpcError -> Doc
docRlpcErr msg = header
$$ nest 2 bullets
$$ source
where
source = vcat $ zipWith (<+>) rule srclines
where
rule = repeat (ttext . Ansi.blue . Ansi.bold $ "|")
srclines = ["", "<problematic source code>", ""]
filename = msgColour "<input>"
pos = msgColour $ tshow (msg ^. msgSpan . srcspanLine)
<> ":"
<> tshow (msg ^. msgSpan . srcspanColumn)
header = ttext $ filename <> msgColour ":" <> pos <> msgColour ": "
<> errorColour "error" <> msgColour ":"
bullets = let Text ts = msg ^. msgDiagnostic
in vcat $ hang "•" 2 . ttext . msgColour <$> ts
msgColour = Ansi.white . Ansi.bold
errorColour = Ansi.red . Ansi.bold
ttext = text . T.unpack
tshow :: (Show a) => a -> Text
tshow = T.pack . show
--------------------------------------------------------------------------------
forFiles_ :: (Monad m)
=> (FilePath -> RLPCT m a)
-> RLPCT m ()
forFiles_ k = do
fs <- view rlpcInputFiles
forM_ fs k
-- TODO: catch any exceptions, i.e. non-existent files should be handled by the
-- compiler
withSource :: (MonadIO m) => FilePath -> (Text -> RLPCT m a) -> RLPCT m a
withSource f k = liftIO (T.readFile f) >>= k

77
src/Compiler/RlpcError.hs Normal file
View File

@@ -0,0 +1,77 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
module Compiler.RlpcError
( IsRlpcError(..)
, MsgEnvelope(..)
, Severity(..)
, RlpcError(..)
, msgSpan
, msgDiagnostic
, msgSeverity
, liftRlpcErrors
, errorMsg
, debugMsg
-- * Located Comonad
, Located(..)
, SrcSpan(..)
)
where
----------------------------------------------------------------------------------
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 Compiler.Types
----------------------------------------------------------------------------------
data MsgEnvelope e = MsgEnvelope
{ _msgSpan :: SrcSpan
, _msgDiagnostic :: e
, _msgSeverity :: Severity
}
deriving (Functor, Show)
newtype RlpcError = Text [Text]
deriving Show
instance IsString RlpcError where
fromString = Text . pure . T.pack
class IsRlpcError e where
liftRlpcError :: e -> RlpcError
instance IsRlpcError RlpcError where
liftRlpcError = id
data Severity = SevWarning
| SevError
| SevDebug Text -- ^ Tag
deriving Show
makeLenses ''MsgEnvelope
liftRlpcErrors :: (Functor m, IsRlpcError e)
=> ErrorfulT e m a
-> ErrorfulT RlpcError m a
liftRlpcErrors = mapErrorful liftRlpcError
instance (IsRlpcError e) => IsRlpcError (MsgEnvelope e) where
liftRlpcError msg = msg ^. msgDiagnostic & liftRlpcError
errorMsg :: SrcSpan -> e -> MsgEnvelope e
errorMsg s e = MsgEnvelope
{ _msgSpan = s
, _msgDiagnostic = e
, _msgSeverity = SevError
}
debugMsg :: Text -> e -> MsgEnvelope e
debugMsg tag e = MsgEnvelope
-- TODO: not pretty, but it is a debug message after all
{ _msgSpan = SrcSpan 0 0 0 0
, _msgDiagnostic = e
, _msgSeverity = SevDebug tag
}

99
src/Compiler/Types.hs Normal file
View File

@@ -0,0 +1,99 @@
{-# LANGUAGE TemplateHaskell #-}
module Compiler.Types
( SrcSpan(..)
, srcspanLine, srcspanColumn, srcspanAbs, srcspanLen
, Located(..)
, _Located
, located
, nolo
, (<<~), (<~>), (<#>)
-- * Re-exports
, Comonad
, Apply
, Bind
)
where
--------------------------------------------------------------------------------
import Control.Comonad
import Data.Functor.Apply
import Data.Functor.Bind
import Control.Lens hiding ((<<~))
import Language.Haskell.TH.Syntax (Lift)
--------------------------------------------------------------------------------
-- | Token wrapped with a span (line, column, absolute, length)
data Located a = Located SrcSpan a
deriving (Show, Lift, Functor)
located :: Lens (Located a) (Located b) a b
located = lens extract ($>)
instance Apply Located where
liftF2 f (Located sa p) (Located sb q)
= Located (sa <> sb) (p `f` q)
instance Bind Located where
Located sa a >>- k = Located (sa <> sb) b
where
Located sb b = k a
instance Comonad Located where
extract (Located _ a) = a
extend ck w@(Located p _) = Located p (ck w)
data SrcSpan = SrcSpan
!Int -- ^ Line
!Int -- ^ Column
!Int -- ^ Absolute
!Int -- ^ Length
deriving (Show, Lift)
tupling :: Iso' SrcSpan (Int, Int, Int, Int)
tupling = iso (\ (SrcSpan a b c d) -> (a,b,c,d))
(\ (a,b,c,d) -> SrcSpan a b c d)
srcspanLine, srcspanColumn, srcspanAbs, srcspanLen :: Lens' SrcSpan Int
srcspanLine = tupling . _1
srcspanColumn = tupling . _2
srcspanAbs = tupling . _3
srcspanLen = tupling . _4
-- | debug tool
nolo :: a -> Located a
nolo = Located (SrcSpan 0 0 0 0)
instance Semigroup SrcSpan where
SrcSpan la ca aa sa <> SrcSpan lb cb ab sb = SrcSpan l c a s where
l = min la lb
c = min ca cb
a = min aa ab
s = case aa `compare` ab of
EQ -> max sa sb
LT -> max sa (ab + lb - aa)
GT -> max sb (aa + la - ab)
-- | A synonym for '(<<=)' with a tighter precedence and left-associativity for
-- use with '(<~>)' in a sort of, comonadic pseudo-applicative style.
(<<~) :: (Comonad w) => (w a -> b) -> w a -> w b
(<<~) = (<<=)
infixl 4 <<~
-- | Similar to '(<*>)', but with a cokleisli arrow.
(<~>) :: (Comonad w, Bind w) => w (w a -> b) -> w a -> w b
mc <~> ma = mc >>- \f -> ma =>> f
infixl 4 <~>
-- this is getting silly
(<#>) :: (Functor f) => f (a -> b) -> a -> f b
fab <#> a = fmap ($ a) fab
infixl 4 <#>
makePrisms ''Located

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

@@ -1,65 +1,87 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TupleSections, PatternSynonyms #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Monad.Errorful
( ErrorfulT
, runErrorfulT
( ErrorfulT(..)
, Errorful
, pattern Errorful
, errorful
, runErrorful
, mapErrorful
, hoistErrorfulT
, MonadErrorful(..)
)
where
----------------------------------------------------------------------------------
import Control.Monad.State.Strict
import Control.Monad.Reader
import Control.Monad.Trans
import Data.Functor.Identity
import Data.Coerce
import Data.HashSet (HashSet)
import Data.HashSet qualified as H
import Lens.Micro
----------------------------------------------------------------------------------
newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Either e (a, [e])) }
newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Maybe a, [e]) }
type Errorful e = ErrorfulT e Identity
pattern Errorful :: (Either e (a, [e])) -> Errorful e a
pattern Errorful :: (Maybe a, [e]) -> Errorful e a
pattern Errorful a = ErrorfulT (Identity a)
runErrorful :: Errorful e a -> Either e (a, [e])
errorful :: (Applicative m) => (Maybe a, [e]) -> ErrorfulT e m a
errorful = ErrorfulT . pure
runErrorful :: Errorful e a -> (Maybe a, [e])
runErrorful m = coerce (runErrorfulT m)
class (Applicative m) => MonadErrorful e m | m -> e where
addWound :: e -> m ()
addFatal :: e -> m a
-- not sure if i want to add this yet...
-- catchWound :: m a -> (e -> m a) -> m a
addWound :: e -> m ()
addFatal :: e -> m a
instance (Applicative m) => MonadErrorful e (ErrorfulT e m) where
addWound e = ErrorfulT $ pure . Right $ ((), [e])
addFatal e = ErrorfulT $ pure . Left $ e
addWound e = ErrorfulT $ pure (Just (), [e])
addFatal e = ErrorfulT $ pure (Nothing, [e])
instance MonadTrans (ErrorfulT e) where
lift m = ErrorfulT (Right . (,[]) <$> m)
lift m = ErrorfulT ((\x -> (Just x,[])) <$> m)
instance (MonadIO m) => MonadIO (ErrorfulT e m) where
liftIO = lift . liftIO
instance (Functor m) => Functor (ErrorfulT e m) where
fmap f (ErrorfulT m) = ErrorfulT $ fmap (_1 %~ f) <$> m
fmap f (ErrorfulT m) = ErrorfulT (m <&> _1 . _Just %~ f)
instance (Applicative m) => Applicative (ErrorfulT e m) where
pure a = ErrorfulT (pure . Right $ (a, []))
pure a = ErrorfulT . pure $ (Just a, [])
m <*> a = ErrorfulT (m' `apply` a')
where
m' = runErrorfulT m
a' = runErrorfulT a
-- TODO: strict concatenation
apply = liftA2 $ liftA2 (\ (f,e1) (x,e2) -> (f x, e1 ++ e2))
ErrorfulT m <*> ErrorfulT n = ErrorfulT $ m `apply` n where
apply :: m (Maybe (a -> b), [e]) -> m (Maybe a, [e]) -> m (Maybe b, [e])
apply = liftA2 $ \ (mf,e1) (ma,e2) -> (mf <*> ma, e1 <> e2)
instance (Monad m) => Monad (ErrorfulT e m) where
ErrorfulT m >>= k = ErrorfulT $ do
m' <- m
case m' of
Right (a,es) -> runErrorfulT (k a)
Left e -> pure (Left e)
(a,es) <- m
case a of
Just x -> runErrorfulT (k x) <&> _2 %~ (es<>)
Nothing -> pure (Nothing, es)
mapErrorful :: (Functor m) => (e -> e') -> ErrorfulT e m a -> ErrorfulT e' m a
mapErrorful f (ErrorfulT m) = ErrorfulT $
m <&> _2 . mapped %~ f
-- when microlens-pro drops we can write this as
-- mapErrorful f = coerced . mapped . _2 . mapped %~ f
-- lol
hoistErrorfulT :: (forall a. m a -> n a) -> ErrorfulT e m a -> ErrorfulT e n a
hoistErrorfulT nt (ErrorfulT m) = ErrorfulT (nt m)
--------------------------------------------------------------------------------
-- daily dose of n^2 instances
instance (Monad m, MonadErrorful e m) => MonadErrorful e (ReaderT r m) where
addWound = lift . addWound
addFatal = lift . addFatal

37
src/Control/Monad/Utils.hs Normal file
View File

@@ -0,0 +1,37 @@
module Control.Monad.Utils
( mapAccumLM
, Kendo(..)
, generalise
)
where
----------------------------------------------------------------------------------
import Data.Tuple (swap)
import Data.Coerce
import Data.Functor.Identity
import Control.Monad.State
import Control.Monad
----------------------------------------------------------------------------------
-- | Monadic variant of @mapAccumL@
mapAccumLM :: forall m t s a b. (Monad m, Traversable t)
=> (s -> a -> m (s, b))
-> s
-> t a
-> m (s, t b)
mapAccumLM k s t = swap <$> runStateT (traverse k' t) s
where
k' :: a -> StateT s m b
k' a = StateT $ fmap swap <$> flip k a
newtype Kendo m a = Kendo { appKendo :: a -> m a }
instance (Monad m) => Semigroup (Kendo m a) where
Kendo f <> Kendo g = Kendo (f <=< g)
instance (Monad m) => Monoid (Kendo m a) where
mempty = Kendo pure
generalise :: (Monad m) => Identity a -> m a
generalise (Identity a) = pure a

116
src/Core/Examples.hs
View File

@@ -4,18 +4,18 @@ Description : Core examples (may eventually be unit tests)
-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
module Core.Examples
( fac3
, sumList
, constDivZero
, idCase
) where
module Core.Examples where
----------------------------------------------------------------------------------
import Core.Syntax
import Core.TH
----------------------------------------------------------------------------------
-- TODO: my shitty lexer isn't inserting semicolons
-- fac3 = undefined
-- sumList = undefined
-- constDivZero = undefined
-- idCase = undefined
---
letrecExample :: Program'
letrecExample = [coreProg|
@@ -76,12 +76,12 @@ negExample3 = [coreProg|
arithExample1 :: Program'
arithExample1 = [coreProg|
main = (+#) 3 (negate# 2);
main = +# 3 (negate# 2);
|]
arithExample2 :: Program'
arithExample2 = [coreProg|
main = negate# ((+#) 2 ((*#) 5 3));
main = negate# (+# 2 (*# 5 3));
|]
ifExample1 :: Program'
@@ -96,7 +96,7 @@ ifExample2 = [coreProg|
facExample :: Program'
facExample = [coreProg|
fac n = if# ((==#) n 0) 1 ((*#) n (fac ((-#) n 1)));
fac n = if# (==# n 0) 1 (*# n (fac (-# n 1)));
main = fac 3;
|]
@@ -142,21 +142,21 @@ simple1 = [coreProg|
caseBool1 :: Program'
caseBool1 = [coreProg|
_if c x y = case c of
{ 1 -> x
; 0 -> y
{ <1> -> x
; <0> -> y
};
false = Pack{0 0};
true = Pack{1 0};
main = _if false ((+#) 2 3) ((*#) 4 5);
main = _if false (+# 2 3) (*# 4 5);
|]
fac3 :: Program'
fac3 = [coreProg|
fac n = case (==#) n 0 of
{ 1 -> 1
; 0 -> (*#) n (fac ((-#) n 1))
fac n = case ==# n 0 of
{ <1> -> 1
; <0> -> *# n (fac (-# n 1))
};
main = fac 3;
@@ -170,8 +170,8 @@ sumList = [coreProg|
cons x y = Pack{1 2} x y;
list = cons 1 (cons 2 (cons 3 nil));
sum l = case l of
{ 0 -> 0
; 1 x xs -> (+#) x (sum xs)
{ <0> -> 0
; <1> x xs -> +# x (sum xs)
};
main = sum list;
|]
@@ -179,7 +179,7 @@ sumList = [coreProg|
constDivZero :: Program'
constDivZero = [coreProg|
k x y = x;
main = k 3 ((/#) 1 0);
main = k 3 (/# 1 0);
|]
idCase :: Program'
@@ -187,34 +187,60 @@ idCase = [coreProg|
id x = x;
main = id (case Pack{1 0} of
{ 1 -> (+#) 2 3
{ <1> -> +# 2 3
})
|]
corePrelude :: Module Name
corePrelude = Module (Just ("Prelude", [])) $
-- non-primitive defs
[coreProg|
id x = x;
k x y = x;
k1 x y = y;
s f g x = f x (g x);
compose f g x = f (g x);
twice f x = f (f x);
fst p = casePair# p k;
snd p = casePair# p k1;
head l = caseList# l abort# k;
tail l = caseList# l abort# k1;
_length_cc x xs = (+#) 1 (length xs);
length l = caseList# l 0 length_cc;
-- NOTE: the GM primitive (==#) returns an untyped constructor with tag 1 for
-- true, and 0 for false. See: GM.boxBool
namedBoolCase :: Program'
namedBoolCase = [coreProg|
{-# PackData True 1 0 #-}
{-# PackData False 0 0 #-}
main = case ==# 1 1 of
{ True -> 123
; False -> 456
}
|]
<>
-- primitive constructors need some specialised wiring:
Program
[ ScDef "False" [] $ Con 0 0
, ScDef "True" [] $ Con 1 0
, ScDef "MkPair" [] $ Con 0 2
, ScDef "Nil" [] $ Con 1 0
, ScDef "Cons" [] $ Con 2 2
]
namedConsCase :: Program'
namedConsCase = [coreProg|
{-# PackData Nil 0 0 #-}
{-# PackData Cons 1 2 #-}
foldr f z l = case l of
{ Nil -> z
; Cons x xs -> f x (foldr f z xs)
};
list = Cons 1 (Cons 2 (Cons 3 Nil));
main = foldr (+#) 0 list
|]
-- corePrelude :: Module Name
-- corePrelude = Module (Just ("Prelude", [])) $
-- -- non-primitive defs
-- [coreProg|
-- id x = x;
-- k x y = x;
-- k1 x y = y;
-- s f g x = f x (g x);
-- compose f g x = f (g x);
-- twice f x = f (f x);
-- fst p = casePair# p k;
-- snd p = casePair# p k1;
-- head l = caseList# l abort# k;
-- tail l = caseList# l abort# k1;
-- _length_cc x xs = (+#) 1 (length xs);
-- length l = caseList# l 0 length_cc;
-- |]
-- <>
-- -- primitive constructors need some specialised wiring:
-- Program
-- [ ScDef "False" [] $ Con 0 0
-- , ScDef "True" [] $ Con 1 0
-- , ScDef "MkPair" [] $ Con 0 2
-- , ScDef "Nil" [] $ Con 1 0
-- , ScDef "Cons" [] $ Con 2 2
-- ]
--}

280
src/Core/HindleyMilner.hs Normal file
View File

@@ -0,0 +1,280 @@
{-|
Module : Core.HindleyMilner
Description : Hindley-Milner type system
-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Core.HindleyMilner
( Context'
, infer
, check
, checkCoreProg
, checkCoreProgR
, checkCoreExprR
, TypeError(..)
, HMError
)
where
----------------------------------------------------------------------------------
import Lens.Micro
import Lens.Micro.Mtl
import Lens.Micro.Platform
import Data.Maybe (fromMaybe)
import Data.Text qualified as T
import Data.Pretty (rpretty)
import Data.HashMap.Strict qualified as H
import Data.Foldable (traverse_)
import Data.Functor
import Data.Functor.Identity
import Compiler.RLPC
import Compiler.Types
import Compiler.RlpcError
import Control.Monad (foldM, void, forM)
import Control.Monad.Errorful
import Control.Monad.State
import Control.Monad.Utils (mapAccumLM, generalise)
import Text.Printf
import Core.Syntax
----------------------------------------------------------------------------------
-- | Annotated typing context -- I have a feeling we're going to want this in the
-- future.
type Context b = [(b, Type)]
-- | Unannotated typing context, AKA our beloved Γ.
type Context' = Context Name
-- | Type error enum.
data TypeError
-- | Two types could not be unified
= TyErrCouldNotUnify Type Type
-- | @x@ could not be unified with @t@ because @x@ occurs in @t@
| TyErrRecursiveType Name Type
-- | Untyped, potentially undefined variable
| TyErrUntypedVariable Name
| TyErrMissingTypeSig Name
deriving (Show, Eq)
instance IsRlpcError TypeError where
liftRlpcError = \case
-- todo: use anti-parser instead of show
TyErrCouldNotUnify t u -> Text
[ T.pack $ printf "Could not match type `%s` with `%s`."
(rpretty @String t) (rpretty @String u)
, "Expected: " <> rpretty t
, "Got: " <> rpretty u
]
TyErrUntypedVariable n -> Text
[ "Untyped (likely undefined) variable `" <> n <> "`"
]
TyErrRecursiveType t x -> Text
[ T.pack $ printf "Recursive type: `%s' occurs in `%s'"
(rpretty @String t) (rpretty @String x)
]
-- | Synonym for @Errorful [TypeError]@. This means an @HMError@ action may
-- throw any number of fatal or nonfatal errors. Run with @runErrorful@.
type HMError = Errorful TypeError
-- | Assert that an expression unifies with a given type
--
-- >>> let e = [coreProg|3|]
-- >>> check [] (TyCon "Bool") e
-- Left (TyErrCouldNotUnify (TyCon "Bool") (TyCon "Int#"))
-- >>> check [] (TyCon "Int#") e
-- Right ()
check :: Context' -> Type -> Expr' -> HMError ()
check g t1 e = do
t2 <- infer g e
void $ unify [(t1,t2)]
-- | Typecheck program. I plan to allow for *some* inference in the future, but
-- in the mean time all top-level binders must have a type annotation.
checkCoreProg :: Program' -> HMError ()
checkCoreProg p = scDefs
& traverse_ k
where
scDefs = p ^. programScDefs
g = gatherTypeSigs p
k :: ScDef' -> HMError ()
k sc = case lookup scname g of
Just t -> check g t (sc ^. _rhs)
Nothing -> addFatal $ TyErrMissingTypeSig scname
where scname = sc ^. _lhs._1
-- | @checkCoreProgR p@ returns @p@ if @p@ successfully typechecks.
checkCoreProgR :: forall m. (Monad m) => Program' -> RLPCT m Program'
checkCoreProgR p = (hoistRlpcT generalise . liftE . checkCoreProg $ p)
$> p
where
liftE = liftErrorful . mapErrorful (errorMsg (SrcSpan 0 0 0 0))
checkCoreExprR :: (Monad m) => Context' -> Expr' -> RLPCT m Expr'
checkCoreExprR g e = (hoistRlpcT generalise . liftE . infer g $ e)
$> e
where
liftE = liftErrorful . mapErrorful (errorMsg (SrcSpan 0 0 0 0))
-- | Infer the type of an expression under some context.
--
-- >>> let g1 = [("id", TyVar "a" :-> TyVar "a")]
-- >>> let g2 = [("id", (TyVar "a" :-> TyVar "a") :-> TyVar "a" :-> TyVar "a")]
-- >>> infer g1 [coreExpr|id 3|]
-- Right TyInt
-- >>> infer g2 [coreExpr|id 3|]
-- Left (TyErrCouldNotUnify (TyVar "a" :-> TyVar "a") TyInt)
infer :: Context' -> Expr' -> HMError Type
infer g e = do
(t,cs) <- gather g e
-- apply all unified constraints
foldr (uncurry subst) t <$> unify cs
-- | A @Constraint@ between two types describes the requirement that the pair
-- must unify
type Constraint = (Type, Type)
-- | Type of an expression under some context, and gather the constraints
-- necessary to unify. Note that this is not the same as @infer@, as the
-- expression will likely be given a fresh type variable along with a
-- constraint, rather than the solved type.
--
-- For example, if the context says "@id@ has type a -> a," in an application of
-- @id 3@, the whole application is assigned type @$a0@ and the constraint that
-- @id@ must unify with type @Int -> $a0@ is generated.
--
-- >>> gather [("id", TyVar "a" :-> TyVar "a")] [coreExpr|id 3|]
-- (TyVar "$a0",[(TyVar "a" :-> TyVar "a",TyInt :-> TyVar "$a0")])
gather :: Context' -> Expr' -> HMError (Type, [Constraint])
gather = \g e -> runStateT (go g e) ([],0) <&> \ (t,(cs,_)) -> (t,cs) where
go :: Context' -> Expr' -> StateT ([Constraint], Int) HMError Type
go g = \case
Lit (IntL _) -> pure TyInt
Var k -> lift $ maybe e pure $ lookup k g
where e = addFatal $ TyErrUntypedVariable k
App f x -> do
tf <- go g f
tx <- go g x
tfx <- uniqueVar
addConstraint tf (tx :-> tfx)
pure tfx
Let NonRec bs e -> do
g' <- buildLetContext g bs
go g' e
Let Rec bs e -> do
g' <- buildLetrecContext g bs
go g' e
Lam bs e -> case bs of
[x] -> do
tx <- uniqueVar
let g' = (x,tx) : g
te <- go g' e
pure (tx :-> te)
-- TODO lambda, case
buildLetrecContext :: Context' -> [Binding']
-> StateT ([Constraint], Int) HMError Context'
buildLetrecContext g bs = do
let f ag (k := _) = do
n <- uniqueVar
pure ((k,n) : ag)
rg <- foldM f g bs
let k ag (k := v) = do
t <- go rg v
pure ((k,t) : ag)
foldM k g bs
-- | augment a context with the inferred types of each binder. the returned
-- context is linearly accumulated, meaning that the context used to infer each binder
-- will include the inferred types of all previous binder
buildLetContext :: Context' -> [Binding']
-> StateT ([Constraint], Int) HMError Context'
buildLetContext = foldM k where
k :: Context' -> Binding' -> StateT ([Constraint], Int) HMError Context'
k g (x := y) = do
ty <- go g y
pure ((x,ty) : g)
uniqueVar :: StateT ([Constraint], Int) HMError Type
uniqueVar = do
n <- use _2
_2 %= succ
pure (TyVar . T.pack $ '$' : 'a' : show n)
addConstraint :: Type -> Type -> StateT ([Constraint], Int) HMError ()
addConstraint t u = _1 %= ((t, u):)
-- | Unify a list of constraints, meaning that pairs between types are turned
-- into pairs of type variables and types. A useful thought model is to think of
-- it as solving an equation such that the unknown variable is the left-hand
-- side.
unify :: [Constraint] -> HMError Context'
unify = go mempty where
go :: Context' -> [Constraint] -> HMError Context'
-- nothing left! return accumulated context
go g [] = pure g
go g (c:cs) = case c of
-- primitives may of course unify with themselves
(TyInt, TyInt) -> go g cs
-- `x` unifies with `x`
(TyVar t, TyVar u) | t == u -> go g cs
-- a type variable `x` unifies with an arbitrary type `t` if `t` does
-- not reference `x`
(TyVar x, t) -> unifyTV g x t cs
(t, TyVar x) -> unifyTV g x t cs
-- two functions may be unified if their domain and codomain unify
(a :-> b, x :-> y) -> go g $ (a,x) : (b,y) : cs
-- anything else is a failure :(
(t,u) -> addFatal $ TyErrCouldNotUnify t u
unifyTV :: Context' -> Name -> Type -> [Constraint] -> HMError Context'
unifyTV g x t cs | occurs t = addFatal $ TyErrRecursiveType x t
| otherwise = go g' substed
where
g' = (x,t) : g
substed = cs & each . both %~ subst x t
occurs (a :-> b) = occurs a || occurs b
occurs (TyVar y)
| x == y = True
occurs _ = False
gatherTypeSigs :: Program b -> Context b
gatherTypeSigs p = p ^. programTypeSigs
& H.toList
-- | The expression @subst x t e@ substitutes all occurences of @x@ in @e@ with
-- @t@
--
-- >>> subst "a" (TyCon "Int") (TyVar "a")
-- TyCon "Int"
-- >>> subst "a" (TyCon "Int") (TyVar "a" :-> TyVar "a")
-- TyCon "Int" :-> TyCon "Int"
subst :: Name -> Type -> Type -> Type
subst x t (TyVar y) | x == y = t
subst x t (a :-> b) = subst x t a :-> subst x t b
subst _ _ e = e
--------------------------------------------------------------------------------
demoContext :: Context'
demoContext =
[ ("fix", (TyVar "a" :-> TyVar "a") :-> TyVar "a")
, ("add", TyInt :-> TyInt :-> TyInt)
, ("==", TyInt :-> TyInt :-> TyCon "Bool")
, ("True", TyCon "Bool")
, ("False", TyCon "Bool")
]

65
src/Core/Lex.x
View File

@@ -3,8 +3,10 @@
Module : Core.Lex
Description : Lexical analysis for the core language
-}
{-# LANGUAGE OverloadedStrings #-}
module Core.Lex
( lexCore
, lexCoreR
, lexCore'
, CoreToken(..)
, SrcError(..)
@@ -15,13 +17,20 @@ module Core.Lex
where
import Data.Char (chr)
import Debug.Trace
import Data.Text (Text)
import Data.Text qualified as T
import Data.String (IsString(..))
import Data.Functor.Identity
import Core.Syntax
import Compiler.RLPC
import Compiler.Types
-- TODO: unify Located definitions
import Compiler.RlpcError
import Lens.Micro
import Lens.Micro.TH
}
%wrapper "monad"
%wrapper "monad-strict-text"
$whitechar = [ \t\n\r\f\v]
$special = [\(\)\,\;\[\]\{\}]
@@ -59,6 +68,8 @@ $white_no_nl = $white # $nl
@decimal = $digit+
@alttag = "<" $digit+ ">"
rlp :-
<0>
@@ -68,6 +79,7 @@ rlp :-
"{" { constTok TokenLBrace }
"}" { constTok TokenRBrace }
";" { constTok TokenSemicolon }
"::" { constTok TokenHasType }
"@" { constTok TokenTypeApp }
"{-#" { constTok TokenLPragma `andBegin` pragma }
@@ -80,17 +92,19 @@ rlp :-
"where" { constTok TokenWhere }
"Pack" { constTok TokenPack } -- temp
"\\" { constTok TokenLambda }
"\" { constTok TokenLambda }
"λ" { constTok TokenLambda }
"=" { constTok TokenEquals }
"->" { constTok TokenArrow }
@alttag { lexWith ( TokenAltTag . read @Int . T.unpack
. T.drop 1 . T.init ) }
@varname { lexWith TokenVarName }
@conname { lexWith TokenConName }
@varsym { lexWith TokenVarSym }
@consym { lexWith TokenConSym }
@decimal { lexWith (TokenLitInt . read @Int) }
@decimal { lexWith (TokenLitInt . read @Int . T.unpack) }
$white { skip }
\n { skip }
@@ -107,11 +121,9 @@ rlp :-
}
{
data Located a = Located Int Int Int a
deriving Show
constTok :: t -> AlexInput -> Int -> Alex (Located t)
constTok t (AlexPn _ y x,_,_,_) l = pure $ Located y x l t
constTok t (AlexPn _ y x,_,_,_) l = pure $ nolo t
data CoreToken = TokenLet
| TokenLetrec
@@ -128,16 +140,18 @@ data CoreToken = TokenLet
| TokenConName Name
| TokenVarSym Name
| TokenConSym Name
| TokenAltTag Tag
| TokenEquals
| TokenLParen
| TokenRParen
| TokenLBrace
| TokenRBrace
| TokenSemicolon
| TokenHasType
| TokenTypeApp
| TokenLPragma
| TokenRPragma
| TokenWord String
| TokenWord Text
| TokenEOF
deriving Show
@@ -155,42 +169,51 @@ data SrcErrorType = SrcErrLexical String
type Lexer = AlexInput -> Int -> Alex (Located CoreToken)
lexWith :: (String -> CoreToken) -> Lexer
lexWith f (AlexPn _ y x,_,_,s) l = pure $ Located y x l (f $ take l s)
lexWith :: (Text -> CoreToken) -> Lexer
lexWith f (AlexPn _ y x,_,_,s) l = pure . nolo . f . T.take l $ s
-- | The main lexer driver.
lexCore :: String -> RLPC SrcError [Located CoreToken]
lexCore :: Text -> RLPC [Located CoreToken]
lexCore s = case m of
Left e -> addFatal err
where err = SrcError
{ _errSpan = (0,0,0) -- TODO: location
, _errSeverity = Error
, _errDiagnostic = SrcErrLexical e
}
Left e -> error "core lex error"
Right ts -> pure ts
where
m = runAlex s lexStream
lexCoreR :: forall m. (Applicative m) => Text -> RLPCT m [Located CoreToken]
lexCoreR = hoistRlpcT generalise . lexCore
where
generalise :: forall a. Identity a -> m a
generalise (Identity a) = pure a
-- | @lexCore@, but the tokens are stripped of location info. Useful for
-- debugging
lexCore' :: String -> RLPC SrcError [CoreToken]
lexCore' :: Text -> RLPC [CoreToken]
lexCore' s = fmap f <$> lexCore s
where f (Located _ _ _ t) = t
where f (Located _ t) = t
lexStream :: Alex [Located CoreToken]
lexStream = do
l <- alexMonadScan
case l of
Located _ _ _ TokenEOF -> pure [l]
_ -> (l:) <$> lexStream
Located _ TokenEOF -> pure [l]
_ -> (l:) <$> lexStream
data ParseError = ParErrLexical String
| ParErrParse
deriving Show
-- TODO:
instance IsRlpcError SrcError where
liftRlpcError = Text . pure . T.pack . show
-- TODO:
instance IsRlpcError ParseError where
liftRlpcError = Text . pure . T.pack . show
alexEOF :: Alex (Located CoreToken)
alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) ->
Right (st, Located y x 0 TokenEOF)
Right (st, nolo $ TokenEOF)
}

315
src/Core/Lex.x.old
View File

@@ -1,315 +0,0 @@
{
-- TODO: layout semicolons are not inserted at EOf.
{-# LANGUAGE TemplateHaskell #-}
module Core.Lex
( lexCore
, lexCore'
, CoreToken(..)
, ParseError(..)
, Located(..)
, AlexPosn(..)
)
where
import Data.Char (chr)
import Debug.Trace
import Core.Syntax
import Compiler.RLPC
import Lens.Micro
import Lens.Micro.TH
}
%wrapper "monadUserState"
$whitechar = [ \t\n\r\f\v]
$special = [\(\)\,\;\[\]\{\}]
$digit = 0-9
$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~]
$unisymbol = [] -- TODO
$symbol = [$ascsymbol $unisymbol] # [$special \_\:\"\']
$large = [A-Z \xc0-\xd6 \xd8-\xde]
$small = [a-z \xdf-\xf6 \xf8-\xff \_]
$alpha = [$small $large]
$graphic = [$small $large $symbol $digit $special \:\"\']
$octit = 0-7
$hexit = [0-9 A-F a-f]
$namechar = [$alpha $digit \' \#]
$symchar = [$symbol \:]
$nl = [\n\r]
$white_no_nl = $white # $nl
@reservedid =
case|data|do|import|in|let|letrec|module|of|where
@reservedop =
"=" | \\ | "->"
@varname = $small $namechar*
@conname = $large $namechar*
@varsym = $symbol $symchar*
@consym = \: $symchar*
@decimal = $digit+
rlp :-
-- everywhere: skip whitespace
$white_no_nl+ { skip }
-- TODO: `--` could begin an operator
"--"[^$nl]* { skip }
"--"\-*[^$symbol].* { skip }
"{-" { nestedComment }
-- syntactic symbols
<0>
{
"(" { constTok TokenLParen }
")" { constTok TokenRParen }
"{" { lbrace }
"}" { rbrace }
";" { constTok TokenSemicolon }
"," { constTok TokenComma }
}
-- keywords
-- see commentary on the layout system
<0>
{
"let" { constTok TokenLet `andBegin` layout }
"letrec" { constTok TokenLetrec `andBegin` layout }
"of" { constTok TokenOf `andBegin` layout }
"case" { constTok TokenCase }
"module" { constTok TokenModule }
"in" { letin }
"where" { constTok TokenWhere `andBegin` layout }
}
-- reserved symbols
<0>
{
"=" { constTok TokenEquals }
"->" { constTok TokenArrow }
}
-- identifiers
<0>
{
-- TODO: qualified names
@varname { lexWith TokenVarName }
@conname { lexWith TokenConName }
@varsym { lexWith TokenVarSym }
}
-- literals
<0>
{
@decimal { lexWith (TokenLitInt . read @Int) }
}
<0> \n { begin bol }
<initial>
{
$white { skip }
\n { skip }
() { topLevelOff `andBegin` 0 }
}
<bol>
{
\n { skip }
() { doBol `andBegin` 0 }
}
<layout>
{
$white { skip }
\{ { lbrace `andBegin` 0 }
() { noBrace `andBegin` 0 }
}
{
data Located a = Located Int Int Int a
deriving Show
constTok :: t -> AlexInput -> Int -> Alex (Located t)
constTok t (AlexPn _ y x,_,_,_) l = pure $ Located y x l t
data CoreToken = TokenLet
| TokenLetrec
| TokenIn
| TokenModule
| TokenWhere
| TokenComma
| TokenCase
| TokenOf
| TokenLambda
| TokenArrow
| TokenLitInt Int
| TokenVarName Name
| TokenConName Name
| TokenVarSym Name
| TokenConSym Name
| TokenEquals
| TokenLParen
| TokenRParen
| TokenLBrace
| TokenRBrace
| TokenLBraceV -- virtual brace inserted by layout
| TokenRBraceV -- virtual brace inserted by layout
| TokenIndent Int
| TokenDedent Int
| TokenSemicolon
| TokenEOF
deriving Show
data LayoutContext = Layout Int
| NoLayout
deriving Show
data AlexUserState = AlexUserState
{ _ausContext :: [LayoutContext]
}
ausContext :: Lens' AlexUserState [LayoutContext]
ausContext f (AlexUserState ctx)
= fmap
(\a -> AlexUserState a) (f ctx)
{-# INLINE ausContext #-}
pushContext :: LayoutContext -> Alex ()
pushContext c = do
st <- alexGetUserState
alexSetUserState $ st { _ausContext = c : _ausContext st }
popContext :: Alex ()
popContext = do
st <- alexGetUserState
alexSetUserState $ st { _ausContext = drop 1 (_ausContext st) }
getContext :: Alex [LayoutContext]
getContext = do
st <- alexGetUserState
pure $ _ausContext st
type Lexer = AlexInput -> Int -> Alex (Located CoreToken)
alexInitUserState :: AlexUserState
alexInitUserState = AlexUserState []
nestedComment :: Lexer
nestedComment _ _ = undefined
lexStream :: Alex [Located CoreToken]
lexStream = do
l <- alexMonadScan
case l of
Located _ _ _ TokenEOF -> pure [l]
_ -> (l:) <$> lexStream
-- | The main lexer driver.
lexCore :: String -> RLPC ParseError [Located CoreToken]
lexCore s = case m of
Left e -> addFatal err
where err = SrcError
{ _errSpan = (0,0,0) -- TODO: location
, _errSeverity = Error
, _errDiagnostic = ParErrLexical e
}
Right ts -> pure ts
where
m = runAlex s (alexSetStartCode initial *> lexStream)
-- | @lexCore@, but the tokens are stripped of location info. Useful for
-- debugging
lexCore' :: String -> RLPC ParseError [CoreToken]
lexCore' s = fmap f <$> lexCore s
where f (Located _ _ _ t) = t
data ParseError = ParErrLexical String
| ParErrParse
deriving Show
lexWith :: (String -> CoreToken) -> Lexer
lexWith f (AlexPn _ y x,_,_,s) l = pure $ Located y x l (f $ take l s)
lexToken :: Alex (Located CoreToken)
lexToken = alexMonadScan
getSrcCol :: Alex Int
getSrcCol = Alex $ \ st ->
let AlexPn _ _ col = alex_pos st
in Right (st, col)
lbrace :: Lexer
lbrace (AlexPn _ y x,_,_,_) l = do
pushContext NoLayout
pure $ Located y x l TokenLBrace
rbrace :: Lexer
rbrace (AlexPn _ y x,_,_,_) l = do
popContext
pure $ Located y x l TokenRBrace
insRBraceV :: AlexPosn -> Alex (Located CoreToken)
insRBraceV (AlexPn _ y x) = do
popContext
pure $ Located y x 0 TokenRBraceV
insSemi :: AlexPosn -> Alex (Located CoreToken)
insSemi (AlexPn _ y x) = do
pure $ Located y x 0 TokenSemicolon
modifyUst :: (AlexUserState -> AlexUserState) -> Alex ()
modifyUst f = do
st <- alexGetUserState
alexSetUserState $ f st
getUst :: Alex AlexUserState
getUst = alexGetUserState
newLayoutContext :: Lexer
newLayoutContext (p,_,_,_) _ = do
undefined
noBrace :: Lexer
noBrace (AlexPn _ y x,_,_,_) l = do
col <- getSrcCol
pushContext (Layout col)
pure $ Located y x l TokenLBraceV
getOffside :: Alex Ordering
getOffside = do
ctx <- getContext
m <- getSrcCol
case ctx of
Layout n : _ -> pure $ m `compare` n
_ -> pure GT
doBol :: Lexer
doBol (p,c,_,s) _ = do
off <- getOffside
case off of
LT -> insRBraceV p
EQ -> insSemi p
_ -> lexToken
letin :: Lexer
letin (AlexPn _ y x,_,_,_) l = do
popContext
pure $ Located y x l TokenIn
topLevelOff :: Lexer
topLevelOff = noBrace
alexEOF :: Alex (Located CoreToken)
alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) ->
Right (st, Located y x 0 TokenEOF)
}

203
src/Core/Parse.y
View File

@@ -3,23 +3,35 @@
Module : Core.Parse
Description : Parser for the Core language
-}
{-# LANGUAGE OverloadedStrings, ViewPatterns #-}
module Core.Parse
( parseCore
, parseCoreExpr
, parseCoreExprR
, parseCoreProg
, parseCoreProgR
, module Core.Lex -- temp convenience
, parseTmp
, SrcError
, Module
)
where
import Control.Monad ((>=>))
import Control.Monad.Utils (generalise)
import Data.Foldable (foldl')
import Data.Functor.Identity
import Core.Syntax
import Core.Lex
import Compiler.RLPC
import Control.Monad
import Lens.Micro
import Data.Default.Class (def)
import Data.Hashable (Hashable)
import Data.List.Extra
import Data.Text.IO qualified as TIO
import Data.Text (Text)
import Data.Text qualified as T
import Data.HashMap.Strict qualified as H
}
%name parseCore Module
@@ -27,35 +39,37 @@ import Data.Default.Class (def)
%name parseCoreProg StandaloneProgram
%tokentype { Located CoreToken }
%error { parseError }
%monad { RLPC SrcError }
%monad { RLPC } { happyBind } { happyPure }
%token
let { Located _ _ _ TokenLet }
letrec { Located _ _ _ TokenLetrec }
module { Located _ _ _ TokenModule }
where { Located _ _ _ TokenWhere }
case { Located _ _ _ TokenCase }
of { Located _ _ _ TokenOf }
pack { Located _ _ _ TokenPack } -- temp
in { Located _ _ _ TokenIn }
litint { Located _ _ _ (TokenLitInt $$) }
varname { Located _ _ _ (TokenVarName $$) }
varsym { Located _ _ _ (TokenVarSym $$) }
conname { Located _ _ _ (TokenConName $$) }
consym { Located _ _ _ (TokenConSym $$) }
word { Located _ _ _ (TokenWord $$) }
'λ' { Located _ _ _ TokenLambda }
'->' { Located _ _ _ TokenArrow }
'=' { Located _ _ _ TokenEquals }
'@' { Located _ _ _ TokenTypeApp }
'(' { Located _ _ _ TokenLParen }
')' { Located _ _ _ TokenRParen }
'{' { Located _ _ _ TokenLBrace }
'}' { Located _ _ _ TokenRBrace }
'{-#' { Located _ _ _ TokenLPragma }
'#-}' { Located _ _ _ TokenRPragma }
';' { Located _ _ _ TokenSemicolon }
eof { Located _ _ _ TokenEOF }
let { Located _ TokenLet }
letrec { Located _ TokenLetrec }
module { Located _ TokenModule }
where { Located _ TokenWhere }
case { Located _ TokenCase }
of { Located _ TokenOf }
pack { Located _ TokenPack } -- temp
in { Located _ TokenIn }
litint { Located _ (TokenLitInt $$) }
varname { Located _ (TokenVarName $$) }
varsym { Located _ (TokenVarSym $$) }
conname { Located _ (TokenConName $$) }
consym { Located _ (TokenConSym $$) }
alttag { Located _ (TokenAltTag $$) }
word { Located _ (TokenWord $$) }
'λ' { Located _ TokenLambda }
'->' { Located _ TokenArrow }
'=' { Located _ TokenEquals }
'@' { Located _ TokenTypeApp }
'(' { Located _ TokenLParen }
')' { Located _ TokenRParen }
'{' { Located _ TokenLBrace }
'}' { Located _ TokenRBrace }
'{-#' { Located _ TokenLPragma }
'#-}' { Located _ TokenRPragma }
';' { Located _ TokenSemicolon }
'::' { Located _ TokenHasType }
eof { Located _ TokenEOF }
%%
@@ -71,16 +85,46 @@ StandaloneProgram :: { Program Name }
StandaloneProgram : Program eof { $1 }
Program :: { Program Name }
Program : ScDefs { Program $1 }
Program : ScTypeSig ';' Program { insTypeSig $1 $3 }
| ScTypeSig OptSemi { singletonTypeSig $1 }
| ScDef ';' Program { insScDef $1 $3 }
| ScDef OptSemi { singletonScDef $1 }
| TLPragma Program {% doTLPragma $1 $2 }
| TLPragma {% doTLPragma $1 mempty }
TLPragma :: { Pragma }
: '{-#' Words '#-}' { Pragma $2 }
Words :: { [Text] }
: Words word { $1 `snoc` $2 }
| word { [$1] }
OptSemi :: { () }
OptSemi : ';' { () }
| {- epsilon -} { () }
ScTypeSig :: { (Name, Type) }
ScTypeSig : Var '::' Type { ($1,$3) }
ScDefs :: { [ScDef Name] }
ScDefs : ScDef ';' ScDefs { $1 : $3 }
| ScDef ';' { [$1] }
| ScDef { [$1] }
| {- epsilon -} { [] }
ScDef :: { ScDef Name }
ScDef : Var ParList '=' Expr { ScDef $1 $2 $4 }
-- hack to allow constructors to be compiled into scs
| Con ParList '=' Expr { ScDef $1 $2 $4 }
Type :: { Type }
Type : Type1 { $1 }
Type1 :: { Type }
Type1 : '(' Type ')' { $2 }
| Type1 '->' Type { $1 :-> $3 }
-- do we want to allow symbolic names for tyvars and tycons?
| varname { TyVar $1 }
| conname { TyCon $1 }
ParList :: { [Name] }
ParList : Var ParList { $1 : $2 }
@@ -120,22 +164,15 @@ Alters : Alter ';' Alters { $1 : $3 }
| Alter { [$1] }
Alter :: { Alter Name }
Alter : litint ParList '->' Expr { Alter (AltData $1) $2 $4 }
Alter : alttag ParList '->' Expr { Alter (AltTag $1) $2 $4 }
| Con ParList '->' Expr { Alter (AltData $1) $2 $4 }
Expr1 :: { Expr Name }
Expr1 : litint { LitE $ IntL $1 }
Expr1 : litint { Lit $ IntL $1 }
| Id { Var $1 }
| PackCon { $1 }
| ExprPragma { $1 }
| '(' Expr ')' { $2 }
ExprPragma :: { Expr Name }
ExprPragma : '{-#' Words '#-}' {% exprPragma $2 }
Words :: { [String] }
Words : word Words { $1 : $2 }
| word { [$1] }
PackCon :: { Expr Name }
PackCon : pack '{' litint litint '}' { Con $3 $4 }
@@ -152,43 +189,73 @@ Id : Var { $1 }
| Con { $1 }
Var :: { Name }
Var : '(' varsym ')' { $2 }
| varname { $1 }
Var : varname { $1 }
| varsym { $1 }
Con :: { Name }
Con : '(' consym ')' { $2 }
| conname { $1 }
Con : conname { $1 }
| consym { $1 }
{
parseError :: [Located CoreToken] -> RLPC SrcError a
parseError (Located y x l _ : _) = addFatal err
where err = SrcError
{ _errSpan = (y,x,l)
, _errSeverity = Error
, _errDiagnostic = SrcErrParse
}
parseError :: [Located CoreToken] -> RLPC a
parseError (Located _ t : _) =
error $ "<line>" <> ":" <> "<col>"
<> ": parse error at token `" <> show t <> "'"
parseTmp :: IO (Module Name)
parseTmp = do
s <- readFile "/tmp/t.hs"
case parse s of
Left e -> error (show e)
Right (ts,_) -> pure ts
{-# WARNING parseError "unimpl" #-}
exprPragma :: [String] -> RLPC (Expr Name)
exprPragma ("AST" : e) = undefined
exprPragma _ = undefined
{-# WARNING exprPragma "unimpl" #-}
astPragma :: [String] -> RLPC (Expr Name)
astPragma _ = undefined
{-# WARNING astPragma "unimpl" #-}
insTypeSig :: (Hashable b) => (b, Type) -> Program b -> Program b
insTypeSig ts = programTypeSigs %~ uncurry H.insert ts
singletonTypeSig :: (Hashable b) => (b, Type) -> Program b
singletonTypeSig ts = insTypeSig ts mempty
insScDef :: (Hashable b) => ScDef b -> Program b -> Program b
insScDef sc = programScDefs %~ (sc:)
singletonScDef :: (Hashable b) => ScDef b -> Program b
singletonScDef sc = insScDef sc mempty
parseCoreExprR :: (Monad m) => [Located CoreToken] -> RLPCT m Expr'
parseCoreExprR = hoistRlpcT generalise . parseCoreExpr
parseCoreProgR :: forall m. (Monad m) => [Located CoreToken] -> RLPCT m Program'
parseCoreProgR = ddumpast <=< (hoistRlpcT generalise . parseCoreProg)
where
parse = evalRLPC def . (lexCore >=> parseCore)
ddumpast :: Program' -> RLPCT m Program'
ddumpast p = do
addDebugMsg "dump-parsed-core" . show $ p
pure p
exprPragma :: [String] -> RLPC SrcError (Expr Name)
exprPragma ("AST" : e) = astPragma e
exprPragma _ = addFatal err
where err = SrcError
{ _errSpan = (0,0,0) -- TODO: span
, _errSeverity = Warning
, _errDiagnostic = SrcErrUnknownPragma "" -- TODO: missing pragma
}
happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b
happyBind m k = m >>= k
astPragma :: [String] -> RLPC SrcError (Expr Name)
astPragma = pure . read . unwords
happyPure :: a -> RLPC a
happyPure a = pure a
doTLPragma :: Pragma -> Program' -> RLPC Program'
-- TODO: warn unrecognised pragma
doTLPragma (Pragma []) p = pure p
doTLPragma (Pragma pr) p = case pr of
-- TODO: warn on overwrite
["PackData", n, readt -> t, readt -> a] ->
pure $ p & programDataTags . at n ?~ (t,a)
readt :: (Read a) => Text -> a
readt = read . T.unpack
}

159
src/Core/Parse.y.old
View File

@@ -1,159 +0,0 @@
{
module Core.Parse
( parseCore
, parseCoreExpr
, parseCoreProg
, module Core.Lex -- temp convenience
, parseTmp
, SrcError
, ParseError
, Module
)
where
import Control.Monad ((>=>))
import Data.Foldable (foldl')
import Core.Syntax
import Core.Lex
import Compiler.RLPC
import Data.Default.Class (def)
}
%name parseCore Module
%name parseCoreExpr StandaloneExpr
%name parseCoreProg StandaloneProgram
%tokentype { Located CoreToken }
%error { parseError }
%monad { RLPC ParseError }
%token
let { Located _ _ _ TokenLet }
letrec { Located _ _ _ TokenLetrec }
module { Located _ _ _ TokenModule }
where { Located _ _ _ TokenWhere }
',' { Located _ _ _ TokenComma }
in { Located _ _ _ TokenIn }
litint { Located _ _ _ (TokenLitInt $$) }
varname { Located _ _ _ (TokenVarName $$) }
varsym { Located _ _ _ (TokenVarSym $$) }
conname { Located _ _ _ (TokenConName $$) }
consym { Located _ _ _ (TokenConSym $$) }
'λ' { Located _ _ _ TokenLambda }
'->' { Located _ _ _ TokenArrow }
'=' { Located _ _ _ TokenEquals }
'(' { Located _ _ _ TokenLParen }
')' { Located _ _ _ TokenRParen }
'{' { Located _ _ _ TokenLBrace }
'}' { Located _ _ _ TokenRBrace }
vl { Located _ _ _ TokenLBraceV }
vr { Located _ _ _ TokenRBraceV }
';' { Located _ _ _ TokenSemicolon }
eof { Located _ _ _ TokenEOF }
%%
Module :: { Module }
Module : module conname where Program Eof { Module (Just ($2, [])) $4 }
| Program Eof { Module Nothing $1 }
Eof :: { () }
Eof : eof { () }
| error { () }
StandaloneProgram :: { Program }
StandaloneProgram : Program eof { $1 }
Program :: { Program }
Program : VOpen ScDefs VClose { Program $2 }
| '{' ScDefs '}' { Program $2 }
VOpen :: { () }
VOpen : vl { () }
VClose :: { () }
VClose : vr { () }
| error { () }
ScDefs :: { [ScDef] }
ScDefs : ScDef ';' ScDefs { $1 : $3 }
| {- epsilon -} { [] }
ScDef :: { ScDef }
ScDef : Var ParList '=' Expr { ScDef $1 $2 $4 }
ParList :: { [Name] }
ParList : Var ParList { $1 : $2 }
| {- epsilon -} { [] }
StandaloneExpr :: { Expr }
StandaloneExpr : Expr eof { $1 }
Expr :: { Expr }
Expr : LetExpr { $1 }
| 'λ' Binders '->' Expr { Lam $2 $4 }
| Application { $1 }
| Expr1 { $1 }
LetExpr :: { Expr }
LetExpr : let VOpen Bindings VClose in Expr { Let NonRec $3 $6 }
| letrec VOpen Bindings VClose in Expr { Let Rec $3 $6 }
| let '{' Bindings '}' in Expr { Let NonRec $3 $6 }
| letrec '{' Bindings '}' in Expr { Let Rec $3 $6 }
Binders :: { [Name] }
Binders : Var Binders { $1 : $2 }
| Var { [$1] }
Application :: { Expr }
Application : Expr1 AppArgs { foldl' App $1 $2 }
-- TODO: Application can probably be written as a single rule, without AppArgs
AppArgs :: { [Expr] }
AppArgs : Expr1 AppArgs { $1 : $2 }
| Expr1 { [$1] }
Expr1 :: { Expr }
Expr1 : litint { IntE $1 }
| Id { Var $1 }
| '(' Expr ')' { $2 }
Bindings :: { [Binding] }
Bindings : Binding ';' Bindings { $1 : $3 }
| Binding ';' { [$1] }
| Binding { [$1] }
Binding :: { Binding }
Binding : Var '=' Expr { $1 := $3 }
Id :: { Name }
Id : Var { $1 }
| Con { $1 }
Var :: { Name }
Var : '(' varsym ')' { $2 }
| varname { $1 }
Con :: { Name }
Con : '(' consym ')' { $2 }
| conname { $1 }
{
parseError :: [Located CoreToken] -> RLPC ParseError a
parseError (Located y x l _ : _) = addFatal err
where err = SrcError
{ _errSpan = (y,x,l)
, _errSeverity = Error
, _errDiagnostic = ParErrParse
}
parseTmp :: IO Module
parseTmp = do
s <- readFile "/tmp/t.hs"
case parse s of
Left e -> error (show e)
Right (ts,_) -> pure ts
where
parse = evalRLPC def . (lexCore >=> parseCore)
}

199
src/Core/Syntax.hs
View File

@@ -4,11 +4,19 @@ Description : Core ASTs and the like
-}
{-# LANGUAGE PatternSynonyms, OverloadedStrings #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TemplateHaskell #-}
-- for recursion-schemes
{-# LANGUAGE DeriveTraversable, TypeFamilies #-}
module Core.Syntax
( Expr(..)
, ExprF(..)
, ExprF'(..)
, Type(..)
, Literal(..)
, pattern TyInt
, Lit(..)
, pattern (:$)
, pattern (:@)
, pattern (:->)
, Binding(..)
, AltCon(..)
, pattern (:=)
@@ -20,52 +28,75 @@ module Core.Syntax
, Module(..)
, Program(..)
, Program'
, Pragma(..)
, unliftScDef
, programScDefs
, programTypeSigs
, programDataTags
, Expr'
, ScDef'
, Alter'
, Binding'
, HasRHS(_rhs)
, HasLHS(_lhs)
, Pretty(pretty)
)
where
----------------------------------------------------------------------------------
import Data.Coerce
import Data.Pretty
import GHC.Generics
import Data.List (intersperse)
import Data.Function ((&))
import Data.Functor.Foldable
import Data.Functor.Foldable.TH (makeBaseFunctor)
import Data.String
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as H
import Data.Hashable
import Data.Text qualified as T
import Data.Char
import Data.These
import Data.Bifoldable (bifoldr)
import GHC.Generics (Generic, Generically(..))
-- Lift instances for the Core quasiquoters
import Language.Haskell.TH.Syntax (Lift)
import Lens.Micro
-- import Lens.Micro.TH (makeLenses)
-- import Lens.Micro
import Control.Lens
----------------------------------------------------------------------------------
data Expr b = Var Name
| Con Tag Int -- Con Tag Arity
| Con Tag Int -- ^ Con Tag Arity
| Case (Expr b) [Alter b]
| Lam [b] (Expr b)
| Let Rec [Binding b] (Expr b)
| App (Expr b) (Expr b)
| LitE Literal
| Type Type
| Lit Lit
deriving (Show, Read, Lift)
deriving instance (Eq b) => Eq (Expr b)
data Type = TyInt
| TyFun
data Type = TyFun
| TyVar Name
| TyApp Type Type
| TyConApp TyCon [Type]
| TyCon Name
deriving (Show, Read, Lift, Eq)
type TyCon = Name
pattern TyInt :: Type
pattern TyInt = TyCon "Int#"
infixl 2 :$
pattern (:$) :: Expr b -> Expr b -> Expr b
pattern (:$) :: Expr b -> Expr b -> Expr b
pattern f :$ x = App f x
infixl 2 :@
pattern (:@) :: Type -> Type -> Type
pattern f :@ x = TyApp f x
infixr 1 :->
pattern (:->) :: Type -> Type -> Type
pattern a :-> b = TyApp (TyApp TyFun a) b
{-# COMPLETE Binding :: Binding #-}
{-# COMPLETE (:=) :: Binding #-}
data Binding b = Binding b (Expr b)
@@ -74,7 +105,7 @@ data Binding b = Binding b (Expr b)
deriving instance (Eq b) => Eq (Binding b)
infixl 1 :=
pattern (:=) :: b -> (Expr b) -> (Binding b)
pattern (:=) :: b -> Expr b -> Binding b
pattern k := v = Binding k v
data Alter b = Alter AltCon [b] (Expr b)
@@ -82,32 +113,54 @@ data Alter b = Alter AltCon [b] (Expr b)
deriving instance (Eq b) => Eq (Alter b)
newtype Pragma = Pragma [T.Text]
data Rec = Rec
| NonRec
deriving (Show, Read, Eq, Lift)
data AltCon = AltData Tag
| AltLiteral Literal
| Default
data AltCon = AltData Name
| AltTag Tag
| AltLit Lit
| AltDefault
deriving (Show, Read, Eq, Lift)
data Literal = IntL Int
newtype Lit = IntL Int
deriving (Show, Read, Eq, Lift)
type Name = String
type Name = T.Text
type Tag = Int
data ScDef b = ScDef b [b] (Expr b)
deriving (Show, Lift)
unliftScDef :: ScDef b -> Expr b
unliftScDef (ScDef _ as e) = Lam as e
data Module b = Module (Maybe (Name, [Name])) (Program b)
deriving (Show, Lift)
newtype Program b = Program [ScDef b]
deriving (Show, Lift)
data Program b = Program
{ _programScDefs :: [ScDef b]
, _programTypeSigs :: HashMap b Type
, _programDataTags :: HashMap b (Tag, Int)
-- ^ map constructors to their tag and arity
}
deriving (Show, Lift, Generic)
deriving (Semigroup, Monoid)
via Generically (Program b)
programScDefs :: Lens' (Program b) [ScDef b]
programScDefs = lens coerce (const coerce)
makeLenses ''Program
makeBaseFunctor ''Expr
pure []
-- this is a weird optic, stronger than Lens and Prism, but weaker than Iso.
programTypeSigsP :: (Hashable b) => Prism' (Program b) (HashMap b Type)
programTypeSigsP = prism
(\b -> mempty & programTypeSigs .~ b)
(Right . view programTypeSigs)
type ExprF' = ExprF Name
type Program' = Program Name
type Expr' = Expr Name
@@ -116,13 +169,14 @@ type Alter' = Alter Name
type Binding' = Binding Name
instance IsString (Expr b) where
fromString = Var
fromString = Var . fromString
instance Semigroup (Program b) where
(<>) = coerce $ (<>) @[ScDef b]
instance Monoid (Program b) where
mempty = Program []
instance IsString Type where
fromString "" = error "IsString Type string may not be empty"
fromString s
| isUpper c = TyCon . fromString $ s
| otherwise = TyVar . fromString $ s
where (c:_) = s
----------------------------------------------------------------------------------
@@ -155,5 +209,94 @@ instance HasLHS (Alter b) (Alter b) (AltCon, [b]) (AltCon, [b]) where
instance HasLHS (ScDef b) (ScDef b) (b, [b]) (b, [b]) where
_lhs = lens
(\ (ScDef n as _) -> (n,as))
(\ (ScDef _ _ e) (n',as') -> (ScDef n' as' e))
(\ (ScDef _ _ e) (n',as') -> ScDef n' as' e)
instance HasLHS (Binding b) (Binding b) b b where
_lhs = lens
(\ (k := _) -> k)
(\ (_ := e) k' -> k' := e)
--------------------------------------------------------------------------------
-- TODO: print type sigs with corresponding scdefs
-- TODO: emit pragmas for datatags
instance (Hashable b, Pretty b) => Pretty (Program b) where
pretty p = ifoldrOf (programDataTags . ifolded) cataDataTag mempty p
$+$ vlinesOf (programJoinedDefs . to prettyGroup) p
where
programJoinedDefs :: Fold (Program b) (These (b, Type) (ScDef b))
programJoinedDefs = folding $ \p ->
foldMapOf programTypeSigs thisTs p
`u` foldMapOf programScDefs thatSc p
where u = H.unionWith unionThese
thisTs = ifoldMap @b @(HashMap b)
(\n t -> H.singleton n (This (n,t)))
thatSc = foldMap $ \sc ->
H.singleton (sc ^. _lhs . _1) (That sc)
prettyGroup :: These (b, Type) (ScDef b) -> Doc
prettyGroup = bifoldr ($$) ($$) mempty . bimap prettyTySig pretty
prettyTySig (n,t) = hsep [ttext n, "::", pretty t]
unionThese (This a) (That b) = These a b
unionThese (That b) (This a) = These a b
unionThese (These a b) _ = These a b
cataDataTag n (t,a) acc = prettyDataTag n t a $+$ acc
prettyDataTag n t a =
hsep ["{-#", "PackData", ttext n, ttext t, ttext a, "#-}"]
instance Pretty Type where
prettyPrec _ (TyVar n) = ttext n
prettyPrec _ TyFun = "(->)"
prettyPrec _ (TyCon n) = ttext n
prettyPrec p (a :-> b) = maybeParens (p>0) $
hsep [prettyPrec 1 a, "->", prettyPrec 0 b]
prettyPrec p (TyApp f x) = maybeParens (p>1) $
prettyPrec 1 f <+> prettyPrec 2 x
instance (Pretty b) => Pretty (ScDef b) where
pretty sc = hsep [name, as, "=", hang empty 1 e, ";"]
where
name = ttext $ sc ^. _lhs . _1
as = sc & hsepOf (_lhs . _2 . each . to ttext)
e = pretty $ sc ^. _rhs
instance (Pretty b) => Pretty (Expr b) where
prettyPrec _ (Var n) = ttext n
prettyPrec _ (Con t a) = "Pack{" <> (ttext t <+> ttext a) <> "}"
prettyPrec _ (Lam bs e) = hsep ["λ", hsep (prettyPrec 1 <$> bs), "->", pretty e]
prettyPrec _ (Let r bs e) = hsep [word, explicitLayout bs]
$+$ hsep ["in", pretty e]
where word = if r == Rec then "letrec" else "let"
prettyPrec p (App f x) = maybeParens (p>0) $
prettyPrec 0 f <+> prettyPrec 1 x
prettyPrec _ (Lit l) = pretty l
prettyPrec p (Case e as) = maybeParens (p>0) $
"case" <+> pretty e <+> "of"
$+$ nest 2 (explicitLayout as)
instance (Pretty b) => Pretty (Alter b) where
pretty (Alter c as e) =
hsep [pretty c, hsep (pretty <$> as), "->", pretty e]
instance Pretty AltCon where
pretty (AltData n) = ttext n
pretty (AltLit l) = pretty l
pretty (AltTag t) = ttext t
pretty AltDefault = "_"
instance Pretty Lit where
pretty (IntL n) = ttext n
instance (Pretty b) => Pretty (Binding b) where
pretty (k := v) = hsep [pretty k, "=", pretty v]
explicitLayout :: (Pretty a) => [a] -> Doc
explicitLayout as = vcat inner <+> "}" where
inner = zipWith (<+>) delims (pretty <$> as)
delims = "{" : repeat ";"

67
src/Core/TH.hs
View File

@@ -5,62 +5,53 @@ Description : Core quasiquoters
module Core.TH
( coreExpr
, coreProg
, core
, coreExprT
, coreProgT
)
where
----------------------------------------------------------------------------------
import Language.Haskell.TH
import Language.Haskell.TH.Syntax hiding (Module)
import Language.Haskell.TH.Syntax hiding (Module)
import Language.Haskell.TH.Quote
import Control.Monad ((>=>))
import Control.Monad.IO.Class
import Control.Arrow ((>>>))
import Compiler.RLPC
import Data.Default.Class (def)
import Data.Text (Text)
import Data.Text qualified as T
import Core.Parse
import Core.Lex
import Core.Syntax
import Core.HindleyMilner (checkCoreProgR, checkCoreExprR)
----------------------------------------------------------------------------------
core :: QuasiQuoter
core = QuasiQuoter
{ quoteExp = qCore
, quotePat = error "core quasiquotes may only be used in expressions"
, quoteType = error "core quasiquotes may only be used in expressions"
, quoteDec = error "core quasiquotes may only be used in expressions"
}
coreProg :: QuasiQuoter
coreProg = QuasiQuoter
{ quoteExp = qCoreProg
, quotePat = error "core quasiquotes may only be used in expressions"
, quoteType = error "core quasiquotes may only be used in expressions"
, quoteDec = error "core quasiquotes may only be used in expressions"
}
coreProg = mkqq $ lexCoreR >=> parseCoreProgR
coreExpr :: QuasiQuoter
coreExpr = QuasiQuoter
{ quoteExp = qCoreExpr
coreExpr = mkqq $ lexCoreR >=> parseCoreExprR
-- | Type-checked @coreProg@
coreProgT :: QuasiQuoter
coreProgT = mkqq $ lexCoreR >=> parseCoreProgR >=> checkCoreProgR
coreExprT :: QuasiQuoter
coreExprT = mkqq $ lexCoreR >=> parseCoreExprR >=> checkCoreExprR g
where
g = [ ("+#", TyCon "Int#" :-> TyCon "Int#" :-> TyCon "Int#")
, ("id", TyCon "a" :-> TyCon "a")
, ("fix", (TyCon "a" :-> TyCon "a") :-> TyCon "a")
]
mkqq :: (Lift a) => (Text -> RLPCIO a) -> QuasiQuoter
mkqq p = QuasiQuoter
{ quoteExp = mkq p
, quotePat = error "core quasiquotes may only be used in expressions"
, quoteType = error "core quasiquotes may only be used in expressions"
, quoteDec = error "core quasiquotes may only be used in expressions"
}
qCore :: String -> Q Exp
qCore s = case parse s of
Left e -> error (show e)
Right (m,ts) -> lift m
where
parse = evalRLPC def . (lexCore >=> parseCore)
qCoreExpr :: String -> Q Exp
qCoreExpr s = case parseExpr s of
Left e -> error (show e)
Right (m,ts) -> lift m
where
parseExpr = evalRLPC def . (lexCore >=> parseCoreExpr)
qCoreProg :: String -> Q Exp
qCoreProg s = case parseProg s of
Left e -> error (show e)
Right (m,ts) -> lift m
where
parseProg = evalRLPC def . (lexCore >=> parseCoreProg)
mkq :: (Lift a) => (Text -> RLPCIO a) -> String -> Q Exp
mkq parse s = liftIO $ evalRLPCIO def (parse $ T.pack s) >>= lift

35
src/Core/Utils.hs
View File

@@ -1,16 +1,10 @@
-- for recursion schemes
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
-- for recursion schemes
{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
module Core.Utils
( bindersOf
, rhssOf
( programRhss
, programGlobals
, isAtomic
, insertModule
-- , insertModule
, extractProgram
, freeVariables
, ExprF(..)
)
where
----------------------------------------------------------------------------------
@@ -19,35 +13,32 @@ import Data.Functor.Foldable
import Data.Set (Set)
import Data.Set qualified as S
import Core.Syntax
import Lens.Micro
import GHC.Exts (IsList(..))
----------------------------------------------------------------------------------
bindersOf :: (IsList l, Item l ~ b) => [Binding b] -> l
bindersOf bs = fromList $ fmap f bs
where f (k := _) = k
programGlobals :: Traversal' (Program b) b
programGlobals = programScDefs . each . _lhs . _1
rhssOf :: (IsList l, Item l ~ Expr b) => [Binding b] -> l
rhssOf = fromList . fmap f
where f (_ := v) = v
programRhss :: Traversal' (Program b) (Expr b)
programRhss = programScDefs . each . _rhs
isAtomic :: Expr b -> Bool
isAtomic (Var _) = True
isAtomic (LitE _) = True
isAtomic (Lit _) = True
isAtomic _ = False
----------------------------------------------------------------------------------
-- TODO: export list awareness
insertModule :: Module b -> Program b -> Program b
insertModule (Module _ m) p = p <> m
-- insertModule :: Module b -> Program b -> Program b
-- insertModule (Module _ p) = programScDefs %~ (<>m)
extractProgram :: Module b -> Program b
extractProgram (Module _ p) = p
----------------------------------------------------------------------------------
makeBaseFunctor ''Expr
freeVariables :: Expr' -> Set Name
freeVariables = cata go
where
@@ -56,8 +47,8 @@ freeVariables = cata go
-- TODO: collect free vars in rhss of bs
go (LetF _ bs e) = (e `S.union` esFree) `S.difference` ns
where
es = rhssOf bs :: [Expr']
ns = bindersOf bs
es = bs ^.. each . _rhs :: [Expr']
ns = S.fromList $ bs ^.. each . _lhs
-- TODO: this feels a little wrong. maybe a different scheme is
-- appropriate
esFree = foldMap id $ freeVariables <$> es

76
src/Core2Core.hs
View File

@@ -1,4 +1,4 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ImplicitParams #-}
module Core2Core
( core2core
, gmPrep
@@ -14,39 +14,82 @@ import Data.Maybe (fromJust)
import Data.Set (Set)
import Data.Set qualified as S
import Data.List
import Data.Foldable
import Control.Monad.Writer
import Control.Monad.State
import Control.Monad.State.Lazy
import Control.Arrow ((>>>))
import Data.Text qualified as T
import Data.HashMap.Strict (HashMap)
import Numeric (showHex)
import Lens.Micro
import Data.Pretty
import Compiler.RLPC
-- import Lens.Micro.Platform
import Control.Lens
import Core.Syntax
import Core.Utils
----------------------------------------------------------------------------------
-- | General optimisations
core2core :: Program' -> Program'
core2core p = undefined
gmPrepR :: (Monad m) => Program' -> RLPCT m Program'
gmPrepR p = do
let p' = gmPrep p
addDebugMsg "dump-gm-preprocessed" $ render . pretty $ p'
pure p'
-- | G-machine-specific preprocessing.
gmPrep :: Program' -> Program'
gmPrep p = p' <> Program caseScs
gmPrep p = p & appFloater (floatNonStrictCases globals)
& tagData
& defineData
where
rhss :: Applicative f => (Expr z -> f (Expr z)) -> Program z -> f (Program z)
rhss = programScDefs . each . _rhs
globals = p ^.. programScDefs . each . _lhs . _1
& S.fromList
-- i kinda don't like that we're calling floatNonStrictCases twice tbh
p' = p & rhss %~ fst . runFloater . floatNonStrictCases globals
caseScs = (p ^.. rhss)
<&> snd . runFloater . floatNonStrictCases globals
& mconcat
-- | Define concrete supercombinators for all datatags defined via pragmas (or
-- desugaring)
defineData :: Program' -> Program'
defineData p = p & programScDefs <>~ defs
where
defs = p ^. programDataTags
. to (ifoldMap (\k (t,a) -> [ScDef k [] (Con t a)]))
-- | Substitute all pattern matches on named constructors for matches on tags
tagData :: Program' -> Program'
tagData p = let ?dt = p ^. programDataTags
in p & programRhss %~ cata go where
go :: (?dt :: HashMap Name (Tag, Int)) => ExprF' Expr' -> Expr'
go (CaseF e as) = Case e (tagAlts <$> as)
go x = embed x
tagAlts :: (?dt :: HashMap Name (Tag, Int)) => Alter' -> Alter'
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
Nothing -> error $ "unknown constructor " <> show c
tagAlts x = x
-- | Auxilary type used in @floatNonSrictCases@
type Floater = StateT [Name] (Writer [ScDef'])
appFloater :: (Expr' -> Floater Expr') -> Program' -> Program'
appFloater fl p = p & traverseOf programRhss fl
& runFloater
& \ (me,floats) -> me & programScDefs %~ (<>floats)
-- TODO: move NameSupply from Rlp2Core into a common module to share here
runFloater :: Floater a -> (a, [ScDef'])
runFloater = flip evalStateT ns >>> runWriter
where
ns = [ "$nonstrict_case_" ++ showHex n "" | n <- [0..] ]
ns = [ T.pack $ "$nonstrict_case_" ++ showHex n "" | n <- [0..] ]
-- TODO: formally define a "strict context" and reference that here
-- the returned ScDefs are guaranteed to be free of non-strict cases.
@@ -55,7 +98,7 @@ floatNonStrictCases g = goE
where
goE :: Expr' -> Floater Expr'
goE (Var k) = pure (Var k)
goE (LitE l) = pure (LitE l)
goE (Lit l) = pure (Lit l)
goE (Case e as) = pure (Case e as)
goE (Let Rec bs e) = Let Rec <$> bs' <*> goE e
where bs' = travBs goE bs
@@ -72,16 +115,16 @@ floatNonStrictCases g = goE
altBodies = (\(Alter _ _ b) -> b) <$> as
tell [sc]
goE e
traverse goE altBodies
traverse_ goE altBodies
pure e'
goC (f :$ x) = (:$) <$> goC f <*> goC x
goC (Let r bs e) = Let r <$> bs' <*> goE e
where bs' = travBs goC bs
goC (LitE l) = pure (LitE l)
goC (Lit l) = pure (Lit l)
goC (Var k) = pure (Var k)
goC (Con t as) = pure (Con t as)
name = state (fromJust . uncons)
name = state (fromJust . Data.List.uncons)
-- extract the right-hand sides of a list of bindings, traverse each
-- one, and return the original list of bindings
@@ -89,6 +132,7 @@ floatNonStrictCases g = goE
travBs c bs = bs ^.. each . _rhs
& traverse goC
& const (pure bs)
-- ^ ??? what the fuck?
-- when provided with a case expr, floatCase will float the case into a
-- supercombinator of its free variables. the sc is returned along with an

18
src/Data/Heap.hs
View File

@@ -27,6 +27,7 @@ import Debug.Trace
import Data.Map.Strict qualified as M
import Data.List (intersect)
import GHC.Stack (HasCallStack)
import Control.Lens
----------------------------------------------------------------------------------
data Heap a = Heap [Addr] (Map Addr a)
@@ -34,6 +35,21 @@ data Heap a = Heap [Addr] (Map Addr a)
type Addr = Int
type instance Index (Heap a) = Addr
type instance IxValue (Heap a) = a
instance Ixed (Heap a) where
ix a k (Heap as m) = Heap as <$> M.alterF k' a m where
k' (Just v) = Just <$> k v
k' Nothing = pure Nothing
instance At (Heap a) where
at ma k (Heap as m) = Heap as <$> M.alterF k ma m
instance FoldableWithIndex Addr Heap where
ifoldr fi z (Heap _ m) = ifoldr fi z m
ifoldMap iam (Heap _ m) = ifoldMap iam m
instance Semigroup (Heap a) where
Heap ua ma <> Heap ub mb = Heap u m
where
@@ -54,7 +70,7 @@ instance Foldable Heap where
length (Heap _ m) = M.size m
instance Traversable Heap where
traverse t (Heap u m) = Heap u <$> (traverse t m)
traverse t (Heap u m) = Heap u <$> traverse t m
----------------------------------------------------------------------------------

99
src/Data/Pretty.hs
View File

@@ -1,80 +1,65 @@
{-# LANGUAGE OverloadedStrings #-}
module Data.Pretty
( Pretty(..)
, ISeq(..)
, precPretty
, prettyPrint
, prettyShow
, iShow
, iBracket
, withPrec
, bracketPrec
, rpretty
, ttext
-- * Pretty-printing lens combinators
, hsepOf, vsepOf
, vcatOf
, vlinesOf
, module Text.PrettyPrint
, maybeParens
)
where
----------------------------------------------------------------------------------
import Data.String (IsString(..))
import Text.PrettyPrint hiding ((<>))
import Text.PrettyPrint.HughesPJ hiding ((<>))
import Text.Printf
import Data.String (IsString(..))
import Data.Text.Lens
import Data.Monoid
import Data.Text qualified as T
import Control.Lens
----------------------------------------------------------------------------------
class Pretty a where
pretty :: a -> ISeq
prettyPrec :: a -> Int -> ISeq
pretty :: a -> Doc
prettyPrec :: Int -> a -> Doc
{-# MINIMAL pretty | prettyPrec #-}
pretty a = prettyPrec a 0
prettyPrec a _ = iBracket (pretty a)
pretty = prettyPrec 0
prettyPrec a _ = pretty a
precPretty :: (Pretty a) => Int -> a -> ISeq
precPretty = flip prettyPrec
rpretty :: (IsString s, Pretty a) => a -> s
rpretty = fromString . render . pretty
prettyPrint :: (Pretty a) => a -> IO ()
prettyPrint = putStr . squash . pretty
instance Pretty String where
pretty = Text.PrettyPrint.text
prettyShow :: (Pretty a) => a -> String
prettyShow = squash . pretty
instance Pretty T.Text where
pretty = Text.PrettyPrint.text . view unpacked
data ISeq where
INil :: ISeq
IStr :: String -> ISeq
IAppend :: ISeq -> ISeq -> ISeq
IIndent :: ISeq -> ISeq
IBreak :: ISeq
newtype Showing a = Showing a
instance IsString ISeq where
fromString = IStr
instance (Show a) => Pretty (Showing a) where
prettyPrec p (Showing a) = fromString $ showsPrec p a ""
instance Semigroup ISeq where
(<>) = IAppend
deriving via Showing Int instance Pretty Int
instance Monoid ISeq where
mempty = INil
--------------------------------------------------------------------------------
squash :: ISeq -> String
squash a = flatten 0 [(a,0)]
ttext :: Pretty t => t -> Doc
ttext = pretty
flatten :: Int -> [(ISeq, Int)] -> String
flatten _ [] = ""
flatten c ((INil, i) : ss) = flatten c ss
flatten c ((IStr s, i) : ss) = s ++ flatten (c + length s) ss
flatten c ((IAppend r s, i) : ss) = flatten c ((r,i) : (s,i) : ss)
flatten _ ((IBreak, i) : ss) = '\n' : replicate i ' ' ++ flatten i ss
flatten c ((IIndent s, i) : ss) = flatten c ((s,c) : ss)
hsepOf :: Getting (Endo Doc) s Doc -> s -> Doc
hsepOf l = foldrOf l (<+>) mempty
iBracket :: ISeq -> ISeq
iBracket s = IStr "(" <> s <> IStr ")"
vsepOf :: Getting (Endo Doc) s Doc -> s -> Doc
vsepOf l = foldrOf l ($+$) mempty
withPrec :: Int -> ISeq -> Int -> ISeq
withPrec n s p
| p > n = iBracket s
| otherwise = s
vcatOf :: Getting (Endo Doc) s Doc -> s -> Doc
vcatOf l = foldrOf l ($$) mempty
bracketPrec :: Int -> Int -> ISeq -> ISeq
bracketPrec n p s = withPrec n s p
vlinesOf :: Getting (Endo Doc) s Doc -> s -> Doc
vlinesOf l = foldrOf l (\a b -> a $+$ "" $+$ b) mempty
-- hack(?) to separate chunks with a blankline
iShow :: (Show a) => a -> ISeq
iShow = IStr . show
----------------------------------------------------------------------------------
instance (Pretty a) => Pretty (Maybe a) where
prettyPrec (Just a) p = prettyPrec a p
prettyPrec Nothing p = "<Nothing>"

164
src/GM.hs
View File

@@ -8,8 +8,13 @@ Description : The G-Machine
module GM
( hdbgProg
, evalProg
, evalProgR
, GmState(..)
, gmCode, gmStack, gmDump, gmHeap, gmEnv, gmStats
, Node(..)
, showState
, gmEvalProg
, Stats(..)
, finalStateOf
, resultOf
, resultOfExpr
@@ -22,19 +27,37 @@ 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 Text.Printf
import Text.PrettyPrint hiding ((<>))
import Text.PrettyPrint.HughesPJ (maybeParens)
import Data.Foldable (traverse_)
import System.IO (Handle, hPutStrLn)
-- TODO: an actual output system
-- TODO: an actual output system
-- TODO: an actual output system
-- TODO: an actual output system
import System.IO.Unsafe (unsafePerformIO)
import Data.String (IsString)
import Data.Heap
import Debug.Trace
import Compiler.RLPC
import Core2Core
import Core
----------------------------------------------------------------------------------
tag_Unit_unit :: Int
tag_Unit_unit = 0
tag_Bool_True :: Int
tag_Bool_True = 1
tag_Bool_False :: Int
tag_Bool_False = 0
{-}
hdbgProg = undefined
@@ -70,6 +93,7 @@ data Key = NameKey Name
| ConstrKey Tag Int
deriving (Show, Eq)
-- >> [ref/Instr]
data Instr = Unwind
| PushGlobal Name
| PushConstr Tag Int
@@ -84,12 +108,14 @@ data Instr = Unwind
-- arith
| Neg | Add | Sub | Mul | Div
-- comparison
| Equals
| Equals | Lesser | GreaterEq
| Pack Tag Int -- Pack Tag Arity
| CaseJump [(Tag, Code)]
| Split Int
| Print
| Halt
deriving (Show, Eq)
-- << [ref/Instr]
data Node = NNum Int
| NAp Addr Addr
@@ -132,7 +158,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`
@@ -140,7 +166,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"
@@ -153,6 +179,21 @@ hdbgProg p hio = do
[resAddr] = final ^. gmStack
res = hLookupUnsafe resAddr h
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
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
where
@@ -175,29 +216,55 @@ isFinal st = null $ st ^. gmCode
step :: GmState -> GmState
step st = case head (st ^. gmCode) of
Unwind -> unwindI
Unwind -> unwindI
PushGlobal n -> pushGlobalI n
PushConstr t n -> pushConstrI t n
PushInt n -> pushIntI n
Push n -> pushI n
MkAp -> mkApI
MkAp -> mkApI
Slide n -> slideI n
Pop n -> popI n
Update n -> updateI n
Alloc n -> allocI n
Eval -> evalI
Neg -> negI
Add -> addI
Sub -> subI
Mul -> mulI
Div -> divI
Equals -> equalsI
Eval -> evalI
Neg -> negI
Add -> addI
Sub -> subI
Mul -> mulI
Div -> divI
Equals -> equalsI
Lesser -> lesserI
GreaterEq -> greaterEqI
Split n -> splitI n
Pack t n -> packI t n
CaseJump as -> caseJumpI as
Print -> printI
Halt -> haltI
where
printI :: GmState
printI = case hLookupUnsafe a h of
NNum n -> (evilTempPrinter `seq` st)
& gmCode .~ i
& gmStack .~ s
where
-- TODO: an actual output system
-- TODO: an actual output system
-- TODO: an actual output system
-- TODO: an actual output system
evilTempPrinter = unsafePerformIO (print n)
NConstr _ as -> st
& gmCode .~ i' ++ i
& gmStack .~ s'
where
i' = mconcat $ replicate n [Eval,Print]
n = length as
s' = as ++ s
where
h = st ^. gmHeap
(a:s) = st ^. gmStack
Print : i = st ^. gmCode
-- nuke the state
haltI :: GmState
haltI = error "halt#"
@@ -281,7 +348,7 @@ step st = case head (st ^. gmCode) of
m = st ^. gmEnv
s = st ^. gmStack
h = st ^. gmHeap
n' = show n
n' = show n ^. packed
-- Core Rule 2. (no sharing)
-- pushIntI :: Int -> GmState
@@ -391,8 +458,10 @@ step st = case head (st ^. gmCode) of
mulI = primitive2 boxInt unboxInt (*) st
divI = primitive2 boxInt unboxInt div st
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
@@ -534,12 +603,13 @@ boxBool st p = st
where
h = st ^. gmHeap
(h',a) = alloc h (NConstr p' [])
p' = if p then 1 else 0
p' = if p then tag_Bool_True else tag_Bool_False
unboxBool :: Addr -> GmState -> Bool
unboxBool a st = case hLookup a h of
Just (NConstr 1 []) -> True
Just (NConstr 0 []) -> False
Just (NConstr t [])
| t == tag_Bool_True -> True
| t == tag_Bool_False -> False
Just _ -> error "unboxInt received a non-int"
Nothing -> error "unboxInt received an invalid address"
where h = st ^. gmHeap
@@ -575,6 +645,10 @@ compiledPrims =
, binop "*#" Mul
, binop "/#" Div
, binop "==#" Equals
, binop "<#" Lesser
, binop ">=#" GreaterEq
, ("print#", 1, [ Push 0, Eval, Print, Pack tag_Unit_unit 0, Update 1, Pop 1
, Unwind ])
]
where
unop k i = (k, 1, [Push 0, Eval, i, Update 1, Pop 1, Unwind])
@@ -582,7 +656,7 @@ compiledPrims =
binop k i = (k, 2, [Push 1, Eval, Push 1, Eval, i, Update 2, Pop 2, Unwind])
buildInitialHeap :: Program' -> (GmHeap, Env)
buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compiledScs
where
compiledScs = fmap compileSc ss <> compiledPrims
@@ -612,12 +686,13 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
| k `elem` domain = [Push n]
| otherwise = [PushGlobal k]
where
n = fromMaybe (error $ "undeclared var: " <> k) $ lookupN k g
n = fromMaybe err $ lookupN k g
err = error $ "undeclared var: " <> (k ^. unpacked)
domain = f `mapMaybe` g
f (NameKey n, _) = Just n
f _ = Nothing
compileC _ (LitE l) = compileCL l
compileC _ (Lit l) = compileCL l
-- >> [ref/compileC]
compileC g (App f x) = compileC g x
@@ -657,33 +732,32 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
compileC _ (Con t n) = [PushConstr t n]
compileC _ (Case _ _) =
error "case expressions may not appear in non-strict contexts :/"
error "GM compiler found a non-strict case expression, which should\
\ have been floated by Core2Core.gmPrep. This is a bug!"
compileC _ _ = error "yet to be implemented!"
compileCL :: Literal -> Code
compileCL :: Lit -> Code
compileCL (IntL n) = [PushInt n]
compileEL :: Literal -> Code
compileEL :: Lit -> Code
compileEL (IntL n) = [PushInt n]
-- compile an expression in a strict context such that a pointer to the
-- expression is left on top of the stack in WHNF
compileE :: Env -> Expr' -> Code
compileE _ (LitE l) = compileEL l
compileE _ (Lit l) = compileEL l
compileE g (Let NonRec bs e) =
-- we use compileE instead of compileC
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
@@ -711,21 +785,27 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
compileE g ("*#" :$ a :$ b) = inlineOp2 g Mul 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 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 e = compileC g e ++ [Eval]
compileD :: Env -> [Alter'] -> [(Tag, Code)]
compileD g as = fmap (compileA g) as
compileD g = fmap (compileA g)
compileA :: Env -> Alter' -> (Tag, Code)
compileA g (Alter (AltData t) as e) = (t, [Split n] <> c <> [Slide n])
compileA g (Alter (AltTag t) as e) = (t, [Split n] <> c <> [Slide n])
where
n = length as
binds = (NameKey <$> as) `zip` [0..]
g' = binds ++ argOffset n g
c = compileE g' e
compileA _ (Alter _ as e) = error "GM.compileA found an untagged\
\ constructor, which should have\
\ been handled by Core2Core.gmPrep.\
\ This is a bug!"
inlineOp1 :: Env -> Instr -> Expr' -> Code
inlineOp1 g i a = compileE g a <> [i]
@@ -738,8 +818,8 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
argOffset :: Int -> Env -> Env
argOffset n = each . _2 %~ (+n)
idPack :: Tag -> Int -> String
idPack t n = printf "Pack{%d %d}" t n
showCon :: (IsText a) => Tag -> Int -> a
showCon t n = printf "Pack{%d %d}" t n ^. packed
----------------------------------------------------------------------------------
@@ -855,12 +935,12 @@ showNodeAt = showNodeAtP 0
showNodeAtP :: Int -> GmState -> Addr -> Doc
showNodeAtP p st a = case hLookup a h of
Just (NNum n) -> int n <> "#"
Just (NGlobal _ _) -> text name
Just (NGlobal _ _) -> textt name
where
g = st ^. gmEnv
name = case lookup a (swap <$> g) of
Just (NameKey n) -> n
Just (ConstrKey t n) -> idPack t n
Just (ConstrKey t n) -> showCon t n
_ -> errTxtInvalidAddress
-- TODO: left-associativity
Just (NAp f x) -> pprec $ showNodeAtP (p+1) st f
@@ -877,7 +957,7 @@ showNodeAtP p st a = case hLookup a h of
pprec = maybeParens (p > 0)
showSc :: GmState -> (Name, Addr) -> Doc
showSc st (k,a) = "Supercomb " <> qquotes (text k) <> colon
showSc st (k,a) = "Supercomb " <> qquotes (textt k) <> colon
$$ code
where
code = case hLookup a (st ^. gmHeap) of
@@ -900,6 +980,9 @@ showInstr (CaseJump alts) = "CaseJump" $$ nest pprTabstop alternatives
alternatives = foldr (\a acc -> showAlt a $$ acc) mempty alts
showInstr i = text $ show i
textt :: (IsText a) => a -> Doc
textt t = t ^. unpacked & text
----------------------------------------------------------------------------------
lookupN :: Name -> Env -> Maybe Addr
@@ -975,7 +1058,8 @@ resultOf p = do
h = st ^. gmHeap
resultOfExpr :: Expr' -> Maybe Node
resultOfExpr e = resultOf $ Program
[ ScDef "main" [] e
]
resultOfExpr e = resultOf $
mempty & programScDefs .~
[ ScDef "main" [] e
]

59
src/RLP/Syntax.hs
View File

@@ -1,59 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module RLP.Syntax
( RlpExpr
)
where
----------------------------------------------------------------------------------
import Data.Text (Text)
import Lens.Micro
import Core (HasRHS(..), HasLHS(..))
----------------------------------------------------------------------------------
newtype RlpProgram b = RlpProgram [Decl b]
data Decl b = InfixD InfixAssoc Int VarId
| FunD VarId [Pat b] (RlpExpr b)
| DataD ConId [ConId] [ConAlt]
data ConAlt = ConAlt ConId [ConId]
data InfixAssoc = Assoc | AssocL | AssocR
data RlpExpr b = LetE [Bind b] (RlpExpr b)
| VarE VarId
| ConE ConId
| LamE [Pat b] (RlpExpr b)
| CaseE (RlpExpr b) [Alt b]
| IfE (RlpExpr b) (RlpExpr b) (RlpExpr b)
| AppE (RlpExpr b) (RlpExpr b)
| LitE (Lit b)
-- do we want guards?
data Alt b = AltA (Pat b) (RlpExpr b)
data Bind b = PatB (Pat b) (RlpExpr b)
| FunB VarId [Pat b] (RlpExpr b)
data VarId = NameVar Text
| SymVar Text
data ConId = NameCon Text
| SymCon Text
data Pat b = VarP VarId
| LitP (Lit b)
| ConP ConId [Pat b]
data Lit b = IntL Int
| CharL Char
| ListL [RlpExpr b]
-- instance HasLHS Alt Alt Pat Pat where
-- _lhs = lens
-- (\ (AltA p _) -> p)
-- (\ (AltA _ e) p' -> AltA p' e)
-- instance HasRHS Alt Alt RlpExpr RlpExpr where
-- _rhs = lens
-- (\ (AltA _ e) -> e)
-- (\ (AltA p _) e' -> AltA p e')

378
src/Rlp/Lex.x Normal file
View File

@@ -0,0 +1,378 @@
{
{-# LANGUAGE ViewPatterns, LambdaCase #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module Rlp.Lex
( P(..)
, RlpToken(..)
, Located(..)
, lexToken
, lexStream
, lexDebug
, lexCont
, popLexState
, programInitState
, runP'
)
where
import Codec.Binary.UTF8.String (encodeChar)
import Control.Monad
import Control.Monad.Errorful
import Core.Syntax (Name)
import Data.Functor.Identity
import Data.Char (digitToInt)
import Data.Monoid (First)
import Data.Maybe
import Data.Text (Text)
import Data.Text qualified as T
import Data.Word
import Data.Default
import Lens.Micro.Mtl
import Lens.Micro
import Debug.Trace
import Rlp.Parse.Types
}
$whitechar = [ \t\n\r\f\v]
$nl = [\n\r]
$white_no_nl = $white # $nl
$lower = [a-z \_]
$upper = [A-Z]
$alpha = [$lower $upper]
$digit = 0-9
$special = [\(\)\,\;\[\]\{\}]
$namechar = [$alpha $digit \' \#]
$asciisym = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
@decimal = $digit+
@varname = $lower $namechar*
@conname = $upper $namechar*
@consym = \: $asciisym*
@varsym = $asciisym+
@reservedname =
case|data|do|import|in|let|letrec|module|of|where
|infixr|infixl|infix
@reservedop =
"=" | \\ | "->" | "|" | "::"
rlp :-
-- everywhere: skip whitespace
$white_no_nl+ ;
-- everywhere: skip comments
-- TODO: don't treat operators like (-->) as comments
"--".* ;
-- we are indentation-sensitive! do not skip NLs!. upon encountering a newline,
-- we check indentation and potentially insert extra tokens. search this file
-- for the definition of `doBol`
<0> \n { beginPush bol }
<layout>
{
}
-- layout keywords
<0>
{
"let" { constToken TokenLet `thenBeginPush` layout_let }
"letrec" { constToken TokenLetrec `thenBeginPush` layout_let }
"of" { constToken TokenOf `thenBeginPush` layout_of }
}
-- scan various identifiers and reserved words. order is important here!
<0>
{
@reservedname { tokenWith lexReservedName }
@conname { tokenWith TokenConName }
@varname { tokenWith TokenVarName }
@reservedop { tokenWith lexReservedOp }
@consym { tokenWith TokenConSym }
@varsym { tokenWith TokenVarSym }
}
-- literals -- currently this is just unsigned integer literals
<0>
{
@decimal { tokenWith (TokenLitInt . readInt) }
}
-- control characters
<0>
{
"(" { constToken TokenLParen }
")" { constToken TokenRParen }
"{" { explicitLBrace }
"}" { explicitRBrace }
";" { constToken TokenSemicolon }
}
-- consume all whitespace leaving us at the beginning of the next non-empty
-- line. we then compare the indentation of that line to the enclosing layout
-- context and proceed accordingly
<bol>
{
$whitechar ;
\n ;
() { doBol }
}
<layout_top>
{
\n ;
"{" { explicitLBrace `thenDo` popLexState }
}
<layout, layout_let, layout_of>
{
\n { beginPush bol }
"{" { explicitLBrace `thenDo` popLexState }
}
<layout_let>
{
"in" { constToken TokenIn `thenDo` (popLexState *> popLayout) }
}
<layout, layout_top, layout_let, layout_of>
{
() { doLayout }
}
{
lexReservedName :: Text -> RlpToken
lexReservedName = \case
"data" -> TokenData
"case" -> TokenCase
"of" -> TokenOf
"let" -> TokenLet
"letrec" -> TokenLetrec
"in" -> TokenIn
"infix" -> TokenInfix
"infixl" -> TokenInfixL
"infixr" -> TokenInfixR
s -> error (show s)
lexReservedOp :: Text -> RlpToken
lexReservedOp = \case
"=" -> TokenEquals
"::" -> TokenHasType
"|" -> TokenPipe
"->" -> TokenArrow
s -> error (show s)
-- | @andBegin@, with the subtle difference that the start code is set
-- /after/ the action
thenBegin :: LexerAction a -> Int -> LexerAction a
thenBegin act c inp l = do
a <- act inp l
psLexState . _head .= c
pure a
thenBeginPush :: LexerAction a -> Int -> LexerAction a
thenBeginPush act c inp l = do
a <- act inp l
pushLexState c
pure a
andBegin :: LexerAction a -> Int -> LexerAction a
andBegin act c inp l = do
psLexState . _head .= c
act inp l
beginPush :: Int -> LexerAction (Located RlpToken)
beginPush n _ _ = pushLexState n >> lexToken
alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)
alexGetByte inp = case inp ^. aiBytes of
[] -> do
(c,t) <- T.uncons (inp ^. aiSource)
let (b:bs) = encodeChar c
-- tail the source
inp' = inp & aiSource .~ t
-- record the excess bytes for successive calls
& aiBytes .~ bs
-- report the previous char
& aiPrevChar .~ c
-- update the position
& aiPos %~ \ (ln,col,a) ->
if c == '\n'
then (ln+1, 1, a+1)
else (ln, col+1, a+1)
pure (b, inp')
_ -> Just (head bs, inp')
where
(bs, inp') = inp & aiBytes <<%~ drop 1
getInput :: P AlexInput
getInput = use psInput
getLexState :: P Int
getLexState = use (psLexState . singular _head)
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar = view aiPrevChar
pushLexState :: Int -> P ()
pushLexState n = psLexState %= (n:)
readInt :: Text -> Int
readInt = T.foldl f 0 where
f n c = 10*n + digitToInt c
constToken :: RlpToken -> LexerAction (Located RlpToken)
constToken t inp l = do
pos <- use (psInput . aiPos)
pure (Located (spanFromPos pos l) t)
tokenWith :: (Text -> RlpToken) -> LexerAction (Located RlpToken)
tokenWith tf inp l = do
pos <- getPos
let t = tf (T.take l $ inp ^. aiSource)
pure (Located (spanFromPos pos l) t)
getPos :: P Position
getPos = use (psInput . aiPos)
alexEOF :: P (Located RlpToken)
alexEOF = do
inp <- getInput
pos <- getPos
pure (Located (spanFromPos pos 0) TokenEOF)
runP' :: P a -> Text -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
runP' p s = runP p st where
st = initParseState [layout_top,0] s
lexToken :: P (Located RlpToken)
lexToken = do
inp <- getInput
c <- getLexState
st <- use id
-- traceM $ "st: " <> show st
case alexScan inp c of
AlexEOF -> pure $ Located (spanFromPos (inp^.aiPos) 0) TokenEOF
AlexSkip inp' l -> do
psInput .= inp'
lexToken
AlexToken inp' l act -> do
psInput .= inp'
act inp l
AlexError inp' -> addFatalHere 1 RlpParErrLexical
lexCont :: (Located RlpToken -> P a) -> P a
lexCont = (lexToken >>=)
lexStream :: P [RlpToken]
lexStream = do
t <- lexToken
case t of
Located _ TokenEOF -> pure [TokenEOF]
Located _ t -> (t:) <$> lexStream
lexDebug :: (Located RlpToken -> P a) -> P a
lexDebug k = do
t <- lexToken
traceM $ "token: " <> show t
k t
lexTest :: Text -> Maybe [RlpToken]
lexTest s = runP' lexStream s ^. _3
indentLevel :: P Int
indentLevel = do
pos <- use (psInput . aiPos)
pure (pos ^. _2)
insertToken :: RlpToken -> P (Located RlpToken)
insertToken t = do
pos <- use (psInput . aiPos)
pure (Located (spanFromPos pos 0) t)
popLayout :: P Layout
popLayout = do
-- traceM "pop layout"
ctx <- preuse (psLayoutStack . _head)
psLayoutStack %= (drop 1)
case ctx of
Just l -> pure l
Nothing -> error "popLayout: layout stack empty! this is a bug."
pushLayout :: Layout -> P ()
pushLayout l = do
-- traceM "push layout"
psLayoutStack %= (l:)
popLexState :: P ()
popLexState = do
psLexState %= tail
insertSemicolon, insertLBrace, insertRBrace :: P (Located RlpToken)
insertSemicolon = {- traceM "inserting semi" >> -} insertToken TokenSemicolonV
insertLBrace = {- traceM "inserting lbrace" >> -} insertToken TokenLBraceV
insertRBrace = {- traceM "inserting rbrace" >> -} insertToken TokenRBraceV
cmpLayout :: P Ordering
cmpLayout = do
i <- indentLevel
ctx <- preuse (psLayoutStack . _head)
case ctx of
Just (Implicit n) -> pure (i `compare` n)
_ -> pure GT
doBol :: LexerAction (Located RlpToken)
doBol inp l = do
off <- cmpLayout
i <- indentLevel
-- traceM $ "i: " <> show i
-- important that we pop the lex state lest we find our lexer diverging
case off of
-- the line is aligned with the previous. it therefore belongs to the
-- same list
EQ -> popLexState *> insertSemicolon
-- the line is indented further than the previous, so we assume it is a
-- line continuation. ignore it and move on!
GT -> popLexState *> lexToken
-- the line is indented less than the previous, pop the layout stack and
-- insert a closing brace. make VERY good note of the fact that we do not
-- pop the lex state! this means doBol is called until indentation is EQ
-- GT. so if multiple layouts are closed at once, this catches that.
LT -> popLayout >> insertRBrace
thenDo :: LexerAction a -> P b -> LexerAction a
thenDo act p inp l = act inp l <* p
explicitLBrace :: LexerAction (Located RlpToken)
explicitLBrace inp l = do
pushLayout Explicit
constToken TokenLBrace inp l
explicitRBrace :: LexerAction (Located RlpToken)
explicitRBrace inp l = do
popLayout
constToken TokenRBrace inp l
doLayout :: LexerAction (Located RlpToken)
doLayout _ _ = do
i <- indentLevel
-- traceM $ "doLayout: i: " <> show i
pushLayout (Implicit i)
popLexState
insertLBrace
programInitState :: Text -> ParseState
programInitState = initParseState [layout_top,0]
}

312
src/Rlp/Parse.y Normal file
View File

@@ -0,0 +1,312 @@
{
{-# LANGUAGE LambdaCase, ViewPatterns #-}
module Rlp.Parse
( parseRlpProg
, parseRlpProgR
, parseRlpExpr
, parseRlpExprR
)
where
import Compiler.RlpcError
import Compiler.RLPC
import Rlp.Lex
import Rlp.Syntax
import Rlp.Parse.Types
import Rlp.Parse.Associate
import Lens.Micro.Platform
import Data.List.Extra
import Data.Fix
import Data.Functor.Const
import Data.Functor.Apply
import Data.Functor.Bind
import Control.Comonad
import Data.Functor
import Data.Semigroup.Traversable
import Data.Text (Text)
import Data.Text qualified as T
import Data.Void
import Compiler.Types
}
%name parseRlpProg StandaloneProgram
%name parseRlpExpr StandaloneExpr
%monad { P }
%lexer { lexCont } { Located _ TokenEOF }
%error { parseError }
%errorhandlertype explist
%tokentype { Located RlpToken }
%token
varname { Located _ (TokenVarName _) }
conname { Located _ (TokenConName _) }
consym { Located _ (TokenConSym _) }
varsym { Located _ (TokenVarSym _) }
data { Located _ TokenData }
case { Located _ TokenCase }
of { Located _ TokenOf }
litint { Located _ (TokenLitInt _) }
'=' { Located _ TokenEquals }
'|' { Located _ TokenPipe }
'::' { Located _ TokenHasType }
';' { Located _ TokenSemicolon }
'(' { Located _ TokenLParen }
')' { Located _ TokenRParen }
'->' { Located _ TokenArrow }
vsemi { Located _ TokenSemicolonV }
'{' { Located _ TokenLBrace }
'}' { Located _ TokenRBrace }
vlbrace { Located _ TokenLBraceV }
vrbrace { Located _ TokenRBraceV }
infixl { Located _ TokenInfixL }
infixr { Located _ TokenInfixR }
infix { Located _ TokenInfix }
let { Located _ TokenLet }
letrec { Located _ TokenLetrec }
in { Located _ TokenIn }
%nonassoc '='
%right '->'
%right in
%%
StandaloneProgram :: { RlpProgram RlpcPs }
StandaloneProgram : '{' Decls '}' {% mkProgram $2 }
| VL DeclsV VR {% mkProgram $2 }
StandaloneExpr :: { RlpExpr RlpcPs }
: VL Expr VR { extract $2 }
VL :: { () }
VL : vlbrace { () }
VR :: { () }
VR : vrbrace { () }
| error { () }
Decls :: { [Decl' RlpcPs] }
Decls : Decl ';' Decls { $1 : $3 }
| Decl ';' { [$1] }
| Decl { [$1] }
DeclsV :: { [Decl' RlpcPs] }
DeclsV : Decl VS DeclsV { $1 : $3 }
| Decl VS { [$1] }
| Decl { [$1] }
VS :: { Located RlpToken }
VS : ';' { $1 }
| vsemi { $1 }
Decl :: { Decl' RlpcPs }
: FunDecl { $1 }
| TySigDecl { $1 }
| DataDecl { $1 }
| InfixDecl { $1 }
TySigDecl :: { Decl' RlpcPs }
: Var '::' Type { (\e -> TySigD [extract e]) <<~ $1 <~> $3 }
InfixDecl :: { Decl' RlpcPs }
: InfixWord litint InfixOp { $1 =>> \w ->
InfixD (extract $1) (extractInt $ extract $2)
(extract $3) }
InfixWord :: { Located Assoc }
: infixl { $1 \$> InfixL }
| infixr { $1 \$> InfixR }
| infix { $1 \$> Infix }
DataDecl :: { Decl' RlpcPs }
: data Con TyParams '=' DataCons { $1 \$> DataD (extract $2) $3 $5 }
TyParams :: { [PsName] }
: {- epsilon -} { [] }
| TyParams varname { $1 `snoc` (extractName . extract $ $2) }
DataCons :: { [ConAlt RlpcPs] }
: DataCons '|' DataCon { $1 `snoc` $3 }
| DataCon { [$1] }
DataCon :: { ConAlt RlpcPs }
: Con Type1s { ConAlt (extract $1) $2 }
Type1s :: { [RlpType' RlpcPs] }
: {- epsilon -} { [] }
| Type1s Type1 { $1 `snoc` $2 }
Type1 :: { RlpType' RlpcPs }
: '(' Type ')' { $2 }
| conname { fmap ConT (mkPsName $1) }
| varname { fmap VarT (mkPsName $1) }
Type :: { RlpType' RlpcPs }
: Type '->' Type { FunT <<~ $1 <~> $3 }
| TypeApp { $1 }
TypeApp :: { RlpType' RlpcPs }
: Type1 { $1 }
| TypeApp Type1 { AppT <<~ $1 <~> $2 }
FunDecl :: { Decl' RlpcPs }
FunDecl : Var Params '=' Expr { $4 =>> \e ->
FunD (extract $1) $2 e Nothing }
Params :: { [Pat' RlpcPs] }
Params : {- epsilon -} { [] }
| Params Pat1 { $1 `snoc` $2 }
Pat :: { Pat' RlpcPs }
: Con Pat1s { $1 =>> \cn ->
ConP (extract $1) $2 }
| Pat1 { $1 }
Pat1s :: { [Pat' RlpcPs] }
: Pat1s Pat1 { $1 `snoc` $2 }
| Pat1 { [$1] }
Pat1 :: { Pat' RlpcPs }
: Con { fmap (`ConP` []) $1 }
| Var { fmap VarP $1 }
| Lit { LitP <<= $1 }
| '(' Pat ')' { $1 .> $2 <. $3 }
Expr :: { RlpExpr' RlpcPs }
-- infixities delayed till next release :(
-- : Expr1 InfixOp Expr { $2 =>> \o ->
-- OAppE (extract o) $1 $3 }
: TempInfixExpr { $1 }
| LetExpr { $1 }
| CaseExpr { $1 }
| AppExpr { $1 }
TempInfixExpr :: { RlpExpr' RlpcPs }
TempInfixExpr : Expr1 InfixOp TempInfixExpr {% tempInfixExprErr $1 $3 }
| Expr1 InfixOp Expr1 { $2 =>> \o ->
OAppE (extract o) $1 $3 }
AppExpr :: { RlpExpr' RlpcPs }
: Expr1 { $1 }
| AppExpr Expr1 { AppE <<~ $1 <~> $2 }
LetExpr :: { RlpExpr' RlpcPs }
: let layout1(Binding) in Expr { $1 \$> LetE $2 $4 }
| letrec layout1(Binding) in Expr { $1 \$> LetrecE $2 $4 }
CaseExpr :: { RlpExpr' RlpcPs }
: case Expr of layout0(CaseAlt)
{ CaseE <<~ $2 <#> $4 }
-- TODO: where-binds
CaseAlt :: { (Alt RlpcPs, Where RlpcPs) }
: Alt { ($1, []) }
Alt :: { Alt RlpcPs }
: Pat '->' Expr { AltA $1 $3 }
-- layout0(p : β) :: [β]
layout0(p) : '{' layout_list0(';',p) '}' { $2 }
| VL layout_list0(VS,p) VR { $2 }
-- layout_list0(sep : α, p : β) :: [β]
layout_list0(sep,p) : p { [$1] }
| layout_list1(sep,p) sep p { $1 `snoc` $3 }
| {- epsilon -} { [] }
-- layout1(p : β) :: [β]
layout1(p) : '{' layout_list1(';',p) '}' { $2 }
| VL layout_list1(VS,p) VR { $2 }
-- layout_list1(sep : α, p : β) :: [β]
layout_list1(sep,p) : p { [$1] }
| layout_list1(sep,p) sep p { $1 `snoc` $3 }
Binding :: { Binding' RlpcPs }
: Pat '=' Expr { PatB <<~ $1 <~> $3 }
Expr1 :: { RlpExpr' RlpcPs }
: '(' Expr ')' { $1 .> $2 <. $3 }
| Lit { fmap LitE $1 }
| Var { fmap VarE $1 }
| Con { fmap VarE $1 }
InfixOp :: { Located PsName }
: consym { mkPsName $1 }
| varsym { mkPsName $1 }
-- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
Lit :: { Lit' RlpcPs }
: litint { $1 <&> (IntL . (\ (TokenLitInt n) -> n)) }
Var :: { Located PsName }
Var : varname { mkPsName $1 }
| varsym { mkPsName $1 }
Con :: { Located PsName }
: conname { mkPsName $1 }
{
parseRlpExprR :: (Monad m) => Text -> RLPCT m (RlpExpr RlpcPs)
parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st
where
st = programInitState s
parseRlpProgR :: (Monad m) => Text -> RLPCT m (RlpProgram RlpcPs)
parseRlpProgR s = do
a <- liftErrorful $ pToErrorful parseRlpProg st
addDebugMsg @_ @String "dump-parsed" $ show a
pure a
where
st = programInitState s
mkPsName :: Located RlpToken -> Located PsName
mkPsName = fmap extractName
extractName :: RlpToken -> PsName
extractName = \case
TokenVarName n -> n
TokenConName n -> n
TokenConSym n -> n
TokenVarSym n -> n
_ -> error "mkPsName: not an identifier"
extractInt :: RlpToken -> Int
extractInt (TokenLitInt n) = n
extractInt _ = error "extractInt: ugh"
mkProgram :: [Decl' RlpcPs] -> P (RlpProgram RlpcPs)
mkProgram ds = do
pt <- use psOpTable
pure $ RlpProgram (associate pt <$> ds)
parseError :: (Located RlpToken, [String]) -> P a
parseError ((Located ss t), exp) = addFatal $
errorMsg ss (RlpParErrUnexpectedToken t exp)
mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs)
mkInfixD a p n = do
let opl :: Lens' ParseState (Maybe OpInfo)
opl = psOpTable . at n
opl <~ (use opl >>= \case
Just o -> addWoundHere l e >> pure (Just o) where
e = RlpParErrDuplicateInfixD n
l = T.length n
Nothing -> pure (Just (a,p))
)
pos <- use (psInput . aiPos)
pure $ Located (spanFromPos pos 0) (InfixD a p n)
intOfToken :: Located RlpToken -> Int
intOfToken (Located _ (TokenLitInt n)) = n
tempInfixExprErr :: RlpExpr' RlpcPs -> RlpExpr' RlpcPs -> P a
tempInfixExprErr (Located a _) (Located b _) =
addFatal $ errorMsg (a <> b) $ RlpParErrOther
[ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :("
, "In the mean time, don't mix any infix operators."
]
}

37
src/Rlp/Parse/Associate.hs Normal file
View File

@@ -0,0 +1,37 @@
module Rlp.Parse.Associate
{-# WARNING "unimplemented" #-}
( associate
)
where
--------------------------------------------------------------------------------
import Data.HashMap.Strict qualified as H
import Data.Functor.Foldable
import Data.Functor.Foldable.TH
import Data.Functor.Const
import Data.Functor
import Data.Text qualified as T
import Text.Printf
import Lens.Micro
import Rlp.Parse.Types
import Rlp.Syntax
--------------------------------------------------------------------------------
associate :: OpTable -> Decl' RlpcPs -> Decl' RlpcPs
associate _ p = p
{-# WARNING associate "unimplemented" #-}
examplePrecTable :: OpTable
examplePrecTable = H.fromList
[ ("+", (InfixL,6))
, ("*", (InfixL,7))
, ("^", (InfixR,8))
, (".", (InfixR,7))
, ("~", (Infix, 9))
, ("=", (Infix, 4))
, ("&&", (Infix, 3))
, ("||", (Infix, 2))
, ("$", (InfixR,0))
, ("&", (InfixL,0))
]

294
src/Rlp/Parse/Types.hs Normal file
View File

@@ -0,0 +1,294 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
{-# LANGUAGE LambdaCase #-}
module Rlp.Parse.Types
(
-- * Trees That Grow
RlpcPs
-- * Parser monad and state
, P(..), ParseState(..), Layout(..), OpTable, OpInfo
, initParseState, initAlexInput
, pToErrorful
-- ** Lenses
, psLayoutStack, psLexState, psInput, psOpTable
-- * Other parser types
, RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
, Located(..), PsName
-- ** Lenses
, aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
, (<<~), (<~>)
-- * Error handling
, MsgEnvelope(..), RlpcError(..), RlpParseError(..)
, addFatal, addWound, addFatalHere, addWoundHere
)
where
--------------------------------------------------------------------------------
import Core.Syntax (Name)
import Control.Monad
import Control.Monad.State.Strict
import Control.Monad.Errorful
import Control.Comonad (extract)
import Compiler.RlpcError
import Language.Haskell.TH.Syntax (Lift)
import Data.Text (Text)
import Data.Maybe
import Data.Fix
import Data.Functor.Foldable
import Data.Functor.Const
import Data.Functor.Classes
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 Rlp.Syntax
import Compiler.Types
--------------------------------------------------------------------------------
-- | Phantom type identifying rlpc's parser phase
data RlpcPs
type instance XRec RlpcPs a = Located a
type instance IdP RlpcPs = PsName
type instance XFunD RlpcPs = ()
type instance XDataD RlpcPs = ()
type instance XInfixD RlpcPs = ()
type instance XTySigD RlpcPs = ()
type instance XXDeclD RlpcPs = ()
type instance XLetE RlpcPs = ()
type instance XLetrecE RlpcPs = ()
type instance XVarE RlpcPs = ()
type instance XLamE RlpcPs = ()
type instance XCaseE RlpcPs = ()
type instance XIfE RlpcPs = ()
type instance XAppE RlpcPs = ()
type instance XLitE RlpcPs = ()
type instance XParE RlpcPs = ()
type instance XOAppE RlpcPs = ()
type instance XXRlpExprE RlpcPs = ()
type PsName = Text
instance MapXRec RlpcPs where
mapXRec = fmap
instance UnXRec RlpcPs where
unXRec = extract
--------------------------------------------------------------------------------
spanFromPos :: Position -> Int -> SrcSpan
spanFromPos (l,c,a) s = SrcSpan l c a s
{-# INLINE spanFromPos #-}
type LexerAction a = AlexInput -> Int -> P a
data AlexInput = AlexInput
{ _aiPrevChar :: Char
, _aiSource :: Text
, _aiBytes :: [Word8]
, _aiPos :: Position
}
deriving Show
type Position =
( Int -- ^ line
, Int -- ^ column
, Int -- ^ Absolutely
)
posLine :: Lens' Position Int
posLine = _1
posColumn :: Lens' Position Int
posColumn = _2
posAbsolute :: Lens' Position Int
posAbsolute = _3
data RlpToken
-- literals
= TokenLitInt Int
-- identifiers
| TokenVarName Name
| TokenConName Name
| TokenVarSym Name
| TokenConSym Name
-- reserved words
| TokenData
| TokenCase
| TokenOf
| TokenLet
| TokenLetrec
| TokenIn
| TokenInfixL
| TokenInfixR
| TokenInfix
-- reserved ops
| TokenArrow
| TokenPipe
| TokenHasType
| TokenLambda
| TokenEquals
-- control symbols
| TokenSemicolon
| TokenLBrace
| TokenRBrace
| TokenLParen
| TokenRParen
-- 'virtual' control symbols, inserted by the lexer without any correlation
-- to a specific part of the input
| TokenSemicolonV
| TokenLBraceV
| TokenRBraceV
| TokenEOF
deriving (Show)
newtype P a = P {
runP :: ParseState
-> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
}
deriving (Functor)
pToErrorful :: (Applicative m)
=> P a -> ParseState -> ErrorfulT (MsgEnvelope RlpParseError) m a
pToErrorful p st = ErrorfulT $ pure (ma,es) where
(_,es,ma) = runP p st
instance Applicative P where
pure a = P $ \st -> (st, [], pure a)
liftA2 = liftM2
instance Monad P where
p >>= k = P $ \st ->
let (st',es,ma) = runP p st
in case ma of
Just a -> runP (k a) st'
& _2 %~ (es<>)
Nothing -> (st',es,Nothing)
{-# INLINE (>>=) #-}
instance MonadState ParseState P where
state f = P $ \st ->
let (a,st') = f st
in (st', [], Just a)
instance MonadErrorful (MsgEnvelope RlpParseError) P where
addWound e = P $ \st -> (st, [e], Just ())
addFatal e = P $ \st -> (st, [e], Nothing)
data ParseState = ParseState
{ _psLayoutStack :: [Layout]
, _psLexState :: [Int]
, _psInput :: AlexInput
, _psOpTable :: OpTable
}
deriving Show
data Layout = Explicit
| Implicit Int
deriving (Show, Eq)
type OpTable = H.HashMap Name OpInfo
type OpInfo = (Assoc, Int)
data RlpParseError = RlpParErrOutOfBoundsPrecedence Int
| RlpParErrDuplicateInfixD Name
| RlpParErrLexical
| RlpParErrUnexpectedToken RlpToken [String]
| RlpParErrOther [Text]
deriving (Show)
instance IsRlpcError RlpParseError where
liftRlpcError = \case
RlpParErrOutOfBoundsPrecedence n ->
Text [ "Illegal precedence in infixity declaration"
, "rl' currently only allows precedences between 0 and 9."
]
RlpParErrDuplicateInfixD s ->
Text [ "Conflicting infixity declarations for operator "
<> tshow s
]
RlpParErrLexical ->
Text [ "Unknown lexical error :(" ]
RlpParErrUnexpectedToken t exp ->
Text [ "Unexpected token " <> tshow t
, "Expected: " <> tshow exp
]
RlpParErrOther ts ->
Text ts
where
tshow :: (Show a) => a -> T.Text
tshow = T.pack . show
----------------------------------------------------------------------------------
makeLenses ''AlexInput
makeLenses ''ParseState
addWoundHere :: Int -> RlpParseError -> P ()
addWoundHere l e = P $ \st ->
let e' = MsgEnvelope
{ _msgSpan = let pos = psInput . aiPos
in SrcSpan (st ^. pos . posLine)
(st ^. pos . posColumn)
(st ^. pos . posAbsolute)
l
, _msgDiagnostic = e
, _msgSeverity = SevError
}
in (st, [e'], Just ())
addFatalHere :: Int -> RlpParseError -> P a
addFatalHere l e = P $ \st ->
let e' = MsgEnvelope
{ _msgSpan = let pos = psInput . aiPos
in SrcSpan (st ^. pos . posLine)
(st ^. pos . posColumn)
(st ^. pos . posAbsolute)
l
, _msgDiagnostic = e
, _msgSeverity = SevError
}
in (st, [e'], Nothing)
initParseState :: [Int] -> Text -> ParseState
initParseState ls s = ParseState
{ _psLayoutStack = []
-- IMPORTANT: the initial state is `bol` to begin the top-level layout,
-- which then returns to state 0 which continues the normal lexing process.
, _psLexState = ls
, _psInput = initAlexInput s
, _psOpTable = mempty
}
initAlexInput :: Text -> AlexInput
initAlexInput s = AlexInput
{ _aiPrevChar = '\0'
, _aiSource = s
, _aiBytes = []
, _aiPos = (1,1,0)
}
--------------------------------------------------------------------------------
deriving instance Lift (RlpProgram RlpcPs)
deriving instance Lift (Decl RlpcPs)
deriving instance Lift (Pat RlpcPs)
deriving instance Lift (Lit RlpcPs)
deriving instance Lift (RlpExpr RlpcPs)
deriving instance Lift (Binding RlpcPs)
deriving instance Lift (RlpType RlpcPs)
deriving instance Lift (Alt RlpcPs)
deriving instance Lift (ConAlt RlpcPs)

363
src/Rlp/Syntax.hs Normal file
View File

@@ -0,0 +1,363 @@
-- recursion-schemes
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable
, TemplateHaskell, TypeFamilies #-}
{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-}
{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-}
module Rlp.Syntax
(
-- * AST
RlpProgram(..)
, progDecls
, Decl(..), Decl', RlpExpr(..), RlpExpr', RlpExprF(..)
, Pat(..), Pat'
, Alt(..), Where
, Assoc(..)
, Lit(..), Lit'
, RlpType(..), RlpType'
, ConAlt(..)
, Binding(..), Binding'
, _PatB, _FunB
, _VarP, _LitP, _ConP
-- * Trees That Grow boilerplate
-- ** Extension points
, IdP, IdP', XRec, UnXRec(..), MapXRec(..)
-- *** Decl
, XFunD, XTySigD, XInfixD, XDataD, XXDeclD
-- *** RlpExpr
, XLetE, XLetrecE, XVarE, XLamE, XCaseE, XIfE, XAppE, XLitE
, XParE, XOAppE, XXRlpExprE
-- ** Pattern synonyms
-- *** Decl
, pattern FunD, pattern TySigD, pattern InfixD, pattern DataD
, pattern FunD'', pattern TySigD'', pattern InfixD'', pattern DataD''
-- *** RlpExpr
, pattern LetE, pattern LetrecE, pattern VarE, pattern LamE, pattern CaseE
, pattern IfE , pattern AppE, pattern LitE, pattern ParE, pattern OAppE
, pattern XRlpExprE
-- *** RlpType
, pattern FunConT'', pattern FunT'', pattern AppT'', pattern VarT''
, pattern ConT''
-- *** Pat
, pattern VarP'', pattern LitP'', pattern ConP''
-- *** Binding
, pattern PatB''
)
where
----------------------------------------------------------------------------------
import Data.Text (Text)
import Data.Text qualified as T
import Data.String (IsString(..))
import Data.Functor.Foldable
import Data.Functor.Foldable.TH (makeBaseFunctor)
import Data.Functor.Classes
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 Core.Syntax hiding (Lit, Type, Binding, Binding')
import Core (HasRHS(..), HasLHS(..))
----------------------------------------------------------------------------------
data RlpModule p = RlpModule
{ _rlpmodName :: Text
, _rlpmodProgram :: RlpProgram p
}
-- | dear god.
type PhaseShow p =
( Show (XRec p (Pat p)), Show (XRec p (RlpExpr p))
, Show (XRec p (Lit p)), Show (IdP p)
, Show (XRec p (RlpType p))
, Show (XRec p (Binding p))
)
newtype RlpProgram p = RlpProgram [Decl' p]
progDecls :: Lens' (RlpProgram p) [Decl' p]
progDecls = lens
(\ (RlpProgram ds) -> ds)
(const RlpProgram)
deriving instance (PhaseShow p, Show (XRec p (Decl p))) => Show (RlpProgram p)
data RlpType p = FunConT
| FunT (RlpType' p) (RlpType' p)
| AppT (RlpType' p) (RlpType' p)
| VarT (IdP p)
| ConT (IdP p)
type RlpType' p = XRec p (RlpType p)
pattern FunConT'' :: (UnXRec p) => RlpType' p
pattern FunT'' :: (UnXRec p) => RlpType' p -> RlpType' p -> RlpType' p
pattern AppT'' :: (UnXRec p) => RlpType' p -> RlpType' p -> RlpType' p
pattern VarT'' :: (UnXRec p) => IdP p -> RlpType' p
pattern ConT'' :: (UnXRec p) => IdP p -> RlpType' p
pattern FunConT'' <- (unXRec -> FunConT)
pattern FunT'' s t <- (unXRec -> FunT s t)
pattern AppT'' s t <- (unXRec -> AppT s t)
pattern VarT'' n <- (unXRec -> VarT n)
pattern ConT'' n <- (unXRec -> ConT n)
deriving instance (PhaseShow p)
=> Show (RlpType p)
data Decl p = FunD' (XFunD p) (IdP p) [Pat' p] (RlpExpr' p) (Maybe (Where p))
| TySigD' (XTySigD p) [IdP p] (RlpType' p)
| DataD' (XDataD p) (IdP p) [IdP p] [ConAlt p]
| InfixD' (XInfixD p) Assoc Int (IdP p)
| XDeclD' !(XXDeclD p)
deriving instance
( Show (XFunD p), Show (XTySigD p)
, Show (XDataD p), Show (XInfixD p)
, Show (XXDeclD p)
, PhaseShow p
)
=> Show (Decl p)
type family XFunD p
type family XTySigD p
type family XDataD p
type family XInfixD p
type family XXDeclD p
pattern FunD :: (XFunD p ~ ())
=> IdP p -> [Pat' p] -> RlpExpr' p -> Maybe (Where p)
-> Decl p
pattern TySigD :: (XTySigD p ~ ()) => [IdP p] -> RlpType' p -> Decl p
pattern DataD :: (XDataD p ~ ()) => IdP p -> [IdP p] -> [ConAlt p] -> Decl p
pattern InfixD :: (XInfixD p ~ ()) => Assoc -> Int -> IdP p -> Decl p
pattern XDeclD :: (XXDeclD p ~ ()) => Decl p
pattern FunD n as e wh = FunD' () n as e wh
pattern TySigD ns t = TySigD' () ns t
pattern DataD n as cs = DataD' () n as cs
pattern InfixD a p n = InfixD' () a p n
pattern XDeclD = XDeclD' ()
pattern FunD'' :: (UnXRec p)
=> IdP p -> [Pat' p] -> RlpExpr' p -> Maybe (Where p)
-> Decl' p
pattern TySigD'' :: (UnXRec p)
=> [IdP p] -> RlpType' p -> Decl' p
pattern DataD'' :: (UnXRec p)
=> IdP p -> [IdP p] -> [ConAlt p] -> Decl' p
pattern InfixD'' :: (UnXRec p)
=> Assoc -> Int -> IdP p -> Decl' p
pattern FunD'' n as e wh <- (unXRec -> FunD' _ n as e wh)
pattern TySigD'' ns t <- (unXRec -> TySigD' _ ns t)
pattern DataD'' n as ds <- (unXRec -> DataD' _ n as ds)
pattern InfixD'' a p n <- (unXRec -> InfixD' _ a p n)
type Decl' p = XRec p (Decl p)
data Assoc = InfixL
| InfixR
| Infix
deriving (Show, Lift)
data ConAlt p = ConAlt (IdP p) [RlpType' p]
deriving instance (Show (IdP p), Show (XRec p (RlpType p))) => Show (ConAlt p)
data RlpExpr p = LetE' (XLetE p) [Binding' p] (RlpExpr' p)
| LetrecE' (XLetrecE p) [Binding' p] (RlpExpr' p)
| VarE' (XVarE p) (IdP p)
| LamE' (XLamE p) [Pat p] (RlpExpr' p)
| CaseE' (XCaseE p) (RlpExpr' p) [(Alt p, Where p)]
| IfE' (XIfE p) (RlpExpr' p) (RlpExpr' p) (RlpExpr' p)
| AppE' (XAppE p) (RlpExpr' p) (RlpExpr' p)
| LitE' (XLitE p) (Lit p)
| ParE' (XParE p) (RlpExpr' p)
| OAppE' (XOAppE p) (IdP p) (RlpExpr' p) (RlpExpr' p)
| XRlpExprE' !(XXRlpExprE p)
deriving (Generic)
type family XLetE p
type family XLetrecE p
type family XVarE p
type family XLamE p
type family XCaseE p
type family XIfE p
type family XAppE p
type family XLitE p
type family XParE p
type family XOAppE p
type family XXRlpExprE p
pattern LetE :: (XLetE p ~ ()) => [Binding' p] -> RlpExpr' p -> RlpExpr p
pattern LetrecE :: (XLetrecE p ~ ()) => [Binding' p] -> RlpExpr' p -> RlpExpr p
pattern VarE :: (XVarE p ~ ()) => IdP p -> RlpExpr p
pattern LamE :: (XLamE p ~ ()) => [Pat p] -> RlpExpr' p -> RlpExpr p
pattern CaseE :: (XCaseE p ~ ()) => RlpExpr' p -> [(Alt p, Where p)] -> RlpExpr p
pattern IfE :: (XIfE p ~ ()) => RlpExpr' p -> RlpExpr' p -> RlpExpr' p -> RlpExpr p
pattern AppE :: (XAppE p ~ ()) => RlpExpr' p -> RlpExpr' p -> RlpExpr p
pattern LitE :: (XLitE p ~ ()) => Lit p -> RlpExpr p
pattern ParE :: (XParE p ~ ()) => RlpExpr' p -> RlpExpr p
pattern OAppE :: (XOAppE p ~ ()) => IdP p -> RlpExpr' p -> RlpExpr' p -> RlpExpr p
pattern XRlpExprE :: (XXRlpExprE p ~ ()) => RlpExpr p
pattern LetE bs e = LetE' () bs e
pattern LetrecE bs e = LetrecE' () bs e
pattern VarE n = VarE' () n
pattern LamE as e = LamE' () as e
pattern CaseE e as = CaseE' () e as
pattern IfE c a b = IfE' () c a b
pattern AppE f x = AppE' () f x
pattern LitE l = LitE' () l
pattern ParE e = ParE' () e
pattern OAppE n a b = OAppE' () n a b
pattern XRlpExprE = XRlpExprE' ()
deriving instance
( Show (XLetE p), Show (XLetrecE p), Show (XVarE p)
, Show (XLamE p), Show (XCaseE p), Show (XIfE p)
, Show (XAppE p), Show (XLitE p), Show (XParE p)
, Show (XOAppE p), Show (XXRlpExprE p)
, PhaseShow p
) => Show (RlpExpr p)
type RlpExpr' p = XRec p (RlpExpr p)
class UnXRec p where
unXRec :: XRec p a -> a
class WrapXRec p where
wrapXRec :: a -> XRec p a
class MapXRec p where
mapXRec :: (a -> b) -> XRec p a -> XRec p b
-- old definition:
-- type family XRec p (f :: Type -> Type) = (r :: Type) | r -> p f
type family XRec p a = (r :: Type) | r -> p a
type family IdP p
type IdP' p = XRec p (IdP p)
type Where p = [Binding p]
-- do we want guards?
data Alt p = AltA (Pat' p) (RlpExpr' p)
deriving instance (PhaseShow p) => Show (Alt p)
data Binding p = PatB (Pat' p) (RlpExpr' p)
| FunB (IdP p) [Pat' p] (RlpExpr' p)
type Binding' p = XRec p (Binding p)
pattern PatB'' :: (UnXRec p) => Pat' p -> RlpExpr' p -> Binding' p
pattern PatB'' p e <- (unXRec -> PatB p e)
deriving instance (Show (XRec p (Pat p)), Show (XRec p (RlpExpr p)), Show (IdP p)
) => Show (Binding p)
data Pat p = VarP (IdP p)
| LitP (Lit' p)
| ConP (IdP p) [Pat' p]
pattern VarP'' :: (UnXRec p) => IdP p -> Pat' p
pattern LitP'' :: (UnXRec p) => Lit' p -> Pat' p
pattern ConP'' :: (UnXRec p) => IdP p -> [Pat' p] -> Pat' p
pattern VarP'' n <- (unXRec -> VarP n)
pattern LitP'' l <- (unXRec -> LitP l)
pattern ConP'' c as <- (unXRec -> ConP c as)
deriving instance (PhaseShow p) => Show (Pat p)
type Pat' p = XRec p (Pat p)
data Lit p = IntL Int
| CharL Char
| ListL [RlpExpr' p]
deriving instance (PhaseShow p) => Show (Lit p)
type Lit' p = XRec p (Lit p)
-- instance HasLHS Alt Alt Pat Pat where
-- _lhs = lens
-- (\ (AltA p _) -> p)
-- (\ (AltA _ e) p' -> AltA p' e)
-- instance HasRHS Alt Alt RlpExpr RlpExpr where
-- _rhs = lens
-- (\ (AltA _ e) -> e)
-- (\ (AltA p _) e' -> AltA p e')
-- makeBaseFunctor ''RlpExpr
-- showsTernaryWith :: (Int -> x -> ShowS)
-- -> (Int -> y -> ShowS)
-- -> (Int -> z -> ShowS)
-- -> String -> Int
-- -> x -> y -> z
-- -> ShowS
-- showsTernaryWith sa sb sc name p a b c = showParen (p > 10)
-- $ showString name
-- . showChar ' ' . sa 11 a
-- . showChar ' ' . sb 11 b
-- . showChar ' ' . sc 11 c
--------------------------------------------------------------------------------
makeLenses ''RlpModule
makePrisms ''Pat
makePrisms ''Binding
--------------------------------------------------------------------------------
data RlpExprF p a = LetE'F (XLetE p) [Binding' p] a
| LetrecE'F (XLetrecE p) [Binding' p] a
| VarE'F (XVarE p) (IdP p)
| LamE'F (XLamE p) [Pat p] a
| CaseE'F (XCaseE p) a [(Alt p, Where p)]
| IfE'F (XIfE p) a a a
| AppE'F (XAppE p) a a
| LitE'F (XLitE p) (Lit p)
| ParE'F (XParE p) a
| OAppE'F (XOAppE p) (IdP p) a a
| XRlpExprE'F !(XXRlpExprE p)
deriving (Functor, Foldable, Traversable, Generic)
type instance Base (RlpExpr p) = RlpExprF p
instance (UnXRec p) => Recursive (RlpExpr p) where
project = \case
LetE' xx bs e -> LetE'F xx bs (unXRec e)
LetrecE' xx bs e -> LetrecE'F xx bs (unXRec e)
VarE' xx n -> VarE'F xx n
LamE' xx ps e -> LamE'F xx ps (unXRec e)
CaseE' xx e as -> CaseE'F xx (unXRec e) as
IfE' xx a b c -> IfE'F xx (unXRec a) (unXRec b) (unXRec c)
AppE' xx f x -> AppE'F xx (unXRec f) (unXRec x)
LitE' xx l -> LitE'F xx l
ParE' xx e -> ParE'F xx (unXRec e)
OAppE' xx f a b -> OAppE'F xx f (unXRec a) (unXRec b)
XRlpExprE' xx -> XRlpExprE'F xx
instance (WrapXRec p) => Corecursive (RlpExpr p) where
embed = \case
LetE'F xx bs e -> LetE' xx bs (wrapXRec e)
LetrecE'F xx bs e -> LetrecE' xx bs (wrapXRec e)
VarE'F xx n -> VarE' xx n
LamE'F xx ps e -> LamE' xx ps (wrapXRec e)
CaseE'F xx e as -> CaseE' xx (wrapXRec e) as
IfE'F xx a b c -> IfE' xx (wrapXRec a) (wrapXRec b) (wrapXRec c)
AppE'F xx f x -> AppE' xx (wrapXRec f) (wrapXRec x)
LitE'F xx l -> LitE' xx l
ParE'F xx e -> ParE' xx (wrapXRec e)
OAppE'F xx f a b -> OAppE' xx f (wrapXRec a) (wrapXRec b)
XRlpExprE'F xx -> XRlpExprE' xx

36
src/Rlp/TH.hs Normal file
View File

@@ -0,0 +1,36 @@
module Rlp.TH
( rlpProg
, rlpExpr
)
where
--------------------------------------------------------------------------------
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
import Data.Text (Text)
import Data.Text qualified as T
import Control.Monad.IO.Class
import Control.Monad
import Compiler.RLPC
import Rlp.Parse
--------------------------------------------------------------------------------
rlpProg :: QuasiQuoter
rlpProg = mkqq parseRlpProgR
rlpExpr :: QuasiQuoter
rlpExpr = mkqq parseRlpExprR
mkq :: (Lift a) => (Text -> RLPCIO a) -> String -> Q Exp
mkq parse = evalAndParse >=> lift where
evalAndParse = liftIO . evalRLPCIO def . parse . T.pack
mkqq :: (Lift a) => (Text -> RLPCIO a) -> QuasiQuoter
mkqq p = QuasiQuoter
{ quoteExp = mkq p
, quotePat = error "rlp quasiquotes may only be used in expressions"
, quoteType = error "rlp quasiquotes may only be used in expressions"
, quoteDec = error "rlp quasiquotes may only be used in expressions"
}

238
src/Rlp2Core.hs Normal file
View File

@@ -0,0 +1,238 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveTraversable #-}
module Rlp2Core
( desugarRlpProgR
, desugarRlpProg
, desugarRlpExpr
)
where
--------------------------------------------------------------------------------
import Control.Monad
import Control.Monad.Writer.CPS
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)
import Data.Text (Text)
import Data.Text qualified as T
import Data.HashMap.Strict qualified as H
import Data.Monoid (Endo(..))
import Data.Either (partitionEithers)
import Data.Foldable
import Data.Fix
import Data.Maybe (fromJust, fromMaybe)
import Data.Functor.Bind
import Data.Function (on)
import GHC.Stack
import Debug.Trace
import Effectful.State.Static.Local
import Effectful.Labeled
import Effectful
import Text.Show.Deriving
import Core.Syntax as Core
import Compiler.Types
import Data.Pretty (render, pretty)
import Rlp.Syntax as Rlp
import Rlp.Parse.Types (RlpcPs, PsName)
--------------------------------------------------------------------------------
type Tree a = Either Name (Name, Branch a)
-- | Rose tree branch representing "nested" "patterns" in the Core language. That
-- is, a constructor with children that are either a normal binder (Left (Given)
-- name) or an indirection to another pattern (Right (Generated name) (Pattern))
data Branch a = Branch Name [Tree a]
deriving (Show, Functor, Foldable, Traversable)
-- | The actual rose tree.
-- @type Rose = 'Data.Fix.Fix' 'Branch'@
type Rose = Fix Branch
deriveShow1 ''Branch
--------------------------------------------------------------------------------
desugarRlpProgR :: forall m. (Monad m) => RlpProgram RlpcPs -> RLPCT m Program'
desugarRlpProgR p = do
let p' = desugarRlpProg p
addDebugMsg "dump-desugared" $ render (pretty p')
pure p'
desugarRlpProg :: RlpProgram RlpcPs -> Program'
desugarRlpProg = rlpProgToCore
desugarRlpExpr :: RlpExpr RlpcPs -> Expr'
desugarRlpExpr = runPureEff . runNameSupply "anon" . exprToCore
-- the rl' program is desugared by desugaring each declaration as a separate
-- program, and taking the monoidal product of the lot :3
rlpProgToCore :: RlpProgram RlpcPs -> Program'
rlpProgToCore = foldMapOf (progDecls . each) declToCore
declToCore :: Decl' RlpcPs -> Program'
declToCore (TySigD'' ns t) = mempty &
programTypeSigs .~ H.fromList [ (n, typeToCore t) | n <- ns ]
declToCore (DataD'' n as ds) = fold . getZipList $
constructorToCore t' <$> ZipList [0..] <*> ZipList ds
where
-- create the appropriate type from the declared constructor and its
-- arguments
t' = foldl TyApp (TyCon n) (TyVar . dsNameToName <$> as)
-- TODO: where-binds
declToCore fd@(FunD'' n as e _) = mempty & programScDefs .~ [ScDef n' as' e']
where
n' = dsNameToName n
e' = runPureEff . runNameSupply n . exprToCore . unXRec $ e
as' = as <&> \case
(unXRec -> VarP k) -> dsNameToName k
_ -> error "no patargs yet"
type NameSupply = Labeled NameSupplyLabel (State [IdP RlpcPs])
type NameSupplyLabel = "expr-name-supply"
exprToCore :: forall es. (NameSupply :> es) => RlpExpr RlpcPs -> Eff es Expr'
exprToCore (VarE n) = pure $ Var (dsNameToName n)
exprToCore (AppE a b) = (liftA2 App `on` exprToCore . unXRec) a b
exprToCore (OAppE f a b) = (liftA2 mkApp `on` exprToCore . unXRec) a b
where
mkApp s t = (Var f `App` s) `App` t
exprToCore (CaseE (unXRec -> e) as) = do
e' <- exprToCore e
Case e' <$> caseAltToCore `traverse` as
exprToCore (LetE bs e) = letToCore NonRec bs e
exprToCore (LetrecE bs e) = letToCore Rec bs e
exprToCore (LitE l) = litToCore l
letToCore :: forall es. (NameSupply :> es)
=> Rec -> [Rlp.Binding' RlpcPs] -> RlpExpr' RlpcPs -> Eff es Expr'
letToCore r bs e = do
-- TODO: preserve binder order.
(bs',as) <- getParts
let insbs | null bs' = pure
| otherwise = pure . Let r bs'
appKendo (foldMap Kendo (as `snoc` insbs)) <=< exprToCore $ unXRec e
where
-- partition & map the list of binders into:
-- bs' : the let-binds that may be directly translated to Core
-- let-binds (we do exactly that). this is all the binders that
-- are a simple variable rather than a pattern match.
-- and as : the let-binds that may **not** be directly translated to
-- Core let-exprs. they get turned into case alternates.
getParts = traverse f bs <&> partitionEithers
f :: Rlp.Binding' RlpcPs
-> Eff es (Either Core.Binding' (Expr' -> Eff es Expr'))
f (PatB'' (VarP'' n) e) = Left . (n :=) <$> exprToCore (unXRec e)
f (PatB'' p e) = pure $ Right (caseify p e)
litToCore :: (NameSupply :> es) => Rlp.Lit RlpcPs -> Eff es Expr'
litToCore (Rlp.IntL n) = pure . Lit $ Core.IntL n
{-
let C x = y
in e
case y of
C x -> e
-}
caseify :: (NameSupply :> es)
=> Pat' RlpcPs -> RlpExpr' RlpcPs -> Expr' -> Eff es Expr'
caseify p (unXRec -> e) i =
Case <$> exprToCore e <*> ((:[]) <$> alt)
where
alt = conToRose (unXRec p) <&> foldFix (branchToCore i)
-- TODO: where-binds
caseAltToCore :: (HasCallStack, NameSupply :> es)
=> (Alt RlpcPs, Where RlpcPs) -> Eff es Alter'
caseAltToCore (AltA (unXRec -> p) e, wh) = do
e' <- exprToCore . unXRec $ e
conToRose p <&> foldFix (branchToCore e')
altToCore :: (NameSupply :> es)
=> Alt RlpcPs -> Eff es Alter'
altToCore (AltA p e) = altToCore' p e
altToCore' :: (NameSupply :> es)
=> Pat' RlpcPs -> RlpExpr' RlpcPs -> Eff es Alter'
altToCore' (unXRec -> p) (unXRec -> e) = do
e' <- exprToCore e
conToRose p <&> foldFix (branchToCore e')
conToRose :: forall es. (HasCallStack, NameSupply :> es) => Pat RlpcPs -> Eff es Rose
conToRose (ConP cn as) = Fix . Branch cn <$> patToForrest `traverse` as
where
patToForrest :: Pat' RlpcPs -> Eff es (Tree Rose)
patToForrest (VarP'' x) = pure $ Left (dsNameToName x)
patToForrest p@(ConP'' _ _) =
Right <$> liftA2 (,) uniqueName br
where
br = unwrapFix <$> conToRose (unXRec p)
conToRose s = error $ "conToRose: not a ConP!: " <> show s
branchToCore :: Expr' -> Branch Alter' -> Alter'
branchToCore e (Branch cn as) = Alter (AltData cn) myBinds e'
where
-- gather binders for the /current/ pattern, and build an expression
-- matching subpatterns
(e', myBinds) = mapAccumL f e as
f :: Expr' -> Tree Alter' -> (Expr', Name)
f e (Left n) = (e, dsNameToName n)
f e (Right (n,cs)) = (e', dsNameToName n) where
e' = Case (Var $ dsNameToName n) [branchToCore e cs]
runNameSupply :: IdP RlpcPs -> Eff (NameSupply ': es) a -> Eff es a
runNameSupply n = runLabeled @NameSupplyLabel (evalState ns) where
ns = [ "$" <> n <> "_" <> T.pack (show k) | k <- [0..] ]
-- | debug helper
nameSupply :: [IdP RlpcPs]
nameSupply = [ T.pack $ "$x_" <> show n | n <- [0..] ]
uniqueName :: (NameSupply :> es) => Eff es (IdP RlpcPs)
uniqueName = labeled @NameSupplyLabel @(State [IdP RlpcPs]) $
state @[IdP RlpcPs] (fromMaybe err . uncons)
where
err = error "NameSupply ran out of names! This shound never happen.\
\ The caller of runNameSupply is responsible."
constructorToCore :: Type -> Tag -> ConAlt RlpcPs -> Program'
constructorToCore t tag (ConAlt cn as) =
mempty & programTypeSigs . at cn ?~ foldr (:->) t as'
& programDataTags . at cn ?~ (tag, length as)
where
as' = typeToCore <$> as
typeToCore :: RlpType' RlpcPs -> Type
typeToCore FunConT'' = TyFun
typeToCore (FunT'' s t) = typeToCore s :-> typeToCore t
typeToCore (AppT'' s t) = TyApp (typeToCore s) (typeToCore t)
typeToCore (ConT'' n) = TyCon (dsNameToName n)
typeToCore (VarT'' x) = TyVar (dsNameToName x)
-- | Forwards-compatiblity if IdP RlpDs is changed
dsNameToName :: IdP RlpcPs -> Name
dsNameToName = id

6
tst/Arith.hs
View File

@@ -6,6 +6,7 @@ module Arith
) where
----------------------------------------------------------------------------------
import Data.Functor.Classes (eq1)
import Lens.Micro
import Core.Syntax
import GM
import Test.QuickCheck
@@ -40,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
@@ -70,13 +72,13 @@ instance Arbitrary ArithExpr where
-- coreResult = evalCore (toCore e)
toCore :: ArithExpr -> Program'
toCore expr = Program
toCore expr = mempty & programScDefs .~
[ ScDef "id" ["x"] $ Var "x"
, ScDef "main" [] $ go expr
]
where
go :: ArithExpr -> Expr'
go (IntA n) = LitE (IntL n)
go (IntA n) = Lit (IntL n)
go (NegateA e) = "negate#" :$ go e
go (IdA e) = "id" :$ go e
go (a :+ b) = f "+#" a b

62
tst/Core/HindleyMilnerSpec.hs Normal file
View File

@@ -0,0 +1,62 @@
{-# LANGUAGE QuasiQuotes, OverloadedStrings #-}
module Core.HindleyMilnerSpec
( spec
)
where
----------------------------------------------------------------------------------
import Core.Syntax
import Core.TH (coreExpr)
import Core.HindleyMilner
import Control.Monad.Errorful
import Data.Either (isLeft)
import Test.Hspec
----------------------------------------------------------------------------------
-- TODO: more tests. preferrably property-based. lol.
spec :: Spec
spec = do
it "should infer `id 3` :: Int" $
let g = [ ("id", "a" :-> "a") ]
in infer' g [coreExpr|id 3|] `shouldBe` Right TyInt
it "should not infer `id 3` when `id` is specialised to `a -> a`" $
let g = [ ("id", ("a" :-> "a") :-> "a" :-> "a") ]
in infer' g [coreExpr|id 3|] `shouldSatisfy` isLeft
-- TODO: property-based tests for let
it "should infer `let x = 3 in id x` :: Int" $
let g = [ ("id", "a" :-> "a") ]
e = [coreExpr|let {x = 3} in id x|]
in infer' g e `shouldBe` Right TyInt
it "should infer `let x = 3; y = 2 in (+#) x y` :: Int" $
let g = [ ("+#", TyInt :-> TyInt :-> TyInt) ]
e = [coreExpr|let {x=3;y=2} in (+#) x y|]
in infer' g e `shouldBe` Right TyInt
it "should find `3 :: Bool` contradictory" $
let e = [coreExpr|3|]
in check' [] (TyCon "Bool") e `shouldSatisfy` isLeft
it "should infer `fix ((+#) 1)` :: Int" $
let g = [ ("fix", ("a" :-> "a") :-> "a")
, ("+#", TyInt :-> TyInt :-> TyInt) ]
e = [coreExpr|fix ((+#) 1)|]
in infer' g e `shouldBe` Right TyInt
it "should infer mutually recursively defined lists" $
let g = [ ("cons", TyInt :-> TyCon "IntList" :-> TyCon "IntList") ]
e :: Expr'
e = [coreExpr|letrec { as = cons 1 bs; bs = cons 2 as } in as|]
in infer' g e `shouldBe` Right (TyCon "IntList")
infer' :: Context' -> Expr' -> Either [TypeError] Type
infer' g e = case runErrorful $ infer g e of
(Just t, _) -> Right t
(Nothing, es) -> Left es
check' :: Context' -> Type -> Expr' -> Either [TypeError] ()
check' g t e = case runErrorful $ check g t e of
(Just t, _) -> Right ()
(Nothing, es) -> Left es

15
tst/GMSpec.hs
View File

@@ -27,15 +27,22 @@ spec = do
in coreRes `shouldBe` arithRes
describe "test programs" $ do
it "fac 3" $ do
it "fac 3" $
resultOf Ex.fac3 `shouldBe` Just (NNum 6)
it "sum [1,2,3]" $ do
it "sum [1,2,3]" $
resultOf Ex.sumList `shouldBe` Just (NNum 6)
it "k 3 ((/#) 1 0)" $ do
it "k 3 ((/#) 1 0)" $
resultOf Ex.constDivZero `shouldBe` Just (NNum 3)
it "id (case ... of { ... })" $ do
it "id (case ... of { ... })" $
resultOf Ex.idCase `shouldBe` Just (NNum 5)
it "bool pattern matching with named constructors" $
resultOf Ex.namedBoolCase `shouldBe` Just (NNum 123)
it "list pattern matching with named constructors" $
resultOf Ex.namedConsCase `shouldBe` Just (NNum 6)