rlp2core

2024-01-18 17:21:04 -07:00
33 changed files with 470 additions and 789 deletions
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,17 +0,0 @@
-# unreleased
-
-* New tag syntax:
-  ```hs
-  case x of
-    { 1 -> something
-    ; 2 -> another
-    }
-  ```
-  is now written as
-  ```hs
-  case x of
-    { <1> -> something
-    ; <2> -> another
-    }
-  ```
-
--- a/10
+++ b/10
@@ -8,8 +8,8 @@ CABAL_BUILD = dist-newstyle/build/x86_64-osx/ghc-9.6.2/rlp-0.1.0.0/build

 all: parsers lexers

-parsers: $(CABAL_BUILD)/Rlp/Parse.hs $(CABAL_BUILD)/Core/Parse.hs
-lexers: $(CABAL_BUILD)/Rlp/Lex.hs $(CABAL_BUILD)/Core/Lex.hs
+parsers: $(CABAL_BUILD)/Rlp/Parse.hs
+lexers: $(CABAL_BUILD)/Rlp/Lex.hs

 $(CABAL_BUILD)/Rlp/Parse.hs: $(SRC)/Rlp/Parse.y
 	$(HAPPY) $(HAPPY_OPTS) $< -o $@
@@ -17,9 +17,3 @@ $(CABAL_BUILD)/Rlp/Parse.hs: $(SRC)/Rlp/Parse.y
 $(CABAL_BUILD)/Rlp/Lex.hs: $(SRC)/Rlp/Lex.x
 	$(ALEX) $(ALEX_OPTS) $< -o $@

-$(CABAL_BUILD)/Core/Parse.hs: $(SRC)/Core/Parse.y
-	$(HAPPY) $(HAPPY_OPTS) $< -o $@
-
-$(CABAL_BUILD)/Core/Lex.hs: $(SRC)/Core/Lex.x
-	$(ALEX) $(ALEX_OPTS) $< -o $@
-
--- a/README.md
+++ b/README.md
@@ -30,12 +30,12 @@ $ rlpc -ddump-opts t.hs

 ### Potential Features
 Listed in order of importance.
- [x] ADTs
- [x] First-class functions
+- [ ] ADTs
+- [ ] First-class functions
 - [ ] Higher-kinded types
 - [ ] Typeclasses
- [x] Parametric polymorphism
- [x] Hindley-Milner type inference
+- [ ] Parametric polymorphism
+- [ ] Hindley-Milner type inference
 - [ ] Newtype coercion
 - [ ] Parallelism

@@ -66,59 +66,32 @@ Listed in order of importance.
        - [ ] TCO
        - [ ] DCE
 - [ ] Frontend
-    - [x] High-level language
-        - [x] AST
-        - [x] Lexer
-        - [x] Parser
+    - [ ] High-level language
+        - [ ] AST
+        - [ ] Lexer
+        - [ ] Parser
    - [ ] Translation to the core language
        - [ ] Constraint solver
        - [ ] `do`-notation
    - [x] CLI
 - [ ] Documentation
-    - [x] State transition rules
+    - [ ] State transition rules
    - [ ] How does the evaluation model work?
-    - [ ] The Hindley-Milner type system
    - [ ] CLI usage
    - [ ] Tail call optimisation
-    - [ ] Parsing rlp
+    - [x] Parsing rlp
 - [ ] Tests
    - [x] Generic example programs
    - [ ] Parser

-### ~~December Release Plan~~
- [x] Tests
+### December Release Plan
+- [ ] Tests
    - [ ] Core lexer
    - [ ] Core parser
-    - [x] Evaluation model
+    - [ ] Evaluation model
 - [ ] Benchmarks
- [x] Stable Core lexer
- [x] Stable Core parser
- [x] Stable evaluation model
-    - [x] Garbage Collection
+- [ ] Stable Core lexer
+- [ ] Stable Core parser
+- [ ] Stable evaluation model
+    - [ ] 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
-
-### 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/doc/src/commentary/gm.rst
+++ b/doc/src/commentary/gm.rst
@@ -112,3 +112,5 @@ 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,21 +2,16 @@ Lexing, Parsing, and Layouts
 ============================

 The C-style languages of my previous experiences have all had quite trivial
-lexical analysis stages: you ignore all whitespace and point out the symbols you
-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, 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.

-In contrast, both lexing and parsing a Haskell-like language poses a number of
+On paper, both lexing and parsing a Haskell-like language seem to pose a few
 greater challenges. Listed by ascending intimidation factor, some of the
 potential roadblocks on my mind before making an attempt were:

-* Context-sensitive keywords; Haskell allows for some words to be used as
-  identifiers in appropriate contexts, such as :code:`family`, :code:`role`,
-  :code:`as`. Reading a note_ found in `GHC's lexer`_, it appears that keywords
-  are only considered in bodies for which their use is relevant, e.g.
-  :code:`family` and :code:`role` in type declarations, :code:`as` after
-  :code:`case`; :code:`if`, :code:`then`, and :code:`else` in expressions, etc.
-
 * Operators; Haskell has not only user-defined infix operators, but user-defined
  precedence levels and associativities. I recall using an algorithm that looked
  up infix, prefix, postfix, and even mixfix operators up in a global table to
@@ -24,9 +19,17 @@ potential roadblocks on my mind before making an attempt were:
  stored in the table). I never modified the table at runtime, however this
  could be a very nice solution for Haskell.

+* Context-sensitive keywords; Haskell allows for some words to be used as identifiers in
+  appropriate contexts, such as :code:`family`, :code:`role`, :code:`as`.
+  Reading a note_ found in `GHC's lexer`_,
+  it appears that keywords are only considered in bodies for which their use is
+  relevant, e.g. :code:`family` and :code:`role` in type declarations,
+  :code:`as` after :code:`case`; :code:`if`, :code:`then`, and :code:`else` in
+  expressions, etc.
+
 * Whitespace sensitivity; While I was comfortable with the idea of a system
-  similar to Python's INDENT/DEDENT tokens, Haskell's layout system is based on
-  alignment and is very generous with line-folding.
+  similar to Python's INDENT/DEDENT tokens, Haskell seemed to use whitespace to
+  section code in a way that *felt* different.

 .. _note: https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/coding-style#2-using-notes
 .. _GHC's lexer: https://gitlab.haskell.org/ghc/ghc/-/blob/master/compiler/GHC/Parser/Lexer.x#L1133
@@ -42,9 +45,9 @@ We will compare and contrast with Python's lexical analysis. Much to my dismay,
 Python uses newlines and indentation to separate statements and resolve scope
 instead of the traditional semicolons and braces found in C-style languages (we
 may generally refer to these C-style languages as *explicitly-sectioned*).
-Internally during tokenisation, when the Python lexer encounters a new line, the
-indentation of the new line is compared with that of the previous and the
-following rules are applied:
+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:

 1. If the new line has greater indentation than the previous, insert an INDENT
   token and push the new line's indentation level onto the indentation stack
@@ -57,37 +60,44 @@ following rules are applied:
 3. If the indentation is equal, insert a NEWLINE token to terminate the previous
   line, and leave it at that!

-On the parser's end, the INDENT, DEDENT, and NEWLINE tokens are identical to
-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.
+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.

 But What About Haskell?
 ***********************

-Parsing Haskell -- and thus rl' -- is only slightly more complex than Python,
-but the design is certainly more sensitive. 
+We saw that Python, the most notable example of an implicitly sectioned
+language, is pretty simple to lex. Why then am I so afraid of Haskell's layouts?
+To be frank, I'm far less scared after asking myself this -- however there are
+certainly some new complexities that Python needn't concern. Haskell has
+implicit line *continuation*: forms written over multiple lines; indentation
+styles often seen in Haskell are somewhat esoteric compared to Python's
+"s/[{};]//".

 .. code-block:: haskell

-   -- line folds
+   -- line continuation
   something = this is a
       single expression

   -- an extremely common style found in haskell
-   data Some = Data
-       { is    :: Presented
-       , in    :: This
-       , silly :: Style
+   data Python = Users
+       { are        :: Crying
+       , right      :: About
+       , now        :: Sorry
       }

-   -- another style oddity
+   -- another formatting oddity
   -- note that this is not a single
   -- continued line! `look at`,
-   -- `this odd`, and `alignment` are all
-   -- discrete items!
+   -- `this`, and `alignment` are all
+   -- separate expressions!
   anotherThing = do look at
-                     this odd
+                     this
                     alignment

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

    other-modules:    Data.Heap
                    , Data.Pretty
                    , Core.Parse
                    , Core.Lex
                    , Core2Core
+                    , Rlp2Core
                    , Control.Monad.Utils

    build-tool-depends: happy:happy, alex:alex
@@ -73,9 +75,6 @@ library
    hs-source-dirs:   src
    default-language: GHC2021

-    default-extensions:
-        OverloadedStrings
-
 executable rlpc
    import:           warnings
    main-is:          Main.hs
--- a/src/Compiler/JustRun.hs
+++ b/src/Compiler/JustRun.hs
@@ -26,23 +26,21 @@ import Data.Function                    ((&))
 import GM
 ----------------------------------------------------------------------------------

-justLexSrc :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
+justLexSrc :: String -> Either RlpcError [CoreToken]
 justLexSrc s = lexCoreR (T.pack s)
             & fmap (map $ \ (Located _ _ _ t) -> t)
             & rlpcToEither

-justParseSrc :: String -> Either [MsgEnvelope RlpcError] Program'
+justParseSrc :: String -> Either RlpcError Program'
 justParseSrc s = parse (T.pack s)
               & rlpcToEither
    where parse = lexCoreR >=> parseCoreProgR

-justTypeCheckSrc :: String -> Either [MsgEnvelope RlpcError] Program'
+justTypeCheckSrc :: String -> Either 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
+rlpcToEither :: RLPC e a -> Either e a
+rlpcToEither = evalRLPC def >>> fmap fst

--- a/src/Compiler/RLPC.hs
+++ b/src/Compiler/RLPC.hs
@@ -16,9 +16,9 @@ module Compiler.RLPC
    , RLPCT(..)
    , RLPCIO
    , RLPCOptions(RLPCOptions)
-    , IsRlpcError(..)
    , RlpcError(..)
-    , MsgEnvelope(..)
+    , IsRlpcError(..)
+    , rlpc
    , addFatal
    , addWound
    , MonadErrorful
@@ -27,6 +27,9 @@ module Compiler.RLPC
    , evalRLPCT
    , evalRLPCIO
    , evalRLPC
+    , addRlpcWound
+    , addRlpcFatal
+    , liftRlpcErrs
    , rlpcLogFile
    , rlpcDebugOpts
    , rlpcEvaluator
@@ -37,7 +40,6 @@ module Compiler.RLPC
    , flagDDumpOpts
    , flagDDumpAST
    , def
-    , liftErrorful
    )
    where
 ----------------------------------------------------------------------------------
@@ -49,7 +51,6 @@ import Control.Monad.Errorful
 import Compiler.RlpcError
 import Data.Functor.Identity
 import Data.Default.Class
-import Data.Foldable
 import GHC.Generics             (Generic)
 import Data.Hashable            (Hashable)
 import Data.HashSet             (HashSet)
@@ -57,44 +58,48 @@ import Data.HashSet             qualified as S
 import Data.Coerce
 import Lens.Micro
 import Lens.Micro.TH
-import System.Exit
 ----------------------------------------------------------------------------------

-newtype RLPCT m a = RLPCT {
-        runRLPCT :: ReaderT RLPCOptions (ErrorfulT (MsgEnvelope RlpcError) m) a
+-- TODO: fancy errors
+newtype RLPCT e m a = RLPCT {
+        runRLPCT :: ReaderT RLPCOptions (ErrorfulT e m) a
    }
-    deriving (Functor, Applicative, Monad)
+    -- TODO: incorrect ussage of MonadReader. RLPC should have its own
+    -- environment access functions
+    deriving (Functor, Applicative, Monad, MonadReader RLPCOptions)

-type RLPC = RLPCT Identity
+deriving instance (MonadIO m) => MonadIO (RLPCT e m)

-type RLPCIO = RLPCT IO
+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

 evalRLPC :: RLPCOptions
-         -> RLPC a
-         -> (Maybe a, [MsgEnvelope RlpcError])
-evalRLPC opt r = runRLPCT r
-               & flip runReaderT opt
-               & runErrorful
+         -> RLPC e a
+         -> Either e (a, [e])
+evalRLPC o m = coerce $ evalRLPCT o m

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

 data RLPCOptions = RLPCOptions
    { _rlpcLogFile     :: Maybe FilePath
@@ -108,6 +113,32 @@ 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
+
+instance (Monad m) => MonadErrorful e (RLPCT e m) where
+    addWound = RLPCT . lift . addWound
+    addFatal = RLPCT . lift . addFatal
+
+liftRlpcErrs :: (IsRlpcError e, Monad m)
+             => RLPCT e m a -> RLPCT RlpcError m a
+liftRlpcErrs m = RLPCT . ReaderT $ \r ->
+    mapErrors liftRlpcErr $ runRLPCT >>> (`runReaderT` r) $ m
+
+addRlpcWound :: (IsRlpcError e, Monad m) => e -> RLPCT RlpcError m ()
+addRlpcWound = addWound . liftRlpcErr
+
+addRlpcFatal :: (IsRlpcError e, Monad m) => e -> RLPCT RlpcError m ()
+addRlpcFatal = addWound . liftRlpcErr
+
+rlpc :: (Monad m) => ErrorfulT e m a -> RLPCT e m a
+rlpc = RLPCT . ReaderT . const
+
 ----------------------------------------------------------------------------------

 instance Default RLPCOptions where
--- a/src/Compiler/RlpcError.hs
+++ b/src/Compiler/RlpcError.hs
@@ -1,70 +1,15 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
 module Compiler.RlpcError
-    ( IsRlpcError(..)
-    , MsgEnvelope(..)
-    , Severity(..)
-    , RlpcError(..)
-    , SrcSpan(..)
-    , msgSpan
-    , msgDiagnostic
-    , msgSeverity
-    , liftRlpcErrors
-    , errorMsg
+    ( RlpcError(..)
+    , IsRlpcError(..)
    )
    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]
+data RlpcError = RlpcErr String -- temp
    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
-    }
+class IsRlpcError a where
+    liftRlpcErr :: a -> RlpcError

--- a/src/Control/Monad/Errorful.hs
+++ b/src/Control/Monad/Errorful.hs
@@ -1,79 +1,73 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE TupleSections, PatternSynonyms #-}
-{-# LANGUAGE UndecidableInstances #-}
 module Control.Monad.Errorful
    ( ErrorfulT
    , runErrorfulT
    , Errorful
    , runErrorful
-    , mapErrorful
+    , mapErrors
    , 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 (Maybe a, [e]) }
+newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Either e (a, [e])) }

 type Errorful e = ErrorfulT e Identity

-pattern Errorful :: (Maybe a, [e]) -> Errorful e a
+pattern Errorful :: (Either e (a, [e])) -> Errorful e a
 pattern Errorful a = ErrorfulT (Identity a)

-runErrorful :: Errorful e a -> (Maybe a, [e])
+runErrorful :: Errorful e a -> Either e (a, [e])
 runErrorful m = coerce (runErrorfulT m)

 class (Applicative m) => MonadErrorful e m | m -> e where
-    addWound :: e -> m ()
-    addFatal :: e -> m a
+    addWound   :: e -> m ()
+    addFatal   :: e -> m a
+
+    -- not sure if i want to add this yet...
+    -- catchWound :: m a -> (e -> m a) -> m a

 instance (Applicative m) => MonadErrorful e (ErrorfulT e m) where
-    addWound e = ErrorfulT $ pure (Just (), [e])
-    addFatal e = ErrorfulT $ pure (Nothing, [e])
+    addWound e = ErrorfulT $ pure . Right $ ((), [e])
+    addFatal e = ErrorfulT $ pure . Left  $ e

 instance MonadTrans (ErrorfulT e) where
-    lift m = ErrorfulT ((\x -> (Just x,[])) <$> m)
+    lift m = ErrorfulT (Right . (,[]) <$> m)

 instance (MonadIO m) => MonadIO (ErrorfulT e m) where
    liftIO = lift . liftIO

 instance (Functor m) => Functor (ErrorfulT e m) where
-    fmap f (ErrorfulT m) = ErrorfulT (m & mapped . _1 . _Just %~ f)
+    fmap f (ErrorfulT m) = ErrorfulT $ fmap (_1 %~ f) <$> m

 instance (Applicative m) => Applicative (ErrorfulT e m) where
-    pure a = ErrorfulT . pure $ (Just a, [])
+    pure a = ErrorfulT (pure . Right $ (a, []))

-    ErrorfulT m <*> ErrorfulT n = ErrorfulT $ m `apply` n where
-        apply :: m (Maybe (a -> b), [e]) -> m (Maybe a, [e]) -> m (Maybe b, [e])
-        apply = liftA2 $ \ (mf,e1) (ma,e2) -> (mf <*> ma, e1 <> e2)
+    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)) 

 instance (Monad m) => Monad (ErrorfulT e m) where
    ErrorfulT m >>= k = ErrorfulT $ do
-        (a,es) <- m
-        case a of
-            Just x      -> runErrorfulT (k x)
-            Nothing     -> pure (Nothing, es)
+        m' <- m
+        case m' of
+            Right (a,es) -> runErrorfulT (k a)
+            Left e       -> pure (Left e)

-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
+mapErrors :: (Monad m) => (e -> e') -> ErrorfulT e m a -> ErrorfulT e' m a
+mapErrors f m = ErrorfulT $ do
+    x <- runErrorfulT m
+    case x of
+        Left  e      -> pure . Left  $ f e
+        Right (a,es) -> pure . Right $ (a, f <$> es)

--- a/src/Core/Examples.hs
+++ b/src/Core/Examples.hs
@@ -4,19 +4,17 @@ Description : Core examples (may eventually be unit tests)
 -}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE OverloadedStrings #-}
-module Core.Examples where
+module Core.Examples
+    ( fac3
+    , sumList
+    , constDivZero
+    , idCase
+    ) where
 ----------------------------------------------------------------------------------
 import Core.Syntax
 import Core.TH
 ----------------------------------------------------------------------------------

-- fac3 = undefined
-- sumList = undefined
-- constDivZero = undefined
-- idCase = undefined
-
---
-
 letrecExample :: Program'
 letrecExample = [coreProg|
    pair x y f = f x y;
@@ -142,8 +140,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 +153,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 +168,8 @@ sumList = [coreProg|
        cons x y = Pack{1 2} x y;
        list = cons 1 (cons 2 (cons 3 nil));
        sum l = case l of
-            { <0>      -> 0
-            ; <1> x xs -> (+#) x (sum xs)
+            { 0      -> 0
+            ; 1 x xs -> (+#) x (sum xs)
            };
        main = sum list;
    |]
@@ -187,36 +185,10 @@ idCase = [coreProg|
        id x = x;

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

-- NOTE: the GM primitive (==#) returns an untyped constructor with tag 1 for
-- true, and 0 for false. See: GM.boxBool
-namedBoolCase :: Program'
-namedBoolCase = [coreProg|
-        {-# PackData True 1 0 #-}
-        {-# PackData False 0 0 #-}
-        main = case (==#) 1 1 of
-            { True -> 123
-            ; False -> 456
-            }
-    |]
-
-namedConsCase :: Program'
-namedConsCase = [coreProg|
-        {-# PackData Nil  0 0 #-}
-        {-# PackData Cons 1 2 #-}
-        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
@@ -244,4 +216,3 @@ namedConsCase = [coreProg|
 --         , ScDef "Cons" [] $ Con 2 2
 --         ]

--}
--- a/src/Core/HindleyMilner.hs
+++ b/src/Core/HindleyMilner.hs
@@ -3,7 +3,6 @@ Module      : Core.HindleyMilner
 Description : Hindley-Milner type system
 -}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
 module Core.HindleyMilner
    ( Context'
    , infer
@@ -17,17 +16,15 @@ module Core.HindleyMilner
 ----------------------------------------------------------------------------------
 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            (foldM, void)
 import Control.Monad.Errorful   (Errorful, addFatal)
 import Control.Monad.State
 import Control.Monad.Utils      (mapAccumLM)
-import Text.Printf
 import Core.Syntax
 ----------------------------------------------------------------------------------

@@ -51,23 +48,9 @@ data TypeError
    | TyErrMissingTypeSig Name
    deriving (Show, Eq)

+-- TODO:
 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
+    liftRlpcErr = RlpcErr . show

 -- | Synonym for @Errorful [TypeError]@. This means an @HMError@ action may
 -- throw any number of fatal or nonfatal errors. Run with @runErrorful@.
@@ -105,10 +88,10 @@ checkCoreProg p = scDefs
             where scname = sc ^. _lhs._1

 -- | @checkCoreProgR p@ returns @p@ if @p@ successfully typechecks.
-checkCoreProgR :: Program' -> RLPC Program'
-checkCoreProgR p = undefined
-
-{-# WARNING checkCoreProgR "unimpl" #-}
+checkCoreProgR :: Program' -> RLPC RlpcError Program'
+checkCoreProgR p = do
+    liftRlpcErrs . rlpc . checkCoreProg $ p
+    pure p

 -- | Infer the type of an expression under some context.
 --
@@ -157,32 +140,7 @@ gather = \g e -> runStateT (go g e) ([],0) <&> \ (t,(cs,_)) -> (t,cs) where
        Let NonRec bs e -> do
            g' <- buildLetContext g bs
            go g' e
-        Let Rec bs e -> do
-            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
+        -- TODO letrec, lambda, case

    buildLetContext :: Context' -> [Binding']
                    -> StateT ([Constraint], Int) HMError Context'
@@ -260,20 +218,3 @@ subst x t (TyVar y) | x == y  = t
 subst x t (a :-> b)           = subst x t a :-> subst x t b
 subst _ _ e                   = e

--------------------------------------------------------------------------------
-
-demoContext :: Context'
-demoContext =
-    [ ("fix", (TyVar "a" :-> TyVar "a") :-> TyVar "a")
-    , ("add", TyInt :-> TyInt :-> TyInt)
-    , ("==", TyInt :-> TyInt :-> TyCon "Bool")
-    , ("True", TyCon "Bool")
-    , ("False", TyCon "Bool")
-    ]
-
-pprintType :: Type -> String
-pprintType (s :-> t) = "(" <> pprintType s <> " -> " <> pprintType t <> ")"
-pprintType TyFun = "(->)"
-pprintType (TyVar x) = x ^. unpacked
-pprintType (TyCon t) = t ^. unpacked
-
--- a/src/Core/Lex.x
+++ b/src/Core/Lex.x
@@ -65,8 +65,6 @@ $white_no_nl = $white # $nl

@decimal = $digit+

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

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

-    @alttag                 { lexWith ( TokenAltTag . read @Int . T.unpack
-                                      . T.drop 1 . T.init ) }
    @varname                { lexWith TokenVarName }
    @conname                { lexWith TokenConName }
    @varsym                 { lexWith TokenVarSym }
@@ -139,7 +135,6 @@ data CoreToken = TokenLet
               | TokenConName Name
               | TokenVarSym Name
               | TokenConSym Name
-               | TokenAltTag Tag
               | TokenEquals
               | TokenLParen
               | TokenRParen
@@ -172,19 +167,24 @@ 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 :: Text -> RLPC [Located CoreToken]
+lexCore :: Text -> RLPC SrcError [Located CoreToken]
 lexCore s = case m of
-    Left e   -> error "core lex error"
+    Left e   -> addFatal err
+        where err = SrcError
+                { _errSpan       = (0,0,0) -- TODO: location
+                , _errSeverity   = Error
+                , _errDiagnostic = SrcErrLexical e
+                }
    Right ts -> pure ts
    where
        m = runAlex s lexStream

-lexCoreR :: Text -> RLPC [Located CoreToken]
-lexCoreR = lexCore
+lexCoreR :: Text -> RLPC RlpcError [Located CoreToken]
+lexCoreR = liftRlpcErrs . lexCore

 -- | @lexCore@, but the tokens are stripped of location info. Useful for
 -- debugging
-lexCore' :: Text -> RLPC [CoreToken]
+lexCore' :: Text -> RLPC SrcError [CoreToken]
 lexCore' s = fmap f <$> lexCore s
    where f (Located _ _ _ t) = t

@@ -201,11 +201,11 @@ data ParseError = ParErrLexical String

 -- TODO:
 instance IsRlpcError SrcError where
-    liftRlpcError = Text . pure . T.pack . show
+    liftRlpcErr = RlpcErr . show

 -- TODO:
 instance IsRlpcError ParseError where
-    liftRlpcError = Text . pure . T.pack . show
+    liftRlpcErr = RlpcErr . show

 alexEOF :: Alex (Located CoreToken)
 alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) ->
--- a/src/Core/Parse.y
+++ b/src/Core/Parse.y
@@ -3,13 +3,14 @@
 Module : Core.Parse
 Description : Parser for the Core language
 -}
-{-# LANGUAGE OverloadedStrings, ViewPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Core.Parse
    ( parseCore
    , parseCoreExpr
    , parseCoreProg
    , parseCoreProgR
    , module Core.Lex -- temp convenience
+    , parseTmp
    , SrcError
    , Module
    )
@@ -23,9 +24,7 @@ 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
 }
@@ -35,7 +34,7 @@ import Data.HashMap.Strict  qualified as H
 %name parseCoreProg StandaloneProgram
 %tokentype { Located CoreToken }
 %error { parseError }
-%monad { RLPC } { happyBind } { happyPure }
+%monad { RLPC SrcError }

 %token
      let             { Located _ _ _ TokenLet }
@@ -51,7 +50,6 @@ 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 }
@@ -85,15 +83,6 @@ Program         : ScTypeSig ';' Program         { insTypeSig $1 $3 }
                | ScTypeSig OptSemi             { singletonTypeSig $1 }
                | ScDef     ';' Program         { insScDef $1 $3 }
                | ScDef     OptSemi             { singletonScDef $1 }
-                | TLPragma  Program             {% doTLPragma $1 $2 }
-                | TLPragma                      {% doTLPragma $1 mempty }
-
-TLPragma        :: { Pragma }
-                : '{-#' Words '#-}'             { Pragma $2 }
-
-Words           :: { [Text] }
-                : Words word                    { $1 `snoc` $2 }
-                | word                          { [$1] }

 OptSemi         :: { () }
 OptSemi         : ';'                           { () }
@@ -106,11 +95,10 @@ ScDefs          :: { [ScDef Name] }
 ScDefs          : ScDef ';' ScDefs              { $1 : $3 }
                | ScDef ';'                     { [$1] }
                | ScDef                         { [$1] }
+                | {- epsilon -}                 { [] }

 ScDef           :: { ScDef Name }
 ScDef           : Var ParList '=' Expr          { ScDef $1 $2 $4 }
-                -- hack to allow constructors to be compiled into scs
-                | Con ParList '=' Expr          { ScDef $1 $2 $4 }

 Type            :: { Type }
 Type            : Type1                         { $1 }
@@ -160,15 +148,22 @@ Alters          : Alter ';' Alters              { $1 : $3 }
                | Alter                         { [$1] }

 Alter           :: { Alter Name }
-Alter           : alttag ParList '->' Expr      { Alter (AltTag  $1) $2 $4 }
-                | Con    ParList '->' Expr      { Alter (AltData $1) $2 $4 }
+Alter           : litint 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 }

@@ -194,23 +189,34 @@ Con             : '(' consym ')'                    { $2 }

 {

-parseError :: [Located CoreToken] -> RLPC a
-parseError (Located y x l t : _) =
-    error $ show y <> ":" <> show x
-         <> ": parse error at token `" <> show t <> "'"
+parseError :: [Located CoreToken] -> RLPC SrcError a
+parseError (Located y x l _ : _) = addFatal err
+    where err = SrcError
+            { _errSpan       = (y,x,l)
+            , _errSeverity   = Error
+            , _errDiagnostic = SrcErrParse
+            }

-{-# WARNING parseError "unimpl" #-}
+parseTmp :: IO (Module Name)
+parseTmp = do
+    s <- TIO.readFile "/tmp/t.hs"
+    case parse s of
+        Left e -> error (show e)
+        Right (ts,_) -> pure ts
+    where
+        parse = evalRLPC def . (lexCore >=> parseCore)

-exprPragma :: [String] -> RLPC (Expr Name)
-exprPragma ("AST" : e) = undefined
-exprPragma _           = undefined
+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
+            }

-{-# WARNING exprPragma "unimpl" #-}
-
-astPragma :: [String] -> RLPC (Expr Name)
-astPragma _ = undefined
-
-{-# WARNING astPragma "unimpl" #-}
+astPragma :: [String] -> RLPC SrcError (Expr Name)
+astPragma = pure . read . unwords

 insTypeSig :: (Hashable b) => (b, Type) -> Program b -> Program b
 insTypeSig ts = programTypeSigs %~ uncurry H.insert ts
@@ -224,26 +230,8 @@ 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
+parseCoreProgR :: [Located CoreToken] -> RLPC RlpcError Program'
+parseCoreProgR = liftRlpcErrs . parseCoreProg

 }

--- a/src/Core/Syntax.hs
+++ b/src/Core/Syntax.hs
@@ -5,14 +5,8 @@ Description : Core ASTs and the like
 {-# LANGUAGE PatternSynonyms, OverloadedStrings #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE DerivingStrategies, DerivingVia #-}
-- for recursion-schemes
-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable
-  , TemplateHaskell, TypeFamilies #-}
 module Core.Syntax
    ( Expr(..)
-    , ExprF(..)
-    , ExprF'(..)
    , Type(..)
    , pattern TyInt
    , Lit(..)
@@ -30,11 +24,9 @@ module Core.Syntax
    , Module(..)
    , Program(..)
    , Program'
-    , Pragma(..)
    , unliftScDef
    , programScDefs
    , programTypeSigs
-    , programDataTags
    , Expr'
    , ScDef'
    , Alter'
@@ -48,15 +40,11 @@ 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)
@@ -111,14 +99,11 @@ data Alter b = Alter AltCon [b] (Expr b)

 deriving instance (Eq b) => Eq (Alter b)

-newtype Pragma = Pragma [T.Text]
-
 data Rec = Rec
         | NonRec
         deriving (Show, Read, Eq, Lift)

-data AltCon = AltData Name
-            | AltTag Tag
+data AltCon = AltData Tag
            | AltLit Lit
            | Default
            deriving (Show, Read, Eq, Lift)
@@ -140,20 +125,13 @@ data Module b = Module (Maybe (Name, [Name])) (Program b)

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

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

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

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

 class HasRHS s t a b | s -> a, t -> b, s b -> t, t a -> s where
@@ -203,8 +187,3 @@ 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/TH.hs
+++ b/src/Core/TH.hs
@@ -6,6 +6,7 @@ module Core.TH
    ( coreExpr
    , coreProg
    , coreProgT
+    , core
    )
    where
 ----------------------------------------------------------------------------------
@@ -13,38 +14,74 @@ import Language.Haskell.TH
 import Language.Haskell.TH.Syntax   hiding (Module)
 import Language.Haskell.TH.Quote
 import Control.Monad                ((>=>))
-import Control.Monad.IO.Class
-import Control.Arrow                ((>>>))
 import Compiler.RLPC
 import Data.Default.Class           (def)
-import Data.Text                    (Text)
 import Data.Text                    qualified as T
 import Core.Parse
 import Core.Lex
-import Core.Syntax
 import Core.HindleyMilner           (checkCoreProgR)
 ----------------------------------------------------------------------------------

-coreProg :: QuasiQuoter
-coreProg = mkqq $ lexCoreR >=> parseCoreProgR
+-- TODO: write in terms of a String -> QuasiQuoter

-coreExpr :: QuasiQuoter
-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
+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"
    }

-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"
+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"
+    }
+
+coreExpr :: QuasiQuoter
+coreExpr = QuasiQuoter
+    { quoteExp = qCoreExpr
+    , quotePat = error "core quasiquotes may only be used in expressions"
+    , quoteType = error "core quasiquotes may only be used in expressions"
+    , quoteDec = error "core quasiquotes may only be used in expressions"
+    }
+
+-- | Type-checked @coreProg@
+coreProgT :: QuasiQuoter
+coreProgT = QuasiQuoter
+    { quoteExp = qCoreProgT
+    , quotePat = error "core quasiquotes may only be used in expressions"
+    , quoteType = error "core quasiquotes may only be used in expressions"
+    , quoteDec = error "core quasiquotes may only be used in expressions"
+    }
+
+qCore :: String -> Q Exp
+qCore s = case parse (T.pack s) of
+    Left e       -> error (show e)
+    Right (m,ts) -> lift m
+    where
+        parse = evalRLPC def . (lexCore >=> parseCore)
+
+qCoreExpr :: String -> Q Exp
+qCoreExpr s = case parseExpr (T.pack s) of
+    Left e       -> error (show e)
+    Right (m,ts) -> lift m
+    where
+        parseExpr = evalRLPC def . (lexCore >=> parseCoreExpr)
+
+qCoreProg :: String -> Q Exp
+qCoreProg s = case parse (T.pack s) of
+    Left e       -> error (show e)
+    Right (m,ts) -> lift m
+    where
+        parse = evalRLPC def . (lexCoreR >=> parseCoreProgR)
+
+qCoreProgT :: String -> Q Exp
+qCoreProgT s = case parse (T.pack s) of
+    Left e      -> error (show e)
+    Right (m,_) -> lift m
+    where
+        parse = evalRLPC def . (lexCoreR >=> parseCoreProgR >=> checkCoreProgR)

--- a/src/Core/Utils.hs
+++ b/src/Core/Utils.hs
@@ -1,10 +1,16 @@
+-- for recursion schemes
+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
+-- for recursion schemes
+{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
+
 module Core.Utils
-    ( programRhss
-    , programGlobals
+    ( bindersOf
+    , rhssOf
    , isAtomic
    -- , insertModule
    , extractProgram
    , freeVariables
+    , ExprF(..)
    )
    where
 ----------------------------------------------------------------------------------
@@ -17,11 +23,13 @@ import Lens.Micro
 import GHC.Exts                     (IsList(..))
 ----------------------------------------------------------------------------------

-programGlobals :: Traversal' (Program b) b
-programGlobals = programScDefs . each . _lhs . _1
+bindersOf :: (IsList l, Item l ~ b) => [Binding b] -> l
+bindersOf bs = fromList $ fmap f bs
+    where f (k := _) = k

-programRhss :: Traversal' (Program b) (Expr b)
-programRhss = programScDefs . each . _rhs
+rhssOf :: (IsList l, Item l ~ Expr b) => [Binding b] -> l
+rhssOf = fromList . fmap f
+    where f (_ := v) = v

 isAtomic :: Expr b -> Bool
 isAtomic (Var _)  = True
@@ -39,6 +47,8 @@ extractProgram (Module _ p) = p

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

+makeBaseFunctor ''Expr
+
 freeVariables :: Expr' -> Set Name
 freeVariables = cata go
    where
@@ -47,8 +57,8 @@ freeVariables = cata go
        -- TODO: collect free vars in rhss of bs
        go (LetF _ bs e)    = (e `S.union` esFree) `S.difference` ns
            where
-                es = bs ^.. each . _rhs :: [Expr']
-                ns = S.fromList $ bs ^.. each . _lhs
+                es = rhssOf bs :: [Expr']
+                ns = bindersOf bs
                -- 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,4 +1,3 @@
-{-# LANGUAGE ImplicitParams #-}
 {-# LANGUAGE LambdaCase #-}
 module Core2Core
    ( core2core
@@ -16,12 +15,11 @@ import Data.Set                 (Set)
 import Data.Set                 qualified as S
 import Data.List
 import Control.Monad.Writer
-import Control.Monad.State.Lazy
+import Control.Monad.State
 import Control.Arrow            ((>>>))
 import Data.Text                qualified as T
-import Data.HashMap.Strict      (HashMap)
 import Numeric                  (showHex)
-import Lens.Micro.Platform
+import Lens.Micro
 import Core.Syntax
 import Core.Utils
 ----------------------------------------------------------------------------------
@@ -30,35 +28,22 @@ core2core :: Program' -> Program'
 core2core p = undefined

 gmPrep :: Program' -> Program'
-gmPrep p = p & appFloater (floatNonStrictCases globals)
-             & tagData
+gmPrep p = p' & programScDefs %~ (<>caseScs)
    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

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

 -- | 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,8 +661,7 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
        compileC _ (Con t n) = [PushConstr t n]

        compileC _ (Case _ _) =
-            error "GM compiler found a non-strict case expression, which should\
-                  \ have been floated by Core2Core.gmPrep. This is a bug!"
+            error "case expressions may not appear in non-strict contexts :/"

        compileC _ _ = error "yet to be implemented!"

@@ -725,16 +724,12 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
        compileD g as = fmap (compileA g) as

        compileA :: Env -> Alter' -> (Tag, Code)
-        compileA g (Alter (AltTag t) as e) = (t, [Split n] <> c <> [Slide n])
+        compileA g (Alter (AltData t) as e) = (t, [Split n] <> c <> [Slide n])
            where
                n = length as
                binds = (NameKey <$> as) `zip` [0..]
                g' = binds ++ argOffset n g
                c = compileE g' e
-        compileA _ (Alter _ as e) = error "GM.compileA found an untagged\
-                                          \ constructor, which should have\
-                                          \ been handled by Core2Core.gmPrep.\
-                                          \ This is a bug!"

        inlineOp1 :: Env -> Instr -> Expr' -> Code
        inlineOp1 g i a = compileE g a <> [i]
--- a/src/Rlp/Lex.x
+++ b/src/Rlp/Lex.x
@@ -7,14 +7,14 @@ module Rlp.Lex
    , RlpToken(..)
    , Located(..)
    , lexToken
-    , lexStream
    , lexDebug
    , lexCont
+    , execP
+    , execP'
    )
    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)
@@ -54,10 +54,9 @@ $asciisym       = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]

@reservedname = 
    case|data|do|import|in|let|letrec|module|of|where
-    |infixr|infixl|infix

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

 rlp :-
    
@@ -126,9 +125,6 @@ lexReservedName = \case
    "of"        -> TokenOf
    "let"       -> TokenLet
    "in"        -> TokenIn
-    "infix"     -> TokenInfix
-    "infixl"    -> TokenInfixL
-    "infixr"    -> TokenInfixR

 lexReservedOp :: Text -> RlpToken
 lexReservedOp = \case
@@ -209,6 +205,13 @@ alexEOF = do
    inp <- getInput
    pure (Located undefined TokenEOF)

+execP :: P a -> ParseState -> Maybe a
+execP p st = runP p st & snd
+
+execP' :: P a -> Text -> Maybe a
+execP' p s = execP p st where
+    st = initParseState s
+
 initParseState :: Text -> ParseState
 initParseState s = ParseState
    { _psLayoutStack = []
@@ -227,10 +230,6 @@ initAlexInput s = AlexInput
    , _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
@@ -245,7 +244,6 @@ lexToken = do
        AlexToken inp' l act -> do
            psInput .= inp'
            act inp l
-        AlexError inp' -> addFatalHere 1 RlpParErrLexical

 lexCont :: (Located RlpToken -> P a) -> P a
 lexCont = (lexToken >>=)
@@ -264,7 +262,7 @@ lexDebug k = do
    k t

 lexTest :: Text -> Maybe [RlpToken]
-lexTest s = runP' lexStream s ^. _3
+lexTest s = execP' lexStream s

 indentLevel :: P Int
 indentLevel = do
--- a/src/Rlp/Parse.y
+++ b/src/Rlp/Parse.y
@@ -2,9 +2,10 @@
 {-# LANGUAGE LambdaCase #-}
 module Rlp.Parse
    ( parseRlpProg
+    , execP
+    , execP'
    )
    where
-import Compiler.RlpcError
 import Rlp.Lex
 import Rlp.Syntax
 import Rlp.Parse.Types
@@ -15,7 +16,6 @@ import Lens.Micro.Platform          ()
 import Data.List.Extra
 import Data.Fix
 import Data.Functor.Const
-import Data.Text                    qualified as T
 }

 %name parseRlpProg StandaloneProgram
@@ -32,6 +32,7 @@ import Data.Text                    qualified as T
    varsym          { Located _ (TokenVarSym $$) }
    data            { Located _ TokenData }
    litint          { Located _ (TokenLitInt $$) }
+    '::'            { Located _ TokenHasType }
    '='             { Located _ TokenEquals }
    '|'             { Located _ TokenPipe }
    ';'             { Located _ TokenSemicolon }
@@ -78,9 +79,15 @@ VS                  : ';'                   { $1 }

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

+-- TODO: multiple vars
+
+TySigDecl   :: { PartialDecl' }
+            : Var '::' Type             { TySigD [$1] $3 }
+
 InfixDecl   :: { PartialDecl' }
            : InfixWord litint InfixOp  {% mkInfixD $1 $2 $3 }

@@ -163,19 +170,15 @@ mkProgram ds = do
    pure $ RlpProgram (associate pt <$> ds)

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

 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
+        Just o  -> error "(TODO: non-fatal) duplicate inix decls"
        Nothing -> pure (Just (a,p))
        )
    pure $ InfixD a p n
-
 }
--- a/src/Rlp/Parse/Types.hs
+++ b/src/Rlp/Parse/Types.hs
@@ -1,47 +1,11 @@
 {-# 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
+module Rlp.Parse.Types where
 --------------------------------------------------------------------------------
 import Core.Syntax                  (Name)
 import Control.Monad
-import Control.Monad.State.Strict
-import Control.Monad.Errorful
-import Compiler.RlpcError
+import Control.Monad.State.Class
 import Data.Text                    (Text)
 import Data.Maybe
 import Data.Fix
@@ -70,12 +34,6 @@ type Position =
    , Int -- column
    )

-posLine :: Lens' Position Int
-posLine = _1
-
-posColumn :: Lens' Position Int
-posColumn = _2
-
 data RlpToken
    -- literals
    = TokenLitInt Int
@@ -113,34 +71,24 @@ data RlpToken
    | TokenEOF
    deriving (Show)

-newtype P a = P {
-        runP :: ParseState
-             -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
-    }
+newtype P a = P { runP :: ParseState -> (ParseState, Maybe a) }
    deriving (Functor)

 instance Applicative P where
-    pure a = P $ \st -> (st, [], pure a)
+    pure a = P $ \st -> (st,Just a)
    liftA2 = liftM2

 instance Monad P where
    p >>= k = P $ \st ->
-        let (st',es,ma) = runP p st
-        in case ma of
-            Just a  -> runP (k a) st'
-                     & _2 %~ (es<>)
-            Nothing -> (st',es,Nothing)
-
-    {-# INLINE (>>=) #-}
+        let (st',a) = runP p st
+        in case a of
+            Just x  -> runP (k x) st'
+            Nothing -> (st', Nothing)

 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)
+        in (st', Just a)

 data ParseState = ParseState
    { _psLayoutStack        :: [Layout]
@@ -163,14 +111,11 @@ 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
+                   | RlpParErrDuplicateInfixD
+    deriving (Eq, Ord, Show)

 ----------------------------------------------------------------------------------
+
 -- absolute psycho shit (partial ASTs)

 type PartialDecl' = Decl (Const PartialExpr') Name
@@ -216,27 +161,3 @@ 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)
-
--- a/src/Rlp/Syntax.hs
+++ b/src/Rlp/Syntax.hs
@@ -45,6 +45,7 @@ import Data.Functor.Foldable.TH     (makeBaseFunctor)
 import Data.Functor.Classes
 import Lens.Micro
 import Lens.Micro.TH
+import Language.Haskell.TH.Syntax   (Lift)
 import Core.Syntax                  hiding (Lit)
 import Core                         (HasRHS(..), HasLHS(..))
 ----------------------------------------------------------------------------------
@@ -55,7 +56,7 @@ data RlpModule b = RlpModule
    }

 newtype RlpProgram b = RlpProgram [Decl RlpExpr b]
-    deriving Show
+    deriving (Show, Lift)

 type RlpProgram' = RlpProgram Name

@@ -70,17 +71,17 @@ data Decl e b = FunD    VarId [Pat b] (e b) (Maybe (Where b))
              | TySigD  [VarId] Type
              | DataD   ConId [Name] [ConAlt]
              | InfixD  Assoc Int Name
-              deriving Show
+              deriving (Show, Lift)

 type Decl' e = Decl e Name

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

 data ConAlt = ConAlt ConId [Type]
-            deriving Show
+            deriving (Show, Lift)

 data RlpExpr b = LetE  [Bind b] (RlpExpr b)
               | VarE  VarId
@@ -90,7 +91,7 @@ data RlpExpr b = LetE  [Bind b] (RlpExpr b)
               | IfE   (RlpExpr b) (RlpExpr b) (RlpExpr b)
               | AppE  (RlpExpr b) (RlpExpr b)
               | LitE  (Lit b)
-               deriving Show
+               deriving (Show, Lift)

 type RlpExpr' = RlpExpr Name

@@ -99,15 +100,15 @@ type Where' = [Bind Name]

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

 data Bind b = PatB (Pat b) (RlpExpr b)
            | FunB VarId [Pat b] (RlpExpr b)
-            deriving Show
+            deriving (Show, Lift)

 data VarId = NameVar Text
           | SymVar Text
-           deriving Show
+           deriving (Show, Lift)

 instance IsString VarId where
    -- TODO: use symvar if it's an operator
@@ -115,19 +116,19 @@ instance IsString VarId where

 data ConId = NameCon Text
           | SymCon Text
-           deriving Show
+           deriving (Show, Lift)

 data Pat b = VarP VarId
           | LitP (Lit b)
           | ConP ConId [Pat b]
-           deriving Show
+           deriving (Show, Lift)

 type Pat' = Pat Name

 data Lit b = IntL Int
           | CharL Char
           | ListL [RlpExpr b]
-           deriving Show
+           deriving (Show, Lift)

 type Lit' = Lit Name

--- a/src/Rlp/TH.hs
+++ b/src/Rlp/TH.hs
@@ -0,0 +1,30 @@
+module Rlp.TH
+    ( rlpProg
+    )
+    where
+--------------------------------------------------------------------------------
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax   hiding (Module)
+import Language.Haskell.TH.Quote
+import Control.Monad                ((>=>))
+import Compiler.RLPC
+import Data.Default.Class           (def)
+import Data.Text                    qualified as T
+import Rlp.Parse
+--------------------------------------------------------------------------------
+
+rlpProg :: QuasiQuoter
+rlpProg = QuasiQuoter
+    { quoteExp = qRlpProg
+    , quotePat = error "rlp quasiquotes may only be used in expressions"
+    , quoteType = error "rlp quasiquotes may only be used in expressions"
+    , quoteDec = error "rlp quasiquotes may only be used in expressions"
+    }
+
+qRlpProg :: String -> Q Exp
+qRlpProg s = case parse (T.pack s) of
+    Nothing      -> error "error lol iddfk"
+    Just a       -> lift a
+    where
+        parse = execP' parseRlpProg
+
--- a/src/Rlp2Core.hs
+++ b/src/Rlp2Core.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE LambdaCase #-}
+module Rlp2Core
+    ( rlp2core
+    )
+    where
+--------------------------------------------------------------------------------
+import Core.Syntax                  as Core
+import Rlp.Syntax                   as Rlp
+import Data.Foldable
+import Data.HashMap.Strict          qualified as H
+import Control.Monad.State
+import Lens.Micro.Platform
+--------------------------------------------------------------------------------
+
+rlp2core :: RlpProgram' -> Program'
+rlp2core (RlpProgram ds) = execState (decl2core `traverse_` ds) init
+    where
+        init = Program
+            { _programScDefs    = mempty
+            , _programTypeSigs  = mempty
+            }
+
+type GenCoreProg b = State (Program b)
+
+type GenCoreProg' = GenCoreProg Name
+
+emitTypeSig :: Name -> Type -> GenCoreProg' ()
+emitTypeSig b t = do
+    let tl :: Lens' Program' (Maybe Type)
+        tl = programTypeSigs . at b
+    tl <~ (use tl >>= \case
+        -- TODO: non-fatal error
+        Just o  -> error "(TODO: non-fatal) duplicate type sigs"
+        Nothing -> pure (Just t)
+        )
+
+decl2core :: Decl' RlpExpr -> GenCoreProg' ()
+
+decl2core (DataD n as cs) = undefined
+
+decl2core (TySigD vs t) = mkSig `traverse_` vs where
+    mkSig :: VarId -> GenCoreProg' ()
+    mkSig (NameVar n) = emitTypeSig n t
+
--- a/tst/Core/HindleyMilnerSpec.hs
+++ b/tst/Core/HindleyMilnerSpec.hs
@@ -38,25 +38,9 @@ spec = do
        let e = [coreExpr|3|]
        in check' [] (TyCon "Bool") e `shouldSatisfy` isLeft

-    it "should infer `fix ((+#) 1)` :: Int" $
-        let g = [ ("fix", ("a" :-> "a") :-> "a")
-                , ("+#", TyInt :-> TyInt :-> TyInt) ]
-            e = [coreExpr|fix ((+#) 1)|]
-        in infer' g e `shouldBe` Right TyInt
+infer' :: Context' -> Expr' -> Either TypeError Type
+infer' g e = fmap fst . runErrorful $ infer g e

-    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
+check' :: Context' -> Type -> Expr' -> Either TypeError ()
+check' g t e = fmap fst . runErrorful $ check g t e

--- a/tst/GMSpec.hs
+++ b/tst/GMSpec.hs
@@ -27,22 +27,15 @@ spec = do
            in coreRes `shouldBe` arithRes

    describe "test programs" $ do
-        it "fac 3" $
+        it "fac 3" $ do
            resultOf Ex.fac3 `shouldBe` Just (NNum 6)

-        it "sum [1,2,3]" $
+        it "sum [1,2,3]" $ do
            resultOf Ex.sumList `shouldBe` Just (NNum 6)

-        it "k 3 ((/#) 1 0)" $
+        it "k 3 ((/#) 1 0)" $ do
            resultOf Ex.constDivZero `shouldBe` Just (NNum 3)

-        it "id (case ... of { ... })" $
+        it "id (case ... of { ... })" $ do
            resultOf Ex.idCase `shouldBe` Just (NNum 5)

-        it "bool pattern matching with named constructors" $
-            resultOf Ex.namedBoolCase `shouldBe` Just (NNum 123)
-
-        it "list pattern matching with named constructors" $
-            resultOf Ex.namedConsCase `shouldBe` Just (NNum 6)
-
-
--- a/tst/Rlp/Parse/DeclsSpec.hs
+++ b/tst/Rlp/Parse/DeclsSpec.hs