organisation and cleaning

organisation and tidying
fixup! ttg boilerplate
2024-01-30 14:04:43 -07:00 · 2024-01-30 13:04:23 -07:00 · 2024-01-30 13:03:07 -07:00 · 2024-01-30 13:01:01 -07:00 · 2024-01-28 19:41:36 -07:00 · 2024-01-28 19:33:05 -07:00
30 changed files with 909 additions and 533 deletions
--- a/CHANGELOG.md
+++ b/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
+
--- a/2
+++ b/2
@@ -1,5 +1,5 @@
 HAPPY = happy
-HAPPY_OPTS = -a -g -c
+HAPPY_OPTS = -a -g -c -i/tmp/t.info
 ALEX = alex
 ALEX_OPTS = -g

--- a/README.md
+++ b/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,61 @@ 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
+    - [ ] Trees That Grow
 - [ ] Tests
    - [x] Generic example programs
    - [ ] Parser

-### December Release Plan
- [ ] Tests
+### ~~December Release Plan~~
+- [x] Tests
    - [ ] Core lexer
    - [ ] Core parser
-    - [ ] Evaluation model
+    - [x] Evaluation model
 - [ ] Benchmarks
- [ ] Stable Core lexer
- [ ] Stable Core parser
- [ ] Stable evaluation model
-    - [ ] Garbage Collection
+- [x] Stable Core lexer
+- [x] Stable Core parser
+- [x] Stable evaluation model
+    - [x] Garbage Collection
 - [ ] Stable documentation for the evaluation model
+
+### 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
+
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -63,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
--- a/doc/src/commentary/gm.rst
+++ b/doc/src/commentary/gm.rst
@@ -112,5 +112,3 @@ The way around this is quite simple: simply offset the stack when w
   :end-before: -- << [ref/compileC]
   :caption: src/GM.hs

-
-
--- a/doc/src/commentary/layout-lexing.rst
+++ b/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>`_
+
--- a/doc/src/commentary/type-inference.rst
+++ b/doc/src/commentary/type-inference.rst
@@ -0,0 +1,5 @@
+Type Inference in rl'
+=====================
+
+rl' implements type inference via the Hindley-Milner type system.
+
--- a/doc/src/references/rlp-inference-rules.rst
+++ b/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}
+
--- a/examples/factorial.hs
+++ b/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;
--- a/examples/sumList.hs
+++ b/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;

--- a/105
+++ b/105
@@ -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.
+
--- a/rlp.cabal
+++ b/rlp.cabal
@@ -7,7 +7,7 @@ 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
@@ -37,6 +37,7 @@ library
                    , Rlp.Parse.Associate
                    , Rlp.Lex
                    , Rlp.Parse.Types
+                    , Compiler.Types

    other-modules:    Data.Heap
                    , Data.Pretty
@@ -48,7 +49,7 @@ library
    build-tool-depends: happy:happy, alex:alex

    -- other-extensions:
-    build-depends:    base ^>=4.18.0.0
+    build-depends:    base >=4.17 && <4.20
                    -- required for happy
                    , array >= 0.5.5 && < 0.6
                    , containers >= 0.6.7 && < 0.7
@@ -69,19 +70,24 @@ library
                    , data-fix >= 0.3.2 && < 0.4
                    , utf8-string >= 1.0.2 && < 1.1
                    , extra >= 1.7.0 && < 2
+                    , semigroupoids
+                    , comonad
+                    , lens

    hs-source-dirs:   src
    default-language: GHC2021

    default-extensions:
        OverloadedStrings
+        TypeFamilies
+        LambdaCase

 executable rlpc
    import:           warnings
    main-is:          Main.hs
    -- other-modules:
    -- other-extensions:
-    build-depends: base ^>=4.18.0.0
+    build-depends: base >=4.17.0.0 && <4.20.0.0
                 , rlp
                 , optparse-applicative >= 0.18.1 && < 0.19
                 , microlens >= 0.4.13 && < 0.5
--- a/src/Compiler/RLPC.hs
+++ b/src/Compiler/RLPC.hs
@@ -28,14 +28,12 @@ module Compiler.RLPC
    , evalRLPCIO
    , evalRLPC
    , rlpcLogFile
-    , rlpcDebugOpts
+    , rlpcDFlags  
    , rlpcEvaluator
    , rlpcInputFiles
    , DebugFlag(..)
-    , whenFlag
-    , flagDDumpEval
-    , flagDDumpOpts
-    , flagDDumpAST
+    , whenDFlag
+    , whenFFlag
    , def
    , liftErrorful
    )
@@ -43,6 +41,7 @@ module Compiler.RLPC
 ----------------------------------------------------------------------------------
 import Control.Arrow            ((>>>))
 import Control.Exception
+import Control.Monad
 import Control.Monad.Reader
 import Control.Monad.State      (MonadState(state))
 import Control.Monad.Errorful
@@ -51,19 +50,19 @@ 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
 ----------------------------------------------------------------------------------

 newtype RLPCT m a = RLPCT {
        runRLPCT :: ReaderT RLPCOptions (ErrorfulT (MsgEnvelope RlpcError) m) a
    }
-    deriving (Functor, Applicative, Monad)
+    deriving (Functor, Applicative, Monad, MonadReader RLPCOptions)

 type RLPC = RLPCT Identity

@@ -98,7 +97,8 @@ 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]
@@ -113,38 +113,33 @@ data Evaluator = EvaluatorGM | EvaluatorTI
 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

--- a/src/Compiler/RlpcError.hs
+++ b/src/Compiler/RlpcError.hs
@@ -5,12 +5,14 @@ module Compiler.RlpcError
    , MsgEnvelope(..)
    , Severity(..)
    , RlpcError(..)
-    , SrcSpan(..)
    , msgSpan
    , msgDiagnostic
    , msgSeverity
    , liftRlpcErrors
    , errorMsg
+    -- * Located Comonad
+    , Located(..)
+    , SrcSpan(..)
    )
    where
 ----------------------------------------------------------------------------------
@@ -20,6 +22,7 @@ import Data.Text                qualified as T
 import GHC.Exts                 (IsString(..))
 import Lens.Micro.Platform
 import Lens.Micro.Platform.Internal
+import Compiler.Types
 ----------------------------------------------------------------------------------

 data MsgEnvelope e = MsgEnvelope
@@ -45,12 +48,6 @@ data Severity = SevWarning
              | SevError
              deriving Show

-data SrcSpan = SrcSpan
-    !Int -- ^ Line
-    !Int -- ^ Column
-    !Int -- ^ Length
-    deriving Show
-
 makeLenses ''MsgEnvelope

 liftRlpcErrors :: (Functor m, IsRlpcError e)
--- a/src/Compiler/Types.hs
+++ b/src/Compiler/Types.hs
@@ -0,0 +1,66 @@
+module Compiler.Types
+    ( SrcSpan(..)
+    , Located(..)
+    , (<<~), (<~>)
+
+    -- * Re-exports
+    , Comonad
+    , Apply
+    , Bind
+    )
+    where
+--------------------------------------------------------------------------------
+import Control.Comonad
+import Data.Functor.Apply
+import Data.Functor.Bind
+--------------------------------------------------------------------------------
+
+-- | Token wrapped with a span (line, column, absolute, length)
+data Located a = Located SrcSpan a
+    deriving (Show, Functor)
+
+instance Apply Located where
+    liftF2 f (Located sa p) (Located sb q)
+            = Located (sa <> sb) (p `f` q)
+
+instance Bind Located where
+    Located sa a >>- k = Located (sa <> sb) b
+        where
+            Located sb b = k a
+
+instance Comonad Located where
+    extract (Located _ a) = a
+    extend ck w@(Located p _) = Located p (ck w)
+
+data SrcSpan = SrcSpan
+    !Int -- ^ Line
+    !Int -- ^ Column
+    !Int -- ^ Absolute
+    !Int -- ^ Length
+    deriving Show
+
+instance Semigroup SrcSpan where
+    SrcSpan la ca aa sa <> SrcSpan lb cb ab sb = SrcSpan l c a s where
+        l = min la lb
+        c = min ca cb
+        a = min aa ab
+        s = case aa `compare` ab of
+            EQ -> max sa sb
+            LT -> max sa (ab + lb - aa)
+            GT -> max sb (aa + la - ab)
+
+-- | A synonym for '(<<=)' with a tighter precedence and left-associativity for
+-- use with '(<~>)' in a sort of, comonadic pseudo-applicative style.
+
+(<<~) :: (Comonad w) => (w a -> b) -> w a -> w b
+(<<~) = (<<=)
+
+infixl 4 <<~
+
+-- | Similar to '(<*>)', but with a cokleisli arrow.
+
+(<~>) :: (Comonad w, Bind w) => w (w a -> b) -> w a -> w b
+mc <~> ma = mc >>- \f -> ma =>> f
+
+infixl 4 <~>
+
--- a/src/Core/Examples.hs
+++ b/src/Core/Examples.hs
@@ -4,12 +4,7 @@ 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
@@ -147,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};
@@ -160,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;
@@ -175,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;
    |]
@@ -192,10 +187,36 @@ idCase = [coreProg|
        id x = x;

        main = id (case Pack{1 0} of
-            { 1 -> (+#) 2 3
+            { <1> -> (+#) 2 3
            })
    |]

+-- NOTE: the GM primitive (==#) returns an untyped constructor with tag 1 for
+-- true, and 0 for false. See: GM.boxBool
+namedBoolCase :: Program'
+namedBoolCase = [coreProg|
+        {-# PackData True 1 0 #-}
+        {-# PackData False 0 0 #-}
+        main = case (==#) 1 1 of
+            { True -> 123
+            ; False -> 456
+            }
+    |]
+
+namedConsCase :: Program'
+namedConsCase = [coreProg|
+        {-# PackData Nil  0 0 #-}
+        {-# PackData Cons 1 2 #-}
+        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
--- a/src/Core/HindleyMilner.hs
+++ b/src/Core/HindleyMilner.hs
@@ -55,11 +55,14 @@ 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'."
+            [ 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"
            ]
@@ -157,7 +160,12 @@ gather = \g e -> runStateT (go g e) ([],0) <&> \ (t,(cs,_)) -> (t,cs) where
        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']
--- a/src/Core/Lex.x
+++ b/src/Core/Lex.x
@@ -22,7 +22,8 @@ import Data.Text            qualified as T
 import Data.String          (IsString(..))
 import Core.Syntax
 import Compiler.RLPC
-import Compiler.RlpcError
+-- TODO: unify Located definitions
+import Compiler.RlpcError   hiding (Located(..))
 import Lens.Micro
 import Lens.Micro.TH
 }
@@ -65,6 +66,8 @@ $white_no_nl = $white # $nl

@decimal = $digit+

+@alttag    = "<" $digit+ ">"
+
 rlp :-

 <0>
@@ -92,6 +95,8 @@ rlp :-
    "="                     { constTok TokenEquals }
    "->"                    { constTok TokenArrow }

+    @alttag                 { lexWith ( TokenAltTag . read @Int . T.unpack
+                                      . T.drop 1 . T.init ) }
    @varname                { lexWith TokenVarName }
    @conname                { lexWith TokenConName }
    @varsym                 { lexWith TokenVarSym }
@@ -135,6 +140,7 @@ data CoreToken = TokenLet
               | TokenConName Name
               | TokenVarSym Name
               | TokenConSym Name
+               | TokenAltTag Tag
               | TokenEquals
               | TokenLParen
               | TokenRParen
--- a/src/Core/Parse.y
+++ b/src/Core/Parse.y
@@ -3,7 +3,7 @@
 Module : Core.Parse
 Description : Parser for the Core language
 -}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, ViewPatterns #-}
 module Core.Parse
    ( parseCore
    , parseCoreExpr
@@ -23,7 +23,9 @@ 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
 }
@@ -49,6 +51,7 @@ import Data.HashMap.Strict  qualified as H
      varsym          { Located _ _ _ (TokenVarSym $$) }
      conname         { Located _ _ _ (TokenConName $$) }
      consym          { Located _ _ _ (TokenConSym $$) }
+      alttag          { Located _ _ _ (TokenAltTag $$) }
      word            { Located _ _ _ (TokenWord $$) }
      'λ'             { Located _ _ _ TokenLambda }
      '->'            { Located _ _ _ TokenArrow }
@@ -82,6 +85,15 @@ 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         : ';'                           { () }
@@ -94,7 +106,6 @@ ScDefs          :: { [ScDef Name] }
 ScDefs          : ScDef ';' ScDefs              { $1 : $3 }
                | ScDef ';'                     { [$1] }
                | ScDef                         { [$1] }
-                | {- epsilon -}                 { [] }

 ScDef           :: { ScDef Name }
 ScDef           : Var ParList '=' Expr          { ScDef $1 $2 $4 }
@@ -149,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                        { Lit $ IntL $1 }
                | Id                            { Var $1 }
                | PackCon                       { $1 }
-                | ExprPragma                    { $1 }
                | '(' Expr ')'                  { $2 }

-ExprPragma      :: { Expr Name }
-ExprPragma      : '{-#' Words '#-}'      {% exprPragma $2 }
-
-Words           :: { [String] }
-Words           : word Words                    { T.unpack $1 : $2 }
-                | word                          { [T.unpack $1] }
-
 PackCon         :: { Expr Name }
 PackCon         : pack '{' litint litint '}'    { Con $3 $4 }

@@ -229,5 +233,17 @@ 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
+
 }

--- a/src/Core/Syntax.hs
+++ b/src/Core/Syntax.hs
@@ -5,8 +5,14 @@ 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(..)
    , pattern TyInt
    , Lit(..)
@@ -24,9 +30,11 @@ module Core.Syntax
    , Module(..)
    , Program(..)
    , Program'
+    , Pragma(..)
    , unliftScDef
    , programScDefs
    , programTypeSigs
+    , programDataTags
    , Expr'
    , ScDef'
    , Alter'
@@ -40,11 +48,15 @@ import Data.Coerce
 import Data.Pretty
 import Data.List                    (intersperse)
 import Data.Function                ((&))
+import Data.Functor.Foldable
+import Data.Functor.Foldable.TH     (makeBaseFunctor)
 import Data.String
+import Data.HashMap.Strict          (HashMap)
 import Data.HashMap.Strict          qualified as H
 import Data.Hashable
 import Data.Text                    qualified as T
 import Data.Char
+import GHC.Generics
 -- Lift instances for the Core quasiquoters
 import Language.Haskell.TH.Syntax   (Lift)
 import Lens.Micro.TH                (makeLenses)
@@ -99,11 +111,14 @@ 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
+data AltCon = AltData Name
+            | AltTag Tag
            | AltLit Lit
            | Default
            deriving (Show, Read, Eq, Lift)
@@ -125,13 +140,20 @@ data Module b = Module (Maybe (Name, [Name])) (Program b)

 data Program b = Program
    { _programScDefs   :: [ScDef b]
-    , _programTypeSigs :: H.HashMap b Type
+    , _programTypeSigs :: HashMap b Type
+    -- map constructors to their tag and arity
+    , _programDataTags :: HashMap b (Tag, Int)
    }
-    deriving (Show, Lift)
+    deriving (Show, Lift, Generic)
+    deriving (Semigroup, Monoid)
+        via Generically (Program b)

 makeLenses ''Program
+makeBaseFunctor ''Expr
 pure []

+type ExprF' = ExprF Name
+
 type Program' = Program Name
 type Expr' = Expr Name
 type ScDef' = ScDef Name
@@ -148,12 +170,6 @@ instance IsString Type where
        | otherwise     = TyVar . fromString $ s
        where (c:_) = s

-instance (Hashable b) => Semigroup (Program b) where
-    (<>) = undefined
-
-instance (Hashable b) => Monoid (Program b) where
-    mempty = Program mempty mempty
-
 ----------------------------------------------------------------------------------

 class HasRHS s t a b | s -> a, t -> b, s b -> t, t a -> s where
@@ -187,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)
+
--- a/src/Core/Utils.hs
+++ b/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
    , extractProgram
    , freeVariables
-    , ExprF(..)
    )
    where
 ----------------------------------------------------------------------------------
@@ -23,13 +17,11 @@ 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
@@ -47,8 +39,6 @@ extractProgram (Module _ p) = p

 ----------------------------------------------------------------------------------

-makeBaseFunctor ''Expr
-
 freeVariables :: Expr' -> Set Name
 freeVariables = cata go
    where
@@ -57,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
--- a/src/Core2Core.hs
+++ b/src/Core2Core.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ImplicitParams #-}
 {-# LANGUAGE LambdaCase #-}
 module Core2Core
    ( core2core
@@ -15,11 +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
 ----------------------------------------------------------------------------------
@@ -28,22 +30,35 @@ core2core :: Program' -> Program'
 core2core p = undefined

 gmPrep :: Program' -> Program'
-gmPrep p = p' & programScDefs %~ (<>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
--- a/src/GM.hs
+++ b/src/GM.hs
@@ -661,7 +661,8 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
        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!"

@@ -724,12 +725,16 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
        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]
--- a/src/Rlp/Lex.x
+++ b/src/Rlp/Lex.x
@@ -10,6 +10,7 @@ module Rlp.Lex
    , lexStream
    , lexDebug
    , lexCont
+    , popLexState
    )
    where
 import Codec.Binary.UTF8.String (encodeChar)
@@ -57,7 +58,7 @@ $asciisym       = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
    |infixr|infixl|infix

@reservedop =
-    "=" | \\ | "->" | "|"
+    "=" | \\ | "->" | "|" | "::"

 rlp :-
    
@@ -73,6 +74,17 @@ $white_no_nl+       ;
 -- for the definition of `doBol`
 <0> \n                  { beginPush bol }

+<layout>
+{
+    
+}
+
+-- layout keywords
+<0>
+{
+    "let"               { constToken TokenLet `thenBeginPush` layout_let }
+}
+
 -- scan various identifiers and reserved words. order is important here!
 <0>
 {
@@ -110,6 +122,14 @@ $white_no_nl+       ;
    ()                  { doBol }
 }

+<layout_let>
+{
+    \n                  { beginPush bol }
+    "{"                 { explicitLBrace }
+    "in"                { constToken TokenIn `thenDo` (popLexState *> popLayout) }
+    ()                  { doLayout }
+}
+
 <layout_top>
 {
    \n                  ;
@@ -144,6 +164,12 @@ thenBegin act c inp l = do
    psLexState . _head .= c
    pure a

+thenBeginPush :: LexerAction a -> Int -> LexerAction a
+thenBeginPush act c inp l = do
+    a <- act inp l
+    pushLexState c
+    pure a
+
 andBegin :: LexerAction a -> Int -> LexerAction a
 andBegin act c inp l = do
    psLexState . _head .= c
@@ -164,10 +190,10 @@ alexGetByte inp = case inp ^. aiBytes of
                       -- report the previous char
                       & aiPrevChar .~ c
                       -- update the position
-                       & aiPos %~ \ (ln,col) ->
+                       & aiPos %~ \ (ln,col,a) ->
                                   if c == '\n'
-                                   then (ln+1,1)
-                                   else (ln,col+1)
+                                   then (ln+1, 1, a+1)
+                                   else (ln, col+1, a+1)
        pure (b, inp')
    
    _ -> Just (head bs, inp')
@@ -187,19 +213,19 @@ pushLexState :: Int -> P ()
 pushLexState n = psLexState %= (n:)

 readInt :: Text -> Int
-readInt = T.foldr f 0 where
-    f c n = digitToInt c + 10*n
+readInt = T.foldl f 0 where
+    f n c = 10*n + digitToInt c

 constToken :: RlpToken -> LexerAction (Located RlpToken)
 constToken t inp l = do
    pos <- use (psInput . aiPos)
-    pure (Located (pos,l) t)
+    pure (Located (spanFromPos pos l) t)

 tokenWith :: (Text -> RlpToken) -> LexerAction (Located RlpToken)
 tokenWith tf inp l = do
    pos <- getPos
    let t = tf (T.take l $ inp ^. aiSource)
-    pure (Located (pos,l) t)
+    pure (Located (spanFromPos pos l) t)

 getPos :: P Position
 getPos = use (psInput . aiPos)
@@ -207,7 +233,8 @@ getPos = use (psInput . aiPos)
 alexEOF :: P (Located RlpToken)
 alexEOF = do
    inp <- getInput
-    pure (Located undefined TokenEOF)
+    pos <- getPos
+    pure (Located (spanFromPos pos 0) TokenEOF)

 initParseState :: Text -> ParseState
 initParseState s = ParseState
@@ -224,7 +251,7 @@ initAlexInput s = AlexInput
    { _aiPrevChar   = '\0'
    , _aiSource     = s
    , _aiBytes      = []
-    , _aiPos        = (1,1)
+    , _aiPos        = (1,1,0)
    }

 runP' :: P a -> Text -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
@@ -238,7 +265,7 @@ lexToken = do
    st <- use id
    -- traceM $ "st: " <> show st
    case alexScan inp c of
-        AlexEOF -> pure $ Located (inp ^. aiPos, 0) TokenEOF
+        AlexEOF -> pure $ Located (spanFromPos (inp^.aiPos) 0) TokenEOF
        AlexSkip inp' l -> do
            psInput .= inp'
            lexToken
@@ -274,7 +301,7 @@ indentLevel = do
 insertToken :: RlpToken -> P (Located RlpToken)
 insertToken t = do
    pos <- use (psInput . aiPos)
-    pure (Located (pos, 0) t)
+    pure (Located (spanFromPos pos 0) t)

 popLayout :: P Layout
 popLayout = do
@@ -341,6 +368,7 @@ explicitRBrace inp l = do
 doLayout :: LexerAction (Located RlpToken)
 doLayout _ _ = do
    i <- indentLevel
+    traceM $ "doLayout: i: " <> show i
    pushLayout (Implicit i)
    popLexState
    insertLBrace
--- a/src/Rlp/Parse.y
+++ b/src/Rlp/Parse.y
@@ -1,7 +1,8 @@
 {
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, ViewPatterns #-}
 module Rlp.Parse
    ( parseRlpProg
+    , parseRlpExpr
    )
    where
 import Compiler.RlpcError
@@ -9,16 +10,21 @@ 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 Lens.Micro.Platform
 import Data.List.Extra
 import Data.Fix
 import Data.Functor.Const
+import Data.Functor.Apply
+import Data.Functor.Bind
+import Control.Comonad
+import Data.Functor
+import Data.Semigroup.Traversable
 import Data.Text                    qualified as T
+import Data.Void
 }

 %name parseRlpProg StandaloneProgram
+%name parseRlpExpr StandaloneExpr

 %monad { P }
 %lexer { lexCont } { Located _ TokenEOF }
@@ -26,14 +32,15 @@ import Data.Text                    qualified as T
 %tokentype { Located RlpToken }

 %token
-    varname         { Located _ (TokenVarName $$) }
-    conname         { Located _ (TokenConName $$) }
-    consym          { Located _ (TokenConSym $$) }
-    varsym          { Located _ (TokenVarSym $$) }
+    varname         { Located _ (TokenVarName _) }
+    conname         { Located _ (TokenConName _) }
+    consym          { Located _ (TokenConSym _) }
+    varsym          { Located _ (TokenVarSym _) }
    data            { Located _ TokenData }
-    litint          { Located _ (TokenLitInt $$) }
+    litint          { Located _ (TokenLitInt _) }
    '='             { Located _ TokenEquals }
    '|'             { Located _ TokenPipe }
+    '::'            { Located _ TokenHasType }
    ';'             { Located _ TokenSemicolon }
    '('             { Located _ TokenLParen }
    ')'             { Located _ TokenRParen }
@@ -46,15 +53,22 @@ import Data.Text                    qualified as T
    infixl          { Located _ TokenInfixL }
    infixr          { Located _ TokenInfixR }
    infix           { Located _ TokenInfix }
+    let             { Located _ TokenLet }
+    in              { Located _ TokenIn }

+%nonassoc '='
 %right '->'
+%right in

 %%

-StandaloneProgram   :: { RlpProgram' }
+StandaloneProgram   :: { RlpProgram RlpcPs }
 StandaloneProgram   : '{' Decls  '}'        {% mkProgram $2 }
                    | VL  DeclsV VR         {% mkProgram $2 }

+StandaloneExpr      :: { RlpExpr RlpcPs }
+                    : VL Expr VR            { extract $2 }
+
 VL  :: { () }
 VL  : vlbrace       { () }

@@ -62,12 +76,12 @@ VR  :: { () }
 VR  : vrbrace       { () }
    | error         { () }

-Decls               :: { [PartialDecl'] }
+Decls               :: { [Decl' RlpcPs] }
 Decls               : Decl ';' Decls        { $1 : $3 }
                    | Decl ';'              { [$1] }
                    | Decl                  { [$1] }

-DeclsV              :: { [PartialDecl'] }
+DeclsV              :: { [Decl' RlpcPs] }
 DeclsV              : Decl VS Decls         { $1 : $3 }
                    | Decl VS               { [$1] }
                    | Decl                  { [$1] }
@@ -76,97 +90,128 @@ VS                  :: { Located RlpToken }
 VS                  : ';'                   { $1 }
                    | vsemi                 { $1 }

-Decl        :: { PartialDecl' }
+Decl        :: { Decl' RlpcPs }
            : FunDecl                   { $1 }
+            | TySigDecl                 { $1 }
            | DataDecl                  { $1 }
            | InfixDecl                 { $1 }

-InfixDecl   :: { PartialDecl' }
-            : InfixWord litint InfixOp  {% mkInfixD $1 $2 $3 }
+TySigDecl   :: { Decl' RlpcPs }
+            : Var '::' Type             { (\e -> TySigD [extract e]) <<~ $1 <~> $3 }

-InfixWord   :: { Assoc }
-            : infixl                    { InfixL }
-            | infixr                    { InfixR }
-            | infix                     { Infix  }
+InfixDecl   :: { Decl' RlpcPs }
+            : InfixWord litint InfixOp  { $1 =>> \w ->
+                                          InfixD (extract $1) (extractInt $ extract $2)
+                                          (extract $3) }

-DataDecl    :: { PartialDecl' }
-            : data Con TyParams '=' DataCons    { DataD $2 $3 $5 }
+InfixWord   :: { Located Assoc }
+            : infixl                    { $1 \$> InfixL }
+            | infixr                    { $1 \$> InfixR }
+            | infix                     { $1 \$> Infix  }

-TyParams    :: { [Name] }
+DataDecl    :: { Decl' RlpcPs }
+            : data Con TyParams '=' DataCons    { $1 \$> DataD (extract $2) $3 $5 }
+
+TyParams    :: { [PsName] }
            : {- epsilon -}             { [] }
-            | TyParams varname          { $1 `snoc` $2 }
+            | TyParams varname          { $1 `snoc` (extractName . extract $ $2) }

-DataCons    :: { [ConAlt] }
+DataCons    :: { [ConAlt RlpcPs] }
            : DataCons '|' DataCon      { $1 `snoc` $3 }
            | DataCon                   { [$1] }

-DataCon     :: { ConAlt }
-            : Con Type1s                { ConAlt $1 $2 }
+DataCon     :: { ConAlt RlpcPs }
+            : Con Type1s                { ConAlt (extract $1) $2 }

-Type1s      :: { [Type] }
+Type1s      :: { [RlpType' RlpcPs] }
            : {- epsilon -}             { [] }
            | Type1s Type1              { $1 `snoc` $2 }

-Type1       :: { Type }
+Type1       :: { RlpType' RlpcPs }
            : '(' Type ')'              { $2 }
-            | conname                   { TyCon $1 }
-            | varname                   { TyVar $1 }
+            | conname                   { fmap ConT (mkPsName $1) }
+            | varname                   { fmap VarT (mkPsName $1) }

-Type        :: { Type }
-            : Type '->' Type            { $1 :-> $3 }
+Type        :: { RlpType' RlpcPs }
+            : Type '->' Type            { FunT <<~ $1 <~> $3 }
            | Type1                     { $1 }

-FunDecl     :: { PartialDecl' }
-FunDecl     : Var Params '=' Expr       { FunD $1 $2 (Const $4) Nothing }
+FunDecl     :: { Decl' RlpcPs }
+FunDecl     : Var Params '=' Expr       { $4 =>> \e ->
+                                          FunD (extract $1) $2 e Nothing }

-Params      :: { [Pat'] }
+Params      :: { [Pat' RlpcPs] }
 Params      : {- epsilon -}             { [] }
            | Params Pat1               { $1 `snoc` $2 }

-Pat1        :: { Pat' }
-            : Var                       { VarP $1 }
-            | Lit                       { LitP $1 }
+Pat1        :: { Pat' RlpcPs }
+            : Var                       { fmap VarP $1 }
+            | Lit                       { LitP <<= $1 }

-Expr        :: { PartialExpr' }
-            : Expr1 varsym Expr         { Fix $ B $2 (unFix $1) (unFix $3) }
+Expr        :: { RlpExpr' RlpcPs }
+            : Expr1 InfixOp Expr        { $2 =>> \o ->
+                                          OAppE (extract o) $1 $3 }
            | Expr1                     { $1 }
+            | LetExpr                   { $1 }

-Expr1       :: { PartialExpr' }
-            : '(' Expr ')'              { wrapFix . Par . unwrapFix $ $2 }
-            | Lit                       { Fix . E $ LitEF $1 }
-            | Var                       { Fix . E $ VarEF $1 }
+LetExpr     :: { RlpExpr' RlpcPs }
+            : let layout1(Binding) in Expr { $1 \$> LetE $2 $4 }

-- 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) }
+layout1(p)  : '{' layout_list1(';',p) '}'   { $2 }
+            | VL  layout_list1(VS,p) VR     { $2 }

-InfixOp     :: { Name }
-            : consym                    { $1 }
-            | varsym                    { $1 }
+layout_list1(sep,p) : p                          { [$1] }
+                    | layout_list1(sep,p) sep p  { $1 `snoc` $3 }

-Lit         :: { Lit' }
-Lit         : litint                    { IntL $1 }
+Binding     :: { Binding' RlpcPs }
+            : Pat1 '=' Expr              { PatB <<~ $1 <~> $3 }

-Var         :: { VarId }
-Var         : varname                   { NameVar $1 }
+Expr1       :: { RlpExpr' RlpcPs }
+            : '(' Expr ')'              { $1 .> $2 <. $3 }
+            | Lit                       { fmap LitE $1 }
+            | Var                       { fmap VarE $1 }

-Con         :: { ConId }
-            : conname                   { NameCon $1 }
+InfixOp     :: { Located PsName }
+            : consym                    { mkPsName $1 }
+            | varsym                    { mkPsName $1 }
+
+-- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
+Lit         :: { Lit' RlpcPs }
+            : litint                    { $1 <&> (IntL . (\ (TokenLitInt n) -> n)) }
+
+Var         :: { Located PsName }
+Var         : varname                   { mkPsName $1 }
+
+Con         :: { Located PsName }
+            : conname                   { mkPsName $1 }

 {

-mkProgram :: [PartialDecl'] -> P RlpProgram'
+mkPsName :: Located RlpToken -> Located PsName
+mkPsName = fmap extractName
+
+extractName :: RlpToken -> PsName
+extractName = \case
+    TokenVarName n -> n
+    TokenConName n -> n
+    TokenConSym  n -> n
+    TokenVarSym  n -> n
+    _              -> error "mkPsName: not an identifier"
+
+extractInt :: RlpToken -> Int
+extractInt (TokenLitInt n) = n
+extractInt _ = error "extractInt: ugh"
+
+mkProgram :: [Decl' RlpcPs] -> P (RlpProgram RlpcPs)
 mkProgram ds = do
    pt <- use psOpTable
    pure $ RlpProgram (associate pt <$> ds)

 parseError :: Located RlpToken -> P a
-parseError (Located ((l,c),s) t) = addFatal $
-    errorMsg (SrcSpan l c s) RlpParErrUnexpectedToken
+parseError (Located ss t) = addFatal $
+    errorMsg ss RlpParErrUnexpectedToken

-mkInfixD :: Assoc -> Int -> Name -> P PartialDecl'
+mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs)
 mkInfixD a p n = do
    let opl :: Lens' ParseState (Maybe OpInfo)
        opl = psOpTable . at n
@@ -176,6 +221,10 @@ mkInfixD a p n = do
            l = T.length n
        Nothing -> pure (Just (a,p))
        )
-    pure $ InfixD a p n
+    pos <- use (psInput . aiPos)
+    pure $ Located (spanFromPos pos 0) (InfixD a p n)
+
+intOfToken :: Located RlpToken -> Int
+intOfToken (Located _ (TokenLitInt n)) = n

 }
--- a/src/Rlp/Parse/Associate.hs
+++ b/src/Rlp/Parse/Associate.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms, ViewPatterns, ImplicitParams #-}
 module Rlp.Parse.Associate
+    {-# WARNING "temporarily unimplemented" #-}
    ( associate
    )
    where
@@ -13,88 +14,6 @@ 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))
-    ]
-
+associate x y = y
+{-# WARNING associate "temporarily undefined" #-}

--- a/src/Rlp/Parse/Types.hs
+++ b/src/Rlp/Parse/Types.hs
@@ -2,38 +2,26 @@
 {-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
 {-# LANGUAGE LambdaCase #-}
 module Rlp.Parse.Types
-    ( LexerAction
-    , MsgEnvelope(..)
-    , RlpcError(..)
-    , AlexInput(..)
-    , Position(..)
-    , RlpToken(..)
-    , P(..)
-    , ParseState(..)
-    , psLayoutStack
-    , psLexState
-    , psInput
-    , psOpTable
-    , Layout(..)
-    , Located(..)
-    , OpTable
-    , OpInfo
-    , RlpParseError(..)
-    , PartialDecl'
-    , Partial(..)
-    , pL, pR
-    , PartialE
-    , pattern WithInfo
-    , opInfoOrDef
-    , PartialExpr'
-    , aiPrevChar
-    , aiSource
-    , aiBytes
-    , aiPos
-    , addFatal
-    , addWound
-    , addFatalHere
-    , addWoundHere
+    (
+    -- * Trees That Grow
+      RlpcPs
+
+    -- * Parser monad and state
+    , P(..), ParseState(..), Layout(..), OpTable, OpInfo
+    -- ** Lenses
+    , psLayoutStack, psLexState, psInput, psOpTable
+
+    -- * Other parser types
+    , RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
+    , Located(..), PsName
+    -- ** Lenses
+    , aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
+
+    , (<<~), (<~>)
+
+    -- * Error handling
+    , MsgEnvelope(..), RlpcError(..), RlpParseError(..)
+    , addFatal, addWound, addFatalHere, addWoundHere
    )
    where
 --------------------------------------------------------------------------------
@@ -49,12 +37,46 @@ import Data.Functor.Foldable
 import Data.Functor.Const
 import Data.Functor.Classes
 import Data.HashMap.Strict          qualified as H
+import Data.Void
 import Data.Word                    (Word8)
 import Lens.Micro.TH
 import Lens.Micro
 import Rlp.Syntax
+import Compiler.Types
 --------------------------------------------------------------------------------

+-- | Phantom type identifying rlpc's parser phase
+
+data RlpcPs
+
+type instance XRec RlpcPs f = Located (f RlpcPs)
+type instance IdP RlpcPs = PsName
+
+type instance XFunD RlpcPs = ()
+type instance XDataD RlpcPs = ()
+type instance XInfixD RlpcPs = ()
+type instance XTySigD RlpcPs = ()
+type instance XXDeclD RlpcPs = ()
+
+type instance XLetE RlpcPs = ()
+type instance XVarE RlpcPs = ()
+type instance XLamE RlpcPs = ()
+type instance XCaseE RlpcPs = ()
+type instance XIfE RlpcPs = ()
+type instance XAppE RlpcPs = ()
+type instance XLitE RlpcPs = ()
+type instance XParE RlpcPs = ()
+type instance XOAppE RlpcPs = ()
+
+type PsName = Text
+
+--------------------------------------------------------------------------------
+
+spanFromPos :: Position -> Int -> SrcSpan
+spanFromPos (l,c,a) s = SrcSpan l c a s
+
+{-# INLINE spanFromPos #-}
+
 type LexerAction a = AlexInput -> Int -> P a

 data AlexInput = AlexInput
@@ -66,8 +88,9 @@ data AlexInput = AlexInput
    deriving Show

 type Position =
-    ( Int -- line
-    , Int -- column
+    ( Int -- ^ line
+    , Int -- ^ column
+    , Int -- ^ Absolutely
    )

 posLine :: Lens' Position Int
@@ -76,6 +99,9 @@ posLine = _1
 posColumn :: Lens' Position Int
 posColumn = _2

+posAbsolute :: Lens' Position Int
+posAbsolute = _3
+
 data RlpToken
    -- literals
    = TokenLitInt Int
@@ -106,7 +132,7 @@ data RlpToken
    | TokenLParen
    | TokenRParen
    -- 'virtual' control symbols, inserted by the lexer without any correlation
-    -- to a specific symbol
+    -- to a specific part of the input
    | TokenSemicolonV
    | TokenLBraceV
    | TokenRBraceV
@@ -154,9 +180,6 @@ 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)

@@ -171,47 +194,6 @@ data RlpParseError = RlpParErrOutOfBoundsPrecedence Int
 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
@@ -221,8 +203,9 @@ addWoundHere l e = P $ \st ->
    let e' = MsgEnvelope
            { _msgSpan = let pos = psInput . aiPos
                         in SrcSpan (st ^. pos . posLine)
-                                   (st ^. pos . posColumn)
-                                   l
+                                    (st ^. pos . posColumn)
+                                    (st ^. pos . posAbsolute)
+                                    l
            , _msgDiagnostic = e
            , _msgSeverity = SevError
            }
@@ -234,6 +217,7 @@ addFatalHere l e = P $ \st ->
            { _msgSpan = let pos = psInput . aiPos
                         in SrcSpan (st ^. pos . posLine)
                                    (st ^. pos . posColumn)
+                                    (st ^. pos . posAbsolute)
                                    l
            , _msgDiagnostic = e
            , _msgSeverity = SevError
--- a/src/Rlp/Syntax.hs
+++ b/src/Rlp/Syntax.hs
@@ -1,40 +1,36 @@
 -- recursion-schemes
-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
-- recursion-schemes
-{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable
+  , TemplateHaskell, TypeFamilies #-}
 {-# LANGUAGE OverloadedStrings, PatternSynonyms #-}
+{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}
+{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-}
 module Rlp.Syntax
-    ( RlpModule(..)
-    , RlpProgram(..)
-    , RlpProgram'
-    , rlpmodName
-    , rlpmodProgram
-    , RlpExpr(..)
-    , RlpExpr'
-    , RlpExprF(..)
-    , RlpExprF'
-    , Decl(..)
-    , Decl'
-    , Bind(..)
-    , Where
-    , Where'
-    , ConAlt(..)
-    , Type(..)
-    , pattern (:->)
+    (
+    -- * AST
+      RlpProgram(..)
+    , Decl(..), Decl', RlpExpr(..), RlpExpr'
+    , Pat(..), Pat'
    , Assoc(..)
-    , VarId(..)
-    , ConId(..)
-    , Pat(..)
-    , Pat'
-    , Lit(..)
-    , Lit'
-    , Name
+    , Lit(..), Lit'
+    , RlpType(..), RlpType'
+    , ConAlt(..)
+    , Binding(..), Binding'

-    -- TODO: ugh move this somewhere else later
-    , showsTernaryWith
-
-    -- * Convenience re-exports
-    , Text
+    -- * Trees That Grow boilerplate
+    -- ** Extension points
+    , IdP, XRec, UnXRec(..), MapXRec(..)
+    -- *** Decl
+    , XFunD, XTySigD, XInfixD, XDataD, XXDeclD
+    -- *** RlpExpr
+    , XLetE, XVarE, XLamE, XCaseE, XIfE, XAppE, XLitE
+    , XParE, XOAppE, XXRlpExprE
+    -- ** Pattern synonyms
+    -- *** Decl
+    , pattern FunD, pattern TySigD, pattern InfixD, pattern DataD
+    -- *** RlpExpr
+    , pattern LetE, pattern VarE, pattern LamE, pattern CaseE, pattern IfE
+    , pattern AppE, pattern LitE, pattern ParE, pattern OAppE
+    , pattern XRlpExprE
    )
    where
 ----------------------------------------------------------------------------------
@@ -43,93 +39,180 @@ import Data.Text                    qualified as T
 import Data.String                  (IsString(..))
 import Data.Functor.Foldable.TH     (makeBaseFunctor)
 import Data.Functor.Classes
+import Data.Kind                    (Type)
 import Lens.Micro
 import Lens.Micro.TH
-import Core.Syntax                  hiding (Lit)
+import Core.Syntax                  hiding (Lit, Type, Binding, Binding')
 import Core                         (HasRHS(..), HasLHS(..))
 ----------------------------------------------------------------------------------

-data RlpModule b = RlpModule
+data RlpModule p = RlpModule
    { _rlpmodName       :: Text
-    , _rlpmodProgram    :: RlpProgram b
+    , _rlpmodProgram    :: RlpProgram p
    }

-newtype RlpProgram b = RlpProgram [Decl RlpExpr b]
-    deriving Show
+-- | dear god.
+type PhaseShow p =
+    ( Show (XRec p Pat), Show (XRec p RlpExpr)
+    , Show (XRec p Lit), Show (IdP p)
+    , Show (XRec p RlpType)
+    , Show (XRec p Binding)
+    )

-type RlpProgram' = RlpProgram Name
+newtype RlpProgram p = RlpProgram [Decl' p]

-- | The @e@ parameter is used for partial results. When parsing an input, we
-- first parse all top-level declarations in order to extract infix[lr]
-- declarations. This process yields a @[Decl (Const Text) Name]@, where @Const
-- Text@ stores the remaining unparsed function bodies. Once infixities are
-- accounted for, we may complete the parsing task and get a proper @[Decl
-- RlpExpr Name]@.
+deriving instance (PhaseShow p, Show (XRec p Decl)) => Show (RlpProgram p)

-data Decl e b = FunD    VarId [Pat b] (e b) (Maybe (Where b))
-              | TySigD  [VarId] Type
-              | DataD   ConId [Name] [ConAlt]
-              | InfixD  Assoc Int Name
-              deriving Show
+data RlpType p = FunConT
+               | FunT (RlpType' p) (RlpType' p)
+               | AppT (RlpType' p) (RlpType' p)
+               | VarT (IdP p)
+               | ConT (IdP p)

-type Decl' e = Decl e Name
+type RlpType' p = XRec p RlpType
+
+deriving instance (PhaseShow p)
+                  => Show (RlpType p)
+
+data Decl p = FunD'   (XFunD p)    (IdP p) [Pat' p] (RlpExpr' p) (Maybe (Where p))
+            | TySigD' (XTySigD p)  [IdP p] (RlpType' p)
+            | DataD'  (XDataD p)   (IdP p) [IdP p] [ConAlt p]
+            | InfixD' (XInfixD p)  Assoc Int (IdP p)
+            | XDeclD' !(XXDeclD p)
+
+deriving instance
+    ( Show (XFunD p), Show (XTySigD p)
+    , Show (XDataD p), Show (XInfixD p)
+    , Show (XXDeclD p)
+    , PhaseShow p
+    ) 
+    => Show (Decl p)
+
+type family XFunD p
+type family XTySigD p
+type family XDataD p
+type family XInfixD p
+type family XXDeclD p
+
+pattern FunD   :: (XFunD p ~ ())
+               => (IdP p) -> [Pat' p] -> (RlpExpr' p) -> (Maybe (Where p))
+               -> Decl p
+pattern TySigD :: (XTySigD p ~ ()) => [IdP p] -> (RlpType' p) -> Decl p
+pattern DataD  :: (XDataD p ~ ()) => (IdP p) -> [IdP p] -> [ConAlt p] -> Decl p
+pattern InfixD :: (XInfixD p ~ ()) => Assoc -> Int -> (IdP p) -> Decl p
+pattern XDeclD :: (XXDeclD p ~ ()) => Decl p
+
+pattern FunD n as e wh = FunD' () n as e wh
+pattern TySigD ns t = TySigD' () ns t
+pattern DataD n as cs = DataD' () n as cs
+pattern InfixD a p n = InfixD' () a p n
+pattern XDeclD = XDeclD' ()
+
+type Decl' p = XRec p Decl

 data Assoc = InfixL
           | InfixR
           | Infix
-           deriving Show
+           deriving (Show)

-data ConAlt = ConAlt ConId [Type]
-            deriving Show
+data ConAlt p = ConAlt (IdP p) [RlpType' p]

-data RlpExpr b = LetE  [Bind b] (RlpExpr b)
-               | VarE  VarId
-               | ConE  ConId
-               | LamE  [Pat b] (RlpExpr b)
-               | CaseE (RlpExpr b) [(Alt b, Where b)]
-               | IfE   (RlpExpr b) (RlpExpr b) (RlpExpr b)
-               | AppE  (RlpExpr b) (RlpExpr b)
-               | LitE  (Lit b)
-               deriving Show
+deriving instance (Show (IdP p), Show (XRec p RlpType)) => Show (ConAlt p)

-type RlpExpr' = RlpExpr Name
+data RlpExpr p = LetE'  (XLetE p) [Binding' p] (RlpExpr' p)
+               | VarE'  (XVarE p) (IdP p)
+               | LamE'  (XLamE p) [Pat p] (RlpExpr' p)
+               | CaseE' (XCaseE p) (RlpExpr' p) [(Alt p, Where p)]
+               | IfE'   (XIfE p) (RlpExpr' p) (RlpExpr' p) (RlpExpr' p)
+               | AppE'  (XAppE p) (RlpExpr' p) (RlpExpr' p)
+               | LitE'  (XLitE p) (Lit p)
+               | ParE'  (XParE p) (RlpExpr' p)
+               | OAppE' (XOAppE p) (IdP p) (RlpExpr' p) (RlpExpr' p)
+               | XRlpExprE' !(XXRlpExprE p)

-type Where b = [Bind b]
-type Where' = [Bind Name]
+type family XLetE p
+type family XVarE p
+type family XLamE p
+type family XCaseE p
+type family XIfE p
+type family XAppE p
+type family XLitE p
+type family XParE p
+type family XOAppE p
+type family XXRlpExprE p
+
+pattern LetE :: (XLetE p ~ ()) => [Binding' p] -> RlpExpr' p -> RlpExpr p
+pattern VarE :: (XVarE p ~ ()) => IdP p -> RlpExpr p
+pattern LamE :: (XLamE p ~ ()) => [Pat p] -> RlpExpr' p -> RlpExpr p
+pattern CaseE :: (XCaseE p ~ ()) => RlpExpr' p -> [(Alt p, Where p)] -> RlpExpr p
+pattern IfE :: (XIfE p ~ ()) => RlpExpr' p -> RlpExpr' p -> RlpExpr' p -> RlpExpr p
+pattern AppE :: (XAppE p ~ ()) => RlpExpr' p -> RlpExpr' p -> RlpExpr p
+pattern LitE :: (XLitE p ~ ()) => Lit p -> RlpExpr p
+pattern ParE :: (XParE p ~ ()) => RlpExpr' p -> RlpExpr p
+pattern OAppE :: (XOAppE p ~ ()) => IdP p -> RlpExpr' p -> RlpExpr' p -> RlpExpr p
+pattern XRlpExprE :: (XXRlpExprE p ~ ()) => RlpExpr p
+
+pattern LetE bs e = LetE' () bs e
+pattern VarE n = VarE' () n
+pattern LamE as e = LamE' () as e
+pattern CaseE e as = CaseE' () e as
+pattern IfE c a b = IfE' () c a b
+pattern AppE f x = AppE' () f x
+pattern LitE l = LitE' () l
+pattern ParE e = ParE' () e
+pattern OAppE n a b = OAppE' () n a b
+pattern XRlpExprE = XRlpExprE' ()
+
+deriving instance
+    ( Show (XLetE p), Show (XVarE p), Show (XLamE p)
+    , Show (XCaseE p), Show (XIfE p), Show (XAppE p)
+    , Show (XLitE p), Show (XParE p), Show (XOAppE p)
+    , Show (XXRlpExprE p)
+    , PhaseShow p
+    ) => Show (RlpExpr p)
+
+type RlpExpr' p = XRec p RlpExpr
+
+class UnXRec p where
+    unXRec :: XRec p f -> f p
+
+class MapXRec p where
+    mapXRec :: (f p -> f' p') -> XRec p f -> XRec p' f'
+
+type family XRec p (f :: Type -> Type) = (r :: Type) | r -> p f
+
+type family IdP p
+
+type Where p = [Binding p]

 -- do we want guards?
-data Alt b = AltA (Pat b) (RlpExpr b)
-           deriving Show
+data Alt p = AltA (Pat' p) (RlpExpr' p)

-data Bind b = PatB (Pat b) (RlpExpr b)
-            | FunB VarId [Pat b] (RlpExpr b)
-            deriving Show
+deriving instance (PhaseShow p) => Show (Alt p)

-data VarId = NameVar Text
-           | SymVar Text
-           deriving Show
+data Binding p = PatB (Pat' p) (RlpExpr' p)
+               | FunB (IdP p) [Pat' p] (RlpExpr' p)

-instance IsString VarId where
-    -- TODO: use symvar if it's an operator
-    fromString = NameVar . T.pack
+type Binding' p = XRec p Binding

-data ConId = NameCon Text
-           | SymCon Text
-           deriving Show
+deriving instance (Show (XRec p Pat), Show (XRec p RlpExpr), Show (IdP p)
+                  ) => Show (Binding p)

-data Pat b = VarP VarId
-           | LitP (Lit b)
-           | ConP ConId [Pat b]
-           deriving Show
+data Pat p = VarP (IdP p)
+           | LitP (Lit' p)
+           | ConP (IdP p) [Pat' p]

-type Pat' = Pat Name
+deriving instance (PhaseShow p) => Show (Pat p)

-data Lit b = IntL Int
+type Pat' p = XRec p Pat
+
+data Lit p = IntL Int
           | CharL Char
-           | ListL [RlpExpr b]
-           deriving Show
+           | ListL [RlpExpr' p]

-type Lit' = Lit Name
+deriving instance (PhaseShow p) => Show (Lit p)
+
+type Lit' p = XRec p Lit

 -- instance HasLHS Alt Alt Pat Pat where
 --     _lhs = lens
@@ -143,33 +226,17 @@ type Lit' = Lit Name

 makeBaseFunctor ''RlpExpr

-deriving instance (Show b, Show a) => Show (RlpExprF b a)
-
-type RlpExprF' = RlpExprF Name
-
-- society if derivable Show1
-instance (Show b) => Show1 (RlpExprF b) where
-    liftShowsPrec sp _ p m = case m of
-        (LetEF bs e)            -> showsBinaryWith showsPrec sp "LetEF" p bs e
-        (VarEF n)               -> showsUnaryWith showsPrec "VarEF" p n
-        (ConEF n)               -> showsUnaryWith showsPrec "ConEF" p n
-        (LamEF bs e)            -> showsBinaryWith showsPrec sp "LamEF" p bs e
-        (CaseEF e as)           -> showsBinaryWith sp showsPrec "CaseEF" p e as
-        (IfEF a b c)            -> showsTernaryWith sp sp sp "IfEF" p a b c
-        (AppEF f x)             -> showsBinaryWith sp sp "AppEF" p f x
-        (LitEF l)               -> showsUnaryWith showsPrec "LitEF" p l
-
-showsTernaryWith :: (Int -> x -> ShowS)
-                 -> (Int -> y -> ShowS)
-                 -> (Int -> z -> ShowS)
-                 -> String -> Int
-                 -> x -> y -> z
-                 -> ShowS
-showsTernaryWith sa sb sc name p a b c = showParen (p > 10)
-    $ showString name
-    . showChar ' ' . sa 11 a 
-    . showChar ' ' . sb 11 b
-    . showChar ' ' . sc 11 c
+-- showsTernaryWith :: (Int -> x -> ShowS)
+--                  -> (Int -> y -> ShowS)
+--                  -> (Int -> z -> ShowS)
+--                  -> String -> Int
+--                  -> x -> y -> z
+--                  -> ShowS
+-- showsTernaryWith sa sb sc name p a b c = showParen (p > 10)
+--     $ showString name
+--     . showChar ' ' . sa 11 a 
+--     . showChar ' ' . sb 11 b
+--     . showChar ' ' . sc 11 c

 --------------------------------------------------------------------------------

--- a/tst/Core/HindleyMilnerSpec.hs
+++ b/tst/Core/HindleyMilnerSpec.hs
@@ -38,6 +38,18 @@ spec = do
        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
--- a/tst/GMSpec.hs
+++ b/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)
+
+
Author	SHA1	Message	Date
crumbtoo	ba099b7028	organisation and cleaning organisation and tidying	2024-01-30 14:04:43 -07:00
crumbtoo	e962bacd2e	fixup! ttg boilerplate	2024-01-30 13:04:23 -07:00
crumbtoo	f0c652b861	fixup! ttg boilerplate	2024-01-30 13:03:07 -07:00
crumbtoo	6a41e123ea	ttg boilerplate	2024-01-30 13:01:01 -07:00
crumbtoo	fbea3d6f3d	let layout	2024-01-28 19:41:36 -07:00
crumbtoo	ab979cb934	i should've made a lisp man this sucks	2024-01-28 19:33:05 -07:00
crumbtoo	7d42f9b641	at long last more no more undefineds	2024-01-28 18:30:12 -07:00
crumbtoo	fdaa2a1afd	abandon ship	2024-01-28 17:02:32 -07:00
crumbtoo	83dda869f8	show	2024-01-28 16:24:08 -07:00
crumbtoo	c74c192645	idk	2024-01-26 19:19:41 -07:00
crumbtoo	e00e4d3418	it's also a comonad. lol.	2024-01-26 17:53:05 -07:00
crumbtoo	8d0f324c63	oh my god guys!!! `Located` is a lax semimonoidal endofunctor on the category Hask!!! ![abstractionjak](https://media.discordapp.net/attachments/1101767463579951154/1200248978642567168/3877820-20SoyBooru.png?ex=65c57df8&is=65b308f8&hm=67da3acb61861cab6156df014b397d78fb8815fa163f2e992474d545beb668ba&=&format=webp&quality=lossless&width=880&height=868)	2024-01-26 17:25:59 -07:00
crumbtoo	6a6076f26e	some	2024-01-26 15:12:10 -07:00
crumbtoo	559fd49f2b	minor changes putting this on hold; implementing TTG first	2024-01-25 15:52:56 -07:00
crumbtoo	bb3f73836c	nearing release :3	2024-01-25 13:18:04 -07:00
crumbtoo	eeeac9cc85	named constr tests	2024-01-25 13:02:12 -07:00
crumbtoo	4f39dd36f1	resolve named data in case exprs	2024-01-25 12:39:57 -07:00
crumbtoo	4c99e44c04	temporary pragma system	2024-01-25 11:15:09 -07:00
crumbtoo	170e4e36ae	new tag syntax; preparing for Core patterns new tag syntax; preparing for data names	2024-01-24 11:34:09 -07:00
crumbtoo	d52a366c1b	small fixups	2024-01-24 11:03:51 -07:00
crumbtoo	0025d33069	stable enough for a demo hey?	2024-01-24 10:14:44 -07:00
crumbtoo	7c474cc064	minor docs	2024-01-24 09:49:27 -07:00
crumbtoo	fbef645746	checklist	2024-01-24 09:39:06 -07:00
crumbtoo	c8199a9dd1	minor docs	2024-01-24 09:31:57 -07:00