minor changes

putting this on hold; implementing TTG first

.ghci

@@ -0,0 +1,18 @@
+:set -XOverloadedStrings
+
+:set -package process
+
+:{
+import System.Exit qualified
+import System.Process qualified
+
+_reload_and_make _ = do
+    p <- System.Process.spawnCommand "make -f Makefile_happysrcs"
+    r <- System.Process.waitForProcess p
+    case r of
+        System.Exit.ExitSuccess -> pure ":reload"
+        _                       -> pure ""
+:}
+
+:def! r _reload_and_make
+

CHANGELOG.md

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

Makefile_happysrcs

@@ -0,0 +1,25 @@
+HAPPY = happy
+HAPPY_OPTS = -a -g -c
+ALEX = alex
+ALEX_OPTS = -g
+
+SRC = src
+CABAL_BUILD = dist-newstyle/build/x86_64-osx/ghc-9.6.2/rlp-0.1.0.0/build
+
+all: parsers lexers
+
+parsers: $(CABAL_BUILD)/Rlp/Parse.hs $(CABAL_BUILD)/Core/Parse.hs
+lexers: $(CABAL_BUILD)/Rlp/Lex.hs $(CABAL_BUILD)/Core/Lex.hs
+
+$(CABAL_BUILD)/Rlp/Parse.hs: $(SRC)/Rlp/Parse.y
+	$(HAPPY) $(HAPPY_OPTS) $< -o $@
+
+$(CABAL_BUILD)/Rlp/Lex.hs: $(SRC)/Rlp/Lex.x
+	$(ALEX) $(ALEX_OPTS) $< -o $@
+
+$(CABAL_BUILD)/Core/Parse.hs: $(SRC)/Core/Parse.y
+	$(HAPPY) $(HAPPY_OPTS) $< -o $@
+
+$(CABAL_BUILD)/Core/Lex.hs: $(SRC)/Core/Lex.x
+	$(ALEX) $(ALEX_OPTS) $< -o $@
+

README.md

@@ -30,12 +30,12 @@ $ rlpc -ddump-opts t.hs
 
 ### Potential Features
 Listed in order of importance.
-- [ ] ADTs
-- [ ] First-class functions
+- [x] ADTs
+- [x] First-class functions
 - [ ] Higher-kinded types
 - [ ] Typeclasses
-- [ ] Parametric polymorphism
-- [ ] Hindley-Milner type inference
+- [x] Parametric polymorphism
+- [x] Hindley-Milner type inference
 - [ ] Newtype coercion
 - [ ] Parallelism
 
@@ -66,32 +66,60 @@ Listed in order of importance.
         - [ ] TCO
         - [ ] DCE
 - [ ] Frontend
-    - [ ] High-level language
-        - [ ] AST
-        - [ ] Lexer
-        - [ ] Parser
+    - [x] High-level language
+        - [x] AST
+        - [x] Lexer
+        - [x] Parser
     - [ ] Translation to the core language
         - [ ] Constraint solver
         - [ ] `do`-notation
     - [x] CLI
 - [ ] Documentation
-    - [ ] State transition rules
+    - [x] State transition rules
     - [ ] How does the evaluation model work?
+    - [ ] The Hindley-Milner type system
     - [ ] CLI usage
     - [ ] Tail call optimisation
-    - [x] Parsing rlp
+    - [ ] Parsing rlp
 - [ ] Tests
     - [x] Generic example programs
     - [ ] Parser
 
-### December Release Plan
-- [ ] Tests
+### ~~December Release Plan~~
+- [x] Tests
     - [ ] Core lexer
     - [ ] Core parser
-    - [ ] Evaluation model
+    - [x] Evaluation model
 - [ ] Benchmarks
-- [ ] Stable Core lexer
-- [ ] Stable Core parser
-- [ ] Stable evaluation model
-    - [ ] Garbage Collection
+- [x] Stable Core lexer
+- [x] Stable Core parser
+- [x] Stable evaluation model
+    - [x] Garbage Collection
 - [ ] Stable documentation for the evaluation model
+
+### 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
+
+### March Release Plan
+- [ ] Tests
+    - [ ] rl' parser
+    - [ ] rl' lexer
+
+### Indefinite Release Plan
+
+This list is more concrete than the milestones, but likely further in the future
+than the other release plans.
+
+- [ ] Stable rl' to Core
+- [ ] Core polish
+    - [ ] Better, stable parser
+    - [ ] Better, stable lexer
+    - [ ] Less hacky handling of named data
+    - [ ] Less hacky pragmas
+- [ ] GM to LLVM
+

app/Main.hs

@@ -7,6 +7,9 @@ import Options.Applicative      hiding (ParseError)
 import Control.Monad
 import Control.Monad.Reader
 import Data.HashSet             qualified as S
+import Data.Text                (Text)
+import Data.Text                qualified as T
+import Data.Text.IO             qualified as TIO
 import System.IO
 import System.Exit              (exitSuccess)
 import Core
@@ -60,7 +63,7 @@ options = RLPCOptions
 evaluatorReader :: ReadM Evaluator
 evaluatorReader = maybeReader $ \case
     "gm"  -> Just EvaluatorGM
-    "tim" -> Just EvaluatorTI
+    "ti"  -> Just EvaluatorTI
     _     -> Nothing
 
 mmany :: (Alternative f, Monoid m) => f m -> f m
@@ -102,7 +105,7 @@ dshowFlags = whenFlag flagDDumpOpts do
 ddumpAST :: RLPCIO CompilerError ()
 ddumpAST = whenFlag flagDDumpAST $ forFiles_ \o f -> do
     liftIO $ withFile f ReadMode $ \h -> do
-        s <- hGetContents h
+        s <- TIO.hGetContents h
         case parseProg o s of
             Right (a,_) -> hPutStrLn stderr $ show a
             Left e -> error "todo errors lol"
@@ -110,10 +113,10 @@ ddumpAST = whenFlag flagDDumpAST $ forFiles_ \o f -> do
 ddumpEval :: RLPCIO CompilerError ()
 ddumpEval = whenFlag flagDDumpEval do
     fs <- view rlpcInputFiles
-    forM_ fs $ \f -> liftIO (readFile f) >>= doProg
+    forM_ fs $ \f -> liftIO (TIO.readFile f) >>= doProg
 
     where
-        doProg :: String -> RLPCIO CompilerError ()
+        doProg :: Text -> RLPCIO CompilerError ()
         doProg s = ask >>= \o -> case parseProg o s of
             -- TODO: error handling
             Left e -> addFatal . CompilerError $ show e
@@ -133,7 +136,7 @@ ddumpEval = whenFlag flagDDumpEval do
             where v f p h = f p h *> pure ()
 
 parseProg :: RLPCOptions
-          -> String
+          -> Text
           -> Either SrcError (Program', [SrcError])
 parseProg o = evalRLPC o . (lexCore >=> parseCoreProg)
 

doc/src/commentary/gm.rst

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

doc/src/commentary/layout-lexing.rst

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

doc/src/commentary/ti.rst

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

doc/src/commentary/type-inference.rst

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

doc/src/conf.py

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

doc/src/references/rlp-grammar.rst

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

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

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

examples/factorial.hs

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

examples/sumList.hs

@@ -2,8 +2,8 @@ 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)
+    { <0>      -> 0
+    ; <1> x xs -> (+#) x (sum xs)
     };
 main = sum list;
 

programming-language-checklist

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

rlp.cabal

@@ -7,11 +7,12 @@ license:            GPL-2.0-only
 -- license-file:       LICENSE
 author:             crumbtoo
 maintainer:         crumb@disroot.org
--- copyright:
+copyright:          Madeleine Sydney Ślaga
 category:           Language
 build-type:         Simple
 extra-doc-files:    README.md
 -- extra-source-files:
+tested-with:        GHC==9.6.2
 
 common warnings
 --    ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-unused-top-binds
@@ -22,41 +23,59 @@ library
                     , TI
                     , GM
                     , Compiler.RLPC
+                    , Compiler.RlpcError
+                    , Compiler.JustRun
                     , Core.Syntax
                     , Core.Examples
                     , Core.Utils
                     , Core.TH
+                    , Core.HindleyMilner
+                    , Control.Monad.Errorful
+                    , Rlp.Syntax
+                    -- , Rlp.Parse.Decls
+                    , Rlp.Parse
+                    , Rlp.Parse.Associate
+                    , Rlp.Lex
+                    , Rlp.Parse.Types
 
     other-modules:    Data.Heap
                     , Data.Pretty
                     , Core.Parse
                     , Core.Lex
-                    , Control.Monad.Errorful
                     , Core2Core
-                    , RLP.Syntax
+                    , Control.Monad.Utils
 
     build-tool-depends: happy:happy, alex:alex
 
     -- other-extensions:
     build-depends:    base ^>=4.18.0.0
-                    , containers
-                    , microlens
-                    , microlens-th
-                    , mtl
-                    , template-haskell
                     -- required for happy
-                    , array
-                    , data-default-class
-                    , unordered-containers
-                    , hashable
-                    , pretty
-                    , recursion-schemes
-                    , megaparsec
-                    , text
+                    , array >= 0.5.5 && < 0.6
+                    , containers >= 0.6.7 && < 0.7
+                    , template-haskell >= 2.20.0 && < 2.21
+                    , pretty >= 1.1.3 && < 1.2
+                    , data-default >= 0.7.1 && < 0.8
+                    , data-default-class >= 0.1.2 && < 0.2
+                    , hashable >= 1.4.3 && < 1.5
+                    , mtl >= 2.3.1 && < 2.4
+                    , text >= 2.0.2 && < 2.1
+                    , megaparsec >= 9.6.1 && < 9.7
+                    , microlens >= 0.4.13 && < 0.5
+                    , microlens-mtl >= 0.2.0 && < 0.3
+                    , microlens-platform >= 0.4.3 && < 0.5
+                    , microlens-th >= 0.4.3 && < 0.5
+                    , unordered-containers >= 0.2.20 && < 0.3
+                    , recursion-schemes >= 5.2.2 && < 5.3
+                    , data-fix >= 0.3.2 && < 0.4
+                    , utf8-string >= 1.0.2 && < 1.1
+                    , extra >= 1.7.0 && < 2
 
     hs-source-dirs:   src
     default-language: GHC2021
 
+    default-extensions:
+        OverloadedStrings
+
 executable rlpc
     import:           warnings
     main-is:          Main.hs
@@ -64,11 +83,12 @@ executable rlpc
     -- other-extensions:
     build-depends: base ^>=4.18.0.0
                  , rlp
-                 , optparse-applicative
-                 , microlens
-                 , microlens-mtl
-                 , mtl
-                 , unordered-containers
+                 , 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
+                 , text >= 2.0.2 && < 2.1
 
     hs-source-dirs:   app
     default-language: GHC2021
@@ -84,7 +104,9 @@ test-suite rlp-test
                  , rlp
                  , QuickCheck
                  , hspec            ==2.*
+                 , microlens
     other-modules: Arith
                  , GMSpec
+                 , Core.HindleyMilnerSpec
     build-tool-depends: hspec-discover:hspec-discover
 

src/Compiler/JustRun.hs

@@ -0,0 +1,48 @@
+{-|
+Module      : Compiler.JustRun
+Description : No-BS, high-level wrappers for major pipeline pieces.
+
+A collection of wrapper functions to demo processes such as lexing, parsing,
+type-checking, and evaluation. This module intends to export "no-BS" functions
+that use Prelude types such as @Either@ and @String@ rather than more complex
+types such as @RLPC@ or @Text@.
+-}
+module Compiler.JustRun
+    ( justLexSrc
+    , justParseSrc
+    , justTypeCheckSrc
+    )
+    where
+----------------------------------------------------------------------------------
+import Core.Lex
+import Core.Parse
+import Core.HindleyMilner
+import Core.Syntax                      (Program')
+import Compiler.RLPC
+import Control.Arrow                    ((>>>))
+import Control.Monad                    ((>=>))
+import Data.Text                        qualified as T
+import Data.Function                    ((&))
+import GM
+----------------------------------------------------------------------------------
+
+justLexSrc :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
+justLexSrc s = lexCoreR (T.pack s)
+             & fmap (map $ \ (Located _ _ _ t) -> t)
+             & rlpcToEither
+
+justParseSrc :: String -> Either [MsgEnvelope RlpcError] Program'
+justParseSrc s = parse (T.pack s)
+               & rlpcToEither
+    where parse = lexCoreR >=> parseCoreProgR
+
+justTypeCheckSrc :: String -> Either [MsgEnvelope RlpcError] Program'
+justTypeCheckSrc s = typechk (T.pack s)
+                   & rlpcToEither
+    where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR
+
+rlpcToEither :: RLPC a -> Either [MsgEnvelope RlpcError] a
+rlpcToEither r = case evalRLPC def r of
+    (Just a,   _) -> Right a
+    (Nothing, es) -> Left es
+

src/Compiler/RLPC.hs

@@ -13,9 +13,12 @@ errors and the family of RLPC monads.
 {-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia #-}
 module Compiler.RLPC
     ( RLPC
-    , RLPCT
+    , RLPCT(..)
     , RLPCIO
     , RLPCOptions(RLPCOptions)
+    , IsRlpcError(..)
+    , RlpcError(..)
+    , MsgEnvelope(..)
     , addFatal
     , addWound
     , MonadErrorful
@@ -25,79 +28,77 @@ module Compiler.RLPC
     , evalRLPCIO
     , evalRLPC
     , rlpcLogFile
-    , rlpcDebugOpts
+    , rlpcDFlags  
     , rlpcEvaluator
     , rlpcInputFiles
     , DebugFlag(..)
-    , whenFlag
-    , flagDDumpEval
-    , flagDDumpOpts
-    , flagDDumpAST
+    , whenDFlag
+    , whenFFlag
     , def
+    , liftErrorful
     )
     where
 ----------------------------------------------------------------------------------
 import Control.Arrow            ((>>>))
 import Control.Exception
+import Control.Monad
 import Control.Monad.Reader
 import Control.Monad.State      (MonadState(state))
 import Control.Monad.Errorful
+import Compiler.RlpcError
 import Data.Functor.Identity
 import Data.Default.Class
+import Data.Foldable
 import GHC.Generics             (Generic)
+import Data.Maybe
 import Data.Hashable            (Hashable)
 import Data.HashSet             (HashSet)
 import Data.HashSet             qualified as S
 import Data.Coerce
-import Lens.Micro
-import Lens.Micro.TH
+import Lens.Micro.Platform
+import System.Exit
 ----------------------------------------------------------------------------------
 
--- TODO: fancy errors
-newtype RLPCT e m a = RLPCT {
-        runRLPCT :: ReaderT RLPCOptions (ErrorfulT e m) a
+newtype RLPCT m a = RLPCT {
+        runRLPCT :: ReaderT RLPCOptions (ErrorfulT (MsgEnvelope RlpcError) m) a
     }
-    -- TODO: incorrect ussage of MonadReader. RLPC should have its own
-    -- environment access functions
     deriving (Functor, Applicative, Monad, MonadReader RLPCOptions)
 
-deriving instance (MonadIO m) => MonadIO (RLPCT e m)
+type RLPC = RLPCT Identity
 
-instance MonadTrans (RLPCT e) where
-    lift = RLPCT . lift . lift
-
-instance (MonadState s m) => MonadState s (RLPCT e m) where
-    state = lift . state
-
-type RLPC e = RLPCT e Identity
-
-type RLPCIO e = RLPCT e IO
-
-evalRLPCT :: RLPCOptions
-          -> RLPCT e m a
-          -> m (Either e (a, [e]))
-evalRLPCT o = runRLPCT >>> flip runReaderT o >>> runErrorfulT
+type RLPCIO = RLPCT IO
 
 evalRLPC :: RLPCOptions
-         -> RLPC e a
-         -> Either e (a, [e])
-evalRLPC o m = coerce $ evalRLPCT o m
+         -> RLPC a
+         -> (Maybe a, [MsgEnvelope RlpcError])
+evalRLPC opt r = runRLPCT r
+               & flip runReaderT opt
+               & runErrorful
 
-evalRLPCIO :: (Exception e)
-           => RLPCOptions
-           -> RLPCIO e a
-           -> IO (a, [e])
-evalRLPCIO o m = do
-    m' <- evalRLPCT o m
-    case m' of
-        -- TODO: errors
-        Left e -> throwIO e
-        Right a -> pure a
-    
+evalRLPCT :: (Monad m)
+          => 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
+
+liftErrorful :: (Monad m, IsRlpcError e) => ErrorfulT (MsgEnvelope e) m a -> RLPCT m a
+liftErrorful e = RLPCT $ lift (fmap liftRlpcError `mapErrorful` e)
 
 data RLPCOptions = RLPCOptions
     { _rlpcLogFile     :: Maybe FilePath
-    , _rlpcDebugOpts   :: DebugOpts
+    , _rlpcDFlags      :: HashSet DebugFlag
+    , _rlpcFFlags      :: HashSet CompilerFlag
     , _rlpcEvaluator   :: Evaluator
     , _rlpcHeapTrigger :: Int
     , _rlpcInputFiles  :: [FilePath]
@@ -107,58 +108,38 @@ data RLPCOptions = RLPCOptions
 data Evaluator = EvaluatorGM | EvaluatorTI
     deriving Show
 
-data Severity = Error
-              | Warning
-              | Debug
-              deriving Show
-
--- temporary until we have a new doc building system
-type ErrorDoc = String
-
-class Diagnostic e where
-    errorDoc :: e -> ErrorDoc
-
-instance (Monad m) => MonadErrorful e (RLPCT e m) where
-    addWound = RLPCT . lift . addWound
-    addFatal = RLPCT . lift . addFatal
-
 ----------------------------------------------------------------------------------
 
 instance Default RLPCOptions where
     def = RLPCOptions
         { _rlpcLogFile = Nothing
-        , _rlpcDebugOpts = mempty
+        , _rlpcDFlags = mempty
+        , _rlpcFFlags = mempty
         , _rlpcEvaluator = EvaluatorGM
         , _rlpcHeapTrigger = 200
         , _rlpcInputFiles = []
         }
 
-type DebugOpts = HashSet DebugFlag
+-- debug flags are passed with -dFLAG
+type DebugFlag = String
 
-data DebugFlag = DDumpEval
-               | DDumpOpts
-               | DDumpAST
-               deriving (Show, Eq, Generic)
-
-instance Hashable DebugFlag
+type CompilerFlag = String
 
 makeLenses ''RLPCOptions
 pure []
 
-whenFlag :: (MonadReader s m) => SimpleGetter s Bool -> m () -> m ()
-whenFlag l m = asks (^. l) >>= \a -> if a then m else pure ()
+-- TODO: rewrite this with prisms once microlens-pro drops :3
+whenDFlag :: (Monad m) => DebugFlag -> RLPCT m () -> RLPCT m ()
+whenDFlag f m = do
+    -- mfw no `At` instance for HashSet
+    fs <- view rlpcDFlags
+    let a = S.member f fs
+    when a m
 
--- there's probably a better way to write this. my current knowledge of lenses
--- is too weak.
-flagGetter :: DebugFlag -> SimpleGetter RLPCOptions Bool
-flagGetter d = to $ \s -> s ^. rlpcDebugOpts & S.member d
-
-flagDDumpEval :: SimpleGetter RLPCOptions Bool
-flagDDumpEval = flagGetter DDumpEval
-
-flagDDumpOpts :: SimpleGetter RLPCOptions Bool
-flagDDumpOpts = flagGetter DDumpOpts
-
-flagDDumpAST :: SimpleGetter RLPCOptions Bool
-flagDDumpAST = flagGetter DDumpAST
+whenFFlag :: (Monad m) => CompilerFlag -> RLPCT m () -> RLPCT m ()
+whenFFlag f m = do
+    -- mfw no `At` instance for HashSet
+    fs <- view rlpcFFlags
+    let a = S.member f fs
+    when a m
 

src/Compiler/RlpcError.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
+module Compiler.RlpcError
+    ( IsRlpcError(..)
+    , MsgEnvelope(..)
+    , Severity(..)
+    , RlpcError(..)
+    , SrcSpan(..)
+    , msgSpan
+    , msgDiagnostic
+    , msgSeverity
+    , liftRlpcErrors
+    , errorMsg
+    )
+    where
+----------------------------------------------------------------------------------
+import Control.Monad.Errorful
+import Data.Text                (Text)
+import Data.Text                qualified as T
+import GHC.Exts                 (IsString(..))
+import Lens.Micro.Platform
+import Lens.Micro.Platform.Internal
+----------------------------------------------------------------------------------
+
+data MsgEnvelope e = MsgEnvelope
+   { _msgSpan        :: SrcSpan
+   , _msgDiagnostic  :: e
+   , _msgSeverity    :: Severity
+   }
+   deriving (Functor, Show)
+
+newtype RlpcError = Text [Text]
+    deriving Show
+
+instance IsString RlpcError where
+    fromString = Text . pure . T.pack
+
+class IsRlpcError e where
+    liftRlpcError :: e -> RlpcError
+
+instance IsRlpcError RlpcError where
+    liftRlpcError = id
+
+data Severity = SevWarning
+              | SevError
+              deriving Show
+
+data SrcSpan = SrcSpan
+    !Int -- ^ Line
+    !Int -- ^ Column
+    !Int -- ^ Length
+    deriving Show
+
+makeLenses ''MsgEnvelope
+
+liftRlpcErrors :: (Functor m, IsRlpcError e)
+               => ErrorfulT e m a
+               -> ErrorfulT RlpcError m a
+liftRlpcErrors = mapErrorful liftRlpcError
+
+instance (IsRlpcError e) => IsRlpcError (MsgEnvelope e) where
+    liftRlpcError msg = msg ^. msgDiagnostic & liftRlpcError
+
+errorMsg :: SrcSpan -> e -> MsgEnvelope e
+errorMsg s e = MsgEnvelope
+    { _msgSpan = s
+    , _msgDiagnostic = e
+    , _msgSeverity = SevError
+    }
+

src/Control/Monad/Errorful.hs

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

src/Control/Monad/Utils.hs

@@ -0,0 +1,21 @@
+module Control.Monad.Utils
+    ( mapAccumLM
+    )
+    where
+----------------------------------------------------------------------------------
+import Data.Tuple               (swap)
+import Control.Monad.State
+----------------------------------------------------------------------------------
+
+-- | Monadic variant of @mapAccumL@
+
+mapAccumLM :: forall m t s a b. (Monad m, Traversable t)
+           => (s -> a -> m (s, b))
+           -> s
+           -> t a
+           -> m (s, t b)
+mapAccumLM k s t = swap <$> runStateT (traverse k' t) s
+    where
+        k' :: a -> StateT s m b
+        k' a = StateT $ fmap swap <$> flip k a
+

src/Core/Examples.hs

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

src/Core/HindleyMilner.hs

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

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

src/Core/Parse.y

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

src/Core/Syntax.hs

@@ -4,11 +4,21 @@ 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 #-}
 module Core.Syntax
     ( Expr(..)
+    , ExprF(..)
+    , ExprF'(..)
     , Type(..)
-    , Literal(..)
+    , pattern TyInt
+    , Lit(..)
     , pattern (:$)
+    , pattern (:@)
+    , pattern (:->)
     , Binding(..)
     , AltCon(..)
     , pattern (:=)
@@ -20,7 +30,11 @@ module Core.Syntax
     , Module(..)
     , Program(..)
     , Program'
+    , Pragma(..)
+    , unliftScDef
     , programScDefs
+    , programTypeSigs
+    , programDataTags
     , Expr'
     , ScDef'
     , Alter'
@@ -32,40 +46,55 @@ module Core.Syntax
 ----------------------------------------------------------------------------------
 import Data.Coerce
 import Data.Pretty
-import GHC.Generics
 import Data.List                    (intersperse)
 import Data.Function                ((&))
+import Data.Functor.Foldable
+import Data.Functor.Foldable.TH     (makeBaseFunctor)
 import Data.String
+import Data.HashMap.Strict          (HashMap)
+import Data.HashMap.Strict          qualified as H
+import Data.Hashable
+import Data.Text                    qualified as T
+import Data.Char
+import GHC.Generics
 -- Lift instances for the Core quasiquoters
 import Language.Haskell.TH.Syntax   (Lift)
+import Lens.Micro.TH                (makeLenses)
 import Lens.Micro
 ----------------------------------------------------------------------------------
 
 data Expr b = Var Name
-            | Con Tag Int -- Con Tag Arity
+            | Con Tag Int -- ^ Con Tag Arity
             | Case (Expr b) [Alter b]
             | Lam [b] (Expr b)
             | Let Rec [Binding b] (Expr b)
             | App (Expr b) (Expr b)
-            | LitE Literal
-            | Type Type
+            | Lit Lit
             deriving (Show, Read, Lift)
 
 deriving instance (Eq b) => Eq (Expr b)
 
-data Type = TyInt
-          | TyFun
+data Type = TyFun
           | TyVar Name
           | TyApp Type Type
-          | TyConApp TyCon [Type]
+          | TyCon Name
           deriving (Show, Read, Lift, Eq)
 
-type TyCon = Name
+pattern TyInt :: Type
+pattern TyInt = TyCon "Int#"
 
 infixl 2 :$
-pattern (:$) :: Expr b  -> Expr b  -> Expr b 
+pattern (:$) :: Expr b -> Expr b -> Expr b 
 pattern f :$ x = App f x
 
+infixl 2 :@
+pattern (:@) :: Type -> Type -> Type
+pattern f :@ x = TyApp f x
+
+infixr 1 :->
+pattern (:->) :: Type -> Type -> Type
+pattern a :-> b = TyApp (TyApp TyFun a) b
+
 {-# COMPLETE Binding :: Binding #-}
 {-# COMPLETE (:=) :: Binding #-}
 data Binding b = Binding b (Expr b)
@@ -82,32 +111,48 @@ data Alter b = Alter AltCon [b] (Expr b)
 
 deriving instance (Eq b) => Eq (Alter b)
 
+newtype Pragma = Pragma [T.Text]
+
 data Rec = Rec
          | NonRec
          deriving (Show, Read, Eq, Lift)
 
-data AltCon = AltData Tag
-            | AltLiteral Literal
+data AltCon = AltData Name
+            | AltTag Tag
+            | AltLit Lit
             | Default
             deriving (Show, Read, Eq, Lift)
 
-data Literal = IntL Int
+data Lit = IntL Int
     deriving (Show, Read, Eq, Lift)
 
-type Name = String
+type Name = T.Text
 type Tag = Int
 
 data ScDef b = ScDef b [b] (Expr b)
     deriving (Show, Lift)
 
+unliftScDef :: ScDef b -> Expr b
+unliftScDef (ScDef _ as e) = Lam as e
+
 data Module b = Module (Maybe (Name, [Name])) (Program b)
     deriving (Show, Lift)
 
-newtype Program b = Program [ScDef b]
-    deriving (Show, Lift)
+data Program b = Program
+    { _programScDefs   :: [ScDef b]
+    , _programTypeSigs :: HashMap b Type
+    -- map constructors to their tag and arity
+    , _programDataTags :: HashMap b (Tag, Int)
+    }
+    deriving (Show, Lift, Generic)
+    deriving (Semigroup, Monoid)
+        via Generically (Program b)
 
-programScDefs :: Lens' (Program b) [ScDef b]
-programScDefs = lens coerce (const coerce)
+makeLenses ''Program
+makeBaseFunctor ''Expr
+pure []
+
+type ExprF' = ExprF Name
 
 type Program' = Program Name
 type Expr' = Expr Name
@@ -116,13 +161,14 @@ type Alter' = Alter Name
 type Binding' = Binding Name
 
 instance IsString (Expr b) where
-    fromString = Var
+    fromString = Var . fromString
 
-instance Semigroup (Program b) where
-    (<>) = coerce $ (<>) @[ScDef b] 
-
-instance Monoid (Program b) where
-    mempty = Program []
+instance IsString Type where
+    fromString "" = error "IsString Type string may not be empty"
+    fromString s
+        | isUpper c     = TyCon . fromString $ s
+        | otherwise     = TyVar . fromString $ s
+        where (c:_) = s
 
 ----------------------------------------------------------------------------------
 
@@ -157,3 +203,8 @@ instance HasLHS (ScDef b) (ScDef b) (b, [b]) (b, [b]) where
         (\ (ScDef n as _) -> (n,as))
         (\ (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)
+

src/Core/TH.hs

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

src/Core/Utils.hs

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

src/Core2Core.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ImplicitParams #-}
 {-# LANGUAGE LambdaCase #-}
 module Core2Core
     ( core2core
@@ -15,10 +16,12 @@ import Data.Set                 (Set)
 import Data.Set                 qualified as S
 import Data.List
 import Control.Monad.Writer
-import Control.Monad.State
+import Control.Monad.State.Lazy
 import Control.Arrow            ((>>>))
+import Data.Text                qualified as T
+import Data.HashMap.Strict      (HashMap)
 import Numeric                  (showHex)
-import Lens.Micro
+import Lens.Micro.Platform
 import Core.Syntax
 import Core.Utils
 ----------------------------------------------------------------------------------
@@ -27,26 +30,39 @@ core2core :: Program' -> Program'
 core2core p = undefined
 
 gmPrep :: Program' -> Program'
-gmPrep p = p' <> Program caseScs
+gmPrep p = p & appFloater (floatNonStrictCases globals)
+             & tagData
     where
-        rhss :: Applicative f => (Expr z -> f (Expr z)) -> Program z -> f (Program z)
-        rhss = programScDefs . each . _rhs
         globals = p ^.. programScDefs . each . _lhs . _1
                 & S.fromList
 
-        -- i kinda don't like that we're calling floatNonStrictCases twice tbh
-        p'      = p & rhss %~ fst . runFloater . floatNonStrictCases globals
-        caseScs = (p ^.. rhss)
-              <&> snd . runFloater . floatNonStrictCases globals
-                & mconcat
+tagData :: Program' -> Program'
+tagData p = let ?dt = p ^. programDataTags
+            in p & programRhss %~ cata go where
+    go :: (?dt :: HashMap Name (Tag, Int)) => ExprF' Expr' -> Expr'
+    go (CaseF  e as)    = Case e (tagAlts <$> as)
+    go x                = embed x
+
+    tagAlts :: (?dt :: HashMap Name (Tag, Int)) => Alter' -> Alter'
+    tagAlts (Alter (AltData c) bs e) = Alter (AltTag tag) bs e
+        where tag = case ?dt ^. at c of
+                Just (t,_) -> t
+                -- TODO: errorful
+                Nothing    -> error $ "unknown constructor " <> show c
+    tagAlts x = x
 
 -- | Auxilary type used in @floatNonSrictCases@
 type Floater = StateT [Name] (Writer [ScDef'])
 
+appFloater :: (Expr' -> Floater Expr') -> Program' -> Program'
+appFloater fl p = p & traverseOf programRhss fl
+                    & runFloater
+                    & \ (me,floats) -> me & programScDefs %~ (<>floats)
+
 runFloater :: Floater a -> (a, [ScDef'])
 runFloater = flip evalStateT ns >>> runWriter
     where
-        ns = [ "$nonstrict_case_" ++ showHex n "" | n <- [0..] ]
+        ns = [ T.pack $ "$nonstrict_case_" ++ showHex n "" | n <- [0..] ]
 
 -- TODO: formally define a "strict context" and reference that here
 -- the returned ScDefs are guaranteed to be free of non-strict cases.
@@ -55,7 +71,7 @@ floatNonStrictCases g = goE
     where
         goE :: Expr' -> Floater Expr'
         goE (Var k)             = pure (Var k)
-        goE (LitE l)            = pure (LitE l)
+        goE (Lit l)             = pure (Lit l)
         goE (Case e as)         = pure (Case e as)
         goE (Let Rec bs e)      = Let Rec <$> bs' <*> goE e
             where bs' = travBs goE bs
@@ -77,7 +93,7 @@ floatNonStrictCases g = goE
         goC (f :$ x)            = (:$) <$> goC f <*> goC x
         goC (Let r bs e)        = Let r <$> bs' <*> goE e
             where bs' = travBs goC bs
-        goC (LitE l)            = pure (LitE l)
+        goC (Lit l)             = pure (Lit l)
         goC (Var k)             = pure (Var k)
         goC (Con t as)          = pure (Con t as)
 

src/GM.hs

@@ -22,7 +22,10 @@ import Data.Maybe                   (fromMaybe, mapMaybe)
 import Data.Monoid                  (Endo(..))
 import Data.Tuple                   (swap)
 import Lens.Micro
+import Lens.Micro.Extras            (view)
 import Lens.Micro.TH
+import Lens.Micro.Platform          (packed, unpacked)
+import Lens.Micro.Platform.Internal (IsText(..))
 import Text.Printf
 import Text.PrettyPrint             hiding ((<>))
 import Text.PrettyPrint.HughesPJ    (maybeParens)
@@ -281,7 +284,7 @@ step st = case head (st ^. gmCode) of
                 m = st ^. gmEnv
                 s = st ^. gmStack
                 h = st ^. gmHeap
-                n' = show n
+                n' = show n ^. packed
 
         -- Core Rule 2. (no sharing)
         -- pushIntI :: Int -> GmState
@@ -582,7 +585,7 @@ compiledPrims =
         binop k i = (k, 2, [Push 1, Eval, Push 1, Eval, i, Update 2, Pop 2, Unwind])
 
 buildInitialHeap :: Program' -> (GmHeap, Env)
-buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
+buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compiledScs
     where
         compiledScs = fmap compileSc ss <> compiledPrims
 
@@ -612,12 +615,13 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
             | k `elem` domain  = [Push n]
             | otherwise        = [PushGlobal k]
             where
-                n = fromMaybe (error $ "undeclared var: " <> k) $ lookupN k g
+                n = fromMaybe err $ lookupN k g
+                err = error $ "undeclared var: " <> (k ^. unpacked)
                 domain = f `mapMaybe` g
                 f (NameKey n, _) = Just n
                 f _              = Nothing
 
-        compileC _ (LitE l)  = compileCL l
+        compileC _ (Lit l)   = compileCL l
 
         -- >> [ref/compileC]
         compileC g (App f x) = compileC g x
@@ -657,20 +661,21 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
         compileC _ (Con t n) = [PushConstr t n]
 
         compileC _ (Case _ _) =
-            error "case expressions may not appear in non-strict contexts :/"
+            error "GM compiler found a non-strict case expression, which should\
+                  \ have been floated by Core2Core.gmPrep. This is a bug!"
 
         compileC _ _ = error "yet to be implemented!"
 
-        compileCL :: Literal -> Code
+        compileCL :: Lit -> Code
         compileCL (IntL n) = [PushInt n]
 
-        compileEL :: Literal -> Code
+        compileEL :: Lit -> Code
         compileEL (IntL n) = [PushInt n]
 
         -- compile an expression in a strict context such that a pointer to the
         -- expression is left on top of the stack in WHNF
         compileE :: Env -> Expr' -> Code
-        compileE _ (LitE l) = compileEL l
+        compileE _ (Lit l) = compileEL l
         compileE g (Let NonRec bs e) =
                 -- we use compileE instead of compileC
                 mconcat binders <> compileE g' e <> [Slide d]
@@ -720,12 +725,16 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
         compileD g as = fmap (compileA g) as
 
         compileA :: Env -> Alter' -> (Tag, Code)
-        compileA g (Alter (AltData t) as e) = (t, [Split n] <> c <> [Slide n])
+        compileA g (Alter (AltTag t) as e) = (t, [Split n] <> c <> [Slide n])
             where
                 n = length as
                 binds = (NameKey <$> as) `zip` [0..]
                 g' = binds ++ argOffset n g
                 c = compileE g' e
+        compileA _ (Alter _ as e) = error "GM.compileA found an untagged\
+                                          \ constructor, which should have\
+                                          \ been handled by Core2Core.gmPrep.\
+                                          \ This is a bug!"
 
         inlineOp1 :: Env -> Instr -> Expr' -> Code
         inlineOp1 g i a = compileE g a <> [i]
@@ -738,8 +747,8 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
         argOffset :: Int -> Env -> Env
         argOffset n = each . _2 %~ (+n)
 
-idPack :: Tag -> Int -> String
-idPack t n = printf "Pack{%d %d}" t n
+showCon :: (IsText a) => Tag -> Int -> a
+showCon t n = printf "Pack{%d %d}" t n ^. packed
 
 ----------------------------------------------------------------------------------
 
@@ -855,12 +864,12 @@ showNodeAt = showNodeAtP 0
 showNodeAtP :: Int -> GmState -> Addr -> Doc
 showNodeAtP p st a = case hLookup a h of
     Just (NNum n)        -> int n <> "#"
-    Just (NGlobal _ _)   -> text name
+    Just (NGlobal _ _)   -> textt name
         where
             g = st ^. gmEnv
             name = case lookup a (swap <$> g) of
                 Just (NameKey n)     -> n
-                Just (ConstrKey t n) -> idPack t n
+                Just (ConstrKey t n) -> showCon t n
                 _                    -> errTxtInvalidAddress
     -- TODO: left-associativity
     Just (NAp f x)       -> pprec $ showNodeAtP (p+1) st f
@@ -877,7 +886,7 @@ showNodeAtP p st a = case hLookup a h of
         pprec = maybeParens (p > 0)
 
 showSc :: GmState -> (Name, Addr) -> Doc
-showSc st (k,a) = "Supercomb " <> qquotes (text k) <> colon
+showSc st (k,a) = "Supercomb " <> qquotes (textt k) <> colon
                $$ code
     where
         code = case hLookup a (st ^. gmHeap) of
@@ -900,6 +909,9 @@ showInstr (CaseJump alts) = "CaseJump" $$ nest pprTabstop alternatives
         alternatives = foldr (\a acc -> showAlt a $$ acc) mempty alts
 showInstr i = text $ show i
 
+textt :: (IsText a) => a -> Doc
+textt t = t ^. unpacked & text
+
 ----------------------------------------------------------------------------------
 
 lookupN :: Name -> Env -> Maybe Addr
@@ -975,7 +987,8 @@ resultOf p = do
         h = st ^. gmHeap
 
 resultOfExpr :: Expr' -> Maybe Node
-resultOfExpr e = resultOf $ Program
-    [ ScDef "main" [] e
-    ]
+resultOfExpr e = resultOf $
+    mempty & programScDefs .~
+                [ ScDef "main" [] e
+                ]
 

src/RLP/Syntax.hs

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

src/Rlp/Lex.x

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

src/Rlp/Parse.y

@@ -0,0 +1,181 @@
+{
+{-# LANGUAGE LambdaCase #-}
+module Rlp.Parse
+    ( parseRlpProg
+    )
+    where
+import Compiler.RlpcError
+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 Data.List.Extra
+import Data.Fix
+import Data.Functor.Const
+import Data.Text                    qualified as T
+}
+
+%name parseRlpProg StandaloneProgram
+
+%monad { P }
+%lexer { lexCont } { Located _ TokenEOF }
+%error { parseError }
+%tokentype { Located RlpToken }
+
+%token
+    varname         { Located _ (TokenVarName $$) }
+    conname         { Located _ (TokenConName $$) }
+    consym          { Located _ (TokenConSym $$) }
+    varsym          { Located _ (TokenVarSym $$) }
+    data            { Located _ TokenData }
+    litint          { Located _ (TokenLitInt $$) }
+    '='             { Located _ TokenEquals }
+    '|'             { Located _ TokenPipe }
+    ';'             { Located _ TokenSemicolon }
+    '('             { Located _ TokenLParen }
+    ')'             { Located _ TokenRParen }
+    '->'            { Located _ TokenArrow }
+    vsemi           { Located _ TokenSemicolonV }
+    '{'             { Located _ TokenLBrace }
+    '}'             { Located _ TokenRBrace }
+    vlbrace         { Located _ TokenLBraceV }
+    vrbrace         { Located _ TokenRBraceV }
+    infixl          { Located _ TokenInfixL }
+    infixr          { Located _ TokenInfixR }
+    infix           { Located _ TokenInfix }
+
+%right '->'
+
+%%
+
+StandaloneProgram   :: { RlpProgram' }
+StandaloneProgram   : '{' Decls  '}'        {% mkProgram $2 }
+                    | VL  DeclsV VR         {% mkProgram $2 }
+
+VL  :: { () }
+VL  : vlbrace       { () }
+
+VR  :: { () }
+VR  : vrbrace       { () }
+    | error         { () }
+
+Decls               :: { [PartialDecl'] }
+Decls               : Decl ';' Decls        { $1 : $3 }
+                    | Decl ';'              { [$1] }
+                    | Decl                  { [$1] }
+
+DeclsV              :: { [PartialDecl'] }
+DeclsV              : Decl VS Decls         { $1 : $3 }
+                    | Decl VS               { [$1] }
+                    | Decl                  { [$1] }
+
+VS                  :: { Located RlpToken }
+VS                  : ';'                   { $1 }
+                    | vsemi                 { $1 }
+
+Decl        :: { PartialDecl' }
+            : FunDecl                   { $1 }
+            | DataDecl                  { $1 }
+            | InfixDecl                 { $1 }
+
+InfixDecl   :: { PartialDecl' }
+            : InfixWord litint InfixOp  {% mkInfixD $1 $2 $3 }
+
+InfixWord   :: { Assoc }
+            : infixl                    { InfixL }
+            | infixr                    { InfixR }
+            | infix                     { Infix  }
+
+DataDecl    :: { PartialDecl' }
+            : data Con TyParams '=' DataCons    { DataD $2 $3 $5 }
+
+TyParams    :: { [Name] }
+            : {- epsilon -}             { [] }
+            | TyParams varname          { $1 `snoc` $2 }
+
+DataCons    :: { [ConAlt] }
+            : DataCons '|' DataCon      { $1 `snoc` $3 }
+            | DataCon                   { [$1] }
+
+DataCon     :: { ConAlt }
+            : Con Type1s                { ConAlt $1 $2 }
+
+Type1s      :: { [Type] }
+            : {- epsilon -}             { [] }
+            | Type1s Type1              { $1 `snoc` $2 }
+
+Type1       :: { Type }
+            : '(' Type ')'              { $2 }
+            | conname                   { TyCon $1 }
+            | varname                   { TyVar $1 }
+
+Type        :: { Type }
+            : Type '->' Type            { $1 :-> $3 }
+            | Type1                     { $1 }
+
+FunDecl     :: { PartialDecl' }
+FunDecl     : Var Params '=' Expr       { FunD $1 $2 (Const $4) Nothing }
+
+Params      :: { [Pat'] }
+Params      : {- epsilon -}             { [] }
+            | Params Pat1               { $1 `snoc` $2 }
+
+Pat1        :: { Pat' }
+            : Var                       { VarP $1 }
+            | Lit                       { LitP $1 }
+
+Expr        :: { PartialExpr' }
+            : Expr1 varsym Expr         { Fix $ B $2 (unFix $1) (unFix $3) }
+            | Expr1                     { $1 }
+
+Expr1       :: { PartialExpr' }
+            : '(' Expr ')'              { wrapFix . Par . unwrapFix $ $2 }
+            | Lit                       { Fix . E $ LitEF $1 }
+            | Var                       { Fix . E $ VarEF $1 }
+
+-- 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) }
+
+InfixOp     :: { Name }
+            : consym                    { $1 }
+            | varsym                    { $1 }
+
+Lit         :: { Lit' }
+Lit         : litint                    { IntL $1 }
+
+Var         :: { VarId }
+Var         : varname                   { NameVar $1 }
+
+Con         :: { ConId }
+            : conname                   { NameCon $1 }
+
+{
+
+mkProgram :: [PartialDecl'] -> P RlpProgram'
+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
+
+mkInfixD :: Assoc -> Int -> Name -> P PartialDecl'
+mkInfixD a p n = do
+    let opl :: Lens' ParseState (Maybe OpInfo)
+        opl = psOpTable . at n
+    opl <~ (use opl >>= \case
+        Just o  -> addWoundHere l e >> pure (Just o) where
+            e = RlpParErrDuplicateInfixD n
+            l = T.length n
+        Nothing -> pure (Just (a,p))
+        )
+    pure $ InfixD a p n
+
+}

src/Rlp/Parse/Associate.hs

@@ -0,0 +1,100 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms, ViewPatterns, ImplicitParams #-}
+module Rlp.Parse.Associate
+    ( associate
+    )
+    where
+--------------------------------------------------------------------------------
+import Data.HashMap.Strict              qualified as H
+import Data.Functor.Foldable
+import Data.Functor.Const
+import Lens.Micro
+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
+
+completeExpr :: (?pt :: OpTable) => PartialExpr' -> RlpExpr'
+completeExpr = cata completePartial
+
+completePartial :: (?pt :: OpTable) => PartialE -> RlpExpr'
+completePartial (E e)        = completeRlpExpr e
+completePartial p@(B o l r)  = completeB (build p)
+completePartial (Par e)      = completePartial e
+
+completeRlpExpr :: (?pt :: OpTable) => RlpExprF' RlpExpr' -> RlpExpr'
+completeRlpExpr = embed
+
+completeB :: (?pt :: OpTable) => PartialE -> RlpExpr'
+completeB p = case build p of
+    B o l r     -> (o' `AppE` l') `AppE` r'
+        where
+            -- TODO: how do we know it's symbolic?
+            o' = VarE (SymVar o)
+            l' = completeB l
+            r' = completeB r
+    Par e       -> completeB e
+    E e         -> completeRlpExpr e
+
+build :: (?pt :: OpTable) => PartialE -> PartialE
+build e = go id e (rightmost e) where
+    rightmost :: PartialE -> PartialE
+    rightmost (B _ _ r) = rightmost r
+    rightmost p@(E _)   = p
+    rightmost p@(Par _) = p
+
+    go :: (?pt :: OpTable)
+       => (PartialE -> PartialE)
+       -> PartialE -> PartialE -> PartialE
+    go f p@(WithInfo o _ r) = case r of
+            E _     -> mkHole o (f . f')
+            Par _   -> mkHole o (f . f')
+            B _ _ _ -> go (mkHole o (f . f')) r
+        where f' r' = p & pR .~ r'
+    go f _ = id
+
+mkHole :: (?pt :: OpTable)
+       => OpInfo
+       -> (PartialE -> PartialE)
+       -> PartialE
+       -> PartialE
+mkHole _     hole p@(Par _)                 = hole p
+mkHole _     hole p@(E _)                   = hole p
+mkHole (a,d) hole p@(WithInfo (a',d') _ _)
+    | d' < d  = above
+    | d' > d  = below
+    | d == d' = case (a,a') of
+                  -- left-associative operators of equal precedence are
+                  -- associated left
+                  (InfixL,InfixL) -> above
+                  -- right-associative operators are handled similarly
+                  (InfixR,InfixR) -> below
+                  -- non-associative operators of equal precedence, or equal
+                  -- precedence operators of different associativities are
+                  -- invalid
+                  (_,     _)      -> error "invalid expression"
+    where
+        above = p & pL %~ hole
+        below = hole p
+
+examplePrecTable :: OpTable
+examplePrecTable = H.fromList
+    [ ("+",    (InfixL,6))
+    , ("*",    (InfixL,7))
+    , ("^",    (InfixR,8))
+    , (".",    (InfixR,7))
+    , ("~",    (Infix, 9))
+    , ("=",    (Infix, 4))
+    , ("&&",   (Infix, 3))
+    , ("||",   (Infix, 2))
+    , ("$",    (InfixR,0))
+    , ("&",    (InfixL,0))
+    ]
+
+

src/Rlp/Parse/Types.hs

@@ -0,0 +1,242 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# 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
+    )
+    where
+--------------------------------------------------------------------------------
+import Core.Syntax                  (Name)
+import Control.Monad
+import Control.Monad.State.Strict
+import Control.Monad.Errorful
+import Compiler.RlpcError
+import Data.Text                    (Text)
+import Data.Maybe
+import Data.Fix
+import Data.Functor.Foldable
+import Data.Functor.Const
+import Data.Functor.Classes
+import Data.HashMap.Strict          qualified as H
+import Data.Word                    (Word8)
+import Lens.Micro.TH
+import Lens.Micro
+import Rlp.Syntax
+--------------------------------------------------------------------------------
+
+type LexerAction a = AlexInput -> Int -> P a
+
+data AlexInput = AlexInput
+    { _aiPrevChar   :: Char
+    , _aiSource     :: Text
+    , _aiBytes      :: [Word8]
+    , _aiPos        :: Position
+    }
+    deriving Show
+
+type Position =
+    ( Int -- line
+    , Int -- column
+    )
+
+posLine :: Lens' Position Int
+posLine = _1
+
+posColumn :: Lens' Position Int
+posColumn = _2
+
+data RlpToken
+    -- literals
+    = TokenLitInt Int
+    -- identifiers
+    | TokenVarName Name
+    | TokenConName Name
+    | TokenVarSym Name
+    | TokenConSym Name
+    -- reserved words
+    | TokenData
+    | TokenCase
+    | TokenOf
+    | TokenLet
+    | TokenIn
+    | TokenInfixL
+    | TokenInfixR
+    | TokenInfix
+    -- reserved ops
+    | TokenArrow
+    | TokenPipe
+    | TokenHasType
+    | TokenLambda
+    | TokenEquals
+    -- control symbols
+    | TokenSemicolon
+    | TokenLBrace
+    | TokenRBrace
+    | TokenLParen
+    | TokenRParen
+    -- 'virtual' control symbols, inserted by the lexer without any correlation
+    -- to a specific symbol
+    | TokenSemicolonV
+    | TokenLBraceV
+    | TokenRBraceV
+    | TokenEOF
+    deriving (Show)
+
+newtype P a = P {
+        runP :: ParseState
+             -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
+    }
+    deriving (Functor)
+
+instance Applicative P where
+    pure a = P $ \st -> (st, [], pure a)
+    liftA2 = liftM2
+
+instance Monad P where
+    p >>= k = P $ \st ->
+        let (st',es,ma) = runP p st
+        in case ma of
+            Just a  -> runP (k a) st'
+                     & _2 %~ (es<>)
+            Nothing -> (st',es,Nothing)
+
+    {-# INLINE (>>=) #-}
+
+instance MonadState ParseState P where
+    state f = P $ \st ->
+        let (a,st') = f st
+        in (st', [], Just a)
+
+instance MonadErrorful (MsgEnvelope RlpParseError) P where
+    addWound e = P $ \st -> (st, [e], Just ())
+    addFatal e = P $ \st -> (st, [e], Nothing)
+
+data ParseState = ParseState
+    { _psLayoutStack        :: [Layout]
+    , _psLexState           :: [Int]
+    , _psInput              :: AlexInput
+    , _psOpTable            :: OpTable
+    }
+    deriving Show
+
+data Layout = Explicit
+            | Implicit Int
+            deriving (Show, Eq)
+
+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)
+
+instance IsRlpcError RlpParseError where
+
+----------------------------------------------------------------------------------
+-- absolute psycho shit (partial ASTs)
+
+type PartialDecl' = Decl (Const PartialExpr') Name
+
+data Partial a = E (RlpExprF Name a)
+               | B Name (Partial a) (Partial a)
+               | Par (Partial a)
+               deriving (Show, Functor)
+
+pL :: Traversal' (Partial a) (Partial a)
+pL k (B o l r) = (\l' -> B o l' r) <$> k l
+pL _ x         = pure x
+
+pR :: Traversal' (Partial a) (Partial a)
+pR k (B o l r) = (\r' -> B o l r') <$> k r
+pR _ x         = pure x
+
+type PartialE = Partial RlpExpr'
+
+-- i love you haskell
+pattern WithInfo :: (?pt :: OpTable) => OpInfo -> PartialE -> PartialE -> PartialE
+pattern WithInfo p l r <- B (opInfoOrDef -> p) l r
+
+opInfoOrDef :: (?pt :: OpTable) => Name -> OpInfo
+opInfoOrDef c = fromMaybe (InfixL,9) $ H.lookup c ?pt
+
+-- required to satisfy constraint on Fix's show instance
+instance Show1 Partial where
+    liftShowsPrec :: forall a. (Int -> a -> ShowS)
+                  -> ([a] -> ShowS)
+                  -> Int -> Partial a -> ShowS
+
+    liftShowsPrec sp sl p m = case m of
+        (E e)       -> showsUnaryWith lshow "E" p e
+        (B f a b)   -> showsTernaryWith showsPrec lshow lshow "B" p f a b
+        (Par e)     -> showsUnaryWith lshow "Par" p e
+        where
+            lshow :: forall f. (Show1 f) => Int -> f a -> ShowS
+            lshow = liftShowsPrec sp sl
+
+type PartialExpr' = Fix Partial
+
+makeLenses ''AlexInput
+makeLenses ''ParseState
+
+addWoundHere :: Int -> RlpParseError -> P ()
+addWoundHere l e = P $ \st ->
+    let e' = MsgEnvelope
+            { _msgSpan = let pos = psInput . aiPos
+                         in SrcSpan (st ^. pos . posLine)
+                                   (st ^. pos . posColumn)
+                                   l
+            , _msgDiagnostic = e
+            , _msgSeverity = SevError
+            }
+    in (st, [e'], Just ())
+
+addFatalHere :: Int -> RlpParseError -> P a
+addFatalHere l e = P $ \st ->
+    let e' = MsgEnvelope
+            { _msgSpan = let pos = psInput . aiPos
+                         in SrcSpan (st ^. pos . posLine)
+                                    (st ^. pos . posColumn)
+                                    l
+            , _msgDiagnostic = e
+            , _msgSeverity = SevError
+            }
+    in (st, [e'], Nothing)
+

src/Rlp/Syntax.hs

@@ -0,0 +1,177 @@
+-- recursion-schemes
+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
+-- recursion-schemes
+{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings, PatternSynonyms #-}
+module Rlp.Syntax
+    ( RlpModule(..)
+    , RlpProgram(..)
+    , RlpProgram'
+    , rlpmodName
+    , rlpmodProgram
+    , RlpExpr(..)
+    , RlpExpr'
+    , RlpExprF(..)
+    , RlpExprF'
+    , Decl(..)
+    , Decl'
+    , Bind(..)
+    , Where
+    , Where'
+    , ConAlt(..)
+    , Type(..)
+    , pattern (:->)
+    , Assoc(..)
+    , VarId(..)
+    , ConId(..)
+    , Pat(..)
+    , Pat'
+    , Lit(..)
+    , Lit'
+    , Name
+
+    -- TODO: ugh move this somewhere else later
+    , showsTernaryWith
+
+    -- * Convenience re-exports
+    , Text
+    )
+    where
+----------------------------------------------------------------------------------
+import Data.Text                    (Text)
+import Data.Text                    qualified as T
+import Data.String                  (IsString(..))
+import Data.Functor.Foldable.TH     (makeBaseFunctor)
+import Data.Functor.Classes
+import Lens.Micro
+import Lens.Micro.TH
+import Core.Syntax                  hiding (Lit)
+import Core                         (HasRHS(..), HasLHS(..))
+----------------------------------------------------------------------------------
+
+data RlpModule b = RlpModule
+    { _rlpmodName       :: Text
+    , _rlpmodProgram    :: RlpProgram b
+    }
+
+newtype RlpProgram b = RlpProgram [Decl RlpExpr b]
+    deriving Show
+
+type RlpProgram' = RlpProgram Name
+
+-- | The @e@ parameter is used for partial results. When parsing an input, we
+-- first parse all top-level declarations in order to extract infix[lr]
+-- declarations. This process yields a @[Decl (Const Text) Name]@, where @Const
+-- Text@ stores the remaining unparsed function bodies. Once infixities are
+-- accounted for, we may complete the parsing task and get a proper @[Decl
+-- RlpExpr Name]@.
+
+data Decl e b = FunD    VarId [Pat b] (e b) (Maybe (Where b))
+              | TySigD  [VarId] Type
+              | DataD   ConId [Name] [ConAlt]
+              | InfixD  Assoc Int Name
+              deriving Show
+
+type Decl' e = Decl e Name
+
+data Assoc = InfixL
+           | InfixR
+           | Infix
+           deriving Show
+
+data ConAlt = ConAlt ConId [Type]
+            deriving Show
+
+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
+
+type RlpExpr' = RlpExpr Name
+
+type Where b = [Bind b]
+type Where' = [Bind Name]
+
+-- do we want guards?
+data Alt b = AltA (Pat b) (RlpExpr b)
+           deriving Show
+
+data Bind b = PatB (Pat b) (RlpExpr b)
+            | FunB VarId [Pat b] (RlpExpr b)
+            deriving Show
+
+data VarId = NameVar Text
+           | SymVar Text
+           deriving Show
+
+instance IsString VarId where
+    -- TODO: use symvar if it's an operator
+    fromString = NameVar . T.pack
+
+data ConId = NameCon Text
+           | SymCon Text
+           deriving Show
+
+data Pat b = VarP VarId
+           | LitP (Lit b)
+           | ConP ConId [Pat b]
+           deriving Show
+
+type Pat' = Pat Name
+
+data Lit b = IntL Int
+           | CharL Char
+           | ListL [RlpExpr b]
+           deriving Show
+
+type Lit' = Lit Name
+
+-- instance HasLHS Alt Alt Pat Pat where
+--     _lhs = lens
+--         (\ (AltA p _) -> p)
+--         (\ (AltA _ e) p' -> AltA p' e)
+
+-- instance HasRHS Alt Alt RlpExpr RlpExpr where
+--     _rhs = lens
+--         (\ (AltA _ e) -> e)
+--         (\ (AltA p _) e' -> AltA p e')
+
+makeBaseFunctor ''RlpExpr
+
+deriving instance (Show b, Show a) => Show (RlpExprF b a)
+
+type RlpExprF' = RlpExprF Name
+
+-- society if derivable Show1
+instance (Show b) => Show1 (RlpExprF b) where
+    liftShowsPrec sp _ p m = case m of
+        (LetEF bs e)            -> showsBinaryWith showsPrec sp "LetEF" p bs e
+        (VarEF n)               -> showsUnaryWith showsPrec "VarEF" p n
+        (ConEF n)               -> showsUnaryWith showsPrec "ConEF" p n
+        (LamEF bs e)            -> showsBinaryWith showsPrec sp "LamEF" p bs e
+        (CaseEF e as)           -> showsBinaryWith sp showsPrec "CaseEF" p e as
+        (IfEF a b c)            -> showsTernaryWith sp sp sp "IfEF" p a b c
+        (AppEF f x)             -> showsBinaryWith sp sp "AppEF" p f x
+        (LitEF l)               -> showsUnaryWith showsPrec "LitEF" p l
+
+showsTernaryWith :: (Int -> x -> ShowS)
+                 -> (Int -> y -> ShowS)
+                 -> (Int -> z -> ShowS)
+                 -> String -> Int
+                 -> x -> y -> z
+                 -> ShowS
+showsTernaryWith sa sb sc name p a b c = showParen (p > 10)
+    $ showString name
+    . showChar ' ' . sa 11 a 
+    . showChar ' ' . sb 11 b
+    . showChar ' ' . sc 11 c
+
+--------------------------------------------------------------------------------
+
+makeLenses ''RlpModule
+

tst/Arith.hs

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

tst/Core/HindleyMilnerSpec.hs

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

tst/GMSpec.hs

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