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,16 +1,15 @@
-GHC_VERSION = $(shell ghc --numeric-version)
 HAPPY = happy
-HAPPY_OPTS = -a -g -c -i/tmp/t.info
+HAPPY_OPTS = -a -g -c
 ALEX = alex
 ALEX_OPTS = -g
 
 SRC = src
-CABAL_BUILD = $(shell ./find-build.cl)
+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 $@
@@ -18,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'"
     ]
+
+dshowFlags :: RLPCIO CompilerError ()
+dshowFlags = whenFlag flagDDumpOpts do
+    ask >>= liftIO . print
+
+ddumpAST :: RLPCIO CompilerError ()
+ddumpAST = whenFlag flagDDumpAST $ forFiles_ \o f -> do
+    liftIO $ withFile f ReadMode $ \h -> do
+        s <- TIO.hGetContents h
+        case parseProg o s of
+            Right (a,_) -> hPutStrLn stderr $ show a
+            Left e -> error "todo errors lol"
+
+ddumpEval :: RLPCIO CompilerError ()
+ddumpEval = whenFlag flagDDumpEval do
+    fs <- view rlpcInputFiles
+    forM_ fs $ \f -> liftIO (TIO.readFile f) >>= doProg
+
     where
-    getLang = liftA2 (<|>)
+        doProg :: Text -> RLPCIO CompilerError ()
-        (view rlpcLanguage)
+        doProg s = ask >>= \o -> case parseProg o s of
-        -- TODO: we only check the first file lol
+            -- TODO: error handling
-        ((listToMaybe >=> inferLanguage) <$> view rlpcInputFiles)
+            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 ()
 
-driver :: RLPCIO ()
+parseProg :: RLPCOptions
-driver = undefined
+          -> Text
+          -> Either SrcError (Program', [SrcError])
+parseProg o = evalRLPC o . (lexCore >=> parseCoreProg)
 
-inferLanguage :: FilePath -> Maybe Language
+forFiles_ :: (Monad m)
-inferLanguage fp
+          => (RLPCOptions -> FilePath -> RLPCT e m a)
-    | ".rl" `isSuffixOf` fp     = Just LanguageRlp
+          -> RLPCT e m ()
-    | ".cr" `isSuffixOf` fp     = Just LanguageCore
+forFiles_ k = do
-    | otherwise                 = Nothing
+    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/factorial.cr

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

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

@@ -0,0 +1,7 @@
+fac n = case (==#) n 0 of
+    { 1 -> 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;
+

find-build.cl

@@ -1,8 +0,0 @@
-#!/usr/bin/env sbcl --script
-
-(let* ((paths (directory "dist-newstyle/build/*/*/rlp-*/build/"))
-       (n (length paths)))
-  (cond ((< 1 n) (error ">1 build directories found. run `cabal clean`."))
-        ((< n 1) (error "no build directories found. this shouldn't happen lol"))
-        (t       (format t "~A" (car paths)))))
-

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
@@ -32,31 +32,25 @@ library
                     , Core.HindleyMilner
                     , Control.Monad.Errorful
                     , Rlp.Syntax
-                    , Rlp.Syntax.Backstage
-                    , Rlp.Syntax.Types
                     -- , Rlp.Parse.Decls
                     , Rlp.Parse
                     , Rlp.Parse.Associate
                     , Rlp.Lex
                     , Rlp.Parse.Types
                     , Rlp.TH
-                    , Compiler.Types
+
-                    , Data.Heap
+    other-modules:    Data.Heap
                     , Data.Pretty
                     , Core.Parse
-                    , Core.Parse.Types
                     , Core.Lex
                     , Core2Core
                     , Rlp2Core
                     , Control.Monad.Utils
-                    , Misc
-                    , Misc.Lift1
-                    , Core.SystemF
 
     build-tool-depends: happy:happy, alex:alex
 
     -- other-extensions:
-    build-depends:    base >=4.17 && <4.20
+    build-depends:    base ^>=4.18.0.0
                     -- required for happy
                     , array >= 0.5.5 && < 0.6
                     , containers >= 0.6.7 && < 0.7
@@ -66,49 +60,34 @@ library
                     , 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.2
+                    , text >= 2.0.2 && < 2.1
+                    , megaparsec >= 9.6.1 && < 9.7
+                    , microlens >= 0.4.13 && < 0.5
+                    , microlens-mtl >= 0.2.0 && < 0.3
+                    , microlens-platform >= 0.4.3 && < 0.5
+                    , microlens-th >= 0.4.3 && < 0.5
                     , unordered-containers >= 0.2.20 && < 0.3
                     , recursion-schemes >= 5.2.2 && < 5.3
                     , data-fix >= 0.3.2 && < 0.4
                     , utf8-string >= 1.0.2 && < 1.1
                     , extra >= 1.7.0 && < 2
-                    , semigroupoids >=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
-                    , free >=5.2
-                    , bifunctors >=5.2
 
     hs-source-dirs:   src
     default-language: GHC2021
 
-    default-extensions:
-        OverloadedStrings
-        TypeFamilies
-        LambdaCase
-        ViewPatterns
-        DataKinds
-        DerivingVia
-        StandaloneDeriving
-        DerivingStrategies
-        BlockArguments
-
 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.2
 
     hs-source-dirs:   app
     default-language: GHC2021
@@ -125,10 +104,8 @@ test-suite rlp-test
                  , QuickCheck
                  , hspec            ==2.*
                  , microlens
-                 , lens >=5.2.3 && <6.0
     other-modules: Arith
                  , GMSpec
                  , Core.HindleyMilnerSpec
-                 , Compiler.TypesSpec
     build-tool-depends: hspec-discover:hspec-discover
 

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,60 +8,39 @@ 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
-    , makeItPretty, makeItPretty'
     )
     where
 ----------------------------------------------------------------------------------
 import Core.Lex
 import Core.Parse
 import Core.HindleyMilner
-import Core.Syntax
+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
-import Data.Pretty
 ----------------------------------------------------------------------------------
 
-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
-
-justLexCore :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
-justLexCore s = lexCoreR (T.pack s)
-              & mapped . each %~ extract
              & rlpcToEither
 
-justParseCore :: String -> Either [MsgEnvelope RlpcError] (Program Var)
+justParseSrc :: String -> Either RlpcError Program'
-justParseCore s = parse (T.pack s)
+justParseSrc s = parse (T.pack s)
                & rlpcToEither
-    where parse = lexCoreR @Identity >=> parseCoreProgR
+    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
     where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR
 
-makeItPretty :: (Pretty a) => Either e a -> Either e Doc
+rlpcToEither :: RLPC e a -> Either e a
-makeItPretty = fmap pretty
+rlpcToEither = evalRLPC def >>> fmap fst
-
-makeItPretty' :: (Pretty (WithTerseBinds a)) => Either e a -> Either e Doc
-makeItPretty' = fmap (pretty . WithTerseBinds)
-
-rlpcToEither :: RLPC a -> Either [MsgEnvelope RlpcError] a
-rlpcToEither r = case evalRLPC def r of
-    (Just a,   _) -> Right a
-    (Nothing, es) -> Left es
 

src/Compiler/RLPC.hs

@@ -10,119 +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, liftMaybe, 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
 
-liftMaybe :: (Monad m) => Maybe a -> RLPCT m a
+evalRLPCIO :: (Exception e)
-liftMaybe m = RLPCT . lift . ErrorfulT . pure $ (m, [])
+           => RLPCOptions
-
+           -> RLPCIO e a
-hoistRlpcT :: (forall a. m a -> n a)
+           -> IO (a, [e])
-         -> RLPCT m a -> RLPCT n a
+evalRLPCIO o m = do
-hoistRlpcT f rma = RLPCT $ ReaderT $ \opt ->
+    m' <- evalRLPCT o m
-    ErrorfulT $ f $ evalRLPCT opt rma
+    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
@@ -130,126 +113,69 @@ data RLPCOptions = RLPCOptions
 data Evaluator = EvaluatorGM | EvaluatorTI
     deriving Show
 
-data Language = LanguageRlp | LanguageCore
+data Severity = Error
+              | 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,84 +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(..)
-
-    -- * Common error messages
-    , undefinedVariableErr
     )
     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
-   , _msgDiagnostic  :: e
-   , _msgSeverity    :: Severity
-   }
-   deriving (Functor, Show)
-
-newtype RlpcError = Text [Text]
     deriving Show
 
-instance IsString RlpcError where
+class IsRlpcError a where
-    fromString = Text . pure . T.pack
+    liftRlpcErr :: a -> RlpcError
-
-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
-    }
-
-undefinedVariableErr :: Text -> RlpcError
-undefinedVariableErr n = Text
-    [ "Variable not in scope: `" <> n <> "'."
-    ]
 

src/Compiler/Types.hs

@@ -1,230 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE UndecidableInstances, QuantifiedConstraints #-}
-{-# LANGUAGE PatternSynonyms #-}
-module Compiler.Types
-    ( SrcSpan(..)
-    , srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen
-    , pattern (:<$)
-    , Located(..)
-    , HasLocation(..)
-    , _Located
-    , nolo, nolo'
-
-    , (<~>), (~>), (~~>), (<~~)
-
-    , comb2, comb3, comb4
-    , lochead
-
-    -- * Re-exports
-    , Comonad(extract)
-    , Apply
-    , Bind
-    )
-    where
---------------------------------------------------------------------------------
-import Language.Haskell.TH.Syntax   (Lift)
-
-import Control.Comonad
-import Control.Comonad.Cofree
-import Control.Comonad.Trans.Cofree qualified as Trans.Cofree
-import Control.Comonad.Trans.Cofree (CofreeF)
-import Data.Functor.Apply
-import Data.Functor.Bind
-import Data.Functor.Compose
-import Data.Functor.Foldable
-import Data.Semigroup.Foldable
-import Data.Fix                     hiding (cata, ana)
-import Data.Kind
-import Control.Lens                 hiding ((<<~), (:<))
-
-import Data.List.NonEmpty           (NonEmpty)
-import Data.Function                (on)
---------------------------------------------------------------------------------
-
--- | Token wrapped with a span (line, column, absolute, length)
-data Located a = Located SrcSpan a
-    deriving (Show, Lift, Functor)
-
-data Floc f = Floc SrcSpan (f (Floc f))
-
-pattern (:<$) :: a -> f b -> Trans.Cofree.CofreeF f a b
-pattern a :<$ b = a Trans.Cofree.:< b
-
-(<~>) :: a -> b -> SrcSpan
-(<~>) = undefined
-
-infixl 5 <~>
-
--- (~>) :: (CanGet k, CanSet k', HasLocation k a, HasLocation k' b)
---      => a -> b -> b
--- a ~> b = 
-(~>) = undefined
-
-infixl 4 ~>
-
--- (~~>) :: (CanGet k, HasLocation k a, CanSet k', HasLocation k' b)
---       => (a -> b) -> a -> b
--- (~~>) :: (f SrcSpan -> b) -> Cofree f SrcSpan -> Cofree f SrcSpan
--- f ~~> (ss :< as) = ss :< f as
-(~~>) = undefined
-
-infixl 3 ~~>
-
--- (<~~) :: (GetLocation a, HasLocation b) => (a -> b) -> a -> b
--- a <~~ b = a b & location <>~ srcspan b
-(<~~) = undefined
-
-infixr 2 <~~
-
-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, Eq, 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)
-
-nolo' :: f (Cofree f SrcSpan) -> Cofree f SrcSpan
-nolo' as = SrcSpan 0 0 0 0 :< as
-
-instance Semigroup SrcSpan where
-    -- multiple identities? what are the consequences of this...?
-    SrcSpan _ _ _ 0 <> SrcSpan l c a s = SrcSpan l c a s
-    SrcSpan l c a s <> SrcSpan _ _ _ 0 = SrcSpan l c a s
-
-    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 + sb - aa)
-            GT -> max sb (aa + sa - ab)
-
---------------------------------------------------------------------------------
-
-data GetOrSet = Get | Set | GetSet
-
-class CanGet (k :: GetOrSet)
-class CanSet (k :: GetOrSet) where
-
-instance CanGet Get
-instance CanGet GetSet
-instance CanSet Set
-instance CanSet GetSet
-
-data GetSetLens (k :: GetOrSet) s t a b :: Type where
-    Getter_      :: (s -> a)             -> GetSetLens Get s t a b
-    Setter_      :: ((a -> b) -> s -> t) -> GetSetLens Set s t a b
-    GetterSetter :: (CanGet k', CanSet k')
-                 => (s -> a) -> (s -> b -> t) -> GetSetLens k' s t a b
-
-type GetSetLens' k s a = GetSetLens k s s a a
-
-class HasLocation k s | s -> k where
-    -- location :: (Access k f, Functor f) => LensLike' f s SrcSpan
-    getSetLocation :: GetSetLens' k s SrcSpan
-
-type family Access (k :: GetOrSet) f where
-    Access GetSet f = Functor f
-    Access Set f = Settable f
-    Access Get f = (Functor f, Contravariant f)
-
-instance HasLocation GetSet SrcSpan where
-    getSetLocation = GetterSetter id (flip const)
-    -- location = fromGetSetLens getSetLocation
-
-instance (CanSet k, HasLocation k a) => HasLocation Set (r -> a) where
-    getSetLocation = Setter_ $ \ss ra r -> ra r & fromSet getSetLocation %~ ss
-    -- location = fromSet getSetLocation
-
-instance (HasLocation k a) => HasLocation k (Cofree f a) where
-    getSetLocation = case getSetLocation @_ @a of
-        Getter_ sa -> Getter_ $ \ (s :< _) -> sa s
-        Setter_ abst -> Setter_ $ \ss (s :< as) -> abst ss s :< as
-        GetterSetter sa sbt -> GetterSetter sa' sbt' where
-            sa' (s :< _) = sa s
-            sbt' (s :< as) b = sbt s b :< as
-
-location :: (Access k f, Functor f, HasLocation k s)
-         => LensLike' f s SrcSpan
-location = fromGetSetLens getSetLocation
-
-fromGetSetLens :: (Access k f, Functor f) => GetSetLens' k s a -> LensLike' f s a
-fromGetSetLens gsl = case gsl of
-    Getter_ sa          -> to sa
-    Setter_ abst        -> setting abst
-    GetterSetter sa sbt -> lens sa sbt
-
-fromGet :: (CanGet k) => GetSetLens k s t a b -> Getter s a
-fromGet (Getter_ sa)        = to sa
-fromGet (GetterSetter sa _) = to sa
-
-fromSet :: (CanSet k) => GetSetLens k s t a b -> Setter s t a b
-fromSet (Setter_ abst)        = setting abst
-fromSet (GetterSetter sa sbt) = lens sa sbt
-
-fromGetSet :: (CanGet k, CanSet k) => GetSetLens k s t a b -> Lens s t a b
-fromGetSet (GetterSetter sa sbt) = lens sa sbt
-
---------------------------------------------------------------------------------
-
-comb2 :: (Functor f, Semigroup m)
-      => (Cofree f m -> Cofree f m -> f (Cofree f m))
-      -> Cofree f m -> Cofree f m -> Cofree f m
-comb2 f a b = ss :< f a b
-    where ss = a `mextract` b
-
-comb3 :: (Functor f, Semigroup m)
-      => (Cofree f m -> Cofree f m -> Cofree f m -> f (Cofree f m))
-      -> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m
-comb3 f a b c = ss :< f a b c
-    where ss = a `mapply` b `mextract` c
-
-comb4 :: (Functor f, Semigroup m)
-      => (Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m
-         -> f (Cofree f m))
-      -> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m
-comb4 f a b c d = ss :< f a b c d
-    where ss = a `mapply` b `mapply` c `mextract` d
-
-mextract :: (Comonad w, Semigroup m) => w m -> w m -> m
-mextract = (<>) `on` extract
-
-mapply :: (Comonad w, Semigroup m) => w m -> w m -> w m
-mapply a b = b <&> (<> extract a)
-
-lochead :: Functor f
-        => (f SrcSpan -> f SrcSpan) -> Located (f SrcSpan) -> Cofree f SrcSpan
-lochead afs (Located ss fss) = ss :< unwrap (lochead afs $ Located ss fss)
-
---------------------------------------------------------------------------------
-
-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 ()
     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.hs

@@ -1,5 +1,6 @@
 module Core
     ( module Core.Syntax
+    , parseCore
     , parseCoreProg
     , parseCoreExpr
     , lexCore

src/Core/Examples.hs

@@ -4,16 +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
 ----------------------------------------------------------------------------------
 
-letRecExample = undefined
-
-{--
-
 letrecExample :: Program'
 letrecExample = [coreProg|
     pair x y f = f x y;
@@ -73,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'
@@ -93,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;
 |]
 
@@ -139,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;
@@ -167,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;
     |]
@@ -176,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'
@@ -184,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
@@ -239,5 +216,3 @@ namedConsCase = [coreProg|
 --         , ScDef "Cons" [] $ Con 2 2
 --         ]
 
---}
-

src/Core/HindleyMilner.hs

@@ -3,44 +3,31 @@ 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
 ----------------------------------------------------------------------------------
 
-infer = undefined
-check = undefined
-checkCoreProg = undefined
-checkCoreProgR = undefined
-checkCoreExprR = undefined
-
 -- | Annotated typing context -- I have a feeling we're going to want this in the
 -- future.
 type Context b = [(b, Type)]
@@ -48,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
@@ -59,28 +48,16 @@ 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
 --
@@ -111,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.
 --
@@ -170,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'
@@ -273,15 +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>
@@ -78,7 +74,7 @@ rlp :-
     "{"                     { constTok TokenLBrace }
     "}"                     { constTok TokenRBrace }
     ";"                     { constTok TokenSemicolon }
-    ":"                     { constTok TokenHasType }
+    "::"                    { constTok TokenHasType }
     "@"                     { constTok TokenTypeApp }
     "{-#"                   { constTok TokenLPragma `andBegin` pragma }
 
@@ -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,33 +164,35 @@ 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
 
 data ParseError = ParErrLexical String
@@ -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,267 +3,235 @@
 Module : Core.Parse
 Description : Parser for the Core language
 -}
-{-# LANGUAGE OverloadedStrings, ViewPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Core.Parse
-    ( parseCoreExpr
+    ( parseCore
-    , parseCoreExprR
+    , parseCoreExpr
     , 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
-
-import Core.Parse.Types
 }
 
+%name parseCore Module
 %name parseCoreExpr StandaloneExpr
 %name parseCoreProg StandaloneProgram
 %tokentype { Located CoreToken }
 %error { parseError }
-%monad { P }
+%monad { RLPC SrcError }
 
 %token
-      let             { Located _ TokenLet }
+      let             { Located _ _ _ TokenLet }
-      letrec          { Located _ TokenLetrec }
+      letrec          { Located _ _ _ TokenLetrec }
-      where           { Located _ TokenWhere }
+      module          { Located _ _ _ TokenModule }
-      case            { Located _ TokenCase }
+      where           { Located _ _ _ TokenWhere }
-      of              { Located _ TokenOf }
+      case            { Located _ _ _ TokenCase }
-      pack            { Located _ TokenPack } -- temp
+      of              { Located _ _ _ TokenOf }
-      in              { Located _ TokenIn }
+      pack            { Located _ _ _ TokenPack } -- temp
-      litint          { Located _ (TokenLitInt $$) }
+      in              { Located _ _ _ TokenIn }
-      varname         { Located _ (TokenVarName $$) }
+      litint          { Located _ _ _ (TokenLitInt $$) }
-      varsym          { Located _ (TokenVarSym $$) }
+      varname         { Located _ _ _ (TokenVarName $$) }
-      conname         { Located _ (TokenConName $$) }
+      varsym          { Located _ _ _ (TokenVarSym $$) }
-      consym          { Located _ (TokenConSym $$) }
+      conname         { Located _ _ _ (TokenConName $$) }
-      alttag          { Located _ (TokenAltTag $$) }
+      consym          { Located _ _ _ (TokenConSym $$) }
-      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 }
-
-%right '->'
 
 %%
 
+Module          :: { Module Name }
+Module          : module conname where Program Eof { Module (Just ($2, [])) $4 }
+                | Program Eof                      { Module Nothing $1 }
+
 Eof             :: { () }
 Eof             : eof           { () }
                 | error         { () }
 
-StandaloneProgram :: { Program Var }
+StandaloneProgram :: { Program Name }
 StandaloneProgram : Program eof                 { $1 }
 
-Program         :: { Program Var }
+Program         :: { Program Name }
-                : TypedScDef ';' Program    { $3 & insTypeSig (fst $1)
+Program         : ScTypeSig ';' Program         { insTypeSig $1 $3 }
-                                                 & insScDef (snd $1) }
+                | ScTypeSig OptSemi             { singletonTypeSig $1 }
-                | TypedScDef OptSemi        { mempty & insTypeSig (fst $1)
+                | ScDef     ';' Program         { insScDef $1 $3 }
-                                                     & insScDef (snd $1) }
+                | ScDef     OptSemi             { singletonScDef $1 }
-                | TLPragma Program          {% doTLPragma $1 $2 }
-                | TLPragma                  {% doTLPragma $1 mempty }
-
-TLPragma        :: { Pragma }
-                : '{-#' Words '#-}'             { Pragma $2 }
-
-Words           :: { [Text] }
-                : Words word                    { $1 `snoc` $2 }
-                | word                          { [$1] }
 
 OptSemi         :: { () }
 OptSemi         : ';'                           { () }
                 | {- epsilon -}                 { () }
 
 ScTypeSig       :: { (Name, Type) }
-ScTypeSig       : Id ':' Type                   { ($1, $3) }
+ScTypeSig       : Var '::' Type                 { ($1,$3) }
 
-TypedScDef      :: { (Var, ScDef Var) }
+ScDefs          :: { [ScDef Name] }
-                : Id ':' Type ';' Id ParList '=' Expr
+ScDefs          : ScDef ';' ScDefs              { $1 : $3 }
-                            { (MkVar $1 $3, mkTypedScDef $1 $3 $5 $6 $8) }
+                | ScDef ';'                     { [$1] }
+                | ScDef                         { [$1] }
+                | {- epsilon -}                 { [] }
 
--- ScDefs          :: { [ScDef PsName] }
+ScDef           :: { ScDef Name }
--- ScDefs          : ScDef ';' ScDefs              { $1 : $3 }
+ScDef           : Var ParList '=' Expr          { ScDef $1 $2 $4 }
---                 | ScDef ';'                     { [$1] }
---                 | ScDef                         { [$1] }
--- 
--- ScDef           :: { ScDef PsName }
--- ScDef           : Id ParList '=' Expr   { ScDef (Left $1) $2
---                                                 ($4 & binders %~ Right) }
 
 Type            :: { Type }
-                : TypeApp '->' TypeApp              { $1 :-> $3 }
+Type            : Type1                         { $1 }
-                | TypeApp                         { $1 }
-
-TypeApp         :: { Type }
-                : TypeApp Type1                 { TyApp $1 $2 }
-                | Type1                         { $1 }
-
--- do we want to allow symbolic names for tyvars and tycons?
 
 Type1           :: { Type }
 Type1           : '(' Type ')'                  { $2 }
+                | Type1 '->' Type               { $1 :-> $3 }
+                -- do we want to allow symbolic names for tyvars and tycons?
                 | varname                       { TyVar $1 }
-                | conname                       { if $1 == "Type"
+                | conname                       { TyCon $1 }
-                                                    then TyKindType else TyCon $1 }
 
 ParList         :: { [Name] }
-ParList      : varname ParList            { $1 : $2 }
+ParList         : Var ParList                   { $1 : $2 }
                 | {- epsilon -}                 { [] }
 
-StandaloneExpr  :: { Expr Var }
+StandaloneExpr  :: { Expr Name }
 StandaloneExpr  : Expr eof                      { $1 }
 
-Expr            :: { Expr Var }
+Expr            :: { Expr Name }
 Expr            : LetExpr                       { $1 }
                 | 'λ' Binders '->' Expr         { Lam $2 $4 }
                 | Application                   { $1 }
                 | CaseExpr                      { $1 }
                 | Expr1                         { $1 }
 
-LetExpr         :: { Expr Var }
+LetExpr         :: { Expr Name }
 LetExpr         : let    '{'   Bindings '}'    in Expr { Let NonRec $3 $6 }
                 | letrec '{'   Bindings '}'    in Expr { Let Rec $3 $6 }
 
-Binders         :: { [Var] }
+Binders         :: { [Name] }
 Binders         : Var Binders                  { $1 : $2 }
                 | Var                          { [$1] }
 
-Application     :: { Expr Var }
+Application     :: { Expr Name }
-Application     : Application AppArg           { App $1 $2 }
+Application     : Expr1 AppArgs                { foldl' App $1 $2 }
-                | Expr1       AppArg           { App $1 $2 }
 
-AppArg          :: { Expr Var }
+AppArgs         :: { [Expr Name] }
-                : '@' Type1                     { Type $2 }
+AppArgs         : Expr1 AppArgs                 { $1 : $2 }
-                | Expr1                         { $1 }
+                | Expr1                         { [$1] }
 
-CaseExpr        :: { Expr Var }
+CaseExpr        :: { Expr Name }
 CaseExpr        : case Expr of '{' Alters '}'   { Case $2 $5 }
 
-Alters          :: { [Alter Var] }
+Alters          :: { [Alter Name] }
 Alters          : Alter ';' Alters              { $1 : $3 }
                 | Alter ';'                     { [$1] }
                 | Alter                         { [$1] }
 
-Alter           :: { Alter Var }
+Alter           :: { Alter Name }
-Alter           : alttag  AltParList '->' Expr     { Alter (AltTag  $1) $2 $4 }
+Alter           : litint ParList '->' Expr      { Alter (AltData $1) $2 $4 }
-                | conname AltParList '->' Expr     { Alter (AltData $1) $2 $4 }
 
-AltParList      :: { [Var] }
+Expr1           :: { Expr Name }
-                : Var AltParList                { $1 : $2 }
-                | {- epsilon -}                 { [] }
-
-Expr1           :: { Expr Var }
 Expr1           : litint                        { Lit $ IntL $1 }
                 | Id                            { Var $1 }
                 | PackCon                       { $1 }
+                | ExprPragma                    { $1 }
                 | '(' Expr ')'                  { $2 }
 
-PackCon         :: { Expr Var }
+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 }
 
-Bindings        :: { [Binding Var] }
+Bindings        :: { [Binding Name] }
 Bindings        : Binding ';' Bindings          { $1 : $3 }
                 | Binding ';'                   { [$1] }
                 | Binding                       { [$1] }
 
-Binding         :: { Binding Var }
+Binding         :: { Binding Name }
 Binding         : Var '=' Expr                  { $1 := $3 }
 
 Id              :: { Name }
-                : varname                           { $1 }
+Id              : Var                                { $1 }
-                | conname                           { $1 }
+                | Con                                { $1 }
 
-Var             :: { Var }
+Var             :: { Name }
-Var             : '(' varname ':' Type ')'          { MkVar $2 $4 }
+Var             : '(' varsym ')'                    { $2 }
+                | varname                           { $1 }
+
+Con             :: { Name }
+Con             : '(' consym ')'                    { $2 }
+                | conname                           { $1 }
 
 {
 
-parseError :: [Located CoreToken] -> P 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
+            }
 
-exprPragma :: [String] -> RLPC (Expr Var)
+parseTmp :: IO (Module Name)
-exprPragma ("AST" : e) = undefined
+parseTmp = do
-exprPragma _           = undefined
+    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)
 
-astPragma :: [String] -> RLPC (Expr Var)
+exprPragma :: [String] -> RLPC SrcError (Expr Name)
-astPragma _ = undefined
+exprPragma ("AST" : e) = astPragma e
+exprPragma _           = addFatal err
+    where err = SrcError
+            { _errSpan       = (0,0,0) -- TODO: span
+            , _errSeverity   = Warning
+            , _errDiagnostic = SrcErrUnknownPragma "" -- TODO: missing pragma
+            }
 
--- insTypeSig :: (Hashable b) => (b, Type) -> Program b -> Program b
+astPragma :: [String] -> RLPC SrcError (Expr Name)
--- insTypeSig ts = programTypeSigs %~ uncurry H.insert ts
+astPragma = pure . read . unwords
 
-insTypeSig :: Var -> Program Var -> Program Var
+insTypeSig :: (Hashable b) => (b, Type) -> Program b -> Program b
-insTypeSig w@(MkVar _ t) = programTypeSigs %~ H.insert w t
+insTypeSig ts = programTypeSigs %~ uncurry H.insert ts
 
--- singletonTypeSig :: (Hashable b) => (b, Type) -> Program b
+singletonTypeSig :: (Hashable b) => (b, Type) -> Program b
--- singletonTypeSig ts = insTypeSig ts mempty
+singletonTypeSig ts = insTypeSig ts mempty
 
 insScDef :: (Hashable b) => ScDef b -> Program b -> Program b
 insScDef sc = programScDefs %~ (sc:)
 
--- singletonScDef :: (Hashable b) => ScDef b -> Program b
+singletonScDef :: (Hashable b) => ScDef b -> Program b
--- singletonScDef sc = insScDef sc mempty
+singletonScDef sc = insScDef sc mempty
 
-parseCoreExprR :: (Monad m) => [Located CoreToken] -> RLPCT m (Expr Var)
+parseCoreProgR :: [Located CoreToken] -> RLPC RlpcError Program'
-parseCoreExprR = liftMaybe . snd . flip runP def . parseCoreExpr
+parseCoreProgR = liftRlpcErrs . parseCoreProg
-
-parseCoreProgR :: forall m. (Monad m)
-               => [Located CoreToken] -> RLPCT m (Program Var)
-parseCoreProgR s = do
-    let p = runP (parseCoreProg s) def
-    case p of
-        (st, Just a) -> do
-            ddumpast a
-            pure a
-  where
-    ddumpast :: Show a => Program a -> RLPCT m (Program a)
-    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 Var -> P (Program Var)
--- 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/Parse/Types.hs

@@ -1,62 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-module Core.Parse.Types
-    ( P(..)
-    , psTyVars
-    , def
-    , PsName
-    , mkTypedScDef
-    )
-    where
---------------------------------------------------------------------------------
-import Control.Applicative
-import Control.Monad
-import Control.Monad.State
-import Data.Default
-import Data.Maybe
-import Data.Tuple               (swap)
-
-import Control.Lens
-
-import Core.Syntax
---------------------------------------------------------------------------------
-
-newtype P a = P { runP :: PState -> (PState, Maybe a) }
-    deriving Functor
-
-data PState = PState
-    { _psTyVars :: [(Name, Kind)]
-    }
-
-instance Applicative P where
-    pure a = P (, Just a)
-
-    P pf <*> P pa = P \st ->
-        let (st',mf) = pf st
-            (st'',ma) = pa st'
-        in (st'', mf <*> ma)
-
-instance Monad P where
-    P pa >>= k = P \st ->
-        let (st',ma) = pa st
-        in case ma of
-            Just a -> runP (k a) st'
-            Nothing -> (st', Nothing)
-
-instance MonadState PState P where
-    state = P . fmap ((_2 %~ Just) . review swapped)
-
-instance Default PState where
-    def = undefined
-
-makeLenses ''PState
-
-type PsName = Either Name Var
-
---------------------------------------------------------------------------------
-
-mkTypedScDef :: Name -> Type -> Name -> [Name] -> Expr Var -> ScDef Var
-mkTypedScDef nt tt n as e | nt == n = ScDef n' as' e
-    where
-        n' = MkVar n tt
-        as' = zipWith MkVar as (tt ^.. arrowStops)
-

src/Core/Syntax.hs

@@ -5,40 +5,34 @@ Description : Core ASTs and the like
 {-# LANGUAGE PatternSynonyms, OverloadedStrings #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE TemplateHaskell #-}
--- for recursion-schemes
-{-# LANGUAGE DeriveTraversable, TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE QuantifiedConstraints #-}
 module Core.Syntax
-    (
+    ( Expr(..)
-    -- * Core AST
+    , Type(..)
-      ExprF(..), ExprF'
+    , pattern TyInt
-    , ScDef(..), ScDef'
+    , Lit(..)
-    , Program(..), Program'
+    , pattern (:$)
-    , Type(..), Kind, pattern (:->), pattern TyInt
+    , pattern (:@)
-    , AlterF(..), Alter(..), Alter', AltCon(..)
+    , pattern (:->)
-    , pattern Binding, pattern Alter
+    , Binding(..)
-    , Rec(..), Lit(..)
+    , AltCon(..)
-    , Pragma(..)
+    , pattern (:=)
-    -- ** Variables and identifiers
+    , Rec(..)
-    , Name, Var(..), Tag, pattern (:^)
+    , Alter(..)
-    , Binding, BindingF(..), pattern (:=), pattern (:$)
+    , Name
-    , type Binding'
+    , Tag
-    -- ** Working with the fixed point of ExprF
+    , ScDef(..)
-    , Expr, Expr'
+    , Module(..)
-    , pattern Con, pattern Var, pattern App, pattern Lam, pattern Let
+    , Program(..)
-    , pattern Case, pattern Type, pattern Lit
+    , Program'
-
+    , unliftScDef
-    -- * Pretty-printing
+    , programScDefs
-    , Pretty(pretty), WithTerseBinds(..)
+    , programTypeSigs
-
+    , Expr'
-    -- * Optics
+    , ScDef'
-    , programScDefs, programTypeSigs, programDataTags
+    , Alter'
-    , formalising
+    , Binding'
-    , HasRHS(_rhs), HasLHS(_lhs)
+    , HasRHS(_rhs)
-    , _BindingF, _MkVar
+    , HasLHS(_lhs)
-    -- ** Classy optics
-    , HasBinders(..), HasArrowStops(..), HasApplicants1(..), HasApplicants(..)
     )
     where
 ----------------------------------------------------------------------------------
@@ -47,649 +41,149 @@ import Data.Pretty
 import Data.List                    (intersperse)
 import Data.Function                ((&))
 import Data.String
-import Data.HashMap.Strict          (HashMap)
 import Data.HashMap.Strict          qualified as H
 import Data.Hashable
-import Data.Foldable                (traverse_)
-import Data.Functor
-import Data.Monoid
-import Data.Functor.Classes
 import Data.Text                    qualified as T
 import Data.Char
-import Data.These
-import GHC.Generics                 (Generic, Generically(..))
-import Text.Show.Deriving
-import Data.Eq.Deriving
-import Data.Kind                    qualified
-
-import Data.Fix                     hiding (cata, ana)
-import Data.Bifunctor               (Bifunctor(..))
-import Data.Bifoldable              (bifoldr, Bifoldable(..))
-import Data.Bifunctor.TH
-import Data.Bitraversable
-import Data.Functor.Foldable
-import Data.Functor.Foldable.TH     (makeBaseFunctor)
-
 -- Lift instances for the Core quasiquoters
-import Misc
+import Language.Haskell.TH.Syntax   (Lift)
-import Misc.Lift1
+import Lens.Micro.TH                (makeLenses)
-import Control.Lens
+import Lens.Micro
 ----------------------------------------------------------------------------------
 
-data ExprF b a = VarF Name
+data Expr b = Var Name
-               | ConF Tag Int -- ^ Con Tag Arity
+            | Con Tag Int -- ^ Con Tag Arity
-               | CaseF a [AlterF b a]
+            | Case (Expr b) [Alter b]
-               | LamF [b] a
+            | Lam [b] (Expr b)
-               | LetF Rec [BindingF b a] a
+            | Let Rec [Binding b] (Expr b)
-               | AppF a a
+            | App (Expr b) (Expr b)
-               | LitF Lit
+            | Lit Lit
-               | TypeF Type
+            deriving (Show, Read, Lift)
-               deriving (Functor, Foldable, Traversable)
 
-type Expr b = Fix (ExprF b)
+deriving instance (Eq b) => Eq (Expr b)
-
-instance IsString (ExprF b a) where
-    fromString = VarF . fromString
-
-instance (IsString (f (Fix f))) => IsString (Fix f) where
-    fromString = Fix . fromString
 
 data Type = TyFun
           | TyVar Name
           | TyApp Type Type
           | TyCon Name
-          | TyForall Var Type
+          deriving (Show, Read, Lift, Eq)
-          | TyKindType
-          deriving (Show, Eq, Lift)
-
-type Kind = Type
-
--- data TyCon = MkTyCon Name Kind
---     deriving (Eq, Show, Lift)
-
-data Var = MkVar Name Type
-    deriving (Eq, Show, Lift)
-
-pattern (:^) :: Name -> Type -> Var
-pattern n :^ t = MkVar n t
-
-instance Hashable Var where
-    hashWithSalt s (MkVar n _) = hashWithSalt s n
-
-pattern Con :: Tag -> Int -> Expr b
-pattern Con t a = Fix (ConF t a)
-
-pattern Var :: Name -> Expr b
-pattern Var b = Fix (VarF b)
-
-pattern App :: Expr b -> Expr b -> Expr b
-pattern App f x = Fix (AppF f x)
-
-pattern Lam :: [b] -> Expr b -> Expr b
-pattern Lam bs e = Fix (LamF bs e)
-
-pattern Let :: Rec -> [Binding b] -> Expr b -> Expr b
-pattern Let r bs e = Fix (LetF r bs e)
-
-pattern Case :: Expr b -> [Alter b] -> Expr b
-pattern Case e as = Fix (CaseF e as)
-
-pattern Type :: Type -> Expr b
-pattern Type t = Fix (TypeF t)
-
-pattern Lit :: Lit -> Expr b
-pattern Lit t = Fix (LitF t)
 
 pattern TyInt :: Type
 pattern TyInt = TyCon "Int#"
 
-infixr 1 :->
-pattern (:->) :: Type -> Type -> Type
-pattern a :-> b = TyApp (TyApp TyFun a) b
-
-data BindingF b a = BindingF b (ExprF b a)
-    deriving (Functor, Foldable, Traversable)
-
-type Binding b = BindingF b (Fix (ExprF b))
-
-type Binding' = Binding Name
-
--- collapse = foldFix embed
-
-pattern Binding :: b -> Expr b -> Binding b
-pattern Binding k v <- BindingF k (wrapFix -> v)
-    where Binding k v = BindingF k (unwrapFix v)
-
-{-# COMPLETE (:=) #-}
-{-# COMPLETE Binding #-}
-
-infixl 1 :=
-pattern (:=) :: b -> Expr b -> Binding b
-pattern k := v = Binding k v
-
 infixl 2 :$
 pattern (:$) :: Expr b -> Expr b -> Expr b 
 pattern f :$ x = App f x
 
-data AlterF b a = AlterF AltCon [b] (ExprF b a)
+infixl 2 :@
-    deriving (Functor, Foldable, Traversable)
+pattern (:@) :: Type -> Type -> Type
+pattern f :@ x = TyApp f x
 
-pattern Alter :: AltCon -> [b] -> Expr b -> Alter b
+infixr 1 :->
-pattern Alter con bs e <- AlterF con bs (wrapFix -> e)
+pattern (:->) :: Type -> Type -> Type
-    where Alter con bs e = AlterF con bs (unwrapFix e)
+pattern a :-> b = TyApp (TyApp TyFun a) b
 
-type Alter b = AlterF b (Fix (ExprF b))
+{-# COMPLETE Binding :: Binding #-}
+{-# COMPLETE (:=) :: Binding #-}
+data Binding b = Binding b (Expr b)
+    deriving (Show, Read, Lift)
 
-type Alter' = Alter Name
+deriving instance (Eq b) => Eq (Binding b)
 
--- pattern Alter :: AltCon -> [b] -> Expr b -> Alter b
+infixl 1 :=
--- pattern Alter con bs e <- Fix (AlterF con bs (undefined -> e))
+pattern (:=) :: b -> (Expr b) -> (Binding b)
---     where Alter con bs e = Fix (AlterF con bs undefined)
+pattern k := v = Binding k v
 
-newtype Pragma = Pragma [T.Text]
+data Alter b = Alter AltCon [b] (Expr b)
+    deriving (Show, Read, Lift)
+
+deriving instance (Eq b) => Eq (Alter b)
 
 data Rec = Rec
          | NonRec
-         deriving (Show, Eq, Lift)
+         deriving (Show, Read, Eq, Lift)
 
-data AltCon = AltData Name
+data AltCon = AltData Tag
-            | AltTag Tag
             | AltLit Lit
-            | AltDefault
+            | Default
-            deriving (Show, Eq, Lift)
+            deriving (Show, Read, Eq, Lift)
 
-newtype Lit = IntL Int
+data Lit = IntL Int
-    deriving (Show, Eq, Lift)
+    deriving (Show, Read, Eq, Lift)
 
 type Name = T.Text
 type Tag = Int
 
 data ScDef b = ScDef b [b] (Expr b)
+    deriving (Show, Lift)
 
--- unliftScDef :: ScDef b -> Expr b
+unliftScDef :: ScDef b -> Expr b
--- unliftScDef (ScDef _ as e) = Lam as e
+unliftScDef (ScDef _ as e) = Lam as e
 
 data Module b = Module (Maybe (Name, [Name])) (Program b)
+    deriving (Show, Lift)
 
 data Program b = Program
     { _programScDefs   :: [ScDef b]
-    , _programTypeSigs :: HashMap b Type
+    , _programTypeSigs :: H.HashMap b Type
-    , _programDataTags :: HashMap Name (Tag, Int)
-    -- ^ map constructors to their tag and arity
     }
-    deriving (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
--- type Alter' = Alter Name
+type Alter' = Alter Name
--- type Binding' = Binding Name
+type Binding' = Binding Name
 
--- instance IsString (Expr b) where
+instance IsString (Expr b) where
---     fromString = Var . fromString
+    fromString = Var . fromString
+
+instance IsString Type where
+    fromString "" = error "IsString Type string may not be empty"
+    fromString s
+        | isUpper c     = TyCon . fromString $ s
+        | otherwise     = TyVar . fromString $ s
+        where (c:_) = s
+
+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
     _rhs :: Lens s t a b
 
-instance HasRHS (AlterF b a) (AlterF b a') (ExprF b a) (ExprF b a') where
+instance HasRHS (Alter b) (Alter b) (Expr b) (Expr b) where
     _rhs = lens
-        (\ (AlterF _ _ e) -> e)
+        (\ (Alter _ _ e) -> e)
-        (\ (AlterF t as _) e' -> AlterF t as e')
+        (\ (Alter t as _) e' -> Alter t as e')
 
 instance HasRHS (ScDef b) (ScDef b) (Expr b) (Expr b) where
     _rhs = lens
         (\ (ScDef _ _ e) -> e)
         (\ (ScDef n as _) e' -> ScDef n as e')
 
-instance HasRHS (BindingF b a) (BindingF b' a') (ExprF b a) (ExprF b' a')
+instance HasRHS (Binding b) (Binding b) (Expr b) (Expr b) where
+    _rhs = lens
+        (\ (_ := e) -> e)
+        (\ (k := _) e' -> k := e')
 
 class HasLHS s t a b | s -> a, t -> b, s b -> t, t a -> s where
     _lhs :: Lens s t a b
 
+instance HasLHS (Alter b) (Alter b) (AltCon, [b]) (AltCon, [b]) where
+    _lhs = lens
+        (\ (Alter a bs _) -> (a,bs))
+        (\ (Alter _ _ e) (a',bs') -> Alter a' bs' e)
+
 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)
-
--- | This is not a valid isomorphism for expressions containing lambdas whose
--- bodies are themselves lambdas with multiple arguments:
---
--- >>> [coreExpr|\x -> \y z -> x|] ^. from (from formalising)
--- Lam ["x"] (Lam ["y"] (Lam ["z"] (Var "x")))
--- >>> [coreExpr|\x -> \y z -> x|]
--- Lam ["x"] (Lam ["y","z"] (Var "x"))
---
--- For this reason, it's best to consider 'formalising' as if it were two
--- unrelated unidirectional getters.
-
-formalising :: Iso (Expr a) (Expr b) (Expr a) (Expr b)
-formalising = iso sa bt where
-    sa :: Expr a -> Expr a
-    sa = ana \case
-        Lam [b] e      -> LamF [b] e
-        Lam (b:bs) e   -> LamF [b] (Lam bs e)
-        Let r (b:bs) e -> LetF r [b] (Let r bs e)
-        x              -> project x
-
-    bt :: Expr b -> Expr b
-    bt = cata \case
-        LamF [b] (Lam bs e)                -> Lam (b:bs) e
-        LetF r [b] (Let r' bs e) | r == r' -> Let r (b:bs) e
-        x                                  -> embed x
-
---------------------------------------------------------------------------------
-
-newtype WithTerseBinds a = WithTerseBinds a
-
-class MakeTerse a where
-    type AsTerse a :: Data.Kind.Type
-    asTerse :: a -> AsTerse a
-
-instance MakeTerse Var where
-    type AsTerse Var = Name
-    asTerse (MkVar n _) = n
-
-instance (Hashable b, Pretty b, Pretty (AsTerse b), MakeTerse b)
-      => Pretty (WithTerseBinds (Program b)) where
-    pretty (WithTerseBinds p)
-            = (datatags <> "\n")
-          $+$ defs
-        where
-            datatags = ifoldrOf (programDataTags . ifolded) cataDataTag mempty p
-            defs = vlinesOf (programJoinedDefs . to prettyGroup) p
-
-            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 vs vs mempty
-                        . bimap (uncurry prettyTySig')
-                                (pretty . WithTerseBinds)
-                where vs = vsepTerm ";"
-
-            cataDataTag n (t,a) acc = prettyDataTag n t a $+$ acc
-
-instance (Hashable b, Pretty b) => Pretty (Program b) where
-    pretty p = (datatags <> "\n")
-           $+$ defs
-        where
-            datatags = ifoldrOf (programDataTags . ifolded) cataDataTag mempty p
-            defs = vlinesOf (programJoinedDefs . to prettyGroup) p
-
-            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 vs vs mempty
-                        . bimap (uncurry prettyTySig) pretty
-                where vs = vsepTerm ";"
-
-            cataDataTag n (t,a) acc = prettyDataTag n t a $+$ acc
-
-unionThese :: These a b -> These a b -> These a b
-unionThese (This a) (That b) = These a b
-unionThese (That b) (This a) = These a b
-unionThese (These a b) _     = These a b
-
-prettyDataTag :: (Pretty n, Pretty t, Pretty a)
-              => n -> t -> a -> Doc
-prettyDataTag n t a =
-    hsep ["{-#", "PackData", ttext n, ttext t, ttext a, "#-}"]
-
-prettyTySig :: (Pretty n, Pretty t) => n -> t -> Doc
-prettyTySig n t = hsep [ttext n, ":", pretty t]
-
-prettyTySig' :: (MakeTerse n, Pretty (AsTerse n), Pretty t) => n -> t -> Doc
-prettyTySig' n t = hsep [ttext (asTerse n), ":", pretty t]
-
--- Pretty Type
--- TyApp | appPrec   | left
--- (:->) | appPrec-1 | right
-
-instance Pretty Type where
-    prettyPrec _ (TyVar n)   = ttext n
-    prettyPrec _ TyFun       = "(->)"
-    prettyPrec _ (TyCon n)   = ttext n
-    prettyPrec p (a :-> b)   = maybeParens (p>appPrec-1) $
-        hsep [prettyPrec appPrec a, "->", prettyPrec (appPrec-1) b]
-    prettyPrec p (TyApp f x) = maybeParens (p>appPrec) $
-        prettyPrec appPrec f <+> prettyPrec appPrec1 x
-    prettyPrec p (TyForall a m) = maybeParens (p>appPrec-2) $
-        "∀" <+> (prettyPrec appPrec1 a <> ".") <+> pretty m
-    prettyPrec _ TyKindType = "Type"
-
-instance (Pretty b, Pretty (AsTerse b), MakeTerse b)
-      => Pretty (WithTerseBinds (ScDef b)) where
-    pretty (WithTerseBinds sc) = hsep [name, as, "=", hang empty 1 e]
-        where
-            name = ttext $ sc ^. _lhs . _1 . to asTerse
-            as = sc & hsepOf (_lhs . _2 . each . to asTerse . to ttext)
-            e = pretty $ sc ^. _rhs
-
-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 (f (Fix f))) => Pretty (Fix f) where
-    prettyPrec d (Fix f) = prettyPrec d f
-
--- Pretty Expr
--- LamF | appPrec1 | right
--- AppF | appPrec  | left
-
-instance (Pretty b, Pretty a) => Pretty (ExprF b a) where
-    prettyPrec _ (VarF n) = ttext n
-    prettyPrec _ (ConF t a) = "Pack{" <> (ttext t <+> ttext a) <> "}"
-    prettyPrec p (LamF bs e) = maybeParens (p>0) $
-        hsep ["λ", hsep (prettyPrec appPrec1 <$> bs), "->", pretty e]
-    prettyPrec p (LetF r bs e) = maybeParens (p>0)
-                               $ hsep [pretty r, explicitLayout bs]
-                             $+$ hsep ["in", pretty e]
-    prettyPrec p (AppF f x) = maybeParens (p>appPrec) $
-        prettyPrec appPrec f <+> prettyPrec appPrec1 x
-    prettyPrec p (LitF l) = prettyPrec p l
-    prettyPrec p (CaseF e as) = maybeParens (p>0) $
-        "case" <+> pretty e <+> "of"
-        $+$ nest 2 (explicitLayout as)
-    prettyPrec p (TypeF t) = "@" <> prettyPrec appPrec1 t
-
-instance Pretty Rec where
-    pretty Rec = "letrec"
-    pretty NonRec = "let"
-
-instance (Pretty b, Pretty a) => Pretty (AlterF b a) where
-    pretty (AlterF 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 a) => Pretty (BindingF b a) where
-    pretty (BindingF k v) = hsep [pretty k, "=", pretty v]
-
-explicitLayout :: (Pretty a) => [a] -> Doc
-explicitLayout as = vcat inner <+> "}" where
-    inner = zipWith (<+>) delims (pretty <$> as)
-    delims = "{" : repeat ";"
-
-instance Pretty Var where
-    prettyPrec p (MkVar n t) = maybeParens (p>0) $
-        hsep [pretty n, ":", pretty t]
-
---------------------------------------------------------------------------------
-
--- instance Functor Alter where
---     fmap f (Alter con bs e) = Alter con (f <$> bs) e'
---         where
---             e' = foldFix (embed . bimap' f id) e
---             bimap' = $(makeBimap ''ExprF)
-
--- instance Foldable Alter where
--- instance Traversable Alter where
--- instance Functor Binding where
--- instance Foldable Binding where
--- instance Traversable Binding where
-
-liftShowsPrecExpr :: (Show b)
-                  => (Int -> a -> ShowS)
-                  -> ([a] -> ShowS)
-                  -> Int -> ExprF b a -> ShowS
-liftShowsPrecExpr = $(makeLiftShowsPrec ''ExprF)
-
-showsPrec1Expr :: (Show b, Show a)
-               => Int -> ExprF b a -> ShowS
-showsPrec1Expr = $(makeShowsPrec1 ''ExprF)
-
-instance (Show b) => Show1 (AlterF b) where
-    liftShowsPrec sp spl d (AlterF con bs e) =
-        showsTernaryWith showsPrec showsPrec (liftShowsPrecExpr sp spl)
-                         "AlterF" d con bs e
-
-instance (Show b) => Show1 (BindingF b) where
-    liftShowsPrec sp spl d (BindingF k v) =
-        showsBinaryWith showsPrec (liftShowsPrecExpr sp spl)
-                        "BindingF" d k v
-
-instance (Show b, Show a) => Show (BindingF b a) where
-    showsPrec d (BindingF k v)
-        = showParen (d > 10)
-        $ showString "BindingF" . showChar ' '
-        . showsPrec 11 k . showChar ' '
-        . showsPrec1Expr 11 v
-
-instance (Show b, Show a) => Show (AlterF b a) where
-    showsPrec d (AlterF con bs e)
-        = showParen (d > 10)
-        $ showString "AlterF" . showChar ' '
-        . showsPrec 11 con . showChar ' '
-        . showsPrec 11 bs . showChar ' '
-        . showsPrec1Expr 11 e
-
-deriveShow1 ''ExprF
-
-deriving instance (Show b, Show a) => Show (ExprF b a)
--- deriving instance (Show b, Show a) => Show (BindingF b a)
--- deriving instance (Show b, Show a) => Show (AlterF b a)
-deriving instance Show b => Show (ScDef b)
-deriving instance Show b => Show (Program b)
-
-bimapExpr :: (b -> b') -> (a -> a')
-          -> ExprF b a -> ExprF b' a'
-bimapExpr = $(makeBimap ''ExprF)
-
-bifoldrExpr :: (b -> c -> c)
-            -> (a -> c -> c)
-            -> c -> ExprF b a -> c
-bifoldrExpr = $(makeBifoldr ''ExprF)
-
-bitraverseExpr :: Applicative f
-               => (b -> f b')
-               -> (a -> f a')
-               -> ExprF b a -> f (ExprF b' a')
-bitraverseExpr = $(makeBitraverse ''ExprF)
-
-instance Bifunctor AlterF where
-    bimap f g (AlterF con bs e) = AlterF con (f <$> bs) (bimapExpr f g e)
-
-instance Bifunctor BindingF where
-    bimap f g (BindingF k v) = BindingF (f k) (bimapExpr f g v)
-
-instance Bifoldable AlterF where
-    bifoldr f g z (AlterF con bs e) = bifoldrExpr f g z' e where
-        z' = foldr f z bs
-
-instance Bitraversable AlterF where
-    bitraverse f g (AlterF con bs e) =
-        AlterF con <$> traverse f bs <*> bitraverseExpr f g e
-
-instance Bifoldable BindingF where
-    bifoldr f g z (BindingF k v) = bifoldrExpr f g (f k z) v
-
-instance Bitraversable BindingF where
-    bitraverse f g (BindingF k v) =
-        BindingF <$> f k <*> bitraverseExpr f g v
-
-deriveBifunctor ''ExprF
-deriveBifoldable ''ExprF
-deriveBitraversable ''ExprF
-
-instance Lift b => Lift1 (ExprF b) where
-    lift1 (VarF k)      = liftCon 'VarF (lift k)
-    lift1 (AppF f x)    = liftCon2 'AppF (lift f) (lift x)
-    lift1 (LamF b e)    = liftCon2 'LamF (lift b) (lift e)
-    lift1 (LetF r bs e) = liftCon3 'LetF (lift r) (lift bs) (lift e)
-    lift1 (CaseF e as)  = liftCon2 'CaseF (lift e) (lift as)
-    lift1 (TypeF t)     = liftCon 'TypeF (lift t)
-    lift1 (LitF l)      = liftCon 'LitF (lift l)
-    lift1 (ConF t a)    = liftCon2 'ConF (lift t) (lift a)
-
-deriving instance (Lift b, Lift a) => Lift (ExprF b a)
-deriving instance (Lift b, Lift a) => Lift (BindingF b a)
-deriving instance (Lift b, Lift a) => Lift (AlterF b a)
-deriving instance Lift b => Lift (ScDef b)
-deriving instance Lift b => Lift (Program b)
-
---------------------------------------------------------------------------------
-
-class HasApplicants1 s t a b | s -> a, t -> b, s b -> t, t a -> s where
-    applicants1 :: Traversal s t a b
-
-class HasApplicants s t a b | s -> a, t -> b, s b -> t, t a -> s where
-    applicants :: Traversal s t a b
-
-instance HasApplicants1 Type Type Type Type where
-    applicants1 k (TyApp f x) = TyApp <$> applicants1 k f <*> k x
-    applicants1 k x           = k x
-
-instance HasApplicants Type Type Type Type where
-    applicants k (TyApp f x) = TyApp <$> applicants k f <*> k x
-    applicants k x           = pure x
-
--- instance HasArguments (ExprF b (Fix (ExprF b))) (ExprF b (Fix (ExprF b)))
---                        (Fix (ExprF b)) (Fix (ExprF b)) where
---     arguments k (AppF f x) = AppF <$> arguments k f <*> k x
---     arguments k x          = unwrapFix <$> k (wrapFix x)
-
--- instance HasArguments (f (Fix f)) (f (Fix f)) (Fix f) (Fix f)
---       => HasArguments (Fix f) (Fix f) (Fix f) (Fix f) where
---     arguments :: forall g. Applicative g
---                => LensLike' g (Fix f) (Fix f)
---     arguments k (Fix f) = Fix <$> arguments k f
-
--- arguments :: Traversal' (Expr b) (Expr b)
--- arguments k (App f x) = App <$> arguments k f <*> k x
--- arguments k x         = k x
-
-class HasBinders s t a b | s -> a, t -> b, s b -> t, t a -> s where
-    binders :: Traversal s t a b
-
-instance HasBinders (ScDef b) (ScDef b') b b' where
-    binders k (ScDef b as e) = ScDef <$> k b <*> traverse k as <*> binders k e
-
-instance (Hashable b, Hashable b')
-      => HasBinders (Program b) (Program b') b b' where
-    binders :: forall f. (Applicative f)
-            => LensLike f (Program b) (Program b') b b'
-    binders k p
-        = Program
-        <$> traverse (binders k) (_programScDefs p)
-        <*> (getAp . ifoldMap toSingleton $ _programTypeSigs p)
-        <*> pure (_programDataTags p)
-      where
-        toSingleton :: b -> Type -> Ap f (HashMap b' Type)
-        toSingleton b t = Ap $ (`H.singleton` t) <$> k b
-
-instance HasBinders a a' b b'
-    => HasBinders (ExprF b a) (ExprF b' a') b b' where
-    binders :: forall f. (Applicative f)
-                    => LensLike f (ExprF b a) (ExprF b' a') b b'
-    binders k = go where
-        go :: ExprF b a -> f (ExprF b' a')
-        go (LamF bs e)   = LamF <$> traverse k bs <*> binders k e
-        go (CaseF e as)  = CaseF <$> binders k e <*> eachbind as
-        go (LetF r bs e) = LetF r <$> eachbind bs <*> binders k e
-        go f             = bitraverse k (binders k) f
-
-        eachbind :: forall p. Bitraversable p => [p b a] -> f [p b' a']
-        eachbind bs = bitraverse k (binders k) `traverse` bs
-
-instance HasBinders a a b b'
-      => HasBinders (AlterF b a) (AlterF b' a) b b' where
-    binders k (AlterF con bs e) =
-        AlterF con <$> traverse k bs <*> traverseOf binders k e
-
-instance HasBinders a a b b'
-      => HasBinders (BindingF b a) (BindingF b' a) b b' where
-    binders k (BindingF b v) = BindingF <$> k b <*> binders k v
-
-instance (HasBinders (f b (Fix (f b))) (f b' (Fix (f b'))) b b')
-      => HasBinders (Fix (f b)) (Fix (f b')) b b' where
-    binders k (Fix f) = Fix <$> binders k f
-
-class HasArrowStops s t a b | s -> a, t -> b, s b -> t, t a -> s where
-    arrowStops :: Traversal s t a b
-
-instance HasArrowStops Type Type Type Type where
-    arrowStops k (s :-> t) = (:->) <$> k s <*> arrowStops k t
-    arrowStops k t = k t
-
---------------------------------------------------------------------------------
-
-liftEqExpr :: (Eq b)
-           => (a -> a' -> Bool)
-           -> ExprF b a -> ExprF b a' -> Bool
-liftEqExpr = $(makeLiftEq ''ExprF)
-
-instance (Eq b, Eq a) => Eq (BindingF b a) where
-    BindingF ka va == BindingF kb vb =
-        ka == kb && va `eq` vb
-      where eq = liftEqExpr (==)
-
-instance (Eq b, Eq a) => Eq (AlterF b a) where
-    AlterF cona bsa ea == AlterF conb bsb eb =
-        cona == conb && bsa == bsb && ea `eq` eb
-      where eq = liftEqExpr (==)
-
-instance (Eq b) => Eq1 (AlterF b) where
-    liftEq f (AlterF cona bsa ea) (AlterF conb bsb eb) =
-        cona == conb && bsa == bsb && ea `eq` eb
-      where eq = liftEqExpr f
-
-instance (Eq b) => Eq1 (BindingF b) where
-    liftEq f (BindingF ka va) (BindingF kb vb) =
-        ka == kb && va `eq` vb
-      where eq = liftEqExpr f
-
-deriveEq1 ''ExprF
-
-deriving instance (Eq b, Eq a) => Eq (ExprF b a)
-
-makePrisms ''BindingF
-makePrisms ''Var
 

src/Core/SystemF.hs

@@ -1,235 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE OverloadedLists #-}
-module Core.SystemF
-    ( lintCoreProgR
-    )
-    where
---------------------------------------------------------------------------------
-import GHC.Generics                 (Generic, Generically(..))
-import Data.HashMap.Strict          (HashMap)
-import Data.HashMap.Strict          qualified as H
-import Data.Function                (on)
-import Data.Traversable
-import Data.Foldable
-import Data.List.Extra
-import Control.Monad.Utils
-import Control.Monad
-import Data.Text                    qualified as T
-import Data.Pretty
-import Text.Printf
-
-import Control.Comonad
-import Control.Comonad.Cofree
-import Data.Fix
-import Data.Functor
-
-import Control.Lens                 hiding ((:<))
-import Control.Lens.Unsound
-
-import Compiler.RLPC
-import Compiler.RlpcError
-import Core
---------------------------------------------------------------------------------
-
-data Gamma = Gamma
-    { _gammaVars   :: HashMap Name Type
-    , _gammaTyVars :: HashMap Name Kind
-    , _gammaTyCons :: HashMap Name Kind
-    }
-    deriving (Generic)
-    deriving (Semigroup, Monoid)
-        via (Generically Gamma)
-
-makeLenses ''Gamma
-
-lintCoreProgR :: (Monad m) => Program Var -> RLPCT m (Program Name)
-lintCoreProgR = undefined
-
-lint :: Program Var -> Program Name
-lint = undefined
-
-type ET = Cofree (ExprF Var) Type
-
-type SysF = Either SystemFError
-
-data SystemFError = SystemFErrorUndefinedVariable Name
-                  | SystemFErrorKindMismatch Kind Kind
-                  | SystemFErrorCouldNotMatch Type Type
-                  deriving Show
-
-instance IsRlpcError SystemFError where
-    liftRlpcError = \case
-        SystemFErrorUndefinedVariable n ->
-            undefinedVariableErr n
-        SystemFErrorKindMismatch k k' ->
-            Text [ T.pack $ printf "Could not match kind `%s' with `%s'"
-                                   (pretty k) (pretty k')
-                 ]
-        SystemFErrorCouldNotMatch t t' ->
-            Text [ T.pack $ printf "Could not match type `%s' with `%s'"
-                                   (pretty t) (pretty t')
-                 ]
-
-justLintCoreExpr = fmap (fmap (prettyPrec appPrec1)) . lintE demoContext
-
-lintE :: Gamma -> Expr Var -> SysF ET
-lintE g = \case
-    Var n -> lookupVar g n <&> (:< VarF n)
-    Lit (IntL n) -> pure $ TyInt :< LitF (IntL n)
-
-    Type t -> kindOf g t <&> (:< TypeF t)
-
-    App f x
-        -- type application
-        | Right (TyForall (a :^ k) m :< f') <- lintE g f
-        , Right (k' :< TypeF t) <- lintE g x
-        , k == k'
-        -> pure $ subst a t m :< f'
-
-        -- value application
-        | Right fw@((s :-> t) :< _) <- lintE g f
-        , Right xw@(s' :< _) <- lintE g x
-        , s == s'
-        -> pure $ t :< AppF fw xw
-
-    Lam bs e -> do
-        e'@(t :< _) <- lintE g' e
-        pure $ foldr arrowify t bs :< LamF bs e'
-      where
-        g' = foldMap suppl bs <> g
-
-        suppl (MkVar n t)
-            | isKind t  = mempty & gammaTyVars %~ H.insert n t
-            | otherwise = mempty & gammaVars %~ H.insert n t
-
-        arrowify (MkVar n s) s'
-            | isKind s  = TyForall (n :^ s) s'
-            | otherwise = s :-> s'
-
-    Let Rec bs e -> do
-        e'@(t :< _) <- lintE g' e
-        bs' <- (uncurry checkBind . (_2 %~ wrapFix)) `traverse` binds
-        pure $ t :< LetF Rec bs' e'
-      where
-        binds = bs ^.. each . _BindingF
-        vs = binds ^.. each . _1 . _MkVar
-        g' = supplementVars vs g
-        checkBind v@(MkVar n t) e = case lintE g' e of
-            Right (t' :< e') | t == t'   -> Right (BindingF v e')
-                             | otherwise -> Left (SystemFErrorCouldNotMatch t t')
-            Left e -> Left e
-    Let NonRec bs e -> do
-        (g',bs') <- mapAccumLM checkBind g bs
-        e'@(t :< _) <- lintE g' e
-        pure $ t :< LetF NonRec bs' e'
-      where
-        checkBind :: Gamma -> BindingF Var (Expr Var)
-                  -> SysF (Gamma, BindingF Var ET)
-        checkBind g (BindingF v@(n :^ t) e) = case lintE g (wrapFix e) of
-            Right (t' :< e')
-                | t == t'   -> Right (supplementVar n t g, BindingF v e')
-                | otherwise -> Left (SystemFErrorCouldNotMatch t t')
-            Left e -> Left e
-
-    Case e as -> do
-        e'@(et :< _) <- lintE g e
-        (ts,as') <- unzip <$> checkAlt et `traverse` as
-        case allUnify ts of
-            Just err -> Left err
-            Nothing  -> pure $ head ts  :< CaseF e' as'
-      where
-        checkAlt :: Type -> Alter Var -> SysF (Type, AlterF Var ET)
-        checkAlt scrutineeType (AlterF (AltData con) bs e) = do
-            ct <- lookupVar g con
-            ct' <- foldrMOf applicants (elimForall g) ct scrutineeType
-            zipWithM_ fzip bs (ct' ^.. arrowStops)
-            (t :< e') <- lintE (supplementVars (varsToPairs bs) g) (wrapFix e)
-            pure (t, AlterF (AltData con) bs e')
-          where
-            fzip (MkVar _ t) t'
-                | t == t'   = Right ()
-                | otherwise = Left (SystemFErrorCouldNotMatch t t')
-
-allUnify :: [Type] -> Maybe SystemFError
-allUnify [] = Nothing
-allUnify [t] = Nothing
-allUnify (t:t':ts)
-    | t == t'   = allUnify ts
-    | otherwise = Just (SystemFErrorCouldNotMatch t t')
-
-elimForall :: Gamma -> Type -> Type -> SysF Type
-elimForall g t (TyForall (n :^ k) m) = do
-    k' <- kindOf g t
-    case k == k' of
-        True -> pure $ subst n t m
-        False -> Left $ SystemFErrorKindMismatch k k'
-elimForall _ m _ = pure m
- 
-varsToPairs :: [Var] -> [(Name, Type)]
-varsToPairs = toListOf (each . _MkVar)
-
-checkAgainst :: Gamma -> Var -> Expr Var -> SysF ET
-checkAgainst g v@(MkVar n t) e = case lintE g e of
-    Right e'@(t' :< _) | t == t'      -> Right e'
-                       | otherwise    -> Left (SystemFErrorCouldNotMatch t t')
-    Left a -> Left a
-
-supplementVars :: [(Name, Type)] -> Gamma -> Gamma
-supplementVars vs = gammaVars <>~ H.fromList vs
-
-supplementVar :: Name -> Type -> Gamma -> Gamma
-supplementVar n t = gammaVars %~ H.insert n t
-
-supplementTyVar :: Name -> Kind -> Gamma -> Gamma
-supplementTyVar n t = gammaTyVars %~ H.insert n t
-
-subst :: Name -> Type -> Type -> Type
-subst k v (TyVar n) | k == n = v
-subst k v (TyForall (MkVar n k') t)
-    | k /= n                 = TyForall (MkVar n k') (subst k v t)
-    | otherwise              = TyForall (MkVar n k') t
-subst k v (TyApp f x)        = (TyApp `on` subst k v) f x
-subst _ _ x                  = x
-
-isKind :: Type -> Bool
-isKind (s :-> t)  = isKind s && isKind t
-isKind TyKindType = True
-isKind _          = False
-
-kindOf :: Gamma -> Type -> SysF Kind
-kindOf g (TyVar n)  = lookupTyVar g n
-kindOf _ TyKindType = pure TyKindType
-kindOf g (TyCon n)  = lookupCon g n
-kindOf _ e          = error (show e)
-
-lookupCon :: Gamma -> Name -> SysF Kind
-lookupCon g n = case g ^. gammaTyCons . at n of
-    Just k  -> Right k
-    Nothing -> Left (SystemFErrorUndefinedVariable n)
-
-lookupVar :: Gamma -> Name -> SysF Type
-lookupVar g n = case g ^. gammaVars . at n of
-    Just t -> Right t
-    Nothing -> Left (SystemFErrorUndefinedVariable n)
-
-lookupTyVar :: Gamma -> Name -> SysF Kind
-lookupTyVar g n = case g ^. gammaTyVars . at n of
-    Just k -> Right k
-    Nothing -> Left (SystemFErrorUndefinedVariable n)
-
-demoContext :: Gamma
-demoContext = Gamma
-    { _gammaVars =
-        [ ("id", TyForall ("a" :^ TyKindType) $ TyVar "a" :-> TyVar "a")
-        , ("Just", TyForall ("a" :^ TyKindType) $
-            TyVar "a" :-> (TyCon "Maybe" `TyApp` TyVar "a"))
-        , ("Nothing", TyForall ("a" :^ TyKindType) $
-            TyCon "Maybe" `TyApp` TyVar "a")
-        ]
-    , _gammaTyVars = []
-    , _gammaTyCons =
-        [ ("Int#", TyKindType)
-        , ("Maybe", TyKindType :-> TyKindType)
-        ]
-    }
-

src/Core/TH.hs

@@ -5,8 +5,8 @@ Description : Core quasiquoters
 module Core.TH
     ( coreExpr
     , coreProg
-    -- , coreExprT
+    , coreProgT
-    -- , coreProgT
+    , core
     )
     where
 ----------------------------------------------------------------------------------
@@ -14,46 +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 = [ ("+#", TyInt :-> TyInt :-> TyInt)
---             , ("id", TyForall (MkVar "a" TyKindType) $
---                     TyVar "a" :-> TyVar "a")
---             , ("fix", TyForall (MkVar "a" TyKindType) $
---                     (TyVar "a" :-> TyVar "a") :-> TyVar "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,8 +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
 ----------------------------------------------------------------------------------
@@ -11,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
@@ -28,29 +38,36 @@ isAtomic _        = False
 
 ----------------------------------------------------------------------------------
 
-freeVariables :: Expr b -> Set b
+-- TODO: export list awareness
-freeVariables = undefined
+-- insertModule :: Module b -> Program b -> Program b
+-- insertModule (Module _ p) = programScDefs %~ (<>m)
 
--- freeVariables :: Expr' -> Set Name
+extractProgram :: Module b -> Program b
--- freeVariables = cata go
+extractProgram (Module _ p) = p
---     where
---         go :: ExprF Name (Set Name) -> Set Name
---         go (VarF k)         = S.singleton k
---         -- 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']
---                 ns = S.fromList $ bs ^.. each . _lhs
---                 -- TODO: this feels a little wrong. maybe a different scheme is
---                 -- appropriate
---                 esFree = foldMap id $ freeVariables <$> es
 
---         go (CaseF e as)     = e `S.union` asFree
+----------------------------------------------------------------------------------
---             where
+
---                 -- asFree = foldMap id $ freeVariables <$> (fmap altToLam as)
+makeBaseFunctor ''Expr
---                 asFree = foldMap (freeVariables . altToLam) as
+
---                 -- we map alts to lambdas to avoid writing a 'freeVariablesAlt'
+freeVariables :: Expr' -> Set Name
---                 altToLam (Alter _ ns e) = Lam ns e
+freeVariables = cata go
---         go (LamF bs e)      = e `S.difference` (S.fromList bs)
+    where
---         go e                = foldMap id e
+        go :: ExprF Name (Set Name) -> Set Name
+        go (VarF k)         = S.singleton k
+        -- TODO: collect free vars in rhss of bs
+        go (LetF _ bs e)    = (e `S.union` esFree) `S.difference` ns
+            where
+                es = rhssOf bs :: [Expr']
+                ns = bindersOf bs
+                -- TODO: this feels a little wrong. maybe a different scheme is
+                -- appropriate
+                esFree = foldMap id $ freeVariables <$> es
+
+        go (CaseF e as)     = e `S.union` asFree
+            where
+                asFree = foldMap id $ freeVariables <$> (fmap altToLam as)
+                -- we map alts to lambdas to avoid writing a 'freeVariablesAlt'
+                altToLam (Alter _ ns e) = Lam ns e
+        go (LamF bs e)      = e `S.difference` (S.fromList bs)
+        go e                = foldMap id e
 

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,23 +73,23 @@ floatNonStrictCases g = goE
                 altBodies = (\(Alter _ _ b) -> b) <$> as
             tell [sc]
             goE e
-            traverse_ goE altBodies
+            traverse goE altBodies
             pure e'
-        goC (App f x)           = App <$> goC f <*> goC x
+        goC (f :$ x)            = (:$) <$> goC f <*> goC x
         goC (Let r bs e)        = Let r <$> bs' <*> goE e
             where bs' = travBs goC bs
         goC (Lit l)             = pure (Lit l)
         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
         travBs :: (Expr' -> Floater Expr') -> [Binding'] -> Floater [Binding']
-        travBs c bs = undefined
+        travBs c bs = bs ^.. each . _rhs
-        -- ^ ??? what the fuck?
+                    & traverse goC
-        -- ^ 24/02/22: what is this shit lol?
+                    & const (pure bs)
 
 -- 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,91 +1,80 @@
-{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Data.Pretty
     ( Pretty(..)
-    , rpretty
+    , ISeq(..)
-    , ttext
+    , precPretty
-    -- * Pretty-printing lens combinators
+    , prettyPrint
-    , hsepOf, vsepOf
+    , prettyShow
-    , vcatOf
+    , iShow
-    , vlinesOf
+    , iBracket
-    , vsepTerm
+    , withPrec
-    , module Text.PrettyPrint
+    , bracketPrec
-    , maybeParens
-    , appPrec
-    , appPrec1
     )
     where
 ----------------------------------------------------------------------------------
-import Text.PrettyPrint             hiding ((<>))
-import Text.PrettyPrint.HughesPJ    hiding ((<>))
-import Text.Printf
 import Data.String      (IsString(..))
-import Data.Text.Lens               hiding ((:<))
-import Data.Monoid
-import Control.Lens
-
--- instances
-import Control.Comonad.Cofree
-import Data.Text                    qualified as T
 ----------------------------------------------------------------------------------
 
 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 = const pretty
+    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
 
-class (forall a. Pretty a => Pretty (f a)) => Pretty1 f where
+instance Monoid ISeq where
-    liftPrettyPrec :: (Int -> a -> Doc) -> f a -> Doc
+    mempty = INil
 
---------------------------------------------------------------------------------
+squash :: ISeq -> String
+squash a = flatten 0 [(a,0)]
 
-ttext :: Pretty t => t -> Doc
+flatten :: Int -> [(ISeq, Int)] -> String
-ttext = pretty
+flatten _ []                      = ""
+flatten c ((INil,        i) : ss) = flatten c ss
+flatten c ((IStr s,      i) : ss) = s ++ flatten (c + length s) ss
+flatten c ((IAppend r s, i) : ss) = flatten c ((r,i) : (s,i) : ss)
+flatten _ ((IBreak,      i) : ss) = '\n' : replicate i ' ' ++ flatten i ss
+flatten c ((IIndent s,   i) : ss) = flatten c ((s,c) : ss)
 
-hsepOf :: Getting (Endo Doc) s Doc -> s -> Doc
+iBracket :: ISeq -> ISeq
-hsepOf l = foldrOf l (<+>) mempty
+iBracket s = IStr "(" <> s <> IStr ")"
 
-vsepOf :: Getting (Endo Doc) s Doc -> s -> Doc
+withPrec :: Int -> ISeq -> Int -> ISeq
-vsepOf l = foldrOf l ($+$) mempty
+withPrec n s p
+    | p > n     = iBracket s
+    | otherwise =          s
 
-vcatOf :: Getting (Endo Doc) s Doc -> s -> Doc
+bracketPrec :: Int -> Int -> ISeq -> ISeq
-vcatOf l = foldrOf l ($$) mempty
+bracketPrec n p s = withPrec n s p
 
-vlinesOf :: Getting (Endo Doc) s Doc -> s -> Doc
+iShow :: (Show a) => a -> ISeq
-vlinesOf l = foldrOf l (\a b -> a $+$ "" $+$ b) mempty
+iShow = IStr . show
--- hack(?) to separate chunks with a blankline
 
-vsepTerm :: Doc -> Doc -> Doc -> Doc
+----------------------------------------------------------------------------------
-vsepTerm term a b = (a <> term) $+$ b
-
---------------------------------------------------------------------------------
-
-appPrec, appPrec1 :: Int
-appPrec  = 10
-appPrec1 = 11
-
-instance PrintfArg Doc where
-    formatArg d fmt
-        | fmtChar (vFmt 'D' fmt) == 'D' = formatString (render d) fmt'
-        | otherwise                     = errorBadFormat $ fmtChar fmt
-      where
-        fmt' = fmt { fmtChar = 's', fmtPrecision = Nothing }
 
+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/Misc.hs

@@ -1,17 +0,0 @@
-module Misc where
---------------------------------------------------------------------------------
-import Data.Functor.Classes
---------------------------------------------------------------------------------
-
-
-showsTernaryWith :: (Int -> a -> ShowS)
-                 -> (Int -> b -> ShowS)
-                 -> (Int -> c -> ShowS)
-                 -> String -> Int -> a -> b -> c -> ShowS
-showsTernaryWith sp1 sp2 sp3 name d x y z
-    = showParen (d > 10)
-    $ showString name . showChar ' '
-    . sp1 11 x . showChar ' '
-    . sp2 11 y . showChar ' '
-    . sp3 11 z
-

src/Misc/Lift1.hs

@@ -1,41 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-module Misc.Lift1
-    ( Lift1(..)
-    , liftCon, liftCon2, liftCon3
-    , Lift(..)
-    )
-    where
---------------------------------------------------------------------------------
-import Language.Haskell.TH              hiding (Type, Name)
-import Language.Haskell.TH.Syntax       hiding (Type, Name)
-import Language.Haskell.TH.Syntax       qualified as TH
-import Language.Haskell.TH.Quote
-import Data.Kind                        qualified
-import GHC.Generics
-
-import Data.Fix
---------------------------------------------------------------------------------
-
-class Lift1 (f :: Data.Kind.Type -> Data.Kind.Type) where
-    lift1 :: (Quote m, Lift t) => f t -> m Exp
-
-liftCon :: Quote m => TH.Name -> m Exp -> m Exp
-liftCon n = fmap (AppE (ConE n))
-
-liftCon2 :: Quote m => TH.Name -> m Exp -> m Exp -> m Exp
-liftCon2 n a b = do
-    a' <- a
-    b' <- b
-    pure $ ConE n `AppE` a' `AppE` b'
-
-liftCon3 :: Quote m => TH.Name -> m Exp -> m Exp -> m Exp -> m Exp
-liftCon3 n a b c = do
-    a' <- a
-    b' <- b
-    c' <- c
-    pure $ ConE n `AppE` a' `AppE` b' `AppE` c'
-
-instance Lift1 f => Lift (Fix f) where
-    lift (Fix f) = AppE (ConE 'Fix) <$> lift1 f
-
-

src/Rlp/Lex.x

@@ -7,18 +7,14 @@ module Rlp.Lex
     , RlpToken(..)
     , Located(..)
     , lexToken
-    , lexStream
-    , 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)
@@ -28,9 +24,9 @@ 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 Compiler.Types
 import Debug.Trace
 import Rlp.Parse.Types
 }
@@ -58,7 +54,6 @@ $asciisym       = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
 
 @reservedname = 
     case|data|do|import|in|let|letrec|module|of|where
-    |infixr|infixl|infix
 
 @reservedop =
     "=" | \\ | "->" | "|" | "::"
@@ -77,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>
 {
@@ -131,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 }
 }
 
@@ -157,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
@@ -180,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
@@ -206,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')
@@ -229,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)
@@ -249,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
@@ -263,25 +237,23 @@ 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 >>=)
 
 lexStream :: P [RlpToken]
-lexStream = fmap extract <$> lexStream'
+lexStream = do
-
+    t <- lexToken
-lexStream' :: P [Located RlpToken]
+    case t of
-lexStream' = lexToken >>= \case
+        Located _ TokenEOF -> pure [TokenEOF]
-    t@(Located _ TokenEOF) -> pure [t]
+        Located _ t        -> (t:) <$> lexStream
-    t        -> (t:) <$> lexStream'
 
 lexDebug :: (Located RlpToken -> P a) -> P a
 lexDebug k = do
@@ -290,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
@@ -300,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
@@ -309,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
@@ -337,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
@@ -368,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,56 +1,40 @@
 {
-{-# LANGUAGE LambdaCase, ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
 module Rlp.Parse
     ( parseRlpProg
-    , parseRlpProgR
+    , execP
-    , parseRlpExpr
+    , execP'
-    , parseRlpExprR
-    , runP'
     )
     where
-import Compiler.RlpcError
-import Compiler.RLPC
-import Control.Comonad.Cofree
 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 }
@@ -63,21 +47,14 @@ 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   :: { Program RlpcPs SrcSpan }
+StandaloneProgram   :: { RlpProgram' }
-StandaloneProgram   : layout0(Decl)         {% mkProgram $1 }
+StandaloneProgram   : '{' Decls  '}'        {% mkProgram $2 }
-
+                    | VL  DeclsV VR         {% mkProgram $2 }
-StandaloneExpr      :: { Expr' RlpcPs SrcSpan }
-                    : VL Expr VR            { $2 }
 
 VL  :: { () }
 VL  : vlbrace       { () }
@@ -86,249 +63,122 @@ VR  :: { () }
 VR  : vrbrace       { () }
     | error         { () }
 
-VS                  :: { () }
+Decls               :: { [PartialDecl'] }
-VS                  : ';'                   { () }
+Decls               : Decl ';' Decls        { $1 : $3 }
-                    | vsemi                 { () }
+                    | Decl ';'              { [$1] }
+                    | Decl                  { [$1] }
 
-Decl        :: { Decl RlpcPs SrcSpan }
+DeclsV              :: { [PartialDecl'] }
+DeclsV              : Decl VS Decls         { $1 : $3 }
+                    | Decl VS               { [$1] }
+                    | Decl                  { [$1] }
+
+VS                  :: { Located RlpToken }
+VS                  : ';'                   { $1 }
+                    | vsemi                 { $1 }
+
+Decl        :: { PartialDecl' }
             : FunDecl                   { $1 }
             | TySigDecl                 { $1 }
             | DataDecl                  { $1 }
             | InfixDecl                 { $1 }
 
-TySigDecl   :: { Decl RlpcPs SrcSpan }
+-- TODO: multiple vars
+
+TySigDecl   :: { PartialDecl' }
             : Var '::' Type             { TySigD [$1] $3 }
 
-InfixDecl   :: { Decl RlpcPs SrcSpan }
+InfixDecl   :: { PartialDecl' }
-            : InfixWord litint InfixOp  {% mkInfixD $1 ($2 ^. _litint) $3 }
+            : InfixWord litint InfixOp  {% mkInfixD $1 $2 $3 }
 
 InfixWord   :: { Assoc }
             : infixl                    { InfixL }
             | infixr                    { InfixR }
             | infix                     { Infix  }
 
-DataDecl    :: { Decl RlpcPs SrcSpan }
+DataDecl    :: { PartialDecl' }
             : data Con TyParams '=' DataCons    { DataD $2 $3 $5 }
 
-TyParams    :: { [PsName] }
+TyParams    :: { [Name] }
             : {- epsilon -}             { [] }
-            | TyParams varname          { $1 `snoc` extractName $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 $1 $2 }
 
-Type1s      :: { [Ty RlpcPs] }
+Type1s      :: { [Type] }
             : {- epsilon -}             { [] }
             | Type1s Type1              { $1 `snoc` $2 }
 
-Type1       :: { Ty RlpcPs }
+Type1       :: { Type }
             : '(' Type ')'              { $2 }
-            | conname                   { ConT (extractName $1) }
+            | conname                   { TyCon $1 }
-            | varname                   { VarT (extractName $1) }
+            | varname                   { TyVar $1 }
 
-Type        :: { Ty RlpcPs }
+Type        :: { Type }
-            : Type '->' Type            { FunT $1 $3 }
+            : Type '->' Type            { $1 :-> $3 }
-            | TypeApp                   { $1 }
+            | Type1                     { $1 }
 
-TypeApp     :: { Ty RlpcPs }
+FunDecl     :: { PartialDecl' }
-            : Type1                     { $1 }
+FunDecl     : Var Params '=' Expr       { FunD $1 $2 (Const $4) Nothing }
-            | TypeApp Type1             { AppT $1 $2 }
 
-FunDecl     :: { Decl RlpcPs SrcSpan }
+Params      :: { [Pat'] }
-FunDecl     : Var Params '=' Expr       { FunD $1 $2 $4 Nothing }
-
-Params      :: { [Pat RlpcPs] }
 Params      : {- epsilon -}             { [] }
             | Params Pat1               { $1 `snoc` $2 }
 
-Pat         :: { Pat RlpcPs }
+Pat1        :: { Pat' }
-            : Con Pat1s                 { ConP $1 $2 }
+            : Var                       { VarP $1 }
-            | Pat1                      { $1 }
-
-Pat1s       :: { [Pat RlpcPs] }
-            : Pat1s Pat1                { $1 `snoc` $2 }
-            | Pat1                      { [$1] }
-
-Pat1        :: { Pat RlpcPs }
-            : Con                       { ConP $1 [] }
-            | Var                       { VarP $1 }
             | Lit                       { LitP $1 }
-            | '(' Pat ')'               { $2 }
 
-Expr        :: { Expr' RlpcPs SrcSpan }
+Expr        :: { PartialExpr' }
-            -- infixities delayed till next release :(
+            : Expr1 varsym Expr         { Fix $ B $2 (unFix $1) (unFix $3) }
-            -- : Expr1 InfixOp Expr        { undefined }
+            | Expr1                     { $1 }
-            : AppExpr                   { $1 }
-            | TempInfixExpr             { $1 }
-            | LetExpr                   { $1 }
-            | CaseExpr                  { $1 }
 
-TempInfixExpr :: { Expr' RlpcPs SrcSpan }
+Expr1       :: { PartialExpr' }
-TempInfixExpr : Expr1 InfixOp TempInfixExpr {% tempInfixExprErr $1 $3 }
+            : '(' Expr ')'              { wrapFix . Par . unwrapFix $ $2 }
-              | Expr1 InfixOp Expr1         { nolo' $ InfixEF $2 $1 $3 }
+            | Lit                       { Fix . E $ LitEF $1 }
+            | Var                       { Fix . E $ VarEF $1 }
 
-AppExpr     :: { Expr' RlpcPs SrcSpan }
+-- TODO: happy prefers left-associativity. doing such would require adjusting
-            : Expr1                     { $1 }
+-- the code in Rlp.Parse.Associate to expect left-associative input rather than
-            | AppExpr Expr1             { comb2 AppEF $1 $2 }
+-- right.
+InfixExpr   :: { PartialExpr' }
+            : Expr1 varsym Expr         { Fix $ B $2 (unFix $1) (unFix $3) }
 
-LetExpr     :: { Expr' RlpcPs SrcSpan }
+InfixOp     :: { Name }
-            : let layout1(Binding) in Expr      { nolo' $ LetEF NonRec $2 $4 }
+            : consym                    { $1 }
-            | letrec layout1(Binding) in Expr   { nolo' $ LetEF Rec $2 $4 }
+            | varsym                    { $1 }
 
-CaseExpr    :: { Expr' RlpcPs SrcSpan }
+Lit         :: { Lit' }
-            : case Expr of layout0(Alt)     { nolo' $ CaseEF $2 $4 }
+Lit         : litint                    { IntL $1 }
 
--- TODO: where-binds
+Var         :: { VarId }
-Alt         :: { Alt' RlpcPs SrcSpan }
+Var         : varname                   { NameVar $1 }
-            : Pat '->' Expr                 { AltA $1 (view _unwrap $3) Nothing }
 
--- layout0(p : β) :: [β]
+Con         :: { ConId }
-layout0(p)  : '{' layout_list0(';',p) '}'   { $2 }
+            : conname                   { NameCon $1 }
-            | 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 SrcSpan }
-            : Pat '=' Expr              { PatB $1 (view _unwrap $3) }
-
-Expr1       :: { Expr' RlpcPs SrcSpan }
-            : '(' Expr ')'              { $2 }
-            | Lit                       { nolo' $ LitEF $1 }
-            | Var                       { case $1 of Located ss _ -> ss :< VarEF $1 }
-            | Con                       { case $1 of Located ss _ -> ss :< VarEF $1 }
-
-InfixOp     :: { PsName }
-            : consym                    { extractName $1 }
-            | varsym                    { extractName $1 }
-
--- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
-Lit         :: { Lit RlpcPs }
-            : litint                    { $1 ^. to extract
-                                              . singular _TokenLitInt
-                                              . to IntL }
-
-Var         :: { PsName }
-Var         : varname                   { $1 <&> view (singular _TokenVarName) }
-            | varsym                    { $1 <&> view (singular _TokenVarSym) }
-
-Con         :: { PsName }
-            : conname                   { $1 <&> view (singular _TokenConName) }
 
 {
 
-parseRlpProgR :: (Monad m) => Text -> RLPCT m (Program RlpcPs SrcSpan)
+mkProgram :: [PartialDecl'] -> P RlpProgram'
-parseRlpProgR s = do
+mkProgram ds = do
-    a <- liftErrorful $ pToErrorful parseRlpProg st
+    pt <- use psOpTable
-    addDebugMsg @_ @String "dump-parsed" $ show a
+    pure $ RlpProgram (associate pt <$> ds)
-    pure a
-  where
-    st = programInitState s
 
-parseRlpExprR :: (Monad m) => Text -> RLPCT m (Expr' RlpcPs SrcSpan)
+parseError :: Located RlpToken -> P a
-parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st
+parseError = error . show
-    where
-        st = programInitState s
 
-mkInfixD :: Assoc -> Int -> PsName -> P (Decl RlpcPs SrcSpan)
+mkInfixD :: Assoc -> Int -> Name -> P PartialDecl'
-mkInfixD a p ln@(Located ss n) = do
+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 $ InfixD a p ln
-
-{--
-
-parseRlpExprR :: (Monad m) => Text -> RLPCT m (Expr RlpcPs)
-parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st
-    where
-        st = programInitState s
-
-parseRlpProgR :: (Monad m) => Text -> RLPCT m (Program 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 SrcSpan] -> P (Program RlpcPs SrcSpan)
-mkProgram ds = do
-    pt <- use psOpTable
-    pure $ Program (associate pt <$> ds)
-
-intOfToken :: Located RlpToken -> Int
-intOfToken (Located _ (TokenLitInt n)) = n
-
-tempInfixExprErr :: Expr RlpcPs -> Expr 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."
-        ]
-
---}
-
-_litint :: Getter (Located RlpToken) Int
-_litint = to extract
-        . singular _TokenLitInt
-
-tempInfixExprErr :: Expr' RlpcPs SrcSpan -> Expr' RlpcPs SrcSpan -> P a
-tempInfixExprErr (a :< _) (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."
-        ]
-
-mkProgram :: [Decl RlpcPs SrcSpan] -> P (Program RlpcPs SrcSpan)
-mkProgram ds = do
-    pt <- use psOpTable
-    pure $ Program (associate pt <$> ds)
-
-extractName :: Located RlpToken -> PsName
-extractName (Located ss (TokenVarSym n)) = Located ss n
-extractName (Located ss (TokenVarName n)) = Located ss n
-extractName (Located ss (TokenConName n)) = Located ss n
-extractName (Located ss (TokenConSym n)) = Located ss n
-
-parseError :: (Located RlpToken, [String]) -> P a
-parseError ((Located ss t), exp) = addFatal $
-    errorMsg ss (RlpParErrUnexpectedToken t exp)
-
 }
-

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 a -> Decl RlpcPs a
+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,40 +1,11 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE UndecidableInstances #-}
+module Rlp.Parse.Types where
-module Rlp.Parse.Types
-    (
-    -- * Trees That Grow
-      RlpcPs
-
-    -- * Parser monad and state
-    , P(..), ParseState(..), Layout(..), OpTable, OpInfo
-    , initParseState, initAlexInput
-    , pToErrorful
-    -- ** Lenses
-    , psLayoutStack, psLexState, psInput, psOpTable
-
-    -- * Other parser types
-    , RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
-    , Located(..), PsName
-    -- ** Lenses
-    , _TokenLitInt, _TokenVarName, _TokenConName, _TokenVarSym
-    , aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
-
-    -- * Error handling
-    , MsgEnvelope(..), RlpcError(..), RlpParseError(..)
-    , addFatal, addWound, addFatalHere, addWoundHere
-    )
-    where
 --------------------------------------------------------------------------------
 import Core.Syntax                  (Name)
-import Text.Show.Deriving
 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
@@ -42,29 +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 NameP RlpcPs = PsName
-
-type PsName = Located Text
-
---------------------------------------------------------------------------------
-
-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
@@ -76,34 +30,23 @@ 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
     -- identifiers
-    | TokenVarName Text
+    | TokenVarName Name
-    | TokenConName Text
+    | TokenConName Name
-    | TokenVarSym Text
+    | TokenVarSym Name
-    | TokenConSym Text
+    | TokenConSym Name
     -- reserved words
     | TokenData
     | TokenCase
     | TokenOf
     | TokenLet
-    | TokenLetrec
     | TokenIn
     | TokenInfixL
     | TokenInfixR
@@ -121,71 +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)
 
-_TokenLitInt :: Prism' RlpToken Int
+newtype P a = P { runP :: ParseState -> (ParseState, Maybe a) }
-_TokenLitInt = prism TokenLitInt $ \case
-    TokenLitInt n -> Right n
-    x             -> Left x
-
-_TokenVarName :: Prism' RlpToken Text
-_TokenVarName = prism TokenVarName $ \case
-    TokenVarName n -> Right n
-    x              -> Left x
-
-_TokenVarSym :: Prism' RlpToken Text
-_TokenVarSym = prism TokenVarSym $ \case
-    TokenVarSym n -> Right n
-    x              -> Left x
-
-_TokenConName :: Prism' RlpToken Text
-_TokenConName = prism TokenConName $ \case
-    TokenConName n -> Right n
-    x              -> Left x
-
-_TokenConSym :: Prism' RlpToken Text
-_TokenConSym = prism TokenConSym $ \case
-    TokenConSym n -> Right n
-    x              -> Left x
-
-newtype P a = P {
-        runP :: ParseState
-             -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
-    }
     deriving (Functor)
 
-pToErrorful :: (Applicative m)
-            => P a -> ParseState -> ErrorfulT (MsgEnvelope RlpParseError) m a
-pToErrorful p st = ErrorfulT $ pure (ma,es) where
-    (_,es,ma) = runP p st
-
 instance Applicative P where
-    pure a = P $ \st -> (st, [], pure a)
+    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]
@@ -199,97 +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 (Program RlpcPs)
--- deriving instance Lift (Decl RlpcPs)
--- deriving instance Lift (Pat RlpcPs)
--- deriving instance Lift (Lit RlpcPs)
--- deriving instance Lift (Expr RlpcPs)
--- deriving instance Lift (Binding RlpcPs)
--- deriving instance Lift (Ty RlpcPs)
--- deriving instance Lift (Alt RlpcPs)
--- deriving instance Lift (ConAlt RlpcPs)
-

src/Rlp/Syntax.hs

@@ -1,10 +1,178 @@
+-- recursion-schemes
+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
+-- recursion-schemes
+{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings, PatternSynonyms #-}
 module Rlp.Syntax
-    ( module Rlp.Syntax.Backstage
+    ( RlpModule(..)
-    , module Rlp.Syntax.Types
+    , RlpProgram(..)
+    , RlpProgram'
+    , rlpmodName
+    , rlpmodProgram
+    , RlpExpr(..)
+    , RlpExpr'
+    , RlpExprF(..)
+    , RlpExprF'
+    , Decl(..)
+    , Decl'
+    , Bind(..)
+    , Where
+    , Where'
+    , ConAlt(..)
+    , Type(..)
+    , pattern (:->)
+    , Assoc(..)
+    , VarId(..)
+    , ConId(..)
+    , Pat(..)
+    , Pat'
+    , Lit(..)
+    , Lit'
+    , Name
+
+    -- TODO: ugh move this somewhere else later
+    , showsTernaryWith
+
+    -- * Convenience re-exports
+    , Text
     )
     where
---------------------------------------------------------------------------------
+----------------------------------------------------------------------------------
-import Rlp.Syntax.Backstage
+import Data.Text                    (Text)
-import Rlp.Syntax.Types
+import Data.Text                    qualified as T
+import Data.String                  (IsString(..))
+import Data.Functor.Foldable.TH     (makeBaseFunctor)
+import Data.Functor.Classes
+import Lens.Micro
+import Lens.Micro.TH
+import Language.Haskell.TH.Syntax   (Lift)
+import Core.Syntax                  hiding (Lit)
+import Core                         (HasRHS(..), HasLHS(..))
+----------------------------------------------------------------------------------
+
+data RlpModule b = RlpModule
+    { _rlpmodName       :: Text
+    , _rlpmodProgram    :: RlpProgram b
+    }
+
+newtype RlpProgram b = RlpProgram [Decl RlpExpr b]
+    deriving (Show, Lift)
+
+type RlpProgram' = RlpProgram Name
+
+-- | The @e@ parameter is used for partial results. When parsing an input, we
+-- first parse all top-level declarations in order to extract infix[lr]
+-- declarations. This process yields a @[Decl (Const Text) Name]@, where @Const
+-- 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]@.
+
+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)
+
+type Decl' e = Decl e Name
+
+data Assoc = InfixL
+           | InfixR
+           | Infix
+           deriving (Show, Lift)
+
+data ConAlt = ConAlt ConId [Type]
+            deriving (Show, Lift)
+
+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)
+
+type RlpExpr' = RlpExpr Name
+
+type Where b = [Bind b]
+type Where' = [Bind Name]
+
+-- do we want guards?
+data Alt b = AltA (Pat b) (RlpExpr b)
+           deriving (Show, Lift)
+
+data Bind b = PatB (Pat b) (RlpExpr b)
+            | FunB VarId [Pat b] (RlpExpr b)
+            deriving (Show, Lift)
+
+data VarId = NameVar Text
+           | SymVar Text
+           deriving (Show, Lift)
+
+instance IsString VarId where
+    -- TODO: use symvar if it's an operator
+    fromString = NameVar . T.pack
+
+data ConId = NameCon Text
+           | SymCon Text
+           deriving (Show, Lift)
+
+data Pat b = VarP VarId
+           | LitP (Lit b)
+           | ConP ConId [Pat b]
+           deriving (Show, Lift)
+
+type Pat' = Pat Name
+
+data Lit b = IntL Int
+           | CharL Char
+           | ListL [RlpExpr b]
+           deriving (Show, Lift)
+
+type Lit' = Lit Name
+
+-- instance HasLHS Alt Alt Pat Pat where
+--     _lhs = lens
+--         (\ (AltA p _) -> p)
+--         (\ (AltA _ e) p' -> AltA p' e)
+
+-- instance HasRHS Alt Alt RlpExpr RlpExpr where
+--     _rhs = lens
+--         (\ (AltA _ e) -> e)
+--         (\ (AltA p _) e' -> AltA p e')
+
+makeBaseFunctor ''RlpExpr
+
+deriving instance (Show b, Show a) => Show (RlpExprF b a)
+
+type RlpExprF' = RlpExprF Name
+
+-- society if derivable Show1
+instance (Show b) => Show1 (RlpExprF b) where
+    liftShowsPrec sp _ p m = case m of
+        (LetEF bs e)            -> showsBinaryWith showsPrec sp "LetEF" p bs e
+        (VarEF n)               -> showsUnaryWith showsPrec "VarEF" p n
+        (ConEF n)               -> showsUnaryWith showsPrec "ConEF" p n
+        (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
+

src/Rlp/Syntax/Backstage.hs

@@ -1,35 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE UndecidableInstances #-}
-module Rlp.Syntax.Backstage
-    ( strip
-    )
-    where
---------------------------------------------------------------------------------
-import Data.Fix                     hiding (cata)
-import Data.Functor.Classes
-import Data.Functor.Foldable
-import Rlp.Syntax.Types
-import Text.Show.Deriving
-import Language.Haskell.TH.Syntax   (Lift)
---------------------------------------------------------------------------------
-
--- oprhan instances because TH
-
-instance (Show (NameP p)) => Show1 (Alt p) where
-    liftShowsPrec = $(makeLiftShowsPrec ''Alt)
-
-instance (Show (NameP p)) => Show1 (Binding p) where
-    liftShowsPrec = $(makeLiftShowsPrec ''Binding)
-
-instance (Show (NameP p)) => Show1 (ExprF p) where
-    liftShowsPrec = $(makeLiftShowsPrec ''ExprF)
-
-deriving instance (Lift (NameP p), Lift a) => Lift (Expr' p a)
-deriving instance (Lift (NameP p), Lift a) => Lift (Decl p a)
-deriving instance (Show (NameP p), Show a) => Show (Decl p a)
-
-deriving instance (Show (NameP p), Show a) => Show (Program p a)
-
-strip :: Functor f => Cofree f a -> Fix f
-strip (_ :< as) = Fix $ strip <$> as
-

src/Rlp/Syntax/Types.hs

@@ -1,143 +0,0 @@
--- recursion-schemes
-{-# LANGUAGE DeriveTraversable, TemplateHaskell, TypeFamilies #-}
-{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-}
-{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-}
-module Rlp.Syntax.Types
-    (
-      NameP
-    , SimpleP
-    , Assoc(..)
-    , ConAlt(..)
-    , Alt(..), Alt'
-    , Ty(..)
-    , Binding(..), Binding'
-    , Expr', ExprF(..)
-    , Rec(..)
-    , Lit(..)
-    , Pat(..)
-    , Decl(..)
-    , Program(..)
-    , Where
-
-    -- * Re-exports
-    , Cofree(..)
-    , Trans.Cofree.CofreeF
-    , SrcSpan(..)
-    )
-    where
-----------------------------------------------------------------------------------
-import Data.Text                    (Text)
-import Data.Text                    qualified as T
-import Data.String                  (IsString(..))
-import Data.Functor.Classes
-import Data.Functor.Identity
-import Data.Functor.Compose
-import Data.Fix
-import Data.Kind                    (Type)
-import GHC.Generics
-import Language.Haskell.TH.Syntax   (Lift)
-import Control.Lens                 hiding ((:<))
-
-import Control.Comonad.Trans.Cofree qualified as Trans.Cofree
-import Control.Comonad.Cofree
-import Data.Functor.Foldable
-import Data.Functor.Foldable.TH     (makeBaseFunctor)
-
-import Compiler.Types               (SrcSpan(..), Located(..))
-import Core.Syntax                  qualified as Core
-import Core                         (Rec(..), HasRHS(..), HasLHS(..))
-----------------------------------------------------------------------------------
-
-data SimpleP
-
-type instance NameP SimpleP = String
-
-type family NameP p
-
-data ExprF p a = LetEF   Rec [Binding p a] a
-               | VarEF   (NameP p)
-               | LamEF   [Pat p] a
-               | CaseEF  a [Alt p a]
-               | IfEF    a a a
-               | AppEF   a a
-               | LitEF   (Lit p)
-               | ParEF   a
-               | InfixEF (NameP p) a a
-               deriving (Functor, Foldable, Traversable)
-
-data ConAlt p = ConAlt (NameP p) [Ty p]
-
-deriving instance (Lift (NameP p)) => Lift (ConAlt p)
-deriving instance (Show (NameP p)) => Show (ConAlt p)
-
-data Ty p = ConT (NameP p)
-          | VarT (NameP p)
-          | FunT (Ty p) (Ty p)
-          | AppT (Ty p) (Ty p)
-
-deriving instance (Show (NameP p)) => Show (Ty p)
-deriving instance (Lift (NameP p)) => Lift (Ty p)
-
-data Pat p = VarP (NameP p)
-           | LitP (Lit p)
-           | ConP (NameP p) [Pat p]
-
-deriving instance (Lift (NameP p)) => Lift (Pat p)
-deriving instance (Show (NameP p)) => Show (Pat p)
-
-data Lit p = IntL Int
-    deriving Show
-
-deriving instance (Lift (NameP p)) => Lift (Lit p)
-
-data Assoc = InfixL | InfixR | Infix
-    deriving (Lift, Show)
-
-deriving instance (Show (NameP p), Show a) => Show (ExprF p a)
-deriving instance (Lift (NameP p), Lift a) => Lift (ExprF p a)
-
-data Binding p a = PatB (Pat p) (ExprF p a)
-    deriving (Functor, Foldable, Traversable)
-
-deriving instance (Lift (NameP p), Lift a) => Lift (Binding p a)
-deriving instance (Show (NameP p), Show a) => Show (Binding p a)
-
-type Binding' p a = Binding p (Cofree (ExprF p) a)
-
-type Where p a = [Binding p a]
-
-data Alt p a = AltA (Pat p) (ExprF p a) (Maybe (Where p a))
-    deriving (Functor, Foldable, Traversable)
-
-deriving instance (Show (NameP p), Show a) => Show (Alt p a)
-deriving instance (Lift (NameP p), Lift a) => Lift (Alt p a)
-
-type Expr p = Fix (ExprF p)
-
-type Alt' p a = Alt p (Cofree (ExprF p) a)
-
---------------------------------------------------------------------------------
-
-data Program p a = Program
-    { _programDecls :: [Decl p a]
-    }
-
-data Decl p a = FunD   (NameP p) [Pat p] (Expr' p a) (Maybe (Where p a))
-              | TySigD [NameP p] (Ty p)
-              | DataD  (NameP p) [NameP p] [ConAlt p]
-              | InfixD Assoc Int (NameP p)
-
-type Decl' p a = Decl p (Cofree (ExprF p) a)
-
-type Expr' p = Cofree (ExprF p)
-
-makeLenses ''Program
-
-loccof :: Iso' (Cofree f SrcSpan) (Located (f (Cofree f SrcSpan)))
-loccof = iso sa bt where
-    sa :: Cofree f SrcSpan -> Located (f (Cofree f SrcSpan))
-    sa (ss :< as) = Located ss as
-
-    bt :: Located (f (Cofree f SrcSpan)) -> Cofree f SrcSpan
-    bt (Located ss as) = ss :< as
-

src/Rlp/TH.hs

@@ -1,38 +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 = undefined
+rlpProg = QuasiQuoter
--- rlpProg = mkqq parseRlpProgR
+    { quoteExp = qRlpProg
-
-rlpExpr :: QuasiQuoter
-rlpExpr = undefined
--- 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,244 +1,44 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE DeriveTraversable #-}
 module Rlp2Core
-    ( desugarRlpProgR
+    ( rlp2core
-    , desugarRlpProg
-    , desugarRlpExpr
     )
     where
 --------------------------------------------------------------------------------
-import Control.Monad
-import Control.Monad.Writer.CPS
-import Control.Monad.Utils
-import Control.Arrow
-import Control.Applicative
-import Control.Comonad
-import Control.Lens
-import Compiler.RLPC
-import Data.List                        (mapAccumL, partition)
-import Data.Text                        (Text)
-import Data.Text                        qualified as T
-import Data.HashMap.Strict              qualified as H
-import Data.Monoid                      (Endo(..))
-import Data.Either                      (partitionEithers)
-import Data.Foldable
-import Data.Fix
-import Data.Maybe                       (fromJust, fromMaybe)
-import Data.Functor.Bind
-import Data.Function                    (on)
-import GHC.Stack
-import Debug.Trace
-
-import Effectful.State.Static.Local
-import Effectful.Labeled
-import Effectful
-import Text.Show.Deriving
-
 import Core.Syntax                  as Core
-import Compiler.Types
-import Data.Pretty                      (render, pretty)
 import Rlp.Syntax                   as Rlp
-import Rlp.Parse.Types                  (RlpcPs, PsName)
+import Data.Foldable
+import Data.HashMap.Strict          qualified as H
+import Control.Monad.State
+import Lens.Micro.Platform
 --------------------------------------------------------------------------------
 
-desugarRlpProgR = undefined
+rlp2core :: RlpProgram' -> Program'
-desugarRlpProg = undefined
+rlp2core (RlpProgram ds) = execState (decl2core `traverse_` ds) init
-desugarRlpExpr = undefined
-
-{--
-
-type Tree a = Either Name (Name, Branch a)
-
--- | Rose tree branch representing "nested" "patterns" in the Core language. That
--- is, a constructor with children that are either a normal binder (Left (Given)
--- name) or an indirection to another pattern (Right (Generated name) (Pattern))
-
-data Branch a = Branch Name [Tree a]
-    deriving (Show, Functor, Foldable, Traversable)
-
--- | The actual rose tree.
--- @type Rose = 'Data.Fix.Fix' 'Branch'@
-
-type Rose = Fix Branch
-
-deriveShow1 ''Branch
-
---------------------------------------------------------------------------------
-
-desugarRlpProgR :: forall m. (Monad m) => RlpProgram RlpcPs -> RLPCT m Program'
-desugarRlpProgR p = do
-    let p' = desugarRlpProg p
-    addDebugMsg "dump-desugared" $ render (pretty p')
-    pure p'
-
-desugarRlpProg :: RlpProgram RlpcPs -> Program'
-desugarRlpProg = rlpProgToCore
-
-desugarRlpExpr :: RlpExpr RlpcPs -> Expr'
-desugarRlpExpr = runPureEff . runNameSupply "anon" . exprToCore
-
--- the rl' program is desugared by desugaring each declaration as a separate
--- program, and taking the monoidal product of the lot :3
-
-rlpProgToCore :: RlpProgram RlpcPs -> Program'
-rlpProgToCore = foldMapOf (progDecls . each) declToCore
-
-declToCore :: Decl' RlpcPs -> Program'
-
-declToCore (TySigD'' ns t) = mempty &
-    programTypeSigs .~ H.fromList [ (n, typeToCore t) | n <- ns ]
-
-declToCore (DataD'' n as ds) = fold . getZipList $
-    constructorToCore t' <$> ZipList [0..] <*> ZipList ds
     where
-        -- create the appropriate type from the declared constructor and its
+        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/Compiler/TypesSpec.hs

@@ -1,67 +0,0 @@
-{-# LANGUAGE ParallelListComp #-}
-module Compiler.TypesSpec
-    ( spec
-    )
-    where
---------------------------------------------------------------------------------
-import Control.Lens.Combinators
-import Data.Function            ((&))
-
-import Test.QuickCheck
-import Test.Hspec
-
-import Compiler.Types           (SrcSpan(..), srcSpanAbs, srcSpanLen)
---------------------------------------------------------------------------------
-
-spec :: Spec
-spec = do
-    describe "SrcSpan" $ do
-        -- it "associates under closure"
-        --     prop_SrcSpan_mul_associative
-        it "commutes under closure"
-            prop_SrcSpan_mul_commutative
-        it "equals itself when squared"
-            prop_SrcSpan_mul_square_eq
-
-prop_SrcSpan_mul_associative :: Property
-prop_SrcSpan_mul_associative = property $ \a b c ->
-    -- very crudely approximate when overflow will occur; bail we think it
-    -- will
-    (([a,b,c] :: [SrcSpan]) & allOf (each . (srcSpanAbs <> srcSpanLen))
-                                    (< (maxBound @Int `div` 3)))
-    ==> (a <> b) <> c === a <> (b <> c :: SrcSpan)
-
-prop_SrcSpan_mul_commutative :: Property
-prop_SrcSpan_mul_commutative = property $ \a b ->
-    a <> b === (b <> a :: SrcSpan)
-
-prop_SrcSpan_mul_square_eq :: Property
-prop_SrcSpan_mul_square_eq = property $ \a ->
-    a <> a === (a :: SrcSpan)
-
-instance Arbitrary SrcSpan where
-    arbitrary = do
-        l <- chooseInt (1, maxBound)
-        c <- chooseInt (1, maxBound)
-        a <- chooseInt (0, maxBound)
-            `suchThat` (\n -> n >= pred l + pred c)
-        s <- chooseInt (0, maxBound)
-        pure $ SrcSpan l c a s
-
-    shrink (SrcSpan l c a s) =
-        [ SrcSpan l' c' a' s'
-        | (l',c',a',s') <- shrinkParts
-        , l' >= 1
-        , c' >= 1
-        , a' >= pred l' + pred c'
-        ]
-      where
-        -- shfl as = unsafePerformIO (generate $ shuffle as)
-        shrinkParts = 
-            [ (l',c',a',s')
-            | l' <- shrinkIntegral l
-            | c' <- shrinkIntegral c
-            | a' <- shrinkIntegral a
-            | s' <- shrinkIntegral s
-            ]
-

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