infer letrec expressions

letrec
allow uppercase sc names in preperation for Rlp2Core
2024-01-23 21:09:25 -07:00 · 2024-01-23 20:19:16 -07:00 · 2024-01-22 12:45:42 -07:00 · 2024-01-22 12:20:05 -07:00 · 2024-01-22 10:26:33 -07:00 · 2024-01-22 10:14:30 -07:00
30 changed files with 2005 additions and 329 deletions
--- a/.ghci
+++ b/.ghci
@@ -0,0 +1,18 @@
+:set -XOverloadedStrings
+
+:set -package process
+
+:{
+import System.Exit qualified
+import System.Process qualified
+
+_reload_and_make _ = do
+    p <- System.Process.spawnCommand "make -f Makefile_happysrcs"
+    r <- System.Process.waitForProcess p
+    case r of
+        System.Exit.ExitSuccess -> pure ":reload"
+        _                       -> pure ""
+:}
+
+:def! r _reload_and_make
+
--- a/25
+++ b/25
@@ -0,0 +1,25 @@
+HAPPY = happy
+HAPPY_OPTS = -a -g -c
+ALEX = alex
+ALEX_OPTS = -g
+
+SRC = src
+CABAL_BUILD = dist-newstyle/build/x86_64-osx/ghc-9.6.2/rlp-0.1.0.0/build
+
+all: parsers lexers
+
+parsers: $(CABAL_BUILD)/Rlp/Parse.hs $(CABAL_BUILD)/Core/Parse.hs
+lexers: $(CABAL_BUILD)/Rlp/Lex.hs $(CABAL_BUILD)/Core/Lex.hs
+
+$(CABAL_BUILD)/Rlp/Parse.hs: $(SRC)/Rlp/Parse.y
+	$(HAPPY) $(HAPPY_OPTS) $< -o $@
+
+$(CABAL_BUILD)/Rlp/Lex.hs: $(SRC)/Rlp/Lex.x
+	$(ALEX) $(ALEX_OPTS) $< -o $@
+
+$(CABAL_BUILD)/Core/Parse.hs: $(SRC)/Core/Parse.y
+	$(HAPPY) $(HAPPY_OPTS) $< -o $@
+
+$(CABAL_BUILD)/Core/Lex.hs: $(SRC)/Core/Lex.x
+	$(ALEX) $(ALEX_OPTS) $< -o $@
+
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -7,6 +7,9 @@ import Options.Applicative      hiding (ParseError)
 import Control.Monad
 import Control.Monad.Reader
 import Data.HashSet             qualified as S
+import Data.Text                (Text)
+import Data.Text                qualified as T
+import Data.Text.IO             qualified as TIO
 import System.IO
 import System.Exit              (exitSuccess)
 import Core
@@ -102,7 +105,7 @@ dshowFlags = whenFlag flagDDumpOpts do
 ddumpAST :: RLPCIO CompilerError ()
 ddumpAST = whenFlag flagDDumpAST $ forFiles_ \o f -> do
    liftIO $ withFile f ReadMode $ \h -> do
-        s <- hGetContents h
+        s <- TIO.hGetContents h
        case parseProg o s of
            Right (a,_) -> hPutStrLn stderr $ show a
            Left e -> error "todo errors lol"
@@ -110,10 +113,10 @@ ddumpAST = whenFlag flagDDumpAST $ forFiles_ \o f -> do
 ddumpEval :: RLPCIO CompilerError ()
 ddumpEval = whenFlag flagDDumpEval do
    fs <- view rlpcInputFiles
-    forM_ fs $ \f -> liftIO (readFile f) >>= doProg
+    forM_ fs $ \f -> liftIO (TIO.readFile f) >>= doProg

    where
-        doProg :: String -> RLPCIO CompilerError ()
+        doProg :: Text -> RLPCIO CompilerError ()
        doProg s = ask >>= \o -> case parseProg o s of
            -- TODO: error handling
            Left e -> addFatal . CompilerError $ show e
@@ -133,7 +136,7 @@ ddumpEval = whenFlag flagDDumpEval do
            where v f p h = f p h *> pure ()

 parseProg :: RLPCOptions
-          -> String
+          -> Text
          -> Either SrcError (Program', [SrcError])
 parseProg o = evalRLPC o . (lexCore >=> parseCoreProg)

--- a/doc/src/commentary/gm.rst
+++ b/doc/src/commentary/gm.rst
@@ -1,16 +1,24 @@
 The *G-Machine*
 ===============

+The G-Machine (graph machine) is the current heart of rlpc, until we potentially
+move onto a STG (spineless tagless graph machine) or a TIM (three-instruction
+machine). rl' source code is desugared into Core; a dumbed-down subset of rl',
+and then compiled to G-Machine code, which is then finally translated to the
+desired target.
+
 **********
 Motivation
 **********

-Our initial model, the *Template Instantiator* (TI) was a very
-straightforward solution to compilation, but its core design has a major
-Achilles' heel, being that Compilation is interleaved with evaluation -- The
-heap nodes for supercombinators hold uninstantiated expressions, i.e. raw ASTs
-straight from the parser. When a supercombinator is found on the stack during
-evaluation, the template expression is instantiated (compiled) on the spot.
+Our initial model, the *Template Instantiator* (TI) was a very straightforward
+solution to compilation, but its core design has a major Achilles' heel, being
+that compilation is interleaved with evaluation -- The heap nodes for
+supercombinators hold uninstantiated expressions, i.e. raw ASTs straight from
+the parser. When a supercombinator is found on the stack during evaluation, the
+template expression is instantiated (compiled) on the spot. This makes
+translation to an assembly difficult, undermining the point of an intermediate
+language.

 .. math::
   \transrule
@@ -31,7 +39,7 @@ evaluation, the template expression is instantiated (compiled) on the spot.
   \text{where } h' = \mathtt{instantiateU} \; e \; a_n \; h \; g
   }

-The process of instantiating a supercombinator goes something like this
+The process of instantiating a supercombinator goes something like this:

 1. Augment the environment with bindings to the arguments.

@@ -52,13 +60,17 @@ The process of instantiating a supercombinator goes something like this
 Instantiating the supercombinator's body in this way is the root of our
 Achilles' heel. Traversing a tree structure is a very non-linear task unfit for
 an assembly target. The goal of our new G-Machine is to compile a *linear
-sequence of instructions* which instantiate the expression at execution.
+sequence of instructions* which, **when executed**, build up a graph
+representing the code.

 **************************
 Trees and Vines, in Theory
 **************************

-WIP.
+Rather than instantiating an expression at runtime -- traversing the AST and
+building a graph -- we want to compile all expressions at compile-time,
+generating a linear sequence of instructions which may be executed to build the
+graph.

 **************************
 Evaluation: Slurping Vines
--- a/doc/src/commentary/ti.rst
+++ b/doc/src/commentary/ti.rst
@@ -1,6 +0,0 @@
-The *Template Instantiator*
-====================================
-
-WIP. This will hopefully be expanded into a thorough walkthrough of the state
-machine.
-
--- a/doc/src/conf.py
+++ b/doc/src/conf.py
@@ -13,7 +13,7 @@ author = 'madeleine sydney slaga'
 # -- General configuration ---------------------------------------------------
 # https://www.sphinx-doc.org/en/master/usage/configuration.html#general-configuration

-extensions = ['sphinx.ext.imgmath']
+extensions = ['sphinx.ext.imgmath', 'sphinx.ext.graphviz']

 # templates_path = ['_templates']
 exclude_patterns = []
@@ -32,6 +32,7 @@ html_theme = 'alabaster'
 imgmath_latex_preamble = r'''
 \usepackage{amsmath}
 \usepackage{tabularray}
+\usepackage{syntax}

 \newcommand{\transrule}[2]
    {\begin{tblr}{|rrrlc|}
--- a/doc/src/references/rlp-grammar.rst
+++ b/doc/src/references/rlp-grammar.rst
@@ -0,0 +1,67 @@
+The Complete Syntax of rl'
+==========================
+
+WIP.
+
+Provided is the complete syntax of rl' in (pseudo) EBNF. {A} represents zero or
+more A's, [A] means optional A, and terminals are wrapped in 'single-quotes'.
+
+.. math
+   :nowrap:
+
+   \setlength{\grammarparsep}{20pt plus 1pt minus 1pt}
+   \setlength{\grammarindent}{12em}
+   \begin{grammar}
+       <Decl> ::= <InfixDecl>
+       \alt <DataDecl>
+       \alt <TypeSig>
+       \alt <FunDef>
+
+       <InfixDecl> ::= <InfixWord> `litint' <Name>
+       <InfixWord> ::= `infix'
+       \alt `infixl'
+       \alt `infixr'
+
+       <DataDecl> ::= `data' `conname' {}
+
+   \end{grammar}
+
+.. code-block:: bnf
+
+   Decl      ::= InfixDecl
+               | DataDecl
+               | TypeSig
+               | FunDef
+
+   InfixDecl ::= InfixWord 'litint' Operator
+   InfixWord ::= 'infix'
+               | 'infixl'
+               | 'infixr'
+
+   DataDecl  ::= 'data' 'conname' {'name'} '=' Data
+   DataCons  ::= 'conname' {Type1} ['|' DataCons]
+
+   TypeSig   ::= Var '::' Type
+   FunDef    ::= Var {Pat1} '=' Expr
+
+   Type      ::= Type1 {Type1}
+               -- note that (->) is right-associative,
+               -- and extends as far as possible
+               | Type '->' Type
+   Type1     ::= '(' Type ')'
+               | 'conname'
+
+   Pat       ::= 'conname' Pat1 {Pat1}
+               | Pat 'consym' Pat
+
+   Pat1      ::= Literal
+               | 'conname'
+               | '(' Pat ')'
+
+   Literal   ::= 'litint'
+
+   Var ::= 'varname'
+         | '(' 'varsym' ')'
+   Con ::= 'conname'
+         | '(' 'consym' ')'
+
--- a/rlp.cabal
+++ b/rlp.cabal
@@ -12,6 +12,7 @@ category:           Language
 build-type:         Simple
 extra-doc-files:    README.md
 -- extra-source-files:
+tested-with:        GHC==9.6.2

 common warnings
 --    ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-unused-top-binds
@@ -22,41 +23,59 @@ library
                    , TI
                    , GM
                    , Compiler.RLPC
+                    , Compiler.RlpcError
+                    , Compiler.JustRun
                    , Core.Syntax
                    , Core.Examples
                    , Core.Utils
                    , Core.TH
+                    , Core.HindleyMilner
+                    , Control.Monad.Errorful
+                    , Rlp.Syntax
+                    -- , Rlp.Parse.Decls
+                    , Rlp.Parse
+                    , Rlp.Parse.Associate
+                    , Rlp.Lex
+                    , Rlp.Parse.Types

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

    build-tool-depends: happy:happy, alex:alex

    -- other-extensions:
    build-depends:    base ^>=4.18.0.0
-                    , containers
-                    , microlens
-                    , microlens-th
-                    , mtl
-                    , template-haskell
                    -- required for happy
-                    , array
-                    , data-default-class
-                    , unordered-containers
-                    , hashable
-                    , pretty
-                    , recursion-schemes
-                    , megaparsec
-                    , text
+                    , array >= 0.5.5 && < 0.6
+                    , containers >= 0.6.7 && < 0.7
+                    , template-haskell >= 2.20.0 && < 2.21
+                    , pretty >= 1.1.3 && < 1.2
+                    , data-default >= 0.7.1 && < 0.8
+                    , data-default-class >= 0.1.2 && < 0.2
+                    , hashable >= 1.4.3 && < 1.5
+                    , mtl >= 2.3.1 && < 2.4
+                    , text >= 2.0.2 && < 2.1
+                    , megaparsec >= 9.6.1 && < 9.7
+                    , microlens >= 0.4.13 && < 0.5
+                    , microlens-mtl >= 0.2.0 && < 0.3
+                    , microlens-platform >= 0.4.3 && < 0.5
+                    , microlens-th >= 0.4.3 && < 0.5
+                    , unordered-containers >= 0.2.20 && < 0.3
+                    , recursion-schemes >= 5.2.2 && < 5.3
+                    , data-fix >= 0.3.2 && < 0.4
+                    , utf8-string >= 1.0.2 && < 1.1
+                    , extra >= 1.7.0 && < 2

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

+    default-extensions:
+        OverloadedStrings
+
 executable rlpc
    import:           warnings
    main-is:          Main.hs
@@ -64,11 +83,12 @@ executable rlpc
    -- other-extensions:
    build-depends: base ^>=4.18.0.0
                 , rlp
-                 , optparse-applicative
-                 , microlens
-                 , microlens-mtl
-                 , mtl
-                 , unordered-containers
+                 , optparse-applicative >= 0.18.1 && < 0.19
+                 , microlens >= 0.4.13 && < 0.5
+                 , microlens-mtl >= 0.2.0 && < 0.3
+                 , mtl >= 2.3.1 && < 2.4
+                 , unordered-containers >= 0.2.20 && < 0.3
+                 , text >= 2.0.2 && < 2.1

    hs-source-dirs:   app
    default-language: GHC2021
@@ -84,7 +104,9 @@ test-suite rlp-test
                 , rlp
                 , QuickCheck
                 , hspec            ==2.*
+                 , microlens
    other-modules: Arith
                 , GMSpec
+                 , Core.HindleyMilnerSpec
    build-tool-depends: hspec-discover:hspec-discover

--- a/src/Compiler/JustRun.hs
+++ b/src/Compiler/JustRun.hs
@@ -0,0 +1,48 @@
+{-|
+Module      : Compiler.JustRun
+Description : No-BS, high-level wrappers for major pipeline pieces.
+
+A collection of wrapper functions to demo processes such as lexing, parsing,
+type-checking, and evaluation. This module intends to export "no-BS" functions
+that use Prelude types such as @Either@ and @String@ rather than more complex
+types such as @RLPC@ or @Text@.
+-}
+module Compiler.JustRun
+    ( justLexSrc
+    , justParseSrc
+    , justTypeCheckSrc
+    )
+    where
+----------------------------------------------------------------------------------
+import Core.Lex
+import Core.Parse
+import Core.HindleyMilner
+import Core.Syntax                      (Program')
+import Compiler.RLPC
+import Control.Arrow                    ((>>>))
+import Control.Monad                    ((>=>))
+import Data.Text                        qualified as T
+import Data.Function                    ((&))
+import GM
+----------------------------------------------------------------------------------
+
+justLexSrc :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
+justLexSrc s = lexCoreR (T.pack s)
+             & fmap (map $ \ (Located _ _ _ t) -> t)
+             & rlpcToEither
+
+justParseSrc :: String -> Either [MsgEnvelope RlpcError] Program'
+justParseSrc s = parse (T.pack s)
+               & rlpcToEither
+    where parse = lexCoreR >=> parseCoreProgR
+
+justTypeCheckSrc :: String -> Either [MsgEnvelope RlpcError] Program'
+justTypeCheckSrc s = typechk (T.pack s)
+                   & rlpcToEither
+    where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR
+
+rlpcToEither :: RLPC a -> Either [MsgEnvelope RlpcError] a
+rlpcToEither r = case evalRLPC def r of
+    (Just a,   _) -> Right a
+    (Nothing, es) -> Left es
+
--- a/src/Compiler/RLPC.hs
+++ b/src/Compiler/RLPC.hs
@@ -13,9 +13,12 @@ errors and the family of RLPC monads.
 {-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia #-}
 module Compiler.RLPC
    ( RLPC
-    , RLPCT
+    , RLPCT(..)
    , RLPCIO
    , RLPCOptions(RLPCOptions)
+    , IsRlpcError(..)
+    , RlpcError(..)
+    , MsgEnvelope(..)
    , addFatal
    , addWound
    , MonadErrorful
@@ -34,6 +37,7 @@ module Compiler.RLPC
    , flagDDumpOpts
    , flagDDumpAST
    , def
+    , liftErrorful
    )
    where
 ----------------------------------------------------------------------------------
@@ -42,8 +46,10 @@ import Control.Exception
 import Control.Monad.Reader
 import Control.Monad.State      (MonadState(state))
 import Control.Monad.Errorful
+import Compiler.RlpcError
 import Data.Functor.Identity
 import Data.Default.Class
+import Data.Foldable
 import GHC.Generics             (Generic)
 import Data.Hashable            (Hashable)
 import Data.HashSet             (HashSet)
@@ -51,49 +57,44 @@ import Data.HashSet             qualified as S
 import Data.Coerce
 import Lens.Micro
 import Lens.Micro.TH
+import System.Exit
 ----------------------------------------------------------------------------------

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

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

-instance MonadTrans (RLPCT e) where
-    lift = RLPCT . lift . lift
-
-instance (MonadState s m) => MonadState s (RLPCT e m) where
-    state = lift . state
-
-type RLPC e = RLPCT e Identity
-
-type RLPCIO e = RLPCT e IO
-
-evalRLPCT :: RLPCOptions
-          -> RLPCT e m a
-          -> m (Either e (a, [e]))
-evalRLPCT o = runRLPCT >>> flip runReaderT o >>> runErrorfulT
+type RLPCIO = RLPCT IO

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

-evalRLPCIO :: (Exception e)
-           => RLPCOptions
-           -> RLPCIO e a
-           -> IO (a, [e])
-evalRLPCIO o m = do
-    m' <- evalRLPCT o m
-    case m' of
-        -- TODO: errors
-        Left e -> throwIO e
-        Right a -> pure a
-    
+evalRLPCT :: (Monad m)
+          => RLPCOptions
+          -> RLPCT m a
+          -> m (Maybe a, [MsgEnvelope RlpcError])
+evalRLPCT = undefined
+
+evalRLPCIO :: RLPCOptions -> RLPCIO a -> IO a
+evalRLPCIO opt r = do
+    (ma,es) <- evalRLPCT opt r
+    putRlpcErrs es
+    case ma of
+        Just x  -> pure x
+        Nothing -> die "Failed, no code compiled."
+
+putRlpcErrs :: [MsgEnvelope RlpcError] -> IO ()
+putRlpcErrs = traverse_ print
+
+liftErrorful :: (Monad m, IsRlpcError e) => ErrorfulT (MsgEnvelope e) m a -> RLPCT m a
+liftErrorful e = RLPCT $ lift (fmap liftRlpcError `mapErrorful` e)

 data RLPCOptions = RLPCOptions
    { _rlpcLogFile     :: Maybe FilePath
@@ -107,21 +108,6 @@ data RLPCOptions = RLPCOptions
 data Evaluator = EvaluatorGM | EvaluatorTI
    deriving Show

-data Severity = Error
-              | Warning
-              | Debug
-              deriving Show
-
-- temporary until we have a new doc building system
-type ErrorDoc = String
-
-class Diagnostic e where
-    errorDoc :: e -> ErrorDoc
-
-instance (Monad m) => MonadErrorful e (RLPCT e m) where
-    addWound = RLPCT . lift . addWound
-    addFatal = RLPCT . lift . addFatal
-
 ----------------------------------------------------------------------------------

 instance Default RLPCOptions where
--- a/src/Compiler/RlpcError.hs
+++ b/src/Compiler/RlpcError.hs
@@ -0,0 +1,70 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
+module Compiler.RlpcError
+    ( IsRlpcError(..)
+    , MsgEnvelope(..)
+    , Severity(..)
+    , RlpcError(..)
+    , SrcSpan(..)
+    , msgSpan
+    , msgDiagnostic
+    , msgSeverity
+    , liftRlpcErrors
+    , errorMsg
+    )
+    where
+----------------------------------------------------------------------------------
+import Control.Monad.Errorful
+import Data.Text                (Text)
+import Data.Text                qualified as T
+import GHC.Exts                 (IsString(..))
+import Lens.Micro.Platform
+import Lens.Micro.Platform.Internal
+----------------------------------------------------------------------------------
+
+data MsgEnvelope e = MsgEnvelope
+   { _msgSpan        :: SrcSpan
+   , _msgDiagnostic  :: e
+   , _msgSeverity    :: Severity
+   }
+   deriving (Functor, Show)
+
+newtype RlpcError = Text [Text]
+    deriving Show
+
+instance IsString RlpcError where
+    fromString = Text . pure . T.pack
+
+class IsRlpcError e where
+    liftRlpcError :: e -> RlpcError
+
+instance IsRlpcError RlpcError where
+    liftRlpcError = id
+
+data Severity = SevWarning
+              | SevError
+              deriving Show
+
+data SrcSpan = SrcSpan
+    !Int -- ^ Line
+    !Int -- ^ Column
+    !Int -- ^ Length
+    deriving Show
+
+makeLenses ''MsgEnvelope
+
+liftRlpcErrors :: (Functor m, IsRlpcError e)
+               => ErrorfulT e m a
+               -> ErrorfulT RlpcError m a
+liftRlpcErrors = mapErrorful liftRlpcError
+
+instance (IsRlpcError e) => IsRlpcError (MsgEnvelope e) where
+    liftRlpcError msg = msg ^. msgDiagnostic & liftRlpcError
+
+errorMsg :: SrcSpan -> e -> MsgEnvelope e
+errorMsg s e = MsgEnvelope
+    { _msgSpan = s
+    , _msgDiagnostic = e
+    , _msgSeverity = SevError
+    }
+
--- a/src/Control/Monad/Errorful.hs
+++ b/src/Control/Monad/Errorful.hs
@@ -1,65 +1,79 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE TupleSections, PatternSynonyms #-}
+{-# LANGUAGE UndecidableInstances #-}
 module Control.Monad.Errorful
    ( ErrorfulT
    , runErrorfulT
    , Errorful
    , runErrorful
+    , mapErrorful
    , MonadErrorful(..)
    )
    where
 ----------------------------------------------------------------------------------
+import Control.Monad.State.Strict
 import Control.Monad.Trans
 import Data.Functor.Identity
 import Data.Coerce
+import Data.HashSet                 (HashSet)
+import Data.HashSet                 qualified as H
 import Lens.Micro
 ----------------------------------------------------------------------------------

-newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Either e (a, [e])) }
+newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Maybe a, [e]) }

 type Errorful e = ErrorfulT e Identity

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

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

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

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

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

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

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

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

-    m <*> a = ErrorfulT (m' `apply` a')
-        where
-            m' = runErrorfulT m
-            a' = runErrorfulT a
-            -- TODO: strict concatenation
-            apply = liftA2 $ liftA2 (\ (f,e1) (x,e2) -> (f x, e1 ++ e2)) 
+    ErrorfulT m <*> ErrorfulT n = ErrorfulT $ m `apply` n where
+        apply :: m (Maybe (a -> b), [e]) -> m (Maybe a, [e]) -> m (Maybe b, [e])
+        apply = liftA2 $ \ (mf,e1) (ma,e2) -> (mf <*> ma, e1 <> e2)

 instance (Monad m) => Monad (ErrorfulT e m) where
    ErrorfulT m >>= k = ErrorfulT $ do
-        m' <- m
-        case m' of
-            Right (a,es) -> runErrorfulT (k a)
-            Left e       -> pure (Left e)
+        (a,es) <- m
+        case a of
+            Just x      -> runErrorfulT (k x)
+            Nothing     -> pure (Nothing, es)
+
+mapErrorful :: (Functor m) => (e -> e') -> ErrorfulT e m a -> ErrorfulT e' m a
+mapErrorful f (ErrorfulT m) = ErrorfulT $
+    m & mapped . _2 . mapped %~ f
+
+-- when microlens-pro drops we can write this as
+--    mapErrorful f = coerced . mapped . _2 . mappd %~ f
+-- lol
+
+--------------------------------------------------------------------------------
+-- daily dose of n^2 instances
+
+instance (Monad m, MonadErrorful e m) => MonadErrorful e (StateT s m) where
+    addWound = undefined
+    addFatal = undefined

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

-- TODO: my shitty lexer isn't inserting semicolons
+-- fac3 = undefined
+-- sumList = undefined
+-- constDivZero = undefined
+-- idCase = undefined
+
+---

 letrecExample :: Program'
 letrecExample = [coreProg|
@@ -191,30 +196,31 @@ idCase = [coreProg|
            })
    |]

-corePrelude :: Module Name
-corePrelude = Module (Just ("Prelude", [])) $
-    -- non-primitive defs
-    [coreProg|
-        id x = x;
-        k x y = x;
-        k1 x y = y;
-        s f g x = f x (g x);
-        compose f g x = f (g x);
-        twice f x = f (f x);
-        fst p = casePair# p k;
-        snd p = casePair# p k1;
-        head l = caseList# l abort# k;
-        tail l = caseList# l abort# k1;
-        _length_cc x xs = (+#) 1 (length xs);
-        length l = caseList# l 0 length_cc;
-    |]
-    <>
-    -- primitive constructors need some specialised wiring:
-    Program
-        [ ScDef "False" [] $ Con 0 0
-        , ScDef "True" [] $ Con 1 0
-        , ScDef "MkPair" [] $ Con 0 2
-        , ScDef "Nil" [] $ Con 1 0
-        , ScDef "Cons" [] $ Con 2 2
-        ]
+-- corePrelude :: Module Name
+-- corePrelude = Module (Just ("Prelude", [])) $
+--     -- non-primitive defs
+--     [coreProg|
+--         id x = x;
+--         k x y = x;
+--         k1 x y = y;
+--         s f g x = f x (g x);
+--         compose f g x = f (g x);
+--         twice f x = f (f x);
+--         fst p = casePair# p k;
+--         snd p = casePair# p k1;
+--         head l = caseList# l abort# k;
+--         tail l = caseList# l abort# k1;
+--         _length_cc x xs = (+#) 1 (length xs);
+--         length l = caseList# l 0 length_cc;
+--     |]
+--     <>
+--     -- primitive constructors need some specialised wiring:
+--     Program
+--         [ ScDef "False" [] $ Con 0 0
+--         , ScDef "True" [] $ Con 1 0
+--         , ScDef "MkPair" [] $ Con 0 2
+--         , ScDef "Nil" [] $ Con 1 0
+--         , ScDef "Cons" [] $ Con 2 2
+--         ]

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

-%wrapper "monad"
+%wrapper "monad-strict-text"

 $whitechar = [ \t\n\r\f\v]
 $special   = [\(\)\,\;\[\]\{\}]
@@ -68,6 +74,7 @@ rlp :-
    "{"                     { constTok TokenLBrace }
    "}"                     { constTok TokenRBrace }
    ";"                     { constTok TokenSemicolon }
+    "::"                    { constTok TokenHasType }
    "@"                     { constTok TokenTypeApp }
    "{-#"                   { constTok TokenLPragma `andBegin` pragma }

@@ -80,7 +87,7 @@ rlp :-
    "where"                 { constTok TokenWhere }
    "Pack"                  { constTok TokenPack } -- temp

-    "\\"                    { constTok TokenLambda }
+    "\"                     { constTok TokenLambda }
    "λ"                     { constTok TokenLambda }
    "="                     { constTok TokenEquals }
    "->"                    { constTok TokenArrow }
@@ -90,7 +97,7 @@ rlp :-
    @varsym                 { lexWith TokenVarSym }
    @consym                 { lexWith TokenConSym }

-    @decimal                { lexWith (TokenLitInt . read @Int) }
+    @decimal                { lexWith (TokenLitInt . read @Int . T.unpack) }

    $white                  { skip }
    \n                      { skip }
@@ -134,10 +141,11 @@ data CoreToken = TokenLet
               | TokenLBrace
               | TokenRBrace
               | TokenSemicolon
+               | TokenHasType
               | TokenTypeApp
               | TokenLPragma
               | TokenRPragma
-               | TokenWord String
+               | TokenWord Text
               | TokenEOF
               deriving Show

@@ -155,25 +163,23 @@ data SrcErrorType = SrcErrLexical String

 type Lexer = AlexInput -> Int -> Alex (Located CoreToken)

-lexWith :: (String -> CoreToken) -> Lexer
-lexWith f (AlexPn _ y x,_,_,s) l = pure $ Located y x l (f $ take l s)
+lexWith :: (Text -> CoreToken) -> Lexer
+lexWith f (AlexPn _ y x,_,_,s) l = pure $ Located y x l (f $ T.take l s)

 -- | The main lexer driver.
-lexCore :: String -> RLPC SrcError [Located CoreToken]
+lexCore :: Text -> RLPC [Located CoreToken]
 lexCore s = case m of
-    Left e   -> addFatal err
-        where err = SrcError
-                { _errSpan       = (0,0,0) -- TODO: location
-                , _errSeverity   = Error
-                , _errDiagnostic = SrcErrLexical e
-                }
+    Left e   -> error "core lex error"
    Right ts -> pure ts
    where
        m = runAlex s lexStream

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

@@ -188,6 +194,14 @@ data ParseError = ParErrLexical String
                | ParErrParse
                deriving Show

+-- TODO:
+instance IsRlpcError SrcError where
+    liftRlpcError = Text . pure . T.pack . show
+
+-- TODO:
+instance IsRlpcError ParseError where
+    liftRlpcError = Text . pure . T.pack . show
+
 alexEOF :: Alex (Located CoreToken)
 alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) ->
    Right (st, Located y x 0 TokenEOF)
--- a/src/Core/Parse.y
+++ b/src/Core/Parse.y
@@ -3,12 +3,13 @@
 Module : Core.Parse
 Description : Parser for the Core language
 -}
+{-# LANGUAGE OverloadedStrings #-}
 module Core.Parse
    ( parseCore
    , parseCoreExpr
    , parseCoreProg
+    , parseCoreProgR
    , module Core.Lex -- temp convenience
-    , parseTmp
    , SrcError
    , Module
    )
@@ -19,7 +20,12 @@ import Data.Foldable        (foldl')
 import Core.Syntax
 import Core.Lex
 import Compiler.RLPC
+import Lens.Micro
 import Data.Default.Class   (def)
+import Data.Hashable        (Hashable)
+import Data.Text.IO         qualified as TIO
+import Data.Text            qualified as T
+import Data.HashMap.Strict  qualified as H
 }

 %name parseCore Module
@@ -27,7 +33,7 @@ import Data.Default.Class   (def)
 %name parseCoreProg StandaloneProgram
 %tokentype { Located CoreToken }
 %error { parseError }
-%monad { RLPC SrcError }
+%monad { RLPC } { happyBind } { happyPure }

 %token
      let             { Located _ _ _ TokenLet }
@@ -55,6 +61,7 @@ import Data.Default.Class   (def)
      '{-#'           { Located _ _ _ TokenLPragma }
      '#-}'           { Located _ _ _ TokenRPragma }
      ';'             { Located _ _ _ TokenSemicolon }
+      '::'            { Located _ _ _ TokenHasType }
      eof             { Located _ _ _ TokenEOF }

 %%
@@ -71,7 +78,17 @@ StandaloneProgram :: { Program Name }
 StandaloneProgram : Program eof                 { $1 }

 Program         :: { Program Name }
-Program         : ScDefs                        { Program $1 }
+Program         : ScTypeSig ';' Program         { insTypeSig $1 $3 }
+                | ScTypeSig OptSemi             { singletonTypeSig $1 }
+                | ScDef     ';' Program         { insScDef $1 $3 }
+                | ScDef     OptSemi             { singletonScDef $1 }
+
+OptSemi         :: { () }
+OptSemi         : ';'                           { () }
+                | {- epsilon -}                 { () }
+
+ScTypeSig       :: { (Name, Type) }
+ScTypeSig       : Var '::' Type                 { ($1,$3) }

 ScDefs          :: { [ScDef Name] }
 ScDefs          : ScDef ';' ScDefs              { $1 : $3 }
@@ -81,6 +98,18 @@ ScDefs          : ScDef ';' ScDefs              { $1 : $3 }

 ScDef           :: { ScDef Name }
 ScDef           : Var ParList '=' Expr          { ScDef $1 $2 $4 }
+                -- hack to allow constructors to be compiled into scs
+                | Con ParList '=' Expr          { ScDef $1 $2 $4 }
+
+Type            :: { Type }
+Type            : Type1                         { $1 }
+
+Type1           :: { Type }
+Type1           : '(' Type ')'                  { $2 }
+                | Type1 '->' Type               { $1 :-> $3 }
+                -- do we want to allow symbolic names for tyvars and tycons?
+                | varname                       { TyVar $1 }
+                | conname                       { TyCon $1 }

 ParList         :: { [Name] }
 ParList         : Var ParList                   { $1 : $2 }
@@ -123,7 +152,7 @@ Alter           :: { Alter Name }
 Alter           : litint ParList '->' Expr      { Alter (AltData $1) $2 $4 }

 Expr1           :: { Expr Name }
-Expr1           : litint                        { LitE $ IntL $1 }
+Expr1           : litint                        { Lit $ IntL $1 }
                | Id                            { Var $1 }
                | PackCon                       { $1 }
                | ExprPragma                    { $1 }
@@ -133,8 +162,8 @@ ExprPragma      :: { Expr Name }
 ExprPragma      : '{-#' Words '#-}'      {% exprPragma $2 }

 Words           :: { [String] }
-Words           : word Words                    { $1 : $2 }
-                | word                          { [$1] }
+Words           : word Words                    { T.unpack $1 : $2 }
+                | word                          { [T.unpack $1] }

 PackCon         :: { Expr Name }
 PackCon         : pack '{' litint litint '}'    { Con $3 $4 }
@@ -161,34 +190,44 @@ Con             : '(' consym ')'                    { $2 }

 {

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

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

-exprPragma :: [String] -> RLPC SrcError (Expr Name)
-exprPragma ("AST" : e) = astPragma e
-exprPragma _           = addFatal err
-    where err = SrcError
-            { _errSpan       = (0,0,0) -- TODO: span
-            , _errSeverity   = Warning
-            , _errDiagnostic = SrcErrUnknownPragma "" -- TODO: missing pragma
-            }
+exprPragma :: [String] -> RLPC (Expr Name)
+exprPragma ("AST" : e) = undefined
+exprPragma _           = undefined

-astPragma :: [String] -> RLPC SrcError (Expr Name)
-astPragma = pure . read . unwords
+{-# WARNING exprPragma "unimpl" #-}
+
+astPragma :: [String] -> RLPC (Expr Name)
+astPragma _ = undefined
+
+{-# WARNING astPragma "unimpl" #-}
+
+insTypeSig :: (Hashable b) => (b, Type) -> Program b -> Program b
+insTypeSig ts = programTypeSigs %~ uncurry H.insert ts
+
+singletonTypeSig :: (Hashable b) => (b, Type) -> Program b
+singletonTypeSig ts = insTypeSig ts mempty
+
+insScDef :: (Hashable b) => ScDef b -> Program b -> Program b
+insScDef sc = programScDefs %~ (sc:)
+
+singletonScDef :: (Hashable b) => ScDef b -> Program b
+singletonScDef sc = insScDef sc mempty
+
+parseCoreProgR :: [Located CoreToken] -> RLPC Program'
+parseCoreProgR = parseCoreProg
+
+happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b
+happyBind m k = m >>= k
+
+happyPure :: a -> RLPC a
+happyPure a = pure a

 }

--- a/src/Core/Syntax.hs
+++ b/src/Core/Syntax.hs
@@ -4,11 +4,15 @@ Description : Core ASTs and the like
 -}
 {-# LANGUAGE PatternSynonyms, OverloadedStrings #-}
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TemplateHaskell #-}
 module Core.Syntax
    ( Expr(..)
    , Type(..)
-    , Literal(..)
+    , pattern TyInt
+    , Lit(..)
    , pattern (:$)
+    , pattern (:@)
+    , pattern (:->)
    , Binding(..)
    , AltCon(..)
    , pattern (:=)
@@ -20,7 +24,9 @@ module Core.Syntax
    , Module(..)
    , Program(..)
    , Program'
+    , unliftScDef
    , programScDefs
+    , programTypeSigs
    , Expr'
    , ScDef'
    , Alter'
@@ -32,40 +38,51 @@ module Core.Syntax
 ----------------------------------------------------------------------------------
 import Data.Coerce
 import Data.Pretty
-import GHC.Generics
 import Data.List                    (intersperse)
 import Data.Function                ((&))
 import Data.String
+import Data.HashMap.Strict          qualified as H
+import Data.Hashable
+import Data.Text                    qualified as T
+import Data.Char
 -- Lift instances for the Core quasiquoters
 import Language.Haskell.TH.Syntax   (Lift)
+import Lens.Micro.TH                (makeLenses)
 import Lens.Micro
 ----------------------------------------------------------------------------------

 data Expr b = Var Name
-            | Con Tag Int -- Con Tag Arity
+            | Con Tag Int -- ^ Con Tag Arity
            | Case (Expr b) [Alter b]
            | Lam [b] (Expr b)
            | Let Rec [Binding b] (Expr b)
            | App (Expr b) (Expr b)
-            | LitE Literal
-            | Type Type
+            | Lit Lit
            deriving (Show, Read, Lift)

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

-data Type = TyInt
-          | TyFun
+data Type = TyFun
          | TyVar Name
          | TyApp Type Type
-          | TyConApp TyCon [Type]
+          | TyCon Name
          deriving (Show, Read, Lift, Eq)

-type TyCon = Name
+pattern TyInt :: Type
+pattern TyInt = TyCon "Int#"

 infixl 2 :$
-pattern (:$) :: Expr b  -> Expr b  -> Expr b 
+pattern (:$) :: Expr b -> Expr b -> Expr b 
 pattern f :$ x = App f x

+infixl 2 :@
+pattern (:@) :: Type -> Type -> Type
+pattern f :@ x = TyApp f x
+
+infixr 1 :->
+pattern (:->) :: Type -> Type -> Type
+pattern a :-> b = TyApp (TyApp TyFun a) b
+
 {-# COMPLETE Binding :: Binding #-}
 {-# COMPLETE (:=) :: Binding #-}
 data Binding b = Binding b (Expr b)
@@ -87,27 +104,33 @@ data Rec = Rec
         deriving (Show, Read, Eq, Lift)

 data AltCon = AltData Tag
-            | AltLiteral Literal
+            | AltLit Lit
            | Default
            deriving (Show, Read, Eq, Lift)

-data Literal = IntL Int
+data Lit = IntL Int
    deriving (Show, Read, Eq, Lift)

-type Name = String
+type Name = T.Text
 type Tag = Int

 data ScDef b = ScDef b [b] (Expr b)
    deriving (Show, Lift)

+unliftScDef :: ScDef b -> Expr b
+unliftScDef (ScDef _ as e) = Lam as e
+
 data Module b = Module (Maybe (Name, [Name])) (Program b)
    deriving (Show, Lift)

-newtype Program b = Program [ScDef b]
+data Program b = Program
+    { _programScDefs   :: [ScDef b]
+    , _programTypeSigs :: H.HashMap b Type
+    }
    deriving (Show, Lift)

-programScDefs :: Lens' (Program b) [ScDef b]
-programScDefs = lens coerce (const coerce)
+makeLenses ''Program
+pure []

 type Program' = Program Name
 type Expr' = Expr Name
@@ -116,13 +139,20 @@ type Alter' = Alter Name
 type Binding' = Binding Name

 instance IsString (Expr b) where
-    fromString = Var
+    fromString = Var . fromString

-instance Semigroup (Program b) where
-    (<>) = coerce $ (<>) @[ScDef b] 
+instance IsString Type where
+    fromString "" = error "IsString Type string may not be empty"
+    fromString s
+        | isUpper c     = TyCon . fromString $ s
+        | otherwise     = TyVar . fromString $ s
+        where (c:_) = s

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

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

--- a/src/Core/TH.hs
+++ b/src/Core/TH.hs
@@ -5,62 +5,46 @@ Description : Core quasiquoters
 module Core.TH
    ( coreExpr
    , coreProg
-    , core
+    , coreProgT
    )
    where
 ----------------------------------------------------------------------------------
 import Language.Haskell.TH
-import Language.Haskell.TH.Syntax hiding (Module)
+import Language.Haskell.TH.Syntax   hiding (Module)
 import Language.Haskell.TH.Quote
 import Control.Monad                ((>=>))
+import Control.Monad.IO.Class
+import Control.Arrow                ((>>>))
 import Compiler.RLPC
 import Data.Default.Class           (def)
+import Data.Text                    (Text)
+import Data.Text                    qualified as T
 import Core.Parse
 import Core.Lex
+import Core.Syntax
+import Core.HindleyMilner           (checkCoreProgR)
 ----------------------------------------------------------------------------------

-core :: QuasiQuoter
-core = QuasiQuoter
-    { quoteExp = qCore
-    , quotePat = error "core quasiquotes may only be used in expressions"
-    , quoteType = error "core quasiquotes may only be used in expressions"
-    , quoteDec = error "core quasiquotes may only be used in expressions"
-    }
-
 coreProg :: QuasiQuoter
-coreProg = QuasiQuoter
-    { quoteExp = qCoreProg
-    , quotePat = error "core quasiquotes may only be used in expressions"
-    , quoteType = error "core quasiquotes may only be used in expressions"
-    , quoteDec = error "core quasiquotes may only be used in expressions"
-    }
+coreProg = mkqq $ lexCoreR >=> parseCoreProgR

 coreExpr :: QuasiQuoter
-coreExpr = QuasiQuoter
-    { quoteExp = qCoreExpr
+coreExpr = mkqq $ lexCoreR >=> parseCoreExpr
+
+-- | Type-checked @coreProg@
+coreProgT :: QuasiQuoter
+coreProgT = mkqq $ lexCoreR >=> parseCoreProgR >=> checkCoreProgR
+
+mkqq :: (Lift a) => (Text -> RLPC a) -> QuasiQuoter
+mkqq p = QuasiQuoter
+    { quoteExp = mkq p
    , quotePat = error "core quasiquotes may only be used in expressions"
    , quoteType = error "core quasiquotes may only be used in expressions"
    , quoteDec = error "core quasiquotes may only be used in expressions"
    }

-qCore :: String -> Q Exp
-qCore s = case parse s of
-    Left e       -> error (show e)
-    Right (m,ts) -> lift m
-    where
-        parse = evalRLPC def . (lexCore >=> parseCore)
-
-qCoreExpr :: String -> Q Exp
-qCoreExpr s = case parseExpr s of
-    Left e       -> error (show e)
-    Right (m,ts) -> lift m
-    where
-        parseExpr = evalRLPC def . (lexCore >=> parseCoreExpr)
-
-qCoreProg :: String -> Q Exp
-qCoreProg s = case parseProg s of
-    Left e       -> error (show e)
-    Right (m,ts) -> lift m
-    where
-        parseProg = evalRLPC def . (lexCore >=> parseCoreProg)
+mkq :: (Lift a) => (Text -> RLPC a) -> String -> Q Exp
+mkq parse s = case evalRLPC def (parse $ T.pack s) of
+    (Just a,  _) -> lift a
+    (Nothing, _) -> error "todo: aaahhbbhjhbdjhabsjh"

--- a/src/Core/Utils.hs
+++ b/src/Core/Utils.hs
@@ -7,7 +7,7 @@ module Core.Utils
    ( bindersOf
    , rhssOf
    , isAtomic
-    , insertModule
+    -- , insertModule
    , extractProgram
    , freeVariables
    , ExprF(..)
@@ -19,6 +19,7 @@ import Data.Functor.Foldable
 import Data.Set                     (Set)
 import Data.Set                     qualified as S
 import Core.Syntax
+import Lens.Micro
 import GHC.Exts                     (IsList(..))
 ----------------------------------------------------------------------------------

@@ -32,14 +33,14 @@ rhssOf = fromList . fmap f

 isAtomic :: Expr b -> Bool
 isAtomic (Var _)  = True
-isAtomic (LitE _) = True
+isAtomic (Lit _)  = True
 isAtomic _        = False

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

 -- TODO: export list awareness
-insertModule :: Module b -> Program b -> Program b
-insertModule (Module _ m) p = p <> m
+-- insertModule :: Module b -> Program b -> Program b
+-- insertModule (Module _ p) = programScDefs %~ (<>m)

 extractProgram :: Module b -> Program b
 extractProgram (Module _ p) = p
--- a/src/Core2Core.hs
+++ b/src/Core2Core.hs
@@ -17,6 +17,7 @@ import Data.List
 import Control.Monad.Writer
 import Control.Monad.State
 import Control.Arrow            ((>>>))
+import Data.Text                qualified as T
 import Numeric                  (showHex)
 import Lens.Micro
 import Core.Syntax
@@ -27,7 +28,7 @@ core2core :: Program' -> Program'
 core2core p = undefined

 gmPrep :: Program' -> Program'
-gmPrep p = p' <> Program caseScs
+gmPrep p = p' & programScDefs %~ (<>caseScs)
    where
        rhss :: Applicative f => (Expr z -> f (Expr z)) -> Program z -> f (Program z)
        rhss = programScDefs . each . _rhs
@@ -46,7 +47,7 @@ type Floater = StateT [Name] (Writer [ScDef'])
 runFloater :: Floater a -> (a, [ScDef'])
 runFloater = flip evalStateT ns >>> runWriter
    where
-        ns = [ "$nonstrict_case_" ++ showHex n "" | n <- [0..] ]
+        ns = [ T.pack $ "$nonstrict_case_" ++ showHex n "" | n <- [0..] ]

 -- TODO: formally define a "strict context" and reference that here
 -- the returned ScDefs are guaranteed to be free of non-strict cases.
@@ -55,7 +56,7 @@ floatNonStrictCases g = goE
    where
        goE :: Expr' -> Floater Expr'
        goE (Var k)             = pure (Var k)
-        goE (LitE l)            = pure (LitE l)
+        goE (Lit l)             = pure (Lit l)
        goE (Case e as)         = pure (Case e as)
        goE (Let Rec bs e)      = Let Rec <$> bs' <*> goE e
            where bs' = travBs goE bs
@@ -77,7 +78,7 @@ floatNonStrictCases g = goE
        goC (f :$ x)            = (:$) <$> goC f <*> goC x
        goC (Let r bs e)        = Let r <$> bs' <*> goE e
            where bs' = travBs goC bs
-        goC (LitE l)            = pure (LitE l)
+        goC (Lit l)             = pure (Lit l)
        goC (Var k)             = pure (Var k)
        goC (Con t as)          = pure (Con t as)

--- a/src/GM.hs
+++ b/src/GM.hs
@@ -22,7 +22,10 @@ import Data.Maybe                   (fromMaybe, mapMaybe)
 import Data.Monoid                  (Endo(..))
 import Data.Tuple                   (swap)
 import Lens.Micro
+import Lens.Micro.Extras            (view)
 import Lens.Micro.TH
+import Lens.Micro.Platform          (packed, unpacked)
+import Lens.Micro.Platform.Internal (IsText(..))
 import Text.Printf
 import Text.PrettyPrint             hiding ((<>))
 import Text.PrettyPrint.HughesPJ    (maybeParens)
@@ -281,7 +284,7 @@ step st = case head (st ^. gmCode) of
                m = st ^. gmEnv
                s = st ^. gmStack
                h = st ^. gmHeap
-                n' = show n
+                n' = show n ^. packed

        -- Core Rule 2. (no sharing)
        -- pushIntI :: Int -> GmState
@@ -582,7 +585,7 @@ compiledPrims =
        binop k i = (k, 2, [Push 1, Eval, Push 1, Eval, i, Update 2, Pop 2, Unwind])

 buildInitialHeap :: Program' -> (GmHeap, Env)
-buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
+buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compiledScs
    where
        compiledScs = fmap compileSc ss <> compiledPrims

@@ -612,12 +615,13 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
            | k `elem` domain  = [Push n]
            | otherwise        = [PushGlobal k]
            where
-                n = fromMaybe (error $ "undeclared var: " <> k) $ lookupN k g
+                n = fromMaybe err $ lookupN k g
+                err = error $ "undeclared var: " <> (k ^. unpacked)
                domain = f `mapMaybe` g
                f (NameKey n, _) = Just n
                f _              = Nothing

-        compileC _ (LitE l)  = compileCL l
+        compileC _ (Lit l)   = compileCL l

        -- >> [ref/compileC]
        compileC g (App f x) = compileC g x
@@ -661,16 +665,16 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs

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

-        compileCL :: Literal -> Code
+        compileCL :: Lit -> Code
        compileCL (IntL n) = [PushInt n]

-        compileEL :: Literal -> Code
+        compileEL :: Lit -> Code
        compileEL (IntL n) = [PushInt n]

        -- compile an expression in a strict context such that a pointer to the
        -- expression is left on top of the stack in WHNF
        compileE :: Env -> Expr' -> Code
-        compileE _ (LitE l) = compileEL l
+        compileE _ (Lit l) = compileEL l
        compileE g (Let NonRec bs e) =
                -- we use compileE instead of compileC
                mconcat binders <> compileE g' e <> [Slide d]
@@ -738,8 +742,8 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
        argOffset :: Int -> Env -> Env
        argOffset n = each . _2 %~ (+n)

-idPack :: Tag -> Int -> String
-idPack t n = printf "Pack{%d %d}" t n
+showCon :: (IsText a) => Tag -> Int -> a
+showCon t n = printf "Pack{%d %d}" t n ^. packed

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

@@ -855,12 +859,12 @@ showNodeAt = showNodeAtP 0
 showNodeAtP :: Int -> GmState -> Addr -> Doc
 showNodeAtP p st a = case hLookup a h of
    Just (NNum n)        -> int n <> "#"
-    Just (NGlobal _ _)   -> text name
+    Just (NGlobal _ _)   -> textt name
        where
            g = st ^. gmEnv
            name = case lookup a (swap <$> g) of
                Just (NameKey n)     -> n
-                Just (ConstrKey t n) -> idPack t n
+                Just (ConstrKey t n) -> showCon t n
                _                    -> errTxtInvalidAddress
    -- TODO: left-associativity
    Just (NAp f x)       -> pprec $ showNodeAtP (p+1) st f
@@ -877,7 +881,7 @@ showNodeAtP p st a = case hLookup a h of
        pprec = maybeParens (p > 0)

 showSc :: GmState -> (Name, Addr) -> Doc
-showSc st (k,a) = "Supercomb " <> qquotes (text k) <> colon
+showSc st (k,a) = "Supercomb " <> qquotes (textt k) <> colon
               $$ code
    where
        code = case hLookup a (st ^. gmHeap) of
@@ -900,6 +904,9 @@ showInstr (CaseJump alts) = "CaseJump" $$ nest pprTabstop alternatives
        alternatives = foldr (\a acc -> showAlt a $$ acc) mempty alts
 showInstr i = text $ show i

+textt :: (IsText a) => a -> Doc
+textt t = t ^. unpacked & text
+
 ----------------------------------------------------------------------------------

 lookupN :: Name -> Env -> Maybe Addr
@@ -975,7 +982,8 @@ resultOf p = do
        h = st ^. gmHeap

 resultOfExpr :: Expr' -> Maybe Node
-resultOfExpr e = resultOf $ Program
-    [ ScDef "main" [] e
-    ]
+resultOfExpr e = resultOf $
+    mempty & programScDefs .~
+                [ ScDef "main" [] e
+                ]

--- a/src/RLP/Syntax.hs
+++ b/src/RLP/Syntax.hs
@@ -1,59 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module RLP.Syntax
-    ( RlpExpr
-    )
-    where
----------------------------------------------------------------------------------
-import Data.Text                    (Text)
-import Lens.Micro
-import Core                         (HasRHS(..), HasLHS(..))
----------------------------------------------------------------------------------
-
-newtype RlpProgram b = RlpProgram [Decl b]
-
-data Decl b = InfixD  InfixAssoc Int VarId
-            | FunD    VarId [Pat b] (RlpExpr b)
-            | DataD   ConId [ConId] [ConAlt]
-
-data ConAlt = ConAlt ConId [ConId]
-
-data InfixAssoc = Assoc | AssocL | AssocR
-
-data RlpExpr b = LetE  [Bind b] (RlpExpr b)
-               | VarE  VarId
-               | ConE  ConId
-               | LamE  [Pat b] (RlpExpr b)
-               | CaseE (RlpExpr b) [Alt b]
-               | IfE   (RlpExpr b) (RlpExpr b) (RlpExpr b)
-               | AppE  (RlpExpr b) (RlpExpr b)
-               | LitE  (Lit b)
-
-- do we want guards?
-data Alt b = AltA (Pat b) (RlpExpr b)
-
-data Bind b = PatB (Pat b) (RlpExpr b)
-            | FunB VarId [Pat b] (RlpExpr b)
-
-data VarId = NameVar Text
-           | SymVar Text
-
-data ConId = NameCon Text
-           | SymCon Text
-
-data Pat b = VarP VarId
-           | LitP (Lit b)
-           | ConP ConId [Pat b]
-
-data Lit b = IntL Int
-           | CharL Char
-           | ListL [RlpExpr b]
-
-- instance HasLHS Alt Alt Pat Pat where
--     _lhs = lens
--         (\ (AltA p _) -> p)
--         (\ (AltA _ e) p' -> AltA p' e)
-
-- instance HasRHS Alt Alt RlpExpr RlpExpr where
--     _rhs = lens
--         (\ (AltA _ e) -> e)
--         (\ (AltA p _) e' -> AltA p e')
--- a/src/Rlp/Lex.x
+++ b/src/Rlp/Lex.x
@@ -0,0 +1,349 @@
+{
+{-# LANGUAGE ViewPatterns, LambdaCase #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Rlp.Lex
+    ( P(..)
+    , RlpToken(..)
+    , Located(..)
+    , lexToken
+    , lexStream
+    , lexDebug
+    , lexCont
+    )
+    where
+import Codec.Binary.UTF8.String (encodeChar)
+import Control.Monad
+import Control.Monad.Errorful
+import Core.Syntax              (Name)
+import Data.Functor.Identity
+import Data.Char                (digitToInt)
+import Data.Monoid              (First)
+import Data.Maybe
+import Data.Text                (Text)
+import Data.Text                qualified as T
+import Data.Word
+import Data.Default
+import Lens.Micro.Mtl
+import Lens.Micro
+
+import Debug.Trace
+import Rlp.Parse.Types
+}
+
+$whitechar      = [ \t\n\r\f\v]
+
+$nl             = [\n\r]
+$white_no_nl    = $white # $nl
+
+$lower          = [a-z \_]
+$upper          = [A-Z]
+$alpha          = [$lower $upper]
+$digit          = 0-9
+
+$special        = [\(\)\,\;\[\]\{\}]
+$namechar       = [$alpha $digit \' \#]
+$asciisym       = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
+
+@decimal        = $digit+
+
+@varname        = $lower $namechar*
+@conname        = $upper $namechar*
+@consym         = \: $asciisym*
+@varsym         = $asciisym+
+
+@reservedname = 
+    case|data|do|import|in|let|letrec|module|of|where
+    |infixr|infixl|infix
+
+@reservedop =
+    "=" | \\ | "->" | "|"
+
+rlp :-
+    
+-- everywhere: skip whitespace
+$white_no_nl+       ;
+
+-- everywhere: skip comments
+-- TODO: don't treat operators like (-->) as comments
+"--".*              ;
+
+-- we are indentation-sensitive! do not skip NLs!. upon encountering a newline,
+-- we check indentation and potentially insert extra tokens. search this file
+-- for the definition of `doBol`
+<0> \n                  { beginPush bol }
+
+-- scan various identifiers and reserved words. order is important here!
+<0>
+{
+    @reservedname       { tokenWith lexReservedName }
+    @conname            { tokenWith TokenConName }
+    @varname            { tokenWith TokenVarName }
+    @reservedop         { tokenWith lexReservedOp }
+    @consym             { tokenWith TokenConSym }
+    @varsym             { tokenWith TokenVarSym }
+}
+
+-- literals -- currently this is just unsigned integer literals
+<0>
+{
+    @decimal            { tokenWith (TokenLitInt . readInt) }
+}
+
+-- control characters
+<0>
+{
+    "("                 { constToken TokenLParen }
+    ")"                 { constToken TokenRParen }
+    "{"                 { explicitLBrace }
+    "}"                 { explicitRBrace }
+    ";"                 { constToken TokenSemicolon }
+}
+
+-- consume all whitespace leaving us at the beginning of the next non-empty
+-- line. we then compare the indentation of that line to the enclosing layout
+-- context and proceed accordingly
+<bol>
+{
+    $whitechar          ;
+    \n                  ;
+    ()                  { doBol }
+}
+
+<layout_top>
+{
+    \n                  ;
+    "{"                 { explicitLBrace `thenDo` popLexState }
+    ()                  { doLayout }
+}
+
+{
+
+lexReservedName :: Text -> RlpToken
+lexReservedName = \case
+    "data"      -> TokenData
+    "case"      -> TokenCase
+    "of"        -> TokenOf
+    "let"       -> TokenLet
+    "in"        -> TokenIn
+    "infix"     -> TokenInfix
+    "infixl"    -> TokenInfixL
+    "infixr"    -> TokenInfixR
+
+lexReservedOp :: Text -> RlpToken
+lexReservedOp = \case
+    "="     -> TokenEquals
+    "::"    -> TokenHasType
+    "|"     -> TokenPipe
+
+-- | @andBegin@, with the subtle difference that the start code is set
+--   /after/ the action
+thenBegin :: LexerAction a -> Int -> LexerAction a
+thenBegin act c inp l = do
+    a <- act inp l
+    psLexState . _head .= c
+    pure a
+
+andBegin :: LexerAction a -> Int -> LexerAction a
+andBegin act c inp l = do
+    psLexState . _head .= c
+    act inp l
+
+beginPush :: Int -> LexerAction (Located RlpToken)
+beginPush n _ _ = pushLexState n >> lexToken
+
+alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)
+alexGetByte inp = case inp ^. aiBytes of
+    [] -> do
+        (c,t) <- T.uncons (inp ^. aiSource)
+        let (b:bs) = encodeChar c
+                       -- tail the source
+            inp' = inp & aiSource .~ t
+                       -- record the excess bytes for successive calls
+                       & aiBytes .~ bs
+                       -- report the previous char
+                       & aiPrevChar .~ c
+                       -- update the position
+                       & aiPos %~ \ (ln,col) ->
+                                   if c == '\n'
+                                   then (ln+1,1)
+                                   else (ln,col+1)
+        pure (b, inp')
+    
+    _ -> Just (head bs, inp')
+        where
+            (bs, inp') = inp & aiBytes <<%~ drop 1
+
+getInput :: P AlexInput
+getInput = use psInput
+
+getLexState :: P Int
+getLexState = use (psLexState . singular _head)
+
+alexInputPrevChar :: AlexInput -> Char
+alexInputPrevChar = view aiPrevChar
+
+pushLexState :: Int -> P ()
+pushLexState n = psLexState %= (n:)
+
+readInt :: Text -> Int
+readInt = T.foldr f 0 where
+    f c n = digitToInt c + 10*n
+
+constToken :: RlpToken -> LexerAction (Located RlpToken)
+constToken t inp l = do
+    pos <- use (psInput . aiPos)
+    pure (Located (pos,l) t)
+
+tokenWith :: (Text -> RlpToken) -> LexerAction (Located RlpToken)
+tokenWith tf inp l = do
+    pos <- getPos
+    let t = tf (T.take l $ inp ^. aiSource)
+    pure (Located (pos,l) t)
+
+getPos :: P Position
+getPos = use (psInput . aiPos)
+
+alexEOF :: P (Located RlpToken)
+alexEOF = do
+    inp <- getInput
+    pure (Located undefined TokenEOF)
+
+initParseState :: Text -> ParseState
+initParseState s = ParseState
+    { _psLayoutStack = []
+    -- IMPORTANT: the initial state is `bol` to begin the top-level layout,
+    -- which then returns to state 0 which continues the normal lexing process.
+    , _psLexState = [layout_top,0]
+    , _psInput = initAlexInput s
+    , _psOpTable = mempty
+    }
+
+initAlexInput :: Text -> AlexInput
+initAlexInput s = AlexInput
+    { _aiPrevChar   = '\0'
+    , _aiSource     = s
+    , _aiBytes      = []
+    , _aiPos        = (1,1)
+    }
+
+runP' :: P a -> Text -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
+runP' p s = runP p st where
+    st = initParseState s
+
+lexToken :: P (Located RlpToken)
+lexToken = do
+    inp <- getInput
+    c <- getLexState
+    st <- use id
+    -- traceM $ "st: " <> show st
+    case alexScan inp c of
+        AlexEOF -> pure $ Located (inp ^. aiPos, 0) TokenEOF
+        AlexSkip inp' l -> do
+            psInput .= inp'
+            lexToken
+        AlexToken inp' l act -> do
+            psInput .= inp'
+            act inp l
+        AlexError inp' -> addFatalHere 1 RlpParErrLexical
+
+lexCont :: (Located RlpToken -> P a) -> P a
+lexCont = (lexToken >>=)
+
+lexStream :: P [RlpToken]
+lexStream = do
+    t <- lexToken
+    case t of
+        Located _ TokenEOF -> pure [TokenEOF]
+        Located _ t        -> (t:) <$> lexStream
+
+lexDebug :: (Located RlpToken -> P a) -> P a
+lexDebug k = do
+    t <- lexToken
+    traceM $ "token: " <> show t
+    k t
+
+lexTest :: Text -> Maybe [RlpToken]
+lexTest s = runP' lexStream s ^. _3
+
+indentLevel :: P Int
+indentLevel = do
+    pos <- use (psInput . aiPos)
+    pure (pos ^. _2)
+
+insertToken :: RlpToken -> P (Located RlpToken)
+insertToken t = do
+    pos <- use (psInput . aiPos)
+    pure (Located (pos, 0) t)
+
+popLayout :: P Layout
+popLayout = do
+    -- traceM "pop layout"
+    ctx <- preuse (psLayoutStack . _head)
+    psLayoutStack %= (drop 1)
+    case ctx of
+        Just l      -> pure l
+        Nothing     -> error "uhh"
+
+pushLayout :: Layout -> P ()
+pushLayout l = do
+    -- traceM "push layout"
+    psLayoutStack %= (l:)
+
+popLexState :: P ()
+popLexState = do
+    psLexState %= tail
+
+insertSemicolon, insertLBrace, insertRBrace :: P (Located RlpToken)
+insertSemicolon = {- traceM "inserting semi"   >> -} insertToken TokenSemicolonV
+insertLBrace    = {- traceM "inserting lbrace" >> -} insertToken TokenLBraceV
+insertRBrace    = {- traceM "inserting rbrace" >> -} insertToken TokenRBraceV
+
+cmpLayout :: P Ordering
+cmpLayout = do
+    i <- indentLevel
+    ctx <- preuse (psLayoutStack . _head)
+    case ctx of
+        Just (Implicit n) -> pure (i `compare` n)
+        _                 -> pure GT
+
+doBol :: LexerAction (Located RlpToken)
+doBol inp l = do
+    off <- cmpLayout
+    i <- indentLevel
+    traceM $ "i: " <> show i
+    -- important that we pop the lex state lest we find our lexer diverging
+    popLexState
+    case off of
+        -- the line is aligned with the previous. it therefore belongs to the
+        -- same list
+        EQ -> insertSemicolon
+        -- the line is indented further than the previous, so we assume it is a
+        -- line continuation. ignore it and move on!
+        GT -> lexToken
+        -- the line is indented less than the previous, pop the layout stack and
+        -- insert a closing brace.
+        LT -> popLayout >> insertRBrace
+
+thenDo :: LexerAction a -> P b -> LexerAction a
+thenDo act p inp l = act inp l <* p
+
+explicitLBrace :: LexerAction (Located RlpToken)
+explicitLBrace inp l = do
+    pushLayout Explicit
+    constToken TokenLBrace inp l
+
+explicitRBrace :: LexerAction (Located RlpToken)
+explicitRBrace inp l = do
+    popLayout
+    constToken TokenRBrace inp l
+
+doLayout :: LexerAction (Located RlpToken)
+doLayout _ _ = do
+    i <- indentLevel
+    pushLayout (Implicit i)
+    popLexState
+    insertLBrace
+
+}
+
--- a/src/Rlp/Parse.y
+++ b/src/Rlp/Parse.y
@@ -0,0 +1,181 @@
+{
+{-# LANGUAGE LambdaCase #-}
+module Rlp.Parse
+    ( parseRlpProg
+    )
+    where
+import Compiler.RlpcError
+import Rlp.Lex
+import Rlp.Syntax
+import Rlp.Parse.Types
+import Rlp.Parse.Associate
+import Lens.Micro
+import Lens.Micro.Mtl
+import Lens.Micro.Platform          ()
+import Data.List.Extra
+import Data.Fix
+import Data.Functor.Const
+import Data.Text                    qualified as T
+}
+
+%name parseRlpProg StandaloneProgram
+
+%monad { P }
+%lexer { lexCont } { Located _ TokenEOF }
+%error { parseError }
+%tokentype { Located RlpToken }
+
+%token
+    varname         { Located _ (TokenVarName $$) }
+    conname         { Located _ (TokenConName $$) }
+    consym          { Located _ (TokenConSym $$) }
+    varsym          { Located _ (TokenVarSym $$) }
+    data            { Located _ TokenData }
+    litint          { Located _ (TokenLitInt $$) }
+    '='             { Located _ TokenEquals }
+    '|'             { Located _ TokenPipe }
+    ';'             { Located _ TokenSemicolon }
+    '('             { Located _ TokenLParen }
+    ')'             { Located _ TokenRParen }
+    '->'            { Located _ TokenArrow }
+    vsemi           { Located _ TokenSemicolonV }
+    '{'             { Located _ TokenLBrace }
+    '}'             { Located _ TokenRBrace }
+    vlbrace         { Located _ TokenLBraceV }
+    vrbrace         { Located _ TokenRBraceV }
+    infixl          { Located _ TokenInfixL }
+    infixr          { Located _ TokenInfixR }
+    infix           { Located _ TokenInfix }
+
+%right '->'
+
+%%
+
+StandaloneProgram   :: { RlpProgram' }
+StandaloneProgram   : '{' Decls  '}'        {% mkProgram $2 }
+                    | VL  DeclsV VR         {% mkProgram $2 }
+
+VL  :: { () }
+VL  : vlbrace       { () }
+
+VR  :: { () }
+VR  : vrbrace       { () }
+    | error         { () }
+
+Decls               :: { [PartialDecl'] }
+Decls               : Decl ';' Decls        { $1 : $3 }
+                    | Decl ';'              { [$1] }
+                    | Decl                  { [$1] }
+
+DeclsV              :: { [PartialDecl'] }
+DeclsV              : Decl VS Decls         { $1 : $3 }
+                    | Decl VS               { [$1] }
+                    | Decl                  { [$1] }
+
+VS                  :: { Located RlpToken }
+VS                  : ';'                   { $1 }
+                    | vsemi                 { $1 }
+
+Decl        :: { PartialDecl' }
+            : FunDecl                   { $1 }
+            | DataDecl                  { $1 }
+            | InfixDecl                 { $1 }
+
+InfixDecl   :: { PartialDecl' }
+            : InfixWord litint InfixOp  {% mkInfixD $1 $2 $3 }
+
+InfixWord   :: { Assoc }
+            : infixl                    { InfixL }
+            | infixr                    { InfixR }
+            | infix                     { Infix  }
+
+DataDecl    :: { PartialDecl' }
+            : data Con TyParams '=' DataCons    { DataD $2 $3 $5 }
+
+TyParams    :: { [Name] }
+            : {- epsilon -}             { [] }
+            | TyParams varname          { $1 `snoc` $2 }
+
+DataCons    :: { [ConAlt] }
+            : DataCons '|' DataCon      { $1 `snoc` $3 }
+            | DataCon                   { [$1] }
+
+DataCon     :: { ConAlt }
+            : Con Type1s                { ConAlt $1 $2 }
+
+Type1s      :: { [Type] }
+            : {- epsilon -}             { [] }
+            | Type1s Type1              { $1 `snoc` $2 }
+
+Type1       :: { Type }
+            : '(' Type ')'              { $2 }
+            | conname                   { TyCon $1 }
+            | varname                   { TyVar $1 }
+
+Type        :: { Type }
+            : Type '->' Type            { $1 :-> $3 }
+            | Type1                     { $1 }
+
+FunDecl     :: { PartialDecl' }
+FunDecl     : Var Params '=' Expr       { FunD $1 $2 (Const $4) Nothing }
+
+Params      :: { [Pat'] }
+Params      : {- epsilon -}             { [] }
+            | Params Pat1               { $1 `snoc` $2 }
+
+Pat1        :: { Pat' }
+            : Var                       { VarP $1 }
+            | Lit                       { LitP $1 }
+
+Expr        :: { PartialExpr' }
+            : Expr1 varsym Expr         { Fix $ B $2 (unFix $1) (unFix $3) }
+            | Expr1                     { $1 }
+
+Expr1       :: { PartialExpr' }
+            : '(' Expr ')'              { wrapFix . Par . unwrapFix $ $2 }
+            | Lit                       { Fix . E $ LitEF $1 }
+            | Var                       { Fix . E $ VarEF $1 }
+
+-- TODO: happy prefers left-associativity. doing such would require adjusting
+-- the code in Rlp.Parse.Associate to expect left-associative input rather than
+-- right.
+InfixExpr   :: { PartialExpr' }
+            : Expr1 varsym Expr         { Fix $ B $2 (unFix $1) (unFix $3) }
+
+InfixOp     :: { Name }
+            : consym                    { $1 }
+            | varsym                    { $1 }
+
+Lit         :: { Lit' }
+Lit         : litint                    { IntL $1 }
+
+Var         :: { VarId }
+Var         : varname                   { NameVar $1 }
+
+Con         :: { ConId }
+            : conname                   { NameCon $1 }
+
+{
+
+mkProgram :: [PartialDecl'] -> P RlpProgram'
+mkProgram ds = do
+    pt <- use psOpTable
+    pure $ RlpProgram (associate pt <$> ds)
+
+parseError :: Located RlpToken -> P a
+parseError (Located ((l,c),s) t) = addFatal $
+    errorMsg (SrcSpan l c s) RlpParErrUnexpectedToken
+
+mkInfixD :: Assoc -> Int -> Name -> P PartialDecl'
+mkInfixD a p n = do
+    let opl :: Lens' ParseState (Maybe OpInfo)
+        opl = psOpTable . at n
+    opl <~ (use opl >>= \case
+        Just o  -> addWoundHere l e >> pure (Just o) where
+            e = RlpParErrDuplicateInfixD n
+            l = T.length n
+        Nothing -> pure (Just (a,p))
+        )
+    pure $ InfixD a p n
+
+}
--- a/src/Rlp/Parse/Associate.hs
+++ b/src/Rlp/Parse/Associate.hs
@@ -0,0 +1,100 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms, ViewPatterns, ImplicitParams #-}
+module Rlp.Parse.Associate
+    ( associate
+    )
+    where
+--------------------------------------------------------------------------------
+import Data.HashMap.Strict              qualified as H
+import Data.Functor.Foldable
+import Data.Functor.Const
+import Lens.Micro
+import Rlp.Parse.Types
+import Rlp.Syntax
+--------------------------------------------------------------------------------
+
+associate :: OpTable -> PartialDecl' -> Decl' RlpExpr
+associate pt (FunD n as b w)    = FunD n as b' w
+    where b' = let ?pt = pt in completeExpr (getConst b)
+associate pt (TySigD ns t)      = TySigD ns t
+associate pt (DataD n as cs)    = DataD n as cs
+associate pt (InfixD a p n)     = InfixD a p n
+
+completeExpr :: (?pt :: OpTable) => PartialExpr' -> RlpExpr'
+completeExpr = cata completePartial
+
+completePartial :: (?pt :: OpTable) => PartialE -> RlpExpr'
+completePartial (E e)        = completeRlpExpr e
+completePartial p@(B o l r)  = completeB (build p)
+completePartial (Par e)      = completePartial e
+
+completeRlpExpr :: (?pt :: OpTable) => RlpExprF' RlpExpr' -> RlpExpr'
+completeRlpExpr = embed
+
+completeB :: (?pt :: OpTable) => PartialE -> RlpExpr'
+completeB p = case build p of
+    B o l r     -> (o' `AppE` l') `AppE` r'
+        where
+            -- TODO: how do we know it's symbolic?
+            o' = VarE (SymVar o)
+            l' = completeB l
+            r' = completeB r
+    Par e       -> completeB e
+    E e         -> completeRlpExpr e
+
+build :: (?pt :: OpTable) => PartialE -> PartialE
+build e = go id e (rightmost e) where
+    rightmost :: PartialE -> PartialE
+    rightmost (B _ _ r) = rightmost r
+    rightmost p@(E _)   = p
+    rightmost p@(Par _) = p
+
+    go :: (?pt :: OpTable)
+       => (PartialE -> PartialE)
+       -> PartialE -> PartialE -> PartialE
+    go f p@(WithInfo o _ r) = case r of
+            E _     -> mkHole o (f . f')
+            Par _   -> mkHole o (f . f')
+            B _ _ _ -> go (mkHole o (f . f')) r
+        where f' r' = p & pR .~ r'
+    go f _ = id
+
+mkHole :: (?pt :: OpTable)
+       => OpInfo
+       -> (PartialE -> PartialE)
+       -> PartialE
+       -> PartialE
+mkHole _     hole p@(Par _)                 = hole p
+mkHole _     hole p@(E _)                   = hole p
+mkHole (a,d) hole p@(WithInfo (a',d') _ _)
+    | d' < d  = above
+    | d' > d  = below
+    | d == d' = case (a,a') of
+                  -- left-associative operators of equal precedence are
+                  -- associated left
+                  (InfixL,InfixL) -> above
+                  -- right-associative operators are handled similarly
+                  (InfixR,InfixR) -> below
+                  -- non-associative operators of equal precedence, or equal
+                  -- precedence operators of different associativities are
+                  -- invalid
+                  (_,     _)      -> error "invalid expression"
+    where
+        above = p & pL %~ hole
+        below = hole p
+
+examplePrecTable :: OpTable
+examplePrecTable = H.fromList
+    [ ("+",    (InfixL,6))
+    , ("*",    (InfixL,7))
+    , ("^",    (InfixR,8))
+    , (".",    (InfixR,7))
+    , ("~",    (Infix, 9))
+    , ("=",    (Infix, 4))
+    , ("&&",   (Infix, 3))
+    , ("||",   (Infix, 2))
+    , ("$",    (InfixR,0))
+    , ("&",    (InfixL,0))
+    ]
+
+
--- a/src/Rlp/Parse/Types.hs
+++ b/src/Rlp/Parse/Types.hs
@@ -0,0 +1,242 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
+{-# LANGUAGE LambdaCase #-}
+module Rlp.Parse.Types
+    ( LexerAction
+    , MsgEnvelope(..)
+    , RlpcError(..)
+    , AlexInput(..)
+    , Position(..)
+    , RlpToken(..)
+    , P(..)
+    , ParseState(..)
+    , psLayoutStack
+    , psLexState
+    , psInput
+    , psOpTable
+    , Layout(..)
+    , Located(..)
+    , OpTable
+    , OpInfo
+    , RlpParseError(..)
+    , PartialDecl'
+    , Partial(..)
+    , pL, pR
+    , PartialE
+    , pattern WithInfo
+    , opInfoOrDef
+    , PartialExpr'
+    , aiPrevChar
+    , aiSource
+    , aiBytes
+    , aiPos
+    , addFatal
+    , addWound
+    , addFatalHere
+    , addWoundHere
+    )
+    where
+--------------------------------------------------------------------------------
+import Core.Syntax                  (Name)
+import Control.Monad
+import Control.Monad.State.Strict
+import Control.Monad.Errorful
+import Compiler.RlpcError
+import Data.Text                    (Text)
+import Data.Maybe
+import Data.Fix
+import Data.Functor.Foldable
+import Data.Functor.Const
+import Data.Functor.Classes
+import Data.HashMap.Strict          qualified as H
+import Data.Word                    (Word8)
+import Lens.Micro.TH
+import Lens.Micro
+import Rlp.Syntax
+--------------------------------------------------------------------------------
+
+type LexerAction a = AlexInput -> Int -> P a
+
+data AlexInput = AlexInput
+    { _aiPrevChar   :: Char
+    , _aiSource     :: Text
+    , _aiBytes      :: [Word8]
+    , _aiPos        :: Position
+    }
+    deriving Show
+
+type Position =
+    ( Int -- line
+    , Int -- column
+    )
+
+posLine :: Lens' Position Int
+posLine = _1
+
+posColumn :: Lens' Position Int
+posColumn = _2
+
+data RlpToken
+    -- literals
+    = TokenLitInt Int
+    -- identifiers
+    | TokenVarName Name
+    | TokenConName Name
+    | TokenVarSym Name
+    | TokenConSym Name
+    -- reserved words
+    | TokenData
+    | TokenCase
+    | TokenOf
+    | TokenLet
+    | TokenIn
+    | TokenInfixL
+    | TokenInfixR
+    | TokenInfix
+    -- reserved ops
+    | TokenArrow
+    | TokenPipe
+    | TokenHasType
+    | TokenLambda
+    | TokenEquals
+    -- control symbols
+    | TokenSemicolon
+    | TokenLBrace
+    | TokenRBrace
+    | TokenLParen
+    | TokenRParen
+    -- 'virtual' control symbols, inserted by the lexer without any correlation
+    -- to a specific symbol
+    | TokenSemicolonV
+    | TokenLBraceV
+    | TokenRBraceV
+    | TokenEOF
+    deriving (Show)
+
+newtype P a = P {
+        runP :: ParseState
+             -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
+    }
+    deriving (Functor)
+
+instance Applicative P where
+    pure a = P $ \st -> (st, [], pure a)
+    liftA2 = liftM2
+
+instance Monad P where
+    p >>= k = P $ \st ->
+        let (st',es,ma) = runP p st
+        in case ma of
+            Just a  -> runP (k a) st'
+                     & _2 %~ (es<>)
+            Nothing -> (st',es,Nothing)
+
+    {-# INLINE (>>=) #-}
+
+instance MonadState ParseState P where
+    state f = P $ \st ->
+        let (a,st') = f st
+        in (st', [], Just a)
+
+instance MonadErrorful (MsgEnvelope RlpParseError) P where
+    addWound e = P $ \st -> (st, [e], Just ())
+    addFatal e = P $ \st -> (st, [e], Nothing)
+
+data ParseState = ParseState
+    { _psLayoutStack        :: [Layout]
+    , _psLexState           :: [Int]
+    , _psInput              :: AlexInput
+    , _psOpTable            :: OpTable
+    }
+    deriving Show
+
+data Layout = Explicit
+            | Implicit Int
+            deriving (Show, Eq)
+
+data Located a = Located (Position, Int) a
+    deriving (Show)
+
+type OpTable = H.HashMap Name OpInfo
+type OpInfo = (Assoc, Int)
+
+-- data WithLocation a = WithLocation [String] a
+
+data RlpParseError = RlpParErrOutOfBoundsPrecedence Int
+                   | RlpParErrDuplicateInfixD Name
+                   | RlpParErrLexical
+                   | RlpParErrUnexpectedToken
+                   deriving (Eq, Ord, Show)
+
+instance IsRlpcError RlpParseError where
+
+----------------------------------------------------------------------------------
+-- absolute psycho shit (partial ASTs)
+
+type PartialDecl' = Decl (Const PartialExpr') Name
+
+data Partial a = E (RlpExprF Name a)
+               | B Name (Partial a) (Partial a)
+               | Par (Partial a)
+               deriving (Show, Functor)
+
+pL :: Traversal' (Partial a) (Partial a)
+pL k (B o l r) = (\l' -> B o l' r) <$> k l
+pL _ x         = pure x
+
+pR :: Traversal' (Partial a) (Partial a)
+pR k (B o l r) = (\r' -> B o l r') <$> k r
+pR _ x         = pure x
+
+type PartialE = Partial RlpExpr'
+
+-- i love you haskell
+pattern WithInfo :: (?pt :: OpTable) => OpInfo -> PartialE -> PartialE -> PartialE
+pattern WithInfo p l r <- B (opInfoOrDef -> p) l r
+
+opInfoOrDef :: (?pt :: OpTable) => Name -> OpInfo
+opInfoOrDef c = fromMaybe (InfixL,9) $ H.lookup c ?pt
+
+-- required to satisfy constraint on Fix's show instance
+instance Show1 Partial where
+    liftShowsPrec :: forall a. (Int -> a -> ShowS)
+                  -> ([a] -> ShowS)
+                  -> Int -> Partial a -> ShowS
+
+    liftShowsPrec sp sl p m = case m of
+        (E e)       -> showsUnaryWith lshow "E" p e
+        (B f a b)   -> showsTernaryWith showsPrec lshow lshow "B" p f a b
+        (Par e)     -> showsUnaryWith lshow "Par" p e
+        where
+            lshow :: forall f. (Show1 f) => Int -> f a -> ShowS
+            lshow = liftShowsPrec sp sl
+
+type PartialExpr' = Fix Partial
+
+makeLenses ''AlexInput
+makeLenses ''ParseState
+
+addWoundHere :: Int -> RlpParseError -> P ()
+addWoundHere l e = P $ \st ->
+    let e' = MsgEnvelope
+            { _msgSpan = let pos = psInput . aiPos
+                         in SrcSpan (st ^. pos . posLine)
+                                   (st ^. pos . posColumn)
+                                   l
+            , _msgDiagnostic = e
+            , _msgSeverity = SevError
+            }
+    in (st, [e'], Just ())
+
+addFatalHere :: Int -> RlpParseError -> P a
+addFatalHere l e = P $ \st ->
+    let e' = MsgEnvelope
+            { _msgSpan = let pos = psInput . aiPos
+                         in SrcSpan (st ^. pos . posLine)
+                                    (st ^. pos . posColumn)
+                                    l
+            , _msgDiagnostic = e
+            , _msgSeverity = SevError
+            }
+    in (st, [e'], Nothing)
+
--- a/src/Rlp/Syntax.hs
+++ b/src/Rlp/Syntax.hs
@@ -0,0 +1,177 @@
+-- recursion-schemes
+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
+-- recursion-schemes
+{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings, PatternSynonyms #-}
+module Rlp.Syntax
+    ( RlpModule(..)
+    , RlpProgram(..)
+    , RlpProgram'
+    , rlpmodName
+    , rlpmodProgram
+    , RlpExpr(..)
+    , RlpExpr'
+    , RlpExprF(..)
+    , RlpExprF'
+    , Decl(..)
+    , Decl'
+    , Bind(..)
+    , Where
+    , Where'
+    , ConAlt(..)
+    , Type(..)
+    , pattern (:->)
+    , Assoc(..)
+    , VarId(..)
+    , ConId(..)
+    , Pat(..)
+    , Pat'
+    , Lit(..)
+    , Lit'
+    , Name
+
+    -- TODO: ugh move this somewhere else later
+    , showsTernaryWith
+
+    -- * Convenience re-exports
+    , Text
+    )
+    where
+----------------------------------------------------------------------------------
+import Data.Text                    (Text)
+import Data.Text                    qualified as T
+import Data.String                  (IsString(..))
+import Data.Functor.Foldable.TH     (makeBaseFunctor)
+import Data.Functor.Classes
+import Lens.Micro
+import Lens.Micro.TH
+import Core.Syntax                  hiding (Lit)
+import Core                         (HasRHS(..), HasLHS(..))
+----------------------------------------------------------------------------------
+
+data RlpModule b = RlpModule
+    { _rlpmodName       :: Text
+    , _rlpmodProgram    :: RlpProgram b
+    }
+
+newtype RlpProgram b = RlpProgram [Decl RlpExpr b]
+    deriving Show
+
+type RlpProgram' = RlpProgram Name
+
+-- | The @e@ parameter is used for partial results. When parsing an input, we
+-- first parse all top-level declarations in order to extract infix[lr]
+-- declarations. This process yields a @[Decl (Const Text) Name]@, where @Const
+-- Text@ stores the remaining unparsed function bodies. Once infixities are
+-- accounted for, we may complete the parsing task and get a proper @[Decl
+-- RlpExpr Name]@.
+
+data Decl e b = FunD    VarId [Pat b] (e b) (Maybe (Where b))
+              | TySigD  [VarId] Type
+              | DataD   ConId [Name] [ConAlt]
+              | InfixD  Assoc Int Name
+              deriving Show
+
+type Decl' e = Decl e Name
+
+data Assoc = InfixL
+           | InfixR
+           | Infix
+           deriving Show
+
+data ConAlt = ConAlt ConId [Type]
+            deriving Show
+
+data RlpExpr b = LetE  [Bind b] (RlpExpr b)
+               | VarE  VarId
+               | ConE  ConId
+               | LamE  [Pat b] (RlpExpr b)
+               | CaseE (RlpExpr b) [(Alt b, Where b)]
+               | IfE   (RlpExpr b) (RlpExpr b) (RlpExpr b)
+               | AppE  (RlpExpr b) (RlpExpr b)
+               | LitE  (Lit b)
+               deriving Show
+
+type RlpExpr' = RlpExpr Name
+
+type Where b = [Bind b]
+type Where' = [Bind Name]
+
+-- do we want guards?
+data Alt b = AltA (Pat b) (RlpExpr b)
+           deriving Show
+
+data Bind b = PatB (Pat b) (RlpExpr b)
+            | FunB VarId [Pat b] (RlpExpr b)
+            deriving Show
+
+data VarId = NameVar Text
+           | SymVar Text
+           deriving Show
+
+instance IsString VarId where
+    -- TODO: use symvar if it's an operator
+    fromString = NameVar . T.pack
+
+data ConId = NameCon Text
+           | SymCon Text
+           deriving Show
+
+data Pat b = VarP VarId
+           | LitP (Lit b)
+           | ConP ConId [Pat b]
+           deriving Show
+
+type Pat' = Pat Name
+
+data Lit b = IntL Int
+           | CharL Char
+           | ListL [RlpExpr b]
+           deriving Show
+
+type Lit' = Lit Name
+
+-- instance HasLHS Alt Alt Pat Pat where
+--     _lhs = lens
+--         (\ (AltA p _) -> p)
+--         (\ (AltA _ e) p' -> AltA p' e)
+
+-- instance HasRHS Alt Alt RlpExpr RlpExpr where
+--     _rhs = lens
+--         (\ (AltA _ e) -> e)
+--         (\ (AltA p _) e' -> AltA p e')
+
+makeBaseFunctor ''RlpExpr
+
+deriving instance (Show b, Show a) => Show (RlpExprF b a)
+
+type RlpExprF' = RlpExprF Name
+
+-- society if derivable Show1
+instance (Show b) => Show1 (RlpExprF b) where
+    liftShowsPrec sp _ p m = case m of
+        (LetEF bs e)            -> showsBinaryWith showsPrec sp "LetEF" p bs e
+        (VarEF n)               -> showsUnaryWith showsPrec "VarEF" p n
+        (ConEF n)               -> showsUnaryWith showsPrec "ConEF" p n
+        (LamEF bs e)            -> showsBinaryWith showsPrec sp "LamEF" p bs e
+        (CaseEF e as)           -> showsBinaryWith sp showsPrec "CaseEF" p e as
+        (IfEF a b c)            -> showsTernaryWith sp sp sp "IfEF" p a b c
+        (AppEF f x)             -> showsBinaryWith sp sp "AppEF" p f x
+        (LitEF l)               -> showsUnaryWith showsPrec "LitEF" p l
+
+showsTernaryWith :: (Int -> x -> ShowS)
+                 -> (Int -> y -> ShowS)
+                 -> (Int -> z -> ShowS)
+                 -> String -> Int
+                 -> x -> y -> z
+                 -> ShowS
+showsTernaryWith sa sb sc name p a b c = showParen (p > 10)
+    $ showString name
+    . showChar ' ' . sa 11 a 
+    . showChar ' ' . sb 11 b
+    . showChar ' ' . sc 11 c
+
+--------------------------------------------------------------------------------
+
+makeLenses ''RlpModule
+
--- a/tst/Arith.hs
+++ b/tst/Arith.hs
@@ -6,6 +6,7 @@ module Arith
    ) where
 ----------------------------------------------------------------------------------
 import Data.Functor.Classes             (eq1)
+import Lens.Micro
 import Core.Syntax
 import GM
 import Test.QuickCheck
@@ -70,13 +71,13 @@ instance Arbitrary ArithExpr where
 --         coreResult  = evalCore (toCore e)

 toCore :: ArithExpr -> Program'
-toCore expr = Program
+toCore expr = mempty & programScDefs .~
        [ ScDef "id" ["x"] $ Var "x"
        , ScDef "main" [] $ go expr
        ]
    where
        go :: ArithExpr -> Expr'
-        go (IntA n)    = LitE (IntL n)
+        go (IntA n)    = Lit (IntL n)
        go (NegateA e) = "negate#" :$ go e
        go (IdA e)     = "id" :$ go e
        go (a :+ b)    = f "+#" a b
--- a/tst/Core/HindleyMilnerSpec.hs
+++ b/tst/Core/HindleyMilnerSpec.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE QuasiQuotes, OverloadedStrings #-}
+module Core.HindleyMilnerSpec
+    ( spec
+    )
+    where
+----------------------------------------------------------------------------------
+import Core.Syntax
+import Core.TH                  (coreExpr)
+import Core.HindleyMilner
+import Control.Monad.Errorful
+import Data.Either              (isLeft)
+import Test.Hspec
+----------------------------------------------------------------------------------
+
+-- TODO: more tests. preferrably property-based. lol.
+spec :: Spec
+spec = do
+    it "should infer `id 3` :: Int" $
+        let g = [ ("id", "a" :-> "a") ]
+        in infer' g [coreExpr|id 3|] `shouldBe` Right TyInt
+
+    it "should not infer `id 3` when `id` is specialised to `a -> a`" $
+        let g = [ ("id", ("a" :-> "a") :-> "a" :-> "a") ]
+        in infer' g [coreExpr|id 3|] `shouldSatisfy` isLeft
+
+    -- TODO: property-based tests for let
+    it "should infer `let x = 3 in id x` :: Int" $
+        let g = [ ("id", "a" :-> "a") ]
+            e = [coreExpr|let {x = 3} in id x|]
+        in infer' g e `shouldBe` Right TyInt
+
+    it "should infer `let x = 3; y = 2 in (+#) x y` :: Int" $
+        let g = [ ("+#", TyInt :-> TyInt :-> TyInt) ]
+            e = [coreExpr|let {x=3;y=2} in (+#) x y|]
+        in infer' g e `shouldBe` Right TyInt
+    
+    it "should find `3 :: Bool` contradictory" $
+        let e = [coreExpr|3|]
+        in check' [] (TyCon "Bool") e `shouldSatisfy` isLeft
+
+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
+
Author	SHA1	Message	Date
crumbtoo	3d45e12676	infer letrec expressions	2024-01-23 21:09:25 -07:00
crumbtoo	22b5b47795	letrec	2024-01-23 20:19:16 -07:00
crumbtoo	cefdf6ffae	allow uppercase sc names in preperation for Rlp2Core	2024-01-22 12:45:42 -07:00
crumbtoo	e3b18c8915	errors!	2024-01-22 12:20:05 -07:00
crumbtoo	692d22afb9	msgenvelope	2024-01-22 10:26:33 -07:00
crumbtoo	c146e1c450	errorful parser small	2024-01-22 10:14:30 -07:00
crumbtoo	5a659d22dd	errorful parser	2024-01-22 09:55:58 -07:00
crumbtoo	1a881399ab	when the "Test suite rlp-test: PASS" hits i'm like atlas and the world is writing two lines of code	2024-01-21 14:02:28 -07:00
crumbtoo	257d02da87	RlpcError -> IsRlpcError	2024-01-21 11:53:41 -07:00
crumbtoo	f47f325e34	compiles (kill me) man	2024-01-19 15:52:47 -07:00
crumbtoo	f22d4238f5	Merge branch 'dev' into frontend-parser	2024-01-17 10:28:59 -07:00
crumbtoo	4e1c9dd750	rename rlp	2024-01-17 10:19:48 -07:00
crumbtoo	d6ac991105	renamerlp	2024-01-17 10:19:16 -07:00
crumbtoo	d5663c1aad	remove debug flags	2024-01-17 10:11:48 -07:00
crumbtoo	7e6bee3d4a	infix exprs	2024-01-17 10:08:57 -07:00
crumbtoo	5ec625e0fd	i really need to learn git proper	2024-01-15 15:20:04 -07:00
crumbtoo	9196e20e08	Merge branch 'frontend-parser' into happy-frontend	2024-01-15 15:18:29 -07:00
crumbtoo	a1a50bd013	now we're fucking GETTING SOMEWHERE	2024-01-15 14:58:26 -07:00
crumbtoo	1c035d092a	works	2024-01-15 13:31:15 -07:00
crumbtoo	c0236dc079	oh my god	2024-01-15 11:11:43 -07:00
crumbtoo	9a4f24ec10	Merge commit '4f66e71' into happy-frontend	2024-01-15 11:06:37 -07:00
crumbtoo	4f66e71b9a	FIX REAL	2024-01-15 11:05:10 -07:00
crumbtoo	bdf74ac6c9	cool	2024-01-15 10:35:11 -07:00
crumbtoo	3dfadc17ec	fixy	2024-01-15 10:33:09 -07:00
crumbtoo	c92d8fac65	we're so back	2024-01-15 09:44:26 -07:00
crumbtoo	a38381f6ca	version bounds	2024-01-15 07:53:40 -07:00
crumbtoo	6390ca80d8	see previous commit and scale back the part where i'm joking	2024-01-15 07:47:23 -07:00
crumbtoo	17ddf3530c	kitten i'll be honest mommy's about to kill herself	2024-01-15 07:47:23 -07:00
crumbtoo	e597ecbfc6	okay layouts kinda	2024-01-15 07:47:23 -07:00
crumbtoo	2496589346	aagh	2024-01-15 07:47:23 -07:00
crumbtoo	681a394312	man this sucks	2024-01-15 07:47:23 -07:00
crumbtoo	aff1c6b4c6	decent starting point	2024-01-15 07:47:23 -07:00
crumbtoo	bec376b7c7	threaded lexer	2024-01-15 07:47:23 -07:00
crumbtoo	eaa04c4a59	its fine	2024-01-15 07:47:23 -07:00
crumbtoo	ea2fb4dcaa	tysigs	2024-01-15 07:47:23 -07:00
crumbtoo	ab2cb59526	i did not realise my fs is case insensitive	2024-01-15 07:47:23 -07:00
crumbtoo	ec4902b2d4	layout layouts oh my layouts	2024-01-15 07:47:23 -07:00
crumbtoo	1fc45b70b4	replace uses of many+satisfy with takeWhileP	2024-01-15 07:47:23 -07:00
crumbtoo	4b9a570c72	finally in a decent state	2024-01-15 07:47:23 -07:00
crumbtoo	65b967689c	decls fix	2024-01-15 07:47:23 -07:00
crumbtoo	ed60ec8b32	aaaaa	2024-01-15 07:47:23 -07:00
crumbtoo	d0dbdbbd9b	cool	2024-01-15 07:47:23 -07:00
crumbtoo	cae0939f0c	where	2024-01-15 07:47:23 -07:00
crumbtoo	3292998c42	expr fixups	2024-01-15 07:47:23 -07:00
crumbtoo	84c1122995	infix decl	2024-01-15 07:47:21 -07:00
crumbtoo	97ce9b48ae	labels	2024-01-15 07:46:23 -07:00
crumbtoo	936f24148f	works	2024-01-15 07:46:23 -07:00
crumbtoo	2a159232c7	fixation fufilled - back to work!	2024-01-15 07:46:23 -07:00
crumbtoo	4ee9785239	Show1 instances	2024-01-15 07:46:20 -07:00
crumbtoo	cbe4276061	goofy	2024-01-15 07:44:17 -07:00
crumbtoo	c5c06fa6cb	something	2024-01-15 07:44:17 -07:00
crumbtoo	0f04e2decf	application and lits appl	2024-01-15 07:44:17 -07:00
crumbtoo	6130a91668	oh boy am i going to hate this code in 12 hours	2024-01-15 07:44:17 -07:00
crumbtoo	c15f9b6546	4:00 AM psychopath code	2024-01-15 07:44:17 -07:00
crumbtoo	bb6aca094c	grammar reference	2024-01-15 07:44:17 -07:00
crumbtoo	245b12a96e	add version bounds	2024-01-15 07:43:59 -07:00
crumbtoo	cb9ec43c14	tysigs	2024-01-10 15:11:26 -07:00
crumbtoo	8ad967fac0	i did not realise my fs is case insensitive	2024-01-10 14:33:03 -07:00
crumbtoo	55dbc9de70	layout layouts oh my layouts	2024-01-10 14:23:37 -07:00
crumbtoo	05226373ee	replace uses of many+satisfy with takeWhileP	2024-01-10 11:33:27 -07:00
crumbtoo	981c5d8a83	finally in a decent state	2024-01-10 11:26:17 -07:00
crumbtoo	86cd1075ca	decls fix	2024-01-10 11:03:06 -07:00
crumbtoo	1d43c1d304	aaaaa	2024-01-10 10:46:53 -07:00
crumbtoo	4b44f57066	cool	2024-01-09 22:57:14 -07:00
crumbtoo	90a9594e8f	where	2024-01-09 14:24:51 -07:00
crumbtoo	074350768c	expr fixups	2024-01-09 12:26:53 -07:00
crumbtoo	37d9e6f219	infix decl	2024-01-09 11:39:26 -07:00
crumbtoo	cb7cdf7ed7	labels	2024-01-08 20:14:18 -07:00
crumbtoo	2f783d96e8	works	2024-01-08 18:56:14 -07:00
crumbtoo	a71c099fe0	fixation fufilled - back to work!	2024-01-08 13:39:12 -07:00
crumbtoo	d1e64eb12d	Show1 instances	2024-01-03 10:04:42 -07:00
crumbtoo	f31726b43d	goofy	2024-01-02 08:43:34 -07:00
crumbtoo	8aa9bb843f	something	2024-01-02 08:04:49 -07:00
crumbtoo	9a357a99b7	application and lits appl	2024-01-02 07:04:27 -07:00
crumbtoo	060d48f9e1	oh boy am i going to hate this code in 12 hours	2024-01-02 06:26:48 -07:00
crumbtoo	bf4abeb8b4	4:00 AM psychopath code	2024-01-02 05:34:11 -07:00
crumbtoo	7ed565fc24	grammar reference	2024-01-02 02:33:31 -07:00
crumbtoo	832767575c	lex \ instead of \\	2023-12-29 18:43:09 -07:00
crumbtoo	1dc695f640	Compiler.JustRun	2023-12-29 14:20:53 -07:00
crumbtoo	b941347f82	fix hm tests	2023-12-29 13:54:09 -07:00
crumbtoo	35446533d7	type-checked quasiquoters	2023-12-29 13:47:42 -07:00
crumbtoo	e80acbcd28	errorful (it's not good)	2023-12-28 15:55:55 -07:00
crumbtoo	cb5692248f	back and medicated!	2023-12-28 15:55:55 -07:00
crumbtoo	1164b13a1e	kinda sorta typechecking	2023-12-28 15:55:55 -07:00
crumbtoo	b6945a64eb	i'm on an airplane rn, my eyelids grow heavy, and i forgot my medication. should this be my final commit (of the week): gootbye	2023-12-28 15:55:55 -07:00
crumbtoo	526bf0734e	RlpcError	2023-12-28 15:55:24 -07:00
crumbtoo	c2960e4acc	Name = Text Name = Text	2023-12-20 15:41:41 -07:00
crumbtoo	07be32c618	parse programs (with type sigs :D)	2023-12-20 14:49:40 -07:00
crumbtoo	5c9bf40e40	parse programs (with types :D)	2023-12-20 14:42:35 -07:00
crumbtoo	fe90c9afb0	parse types	2023-12-20 14:13:17 -07:00
crumbtoo	414312cf98	parse type sigs; program type sigs	2023-12-20 14:13:17 -07:00
crumbtoo	6f522d34ff	TyInt -> TyCon "Int#"	2023-12-20 14:12:45 -07:00
crumbtoo	d954734660	LitE -> Lit	2023-12-18 15:42:41 -07:00
crumbtoo	52b7723ea0	LitE -> Lit	2023-12-18 15:38:26 -07:00
crumbtoo	ac6f826141	small	2023-12-18 15:37:32 -07:00
crumbtoo	e222dae6ac	infer nonrec let binds infer nonrec let binds	2023-12-18 15:37:32 -07:00
crumbtoo	e9e1c075db	type IsString + test unification error	2023-12-18 15:37:32 -07:00
crumbtoo	0470912983	comments and better type errors	2023-12-18 15:37:32 -07:00
crumbtoo	f7e850c61a	hindley milner inference :D	2023-12-18 15:37:27 -07:00
crumbtoo	78f88e085f	infer	2023-12-18 15:36:32 -07:00
crumbtoo	20c936f317	commentary	2023-12-18 15:36:32 -07:00
crumbtoo	136e3687b0	Literal -> Lit, LitE -> Lit	2023-12-18 15:36:17 -07:00