post

whole-program inference

whole-program inference

whole-program inference

.ghci

@@ -0,0 +1,25 @@
+-- repl extensions
+:set -XOverloadedStrings
+:set -XQuasiQuotes
+
+--------------------------------------------------------------------------------
+
+-- happy/alex: override :r to rebuild parsers
+:set -package process
+
+:{
+import System.Exit qualified
+import System.Process qualified
+
+_reload_and_make _ = do
+    p <- System.Process.spawnCommand "make -f Makefile_happysrcs"
+    r <- System.Process.waitForProcess p
+    case r of
+        System.Exit.ExitSuccess -> pure ":reload"
+        _                       -> pure ""
+:}
+
+:def! r _reload_and_make
+
+--------------------------------------------------------------------------------
+

CHANGELOG.md

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

Makefile_happysrcs

@@ -0,0 +1,30 @@
+GHC_VERSION = $(shell ghc --numeric-version)
+HAPPY = happy
+HAPPY_OPTS = -a -g -c -i/tmp/t.info
+ALEX = alex
+ALEX_OPTS = -g
+
+SRC = src
+CABAL_BUILD = $(shell ./find-build.clj)
+
+all: parsers lexers
+
+parsers: $(CABAL_BUILD)/Rlp/Parse.hs $(CABAL_BUILD)/Core/Parse.hs \
+		$(CABAL_BUILD)/Rlp/AltParse.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/AltParse.hs: $(SRC)/Rlp/AltParse.y
+	$(HAPPY) $(HAPPY_OPTS) $< -o $@
+
+$(CABAL_BUILD)/Rlp/Lex.hs: $(SRC)/Rlp/Lex.x
+	$(ALEX) $(ALEX_OPTS) $< -o $@
+
+$(CABAL_BUILD)/Core/Parse.hs: $(SRC)/Core/Parse.y
+	$(HAPPY) $(HAPPY_OPTS) $< -o $@
+
+$(CABAL_BUILD)/Core/Lex.hs: $(SRC)/Core/Lex.x
+	$(ALEX) $(ALEX_OPTS) $< -o $@
+

README.md

@@ -1,97 +0,0 @@
-# rl'
-
-`rlp` (ruelang') will be a lazily-evaluated purely-functional language heavily
-imitating Haskell.
-
-### Build Info
-* rlp is built using [Cabal](https://www.haskell.org/ghcup/)
-* rlp's documentation is built using [Sphinx](https://www.sphinx-doc.org/en/master/)
-
-```sh
-$ cabal build       # Build the rlpc compiler
-$ cabal install     # Install rlpc to $PATH
-$ cabal haddock     # Build the API docs w/ Haddock
-$ make -C doc html  # Build the primary docs w/ Sphinx
-
-# run the test suite
-$ cabal test --test-show-details=direct
-```
-
-### Use
-```sh
-# Compile and evaluate examples/factorial.hs, with evaluation info dumped to stderr
-$ rlpc -ddump-eval examples/factorial.hs
-# Compile and evaluate t.hs, with evaluation info dumped to t.log
-$ rlpc -ddump-eval -l t.log t.hs
-# Print the raw structure describing the compiler options and die
-# (option parsing still must succeed in order to print)
-$ rlpc -ddump-opts t.hs
-```
-
-### Potential Features
-Listed in order of importance.
-- [ ] ADTs
-- [ ] First-class functions
-- [ ] Higher-kinded types
-- [ ] Typeclasses
-- [ ] Parametric polymorphism
-- [ ] Hindley-Milner type inference
-- [ ] Newtype coercion
-- [ ] Parallelism
-
-### Milestones
-(This list is incomplete.)
-
-- [ ] Backend
-    - [x] Core language
-        - [x] AST
-    - [x] Low-level execution model (TI)
-        - [x] Arithmetic
-        - [x] Conditionals
-        - [x] Structured data
-        - [x] Garbage collection
-    - [x] Low-level execution model (GM)
-        - [x] Arithmetic
-        - [x] Conditionals
-        - [x] Structured data
-        - [x] Garbage Collection
-    - [ ] Emitter
-        - [ ] Code-gen (target yet to be decided)
-        - [ ] Core language emitter
-    - [ ] Core linter (Type-checker)
-    - [ ] Core2Core pass
-        - [x] GM prep
-            - [x] Non-strict case-floating
-        - [ ] Let-floating
-        - [ ] TCO
-        - [ ] DCE
-- [ ] Frontend
-    - [ ] High-level language
-        - [ ] AST
-        - [ ] Lexer
-        - [ ] Parser
-    - [ ] Translation to the core language
-        - [ ] Constraint solver
-        - [ ] `do`-notation
-    - [x] CLI
-- [ ] Documentation
-    - [ ] State transition rules
-    - [ ] How does the evaluation model work?
-    - [ ] CLI usage
-    - [ ] Tail call optimisation
-    - [x] Parsing rlp
-- [ ] Tests
-    - [x] Generic example programs
-    - [ ] Parser
-
-### December Release Plan
-- [ ] Tests
-    - [ ] Core lexer
-    - [ ] Core parser
-    - [ ] Evaluation model
-- [ ] Benchmarks
-- [ ] Stable Core lexer
-- [ ] Stable Core parser
-- [ ] Stable evaluation model
-    - [ ] Garbage Collection
-- [ ] Stable documentation for the evaluation model

README.org

@@ -0,0 +1,223 @@
+#+title: rl'
+#+author: Madeleine Sydney Slaga
+
+~rl'~ will be a lazily-evaluated, purely-functional, statically-typed language
+heavily imitating Haskell.
+
+* Architecture
+
+[[file:rlpc.drawio.svg]]
+
+* Build Info
+
+- ~rlpc~ is built using [[https://www.haskell.org/ghcup/][Cabal]]
+- ~rlpc~'s documentation is built using
+  [[https://www.sphinx-doc.org/en/master/][Sphinx]]
+
+#+BEGIN_SRC sh
+$ cabal build       # Build the rlpc compiler
+$ cabal install     # Install rlpc to $PATH
+$ cabal haddock     # Build the API docs w/ Haddock
+$ make -C doc html  # Build the primary docs w/ Sphinx
+
+# run the test suite
+$ cabal test --test-show-details=direct
+#+END_SRC
+
+* Use
+
+** TLDR
+#+begin_src sh
+# Compile and evaluate examples/rlp/QuickSort.rl
+$ rlpc examples/QuickSort.rl
+# Compile and evaluate t.cr, with evaluation info dumped to t.log
+$ rlpc -ddump-eval -l t.log t.cr
+# Compile and evaluate t.rl, dumping the desugared Core
+$ rlpc -ddump-desugared t.rl
+# Compile and evaluate t.rl with all compiler messages enabled
+$ rlpc -dALL t.rl
+#+end_src
+
+** Options
+#+begin_src sh
+Usage: rlpc [-l|--log FILE] [-d DEBUG FLAG] [-f COMPILATION FLAG]
+            [-e|--evaluator gm|ti] [--heap-trigger INT] [-x|--language rlp|core]
+            FILES...
+#+end_src
+
+Available debug flags include:
+- ~-ddump-desugared~: dump Core generated from rl'
+- ~-ddump-parsed-core~: dump raw Core AST
+- ~-ddump-parsed~: dump raw rl' AST
+- ~-ddump-eval~: dump evaluation logs
+- ~-dALL~: disable debug message filtering. enables *all* debug messages
+
+* Demos
+
+[TODO: add hmvis video here]
+
+* To-do List
+
+** TODO [#A] rlp to core desugaring                                    :feature:
+
+** DONE [#A] HM memoisation prevents shadowing                             :bug:
+   CLOSED: [2024-04-04 Thu 12:29]
+   Example:
+   #+begin_src haskell
+   -- >>> runHM' $ infer1 [rlpExpr|let f = \x -> x in f (let f = 2 in f)|]
+   -- Left [TyErrCouldNotUnify
+   --         (ConT "Int#")
+   --         (AppT (AppT FunT (ConT "Int#")) (VarT "$a2"))]
+   -- >>> :t let f = \x -> x in f (let f = 2 in f)
+   -- let f = \x -> x in f (let f = 2 in f) :: Int
+   #+end_src
+   For the time being, I just disabled the memoisation. This is very, very bad.
+*** Closing Remarks
+    Fixed by entirely rewriting the type inference algorithm :P. Memoisation is
+    no longer required; the bottom-up inference a la Algorithm M was previously
+    hacked together using a comonadic extend with a catamorphism, which, for each
+    node, would fold the entire subtree and memoise the result, which would then
+    be retrieved when parent nodes attempted to infer children nodes. This sucks!
+    It's not "bottom-up" at all! I replaced it with a gorgeous hand-rolled
+    recursion scheme which truly works from the bottom upwards. A bonus
+    specialisation is that it annotates each node with the result of a
+    catamorphism from that node downwards via the cofree comonad.
+    #+begin_src haskell
+    dendroscribe :: (Functor f, Base t ~ f, Recursive t)
+                => (f (Cofree f a) -> a) -> t -> Cofree f a
+    dendroscribe c (project -> f) = c f' :< f'
+         where f' = dendroscribe c <$> f
+
+    dendroscribeM :: (Traversable f, Monad m, Base t ~ f, Recursive t)
+                  => (f (Cofree f a) -> m a) -> t -> m (Cofree f a)
+    dendroscribeM c (project -> f) = do
+         as <- dendroscribeM c `traverse` f
+         a <- c as
+         pure (a :< as)
+    #+end_src
+
+** DONE README.md -> README.org                                           :docs:
+   CLOSED: [2024-03-28 Thu 10:44]
+
+** DONE [#A] ~case~ inference                                          :feature:
+   CLOSED: [2024-04-05 Fri 15:26]
+
+** DONE [#A] ADT support in Rlp/HindleyMilner.hs                       :feature:
+   CLOSED: [2024-04-05 Fri 12:28]
+
+** DONE whole-program inference (wrap top-level in a ~letrec~)         :feature:
+   CLOSED: [2024-04-04 Thu 12:42]
+   shadowing issue sucks. i'm going to have to rewrite the whole type inference
+   system later. and i never learn, so i'm gonna use a chronomorphism :3.
+*** Closing Remarks
+    I don't know how a fucking chronomorphism works. None of the experts can
+    think of a single example of how to use it. The rewrite uses a bottom-up
+    recursion scheme I've dubbed ~dendroscribe~.
+
+** TODO user-supplied annotation support in Rlp/HindleyMilner.hs       :feature:
+
+** DONE [#A] update architecture diagram                                  :docs:
+   CLOSED: [2024-04-05 Fri 15:41]
+
+** TODO pattern support; everywhere [0%]                                :feature:
+   - [-] in the type-checker
+   - [ ] in the desugarer
+
+** TODO [#A] G-machine visualiser                                         :docs:
+
+** TODO [#C] lambda calculus visualiser                                   :docs:
+
+** TODO hmvis does not reload when redefining expressions                  :bug:
+   To recreate:
+   1. enter
+      #+begin_src haskell
+      x = 2
+      #+end_src
+   2. hit "type-check"
+   3. edit source to
+      #+begin_src haskell
+      x = \x -> x
+      #+end_src
+   4. hit "type-check"
+
+** DONE in Rlp/HindleyMilner.hs, fix ~listenFreshTvNames~         :housekeeping:
+   CLOSED: [2024-04-04 Thu 13:17]
+   it /does/ work in its current state, however it captures an unreasonably
+   excessive amount of names, even for a heuristic.
+*** Closing Remarks
+    Fixed with the proper Algorithm M rewrite. The original purpose of
+    ~listenFreshTvNames~ (tracking monomorphic type variables) has been solved
+    much more cleanly via the (non-monadic!) ~monomorphise~ function paired with
+    the new ~ImplicitInstance~ constraint.
+
+** TODO up-to-date examples [0/2]                                         :docs:
+- [ ] quicksort (core and rlp)
+- [ ] factorial (core and rlp)
+
+
+
+** TODO [#C] fix spacing in pretty-printing                                :bug:
+   note the extra space before the equals sign:
+   #begin_src
+   >>> makeItPretty $ justInferRlp "id x = x" <&> rlpProgToCore
+   Right 
+   
+   id : ∀ ($a0 : Type). $a0 -> $a0  = <lambda>;
+   #end_src
+
+
+** TODO Core.Utils.freeVariables does not handle let-bindings              :bug:
+
+* Releases
+
+** +December Release+
+- [X] Tests
+    - [ ] Core lexer
+    - [ ] Core parser
+    - [X] Evaluation model
+- [ ] Benchmarks
+- [X] Stable Core lexer
+- [X] Stable Core parser
+- [X] Stable evaluation model
+    - [X] Garbage Collection
+- [ ] Stable documentation for the evaluation model
+
+** +February Release Plan+
+- [X] Beta rl' to Core
+- [X] UX improvements
+    - [X] Actual compiler errors -- no more unexceptional `error` calls
+    - [X] Better CLI dump flags
+    - [X] Annotate the AST with token positions for errors (NOTE: As of Feb. 1,
+      this has been done, but the locational info is not yet used in error messages)
+- [X] Compiler architecture diagram
+- [X] More examples
+
+** Final Release Plan
+   SCHEDULED: <2024-04-19 Fri>
+*** TODO Complete all A-priority checks in the main todo-list!!
+*** TODO Tests
+    - [ ] rl' parser
+    - [ ] Type inference
+*** TODO Examples
+    - [ ] quicksort
+    - [ ] factorial
+    - [ ] your typical FP operations -- mapping, folding, etc.
+*** DONE Ditch TTG in favour of fixed-points of functors
+    Focus on extendability via Fix, Free, Cofree, etc. rather than
+    boilerplate-heavy type families
+*** DONE rl' type inference
+*** DONE Core type checking
+
+** Presentation
+   SCHEDULED: <2024-05-10 Fri>
+*** TODO Documentation
+    - [ ] Type inference / Algorithm M
+    - [ ] The G-Machine
+*** TODO G-Machine visualiser
+*** TODO Post-mortem write-up
+    e.g. what would I do differently next time, what have I learned, etc.
+*** TODO Final polish check [0/3]
+    - [ ] CLI
+    - [ ] G-Machine output
+    - [ ] ~Compiler.JustRun~ module
+

app/CoreDriver.hs

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

app/Main.hs

@@ -1,18 +1,30 @@
 {-# LANGUAGE BlockArguments, LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Main where
 ----------------------------------------------------------------------------------
+import Control.Lens             hiding (argument)
 import Compiler.RLPC
+import Compiler.RlpcError
 import Control.Exception
 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 Data.List
+import Data.Maybe               (listToMaybe)
 import System.IO
 import System.Exit              (exitSuccess)
 import Core
 import TI
 import GM
-import Lens.Micro.Mtl
+import Control.Lens.Combinators hiding (argument)
+
+import CoreDriver               qualified
+import RlpDriver                qualified
+import Server                   qualified
 ----------------------------------------------------------------------------------
 
 optParser :: ParserInfo RLPCOptions
@@ -34,9 +46,15 @@ options = RLPCOptions
     {- -d -}
     <*> fmap S.fromList # many # option debugFlagReader
         (  short 'd'
-        <> help "dump evaluation logs"
+        <> help "pass debug flags"
         <> metavar "DEBUG FLAG"
         )
+    {- -f -}
+    <*> fmap S.fromList # many # option compilerFlagReader
+        (  short 'f'
+        <> help "pass compilation flags"
+        <> metavar "COMPILATION FLAG"
+        )
     {- --evaluator, -e -}
     <*> option evaluatorReader
         (  long "evaluator"
@@ -52,96 +70,79 @@ options = RLPCOptions
                 \triggering the garbage collector"
         <> value 50
         )
-    <*> some (argument str $ metavar "FILES...")
+    <*> optional # option languageReader
+        (  long "language"
+        <> short 'x'
+        <> metavar "rlp|core"
+        <> help "the language to be compiled -- see README"
+        )
+    <*> switch
+        (  long "server"
+        <> short 's'
+        )
+    <*> many (argument str $ metavar "FILES...")
     where
         infixr 9 #
         f # x = f x
 
+languageReader :: ReadM Language
+languageReader = maybeReader $ \case
+    "rlp"   -> Just LanguageRlp
+    "core"  -> Just LanguageCore
+    "rl"    -> Just LanguageRlp
+    "cr"    -> Just LanguageCore
+    _       -> Nothing
+
+debugFlagReader :: ReadM DebugFlag
+debugFlagReader = str
+
+compilerFlagReader :: ReadM CompilerFlag
+compilerFlagReader = str
+
 evaluatorReader :: ReadM Evaluator
 evaluatorReader = maybeReader $ \case
     "gm"  -> Just EvaluatorGM
-    "tim" -> Just EvaluatorTI
+    "ti"  -> Just EvaluatorTI
     _     -> Nothing
 
 mmany :: (Alternative f, Monoid m) => f m -> f m
 mmany v = liftA2 (<>) v (mmany v)
 
-debugFlagReader :: ReadM DebugFlag
-debugFlagReader = maybeReader $ \case
-    "dump-eval"  -> Just DDumpEval
-    "dump-opts"  -> Just DDumpOpts
-    "dump-ast"   -> Just DDumpAST
-    _            -> Nothing
-
 ----------------------------------------------------------------------------------
 
--- temp
-data CompilerError = CompilerError String
-    deriving Show
-
-instance Exception CompilerError
-
 main :: IO ()
 main = do
     opts <- execParser optParser
-    (_, es) <- evalRLPCIO opts driver
-    forM_ es $ \ (CompilerError e) -> print $ "warning: " <> e
-    pure ()
+    if opts ^. rlpcServer
+    then Server.server
+    else void $ evalRLPCIO opts dispatch
 
-driver :: RLPCIO CompilerError ()
-driver = sequence_
-    [ dshowFlags
-    , ddumpAST
-    , ddumpEval
-    ]
+dispatch :: RLPCIO ()
+dispatch = getLang >>= \case
+    Just LanguageCore -> CoreDriver.driver
+    Just LanguageRlp  -> RlpDriver.driver
+    Nothing           -> addFatal err
+        where
+            -- TODO: why didn't i make the srcspan optional LOL
+            err = errorMsg (SrcSpan 0 0 0 0) $ Text
+                [ "Could not determine source language from filetype."
+                , "Possible Solutions:\n\
+                  \  Suffix the file with `.cr' for Core, or `.rl' for rl'\n\
+                  \  Specify a language with `rlpc -x core' or `rlpc -x rlp'"
+                ]
+  where
+    getLang = liftA2 (<|>)
+        (view rlpcLanguage)
+        -- TODO: we only check the first file lol
+        ((listToMaybe >=> inferLanguage) <$> view rlpcInputFiles)
 
-dshowFlags :: RLPCIO CompilerError ()
-dshowFlags = whenFlag flagDDumpOpts do
-    ask >>= liftIO . print
 
-ddumpAST :: RLPCIO CompilerError ()
-ddumpAST = whenFlag flagDDumpAST $ forFiles_ \o f -> do
-    liftIO $ withFile f ReadMode $ \h -> do
-        s <- hGetContents h
-        case parseProg o s of
-            Right (a,_) -> hPutStrLn stderr $ show a
-            Left e -> error "todo errors lol"
+driver :: RLPCIO ()
+driver = undefined
 
-ddumpEval :: RLPCIO CompilerError ()
-ddumpEval = whenFlag flagDDumpEval do
-    fs <- view rlpcInputFiles
-    forM_ fs $ \f -> liftIO (readFile f) >>= doProg
-
-    where
-        doProg :: String -> RLPCIO CompilerError ()
-        doProg s = ask >>= \o -> case parseProg o s of
-            -- TODO: error handling
-            Left e -> addFatal . CompilerError $ show e
-            Right (a,_) -> do
-                log <- view rlpcLogFile
-                dumpEval <- chooseEval
-                case log of
-                    Just f  -> liftIO $ withFile f WriteMode $ dumpEval a
-                    Nothing -> liftIO $ dumpEval a stderr
-
-        -- choose the appropriate model based on the compiler opts
-        chooseEval = do
-            ev <- view rlpcEvaluator
-            pure $ case ev of
-                EvaluatorGM  -> v GM.hdbgProg
-                EvaluatorTI -> v TI.hdbgProg
-            where v f p h = f p h *> pure ()
-
-parseProg :: RLPCOptions
-          -> String
-          -> Either SrcError (Program', [SrcError])
-parseProg o = evalRLPC o . (lexCore >=> parseCoreProg)
-
-forFiles_ :: (Monad m)
-          => (RLPCOptions -> FilePath -> RLPCT e m a)
-          -> RLPCT e m ()
-forFiles_ k = do
-    fs <- view rlpcInputFiles
-    o <- ask
-    forM_ fs (k o)
+inferLanguage :: FilePath -> Maybe Language
+inferLanguage fp
+    | ".rl" `isSuffixOf` fp     = Just LanguageRlp
+    | ".cr" `isSuffixOf` fp     = Just LanguageCore
+    | otherwise                 = Nothing
 

app/RlpDriver.hs

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

app/Server.hs

@@ -0,0 +1,115 @@
+{-# LANGUAGE LambdaCase, BlockArguments #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Server
+    ( server
+    )
+    where
+--------------------------------------------------------------------------------
+import GHC.Generics                 (Generic, Generically(..))
+import Data.Text.Encoding           qualified as T
+import Data.Text                    (Text)
+import Data.Text                    qualified as T
+import Data.Text.IO                 qualified as T
+import Data.Pretty                  hiding (annotate)
+import Data.Aeson
+import Data.Function
+import Control.Arrow
+import Control.Applicative
+import Control.Monad
+import Control.Concurrent
+import Network.WebSockets           qualified as WS
+import Control.Exception
+import GHC.IO
+import Control.Lens                 hiding ((.=))
+
+import Control.Comonad
+import Data.Functor.Foldable
+
+import Compiler.RLPC
+
+import Misc.CofreeF
+import Rlp.AltSyntax
+import Rlp.HindleyMilner
+import Rlp.AltParse
+--------------------------------------------------------------------------------
+
+server :: IO ()
+server = do
+    T.putStrLn "rlpc server started at 127.0.0.1:9002"
+    WS.runServer "127.0.0.1" 9002 application
+
+application :: WS.ServerApp
+application pending = do
+    WS.acceptRequest pending >>= talk
+
+data Command = Annotate Text
+             | PartiallyAnnotate Text
+    deriving Show
+
+instance FromJSON Command where
+    parseJSON = withObject "command object" $ \v -> do
+        cmd :: Text <- v .: "command"
+        case cmd of
+            "annotate"           -> Annotate <$> v .: "source"
+            "partially-annotate" -> PartiallyAnnotate <$> v .: "source"
+            _          -> empty
+
+data Response = Annotated Value
+              | PartiallyAnnotated Value
+    deriving (Generic)
+    deriving (ToJSON)
+        via Generically Response
+
+talk :: WS.Connection -> IO ()
+talk conn = (`catchAny` print) . forever $ do
+    msg <- WS.receiveData @Text conn
+    T.putStrLn $ "received: " <> msg
+    doCommand conn `traverse` decodeStrictText msg
+
+doCommand :: WS.Connection -> Command -> IO ()
+doCommand conn c = do
+    putStr "sending: "
+    let r = encode . respond $ c
+    print r
+    WS.sendTextData conn r
+
+respond :: Command -> Response
+respond (Annotate s)
+    = s & (parseRlpProgR >=> typeCheckRlpProgR)
+        & fmap (\p -> p ^.. funDs
+           <&> serialiseSc)
+        & runRLPCJsonDef
+        & Annotated
+
+showPartialAnn = undefined
+
+funDs :: Traversal' (Program b a) (b, [Pat b], a)
+funDs = programDecls . each . _FunD
+
+serialiseSc :: (PsName, [Pat PsName], Cofree (RlpExprF PsName) (Type PsName))
+            -> Value
+serialiseSc (n,as,e) = object
+    [ "name" .= n
+    , "args" .= as
+    , "body" .= let root = extract e
+                in serialiseAnnotated (e <&> renamePrettily root)
+    ]
+
+serialiseAnnotated :: Cofree (RlpExprF PsName) (Type PsName)
+                   -> Value
+serialiseAnnotated = cata \case
+    t :<$ e -> object [ "e" .= e, "type" .= rout @Text t ]
+
+runRLPCJsonWithDef :: (a -> Value) -> RLPC a -> Value
+runRLPCJsonWithDef f = runRLPCJsonWith f def
+
+runRLPCJsonDef :: (ToJSON a) => RLPC a -> Value
+runRLPCJsonDef = runRLPCJsonWith toJSON def
+
+runRLPCJsonWith :: (a -> Value) -> RLPCOptions -> RLPC a -> Value
+runRLPCJsonWith f o r = object
+    [ "errors" .= es
+    , "result" .= (f <$> ma) ]
+  where (ma,es) = evalRLPC o r
+

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,53 +60,16 @@ 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.
-
-**************************
-Evaluation: Slurping Vines
-**************************
-
-WIP.
-
-Laziness
---------
-
-WIP.
-
-* Instead of :code:`Slide (n+1); Unwind`, do :code:`Update n; Pop n; Unwind`
-
-****************************
-Compilation: Squashing Trees
-****************************
-
-WIP.
-
-Notice that we do not keep a (local) environment at run-time. The environment
-only exists at compile-time to map local names to stack indices. When compiling
-a supercombinator, the arguments are enumerated from zero (the top of the
-stack), and passed to :code:`compileR` as an environment.
+*************
+The G-Machine
+*************
 
 .. literalinclude:: /../../src/GM.hs
    :dedent:
-   :start-after: -- >> [ref/compileSc]
-   :end-before: -- << [ref/compileSc]
+   :start-after: -- >> [ref/Instr]
+   :end-before: -- << [ref/Instr]
    :caption: src/GM.hs
 
-Of course, variables being indexed relative to the top of the stack means that
-they will become inaccurate the moment we push or pop the stack a single time.
-The way around this is quite simple: simply offset the stack when w
-
-.. literalinclude:: /../../src/GM.hs
-   :dedent:
-   :start-after: -- >> [ref/compileC]
-   :end-before: -- << [ref/compileC]
-   :caption: src/GM.hs
-
-
-

doc/src/commentary/layout-lexing.rst

@@ -2,16 +2,21 @@ Lexing, Parsing, and Layouts
 ============================
 
 The C-style languages of my previous experiences have all had quite trivial
-lexical analysis stages, peaking in complexity when I streamed tokens lazily in
-C. The task of tokenising a C-style language is very simple in description: you
-ignore all whitespace and point out what you recognise. If you don't recognise
-something, check if it's a literal or an identifier. Should it be neither,
-return an error.
+lexical analysis stages: you ignore all whitespace and point out the symbols you
+recognise. If you don't recognise something, check if it's a literal or an
+identifier. Should it be neither, return an error.
 
-On paper, both lexing and parsing a Haskell-like language seem to pose a few
+In contrast, both lexing and parsing a Haskell-like language poses a number of
 greater challenges. Listed by ascending intimidation factor, some of the
 potential roadblocks on my mind before making an attempt were:
 
+* Context-sensitive keywords; Haskell allows for some words to be used as
+  identifiers in appropriate contexts, such as :code:`family`, :code:`role`,
+  :code:`as`. Reading a note_ found in `GHC's lexer`_, it appears that keywords
+  are only considered in bodies for which their use is relevant, e.g.
+  :code:`family` and :code:`role` in type declarations, :code:`as` after
+  :code:`case`; :code:`if`, :code:`then`, and :code:`else` in expressions, etc.
+
 * Operators; Haskell has not only user-defined infix operators, but user-defined
   precedence levels and associativities. I recall using an algorithm that looked
   up infix, prefix, postfix, and even mixfix operators up in a global table to
@@ -19,17 +24,9 @@ potential roadblocks on my mind before making an attempt were:
   stored in the table). I never modified the table at runtime, however this
   could be a very nice solution for Haskell.
 
-* Context-sensitive keywords; Haskell allows for some words to be used as identifiers in
-  appropriate contexts, such as :code:`family`, :code:`role`, :code:`as`.
-  Reading a note_ found in `GHC's lexer`_,
-  it appears that keywords are only considered in bodies for which their use is
-  relevant, e.g. :code:`family` and :code:`role` in type declarations,
-  :code:`as` after :code:`case`; :code:`if`, :code:`then`, and :code:`else` in
-  expressions, etc.
-
 * Whitespace sensitivity; While I was comfortable with the idea of a system
-  similar to Python's INDENT/DEDENT tokens, Haskell seemed to use whitespace to
-  section code in a way that *felt* different.
+  similar to Python's INDENT/DEDENT tokens, Haskell's layout system is based on
+  alignment and is very generous with line-folding.
 
 .. _note: https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/coding-style#2-using-notes
 .. _GHC's lexer: https://gitlab.haskell.org/ghc/ghc/-/blob/master/compiler/GHC/Parser/Lexer.x#L1133
@@ -45,9 +42,9 @@ We will compare and contrast with Python's lexical analysis. Much to my dismay,
 Python uses newlines and indentation to separate statements and resolve scope
 instead of the traditional semicolons and braces found in C-style languages (we
 may generally refer to these C-style languages as *explicitly-sectioned*).
-Internally during tokenisation, when the Python lexer begins a new line, they
-compare the indentation of the new line with that of the previous and apply the
-following rules:
+Internally during tokenisation, when the Python lexer encounters a new line, the
+indentation of the new line is compared with that of the previous and the
+following rules are applied:
 
 1. If the new line has greater indentation than the previous, insert an INDENT
    token and push the new line's indentation level onto the indentation stack
@@ -60,170 +57,10 @@ following rules:
 3. If the indentation is equal, insert a NEWLINE token to terminate the previous
    line, and leave it at that!
 
-Parsing Python with the INDENT, DEDENT, and NEWLINE tokens is identical to
-parsing a language with braces and semicolons. This is a solution pretty in line
-with Python's philosophy of the "one correct answer" (TODO: this needs a
-source). In developing our *layout* rules, we will follow in the pattern of
-translating the whitespace-sensitive source language to an explicitly sectioned
-language.
-
-But What About Haskell?
-***********************
-
-We saw that Python, the most notable example of an implicitly sectioned
-language, is pretty simple to lex. Why then am I so afraid of Haskell's layouts?
-To be frank, I'm far less scared after asking myself this -- however there are
-certainly some new complexities that Python needn't concern. Haskell has
-implicit line *continuation*: forms written over multiple lines; indentation
-styles often seen in Haskell are somewhat esoteric compared to Python's
-"s/[{};]//".
-
-.. code-block:: haskell
-
-   -- line continuation
-   something = this is a
-       single expression
-
-   -- an extremely common style found in haskell
-   data Python = Users
-       { are        :: Crying
-       , right      :: About
-       , now        :: Sorry
-       }
-
-   -- another formatting oddity
-   -- note that this is not a single
-   -- continued line! `look at`,
-   -- `this`, and `alignment` are all
-   -- separate expressions!
-   anotherThing = do look at
-                     this
-                     alignment
-
-But enough fear, lets actually think about implementation. Firstly, some
-formality: what do we mean when we say layout? We will define layout as the
-rules we apply to an implicitly-sectioned language in order to yield one that is
-explicitly-sectioned. We will also define indentation of a lexeme as the column
-number of its first character.
-
-Thankfully for us, our entry point is quite clear; layouts only appear after a
-select few keywords, (with a minor exception; TODO: elaborate) being :code:`let`
-(followed by supercombinators), :code:`where` (followed by supercombinators),
-:code:`do` (followed by expressions), and :code:`of` (followed by alternatives)
-(TODO: all of these terms need linked glossary entries). In order to manage the
-cascade of layout contexts, our lexer will record a stack for which each element
-is either :math:`\varnothing`, denoting an explicit layout written with braces
-and semicolons, or a :math:`\langle n \rangle`, denoting an implicitly laid-out
-layout where the start of each item belonging to the layout is indented
-:math:`n` columns.
-
-.. code-block:: haskell
-
-    -- layout stack: []
-    module M where -- layout stack: [∅]
-
-    f x = let -- layout keyword; remember indentation of next token
-              y = w * w -- layout stack: [∅, <10>]
-              w = x + x
-              -- layout ends here
-          in do -- layout keyword; next token is a brace!
-              { -- layout stack: [∅]
-                  print y;
-                  print x;
-              }
-
-Finally, we also need the concept of "virtual" brace tokens, which as far as
-we're concerned at this moment are exactly like normal brace tokens, except
-implicitly inserted by the compiler. With the presented ideas in mind, we may
-begin to introduce a small set of informal rules describing the lexer's handling
-of layouts, the first being:
-
-1. If a layout keyword is followed by the token '{', push :math:`\varnothing`
-   onto the layout context stack. Otherwise, push :math:`\langle n \rangle` onto
-   the layout context stack where :math:`n` is the indentation of the token
-   following the layout keyword. Additionally, the lexer is to insert a virtual
-   opening brace after the token representing the layout keyword.
-
-Consider the following observations from that previous code sample:
-
-* Function definitions should belong to a layout, each of which may start at
-  column 1.
-
-* A layout can enclose multiple bodies, as seen in the :code:`let`-bindings and
-  the :code:`do`-expression.
-
-* Semicolons should *terminate* items, rather than *separate* them.
-
-Our current focus is the semicolons. In an implicit layout, items are on
-separate lines each aligned with the previous. A naïve implementation would be
-to insert the semicolon token when the EOL is reached, but this proves unideal
-when you consider the alignment requirement. In our implementation, our lexer
-will wait until the first token on a new line is reached, then compare
-indentation and insert a semicolon if appropriate. This comparison -- the
-nondescript measurement of "more, less, or equal indentation" rather than a
-numeric value -- is referred to as *offside* by myself internally and the
-Haskell report describing layouts. We informally formalise this rule as follows:
-
-2. When the first token on a line is preceeded only by whitespace, if the
-   token's first grapheme resides on a column number :math:`m` equal to the
-   indentation level of the enclosing context -- i.e. the :math:`\langle n
-   \rangle` on top of the layout stack. Should no such context exist on the
-   stack, assume :math:`m > n`.
-
-We have an idea of how to begin layouts, delimit the enclosed items, and last
-we'll need to end layouts. This is where the distinction between virtual and
-non-virtual brace tokens comes into play. The lexer needs only partial concern
-towards closing layouts; the complete responsibility is shared with the parser.
-This will be elaborated on in the next section. For now, we will be content with
-naïvely inserting a virtual closing brace when a token is indented right of the
-layout.
-
-3. Under the same conditions as rule 2., when :math:`m < n` the lexer shall
-   insert a virtual closing brace and pop the layout stack.
-
-This rule covers some cases including the top-level, however, consider
-tokenising the :code:`in` in a :code:`let`-expression. If our lexical analysis
-framework only allows for lexing a single token at a time, we cannot return both
-a virtual right-brace and a :code:`in`. Under this model, the lexer may simply
-pop the layout stack and return the :code:`in` token. As we'll see in the next
-section, as long as the lexer keeps track of its own context (i.e. the stack),
-the parser will cope just fine without the virtual end-brace.
-
-Parsing Lonely Braces
-*********************
-
-When viewed in the abstract, parsing and tokenising are near-identical tasks yet
-the two are very often decomposed into discrete systems with very different
-implementations. Lexers operate on streams of text and tokens, while parsers
-are typically far less linear, using a parse stack or recursing top-down. A
-big reason for this separation is state management: the parser aims to be as
-context-free as possible, while the lexer tends to burden the necessary
-statefulness. Still, the nature of a stream-oriented lexer makes backtracking
-difficult and quite inelegant.
-
-However, simply declaring a parse error to be not an error at all
-counterintuitively proves to be an elegant solution our layout problem which
-minimises backtracking and state in both the lexer and the parser. Consider the
-following definitions found in rlp's BNF:
-
-.. productionlist:: rlp
-   VOpen   : `vopen`
-   VClose  : `vclose` | `error`
-
-A parse error is recovered and treated as a closing brace. Another point of note
-in the BNF is the difference between virtual and non-virtual braces (TODO: i
-don't like that the BNF is formatted without newlines :/):
-
-.. productionlist:: rlp
-   LetExpr : `let` VOpen Bindings VClose `in` Expr | `let` `{` Bindings `}` `in` Expr
-
-This ensures that non-virtual braces are closed explicitly.
-
-This set of rules is adequete enough to satisfy our basic concerns about line
-continations and layout lists. For a more pedantic description of the layout
-system, see `chapter 10
-<https://www.haskell.org/onlinereport/haskell2010/haskellch10.html>`_ of the
-2010 Haskell Report, which I heavily referenced here.
+On the parser's end, the INDENT, DEDENT, and NEWLINE tokens are identical to
+braces and semicolons. In developing our *layout* rules, we will follow in the
+pattern of translating the whitespace-sensitive source language to an explicitly
+sectioned language.
 
 References
 ----------
@@ -233,3 +70,4 @@ References
 
 * `Haskell syntax reference
   <https://www.haskell.org/onlinereport/haskell2010/haskellch10.html>`_
+

doc/src/commentary/post-mortem.rst

@@ -0,0 +1,6 @@
+rlpc Post-Mortem
+================
+
+I begin writing this (10:11 AM, 15 Apr) shortly after I push what I believe to
+be one of my final commits.
+

doc/src/commentary/ti.rst

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

doc/src/commentary/type-inference.rst

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

doc/src/conf.py

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

doc/src/references/rlp-grammar.rst

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

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

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

examples/Core/constDivZero.cr

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

examples/Core/factorial.cr

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

examples/Core/sumList.cr

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

examples/constDivZero.hs

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

examples/factorial.hs

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

examples/rlp/QuickSort.rl

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

examples/rlp/SumList.rl

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

examples/sumList.hs

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

find-build.clj

@@ -0,0 +1,13 @@
+#!/usr/bin/env bb
+
+(defn die [& msgs]
+  (binding [*out* *err*]
+    (run! println msgs))
+  (System/exit 1))
+
+(let [paths (map str (fs/glob "." "dist-newstyle/build/*/*/rlp-*/build"))
+      n (count paths)]
+  (cond (< 1 n) (die ">1 build directories found. run `cabal clean`.")
+        (< n 1) (die "no build directories found. this shouldn't happen lol")
+        :else   (-> paths first fs/real-path str println)))
+

programming-language-checklist

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

rlp.cabal

@@ -7,14 +7,16 @@ license:            GPL-2.0-only
 -- license-file:       LICENSE
 author:             crumbtoo
 maintainer:         crumb@disroot.org
--- copyright:
+copyright:          Madeleine Sydney Ślaga
 category:           Language
 build-type:         Simple
 extra-doc-files:    README.md
 -- extra-source-files:
+tested-with:        GHC==9.6.2
 
 common warnings
 --    ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-unused-top-binds
+    ghc-options: -fdefer-typed-holes
 
 library
     import:           warnings
@@ -22,53 +24,102 @@ library
                     , TI
                     , GM
                     , Compiler.RLPC
+                    , Compiler.RlpcError
+                    , Compiler.JustRun
                     , Core.Syntax
                     , Core.Examples
                     , Core.Utils
                     , Core.TH
-
-    other-modules:    Data.Heap
+                    , Core.HindleyMilner
+                    , Control.Monad.Errorful
+                    , Rlp.Syntax
+                    , Rlp.AltSyntax
+                    , Rlp.AltParse
+                    , Rlp.HindleyMilner
+                    , Rlp.HindleyMilner.Visual
+                    , Rlp.HindleyMilner.Types
+                    , Rlp.Syntax.Backstage
+                    , Rlp.Syntax.Types
+                    -- , Rlp.Parse.Decls
+                    , Rlp.Parse
+                    , Rlp.Parse.Associate
+                    , Rlp.Lex
+                    , Rlp.Parse.Types
+                    , Rlp.TH
+                    , Compiler.Types
+                    , Data.Heap
                     , Data.Pretty
                     , Core.Parse
+                    , Core.Parse.Types
                     , Core.Lex
-                    , Control.Monad.Errorful
                     , Core2Core
-                    , RLP.Syntax
+                    , Rlp2Core
+                    , Control.Monad.Utils
+                    , Misc
+                    , Misc.MonadicRecursionSchemes
+                    , Misc.Lift1
+                    , Misc.CofreeF
+                    , Core.SystemF
 
     build-tool-depends: happy:happy, alex:alex
 
     -- other-extensions:
-    build-depends:    base ^>=4.18.0.0
-                    , containers
-                    , microlens
-                    , microlens-th
-                    , mtl
-                    , template-haskell
+    build-depends:    base >=4.17 && <4.21
                     -- 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.23
+                    , 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.3
+                    , 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
+                    , semigroupoids >=6.0 && <6.1
+                    , comonad >=5.0.0 && <6
+                    , lens >=5.2.3 && <6.0
+                    , text-ansi >=0.2.0 && <0.4
+                    , effectful-core ^>=2.3.0.0
+                    , deriving-compat ^>=0.6.0
+                    , these >=0.2 && <2.0
+                    , free >=5.2
+                    , bifunctors >=5.2
+                    , aeson >=2.2.1.0 && <2.3.1.0
+                    , lens-aeson
 
     hs-source-dirs:   src
     default-language: GHC2021
 
+    default-extensions:
+        OverloadedStrings
+        TypeFamilies
+        LambdaCase
+        ViewPatterns
+        DataKinds
+        DerivingVia
+        StandaloneDeriving
+        DerivingStrategies
+        BlockArguments
+
 executable rlpc
     import:           warnings
     main-is:          Main.hs
-    -- other-modules:
-    -- other-extensions:
-    build-depends: base ^>=4.18.0.0
+    other-modules:    RlpDriver
+                    , CoreDriver
+                    , Server
+
+    build-depends: base >=4.17.0.0 && <4.20.0.0
                  , rlp
-                 , optparse-applicative
-                 , microlens
-                 , microlens-mtl
-                 , mtl
-                 , unordered-containers
+                 , optparse-applicative >= 0.18.1 && < 0.19
+                 , mtl >= 2.3.1 && < 2.4
+                 , unordered-containers >= 0.2.20 && < 0.3
+                 , lens >=5.2.3 && <6.0
+                 , text >= 2.0.2 && < 2.3
 
     hs-source-dirs:   app
     default-language: GHC2021
@@ -84,7 +135,11 @@ test-suite rlp-test
                  , rlp
                  , QuickCheck
                  , hspec            ==2.*
+                 , microlens
+                 , lens >=5.2.3 && <6.0
     other-modules: Arith
                  , GMSpec
+                 , Core.HindleyMilnerSpec
+                 , Compiler.TypesSpec
     build-tool-depends: hspec-discover:hspec-discover
 

rlpc.drawio

@@ -0,0 +1,263 @@
+<mxfile host="app.diagrams.net" modified="2024-04-05T21:39:15.427Z" agent="Mozilla/5.0 (Macintosh; Intel Mac OS X 10.15; rv:124.0) Gecko/20100101 Firefox/124.0" etag="vzU3tfRucuQcOEqioBHC" version="23.1.2" type="device">
+  <diagram name="Page-1" id="ijVUcW-Be2043inOeyM6">
+    <mxGraphModel dx="1792" dy="2289" grid="1" gridSize="10" guides="1" tooltips="1" connect="1" arrows="1" fold="1" page="1" pageScale="1" pageWidth="827" pageHeight="1169" math="0" shadow="0">
+      <root>
+        <mxCell id="0" />
+        <mxCell id="1" parent="0" />
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-64" value="&lt;div&gt;&lt;font face=&quot;Helvetica&quot;&gt;rl&#39; source code&lt;/font&gt;&lt;/div&gt;" style="rounded=0;whiteSpace=wrap;html=1;fillColor=#fff2cc;strokeColor=#d6b656;fontFamily=Courier New;" parent="1" vertex="1">
+          <mxGeometry x="10" y="154.92" width="120" height="60" as="geometry" />
+        </mxCell>
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-72" value="" style="group;fontFamily=Courier New;" parent="1" vertex="1" connectable="0">
+          <mxGeometry x="150" y="-60" width="1440" height="780" as="geometry" />
+        </mxCell>
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-2" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-72" vertex="1">
+          <mxGeometry width="1440" height="780" as="geometry" />
+        </mxCell>
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-3" value="&lt;div&gt;&lt;font face=&quot;Helvetica&quot;&gt;RLPC&lt;/font&gt;&lt;/div&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-2" vertex="1">
+          <mxGeometry width="1440" height="76.09756097560975" as="geometry" />
+        </mxCell>
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-56" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-2" vertex="1">
+          <mxGeometry x="38.4" y="68.42" width="431.6" height="221.58" as="geometry" />
+        </mxCell>
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-57" value="&lt;div&gt;&lt;font face=&quot;Helvetica&quot;&gt;Parser&lt;/font&gt;&lt;/div&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-56" vertex="1">
+          <mxGeometry width="431.6" height="27.6975" as="geometry" />
+        </mxCell>
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-58" value="Rlp.AltParse&lt;br&gt;&lt;div&gt;(src/Rlp/AltParse.y)&lt;/div&gt;" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;whiteSpace=wrap;points=[];strokeColor=#6c8ebf;fillColor=#dae8fc;glass=0;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-56" vertex="1">
+          <mxGeometry x="26.980533333333334" y="27.6975" width="371.43053333333336" height="55.395" as="geometry" />
+        </mxCell>
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-59" value="&lt;div&gt;Rlp.Lex&lt;/div&gt;&lt;div&gt;&lt;br&gt;&lt;/div&gt;&lt;div&gt;(src/Rlp/Lex.x)&lt;br&gt;&lt;/div&gt;" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-56" vertex="1">
+          <mxGeometry x="26.98606666666666" y="147.72" width="170.33402285714286" height="55.395" as="geometry" />
+        </mxCell>
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-61" value="" style="endArrow=classic;html=1;rounded=0;fontFamily=Courier New;exitX=0.25;exitY=0;exitDx=0;exitDy=0;" parent="l7NxJpuHm0Jx_7flO9iA-56" source="l7NxJpuHm0Jx_7flO9iA-59" edge="1">
+          <mxGeometry relative="1" as="geometry">
+            <mxPoint x="111.49666666666668" y="147.72" as="sourcePoint" />
+            <mxPoint x="69.26631355932203" y="83.84879190161169" as="targetPoint" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-62" value="&lt;div&gt;RlpToken&lt;/div&gt;" style="edgeLabel;resizable=0;html=1;align=center;verticalAlign=middle;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-61" connectable="0" vertex="1">
+          <mxGeometry relative="1" as="geometry">
+            <mxPoint x="-33" y="5" as="offset" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-74" value="&lt;div&gt;Rlp.Parse.Associate&lt;/div&gt;" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-56" vertex="1">
+          <mxGeometry x="244.26979047619054" y="147.72" width="154.14285714285714" height="55.395" as="geometry" />
+        </mxCell>
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-75" value="" style="endArrow=classic;html=1;rounded=0;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-56" source="l7NxJpuHm0Jx_7flO9iA-58" target="l7NxJpuHm0Jx_7flO9iA-74" edge="1">
+          <mxGeometry relative="1" as="geometry">
+            <mxPoint x="271.29142857142864" y="175.4175" as="sourcePoint" />
+            <mxPoint x="394.60571428571427" y="175.4175" as="targetPoint" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-77" value="&lt;div&gt;Rlp.Program PsName RlpExpr&#39;&lt;br&gt;&lt;/div&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-75" vertex="1" connectable="0">
+          <mxGeometry x="0.0677" y="5" relative="1" as="geometry">
+            <mxPoint x="39" y="6" as="offset" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-3" value="" style="endArrow=classic;html=1;rounded=0;exitX=0.368;exitY=1.014;exitDx=0;exitDy=0;exitPerimeter=0;entryX=0.811;entryY=-0.021;entryDx=0;entryDy=0;entryPerimeter=0;" parent="l7NxJpuHm0Jx_7flO9iA-56" source="l7NxJpuHm0Jx_7flO9iA-58" target="l7NxJpuHm0Jx_7flO9iA-59" edge="1">
+          <mxGeometry width="50" height="50" relative="1" as="geometry">
+            <mxPoint x="168.70805084745763" y="201.9041131288017" as="sourcePoint" />
+            <mxPoint x="225.8584745762712" y="152.71439595080588" as="targetPoint" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-4" value="&lt;p style=&quot;line-height: 60%;&quot;&gt;&lt;font style=&quot;font-size: 7px;&quot;&gt;(lexer &amp;amp; parser threaded w/ CPS)&lt;/font&gt;&lt;/p&gt;" style="text;html=1;strokeColor=none;fillColor=none;align=center;verticalAlign=middle;whiteSpace=wrap;rounded=0;" parent="l7NxJpuHm0Jx_7flO9iA-56" vertex="1">
+          <mxGeometry x="88.69745762711862" y="103.52467877281002" width="68.58050847457626" height="29.513830306797498" as="geometry" />
+        </mxCell>
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-69" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-2" vertex="1">
+          <mxGeometry x="38.4" y="531.8231578947368" width="431.6" height="230.4557894736842" as="geometry" />
+        </mxCell>
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-70" value="&lt;div&gt;&lt;font face=&quot;Helvetica&quot;&gt;Desugarer&lt;/font&gt;&lt;/div&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-69" vertex="1">
+          <mxGeometry width="431.6" height="46.091157894736845" as="geometry" />
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-1" value="&lt;div&gt;Rlp2Core&lt;/div&gt;" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-69" vertex="1">
+          <mxGeometry x="22.122266666666665" y="46.088669843028626" width="387.34440000000006" height="159.17559608494923" as="geometry" />
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-6" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-2" vertex="1">
+          <mxGeometry x="904" y="68.42105263157895" width="244.8600518134714" height="697.8947368421053" as="geometry" />
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-7" value="&lt;font face=&quot;Helvetica&quot;&gt;Evaluation Model&lt;br&gt;&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" parent="MMc0v0DIyy0xya0iXp__-6" vertex="1">
+          <mxGeometry width="186.6" height="107.07065060420568" as="geometry" />
+        </mxCell>
+        <mxCell id="DDBEc0rYRfbomnRGFAIR-4" value="GM" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;verticalAlign=top;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
+          <mxGeometry x="10" y="70" width="220" height="260.78" as="geometry" />
+        </mxCell>
+        <mxCell id="DDBEc0rYRfbomnRGFAIR-5" value="&lt;font face=&quot;Courier New&quot;&gt;compile&lt;/font&gt;" style="rounded=1;whiteSpace=wrap;html=1;fillColor=#d5e8d4;strokeColor=#82b366;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
+          <mxGeometry x="26" y="91.58" width="184" height="37.03" as="geometry" />
+        </mxCell>
+        <mxCell id="DDBEc0rYRfbomnRGFAIR-6" value="&lt;font face=&quot;Courier New&quot;&gt;eval&lt;/font&gt;" style="rounded=1;whiteSpace=wrap;html=1;fillColor=#d5e8d4;strokeColor=#82b366;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
+          <mxGeometry x="26" y="211.58" width="184" height="37.03" as="geometry" />
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-32" value="" style="endArrow=classic;html=1;rounded=0;entryX=0.5;entryY=0;entryDx=0;entryDy=0;exitX=0.5;exitY=1;exitDx=0;exitDy=0;" parent="MMc0v0DIyy0xya0iXp__-6" source="DDBEc0rYRfbomnRGFAIR-5" target="DDBEc0rYRfbomnRGFAIR-6" edge="1">
+          <mxGeometry width="50" height="50" relative="1" as="geometry">
+            <mxPoint x="-94" y="520" as="sourcePoint" />
+            <mxPoint x="-44" y="451.57894736842104" as="targetPoint" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-33" value="&lt;font face=&quot;Courier New&quot;&gt;[Instr]&lt;/font&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];" parent="MMc0v0DIyy0xya0iXp__-32" vertex="1" connectable="0">
+          <mxGeometry x="0.0406" y="1" relative="1" as="geometry">
+            <mxPoint as="offset" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="DDBEc0rYRfbomnRGFAIR-7" value="" style="curved=1;endArrow=classic;html=1;rounded=0;entryX=0.922;entryY=0.046;entryDx=0;entryDy=0;entryPerimeter=0;" edge="1" parent="MMc0v0DIyy0xya0iXp__-6" target="DDBEc0rYRfbomnRGFAIR-6">
+          <mxGeometry width="50" height="50" relative="1" as="geometry">
+            <mxPoint x="210" y="231.57894736842104" as="sourcePoint" />
+            <mxPoint x="260" y="181.57894736842104" as="targetPoint" />
+            <Array as="points">
+              <mxPoint x="226" y="231.57894736842104" />
+              <mxPoint x="236" y="201.57894736842104" />
+              <mxPoint x="236" y="191.57894736842104" />
+              <mxPoint x="226" y="181.57894736842104" />
+              <mxPoint x="206" y="181.57894736842104" />
+              <mxPoint x="196" y="191.57894736842104" />
+            </Array>
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="DDBEc0rYRfbomnRGFAIR-8" value="&lt;font face=&quot;Courier New&quot;&gt;GMState&lt;/font&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];" vertex="1" connectable="0" parent="MMc0v0DIyy0xya0iXp__-6">
+          <mxGeometry x="216" y="171.58333333333314" as="geometry">
+            <mxPoint x="-4" y="-1" as="offset" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-12" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-2" vertex="1">
+          <mxGeometry x="530" y="68.42" width="281.6" height="314.74" as="geometry" />
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-13" value="&lt;div&gt;&lt;font face=&quot;Helvetica&quot;&gt;Preprocessing&lt;/font&gt;&lt;/div&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" parent="MMc0v0DIyy0xya0iXp__-12" vertex="1">
+          <mxGeometry width="281.5999999999999" height="24.68549019607843" as="geometry" />
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-15" value="Core2Core" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;verticalAlign=top;" parent="MMc0v0DIyy0xya0iXp__-12" vertex="1">
+          <mxGeometry x="22.25077720207253" y="49.37098039215686" width="237.09844559585483" height="259.1976470588235" as="geometry" />
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-16" value="&lt;font face=&quot;Courier New&quot;&gt;tagData&lt;/font&gt;" style="rounded=1;whiteSpace=wrap;html=1;fillColor=#d5e8d4;strokeColor=#82b366;" parent="MMc0v0DIyy0xya0iXp__-12" vertex="1">
+          <mxGeometry x="31.36994818652857" y="74.0564705882353" width="218.860103626943" height="37.02823529411765" as="geometry" />
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-18" value="&lt;font face=&quot;Courier New&quot;&gt;defineData&lt;/font&gt;" style="rounded=1;whiteSpace=wrap;html=1;fillColor=#d5e8d4;strokeColor=#82b366;" parent="MMc0v0DIyy0xya0iXp__-12" vertex="1">
+          <mxGeometry x="31.36994818652857" y="160.45568627450984" width="218.860103626943" height="37.02823529411765" as="geometry" />
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-17" value="&lt;font face=&quot;Courier New&quot;&gt;liftNonStrictCases&lt;/font&gt;" style="rounded=1;whiteSpace=wrap;html=1;fillColor=#d5e8d4;strokeColor=#82b366;" parent="MMc0v0DIyy0xya0iXp__-12" vertex="1">
+          <mxGeometry x="31.369948186528582" y="118.66932274509804" width="218.860103626943" height="37.02823529411765" as="geometry" />
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-27" value="" style="endArrow=classic;html=1;rounded=0;entryX=-0.019;entryY=0.844;entryDx=0;entryDy=0;entryPerimeter=0;exitX=0.98;exitY=0.066;exitDx=0;exitDy=0;exitPerimeter=0;" parent="l7NxJpuHm0Jx_7flO9iA-2" source="MMc0v0DIyy0xya0iXp__-1" target="MMc0v0DIyy0xya0iXp__-12" edge="1">
+          <mxGeometry width="50" height="50" relative="1" as="geometry">
+            <mxPoint x="450" y="684.2105263157895" as="sourcePoint" />
+            <mxPoint x="500" y="615.7894736842105" as="targetPoint" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-28" value="&lt;font face=&quot;Courier New&quot;&gt;Core.Program Var&lt;br&gt;&lt;/font&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];" parent="MMc0v0DIyy0xya0iXp__-27" vertex="1" connectable="0">
+          <mxGeometry x="-0.1473" y="1" relative="1" as="geometry">
+            <mxPoint x="7" y="1" as="offset" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-30" value="" style="endArrow=classic;html=1;rounded=0;entryX=-0.013;entryY=0.321;entryDx=0;entryDy=0;exitX=1;exitY=0.5;exitDx=0;exitDy=0;entryPerimeter=0;" parent="l7NxJpuHm0Jx_7flO9iA-2" source="MMc0v0DIyy0xya0iXp__-12" target="MMc0v0DIyy0xya0iXp__-6" edge="1">
+          <mxGeometry width="50" height="50" relative="1" as="geometry">
+            <mxPoint x="810" y="588.421052631579" as="sourcePoint" />
+            <mxPoint x="860" y="520" as="targetPoint" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-31" value="&lt;font face=&quot;Courier New&quot;&gt;Core.Program Name&lt;br&gt;&lt;/font&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];" parent="MMc0v0DIyy0xya0iXp__-30" vertex="1" connectable="0">
+          <mxGeometry x="0.0097" y="-1" relative="1" as="geometry">
+            <mxPoint x="-1" as="offset" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-35" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-2" vertex="1">
+          <mxGeometry x="530" y="630" width="281.6" height="131.32" as="geometry" />
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-36" value="&lt;font face=&quot;Helvetica&quot;&gt;Core Parser&lt;br&gt;&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" parent="MMc0v0DIyy0xya0iXp__-35" vertex="1">
+          <mxGeometry width="281.59999999999997" height="10.299607843137254" as="geometry" />
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-41" value="Core.Lex" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" parent="MMc0v0DIyy0xya0iXp__-35" vertex="1">
+          <mxGeometry x="10.140518134715029" y="16.369019607843132" width="87.1306390328152" height="106.24535947712415" as="geometry" />
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-42" value="Core.Parse" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" parent="MMc0v0DIyy0xya0iXp__-35" vertex="1">
+          <mxGeometry x="182.3834196891192" y="16.369019607843146" width="87.1306390328152" height="106.24535947712415" as="geometry" />
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-43" value="&lt;font face=&quot;Courier New&quot;&gt;CoreToken&lt;/font&gt;" style="endArrow=classic;html=1;rounded=0;entryX=0;entryY=0.5;entryDx=0;entryDy=0;exitX=1;exitY=0.5;exitDx=0;exitDy=0;" parent="MMc0v0DIyy0xya0iXp__-35" source="MMc0v0DIyy0xya0iXp__-41" target="MMc0v0DIyy0xya0iXp__-42" edge="1">
+          <mxGeometry width="50" height="50" relative="1" as="geometry">
+            <mxPoint x="-72.95336787564769" y="39.35921568627452" as="sourcePoint" />
+            <mxPoint x="-12.15889464594128" y="1.0422222222222326" as="targetPoint" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-51" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-2" vertex="1">
+          <mxGeometry x="530" y="440" width="281.6" height="131.32" as="geometry" />
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-52" value="&lt;font face=&quot;Helvetica&quot;&gt;Core Type-checker&lt;br&gt;&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" parent="MMc0v0DIyy0xya0iXp__-51" vertex="1">
+          <mxGeometry width="281.59999999999997" height="10.299607843137254" as="geometry" />
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-46" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-72" vertex="1">
+          <mxGeometry x="40" y="360" width="431.6" height="90.46" as="geometry" />
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-47" value="&lt;font face=&quot;Verdana&quot;&gt;Type-checker&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" parent="MMc0v0DIyy0xya0iXp__-46" vertex="1">
+          <mxGeometry width="431.6" height="18.092000000000002" as="geometry" />
+        </mxCell>
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-80" value="" style="endArrow=classic;html=1;rounded=0;" parent="l7NxJpuHm0Jx_7flO9iA-72" source="DDBEc0rYRfbomnRGFAIR-1" target="MMc0v0DIyy0xya0iXp__-46" edge="1">
+          <mxGeometry relative="1" as="geometry">
+            <mxPoint x="537.6" y="424.2105263157895" as="sourcePoint" />
+            <mxPoint x="-40" y="490" as="targetPoint" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-49" value="" style="endArrow=classic;html=1;rounded=0;" parent="l7NxJpuHm0Jx_7flO9iA-72" source="MMc0v0DIyy0xya0iXp__-46" target="l7NxJpuHm0Jx_7flO9iA-69" edge="1">
+          <mxGeometry relative="1" as="geometry">
+            <mxPoint x="352" y="282" as="sourcePoint" />
+            <mxPoint x="295" y="370" as="targetPoint" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-50" value="&lt;font face=&quot;Courier New&quot;&gt;Rlp.Program PsName (Cofree RlpExprF&#39; Type&#39;)&lt;br&gt;&lt;/font&gt;" style="edgeLabel;resizable=0;html=1;align=center;verticalAlign=middle;" parent="MMc0v0DIyy0xya0iXp__-49" connectable="0" vertex="1">
+          <mxGeometry relative="1" as="geometry">
+            <mxPoint x="6" as="offset" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-57" value="Core.HindleyMilner" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-72" vertex="1">
+          <mxGeometry x="540" y="460" width="260" height="106.24" as="geometry" />
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-58" value="" style="endArrow=classic;html=1;rounded=0;" parent="l7NxJpuHm0Jx_7flO9iA-72" source="MMc0v0DIyy0xya0iXp__-42" target="MMc0v0DIyy0xya0iXp__-57" edge="1">
+          <mxGeometry width="50" height="50" relative="1" as="geometry">
+            <mxPoint x="530" y="550" as="sourcePoint" />
+            <mxPoint x="580" y="500" as="targetPoint" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-59" value="Core.Program PsName" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];fontFamily=Courier New;" parent="MMc0v0DIyy0xya0iXp__-58" vertex="1" connectable="0">
+          <mxGeometry x="-0.0188" y="-3" relative="1" as="geometry">
+            <mxPoint y="-1" as="offset" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-60" value="" style="endArrow=classic;html=1;rounded=0;" parent="l7NxJpuHm0Jx_7flO9iA-72" source="MMc0v0DIyy0xya0iXp__-57" target="MMc0v0DIyy0xya0iXp__-15" edge="1">
+          <mxGeometry width="50" height="50" relative="1" as="geometry">
+            <mxPoint x="741" y="656" as="sourcePoint" />
+            <mxPoint x="704" y="576" as="targetPoint" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-61" value="Core.Program Var" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];fontFamily=Courier New;" parent="MMc0v0DIyy0xya0iXp__-60" vertex="1" connectable="0">
+          <mxGeometry x="-0.0188" y="-3" relative="1" as="geometry">
+            <mxPoint y="-1" as="offset" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="DDBEc0rYRfbomnRGFAIR-1" value="Rlp.HindleyMilner" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-72">
+          <mxGeometry x="49.47" y="380" width="410.53" height="60" as="geometry" />
+        </mxCell>
+        <mxCell id="DDBEc0rYRfbomnRGFAIR-2" value="" style="endArrow=classic;html=1;rounded=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-72" source="l7NxJpuHm0Jx_7flO9iA-74" target="DDBEc0rYRfbomnRGFAIR-1">
+          <mxGeometry relative="1" as="geometry">
+            <mxPoint x="492" y="212" as="sourcePoint" />
+            <mxPoint x="435" y="300" as="targetPoint" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="DDBEc0rYRfbomnRGFAIR-3" value="&lt;font face=&quot;Courier New&quot;&gt;Rlp.Program PsName RlpExpr&#39;&lt;br&gt;&lt;/font&gt;" style="edgeLabel;resizable=0;html=1;align=center;verticalAlign=middle;" connectable="0" vertex="1" parent="DDBEc0rYRfbomnRGFAIR-2">
+          <mxGeometry relative="1" as="geometry">
+            <mxPoint x="6" as="offset" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-65" value="" style="endArrow=classic;html=1;rounded=0;fontFamily=Courier New;" parent="1" source="l7NxJpuHm0Jx_7flO9iA-64" target="l7NxJpuHm0Jx_7flO9iA-59" edge="1">
+          <mxGeometry width="50" height="50" relative="1" as="geometry">
+            <mxPoint x="290" y="400" as="sourcePoint" />
+            <mxPoint x="340" y="350" as="targetPoint" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-26" value="&lt;font face=&quot;Helvetica&quot;&gt;Core source code&lt;br&gt;&lt;/font&gt;" style="rounded=0;whiteSpace=wrap;html=1;fillColor=#fff2cc;strokeColor=#d6b656;fontFamily=Courier New;" parent="1" vertex="1">
+          <mxGeometry x="673.7099999999999" y="740" width="120" height="60" as="geometry" />
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-34" value="" style="endArrow=classic;html=1;rounded=0;exitX=0.5;exitY=0;exitDx=0;exitDy=0;" parent="1" source="MMc0v0DIyy0xya0iXp__-26" target="MMc0v0DIyy0xya0iXp__-41" edge="1">
+          <mxGeometry width="50" height="50" relative="1" as="geometry">
+            <mxPoint x="960" y="370" as="sourcePoint" />
+            <mxPoint x="690" y="570" as="targetPoint" />
+          </mxGeometry>
+        </mxCell>
+      </root>
+    </mxGraphModel>
+  </diagram>
+</mxfile>

src/Compiler/JustRun.hs

@@ -0,0 +1,86 @@
+{-|
+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
+    ( justLexCore
+    , justParseCore
+    , justParseRlp
+    , justTypeCheckCore
+    , justHdbg
+    , justInferRlp
+    , makeItPretty, makeItPretty'
+    )
+    where
+----------------------------------------------------------------------------------
+import Core.Lex
+import Core.Parse
+import Core.HindleyMilner
+import Core.Syntax
+import Compiler.RLPC
+import Control.Arrow                    ((>>>))
+import Control.Monad                    ((>=>), void)
+import Control.Comonad
+import Control.Lens
+import Data.Text                        qualified as T
+import Data.Function                    ((&))
+import System.IO
+import GM
+import Rlp2Core
+import Data.Pretty
+
+import Rlp.AltParse
+import Rlp.AltSyntax                    qualified as Rlp
+import Rlp.HindleyMilner
+----------------------------------------------------------------------------------
+
+justHdbg :: String -> IO GmState
+justHdbg = undefined
+-- justHdbg s = do
+--     p <- evalRLPCIO def (parseRlpProgR >=> desugarRlpProgR $ T.pack s)
+--     withFile "/tmp/t.log" WriteMode $ hdbgProg p
+
+justLexCore :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
+justLexCore s = lexCoreR (T.pack s)
+              & mapped . each %~ extract
+              & rlpcToEither
+
+justParseCore :: String -> Either [MsgEnvelope RlpcError] (Program Var)
+justParseCore s = parse (T.pack s)
+                & rlpcToEither
+    where parse = lexCoreR @Identity >=> parseCoreProgR
+
+justParseRlp :: String
+             -> Either [MsgEnvelope RlpcError]
+                       (Rlp.Program Name (Rlp.RlpExpr Name))
+justParseRlp s = parse (T.pack s)
+               & rlpcToEither
+    where parse = parseRlpProgR @Identity
+
+justTypeCheckCore :: String -> Either [MsgEnvelope RlpcError] Program'
+justTypeCheckCore s = typechk (T.pack s)
+                    & rlpcToEither
+    where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR
+
+justInferRlp :: String
+              -> Either [MsgEnvelope RlpcError]
+                  (Rlp.Program Rlp.PsName Rlp.TypedRlpExpr')
+justInferRlp s = infr (T.pack s) & rlpcToEither
+    where infr = parseRlpProgR >=> typeCheckRlpProgR
+
+makeItPretty :: (Out a) => Either e a -> Either e (Doc ann)
+makeItPretty = fmap out
+
+makeItPretty' :: (Out (WithTerseBinds a)) => Either e a -> Either e (Doc ann)
+makeItPretty' = fmap (out . WithTerseBinds)
+
+rlpcToEither :: RLPC a -> Either [MsgEnvelope RlpcError] a
+rlpcToEither r = case evalRLPC def r of
+    (Just a,   _) -> Right a
+    (Nothing, es) -> Left es
+

src/Compiler/RLPC.hs

@@ -10,96 +10,128 @@ errors and the family of RLPC monads.
 {-# LANGUAGE TemplateHaskell #-}
 -- only used for mtl instances
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia #-}
+{-# LANGUAGE BlockArguments, ViewPatterns #-}
 module Compiler.RLPC
-    ( RLPC
-    , RLPCT
-    , RLPCIO
-    , RLPCOptions(RLPCOptions)
-    , addFatal
-    , addWound
-    , MonadErrorful
-    , Severity(..)
-    , Evaluator(..)
-    , evalRLPCT
-    , evalRLPCIO
-    , evalRLPC
-    , rlpcLogFile
-    , rlpcDebugOpts
-    , rlpcEvaluator
-    , rlpcInputFiles
-    , DebugFlag(..)
-    , whenFlag
-    , flagDDumpEval
-    , flagDDumpOpts
-    , flagDDumpAST
-    , def
+    (
+    -- * Rlpc Monad transformer
+      RLPCT(RLPCT),
+    -- ** Special cases
+      RLPC, RLPCIO
+    , liftIO
+    -- ** Running
+    , runRLPCT
+    , evalRLPCT, evalRLPCIO, evalRLPC
+    -- * Rlpc options
+    , Language(..), Evaluator(..)
+    , DebugFlag(..), CompilerFlag(..)
+    -- ** Lenses
+    , rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage
+    , rlpcServer
+    -- * Misc. MTL-style functions
+    , liftErrorful, liftEither, liftMaybe, hoistRlpcT
+    -- * Misc. Rlpc Monad -related types
+    , RLPCOptions(RLPCOptions), IsRlpcError(..), RlpcError(..)
+    , MsgEnvelope(..), Severity(..)
+    , addDebugMsg
+    , whenDFlag, whenFFlag
+    -- * Misc. Utilities
+    , forFiles_, withSource
+    -- * Convenient re-exports
+    , addFatal, addWound, def
     )
     where
 ----------------------------------------------------------------------------------
 import Control.Arrow            ((>>>))
 import Control.Exception
+import Control.Monad
 import Control.Monad.Reader
 import Control.Monad.State      (MonadState(state))
 import Control.Monad.Errorful
+import Control.Monad.IO.Class
+import Compiler.RlpcError
+import Compiler.Types
 import Data.Functor.Identity
 import Data.Default.Class
+import Data.Foldable
 import GHC.Generics             (Generic)
+import Data.Maybe
+import Data.Pretty
 import Data.Hashable            (Hashable)
 import Data.HashSet             (HashSet)
 import Data.HashSet             qualified as S
 import Data.Coerce
-import Lens.Micro
-import Lens.Micro.TH
+import Data.Text                (Text)
+import Data.Text                qualified as T
+import Data.Text.IO             qualified as T
+import System.IO
+import Text.ANSI                qualified as Ansi
+import Control.Lens
+import Data.Text.Lens           (packed, unpacked, IsText)
+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
+             , MonadReader RLPCOptions, MonadErrorful (MsgEnvelope RlpcError))
 
-deriving instance (MonadIO m) => MonadIO (RLPCT e m)
+rlpc :: (IsRlpcError e, Monad m)
+     => (RLPCOptions -> (Maybe a, [MsgEnvelope e]))
+     -> RLPCT m a
+rlpc f = RLPCT . ReaderT $ \opt ->
+    ErrorfulT . pure $ f opt & _2 . each . mapped %~ liftRlpcError
 
-instance MonadTrans (RLPCT e) where
+type RLPC = RLPCT Identity
+
+type RLPCIO = RLPCT IO
+
+instance MonadTrans RLPCT 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
+instance (MonadIO m) => MonadIO (RLPCT m) where
+    liftIO = lift . liftIO
 
 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 :: RLPCOptions
+          -> RLPCT m a
+          -> m (Maybe a, [MsgEnvelope RlpcError])
+evalRLPCT opt r = runRLPCT r
+                & flip runReaderT opt
+                & runErrorfulT
+
+liftErrorful :: (Monad m, IsRlpcError e) => ErrorfulT (MsgEnvelope e) m a -> RLPCT m a
+liftErrorful e = RLPCT $ lift (fmap liftRlpcError `mapErrorful` e)
+
+liftMaybe :: (Monad m) => Maybe a -> RLPCT m a
+liftMaybe m = RLPCT . lift . ErrorfulT . pure $ (m, [])
+
+liftEither :: (Monad m, IsRlpcError e)
+           => Either [e] a -> RLPCT m a
+liftEither = RLPCT . lift . ErrorfulT . pure . f where
+    f (Left es) = (Nothing, errorMsg s . liftRlpcError <$> es)
+        where s = SrcSpan 0 0 0 0
+    f (Right a) = (Just a, [])
+
+hoistRlpcT :: (forall a. m a -> n a)
+         -> RLPCT m a -> RLPCT n a
+hoistRlpcT f rma = RLPCT $ ReaderT $ \opt ->
+    ErrorfulT $ f $ evalRLPCT opt rma
 
 data RLPCOptions = RLPCOptions
     { _rlpcLogFile     :: Maybe FilePath
-    , _rlpcDebugOpts   :: DebugOpts
+    , _rlpcDFlags      :: HashSet DebugFlag
+    , _rlpcFFlags      :: HashSet CompilerFlag
     , _rlpcEvaluator   :: Evaluator
     , _rlpcHeapTrigger :: Int
+    , _rlpcLanguage    :: Maybe Language
+    , _rlpcServer      :: Bool
     , _rlpcInputFiles  :: [FilePath]
     }
     deriving Show
@@ -107,58 +139,126 @@ 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
+data Language = LanguageRlp | LanguageCore
+    deriving Show
 
 ----------------------------------------------------------------------------------
 
 instance Default RLPCOptions where
     def = RLPCOptions
         { _rlpcLogFile = Nothing
-        , _rlpcDebugOpts = mempty
+        , _rlpcDFlags = mempty
+        , _rlpcFFlags = mempty
         , _rlpcEvaluator = EvaluatorGM
         , _rlpcHeapTrigger = 200
         , _rlpcInputFiles = []
+        , _rlpcServer = False
+        , _rlpcLanguage = Nothing
         }
 
-type DebugOpts = HashSet DebugFlag
+-- debug flags are passed with -dFLAG
+type DebugFlag = Text
 
-data DebugFlag = DDumpEval
-               | DDumpOpts
-               | DDumpAST
-               deriving (Show, Eq, Generic)
-
-instance Hashable DebugFlag
+type CompilerFlag = Text
 
 makeLenses ''RLPCOptions
 pure []
 
-whenFlag :: (MonadReader s m) => SimpleGetter s Bool -> m () -> m ()
-whenFlag l m = asks (^. l) >>= \a -> if a then m else pure ()
+addDebugMsg :: (Monad m, IsText e) => Text -> e -> RLPCT m ()
+addDebugMsg tag e = addWound . debugMsg tag $ Text [e ^. unpacked . packed]
 
--- there's probably a better way to write this. my current knowledge of lenses
--- is too weak.
-flagGetter :: DebugFlag -> SimpleGetter RLPCOptions Bool
-flagGetter d = to $ \s -> s ^. rlpcDebugOpts & S.member d
+-- TODO: rewrite this with prisms once microlens-pro drops :3
+whenDFlag :: (Monad m) => DebugFlag -> RLPCT m () -> RLPCT m ()
+whenDFlag f m = do
+    -- mfw no `At` instance for HashSet
+    fs <- view rlpcDFlags
+    let a = S.member f fs
+    when a m
 
-flagDDumpEval :: SimpleGetter RLPCOptions Bool
-flagDDumpEval = flagGetter DDumpEval
+whenFFlag :: (Monad m) => CompilerFlag -> RLPCT m () -> RLPCT m ()
+whenFFlag f m = do
+    -- mfw no `At` instance for HashSet
+    fs <- view rlpcFFlags
+    let a = S.member f fs
+    when a m
 
-flagDDumpOpts :: SimpleGetter RLPCOptions Bool
-flagDDumpOpts = flagGetter DDumpOpts
+--------------------------------------------------------------------------------
 
-flagDDumpAST :: SimpleGetter RLPCOptions Bool
-flagDDumpAST = flagGetter DDumpAST
+evalRLPCIO :: RLPCOptions -> RLPCIO a -> IO a
+evalRLPCIO opt r = do
+    (ma,es) <- evalRLPCT opt r
+    putRlpcErrs opt es
+    case ma of
+        Just x  -> pure x
+        Nothing -> die "Failed, no code compiled."
+
+putRlpcErrs :: RLPCOptions -> [MsgEnvelope RlpcError] -> IO ()
+putRlpcErrs opt es = case opt ^. rlpcLogFile of
+    Just lf -> withFile lf WriteMode putter
+    Nothing -> putter stderr
+  where
+    putter h = hPutStrLn h `traverse_` renderRlpcErrs opt es
+
+renderRlpcErrs :: RLPCOptions -> [MsgEnvelope RlpcError] -> [String]
+renderRlpcErrs opts = (if don'tBother then id else filter byTag)
+                  >>> fmap prettyRlpcMsg
+    where
+        dflags = opts ^. rlpcDFlags
+        don'tBother = "ALL" `S.member` (opts ^. rlpcDFlags)
+
+        byTag :: MsgEnvelope RlpcError -> Bool
+        byTag (view msgSeverity -> SevDebug t) =
+            t `S.member` dflags
+        byTag _ = True
+
+prettyRlpcMsg :: MsgEnvelope RlpcError -> String
+prettyRlpcMsg m@(view msgSeverity -> SevDebug _) = prettyRlpcDebugMsg m
+prettyRlpcMsg m                                  = show $ docRlpcErr m
+
+prettyRlpcDebugMsg :: MsgEnvelope RlpcError -> String
+prettyRlpcDebugMsg msg =
+        T.unpack . foldMap mkLine $ [ t' | t <- ts, t' <- T.lines t ]
+    where
+        mkLine s = "-d" <> tag <> ": " <> s <> "\n"
+        Text ts = msg ^. msgDiagnostic
+        SevDebug tag = msg ^. msgSeverity
+
+docRlpcErr :: MsgEnvelope RlpcError -> Doc ann
+docRlpcErr msg = vcat [ header
+                      , nest 2 bullets
+                      , source ]
+    where
+        source = vcat $ zipWith (<+>) rule srclines
+            where
+                rule = repeat (ttext . Ansi.blue . Ansi.bold $ "|")
+                srclines = ["", "<problematic source code>", ""]
+        filename = msgColour "<input>"
+        pos = msgColour $ tshow (msg ^. msgSpan . srcSpanLine)
+                       <> ":"
+                       <> tshow (msg ^. msgSpan . srcSpanColumn)
+
+        header = ttext $ filename <> msgColour ":" <> pos <> msgColour ": "
+                        <> errorColour "error" <> msgColour ":"
+
+        bullets = let Text ts = msg ^. msgDiagnostic
+                  in vcat $ ("•" <>) . hang 2 . ttext . msgColour <$> ts
+
+        msgColour = Ansi.white . Ansi.bold
+        errorColour = Ansi.red . Ansi.bold
+        tshow :: (Show a) => a -> Text
+        tshow = T.pack . show
+
+--------------------------------------------------------------------------------
+
+forFiles_ :: (Monad m)
+          => (FilePath -> RLPCT m a)
+          -> RLPCT m ()
+forFiles_ k = do
+    fs <- view rlpcInputFiles
+    forM_ fs k
+
+-- TODO: catch any exceptions, i.e. non-existent files should be handled by the
+-- compiler
+withSource :: (MonadIO m) => FilePath -> (Text -> RLPCT m a) -> RLPCT m a
+withSource f k = liftIO (T.readFile f) >>= k
 

src/Compiler/RlpcError.hs

@@ -0,0 +1,98 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
+module Compiler.RlpcError
+    ( IsRlpcError(..)
+    , MsgEnvelope(..)
+    , Severity(..)
+    , RlpcError(..)
+    , msgSpan
+    , msgDiagnostic
+    , msgSeverity
+    , liftRlpcErrors
+    , errorMsg
+    , debugMsg
+    -- * Located Comonad
+    , Located(..)
+    , SrcSpan(..)
+
+    -- * Common error messages
+    , undefinedVariableErr
+    )
+    where
+----------------------------------------------------------------------------------
+import Control.Monad.Errorful
+import Data.Text                (Text)
+import Data.Text                qualified as T
+import GHC.Exts                 (IsString(..))
+import GHC.Generics
+import Control.Lens             hiding ((.=))
+import Compiler.Types
+
+import Data.Aeson
+----------------------------------------------------------------------------------
+
+data MsgEnvelope e = MsgEnvelope
+   { _msgSpan        :: SrcSpan
+   , _msgDiagnostic  :: e
+   , _msgSeverity    :: Severity
+   }
+   deriving (Functor, Show)
+
+instance (ToJSON e) => ToJSON (MsgEnvelope e) where
+    toJSON msg = object
+        [ "span" .= _msgSpan msg
+        , "severity" .= _msgSeverity msg
+        , "diagnostic" .= _msgDiagnostic msg
+        ]
+
+newtype RlpcError = Text [Text]
+    deriving (Show, Generic)
+    deriving (ToJSON)
+        via Generically [Text]
+
+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
+              | SevDebug Text -- ^ Tag
+              deriving (Show, Generic)
+              deriving (ToJSON)
+                via Generically Severity
+
+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
+    }
+
+debugMsg :: Text -> e -> MsgEnvelope e
+debugMsg tag e = MsgEnvelope
+    -- TODO: not pretty, but it is a debug message after all
+    { _msgSpan = SrcSpan 0 0 0 0
+    , _msgDiagnostic = e
+    , _msgSeverity = SevDebug tag
+    }
+
+undefinedVariableErr :: Text -> RlpcError
+undefinedVariableErr n = Text
+    [ "Variable not in scope: `" <> n <> "'."
+    ]
+

src/Compiler/Types.hs

@@ -0,0 +1,234 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE UndecidableInstances, QuantifiedConstraints #-}
+{-# LANGUAGE PatternSynonyms #-}
+module Compiler.Types
+    ( SrcSpan(..)
+    , srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen
+    , pattern (:<$)
+    , Located(..)
+    , HasLocation(..)
+    , _Located
+    , nolo, nolo'
+
+    , (<~>), (~>), (~~>), (<~~)
+
+    , comb2, comb3, comb4
+    , lochead
+
+    -- * Re-exports
+    , Comonad(extract)
+    , Apply
+    , Bind
+    )
+    where
+--------------------------------------------------------------------------------
+import Language.Haskell.TH.Syntax   (Lift)
+
+import Control.Comonad
+import Control.Comonad.Cofree
+import Data.Functor.Apply
+import Data.Functor.Bind
+import Data.Functor.Compose
+import Data.Functor.Foldable
+import Data.Semigroup.Foldable
+import Data.Fix                     hiding (cata, ana)
+
+import Data.Kind
+import Data.Aeson
+import Control.Lens                 hiding ((<<~), (:<), (.=))
+
+import Data.List.NonEmpty           (NonEmpty)
+import Data.Function                (on)
+import Misc.CofreeF
+--------------------------------------------------------------------------------
+
+-- | Token wrapped with a span (line, column, absolute, length)
+data Located a = Located SrcSpan a
+    deriving (Show, Lift, Functor)
+
+instance ToJSON SrcSpan where
+    toJSON (SrcSpan l c a s) = object
+        [ "line" .= l
+        , "column" .= c
+        , "abs" .= a
+        , "length" .= s]
+
+(<~>) :: a -> b -> SrcSpan
+(<~>) = undefined
+
+infixl 5 <~>
+
+(~>) :: (CanGet k, CanSet k', HasLocation k a, HasLocation k' b)
+     => a -> b -> b
+a ~> b = b & fromSet getSetLocation .~ (a ^. fromGet getSetLocation)
+-- (~>) = undefined
+
+infixl 4 ~>
+
+-- (~~>) :: (CanGet k, HasLocation k a, CanSet k', HasLocation k' b)
+--       => (a -> b) -> a -> b
+-- (~~>) :: (f SrcSpan -> b) -> Cofree f SrcSpan -> Cofree f SrcSpan
+-- f ~~> (ss :< as) = ss :< f as
+(~~>) = undefined
+
+infixl 3 ~~>
+
+-- (<~~) :: (GetLocation a, HasLocation b) => (a -> b) -> a -> b
+-- a <~~ b = a b & location <>~ srcspan b
+(<~~) = undefined
+
+infixr 2 <~~
+
+instance Apply Located where
+    liftF2 f (Located sa p) (Located sb q)
+            = Located (sa <> sb) (p `f` q)
+
+instance Bind Located where
+    Located sa a >>- k = Located (sa <> sb) b
+        where
+            Located sb b = k a
+
+instance Comonad Located where
+    extract (Located _ a) = a
+    extend ck w@(Located p _) = Located p (ck w)
+
+data SrcSpan = SrcSpan
+    !Int -- ^ Line
+    !Int -- ^ Column
+    !Int -- ^ Absolute
+    !Int -- ^ Length
+    deriving (Show, Eq, Lift)
+
+_SrcSpan :: Iso' SrcSpan (Int, Int, Int, Int)
+_SrcSpan = iso (\ (SrcSpan a b c d) -> (a,b,c,d))
+              (\ (a,b,c,d) -> SrcSpan a b c d)
+
+srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen :: Lens' SrcSpan Int
+srcSpanLine = _SrcSpan . _1
+srcSpanColumn = _SrcSpan . _2
+srcSpanAbs = _SrcSpan . _3
+srcSpanLen = _SrcSpan . _4
+
+-- | debug tool
+nolo :: a -> Located a
+nolo = Located (SrcSpan 0 0 0 0)
+
+nolo' :: f (Cofree f SrcSpan) -> Cofree f SrcSpan
+nolo' as = SrcSpan 0 0 0 0 :< as
+
+instance Semigroup SrcSpan where
+    -- multiple identities? what are the consequences of this...?
+    SrcSpan _ _ _ 0 <> SrcSpan l c a s = SrcSpan l c a s
+    SrcSpan l c a s <> SrcSpan _ _ _ 0 = SrcSpan l c a s
+
+    SrcSpan la ca aa sa <> SrcSpan lb cb ab sb = SrcSpan l c a s where
+        l = min la lb
+        c = min ca cb
+        a = min aa ab
+        s = case aa `compare` ab of
+            EQ -> max sa sb
+            LT -> max sa (ab + sb - aa)
+            GT -> max sb (aa + sa - ab)
+
+--------------------------------------------------------------------------------
+
+data GetOrSet = Get | Set | GetSet
+
+class CanGet (k :: GetOrSet)
+class CanSet (k :: GetOrSet) where
+
+instance CanGet Get
+instance CanGet GetSet
+instance CanSet Set
+instance CanSet GetSet
+
+data GetSetLens (k :: GetOrSet) s t a b :: Type where
+    Getter_      :: (s -> a)             -> GetSetLens Get s t a b
+    Setter_      :: ((a -> b) -> s -> t) -> GetSetLens Set s t a b
+    GetterSetter :: (CanGet k', CanSet k')
+                 => (s -> a) -> (s -> b -> t) -> GetSetLens k' s t a b
+
+type GetSetLens' k s a = GetSetLens k s s a a
+
+class HasLocation k s | s -> k where
+    -- location :: (Access k f, Functor f) => LensLike' f s SrcSpan
+    getSetLocation :: GetSetLens' k s SrcSpan
+
+type family Access (k :: GetOrSet) f where
+    Access GetSet f = Functor f
+    Access Set f = Settable f
+    Access Get f = (Functor f, Contravariant f)
+
+instance HasLocation GetSet SrcSpan where
+    getSetLocation = GetterSetter id (flip const)
+    -- location = fromGetSetLens getSetLocation
+
+instance (CanSet k, HasLocation k a) => HasLocation Set (r -> a) where
+    getSetLocation = Setter_ $ \ss ra r -> ra r & fromSet getSetLocation %~ ss
+    -- location = fromSet getSetLocation
+
+instance (HasLocation k a) => HasLocation k (Cofree f a) where
+    getSetLocation = case getSetLocation @_ @a of
+        Getter_ sa -> Getter_ $ \ (s :< _) -> sa s
+        Setter_ abst -> Setter_ $ \ss (s :< as) -> abst ss s :< as
+        GetterSetter sa sbt -> GetterSetter sa' sbt' where
+            sa' (s :< _) = sa s
+            sbt' (s :< as) b = sbt s b :< as
+
+location :: (Access k f, Functor f, HasLocation k s)
+         => LensLike' f s SrcSpan
+location = fromGetSetLens getSetLocation
+
+fromGetSetLens :: (Access k f, Functor f) => GetSetLens' k s a -> LensLike' f s a
+fromGetSetLens gsl = case gsl of
+    Getter_ sa          -> to sa
+    Setter_ abst        -> setting abst
+    GetterSetter sa sbt -> lens sa sbt
+
+fromGet :: (CanGet k) => GetSetLens k s t a b -> Getter s a
+fromGet (Getter_ sa)        = to sa
+fromGet (GetterSetter sa _) = to sa
+
+fromSet :: (CanSet k) => GetSetLens k s t a b -> Setter s t a b
+fromSet (Setter_ abst)        = setting abst
+fromSet (GetterSetter sa sbt) = lens sa sbt
+
+fromGetSet :: (CanGet k, CanSet k) => GetSetLens k s t a b -> Lens s t a b
+fromGetSet (GetterSetter sa sbt) = lens sa sbt
+
+--------------------------------------------------------------------------------
+
+comb2 :: (Functor f, Semigroup m)
+      => (Cofree f m -> Cofree f m -> f (Cofree f m))
+      -> Cofree f m -> Cofree f m -> Cofree f m
+comb2 f a b = ss :< f a b
+    where ss = a `mextract` b
+
+comb3 :: (Functor f, Semigroup m)
+      => (Cofree f m -> Cofree f m -> Cofree f m -> f (Cofree f m))
+      -> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m
+comb3 f a b c = ss :< f a b c
+    where ss = a `mapply` b `mextract` c
+
+comb4 :: (Functor f, Semigroup m)
+      => (Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m
+         -> f (Cofree f m))
+      -> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m
+comb4 f a b c d = ss :< f a b c d
+    where ss = a `mapply` b `mapply` c `mextract` d
+
+mextract :: (Comonad w, Semigroup m) => w m -> w m -> m
+mextract = (<>) `on` extract
+
+mapply :: (Comonad w, Semigroup m) => w m -> w m -> w m
+mapply a b = b <&> (<> extract a)
+
+lochead :: Functor f
+        => (f SrcSpan -> f SrcSpan) -> Located (f SrcSpan) -> Cofree f SrcSpan
+lochead afs (Located ss fss) = ss :< unwrap (lochead afs $ Located ss fss)
+
+--------------------------------------------------------------------------------
+
+makePrisms ''Located
+

src/Control/Monad/Errorful.hs

@@ -1,65 +1,112 @@
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE TupleSections, PatternSynonyms #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE UndecidableInstances #-}
 module Control.Monad.Errorful
-    ( ErrorfulT
-    , runErrorfulT
+    ( ErrorfulT(..)
     , Errorful
+    , pattern Errorful
+    , errorful
     , runErrorful
+    , mapErrorful
+    , hoistErrorfulT
     , MonadErrorful(..)
     )
     where
 ----------------------------------------------------------------------------------
+import Control.Monad.State.Strict
+import Control.Monad.Writer
+import Control.Monad.Reader
+import Control.Monad.Accum
 import Control.Monad.Trans
 import Data.Functor.Identity
 import Data.Coerce
-import Lens.Micro
+import Data.HashSet                 (HashSet)
+import Data.HashSet                 qualified as H
+import Control.Lens
 ----------------------------------------------------------------------------------
 
-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])
+errorful :: (Applicative m) => (Maybe a, [e]) -> ErrorfulT e m a
+errorful = ErrorfulT . pure
+
+runErrorful :: Errorful e a -> (Maybe a, [e])
 runErrorful m = coerce (runErrorfulT m)
 
 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
+    -- | Turn any wounds into fatals
+    bleedOut :: m a -> 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])
+    bleedOut m = ErrorfulT $ runErrorfulT m <&> \case
+        (a, []) -> (a, [])
+        (_, es) -> (Nothing, es)
 
 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 <&> _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) <&> _2 %~ (es<>)
+            Nothing     -> pure (Nothing, es)
+
+mapErrorful :: (Functor m) => (e -> e') -> ErrorfulT e m a -> ErrorfulT e' m a
+mapErrorful f (ErrorfulT m) = ErrorfulT $
+    m <&> _2 . mapped %~ f
+
+-- when microlens-pro drops we can write this as
+--    mapErrorful f = coerced . mapped . _2 . mapped %~ f
+-- lol
+
+hoistErrorfulT :: (forall a. m a -> n a) -> ErrorfulT e m a -> ErrorfulT e n a
+hoistErrorfulT nt (ErrorfulT m) = ErrorfulT (nt m)
+
+--------------------------------------------------------------------------------
+-- daily dose of n^2 instances
+
+instance (Monad m, MonadErrorful e m) => MonadErrorful e (ReaderT r m) where
+    addWound = lift . addWound
+    addFatal = lift . addFatal
+    bleedOut = mapReaderT bleedOut
+
+instance (Monad m, MonadState s m) => MonadState s (ErrorfulT e m) where
+    state = lift . state
+
+instance (Monoid w, Monad m, MonadWriter w m) => MonadWriter w (ErrorfulT e m) where
+    tell = lift . tell
+    listen (ErrorfulT m) = ErrorfulT $ listen m <&> \ ((ma,es),w) ->
+        ((,w) <$> ma, es)
+    pass (ErrorfulT m) = undefined
+
+instance (Monad m, MonadReader r m) => MonadReader r (ErrorfulT e m) where
+    ask      = lift ask
+    local rr = hoistErrorfulT (local rr)
+
+instance (Monoid w, Monad m, MonadAccum w m)
+      => MonadAccum w (ErrorfulT e m) where
+    accum = lift . accum
 

src/Control/Monad/Utils.hs

@@ -0,0 +1,37 @@
+module Control.Monad.Utils
+    ( mapAccumLM
+    , Kendo(..)
+    , generalise
+    )
+    where
+----------------------------------------------------------------------------------
+import Data.Tuple               (swap)
+import Data.Coerce
+import Data.Functor.Identity
+import Control.Monad.State
+import Control.Monad
+----------------------------------------------------------------------------------
+
+-- | Monadic variant of @mapAccumL@
+
+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
+
+newtype Kendo m a = Kendo { appKendo :: a -> m a }
+
+instance (Monad m) => Semigroup (Kendo m a) where
+    Kendo f <> Kendo g = Kendo (f <=< g)
+
+instance (Monad m) => Monoid (Kendo m a) where
+    mempty = Kendo pure
+
+generalise :: (Monad m) => Identity a -> m a
+generalise (Identity a) = pure a
+

src/Core.hs

@@ -1,6 +1,5 @@
 module Core
     ( module Core.Syntax
-    , parseCore
     , parseCoreProg
     , parseCoreExpr
     , lexCore

src/Core/Examples.hs

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

src/Core/HindleyMilner.hs

@@ -0,0 +1,260 @@
+{-|
+Module      : Core.HindleyMilner
+Description : Hindley-Milner type system
+-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Core.HindleyMilner
+    ( Context'
+    , infer
+    , check
+    , checkCoreProg
+    , checkCoreProgR
+    , checkCoreExprR
+    , TypeError(..)
+    , HMError
+    )
+    where
+----------------------------------------------------------------------------------
+import Compiler.RLPC
+import Data.Text qualified as T
+import Control.Monad.Errorful
+import Core.Syntax
+----------------------------------------------------------------------------------
+
+infer = undefined
+check = undefined
+checkCoreProg = undefined
+checkCoreProgR = undefined
+checkCoreExprR = undefined
+
+-- | 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
+
+-- | 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 = undefined
+
+-- | 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
+
+{--
+
+-- | 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 :: forall m. (Monad m) => Program' -> RLPCT m Program'
+checkCoreProgR p = (hoistRlpcT generalise . liftE . checkCoreProg $ p)
+                $> p
+    where
+        liftE = liftErrorful . mapErrorful (errorMsg (SrcSpan 0 0 0 0))
+
+checkCoreExprR :: (Monad m) => Context' -> Expr' -> RLPCT m Expr'
+checkCoreExprR g e = (hoistRlpcT generalise . liftE . infer g $ e)
+                  $> e
+    where
+        liftE = liftErrorful . mapErrorful (errorMsg (SrcSpan 0 0 0 0))
+
+-- | Infer the type of an expression under some context.
+--
+-- >>> let g1 = [("id", TyVar "a" :-> TyVar "a")]
+-- >>> let g2 = [("id", (TyVar "a" :-> TyVar "a") :-> TyVar "a" :-> TyVar "a")]
+-- >>> infer g1 [coreExpr|id 3|]
+-- Right TyInt
+-- >>> infer g2 [coreExpr|id 3|]
+-- Left (TyErrCouldNotUnify (TyVar "a" :-> TyVar "a") TyInt)
+
+infer :: Context' -> Expr' -> HMError Type
+infer g e = do
+    (t,cs) <- gather g e
+    -- apply all unified constraints
+    foldr (uncurry subst) t <$> unify cs
+
+-- | A @Constraint@ between two types describes the requirement that the pair
+-- must unify
+type Constraint = (Type, Type)
+
+-- | Type of an expression under some context, and gather the constraints
+-- necessary to unify. Note that this is not the same as @infer@, as the
+-- expression will likely be given a fresh type variable along with a
+-- constraint, rather than the solved type.
+--
+-- For example, if the context says "@id@ has type a -> a," in an application of
+-- @id 3@, the whole application is assigned type @$a0@ and the constraint that
+-- @id@ must unify with type @Int -> $a0@ is generated.
+--
+-- >>> gather [("id", TyVar "a" :-> TyVar "a")] [coreExpr|id 3|]
+-- (TyVar "$a0",[(TyVar "a" :-> TyVar "a",TyInt :-> TyVar "$a0")])
+
+gather :: Context' -> Expr' -> HMError (Type, [Constraint])
+gather = \g e -> runStateT (go g e) ([],0) <&> \ (t,(cs,_)) -> (t,cs) where
+    go :: Context' -> Expr' -> StateT ([Constraint], Int) HMError Type
+    go g = \case
+        Lit (IntL _)  -> pure TyInt
+        Var k         -> lift $ maybe e pure $ lookup k g
+            where e = addFatal $ TyErrUntypedVariable k
+        App f x       -> do
+            tf <- go g f
+            tx <- go g x
+            tfx <- uniqueVar
+            addConstraint tf (tx :-> tfx)
+            pure tfx
+        Let NonRec bs e -> do
+            g' <- buildLetContext g bs
+            go g' e
+        Let Rec bs e -> do
+            g' <- buildLetrecContext g bs
+            go g' e
+        Lam bs e -> case bs of
+            [x] -> do
+                tx <- uniqueVar
+                let g' = (x,tx) : g
+                te <- go g' e
+                pure (tx :-> te)
+        -- TODO lambda, case
+
+    buildLetrecContext :: Context' -> [Binding']
+                       -> StateT ([Constraint], Int) HMError Context'
+    buildLetrecContext g bs = do
+        let f ag (k := _) = do
+                n <- uniqueVar
+                pure ((k,n) : ag)
+        rg <- foldM f g bs
+        let k ag (k := v) = do
+                t <- go rg v
+                pure ((k,t) : ag)
+        foldM k g bs
+
+    -- | augment a context with the inferred types of each binder. the returned
+    -- context is linearly accumulated, meaning that the context used to infer each binder
+    -- will include the inferred types of all previous binder
+
+    buildLetContext :: Context' -> [Binding']
+                    -> StateT ([Constraint], Int) HMError Context'
+    buildLetContext = foldM k where
+        k :: Context' -> Binding' -> StateT ([Constraint], Int) HMError Context'
+        k g (x := y) = do
+            ty <- go g y
+            pure ((x,ty) : g)
+
+uniqueVar :: StateT ([Constraint], Int) HMError Type
+uniqueVar = do
+    n <- use _2
+    _2 %= succ
+    pure (TyVar . T.pack $ '$' : 'a' : show n)
+
+addConstraint :: Type -> Type -> StateT ([Constraint], Int) HMError ()
+addConstraint t u = _1 %= ((t, u):)
+
+-- | Unify a list of constraints, meaning that pairs between types are turned
+-- into pairs of type variables and types. A useful thought model is to think of
+-- it as solving an equation such that the unknown variable is the left-hand
+-- side.
+
+unify :: [Constraint] -> HMError Context'
+unify = go mempty where
+    go :: Context' -> [Constraint] -> HMError Context'
+
+    -- nothing left! return accumulated context
+    go g [] = pure g
+
+    go g (c:cs) = case c of
+        -- primitives may of course unify with themselves
+        (TyInt,   TyInt)            -> go g cs
+
+        -- `x` unifies with `x`
+        (TyVar t, TyVar u) | t == u -> go g cs
+
+        -- a type variable `x` unifies with an arbitrary type `t` if `t` does
+        -- not reference `x`
+        (TyVar x, t)                -> unifyTV g x t cs
+        (t, TyVar x)                -> unifyTV g x t cs
+
+        -- two functions may be unified if their domain and codomain unify
+        (a :-> b, x :-> y)          -> go g $ (a,x) : (b,y) : cs
+
+        -- anything else is a failure :(
+        (t,u)                       -> addFatal $ TyErrCouldNotUnify t u
+
+    unifyTV :: Context' -> Name -> Type -> [Constraint] -> HMError Context'
+    unifyTV g x t cs | occurs t   = addFatal $ TyErrRecursiveType x t
+                     | otherwise  = go g' substed
+        where
+            g' = (x,t) : g
+            substed = cs & each . both %~ subst x t
+
+            occurs (a :-> b) = occurs a || occurs b
+            occurs (TyVar y)
+                | x == y     = True
+            occurs _         = False
+
+gatherTypeSigs :: Program b -> Context b
+gatherTypeSigs p = p ^. programTypeSigs
+                 & H.toList
+
+-- | The expression @subst x t e@ substitutes all occurences of @x@ in @e@ with
+-- @t@
+--
+-- >>> subst "a" (TyCon "Int") (TyVar "a")
+-- TyCon "Int"
+-- >>> subst "a" (TyCon "Int") (TyVar "a" :-> TyVar "a")
+-- TyCon "Int" :-> TyCon "Int"
+
+subst :: Name -> Type -> Type -> Type
+subst x t (TyVar y) | x == y  = t
+subst x t (a :-> b)           = subst x t a :-> subst x t b
+subst _ _ e                   = e
+
+--------------------------------------------------------------------------------
+
+demoContext :: Context'
+demoContext =
+    [ ("fix", (TyVar "a" :-> TyVar "a") :-> TyVar "a")
+    , ("add", TyInt :-> TyInt :-> TyInt)
+    , ("==", TyInt :-> TyInt :-> TyCon "Bool")
+    , ("True", TyCon "Bool")
+    , ("False", TyCon "Bool")
+    ]
+
+--}

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,19 @@ 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 Data.Functor.Identity
 import Core.Syntax
 import Compiler.RLPC
-import Lens.Micro
-import Lens.Micro.TH
+import Compiler.Types
+-- TODO: unify Located definitions
+import Compiler.RlpcError
+import Control.Lens
 }
 
-%wrapper "monad"
+%wrapper "monad-strict-text"
 
 $whitechar = [ \t\n\r\f\v]
 $special   = [\(\)\,\;\[\]\{\}]
@@ -59,6 +67,8 @@ $white_no_nl = $white # $nl
 
 @decimal = $digit+
 
+@alttag    = "<" $digit+ ">"
+
 rlp :-
 
 <0>
@@ -68,6 +78,7 @@ rlp :-
     "{"                     { constTok TokenLBrace }
     "}"                     { constTok TokenRBrace }
     ";"                     { constTok TokenSemicolon }
+    ":"                     { constTok TokenHasType }
     "@"                     { constTok TokenTypeApp }
     "{-#"                   { constTok TokenLPragma `andBegin` pragma }
 
@@ -80,17 +91,19 @@ rlp :-
     "where"                 { constTok TokenWhere }
     "Pack"                  { constTok TokenPack } -- temp
 
-    "\\"                    { constTok TokenLambda }
+    "\"                     { constTok TokenLambda }
     "λ"                     { constTok TokenLambda }
     "="                     { constTok TokenEquals }
     "->"                    { constTok TokenArrow }
 
+    @alttag                 { lexWith ( TokenAltTag . read @Int . T.unpack
+                                      . T.drop 1 . T.init ) }
     @varname                { lexWith TokenVarName }
     @conname                { lexWith TokenConName }
     @varsym                 { lexWith TokenVarSym }
     @consym                 { lexWith TokenConSym }
 
-    @decimal                { lexWith (TokenLitInt . read @Int) }
+    @decimal                { lexWith (TokenLitInt . read @Int . T.unpack) }
 
     $white                  { skip }
     \n                      { skip }
@@ -107,11 +120,9 @@ rlp :-
 }
 
 {
-data Located a = Located Int Int Int a
-    deriving Show
 
 constTok :: t -> AlexInput -> Int -> Alex (Located t)
-constTok t (AlexPn _ y x,_,_,_) l = pure $ Located y x l t
+constTok t (AlexPn _ y x,_,_,_) l = pure $ nolo t
 
 data CoreToken = TokenLet
                | TokenLetrec
@@ -128,16 +139,18 @@ data CoreToken = TokenLet
                | TokenConName Name
                | TokenVarSym Name
                | TokenConSym Name
+               | TokenAltTag Tag
                | TokenEquals
                | TokenLParen
                | TokenRParen
                | TokenLBrace
                | TokenRBrace
                | TokenSemicolon
+               | TokenHasType
                | TokenTypeApp
                | TokenLPragma
                | TokenRPragma
-               | TokenWord String
+               | TokenWord Text
                | TokenEOF
                deriving Show
 
@@ -155,42 +168,51 @@ 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 . nolo . 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 :: forall m. (Applicative m) => Text -> RLPCT m [Located CoreToken]
+lexCoreR = hoistRlpcT generalise . lexCore
+    where
+        generalise :: forall a. Identity a -> m a
+        generalise (Identity a) = pure a
+
 -- | @lexCore@, but the tokens are stripped of location info. Useful for
 -- debugging
-lexCore' :: String -> RLPC SrcError [CoreToken]
+lexCore' :: Text -> RLPC [CoreToken]
 lexCore' s = fmap f <$> lexCore s
-    where f (Located _ _ _ t) = t
+    where f (Located _ t) = t
 
 lexStream :: Alex [Located CoreToken]
 lexStream = do
     l <- alexMonadScan
     case l of
-        Located _ _ _ TokenEOF  -> pure [l]
-        _                       -> (l:) <$> lexStream
+        Located _ TokenEOF -> pure [l]
+        _                  -> (l:) <$> lexStream
 
 data ParseError = ParErrLexical String
                 | ParErrParse
                 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)
+    Right (st, nolo $ TokenEOF)
 
 }
 

src/Core/Lex.x.old

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

src/Core/Parse.y

@@ -3,192 +3,267 @@
 Module : Core.Parse
 Description : Parser for the Core language
 -}
+{-# LANGUAGE OverloadedStrings, ViewPatterns #-}
 module Core.Parse
-    ( parseCore
-    , parseCoreExpr
+    ( parseCoreExpr
+    , parseCoreExprR
     , parseCoreProg
+    , parseCoreProgR
     , module Core.Lex -- temp convenience
-    , parseTmp
     , SrcError
-    , Module
     )
     where
 
 import Control.Monad        ((>=>))
+import Control.Monad.Utils  (generalise)
 import Data.Foldable        (foldl')
+import Data.Functor.Identity
 import Core.Syntax
 import Core.Lex
 import Compiler.RLPC
+import Control.Monad
+import Control.Lens         hiding (snoc)
 import Data.Default.Class   (def)
+import Data.Hashable        (Hashable)
+import Data.List.Extra
+import Data.Text.IO         qualified as TIO
+import Data.Text            (Text)
+import Data.Text            qualified as T
+import Data.HashMap.Strict  qualified as H
+
+import Core.Parse.Types
 }
 
-%name parseCore Module
 %name parseCoreExpr StandaloneExpr
 %name parseCoreProg StandaloneProgram
 %tokentype { Located CoreToken }
 %error { parseError }
-%monad { RLPC SrcError }
+%monad { P }
 
 %token
-      let             { Located _ _ _ TokenLet }
-      letrec          { Located _ _ _ TokenLetrec }
-      module          { Located _ _ _ TokenModule }
-      where           { Located _ _ _ TokenWhere }
-      case            { Located _ _ _ TokenCase }
-      of              { Located _ _ _ TokenOf }
-      pack            { Located _ _ _ TokenPack } -- temp
-      in              { Located _ _ _ TokenIn }
-      litint          { Located _ _ _ (TokenLitInt $$) }
-      varname         { Located _ _ _ (TokenVarName $$) }
-      varsym          { Located _ _ _ (TokenVarSym $$) }
-      conname         { Located _ _ _ (TokenConName $$) }
-      consym          { Located _ _ _ (TokenConSym $$) }
-      word            { Located _ _ _ (TokenWord $$) }
-      'λ'             { Located _ _ _ TokenLambda }
-      '->'            { Located _ _ _ TokenArrow }
-      '='             { Located _ _ _ TokenEquals }
-      '@'             { Located _ _ _ TokenTypeApp }
-      '('             { Located _ _ _ TokenLParen }
-      ')'             { Located _ _ _ TokenRParen }
-      '{'             { Located _ _ _ TokenLBrace }
-      '}'             { Located _ _ _ TokenRBrace }
-      '{-#'           { Located _ _ _ TokenLPragma }
-      '#-}'           { Located _ _ _ TokenRPragma }
-      ';'             { Located _ _ _ TokenSemicolon }
-      eof             { Located _ _ _ TokenEOF }
+      let             { Located _ TokenLet }
+      letrec          { Located _ TokenLetrec }
+      where           { Located _ TokenWhere }
+      case            { Located _ TokenCase }
+      of              { Located _ TokenOf }
+      pack            { Located _ TokenPack } -- temp
+      in              { Located _ TokenIn }
+      litint          { Located _ (TokenLitInt $$) }
+      varname         { Located _ (TokenVarName $$) }
+      varsym          { Located _ (TokenVarSym $$) }
+      conname         { Located _ (TokenConName $$) }
+      consym          { Located _ (TokenConSym $$) }
+      alttag          { Located _ (TokenAltTag $$) }
+      word            { Located _ (TokenWord $$) }
+      'λ'             { Located _ TokenLambda }
+      '->'            { Located _ TokenArrow }
+      '='             { Located _ TokenEquals }
+      '@'             { Located _ TokenTypeApp }
+      '('             { Located _ TokenLParen }
+      ')'             { Located _ TokenRParen }
+      '{'             { Located _ TokenLBrace }
+      '}'             { Located _ TokenRBrace }
+      '{-#'           { Located _ TokenLPragma }
+      '#-}'           { Located _ TokenRPragma }
+      ';'             { Located _ TokenSemicolon }
+      ':'             { Located _ TokenHasType }
+      eof             { Located _ TokenEOF }
+
+%right '->'
 
 %%
 
-Module          :: { Module Name }
-Module          : module conname where Program Eof { Module (Just ($2, [])) $4 }
-                | Program Eof                      { Module Nothing $1 }
-
 Eof             :: { () }
 Eof             : eof           { () }
                 | error         { () }
 
-StandaloneProgram :: { Program Name }
+StandaloneProgram :: { Program Var }
 StandaloneProgram : Program eof                 { $1 }
 
-Program         :: { Program Name }
-Program         : ScDefs                        { Program $1 }
+Program         :: { Program Var }
+                : TypedScDef ';' Program    { $3 & insTypeSig (fst $1)
+                                                 & insScDef (snd $1) }
+                | TypedScDef OptSemi        { mempty & insTypeSig (fst $1)
+                                                     & insScDef (snd $1) }
+                | TLPragma Program          {% doTLPragma $1 $2 }
+                | TLPragma                  {% doTLPragma $1 mempty }
 
-ScDefs          :: { [ScDef Name] }
-ScDefs          : ScDef ';' ScDefs              { $1 : $3 }
-                | ScDef ';'                     { [$1] }
-                | ScDef                         { [$1] }
-                | {- epsilon -}                 { [] }
+TLPragma        :: { Pragma }
+                : '{-#' Words '#-}'             { Pragma $2 }
 
-ScDef           :: { ScDef Name }
-ScDef           : Var ParList '=' Expr          { ScDef $1 $2 $4 }
+Words           :: { [Text] }
+                : Words word                    { $1 `snoc` $2 }
+                | word                          { [$1] }
 
-ParList         :: { [Name] }
-ParList         : Var ParList                   { $1 : $2 }
-                | {- epsilon -}                 { [] }
+OptSemi         :: { () }
+OptSemi         : ';'                           { () }
+                | {- epsilon -}                 { () }
 
-StandaloneExpr  :: { Expr Name }
+ScTypeSig       :: { (Name, Type) }
+ScTypeSig       : Id ':' Type                   { ($1, $3) }
+
+TypedScDef      :: { (Var, ScDef Var) }
+                : Id ':' Type ';' Id ParList '=' Expr
+                            { (MkVar $1 $3, mkTypedScDef $1 $3 $5 $6 $8) }
+
+-- ScDefs          :: { [ScDef PsName] }
+-- ScDefs          : ScDef ';' ScDefs              { $1 : $3 }
+--                 | ScDef ';'                     { [$1] }
+--                 | ScDef                         { [$1] }
+-- 
+-- ScDef           :: { ScDef PsName }
+-- ScDef           : Id ParList '=' Expr   { ScDef (Left $1) $2
+--                                                 ($4 & binders %~ Right) }
+
+Type            :: { Type }
+                : TypeApp '->' TypeApp              { $1 :-> $3 }
+                | TypeApp                         { $1 }
+
+TypeApp         :: { Type }
+                : TypeApp Type1                 { TyApp $1 $2 }
+                | Type1                         { $1 }
+
+-- do we want to allow symbolic names for tyvars and tycons?
+
+Type1           :: { Type }
+Type1           : '(' Type ')'                  { $2 }
+                | varname                       { TyVar $1 }
+                | conname                       { if $1 == "Type"
+                                                    then TyKindType else TyCon $1 }
+
+ParList      :: { [Name] }
+ParList      : varname ParList            { $1 : $2 }
+             | {- epsilon -}                 { [] }
+
+StandaloneExpr  :: { Expr Var }
 StandaloneExpr  : Expr eof                      { $1 }
 
-Expr            :: { Expr Name }
+Expr            :: { Expr Var }
 Expr            : LetExpr                       { $1 }
                 | 'λ' Binders '->' Expr         { Lam $2 $4 }
                 | Application                   { $1 }
                 | CaseExpr                      { $1 }
                 | Expr1                         { $1 }
 
-LetExpr         :: { Expr Name }
+LetExpr         :: { Expr Var }
 LetExpr         : let    '{'   Bindings '}'    in Expr { Let NonRec $3 $6 }
                 | letrec '{'   Bindings '}'    in Expr { Let Rec $3 $6 }
 
-Binders         :: { [Name] }
+Binders         :: { [Var] }
 Binders         : Var Binders                  { $1 : $2 }
                 | Var                          { [$1] }
 
-Application     :: { Expr Name }
-Application     : Expr1 AppArgs                { foldl' App $1 $2 }
+Application     :: { Expr Var }
+Application     : Application AppArg           { App $1 $2 }
+                | Expr1       AppArg           { App $1 $2 }
 
-AppArgs         :: { [Expr Name] }
-AppArgs         : Expr1 AppArgs                 { $1 : $2 }
-                | Expr1                         { [$1] }
+AppArg          :: { Expr Var }
+                : '@' Type1                     { Type $2 }
+                | Expr1                         { $1 }
 
-CaseExpr        :: { Expr Name }
+CaseExpr        :: { Expr Var }
 CaseExpr        : case Expr of '{' Alters '}'   { Case $2 $5 }
 
-Alters          :: { [Alter Name] }
+Alters          :: { [Alter Var] }
 Alters          : Alter ';' Alters              { $1 : $3 }
                 | Alter ';'                     { [$1] }
                 | Alter                         { [$1] }
 
-Alter           :: { Alter Name }
-Alter           : litint ParList '->' Expr      { Alter (AltData $1) $2 $4 }
+Alter           :: { Alter Var }
+Alter           : alttag  AltParList '->' Expr     { Alter (AltTag  $1) $2 $4 }
+                | conname AltParList '->' Expr     { Alter (AltData $1) $2 $4 }
 
-Expr1           :: { Expr Name }
-Expr1           : litint                        { LitE $ IntL $1 }
+AltParList      :: { [Var] }
+                : Var AltParList                { $1 : $2 }
+                | {- epsilon -}                 { [] }
+
+Expr1           :: { Expr Var }
+Expr1           : litint                        { Lit $ IntL $1 }
                 | Id                            { Var $1 }
                 | PackCon                       { $1 }
-                | ExprPragma                    { $1 }
                 | '(' Expr ')'                  { $2 }
 
-ExprPragma      :: { Expr Name }
-ExprPragma      : '{-#' Words '#-}'      {% exprPragma $2 }
-
-Words           :: { [String] }
-Words           : word Words                    { $1 : $2 }
-                | word                          { [$1] }
-
-PackCon         :: { Expr Name }
+PackCon         :: { Expr Var }
 PackCon         : pack '{' litint litint '}'    { Con $3 $4 }
 
-Bindings        :: { [Binding Name] }
+Bindings        :: { [Binding Var] }
 Bindings        : Binding ';' Bindings          { $1 : $3 }
                 | Binding ';'                   { [$1] }
                 | Binding                       { [$1] }
 
-Binding         :: { Binding Name }
+Binding         :: { Binding Var }
 Binding         : Var '=' Expr                  { $1 := $3 }
 
 Id              :: { Name }
-Id              : Var                                { $1 }
-                | Con                                { $1 }
-
-Var             :: { Name }
-Var             : '(' varsym ')'                    { $2 }
-                | varname                           { $1 }
-
-Con             :: { Name }
-Con             : '(' consym ')'                    { $2 }
+                : varname                           { $1 }
                 | conname                           { $1 }
 
+Var             :: { Var }
+Var             : '(' varname ':' Type ')'          { MkVar $2 $4 }
+
 {
 
-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] -> P a
+parseError (Located _ t : _) =
+    error $ "<line>" <> ":" <> "<col>"
+         <> ": 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)
+exprPragma :: [String] -> RLPC (Expr Var)
+exprPragma ("AST" : e) = undefined
+exprPragma _           = undefined
 
-exprPragma :: [String] -> RLPC SrcError (Expr Name)
-exprPragma ("AST" : e) = astPragma e
-exprPragma _           = addFatal err
-    where err = SrcError
-            { _errSpan       = (0,0,0) -- TODO: span
-            , _errSeverity   = Warning
-            , _errDiagnostic = SrcErrUnknownPragma "" -- TODO: missing pragma
-            }
+astPragma :: [String] -> RLPC (Expr Var)
+astPragma _ = undefined
 
-astPragma :: [String] -> RLPC SrcError (Expr Name)
-astPragma = pure . read . unwords
+-- insTypeSig :: (Hashable b) => (b, Type) -> Program b -> Program b
+-- insTypeSig ts = programTypeSigs %~ uncurry H.insert ts
+
+insTypeSig :: Var -> Program Var -> Program Var
+insTypeSig w@(MkVar _ t) = programTypeSigs %~ H.insert w t
+
+-- 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
+
+parseCoreExprR :: (Monad m) => [Located CoreToken] -> RLPCT m (Expr Var)
+parseCoreExprR = liftMaybe . snd . flip runP def . parseCoreExpr
+
+parseCoreProgR :: forall m. (Monad m)
+               => [Located CoreToken] -> RLPCT m (Program Var)
+parseCoreProgR s = do
+    let p = runP (parseCoreProg s) def
+    case p of
+        (st, Just a) -> do
+            ddumpast a
+            pure a
+  where
+    ddumpast :: Show a => Program a -> RLPCT m (Program a)
+    ddumpast p = do
+        addDebugMsg "dump-parsed-core" . show $ p
+        pure p
+
+happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b
+happyBind m k = m >>= k
+
+happyPure :: a -> RLPC a
+happyPure a = pure a
+
+doTLPragma :: Pragma -> Program Var -> P (Program Var)
+-- TODO: warn unrecognised pragma
+doTLPragma (Pragma []) p = pure p
+
+doTLPragma (Pragma pr) p = case pr of
+    -- TODO: warn on overwrite
+    ["PackData", n, readt -> t, readt -> a] ->
+        pure $ p & programDataTags . at n ?~ (t,a)
+
+readt :: (Read a) => Text -> a
+readt = read . T.unpack
 
 }
 

src/Core/Parse.y.old

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

src/Core/Parse/Types.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Core.Parse.Types
+    ( P(..)
+    , psTyVars
+    , def
+    , PsName
+    , mkTypedScDef
+    )
+    where
+--------------------------------------------------------------------------------
+import Control.Applicative
+import Control.Monad
+import Control.Monad.State
+import Data.Default
+import Data.Maybe
+import Data.Tuple               (swap)
+
+import Control.Lens
+
+import Core.Syntax
+--------------------------------------------------------------------------------
+
+newtype P a = P { runP :: PState -> (PState, Maybe a) }
+    deriving Functor
+
+data PState = PState
+    { _psTyVars :: [(Name, Kind)]
+    }
+
+instance Applicative P where
+    pure a = P (, Just a)
+
+    P pf <*> P pa = P \st ->
+        let (st',mf) = pf st
+            (st'',ma) = pa st'
+        in (st'', mf <*> ma)
+
+instance Monad P where
+    P pa >>= k = P \st ->
+        let (st',ma) = pa st
+        in case ma of
+            Just a -> runP (k a) st'
+            Nothing -> (st', Nothing)
+
+instance MonadState PState P where
+    state = P . fmap ((_2 %~ Just) . review swapped)
+
+instance Default PState where
+    def = undefined
+
+makeLenses ''PState
+
+type PsName = Either Name Var
+
+--------------------------------------------------------------------------------
+
+mkTypedScDef :: Name -> Type -> Name -> [Name] -> Expr Var -> ScDef Var
+mkTypedScDef nt tt n as e | nt == n = ScDef n' as' e
+    where
+        n' = MkVar n tt
+        as' = zipWith MkVar as (tt ^.. arrowStops)
+

src/Core/Syntax.hs

@@ -4,156 +4,785 @@ Description : Core ASTs and the like
 -}
 {-# LANGUAGE PatternSynonyms, OverloadedStrings #-}
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TemplateHaskell #-}
+-- for recursion-schemes
+{-# LANGUAGE DeriveTraversable, TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE QuantifiedConstraints #-}
 module Core.Syntax
-    ( Expr(..)
-    , Type(..)
-    , Literal(..)
-    , pattern (:$)
-    , Binding(..)
-    , AltCon(..)
-    , pattern (:=)
-    , Rec(..)
-    , Alter(..)
-    , Name
-    , Tag
-    , ScDef(..)
-    , Module(..)
-    , Program(..)
-    , Program'
-    , programScDefs
-    , Expr'
-    , ScDef'
-    , Alter'
-    , Binding'
-    , HasRHS(_rhs)
-    , HasLHS(_lhs)
+    (
+    -- * Core AST
+      ExprF(..), ExprF'
+    , ScDef(..), ScDef'
+    , Program(..), Program'
+    , Type(..), Kind, pattern (:->), pattern TyInt
+    , AlterF(..), Alter(..), Alter', AltCon(..)
+    , pattern Binding, pattern Alter
+    , Rec(..), Lit(..)
+    , Pragma(..)
+    -- ** Variables and identifiers
+    , Name, Var(..), Tag, pattern (:^)
+    , Binding, BindingF(..), pattern (:=), pattern (:$)
+    , type Binding'
+    -- ** Working with the fixed point of ExprF
+    , Expr, Expr'
+    , pattern Con, pattern Var, pattern App, pattern Lam, pattern Let
+    , pattern Case, pattern Type, pattern Lit
+
+    -- * pretty-printing
+    , Out(out), WithTerseBinds(..)
+
+    -- * Optics
+    , HasArrowSyntax(..)
+    , programScDefs, programTypeSigs, programDataTags, programTyCons
+    , formalising, lambdaLifting
+    , HasRHS(_rhs), HasLHS(_lhs)
+    , _BindingF, _MkVar, _ScDef
+    -- ** Classy optics
+    , HasBinders(..), HasArrowStops(..), HasApplicants1(..), HasApplicants(..)
     )
     where
 ----------------------------------------------------------------------------------
 import Data.Coerce
 import Data.Pretty
-import GHC.Generics
 import Data.List                    (intersperse)
 import Data.Function                ((&))
 import Data.String
+import Data.HashMap.Strict          (HashMap)
+import Data.HashMap.Strict          qualified as H
+import Data.Hashable
+import Data.Hashable.Lifted
+import Data.Foldable                (traverse_)
+import Data.Functor
+import Data.Monoid
+import Data.Functor.Classes
+import Data.Text                    qualified as T
+import Data.Char
+import Data.These
+import Data.Aeson
+import GHC.Generics                 ( Generic, Generic1
+                                    , Generically(..), Generically1(..))
+import Text.Show.Deriving
+import Data.Eq.Deriving
+import Data.Kind                    qualified
+
+import Data.Fix                     hiding (cata, ana)
+import Data.Bifunctor               (Bifunctor(..))
+import Data.Bifoldable              (bifoldr, Bifoldable(..))
+import Data.Bifunctor.TH
+import Data.Bitraversable
+import Data.Functor.Foldable
+import Data.Functor.Foldable.TH     (makeBaseFunctor)
+
 -- Lift instances for the Core quasiquoters
-import Language.Haskell.TH.Syntax   (Lift)
-import Lens.Micro
+import Misc
+import Misc.Lift1
+import Control.Lens
 ----------------------------------------------------------------------------------
 
-data Expr b = Var Name
-            | 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
-            deriving (Show, Read, Lift)
+data ExprF b a = VarF Name
+               | ConF Tag Int -- ^ Con Tag Arity
+               | CaseF a [AlterF b a]
+               | LamF [b] a
+               | LetF Rec [BindingF b a] a
+               | AppF a a
+               | LitF Lit
+               | TypeF Type
+               deriving (Functor, Foldable, Traversable)
 
-deriving instance (Eq b) => Eq (Expr b)
+type Expr b = Fix (ExprF b)
 
-data Type = TyInt
-          | TyFun
+instance IsString (ExprF b a) where
+    fromString = VarF . fromString
+
+instance (IsString (f (Fix f))) => IsString (Fix f) where
+    fromString = Fix . fromString
+
+data Type = TyFun
           | TyVar Name
           | TyApp Type Type
-          | TyConApp TyCon [Type]
-          deriving (Show, Read, Lift, Eq)
+          | TyCon Name
+          | TyForall Var Type
+          | TyKindType
+          deriving (Show, Eq, Lift)
 
-type TyCon = Name
+type Kind = Type
 
-infixl 2 :$
-pattern (:$) :: Expr b  -> Expr b  -> Expr b 
-pattern f :$ x = App f x
+-- data TyCon = MkTyCon Name Kind
+--     deriving (Eq, Show, Lift)
 
-{-# COMPLETE Binding :: Binding #-}
-{-# COMPLETE (:=) :: Binding #-}
-data Binding b = Binding b (Expr b)
-    deriving (Show, Read, Lift)
+data Var = MkVar Name Type
+    deriving (Eq, Show, Lift, Generic)
 
-deriving instance (Eq b) => Eq (Binding b)
+pattern (:^) :: Name -> Type -> Var
+pattern n :^ t = MkVar n t
+
+instance Hashable Var where
+    hashWithSalt s (MkVar n _) = hashWithSalt s n
+
+pattern Con :: Tag -> Int -> Expr b
+pattern Con t a = Fix (ConF t a)
+
+pattern Var :: Name -> Expr b
+pattern Var b = Fix (VarF b)
+
+pattern App :: Expr b -> Expr b -> Expr b
+pattern App f x = Fix (AppF f x)
+
+pattern Lam :: [b] -> Expr b -> Expr b
+pattern Lam bs e = Fix (LamF bs e)
+
+pattern Let :: Rec -> [Binding b] -> Expr b -> Expr b
+pattern Let r bs e = Fix (LetF r bs e)
+
+pattern Case :: Expr b -> [Alter b] -> Expr b
+pattern Case e as = Fix (CaseF e as)
+
+pattern Type :: Type -> Expr b
+pattern Type t = Fix (TypeF t)
+
+pattern Lit :: Lit -> Expr b
+pattern Lit t = Fix (LitF t)
+
+pattern TyInt :: Type
+pattern TyInt = TyCon "Int#"
+
+class HasArrowSyntax s a b | s -> a b where
+    _arrowSyntax :: Prism' s (a, b)
+
+instance HasArrowSyntax Type Type Type where
+    _arrowSyntax = prism make unmake where
+        make (s,t) = TyFun `TyApp` s `TyApp` t
+
+        unmake (TyFun `TyApp` s `TyApp` t) = Right (s,t)
+        unmake s                           = Left s
+
+infixr 1 :->
+pattern (:->) :: HasArrowSyntax s a b
+              => a -> b -> s
+-- pattern (:->) :: Type -> Type -> Type
+pattern a :-> b <- (preview _arrowSyntax -> Just (a, b))
+    where a :-> b = _arrowSyntax # (a, b)
+
+data BindingF b a = BindingF b (ExprF b a)
+    deriving (Functor, Foldable, Traversable)
+
+type Binding b = BindingF b (Fix (ExprF b))
+
+type Binding' = Binding Name
+
+-- collapse = foldFix embed
+
+pattern Binding :: b -> Expr b -> Binding b
+pattern Binding k v <- BindingF k (wrapFix -> v)
+    where Binding k v = BindingF k (unwrapFix v)
+
+{-# COMPLETE (:=) #-}
+{-# COMPLETE Binding #-}
 
 infixl 1 :=
-pattern (:=) :: b -> (Expr b) -> (Binding b)
+pattern (:=) :: b -> Expr b -> Binding b
 pattern k := v = Binding k v
 
-data Alter b = Alter AltCon [b] (Expr b)
-    deriving (Show, Read, Lift)
+infixl 2 :$
+pattern (:$) :: Expr b -> Expr b -> Expr b
+pattern f :$ x = App f x
 
-deriving instance (Eq b) => Eq (Alter b)
+data AlterF b a = AlterF AltCon [b] (ExprF b a)
+    deriving (Functor, Foldable, Traversable)
+
+pattern Alter :: AltCon -> [b] -> Expr b -> Alter b
+pattern Alter con bs e <- AlterF con bs (wrapFix -> e)
+    where Alter con bs e = AlterF con bs (unwrapFix e)
+
+type Alter b = AlterF b (Fix (ExprF b))
+
+type Alter' = Alter Name
+
+-- pattern Alter :: AltCon -> [b] -> Expr b -> Alter b
+-- pattern Alter con bs e <- Fix (AlterF con bs (undefined -> e))
+--     where Alter con bs e = Fix (AlterF con bs undefined)
+
+newtype Pragma = Pragma [T.Text]
 
 data Rec = Rec
          | NonRec
-         deriving (Show, Read, Eq, Lift)
+         deriving (Show, Eq, Lift)
 
-data AltCon = AltData Tag
-            | AltLiteral Literal
-            | Default
-            deriving (Show, Read, Eq, Lift)
+data AltCon = AltData Name
+            | AltTag Tag
+            | AltLit Lit
+            | AltDefault
+            deriving (Show, Eq, Lift)
 
-data Literal = IntL Int
-    deriving (Show, Read, Eq, Lift)
+newtype Lit = IntL Int
+    deriving (Show, Eq, Lift)
 
-type Name = String
+type Name = T.Text
 type Tag = Int
 
 data ScDef b = ScDef b [b] (Expr b)
-    deriving (Show, Lift)
+
+-- unliftScDef :: ScDef b -> Expr b
+-- unliftScDef (ScDef _ as e) = Lam as e
 
 data Module b = Module (Maybe (Name, [Name])) (Program b)
-    deriving (Show, Lift)
 
-newtype Program b = Program [ScDef b]
-    deriving (Show, Lift)
+data Program b = Program
+    { _programScDefs   :: [ScDef b]
+    , _programTypeSigs :: HashMap b Type
+    , _programDataTags :: HashMap Name (Tag, Int)
+    -- ^ map constructors to their tag and arity
+    , _programTyCons   :: HashMap Name Kind
+    -- ^ map type constructors to their kind
+    }
+    deriving (Generic)
+    deriving (Semigroup, Monoid)
+        via Generically (Program b)
 
-programScDefs :: Lens' (Program b) [ScDef b]
-programScDefs = lens coerce (const coerce)
+makeLenses ''Program
+-- makeBaseFunctor ''Expr
+pure []
+
+-- this is a weird optic, stronger than Lens and Prism, but weaker than Iso.
+programTypeSigsP :: (Hashable b) => Prism' (Program b) (HashMap b Type)
+programTypeSigsP = prism
+    (\b -> mempty & programTypeSigs .~ b)
+    (Right . view programTypeSigs)
+
+type ExprF' = ExprF Name
 
 type Program' = Program Name
 type Expr' = Expr Name
 type ScDef' = ScDef Name
-type Alter' = Alter Name
-type Binding' = Binding Name
+-- type Alter' = Alter Name
+-- type Binding' = Binding Name
 
-instance IsString (Expr b) where
-    fromString = Var
+-- instance IsString (Expr b) where
+--     fromString = Var . fromString
 
-instance Semigroup (Program b) where
-    (<>) = coerce $ (<>) @[ScDef b] 
+lambdaLifting :: Iso (ScDef b) (ScDef b') (b, Expr b) (b', Expr b')
+lambdaLifting = iso sa bt where
+    sa (ScDef n [] e) = (n, e) where
+    sa (ScDef n as e) = (n, e') where
+        e' = Lam as e
 
-instance Monoid (Program b) where
-    mempty = Program []
+    bt (n, Lam as e) = ScDef n as e
+    bt (n, e)        = ScDef n [] e
 
 ----------------------------------------------------------------------------------
 
 class HasRHS s t a b | s -> a, t -> b, s b -> t, t a -> s where
     _rhs :: Lens s t a b
 
-instance HasRHS (Alter b) (Alter b) (Expr b) (Expr b) where
+instance HasRHS (AlterF b a) (AlterF b a') (ExprF b a) (ExprF b a') where
     _rhs = lens
-        (\ (Alter _ _ e) -> e)
-        (\ (Alter t as _) e' -> Alter t as e')
+        (\ (AlterF _ _ e) -> e)
+        (\ (AlterF t as _) e' -> AlterF t as e')
 
 instance HasRHS (ScDef b) (ScDef b) (Expr b) (Expr b) where
     _rhs = lens
         (\ (ScDef _ _ e) -> e)
         (\ (ScDef n as _) e' -> ScDef n as e')
 
-instance HasRHS (Binding b) (Binding b) (Expr b) (Expr b) where
-    _rhs = lens
-        (\ (_ := e) -> e)
-        (\ (k := _) e' -> k := e')
+instance HasRHS (BindingF b a) (BindingF b' a') (ExprF b a) (ExprF b' a')
 
 class HasLHS s t a b | s -> a, t -> b, s b -> t, t a -> s where
     _lhs :: Lens s t a b
 
-instance HasLHS (Alter b) (Alter b) (AltCon, [b]) (AltCon, [b]) where
-    _lhs = lens
-        (\ (Alter a bs _) -> (a,bs))
-        (\ (Alter _ _ e) (a',bs') -> Alter a' bs' e)
-
 instance HasLHS (ScDef b) (ScDef b) (b, [b]) (b, [b]) where
     _lhs = lens
         (\ (ScDef n as _) -> (n,as))
-        (\ (ScDef _ _ e) (n',as') -> (ScDef n' as' e))
+        (\ (ScDef _ _ e) (n',as') -> ScDef n' as' e)
+
+-- instance HasLHS (Binding b) (Binding b) b b where
+    -- _lhs = lens
+    --     (\ (k := _) -> k)
+    --     (\ (_ := e) k' -> k' := e)
+
+-- | This is not a valid isomorphism for expressions containing lambdas whose
+-- bodies are themselves lambdas with multiple arguments:
+--
+-- >>> [coreExpr|\x -> \y z -> x|] ^. from (from formalising)
+-- Lam ["x"] (Lam ["y"] (Lam ["z"] (Var "x")))
+-- >>> [coreExpr|\x -> \y z -> x|]
+-- Lam ["x"] (Lam ["y","z"] (Var "x"))
+--
+-- For this reason, it's best to consider 'formalising' as if it were two
+-- unrelated unidirectional getters.
+
+formalising :: Iso (Expr a) (Expr b) (Expr a) (Expr b)
+formalising = iso sa bt where
+    sa :: Expr a -> Expr a
+    sa = ana \case
+        Lam [b] e      -> LamF [b] e
+        Lam (b:bs) e   -> LamF [b] (Lam bs e)
+        Let r (b:bs) e -> LetF r [b] (Let r bs e)
+        x              -> project x
+
+    bt :: Expr b -> Expr b
+    bt = cata \case
+        LamF [b] (Lam bs e)                -> Lam (b:bs) e
+        LetF r [b] (Let r' bs e) | r == r' -> Let r (b:bs) e
+        x                                  -> embed x
+
+--------------------------------------------------------------------------------
+
+newtype WithTerseBinds a = WithTerseBinds a
+
+class MakeTerse a where
+    type AsTerse a :: Data.Kind.Type
+    asTerse :: a -> AsTerse a
+
+instance MakeTerse Var where
+    type AsTerse Var = Name
+    asTerse (MkVar n _) = n
+
+instance (Hashable b, Out b, Out (AsTerse b), MakeTerse b)
+      => Out (WithTerseBinds (Program b)) where
+    out (WithTerseBinds p)
+            = vsep [ (datatags <> "\n")
+                   , defs ]
+        where
+            datatags = ifoldrOf (programDataTags . ifolded) cataDataTag mempty p
+            defs = vlinesOf (programJoinedDefs . to prettyGroup) p
+
+            programJoinedDefs :: Fold (Program b) (These (b, Type) (ScDef b))
+            programJoinedDefs = folding $ \p ->
+                foldMapOf programTypeSigs thisTs p
+                `u` foldMapOf programScDefs thatSc p
+              where u = H.unionWith unionThese
+
+            thisTs = ifoldMap @b @(HashMap b)
+                (\n t -> H.singleton n (This (n,t)))
+            thatSc = foldMap $ \sc ->
+                H.singleton (sc ^. _lhs . _1) (That sc)
+
+            prettyGroup :: These (b, Type) (ScDef b) -> Doc ann
+            prettyGroup = bifoldr vs vs mempty
+                        . bimap (uncurry prettyTySig')
+                                (out . WithTerseBinds)
+                where vs a b = a <> ";" <> line <> b
+
+            cataDataTag n (t,a) acc = prettyDataTag n t a <> line <> acc
+
+instance (Hashable b, Out b) => Out (Program b) where
+    out p = vsep [ datatags <> "\n"
+                 , defs ]
+        where
+            datatags = ifoldrOf (programDataTags . ifolded) cataDataTag mempty p
+            defs = vlinesOf (programJoinedDefs . to prettyGroup) p
+
+            programJoinedDefs :: Fold (Program b) (These (b, Type) (ScDef b))
+            programJoinedDefs = folding $ \p ->
+                foldMapOf programTypeSigs thisTs p
+                `u` foldMapOf programScDefs thatSc p
+              where u = H.unionWith unionThese
+
+            thisTs = ifoldMap @b @(HashMap b)
+                (\n t -> H.singleton n (This (n,t)))
+            thatSc = foldMap $ \sc ->
+                H.singleton (sc ^. _lhs . _1) (That sc)
+
+            prettyGroup :: These (b, Type) (ScDef b) -> Doc ann
+            prettyGroup = bifoldr vs vs mempty
+                        . bimap (uncurry prettyTySig) out
+                where vs a b = a <> ";" <> line <> b
+
+            cataDataTag n (t,a) acc = prettyDataTag n t a <> line <> acc
+
+unionThese :: These a b -> These a b -> These a b
+unionThese (This a) (That b) = These a b
+unionThese (That b) (This a) = These a b
+unionThese (These a b) _     = These a b
+
+prettyDataTag :: (Out n, Out t, Out a)
+              => n -> t -> a -> Doc ann
+prettyDataTag n t a =
+    hsep ["{-#", "PackData", ttext n, ttext t, ttext a, "#-}"]
+
+prettyTySig :: (Out n, Out t) => n -> t -> Doc ann
+prettyTySig n t = hsep [ttext n, ":", out t]
+
+prettyTySig' :: (MakeTerse n, Out (AsTerse n), Out t) => n -> t -> Doc ann
+prettyTySig' n t = hsep [ttext (asTerse n), ":", out t]
+
+-- out Type
+-- TyApp | appPrec   | left
+-- (:->) | appPrec-1 | right
+
+instance Out Type where
+    outPrec _ (TyVar n)   = ttext n
+    outPrec _ TyFun       = "(->)"
+    outPrec _ (TyCon n)   = ttext n
+    outPrec p (a :-> b)   = maybeParens (p>appPrec-1) $
+        hsep [outPrec appPrec a, "->", outPrec (appPrec-1) b]
+    outPrec p (TyApp f x) = maybeParens (p>appPrec) $
+        outPrec appPrec f <+> outPrec appPrec1 x
+    outPrec p (TyForall a m) = maybeParens (p>appPrec-2) $
+        "∀" <+> (outPrec appPrec1 a <> ".") <+> out m
+    outPrec _ TyKindType = "Type"
+
+instance (Out b, Out (AsTerse b), MakeTerse b)
+      => Out (WithTerseBinds (ScDef b)) where
+    out (WithTerseBinds sc) = hsep [name, as, "=", hang 1 e]
+        where
+            name = ttext $ sc ^. _lhs . _1 . to asTerse
+            as = sc & hsepOf (_lhs . _2 . each . to asTerse . to ttext)
+            e = out $ sc ^. _rhs
+
+instance (Out b) => Out (ScDef b) where
+    out sc = hsep [name, as, "=", hang 1 e]
+        where
+            name = ttext $ sc ^. _lhs . _1
+            as = sc & hsepOf (_lhs . _2 . each . to ttext)
+            e = out $ sc ^. _rhs
+
+-- out Expr
+-- LamF | appPrec1 | right
+-- AppF | appPrec  | left
+
+instance (Out b, Out a) => Out (ExprF b a) where
+    outPrec = outPrec1
+
+instance (Out b) => Out1 (ExprF b) where
+    liftOutPrec pr _ (VarF n) = ttext n
+    liftOutPrec pr _ (ConF t a) = "Pack{" <> (ttext t <+> ttext a) <> "}"
+    liftOutPrec pr p (LamF bs e) = maybeParens (p>0) $
+        hsep ["λ", hsep (outPrec appPrec1 <$> bs), "->", pr 0 e]
+    liftOutPrec pr p (LetF r bs e) = maybeParens (p>0)
+                               $ vsep [ hsep [out r, bs']
+                                      , hsep ["in", pr 0 e] ]
+        where bs' = liftExplicitLayout (liftOutPrec pr 0) bs
+    liftOutPrec pr p (AppF f x) = maybeParens (p>appPrec) $
+        pr appPrec f <+> pr appPrec1 x
+    liftOutPrec pr p (LitF l) = outPrec p l
+    liftOutPrec pr p (CaseF e as) = maybeParens (p>0) $
+            vsep [ "case" <+> pr 0 e <+> "of"
+                 , nest 2 as' ]
+        where as' = liftExplicitLayout (liftOutPrec pr 0) as
+    liftOutPrec pr p (TypeF t) = "@" <> outPrec appPrec1 t
+
+instance Out Rec where
+    out Rec = "letrec"
+    out NonRec = "let"
+
+instance (Out b, Out a) => Out (AlterF b a) where
+    outPrec = outPrec1
+
+instance (Out b) => Out1 (AlterF b) where
+    liftOutPrec pr _ (AlterF c as e) =
+        hsep [out c, hsep (out <$> as), "->", liftOutPrec pr 0 e]
+
+instance Out AltCon where
+    out (AltData n) = ttext n
+    out (AltLit l) = out l
+    out (AltTag t) = "<" <> ttext t <> ">"
+    out AltDefault = "_"
+
+instance Out Lit where
+    out (IntL n) = ttext n
+
+instance (Out b, Out a) => Out (BindingF b a) where
+    outPrec = outPrec1
+
+instance Out b => Out1 (BindingF b) where
+    liftOutPrec pr _ (BindingF k v) = hsep [out k, "=", liftOutPrec pr 0 v]
+
+liftExplicitLayout :: (a -> Doc ann) -> [a] -> Doc ann
+liftExplicitLayout pr as = vcat inner <+> "}" where
+    inner = zipWith (<+>) delims (pr <$> as)
+    delims = "{" : repeat ";"
+
+explicitLayout :: (Out a) => [a] -> Doc ann
+explicitLayout as = vcat inner <+> "}" where
+    inner = zipWith (<+>) delims (out <$> as)
+    delims = "{" : repeat ";"
+
+instance Out Var where
+    outPrec p (MkVar n t) = maybeParens (p>0) $
+        hsep [out n, ":", out t]
+
+--------------------------------------------------------------------------------
+
+-- instance Functor Alter where
+--     fmap f (Alter con bs e) = Alter con (f <$> bs) e'
+--         where
+--             e' = foldFix (embed . bimap' f id) e
+--             bimap' = $(makeBimap ''ExprF)
+
+-- instance Foldable Alter where
+-- instance Traversable Alter where
+-- instance Functor Binding where
+-- instance Foldable Binding where
+-- instance Traversable Binding where
+
+liftShowsPrecExpr :: (Show b)
+                  => (Int -> a -> ShowS)
+                  -> ([a] -> ShowS)
+                  -> Int -> ExprF b a -> ShowS
+liftShowsPrecExpr = $(makeLiftShowsPrec ''ExprF)
+
+showsPrec1Expr :: (Show b, Show a)
+               => Int -> ExprF b a -> ShowS
+showsPrec1Expr = $(makeShowsPrec1 ''ExprF)
+
+instance (Show b) => Show1 (AlterF b) where
+    liftShowsPrec sp spl d (AlterF con bs e) =
+        showsTernaryWith showsPrec showsPrec (liftShowsPrecExpr sp spl)
+                         "AlterF" d con bs e
+
+instance (Show b) => Show1 (BindingF b) where
+    liftShowsPrec sp spl d (BindingF k v) =
+        showsBinaryWith showsPrec (liftShowsPrecExpr sp spl)
+                        "BindingF" d k v
+
+instance (Show b, Show a) => Show (BindingF b a) where
+    showsPrec d (BindingF k v)
+        = showParen (d > 10)
+        $ showString "BindingF" . showChar ' '
+        . showsPrec 11 k . showChar ' '
+        . showsPrec1Expr 11 v
+
+instance (Show b, Show a) => Show (AlterF b a) where
+    showsPrec d (AlterF con bs e)
+        = showParen (d > 10)
+        $ showString "AlterF" . showChar ' '
+        . showsPrec 11 con . showChar ' '
+        . showsPrec 11 bs . showChar ' '
+        . showsPrec1Expr 11 e
+
+deriveShow1 ''ExprF
+
+deriving instance (Show b, Show a) => Show (ExprF b a)
+-- deriving instance (Show b, Show a) => Show (BindingF b a)
+-- deriving instance (Show b, Show a) => Show (AlterF b a)
+deriving instance Show b => Show (ScDef b)
+deriving instance Show b => Show (Program b)
+
+bimapExpr :: (b -> b') -> (a -> a')
+          -> ExprF b a -> ExprF b' a'
+bimapExpr = $(makeBimap ''ExprF)
+
+bifoldrExpr :: (b -> c -> c)
+            -> (a -> c -> c)
+            -> c -> ExprF b a -> c
+bifoldrExpr = $(makeBifoldr ''ExprF)
+
+bitraverseExpr :: Applicative f
+               => (b -> f b')
+               -> (a -> f a')
+               -> ExprF b a -> f (ExprF b' a')
+bitraverseExpr = $(makeBitraverse ''ExprF)
+
+instance Bifunctor AlterF where
+    bimap f g (AlterF con bs e) = AlterF con (f <$> bs) (bimapExpr f g e)
+
+instance Bifunctor BindingF where
+    bimap f g (BindingF k v) = BindingF (f k) (bimapExpr f g v)
+
+instance Bifoldable AlterF where
+    bifoldr f g z (AlterF con bs e) = bifoldrExpr f g z' e where
+        z' = foldr f z bs
+
+instance Bitraversable AlterF where
+    bitraverse f g (AlterF con bs e) =
+        AlterF con <$> traverse f bs <*> bitraverseExpr f g e
+
+instance Bifoldable BindingF where
+    bifoldr f g z (BindingF k v) = bifoldrExpr f g (f k z) v
+
+instance Bitraversable BindingF where
+    bitraverse f g (BindingF k v) =
+        BindingF <$> f k <*> bitraverseExpr f g v
+
+deriveBifunctor ''ExprF
+deriveBifoldable ''ExprF
+deriveBitraversable ''ExprF
+
+instance Lift b => Lift1 (BindingF b) where
+    liftLift lf (BindingF k v) = liftCon2 'BindingF (lift k) (liftLift lf v)
+
+instance Lift b => Lift1 (AlterF b) where
+    liftLift lf (AlterF con bs e) =
+        liftCon3 'AlterF (lift con) (lift1 bs) (liftLift lf e)
+
+instance Lift b => Lift1 (ExprF b) where
+    liftLift lf (VarF k)      = liftCon 'VarF (lift k)
+    liftLift lf (AppF f x)    = liftCon2 'AppF (lf f) (lf x)
+    liftLift lf (LamF b e)    = liftCon2 'LamF (lift b) (lf e)
+    liftLift lf (LetF r bs e) = liftCon3 'LetF (lift r) bs' (lf e)
+        where bs' = liftLift (liftLift lf) bs
+    liftLift lf (CaseF e as)  = liftCon2 'CaseF (lf e) as'
+        where as' = liftLift (liftLift lf) as
+    liftLift lf (TypeF t)     = liftCon 'TypeF (lift t)
+    liftLift lf (LitF l)      = liftCon 'LitF (lift l)
+    liftLift lf (ConF t a)    = liftCon2 'ConF (lift t) (lift a)
+
+deriving instance (Lift b, Lift a) => Lift (ExprF b a)
+deriving instance (Lift b, Lift a) => Lift (BindingF b a)
+deriving instance (Lift b, Lift a) => Lift (AlterF b a)
+deriving instance Lift b => Lift (ScDef b)
+deriving instance Lift b => Lift (Program b)
+
+--------------------------------------------------------------------------------
+
+class HasApplicants1 s t a b | s -> a, t -> b, s b -> t, t a -> s where
+    applicants1 :: Traversal s t a b
+
+class HasApplicants s t a b | s -> a, t -> b, s b -> t, t a -> s where
+    applicants :: Traversal s t a b
+
+instance HasApplicants1 Type Type Type Type where
+    applicants1 k (TyApp f x) = TyApp <$> applicants1 k f <*> k x
+    applicants1 k x           = k x
+
+instance HasApplicants Type Type Type Type where
+    applicants k (TyApp f x) = TyApp <$> applicants k f <*> k x
+    applicants k x           = pure x
+
+-- instance HasArguments (ExprF b (Fix (ExprF b))) (ExprF b (Fix (ExprF b)))
+--                        (Fix (ExprF b)) (Fix (ExprF b)) where
+--     arguments k (AppF f x) = AppF <$> arguments k f <*> k x
+--     arguments k x          = unwrapFix <$> k (wrapFix x)
+
+-- instance HasArguments (f (Fix f)) (f (Fix f)) (Fix f) (Fix f)
+--       => HasArguments (Fix f) (Fix f) (Fix f) (Fix f) where
+--     arguments :: forall g. Applicative g
+--                => LensLike' g (Fix f) (Fix f)
+--     arguments k (Fix f) = Fix <$> arguments k f
+
+-- arguments :: Traversal' (Expr b) (Expr b)
+-- arguments k (App f x) = App <$> arguments k f <*> k x
+-- arguments k x         = k x
+
+class HasBinders s t a b | s -> a, t -> b, s b -> t, t a -> s where
+    binders :: Traversal s t a b
+
+instance HasBinders (ScDef b) (ScDef b') b b' where
+    binders k (ScDef b as e) = ScDef <$> k b <*> traverse k as <*> binders k e
+
+instance (Hashable b, Hashable b')
+      => HasBinders (Program b) (Program b') b b' where
+    binders :: forall f. (Applicative f)
+            => LensLike f (Program b) (Program b') b b'
+    binders k p
+        = Program
+        <$> traverse (binders k) (_programScDefs p)
+        <*> (getAp . ifoldMap toSingleton $ _programTypeSigs p)
+        <*> pure (_programDataTags p)
+        <*> pure (_programTyCons p)
+      where
+        toSingleton :: b -> Type -> Ap f (HashMap b' Type)
+        toSingleton b t = Ap $ (`H.singleton` t) <$> k b
+
+instance HasBinders a a' b b'
+    => HasBinders (ExprF b a) (ExprF b' a') b b' where
+    binders :: forall f. (Applicative f)
+                    => LensLike f (ExprF b a) (ExprF b' a') b b'
+    binders k = go where
+        go :: ExprF b a -> f (ExprF b' a')
+        go (LamF bs e)   = LamF <$> traverse k bs <*> binders k e
+        go (CaseF e as)  = CaseF <$> binders k e <*> eachbind as
+        go (LetF r bs e) = LetF r <$> eachbind bs <*> binders k e
+        go f             = bitraverse k (binders k) f
+
+        eachbind :: forall p. Bitraversable p => [p b a] -> f [p b' a']
+        eachbind bs = bitraverse k (binders k) `traverse` bs
+
+instance HasBinders a a b b'
+      => HasBinders (AlterF b a) (AlterF b' a) b b' where
+    binders k (AlterF con bs e) =
+        AlterF con <$> traverse k bs <*> traverseOf binders k e
+
+instance HasBinders a a b b'
+      => HasBinders (BindingF b a) (BindingF b' a) b b' where
+    binders k (BindingF b v) = BindingF <$> k b <*> binders k v
+
+instance (HasBinders (f b (Fix (f b))) (f b' (Fix (f b'))) b b')
+      => HasBinders (Fix (f b)) (Fix (f b')) b b' where
+    binders k (Fix f) = Fix <$> binders k f
+
+class HasArrowStops s t a b | s -> a, t -> b, s b -> t, t a -> s where
+    arrowStops :: Traversal s t a b
+
+instance HasArrowStops Type Type Type Type where
+    arrowStops k (s :-> t) = (:->) <$> k s <*> arrowStops k t
+    arrowStops k t         = k t
+
+--------------------------------------------------------------------------------
+
+liftEqExpr :: (Eq b)
+           => (a -> a' -> Bool)
+           -> ExprF b a -> ExprF b a' -> Bool
+liftEqExpr = $(makeLiftEq ''ExprF)
+
+instance (Eq b, Eq a) => Eq (BindingF b a) where
+    BindingF ka va == BindingF kb vb =
+        ka == kb && va `eq` vb
+      where eq = liftEqExpr (==)
+
+instance (Eq b, Eq a) => Eq (AlterF b a) where
+    AlterF cona bsa ea == AlterF conb bsb eb =
+        cona == conb && bsa == bsb && ea `eq` eb
+      where eq = liftEqExpr (==)
+
+instance (Eq b) => Eq1 (AlterF b) where
+    liftEq f (AlterF cona bsa ea) (AlterF conb bsb eb) =
+        cona == conb && bsa == bsb && ea `eq` eb
+      where eq = liftEqExpr f
+
+instance (Eq b) => Eq1 (BindingF b) where
+    liftEq f (BindingF ka va) (BindingF kb vb) =
+        ka == kb && va `eq` vb
+      where eq = liftEqExpr f
+
+deriveEq1 ''ExprF
+
+deriving instance (Eq b, Eq a) => Eq (ExprF b a)
+
+makePrisms ''BindingF
+makePrisms ''Var
+makePrisms ''ScDef
+
+deriving instance Generic (ExprF b a)
+deriving instance Generic1 (ExprF b)
+deriving instance Generic1 (AlterF b)
+deriving instance Generic1 (BindingF b)
+deriving instance Generic (AlterF b a)
+deriving instance Generic (BindingF b a)
+deriving instance Generic AltCon
+deriving instance Generic Lit
+deriving instance Generic Rec
+deriving instance Generic Type
+
+instance Hashable Lit
+instance Hashable AltCon
+instance Hashable Rec
+instance Hashable Type
+instance (Hashable b, Hashable a) => Hashable (BindingF b a)
+instance (Hashable b, Hashable a) => Hashable (AlterF b a)
+instance (Hashable b, Hashable a) => Hashable (ExprF b a)
+
+instance Hashable b => Hashable1 (AlterF b)
+instance Hashable b => Hashable1 (BindingF b)
+instance Hashable b => Hashable1 (ExprF b)
+
+deriving via (Generically Rec)
+    instance ToJSON Rec
+deriving via (Generically Lit)
+    instance ToJSON Lit
+deriving via (Generically AltCon)
+    instance ToJSON AltCon
+deriving via (Generically Type)
+    instance ToJSON Type
+deriving via (Generically Var)
+    instance ToJSON Var
+
+deriving via (Generically1 (BindingF b))
+    instance ToJSON b => ToJSON1 (BindingF b)
+deriving via (Generically1 (AlterF b))
+    instance ToJSON b => ToJSON1 (AlterF b)
+deriving via (Generically1 (ExprF b))
+    instance ToJSON b => ToJSON1 (ExprF b)
 

src/Core/SystemF.hs

@@ -0,0 +1,269 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedLists #-}
+module Core.SystemF
+    ( lintCoreProgR
+    , kindOf
+    )
+    where
+--------------------------------------------------------------------------------
+import GHC.Generics                 (Generic, Generically(..))
+import Data.HashMap.Strict          (HashMap)
+import Data.HashMap.Strict          qualified as H
+import Data.Function                (on)
+import Data.Traversable
+import Data.Foldable
+import Data.List.Extra
+import Control.Monad.Utils
+import Control.Monad
+import Data.Text                    qualified as T
+import Data.Pretty
+import Text.Printf
+
+import Control.Comonad
+import Control.Comonad.Cofree
+import Data.Fix
+import Data.Functor                 hiding (unzip)
+
+import Control.Lens                 hiding ((:<))
+import Control.Lens.Unsound
+
+import Compiler.RLPC
+import Compiler.RlpcError
+import Core
+--------------------------------------------------------------------------------
+
+data Gamma = Gamma
+    { _gammaVars   :: HashMap Name Type
+    , _gammaTyVars :: HashMap Name Kind
+    , _gammaTyCons :: HashMap Name Kind
+    }
+    deriving (Generic)
+    deriving (Semigroup, Monoid)
+        via (Generically Gamma)
+
+makeLenses ''Gamma
+
+lintCoreProgR :: (Monad m) => Program Var -> RLPCT m (Program Name)
+lintCoreProgR = liftEither . (_Left %~ pure) . lint
+
+lintDontCheck :: Program Var -> Program Name
+lintDontCheck = binders %~ view (_MkVar . _1)
+
+lint :: Program Var -> SysF (Program Name)
+lint p = do
+    scs <- traverse (lintScDef g0) $ p ^. programScDefs
+    pure $ lintDontCheck p & programScDefs .~ scs
+  where
+    g0 = mempty & gammaVars .~ typeSigs
+                & gammaTyCons .~ p ^. programTyCons
+    -- 'p' stores the type signatures as 'HashMap Var Type',
+    -- while our typechecking context demands a 'HashMap Name Type'.
+    -- This conversion is perfectly safe, as the 'Hashable' instance for
+    -- 'Var' hashes exactly the internal 'Name'. i.e.
+    -- `hash (MkVar n t) = hash n`.
+    typeSigs = p ^. programTypeSigs
+             & H.mapKeys (view $ _MkVar . _1)
+
+lintScDef :: Gamma -> ScDef Var -> SysF (ScDef Name)
+lintScDef g = traverseOf lambdaLifting $ \ (MkVar n t, e) -> do
+    e'@(t' :< _) <- lintE g e
+    assertUnify t t'
+    let e'' = stripVars . stripTypes $ e'
+    pure (n, e'')
+
+stripTypes :: ET -> Expr Var
+stripTypes (_ :< as) = Fix (stripTypes <$> as)
+
+stripVars :: Expr Var -> Expr Name
+stripVars = binders %~ view (_MkVar . _1)
+
+type ET = Cofree (ExprF Var) Type
+
+type SysF = Either SystemFError
+
+data SystemFError = SystemFErrorUndefinedVariable Name
+                  | SystemFErrorKindMismatch Kind Kind
+                  | SystemFErrorCouldNotMatch Type Type
+                  deriving Show
+
+instance IsRlpcError SystemFError where
+    liftRlpcError = \case
+        SystemFErrorUndefinedVariable n ->
+            undefinedVariableErr n
+        SystemFErrorKindMismatch k k' ->
+            Text [ T.pack $ printf "Could not match kind `%s' with `%s'"
+                                   (out k) (out k')
+                 ]
+        SystemFErrorCouldNotMatch t t' ->
+            Text [ T.pack $ printf "Could not match type `%s' with `%s'"
+                                   (out t) (out t')
+                 ]
+
+justLintCoreExpr = fmap (fmap (outPrec appPrec1)) . lintE demoContext
+
+lintE :: Gamma -> Expr Var -> SysF ET
+lintE g = \case
+    Var n -> lookupVar g n <&> (:< VarF n)
+    Lit (IntL n) -> pure $ TyInt :< LitF (IntL n)
+
+    Type t -> kindOf g t <&> (:< TypeF t)
+
+    App f x
+        -- type application
+        | Right (TyForall (a :^ k) m :< f') <- lintE g f
+        , Right (k' :< TypeF t) <- lintE g x
+        , k == k'
+        -> pure $ subst a t m :< f'
+
+        -- value application
+        | Right fw@((s :-> t) :< _) <- lintE g f
+        , Right xw@(s' :< _) <- lintE g x
+        , s == s'
+        -> pure $ t :< AppF fw xw
+
+    Lam bs e -> do
+        e'@(t :< _) <- lintE g' e
+        pure $ foldr arrowify t bs :< LamF bs e'
+      where
+        g' = foldMap suppl bs <> g
+
+        suppl (MkVar n t)
+            | isKind t  = mempty & gammaTyVars %~ H.insert n t
+            | otherwise = mempty & gammaVars %~ H.insert n t
+
+        arrowify (MkVar n s) s'
+            | isKind s  = TyForall (n :^ s) s'
+            | otherwise = s :-> s'
+
+    Let Rec bs e -> do
+        e'@(t :< _) <- lintE g' e
+        bs' <- (uncurry checkBind . (_2 %~ wrapFix)) `traverse` binds
+        pure $ t :< LetF Rec bs' e'
+      where
+        binds = bs ^.. each . _BindingF
+        vs = binds ^.. each . _1 . _MkVar
+        g' = supplementVars vs g
+        checkBind v@(MkVar n t) e = case lintE g' e of
+            Right (t' :< e') | t == t'   -> Right (BindingF v e')
+                             | otherwise -> Left (SystemFErrorCouldNotMatch t t')
+            Left e -> Left e
+    Let NonRec bs e -> do
+        (g',bs') <- mapAccumLM checkBind g bs
+        e'@(t :< _) <- lintE g' e
+        pure $ t :< LetF NonRec bs' e'
+      where
+        checkBind :: Gamma -> BindingF Var (Expr Var)
+                  -> SysF (Gamma, BindingF Var ET)
+        checkBind g (BindingF v@(n :^ t) e) = case lintE g (wrapFix e) of
+            Right (t' :< e')
+                | t == t'   -> Right (supplementVar n t g, BindingF v e')
+                | otherwise -> Left (SystemFErrorCouldNotMatch t t')
+            Left e -> Left e
+
+    Case e as -> do
+        e'@(et :< _) <- lintE g e
+        (ts,as') <- unzip <$> checkAlt et `traverse` as
+        case allUnify ts of
+            Just err -> Left err
+            Nothing  -> pure $ head ts :< CaseF e' as'
+      where
+        checkAlt :: Type -> Alter Var -> SysF (Type, AlterF Var ET)
+        checkAlt scrutineeType (AlterF (AltData con) bs e) = do
+            ct <- lookupVar g con
+            ct' <- foldrMOf applicants (elimForall g) ct scrutineeType
+            zipWithM_ fzip bs (ct' ^.. arrowStops)
+            (t :< e') <- lintE (supplementVars (varsToPairs bs) g) (wrapFix e)
+            pure (t, AlterF (AltData con) bs e')
+          where
+            fzip (MkVar _ t) t'
+                | t == t'   = Right ()
+                | otherwise = Left (SystemFErrorCouldNotMatch t t')
+
+assertUnify :: Type -> Type -> SysF ()
+assertUnify t t'
+    | t == t'   = pure ()
+    | otherwise = Left (SystemFErrorCouldNotMatch t t')
+
+allUnify :: [Type] -> Maybe SystemFError
+allUnify [] = Nothing
+allUnify [t] = Nothing
+allUnify (t:t':ts)
+    | t == t'   = allUnify ts
+    | otherwise = Just (SystemFErrorCouldNotMatch t t')
+
+elimForall :: Gamma -> Type -> Type -> SysF Type
+elimForall g t (TyForall (n :^ k) m) = do
+    k' <- kindOf g t
+    case k == k' of
+        True -> pure $ subst n t m
+        False -> Left $ SystemFErrorKindMismatch k k'
+elimForall _ m _ = pure m
+ 
+varsToPairs :: [Var] -> [(Name, Type)]
+varsToPairs = toListOf (each . _MkVar)
+
+checkAgainst :: Gamma -> Var -> Expr Var -> SysF ET
+checkAgainst g v@(MkVar n t) e = case lintE g e of
+    Right e'@(t' :< _) | t == t'      -> Right e'
+                       | otherwise    -> Left (SystemFErrorCouldNotMatch t t')
+    Left a -> Left a
+
+supplementVars :: [(Name, Type)] -> Gamma -> Gamma
+supplementVars vs = gammaVars <>~ H.fromList vs
+
+supplementVar :: Name -> Type -> Gamma -> Gamma
+supplementVar n t = gammaVars %~ H.insert n t
+
+supplementTyVar :: Name -> Kind -> Gamma -> Gamma
+supplementTyVar n t = gammaTyVars %~ H.insert n t
+
+subst :: Name -> Type -> Type -> Type
+subst k v (TyVar n) | k == n = v
+subst k v (TyForall (MkVar n k') t)
+    | k /= n                 = TyForall (MkVar n k') (subst k v t)
+    | otherwise              = TyForall (MkVar n k') t
+subst k v (TyApp f x)        = (TyApp `on` subst k v) f x
+subst _ _ x                  = x
+
+isKind :: Type -> Bool
+isKind (s :-> t)  = isKind s && isKind t
+isKind TyKindType = True
+isKind _          = False
+
+kindOf :: Gamma -> Type -> SysF Kind
+kindOf g (TyVar n)  = lookupTyVar g n
+kindOf _ TyKindType = pure TyKindType
+kindOf g (TyCon n)  = lookupCon g n
+kindOf _ e          = error (show e)
+
+lookupCon :: Gamma -> Name -> SysF Kind
+lookupCon g n = case g ^. gammaTyCons . at n of
+    Just k  -> Right k
+    Nothing -> Left (SystemFErrorUndefinedVariable n)
+
+lookupVar :: Gamma -> Name -> SysF Type
+lookupVar g n = case g ^. gammaVars . at n of
+    Just t -> Right t
+    Nothing -> Left (SystemFErrorUndefinedVariable n)
+
+lookupTyVar :: Gamma -> Name -> SysF Kind
+lookupTyVar g n = case g ^. gammaTyVars . at n of
+    Just k -> Right k
+    Nothing -> Left (SystemFErrorUndefinedVariable n)
+
+demoContext :: Gamma
+demoContext = Gamma
+    { _gammaVars =
+        [ ("id", TyForall ("a" :^ TyKindType) $ TyVar "a" :-> TyVar "a")
+        , ("Just", TyForall ("a" :^ TyKindType) $
+            TyVar "a" :-> (TyCon "Maybe" `TyApp` TyVar "a"))
+        , ("Nothing", TyForall ("a" :^ TyKindType) $
+            TyCon "Maybe" `TyApp` TyVar "a")
+        ]
+    , _gammaTyVars = []
+    , _gammaTyCons =
+        [ ("Int#", TyKindType)
+        , ("Maybe", TyKindType :-> TyKindType)
+        ]
+    }
+

src/Core/TH.hs

@@ -5,62 +5,55 @@ Description : Core quasiquoters
 module Core.TH
     ( coreExpr
     , coreProg
-    , core
+    -- , coreExprT
+    -- , 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, checkCoreExprR)
 ----------------------------------------------------------------------------------
 
-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 >=> parseCoreExprR
+
+-- | Type-checked @coreProg@
+-- coreProgT :: QuasiQuoter
+-- coreProgT = mkqq $ lexCoreR >=> parseCoreProgR >=> checkCoreProgR
+
+-- coreExprT :: QuasiQuoter
+-- coreExprT = mkqq $ lexCoreR >=> parseCoreExprR >=> checkCoreExprR g
+--     where
+--         g = [ ("+#", TyInt :-> TyInt :-> TyInt)
+--             , ("id", TyForall (MkVar "a" TyKindType) $
+--                     TyVar "a" :-> TyVar "a")
+--             , ("fix", TyForall (MkVar "a" TyKindType) $
+--                     (TyVar "a" :-> TyVar "a") :-> TyVar "a")
+--             ]
+
+mkqq :: (Lift a) => (Text -> RLPCIO 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 -> RLPCIO a) -> String -> Q Exp
+mkq parse s = liftIO $ evalRLPCIO def (parse $ T.pack s) >>= lift
 

src/Core/Utils.hs

@@ -1,72 +1,37 @@
--- for recursion schemes
-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
--- for recursion schemes
-{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
-
 module Core.Utils
-    ( bindersOf
-    , rhssOf
+    ( programRhss
+    , programGlobals
     , isAtomic
-    , insertModule
-    , extractProgram
     , freeVariables
-    , ExprF(..)
     )
     where
 ----------------------------------------------------------------------------------
 import Data.Functor.Foldable.TH     (makeBaseFunctor)
 import Data.Functor.Foldable
-import Data.Set                     (Set)
-import Data.Set                     qualified as S
+import Data.HashSet                 (HashSet)
+import Data.HashSet                 qualified as S
 import Core.Syntax
+import Control.Lens
 import GHC.Exts                     (IsList(..))
 ----------------------------------------------------------------------------------
 
-bindersOf :: (IsList l, Item l ~ b) => [Binding b] -> l
-bindersOf bs = fromList $ fmap f bs
-    where f (k := _) = k
+programGlobals :: Traversal' (Program b) b
+programGlobals = programScDefs . each . _lhs . _1
 
-rhssOf :: (IsList l, Item l ~ Expr b) => [Binding b] -> l
-rhssOf = fromList . fmap f
-    where f (_ := v) = v
+programRhss :: Traversal' (Program b) (Expr b)
+programRhss = programScDefs . each . _rhs
 
 isAtomic :: Expr b -> Bool
 isAtomic (Var _)  = True
-isAtomic (LitE _) = True
+isAtomic (Lit _)  = True
 isAtomic _        = False
 
 ----------------------------------------------------------------------------------
 
--- TODO: export list awareness
-insertModule :: Module b -> Program b -> Program b
-insertModule (Module _ m) p = p <> m
-
-extractProgram :: Module b -> Program b
-extractProgram (Module _ p) = p
-
-----------------------------------------------------------------------------------
-
-makeBaseFunctor ''Expr
-
-freeVariables :: Expr' -> Set Name
-freeVariables = cata go
-    where
-        go :: ExprF Name (Set Name) -> Set Name
-        go (VarF k)         = S.singleton k
-        -- TODO: collect free vars in rhss of bs
-        go (LetF _ bs e)    = (e `S.union` esFree) `S.difference` ns
-            where
-                es = rhssOf bs :: [Expr']
-                ns = bindersOf bs
-                -- TODO: this feels a little wrong. maybe a different scheme is
-                -- appropriate
-                esFree = foldMap id $ freeVariables <$> es
-
-        go (CaseF e as)     = e `S.union` asFree
-            where
-                asFree = foldMap id $ freeVariables <$> (fmap altToLam as)
-                -- we map alts to lambdas to avoid writing a 'freeVariablesAlt'
-                altToLam (Alter _ ns e) = Lam ns e
-        go (LamF bs e)      = e `S.difference` (S.fromList bs)
-        go e                = foldMap id e
+freeVariables :: Expr' -> HashSet Name
+freeVariables = undefined
+-- freeVariables = cata \case
+--     VarF n -> S.singleton n
+--     CaseF e as -> e <> (foldMap f as)
+--         where f (AlterF _ bs e) = fold e `S.difference` S.fromList bs
 

src/Core2Core.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ImplicitParams #-}
 module Core2Core
     ( core2core
     , gmPrep
@@ -11,89 +11,138 @@ module Core2Core
 ----------------------------------------------------------------------------------
 import Data.Functor.Foldable
 import Data.Maybe               (fromJust)
-import Data.Set                 (Set)
-import Data.Set                 qualified as S
+import Data.HashSet             (HashSet)
+import Data.HashSet             qualified as S
 import Data.List
+import Data.Foldable
 import Control.Monad.Writer
-import Control.Monad.State
+import Control.Monad.State.Lazy
 import Control.Arrow            ((>>>))
+import Data.Text                qualified as T
+import Data.HashMap.Strict      (HashMap)
 import Numeric                  (showHex)
-import Lens.Micro
+
+import Misc.MonadicRecursionSchemes
+
+import Data.Pretty
+import Compiler.RLPC
+import Control.Lens
 import Core.Syntax
 import Core.Utils
 ----------------------------------------------------------------------------------
 
+-- | General optimisations
+
 core2core :: Program' -> Program'
 core2core p = undefined
 
+gmPrepR :: (Monad m) => Program' -> RLPCT m Program'
+gmPrepR p = do
+    let p' = gmPrep p
+    addDebugMsg "dump-gm-preprocessed" $ show . out $ p'
+    pure p'
+
+-- | G-machine-specific preprocessing.
+
 gmPrep :: Program' -> Program'
-gmPrep p = p' <> Program caseScs
+gmPrep p = p & appFloater (floatNonStrictCases globals)
+             & tagData
+             & defineData
+             & etaReduce
     where
-        rhss :: Applicative f => (Expr z -> f (Expr z)) -> Program z -> f (Program z)
-        rhss = programScDefs . each . _rhs
         globals = p ^.. programScDefs . each . _lhs . _1
                 & S.fromList
 
-        -- i kinda don't like that we're calling floatNonStrictCases twice tbh
-        p'      = p & rhss %~ fst . runFloater . floatNonStrictCases globals
-        caseScs = (p ^.. rhss)
-              <&> snd . runFloater . floatNonStrictCases globals
-                & mconcat
+programGlobals :: Program b -> HashSet b
+programGlobals = undefined
+
+-- | Define concrete supercombinators for all datatags defined via pragmas (or
+-- desugaring)
+
+defineData :: Program' -> Program'
+defineData p = p & programScDefs <>~ defs
+    where
+        defs = p ^. programDataTags
+             . to (ifoldMap (\k (t,a) -> [ScDef k [] (Con t a)]))
+
+-- | Substitute all pattern matches on named constructors for matches on tags
+
+tagData :: Program' -> Program'
+tagData p = let ?dt = p ^. programDataTags
+            in p & programRhss %~ cata go where
+    go :: (?dt :: HashMap Name (Tag, Int)) => ExprF' Expr' -> Expr'
+    go (CaseF  e as)    = Case e (tagAlts <$> as)
+    go x                = embed x
+
+    tagAlts :: (?dt :: HashMap Name (Tag, Int)) => Alter' -> Alter'
+    tagAlts (Alter (AltData c) bs e) = Alter (AltTag tag) bs (cata go e)
+        where tag = case ?dt ^. at c of
+                Just (t,_) -> t
+                -- TODO: errorful
+                Nothing    -> error $ "unknown constructor " <> show c
+    tagAlts x = x
 
 -- | Auxilary type used in @floatNonSrictCases@
 type Floater = StateT [Name] (Writer [ScDef'])
 
+appFloater :: (Expr' -> Floater Expr') -> Program' -> Program'
+appFloater fl p = p & traverseOf programRhss fl
+                    & runFloater
+                    & \ (me,floats) -> me & programScDefs %~ (<>floats)
+
+-- TODO: move NameSupply from Rlp2Core into a common module to share here
 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.
-floatNonStrictCases :: Set Name -> Expr' -> Floater Expr'
+floatNonStrictCases :: HashSet Name -> Expr' -> Floater Expr'
 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
         goE e                   = goC e
 
         goC :: Expr' -> Floater Expr'
-        -- the only truly non-trivial case: when a case expr is found in a
-        -- non-strict context, we float it into a supercombinator, give it a
-        -- name consumed from the state, record the newly created sc within the
-        -- Writer, and finally return an expression appropriately calling the sc
-        goC p@(Case e as)       = do
-            n <- name
-            let (e',sc) = floatCase g n p
-                altBodies = (\(Alter _ _ b) -> b) <$> as
-            tell [sc]
-            goE e
-            traverse goE altBodies
-            pure e'
-        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 (Var k)             = pure (Var k)
-        goC (Con t as)          = pure (Con t as)
+        goC = cataM \case
+            -- the only truly non-trivial case: when a case expr is found in a
+            -- non-strict context, we float it into a supercombinator, give it a
+            -- name consumed from the state, record the newly created sc within the
+            -- Writer, and finally return an expression appropriately calling the sc
+            CaseF e as -> do
+                n <- name
+                let (e',sc) = floatCase g n (Case e as)
+                    altBodies = (\(Alter _ _ b) -> b) <$> as
+                tell [sc]
+                goE e
+                traverse_ goE altBodies
+                pure e'
+            t -> pure $ embed t
 
-        name = state (fromJust . uncons)
+        name = state (fromJust . Data.List.uncons)
 
         -- extract the right-hand sides of a list of bindings, traverse each
         -- one, and return the original list of bindings
         travBs :: (Expr' -> Floater Expr') -> [Binding'] -> Floater [Binding']
-        travBs c bs = bs ^.. each . _rhs
-                    & traverse goC
-                    & const (pure bs)
+        travBs c bs = undefined
+        -- ^ ??? what the fuck?
+        -- ^ 24/02/22: what is this shit lol?
+
+etaReduce :: Program' -> Program'
+etaReduce = programScDefs . each %~ \case
+    ScDef n as (Lam bs e) -> ScDef n (as ++ bs) e
+    ScDef n as e -> ScDef n as e
 
 -- when provided with a case expr, floatCase will float the case into a
 -- supercombinator of its free variables. the sc is returned along with an
 -- expression that calls the sc with the necessary arguments
-floatCase :: Set Name -> Name -> Expr' -> (Expr', ScDef')
+floatCase :: HashSet Name -> Name -> Expr' -> (Expr', ScDef')
 floatCase g n c@(Case e as) = (e', sc)
     where
         sc = ScDef n caseFrees c

src/Data/Heap.hs

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

src/Data/Pretty.hs

@@ -1,80 +1,114 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE QuantifiedConstraints, UndecidableInstances #-}
 module Data.Pretty
-    ( Pretty(..)
-    , ISeq(..)
-    , precPretty
-    , prettyPrint
-    , prettyShow
-    , iShow
-    , iBracket
-    , withPrec
-    , bracketPrec
+    ( Out(..), Out1(..)
+    , outPrec1
+    , rout
+    , ttext
+    , Showing(..)
+    -- * Out-printing lens combinators
+    , hsepOf, vsepOf, vcatOf, vlinesOf
+    , module Prettyprinter
+    , maybeParens
+    , appPrec
+    , appPrec1
     )
     where
 ----------------------------------------------------------------------------------
-import Data.String      (IsString(..))
+import Prettyprinter
+import Text.Printf
+import Data.String                  (IsString(..))
+import Data.Text.Lens               hiding ((:<))
+import Data.Monoid                  hiding (Sum)
+import Data.Bool
+import Control.Lens                 hiding ((:<))
+
+-- instances
+import Control.Comonad.Cofree
+import Data.Text                    qualified as T
+import Data.Functor.Sum
+import Data.Fix                     (Fix(..))
 ----------------------------------------------------------------------------------
 
-class Pretty a where
-    pretty :: a -> ISeq
-    prettyPrec :: a -> Int -> ISeq
+class Out a where
+    out :: a -> Doc ann
+    outPrec :: Int -> a -> Doc ann
 
-    {-# MINIMAL pretty | prettyPrec #-}
-    pretty a = prettyPrec a 0
-    prettyPrec a _ = iBracket (pretty a)
+    {-# MINIMAL out | outPrec #-}
+    out = outPrec 0
+    outPrec = const out
 
-precPretty :: (Pretty a) => Int -> a -> ISeq
-precPretty = flip prettyPrec
+rout :: (IsString s, Out a) => a -> s
+rout = fromString . show . out
 
-prettyPrint :: (Pretty a) => a -> IO ()
-prettyPrint = putStr . squash . pretty
+-- instance Out (Doc ann) where
+--     out = id
 
-prettyShow :: (Pretty a) => a -> String
-prettyShow = squash . pretty
+instance Out String where
+    out = pretty
 
-data ISeq where
-    INil :: ISeq
-    IStr :: String -> ISeq
-    IAppend :: ISeq -> ISeq -> ISeq
-    IIndent :: ISeq -> ISeq
-    IBreak :: ISeq
+instance Out T.Text where
+    out = pretty
 
-instance IsString ISeq where
-    fromString = IStr
+newtype Showing a = Showing a
 
-instance Semigroup ISeq where
-    (<>) = IAppend
+instance (Show a) => Out (Showing a) where
+    outPrec p (Showing a) = fromString $ showsPrec p a ""
 
-instance Monoid ISeq where
-    mempty = INil
+deriving via Showing Int instance Out Int
 
-squash :: ISeq -> String
-squash a = flatten 0 [(a,0)]
+class (forall a. Out a => Out (f a)) => Out1 f where
+    liftOutPrec :: (Int -> a -> Doc ann) -> Int -> f a -> Doc ann
 
-flatten :: Int -> [(ISeq, Int)] -> String
-flatten _ []                      = ""
-flatten c ((INil,        i) : ss) = flatten c ss
-flatten c ((IStr s,      i) : ss) = s ++ flatten (c + length s) ss
-flatten c ((IAppend r s, i) : ss) = flatten c ((r,i) : (s,i) : ss)
-flatten _ ((IBreak,      i) : ss) = '\n' : replicate i ' ' ++ flatten i ss
-flatten c ((IIndent s,   i) : ss) = flatten c ((s,c) : ss)
+outPrec1 :: (Out1 f, Out a) => Int -> f a -> Doc ann
+outPrec1 = liftOutPrec outPrec
 
-iBracket :: ISeq -> ISeq
-iBracket s = IStr "(" <> s <> IStr ")"
+instance (Out1 f, Out1 g, Out a) => Out (Sum f g a) where
+    outPrec p (InL fa) = outPrec1 p fa
+    outPrec p (InR ga) = outPrec1 p ga
 
-withPrec :: Int -> ISeq -> Int -> ISeq
-withPrec n s p
-    | p > n     = iBracket s
-    | otherwise =          s
+instance (Out1 f, Out1 g) => Out1 (Sum f g) where
+    liftOutPrec pr p (InL fa) = liftOutPrec pr p fa
+    liftOutPrec pr p (InR ga) = liftOutPrec pr p ga
 
-bracketPrec :: Int -> Int -> ISeq -> ISeq
-bracketPrec n p s = withPrec n s p
+instance (Out (f (Fix f))) => Out (Fix f) where
+    outPrec d (Fix f) = outPrec d f
 
-iShow :: (Show a) => a -> ISeq
-iShow = IStr . show
+instance (Out (f (Cofree f a)), Out a) => Out (Cofree f a) where
+    outPrec d (a :< f) = maybeParens (d>0) $
+        hsep [outPrec 0 f, ":", outPrec 0 a]
 
-----------------------------------------------------------------------------------
+--------------------------------------------------------------------------------
+
+ttext :: Out t => t -> Doc ann
+ttext = out
+
+hsepOf :: Getting (Endo (Doc ann)) s (Doc ann) -> s -> Doc ann
+hsepOf l = foldrOf l (<+>) mempty
+
+vsepOf :: _ -> s -> Doc ann
+vsepOf l = vsep . toListOf l
+
+vcatOf :: _ -> s -> Doc ann
+vcatOf l = vcat . toListOf l
+
+vlinesOf :: Getting (Endo (Doc ann)) s (Doc ann) -> s -> Doc ann
+vlinesOf l = foldrOf l (\a b -> a <> line <> b) mempty
+-- hack(?) to separate chunks with a blankline
+
+--------------------------------------------------------------------------------
+
+maybeParens :: Bool -> Doc ann -> Doc ann
+maybeParens = bool id parens
+
+appPrec, appPrec1 :: Int
+appPrec  = 10
+appPrec1 = 11
+
+instance PrintfArg (Doc ann) where
+    formatArg d fmt
+        | fmtChar (vFmt 'D' fmt) == 'D' = formatString (show d) fmt'
+        | otherwise                     = errorBadFormat $ fmtChar fmt
+      where
+        fmt' = fmt { fmtChar = 's', fmtPrecision = Nothing }
 
-instance (Pretty a) => Pretty (Maybe a) where
-    prettyPrec (Just a) p = prettyPrec a p
-    prettyPrec Nothing  p = "<Nothing>"

src/GM.hs

@@ -8,8 +8,13 @@ Description : The G-Machine
 module GM
     ( hdbgProg
     , evalProg
+    , evalProgR
+    , GmState(..)
+    , gmCode, gmStack, gmDump, gmHeap, gmEnv, gmStats
     , Node(..)
+    , showState
     , gmEvalProg
+    , Stats(..)
     , finalStateOf
     , resultOf
     , resultOfExpr
@@ -21,20 +26,35 @@ import Data.List                    (mapAccumL)
 import Data.Maybe                   (fromMaybe, mapMaybe)
 import Data.Monoid                  (Endo(..))
 import Data.Tuple                   (swap)
-import Lens.Micro
-import Lens.Micro.TH
+import Control.Lens
+import Data.Text.Lens               (IsText, packed, unpacked)
 import Text.Printf
-import Text.PrettyPrint             hiding ((<>))
-import Text.PrettyPrint.HughesPJ    (maybeParens)
 import Data.Foldable                (traverse_)
+import Prettyprinter
+import Data.Pretty
 import System.IO                    (Handle, hPutStrLn)
+-- TODO: an actual output system
+-- TODO: an actual output system
+-- TODO: an actual output system
+-- TODO: an actual output system
+import System.IO.Unsafe             (unsafePerformIO)
 import Data.String                  (IsString)
 import Data.Heap
 import Debug.Trace
+import Compiler.RLPC
 import Core2Core
 import Core
 ----------------------------------------------------------------------------------
 
+tag_Unit_unit :: Int
+tag_Unit_unit = 0
+
+tag_Bool_True :: Int
+tag_Bool_True = 1
+
+tag_Bool_False :: Int
+tag_Bool_False = 0
+
 {-}
 
 hdbgProg = undefined
@@ -70,6 +90,7 @@ data Key = NameKey Name
          | ConstrKey Tag Int
          deriving (Show, Eq)
 
+-- >> [ref/Instr]
 data Instr = Unwind
            | PushGlobal Name
            | PushConstr Tag Int
@@ -84,12 +105,14 @@ data Instr = Unwind
            -- arith
            | Neg | Add | Sub | Mul | Div
            -- comparison
-           | Equals
+           | Equals | Lesser | GreaterEq
            | Pack Tag Int -- Pack Tag Arity
            | CaseJump [(Tag, Code)]
            | Split Int
+           | Print
            | Halt
            deriving (Show, Eq)
+-- << [ref/Instr]
 
 data Node = NNum Int
           | NAp Addr Addr
@@ -132,7 +155,7 @@ evalProg p = res <&> (,sts)
         resAddr = final ^. gmStack ^? _head
         res = resAddr >>= flip hLookup h
 
-hdbgProg :: Program' -> Handle -> IO (Node, Stats)
+hdbgProg :: Program' -> Handle -> IO GmState
 hdbgProg p hio = do
     (renderOut . showState) `traverse_` states
     -- TODO: i'd like the statistics to be at the top of the file, but `sts`
@@ -140,9 +163,9 @@ hdbgProg p hio = do
     -- *can't* get partial logs in the case of a crash. this is in opposition to
     -- the above traversal which *will* produce partial logs. i love laziness :3
     renderOut . showStats $ sts
-    pure (res, sts)
+    pure final
     where
-        renderOut r = hPutStrLn hio $ render r ++ "\n"
+        renderOut r = hPutStrLn hio $ show r ++ "\n"
 
         states = eval $ compile p
         final = last states
@@ -153,6 +176,21 @@ hdbgProg p hio = do
         [resAddr] = final ^. gmStack
         res = hLookupUnsafe resAddr h
 
+evalProgR :: (Monad m) => Program' -> RLPCT m (Node, Stats)
+evalProgR p = do
+    (renderOut . showState) `traverse_` states
+    renderOut . showStats $ sts
+    pure (res, sts)
+    where
+        renderOut r = addDebugMsg "dump-eval" $ show r ++ "\n"
+        states = eval . compile $ p
+        final = last states
+
+        sts = final ^. gmStats
+        -- the address of the result should be the one and only stack entry
+        [resAddr] = final ^. gmStack
+        res = hLookupUnsafe resAddr (final ^. gmHeap)
+
 eval :: GmState -> [GmState]
 eval st = st : rest
     where
@@ -175,29 +213,55 @@ isFinal st = null $ st ^. gmCode
 
 step :: GmState -> GmState
 step st = case head (st ^. gmCode) of
-    Unwind         -> unwindI        
+    Unwind         -> unwindI
     PushGlobal n   -> pushGlobalI   n
     PushConstr t n -> pushConstrI t n
     PushInt    n   -> pushIntI      n
     Push       n   -> pushI         n
-    MkAp           -> mkApI          
+    MkAp           -> mkApI
     Slide      n   -> slideI        n
     Pop        n   -> popI          n
     Update     n   -> updateI       n
     Alloc      n   -> allocI        n
-    Eval           -> evalI          
-    Neg            -> negI           
-    Add            -> addI           
-    Sub            -> subI           
-    Mul            -> mulI           
-    Div            -> divI           
-    Equals         -> equalsI           
+    Eval           -> evalI
+    Neg            -> negI
+    Add            -> addI
+    Sub            -> subI
+    Mul            -> mulI
+    Div            -> divI
+    Equals         -> equalsI
+    Lesser         -> lesserI
+    GreaterEq      -> greaterEqI
     Split      n   -> splitI        n
     Pack       t n -> packI       t n
     CaseJump    as -> caseJumpI    as
+    Print          -> printI
     Halt           -> haltI
     where
 
+        printI :: GmState
+        printI = case hLookupUnsafe a h of
+            NNum n       -> (evilTempPrinter `seq` st)
+                          & gmCode .~ i
+                          & gmStack .~ s
+                where
+                    -- TODO: an actual output system
+                    -- TODO: an actual output system
+                    -- TODO: an actual output system
+                    -- TODO: an actual output system
+                    evilTempPrinter = unsafePerformIO (print n)
+            NConstr _ as -> st
+                          & gmCode .~ i' ++ i
+                          & gmStack .~ s'
+                where
+                    i' = mconcat $ replicate n [Eval,Print]
+                    n = length as
+                    s' = as ++ s
+          where
+            h = st ^. gmHeap
+            (a:s) = st ^. gmStack
+            Print : i = st ^. gmCode
+
         -- nuke the state
         haltI :: GmState
         haltI = error "halt#"
@@ -281,7 +345,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
@@ -391,8 +455,10 @@ step st = case head (st ^. gmCode) of
         mulI = primitive2 boxInt unboxInt (*) st
         divI = primitive2 boxInt unboxInt div st
 
-        equalsI :: GmState
+        lesserI, greaterEqI, equalsI :: GmState
         equalsI = primitive2 boxBool unboxInt (==) st
+        lesserI = primitive2 boxBool unboxInt (<) st
+        greaterEqI = primitive2 boxBool unboxInt (>=) st
 
         splitI :: Int -> GmState
         splitI n = st
@@ -534,12 +600,13 @@ boxBool st p = st
     where
         h = st ^. gmHeap
         (h',a) = alloc h (NConstr p' [])
-        p' = if p then 1 else 0
+        p' = if p then tag_Bool_True else tag_Bool_False
 
 unboxBool :: Addr -> GmState -> Bool
 unboxBool a st = case hLookup a h of
-        Just (NConstr 1 []) -> True
-        Just (NConstr 0 []) -> False
+        Just (NConstr t [])
+            | t == tag_Bool_True  -> True
+            | t == tag_Bool_False -> False
         Just _              -> error "unboxInt received a non-int"
         Nothing             -> error "unboxInt received an invalid address"
     where h = st ^. gmHeap
@@ -575,6 +642,10 @@ compiledPrims =
     , binop "*#" Mul
     , binop "/#" Div
     , binop "==#" Equals
+    , binop "<#" Lesser
+    , binop ">=#" GreaterEq
+    , ("print#", 1, [ Push 0, Eval, Print, Pack tag_Unit_unit 0, Update 1, Pop 1
+                    , Unwind ])
     ]
     where
         unop k i = (k, 1, [Push 0, Eval, i, Update 1, Pop 1, Unwind])
@@ -582,7 +653,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 +683,13 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
             | k `elem` domain  = [Push n]
             | otherwise        = [PushGlobal k]
             where
-                n = fromMaybe (error $ "undeclared var: " <> k) $ lookupN k g
+                n = fromMaybe err $ lookupN k g
+                err = error $ "undeclared var: " <> (k ^. unpacked)
                 domain = f `mapMaybe` g
                 f (NameKey n, _) = Just n
                 f _              = Nothing
 
-        compileC _ (LitE l)  = compileCL l
+        compileC _ (Lit l)   = compileCL l
 
         -- >> [ref/compileC]
         compileC g (App f x) = compileC g x
@@ -657,33 +729,32 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
         compileC _ (Con t n) = [PushConstr t n]
 
         compileC _ (Case _ _) =
-            error "case expressions may not appear in non-strict contexts :/"
+            error "GM compiler found a non-strict case expression, which should\
+                  \ have been floated by Core2Core.gmPrep. This is a bug!"
 
         compileC _ _ = error "yet to be implemented!"
 
-        compileCL :: Literal -> Code
+        compileCL :: Lit -> Code
         compileCL (IntL n) = [PushInt n]
 
-        compileEL :: Literal -> Code
+        compileEL :: Lit -> Code
         compileEL (IntL n) = [PushInt n]
 
         -- compile an expression in a strict context such that a pointer to the
         -- expression is left on top of the stack in WHNF
         compileE :: Env -> Expr' -> Code
-        compileE _ (LitE l) = compileEL l
+        compileE _ (Lit l) = compileEL l
         compileE g (Let NonRec bs e) =
                 -- we use compileE instead of compileC
                 mconcat binders <> compileE g' e <> [Slide d]
             where
                 d = length bs
-                (g',binders) = mapAccumL compileBinder (argOffset d g) addressed
-                -- kinda gross. revisit this
-                addressed = bs `zip` reverse [0 .. d-1]
+                (g',binders) = mapAccumL compileBinder g bs
 
-                compileBinder :: Env -> (Binding', Int) -> (Env, Code)
-                compileBinder m (k := v, a) = (m',c)
+                compileBinder :: Env -> Binding' -> (Env, Code)
+                compileBinder m (k := v) = (m',c)
                     where
-                        m' = (NameKey k, a) : m
+                        m' = (NameKey k, 0) : argOffset 1 m
                         -- make note that we use m rather than m'!
                         c = compileC m v
 
@@ -711,21 +782,27 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
         compileE g ("*#" :$ a :$ b)  = inlineOp2 g Mul    a b
         compileE g ("/#" :$ a :$ b)  = inlineOp2 g Div    a b
         compileE g ("==#" :$ a :$ b) = inlineOp2 g Equals a b
+        compileE g ("<#" :$ a :$ b)  = inlineOp2 g Lesser a b
+        compileE g (">=#" :$ a :$ b)  = inlineOp2 g GreaterEq a b
 
         compileE g (Case e as) = compileE g e <> [CaseJump (compileD g as)]
 
         compileE g e = compileC g e ++ [Eval]
 
         compileD :: Env -> [Alter'] -> [(Tag, Code)]
-        compileD g as = fmap (compileA g) as
+        compileD g = fmap (compileA g)
 
         compileA :: Env -> Alter' -> (Tag, Code)
-        compileA g (Alter (AltData t) as e) = (t, [Split n] <> c <> [Slide n])
+        compileA g (Alter (AltTag t) as e) = (t, [Split n] <> c <> [Slide n])
             where
                 n = length as
                 binds = (NameKey <$> as) `zip` [0..]
                 g' = binds ++ argOffset n g
                 c = compileE g' e
+        compileA _ (Alter _ as e) = error "GM.compileA found an untagged\
+                                          \ constructor, which should have\
+                                          \ been handled by Core2Core.gmPrep.\
+                                          \ This is a bug!"
 
         inlineOp1 :: Env -> Instr -> Expr' -> Code
         inlineOp1 g i a = compileE g a <> [i]
@@ -738,21 +815,21 @@ 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
 
 ----------------------------------------------------------------------------------
 
 pprTabstop :: Int
 pprTabstop = 4
 
-qquotes :: Doc -> Doc
+qquotes :: Doc ann -> Doc ann
 qquotes d = "`" <> d <> "'"
 
-showStats :: Stats -> Doc
-showStats sts = "==== Stats ============" $$ stats
+showStats :: Stats -> Doc ann
+showStats sts = "==== Stats ============" <> line <> stats
     where
-        stats = text $ printf
+        stats = textt @String $ printf
             "Reductions      : %5d\n\
             \Prim Reductions : %5d\n\
             \Allocations     : %5d\n\
@@ -762,10 +839,10 @@ showStats sts = "==== Stats ============" $$ stats
             (sts ^. stsAllocations)
             (sts ^. stsGCCycles)
 
-showState :: GmState -> Doc
+showState :: GmState -> Doc ann
 showState st = vcat
         [ "==== GmState " <> int stnum <> " "
-            <> text (replicate (28 - 13 - 1 - digitalWidth stnum) '=')
+            <> textt (replicate (28 - 13 - 1 - digitalWidth stnum) '=')
         , "-- Next instructions -------"
         , info $ showCodeShort c
         , "-- Stack -------------------"
@@ -782,23 +859,23 @@ showState st = vcat
         -- indent data
         info = nest pprTabstop
 
-showCodeShort :: Code -> Doc
+showCodeShort :: Code -> Doc ann
 showCodeShort c = braces c'
     where
         c' | length c > 3 = list (showInstr <$> take 3 c) <> "; ..."
            | otherwise    = list (showInstr <$> c)
         list = hcat . punctuate "; "
 
-showStackShort :: Stack -> Doc
+showStackShort :: Stack -> Doc ann
 showStackShort s = brackets s'
     where
            -- no access to heap, otherwise we'd use showNodeAt
         s' | length s > 3 = list (showEntry <$> take 3 s) <> ", ..."
            | otherwise    = list (showEntry <$> s)
         list = hcat . punctuate ", "
-        showEntry = text . show
+        showEntry = textt . show
 
-showStack :: GmState -> Doc
+showStack :: GmState -> Doc ann
 showStack st = vcat $ uncurry showEntry <$> si
     where
         h = st ^. gmHeap
@@ -810,10 +887,9 @@ showStack st = vcat $ uncurry showEntry <$> si
         w = maxWidth (addresses h)
         showIndex n = padInt w n <> ": "
 
-        showEntry :: Int -> Addr -> Doc
         showEntry n a = showIndex n <> showNodeAt st a
 
-showDump :: GmState -> Doc
+showDump :: GmState -> Doc ann
 showDump st = vcat $ uncurry showEntry <$> di
     where
         d = st ^. gmDump
@@ -822,14 +898,13 @@ showDump st = vcat $ uncurry showEntry <$> di
         showIndex n = padInt w n <> ": "
         w = maxWidth (fst <$> di)
 
-        showEntry :: Int -> (Code, Stack) -> Doc
         showEntry n (c,s) = showIndex n <> nest pprTabstop entry
             where
-                entry = ("Stack : " <> showCodeShort c)
-                     $$ ("Code  : " <> showStackShort s)
+                entry = vsep [ "Stack : " <> showCodeShort c
+                             , "Code  : " <> showStackShort s ]
 
-padInt :: Int -> Int -> Doc
-padInt m n = text (replicate (m - digitalWidth n) ' ') <> int n
+padInt :: Int -> Int -> Doc ann
+padInt m n = textt (replicate (m - digitalWidth n) ' ') <> int n
 
 maxWidth :: [Int] -> Int
 maxWidth ns = digitalWidth $ maximum ns
@@ -837,7 +912,7 @@ maxWidth ns = digitalWidth $ maximum ns
 digitalWidth :: Int -> Int
 digitalWidth = length . show
 
-showHeap :: GmState -> Doc
+showHeap :: GmState -> Doc ann
 showHeap st = vcat $ showEntry <$> addrs
     where
         showAddr n = padInt w n <> ": "
@@ -846,21 +921,20 @@ showHeap st = vcat $ showEntry <$> addrs
         h = st ^. gmHeap
         addrs = addresses h
 
-        showEntry :: Addr -> Doc
         showEntry a = showAddr a <> showNodeAt st a
 
-showNodeAt :: GmState -> Addr -> Doc
+showNodeAt :: GmState -> Addr -> Doc ann
 showNodeAt = showNodeAtP 0
 
-showNodeAtP :: Int -> GmState -> Addr -> Doc
+showNodeAtP :: Int -> GmState -> Addr -> Doc ann
 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
@@ -876,9 +950,9 @@ showNodeAtP p st a = case hLookup a h of
         h = st ^. gmHeap
         pprec = maybeParens (p > 0)
 
-showSc :: GmState -> (Name, Addr) -> Doc
-showSc st (k,a) = "Supercomb " <> qquotes (text k) <> colon
-               $$ code
+showSc :: GmState -> (Name, Addr) -> Doc ann
+showSc st (k,a) = vcat [ "Supercomb " <> qquotes (textt k) <> colon
+                       , code ]
     where
         code = case hLookup a (st ^. gmHeap) of
             Just (NGlobal _ c) -> showCode c
@@ -889,16 +963,21 @@ errTxtInvalidObject, errTxtInvalidAddress :: (IsString a) => a
 errTxtInvalidObject = "<invalid object>"
 errTxtInvalidAddress = "<invalid address>"
 
-showCode :: Code -> Doc
+showCode :: Code -> Doc ann
 showCode c = "Code" <+> braces instrs
     where instrs = vcat $ showInstr <$> c
 
-showInstr :: Instr -> Doc
-showInstr (CaseJump alts) = "CaseJump" $$ nest pprTabstop alternatives
+showInstr :: Instr -> Doc ann
+showInstr (CaseJump alts) = vcat [ "CaseJump", nest pprTabstop alternatives ]
     where
         showAlt (t,c) = "<" <> int t <> ">" <> showCodeShort c
-        alternatives = foldr (\a acc -> showAlt a $$ acc) mempty alts
-showInstr i = text $ show i
+        alternatives = foldr (\a acc -> showAlt a <> line <> acc) mempty alts
+showInstr i = textt $ show i
+
+int = pretty
+
+textt :: (Pretty a) => a -> Doc ann
+textt = pretty
 
 ----------------------------------------------------------------------------------
 
@@ -975,7 +1054,8 @@ resultOf p = do
         h = st ^. gmHeap
 
 resultOfExpr :: Expr' -> Maybe Node
-resultOfExpr e = resultOf $ Program
-    [ ScDef "main" [] e
-    ]
+resultOfExpr e = resultOf $
+    mempty & programScDefs .~
+                [ ScDef "main" [] e
+                ]
 

src/Misc.hs

@@ -0,0 +1,17 @@
+module Misc where
+--------------------------------------------------------------------------------
+import Data.Functor.Classes
+--------------------------------------------------------------------------------
+
+
+showsTernaryWith :: (Int -> a -> ShowS)
+                 -> (Int -> b -> ShowS)
+                 -> (Int -> c -> ShowS)
+                 -> String -> Int -> a -> b -> c -> ShowS
+showsTernaryWith sp1 sp2 sp3 name d x y z
+    = showParen (d > 10)
+    $ showString name . showChar ' '
+    . sp1 11 x . showChar ' '
+    . sp2 11 y . showChar ' '
+    . sp3 11 z
+

src/Misc/CofreeF.hs

@@ -0,0 +1,13 @@
+{-# LANGUAGE PatternSynonyms #-}
+module Misc.CofreeF
+    ( pattern (:<$)
+    )
+    where
+--------------------------------------------------------------------------------
+import Control.Comonad.Trans.Cofree qualified as Trans.Cofree
+import Control.Comonad.Trans.Cofree (CofreeF)
+--------------------------------------------------------------------------------
+
+pattern (:<$) :: a -> f b -> Trans.Cofree.CofreeF f a b
+pattern a :<$ b = a Trans.Cofree.:< b
+

src/Misc/Lift1.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Misc.Lift1
+    ( Lift1(..), lift1
+    , liftCon, liftCon2, liftCon3
+    , Lift(..)
+    )
+    where
+--------------------------------------------------------------------------------
+import Language.Haskell.TH              hiding (Type, Name)
+import Language.Haskell.TH.Syntax       hiding (Type, Name)
+import Language.Haskell.TH.Syntax       qualified as TH
+import Language.Haskell.TH.Quote
+import Data.Kind                        qualified
+import GHC.Generics
+
+-- instances
+import Data.Fix
+import Data.Functor.Sum
+--------------------------------------------------------------------------------
+
+class Lift1 (f :: Data.Kind.Type -> Data.Kind.Type) where
+    -- lift1 :: (Quote m, Lift t) => f t -> m Exp
+    liftLift :: (Quote m) => (a -> m Exp) -> f a -> m Exp
+
+lift1 :: (Lift1 f, Lift a, Quote m) => f a -> m Exp
+lift1 = liftLift lift
+
+liftCon :: Quote m => TH.Name -> m Exp -> m Exp
+liftCon n = fmap (AppE (ConE n))
+
+liftCon2 :: Quote m => TH.Name -> m Exp -> m Exp -> m Exp
+liftCon2 n a b = do
+    a' <- a
+    b' <- b
+    pure $ ConE n `AppE` a' `AppE` b'
+
+liftCon3 :: Quote m => TH.Name -> m Exp -> m Exp -> m Exp -> m Exp
+liftCon3 n a b c = do
+    a' <- a
+    b' <- b
+    c' <- c
+    pure $ ConE n `AppE` a' `AppE` b' `AppE` c'
+
+instance Lift1 f => Lift (Fix f) where
+    lift (Fix f) = AppE (ConE 'Fix) <$> lift1 f
+
+instance Lift1 [] where
+    liftLift lf []     = pure $ ConE '[]
+    liftLift lf (a:as) = liftCon2 '(:) (lf a) (liftLift lf as)
+
+instance (Lift1 f, Lift1 g) => Lift1 (Sum f g) where
+    liftLift lf (InL fa) = liftCon 'InL $ liftLift lf fa
+    liftLift lf (InR ga) = liftCon 'InR $ liftLift lf ga
+

src/Misc/MonadicRecursionSchemes.hs

@@ -0,0 +1,14 @@
+module Misc.MonadicRecursionSchemes
+    where
+--------------------------------------------------------------------------------
+import Control.Monad
+import Data.Functor.Foldable
+--------------------------------------------------------------------------------
+
+-- | catamorphism
+cataM :: (Monad m, Traversable (Base t), Recursive t)
+      => (Base t a -> m a) -- ^ algebra
+      -> t -> m a
+cataM phi = h
+  where h = phi <=< mapM h . project
+

src/RLP/Syntax.hs

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

src/Rlp/AltParse.y

@@ -0,0 +1,243 @@
+{
+module Rlp.AltParse
+    ( parseRlpProg
+    , parseRlpProgR
+    , parseRlpExprR
+    , runP'
+    )
+    where
+import Data.List.Extra
+import Data.Text                (Text)
+
+import Control.Comonad
+import Control.Comonad.Cofree
+import Control.Lens             hiding (snoc)
+
+import Compiler.RlpcError
+import Compiler.RLPC
+import Control.Monad.Errorful
+
+import Rlp.Lex
+import Rlp.AltSyntax
+import Rlp.Parse.Types          hiding (PsName)
+import Core.Syntax              qualified as Core
+}
+
+%name parseRlpProg StandaloneProgram
+%name parseRlpExpr StandaloneExpr
+
+%monad { P }
+%lexer { lexCont } { Located _ TokenEOF }
+%error { parseError }
+%errorhandlertype explist
+%tokentype { Located RlpToken }
+
+%token
+    varname         { Located _ (TokenVarName _) }
+    conname         { Located _ (TokenConName _) }
+    consym          { Located _ (TokenConSym _) }
+    varsym          { Located _ (TokenVarSym _) }
+    data            { Located _ TokenData }
+    case            { Located _ TokenCase }
+    of              { Located _ TokenOf }
+    litint          { Located _ (TokenLitInt _) }
+    '='             { Located _ TokenEquals }
+    '|'             { Located _ TokenPipe }
+    '::'            { Located _ TokenHasType }
+    ';'             { Located _ TokenSemicolon }
+    'λ'             { Located _ TokenLambda }
+    '('             { 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 }
+    let             { Located _ TokenLet }
+    letrec          { Located _ TokenLetrec }
+    in              { Located _ TokenIn }
+    forall          { Located _ TokenForall }
+
+%nonassoc '='
+%right '->'
+%right in
+
+%%
+
+StandaloneProgram :: { Program Name (RlpExpr PsName) }
+                  : layout0(Decl)       { Program $1 }
+
+
+StandaloneExpr :: { RlpExpr PsName }
+               : VL Expr VR             { $2 }
+
+VL  :: { () }
+VL  : vlbrace       { () }
+
+VR  :: { () }
+VR  : vrbrace       { () }
+    | error         { () }
+
+VS                  :: { () }
+VS                  : ';'                   { () }
+                    | vsemi                 { () }
+
+Decl                :: { Decl PsName (RlpExpr PsName) }
+                    : FunD                  { $1 }
+                    | DataD                 { $1 }
+                    | TySigD                { $1 }
+
+TySigD              :: { Decl PsName (RlpExpr PsName) }
+                    : Var '::' Type         { TySigD $1 $3 }
+
+DataD               :: { Decl PsName (RlpExpr PsName) }
+                    : data Con TyVars               { DataD $2 $3 [] }
+                    | data Con TyVars '=' DataCons  { DataD $2 $3 $5 }
+
+DataCons            :: { [DataCon PsName] }
+                    : DataCon '|' DataCons  { $1 : $3 }
+                    | DataCon               { [$1] }
+
+DataCon             :: { DataCon PsName }
+                    : Con list0(Type1)      { DataCon $1 $2 }
+
+Type1               :: { Type PsName }
+                    : varname               { VarT $ extractVarName $1 }
+                    | Con                   { ConT $1 }
+                    | '(' Type ')'          { $2 }
+
+Type                :: { Type PsName }
+                    : Type '->' Type        { $1 :-> $3 }
+                    | AppT                  { $1 }
+
+AppT                :: { Type PsName }
+                    : Type1                 { $1 }
+                    | AppT Type1            { AppT $1 $2 }
+
+TyVars              :: { [PsName] }
+                    : list0(varname)     { $1 <&> view ( to extract
+                                                       . singular _TokenVarName ) }
+
+FunD                :: { Decl PsName (RlpExpr PsName) }
+                    : Var Pat1s '=' Expr    { FunD $1 $2 $4 }
+
+Expr                :: { RlpExpr PsName }
+                    : AppE                  { $1 }
+                    | LetE                  { $1 }
+                    | CaseE                 { $1 }
+                    | LamE                  { $1 }
+
+LamE                :: { RlpExpr PsName }
+                    : 'λ' list0(varname) '->' Expr { Finl $ Core.LamF (fmap extractName $2) $4 }
+
+CaseE               :: { RlpExpr PsName }
+                    : case Expr of CaseAlts { Finr $ CaseEF $2 $4 }
+
+CaseAlts            :: { [Alter PsName (RlpExpr PsName)] }
+                    : layout1(CaseAlt)      { $1 }
+
+CaseAlt             :: { Alter PsName (RlpExpr PsName) }
+                    : Pat '->' Expr    { Alter $1 $3 }
+
+LetE                :: { RlpExpr PsName }
+                    : let layout1(Binding) in Expr
+                        { Finr $ LetEF Core.NonRec $2 $4 }
+                    | letrec layout1(Binding) in Expr
+                        { Finr $ LetEF Core.Rec $2 $4 }
+
+Binding             :: { Binding PsName (RlpExpr PsName) }
+                    : Pat '=' Expr          { VarB $1 $3 }
+
+Expr1               :: { RlpExpr PsName }
+                    : VarE                  { $1 }
+                    | litint                { $1 ^. to extract
+                                                  . singular _TokenLitInt
+                                                  . to (Finl . Core.LitF . Core.IntL) }
+                    | '(' Expr ')'          { $2 }
+                    | ConE                  { $1 }
+
+AppE                :: { RlpExpr PsName }
+                    : AppE Expr1            { Finl $ Core.AppF $1 $2 }
+                    | Expr1                 { $1 }
+
+VarE                :: { RlpExpr PsName }
+                    : Var                   { Finl $ Core.VarF $1 }
+
+ConE                :: { RlpExpr PsName }
+                    : Con                   { Finl $ Core.VarF $1 }
+
+Pat1s               :: { [Pat PsName] }
+                    : list0(Pat1)           { $1 }
+
+Pat1                :: { Pat PsName }
+                    : Var                   { VarP $1 }
+                    | Con                   { ConP $1 }
+                    | '(' Pat ')'           { $2 }
+
+Pat                 :: { Pat PsName }
+                    : AppP                  { $1 }
+
+AppP                :: { Pat PsName }
+                    : Pat1                  { $1 }
+                    | AppP Pat1             { $1 `AppP` $2 }
+
+Con                 :: { PsName }
+                    : conname               { $1 ^. to extract
+                                                  . singular _TokenConName }
+                    | '(' consym ')'        { $1 ^. to extract
+                                                  . singular _TokenConSym }
+
+Var                 :: { PsName }
+                    : varname               { $1 ^. to extract
+                                                  . singular _TokenVarName }
+                    | '(' varsym ')'        { $2 ^. to extract
+                                                  . singular _TokenVarSym }
+
+-- list0(p : α) : [α]
+list0(p) : {- epsilon -}            { [] }
+         | list0(p) p             { $1 `snoc` $2 }
+
+-- layout0(p : β) :: [β]
+layout0(p)  : '{' '}'                   { [] }
+            | VL  VR                    { [] }
+            | layout1(p)                { $1 }
+
+-- layout_list0(sep : α, p : β) :: [β]
+layout_list0(sep,p) : p                          { [$1] }
+                    | layout_list1(sep,p) sep p  { $1 `snoc` $3 }
+                    | {- epsilon -}              { [] }
+
+-- layout1(p : β) :: [β]
+layout1(p)  : '{' layout_list1(';',p) '}'   { $2 }
+            | VL  layout_list1(VS,p) VS VR  { $2 }
+            | VL  layout_list1(VS,p) VR     { $2 }
+
+-- layout_list1(sep : α, p : β) :: [β]
+layout_list1(sep,p) : p                          { [$1] }
+                    | layout_list1(sep,p) sep p  { $1 `snoc` $3 }
+
+{
+
+extractVarName = view $ to extract . singular _TokenVarName
+
+parseRlpProgR :: (Monad m) => Text -> RLPCT m (Program Name (RlpExpr PsName))
+parseRlpProgR s = liftErrorful $ errorful (ma,es)
+    where
+        (_,es,ma) = runP' parseRlpProg s
+
+parseRlpExprR :: (Monad m) => Text -> RLPCT m (RlpExpr PsName)
+parseRlpExprR s = liftErrorful $ errorful (ma,es)
+    where
+        (_,es,ma) = runP' parseRlpExpr s
+
+parseError :: (Located RlpToken, [String]) -> P a
+parseError (Located ss t,ts) = addFatalHere (ss ^. srcSpanLen) $
+    RlpParErrUnexpectedToken t ts
+
+extractName = view $ to extract . singular _TokenVarName
+
+}

src/Rlp/AltSyntax.hs

@@ -0,0 +1,326 @@
+{-# LANGUAGE TemplateHaskell, PatternSynonyms #-}
+module Rlp.AltSyntax
+    (
+    -- * AST
+      Program(..), Decl(..), ExprF(..), Pat(..), pattern ConP'
+    , RlpExprF, RlpExpr, Binding(..), Alter(..)
+    , RlpExpr', RlpExprF', AnnotatedRlpExpr', Type'
+    , DataCon(..), Type(..), Kind
+    , pattern IntT, pattern TypeT
+    , Core.Rec(..)
+
+    , TypedRlpExpr'
+    , AnnotatedRlpExpr, TypedRlpExpr
+    , TypeF(..)
+
+    , Core.Name, PsName
+    , pattern (Core.:->)
+
+    -- * Optics
+    , programDecls
+    , _VarP, _FunB, _VarB
+    , _TySigD, _FunD, _DataD
+    , _LetEF
+    , Core.applicants1, Core.arrowStops
+
+    -- * Functor-related tools
+    , Fix(..), Cofree(..), Sum(..), pattern Finl, pattern Finr
+
+    -- * Misc
+    , serialiseCofree
+    , fixCofree
+    )
+    where
+--------------------------------------------------------------------------------
+import Data.Functor.Sum
+import Control.Comonad.Cofree
+import Data.Fix                 hiding (cata)
+import Data.Functor.Foldable
+import Data.Function            (fix)
+import GHC.Generics             ( Generic, Generic1
+                                , Generically(..), Generically1(..))
+import Data.Hashable
+import Data.Hashable.Lifted
+import GHC.Exts                 (IsString)
+import Control.Lens             hiding ((.=), (:<))
+
+import Data.Functor.Extend
+import Data.Functor.Foldable.TH
+import Text.Show.Deriving
+import Data.Eq.Deriving
+import Data.Text                qualified as T
+import Data.Aeson
+import Data.Pretty
+import Misc.Lift1
+
+import Compiler.Types
+import Core.Syntax              qualified as Core
+--------------------------------------------------------------------------------
+
+type RlpExpr' = RlpExpr PsName
+type RlpExprF' = RlpExprF PsName
+type AnnotatedRlpExpr' = Cofree (RlpExprF PsName)
+type TypedRlpExpr' = TypedRlpExpr PsName
+type Type' = Type PsName
+
+type AnnotatedRlpExpr b = Cofree (RlpExprF b)
+
+type TypedRlpExpr b = Cofree (RlpExprF b) (Type b)
+
+type PsName = T.Text
+
+newtype Program b a = Program [Decl b a]
+    deriving (Show, Functor, Foldable, Traversable)
+
+instance Extend (Decl b) where
+    extended c w@(FunD n as a) = FunD n as (c w)
+    extended _ (DataD n as cs) = DataD n as cs
+    extended _ (TySigD n t)    = TySigD n t
+
+programDecls :: Iso (Program b a) (Program b' a') [Decl b a] [Decl b' a']
+programDecls = iso sa bt where
+    sa (Program ds) = ds
+    bt = Program
+
+data Decl b a = FunD b [Pat b] a
+              | DataD Core.Name [Core.Name] [DataCon b]
+              | TySigD Core.Name (Type b)
+              deriving (Show, Functor, Foldable, Traversable)
+
+data DataCon b = DataCon Core.Name [Type b]
+    deriving (Show, Generic)
+
+data Type b = VarT Core.Name
+            | ConT Core.Name
+            | AppT (Type b) (Type b)
+            | FunT
+            | ForallT b (Type b)
+            deriving (Show, Eq, Generic, Functor, Foldable, Traversable)
+
+instance Core.HasApplicants1 (Type b) (Type b) (Type b) (Type b) where
+    applicants1 k (AppT f x) = AppT <$> Core.applicants1 k f <*> k x
+    applicants1 k t          = k t
+
+instance (Hashable b) => Hashable (Type b)
+
+pattern IntT :: (IsString b, Eq b) => Type b
+pattern IntT = ConT "Int#"
+
+type Kind = Type
+
+pattern TypeT :: (IsString b, Eq b) => Type b
+pattern TypeT = ConT "Type"
+
+instance Core.HasArrowSyntax (Type b) (Type b) (Type b) where
+    _arrowSyntax = prism make unmake where
+        make (s,t) = FunT `AppT` s `AppT` t
+
+        unmake (FunT `AppT` s `AppT` t) = Right (s,t)
+        unmake s                        = Left s
+
+data ExprF b a = InfixEF b a a
+               | LetEF Core.Rec [Binding b a] a
+               | CaseEF a [Alter b a]
+               deriving (Functor, Foldable, Traversable)
+               deriving (Eq, Generic, Generic1)
+
+data Alter b a = Alter (Pat b) a
+               deriving (Show, Functor, Foldable, Traversable)
+               deriving (Eq, Generic, Generic1)
+
+data Binding b a = FunB b [Pat b] a
+                 | VarB (Pat b) a
+                 deriving (Show, Functor, Foldable, Traversable)
+                 deriving (Eq, Generic, Generic1)
+
+-- type Expr b = Cofree (ExprF b)
+
+type RlpExprF b = Sum (Core.ExprF b) (ExprF b)
+
+type RlpExpr b = Fix (RlpExprF b)
+
+data Pat b = VarP b
+           | ConP b
+           | AppP (Pat b) (Pat b)
+           deriving (Eq, Show, Generic, Generic1)
+
+conList :: Prism' (Pat b) (b, [Pat b])
+conList = prism' up down where
+    up (b,as)               = foldl AppP (ConP b) as
+    down (ConP b)           = Just (b, [])
+    down (AppP (ConP b) as) = Just (b, go as)
+    down _                  = Nothing
+
+    go (AppP f x) = f : go x
+    go p          = [p]
+
+pattern ConP' :: b -> [Pat b] -> Pat b
+pattern ConP' c as <- (preview conList -> Just (c,as))
+    where ConP' c as = review conList (c,as)
+
+deriveShow1 ''Alter
+deriveShow1 ''Binding
+deriveShow1 ''ExprF
+deriving instance (Show b, Show a) => Show (ExprF b a)
+
+pattern Finl :: f (Fix (Sum f g)) -> Fix (Sum f g)
+pattern Finl fa = Fix (InL fa)
+
+pattern Finr :: g (Fix (Sum f g)) -> Fix (Sum f g)
+pattern Finr ga = Fix (InR ga)
+
+--------------------------------------------------------------------------------
+
+instance (Out b, Out a) => Out (ExprF b a) where
+    outPrec = outPrec1
+
+instance (Out b, Out a) => Out (Alter b a) where
+    outPrec = outPrec1
+
+instance (Out b) => Out1 (Alter b) where
+    liftOutPrec pr _ (Alter p e) =
+        hsep [ out p, "->", pr 0 e]
+
+instance Out b => Out1 (ExprF b) where
+    liftOutPrec pr p (InfixEF o a b) = maybeParens (p>0) $
+        pr 1 a <+> out o <+> pr 1 b
+    liftOutPrec pr p (CaseEF e as) = maybeParens (p>0) $
+        vsep [ hsep [ "case", pr 0 e, "of" ]
+             , nest 2 (vcat $ liftOutPrec pr 0 <$> as) ]
+    liftOutPrec pr p (LetEF r bs e) = maybeParens (p>0) $
+        vsep [ hsep [ letword r, "<bs>" ]
+             , nest 2 (hsep [ "in", pr 0 e ]) ]
+      where
+        letword Core.Rec = "letrec"
+        letword Core.NonRec = "let"
+
+instance (Out b, Out a) => Out (Decl b a) where
+    outPrec = outPrec1
+
+instance (Out b) => Out1 (Decl b) where
+    liftOutPrec pr _ (FunD f as e) =
+        hsep [ ttext f, hsep (outPrec appPrec1 <$> as)
+             , "=", pr 0 e ]
+
+    liftOutPrec _ _ (DataD f as []) =
+        hsep [ "data", ttext f, hsep (out <$> as) ]
+
+    liftOutPrec _ _ (DataD f as ds) =
+        hsep [ "data", ttext f, hsep (out <$> as), cons ]
+      where
+        cons = vcat $ zipWith (<+>) delims (out <$> ds)
+        delims = "=" : repeat "|"
+
+    liftOutPrec _ _ (TySigD n t) =
+        hsep [ ttext n, ":", out t ]
+
+instance (Out b) => Out (DataCon b) where
+    out (DataCon n as) = ttext n <+> hsep (outPrec appPrec1 <$> as)
+
+collapseForalls :: Prism' (Type b) ([b], Type b)
+collapseForalls = prism' up down where
+    up (bs,m) = foldr ForallT m bs
+    down (ForallT x m) = case down m of
+        Just (xs,m') -> Just (x : xs, m')
+        Nothing      -> Just ([x],m)
+    down _ = Nothing
+
+-- (->) is given prec `appPrec-1`
+instance (Out b) => Out (Type b) where
+    outPrec _ (VarT n) = ttext n
+    outPrec _ (ConT n) = ttext n
+    outPrec p (s Core.:-> t) = maybeParens (p>arrPrec) $
+        hsep [ outPrec arrPrec1 s, "->", outPrec arrPrec t ]
+      where arrPrec = appPrec-1
+            arrPrec1 = appPrec
+    outPrec p (AppT f x) = maybeParens (p>appPrec) $
+        outPrec appPrec f <+> outPrec appPrec1 x
+    outPrec p FunT = maybeParens (p>0) "->"
+    outPrec p t@(ForallT _ _) = maybeParens (p>0) $
+        t ^. singular collapseForalls & \(bs,m) ->
+            let bs' = "∀" <> (hsep $ outPrec appPrec1 <$> bs) <> "."
+            in bs' <+> outPrec 0 m
+
+instance (Out b) => Out (Pat b) where
+    outPrec p (VarP b) = outPrec p b
+    outPrec p (ConP b) = outPrec p b
+    outPrec p (AppP c x) = maybeParens (p>appPrec) $
+        outPrec appPrec c <+> outPrec appPrec1 x
+
+instance (Out a, Out b) => Out (Program b a) where
+    outPrec = outPrec1
+
+instance (Out b) => Out1 (Program b) where
+    liftOutPrec pr p (Program ds) = vsep $ liftOutPrec pr p <$> ds
+
+makePrisms ''ExprF
+makePrisms ''Pat
+makePrisms ''Binding
+makePrisms ''Decl
+
+deriving instance (Lift b, Lift a) => Lift (Program b a)
+deriving instance (Lift b, Lift a) => Lift (Decl b a)
+deriving instance (Lift b) => Lift (Pat b)
+deriving instance (Lift b) => Lift (DataCon b)
+deriving instance (Lift b) => Lift (Type b)
+
+instance Lift b => Lift1 (Binding b) where
+    liftLift lf (VarB b a) = liftCon2 'VarB (lift b) (lf a)
+
+instance Lift b => Lift1 (Alter b) where
+    liftLift lf (Alter b a) = liftCon2 'Alter (lift b) (lf a)
+
+instance Lift b => Lift1 (ExprF b) where
+    liftLift lf (InfixEF o a b) =
+        liftCon3 'InfixEF (lift o) (lf a) (lf b)
+    liftLift lf (LetEF r bs e) =
+        liftCon3 'LetEF (lift r) bs' (lf e)
+      where bs' = liftLift (liftLift lf) bs
+    liftLift lf (CaseEF e as) =
+        liftCon2 'CaseEF (lf e) as'
+      where as' = liftLift (liftLift lf) as
+
+deriveEq1 ''Binding
+deriveEq1 ''Alter
+deriveEq1 ''ExprF
+
+instance (Hashable b) => Hashable (Pat b)
+instance (Hashable b, Hashable a) => Hashable (Binding b a)
+instance (Hashable b, Hashable a) => Hashable (Alter b a)
+instance (Hashable b, Hashable a) => Hashable (ExprF b a)
+instance (Hashable b) => Hashable1 (Alter b)
+instance (Hashable b) => Hashable1 (Binding b)
+instance (Hashable b) => Hashable1 (ExprF b)
+
+makeBaseFunctor ''Type
+
+instance Core.HasArrowStops (Type b) (Type b) (Type b) (Type b) where
+    arrowStops k (s Core.:-> t) = (Core.:->) <$> k s <*> Core.arrowStops k t
+    arrowStops k t         = k t
+
+deriving via (Generically1 Pat)
+    instance ToJSON1 Pat
+deriving via (Generically (Pat b))
+    instance ToJSON b => ToJSON (Pat b)
+deriving via (Generically1 (Alter b))
+    instance ToJSON b => ToJSON1 (Alter b)
+deriving via (Generically1 (Binding b))
+    instance ToJSON b => ToJSON1 (Binding b)
+deriving via (Generically1 (ExprF b))
+    instance ToJSON b => ToJSON1 (ExprF b)
+deriving via (Generically1 (RlpExprF b))
+    instance ToJSON b => ToJSON1 (RlpExprF b)
+
+serialiseCofree :: (Functor f, ToJSON1 f, ToJSON a) => Cofree f a -> Value
+serialiseCofree = cata \case
+    ann :<$ e -> object [ "ann" .= ann
+                        , "val" .= toJSON1 e ]
+
+--------------------------------------------------------------------------------
+
+fixCofree :: (Functor f, Functor g)
+          => Iso (Fix f) (Fix g) (Cofree f ()) (Cofree g b)
+fixCofree = iso sa bt where
+    sa = foldFix (() :<)
+    bt (_ :< f) = Fix (bt <$> f)
+

src/Rlp/HindleyMilner.hs

@@ -0,0 +1,373 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Rlp.HindleyMilner
+    ( typeCheckRlpProgR
+    , TypeError(..)
+    , renamePrettily
+    )
+    where
+--------------------------------------------------------------------------------
+import Control.Lens             hiding (Context', Context, (:<), para, uncons)
+import Control.Lens.Unsound
+import Control.Lens.Extras
+import Control.Monad.Errorful
+import Control.Monad.State
+import Control.Monad.Accum
+import Control.Monad.Reader
+import Control.Monad
+import Control.Monad.Extra
+import Control.Monad.Free
+import Control.Arrow            ((>>>))
+import Control.Monad.Writer.Strict
+
+import Data.List
+import Data.Monoid
+import Data.Text                qualified as T
+import Data.Foldable            (fold)
+import Data.Function
+import Data.Foldable
+import Data.Pretty              hiding (annotate)
+import Data.Maybe
+import Data.Hashable
+import Data.HashMap.Strict      (HashMap)
+import Data.HashMap.Strict      qualified as H
+import Data.HashSet             (HashSet)
+import Data.HashSet.Lens
+import Data.HashSet             qualified as S
+import Data.Maybe               (fromMaybe)
+import Data.Traversable
+import GHC.Generics             (Generic, Generically(..))
+import Debug.Trace
+
+import Data.Functor             hiding (unzip)
+import Data.Functor.Extend
+import Data.Functor.Foldable    hiding (fold)
+import Data.Fix                 hiding (cata, para, cataM, ana)
+import Control.Comonad.Cofree
+import Control.Comonad
+
+import Effectful
+
+import Compiler.RLPC
+import Compiler.RlpcError
+import Rlp.AltSyntax            as Rlp
+import Core.Syntax              qualified as Core
+import Core.Syntax              (ExprF(..), Lit(..))
+import Rlp.HindleyMilner.Types
+--------------------------------------------------------------------------------
+
+-- | Annotate a structure with the result of a catamorphism at each level.
+--
+--   Pretentious etymology: 'dendr-' means 'tree'
+
+dendroscribe :: (Functor f, Base t ~ f, Recursive t)
+           => (f (Cofree f a) -> a) -> t -> Cofree f a
+dendroscribe c (project -> f) = c f' :< f'
+    where f' = dendroscribe c <$> f
+
+dendroscribeM :: (Traversable f, Monad m, Base t ~ f, Recursive t)
+            => (f (Cofree f a) -> m a) -> t -> m (Cofree f a)
+dendroscribeM c (project -> f) = do
+    as <- dendroscribeM c `traverse` f
+    a <- c as
+    pure (a :< as)
+
+--------------------------------------------------------------------------------
+
+assume :: Name -> Type' -> Judgement
+assume n t = mempty & assumptions .~ H.singleton n [t]
+
+equal :: Type' -> Type' -> Judgement
+equal a b = mempty & constraints .~ [Equality a b]
+
+elim :: Name -> Type' -> Judgement -> Judgement
+elim n t j = j & assumptions %~ H.delete n
+               & constraints <>~ cs
+    where
+        cs = j & foldMapOf (assumptions . at n . each . each) \t' ->
+            [Equality t t']
+
+elimGenerally :: Name -> Type' -> Judgement -> Judgement
+elimGenerally n t j = j & assumptions %~ H.delete n
+                        & constraints <>~ cs
+    where
+        cs = j & foldMapOf (assumptions . at n . each . each) \t' ->
+            [ImplicitInstance mempty t' t]
+
+monomorphise :: Type' -> Judgement -> Judgement
+monomorphise n = constraints . each . _ImplicitInstance . _1 %~ S.insert n
+
+withoutPatterns :: [Binding b a] -> [(b, a)]
+withoutPatterns bs = bs ^.. each . singular _VarB
+                          & each . _1 %~ view (singular _VarP)
+
+--------------------------------------------------------------------------------
+
+gather :: (Unique :> es)
+       => RlpExprF' (Type', Judgement) -> Eff es (Type', Judgement)
+gather (InL (LitF (IntL _))) = pure (IntT, mempty)
+
+gather (InL (VarF n)) = do
+    t <- freshTv
+    pure (t, assume n t)
+
+gather (InL (AppF (tf,jf) (tx,jx))) = do
+    tfx <- freshTv
+    pure (tfx, jf <> jx <> equal tf (tx :-> tfx))
+
+gather (InL (LamF xs (te,je))) = do
+    bs <- for xs (\x -> (x,) <$> freshTv)
+    let j = je & forBinds elim bs
+               & forBinds (const monomorphise) bs
+        t = foldr (:->) te (bs ^.. each . _2)
+    pure (t, j)
+  where
+    elimBind (x,tx) j1 = elim x tx j1
+
+gather (InR (LetEF NonRec (withoutPatterns -> bs) (te,je))) = do
+    let j = foldr elimBind je bs
+    pure (te, j)
+  where
+    elimBind (x,(tx,jx)) j1 = elimGenerally x tx (jx <> j1)
+
+gather (InR (LetEF Rec (withoutPatterns -> bs) (te,je))) = do
+    let j = foldOf (each . _2 . _2) bs
+        j' = foldr elimRecBind j bs
+    pure (te, j' <> foldr elimBind je bs)
+  where
+    elimRecBind (x,(tx,_)) j = elim x tx j
+    elimBind (x,(tx,_)) j = elimGenerally x tx j
+
+gather (InR (CaseEF (te,je) as)) = do
+    as' <- gatherAlter te `traverse` as
+    t <- freshTv
+    let eqs = allEqual (t : (as' ^.. each . _1))
+        j = je <> foldOf (each . _2) as' <> eqs
+    pure (t,j)
+
+gatherAlter :: (Unique :> es)
+            => Type'
+            -> Alter PsName (Type', Judgement)
+            -> Eff es (Type', Judgement)
+gatherAlter te (Alter (ConP' n bs) (ta,ja)) = do
+    -- let tc' be the type of the saturated type constructor
+    tc' <- freshTv
+    bs' <- for bs (\b -> (b ^. singular _VarP,) <$> freshTv)
+    let tbs = bs' ^.. each . _2
+        tc = foldr (:->) tc' tbs
+        j = equal te tc' <> assume n tc <> forBinds elim bs' ja
+    pure (ta,j)
+
+allEqual :: [Type'] -> Judgement
+allEqual = fold . ana @[_] \case
+    [] -> Nil
+    [a] -> Nil
+    (a:b:xs) -> Cons (equal a b) (b:xs)
+
+forBinds :: (PsName -> Type' -> Judgement -> Judgement)
+         -> [(PsName, Type')] -> Judgement -> Judgement
+forBinds f bs j = foldr (uncurry f) j bs
+
+unify :: (Unique :> es)
+      => [Constraint] -> ErrorfulT TypeError (Eff es) Subst
+unify [] = pure id
+unify (c:cs) = case c of
+
+    Equality (ConT a) (ConT b)
+        | a == b
+        -> unify cs
+
+    Equality (VarT a) (VarT b)
+        | a == b
+        -> unify cs
+
+    Equality (VarT a) t
+        | a `occurs` t
+        -> error "recursive type"
+        | otherwise
+        -> unify (subst a t <$> cs) <&> (. subst a t)
+
+    Equality t (VarT a)
+        -> unify (Equality (VarT a) t : cs)
+
+    Equality (s :-> t) (s' :-> t')
+        -> unify (Equality s s' : Equality t t' : cs)
+
+    Equality (AppT s t) (AppT s' t')
+        -> unify (Equality s s' : Equality t t' : cs)
+
+    ImplicitInstance m s t
+        | null $ (freeTvs t `S.difference` freeTvs m)
+                    `S.intersection` activeTvs cs
+        -> unify $ ExplicitInstance s (generalise (freeTvs m) t) : cs
+
+    ExplicitInstance s t -> do
+        t' <- lift $ instantiate t
+        unify $ Equality s t' : cs
+
+    Equality a b
+        -> addFatal $ TyErrCouldNotUnify a b
+
+    _ -> error $ "explode (typecheckr explsiong): " <> show c
+
+activeTvs :: [Constraint] -> HashSet Name
+activeTvs = foldMap \case
+    Equality s t           -> freeTvs s <> freeTvs t
+    ImplicitInstance m s t -> freeTvs s <> (freeTvs m `S.intersection` freeTvs t)
+    ExplicitInstance s t   -> freeTvs s <> freeTvs t
+
+instantiate :: (Unique :> es) => Scheme -> Eff es Type'
+instantiate (ForallT x t) = do
+    x' <- freshTv
+    subst x x' <$> instantiate t
+instantiate t = pure t
+
+generalise :: HashSet Name -> Type' -> Scheme
+generalise m t = foldr ForallT t as
+    where as = S.toList $ freeTvs t `S.difference` m
+
+occurs :: (HasTypes a) => Name -> a -> Bool
+occurs x t = x `elem` freeTvs t
+
+elimGlobalBinds :: [(Name, Scheme)] -> Cofree RlpExprF' (Type', Judgement)
+                -> Cofree RlpExprF' (Type', Judgement)
+elimGlobalBinds bs = traversed . _2 %~ forBinds f bs where
+    f n t@(ForallT _ _) = elimGenerally n t
+    f n t               = elim n t
+
+--------------------------------------------------------------------------------
+
+annotate :: (Unique :> es)
+         => RlpExpr' -> Eff es (Cofree RlpExprF' (Type', Judgement))
+annotate = fmap (elimGlobalBinds [ ("Just", ForallT "a" $ VarT "a" :-> ConT "Maybe" `AppT` VarT "a")
+                                 , ("isJust", ForallT "a" $ ConT "Maybe" `AppT` VarT "a" :-> ConT "Bool")])
+         . dendroscribeM (gather . fmap extract)
+
+orderConstraints :: [Constraint] -> [Constraint]
+orderConstraints cs = a <> b
+    where (a,b) = partition (isn't _ImplicitInstance) cs
+
+finalJudgement :: Cofree RlpExprF' (Type', Judgement) -> Judgement
+finalJudgement = snd . extract
+
+solveTree :: (Unique :> es)
+          => Cofree RlpExprF' (Type', Judgement)
+          -> ErrorfulT TypeError (Eff es) (Cofree RlpExprF' Type')
+solveTree e = do
+    sub <- unify (orderConstraints $ finalJudgement e ^. constraints . reversed)
+    pure $ sub . view _1 <$> e
+
+solveJudgement :: (Unique :> es)
+               => Judgement
+               -> ErrorfulT TypeError (Eff es) Subst
+solveJudgement j = unify (orderConstraints $ j ^. constraints . reversed)
+
+typeCheckRlpProgR :: Monad m
+                  => Program PsName RlpExpr'
+                  -> RLPCT m (Program PsName (Cofree RlpExprF' Type'))
+typeCheckRlpProgR
+    = liftErrorful
+    . hoistErrorfulT (pure . runPureEff . runUnique)
+    . mapErrorful (errorMsg (SrcSpan 0 0 0 0))
+    . inferProg
+
+finallyGeneralise :: Cofree RlpExprF' Type' -> Cofree RlpExprF' Type'
+finallyGeneralise = _extract %~ generalise mempty
+
+inferProg :: (Unique :> es)
+          => Program PsName RlpExpr'
+          -> ErrorfulT TypeError (Eff es)
+              (Program PsName (Cofree RlpExprF' Type'))
+inferProg p = do
+    p' <- lift $ annotateProg (etaExpandProg p)
+    sub <- solveJudgement (foldOf (folded . _extract . _2) p')
+    pure $ p' & traversed . traversed %~ sub . view _1
+              & traversed %~ finallyGeneralise
+
+etaExpandProg :: Program PsName RlpExpr' -> Program PsName RlpExpr'
+etaExpandProg = programDecls . each %~ etaExpand where
+    etaExpand (FunD n [] e) = FunD n [] e
+    etaExpand (FunD n as e) = FunD n [] $ Finl (LamF as' e)
+        where as' = as ^.. each . singular _VarP
+    etaExpand x = x
+
+infer :: (Unique :> es)
+      => RlpExpr'
+      -> ErrorfulT TypeError (Eff es)
+            (Cofree RlpExprF' Type')
+infer e = do
+    e' <- solveTree <=< (lift . annotate) $ e
+    pure $ finallyGeneralise e'
+
+annotateDefs :: (Unique :> es)
+             => Program PsName RlpExpr'
+             -> Eff es (Program PsName
+                         (Cofree RlpExprF' (Type', Judgement)))
+annotateDefs = traverseOf (programDefs . _2) annotate
+
+extractDefs :: Program PsName (Cofree RlpExprF' (Type', Judgement))
+            -> [(Name, Type')]
+extractDefs p = p ^.. programDefs & each . _2 %~ fst . extract
+
+extractCons :: Program PsName (Cofree RlpExprF' (Type', Judgement))
+            -> [(Name, Type')]
+extractCons = foldMapOf (programDecls . each . _DataD) \(n,as,cs) ->
+    let root = foldl AppT (ConT n) (VarT <$> as)
+    in cs & fmap \ (DataCon cn cas) -> (cn, foldr (:->) root cas)
+
+annotateProg :: (Unique :> es)
+             => Program PsName RlpExpr'
+             -> Eff es (Program PsName
+                         (Cofree RlpExprF' (Type', Judgement)))
+annotateProg p = do
+    p' <- annotateDefs p
+    let bs = extractCons p' ++ extractDefs p'
+        p'' = p' & programDefs . _2 . traversed . _2
+            %~ forBinds elimGenerally bs
+    pure p''
+
+programDefs :: Traversal (Program b a) (Program b a') (b, a) (b, a')
+programDefs k (Program ds) = Program <$> traverse go ds where
+    go (FunD n as e) = refun as (k (n,e))
+    go (DataD n as cs) = pure $ DataD n as cs
+    go (TySigD n ts) = pure $ TySigD n ts
+    refun as kne = uncurry (\a b -> FunD a as b) <$> kne
+
+--------------------------------------------------------------------------------
+
+renamePrettily' :: Type PsName -> Type PsName
+renamePrettily' = join renamePrettily
+
+-- | for some type, compute a substitution which will rename all free variables
+-- for aesthetic purposes
+
+renamePrettily :: Type PsName -> Type PsName -> Type PsName
+renamePrettily root = (`evalState` alphabetNames) . (renameFree <=< renameBound)
+  where
+    renameBound :: Type PsName -> State [PsName] (Type PsName)
+    renameBound = cata \case
+        ForallTF x m -> do
+            n <- getName
+            ForallT n <$> (subst x (VarT n) <$> m)
+        t -> embed <$> sequenceA t
+
+    renameFree :: Type PsName -> State [PsName] (Type PsName)
+    renameFree t = do
+        subs <- forM (freeVariablesLTR root) $ \v -> do
+            n <- getName
+            pure $ Endo (subst v (VarT n))
+        pure . appEndo (fold subs) $ t
+
+    getName :: State [PsName] PsName
+    getName = state (fromJust . uncons)
+
+alphabetNames :: [PsName]
+alphabetNames = alphabet ++ concatMap appendAlphabet alphabetNames
+    where alphabet = [ T.pack [c] | c <- ['a'..'z'] ]
+          appendAlphabet c = [ c <> c' | c' <- alphabet ]
+
+freeVariablesLTR :: Type PsName -> [PsName]
+freeVariablesLTR = nub . cata \case
+    VarTF x -> [x]
+    ForallTF x m -> m \\ [x]
+    vs -> concat vs
+

src/Rlp/HindleyMilner/Types.hs

@@ -0,0 +1,175 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Rlp.HindleyMilner.Types
+    where
+--------------------------------------------------------------------------------
+import Data.Hashable
+import Data.HashMap.Strict      (HashMap)
+import Data.HashMap.Strict      qualified as H
+import Data.HashSet             (HashSet)
+import Data.HashSet             qualified as S
+import GHC.Generics             (Generic(..), Generically(..))
+import Data.Kind                qualified
+import Data.Text                qualified as T
+import Effectful.State.Static.Local
+import Effectful.Labeled
+import Effectful
+import Text.Printf
+import Data.Pretty
+import Data.Function
+
+import Control.Lens             hiding (Context', Context, para)
+
+import Data.Functor.Foldable    hiding (fold)
+import Data.Foldable
+
+import Compiler.RlpcError
+import Rlp.AltSyntax
+--------------------------------------------------------------------------------
+
+-- | A polymorphic type
+
+type Scheme = Type'
+
+type Subst = Type' -> Type'
+
+data Constraint = Equality Type' Type'
+                | ImplicitInstance (HashSet Type') Type' Type'
+                | ExplicitInstance Type' Scheme
+                deriving Show
+
+instance Out Constraint where
+    out (Equality s t) =
+        hsep [outPrec appPrec1 s, "~", outPrec appPrec1 t]
+
+--------------------------------------------------------------------------------
+
+-- | 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
+    | TyErrNonHomogenousCaseAlternatives (RlpExpr PsName)
+    deriving (Show)
+
+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`."
+                              (rout @String t) (rout @String u)
+            , "Expected: " <> rout t
+            , "Got: " <> rout u
+            ]
+        TyErrUntypedVariable n -> Text
+            [ "Untyped (likely undefined) variable `" <> n <> "`"
+            ]
+        TyErrRecursiveType t x -> Text
+            [ T.pack $ printf "Recursive type: `%s' occurs in `%s'"
+                              (rout @String t) (rout @String x)
+            ]
+
+--------------------------------------------------------------------------------
+
+type Unique = State Int
+
+runUnique :: Eff (Unique : es) a -> Eff es a
+runUnique = evalState 0
+
+freshTv :: (Unique :> es) => Eff es (Type PsName)
+freshTv = do
+    n <- get
+    modify @Int succ
+    pure (VarT $ tvNameOfInt n)
+
+tvNameOfInt :: Int -> PsName
+tvNameOfInt n = "$a" <> T.pack (show n)
+
+--------------------------------------------------------------------------------
+
+-- | A 'Judgement' is a sort of "co-context" used in bottom-up inference. The
+--   typical algorithms J, W, and siblings pass some context Γ to the inference
+--   algorithm which is used to lookup variables and such. Here in rlpc we
+--   infer a type under zero context; inference returns the assumptions made of
+--   a variable which may be later eliminated and solved.
+
+data Judgement = Judgement
+    { _constraints :: [Constraint]
+    , _assumptions :: Assumptions
+    }
+    deriving (Show)
+
+type Assumptions = HashMap PsName [Type PsName]
+
+instance Semigroup Judgement where
+    a <> b = Judgement
+        { _constraints = ((<>) `on` _constraints) a b
+        , _assumptions = (H.unionWith (<>) `on` _assumptions) a b
+        }
+
+instance Monoid Judgement where
+    mempty = Judgement
+        { _constraints = mempty
+        , _assumptions = mempty
+        }
+
+--------------------------------------------------------------------------------
+
+class HasTypes a where
+    types :: Traversal' a Type'
+    freeTvs :: a -> HashSet PsName
+    boundTvs :: a -> HashSet PsName
+    subst :: Name -> Type' -> a -> a
+
+    freeTvs = foldMapOf types $ cata \case
+        VarTF n -> S.singleton n
+        t       -> fold t
+
+    boundTvs = const mempty
+
+    subst k v = types %~ cata \case
+        VarTF n | k == n -> v
+        t                -> embed t
+
+instance HasTypes Constraint where
+    types k (Equality s t) = Equality <$> types k s <*> types k t
+    types k (ImplicitInstance m s t) =
+        ImplicitInstance <$> types k m <*> types k s <*> types k t
+    types k (ExplicitInstance s t) =
+        ExplicitInstance <$> types k s <*> types k t
+
+instance (Hashable a, HasTypes a) => HasTypes (HashSet a) where
+    types k = traverseHashSetBad (types k)
+
+instance HasTypes Type' where
+    types = id
+    freeTvs = cata \case
+        VarTF n -> S.singleton n
+        ForallTF x t -> S.delete x t
+        t -> fold t
+    boundTvs = cata \case
+        ForallTF x t -> S.insert x t
+        t -> fold t
+    subst k v = para \case
+        VarTF n | k == n -> v
+        ForallTF x (pre,post)
+            | k == x -> ForallT x pre
+        t -> embed $ snd <$> t
+
+-- illegal traversal
+traverseHashSetBad :: (Hashable a, Hashable b)
+                   => Traversal (HashSet a) (HashSet b) a b
+traverseHashSetBad k s = fmap S.fromList $ traverse k (S.toList s)
+
+
+--------------------------------------------------------------------------------
+
+makePrisms ''Judgement
+makeLenses ''Judgement
+makePrisms ''Constraint
+makePrisms ''TypeError
+

src/Rlp/HindleyMilner/Visual.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE LexicalNegation #-}
+module Rlp.HindleyMilner.Visual
+    (
+    )
+    where
+--------------------------------------------------------------------------------
+import Control.Monad
+import System.IO
+import Data.Text                        (Text)
+import Data.Text                        qualified as T
+import Data.Text.IO                     qualified as T
+import Data.Pretty                      hiding (annotate)
+import Data.String                      (IsString(..))
+import Data.Foldable
+import Misc.CofreeF
+import Control.Exception
+
+import Data.Functor.Foldable
+
+import Data.Aeson
+
+import Core.Syntax                      as Core
+import Rlp.AltSyntax                    as Rlp
+import Rlp.HindleyMilner
+
+import Prelude hiding ((**))
+--------------------------------------------------------------------------------
+
+type AnnExpr = Cofree (RlpExprF PsName)
+

src/Rlp/Lex.x

@@ -0,0 +1,382 @@
+{
+{-# LANGUAGE ViewPatterns, LambdaCase #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Rlp.Lex
+    ( P(..)
+    , RlpToken(..)
+    , Located(..)
+    , lexToken
+    , lexStream
+    , lexStream'
+    , lexDebug
+    , lexCont
+    , popLexState
+    , programInitState
+    , runP'
+    , popLayout
+    )
+    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 Control.Lens
+
+import Compiler.Types
+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|forall
+
+@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 }
+
+<layout>
+{
+    
+}
+
+-- layout keywords
+<0>
+{
+    "let"               { constToken TokenLet `thenBeginPush` layout_let }
+    "letrec"            { constToken TokenLetrec `thenBeginPush` layout_let }
+    "of"                { constToken TokenOf `thenBeginPush` layout_of }
+}
+
+-- scan various identifiers and reserved words. order is important here!
+<0>
+{
+    @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 }
+}
+
+<layout, layout_let, layout_of>
+{
+    \n                  { beginPush bol }
+    "{"                 { explicitLBrace `thenDo` popLexState }
+}
+
+<layout_let>
+{
+    "in"                { constToken TokenIn `thenDo` (popLexState *> popLayout) }
+}
+
+<layout, layout_top, layout_let, layout_of>
+{
+    ()                  { doLayout }
+}
+
+{
+
+lexReservedName :: Text -> RlpToken
+lexReservedName = \case
+    "data"      -> TokenData
+    "case"      -> TokenCase
+    "of"        -> TokenOf
+    "let"       -> TokenLet
+    "letrec"    -> TokenLetrec
+    "in"        -> TokenIn
+    "infix"     -> TokenInfix
+    "infixl"    -> TokenInfixL
+    "infixr"    -> TokenInfixR
+    "forall"    -> TokenForall
+    s           -> error (show s)
+
+lexReservedOp :: Text -> RlpToken
+lexReservedOp = \case
+    "="     -> TokenEquals
+    ":"     -> TokenHasType
+    "|"     -> TokenPipe
+    "->"    -> TokenArrow
+    "\\"    -> TokenLambda
+    s       -> error (show s)
+
+-- | @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
+
+thenBeginPush :: LexerAction a -> Int -> LexerAction a
+thenBeginPush act c inp l = do
+    a <- act inp l
+    pushLexState c
+    pure a
+
+andBegin :: LexerAction a -> Int -> LexerAction a
+andBegin act c inp l = do
+    psLexState . _head .= c
+    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,a) ->
+                                   if c == '\n'
+                                   then (ln+1, 1, a+1)
+                                   else (ln, col+1, a+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.foldl f 0 where
+    f n c = 10*n + digitToInt c
+
+constToken :: RlpToken -> LexerAction (Located RlpToken)
+constToken t inp l = do
+    pos <- use (psInput . aiPos)
+    pure (Located (spanFromPos pos l) t)
+
+tokenWith :: (Text -> RlpToken) -> LexerAction (Located RlpToken)
+tokenWith tf inp l = do
+    pos <- getPos
+    let t = tf (T.take l $ inp ^. aiSource)
+    pure (Located (spanFromPos pos l) t)
+
+getPos :: P Position
+getPos = use (psInput . aiPos)
+
+alexEOF :: P (Located RlpToken)
+alexEOF = do
+    inp <- getInput
+    pos <- getPos
+    pure (Located (spanFromPos pos 0) TokenEOF)
+
+runP' :: P a -> Text -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
+runP' p s = runP p st where
+    st = initParseState [layout_top,0] 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 (spanFromPos (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 = fmap extract <$> lexStream'
+
+lexStream' :: P [Located RlpToken]
+lexStream' = lexToken >>= \case
+    t@(Located _ TokenEOF) -> pure [t]
+    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 (spanFromPos 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 "popLayout: layout stack empty! this is a bug."
+
+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
+    -- traceM $ "i: " <> show i
+    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
+    -- important that we pop the lex state lest we find our lexer diverging
+    case off of
+        -- the line is aligned with the previous. it therefore belongs to the
+        -- same list
+        EQ -> popLexState *> insertSemicolon
+        -- the line is indented further than the previous, so we assume it is a
+        -- line continuation. ignore it and move on!
+        GT -> popLexState *> lexToken
+        -- the line is indented less than the previous, pop the layout stack and
+        -- insert a closing brace. make VERY good note of the fact that we do not
+        -- pop the lex state! this means doBol is called until indentation is EQ
+        -- GT. so if multiple layouts are closed at once, this catches that.
+        LT -> popLayout >> insertRBrace
+
+thenDo :: LexerAction a -> P b -> LexerAction a
+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
+    -- traceM $ "doLayout: i: " <> show i
+    pushLayout (Implicit i)
+    popLexState
+    insertLBrace
+
+programInitState :: Text -> ParseState
+programInitState = initParseState [layout_top,0]
+
+}
+

src/Rlp/Parse.y

@@ -0,0 +1,334 @@
+{
+{-# LANGUAGE LambdaCase, ViewPatterns #-}
+module Rlp.Parse
+    ( parseRlpProg
+    , parseRlpProgR
+    , parseRlpExpr
+    , parseRlpExprR
+    , runP'
+    )
+    where
+import Compiler.RlpcError
+import Compiler.RLPC
+import Control.Comonad.Cofree
+import Rlp.Lex
+import Rlp.Syntax
+import Rlp.Parse.Types
+import Rlp.Parse.Associate
+import Control.Lens                 hiding (snoc, (.>), (<.), (<<~), (:<))
+import Data.List.Extra
+import Data.Fix
+import Data.Functor.Const
+import Data.Functor.Apply
+import Data.Functor.Bind
+import Control.Comonad
+import Data.Functor
+import Data.Semigroup.Traversable
+import Data.Text                    (Text)
+import Data.Text                    qualified as T
+import Data.Void
+import Compiler.Types
+}
+
+%name parseRlpProg StandaloneProgram
+%name parseRlpExpr StandaloneExpr
+
+%monad { P }
+%lexer { lexCont } { Located _ TokenEOF }
+%error { parseError }
+%errorhandlertype explist
+%tokentype { Located RlpToken }
+
+%token
+    varname         { Located _ (TokenVarName _) }
+    conname         { Located _ (TokenConName _) }
+    consym          { Located _ (TokenConSym _) }
+    varsym          { Located _ (TokenVarSym _) }
+    data            { Located _ TokenData }
+    case            { Located _ TokenCase }
+    of              { Located _ TokenOf }
+    litint          { Located _ (TokenLitInt _) }
+    '='             { Located _ TokenEquals }
+    '|'             { Located _ TokenPipe }
+    '::'            { Located _ TokenHasType }
+    ';'             { 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 }
+    let             { Located _ TokenLet }
+    letrec          { Located _ TokenLetrec }
+    in              { Located _ TokenIn }
+
+%nonassoc '='
+%right '->'
+%right in
+
+%%
+
+StandaloneProgram   :: { Program RlpcPs SrcSpan }
+StandaloneProgram   : layout0(Decl)         {% mkProgram $1 }
+
+StandaloneExpr      :: { Expr' RlpcPs SrcSpan }
+                    : VL Expr VR            { $2 }
+
+VL  :: { () }
+VL  : vlbrace       { () }
+
+VR  :: { () }
+VR  : vrbrace       { () }
+    | error         {% void popLayout }
+
+VS                  :: { () }
+VS                  : ';'                   { () }
+                    | vsemi                 { () }
+
+Decl        :: { Decl RlpcPs SrcSpan }
+            : FunDecl                   { $1 }
+            | TySigDecl                 { $1 }
+            | DataDecl                  { $1 }
+            | InfixDecl                 { $1 }
+
+TySigDecl   :: { Decl RlpcPs SrcSpan }
+            : Var '::' Type             { TySigD [$1] $3 }
+
+InfixDecl   :: { Decl RlpcPs SrcSpan }
+            : InfixWord litint InfixOp  {% mkInfixD $1 ($2 ^. _litint) $3 }
+
+InfixWord   :: { Assoc }
+            : infixl                    { InfixL }
+            | infixr                    { InfixR }
+            | infix                     { Infix }
+
+DataDecl    :: { Decl RlpcPs SrcSpan }
+            : data Con TyParams '=' DataCons    { DataD $2 $3 $5 }
+
+TyParams    :: { [PsName] }
+            : {- epsilon -}             { [] }
+            | TyParams varname          { $1 `snoc` extractName $2 }
+
+DataCons    :: { [ConAlt RlpcPs] }
+            : DataCons '|' DataCon      { $1 `snoc` $3 }
+            | DataCon                   { [$1] }
+
+DataCon     :: { ConAlt RlpcPs }
+            : Con Type1s                { ConAlt $1 $2 }
+
+Type1s      :: { [Ty RlpcPs] }
+            : {- epsilon -}             { [] }
+            | Type1s Type1              { $1 `snoc` $2 }
+
+Type1       :: { Ty RlpcPs }
+            : '(' Type ')'              { $2 }
+            | conname                   { ConT (extractName $1) }
+            | varname                   { VarT (extractName $1) }
+
+Type        :: { Ty RlpcPs }
+            : Type '->' Type            { FunT $1 $3 }
+            | TypeApp                   { $1 }
+
+TypeApp     :: { Ty RlpcPs }
+            : Type1                     { $1 }
+            | TypeApp Type1             { AppT $1 $2 }
+
+FunDecl     :: { Decl RlpcPs SrcSpan }
+FunDecl     : Var Params '=' Expr       { FunD $1 $2 $4 Nothing }
+
+Params      :: { [Pat RlpcPs] }
+Params      : {- epsilon -}             { [] }
+            | Params Pat1               { $1 `snoc` $2 }
+
+Pat         :: { Pat RlpcPs }
+            : Con Pat1s                 { ConP $1 $2 }
+            | Pat1                      { $1 }
+
+Pat1s       :: { [Pat RlpcPs] }
+            : Pat1s Pat1                { $1 `snoc` $2 }
+            | Pat1                      { [$1] }
+
+Pat1        :: { Pat RlpcPs }
+            : Con                       { ConP $1 [] }
+            | Var                       { VarP $1 }
+            | Lit                       { LitP $1 }
+            | '(' Pat ')'               { $2 }
+
+Expr        :: { Expr' RlpcPs SrcSpan }
+            -- infixities delayed till next release :(
+            -- : Expr1 InfixOp Expr        { undefined }
+            : AppExpr                   { $1 }
+            | TempInfixExpr             { $1 }
+            | LetExpr                   { $1 }
+            | CaseExpr                  { $1 }
+
+TempInfixExpr :: { Expr' RlpcPs SrcSpan }
+TempInfixExpr : Expr1 InfixOp TempInfixExpr {% tempInfixExprErr $1 $3 }
+              | Expr1 InfixOp Expr1         { nolo' $ InfixEF $2 $1 $3 }
+
+AppExpr     :: { Expr' RlpcPs SrcSpan }
+            : Expr1                     { $1 }
+            | AppExpr Expr1             { comb2 AppEF $1 $2 }
+
+LetExpr     :: { Expr' RlpcPs SrcSpan }
+            : let layout1(Binding) in Expr      { nolo' $ LetEF NonRec $2 $4 }
+            | letrec layout1(Binding) in Expr   { nolo' $ LetEF Rec $2 $4 }
+
+CaseExpr    :: { Expr' RlpcPs SrcSpan }
+            : case Expr of layout0(Alt)     { nolo' $ CaseEF $2 $4 }
+
+-- TODO: where-binds
+Alt         :: { Alt' RlpcPs SrcSpan }
+            : Pat '->' Expr                 { AltA $1 (view _unwrap $3) Nothing }
+
+-- layout0(p : β) :: [β]
+layout0(p)  : '{' layout_list0(';',p) '}'   { $2 }
+            | VL  layout_list0(VS,p)  VR    { $2 }
+
+-- layout_list0(sep : α, p : β) :: [β]
+layout_list0(sep,p) : p                          { [$1] }
+                    | layout_list1(sep,p) sep p  { $1 `snoc` $3 }
+                    | {- epsilon -}              { [] }
+
+-- layout1(p : β) :: [β]
+layout1(p)  : '{' layout_list1(';',p) '}'   { $2 }
+            | VL  layout_list1(VS,p) VR     { $2 }
+
+-- layout_list1(sep : α, p : β) :: [β]
+layout_list1(sep,p) : p                          { [$1] }
+                    | layout_list1(sep,p) sep p  { $1 `snoc` $3 }
+
+Binding     :: { Binding' RlpcPs SrcSpan }
+            : Pat '=' Expr              { PatB $1 (view _unwrap $3) }
+
+Expr1       :: { Expr' RlpcPs SrcSpan }
+            : '(' Expr ')'              { $2 }
+            | Lit                       { nolo' $ LitEF $1 }
+            | Var                       { case $1 of Located ss _ -> ss :< VarEF $1 }
+            | Con                       { case $1 of Located ss _ -> ss :< VarEF $1 }
+
+InfixOp     :: { PsName }
+            : consym                    { extractName $1 }
+            | varsym                    { extractName $1 }
+
+-- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
+Lit         :: { Lit RlpcPs }
+            : litint                    { $1 ^. to extract
+                                              . singular _TokenLitInt
+                                              . to IntL }
+
+Var         :: { PsName }
+Var         : varname                   { $1 <&> view (singular _TokenVarName) }
+            | varsym                    { $1 <&> view (singular _TokenVarSym) }
+
+Con         :: { PsName }
+            : conname                   { $1 <&> view (singular _TokenConName) }
+
+{
+
+parseRlpProgR :: (Monad m) => Text -> RLPCT m (Program RlpcPs SrcSpan)
+parseRlpProgR s = do
+    a <- liftErrorful $ pToErrorful parseRlpProg st
+    addDebugMsg @_ @String "dump-parsed" $ show a
+    pure a
+  where
+    st = programInitState s
+
+parseRlpExprR :: (Monad m) => Text -> RLPCT m (Expr' RlpcPs SrcSpan)
+parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st
+    where
+        st = programInitState s
+
+mkInfixD :: Assoc -> Int -> PsName -> P (Decl RlpcPs SrcSpan)
+mkInfixD a p ln@(Located ss 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))
+        )
+    pos <- use (psInput . aiPos)
+    pure $ InfixD a p ln
+
+{--
+
+parseRlpExprR :: (Monad m) => Text -> RLPCT m (Expr RlpcPs)
+parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st
+    where
+        st = programInitState s
+
+parseRlpProgR :: (Monad m) => Text -> RLPCT m (Program RlpcPs)
+parseRlpProgR s = do
+    a <- liftErrorful $ pToErrorful parseRlpProg st
+    addDebugMsg @_ @String "dump-parsed" $ show a
+    pure a
+  where
+        st = programInitState s
+
+mkPsName :: Located RlpToken -> Located PsName
+mkPsName = fmap extractName
+
+extractName :: RlpToken -> PsName
+extractName = \case
+    TokenVarName n -> n
+    TokenConName n -> n
+    TokenConSym  n -> n
+    TokenVarSym  n -> n
+    _              -> error "mkPsName: not an identifier"
+
+extractInt :: RlpToken -> Int
+extractInt (TokenLitInt n) = n
+extractInt _ = error "extractInt: ugh"
+
+mkProgram :: [Decl RlpcPs SrcSpan] -> P (Program RlpcPs SrcSpan)
+mkProgram ds = do
+    pt <- use psOpTable
+    pure $ Program (associate pt <$> ds)
+
+intOfToken :: Located RlpToken -> Int
+intOfToken (Located _ (TokenLitInt n)) = n
+
+tempInfixExprErr :: Expr RlpcPs -> Expr RlpcPs -> P a
+tempInfixExprErr (Located a _) (Located b _) =
+    addFatal $ errorMsg (a <> b) $ RlpParErrOther
+        [ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :("
+        , "In the mean time, don't mix any infix operators."
+        ]
+
+--}
+
+_litint :: Getter (Located RlpToken) Int
+_litint = to extract
+        . singular _TokenLitInt
+
+tempInfixExprErr :: Expr' RlpcPs SrcSpan -> Expr' RlpcPs SrcSpan -> P a
+tempInfixExprErr (a :< _) (b :< _) =
+    addFatal $ errorMsg (a <> b) $ RlpParErrOther
+        [ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :("
+        , "In the mean time, don't mix any infix operators."
+        ]
+
+mkProgram :: [Decl RlpcPs SrcSpan] -> P (Program RlpcPs SrcSpan)
+mkProgram ds = do
+    pt <- use psOpTable
+    pure $ Program (associate pt <$> ds)
+
+extractName :: Located RlpToken -> PsName
+extractName (Located ss (TokenVarSym n)) = Located ss n
+extractName (Located ss (TokenVarName n)) = Located ss n
+extractName (Located ss (TokenConName n)) = Located ss n
+extractName (Located ss (TokenConSym n)) = Located ss n
+
+parseError :: (Located RlpToken, [String]) -> P a
+parseError ((Located ss t), exp) = addFatal $
+    errorMsg ss (RlpParErrUnexpectedToken t exp)
+
+}
+

src/Rlp/Parse/Associate.hs

@@ -0,0 +1,37 @@
+module Rlp.Parse.Associate
+    {-# WARNING "unimplemented" #-}
+    ( associate
+    )
+    where
+--------------------------------------------------------------------------------
+import Data.HashMap.Strict              qualified as H
+import Data.Functor.Foldable
+import Data.Functor.Foldable.TH
+import Data.Functor.Const
+import Data.Functor
+import Data.Text                        qualified as T
+import Text.Printf
+import Control.Lens
+import Rlp.Parse.Types
+import Rlp.Syntax
+--------------------------------------------------------------------------------
+
+associate :: OpTable -> Decl RlpcPs a -> Decl RlpcPs a
+associate _ p = p
+
+{-# WARNING associate "unimplemented" #-}
+
+examplePrecTable :: OpTable
+examplePrecTable = H.fromList
+    [ ("+",    (InfixL,6))
+    , ("*",    (InfixL,7))
+    , ("^",    (InfixR,8))
+    , (".",    (InfixR,7))
+    , ("~",    (Infix, 9))
+    , ("=",    (Infix, 4))
+    , ("&&",   (Infix, 3))
+    , ("||",   (Infix, 2))
+    , ("$",    (InfixR,0))
+    , ("&",    (InfixL,0))
+    ]
+

src/Rlp/Parse/Types.hs

@@ -0,0 +1,297 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Rlp.Parse.Types
+    (
+    -- * Trees That Grow
+      RlpcPs
+
+    -- * Parser monad and state
+    , P(..), ParseState(..), Layout(..), OpTable, OpInfo
+    , initParseState, initAlexInput
+    , pToErrorful
+    -- ** Lenses
+    , psLayoutStack, psLexState, psInput, psOpTable
+
+    -- * Other parser types
+    , RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
+    , Located(..), PsName
+    , srcSpanLen
+    -- ** Lenses
+    , _TokenLitInt, _TokenVarName, _TokenConName, _TokenVarSym, _TokenConSym
+    , aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
+
+    -- * Error handling
+    , MsgEnvelope(..), RlpcError(..), RlpParseError(..)
+    , addFatal, addWound, addFatalHere, addWoundHere
+    )
+    where
+--------------------------------------------------------------------------------
+import Core.Syntax                  (Name)
+import Text.Show.Deriving
+import Control.Monad
+import Control.Monad.State.Strict
+import Control.Monad.Errorful
+import Control.Comonad              (extract)
+import Compiler.RlpcError
+import Language.Haskell.TH.Syntax   (Lift)
+import Data.Text                    (Text)
+import Data.Maybe
+import Data.Fix
+import Data.Functor.Foldable
+import Data.Functor.Const
+import Data.Functor.Classes
+import Data.HashMap.Strict          qualified as H
+import Data.Void
+import Data.Word                    (Word8)
+import Data.Text                    qualified as T
+import Control.Lens                 hiding ((<<~))
+import Rlp.Syntax
+import Compiler.Types
+--------------------------------------------------------------------------------
+
+-- | Phantom type identifying rlpc's parser phase
+
+data RlpcPs
+
+type instance NameP RlpcPs = PsName
+
+type PsName = Located Text
+
+--------------------------------------------------------------------------------
+
+spanFromPos :: Position -> Int -> SrcSpan
+spanFromPos (l,c,a) s = SrcSpan l c a s
+
+{-# INLINE spanFromPos #-}
+
+type LexerAction a = AlexInput -> Int -> P a
+
+data AlexInput = AlexInput
+    { _aiPrevChar   :: Char
+    , _aiSource     :: Text
+    , _aiBytes      :: [Word8]
+    , _aiPos        :: Position
+    }
+    deriving Show
+
+type Position =
+    ( Int -- ^ line
+    , Int -- ^ column
+    , Int -- ^ Absolutely
+    )
+
+posLine :: Lens' Position Int
+posLine = _1
+
+posColumn :: Lens' Position Int
+posColumn = _2
+
+posAbsolute :: Lens' Position Int
+posAbsolute = _3
+
+data RlpToken
+    -- literals
+    = TokenLitInt Int
+    -- identifiers
+    | TokenVarName Text
+    | TokenConName Text
+    | TokenVarSym Text
+    | TokenConSym Text
+    -- reserved words
+    | TokenData
+    | TokenCase
+    | TokenOf
+    | TokenLet
+    | TokenLetrec
+    | TokenIn
+    | TokenInfixL
+    | TokenInfixR
+    | TokenInfix
+    | TokenForall
+    -- 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 part of the input
+    | TokenSemicolonV
+    | TokenLBraceV
+    | TokenRBraceV
+    | TokenEOF
+    deriving (Show)
+
+_TokenLitInt :: Prism' RlpToken Int
+_TokenLitInt = prism TokenLitInt $ \case
+    TokenLitInt n -> Right n
+    x             -> Left x
+
+_TokenVarName :: Prism' RlpToken Text
+_TokenVarName = prism TokenVarName $ \case
+    TokenVarName n -> Right n
+    x              -> Left x
+
+_TokenVarSym :: Prism' RlpToken Text
+_TokenVarSym = prism TokenVarSym $ \case
+    TokenVarSym n -> Right n
+    x              -> Left x
+
+_TokenConName :: Prism' RlpToken Text
+_TokenConName = prism TokenConName $ \case
+    TokenConName n -> Right n
+    x              -> Left x
+
+_TokenConSym :: Prism' RlpToken Text
+_TokenConSym = prism TokenConSym $ \case
+    TokenConSym n -> Right n
+    x              -> Left x
+
+newtype P a = P {
+        runP :: ParseState
+             -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
+    }
+    deriving (Functor)
+
+pToErrorful :: (Applicative m)
+            => P a -> ParseState -> ErrorfulT (MsgEnvelope RlpParseError) m a
+pToErrorful p st = ErrorfulT $ pure (ma,es) where
+    (_,es,ma) = runP p st
+
+instance Applicative P where
+    pure a = P $ \st -> (st, [], pure a)
+    liftA2 = liftM2
+
+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)
+
+type OpTable = H.HashMap Name OpInfo
+type OpInfo = (Assoc, Int)
+
+data RlpParseError = RlpParErrOutOfBoundsPrecedence Int
+                   | RlpParErrDuplicateInfixD Name
+                   | RlpParErrLexical
+                   | RlpParErrUnexpectedToken RlpToken [String]
+                   | RlpParErrOther [Text]
+                   deriving (Show)
+
+instance IsRlpcError RlpParseError where
+    liftRlpcError = \case
+        RlpParErrOutOfBoundsPrecedence n ->
+            Text [ "Illegal precedence in infixity declaration"
+                 , "rl' currently only allows precedences between 0 and 9."
+                 ]
+        RlpParErrDuplicateInfixD s ->
+            Text [ "Conflicting infixity declarations for operator "
+                    <> tshow s
+                 ]
+        RlpParErrLexical ->
+            Text [ "Unknown lexical error :(" ]
+        RlpParErrUnexpectedToken t exp ->
+            Text [ "Unexpected token " <> tshow t
+                 , "Expected: " <> tshow exp
+                 ]
+        RlpParErrOther ts ->
+            Text ts
+        where
+            tshow :: (Show a) => a -> T.Text
+            tshow = T.pack . show
+
+----------------------------------------------------------------------------------
+
+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)
+                                    (st ^. pos . posAbsolute)
+                                    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)
+                                    (st ^. pos . posAbsolute)
+                                    l
+            , _msgDiagnostic = e
+            , _msgSeverity = SevError
+            }
+    in (st, [e'], Nothing)
+
+initParseState :: [Int] -> Text -> ParseState
+initParseState ls s = ParseState
+    { _psLayoutStack = []
+    -- IMPORTANT: the initial state is `bol` to begin the top-level layout,
+    -- which then returns to state 0 which continues the normal lexing process.
+    , _psLexState = ls
+    , _psInput = initAlexInput s
+    , _psOpTable = mempty
+    }
+
+initAlexInput :: Text -> AlexInput
+initAlexInput s = AlexInput
+    { _aiPrevChar   = '\0'
+    , _aiSource     = s
+    , _aiBytes      = []
+    , _aiPos        = (1,1,0)
+    }
+
+--------------------------------------------------------------------------------
+
+
+-- deriving instance Lift (Program RlpcPs)
+-- deriving instance Lift (Decl RlpcPs)
+-- deriving instance Lift (Pat RlpcPs)
+-- deriving instance Lift (Lit RlpcPs)
+-- deriving instance Lift (Expr RlpcPs)
+-- deriving instance Lift (Binding RlpcPs)
+-- deriving instance Lift (Ty RlpcPs)
+-- deriving instance Lift (Alt RlpcPs)
+-- deriving instance Lift (ConAlt RlpcPs)
+

src/Rlp/Syntax.hs

@@ -0,0 +1,10 @@
+module Rlp.Syntax
+    ( module Rlp.Syntax.Backstage
+    , module Rlp.Syntax.Types
+    )
+    where
+--------------------------------------------------------------------------------
+import Rlp.Syntax.Backstage
+import Rlp.Syntax.Types
+--------------------------------------------------------------------------------
+

src/Rlp/Syntax/Backstage.hs

@@ -0,0 +1,35 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Rlp.Syntax.Backstage
+    ( strip
+    )
+    where
+--------------------------------------------------------------------------------
+import Data.Fix                     hiding (cata)
+import Data.Functor.Classes
+import Data.Functor.Foldable
+import Rlp.Syntax.Types
+import Text.Show.Deriving
+import Language.Haskell.TH.Syntax   (Lift)
+--------------------------------------------------------------------------------
+
+-- oprhan instances because TH
+
+instance (Show (NameP p)) => Show1 (Alt p) where
+    liftShowsPrec = $(makeLiftShowsPrec ''Alt)
+
+instance (Show (NameP p)) => Show1 (Binding p) where
+    liftShowsPrec = $(makeLiftShowsPrec ''Binding)
+
+instance (Show (NameP p)) => Show1 (ExprF p) where
+    liftShowsPrec = $(makeLiftShowsPrec ''ExprF)
+
+deriving instance (Lift (NameP p), Lift a) => Lift (Expr' p a)
+deriving instance (Lift (NameP p), Lift a) => Lift (Decl p a)
+deriving instance (Show (NameP p), Show a) => Show (Decl p a)
+
+deriving instance (Show (NameP p), Show a) => Show (Program p a)
+
+strip :: Functor f => Cofree f a -> Fix f
+strip (_ :< as) = Fix $ strip <$> as
+

src/Rlp/Syntax/Types.hs

@@ -0,0 +1,145 @@
+-- recursion-schemes
+{-# LANGUAGE DeriveTraversable, TemplateHaskell, TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-}
+{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-}
+module Rlp.Syntax.Types
+    (
+      NameP
+    , SimpleP
+    , Assoc(..)
+    , ConAlt(..)
+    , Alt(..), Alt'
+    , Ty(..)
+    , Binding(..), Binding'
+    , Expr', ExprF(..)
+    , Rec(..)
+    , Lit(..)
+    , Pat(..)
+    , Decl(..), Decl'
+    , Program(..)
+    , Where
+
+    -- * Re-exports
+    , Cofree(..)
+    , Trans.Cofree.CofreeF
+    , SrcSpan(..)
+
+    , programDecls
+    )
+    where
+----------------------------------------------------------------------------------
+import Data.Text                    (Text)
+import Data.Text                    qualified as T
+import Data.String                  (IsString(..))
+import Data.Functor.Classes
+import Data.Functor.Identity
+import Data.Functor.Compose
+import Data.Fix
+import Data.Kind                    (Type)
+import GHC.Generics
+import Language.Haskell.TH.Syntax   (Lift)
+import Control.Lens                 hiding ((:<))
+
+import Control.Comonad.Trans.Cofree qualified as Trans.Cofree
+import Control.Comonad.Cofree
+import Data.Functor.Foldable
+import Data.Functor.Foldable.TH     (makeBaseFunctor)
+
+import Compiler.Types               (SrcSpan(..), Located(..))
+import Core.Syntax                  qualified as Core
+import Core                         (Rec(..), HasRHS(..), HasLHS(..))
+----------------------------------------------------------------------------------
+
+data SimpleP
+
+type instance NameP SimpleP = String
+
+type family NameP p
+
+data ExprF p a = LetEF   Rec [Binding p a] a
+               | VarEF   (NameP p)
+               | LamEF   [Pat p] a
+               | CaseEF  a [Alt p a]
+               | IfEF    a a a
+               | AppEF   a a
+               | LitEF   (Lit p)
+               | ParEF   a
+               | InfixEF (NameP p) a a
+               deriving (Functor, Foldable, Traversable)
+
+data ConAlt p = ConAlt (NameP p) [Ty p]
+
+deriving instance (Lift (NameP p)) => Lift (ConAlt p)
+deriving instance (Show (NameP p)) => Show (ConAlt p)
+
+data Ty p = ConT (NameP p)
+          | VarT (NameP p)
+          | FunT (Ty p) (Ty p)
+          | AppT (Ty p) (Ty p)
+
+deriving instance (Show (NameP p)) => Show (Ty p)
+deriving instance (Lift (NameP p)) => Lift (Ty p)
+
+data Pat p = VarP (NameP p)
+           | LitP (Lit p)
+           | ConP (NameP p) [Pat p]
+
+deriving instance (Lift (NameP p)) => Lift (Pat p)
+deriving instance (Show (NameP p)) => Show (Pat p)
+
+data Lit p = IntL Int
+    deriving Show
+
+deriving instance (Lift (NameP p)) => Lift (Lit p)
+
+data Assoc = InfixL | InfixR | Infix
+    deriving (Lift, Show)
+
+deriving instance (Show (NameP p), Show a) => Show (ExprF p a)
+deriving instance (Lift (NameP p), Lift a) => Lift (ExprF p a)
+
+data Binding p a = PatB (Pat p) (ExprF p a)
+    deriving (Functor, Foldable, Traversable)
+
+deriving instance (Lift (NameP p), Lift a) => Lift (Binding p a)
+deriving instance (Show (NameP p), Show a) => Show (Binding p a)
+
+type Binding' p a = Binding p (Cofree (ExprF p) a)
+
+type Where p a = [Binding p a]
+
+data Alt p a = AltA (Pat p) (ExprF p a) (Maybe (Where p a))
+    deriving (Functor, Foldable, Traversable)
+
+deriving instance (Show (NameP p), Show a) => Show (Alt p a)
+deriving instance (Lift (NameP p), Lift a) => Lift (Alt p a)
+
+type Expr p = Fix (ExprF p)
+
+type Alt' p a = Alt p (Cofree (ExprF p) a)
+
+--------------------------------------------------------------------------------
+
+data Program p a = Program
+    { _programDecls :: [Decl p a]
+    }
+
+data Decl p a = FunD   (NameP p) [Pat p] (Expr' p a) (Maybe (Where p a))
+              | TySigD [NameP p] (Ty p)
+              | DataD  (NameP p) [NameP p] [ConAlt p]
+              | InfixD Assoc Int (NameP p)
+
+type Decl' p a = Decl p (Cofree (ExprF p) a)
+
+type Expr' p = Cofree (ExprF p)
+
+makeLenses ''Program
+
+loccof :: Iso' (Cofree f SrcSpan) (Located (f (Cofree f SrcSpan)))
+loccof = iso sa bt where
+    sa :: Cofree f SrcSpan -> Located (f (Cofree f SrcSpan))
+    sa (ss :< as) = Located ss as
+
+    bt :: Located (f (Cofree f SrcSpan)) -> Cofree f SrcSpan
+    bt (Located ss as) = ss :< as
+

src/Rlp/TH.hs

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

src/Rlp2Core.hs

@@ -0,0 +1,212 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveTraversable #-}
+module Rlp2Core
+    ( desugarRlpProgR
+    , desugarRlpProg
+    , desugarRlpExpr
+    )
+    where
+--------------------------------------------------------------------------------
+import Control.Monad
+import Control.Monad.Writer.CPS
+import Control.Monad.Utils
+import Control.Arrow
+import Control.Applicative
+import Control.Lens                     hiding ((:<))
+import Compiler.RLPC
+import Data.List                        (mapAccumL, partition)
+import Data.Text                        (Text)
+import Data.Text                        qualified as T
+import Data.HashMap.Strict              qualified as H
+import Data.Monoid                      (Endo(..))
+import Data.Either                      (partitionEithers)
+import Data.Foldable
+import Data.Maybe                       (fromJust, fromMaybe)
+import Data.Function                    (on)
+import GHC.Stack
+import Debug.Trace
+import Numeric
+import Misc.MonadicRecursionSchemes
+
+import Data.Fix                         hiding (cata, para, cataM)
+import Data.Functor.Bind
+import Data.Functor.Foldable
+import Control.Comonad
+import Control.Comonad.Cofree
+
+import Effectful.State.Static.Local
+import Effectful.Labeled
+import Effectful
+import Text.Show.Deriving
+
+import Core.Syntax                      as Core
+import Rlp.AltSyntax                    as Rlp
+import Compiler.Types
+import Data.Pretty
+--------------------------------------------------------------------------------
+
+type Tree a = Either Name (Name, Branch a)
+
+-- | Rose tree branch representing "nested" "patterns" in the Core language. That
+-- is, a constructor with children that are either a normal binder (Left (Given)
+-- name) or an indirection to another pattern (Right (Generated name) (Pattern))
+
+data Branch a = Branch Name [Tree a]
+    deriving (Show, Functor, Foldable, Traversable)
+
+-- | The actual rose tree.
+-- @type Rose = 'Data.Fix.Fix' 'Branch'@
+
+type Rose = Fix Branch
+
+deriveShow1 ''Branch
+
+--------------------------------------------------------------------------------
+
+-- desugarRlpProgR :: forall m a. (Monad m)
+--                 => Rlp.Program PsName (TypedRlpExpr PsName)
+--                 -> RLPCT m (Core.Program Var)
+-- desugarRlpProgR p = do
+--     let p' = desugarRlpProg p
+--     addDebugMsg "dump-desugared" $ show (out p')
+--     pure p'
+
+desugarRlpProgR = undefined
+
+desugarRlpProg :: Rlp.Program PsName (TypedRlpExpr PsName) -> Core.Program Var
+desugarRlpProg = rlpProgToCore
+
+desugarRlpExpr = undefined
+
+type NameSupply = Labeled "NameSupply" (State [Name])
+
+runNameSupply :: Text -> Eff (NameSupply ': es) a -> Eff es a
+runNameSupply pre = runLabeled $ evalState [ pre <> "_" <> tshow name | name <- [0..] ]
+    where tshow = T.pack . show
+
+single :: (Monoid s) => ASetter s t a b -> b -> t
+single l a = mempty & l .~ a
+
+-- the rl' program is desugared by desugaring each declaration as a separate
+-- program, and taking the monoidal product of the lot :3
+
+rlpProgToCore :: Rlp.Program PsName (TypedRlpExpr PsName) -> Core.Program Var
+rlpProgToCore = foldMapOf (programDecls . each) declToCore
+
+--------------------------------------------------------------------------------
+
+declToCore :: Rlp.Decl PsName TypedRlpExpr' -> Core.Program Var
+
+declToCore (DataD n as ds)
+    = foldMap (uncurry $ conToCore t) ([0..] `zip` ds)
+   <> single programTyCons (H.singleton n k)
+  where
+    as' = TyVar <$> as
+    k = foldr (:->) t as'
+    t = foldl TyApp (TyCon n) as'
+
+-- assume full eta-expansion for now
+declToCore (FunD b [] e) = single programScDefs $
+    [ScDef b' [] e']
+  where
+    b' = MkVar b (typeToCore $ extract e)
+    e' = runPureEff . runNameSupply b . cataM exprToCore . retype $ e
+
+conToCore :: Core.Type -> Int -> DataCon PsName -> Core.Program Var
+conToCore t tag (DataCon b as)
+    = single programScDefs [ScDef b' [] $ Con tag arity]
+  where
+    arity = lengthOf arrowStops t - 1
+    b' = MkVar b t
+
+dummyExpr :: Text -> Core.Expr b
+dummyExpr a = Var ("<" <> a <> ">")
+
+stripTypes :: Core.Program Var -> Core.Program Name
+stripTypes p = Core.Program
+    { _programTyCons = p ^. programTyCons 
+    , _programDataTags = p ^. programDataTags
+    , _programScDefs =  p ^. programScDefs
+            & each . binders %~ (\ (MkVar n _) -> n)
+    -- TEMP
+    , _programTypeSigs = mempty
+    }
+
+--------------------------------------------------------------------------------
+
+-- | convert rl' types to Core types, annotate binders, and strip excess type
+-- info.
+retype :: Cofree RlpExprF' (Rlp.Type PsName) -> RlpExpr Var
+retype = (_extract %~ unquantify) >>> fmap typeToCore >>> cata \case
+    t :<$ InL (LamF bs e)
+        -> Finl (LamF bs' e)
+      where
+        bs' = zipWith MkVar bs (t ^.. arrowStops)
+
+    t :<$ InL (VarF n)
+        -> Finl (VarF n)
+
+    t :<$ InR (LetEF r bs e)
+        -> Finr (LetEF r _ _)
+
+    t :<$ InR (CaseEF e as)
+        -> _
+
+unquantify :: Rlp.Type b
+           -> Rlp.Type b
+unquantify (ForallT _ x) = unquantify x
+unquantify x             = x
+
+typeToCore :: Rlp.Type PsName -> Core.Type
+typeToCore = cata \case
+    VarTF n   -> TyVar n
+    ConTF n   -> TyCon n
+    FunTF     -> TyFun
+    AppTF f x -> TyApp f x
+    -- TODO: we assume all quantified tyvars are of kind Type
+    ForallTF x m -> TyForall (MkVar x TyKindType) m
+
+--------------------------------------------------------------------------------
+
+exprToCore :: (NameSupply :> es)
+           => RlpExprF Var (Core.Expr Var)
+           -> Eff es (Core.Expr Var)
+
+exprToCore (InL e) = pure . embed $ e
+
+exprToCore (InR e) = exprToCore' e
+
+exprToCore' :: (NameSupply :> es)
+            => Rlp.ExprF Var (Core.Expr Var) -> Eff es (Core.Expr Var)
+
+exprToCore' (CaseEF e as) = pure $ Case e (alterToCore <$> as)
+
+exprToCore' _ = pure $ dummyExpr "expr"
+
+alterToCore :: Rlp.Alter Var (Expr Var) -> Core.Alter Var
+alterToCore (Rlp.Alter (ConP' (MkVar n _) bs) e)
+    = Core.Alter (AltData n) (noPatterns bs) e
+
+noPatterns :: [Pat b] -> [b]
+noPatterns ps = ps ^.. each . singular _VarP
+
+--------------------------------------------------------------------------------
+
+annotateVar :: Core.Type -> Core.ExprF PsName a -> Core.ExprF Var a
+
+-- fix-points:
+annotateVar _ (VarF n)   = VarF n
+annotateVar _ (ConF t a) = ConF t a
+annotateVar _ (AppF f x) = AppF f x
+annotateVar _ (LitF l)   = LitF l
+annotateVar _ (TypeF t)  = TypeF t
+
+rlpExprToCore :: (NameSupply :> es)
+              => Rlp.ExprF PsName Core.Expr' -> Eff es Core.Expr'
+
+-- assume all binders are simple variable patterns for now
+rlpExprToCore (LetEF r bs e) = pure $ Let r bs' e
+  where
+    bs' = b2b <$> bs
+    b2b (VarB (VarP k) v) = Binding k v
+

src/TI.hs

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

tst/Arith.hs

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

tst/Compiler/TypesSpec.hs

@@ -0,0 +1,67 @@
+{-# LANGUAGE ParallelListComp #-}
+module Compiler.TypesSpec
+    ( spec
+    )
+    where
+--------------------------------------------------------------------------------
+import Control.Lens.Combinators
+import Data.Function            ((&))
+
+import Test.QuickCheck
+import Test.Hspec
+
+import Compiler.Types           (SrcSpan(..), srcSpanAbs, srcSpanLen)
+--------------------------------------------------------------------------------
+
+spec :: Spec
+spec = do
+    describe "SrcSpan" $ do
+        -- it "associates under closure"
+        --     prop_SrcSpan_mul_associative
+        it "commutes under closure"
+            prop_SrcSpan_mul_commutative
+        it "equals itself when squared"
+            prop_SrcSpan_mul_square_eq
+
+prop_SrcSpan_mul_associative :: Property
+prop_SrcSpan_mul_associative = property $ \a b c ->
+    -- very crudely approximate when overflow will occur; bail we think it
+    -- will
+    (([a,b,c] :: [SrcSpan]) & allOf (each . (srcSpanAbs <> srcSpanLen))
+                                    (< (maxBound @Int `div` 3)))
+    ==> (a <> b) <> c === a <> (b <> c :: SrcSpan)
+
+prop_SrcSpan_mul_commutative :: Property
+prop_SrcSpan_mul_commutative = property $ \a b ->
+    a <> b === (b <> a :: SrcSpan)
+
+prop_SrcSpan_mul_square_eq :: Property
+prop_SrcSpan_mul_square_eq = property $ \a ->
+    a <> a === (a :: SrcSpan)
+
+instance Arbitrary SrcSpan where
+    arbitrary = do
+        l <- chooseInt (1, maxBound)
+        c <- chooseInt (1, maxBound)
+        a <- chooseInt (0, maxBound)
+            `suchThat` (\n -> n >= pred l + pred c)
+        s <- chooseInt (0, maxBound)
+        pure $ SrcSpan l c a s
+
+    shrink (SrcSpan l c a s) =
+        [ SrcSpan l' c' a' s'
+        | (l',c',a',s') <- shrinkParts
+        , l' >= 1
+        , c' >= 1
+        , a' >= pred l' + pred c'
+        ]
+      where
+        -- shfl as = unsafePerformIO (generate $ shuffle as)
+        shrinkParts = 
+            [ (l',c',a',s')
+            | l' <- shrinkIntegral l
+            | c' <- shrinkIntegral c
+            | a' <- shrinkIntegral a
+            | s' <- shrinkIntegral s
+            ]
+

tst/Core/HindleyMilnerSpec.hs

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

tst/GMSpec.hs

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

tst/Rlp/HindleyMilnerSpec.hs

@@ -0,0 +1,14 @@
+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
+module Rlp.HindleyMilnerSpec
+    ( spec
+    )
+    where
+--------------------------------------------------------------------------------
+import Test.Hspec
+import Rlp.TH
+import Rlp.HindleyMilner
+--------------------------------------------------------------------------------
+
+spec :: Spec
+spec = undefined
+

visualisers/hmvis/.gitignore

@@ -0,0 +1,8 @@
+/public/js
+/node_modules
+/target
+/.shadow-cljs
+/*.iml
+/.nrepl-port
+/.idea
+

visualisers/hmvis/package.json

@@ -0,0 +1,11 @@
+{
+  "devDependencies": {
+    "shadow-cljs": "^2.26.2"
+  },
+  "dependencies": {
+    "ace-builds": "^1.32.7",
+    "react": "16.13.0",
+    "react-ace": "^10.1.0",
+    "react-dom": "16.13.0"
+  }
+}

visualisers/hmvis/public/css/main.css

@@ -0,0 +1,99 @@
+@import "solarized.css";
+
+html, body
+{ height: 100%
+}
+
+body {
+    font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', Roboto, Oxygen, Ubuntu, Cantarell, 'Open Sans', 'Helvetica Neue', sans-serif;
+    overflow: hidden;
+}
+
+.editor-container
+{ position: relative
+; height: 80vh
+}
+
+#editor
+{ width: 100%;
+; height: 100%
+; position: relative
+}
+
+#type-check-button {
+    position: fixed;
+    top: 0;
+    left: 50%;
+    z-index: 2;
+    /* margin: 0 auto; */
+    transform: translateX(-50%);
+}
+
+#type-check-output
+{ background: green
+; width: 100%
+; height: 100%
+}
+
+.main-view-container
+{ columns: 2 auto;
+
+}
+
+.split {
+    height: 100%;
+    width: 50%;
+    position: fixed;
+    z-index: 1;
+    top: 0;
+    overflow-x: hidden;
+    padding-top: 20px;
+}
+
+.left {
+    left: 0;
+}
+
+.right {
+    right: 0;
+}
+
+.annotation-wrapper
+{ display: inline-flex
+; flex-direction: column
+/* ; border-style: solid */
+/* ; border-width: 0 0 0.45em 0 */
+}
+
+.typed-wrapper
+{ display: inline-block
+}
+
+.annotation-wrapper .annotation
+{ position: relative
+; bottom: 0
+; min-height: 0.60em
+}
+
+.annotation-text
+{ display: none
+}
+
+.annotation.hovering > .annotation-text
+{ display: inline-block
+}
+
+.code-wrapper
+{ display: inline-block
+}
+
+code
+{ font-family: monospace
+; font-size: 1em
+}
+
+/* .typed-wrapper.hovering > .code-wrapper */
+/* { border-width: 0.2em */
+/* ; border-style: solid */
+/* } */
+

visualisers/hmvis/public/css/solarized.css

@@ -0,0 +1,303 @@
+@import url(http://fonts.googleapis.com/css?family=PT+Sans);
+@import url(http://fonts.googleapis.com/css?family=PT+Sans+Narrow:400,700);
+article,
+aside,
+details,
+figcaption,
+figure,
+footer,
+header,
+hgroup,
+nav,
+section,
+summary {
+  display: block;
+}
+audio,
+canvas,
+video {
+  display: inline-block;
+}
+audio:not([controls]) {
+  display: none;
+  height: 0;
+}
+[hidden] {
+  display: none;
+}
+html {
+  font-family: sans-serif;
+  -webkit-text-size-adjust: 100%;
+  -ms-text-size-adjust: 100%;
+}
+body {
+  margin: 0;
+}
+a:focus {
+  outline: thin dotted;
+}
+a:active,
+a:hover {
+  outline: 0;
+}
+h1 {
+  font-size: 2em;
+}
+abbr[title] {
+  border-bottom: 1px dotted;
+}
+b,
+strong {
+  font-weight: bold;
+}
+dfn {
+  font-style: italic;
+}
+mark {
+  background: #ff0;
+  color: #000;
+}
+code,
+kbd,
+pre,
+samp {
+  font-family: monospace, serif;
+  font-size: 1em;
+}
+pre {
+  white-space: pre-wrap;
+  word-wrap: break-word;
+}
+q {
+  quotes: "\201C" "\201D" "\2018" "\2019";
+}
+small {
+  font-size: 80%;
+}
+sub,
+sup {
+  font-size: 75%;
+  line-height: 0;
+  position: relative;
+  vertical-align: baseline;
+}
+sup {
+  top: -0.5em;
+}
+sub {
+  bottom: -0.25em;
+}
+img {
+  border: 0;
+}
+svg:not(:root) {
+  overflow: hidden;
+}
+figure {
+  margin: 0;
+}
+fieldset {
+  border: 1px solid #c0c0c0;
+  margin: 0 2px;
+  padding: 0.35em 0.625em 0.75em;
+}
+legend {
+  border: 0;
+  padding: 0;
+}
+button,
+input,
+select,
+textarea {
+  font-family: inherit;
+  font-size: 100%;
+  margin: 0;
+}
+button,
+input {
+  line-height: normal;
+}
+button,
+html input[type="button"],
+input[type="reset"],
+input[type="submit"] {
+  -webkit-appearance: button;
+  cursor: pointer;
+}
+button[disabled],
+input[disabled] {
+  cursor: default;
+}
+input[type="checkbox"],
+input[type="radio"] {
+  box-sizing: border-box;
+  padding: 0;
+}
+input[type="search"] {
+  -webkit-appearance: textfield;
+  -moz-box-sizing: content-box;
+  -webkit-box-sizing: content-box;
+  box-sizing: content-box;
+}
+input[type="search"]::-webkit-search-cancel-button,
+input[type="search"]::-webkit-search-decoration {
+  -webkit-appearance: none;
+}
+button::-moz-focus-inner,
+input::-moz-focus-inner {
+  border: 0;
+  padding: 0;
+}
+textarea {
+  overflow: auto;
+  vertical-align: top;
+}
+table {
+  border-collapse: collapse;
+  border-spacing: 0;
+}
+html {
+  font-family: 'PT Sans', sans-serif;
+}
+pre,
+code {
+  font-family: 'Inconsolata', sans-serif;
+}
+h1,
+h2,
+h3,
+h4,
+h5,
+h6 {
+  font-family: 'PT Sans Narrow', sans-serif;
+  font-weight: 700;
+}
+html {
+  background-color: #eee8d5;
+  color: #657b83;
+  margin: 1em;
+}
+body {
+  background-color: #fdf6e3;
+  margin: 0 auto;
+  max-width: 23cm;
+  border: 1pt solid #93a1a1;
+  padding: 1em;
+}
+code {
+  background-color: #eee8d5;
+  padding: 2px;
+}
+a {
+  color: #b58900;
+}
+a:visited {
+  color: #cb4b16;
+}
+a:hover {
+  color: #cb4b16;
+}
+h1 {
+  color: #d33682;
+}
+h2,
+h3,
+h4,
+h5,
+h6 {
+  color: #859900;
+}
+pre {
+  background-color: #fdf6e3;
+  color: #657b83;
+  border: 1pt solid #93a1a1;
+  padding: 1em;
+  box-shadow: 5pt 5pt 8pt #eee8d5;
+}
+pre code {
+  background-color: #fdf6e3;
+}
+h1 {
+  font-size: 2.8em;
+}
+h2 {
+  font-size: 2.4em;
+}
+h3 {
+  font-size: 1.8em;
+}
+h4 {
+  font-size: 1.4em;
+}
+h5 {
+  font-size: 1.3em;
+}
+h6 {
+  font-size: 1.15em;
+}
+.tag {
+  background-color: #eee8d5;
+  color: #d33682;
+  padding: 0 0.2em;
+}
+.todo,
+.next,
+.done {
+  color: #fdf6e3;
+  background-color: #dc322f;
+  padding: 0 0.2em;
+}
+.tag {
+  -webkit-border-radius: 0.35em;
+  -moz-border-radius: 0.35em;
+  border-radius: 0.35em;
+}
+.TODO {
+  -webkit-border-radius: 0.2em;
+  -moz-border-radius: 0.2em;
+  border-radius: 0.2em;
+  background-color: #2aa198;
+}
+.NEXT {
+  -webkit-border-radius: 0.2em;
+  -moz-border-radius: 0.2em;
+  border-radius: 0.2em;
+  background-color: #268bd2;
+}
+.ACTIVE {
+  -webkit-border-radius: 0.2em;
+  -moz-border-radius: 0.2em;
+  border-radius: 0.2em;
+  background-color: #268bd2;
+}
+.DONE {
+  -webkit-border-radius: 0.2em;
+  -moz-border-radius: 0.2em;
+  border-radius: 0.2em;
+  background-color: #859900;
+}
+.WAITING {
+  -webkit-border-radius: 0.2em;
+  -moz-border-radius: 0.2em;
+  border-radius: 0.2em;
+  background-color: #cb4b16;
+}
+.HOLD {
+  -webkit-border-radius: 0.2em;
+  -moz-border-radius: 0.2em;
+  border-radius: 0.2em;
+  background-color: #d33682;
+}
+.NOTE {
+  -webkit-border-radius: 0.2em;
+  -moz-border-radius: 0.2em;
+  border-radius: 0.2em;
+  background-color: #d33682;
+}
+.CANCELLED {
+  -webkit-border-radius: 0.2em;
+  -moz-border-radius: 0.2em;
+  border-radius: 0.2em;
+  background-color: #859900;
+}
+

visualisers/hmvis/public/index.html

@@ -0,0 +1,22 @@
+<!DOCTYPE html>
+<html lang="en">
+<head>
+  <meta charset="UTF-8">
+  <meta http-equiv="X-UA-Compatible" content="IE=edge">
+  <meta name="viewport" content="width=device-width, initial-scale=1.0">
+  <link rel="stylesheet" href="/css/main.css">
+  <title>Hindley-Milner</title>
+
+  <style type="text/css" media="screen">
+  </style>
+</head>
+<body>
+
+    <div id="mount">
+        <div id="editor">
+        </div>
+    </div>
+  <script src="/js/main.js"></script>
+</body>
+</html>
+

visualisers/hmvis/shadow-cljs.edn

@@ -0,0 +1,27 @@
+;; shadow-cljs configuration
+{:source-paths
+ ["src/"]
+
+ :dependencies
+ [[cider/cider-nrepl "0.24.0"]
+  [nilenso/wscljs "0.2.0"]
+  [org.clojure/core.match "1.1.0"]
+  [binaryage/oops "0.7.2"]
+  [reagent "0.10.0"]
+  [cljsjs/react "17.0.2-0"]
+  [cljsjs/react-dom "17.0.2-0"]
+  [cljsx "1.0.0"]]
+
+ :dev-http
+ {8020 "public"}
+
+ :builds
+ {:app
+  {:target :browser
+   :output-dir "public/js"
+   :asset-path "/js"
+
+   :modules
+   {:main ; becomes public/js/main.js
+    {:init-fn main/init}}}}}
+

visualisers/hmvis/src/hmvis/annotated.cljs

@@ -0,0 +1,154 @@
+(ns hmvis.annotated
+  (:require [cljs.core.match :refer-macros [match]]
+            [cljsx.core :refer [jsx> react> defcomponent]]
+            [react :as react]
+            [react-dom :as react-dom]
+            [reagent.core :as r]
+            [reagent.dom :as rdom]
+            [clojure.pprint :refer [cl-format]]
+            [hmvis.ppr :as ppr]
+            [clojure.pprint :refer [pprint]]
+            [clojure.string :as str]))
+
+(defonce tc-input (r/atom nil))
+
+(defonce current-annotation-text (r/atom nil))
+
+(defn unicodify [s]
+  (str/replace s #"->" "→"))
+
+(defn punctuate [p & as]
+  (match as
+         [] ""
+         _  (reduce #(str %1 p %2) as)))
+
+(defn hsep [& as]
+  (apply punctuate " " as))
+
+(defn maybe-parens [c s]
+  (if c
+      [:<> "(" s ")"]
+      s))
+
+(defn formatln [fs & rest]
+  (apply cl-format true (str fs "~%") rest))
+
+(def nesting-rainbow (cycle ["red" "orange" "yellow"
+                             "green" "blue" "purple"]))
+
+(defn text-colour-by-background [colour]
+  (match colour
+         "yellow" "black"
+         _        "white"))
+
+(defn Annotation [colour text hovering?]
+  [:div {:class (if @hovering?
+                    "annotation hovering"
+                    "annotation")
+         :on-mouse-enter #(reset! hovering? true)
+         :on-mouse-leave #(reset! hovering? false)
+         :style {:background colour
+                 :color (text-colour-by-background colour)}}
+   [:div {:class "annotation-text"}
+    text]])
+
+(defn Typed [colour t child]
+  (let [hovering? (r/atom false)]
+    (fn []
+        [:div {:class "annotation-wrapper"}
+         [:div {:class (if @hovering?
+                           "typed-wrapper hovering"
+                           "typed-wrapper")
+                }
+          [:div {:class "code-wrapper"} child]]
+         [Annotation colour (unicodify t) hovering?]])))
+
+(declare Expr)
+
+(defn LambdaExpr [colours binds body]
+  [:<>
+    [:code
+      (hsep "λ" (apply hsep binds) "-> ")]
+    [Expr colours 0 body]])
+
+(defn VarExpr [var-id]
+  [:code var-id])
+
+(defn AppExpr [colours f x]
+  [:<> [Expr colours ppr/app-prec f]
+       " "
+       [Expr colours ppr/app-prec1 x]])
+
+(defn let-or-letrec [rec]
+  (match rec
+         "Rec"    "letrec"
+         "NonRec" "let"))
+
+(defn Pat [colours p {:keys [tag contents]}]
+  (match tag
+         "VarP" contents))
+
+(defn Binding [colours {:keys [tag contents]}]
+  (match tag
+         "VarB" (let [[p v] contents]
+                  [:<> [Pat colours 0 p] " = " [Expr colours 0 v]])))
+
+(defn LetExpr [colours rec bs e]
+  [:<> (let-or-letrec rec)
+       " "
+       (apply punctuate "; " (map (partial Binding colours) bs))
+       " in "
+       (Expr colours 0 e)])
+
+(defn LitExpr [_ l]
+  [:code (str l)])
+
+(defn Alter [colours a]
+  (pprint a)
+  [:code "<alter>"])
+
+(defn CaseExpr [colours e as]
+  [:<> "case " [Expr colours 0 e] " of { "
+       "<alters>"
+       " }"])
+
+(defn Expr [[c & colours] p {e :e t :type}]
+  (match e
+    {:InL {:tag "LamF" :contents [bs body & _]}}
+      (maybe-parens (< ppr/app-prec1 p)
+                    [Typed c t [LambdaExpr colours bs body]])
+    {:InL {:tag "VarF" :contents var-id}}
+      [Typed c t [VarExpr var-id]]
+    {:InL {:tag "AppF" :contents [f x]}}
+      (maybe-parens (< ppr/app-prec p)
+                    [Typed c t [AppExpr colours f x]])
+    {:InR {:tag "LetEF" :contents [r bs body]}}
+      (maybe-parens (< ppr/app-prec1 p)
+                    [Typed c t [LetExpr colours r bs body]])
+    {:InL {:tag "LitF" :contents l}}
+      [Typed c t [LitExpr colours l]]
+    {:InR {:tag "CaseEF" :contents [scrut as]}}
+      (maybe-parens (< ppr/app-prec1 p)
+                    [Typed c t [CaseExpr colours scrut as]])
+    :else [:code "<expr>"]))
+
+(def rainbow-cycle (cycle ["red"
+                           "orange"
+                           "yellow"
+                           "green"
+                           "blue"
+                           "violet"]))
+
+(defn render-decl [{name :name body :body}]
+  [:code {:key name :display "block"}
+           (str name " = ") [Expr rainbow-cycle 0 body] #_ (render-expr body)
+           [:br]])
+
+(defn TypeChecker []
+  [:div
+   (map render-decl (or @tc-input []))])
+
+; (defn init []
+;   (rdom/render [type-checker]
+;                (js/document.querySelector "#output")))
+

visualisers/hmvis/src/hmvis/ppr.cljs

@@ -0,0 +1,41 @@
+(ns hmvis.ppr
+    (:require [cljs.core.match :refer-macros [match]]))
+
+(def app-prec  10)
+(def app-prec1 11)
+
+(defn- maybe-parens [c s]
+  (if c
+      (str "(" s ")")
+      s))
+
+(defn- hsep [& as]
+  (let [f (fn [a b] (str a " " b))]
+    (reduce f as)))
+
+(declare expr)
+
+(defn lambda-expr [binds body]
+  (hsep "λ" (apply hsep binds) "->" (expr body)))
+
+(defn app-expr [f x]
+  (hsep (expr app-prec f) (expr app-prec1 x)))
+
+(defn var-expr [var-id]
+  var-id)
+
+(defn expr
+  ([exp] (expr 0 exp))
+
+  ([p {e :e}]
+    (match e
+           {:InL {:tag "LamF" :contents [bs body & _]}}
+           (maybe-parens (< app-prec1 p)
+                         (lambda-expr bs body))
+           {:InL {:tag "VarF" :contents var-id}}
+           (var-expr var-id)
+           {:InL {:tag "AppF" :contents [f x]}}
+           (maybe-parens (< app-prec p)
+                         (app-expr f x))
+           :else [:code "<expr>"])))
+

visualisers/hmvis/src/main.cljs

@@ -0,0 +1,103 @@
+(ns main
+  (:require [clojure.spec.alpha :as s]
+            ["react-ace$default" :as AceEditor]
+            ["ace-builds/src-noconflict/mode-haskell"]
+            ["ace-builds/src-noconflict/theme-solarized_light"]
+            ["ace-builds/src-noconflict/keybinding-vim"]
+            [wscljs.client :as ws]
+            [wscljs.format :as fmt]
+            [cljs.core.match :refer-macros [match]]
+            [hmvis.annotated :as annotated]
+            [reagent.core :as r]
+            [reagent.dom :as rdom]))
+
+; (def *editor
+;   (doto (js/ace.edit "editor")
+;         (.setTheme "ace/theme/solarized_light")
+;         (.setKeyboardHandler "ace/keyboard/vim")
+;         (.setOption "mode" "ace/mode/haskell")))
+
+(def *output (.querySelector js/document "#output"))
+
+(defn display-errors [es]
+  (doseq [{{e :contents} :diagnostic} es]
+         (let [fmte (map #(str "  • " % "\n") e)]
+           (js/console.warn (apply str "message from rlpc:\n" fmte)))))
+
+(defn with-success [f ma]
+  (match ma
+    {:errors es :result nil} (display-errors es)
+    {:errors es :result a}   (do (display-errors es)
+                                 (f a))))
+
+(defn on-message [e]
+  (let [r (js->clj (js/JSON.parse (.-data e)) :keywordize-keys true)]
+    (match r
+           {:tag "Annotated" :contents c}
+             (with-success #(reset! annotated/tc-input %) c)
+           :else
+             (js/console.warn "unrecognisable response from rlp"))))
+
+(defonce *socket (ws/create "ws://127.0.0.1:9002"
+                            {:on-message on-message
+                             :on-open #(println "socket opened")
+                             :on-close #(println "socket closed")
+                             :on-error #(println "error: " %)}))
+
+(defn send [msg]
+  (ws/send *socket msg fmt/json))
+
+(defonce *editor nil)
+
+(defn TypeCheckButton []
+  [:button {:id "type-check-button"
+            :on-click #(send {:command "annotate"
+                              :source (.getValue *editor)})}
+   "type-check"])
+
+(defn Editor []
+  [:div {:class "editor-container"}
+    [(r/adapt-react-class AceEditor)
+     {:mode "haskell"
+      :theme "solarized_light"
+      :keyboardHandler "vim"
+      :defaultValue (str "id = \\x -> x\n"
+                         "flip f x y = f y x\n"
+                         "fix f = letrec x = f x in x")
+      :style {:width "100%"
+              :height "100%"}
+      :on-load (fn [editor]
+                 (set! *editor editor)
+                 (set! (.. editor -container -style -resize) "both")
+                 (js/document.addEventListener
+                   "mouseup"
+                   #(.resize editor)))
+      :name "editor"} ]])
+
+(defn Main []
+  [:<>
+    [:div {:class "main-view-container"}
+     [TypeCheckButton]
+     [Editor]
+     [annotated/TypeChecker]
+     #_ [:div {:id "type-check-output"}
+      "doge soge quoge"]]
+   #_ [annotated/TypeChecker]])
+
+;; start is called by init and after code reloading finishes
+(defn ^:dev/after-load start []
+  (rdom/render [Main]
+               (js/document.getElementById "mount"))
+  (js/console.log "start"))
+
+(defn init []
+  ;; init is called ONCE when the page loads
+  ;; this is called in the index.html and must be exported
+  ;; so it is available even in :advanced release builds
+  (js/console.log "init")
+  (start))
+
+;; this is called before any code is reloaded
+(defn ^:dev/before-load stop []
+  (js/console.log "stop"))
+