rlp2core

.ghci

@@ -1,9 +1,5 @@
--- repl extensions
 :set -XOverloadedStrings
 
---------------------------------------------------------------------------------
-
--- happy/alex: override :r to rebuild parsers
 :set -package process
 
 :{
@@ -20,5 +16,3 @@ _reload_and_make _ = do
 
 :def! r _reload_and_make
 
---------------------------------------------------------------------------------
-

CHANGELOG.md

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

Makefile_happysrcs

@@ -1,5 +1,5 @@
 HAPPY = happy
-HAPPY_OPTS = -a -g -c -i/tmp/t.info
+HAPPY_OPTS = -a -g -c
 ALEX = alex
 ALEX_OPTS = -g
 
@@ -8,8 +8,8 @@ CABAL_BUILD = dist-newstyle/build/x86_64-osx/ghc-9.6.2/rlp-0.1.0.0/build
 
 all: parsers lexers
 
-parsers: $(CABAL_BUILD)/Rlp/Parse.hs $(CABAL_BUILD)/Core/Parse.hs
+parsers: $(CABAL_BUILD)/Rlp/Parse.hs
-lexers: $(CABAL_BUILD)/Rlp/Lex.hs $(CABAL_BUILD)/Core/Lex.hs
+lexers: $(CABAL_BUILD)/Rlp/Lex.hs
 
 $(CABAL_BUILD)/Rlp/Parse.hs: $(SRC)/Rlp/Parse.y
 	$(HAPPY) $(HAPPY_OPTS) $< -o $@
@@ -17,9 +17,3 @@ $(CABAL_BUILD)/Rlp/Parse.hs: $(SRC)/Rlp/Parse.y
 $(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 $@
-

README.md

@@ -3,10 +3,6 @@
 `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/)
@@ -22,57 +18,30 @@ $ cabal test --test-show-details=direct
 ```
 
 ### Use
-
-#### TLDR
-
 ```sh
-# Compile and evaluate examples/rlp/QuickSort.rl
+# Compile and evaluate examples/factorial.hs, with evaluation info dumped to stderr
-$ rlpc examples/QuickSort.rl
+$ rlpc -ddump-eval examples/factorial.hs
-# Compile and evaluate t.cr, with evaluation info dumped to t.log
+# Compile and evaluate t.hs, with evaluation info dumped to t.log
-$ rlpc -ddump-eval -l t.log t.cr
+$ rlpc -ddump-eval -l t.log t.hs
-# Compile and evaluate t.rl, dumping the desugared Core
+# Print the raw structure describing the compiler options and die
-$ rlpc -ddump-desugared t.rl
+# (option parsing still must succeed in order to print)
-# Compile and evaluate t.rl with all compiler messages enabled
+$ rlpc -ddump-opts t.hs
-$ 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.
-- [x] ADTs
+- [ ] ADTs
-- [x] First-class functions
+- [ ] First-class functions
-- [x] Higher-kinded types
+- [ ] Higher-kinded types
 - [ ] Typeclasses
-- [x] Parametric polymorphism
+- [ ] Parametric polymorphism
-- [x] Hindley-Milner type inference
+- [ ] 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
@@ -88,78 +57,41 @@ parsing remains.
         - [x] Garbage Collection
     - [ ] Emitter
         - [ ] Code-gen (target yet to be decided)
-    - [x] Core linter (Type-checker)
+        - [ ] Core language emitter
-    - [ ] Core2Core pass (optimisations and misc. preprocessing)
+    - [ ] Core linter (Type-checker)
+    - [ ] Core2Core pass
         - [x] GM prep
             - [x] Non-strict case-floating
         - [ ] Let-floating
         - [ ] TCO
         - [ ] DCE
 - [ ] Frontend
-    - [x] High-level language
+    - [ ] High-level language
-        - [x] AST
+        - [ ] AST
-        - [x] Lexer
+        - [ ] Lexer
-        - [x] Parser
+        - [ ] Parser
-    - [x] Translation to the core language
+    - [ ] Translation to the core language
         - [ ] Constraint solver
         - [ ] `do`-notation
     - [x] CLI
 - [ ] Documentation
-    - [x] State transition rules
+    - [ ] State transition rules
     - [ ] How does the evaluation model work?
-    - [ ] The Hindley-Milner type system
     - [ ] CLI usage
     - [ ] Tail call optimisation
-    - [ ] Parsing rlp
+    - [x] Parsing rlp
-    - [ ] Trees That Grow
 - [ ] Tests
     - [x] Generic example programs
     - [ ] Parser
 
-### ~~December Release Plan~~
+### December Release Plan
-- [x] Tests
+- [ ] Tests
     - [ ] Core lexer
     - [ ] Core parser
-    - [x] Evaluation model
+    - [ ] Evaluation model
 - [ ] Benchmarks
-- [x] Stable Core lexer
+- [ ] Stable Core lexer
-- [x] Stable Core parser
+- [ ] Stable Core parser
-- [x] Stable evaluation model
+- [ ] Stable evaluation model
-    - [x] Garbage Collection
+    - [ ] 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
-

app/CoreDriver.hs

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

app/Main.hs

@@ -1,9 +1,7 @@
 {-# 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
@@ -12,17 +10,12 @@ import Data.HashSet             qualified as S
 import Data.Text                (Text)
 import Data.Text                qualified as T
 import Data.Text.IO             qualified as TIO
-import Data.List
-import Data.Maybe               (listToMaybe)
 import System.IO
 import System.Exit              (exitSuccess)
 import Core
 import TI
 import GM
-import Control.Lens.Combinators hiding (argument)
+import Lens.Micro.Mtl
-
-import CoreDriver               qualified
-import RlpDriver                qualified
 ----------------------------------------------------------------------------------
 
 optParser :: ParserInfo RLPCOptions
@@ -44,15 +37,9 @@ options = RLPCOptions
     {- -d -}
     <*> fmap S.fromList # many # option debugFlagReader
         (  short 'd'
-        <> help "pass debug flags"
+        <> help "dump evaluation logs"
         <> 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"
@@ -68,73 +55,96 @@ 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
-    "ti"  -> Just EvaluatorTI
+    "tim" -> 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
-    void $ evalRLPCIO opts dispatch
+    (_, es) <- evalRLPCIO opts driver
+    forM_ es $ \ (CompilerError e) -> print $ "warning: " <> e
+    pure ()
 
-dispatch :: RLPCIO ()
+driver :: RLPCIO CompilerError ()
-dispatch = getLang >>= \case
+driver = sequence_
-    Just LanguageCore -> CoreDriver.driver
+    [ dshowFlags
-    Just LanguageRlp  -> RlpDriver.driver
+    , ddumpAST
-    Nothing           -> addFatal err
+    , ddumpEval
-        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
 
-driver :: RLPCIO ()
+ddumpAST :: RLPCIO CompilerError ()
-driver = undefined
+ddumpAST = whenFlag flagDDumpAST $ forFiles_ \o f -> do
+    liftIO $ withFile f ReadMode $ \h -> do
+        s <- TIO.hGetContents h
+        case parseProg o s of
+            Right (a,_) -> hPutStrLn stderr $ show a
+            Left e -> error "todo errors lol"
 
-inferLanguage :: FilePath -> Maybe Language
+ddumpEval :: RLPCIO CompilerError ()
-inferLanguage fp
+ddumpEval = whenFlag flagDDumpEval do
-    | ".rl" `isSuffixOf` fp     = Just LanguageRlp
+    fs <- view rlpcInputFiles
-    | ".cr" `isSuffixOf` fp     = Just LanguageCore
+    forM_ fs $ \f -> liftIO (TIO.readFile f) >>= doProg
-    | otherwise                 = Nothing
+
+    where
+        doProg :: Text -> 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
+          -> Text
+          -> 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)
 

app/RlpDriver.hs

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

doc/src/commentary/gm.rst

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

doc/src/commentary/layout-lexing.rst

@@ -2,21 +2,16 @@ Lexing, Parsing, and Layouts
 ============================
 
 The C-style languages of my previous experiences have all had quite trivial
-lexical analysis stages: you ignore all whitespace and point out the symbols you
+lexical analysis stages, peaking in complexity when I streamed tokens lazily in
-recognise. If you don't recognise something, check if it's a literal or an
+C. The task of tokenising a C-style language is very simple in description: you
-identifier. Should it be neither, return an error.
+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.
 
-In contrast, both lexing and parsing a Haskell-like language poses a number of
+On paper, both lexing and parsing a Haskell-like language seem to pose a few
 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
@@ -24,9 +19,17 @@ 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's layout system is based on
+  similar to Python's INDENT/DEDENT tokens, Haskell seemed to use whitespace to
-  alignment and is very generous with line-folding.
+  section code in a way that *felt* different.
 
 .. _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
@@ -42,9 +45,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 encounters a new line, the
+Internally during tokenisation, when the Python lexer begins a new line, they
-indentation of the new line is compared with that of the previous and the
+compare the indentation of the new line with that of the previous and apply the
-following rules are applied:
+following rules:
 
 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
@@ -57,10 +60,170 @@ following rules are applied:
 3. If the indentation is equal, insert a NEWLINE token to terminate the previous
    line, and leave it at that!
 
-On the parser's end, the INDENT, DEDENT, and NEWLINE tokens are identical to
+Parsing Python with the INDENT, DEDENT, and NEWLINE tokens is identical to
-braces and semicolons. In developing our *layout* rules, we will follow in the
+parsing a language with braces and semicolons. This is a solution pretty in line
-pattern of translating the whitespace-sensitive source language to an explicitly
+with Python's philosophy of the "one correct answer" (TODO: this needs a
-sectioned language.
+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.
 
 References
 ----------
@@ -70,4 +233,3 @@ References
 
 * `Haskell syntax reference
   <https://www.haskell.org/onlinereport/haskell2010/haskellch10.html>`_
-

doc/src/commentary/type-inference.rst

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

doc/src/references/rlp-inference-rules.rst

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

examples/Core/constDivZero.cr

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

examples/Core/sumList.cr

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

examples/constDivZero.hs

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

examples/factorial.hs

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

examples/rlp/QuickSort.rl

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

examples/rlp/SumList.rl

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

examples/sumList.hs

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

programming-language-checklist

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

rlp.cabal

@@ -7,7 +7,7 @@ license:            GPL-2.0-only
 -- license-file:       LICENSE
 author:             crumbtoo
 maintainer:         crumb@disroot.org
-copyright:          Madeleine Sydney Ślaga
+-- copyright:
 category:           Language
 build-type:         Simple
 extra-doc-files:    README.md
@@ -38,8 +38,8 @@ library
                     , Rlp.Lex
                     , Rlp.Parse.Types
                     , Rlp.TH
-                    , Compiler.Types
+
-                    , Data.Heap
+    other-modules:    Data.Heap
                     , Data.Pretty
                     , Core.Parse
                     , Core.Lex
@@ -50,56 +50,44 @@ library
     build-tool-depends: happy:happy, alex:alex
 
     -- other-extensions:
-    build-depends:    base >=4.17 && <4.21
+    build-depends:    base ^>=4.18.0.0
                     -- required for happy
                     , array >= 0.5.5 && < 0.6
                     , containers >= 0.6.7 && < 0.7
-                    , template-haskell >= 2.20.0 && < 2.23
+                    , template-haskell >= 2.20.0 && < 2.21
                     , pretty >= 1.1.3 && < 1.2
                     , data-default >= 0.7.1 && < 0.8
                     , data-default-class >= 0.1.2 && < 0.2
                     , hashable >= 1.4.3 && < 1.5
                     , mtl >= 2.3.1 && < 2.4
-                    , text >= 2.0.2 && < 2.3
+                    , text >= 2.0.2 && < 2.1
+                    , 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
+                    , extra >= 1.7.0 && < 2
-                    , semigroupoids >=6.0 && <6.1
-                    , comonad >=5.0.0 && <6
-                    , lens >=5.2.3 && <6.0
-                    , text-ansi >=0.2.0 && <0.4
-                    , effectful-core ^>=2.3.0.0
-                    , deriving-compat ^>=0.6.0
-                    , these >=0.2 && <2.0
 
     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:    RlpDriver
+    -- other-modules:
-                    , CoreDriver
+    -- other-extensions:
-
+    build-depends: base ^>=4.18.0.0
-    build-depends: base >=4.17.0.0 && <4.20.0.0
                  , rlp
                  , optparse-applicative >= 0.18.1 && < 0.19
+                 , microlens >= 0.4.13 && < 0.5
+                 , microlens-mtl >= 0.2.0 && < 0.3
                  , mtl >= 2.3.1 && < 2.4
                  , unordered-containers >= 0.2.20 && < 0.3
-                 , lens >=5.2.3 && <6.0
+                 , text >= 2.0.2 && < 2.1
-                 , text >= 2.0.2 && < 2.3
 
     hs-source-dirs:   app
     default-language: GHC2021

rlpc.drawio

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

src/Compiler/JustRun.hs

@@ -8,10 +8,9 @@ that use Prelude types such as @Either@ and @String@ rather than more complex
 types such as @RLPC@ or @Text@.
 -}
 module Compiler.JustRun
-    ( justLexCore
+    ( justLexSrc
-    , justParseCore
+    , justParseSrc
-    , justTypeCheckCore
+    , justTypeCheckSrc
-    , justHdbg
     )
     where
 ----------------------------------------------------------------------------------
@@ -21,39 +20,27 @@ import Core.HindleyMilner
 import Core.Syntax                      (Program')
 import Compiler.RLPC
 import Control.Arrow                    ((>>>))
-import Control.Monad                    ((>=>), void)
+import Control.Monad                    ((>=>))
-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
+justLexSrc :: String -> Either RlpcError [CoreToken]
-justHdbg s = do
+justLexSrc s = lexCoreR (T.pack s)
-    p <- evalRLPCIO def (parseRlpProgR >=> desugarRlpProgR $ T.pack s)
+             & fmap (map $ \ (Located _ _ _ t) -> t)
-    withFile "/tmp/t.log" WriteMode $ hdbgProg p
+             & rlpcToEither
 
-justLexCore :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
+justParseSrc :: String -> Either RlpcError Program'
-justLexCore s = lexCoreR (T.pack s)
+justParseSrc s = parse (T.pack s)
-              & mapped . each %~ extract
+               & rlpcToEither
-              & rlpcToEither
-
-justParseCore :: String -> Either [MsgEnvelope RlpcError] Program'
-justParseCore s = parse (T.pack s)
-                & rlpcToEither
     where parse = lexCoreR >=> parseCoreProgR
 
-justTypeCheckCore :: String -> Either [MsgEnvelope RlpcError] Program'
+justTypeCheckSrc :: String -> Either RlpcError Program'
-justTypeCheckCore s = typechk (T.pack s)
+justTypeCheckSrc s = typechk (T.pack s)
-                    & rlpcToEither
+                   & rlpcToEither
     where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR
 
-rlpcToEither :: RLPC a -> Either [MsgEnvelope RlpcError] a
+rlpcToEither :: RLPC e a -> Either e a
-rlpcToEither r = case evalRLPC def r of
+rlpcToEither = evalRLPC def >>> fmap fst
-    (Just a,   _) -> Right a
-    (Nothing, es) -> Left es
 

src/Compiler/RLPC.hs

@@ -10,116 +10,102 @@ errors and the family of RLPC monads.
 {-# LANGUAGE TemplateHaskell #-}
 -- only used for mtl instances
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE BlockArguments, ViewPatterns #-}
+{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia #-}
 module Compiler.RLPC
-    (
+    ( RLPC
-    -- * Rlpc Monad transformer
+    , RLPCT(..)
-      RLPCT(RLPCT),
+    , RLPCIO
-    -- ** Special cases
+    , RLPCOptions(RLPCOptions)
-      RLPC, RLPCIO
+    , RlpcError(..)
-    , liftIO
+    , IsRlpcError(..)
-    -- ** Running
+    , rlpc
-    , runRLPCT
+    , addFatal
-    , evalRLPCT, evalRLPCIO, evalRLPC
+    , addWound
-    -- * Rlpc options
+    , MonadErrorful
-    , Language(..), Evaluator(..)
+    , Severity(..)
-    , DebugFlag(..), CompilerFlag(..)
+    , Evaluator(..)
-    -- ** Lenses
+    , evalRLPCT
-    , rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage
+    , evalRLPCIO
-    -- * Misc. MTL-style functions
+    , evalRLPC
-    , liftErrorful, hoistRlpcT
+    , addRlpcWound
-    -- * Misc. Rlpc Monad -related types
+    , addRlpcFatal
-    , RLPCOptions(RLPCOptions), IsRlpcError(..), RlpcError(..)
+    , liftRlpcErrs
-    , MsgEnvelope(..), Severity(..)
+    , rlpcLogFile
-    , addDebugMsg
+    , rlpcDebugOpts
-    , whenDFlag, whenFFlag
+    , rlpcEvaluator
-    -- * Misc. Utilities
+    , rlpcInputFiles
-    , forFiles_, withSource
+    , DebugFlag(..)
-    -- * Convenient re-exports
+    , whenFlag
-    , addFatal, addWound, def
+    , flagDDumpEval
+    , flagDDumpOpts
+    , flagDDumpAST
+    , 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 Data.Text                (Text)
+import Lens.Micro
-import Data.Text                qualified as T
+import Lens.Micro.TH
-import Data.Text.IO             qualified as T
-import System.IO
-import Text.ANSI                qualified as Ansi
-import Text.PrettyPrint         hiding ((<>))
-import Control.Lens
-import Data.Text.Lens           (packed, unpacked, IsText)
-import System.Exit
 ----------------------------------------------------------------------------------
 
-newtype RLPCT m a = RLPCT {
+-- TODO: fancy errors
-        runRLPCT :: ReaderT RLPCOptions (ErrorfulT (MsgEnvelope RlpcError) m) a
+newtype RLPCT e m a = RLPCT {
+        runRLPCT :: ReaderT RLPCOptions (ErrorfulT e m) a
     }
-    deriving ( Functor, Applicative, Monad
+    -- TODO: incorrect ussage of MonadReader. RLPC should have its own
-             , MonadReader RLPCOptions, MonadErrorful (MsgEnvelope RlpcError))
+    -- environment access functions
+    deriving (Functor, Applicative, Monad, MonadReader RLPCOptions)
 
-rlpc :: (IsRlpcError e, Monad m)
+deriving instance (MonadIO m) => MonadIO (RLPCT e m)
-     => (RLPCOptions -> (Maybe a, [MsgEnvelope e]))
-     -> RLPCT m a
-rlpc f = RLPCT . ReaderT $ \opt ->
-    ErrorfulT . pure $ f opt & _2 . each . mapped %~ liftRlpcError
 
-type RLPC = RLPCT Identity
+instance MonadTrans (RLPCT e) where
-
-type RLPCIO = RLPCT IO
-
-instance MonadTrans RLPCT where
     lift = RLPCT . lift . lift
 
-instance (MonadIO m) => MonadIO (RLPCT m) where
+instance (MonadState s m) => MonadState s (RLPCT e m) where
-    liftIO = lift . liftIO
+    state = lift . state
 
-evalRLPC :: RLPCOptions
+type RLPC e = RLPCT e Identity
-         -> RLPC a
+
-         -> (Maybe a, [MsgEnvelope RlpcError])
+type RLPCIO e = RLPCT e IO
-evalRLPC opt r = runRLPCT r
-               & flip runReaderT opt
-               & runErrorful
 
 evalRLPCT :: RLPCOptions
-          -> RLPCT m a
+          -> RLPCT e m a
-          -> m (Maybe a, [MsgEnvelope RlpcError])
+          -> m (Either e (a, [e]))
-evalRLPCT opt r = runRLPCT r
+evalRLPCT o = runRLPCT >>> flip runReaderT o >>> runErrorfulT
-                & flip runReaderT opt
-                & runErrorfulT
 
-liftErrorful :: (Monad m, IsRlpcError e) => ErrorfulT (MsgEnvelope e) m a -> RLPCT m a
+evalRLPC :: RLPCOptions
-liftErrorful e = RLPCT $ lift (fmap liftRlpcError `mapErrorful` e)
+         -> RLPC e a
+         -> Either e (a, [e])
+evalRLPC o m = coerce $ evalRLPCT o m
 
-hoistRlpcT :: (forall a. m a -> n a)
+evalRLPCIO :: (Exception e)
-         -> RLPCT m a -> RLPCT n a
+           => RLPCOptions
-hoistRlpcT f rma = RLPCT $ ReaderT $ \opt ->
+           -> RLPCIO e a
-    ErrorfulT $ f $ evalRLPCT opt rma
+           -> IO (a, [e])
+evalRLPCIO o m = do
+    m' <- evalRLPCT o m
+    case m' of
+        -- TODO: errors
+        Left e -> throwIO e
+        Right a -> pure a
 
 data RLPCOptions = RLPCOptions
     { _rlpcLogFile     :: Maybe FilePath
-    , _rlpcDFlags      :: HashSet DebugFlag
+    , _rlpcDebugOpts   :: DebugOpts
-    , _rlpcFFlags      :: HashSet CompilerFlag
     , _rlpcEvaluator   :: Evaluator
     , _rlpcHeapTrigger :: Int
-    , _rlpcLanguage    :: Maybe Language
     , _rlpcInputFiles  :: [FilePath]
     }
     deriving Show
@@ -127,126 +113,69 @@ data RLPCOptions = RLPCOptions
 data Evaluator = EvaluatorGM | EvaluatorTI
     deriving Show
 
-data Language = LanguageRlp | LanguageCore
+data Severity = Error
-    deriving Show
+              | Warning
+              | Debug
+              deriving Show
+
+-- temporary until we have a new doc building system
+type ErrorDoc = String
+
+instance (Monad m) => MonadErrorful e (RLPCT e m) where
+    addWound = RLPCT . lift . addWound
+    addFatal = RLPCT . lift . addFatal
+
+liftRlpcErrs :: (IsRlpcError e, Monad m)
+             => RLPCT e m a -> RLPCT RlpcError m a
+liftRlpcErrs m = RLPCT . ReaderT $ \r ->
+    mapErrors liftRlpcErr $ runRLPCT >>> (`runReaderT` r) $ m
+
+addRlpcWound :: (IsRlpcError e, Monad m) => e -> RLPCT RlpcError m ()
+addRlpcWound = addWound . liftRlpcErr
+
+addRlpcFatal :: (IsRlpcError e, Monad m) => e -> RLPCT RlpcError m ()
+addRlpcFatal = addWound . liftRlpcErr
+
+rlpc :: (Monad m) => ErrorfulT e m a -> RLPCT e m a
+rlpc = RLPCT . ReaderT . const
 
 ----------------------------------------------------------------------------------
 
 instance Default RLPCOptions where
     def = RLPCOptions
         { _rlpcLogFile = Nothing
-        , _rlpcDFlags = mempty
+        , _rlpcDebugOpts = mempty
-        , _rlpcFFlags = mempty
         , _rlpcEvaluator = EvaluatorGM
         , _rlpcHeapTrigger = 200
         , _rlpcInputFiles = []
-        , _rlpcLanguage = Nothing
         }
 
--- debug flags are passed with -dFLAG
+type DebugOpts = HashSet DebugFlag
-type DebugFlag = Text
 
-type CompilerFlag = Text
+data DebugFlag = DDumpEval
+               | DDumpOpts
+               | DDumpAST
+               deriving (Show, Eq, Generic)
+
+instance Hashable DebugFlag
 
 makeLenses ''RLPCOptions
 pure []
 
-addDebugMsg :: (Monad m, IsText e) => Text -> e -> RLPCT m ()
+whenFlag :: (MonadReader s m) => SimpleGetter s Bool -> m () -> m ()
-addDebugMsg tag e = addWound . debugMsg tag $ Text [e ^. unpacked . packed]
+whenFlag l m = asks (^. l) >>= \a -> if a then m else pure ()
 
--- TODO: rewrite this with prisms once microlens-pro drops :3
+-- there's probably a better way to write this. my current knowledge of lenses
-whenDFlag :: (Monad m) => DebugFlag -> RLPCT m () -> RLPCT m ()
+-- is too weak.
-whenDFlag f m = do
+flagGetter :: DebugFlag -> SimpleGetter RLPCOptions Bool
-    -- mfw no `At` instance for HashSet
+flagGetter d = to $ \s -> s ^. rlpcDebugOpts & S.member d
-    fs <- view rlpcDFlags
-    let a = S.member f fs
-    when a m
 
-whenFFlag :: (Monad m) => CompilerFlag -> RLPCT m () -> RLPCT m ()
+flagDDumpEval :: SimpleGetter RLPCOptions Bool
-whenFFlag f m = do
+flagDDumpEval = flagGetter DDumpEval
-    -- 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
 
-evalRLPCIO :: RLPCOptions -> RLPCIO a -> IO a
+flagDDumpAST :: SimpleGetter RLPCOptions Bool
-evalRLPCIO opt r = do
+flagDDumpAST = flagGetter DDumpAST
-    (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
 

src/Compiler/RlpcError.hs

@@ -1,76 +1,15 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
 module Compiler.RlpcError
-    ( IsRlpcError(..)
+    ( RlpcError(..)
-    , MsgEnvelope(..)
+    , IsRlpcError(..)
-    , 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 Control.Lens
-import Compiler.Types
 ----------------------------------------------------------------------------------
 
-data MsgEnvelope e = MsgEnvelope
+data RlpcError = RlpcErr String -- temp
-   { _msgSpan        :: SrcSpan
+    deriving Show
-   , _msgDiagnostic  :: e
-   , _msgSeverity    :: Severity
-   }
-   deriving (Functor, Show)
 
-newtype RlpcError = Text [Text]
+class IsRlpcError a where
-               deriving Show
+    liftRlpcErr :: a -> RlpcError
-
-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
-    }
 

src/Compiler/Types.hs

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

src/Control/Monad/Errorful.hs

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

src/Control/Monad/Utils.hs

@@ -1,15 +1,10 @@
 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@
@@ -24,14 +19,3 @@ mapAccumLM k s t = swap <$> runStateT (traverse k' t) s
         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
-

src/Core/Examples.hs

@@ -4,19 +4,17 @@ Description : Core examples (may eventually be unit tests)
 -}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE OverloadedStrings #-}
-module Core.Examples where
+module Core.Examples
+    ( fac3
+    , sumList
+    , constDivZero
+    , idCase
+    ) where
 ----------------------------------------------------------------------------------
 import Core.Syntax
 import Core.TH
 ----------------------------------------------------------------------------------
 
--- fac3 = undefined
--- sumList = undefined
--- constDivZero = undefined
--- idCase = undefined
-
----
-
 letrecExample :: Program'
 letrecExample = [coreProg|
     pair x y f = f x y;
@@ -76,12 +74,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 +94,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 +140,21 @@ simple1 = [coreProg|
 caseBool1 :: Program'
 caseBool1 = [coreProg|
     _if c x y = case c of
-        { <1> -> x
+        { 1 -> x
-        ; <0> -> y
+        ; 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
+    fac n = case (==#) n 0 of
-        { <1> -> 1
+        { 1 -> 1
-        ; <0> -> *# n (fac (-# n 1))
+        ; 0 -> (*#) n (fac ((-#) n 1))
         };
 
     main = fac 3;
@@ -170,8 +168,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
+            { 0      -> 0
-            ; <1> x xs -> +# x (sum xs)
+            ; 1 x xs -> (+#) x (sum xs)
             };
         main = sum list;
     |]
@@ -179,7 +177,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 +185,10 @@ idCase = [coreProg|
         id x = x;
 
         main = id (case Pack{1 0} of
-            { <1> -> +# 2 3
+            { 1 -> (+#) 2 3
             })
     |]
 
--- 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
-            }
-    |]
-
-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
@@ -242,5 +216,3 @@ namedConsCase = [coreProg|
 --         , ScDef "Cons" [] $ Con 2 2
 --         ]
 
---}
-

src/Core/HindleyMilner.hs

@@ -3,35 +3,28 @@ 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 Control.Lens             hiding (Context', Context)
+import Lens.Micro
+import Lens.Micro.Mtl
 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 Control.Monad            (foldM, void)
-import Compiler.RlpcError
+import Control.Monad.Errorful   (Errorful, addFatal)
-import Control.Monad            (foldM, void, forM)
-import Control.Monad.Errorful
 import Control.Monad.State
-import Control.Monad.Utils      (mapAccumLM, generalise)
+import Control.Monad.Utils      (mapAccumLM)
-import Text.Printf
 import Core.Syntax
 ----------------------------------------------------------------------------------
 
@@ -42,6 +35,8 @@ type Context b = [(b, Type)]
 -- | Unannotated typing context, AKA our beloved Γ.
 type Context' = Context Name
 
+-- TODO: Errorful monad?
+
 -- | Type error enum.
 data TypeError
     -- | Two types could not be unified
@@ -53,27 +48,17 @@ data TypeError
     | TyErrMissingTypeSig Name
     deriving (Show, Eq)
 
+-- TODO:
 instance IsRlpcError TypeError where
-    liftRlpcError = \case
+    liftRlpcErr = RlpcErr . show
-        -- 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
 
+-- TODO: better errors. Errorful-esque, with cummulative errors instead of
+-- instantly dying.
+
 -- | Assert that an expression unifies with a given type
 --
 -- >>> let e = [coreProg|3|]
@@ -91,7 +76,7 @@ check g t1 e = do
 -- in the mean time all top-level binders must have a type annotation.
 checkCoreProg :: Program' -> HMError ()
 checkCoreProg p = scDefs
-                & traverse_ k
+            & traverse_ k
     where
         scDefs = p ^. programScDefs
         g = gatherTypeSigs p
@@ -103,17 +88,10 @@ checkCoreProg p = scDefs
              where scname = sc ^. _lhs._1
 
 -- | @checkCoreProgR p@ returns @p@ if @p@ successfully typechecks.
-checkCoreProgR :: forall m. (Monad m) => Program' -> RLPCT m Program'
+checkCoreProgR :: Program' -> RLPC RlpcError Program'
-checkCoreProgR p = (hoistRlpcT generalise . liftE . checkCoreProg $ p)
+checkCoreProgR p = do
-                $> p
+    liftRlpcErrs . rlpc . checkCoreProg $ p
-    where
+    pure p
-        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.
 --
@@ -162,32 +140,7 @@ gather = \g e -> runStateT (go g e) ([],0) <&> \ (t,(cs,_)) -> (t,cs) where
         Let NonRec bs e -> do
             g' <- buildLetContext g bs
             go g' e
-        Let Rec bs e -> do
+        -- TODO letrec, lambda, case
-            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'
@@ -265,14 +218,3 @@ 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")
-    ]
-

src/Core/Lex.x

@@ -20,13 +20,11 @@ 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 Control.Lens
+import Lens.Micro
+import Lens.Micro.TH
 }
 
 %wrapper "monad-strict-text"
@@ -67,8 +65,6 @@ $white_no_nl = $white # $nl
 
 @decimal = $digit+
 
-@alttag    = "<" $digit+ ">"
-
 rlp :-
 
 <0>
@@ -96,8 +92,6 @@ rlp :-
     "="                     { 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 }
@@ -120,9 +114,11 @@ 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 $ nolo t
+constTok t (AlexPn _ y x,_,_,_) l = pure $ Located y x l t
 
 data CoreToken = TokenLet
                | TokenLetrec
@@ -139,7 +135,6 @@ data CoreToken = TokenLet
                | TokenConName Name
                | TokenVarSym Name
                | TokenConSym Name
-               | TokenAltTag Tag
                | TokenEquals
                | TokenLParen
                | TokenRParen
@@ -169,34 +164,36 @@ data SrcErrorType = SrcErrLexical String
 type Lexer = AlexInput -> Int -> Alex (Located CoreToken)
 
 lexWith :: (Text -> CoreToken) -> Lexer
-lexWith f (AlexPn _ y x,_,_,s) l = pure . nolo . f . T.take l $ s
+lexWith f (AlexPn _ y x,_,_,s) l = pure $ Located y x l (f $ T.take l s)
 
 -- | The main lexer driver.
-lexCore :: Text -> RLPC [Located CoreToken]
+lexCore :: Text -> RLPC SrcError [Located CoreToken]
 lexCore s = case m of
-    Left e   -> error "core lex error"
+    Left e   -> addFatal err
+        where err = SrcError
+                { _errSpan       = (0,0,0) -- TODO: location
+                , _errSeverity   = Error
+                , _errDiagnostic = SrcErrLexical e
+                }
     Right ts -> pure ts
     where
         m = runAlex s lexStream
 
-lexCoreR :: forall m. (Applicative m) => Text -> RLPCT m [Located CoreToken]
+lexCoreR :: Text -> RLPC RlpcError [Located CoreToken]
-lexCoreR = hoistRlpcT generalise . lexCore
+lexCoreR = liftRlpcErrs . 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' :: Text -> RLPC [CoreToken]
+lexCore' :: Text -> RLPC SrcError [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]
+        Located _ _ _ TokenEOF  -> pure [l]
-        _                  -> (l:) <$> lexStream
+        _                       -> (l:) <$> lexStream
 
 data ParseError = ParErrLexical String
                 | ParErrParse
@@ -204,15 +201,15 @@ data ParseError = ParErrLexical String
 
 -- TODO:
 instance IsRlpcError SrcError where
-    liftRlpcError = Text . pure . T.pack . show
+    liftRlpcErr = RlpcErr . show
 
 -- TODO:
 instance IsRlpcError ParseError where
-    liftRlpcError = Text . pure . T.pack . show
+    liftRlpcErr = RlpcErr . show
 
 alexEOF :: Alex (Located CoreToken)
 alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) ->
-    Right (st, nolo $ TokenEOF)
+    Right (st, Located y x 0 TokenEOF)
 
 }
 

src/Core/Lex.x.old

@@ -0,0 +1,315 @@
+{
+-- 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)
+
+}

src/Core/Parse.y

@@ -3,33 +3,28 @@
 Module : Core.Parse
 Description : Parser for the Core language
 -}
-{-# LANGUAGE OverloadedStrings, ViewPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
 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 Control.Lens         hiding (snoc)
 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
 }
@@ -39,37 +34,36 @@ import Data.HashMap.Strict  qualified as H
 %name parseCoreProg StandaloneProgram
 %tokentype { Located CoreToken }
 %error { parseError }
-%monad { RLPC } { happyBind } { happyPure }
+%monad { RLPC SrcError }
 
 %token
-      let             { Located _ TokenLet }
+      let             { Located _ _ _ TokenLet }
-      letrec          { Located _ TokenLetrec }
+      letrec          { Located _ _ _ TokenLetrec }
-      module          { Located _ TokenModule }
+      module          { Located _ _ _ TokenModule }
-      where           { Located _ TokenWhere }
+      where           { Located _ _ _ TokenWhere }
-      case            { Located _ TokenCase }
+      case            { Located _ _ _ TokenCase }
-      of              { Located _ TokenOf }
+      of              { Located _ _ _ TokenOf }
-      pack            { Located _ TokenPack } -- temp
+      pack            { Located _ _ _ TokenPack } -- temp
-      in              { Located _ TokenIn }
+      in              { Located _ _ _ TokenIn }
-      litint          { Located _ (TokenLitInt $$) }
+      litint          { Located _ _ _ (TokenLitInt $$) }
-      varname         { Located _ (TokenVarName $$) }
+      varname         { Located _ _ _ (TokenVarName $$) }
-      varsym          { Located _ (TokenVarSym $$) }
+      varsym          { Located _ _ _ (TokenVarSym $$) }
-      conname         { Located _ (TokenConName $$) }
+      conname         { Located _ _ _ (TokenConName $$) }
-      consym          { Located _ (TokenConSym $$) }
+      consym          { Located _ _ _ (TokenConSym $$) }
-      alttag          { Located _ (TokenAltTag $$) }
+      word            { Located _ _ _ (TokenWord $$) }
-      word            { Located _ (TokenWord $$) }
+      'λ'             { Located _ _ _ TokenLambda }
-      'λ'             { Located _ TokenLambda }
+      '->'            { Located _ _ _ TokenArrow }
-      '->'            { Located _ TokenArrow }
+      '='             { Located _ _ _ TokenEquals }
-      '='             { Located _ TokenEquals }
+      '@'             { Located _ _ _ TokenTypeApp }
-      '@'             { Located _ TokenTypeApp }
+      '('             { Located _ _ _ TokenLParen }
-      '('             { Located _ TokenLParen }
+      ')'             { Located _ _ _ TokenRParen }
-      ')'             { Located _ TokenRParen }
+      '{'             { Located _ _ _ TokenLBrace }
-      '{'             { Located _ TokenLBrace }
+      '}'             { Located _ _ _ TokenRBrace }
-      '}'             { Located _ TokenRBrace }
+      '{-#'           { Located _ _ _ TokenLPragma }
-      '{-#'           { Located _ TokenLPragma }
+      '#-}'           { Located _ _ _ TokenRPragma }
-      '#-}'           { Located _ TokenRPragma }
+      ';'             { Located _ _ _ TokenSemicolon }
-      ';'             { Located _ TokenSemicolon }
+      '::'            { Located _ _ _ TokenHasType }
-      '::'            { Located _ TokenHasType }
+      eof             { Located _ _ _ TokenEOF }
-      eof             { Located _ TokenEOF }
 
 %%
 
@@ -89,15 +83,6 @@ 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         : ';'                           { () }
@@ -110,11 +95,10 @@ 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 }
@@ -164,15 +148,22 @@ Alters          : Alter ';' Alters              { $1 : $3 }
                 | Alter                         { [$1] }
 
 Alter           :: { Alter Name }
-Alter           : alttag ParList '->' Expr      { Alter (AltTag  $1) $2 $4 }
+Alter           : litint ParList '->' Expr      { Alter (AltData $1) $2 $4 }
-                | Con    ParList '->' Expr      { Alter (AltData $1) $2 $4 }
 
 Expr1           :: { Expr Name }
 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                    { T.unpack $1 : $2 }
+                | word                          { [T.unpack $1] }
+
 PackCon         :: { Expr Name }
 PackCon         : pack '{' litint litint '}'    { Con $3 $4 }
 
@@ -189,32 +180,43 @@ Id              : Var                                { $1 }
                 | Con                                { $1 }
 
 Var             :: { Name }
-Var             : varname                           { $1 }
+Var             : '(' varsym ')'                    { $2 }
-                | varsym                            { $1 }
+                | varname                           { $1 }
 
 Con             :: { Name }
-Con             : conname                           { $1 }
+Con             : '(' consym ')'                    { $2 }
-                | consym                            { $1 }
+                | conname                           { $1 }
 
 {
 
-parseError :: [Located CoreToken] -> RLPC a
+parseError :: [Located CoreToken] -> RLPC SrcError a
-parseError (Located _ t : _) =
+parseError (Located y x l _ : _) = addFatal err
-    error $ "<line>" <> ":" <> "<col>"
+    where err = SrcError
-         <> ": parse error at token `" <> show t <> "'"
+            { _errSpan       = (y,x,l)
+            , _errSeverity   = Error
+            , _errDiagnostic = SrcErrParse
+            }
 
-{-# WARNING parseError "unimpl" #-}
+parseTmp :: IO (Module Name)
+parseTmp = do
+    s <- TIO.readFile "/tmp/t.hs"
+    case parse s of
+        Left e -> error (show e)
+        Right (ts,_) -> pure ts
+    where
+        parse = evalRLPC def . (lexCore >=> parseCore)
 
-exprPragma :: [String] -> RLPC (Expr Name)
+exprPragma :: [String] -> RLPC SrcError (Expr Name)
-exprPragma ("AST" : e) = undefined
+exprPragma ("AST" : e) = astPragma e
-exprPragma _           = undefined
+exprPragma _           = addFatal err
+    where err = SrcError
+            { _errSpan       = (0,0,0) -- TODO: span
+            , _errSeverity   = Warning
+            , _errDiagnostic = SrcErrUnknownPragma "" -- TODO: missing pragma
+            }
 
-{-# WARNING exprPragma "unimpl" #-}
+astPragma :: [String] -> RLPC SrcError (Expr Name)
-
+astPragma = pure . read . unwords
-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
@@ -228,34 +230,8 @@ insScDef sc = programScDefs %~ (sc:)
 singletonScDef :: (Hashable b) => ScDef b -> Program b
 singletonScDef sc = insScDef sc mempty
 
-parseCoreExprR :: (Monad m) => [Located CoreToken] -> RLPCT m Expr'
+parseCoreProgR :: [Located CoreToken] -> RLPC RlpcError Program'
-parseCoreExprR = hoistRlpcT generalise . parseCoreExpr
+parseCoreProgR = liftRlpcErrs . parseCoreProg
-
-parseCoreProgR :: forall m. (Monad m) => [Located CoreToken] -> RLPCT m Program'
-parseCoreProgR = ddumpast <=< (hoistRlpcT generalise . parseCoreProg)
-    where
-        ddumpast :: Program' -> RLPCT m Program'
-        ddumpast p = do
-            addDebugMsg "dump-parsed-core" . show $ p
-            pure p
-
-happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b
-happyBind m k = m >>= k
-
-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
 
 }
 

src/Core/Parse.y.old

@@ -0,0 +1,159 @@
+{
+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)
+
+}
+

src/Core/Syntax.hs

@@ -5,12 +5,8 @@ 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(..)
     , pattern TyInt
     , Lit(..)
@@ -28,18 +24,15 @@ module Core.Syntax
     , Module(..)
     , Program(..)
     , Program'
-    , Pragma(..)
     , unliftScDef
     , programScDefs
     , programTypeSigs
-    , programDataTags
     , Expr'
     , ScDef'
     , Alter'
     , Binding'
     , HasRHS(_rhs)
     , HasLHS(_lhs)
-    , Pretty(pretty)
     )
     where
 ----------------------------------------------------------------------------------
@@ -47,20 +40,15 @@ import Data.Coerce
 import Data.Pretty
 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 Control.Lens
+import Lens.Micro.TH                (makeLenses)
+import Lens.Micro
 ----------------------------------------------------------------------------------
 
 data Expr b = Var Name
@@ -103,7 +91,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)
@@ -111,19 +99,16 @@ 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 Name
+data AltCon = AltData Tag
-            | AltTag Tag
             | AltLit Lit
-            | AltDefault
+            | Default
             deriving (Show, Read, Eq, Lift)
 
-newtype Lit = IntL Int
+data Lit = IntL Int
     deriving (Show, Read, Eq, Lift)
 
 type Name = T.Text
@@ -140,26 +125,13 @@ data Module b = Module (Maybe (Name, [Name])) (Program b)
 
 data Program b = Program
     { _programScDefs   :: [ScDef b]
-    , _programTypeSigs :: HashMap b Type
+    , _programTypeSigs :: H.HashMap b Type
-    , _programDataTags :: HashMap b (Tag, Int)
-    -- ^ map constructors to their tag and arity
     }
-    deriving (Show, Lift, Generic)
+    deriving (Show, Lift)
-    deriving (Semigroup, Monoid)
-        via Generically (Program b)
 
 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
 type ScDef' = ScDef Name
@@ -176,6 +148,12 @@ instance IsString Type where
         | otherwise     = TyVar . fromString $ s
         where (c:_) = s
 
+instance (Hashable b) => Semigroup (Program b) where
+    (<>) = undefined
+
+instance (Hashable b) => Monoid (Program b) where
+    mempty = Program mempty mempty
+
 ----------------------------------------------------------------------------------
 
 class HasRHS s t a b | s -> a, t -> b, s b -> t, t a -> s where
@@ -207,94 +185,5 @@ 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 ";"
 

src/Core/TH.hs

@@ -5,8 +5,8 @@ Description : Core quasiquoters
 module Core.TH
     ( coreExpr
     , coreProg
-    , coreExprT
     , coreProgT
+    , core
     )
     where
 ----------------------------------------------------------------------------------
@@ -14,44 +14,74 @@ import Language.Haskell.TH
 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)
-import Core.HindleyMilner           (checkCoreProgR, checkCoreExprR)
 ----------------------------------------------------------------------------------
 
-coreProg :: QuasiQuoter
+-- TODO: write in terms of a String -> QuasiQuoter
-coreProg = mkqq $ lexCoreR >=> parseCoreProgR
 
-coreExpr :: QuasiQuoter
+core :: QuasiQuoter
-coreExpr = mkqq $ lexCoreR >=> parseCoreExprR
+core = QuasiQuoter
-
+    { quoteExp = qCore
--- | 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"
     }
 
-mkq :: (Lift a) => (Text -> RLPCIO a) -> String -> Q Exp
+coreProg :: QuasiQuoter
-mkq parse s = liftIO $ evalRLPCIO def (parse $ T.pack s) >>= lift
+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"
+    }
+
+coreExpr :: QuasiQuoter
+coreExpr = QuasiQuoter
+    { quoteExp = qCoreExpr
+    , 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"
+    }
+
+-- | Type-checked @coreProg@
+coreProgT :: QuasiQuoter
+coreProgT = QuasiQuoter
+    { quoteExp = qCoreProgT
+    , 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 (T.pack 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 (T.pack 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 parse (T.pack s) of
+    Left e       -> error (show e)
+    Right (m,ts) -> lift m
+    where
+        parse = evalRLPC def . (lexCoreR >=> parseCoreProgR)
+
+qCoreProgT :: String -> Q Exp
+qCoreProgT s = case parse (T.pack s) of
+    Left e      -> error (show e)
+    Right (m,_) -> lift m
+    where
+        parse = evalRLPC def . (lexCoreR >=> parseCoreProgR >=> checkCoreProgR)
 

src/Core/Utils.hs

@@ -1,10 +1,16 @@
+-- for recursion schemes
+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
+-- for recursion schemes
+{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
+
 module Core.Utils
-    ( programRhss
+    ( bindersOf
-    , programGlobals
+    , rhssOf
     , isAtomic
     -- , insertModule
     , extractProgram
     , freeVariables
+    , ExprF(..)
     )
     where
 ----------------------------------------------------------------------------------
@@ -13,15 +19,17 @@ import Data.Functor.Foldable
 import Data.Set                     (Set)
 import Data.Set                     qualified as S
 import Core.Syntax
-import Control.Lens
+import Lens.Micro
 import GHC.Exts                     (IsList(..))
 ----------------------------------------------------------------------------------
 
-programGlobals :: Traversal' (Program b) b
+bindersOf :: (IsList l, Item l ~ b) => [Binding b] -> l
-programGlobals = programScDefs . each . _lhs . _1
+bindersOf bs = fromList $ fmap f bs
+    where f (k := _) = k
 
-programRhss :: Traversal' (Program b) (Expr b)
+rhssOf :: (IsList l, Item l ~ Expr b) => [Binding b] -> l
-programRhss = programScDefs . each . _rhs
+rhssOf = fromList . fmap f
+    where f (_ := v) = v
 
 isAtomic :: Expr b -> Bool
 isAtomic (Var _)  = True
@@ -39,6 +47,8 @@ extractProgram (Module _ p) = p
 
 ----------------------------------------------------------------------------------
 
+makeBaseFunctor ''Expr
+
 freeVariables :: Expr' -> Set Name
 freeVariables = cata go
     where
@@ -47,8 +57,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 = bs ^.. each . _rhs :: [Expr']
+                es = rhssOf bs :: [Expr']
-                ns = S.fromList $ bs ^.. each . _lhs
+                ns = bindersOf bs
                 -- TODO: this feels a little wrong. maybe a different scheme is
                 -- appropriate
                 esFree = foldMap id $ freeVariables <$> es

src/Core2Core.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE LambdaCase #-}
 module Core2Core
     ( core2core
     , gmPrep
@@ -14,77 +14,36 @@ 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.Lazy
+import Control.Monad.State
 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 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 & appFloater (floatNonStrictCases globals)
+gmPrep p = p' & programScDefs %~ (<>caseScs)
-             & 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
 
--- | Define concrete supercombinators for all datatags defined via pragmas (or
+        -- i kinda don't like that we're calling floatNonStrictCases twice tbh
--- desugaring)
+        p'      = p & rhss %~ fst . runFloater . floatNonStrictCases globals
-
+        caseScs = (p ^.. rhss)
-defineData :: Program' -> Program'
+              <&> snd . runFloater . floatNonStrictCases globals
-defineData p = p & programScDefs <>~ defs
+                & mconcat
-    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
@@ -114,7 +73,7 @@ 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
@@ -123,7 +82,7 @@ floatNonStrictCases g = goE
         goC (Var k)             = pure (Var k)
         goC (Con t as)          = pure (Con t as)
 
-        name = state (fromJust . Data.List.uncons)
+        name = state (fromJust . uncons)
 
         -- extract the right-hand sides of a list of bindings, traverse each
         -- one, and return the original list of bindings
@@ -131,7 +90,6 @@ 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

src/Data/Heap.hs

@@ -27,7 +27,6 @@ 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)
@@ -35,21 +34,6 @@ 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
@@ -70,7 +54,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)
 
 ----------------------------------------------------------------------------------
 

src/Data/Pretty.hs

@@ -1,65 +1,80 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Data.Pretty
     ( Pretty(..)
-    , rpretty
+    , ISeq(..)
-    , ttext
+    , precPretty
-    -- * Pretty-printing lens combinators
+    , prettyPrint
-    , hsepOf, vsepOf
+    , prettyShow
-    , vcatOf
+    , iShow
-    , vlinesOf
+    , iBracket
-    , module Text.PrettyPrint
+    , withPrec
-    , maybeParens
+    , bracketPrec
     )
     where
 ----------------------------------------------------------------------------------
-import Text.PrettyPrint             hiding ((<>))
+import Data.String      (IsString(..))
-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 -> Doc
+    pretty :: a -> ISeq
-    prettyPrec :: Int -> a -> Doc
+    prettyPrec :: a -> Int -> ISeq
 
     {-# MINIMAL pretty | prettyPrec #-}
-    pretty = prettyPrec 0
+    pretty a = prettyPrec a 0
-    prettyPrec a _ = pretty a
+    prettyPrec a _ = iBracket (pretty a)
 
-rpretty :: (IsString s, Pretty a) => a -> s
+precPretty :: (Pretty a) => Int -> a -> ISeq
-rpretty = fromString . render . pretty
+precPretty = flip prettyPrec
 
-instance Pretty String where
+prettyPrint :: (Pretty a) => a -> IO ()
-    pretty = Text.PrettyPrint.text
+prettyPrint = putStr . squash . pretty
 
-instance Pretty T.Text where
+prettyShow :: (Pretty a) => a -> String
-    pretty = Text.PrettyPrint.text . view unpacked
+prettyShow = squash . pretty
 
-newtype Showing a = Showing a
+data ISeq where
+    INil :: ISeq
+    IStr :: String -> ISeq
+    IAppend :: ISeq -> ISeq -> ISeq
+    IIndent :: ISeq -> ISeq
+    IBreak :: ISeq
 
-instance (Show a) => Pretty (Showing a) where
+instance IsString ISeq where
-    prettyPrec p (Showing a) = fromString $ showsPrec p a ""
+    fromString = IStr
 
-deriving via Showing Int instance Pretty Int
+instance Semigroup ISeq where
+    (<>) = IAppend
 
---------------------------------------------------------------------------------
+instance Monoid ISeq where
+    mempty = INil
 
-ttext :: Pretty t => t -> Doc
+squash :: ISeq -> String
-ttext = pretty
+squash a = flatten 0 [(a,0)]
 
-hsepOf :: Getting (Endo Doc) s Doc -> s -> Doc
+flatten :: Int -> [(ISeq, Int)] -> String
-hsepOf l = foldrOf l (<+>) mempty
+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)
 
-vsepOf :: Getting (Endo Doc) s Doc -> s -> Doc
+iBracket :: ISeq -> ISeq
-vsepOf l = foldrOf l ($+$) mempty
+iBracket s = IStr "(" <> s <> IStr ")"
 
-vcatOf :: Getting (Endo Doc) s Doc -> s -> Doc
+withPrec :: Int -> ISeq -> Int -> ISeq
-vcatOf l = foldrOf l ($$) mempty
+withPrec n s p
+    | p > n     = iBracket s
+    | otherwise =          s
 
-vlinesOf :: Getting (Endo Doc) s Doc -> s -> Doc
+bracketPrec :: Int -> Int -> ISeq -> ISeq
-vlinesOf l = foldrOf l (\a b -> a $+$ "" $+$ b) mempty
+bracketPrec n p s = withPrec n s p
--- 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>"

src/GM.hs

@@ -8,13 +8,8 @@ Description : The G-Machine
 module GM
     ( hdbgProg
     , evalProg
-    , evalProgR
-    , GmState(..)
-    , gmCode, gmStack, gmDump, gmHeap, gmEnv, gmStats
     , Node(..)
-    , showState
     , gmEvalProg
-    , Stats(..)
     , finalStateOf
     , resultOf
     , resultOfExpr
@@ -26,35 +21,23 @@ import Data.List                    (mapAccumL)
 import Data.Maybe                   (fromMaybe, mapMaybe)
 import Data.Monoid                  (Endo(..))
 import Data.Tuple                   (swap)
-import Control.Lens
+import Lens.Micro
-import Data.Text.Lens               (IsText, packed, unpacked)
+import Lens.Micro.Extras            (view)
+import Lens.Micro.TH
+import Lens.Micro.Platform          (packed, unpacked)
+import Lens.Micro.Platform.Internal (IsText(..))
 import Text.Printf
 import Text.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
@@ -90,7 +73,6 @@ data Key = NameKey Name
          | ConstrKey Tag Int
          deriving (Show, Eq)
 
--- >> [ref/Instr]
 data Instr = Unwind
            | PushGlobal Name
            | PushConstr Tag Int
@@ -105,14 +87,12 @@ data Instr = Unwind
            -- arith
            | Neg | Add | Sub | Mul | Div
            -- comparison
-           | Equals | Lesser | GreaterEq
+           | Equals
            | 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
@@ -155,7 +135,7 @@ evalProg p = res <&> (,sts)
         resAddr = final ^. gmStack ^? _head
         res = resAddr >>= flip hLookup h
 
-hdbgProg :: Program' -> Handle -> IO GmState
+hdbgProg :: Program' -> Handle -> IO (Node, Stats)
 hdbgProg p hio = do
     (renderOut . showState) `traverse_` states
     -- TODO: i'd like the statistics to be at the top of the file, but `sts`
@@ -163,7 +143,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 final
+    pure (res, sts)
     where
         renderOut r = hPutStrLn hio $ render r ++ "\n"
 
@@ -176,21 +156,6 @@ 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
@@ -230,38 +195,12 @@ step st = case head (st ^. gmCode) of
     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#"
@@ -455,10 +394,8 @@ step st = case head (st ^. gmCode) of
         mulI = primitive2 boxInt unboxInt (*) st
         divI = primitive2 boxInt unboxInt div st
 
-        lesserI, greaterEqI, equalsI :: GmState
+        equalsI :: GmState
         equalsI = primitive2 boxBool unboxInt (==) st
-        lesserI = primitive2 boxBool unboxInt (<) st
-        greaterEqI = primitive2 boxBool unboxInt (>=) st
 
         splitI :: Int -> GmState
         splitI n = st
@@ -600,13 +537,12 @@ boxBool st p = st
     where
         h = st ^. gmHeap
         (h',a) = alloc h (NConstr p' [])
-        p' = if p then tag_Bool_True else tag_Bool_False
+        p' = if p then 1 else 0
 
 unboxBool :: Addr -> GmState -> Bool
 unboxBool a st = case hLookup a h of
-        Just (NConstr t [])
+        Just (NConstr 1 []) -> True
-            | t == tag_Bool_True  -> True
+        Just (NConstr 0 []) -> False
-            | t == tag_Bool_False -> False
         Just _              -> error "unboxInt received a non-int"
         Nothing             -> error "unboxInt received an invalid address"
     where h = st ^. gmHeap
@@ -642,10 +578,6 @@ 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])
@@ -729,8 +661,7 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
         compileC _ (Con t n) = [PushConstr t n]
 
         compileC _ (Case _ _) =
-            error "GM compiler found a non-strict case expression, which should\
+            error "case expressions may not appear in non-strict contexts :/"
-                  \ have been floated by Core2Core.gmPrep. This is a bug!"
 
         compileC _ _ = error "yet to be implemented!"
 
@@ -749,12 +680,14 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
                 mconcat binders <> compileE g' e <> [Slide d]
             where
                 d = length bs
-                (g',binders) = mapAccumL compileBinder g bs
+                (g',binders) = mapAccumL compileBinder (argOffset d g) addressed
+                -- kinda gross. revisit this
+                addressed = bs `zip` reverse [0 .. d-1]
 
-                compileBinder :: Env -> Binding' -> (Env, Code)
+                compileBinder :: Env -> (Binding', Int) -> (Env, Code)
-                compileBinder m (k := v) = (m',c)
+                compileBinder m (k := v, a) = (m',c)
                     where
-                        m' = (NameKey k, 0) : argOffset 1 m
+                        m' = (NameKey k, a) : m
                         -- make note that we use m rather than m'!
                         c = compileC m v
 
@@ -782,27 +715,21 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
         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 = fmap (compileA g)
+        compileD g as = fmap (compileA g) as
 
         compileA :: Env -> Alter' -> (Tag, Code)
-        compileA g (Alter (AltTag t) as e) = (t, [Split n] <> c <> [Slide n])
+        compileA g (Alter (AltData 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]

src/Rlp/Lex.x

@@ -7,17 +7,14 @@ module Rlp.Lex
     , RlpToken(..)
     , Located(..)
     , lexToken
-    , lexStream
     , lexDebug
     , lexCont
-    , popLexState
+    , execP
-    , programInitState
+    , execP'
-    , 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)
@@ -27,7 +24,8 @@ import Data.Text                (Text)
 import Data.Text                qualified as T
 import Data.Word
 import Data.Default
-import Control.Lens
+import Lens.Micro.Mtl
+import Lens.Micro
 
 import Debug.Trace
 import Rlp.Parse.Types
@@ -56,7 +54,6 @@ $asciisym       = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
 
 @reservedname = 
     case|data|do|import|in|let|letrec|module|of|where
-    |infixr|infixl|infix
 
 @reservedop =
     "=" | \\ | "->" | "|" | "::"
@@ -75,19 +72,6 @@ $white_no_nl+       ;
 -- 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>
 {
@@ -129,21 +113,6 @@ $white_no_nl+       ;
 {
     \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 }
 }
 
@@ -155,20 +124,13 @@ lexReservedName = \case
     "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
@@ -178,12 +140,6 @@ thenBegin act c inp l = do
     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
@@ -204,10 +160,10 @@ alexGetByte inp = case inp ^. aiBytes of
                        -- report the previous char
                        & aiPrevChar .~ c
                        -- update the position
-                       & aiPos %~ \ (ln,col,a) ->
+                       & aiPos %~ \ (ln,col) ->
                                    if c == '\n'
-                                   then (ln+1, 1, a+1)
+                                   then (ln+1,1)
-                                   else (ln, col+1, a+1)
+                                   else (ln,col+1)
         pure (b, inp')
     
     _ -> Just (head bs, inp')
@@ -227,19 +183,19 @@ pushLexState :: Int -> P ()
 pushLexState n = psLexState %= (n:)
 
 readInt :: Text -> Int
-readInt = T.foldl f 0 where
+readInt = T.foldr f 0 where
-    f n c = 10*n + digitToInt c
+    f c n = digitToInt c + 10*n
 
 constToken :: RlpToken -> LexerAction (Located RlpToken)
 constToken t inp l = do
     pos <- use (psInput . aiPos)
-    pure (Located (spanFromPos pos l) t)
+    pure (Located (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)
+    pure (Located (pos,l) t)
 
 getPos :: P Position
 getPos = use (psInput . aiPos)
@@ -247,12 +203,32 @@ getPos = use (psInput . aiPos)
 alexEOF :: P (Located RlpToken)
 alexEOF = do
     inp <- getInput
-    pos <- getPos
+    pure (Located undefined TokenEOF)
-    pure (Located (spanFromPos pos 0) TokenEOF)
 
-runP' :: P a -> Text -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
+execP :: P a -> ParseState -> Maybe a
-runP' p s = runP p st where
+execP p st = runP p st & snd
-    st = initParseState [layout_top,0] s
+
+execP' :: P a -> Text -> Maybe a
+execP' p s = execP p st where
+    st = initParseState s
+
+initParseState :: Text -> ParseState
+initParseState 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 = [layout_top,0]
+    , _psInput = initAlexInput s
+    , _psOpTable = mempty
+    }
+
+initAlexInput :: Text -> AlexInput
+initAlexInput s = AlexInput
+    { _aiPrevChar   = '\0'
+    , _aiSource     = s
+    , _aiBytes      = []
+    , _aiPos        = (1,1)
+    }
 
 lexToken :: P (Located RlpToken)
 lexToken = do
@@ -261,14 +237,13 @@ lexToken = do
     st <- use id
     -- traceM $ "st: " <> show st
     case alexScan inp c of
-        AlexEOF -> pure $ Located (spanFromPos (inp^.aiPos) 0) TokenEOF
+        AlexEOF -> pure $ Located (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 >>=)
@@ -287,7 +262,7 @@ lexDebug k = do
     k t
 
 lexTest :: Text -> Maybe [RlpToken]
-lexTest s = runP' lexStream s ^. _3
+lexTest s = execP' lexStream s
 
 indentLevel :: P Int
 indentLevel = do
@@ -297,7 +272,7 @@ indentLevel = do
 insertToken :: RlpToken -> P (Located RlpToken)
 insertToken t = do
     pos <- use (psInput . aiPos)
-    pure (Located (spanFromPos pos 0) t)
+    pure (Located (pos, 0) t)
 
 popLayout :: P Layout
 popLayout = do
@@ -306,7 +281,7 @@ popLayout = do
     psLayoutStack %= (drop 1)
     case ctx of
         Just l      -> pure l
-        Nothing     -> error "popLayout: layout stack empty! this is a bug."
+        Nothing     -> error "uhh"
 
 pushLayout :: Layout -> P ()
 pushLayout l = do
@@ -334,19 +309,18 @@ doBol :: LexerAction (Located RlpToken)
 doBol inp l = do
     off <- cmpLayout
     i <- indentLevel
-    -- traceM $ "i: " <> show i
+    traceM $ "i: " <> show i
     -- important that we pop the lex state lest we find our lexer diverging
+    popLexState
     case off of
         -- the line is aligned with the previous. it therefore belongs to the
         -- same list
-        EQ -> popLexState *> insertSemicolon
+        EQ -> 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
+        GT -> 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
+        -- insert a closing brace.
-        -- 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
@@ -365,13 +339,9 @@ explicitRBrace inp l = do
 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]
-
 }
 

src/Rlp/Parse.y

@@ -1,54 +1,40 @@
 {
-{-# LANGUAGE LambdaCase, ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
 module Rlp.Parse
     ( parseRlpProg
-    , parseRlpProgR
+    , execP
-    , parseRlpExpr
+    , execP'
-    , parseRlpExprR
     )
     where
-import Compiler.RlpcError
-import Compiler.RLPC
 import Rlp.Lex
 import Rlp.Syntax
 import Rlp.Parse.Types
 import Rlp.Parse.Associate
-import Control.Lens                 hiding (snoc, (.>), (<.), (<<~))
+import Lens.Micro
+import Lens.Micro.Mtl
+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 _) }
+    varname         { Located _ (TokenVarName $$) }
-    conname         { Located _ (TokenConName _) }
+    conname         { Located _ (TokenConName $$) }
-    consym          { Located _ (TokenConSym _) }
+    consym          { Located _ (TokenConSym $$) }
-    varsym          { Located _ (TokenVarSym _) }
+    varsym          { Located _ (TokenVarSym $$) }
     data            { Located _ TokenData }
-    case            { Located _ TokenCase }
+    litint          { Located _ (TokenLitInt $$) }
-    of              { Located _ TokenOf }
+    '::'            { Located _ TokenHasType }
-    litint          { Located _ (TokenLitInt _) }
     '='             { Located _ TokenEquals }
     '|'             { Located _ TokenPipe }
-    '::'            { Located _ TokenHasType }
     ';'             { Located _ TokenSemicolon }
     '('             { Located _ TokenLParen }
     ')'             { Located _ TokenRParen }
@@ -61,23 +47,15 @@ import Compiler.Types
     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   :: { RlpProgram' }
 StandaloneProgram   : '{' Decls  '}'        {% mkProgram $2 }
                     | VL  DeclsV VR         {% mkProgram $2 }
 
-StandaloneExpr      :: { RlpExpr RlpcPs }
-                    : VL Expr VR            { extract $2 }
-
 VL  :: { () }
 VL  : vlbrace       { () }
 
@@ -85,13 +63,13 @@ VR  :: { () }
 VR  : vrbrace       { () }
     | error         { () }
 
-Decls               :: { [Decl' RlpcPs] }
+Decls               :: { [PartialDecl'] }
 Decls               : Decl ';' Decls        { $1 : $3 }
                     | Decl ';'              { [$1] }
                     | Decl                  { [$1] }
 
-DeclsV              :: { [Decl' RlpcPs] }
+DeclsV              :: { [PartialDecl'] }
-DeclsV              : Decl VS DeclsV        { $1 : $3 }
+DeclsV              : Decl VS Decls         { $1 : $3 }
                     | Decl VS               { [$1] }
                     | Decl                  { [$1] }
 
@@ -99,214 +77,108 @@ VS                  :: { Located RlpToken }
 VS                  : ';'                   { $1 }
                     | vsemi                 { $1 }
 
-Decl        :: { Decl' RlpcPs }
+Decl        :: { PartialDecl' }
             : FunDecl                   { $1 }
             | TySigDecl                 { $1 }
             | DataDecl                  { $1 }
             | InfixDecl                 { $1 }
 
-TySigDecl   :: { Decl' RlpcPs }
+-- TODO: multiple vars
-            : Var '::' Type             { (\e -> TySigD [extract e]) <<~ $1 <~> $3 }
 
-InfixDecl   :: { Decl' RlpcPs }
+TySigDecl   :: { PartialDecl' }
-            : InfixWord litint InfixOp  { $1 =>> \w ->
+            : Var '::' Type             { TySigD [$1] $3 }
-                                          InfixD (extract $1) (extractInt $ extract $2)
-                                          (extract $3) }
 
-InfixWord   :: { Located Assoc }
+InfixDecl   :: { PartialDecl' }
-            : infixl                    { $1 \$> InfixL }
+            : InfixWord litint InfixOp  {% mkInfixD $1 $2 $3 }
-            | infixr                    { $1 \$> InfixR }
-            | infix                     { $1 \$> Infix  }
 
-DataDecl    :: { Decl' RlpcPs }
+InfixWord   :: { Assoc }
-            : data Con TyParams '=' DataCons    { $1 \$> DataD (extract $2) $3 $5 }
+            : infixl                    { InfixL }
+            | infixr                    { InfixR }
+            | infix                     { Infix  }
 
-TyParams    :: { [PsName] }
+DataDecl    :: { PartialDecl' }
+            : data Con TyParams '=' DataCons    { DataD $2 $3 $5 }
+
+TyParams    :: { [Name] }
             : {- epsilon -}             { [] }
-            | TyParams varname          { $1 `snoc` (extractName . extract $ $2) }
+            | TyParams varname          { $1 `snoc` $2 }
 
-DataCons    :: { [ConAlt RlpcPs] }
+DataCons    :: { [ConAlt] }
             : DataCons '|' DataCon      { $1 `snoc` $3 }
             | DataCon                   { [$1] }
 
-DataCon     :: { ConAlt RlpcPs }
+DataCon     :: { ConAlt }
-            : Con Type1s                { ConAlt (extract $1) $2 }
+            : Con Type1s                { ConAlt $1 $2 }
 
-Type1s      :: { [RlpType' RlpcPs] }
+Type1s      :: { [Type] }
             : {- epsilon -}             { [] }
             | Type1s Type1              { $1 `snoc` $2 }
 
-Type1       :: { RlpType' RlpcPs }
+Type1       :: { Type }
             : '(' Type ')'              { $2 }
-            | conname                   { fmap ConT (mkPsName $1) }
+            | conname                   { TyCon $1 }
-            | varname                   { fmap VarT (mkPsName $1) }
+            | varname                   { TyVar $1 }
 
-Type        :: { RlpType' RlpcPs }
+Type        :: { Type }
-            : Type '->' Type            { FunT <<~ $1 <~> $3 }
+            : Type '->' Type            { $1 :-> $3 }
-            | TypeApp                   { $1 }
+            | Type1                     { $1 }
 
-TypeApp     :: { RlpType' RlpcPs }
+FunDecl     :: { PartialDecl' }
-            : Type1                     { $1 }
+FunDecl     : Var Params '=' Expr       { FunD $1 $2 (Const $4) Nothing }
-            | TypeApp Type1             { AppT <<~ $1 <~> $2 }
 
-FunDecl     :: { Decl' RlpcPs }
+Params      :: { [Pat'] }
-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 }
+Pat1        :: { Pat' }
-            : Con Pat1s                 { $1 =>> \cn ->
+            : Var                       { VarP $1 }
-                                          ConP (extract $1) $2 }
+            | Lit                       { LitP $1 }
-            | Pat1                      { $1 }
 
-Pat1s       :: { [Pat' RlpcPs] }
+Expr        :: { PartialExpr' }
-            : Pat1s Pat1                { $1 `snoc` $2 }
+            : Expr1 varsym Expr         { Fix $ B $2 (unFix $1) (unFix $3) }
-            | Pat1                      { [$1] }
+            | Expr1                     { $1 }
 
-Pat1        :: { Pat' RlpcPs }
+Expr1       :: { PartialExpr' }
-            : Con                       { fmap (`ConP` []) $1 }
+            : '(' Expr ')'              { wrapFix . Par . unwrapFix $ $2 }
-            | Var                       { fmap VarP $1 }
+            | Lit                       { Fix . E $ LitEF $1 }
-            | Lit                       { LitP <<= $1 }
+            | Var                       { Fix . E $ VarEF $1 }
-            | '(' Pat ')'               { $1 .> $2 <. $3 }
 
-Expr        :: { RlpExpr' RlpcPs }
+-- TODO: happy prefers left-associativity. doing such would require adjusting
-            -- infixities delayed till next release :(
+-- the code in Rlp.Parse.Associate to expect left-associative input rather than
-            -- : Expr1 InfixOp Expr        { $2 =>> \o ->
+-- right.
-            --                              OAppE (extract o) $1 $3 }
+InfixExpr   :: { PartialExpr' }
-            : TempInfixExpr             { $1 }
+            : Expr1 varsym Expr         { Fix $ B $2 (unFix $1) (unFix $3) }
-            | LetExpr                   { $1 }
-            | CaseExpr                  { $1 }
-            | AppExpr                   { $1 }
 
-TempInfixExpr :: { RlpExpr' RlpcPs }
+InfixOp     :: { Name }
-TempInfixExpr : Expr1 InfixOp TempInfixExpr {% tempInfixExprErr $1 $3 }
+            : consym                    { $1 }
-              | Expr1 InfixOp Expr1 { $2 =>> \o ->
+            | varsym                    { $1 }
-                                      OAppE (extract o) $1 $3 }
 
-AppExpr     :: { RlpExpr' RlpcPs }
+Lit         :: { Lit' }
-            : Expr1                     { $1 }
+Lit         : litint                    { IntL $1 }
-            | AppExpr Expr1             { AppE <<~ $1 <~> $2 }
 
-LetExpr     :: { RlpExpr' RlpcPs }
+Var         :: { VarId }
-            : let layout1(Binding) in Expr      { $1 \$> LetE $2 $4 }
+Var         : varname                   { NameVar $1 }
-            | letrec layout1(Binding) in Expr   { $1 \$> LetrecE $2 $4 }
 
-CaseExpr    :: { RlpExpr' RlpcPs }
+Con         :: { ConId }
-            : case Expr of layout0(CaseAlt)
+            : conname                   { NameCon $1 }
-                { 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)
+mkProgram :: [PartialDecl'] -> P RlpProgram'
-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 RlpToken -> P a
-parseError ((Located ss t), exp) = addFatal $
+parseError = error . show
-    errorMsg ss (RlpParErrUnexpectedToken t exp)
 
-mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs)
+mkInfixD :: Assoc -> Int -> Name -> P PartialDecl'
 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
+        Just o  -> error "(TODO: non-fatal) duplicate inix decls"
-            e = RlpParErrDuplicateInfixD n
-            l = T.length n
         Nothing -> pure (Just (a,p))
         )
-    pos <- use (psInput . aiPos)
+    pure $ InfixD a p n
-    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."
-        ]
-
 }
-

src/Rlp/Parse/Associate.hs

@@ -1,25 +1,87 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms, ViewPatterns, ImplicitParams #-}
 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 Lens.Micro
-import Data.Text                        qualified as T
-import Text.Printf
-import Control.Lens
 import Rlp.Parse.Types
 import Rlp.Syntax
 --------------------------------------------------------------------------------
 
-associate :: OpTable -> Decl' RlpcPs -> Decl' RlpcPs
+associate :: OpTable -> PartialDecl' -> Decl' RlpExpr
-associate _ p = p
+associate pt (FunD n as b w)    = FunD n as b' w
+    where b' = let ?pt = pt in completeExpr (getConst b)
+associate pt (TySigD ns t)      = TySigD ns t
+associate pt (DataD n as cs)    = DataD n as cs
+associate pt (InfixD a p n)     = InfixD a p n
 
-{-# WARNING associate "unimplemented" #-}
+completeExpr :: (?pt :: OpTable) => PartialExpr' -> RlpExpr'
+completeExpr = cata completePartial
+
+completePartial :: (?pt :: OpTable) => PartialE -> RlpExpr'
+completePartial (E e)        = completeRlpExpr e
+completePartial p@(B o l r)  = completeB (build p)
+completePartial (Par e)      = completePartial e
+
+completeRlpExpr :: (?pt :: OpTable) => RlpExprF' RlpExpr' -> RlpExpr'
+completeRlpExpr = embed
+
+completeB :: (?pt :: OpTable) => PartialE -> RlpExpr'
+completeB p = case build p of
+    B o l r     -> (o' `AppE` l') `AppE` r'
+        where
+            -- TODO: how do we know it's symbolic?
+            o' = VarE (SymVar o)
+            l' = completeB l
+            r' = completeB r
+    Par e       -> completeB e
+    E e         -> completeRlpExpr e
+
+build :: (?pt :: OpTable) => PartialE -> PartialE
+build e = go id e (rightmost e) where
+    rightmost :: PartialE -> PartialE
+    rightmost (B _ _ r) = rightmost r
+    rightmost p@(E _)   = p
+    rightmost p@(Par _) = p
+
+    go :: (?pt :: OpTable)
+       => (PartialE -> PartialE)
+       -> PartialE -> PartialE -> PartialE
+    go f p@(WithInfo o _ r) = case r of
+            E _     -> mkHole o (f . f')
+            Par _   -> mkHole o (f . f')
+            B _ _ _ -> go (mkHole o (f . f')) r
+        where f' r' = p & pR .~ r'
+    go f _ = id
+
+mkHole :: (?pt :: OpTable)
+       => OpInfo
+       -> (PartialE -> PartialE)
+       -> PartialE
+       -> PartialE
+mkHole _     hole p@(Par _)                 = hole p
+mkHole _     hole p@(E _)                   = hole p
+mkHole (a,d) hole p@(WithInfo (a',d') _ _)
+    | d' < d  = above
+    | d' > d  = below
+    | d == d' = case (a,a') of
+                  -- left-associative operators of equal precedence are
+                  -- associated left
+                  (InfixL,InfixL) -> above
+                  -- right-associative operators are handled similarly
+                  (InfixR,InfixR) -> below
+                  -- non-associative operators of equal precedence, or equal
+                  -- precedence operators of different associativities are
+                  -- invalid
+                  (_,     _)      -> error "invalid expression"
+    where
+        above = p & pL %~ hole
+        below = hole p
 
 examplePrecTable :: OpTable
 examplePrecTable = H.fromList
@@ -35,3 +97,4 @@ examplePrecTable = H.fromList
     , ("&",    (InfixL,0))
     ]
 
+

src/Rlp/Parse/Types.hs

@@ -1,39 +1,11 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
 {-# LANGUAGE LambdaCase #-}
-module Rlp.Parse.Types
+module Rlp.Parse.Types where
-    (
-    -- * 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.State.Class
-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
@@ -41,54 +13,12 @@ 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 Control.Lens                 hiding ((<<~))
+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
@@ -100,20 +30,10 @@ data AlexInput = AlexInput
     deriving Show
 
 type Position =
-    ( Int -- ^ line
+    ( Int -- line
-    , Int -- ^ column
+    , 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
@@ -127,7 +47,6 @@ data RlpToken
     | TokenCase
     | TokenOf
     | TokenLet
-    | TokenLetrec
     | TokenIn
     | TokenInfixL
     | TokenInfixR
@@ -145,46 +64,31 @@ data RlpToken
     | TokenLParen
     | TokenRParen
     -- 'virtual' control symbols, inserted by the lexer without any correlation
-    -- to a specific part of the input
+    -- to a specific symbol
     | TokenSemicolonV
     | TokenLBraceV
     | TokenRBraceV
     | TokenEOF
     deriving (Show)
 
-newtype P a = P {
+newtype P a = P { runP :: ParseState -> (ParseState, Maybe a) }
-        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)
+    pure a = P $ \st -> (st,Just a)
     liftA2 = liftM2
 
 instance Monad P where
     p >>= k = P $ \st ->
-        let (st',es,ma) = runP p st
+        let (st',a) = runP p st
-        in case ma of
+        in case a of
-            Just a  -> runP (k a) st'
+            Just x  -> runP (k x) st'
-                     & _2 %~ (es<>)
+            Nothing -> (st', Nothing)
-            Nothing -> (st',es,Nothing)
-
-    {-# INLINE (>>=) #-}
 
 instance MonadState ParseState P where
     state f = P $ \st ->
         let (a,st') = f st
-        in (st', [], Just a)
+        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]
@@ -198,96 +102,62 @@ data Layout = Explicit
             | Implicit Int
             deriving (Show, Eq)
 
+data Located a = Located (Position, Int) a
+    deriving (Show)
+
 type OpTable = H.HashMap Name OpInfo
 type OpInfo = (Assoc, Int)
 
-data RlpParseError = RlpParErrOutOfBoundsPrecedence Int
+-- data WithLocation a = WithLocation [String] a
-                   | RlpParErrDuplicateInfixD Name
-                   | RlpParErrLexical
-                   | RlpParErrUnexpectedToken RlpToken [String]
-                   | RlpParErrOther [Text]
-                   deriving (Show)
 
-instance IsRlpcError RlpParseError where
+data RlpParseError = RlpParErrOutOfBoundsPrecedence Int
-    liftRlpcError = \case
+                   | RlpParErrDuplicateInfixD
-        RlpParErrOutOfBoundsPrecedence n ->
+    deriving (Eq, Ord, Show)
-            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
 
 ----------------------------------------------------------------------------------
 
+-- absolute psycho shit (partial ASTs)
+
+type PartialDecl' = Decl (Const PartialExpr') Name
+
+data Partial a = E (RlpExprF Name a)
+               | B Name (Partial a) (Partial a)
+               | Par (Partial a)
+               deriving (Show, Functor)
+
+pL :: Traversal' (Partial a) (Partial a)
+pL k (B o l r) = (\l' -> B o l' r) <$> k l
+pL _ x         = pure x
+
+pR :: Traversal' (Partial a) (Partial a)
+pR k (B o l r) = (\r' -> B o l r') <$> k r
+pR _ x         = pure x
+
+type PartialE = Partial RlpExpr'
+
+-- i love you haskell
+pattern WithInfo :: (?pt :: OpTable) => OpInfo -> PartialE -> PartialE -> PartialE
+pattern WithInfo p l r <- B (opInfoOrDef -> p) l r
+
+opInfoOrDef :: (?pt :: OpTable) => Name -> OpInfo
+opInfoOrDef c = fromMaybe (InfixL,9) $ H.lookup c ?pt
+
+-- required to satisfy constraint on Fix's show instance
+instance Show1 Partial where
+    liftShowsPrec :: forall a. (Int -> a -> ShowS)
+                  -> ([a] -> ShowS)
+                  -> Int -> Partial a -> ShowS
+
+    liftShowsPrec sp sl p m = case m of
+        (E e)       -> showsUnaryWith lshow "E" p e
+        (B f a b)   -> showsTernaryWith showsPrec lshow lshow "B" p f a b
+        (Par e)     -> showsUnaryWith lshow "Par" p e
+        where
+            lshow :: forall f. (Show1 f) => Int -> f a -> ShowS
+            lshow = liftShowsPrec sp sl
+
+type PartialExpr' = Fix Partial
+
 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)
-

src/Rlp/Syntax.hs

@@ -1,289 +1,136 @@
 -- recursion-schemes
-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable
+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
-  , TemplateHaskell, TypeFamilies #-}
+-- recursion-schemes
-{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-}
+{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
-{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}
+{-# LANGUAGE OverloadedStrings, PatternSynonyms #-}
-{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-}
 module Rlp.Syntax
-    (
+    ( RlpModule(..)
-    -- * AST
+    , RlpProgram(..)
-      RlpProgram(..)
+    , RlpProgram'
-    , progDecls
+    , rlpmodName
-    , Decl(..), Decl', RlpExpr(..), RlpExpr', RlpExprF(..)
+    , rlpmodProgram
-    , Pat(..), Pat'
+    , RlpExpr(..)
-    , Alt(..), Where
+    , RlpExpr'
-    , Assoc(..)
+    , RlpExprF(..)
-    , Lit(..), Lit'
+    , RlpExprF'
-    , RlpType(..), RlpType'
+    , Decl(..)
+    , Decl'
+    , Bind(..)
+    , Where
+    , Where'
     , ConAlt(..)
-    , Binding(..), Binding'
+    , Type(..)
+    , pattern (:->)
+    , Assoc(..)
+    , VarId(..)
+    , ConId(..)
+    , Pat(..)
+    , Pat'
+    , Lit(..)
+    , Lit'
+    , Name
 
-    , _PatB, _FunB
+    -- TODO: ugh move this somewhere else later
-    , _VarP, _LitP, _ConP
+    , showsTernaryWith
 
-    -- * Trees That Grow boilerplate
+    -- * Convenience re-exports
-    -- ** Extension points
+    , Text
-    , 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 Lens.Micro
-import Data.Kind                    (Type)
+import Lens.Micro.TH
-import GHC.Generics
 import Language.Haskell.TH.Syntax   (Lift)
-import Control.Lens
+import Core.Syntax                  hiding (Lit)
-import Core.Syntax                  hiding (Lit, Type, Binding, Binding')
 import Core                         (HasRHS(..), HasLHS(..))
 ----------------------------------------------------------------------------------
 
-data RlpModule p = RlpModule
+data RlpModule b = RlpModule
     { _rlpmodName       :: Text
-    , _rlpmodProgram    :: RlpProgram p
+    , _rlpmodProgram    :: RlpProgram b
     }
 
--- | dear god.
+newtype RlpProgram b = RlpProgram [Decl RlpExpr b]
-type PhaseShow p =
+    deriving (Show, Lift)
-    ( 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]
+type RlpProgram' = RlpProgram Name
 
-progDecls :: Lens' (RlpProgram p) [Decl' p]
+-- | The @e@ parameter is used for partial results. When parsing an input, we
-progDecls = lens
+-- first parse all top-level declarations in order to extract infix[lr]
-    (\ (RlpProgram ds) -> ds)
+-- declarations. This process yields a @[Decl (Const Text) Name]@, where @Const
-    (const RlpProgram)
+-- Text@ stores the remaining unparsed function bodies. Once infixities are
+-- accounted for, we may complete the parsing task and get a proper @[Decl
+-- RlpExpr Name]@.
 
-deriving instance (PhaseShow p, Show (XRec p (Decl p))) => Show (RlpProgram p)
+data Decl e b = FunD    VarId [Pat b] (e b) (Maybe (Where b))
+              | TySigD  [VarId] Type
+              | DataD   ConId [Name] [ConAlt]
+              | InfixD  Assoc Int Name
+              deriving (Show, Lift)
 
-data RlpType p = FunConT
+type Decl' e = Decl e Name
-               | 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]
+data ConAlt = ConAlt ConId [Type]
+            deriving (Show, Lift)
 
-deriving instance (Show (IdP p), Show (XRec p (RlpType p))) => Show (ConAlt p)
+data RlpExpr b = LetE  [Bind b] (RlpExpr b)
+               | VarE  VarId
+               | ConE  ConId
+               | LamE  [Pat b] (RlpExpr b)
+               | CaseE (RlpExpr b) [(Alt b, Where b)]
+               | IfE   (RlpExpr b) (RlpExpr b) (RlpExpr b)
+               | AppE  (RlpExpr b) (RlpExpr b)
+               | LitE  (Lit b)
+               deriving (Show, Lift)
 
-data RlpExpr p = LetE'      (XLetE p) [Binding' p] (RlpExpr' p)
+type RlpExpr' = RlpExpr Name
-               | 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 Where b = [Bind b]
-type family XLetrecE p
+type Where' = [Bind Name]
-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)
+data Alt b = AltA (Pat b) (RlpExpr b)
+           deriving (Show, Lift)
 
-deriving instance (PhaseShow p) => Show (Alt p)
+data Bind b = PatB (Pat b) (RlpExpr b)
+            | FunB VarId [Pat b] (RlpExpr b)
+            deriving (Show, Lift)
 
-data Binding p = PatB (Pat' p) (RlpExpr' p)
+data VarId = NameVar Text
-               | FunB (IdP p) [Pat' p] (RlpExpr' p)
+           | SymVar Text
+           deriving (Show, Lift)
 
-type Binding' p = XRec p (Binding p)
+instance IsString VarId where
+    -- TODO: use symvar if it's an operator
+    fromString = NameVar . T.pack
 
-pattern PatB'' :: (UnXRec p) => Pat' p -> RlpExpr' p -> Binding' p
+data ConId = NameCon Text
-pattern PatB'' p e <- (unXRec -> PatB p e)
+           | SymCon Text
+           deriving (Show, Lift)
 
-deriving instance (Show (XRec p (Pat p)), Show (XRec p (RlpExpr p)), Show (IdP p)
+data Pat b = VarP VarId
-                  ) => Show (Binding p)
+           | LitP (Lit b)
+           | ConP ConId [Pat b]
+           deriving (Show, Lift)
 
-data Pat p = VarP (IdP p)
+type Pat' = Pat Name
-           | LitP (Lit' p)
-           | ConP (IdP p) [Pat' p]
 
-pattern VarP'' :: (UnXRec p) => IdP p -> Pat' p
+data Lit b = IntL Int
-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]
+           | ListL [RlpExpr b]
+           deriving (Show, Lift)
 
-deriving instance (PhaseShow p) => Show (Lit p)
+type Lit' = Lit Name
-
-type Lit' p = XRec p (Lit p)
 
 -- instance HasLHS Alt Alt Pat Pat where
 --     _lhs = lens
@@ -295,68 +142,37 @@ type Lit' p = XRec p (Lit p)
 --         (\ (AltA _ e) -> e)
 --         (\ (AltA p _) e' -> AltA p e')
 
--- makeBaseFunctor ''RlpExpr
+makeBaseFunctor ''RlpExpr
 
--- showsTernaryWith :: (Int -> x -> ShowS)
+deriving instance (Show b, Show a) => Show (RlpExprF b a)
---                  -> (Int -> y -> ShowS)
+
---                  -> (Int -> z -> ShowS)
+type RlpExprF' = RlpExprF Name
---                  -> String -> Int
+
---                  -> x -> y -> z
+-- society if derivable Show1
---                  -> ShowS
+instance (Show b) => Show1 (RlpExprF b) where
--- showsTernaryWith sa sb sc name p a b c = showParen (p > 10)
+    liftShowsPrec sp _ p m = case m of
---     $ showString name
+        (LetEF bs e)            -> showsBinaryWith showsPrec sp "LetEF" p bs e
---     . showChar ' ' . sa 11 a 
+        (VarEF n)               -> showsUnaryWith showsPrec "VarEF" p n
---     . showChar ' ' . sb 11 b
+        (ConEF n)               -> showsUnaryWith showsPrec "ConEF" p n
---     . showChar ' ' . sc 11 c
+        (LamEF bs e)            -> showsBinaryWith showsPrec sp "LamEF" p bs e
+        (CaseEF e as)           -> showsBinaryWith sp showsPrec "CaseEF" p e as
+        (IfEF a b c)            -> showsTernaryWith sp sp sp "IfEF" p a b c
+        (AppEF f x)             -> showsBinaryWith sp sp "AppEF" p f x
+        (LitEF l)               -> showsUnaryWith showsPrec "LitEF" p l
+
+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
 

src/Rlp/TH.hs

@@ -1,36 +1,30 @@
 module Rlp.TH
     ( rlpProg
-    , rlpExpr
     )
     where
 --------------------------------------------------------------------------------
 import Language.Haskell.TH
-import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Syntax   hiding (Module)
 import Language.Haskell.TH.Quote
-import Data.Text                        (Text)
+import Control.Monad                ((>=>))
-import Data.Text                        qualified as T
-import Control.Monad.IO.Class
-import Control.Monad
-
 import Compiler.RLPC
+import Data.Default.Class           (def)
+import Data.Text                    qualified as T
 import Rlp.Parse
 --------------------------------------------------------------------------------
 
 rlpProg :: QuasiQuoter
-rlpProg = mkqq parseRlpProgR
+rlpProg = QuasiQuoter
-
+    { quoteExp = qRlpProg
-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"
     }
 
+qRlpProg :: String -> Q Exp
+qRlpProg s = case parse (T.pack s) of
+    Nothing      -> error "error lol iddfk"
+    Just a       -> lift a
+    where
+        parse = execP' parseRlpProg
+

src/Rlp2Core.hs

@@ -1,236 +1,44 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE DeriveTraversable #-}
 module Rlp2Core
-    ( desugarRlpProgR
+    ( rlp2core
-    , desugarRlpProg
-    , desugarRlpExpr
     )
     where
 --------------------------------------------------------------------------------
-import Control.Monad
+import Core.Syntax                  as Core
-import Control.Monad.Writer.CPS
+import Rlp.Syntax                   as Rlp
-import Control.Monad.Utils
-import Control.Arrow
-import Control.Applicative
-import Control.Comonad
-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.HashMap.Strict          qualified as H
-import Data.Maybe                       (fromJust, fromMaybe)
+import Control.Monad.State
-import Data.Functor.Bind
+import Lens.Micro.Platform
-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)
+rlp2core :: RlpProgram' -> Program'
-
+rlp2core (RlpProgram ds) = execState (decl2core `traverse_` ds) init
--- | 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
+        init = Program
-        -- arguments
+            { _programScDefs    = mempty
-        t' = foldl TyApp (TyCon n) (TyVar . dsNameToName <$> as)
+            , _programTypeSigs  = mempty
+            }
 
--- TODO: where-binds
+type GenCoreProg b = State (Program b)
-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 GenCoreProg' = GenCoreProg Name
-type NameSupplyLabel = "expr-name-supply"
 
-exprToCore :: forall es. (NameSupply :> es) => RlpExpr RlpcPs -> Eff es Expr'
+emitTypeSig :: Name -> Type -> GenCoreProg' ()
+emitTypeSig b t = do
+    let tl :: Lens' Program' (Maybe Type)
+        tl = programTypeSigs . at b
+    tl <~ (use tl >>= \case
+        -- TODO: non-fatal error
+        Just o  -> error "(TODO: non-fatal) duplicate type sigs"
+        Nothing -> pure (Just t)
+        )
 
-exprToCore (VarE n) = pure $ Var (dsNameToName n)
+decl2core :: Decl' RlpExpr -> GenCoreProg' ()
 
-exprToCore (AppE a b) = (liftA2 App `on` exprToCore . unXRec) a b
+decl2core (DataD n as cs) = undefined
 
-exprToCore (OAppE f a b) = (liftA2 mkApp `on` exprToCore . unXRec) a b
+decl2core (TySigD vs t) = mkSig `traverse_` vs where
-    where
+    mkSig :: VarId -> GenCoreProg' ()
-        mkApp s t = (Var f `App` s) `App` t
+    mkSig (NameVar n) = emitTypeSig n 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
 

src/TI.hs

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

tst/Arith.hs

@@ -41,7 +41,6 @@ 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

tst/Core/HindleyMilnerSpec.hs

@@ -38,25 +38,9 @@ spec = do
         let e = [coreExpr|3|]
         in check' [] (TyCon "Bool") e `shouldSatisfy` isLeft
 
-    it "should infer `fix ((+#) 1)` :: Int" $
+infer' :: Context' -> Expr' -> Either TypeError Type
-        let g = [ ("fix", ("a" :-> "a") :-> "a")
+infer' g e = fmap fst . runErrorful $ infer g e
-                , ("+#", TyInt :-> TyInt :-> TyInt) ]
-            e = [coreExpr|fix ((+#) 1)|]
-        in infer' g e `shouldBe` Right TyInt
 
-    it "should infer mutually recursively defined lists" $
+check' :: Context' -> Type -> Expr' -> Either TypeError ()
-        let g = [ ("cons", TyInt :-> TyCon "IntList" :-> TyCon "IntList") ]
+check' g t e = fmap fst . runErrorful $ check g t e
-            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
 

tst/GMSpec.hs

@@ -27,22 +27,15 @@ spec = do
             in coreRes `shouldBe` arithRes
 
     describe "test programs" $ do
-        it "fac 3" $
+        it "fac 3" $ do
             resultOf Ex.fac3 `shouldBe` Just (NNum 6)
 
-        it "sum [1,2,3]" $
+        it "sum [1,2,3]" $ do
             resultOf Ex.sumList `shouldBe` Just (NNum 6)
 
-        it "k 3 ((/#) 1 0)" $
+        it "k 3 ((/#) 1 0)" $ do
             resultOf Ex.constDivZero `shouldBe` Just (NNum 3)
 
-        it "id (case ... of { ... })" $
+        it "id (case ... of { ... })" $ do
             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)
-
-