diagrams

i still love you microlens..

.ghci

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

Makefile_happysrcs

@@ -1,5 +1,5 @@
 HAPPY = happy
-HAPPY_OPTS = -a -g -c
+HAPPY_OPTS = -a -g -c -i/tmp/t.info
 ALEX = alex
 ALEX_OPTS = -g
 

README.md

@@ -3,6 +3,10 @@
 `rlp` (ruelang') will be a lazily-evaluated purely-functional language heavily
 imitating Haskell.
 
+### Architecture
+
+![rlpc architecture diagram](/rlpc.drawio.svg)
+
 ### Build Info
 * rlp is built using [Cabal](https://www.haskell.org/ghcup/)
 * rlp's documentation is built using [Sphinx](https://www.sphinx-doc.org/en/master/)
@@ -18,21 +22,40 @@ $ cabal test --test-show-details=direct
 ```
 
 ### Use
+
+#### TLDR
+
 ```sh
-# Compile and evaluate examples/factorial.hs, with evaluation info dumped to stderr
-$ rlpc -ddump-eval examples/factorial.hs
-# Compile and evaluate t.hs, with evaluation info dumped to t.log
-$ rlpc -ddump-eval -l t.log t.hs
-# Print the raw structure describing the compiler options and die
-# (option parsing still must succeed in order to print)
-$ rlpc -ddump-opts t.hs
+# Compile and evaluate examples/rlp/QuickSort.rl
+$ rlpc examples/QuickSort.rl
+# Compile and evaluate t.cr, with evaluation info dumped to t.log
+$ rlpc -ddump-eval -l t.log t.cr
+# Compile and evaluate t.rl, dumping the desugared Core
+$ rlpc -ddump-desugared t.rl
+# Compile and evaluate t.rl with all compiler messages enabled
+$ rlpc -dALL t.rl
 ```
 
+#### Options
+
+```sh
+Usage: rlpc [-l|--log FILE] [-d DEBUG FLAG] [-f COMPILATION FLAG] 
+            [-e|--evaluator gm|ti] [--heap-trigger INT] [-x|--language rlp|core]
+            FILES...
+```
+
+Available debug flags include:
+* `-ddump-desugared`: dump Core generated from rl'
+* `-ddump-parsed-core`: dump raw Core AST
+* `-ddump-parsed`: dump raw rl' AST
+* `-ddump-eval`: dump evaluation logs
+* `-dALL`: disable debug message filtering. enables **all** debug messages
+
 ### Potential Features
 Listed in order of importance.
 - [x] ADTs
 - [x] First-class functions
-- [ ] Higher-kinded types
+- [x] Higher-kinded types
 - [ ] Typeclasses
 - [x] Parametric polymorphism
 - [x] Hindley-Milner type inference
@@ -42,6 +65,14 @@ Listed in order of importance.
 ### 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
@@ -57,9 +88,8 @@ Listed in order of importance.
         - [x] Garbage Collection
     - [ ] Emitter
         - [ ] Code-gen (target yet to be decided)
-        - [ ] Core language emitter
-    - [ ] Core linter (Type-checker)
-    - [ ] Core2Core pass
+    - [x] Core linter (Type-checker)
+    - [ ] Core2Core pass (optimisations and misc. preprocessing)
         - [x] GM prep
             - [x] Non-strict case-floating
         - [ ] Let-floating
@@ -70,7 +100,7 @@ Listed in order of importance.
         - [x] AST
         - [x] Lexer
         - [x] Parser
-    - [ ] Translation to the core language
+    - [x] Translation to the core language
         - [ ] Constraint solver
         - [ ] `do`-notation
     - [x] CLI
@@ -81,6 +111,7 @@ Listed in order of importance.
     - [ ] CLI usage
     - [ ] Tail call optimisation
     - [ ] Parsing rlp
+    - [ ] Trees That Grow
 - [ ] Tests
     - [x] Generic example programs
     - [ ] Parser
@@ -97,29 +128,38 @@ Listed in order of importance.
     - [x] Garbage Collection
 - [ ] Stable documentation for the evaluation model
 
-### January Release Plan
-- [ ] Beta rl' to Core
-- [ ] UX improvements
-    - [ ] Actual compiler errors -- no more unexceptional `error` calls
-    - [ ] Better CLI dump flags
-    - [ ] Annotate the AST with token positions for errors
-- [ ] More examples
+### ~~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
-- [ ] GM to LLVM
+- [ ] Choose a target. LLVM, JS, C, and WASM are currently top contenders
+- [ ] https://proglangdesign.net/wiki/challenges
 

app/CoreDriver.hs

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

app/Main.hs

@@ -1,7 +1,9 @@
 {-# 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
@@ -10,12 +12,17 @@ import Data.HashSet             qualified as S
 import Data.Text                (Text)
 import Data.Text                qualified as T
 import Data.Text.IO             qualified as TIO
+import Data.List
+import Data.Maybe               (listToMaybe)
 import System.IO
 import System.Exit              (exitSuccess)
 import Core
 import TI
 import GM
-import Lens.Micro.Mtl
+import Control.Lens.Combinators hiding (argument)
+
+import CoreDriver               qualified
+import RlpDriver                qualified
 ----------------------------------------------------------------------------------
 
 optParser :: ParserInfo RLPCOptions
@@ -37,9 +44,15 @@ options = RLPCOptions
     {- -d -}
     <*> fmap S.fromList # many # option debugFlagReader
         (  short 'd'
-        <> help "dump evaluation logs"
+        <> help "pass debug flags"
         <> metavar "DEBUG FLAG"
         )
+    {- -f -}
+    <*> fmap S.fromList # many # option compilerFlagReader
+        (  short 'f'
+        <> help "pass compilation flags"
+        <> metavar "COMPILATION FLAG"
+        )
     {- --evaluator, -e -}
     <*> option evaluatorReader
         (  long "evaluator"
@@ -55,11 +68,36 @@ 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"
+        )
+    <*> flag False True
+        (  long "render"
+        <> short 'r'
+        <> help "render a diagram of each GM state"
+        )
     <*> 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
@@ -69,82 +107,39 @@ evaluatorReader = maybeReader $ \case
 mmany :: (Alternative f, Monoid m) => f m -> f m
 mmany v = liftA2 (<>) v (mmany v)
 
-debugFlagReader :: ReadM DebugFlag
-debugFlagReader = maybeReader $ \case
-    "dump-eval"  -> Just DDumpEval
-    "dump-opts"  -> Just DDumpOpts
-    "dump-ast"   -> Just DDumpAST
-    _            -> Nothing
-
 ----------------------------------------------------------------------------------
 
--- temp
-data CompilerError = CompilerError String
-    deriving Show
-
-instance Exception CompilerError
-
 main :: IO ()
 main = do
     opts <- execParser optParser
-    (_, es) <- evalRLPCIO opts driver
-    forM_ es $ \ (CompilerError e) -> print $ "warning: " <> e
-    pure ()
+    void $ evalRLPCIO opts dispatch
 
-driver :: RLPCIO CompilerError ()
-driver = sequence_
-    [ dshowFlags
-    , ddumpAST
-    , ddumpEval
-    ]
+dispatch :: RLPCIO ()
+dispatch = getLang >>= \case
+    Just LanguageCore -> CoreDriver.driver
+    Just LanguageRlp  -> RlpDriver.driver
+    Nothing           -> addFatal err
+        where
+            -- TODO: why didn't i make the srcspan optional LOL
+            err = errorMsg (SrcSpan 0 0 0 0) $ Text
+                [ "Could not determine source language from filetype."
+                , "Possible Solutions:\n\
+                  \  Suffix the file with `.cr' for Core, or `.rl' for rl'\n\
+                  \  Specify a language with `rlpc -x core' or `rlpc -x rlp'"
+                ]
+  where
+    getLang = liftA2 (<|>)
+        (view rlpcLanguage)
+        -- TODO: we only check the first file lol
+        ((listToMaybe >=> inferLanguage) <$> view rlpcInputFiles)
 
-dshowFlags :: RLPCIO CompilerError ()
-dshowFlags = whenFlag flagDDumpOpts do
-    ask >>= liftIO . print
 
-ddumpAST :: RLPCIO CompilerError ()
-ddumpAST = whenFlag flagDDumpAST $ forFiles_ \o f -> do
-    liftIO $ withFile f ReadMode $ \h -> do
-        s <- TIO.hGetContents h
-        case parseProg o s of
-            Right (a,_) -> hPutStrLn stderr $ show a
-            Left e -> error "todo errors lol"
+driver :: RLPCIO ()
+driver = undefined
 
-ddumpEval :: RLPCIO CompilerError ()
-ddumpEval = whenFlag flagDDumpEval do
-    fs <- view rlpcInputFiles
-    forM_ fs $ \f -> liftIO (TIO.readFile f) >>= doProg
-
-    where
-        doProg :: Text -> RLPCIO CompilerError ()
-        doProg s = ask >>= \o -> case parseProg o s of
-            -- TODO: error handling
-            Left e -> addFatal . CompilerError $ show e
-            Right (a,_) -> do
-                log <- view rlpcLogFile
-                dumpEval <- chooseEval
-                case log of
-                    Just f  -> liftIO $ withFile f WriteMode $ dumpEval a
-                    Nothing -> liftIO $ dumpEval a stderr
-
-        -- choose the appropriate model based on the compiler opts
-        chooseEval = do
-            ev <- view rlpcEvaluator
-            pure $ case ev of
-                EvaluatorGM  -> v GM.hdbgProg
-                EvaluatorTI -> v TI.hdbgProg
-            where v f p h = f p h *> pure ()
-
-parseProg :: RLPCOptions
-          -> Text
-          -> Either SrcError (Program', [SrcError])
-parseProg o = evalRLPC o . (lexCore >=> parseCoreProg)
-
-forFiles_ :: (Monad m)
-          => (RLPCOptions -> FilePath -> RLPCT e m a)
-          -> RLPCT e m ()
-forFiles_ k = do
-    fs <- view rlpcInputFiles
-    o <- ask
-    forM_ fs (k o)
+inferLanguage :: FilePath -> Maybe Language
+inferLanguage fp
+    | ".rl" `isSuffixOf` fp     = Just LanguageRlp
+    | ".cr" `isSuffixOf` fp     = Just LanguageCore
+    | otherwise                 = Nothing
 

app/RlpDriver.hs

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

doc/src/commentary/gm.rst

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

doc/src/commentary/layout-lexing.rst

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

examples/Core/constDivZero.cr

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

examples/Core/factorial.cr

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

examples/Core/sumList.cr

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

examples/constDivZero.hs

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

examples/rlp/QuickSort.rl

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

examples/rlp/SumList.rl

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

examples/sumList.hs

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

rlp.cabal

@@ -22,6 +22,9 @@ library
     exposed-modules:  Core
                     , TI
                     , GM
+                    , GM.Visual
+                    , GM.Types
+                    , GM.Print
                     , Compiler.RLPC
                     , Compiler.RlpcError
                     , Compiler.JustRun
@@ -37,18 +40,20 @@ library
                     , Rlp.Parse.Associate
                     , Rlp.Lex
                     , Rlp.Parse.Types
-
-    other-modules:    Data.Heap
+                    , Rlp.TH
+                    , Compiler.Types
+                    , Data.Heap
                     , Data.Pretty
                     , Core.Parse
                     , Core.Lex
                     , Core2Core
+                    , Rlp2Core
                     , Control.Monad.Utils
 
     build-tool-depends: happy:happy, alex:alex
 
     -- other-extensions:
-    build-depends:    base ^>=4.18.0.0
+    build-depends:    base >=4.17 && <4.20
                     -- required for happy
                     , array >= 0.5.5 && < 0.6
                     , containers >= 0.6.7 && < 0.7
@@ -59,35 +64,47 @@ library
                     , hashable >= 1.4.3 && < 1.5
                     , mtl >= 2.3.1 && < 2.4
                     , text >= 2.0.2 && < 2.1
-                    , megaparsec >= 9.6.1 && < 9.7
-                    , microlens >= 0.4.13 && < 0.5
-                    , microlens-mtl >= 0.2.0 && < 0.3
-                    , microlens-platform >= 0.4.3 && < 0.5
-                    , microlens-th >= 0.4.3 && < 0.5
                     , unordered-containers >= 0.2.20 && < 0.3
                     , recursion-schemes >= 5.2.2 && < 5.3
                     , data-fix >= 0.3.2 && < 0.4
                     , utf8-string >= 1.0.2 && < 1.1
-                    , extra >= 1.7.0 && < 2
+                    , 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
+                    , diagrams
+                    , diagrams-lib
+                    , diagrams-cairo
 
     hs-source-dirs:   src
     default-language: GHC2021
 
     default-extensions:
         OverloadedStrings
+        TypeFamilies
+        LambdaCase
+        ViewPatterns
+        DataKinds
+        DerivingVia
+        StandaloneDeriving
+        DerivingStrategies
 
 executable rlpc
     import:           warnings
     main-is:          Main.hs
-    -- other-modules:
-    -- other-extensions:
-    build-depends: base ^>=4.18.0.0
+    other-modules:    RlpDriver
+                    , CoreDriver
+
+    build-depends: base >=4.17.0.0 && <4.20.0.0
                  , rlp
                  , optparse-applicative >= 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
 
     hs-source-dirs:   app

rlpc.drawio

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

src/Compiler/JustRun.hs

@@ -8,9 +8,10 @@ that use Prelude types such as @Either@ and @String@ rather than more complex
 types such as @RLPC@ or @Text@.
 -}
 module Compiler.JustRun
-    ( justLexSrc
-    , justParseSrc
-    , justTypeCheckSrc
+    ( justLexCore
+    , justParseCore
+    , justTypeCheckCore
+    , justHdbg
     )
     where
 ----------------------------------------------------------------------------------
@@ -20,25 +21,35 @@ import Core.HindleyMilner
 import Core.Syntax                      (Program')
 import Compiler.RLPC
 import Control.Arrow                    ((>>>))
-import Control.Monad                    ((>=>))
+import Control.Monad                    ((>=>), void)
+import Control.Comonad
+import Control.Lens
 import Data.Text                        qualified as T
 import Data.Function                    ((&))
+import System.IO
 import GM
+import Rlp.Parse
+import Rlp2Core
 ----------------------------------------------------------------------------------
 
-justLexSrc :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
-justLexSrc s = lexCoreR (T.pack s)
-             & fmap (map $ \ (Located _ _ _ t) -> t)
-             & rlpcToEither
+justHdbg :: String -> IO GmState
+justHdbg s = do
+    p <- evalRLPCIO def (parseRlpProgR >=> desugarRlpProgR $ T.pack s)
+    withFile "/tmp/t.log" WriteMode $ hdbgProg p
 
-justParseSrc :: String -> Either [MsgEnvelope RlpcError] Program'
-justParseSrc s = parse (T.pack s)
-               & rlpcToEither
+justLexCore :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
+justLexCore s = lexCoreR (T.pack s)
+              & mapped . each %~ extract
+              & rlpcToEither
+
+justParseCore :: String -> Either [MsgEnvelope RlpcError] Program'
+justParseCore s = parse (T.pack s)
+                & rlpcToEither
     where parse = lexCoreR >=> parseCoreProgR
 
-justTypeCheckSrc :: String -> Either [MsgEnvelope RlpcError] Program'
-justTypeCheckSrc s = typechk (T.pack s)
-                   & rlpcToEither
+justTypeCheckCore :: String -> Either [MsgEnvelope RlpcError] Program'
+justTypeCheckCore s = typechk (T.pack s)
+                    & rlpcToEither
     where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR
 
 rlpcToEither :: RLPC a -> Either [MsgEnvelope RlpcError] a

src/Compiler/RLPC.hs

@@ -10,32 +10,33 @@ errors and the family of RLPC monads.
 {-# LANGUAGE TemplateHaskell #-}
 -- only used for mtl instances
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia #-}
+{-# LANGUAGE BlockArguments, ViewPatterns #-}
 module Compiler.RLPC
-    ( RLPC
-    , RLPCT(..)
-    , RLPCIO
-    , RLPCOptions(RLPCOptions)
-    , IsRlpcError(..)
-    , RlpcError(..)
-    , MsgEnvelope(..)
-    , addFatal
-    , addWound
-    , MonadErrorful
-    , Severity(..)
-    , Evaluator(..)
-    , evalRLPCT
-    , evalRLPCIO
-    , evalRLPC
-    , rlpcLogFile
-    , rlpcDFlags  
-    , rlpcEvaluator
-    , rlpcInputFiles
-    , DebugFlag(..)
-    , whenDFlag
-    , whenFFlag
-    , def
-    , liftErrorful
+    (
+    -- * Rlpc Monad transformer
+      RLPCT(RLPCT),
+    -- ** Special cases
+      RLPC, RLPCIO
+    , liftIO
+    -- ** Running
+    , runRLPCT
+    , evalRLPCT, evalRLPCIO, evalRLPC
+    -- * Rlpc options
+    , Language(..), Evaluator(..)
+    , DebugFlag(..), CompilerFlag(..)
+    -- ** Lenses
+    , rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage
+    -- * Misc. MTL-style functions
+    , liftErrorful, hoistRlpcT
+    -- * Misc. Rlpc Monad -related types
+    , RLPCOptions(RLPCOptions), IsRlpcError(..), RlpcError(..)
+    , MsgEnvelope(..), Severity(..)
+    , addDebugMsg
+    , whenDFlag, whenFFlag
+    -- * Misc. Utilities
+    , forFiles_, withSource
+    -- * Convenient re-exports
+    , addFatal, addWound, def
     )
     where
 ----------------------------------------------------------------------------------
@@ -45,7 +46,9 @@ 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
@@ -55,19 +58,39 @@ import Data.Hashable            (Hashable)
 import Data.HashSet             (HashSet)
 import Data.HashSet             qualified as S
 import Data.Coerce
-import Lens.Micro.Platform
+import Data.Text                (Text)
+import Data.Text                qualified as T
+import Data.Text.IO             qualified as T
+import System.IO
+import Text.ANSI                qualified as Ansi
+import Text.PrettyPrint         hiding ((<>))
+import Control.Lens
+import Data.Text.Lens           (packed, unpacked, IsText)
 import System.Exit
 ----------------------------------------------------------------------------------
 
 newtype RLPCT m a = RLPCT {
         runRLPCT :: ReaderT RLPCOptions (ErrorfulT (MsgEnvelope RlpcError) m) a
     }
-    deriving (Functor, Applicative, Monad, MonadReader RLPCOptions)
+    deriving ( Functor, Applicative, Monad
+             , MonadReader RLPCOptions, MonadErrorful (MsgEnvelope RlpcError))
+
+rlpc :: (IsRlpcError e, Monad m)
+     => (RLPCOptions -> (Maybe a, [MsgEnvelope e]))
+     -> RLPCT m a
+rlpc f = RLPCT . ReaderT $ \opt ->
+    ErrorfulT . pure $ f opt & _2 . each . mapped %~ liftRlpcError
 
 type RLPC = RLPCT Identity
 
 type RLPCIO = RLPCT IO
 
+instance MonadTrans RLPCT where
+    lift = RLPCT . lift . lift
+
+instance (MonadIO m) => MonadIO (RLPCT m) where
+    liftIO = lift . liftIO
+
 evalRLPC :: RLPCOptions
          -> RLPC a
          -> (Maybe a, [MsgEnvelope RlpcError])
@@ -75,32 +98,29 @@ evalRLPC opt r = runRLPCT r
                & flip runReaderT opt
                & runErrorful
 
-evalRLPCT :: (Monad m)
-          => RLPCOptions
+evalRLPCT :: RLPCOptions
           -> RLPCT m a
           -> m (Maybe a, [MsgEnvelope RlpcError])
-evalRLPCT = undefined
-
-evalRLPCIO :: RLPCOptions -> RLPCIO a -> IO a
-evalRLPCIO opt r = do
-    (ma,es) <- evalRLPCT opt r
-    putRlpcErrs es
-    case ma of
-        Just x  -> pure x
-        Nothing -> die "Failed, no code compiled."
-
-putRlpcErrs :: [MsgEnvelope RlpcError] -> IO ()
-putRlpcErrs = traverse_ print
+evalRLPCT opt r = runRLPCT r
+                & flip runReaderT opt
+                & runErrorfulT
 
 liftErrorful :: (Monad m, IsRlpcError e) => ErrorfulT (MsgEnvelope e) m a -> RLPCT m a
 liftErrorful e = RLPCT $ lift (fmap liftRlpcError `mapErrorful` e)
 
+hoistRlpcT :: (forall a. m a -> n a)
+         -> RLPCT m a -> RLPCT n a
+hoistRlpcT f rma = RLPCT $ ReaderT $ \opt ->
+    ErrorfulT $ f $ evalRLPCT opt rma
+
 data RLPCOptions = RLPCOptions
     { _rlpcLogFile     :: Maybe FilePath
     , _rlpcDFlags      :: HashSet DebugFlag
     , _rlpcFFlags      :: HashSet CompilerFlag
     , _rlpcEvaluator   :: Evaluator
     , _rlpcHeapTrigger :: Int
+    , _rlpcLanguage    :: Maybe Language
+    , _rlpcRender      :: Bool
     , _rlpcInputFiles  :: [FilePath]
     }
     deriving Show
@@ -108,6 +128,9 @@ data RLPCOptions = RLPCOptions
 data Evaluator = EvaluatorGM | EvaluatorTI
     deriving Show
 
+data Language = LanguageRlp | LanguageCore
+    deriving Show
+
 ----------------------------------------------------------------------------------
 
 instance Default RLPCOptions where
@@ -118,16 +141,21 @@ instance Default RLPCOptions where
         , _rlpcEvaluator = EvaluatorGM
         , _rlpcHeapTrigger = 200
         , _rlpcInputFiles = []
+        , _rlpcLanguage = Nothing
+        , _rlpcRender = False
         }
 
 -- debug flags are passed with -dFLAG
-type DebugFlag = String
+type DebugFlag = Text
 
-type CompilerFlag = String
+type CompilerFlag = Text
 
 makeLenses ''RLPCOptions
 pure []
 
+addDebugMsg :: (Monad m, IsText e) => Text -> e -> RLPCT m ()
+addDebugMsg tag e = addWound . debugMsg tag $ Text [e ^. unpacked . packed]
+
 -- TODO: rewrite this with prisms once microlens-pro drops :3
 whenDFlag :: (Monad m) => DebugFlag -> RLPCT m () -> RLPCT m ()
 whenDFlag f m = do
@@ -143,3 +171,84 @@ whenFFlag f m = do
     let a = S.member f fs
     when a m
 
+--------------------------------------------------------------------------------
+
+evalRLPCIO :: RLPCOptions -> RLPCIO a -> IO a
+evalRLPCIO opt r = do
+    (ma,es) <- evalRLPCT opt r
+    putRlpcErrs opt es
+    case ma of
+        Just x  -> pure x
+        Nothing -> die "Failed, no code compiled."
+
+putRlpcErrs :: RLPCOptions -> [MsgEnvelope RlpcError] -> IO ()
+putRlpcErrs opt es = case opt ^. rlpcLogFile of
+    Just lf -> withFile lf WriteMode putter
+    Nothing -> putter stderr
+  where
+    putter h = hPutStrLn h `traverse_` renderRlpcErrs opt es
+
+renderRlpcErrs :: RLPCOptions -> [MsgEnvelope RlpcError] -> [String]
+renderRlpcErrs opts = (if don'tBother then id else filter byTag)
+                  >>> fmap prettyRlpcMsg
+    where
+        dflags = opts ^. rlpcDFlags
+        don'tBother = "ALL" `S.member` (opts ^. rlpcDFlags)
+
+        byTag :: MsgEnvelope RlpcError -> Bool
+        byTag (view msgSeverity -> SevDebug t) =
+            t `S.member` dflags
+        byTag _ = True
+
+prettyRlpcMsg :: MsgEnvelope RlpcError -> String
+prettyRlpcMsg m@(view msgSeverity -> SevDebug _) = prettyRlpcDebugMsg m
+prettyRlpcMsg m                                  = render $ docRlpcErr m
+
+prettyRlpcDebugMsg :: MsgEnvelope RlpcError -> String
+prettyRlpcDebugMsg msg =
+        T.unpack . foldMap mkLine $ [ t' | t <- ts, t' <- T.lines t ]
+    where
+        mkLine s = "-d" <> tag <> ": " <> s <> "\n"
+        Text ts = msg ^. msgDiagnostic
+        SevDebug tag = msg ^. msgSeverity
+
+docRlpcErr :: MsgEnvelope RlpcError -> Doc
+docRlpcErr msg = header
+                 $$ nest 2 bullets
+                 $$ source
+    where
+        source = vcat $ zipWith (<+>) rule srclines
+            where
+                rule = repeat (ttext . Ansi.blue . Ansi.bold $ "|")
+                srclines = ["", "<problematic source code>", ""]
+        filename = msgColour "<input>"
+        pos = msgColour $ tshow (msg ^. msgSpan . srcspanLine)
+                       <> ":"
+                       <> tshow (msg ^. msgSpan . srcspanColumn)
+
+        header = ttext $ filename <> msgColour ":" <> pos <> msgColour ": "
+                        <> errorColour "error" <> msgColour ":"
+
+        bullets = let Text ts = msg ^. msgDiagnostic
+                  in vcat $ hang "•" 2 . ttext . msgColour <$> ts
+
+        msgColour = Ansi.white . Ansi.bold
+        errorColour = Ansi.red . Ansi.bold
+        ttext = text . T.unpack
+        tshow :: (Show a) => a -> Text
+        tshow = T.pack . show
+
+--------------------------------------------------------------------------------
+
+forFiles_ :: (Monad m)
+          => (FilePath -> RLPCT m a)
+          -> RLPCT m ()
+forFiles_ k = do
+    fs <- view rlpcInputFiles
+    forM_ fs k
+
+-- TODO: catch any exceptions, i.e. non-existent files should be handled by the
+-- compiler
+withSource :: (MonadIO m) => FilePath -> (Text -> RLPCT m a) -> RLPCT m a
+withSource f k = liftIO (T.readFile f) >>= k
+

src/Compiler/RlpcError.hs

@@ -5,12 +5,15 @@ module Compiler.RlpcError
     , MsgEnvelope(..)
     , Severity(..)
     , RlpcError(..)
-    , SrcSpan(..)
     , msgSpan
     , msgDiagnostic
     , msgSeverity
     , liftRlpcErrors
     , errorMsg
+    , debugMsg
+    -- * Located Comonad
+    , Located(..)
+    , SrcSpan(..)
     )
     where
 ----------------------------------------------------------------------------------
@@ -18,8 +21,8 @@ import Control.Monad.Errorful
 import Data.Text                (Text)
 import Data.Text                qualified as T
 import GHC.Exts                 (IsString(..))
-import Lens.Micro.Platform
-import Lens.Micro.Platform.Internal
+import Control.Lens
+import Compiler.Types
 ----------------------------------------------------------------------------------
 
 data MsgEnvelope e = MsgEnvelope
@@ -30,7 +33,7 @@ data MsgEnvelope e = MsgEnvelope
    deriving (Functor, Show)
 
 newtype RlpcError = Text [Text]
-    deriving Show
+               deriving Show
 
 instance IsString RlpcError where
     fromString = Text . pure . T.pack
@@ -43,14 +46,9 @@ instance IsRlpcError RlpcError where
 
 data Severity = SevWarning
               | SevError
+              | SevDebug Text -- ^ Tag
               deriving Show
 
-data SrcSpan = SrcSpan
-    !Int -- ^ Line
-    !Int -- ^ Column
-    !Int -- ^ Length
-    deriving Show
-
 makeLenses ''MsgEnvelope
 
 liftRlpcErrors :: (Functor m, IsRlpcError e)
@@ -68,3 +66,11 @@ errorMsg s e = MsgEnvelope
     , _msgSeverity = SevError
     }
 
+debugMsg :: Text -> e -> MsgEnvelope e
+debugMsg tag e = MsgEnvelope
+    -- TODO: not pretty, but it is a debug message after all
+    { _msgSpan = SrcSpan 0 0 0 0
+    , _msgDiagnostic = e
+    , _msgSeverity = SevDebug tag
+    }
+

src/Compiler/Types.hs

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

src/Control/Monad/Errorful.hs

@@ -1,24 +1,26 @@
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE TupleSections, PatternSynonyms #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE UndecidableInstances #-}
 module Control.Monad.Errorful
-    ( ErrorfulT
-    , runErrorfulT
+    ( ErrorfulT(..)
     , Errorful
+    , pattern Errorful
+    , errorful
     , runErrorful
     , mapErrorful
+    , hoistErrorfulT
     , MonadErrorful(..)
     )
     where
 ----------------------------------------------------------------------------------
 import Control.Monad.State.Strict
+import Control.Monad.Reader
 import Control.Monad.Trans
 import Data.Functor.Identity
 import Data.Coerce
 import Data.HashSet                 (HashSet)
 import Data.HashSet                 qualified as H
-import Lens.Micro
+import Control.Lens
 ----------------------------------------------------------------------------------
 
 newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Maybe a, [e]) }
@@ -28,6 +30,9 @@ type Errorful e = ErrorfulT e Identity
 pattern Errorful :: (Maybe a, [e]) -> Errorful e a
 pattern Errorful a = ErrorfulT (Identity a)
 
+errorful :: (Applicative m) => (Maybe a, [e]) -> ErrorfulT e m a
+errorful = ErrorfulT . pure
+
 runErrorful :: Errorful e a -> (Maybe a, [e])
 runErrorful m = coerce (runErrorfulT m)
 
@@ -46,7 +51,7 @@ 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 & mapped . _1 . _Just %~ f)
+    fmap f (ErrorfulT m) = ErrorfulT (m <&> _1 . _Just %~ f)
 
 instance (Applicative m) => Applicative (ErrorfulT e m) where
     pure a = ErrorfulT . pure $ (Just a, [])
@@ -59,21 +64,24 @@ instance (Monad m) => Monad (ErrorfulT e m) where
     ErrorfulT m >>= k = ErrorfulT $ do
         (a,es) <- m
         case a of
-            Just x      -> runErrorfulT (k x)
+            Just x      -> runErrorfulT (k x) <&> _2 %~ (es<>)
             Nothing     -> pure (Nothing, es)
 
 mapErrorful :: (Functor m) => (e -> e') -> ErrorfulT e m a -> ErrorfulT e' m a
 mapErrorful f (ErrorfulT m) = ErrorfulT $
-    m & mapped . _2 . mapped %~ f
+    m <&> _2 . mapped %~ f
 
 -- when microlens-pro drops we can write this as
---    mapErrorful f = coerced . mapped . _2 . mappd %~ f
+--    mapErrorful f = coerced . mapped . _2 . mapped %~ f
 -- lol
 
+hoistErrorfulT :: (forall a. m a -> n a) -> ErrorfulT e m a -> ErrorfulT e n a
+hoistErrorfulT nt (ErrorfulT m) = ErrorfulT (nt m)
+
 --------------------------------------------------------------------------------
 -- daily dose of n^2 instances
 
-instance (Monad m, MonadErrorful e m) => MonadErrorful e (StateT s m) where
-    addWound = undefined
-    addFatal = undefined
+instance (Monad m, MonadErrorful e m) => MonadErrorful e (ReaderT r m) where
+    addWound = lift . addWound
+    addFatal = lift . addFatal
 

src/Control/Monad/Utils.hs

@@ -1,10 +1,15 @@
 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@
@@ -19,3 +24,14 @@ mapAccumLM k s t = swap <$> runStateT (traverse k' t) s
         k' :: a -> StateT s m b
         k' a = StateT $ fmap swap <$> flip k a
 
+newtype Kendo m a = Kendo { appKendo :: a -> m a }
+
+instance (Monad m) => Semigroup (Kendo m a) where
+    Kendo f <> Kendo g = Kendo (f <=< g)
+
+instance (Monad m) => Monoid (Kendo m a) where
+    mempty = Kendo pure
+
+generalise :: (Monad m) => Identity a -> m a
+generalise (Identity a) = pure a
+

src/Core/Examples.hs

@@ -76,12 +76,12 @@ negExample3 = [coreProg|
 
 arithExample1 :: Program'
 arithExample1 = [coreProg|
-    main = (+#) 3 (negate# 2);
+    main = +# 3 (negate# 2);
 |]
 
 arithExample2 :: Program'
 arithExample2 = [coreProg|
-    main = negate# ((+#) 2 ((*#) 5 3));
+    main = negate# (+# 2 (*# 5 3));
 |]
 
 ifExample1 :: Program'
@@ -96,7 +96,7 @@ ifExample2 = [coreProg|
 
 facExample :: Program'
 facExample = [coreProg|
-    fac n = if# ((==#) n 0) 1 ((*#) n (fac ((-#) n 1)));
+    fac n = if# (==# n 0) 1 (*# n (fac (-# n 1)));
     main = fac 3;
 |]
 
@@ -149,14 +149,14 @@ caseBool1 = [coreProg|
     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
-        ; <0> -> (*#) n (fac ((-#) n 1))
+        ; <0> -> *# n (fac (-# n 1))
         };
 
     main = fac 3;
@@ -171,7 +171,7 @@ sumList = [coreProg|
         list = cons 1 (cons 2 (cons 3 nil));
         sum l = case l of
             { <0>      -> 0
-            ; <1> x xs -> (+#) x (sum xs)
+            ; <1> x xs -> +# x (sum xs)
             };
         main = sum list;
     |]
@@ -179,7 +179,7 @@ sumList = [coreProg|
 constDivZero :: Program'
 constDivZero = [coreProg|
         k x y = x;
-        main = k 3 ((/#) 1 0);
+        main = k 3 (/# 1 0);
     |]
 
 idCase :: Program'
@@ -187,7 +187,7 @@ idCase = [coreProg|
         id x = x;
 
         main = id (case Pack{1 0} of
-            { <1> -> (+#) 2 3
+            { <1> -> +# 2 3
             })
     |]
 
@@ -197,7 +197,7 @@ namedBoolCase :: Program'
 namedBoolCase = [coreProg|
         {-# PackData True 1 0 #-}
         {-# PackData False 0 0 #-}
-        main = case (==#) 1 1 of
+        main = case ==# 1 1 of
             { True -> 123
             ; False -> 456
             }
@@ -207,8 +207,6 @@ namedConsCase :: Program'
 namedConsCase = [coreProg|
         {-# PackData Nil  0 0 #-}
         {-# PackData Cons 1 2 #-}
-        Nil = Pack{0 0};
-        Cons = Pack{1 2};
         foldr f z l = case l of
             { Nil       -> z
             ; Cons x xs -> f x (foldr f z xs)
@@ -245,3 +243,4 @@ namedConsCase = [coreProg|
 --         ]
 
 --}
+

src/Core/HindleyMilner.hs

@@ -10,23 +10,27 @@ module Core.HindleyMilner
     , check
     , checkCoreProg
     , checkCoreProgR
+    , checkCoreExprR
     , TypeError(..)
     , HMError
     )
     where
 ----------------------------------------------------------------------------------
-import Lens.Micro
-import Lens.Micro.Mtl
-import Lens.Micro.Platform
+import Control.Lens             hiding (Context', Context)
 import Data.Maybe               (fromMaybe)
 import Data.Text                qualified as T
+import Data.Pretty              (rpretty)
 import Data.HashMap.Strict      qualified as H
 import Data.Foldable            (traverse_)
+import Data.Functor
+import Data.Functor.Identity
 import Compiler.RLPC
+import Compiler.Types
+import Compiler.RlpcError
 import Control.Monad            (foldM, void, forM)
-import Control.Monad.Errorful   (Errorful, addFatal)
+import Control.Monad.Errorful
 import Control.Monad.State
-import Control.Monad.Utils      (mapAccumLM)
+import Control.Monad.Utils      (mapAccumLM, generalise)
 import Text.Printf
 import Core.Syntax
 ----------------------------------------------------------------------------------
@@ -38,8 +42,6 @@ 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
@@ -56,26 +58,22 @@ instance IsRlpcError TypeError where
         -- todo: use anti-parser instead of show
         TyErrCouldNotUnify t u -> Text
             [ T.pack $ printf "Could not match type `%s` with `%s`."
-                              (show t) (show u)
-            , "Expected: " <> tshow t
-            , "Got: " <> tshow u
+                              (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 error lol"
+            [ T.pack $ printf "Recursive type: `%s' occurs in `%s'"
+                              (rpretty @String t) (rpretty @String x)
             ]
 
-        where tshow = T.pack . show
-
 -- | Synonym for @Errorful [TypeError]@. This means an @HMError@ action may
 -- throw any number of fatal or nonfatal errors. Run with @runErrorful@.
 type HMError = Errorful TypeError
 
--- TODO: better errors. Errorful-esque, with cummulative errors instead of
--- instantly dying.
-
 -- | Assert that an expression unifies with a given type
 --
 -- >>> let e = [coreProg|3|]
@@ -93,7 +91,7 @@ check g t1 e = do
 -- in the mean time all top-level binders must have a type annotation.
 checkCoreProg :: Program' -> HMError ()
 checkCoreProg p = scDefs
-            & traverse_ k
+                & traverse_ k
     where
         scDefs = p ^. programScDefs
         g = gatherTypeSigs p
@@ -105,10 +103,17 @@ checkCoreProg p = scDefs
              where scname = sc ^. _lhs._1
 
 -- | @checkCoreProgR p@ returns @p@ if @p@ successfully typechecks.
-checkCoreProgR :: Program' -> RLPC Program'
-checkCoreProgR p = undefined
+checkCoreProgR :: forall m. (Monad m) => Program' -> RLPCT m Program'
+checkCoreProgR p = (hoistRlpcT generalise . liftE . checkCoreProg $ p)
+                $> p
+    where
+        liftE = liftErrorful . mapErrorful (errorMsg (SrcSpan 0 0 0 0))
 
-{-# WARNING checkCoreProgR "unimpl" #-}
+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.
 --
@@ -271,9 +276,3 @@ demoContext =
     , ("False", TyCon "Bool")
     ]
 
-pprintType :: Type -> String
-pprintType (s :-> t) = "(" <> pprintType s <> " -> " <> pprintType t <> ")"
-pprintType TyFun = "(->)"
-pprintType (TyVar x) = x ^. unpacked
-pprintType (TyCon t) = t ^. unpacked
-

src/Core/Lex.x

@@ -20,11 +20,13 @@ import Debug.Trace
 import Data.Text            (Text)
 import Data.Text            qualified as T
 import Data.String          (IsString(..))
+import Data.Functor.Identity
 import Core.Syntax
 import Compiler.RLPC
+import Compiler.Types
+-- TODO: unify Located definitions
 import Compiler.RlpcError
-import Lens.Micro
-import Lens.Micro.TH
+import Control.Lens
 }
 
 %wrapper "monad-strict-text"
@@ -118,11 +120,9 @@ rlp :-
 }
 
 {
-data Located a = Located Int Int Int a
-    deriving Show
 
 constTok :: t -> AlexInput -> Int -> Alex (Located t)
-constTok t (AlexPn _ y x,_,_,_) l = pure $ Located y x l t
+constTok t (AlexPn _ y x,_,_,_) l = pure $ nolo t
 
 data CoreToken = TokenLet
                | TokenLetrec
@@ -169,7 +169,7 @@ data SrcErrorType = SrcErrLexical String
 type Lexer = AlexInput -> Int -> Alex (Located CoreToken)
 
 lexWith :: (Text -> CoreToken) -> Lexer
-lexWith f (AlexPn _ y x,_,_,s) l = pure $ Located y x l (f $ T.take l s)
+lexWith f (AlexPn _ y x,_,_,s) l = pure . nolo . f . T.take l $ s
 
 -- | The main lexer driver.
 lexCore :: Text -> RLPC [Located CoreToken]
@@ -179,21 +179,24 @@ lexCore s = case m of
     where
         m = runAlex s lexStream
 
-lexCoreR :: Text -> RLPC [Located CoreToken]
-lexCoreR = lexCore
+lexCoreR :: forall m. (Applicative m) => Text -> RLPCT m [Located CoreToken]
+lexCoreR = hoistRlpcT generalise . lexCore
+    where
+        generalise :: forall a. Identity a -> m a
+        generalise (Identity a) = pure a
 
 -- | @lexCore@, but the tokens are stripped of location info. Useful for
 -- debugging
 lexCore' :: Text -> RLPC [CoreToken]
 lexCore' s = fmap f <$> lexCore s
-    where f (Located _ _ _ t) = t
+    where f (Located _ t) = t
 
 lexStream :: Alex [Located CoreToken]
 lexStream = do
     l <- alexMonadScan
     case l of
-        Located _ _ _ TokenEOF  -> pure [l]
-        _                       -> (l:) <$> lexStream
+        Located _ TokenEOF -> pure [l]
+        _                  -> (l:) <$> lexStream
 
 data ParseError = ParErrLexical String
                 | ParErrParse
@@ -209,7 +212,7 @@ instance IsRlpcError ParseError where
 
 alexEOF :: Alex (Located CoreToken)
 alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) ->
-    Right (st, Located y x 0 TokenEOF)
+    Right (st, nolo $ TokenEOF)
 
 }
 

src/Core/Lex.x.old

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

src/Core/Parse.y

@@ -7,6 +7,7 @@ Description : Parser for the Core language
 module Core.Parse
     ( parseCore
     , parseCoreExpr
+    , parseCoreExprR
     , parseCoreProg
     , parseCoreProgR
     , module Core.Lex -- temp convenience
@@ -16,11 +17,14 @@ module Core.Parse
     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 Lens.Micro
+import Control.Monad
+import Control.Lens         hiding (snoc)
 import Data.Default.Class   (def)
 import Data.Hashable        (Hashable)
 import Data.List.Extra
@@ -38,34 +42,34 @@ import Data.HashMap.Strict  qualified as H
 %monad { RLPC } { happyBind } { happyPure }
 
 %token
-      let             { Located _ _ _ TokenLet }
-      letrec          { Located _ _ _ TokenLetrec }
-      module          { Located _ _ _ TokenModule }
-      where           { Located _ _ _ TokenWhere }
-      case            { Located _ _ _ TokenCase }
-      of              { Located _ _ _ TokenOf }
-      pack            { Located _ _ _ TokenPack } -- temp
-      in              { Located _ _ _ TokenIn }
-      litint          { Located _ _ _ (TokenLitInt $$) }
-      varname         { Located _ _ _ (TokenVarName $$) }
-      varsym          { Located _ _ _ (TokenVarSym $$) }
-      conname         { Located _ _ _ (TokenConName $$) }
-      consym          { Located _ _ _ (TokenConSym $$) }
-      alttag          { Located _ _ _ (TokenAltTag $$) }
-      word            { Located _ _ _ (TokenWord $$) }
-      'λ'             { Located _ _ _ TokenLambda }
-      '->'            { Located _ _ _ TokenArrow }
-      '='             { Located _ _ _ TokenEquals }
-      '@'             { Located _ _ _ TokenTypeApp }
-      '('             { Located _ _ _ TokenLParen }
-      ')'             { Located _ _ _ TokenRParen }
-      '{'             { Located _ _ _ TokenLBrace }
-      '}'             { Located _ _ _ TokenRBrace }
-      '{-#'           { Located _ _ _ TokenLPragma }
-      '#-}'           { Located _ _ _ TokenRPragma }
-      ';'             { Located _ _ _ TokenSemicolon }
-      '::'            { Located _ _ _ TokenHasType }
-      eof             { Located _ _ _ TokenEOF }
+      let             { Located _ TokenLet }
+      letrec          { Located _ TokenLetrec }
+      module          { Located _ TokenModule }
+      where           { Located _ TokenWhere }
+      case            { Located _ TokenCase }
+      of              { Located _ TokenOf }
+      pack            { Located _ TokenPack } -- temp
+      in              { Located _ TokenIn }
+      litint          { Located _ (TokenLitInt $$) }
+      varname         { Located _ (TokenVarName $$) }
+      varsym          { Located _ (TokenVarSym $$) }
+      conname         { Located _ (TokenConName $$) }
+      consym          { Located _ (TokenConSym $$) }
+      alttag          { Located _ (TokenAltTag $$) }
+      word            { Located _ (TokenWord $$) }
+      'λ'             { Located _ TokenLambda }
+      '->'            { Located _ TokenArrow }
+      '='             { Located _ TokenEquals }
+      '@'             { Located _ TokenTypeApp }
+      '('             { Located _ TokenLParen }
+      ')'             { Located _ TokenRParen }
+      '{'             { Located _ TokenLBrace }
+      '}'             { Located _ TokenRBrace }
+      '{-#'           { Located _ TokenLPragma }
+      '#-}'           { Located _ TokenRPragma }
+      ';'             { Located _ TokenSemicolon }
+      '::'            { Located _ TokenHasType }
+      eof             { Located _ TokenEOF }
 
 %%
 
@@ -185,18 +189,18 @@ Id              : Var                                { $1 }
                 | Con                                { $1 }
 
 Var             :: { Name }
-Var             : '(' varsym ')'                    { $2 }
-                | varname                           { $1 }
+Var             : varname                           { $1 }
+                | varsym                            { $1 }
 
 Con             :: { Name }
-Con             : '(' consym ')'                    { $2 }
-                | conname                           { $1 }
+Con             : conname                           { $1 }
+                | consym                            { $1 }
 
 {
 
 parseError :: [Located CoreToken] -> RLPC a
-parseError (Located y x l t : _) =
-    error $ show y <> ":" <> show x
+parseError (Located _ t : _) =
+    error $ "<line>" <> ":" <> "<col>"
          <> ": parse error at token `" <> show t <> "'"
 
 {-# WARNING parseError "unimpl" #-}
@@ -224,8 +228,16 @@ insScDef sc = programScDefs %~ (sc:)
 singletonScDef :: (Hashable b) => ScDef b -> Program b
 singletonScDef sc = insScDef sc mempty
 
-parseCoreProgR :: [Located CoreToken] -> RLPC Program'
-parseCoreProgR = parseCoreProg
+parseCoreExprR :: (Monad m) => [Located CoreToken] -> RLPCT m Expr'
+parseCoreExprR = hoistRlpcT generalise . parseCoreExpr
+
+parseCoreProgR :: forall m. (Monad m) => [Located CoreToken] -> RLPCT m Program'
+parseCoreProgR = ddumpast <=< (hoistRlpcT generalise . parseCoreProg)
+    where
+        ddumpast :: Program' -> RLPCT m Program'
+        ddumpast p = do
+            addDebugMsg "dump-parsed-core" . show $ p
+            pure p
 
 happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b
 happyBind m k = m >>= k

src/Core/Parse.y.old

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

src/Core/Syntax.hs

@@ -5,10 +5,8 @@ Description : Core ASTs and the like
 {-# LANGUAGE PatternSynonyms, OverloadedStrings #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE DerivingStrategies, DerivingVia #-}
 -- for recursion-schemes
-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable
-  , TemplateHaskell, TypeFamilies #-}
+{-# LANGUAGE DeriveTraversable, TypeFamilies #-}
 module Core.Syntax
     ( Expr(..)
     , ExprF(..)
@@ -41,6 +39,7 @@ module Core.Syntax
     , Binding'
     , HasRHS(_rhs)
     , HasLHS(_lhs)
+    , Pretty(pretty)
     )
     where
 ----------------------------------------------------------------------------------
@@ -56,11 +55,12 @@ import Data.HashMap.Strict          qualified as H
 import Data.Hashable
 import Data.Text                    qualified as T
 import Data.Char
-import GHC.Generics
+import Data.These
+import Data.Bifoldable              (bifoldr)
+import GHC.Generics                 (Generic, Generically(..))
 -- Lift instances for the Core quasiquoters
 import Language.Haskell.TH.Syntax   (Lift)
-import Lens.Micro.TH                (makeLenses)
-import Lens.Micro
+import Control.Lens
 ----------------------------------------------------------------------------------
 
 data Expr b = Var Name
@@ -103,7 +103,7 @@ data Binding b = Binding b (Expr b)
 deriving instance (Eq b) => Eq (Binding b)
 
 infixl 1 :=
-pattern (:=) :: b -> (Expr b) -> (Binding b)
+pattern (:=) :: b -> Expr b -> Binding b
 pattern k := v = Binding k v
 
 data Alter b = Alter AltCon [b] (Expr b)
@@ -120,10 +120,10 @@ data Rec = Rec
 data AltCon = AltData Name
             | AltTag Tag
             | AltLit Lit
-            | Default
+            | AltDefault
             deriving (Show, Read, Eq, Lift)
 
-data Lit = IntL Int
+newtype Lit = IntL Int
     deriving (Show, Read, Eq, Lift)
 
 type Name = T.Text
@@ -141,8 +141,8 @@ data Module b = Module (Maybe (Name, [Name])) (Program b)
 data Program b = Program
     { _programScDefs   :: [ScDef b]
     , _programTypeSigs :: HashMap b Type
-    -- map constructors to their tag and arity
     , _programDataTags :: HashMap b (Tag, Int)
+    -- ^ map constructors to their tag and arity
     }
     deriving (Show, Lift, Generic)
     deriving (Semigroup, Monoid)
@@ -152,6 +152,12 @@ 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
@@ -201,10 +207,94 @@ instance HasLHS (Alter b) (Alter b) (AltCon, [b]) (AltCon, [b]) where
 instance HasLHS (ScDef b) (ScDef b) (b, [b]) (b, [b]) where
     _lhs = lens
         (\ (ScDef n as _) -> (n,as))
-        (\ (ScDef _ _ e) (n',as') -> (ScDef n' as' e))
+        (\ (ScDef _ _ e) (n',as') -> ScDef n' as' e)
 
 instance HasLHS (Binding b) (Binding b) b b where
     _lhs = lens
         (\ (k := _) -> k)
         (\ (_ := e) k' -> k' := e)
 
+--------------------------------------------------------------------------------
+
+-- TODO: print type sigs with corresponding scdefs
+-- TODO: emit pragmas for datatags
+instance (Hashable b, Pretty b) => Pretty (Program b) where
+    pretty p = ifoldrOf (programDataTags . ifolded) cataDataTag mempty p
+           $+$ vlinesOf (programJoinedDefs . to prettyGroup) p
+        where
+            programJoinedDefs :: Fold (Program b) (These (b, Type) (ScDef b))
+            programJoinedDefs = folding $ \p ->
+                foldMapOf programTypeSigs thisTs p
+                `u` foldMapOf programScDefs thatSc p
+              where u = H.unionWith unionThese
+
+            thisTs = ifoldMap @b @(HashMap b)
+                (\n t -> H.singleton n (This (n,t)))
+            thatSc = foldMap $ \sc ->
+                H.singleton (sc ^. _lhs . _1) (That sc)
+
+            prettyGroup :: These (b, Type) (ScDef b) -> Doc
+            prettyGroup = bifoldr ($$) ($$) mempty . bimap prettyTySig pretty
+
+            prettyTySig (n,t) = hsep [ttext n, "::", pretty t]
+
+            unionThese (This a) (That b) = These a b
+            unionThese (That b) (This a) = These a b
+            unionThese (These a b) _     = These a b
+
+            cataDataTag n (t,a) acc = prettyDataTag n t a $+$ acc
+
+            prettyDataTag n t a =
+                hsep ["{-#", "PackData", ttext n, ttext t, ttext a, "#-}"]
+
+instance Pretty Type where
+    prettyPrec _ (TyVar n) = ttext n
+    prettyPrec _ TyFun = "(->)"
+    prettyPrec _ (TyCon n) = ttext n
+    prettyPrec p (a :-> b) = maybeParens (p>0) $
+        hsep [prettyPrec 1 a, "->", prettyPrec 0 b]
+    prettyPrec p (TyApp f x) = maybeParens (p>1) $
+        prettyPrec 1 f <+> prettyPrec 2 x
+
+instance (Pretty b) => Pretty (ScDef b) where
+    pretty sc = hsep [name, as, "=", hang empty 1 e, ";"]
+        where
+            name = ttext $ sc ^. _lhs . _1
+            as = sc & hsepOf (_lhs . _2 . each . to ttext)
+            e = pretty $ sc ^. _rhs
+
+instance (Pretty b) => Pretty (Expr b) where
+    prettyPrec _ (Var n)      = ttext n
+    prettyPrec _ (Con t a)    = "Pack{" <> (ttext t <+> ttext a) <> "}"
+    prettyPrec _ (Lam bs e)   = hsep ["λ", hsep (prettyPrec 1 <$> bs), "->", pretty e]
+    prettyPrec _ (Let r bs e) = hsep [word, explicitLayout bs]
+                            $+$ hsep ["in", pretty e]
+        where word = if r == Rec then "letrec" else "let"
+    prettyPrec p (App f x)    = maybeParens (p>0) $
+        prettyPrec 0 f <+> prettyPrec 1 x
+    prettyPrec _ (Lit l)      = pretty l
+    prettyPrec p (Case e as)  = maybeParens (p>0) $
+        "case" <+> pretty e <+> "of"
+        $+$ nest 2 (explicitLayout as)
+
+instance (Pretty b) => Pretty (Alter b) where
+    pretty (Alter c as e) =
+        hsep [pretty c, hsep (pretty <$> as), "->", pretty e]
+
+instance Pretty AltCon where
+    pretty (AltData n) = ttext n
+    pretty (AltLit l) = pretty l
+    pretty (AltTag t) = ttext t
+    pretty AltDefault = "_"
+
+instance Pretty Lit where
+    pretty (IntL n) = ttext n
+
+instance (Pretty b) => Pretty (Binding b) where
+    pretty (k := v) = hsep [pretty k, "=", pretty v]
+
+explicitLayout :: (Pretty a) => [a] -> Doc
+explicitLayout as = vcat inner <+> "}" where
+    inner = zipWith (<+>) delims (pretty <$> as)
+    delims = "{" : repeat ";"
+

src/Core/TH.hs

@@ -5,6 +5,7 @@ Description : Core quasiquoters
 module Core.TH
     ( coreExpr
     , coreProg
+    , coreExprT
     , coreProgT
     )
     where
@@ -22,20 +23,28 @@ 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
 coreProg = mkqq $ lexCoreR >=> parseCoreProgR
 
 coreExpr :: QuasiQuoter
-coreExpr = mkqq $ lexCoreR >=> parseCoreExpr
+coreExpr = mkqq $ lexCoreR >=> parseCoreExprR
 
 -- | Type-checked @coreProg@
 coreProgT :: QuasiQuoter
 coreProgT = mkqq $ lexCoreR >=> parseCoreProgR >=> checkCoreProgR
 
-mkqq :: (Lift a) => (Text -> RLPC a) -> QuasiQuoter
+coreExprT :: QuasiQuoter
+coreExprT = mkqq $ lexCoreR >=> parseCoreExprR >=> checkCoreExprR g
+    where
+        g = [ ("+#", TyCon "Int#" :-> TyCon "Int#" :-> TyCon "Int#")
+            , ("id", TyCon "a" :-> TyCon "a")
+            , ("fix", (TyCon "a" :-> TyCon "a") :-> TyCon "a")
+            ]
+
+mkqq :: (Lift a) => (Text -> RLPCIO a) -> QuasiQuoter
 mkqq p = QuasiQuoter
     { quoteExp = mkq p
     , quotePat = error "core quasiquotes may only be used in expressions"
@@ -43,8 +52,6 @@ mkqq p = QuasiQuoter
     , quoteDec = error "core quasiquotes may only be used in expressions"
     }
 
-mkq :: (Lift a) => (Text -> RLPC a) -> String -> Q Exp
-mkq parse s = case evalRLPC def (parse $ T.pack s) of
-    (Just a,  _) -> lift a
-    (Nothing, _) -> error "todo: aaahhbbhjhbdjhabsjh"
+mkq :: (Lift a) => (Text -> RLPCIO a) -> String -> Q Exp
+mkq parse s = liftIO $ evalRLPCIO def (parse $ T.pack s) >>= lift
 

src/Core/Utils.hs

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

src/Core2Core.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE ImplicitParams #-}
-{-# LANGUAGE LambdaCase #-}
 module Core2Core
     ( core2core
     , gmPrep
@@ -15,27 +14,53 @@ 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.Arrow            ((>>>))
 import Data.Text                qualified as T
 import Data.HashMap.Strict      (HashMap)
 import Numeric                  (showHex)
-import Lens.Micro.Platform
+
+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)
              & tagData
+             & defineData
     where
         globals = p ^.. programScDefs . each . _lhs . _1
                 & S.fromList
 
+-- | Define concrete supercombinators for all datatags defined via pragmas (or
+-- desugaring)
+
+defineData :: Program' -> Program'
+defineData p = p & programScDefs <>~ defs
+    where
+        defs = p ^. programDataTags
+             . to (ifoldMap (\k (t,a) -> [ScDef k [] (Con t a)]))
+
+-- | Substitute all pattern matches on named constructors for matches on tags
+
 tagData :: Program' -> Program'
 tagData p = let ?dt = p ^. programDataTags
             in p & programRhss %~ cata go where
@@ -44,7 +69,7 @@ tagData p = let ?dt = p ^. programDataTags
     go x                = embed x
 
     tagAlts :: (?dt :: HashMap Name (Tag, Int)) => Alter' -> Alter'
-    tagAlts (Alter (AltData c) bs e) = Alter (AltTag tag) bs e
+    tagAlts (Alter (AltData c) bs e) = Alter (AltTag tag) bs (cata go e)
         where tag = case ?dt ^. at c of
                 Just (t,_) -> t
                 -- TODO: errorful
@@ -59,6 +84,7 @@ 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
@@ -88,7 +114,7 @@ floatNonStrictCases g = goE
                 altBodies = (\(Alter _ _ b) -> b) <$> as
             tell [sc]
             goE e
-            traverse goE altBodies
+            traverse_ goE altBodies
             pure e'
         goC (f :$ x)            = (:$) <$> goC f <*> goC x
         goC (Let r bs e)        = Let r <$> bs' <*> goE e
@@ -97,7 +123,7 @@ floatNonStrictCases g = goE
         goC (Var k)             = pure (Var k)
         goC (Con t as)          = pure (Con t as)
 
-        name = state (fromJust . uncons)
+        name = state (fromJust . Data.List.uncons)
 
         -- extract the right-hand sides of a list of bindings, traverse each
         -- one, and return the original list of bindings
@@ -105,6 +131,7 @@ floatNonStrictCases g = goE
         travBs c bs = bs ^.. each . _rhs
                     & traverse goC
                     & const (pure bs)
+        -- ^ ??? what the fuck?
 
 -- when provided with a case expr, floatCase will float the case into a
 -- supercombinator of its free variables. the sc is returned along with an

src/Data/Heap.hs

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

src/Data/Pretty.hs

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

src/GM.hs

@@ -8,8 +8,18 @@ Description : The G-Machine
 module GM
     ( hdbgProg
     , evalProg
+    , evalProgR
+    , GmState(..)
+    , gmCode, gmStack, gmDump, gmHeap, gmEnv, gmStats
+    , stsReductions
+    , stsPrimReductions
+    , stsAllocations
+    , stsDereferences
+    , stsGCCycles
     , Node(..)
+    , showState
     , gmEvalProg
+    , Stats(..)
     , finalStateOf
     , resultOf
     , resultOfExpr
@@ -21,121 +31,52 @@ import Data.List                    (mapAccumL)
 import Data.Maybe                   (fromMaybe, mapMaybe)
 import Data.Monoid                  (Endo(..))
 import Data.Tuple                   (swap)
-import Lens.Micro
-import Lens.Micro.Extras            (view)
-import Lens.Micro.TH
-import Lens.Micro.Platform          (packed, unpacked)
-import Lens.Micro.Platform.Internal (IsText(..))
+import Control.Lens
+import Data.Text.Lens               (IsText, packed, unpacked)
 import Text.Printf
-import Text.PrettyPrint             hiding ((<>))
-import Text.PrettyPrint.HughesPJ    (maybeParens)
 import Data.Foldable                (traverse_)
 import System.IO                    (Handle, hPutStrLn)
+import Text.PrettyPrint             (render)
+-- 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
+import GM.Types
+import GM.Print
 ----------------------------------------------------------------------------------
 
-{-}
+tag_Unit_unit :: Int
+tag_Unit_unit = 0
 
-hdbgProg = undefined
-evalProg = undefined
+tag_Bool_True :: Int
+tag_Bool_True = 1
 
-data Node = NNum Int
-          | NAp Addr Addr
-          | NInd Addr
-          | NUninitialised
-          | NConstr Tag [Addr] -- NConstr Tag Components
-          | NMarked Node
-          deriving (Show, Eq)
-
---}
-
-data GmState = GmState
-    { _gmCode   :: Code
-    , _gmStack  :: Stack
-    , _gmDump   :: Dump
-    , _gmHeap   :: GmHeap
-    , _gmEnv    :: Env
-    , _gmStats  :: Stats
-    }
-    deriving Show
-
-type Code = [Instr]
-type Stack = [Addr]
-type Dump = [(Code, Stack)]
-type Env = [(Key, Addr)]
-type GmHeap = Heap Node
-
-data Key = NameKey Name
-         | ConstrKey Tag Int
-         deriving (Show, Eq)
-
-data Instr = Unwind
-           | PushGlobal Name
-           | PushConstr Tag Int
-           | PushInt Int
-           | Push Int
-           | MkAp
-           | Slide Int
-           | Update Int
-           | Pop Int
-           | Alloc Int
-           | Eval
-           -- arith
-           | Neg | Add | Sub | Mul | Div
-           -- comparison
-           | Equals
-           | Pack Tag Int -- Pack Tag Arity
-           | CaseJump [(Tag, Code)]
-           | Split Int
-           | Halt
-           deriving (Show, Eq)
-
-data Node = NNum Int
-          | NAp Addr Addr
-          -- NGlobal is the GM equivalent of NSupercomb. rather than storing a
-          -- template to be instantiated, NGlobal holds the global's arity and
-          -- the pre-compiled code :3
-          | NGlobal Int Code
-          | NInd Addr
-          | NUninitialised
-          | NConstr Tag [Addr] -- NConstr Tag Components
-          | NMarked Node
-          deriving (Show, Eq)
-
--- TODO: log executed instructions
-data Stats = Stats
-    { _stsReductions     :: Int
-    , _stsPrimReductions :: Int
-    , _stsAllocations    :: Int
-    , _stsDereferences   :: Int
-    , _stsGCCycles       :: Int
-    }
-    deriving Show
-
-instance Default Stats where
-    def = Stats 0 0 0 0 0
-
--- TODO: _gmGlobals should not have a setter
-makeLenses ''GmState
-makeLenses ''Stats
-pure []
+tag_Bool_False :: Int
+tag_Bool_False = 0
 
 ----------------------------------------------------------------------------------
 
-evalProg :: Program' -> Maybe (Node, Stats)
-evalProg p = res <&> (,sts)
-    where
-        final = eval (compile p) & last
-        h = final ^. gmHeap
-        sts = final ^. gmStats
-        resAddr = final ^. gmStack ^? _head
-        res = resAddr >>= flip hLookup h
+evalProg :: Program' -> [GmState]
+evalProg = eval . compile
 
-hdbgProg :: Program' -> Handle -> IO (Node, Stats)
+-- evalProg :: Program' -> Maybe (Node, Stats)
+-- evalProg p = res <&> (,sts)
+--     where
+--         final = eval (compile p) & last
+--         h = final ^. gmHeap
+--         sts = final ^. gmStats
+--         resAddr = final ^. gmStack ^? _head
+--         res = resAddr >>= flip hLookup h
+
+hdbgProg :: Program' -> Handle -> IO GmState
 hdbgProg p hio = do
     (renderOut . showState) `traverse_` states
     -- TODO: i'd like the statistics to be at the top of the file, but `sts`
@@ -143,7 +84,7 @@ hdbgProg p hio = do
     -- *can't* get partial logs in the case of a crash. this is in opposition to
     -- the above traversal which *will* produce partial logs. i love laziness :3
     renderOut . showStats $ sts
-    pure (res, sts)
+    pure final
     where
         renderOut r = hPutStrLn hio $ render r ++ "\n"
 
@@ -156,6 +97,21 @@ hdbgProg p hio = do
         [resAddr] = final ^. gmStack
         res = hLookupUnsafe resAddr h
 
+evalProgR :: (Monad m) => Program' -> RLPCT m (Node, Stats)
+evalProgR p = do
+    (renderOut . showState) `traverse_` states
+    renderOut . showStats $ sts
+    pure (res, sts)
+    where
+        renderOut r = addDebugMsg "dump-eval" $ render r ++ "\n"
+        states = eval . compile $ p
+        final = last states
+
+        sts = final ^. gmStats
+        -- the address of the result should be the one and only stack entry
+        [resAddr] = final ^. gmStack
+        res = hLookupUnsafe resAddr (final ^. gmHeap)
+
 eval :: GmState -> [GmState]
 eval st = st : rest
     where
@@ -178,29 +134,55 @@ isFinal st = null $ st ^. gmCode
 
 step :: GmState -> GmState
 step st = case head (st ^. gmCode) of
-    Unwind         -> unwindI        
+    Unwind         -> unwindI
     PushGlobal n   -> pushGlobalI   n
     PushConstr t n -> pushConstrI t n
     PushInt    n   -> pushIntI      n
     Push       n   -> pushI         n
-    MkAp           -> mkApI          
+    MkAp           -> mkApI
     Slide      n   -> slideI        n
     Pop        n   -> popI          n
     Update     n   -> updateI       n
     Alloc      n   -> allocI        n
-    Eval           -> evalI          
-    Neg            -> negI           
-    Add            -> addI           
-    Sub            -> subI           
-    Mul            -> mulI           
-    Div            -> divI           
-    Equals         -> equalsI           
+    Eval           -> evalI
+    Neg            -> negI
+    Add            -> addI
+    Sub            -> subI
+    Mul            -> mulI
+    Div            -> divI
+    Equals         -> equalsI
+    Lesser         -> lesserI
+    GreaterEq      -> greaterEqI
     Split      n   -> splitI        n
     Pack       t n -> packI       t n
     CaseJump    as -> caseJumpI    as
+    Print          -> printI
     Halt           -> haltI
     where
 
+        printI :: GmState
+        printI = case hLookupUnsafe a h of
+            NNum n       -> (evilTempPrinter `seq` st)
+                          & gmCode .~ i
+                          & gmStack .~ s
+                where
+                    -- TODO: an actual output system
+                    -- TODO: an actual output system
+                    -- TODO: an actual output system
+                    -- TODO: an actual output system
+                    evilTempPrinter = unsafePerformIO (print n)
+            NConstr _ as -> st
+                          & gmCode .~ i' ++ i
+                          & gmStack .~ s'
+                where
+                    i' = mconcat $ replicate n [Eval,Print]
+                    n = length as
+                    s' = as ++ s
+          where
+            h = st ^. gmHeap
+            (a:s) = st ^. gmStack
+            Print : i = st ^. gmCode
+
         -- nuke the state
         haltI :: GmState
         haltI = error "halt#"
@@ -394,8 +376,10 @@ step st = case head (st ^. gmCode) of
         mulI = primitive2 boxInt unboxInt (*) st
         divI = primitive2 boxInt unboxInt div st
 
-        equalsI :: GmState
+        lesserI, greaterEqI, equalsI :: GmState
         equalsI = primitive2 boxBool unboxInt (==) st
+        lesserI = primitive2 boxBool unboxInt (<) st
+        greaterEqI = primitive2 boxBool unboxInt (>=) st
 
         splitI :: Int -> GmState
         splitI n = st
@@ -537,12 +521,13 @@ boxBool st p = st
     where
         h = st ^. gmHeap
         (h',a) = alloc h (NConstr p' [])
-        p' = if p then 1 else 0
+        p' = if p then tag_Bool_True else tag_Bool_False
 
 unboxBool :: Addr -> GmState -> Bool
 unboxBool a st = case hLookup a h of
-        Just (NConstr 1 []) -> True
-        Just (NConstr 0 []) -> False
+        Just (NConstr t [])
+            | t == tag_Bool_True  -> True
+            | t == tag_Bool_False -> False
         Just _              -> error "unboxInt received a non-int"
         Nothing             -> error "unboxInt received an invalid address"
     where h = st ^. gmHeap
@@ -578,6 +563,10 @@ compiledPrims =
     , binop "*#" Mul
     , binop "/#" Div
     , binop "==#" Equals
+    , binop "<#" Lesser
+    , binop ">=#" GreaterEq
+    , ("print#", 1, [ Push 0, Eval, Print, Pack tag_Unit_unit 0, Update 1, Pop 1
+                    , Unwind ])
     ]
     where
         unop k i = (k, 1, [Push 0, Eval, i, Update 1, Pop 1, Unwind])
@@ -681,14 +670,12 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
                 mconcat binders <> compileE g' e <> [Slide d]
             where
                 d = length bs
-                (g',binders) = mapAccumL compileBinder (argOffset d g) addressed
-                -- kinda gross. revisit this
-                addressed = bs `zip` reverse [0 .. d-1]
+                (g',binders) = mapAccumL compileBinder g bs
 
-                compileBinder :: Env -> (Binding', Int) -> (Env, Code)
-                compileBinder m (k := v, a) = (m',c)
+                compileBinder :: Env -> Binding' -> (Env, Code)
+                compileBinder m (k := v) = (m',c)
                     where
-                        m' = (NameKey k, a) : m
+                        m' = (NameKey k, 0) : argOffset 1 m
                         -- make note that we use m rather than m'!
                         c = compileC m v
 
@@ -716,13 +703,15 @@ 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 as = fmap (compileA g) as
+        compileD g = fmap (compileA g)
 
         compileA :: Env -> Alter' -> (Tag, Code)
         compileA g (Alter (AltTag t) as e) = (t, [Split n] <> c <> [Slide n])
@@ -747,185 +736,8 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
         argOffset :: Int -> Env -> Env
         argOffset n = each . _2 %~ (+n)
 
-showCon :: (IsText a) => Tag -> Int -> a
-showCon t n = printf "Pack{%d %d}" t n ^. packed
-
 ----------------------------------------------------------------------------------
 
-pprTabstop :: Int
-pprTabstop = 4
-
-qquotes :: Doc -> Doc
-qquotes d = "`" <> d <> "'"
-
-showStats :: Stats -> Doc
-showStats sts = "==== Stats ============" $$ stats
-    where
-        stats = text $ printf
-            "Reductions      : %5d\n\
-            \Prim Reductions : %5d\n\
-            \Allocations     : %5d\n\
-            \GC Cycles       : %5d"
-            (sts ^. stsReductions)
-            (sts ^. stsPrimReductions)
-            (sts ^. stsAllocations)
-            (sts ^. stsGCCycles)
-
-showState :: GmState -> Doc
-showState st = vcat
-        [ "==== GmState " <> int stnum <> " "
-            <> text (replicate (28 - 13 - 1 - digitalWidth stnum) '=')
-        , "-- Next instructions -------"
-        , info $ showCodeShort c
-        , "-- Stack -------------------"
-        , info $ showStack st
-        , "-- Heap --------------------"
-        , info $ showHeap st
-        , "-- Dump --------------------"
-        , info $ showDump st
-        ]
-    where
-        stnum = st ^. (gmStats . stsReductions)
-        c = st ^. gmCode
-
-        -- indent data
-        info = nest pprTabstop
-
-showCodeShort :: Code -> Doc
-showCodeShort c = braces c'
-    where
-        c' | length c > 3 = list (showInstr <$> take 3 c) <> "; ..."
-           | otherwise    = list (showInstr <$> c)
-        list = hcat . punctuate "; "
-
-showStackShort :: Stack -> Doc
-showStackShort s = brackets s'
-    where
-           -- no access to heap, otherwise we'd use showNodeAt
-        s' | length s > 3 = list (showEntry <$> take 3 s) <> ", ..."
-           | otherwise    = list (showEntry <$> s)
-        list = hcat . punctuate ", "
-        showEntry = text . show
-
-showStack :: GmState -> Doc
-showStack st = vcat $ uncurry showEntry <$> si
-    where
-        h = st ^. gmHeap
-        s = st ^. gmStack
-
-        -- stack with labeled indices
-        si = [0..] `zip` s
-
-        w = maxWidth (addresses h)
-        showIndex n = padInt w n <> ": "
-
-        showEntry :: Int -> Addr -> Doc
-        showEntry n a = showIndex n <> showNodeAt st a
-
-showDump :: GmState -> Doc
-showDump st = vcat $ uncurry showEntry <$> di
-    where
-        d = st ^. gmDump
-        di = [0..] `zip` d
-
-        showIndex n = padInt w n <> ": "
-        w = maxWidth (fst <$> di)
-
-        showEntry :: Int -> (Code, Stack) -> Doc
-        showEntry n (c,s) = showIndex n <> nest pprTabstop entry
-            where
-                entry = ("Stack : " <> showCodeShort c)
-                     $$ ("Code  : " <> showStackShort s)
-
-padInt :: Int -> Int -> Doc
-padInt m n = text (replicate (m - digitalWidth n) ' ') <> int n
-
-maxWidth :: [Int] -> Int
-maxWidth ns = digitalWidth $ maximum ns
-
-digitalWidth :: Int -> Int
-digitalWidth = length . show
-
-showHeap :: GmState -> Doc
-showHeap st = vcat $ showEntry <$> addrs
-    where
-        showAddr n = padInt w n <> ": "
-
-        w = maxWidth addrs
-        h = st ^. gmHeap
-        addrs = addresses h
-
-        showEntry :: Addr -> Doc
-        showEntry a = showAddr a <> showNodeAt st a
-
-showNodeAt :: GmState -> Addr -> Doc
-showNodeAt = showNodeAtP 0
-
-showNodeAtP :: Int -> GmState -> Addr -> Doc
-showNodeAtP p st a = case hLookup a h of
-    Just (NNum n)        -> int n <> "#"
-    Just (NGlobal _ _)   -> textt name
-        where
-            g = st ^. gmEnv
-            name = case lookup a (swap <$> g) of
-                Just (NameKey n)     -> n
-                Just (ConstrKey t n) -> showCon t n
-                _                    -> errTxtInvalidAddress
-    -- TODO: left-associativity
-    Just (NAp f x)       -> pprec $ showNodeAtP (p+1) st f
-                                <+> showNodeAtP (p+1) st x
-    Just (NInd a')       -> pprec $ "NInd -> " <> showNodeAtP (p+1) st a'
-    Just (NConstr t as)  -> pprec $ "NConstr"
-                                <+> int t
-                                <+> brackets (list $ showNodeAtP 0 st <$> as)
-        where list = hcat . punctuate ", "
-    Just NUninitialised  -> "<uninitialised>"
-    Nothing              -> errTxtInvalidAddress
-    where
-        h = st ^. gmHeap
-        pprec = maybeParens (p > 0)
-
-showSc :: GmState -> (Name, Addr) -> Doc
-showSc st (k,a) = "Supercomb " <> qquotes (textt k) <> colon
-               $$ code
-    where
-        code = case hLookup a (st ^. gmHeap) of
-            Just (NGlobal _ c) -> showCode c
-            Just _             -> errTxtInvalidObject
-            Nothing            -> errTxtInvalidAddress
-
-errTxtInvalidObject, errTxtInvalidAddress :: (IsString a) => a
-errTxtInvalidObject = "<invalid object>"
-errTxtInvalidAddress = "<invalid address>"
-
-showCode :: Code -> Doc
-showCode c = "Code" <+> braces instrs
-    where instrs = vcat $ showInstr <$> c
-
-showInstr :: Instr -> Doc
-showInstr (CaseJump alts) = "CaseJump" $$ nest pprTabstop alternatives
-    where
-        showAlt (t,c) = "<" <> int t <> ">" <> showCodeShort c
-        alternatives = foldr (\a acc -> showAlt a $$ acc) mempty alts
-showInstr i = text $ show i
-
-textt :: (IsText a) => a -> Doc
-textt t = t ^. unpacked & text
-
-----------------------------------------------------------------------------------
-
-lookupN :: Name -> Env -> Maybe Addr
-lookupN k = lookup (NameKey k)
-
-lookupC :: Tag -> Int -> Env -> Maybe Addr
-lookupC t n = lookup (ConstrKey t n)
-
-----------------------------------------------------------------------------------
-
-gc :: GmState -> GmState
-gc st = (sweepNodes . markNodes $ st)
-      & gmStats . stsGCCycles %~ succ
-
 markNodes :: GmState -> GmState
 markNodes st = st & gmHeap %~ thread (markFrom <$> roots)
     where
@@ -968,6 +780,18 @@ sweepNodes st = st & gmHeap %~ thread (f <$> addresses h)
 thread :: [a -> a] -> (a -> a)
 thread = appEndo . foldMap Endo
 
+gc :: GmState -> GmState
+gc st = (sweepNodes . markNodes $ st)
+      & gmStats . stsGCCycles %~ succ
+
+--------------------------------------------------------------------------------
+
+lookupN :: Name -> Env -> Maybe Addr
+lookupN k = lookup (NameKey k)
+
+lookupC :: Tag -> Int -> Env -> Maybe Addr
+lookupC t n = lookup (ConstrKey t n)
+
 ----------------------------------------------------------------------------------
 
 gmEvalProg :: Program' -> GmState
@@ -979,12 +803,11 @@ finalStateOf f = f . gmEvalProg
 resultOf :: Program' -> Maybe Node
 resultOf p = do
     a <- res
-    n <- hLookup a h
-    pure n
-    where
-        res = st ^? gmStack . _head
-        st = gmEvalProg p
-        h = st ^. gmHeap
+    hLookup a h
+  where
+    res = st ^? gmStack . _head
+    st = gmEvalProg p
+    h = st ^. gmHeap
 
 resultOfExpr :: Expr' -> Maybe Node
 resultOfExpr e = resultOf $

src/GM/Print.hs

@@ -0,0 +1,186 @@
+module GM.Print
+    ( showState
+    , showStats
+    , showNodeAt
+    )
+    where
+--------------------------------------------------------------------------------
+import Data.Monoid
+import Data.String              (IsString(..))
+import Data.Text.Lens           (IsText, packed, unpacked)
+import Text.Printf
+
+import Text.PrettyPrint             hiding ((<>))
+import Text.PrettyPrint.HughesPJ    (maybeParens)
+import Control.Lens
+
+import Data.Heap
+import Core.Syntax
+import GM.Types
+--------------------------------------------------------------------------------
+
+pprTabstop :: Int
+pprTabstop = 4
+
+qquotes :: Doc -> Doc
+qquotes d = "`" <> d <> "'"
+
+showStats :: Stats -> Doc
+showStats sts = "==== Stats ============" $$ stats
+    where
+        stats = text $ printf
+            "Reductions      : %5d\n\
+            \Prim Reductions : %5d\n\
+            \Allocations     : %5d\n\
+            \GC Cycles       : %5d"
+            (sts ^. stsReductions)
+            (sts ^. stsPrimReductions)
+            (sts ^. stsAllocations)
+            (sts ^. stsGCCycles)
+
+showState :: GmState -> Doc
+showState st = vcat
+        [ "==== GmState " <> int stnum <> " "
+            <> text (replicate (28 - 13 - 1 - digitalWidth stnum) '=')
+        , "-- Next instructions -------"
+        , info $ showCodeShort c
+        , "-- Stack -------------------"
+        , info $ showStack st
+        , "-- Heap --------------------"
+        , info $ showHeap st
+        , "-- Dump --------------------"
+        , info $ showDump st
+        ]
+    where
+        stnum = st ^. (gmStats . stsReductions)
+        c = st ^. gmCode
+
+        -- indent data
+        info = nest pprTabstop
+
+showCodeShort :: Code -> Doc
+showCodeShort c = braces c'
+    where
+        c' | length c > 3 = list (showInstr <$> take 3 c) <> "; ..."
+           | otherwise    = list (showInstr <$> c)
+        list = hcat . punctuate "; "
+
+showStackShort :: Stack -> Doc
+showStackShort s = brackets s'
+    where
+           -- no access to heap, otherwise we'd use showNodeAt
+        s' | length s > 3 = list (showEntry <$> take 3 s) <> ", ..."
+           | otherwise    = list (showEntry <$> s)
+        list = hcat . punctuate ", "
+        showEntry = text . show
+
+showStack :: GmState -> Doc
+showStack st = vcat $ uncurry showEntry <$> si
+    where
+        h = st ^. gmHeap
+        s = st ^. gmStack
+
+        -- stack with labeled indices
+        si = [0..] `zip` s
+
+        w = maxWidth (addresses h)
+        showIndex n = padInt w n <> ": "
+
+        showEntry :: Int -> Addr -> Doc
+        showEntry n a = showIndex n <> showNodeAt st a
+
+showDump :: GmState -> Doc
+showDump st = vcat $ uncurry showEntry <$> di
+    where
+        d = st ^. gmDump
+        di = [0..] `zip` d
+
+        showIndex n = padInt w n <> ": "
+        w = maxWidth (fst <$> di)
+
+        showEntry :: Int -> (Code, Stack) -> Doc
+        showEntry n (c,s) = showIndex n <> nest pprTabstop entry
+            where
+                entry = ("Stack : " <> showCodeShort c)
+                     $$ ("Code  : " <> showStackShort s)
+
+padInt :: Int -> Int -> Doc
+padInt m n = text (replicate (m - digitalWidth n) ' ') <> int n
+
+maxWidth :: [Int] -> Int
+maxWidth ns = digitalWidth $ maximum ns
+
+digitalWidth :: Int -> Int
+digitalWidth = length . show
+
+showHeap :: GmState -> Doc
+showHeap st = vcat $ showEntry <$> addrs
+    where
+        showAddr n = padInt w n <> ": "
+
+        w = maxWidth addrs
+        h = st ^. gmHeap
+        addrs = addresses h
+
+        showEntry :: Addr -> Doc
+        showEntry a = showAddr a <> showNodeAt st a
+
+showNodeAt :: GmState -> Addr -> Doc
+showNodeAt = showNodeAtP 0
+
+showNodeAtP :: Int -> GmState -> Addr -> Doc
+showNodeAtP p st a = case hLookup a h of
+    Just (NNum n)        -> int n <> "#"
+    Just (NGlobal _ _)   -> textt name
+        where
+            g = st ^. gmEnv
+            name = case lookup a (view swapped <$> g) of
+                Just (NameKey n)     -> n
+                Just (ConstrKey t n) -> showCon t n
+                _                    -> errTxtInvalidAddress
+    -- TODO: left-associativity
+    Just (NAp f x)       -> pprec $ showNodeAtP (p+1) st f
+                                <+> showNodeAtP (p+1) st x
+    Just (NInd a')       -> pprec $ "NInd -> " <> showNodeAtP (p+1) st a'
+    Just (NConstr t as)  -> pprec $ "NConstr"
+                                <+> int t
+                                <+> brackets (list $ showNodeAtP 0 st <$> as)
+        where list = hcat . punctuate ", "
+    Just NUninitialised  -> "<uninitialised>"
+    Nothing              -> errTxtInvalidAddress
+    where
+        h = st ^. gmHeap
+        pprec = maybeParens (p > 0)
+
+showSc :: GmState -> (Name, Addr) -> Doc
+showSc st (k,a) = "Supercomb " <> qquotes (textt k) <> colon
+               $$ code
+    where
+        code = case hLookup a (st ^. gmHeap) of
+            Just (NGlobal _ c) -> showCode c
+            Just _             -> errTxtInvalidObject
+            Nothing            -> errTxtInvalidAddress
+
+errTxtInvalidObject, errTxtInvalidAddress :: (IsString a) => a
+errTxtInvalidObject = "<invalid object>"
+errTxtInvalidAddress = "<invalid address>"
+
+showCode :: Code -> Doc
+showCode c = "Code" <+> braces instrs
+    where instrs = vcat $ showInstr <$> c
+
+showInstr :: Instr -> Doc
+showInstr (CaseJump alts) = "CaseJump" $$ nest pprTabstop alternatives
+    where
+        showAlt (t,c) = "<" <> int t <> ">" <> showCodeShort c
+        alternatives = foldr (\a acc -> showAlt a $$ acc) mempty alts
+showInstr i = text $ show i
+
+textt :: (IsText a) => a -> Doc
+textt t = t ^. unpacked & text
+
+----------------------------------------------------------------------------------
+
+showCon :: (IsText a) => Tag -> Int -> a
+showCon t n = printf "Pack{%d %d}" t n ^. packed
+

src/GM/Types.hs

@@ -0,0 +1,83 @@
+{-# LANGUAGE TemplateHaskell #-}
+module GM.Types where
+--------------------------------------------------------------------------------
+import Control.Lens.Combinators
+import Data.Heap
+import Data.Default
+
+import Core.Syntax
+--------------------------------------------------------------------------------
+
+data GmState = GmState
+    { _gmCode   :: Code
+    , _gmStack  :: Stack
+    , _gmDump   :: Dump
+    , _gmHeap   :: GmHeap
+    , _gmEnv    :: Env
+    , _gmStats  :: Stats
+    }
+    deriving Show
+
+type Code = [Instr]
+type Stack = [Addr]
+type Dump = [(Code, Stack)]
+type Env = [(Key, Addr)]
+type GmHeap = Heap Node
+
+data Key = NameKey Name
+         | ConstrKey Tag Int
+         deriving (Show, Eq)
+
+-- >> [ref/Instr]
+data Instr = Unwind
+           | PushGlobal Name
+           | PushConstr Tag Int
+           | PushInt Int
+           | Push Int
+           | MkAp
+           | Slide Int
+           | Update Int
+           | Pop Int
+           | Alloc Int
+           | Eval
+           -- arith
+           | Neg | Add | Sub | Mul | Div
+           -- comparison
+           | Equals | Lesser | GreaterEq
+           | Pack Tag Int -- Pack Tag Arity
+           | CaseJump [(Tag, Code)]
+           | Split Int
+           | Print
+           | Halt
+           deriving (Show, Eq)
+-- << [ref/Instr]
+
+data Node = NNum Int
+          | NAp Addr Addr
+          -- NGlobal is the GM equivalent of NSupercomb. rather than storing a
+          -- template to be instantiated, NGlobal holds the global's arity and
+          -- the pre-compiled code :3
+          | NGlobal Int Code
+          | NInd Addr
+          | NUninitialised
+          | NConstr Tag [Addr] -- NConstr Tag Components
+          | NMarked Node
+          deriving (Show, Eq)
+
+-- TODO: log executed instructions
+data Stats = Stats
+    { _stsReductions     :: Int
+    , _stsPrimReductions :: Int
+    , _stsAllocations    :: Int
+    , _stsDereferences   :: Int
+    , _stsGCCycles       :: Int
+    }
+    deriving Show
+
+instance Default Stats where
+    def = Stats 0 0 0 0 0
+
+-- TODO: _gmGlobals should not have a setter
+makeLenses ''GmState
+makeLenses ''Stats
+

src/GM/Visual.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+module GM.Visual
+    ( renderGmState
+    )
+    where
+--------------------------------------------------------------------------------
+import Text.Printf
+import Data.Function            ((&), on)
+import Text.PrettyPrint         qualified as P
+
+import Diagrams.Prelude
+import Diagrams.Backend.Cairo
+
+import GM.Types
+import GM.Print
+--------------------------------------------------------------------------------
+
+renderGmState :: GmState -> IO ()
+renderGmState st = renderCairo path size (drawState st)
+    where
+        size = mkSizeSpec2D (Just 1000) (Just 1000)
+        path = printf "/tmp/render/%04d.png" n
+        n = st ^. gmStats . stsReductions
+
+drawState :: GmState -> Diagram B
+drawState = drawStack
+
+drawStack :: GmState -> Diagram B
+drawStack st = st & vcatOf (gmStack . each . to cell)
+    where
+        cell a = rect 10 5
+              <> text (printf "%04x: %s" a (P.render . showNodeAt st $ a))
+
+vcatOf :: (InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a, Monoid' a)
+       => Getting (Endo [a]) s a -> s -> a
+vcatOf l = vcat . (^.. l)
+
+newtype Vap a = Vap { getVap :: a }
+
+instance (InSpace V2 n a, Juxtaposable a, Semigroup a)
+         => Semigroup (Vap a) where (<>) = (Vap .) . ((===) `on` getVap)
+instance (InSpace V2 n a, Juxtaposable a, Monoid a)
+         => Monoid (Vap a) where mempty = Vap mempty
+
+newtype Hap a = Hap { getHap :: a }
+
+instance (InSpace V2 n a, Juxtaposable a, Semigroup a)
+         => Semigroup (Hap a) where (<>) = (Hap .) . ((|||) `on` getHap)
+instance (InSpace V2 n a, Juxtaposable a, Monoid a)
+         => Monoid (Hap a) where mempty = Hap mempty
+

src/Rlp/Lex.x

@@ -10,6 +10,9 @@ module Rlp.Lex
     , lexStream
     , lexDebug
     , lexCont
+    , popLexState
+    , programInitState
+    , runP'
     )
     where
 import Codec.Binary.UTF8.String (encodeChar)
@@ -24,8 +27,7 @@ import Data.Text                (Text)
 import Data.Text                qualified as T
 import Data.Word
 import Data.Default
-import Lens.Micro.Mtl
-import Lens.Micro
+import Control.Lens
 
 import Debug.Trace
 import Rlp.Parse.Types
@@ -57,7 +59,7 @@ $asciisym       = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
     |infixr|infixl|infix
 
 @reservedop =
-    "=" | \\ | "->" | "|"
+    "=" | \\ | "->" | "|" | "::"
 
 rlp :-
     
@@ -73,6 +75,19 @@ $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>
 {
@@ -114,6 +129,21 @@ $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 }
 }
 
@@ -125,16 +155,20 @@ 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
@@ -144,6 +178,12 @@ 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
@@ -164,10 +204,10 @@ alexGetByte inp = case inp ^. aiBytes of
                        -- report the previous char
                        & aiPrevChar .~ c
                        -- update the position
-                       & aiPos %~ \ (ln,col) ->
+                       & aiPos %~ \ (ln,col,a) ->
                                    if c == '\n'
-                                   then (ln+1,1)
-                                   else (ln,col+1)
+                                   then (ln+1, 1, a+1)
+                                   else (ln, col+1, a+1)
         pure (b, inp')
     
     _ -> Just (head bs, inp')
@@ -187,19 +227,19 @@ pushLexState :: Int -> P ()
 pushLexState n = psLexState %= (n:)
 
 readInt :: Text -> Int
-readInt = T.foldr f 0 where
-    f c n = digitToInt c + 10*n
+readInt = T.foldl f 0 where
+    f n c = 10*n + digitToInt c
 
 constToken :: RlpToken -> LexerAction (Located RlpToken)
 constToken t inp l = do
     pos <- use (psInput . aiPos)
-    pure (Located (pos,l) t)
+    pure (Located (spanFromPos pos l) t)
 
 tokenWith :: (Text -> RlpToken) -> LexerAction (Located RlpToken)
 tokenWith tf inp l = do
     pos <- getPos
     let t = tf (T.take l $ inp ^. aiSource)
-    pure (Located (pos,l) t)
+    pure (Located (spanFromPos pos l) t)
 
 getPos :: P Position
 getPos = use (psInput . aiPos)
@@ -207,29 +247,12 @@ getPos = use (psInput . aiPos)
 alexEOF :: P (Located RlpToken)
 alexEOF = do
     inp <- getInput
-    pure (Located undefined TokenEOF)
-
-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)
-    }
+    pos <- getPos
+    pure (Located (spanFromPos pos 0) TokenEOF)
 
 runP' :: P a -> Text -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
 runP' p s = runP p st where
-    st = initParseState s
+    st = initParseState [layout_top,0] s
 
 lexToken :: P (Located RlpToken)
 lexToken = do
@@ -238,7 +261,7 @@ lexToken = do
     st <- use id
     -- traceM $ "st: " <> show st
     case alexScan inp c of
-        AlexEOF -> pure $ Located (inp ^. aiPos, 0) TokenEOF
+        AlexEOF -> pure $ Located (spanFromPos (inp^.aiPos) 0) TokenEOF
         AlexSkip inp' l -> do
             psInput .= inp'
             lexToken
@@ -274,7 +297,7 @@ indentLevel = do
 insertToken :: RlpToken -> P (Located RlpToken)
 insertToken t = do
     pos <- use (psInput . aiPos)
-    pure (Located (pos, 0) t)
+    pure (Located (spanFromPos pos 0) t)
 
 popLayout :: P Layout
 popLayout = do
@@ -283,7 +306,7 @@ popLayout = do
     psLayoutStack %= (drop 1)
     case ctx of
         Just l      -> pure l
-        Nothing     -> error "uhh"
+        Nothing     -> error "popLayout: layout stack empty! this is a bug."
 
 pushLayout :: Layout -> P ()
 pushLayout l = do
@@ -311,18 +334,19 @@ 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 -> insertSemicolon
+        EQ -> popLexState *> insertSemicolon
         -- the line is indented further than the previous, so we assume it is a
         -- line continuation. ignore it and move on!
-        GT -> lexToken
+        GT -> popLexState *> lexToken
         -- the line is indented less than the previous, pop the layout stack and
-        -- insert a closing brace.
+        -- insert a closing brace. make VERY good note of the fact that we do not
+        -- pop the lex state! this means doBol is called until indentation is EQ
+        -- GT. so if multiple layouts are closed at once, this catches that.
         LT -> popLayout >> insertRBrace
 
 thenDo :: LexerAction a -> P b -> LexerAction a
@@ -341,9 +365,13 @@ 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,39 +1,54 @@
 {
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, ViewPatterns #-}
 module Rlp.Parse
     ( parseRlpProg
+    , parseRlpProgR
+    , parseRlpExpr
+    , parseRlpExprR
     )
     where
 import Compiler.RlpcError
+import Compiler.RLPC
 import Rlp.Lex
 import Rlp.Syntax
 import Rlp.Parse.Types
 import Rlp.Parse.Associate
-import Lens.Micro
-import Lens.Micro.Mtl
-import Lens.Micro.Platform          ()
+import Control.Lens                 hiding (snoc, (.>), (<.), (<<~))
 import Data.List.Extra
 import Data.Fix
 import Data.Functor.Const
+import Data.Functor.Apply
+import Data.Functor.Bind
+import Control.Comonad
+import Data.Functor
+import Data.Semigroup.Traversable
+import Data.Text                    (Text)
 import Data.Text                    qualified as T
+import Data.Void
+import Compiler.Types
 }
 
 %name parseRlpProg StandaloneProgram
+%name parseRlpExpr StandaloneExpr
 
 %monad { P }
 %lexer { lexCont } { Located _ TokenEOF }
 %error { parseError }
+%errorhandlertype explist
 %tokentype { Located RlpToken }
 
 %token
-    varname         { Located _ (TokenVarName $$) }
-    conname         { Located _ (TokenConName $$) }
-    consym          { Located _ (TokenConSym $$) }
-    varsym          { Located _ (TokenVarSym $$) }
+    varname         { Located _ (TokenVarName _) }
+    conname         { Located _ (TokenConName _) }
+    consym          { Located _ (TokenConSym _) }
+    varsym          { Located _ (TokenVarSym _) }
     data            { Located _ TokenData }
-    litint          { Located _ (TokenLitInt $$) }
+    case            { Located _ TokenCase }
+    of              { Located _ TokenOf }
+    litint          { Located _ (TokenLitInt _) }
     '='             { Located _ TokenEquals }
     '|'             { Located _ TokenPipe }
+    '::'            { Located _ TokenHasType }
     ';'             { Located _ TokenSemicolon }
     '('             { Located _ TokenLParen }
     ')'             { Located _ TokenRParen }
@@ -46,15 +61,23 @@ import Data.Text                    qualified as T
     infixl          { Located _ TokenInfixL }
     infixr          { Located _ TokenInfixR }
     infix           { Located _ TokenInfix }
+    let             { Located _ TokenLet }
+    letrec          { Located _ TokenLetrec }
+    in              { Located _ TokenIn }
 
+%nonassoc '='
 %right '->'
+%right in
 
 %%
 
-StandaloneProgram   :: { RlpProgram' }
+StandaloneProgram   :: { RlpProgram RlpcPs }
 StandaloneProgram   : '{' Decls  '}'        {% mkProgram $2 }
                     | VL  DeclsV VR         {% mkProgram $2 }
 
+StandaloneExpr      :: { RlpExpr RlpcPs }
+                    : VL Expr VR            { extract $2 }
+
 VL  :: { () }
 VL  : vlbrace       { () }
 
@@ -62,13 +85,13 @@ VR  :: { () }
 VR  : vrbrace       { () }
     | error         { () }
 
-Decls               :: { [PartialDecl'] }
+Decls               :: { [Decl' RlpcPs] }
 Decls               : Decl ';' Decls        { $1 : $3 }
                     | Decl ';'              { [$1] }
                     | Decl                  { [$1] }
 
-DeclsV              :: { [PartialDecl'] }
-DeclsV              : Decl VS Decls         { $1 : $3 }
+DeclsV              :: { [Decl' RlpcPs] }
+DeclsV              : Decl VS DeclsV        { $1 : $3 }
                     | Decl VS               { [$1] }
                     | Decl                  { [$1] }
 
@@ -76,97 +99,193 @@ VS                  :: { Located RlpToken }
 VS                  : ';'                   { $1 }
                     | vsemi                 { $1 }
 
-Decl        :: { PartialDecl' }
+Decl        :: { Decl' RlpcPs }
             : FunDecl                   { $1 }
+            | TySigDecl                 { $1 }
             | DataDecl                  { $1 }
             | InfixDecl                 { $1 }
 
-InfixDecl   :: { PartialDecl' }
-            : InfixWord litint InfixOp  {% mkInfixD $1 $2 $3 }
+TySigDecl   :: { Decl' RlpcPs }
+            : Var '::' Type             { (\e -> TySigD [extract e]) <<~ $1 <~> $3 }
 
-InfixWord   :: { Assoc }
-            : infixl                    { InfixL }
-            | infixr                    { InfixR }
-            | infix                     { Infix  }
+InfixDecl   :: { Decl' RlpcPs }
+            : InfixWord litint InfixOp  { $1 =>> \w ->
+                                          InfixD (extract $1) (extractInt $ extract $2)
+                                          (extract $3) }
 
-DataDecl    :: { PartialDecl' }
-            : data Con TyParams '=' DataCons    { DataD $2 $3 $5 }
+InfixWord   :: { Located Assoc }
+            : infixl                    { $1 \$> InfixL }
+            | infixr                    { $1 \$> InfixR }
+            | infix                     { $1 \$> Infix  }
 
-TyParams    :: { [Name] }
+DataDecl    :: { Decl' RlpcPs }
+            : data Con TyParams '=' DataCons    { $1 \$> DataD (extract $2) $3 $5 }
+
+TyParams    :: { [PsName] }
             : {- epsilon -}             { [] }
-            | TyParams varname          { $1 `snoc` $2 }
+            | TyParams varname          { $1 `snoc` (extractName . extract $ $2) }
 
-DataCons    :: { [ConAlt] }
+DataCons    :: { [ConAlt RlpcPs] }
             : DataCons '|' DataCon      { $1 `snoc` $3 }
             | DataCon                   { [$1] }
 
-DataCon     :: { ConAlt }
-            : Con Type1s                { ConAlt $1 $2 }
+DataCon     :: { ConAlt RlpcPs }
+            : Con Type1s                { ConAlt (extract $1) $2 }
 
-Type1s      :: { [Type] }
+Type1s      :: { [RlpType' RlpcPs] }
             : {- epsilon -}             { [] }
             | Type1s Type1              { $1 `snoc` $2 }
 
-Type1       :: { Type }
+Type1       :: { RlpType' RlpcPs }
             : '(' Type ')'              { $2 }
-            | conname                   { TyCon $1 }
-            | varname                   { TyVar $1 }
+            | conname                   { fmap ConT (mkPsName $1) }
+            | varname                   { fmap VarT (mkPsName $1) }
 
-Type        :: { Type }
-            : Type '->' Type            { $1 :-> $3 }
-            | Type1                     { $1 }
+Type        :: { RlpType' RlpcPs }
+            : Type '->' Type            { FunT <<~ $1 <~> $3 }
+            | TypeApp                   { $1 }
 
-FunDecl     :: { PartialDecl' }
-FunDecl     : Var Params '=' Expr       { FunD $1 $2 (Const $4) Nothing }
+TypeApp     :: { RlpType' RlpcPs }
+            : Type1                     { $1 }
+            | TypeApp Type1             { AppT <<~ $1 <~> $2 }
 
-Params      :: { [Pat'] }
+FunDecl     :: { Decl' RlpcPs }
+FunDecl     : Var Params '=' Expr       { $4 =>> \e ->
+                                          FunD (extract $1) $2 e Nothing }
+
+Params      :: { [Pat' RlpcPs] }
 Params      : {- epsilon -}             { [] }
             | Params Pat1               { $1 `snoc` $2 }
 
-Pat1        :: { Pat' }
-            : Var                       { VarP $1 }
-            | Lit                       { LitP $1 }
+Pat         :: { Pat' RlpcPs }
+            : Con Pat1s                 { $1 =>> \cn ->
+                                          ConP (extract $1) $2 }
+            | Pat1                      { $1 }
 
-Expr        :: { PartialExpr' }
-            : Expr1 varsym Expr         { Fix $ B $2 (unFix $1) (unFix $3) }
-            | Expr1                     { $1 }
+Pat1s       :: { [Pat' RlpcPs] }
+            : Pat1s Pat1                { $1 `snoc` $2 }
+            | Pat1                      { [$1] }
 
-Expr1       :: { PartialExpr' }
-            : '(' Expr ')'              { wrapFix . Par . unwrapFix $ $2 }
-            | Lit                       { Fix . E $ LitEF $1 }
-            | Var                       { Fix . E $ VarEF $1 }
+Pat1        :: { Pat' RlpcPs }
+            : Con                       { fmap (`ConP` []) $1 }
+            | Var                       { fmap VarP $1 }
+            | Lit                       { LitP <<= $1 }
+            | '(' Pat ')'               { $1 .> $2 <. $3 }
 
--- TODO: happy prefers left-associativity. doing such would require adjusting
--- the code in Rlp.Parse.Associate to expect left-associative input rather than
--- right.
-InfixExpr   :: { PartialExpr' }
-            : Expr1 varsym Expr         { Fix $ B $2 (unFix $1) (unFix $3) }
+Expr        :: { RlpExpr' RlpcPs }
+            -- infixities delayed till next release :(
+            -- : Expr1 InfixOp Expr        { $2 =>> \o ->
+            --                              OAppE (extract o) $1 $3 }
+            : TempInfixExpr             { $1 }
+            | LetExpr                   { $1 }
+            | CaseExpr                  { $1 }
+            | AppExpr                   { $1 }
 
-InfixOp     :: { Name }
-            : consym                    { $1 }
-            | varsym                    { $1 }
+TempInfixExpr :: { RlpExpr' RlpcPs }
+TempInfixExpr : Expr1 InfixOp TempInfixExpr {% tempInfixExprErr $1 $3 }
+              | Expr1 InfixOp Expr1 { $2 =>> \o ->
+                                      OAppE (extract o) $1 $3 }
 
-Lit         :: { Lit' }
-Lit         : litint                    { IntL $1 }
+AppExpr     :: { RlpExpr' RlpcPs }
+            : Expr1                     { $1 }
+            | AppExpr Expr1             { AppE <<~ $1 <~> $2 }
 
-Var         :: { VarId }
-Var         : varname                   { NameVar $1 }
+LetExpr     :: { RlpExpr' RlpcPs }
+            : let layout1(Binding) in Expr      { $1 \$> LetE $2 $4 }
+            | letrec layout1(Binding) in Expr   { $1 \$> LetrecE $2 $4 }
 
-Con         :: { ConId }
-            : conname                   { NameCon $1 }
+CaseExpr    :: { RlpExpr' RlpcPs }
+            : case Expr of layout0(CaseAlt)
+                { CaseE <<~ $2 <#> $4 }
+
+-- TODO: where-binds
+CaseAlt     :: { (Alt RlpcPs, Where RlpcPs) }
+            : Alt                           { ($1, []) }
+
+Alt         :: { Alt RlpcPs }
+            : Pat '->' Expr                 { AltA $1 $3 }
+
+-- layout0(p : β) :: [β]
+layout0(p)  : '{' layout_list0(';',p) '}'   { $2 }
+            | VL  layout_list0(VS,p)  VR    { $2 }
+
+-- layout_list0(sep : α, p : β) :: [β]
+layout_list0(sep,p) : p                          { [$1] }
+                    | layout_list1(sep,p) sep p  { $1 `snoc` $3 }
+                    | {- epsilon -}              { [] }
+
+-- layout1(p : β) :: [β]
+layout1(p)  : '{' layout_list1(';',p) '}'   { $2 }
+            | VL  layout_list1(VS,p) VR     { $2 }
+
+-- layout_list1(sep : α, p : β) :: [β]
+layout_list1(sep,p) : p                          { [$1] }
+                    | layout_list1(sep,p) sep p  { $1 `snoc` $3 }
+
+Binding     :: { Binding' RlpcPs }
+            : Pat '=' Expr              { PatB <<~ $1 <~> $3 }
+
+Expr1       :: { RlpExpr' RlpcPs }
+            : '(' Expr ')'              { $1 .> $2 <. $3 }
+            | Lit                       { fmap LitE $1 }
+            | Var                       { fmap VarE $1 }
+            | Con                       { fmap VarE $1 }
+
+InfixOp     :: { Located PsName }
+            : consym                    { mkPsName $1 }
+            | varsym                    { mkPsName $1 }
+
+-- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
+Lit         :: { Lit' RlpcPs }
+            : litint                    { $1 <&> (IntL . (\ (TokenLitInt n) -> n)) }
+
+Var         :: { Located PsName }
+Var         : varname                   { mkPsName $1 }
+            | varsym                    { mkPsName $1 }
+
+Con         :: { Located PsName }
+            : conname                   { mkPsName $1 }
 
 {
 
-mkProgram :: [PartialDecl'] -> P RlpProgram'
+parseRlpExprR :: (Monad m) => Text -> RLPCT m (RlpExpr RlpcPs)
+parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st
+    where
+        st = programInitState s
+
+parseRlpProgR :: (Monad m) => Text -> RLPCT m (RlpProgram RlpcPs)
+parseRlpProgR s = do
+    a <- liftErrorful $ pToErrorful parseRlpProg st
+    addDebugMsg @_ @String "dump-parsed" $ show a
+    pure a
+  where
+        st = programInitState s
+
+mkPsName :: Located RlpToken -> Located PsName
+mkPsName = fmap extractName
+
+extractName :: RlpToken -> PsName
+extractName = \case
+    TokenVarName n -> n
+    TokenConName n -> n
+    TokenConSym  n -> n
+    TokenVarSym  n -> n
+    _              -> error "mkPsName: not an identifier"
+
+extractInt :: RlpToken -> Int
+extractInt (TokenLitInt n) = n
+extractInt _ = error "extractInt: ugh"
+
+mkProgram :: [Decl' RlpcPs] -> P (RlpProgram RlpcPs)
 mkProgram ds = do
     pt <- use psOpTable
     pure $ RlpProgram (associate pt <$> ds)
 
-parseError :: Located RlpToken -> P a
-parseError (Located ((l,c),s) t) = addFatal $
-    errorMsg (SrcSpan l c s) RlpParErrUnexpectedToken
+parseError :: (Located RlpToken, [String]) -> P a
+parseError ((Located ss t), exp) = addFatal $
+    errorMsg ss (RlpParErrUnexpectedToken t exp)
 
-mkInfixD :: Assoc -> Int -> Name -> P PartialDecl'
+mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs)
 mkInfixD a p n = do
     let opl :: Lens' ParseState (Maybe OpInfo)
         opl = psOpTable . at n
@@ -176,6 +295,18 @@ mkInfixD a p n = do
             l = T.length n
         Nothing -> pure (Just (a,p))
         )
-    pure $ InfixD a p n
+    pos <- use (psInput . aiPos)
+    pure $ Located (spanFromPos pos 0) (InfixD a p n)
+
+intOfToken :: Located RlpToken -> Int
+intOfToken (Located _ (TokenLitInt n)) = n
+
+tempInfixExprErr :: RlpExpr' RlpcPs -> RlpExpr' RlpcPs -> P a
+tempInfixExprErr (Located a _) (Located b _) =
+    addFatal $ errorMsg (a <> b) $ RlpParErrOther
+        [ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :("
+        , "In the mean time, don't mix any infix operators."
+        ]
 
 }
+

src/Rlp/Parse/Associate.hs

@@ -1,87 +1,25 @@
-{-# 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 Lens.Micro
+import Data.Functor
+import Data.Text                        qualified as T
+import Text.Printf
+import Control.Lens
 import Rlp.Parse.Types
 import Rlp.Syntax
 --------------------------------------------------------------------------------
 
-associate :: OpTable -> PartialDecl' -> Decl' RlpExpr
-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
+associate :: OpTable -> Decl' RlpcPs -> Decl' RlpcPs
+associate _ p = p
 
-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
+{-# WARNING associate "unimplemented" #-}
 
 examplePrecTable :: OpTable
 examplePrecTable = H.fromList
@@ -97,4 +35,3 @@ examplePrecTable = H.fromList
     , ("&",    (InfixL,0))
     ]
 
-

src/Rlp/Parse/Types.hs

@@ -2,38 +2,28 @@
 {-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
 {-# LANGUAGE LambdaCase #-}
 module Rlp.Parse.Types
-    ( LexerAction
-    , MsgEnvelope(..)
-    , RlpcError(..)
-    , AlexInput(..)
-    , Position(..)
-    , RlpToken(..)
-    , P(..)
-    , ParseState(..)
-    , psLayoutStack
-    , psLexState
-    , psInput
-    , psOpTable
-    , Layout(..)
-    , Located(..)
-    , OpTable
-    , OpInfo
-    , RlpParseError(..)
-    , PartialDecl'
-    , Partial(..)
-    , pL, pR
-    , PartialE
-    , pattern WithInfo
-    , opInfoOrDef
-    , PartialExpr'
-    , aiPrevChar
-    , aiSource
-    , aiBytes
-    , aiPos
-    , addFatal
-    , addWound
-    , addFatalHere
-    , addWoundHere
+    (
+    -- * Trees That Grow
+      RlpcPs
+
+    -- * Parser monad and state
+    , P(..), ParseState(..), Layout(..), OpTable, OpInfo
+    , initParseState, initAlexInput
+    , pToErrorful
+    -- ** Lenses
+    , psLayoutStack, psLexState, psInput, psOpTable
+
+    -- * Other parser types
+    , RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
+    , Located(..), PsName
+    -- ** Lenses
+    , aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
+
+    , (<<~), (<~>)
+
+    -- * Error handling
+    , MsgEnvelope(..), RlpcError(..), RlpParseError(..)
+    , addFatal, addWound, addFatalHere, addWoundHere
     )
     where
 --------------------------------------------------------------------------------
@@ -41,7 +31,9 @@ import Core.Syntax                  (Name)
 import Control.Monad
 import Control.Monad.State.Strict
 import Control.Monad.Errorful
+import Control.Comonad              (extract)
 import Compiler.RlpcError
+import Language.Haskell.TH.Syntax   (Lift)
 import Data.Text                    (Text)
 import Data.Maybe
 import Data.Fix
@@ -49,12 +41,54 @@ 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 Lens.Micro.TH
-import Lens.Micro
+import Data.Text                    qualified as T
+import Control.Lens                 hiding ((<<~))
 import Rlp.Syntax
+import Compiler.Types
 --------------------------------------------------------------------------------
 
+-- | Phantom type identifying rlpc's parser phase
+
+data RlpcPs
+
+type instance XRec RlpcPs a = Located a
+type instance IdP RlpcPs = PsName
+
+type instance XFunD RlpcPs = ()
+type instance XDataD RlpcPs = ()
+type instance XInfixD RlpcPs = ()
+type instance XTySigD RlpcPs = ()
+type instance XXDeclD RlpcPs = ()
+
+type instance XLetE RlpcPs = ()
+type instance XLetrecE RlpcPs = ()
+type instance XVarE RlpcPs = ()
+type instance XLamE RlpcPs = ()
+type instance XCaseE RlpcPs = ()
+type instance XIfE RlpcPs = ()
+type instance XAppE RlpcPs = ()
+type instance XLitE RlpcPs = ()
+type instance XParE RlpcPs = ()
+type instance XOAppE RlpcPs = ()
+type instance XXRlpExprE RlpcPs = ()
+
+type PsName = Text
+
+instance MapXRec RlpcPs where
+    mapXRec = fmap
+
+instance UnXRec RlpcPs where
+    unXRec = extract
+
+--------------------------------------------------------------------------------
+
+spanFromPos :: Position -> Int -> SrcSpan
+spanFromPos (l,c,a) s = SrcSpan l c a s
+
+{-# INLINE spanFromPos #-}
+
 type LexerAction a = AlexInput -> Int -> P a
 
 data AlexInput = AlexInput
@@ -66,8 +100,9 @@ data AlexInput = AlexInput
     deriving Show
 
 type Position =
-    ( Int -- line
-    , Int -- column
+    ( Int -- ^ line
+    , Int -- ^ column
+    , Int -- ^ Absolutely
     )
 
 posLine :: Lens' Position Int
@@ -76,6 +111,9 @@ posLine = _1
 posColumn :: Lens' Position Int
 posColumn = _2
 
+posAbsolute :: Lens' Position Int
+posAbsolute = _3
+
 data RlpToken
     -- literals
     = TokenLitInt Int
@@ -89,6 +127,7 @@ data RlpToken
     | TokenCase
     | TokenOf
     | TokenLet
+    | TokenLetrec
     | TokenIn
     | TokenInfixL
     | TokenInfixR
@@ -106,7 +145,7 @@ data RlpToken
     | TokenLParen
     | TokenRParen
     -- 'virtual' control symbols, inserted by the lexer without any correlation
-    -- to a specific symbol
+    -- to a specific part of the input
     | TokenSemicolonV
     | TokenLBraceV
     | TokenRBraceV
@@ -119,6 +158,11 @@ newtype P a = P {
     }
     deriving (Functor)
 
+pToErrorful :: (Applicative m)
+            => P a -> ParseState -> ErrorfulT (MsgEnvelope RlpParseError) m a
+pToErrorful p st = ErrorfulT $ pure (ma,es) where
+    (_,es,ma) = runP p st
+
 instance Applicative P where
     pure a = P $ \st -> (st, [], pure a)
     liftA2 = liftM2
@@ -154,64 +198,39 @@ 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 WithLocation a = WithLocation [String] a
-
 data RlpParseError = RlpParErrOutOfBoundsPrecedence Int
                    | RlpParErrDuplicateInfixD Name
                    | RlpParErrLexical
-                   | RlpParErrUnexpectedToken
-                   deriving (Eq, Ord, Show)
+                   | RlpParErrUnexpectedToken RlpToken [String]
+                   | RlpParErrOther [Text]
+                   deriving (Show)
 
 instance IsRlpcError RlpParseError where
+    liftRlpcError = \case
+        RlpParErrOutOfBoundsPrecedence n ->
+            Text [ "Illegal precedence in infixity declaration"
+                 , "rl' currently only allows precedences between 0 and 9."
+                 ]
+        RlpParErrDuplicateInfixD s ->
+            Text [ "Conflicting infixity declarations for operator "
+                    <> tshow s
+                 ]
+        RlpParErrLexical ->
+            Text [ "Unknown lexical error :(" ]
+        RlpParErrUnexpectedToken t exp ->
+            Text [ "Unexpected token " <> tshow t
+                 , "Expected: " <> tshow exp
+                 ]
+        RlpParErrOther ts ->
+            Text ts
+        where
+            tshow :: (Show a) => a -> T.Text
+            tshow = T.pack . show
 
 ----------------------------------------------------------------------------------
--- 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
@@ -221,8 +240,9 @@ addWoundHere l e = P $ \st ->
     let e' = MsgEnvelope
             { _msgSpan = let pos = psInput . aiPos
                          in SrcSpan (st ^. pos . posLine)
-                                   (st ^. pos . posColumn)
-                                   l
+                                    (st ^. pos . posColumn)
+                                    (st ^. pos . posAbsolute)
+                                    l
             , _msgDiagnostic = e
             , _msgSeverity = SevError
             }
@@ -234,9 +254,40 @@ addFatalHere l e = P $ \st ->
             { _msgSpan = let pos = psInput . aiPos
                          in SrcSpan (st ^. pos . posLine)
                                     (st ^. pos . posColumn)
+                                    (st ^. pos . posAbsolute)
                                     l
             , _msgDiagnostic = e
             , _msgSeverity = SevError
             }
     in (st, [e'], Nothing)
 
+initParseState :: [Int] -> Text -> ParseState
+initParseState ls s = ParseState
+    { _psLayoutStack = []
+    -- IMPORTANT: the initial state is `bol` to begin the top-level layout,
+    -- which then returns to state 0 which continues the normal lexing process.
+    , _psLexState = ls
+    , _psInput = initAlexInput s
+    , _psOpTable = mempty
+    }
+
+initAlexInput :: Text -> AlexInput
+initAlexInput s = AlexInput
+    { _aiPrevChar   = '\0'
+    , _aiSource     = s
+    , _aiBytes      = []
+    , _aiPos        = (1,1,0)
+    }
+
+--------------------------------------------------------------------------------
+
+deriving instance Lift (RlpProgram RlpcPs)
+deriving instance Lift (Decl RlpcPs)
+deriving instance Lift (Pat RlpcPs)
+deriving instance Lift (Lit RlpcPs)
+deriving instance Lift (RlpExpr RlpcPs)
+deriving instance Lift (Binding RlpcPs)
+deriving instance Lift (RlpType RlpcPs)
+deriving instance Lift (Alt RlpcPs)
+deriving instance Lift (ConAlt RlpcPs)
+

src/Rlp/Syntax.hs

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

src/Rlp/TH.hs

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

src/Rlp2Core.hs

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

src/TI.hs

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

tst/Arith.hs

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