post

whole-program inference

whole-program inference

whole-program inference

.ghci

@@ -1,5 +1,10 @@
+-- repl extensions
 :set -XOverloadedStrings
+:set -XQuasiQuotes
 
+--------------------------------------------------------------------------------
+
+-- happy/alex: override :r to rebuild parsers
 :set -package process
 
 :{
@@ -16,3 +21,5 @@ _reload_and_make _ = do
 
 :def! r _reload_and_make
 
+--------------------------------------------------------------------------------
+

Makefile_happysrcs

@@ -1,19 +1,24 @@
+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 = dist-newstyle/build/x86_64-osx/ghc-9.6.2/rlp-0.1.0.0/build
+CABAL_BUILD = $(shell ./find-build.clj)
 
 all: parsers lexers
 
-parsers: $(CABAL_BUILD)/Rlp/Parse.hs $(CABAL_BUILD)/Core/Parse.hs
+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 $@
 

README.md

@@ -1,126 +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.
-- [x] ADTs
-- [x] First-class functions
-- [ ] Higher-kinded types
-- [ ] Typeclasses
-- [x] Parametric polymorphism
-- [x] 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
-    - [x] High-level language
-        - [x] AST
-        - [x] Lexer
-        - [x] Parser
-    - [ ] Translation to the core language
-        - [ ] Constraint solver
-        - [ ] `do`-notation
-    - [x] CLI
-- [ ] Documentation
-    - [x] State transition rules
-    - [ ] How does the evaluation model work?
-    - [ ] The Hindley-Milner type system
-    - [ ] CLI usage
-    - [ ] Tail call optimisation
-    - [ ] Parsing rlp
-    - [ ] Trees That Grow
-- [ ] Tests
-    - [x] Generic example programs
-    - [ ] Parser
-
-### ~~December Release Plan~~
-- [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
-
-### January Release Plan
-- [ ] Beta rl' to Core
-- [ ] UX improvements
-    - [ ] Actual compiler errors -- no more unexceptional `error` calls
-    - [ ] Better CLI dump flags
-    - [ ] Annotate the AST with token positions for errors
-- [ ] More examples
-
-### March Release Plan
-- [ ] Tests
-    - [ ] rl' parser
-    - [ ] rl' lexer
-
-### Indefinite Release Plan
-
-This list is more concrete than the milestones, but likely further in the future
-than the other release plans.
-
-- [ ] Stable rl' to Core
-- [ ] Core polish
-    - [ ] Better, stable parser
-    - [ ] Better, stable lexer
-    - [ ] Less hacky handling of named data
-    - [ ] Less hacky pragmas
-- [ ] GM to LLVM
-

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,7 +1,10 @@
 {-# 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
@@ -10,12 +13,18 @@ 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
@@ -37,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"
@@ -55,11 +70,35 @@ 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
@@ -69,82 +108,41 @@ evaluatorReader = maybeReader $ \case
 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
+    if opts ^. rlpcServer
-    forM_ es $ \ (CompilerError e) -> print $ "warning: " <> e
+    then Server.server
-    pure ()
+    else void $ evalRLPCIO opts dispatch
 
-driver :: RLPCIO CompilerError ()
+dispatch :: RLPCIO ()
-driver = sequence_
+dispatch = getLang >>= \case
-    [ dshowFlags
+    Just LanguageCore -> CoreDriver.driver
-    , ddumpAST
+    Just LanguageRlp  -> RlpDriver.driver
-    , ddumpEval
+    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 ()
+driver :: RLPCIO ()
-ddumpAST = whenFlag flagDDumpAST $ forFiles_ \o f -> do
+driver = undefined
-    liftIO $ withFile f ReadMode $ \h -> do
-        s <- TIO.hGetContents h
-        case parseProg o s of
-            Right (a,_) -> hPutStrLn stderr $ show a
-            Left e -> error "todo errors lol"
 
-ddumpEval :: RLPCIO CompilerError ()
+inferLanguage :: FilePath -> Maybe Language
-ddumpEval = whenFlag flagDDumpEval do
+inferLanguage fp
-    fs <- view rlpcInputFiles
+    | ".rl" `isSuffixOf` fp     = Just LanguageRlp
-    forM_ fs $ \f -> liftIO (TIO.readFile f) >>= doProg
+    | ".cr" `isSuffixOf` fp     = Just LanguageCore
-
+    | otherwise                 = Nothing
-    where
-        doProg :: Text -> 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
-          -> Text
-          -> 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)
 

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

@@ -63,52 +63,13 @@ an assembly target. The goal of our new G-Machine is to compile a *linear
 sequence of instructions* which, **when executed**, build up a graph
 representing the code.
 
-**************************
+*************
-Trees and Vines, in Theory
+The G-Machine
-**************************
+*************
-
-Rather than instantiating an expression at runtime -- traversing the AST and
-building a graph -- we want to compile all expressions at compile-time,
-generating a linear sequence of instructions which may be executed to build the
-graph.
-
-**************************
-Evaluation: Slurping Vines
-**************************
-
-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.
 
 .. literalinclude:: /../../src/GM.hs
    :dedent:
-   :start-after: -- >> [ref/compileSc]
+   :start-after: -- >> [ref/Instr]
-   :end-before: -- << [ref/compileSc]
+   :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

@@ -62,159 +62,6 @@ braces and semicolons. In developing our *layout* rules, we will follow in the
 pattern of translating the whitespace-sensitive source language to an explicitly
 sectioned language.
 
-But What About Haskell?
-***********************
-
-Parsing Haskell -- and thus rl' -- is only slightly more complex than Python,
-but the design is certainly more sensitive. 
-
-.. code-block:: haskell
-
-   -- line folds
-   something = this is a
-       single expression
-
-   -- an extremely common style found in haskell
-   data Some = Data
-       { is    :: Presented
-       , in    :: This
-       , silly :: Style
-       }
-
-   -- another style oddity
-   -- note that this is not a single
-   -- continued line! `look at`,
-   -- `this odd`, and `alignment` are all
-   -- discrete items!
-   anotherThing = do look at
-                     this odd
-                     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.
-
 References
 ----------
 

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

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

rlp.cabal

@@ -16,6 +16,7 @@ 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
@@ -32,47 +33,64 @@ library
                     , 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
-    other-modules:    Data.Heap
                     , Data.Pretty
                     , Core.Parse
+                    , Core.Parse.Types
                     , Core.Lex
                     , Core2Core
+                    , 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.17 && <4.20
+    build-depends:    base >=4.17 && <4.21
                     -- required for happy
                     , array >= 0.5.5 && < 0.6
                     , containers >= 0.6.7 && < 0.7
-                    , template-haskell >= 2.20.0 && < 2.21
+                    , 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.1
+                    , text >= 2.0.2 && < 2.3
-                    , megaparsec >= 9.6.1 && < 9.7
-                    , microlens >= 0.4.13 && < 0.5
-                    , microlens-mtl >= 0.2.0 && < 0.3
-                    , microlens-platform >= 0.4.3 && < 0.5
-                    , microlens-th >= 0.4.3 && < 0.5
                     , unordered-containers >= 0.2.20 && < 0.3
                     , recursion-schemes >= 5.2.2 && < 5.3
                     , data-fix >= 0.3.2 && < 0.4
                     , utf8-string >= 1.0.2 && < 1.1
-                    , extra >= 1.7.0 && < 2
+                    , extra >= 1.7.0 && <2
-                    , semigroupoids
+                    , semigroupoids >=6.0 && <6.1
-                    , comonad
+                    , comonad >=5.0.0 && <6
-                    , lens
+                    , 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
@@ -81,20 +99,27 @@ library
         OverloadedStrings
         TypeFamilies
         LambdaCase
+        ViewPatterns
+        DataKinds
+        DerivingVia
+        StandaloneDeriving
+        DerivingStrategies
+        BlockArguments
 
 executable rlpc
     import:           warnings
     main-is:          Main.hs
-    -- other-modules:
+    other-modules:    RlpDriver
-    -- other-extensions:
+                    , CoreDriver
+                    , Server
+
     build-depends: base >=4.17.0.0 && <4.20.0.0
                  , rlp
                  , optparse-applicative >= 0.18.1 && < 0.19
-                 , microlens >= 0.4.13 && < 0.5
-                 , microlens-mtl >= 0.2.0 && < 0.3
                  , mtl >= 2.3.1 && < 2.4
                  , unordered-containers >= 0.2.20 && < 0.3
-                 , text >= 2.0.2 && < 2.1
+                 , lens >=5.2.3 && <6.0
+                 , text >= 2.0.2 && < 2.3
 
     hs-source-dirs:   app
     default-language: GHC2021
@@ -111,8 +136,10 @@ test-suite rlp-test
                  , 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

@@ -8,39 +8,77 @@ that use Prelude types such as @Either@ and @String@ rather than more complex
 types such as @RLPC@ or @Text@.
 -}
 module Compiler.JustRun
-    ( justLexSrc
+    ( justLexCore
-    , justParseSrc
+    , justParseCore
-    , justTypeCheckSrc
+    , justParseRlp
+    , justTypeCheckCore
+    , justHdbg
+    , justInferRlp
+    , makeItPretty, makeItPretty'
     )
     where
 ----------------------------------------------------------------------------------
 import Core.Lex
 import Core.Parse
 import Core.HindleyMilner
-import Core.Syntax                      (Program')
+import Core.Syntax
 import Compiler.RLPC
 import Control.Arrow                    ((>>>))
-import Control.Monad                    ((>=>))
+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
 ----------------------------------------------------------------------------------
 
-justLexSrc :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
+justHdbg :: String -> IO GmState
-justLexSrc s = lexCoreR (T.pack s)
+justHdbg = undefined
-             & fmap (map $ \ (Located _ _ _ t) -> t)
+-- justHdbg s = do
-             & rlpcToEither
+--     p <- evalRLPCIO def (parseRlpProgR >=> desugarRlpProgR $ T.pack s)
+--     withFile "/tmp/t.log" WriteMode $ hdbgProg p
 
-justParseSrc :: String -> Either [MsgEnvelope RlpcError] Program'
+justLexCore :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
-justParseSrc s = parse (T.pack s)
+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 = lexCoreR >=> parseCoreProgR
+    where parse = parseRlpProgR @Identity
 
-justTypeCheckSrc :: String -> Either [MsgEnvelope RlpcError] Program'
+justTypeCheckCore :: String -> Either [MsgEnvelope RlpcError] Program'
-justTypeCheckSrc s = typechk (T.pack s)
+justTypeCheckCore s = typechk (T.pack s)
-                   & rlpcToEither
+                    & 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

src/Compiler/RLPC.hs

@@ -10,32 +10,34 @@ 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(..)
+    -- * Rlpc Monad transformer
-    , RLPCIO
+      RLPCT(RLPCT),
-    , RLPCOptions(RLPCOptions)
+    -- ** Special cases
-    , IsRlpcError(..)
+      RLPC, RLPCIO
-    , RlpcError(..)
+    , liftIO
-    , MsgEnvelope(..)
+    -- ** Running
-    , addFatal
+    , runRLPCT
-    , addWound
+    , evalRLPCT, evalRLPCIO, evalRLPC
-    , MonadErrorful
+    -- * Rlpc options
-    , Severity(..)
+    , Language(..), Evaluator(..)
-    , Evaluator(..)
+    , DebugFlag(..), CompilerFlag(..)
-    , evalRLPCT
+    -- ** Lenses
-    , evalRLPCIO
+    , rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage
-    , evalRLPC
+    , rlpcServer
-    , rlpcLogFile
+    -- * Misc. MTL-style functions
-    , rlpcDFlags  
+    , liftErrorful, liftEither, liftMaybe, hoistRlpcT
-    , rlpcEvaluator
+    -- * Misc. Rlpc Monad -related types
-    , rlpcInputFiles
+    , RLPCOptions(RLPCOptions), IsRlpcError(..), RlpcError(..)
-    , DebugFlag(..)
+    , MsgEnvelope(..), Severity(..)
-    , whenDFlag
+    , addDebugMsg
-    , whenFFlag
+    , whenDFlag, whenFFlag
-    , def
+    -- * Misc. Utilities
-    , liftErrorful
+    , forFiles_, withSource
+    -- * Convenient re-exports
+    , addFatal, addWound, def
     )
     where
 ----------------------------------------------------------------------------------
@@ -45,29 +47,51 @@ 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.Platform
+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
 ----------------------------------------------------------------------------------
 
 newtype RLPCT m a = RLPCT {
         runRLPCT :: ReaderT RLPCOptions (ErrorfulT (MsgEnvelope RlpcError) m) a
     }
-    deriving (Functor, Applicative, Monad, MonadReader RLPCOptions)
+    deriving ( Functor, Applicative, Monad
+             , MonadReader RLPCOptions, MonadErrorful (MsgEnvelope RlpcError))
+
+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
 
 type RLPC = RLPCT Identity
 
 type RLPCIO = RLPCT IO
 
+instance MonadTrans RLPCT where
+    lift = RLPCT . lift . lift
+
+instance (MonadIO m) => MonadIO (RLPCT m) where
+    liftIO = lift . liftIO
+
 evalRLPC :: RLPCOptions
          -> RLPC a
          -> (Maybe a, [MsgEnvelope RlpcError])
@@ -75,32 +99,39 @@ evalRLPC opt r = runRLPCT r
                & flip runReaderT opt
                & runErrorful
 
-evalRLPCT :: (Monad m)
+evalRLPCT :: RLPCOptions
-          => RLPCOptions
           -> RLPCT m a
           -> m (Maybe a, [MsgEnvelope RlpcError])
-evalRLPCT = undefined
+evalRLPCT opt r = runRLPCT r
-
+                & flip runReaderT opt
-evalRLPCIO :: RLPCOptions -> RLPCIO a -> IO a
+                & runErrorfulT
-evalRLPCIO opt r = do
-    (ma,es) <- evalRLPCT opt r
-    putRlpcErrs es
-    case ma of
-        Just x  -> pure x
-        Nothing -> die "Failed, no code compiled."
-
-putRlpcErrs :: [MsgEnvelope RlpcError] -> IO ()
-putRlpcErrs = traverse_ print
 
 liftErrorful :: (Monad m, IsRlpcError e) => ErrorfulT (MsgEnvelope e) m a -> RLPCT m a
 liftErrorful e = RLPCT $ lift (fmap liftRlpcError `mapErrorful` e)
 
+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
     , _rlpcDFlags      :: HashSet DebugFlag
     , _rlpcFFlags      :: HashSet CompilerFlag
     , _rlpcEvaluator   :: Evaluator
     , _rlpcHeapTrigger :: Int
+    , _rlpcLanguage    :: Maybe Language
+    , _rlpcServer      :: Bool
     , _rlpcInputFiles  :: [FilePath]
     }
     deriving Show
@@ -108,6 +139,9 @@ data RLPCOptions = RLPCOptions
 data Evaluator = EvaluatorGM | EvaluatorTI
     deriving Show
 
+data Language = LanguageRlp | LanguageCore
+    deriving Show
+
 ----------------------------------------------------------------------------------
 
 instance Default RLPCOptions where
@@ -118,16 +152,21 @@ instance Default RLPCOptions where
         , _rlpcEvaluator = EvaluatorGM
         , _rlpcHeapTrigger = 200
         , _rlpcInputFiles = []
+        , _rlpcServer = False
+        , _rlpcLanguage = Nothing
         }
 
 -- debug flags are passed with -dFLAG
-type DebugFlag = String
+type DebugFlag = Text
 
-type CompilerFlag = String
+type CompilerFlag = Text
 
 makeLenses ''RLPCOptions
 pure []
 
+addDebugMsg :: (Monad m, IsText e) => Text -> e -> RLPCT m ()
+addDebugMsg tag e = addWound . debugMsg tag $ Text [e ^. unpacked . packed]
+
 -- TODO: rewrite this with prisms once microlens-pro drops :3
 whenDFlag :: (Monad m) => DebugFlag -> RLPCT m () -> RLPCT m ()
 whenDFlag f m = do
@@ -143,3 +182,83 @@ whenFFlag f m = do
     let a = S.member f fs
     when a m
 
+--------------------------------------------------------------------------------
+
+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

@@ -10,9 +10,13 @@ module Compiler.RlpcError
     , msgSeverity
     , liftRlpcErrors
     , errorMsg
+    , debugMsg
     -- * Located Comonad
     , Located(..)
     , SrcSpan(..)
+
+    -- * Common error messages
+    , undefinedVariableErr
     )
     where
 ----------------------------------------------------------------------------------
@@ -20,9 +24,11 @@ import Control.Monad.Errorful
 import Data.Text                (Text)
 import Data.Text                qualified as T
 import GHC.Exts                 (IsString(..))
-import Lens.Micro.Platform
+import GHC.Generics
-import Lens.Micro.Platform.Internal
+import Control.Lens             hiding ((.=))
 import Compiler.Types
+
+import Data.Aeson
 ----------------------------------------------------------------------------------
 
 data MsgEnvelope e = MsgEnvelope
@@ -32,8 +38,17 @@ data MsgEnvelope e = MsgEnvelope
    }
    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
+    deriving (Show, Generic)
+    deriving (ToJSON)
+        via Generically [Text]
 
 instance IsString RlpcError where
     fromString = Text . pure . T.pack
@@ -46,7 +61,10 @@ instance IsRlpcError RlpcError where
 
 data Severity = SevWarning
               | SevError
-              deriving Show
+              | SevDebug Text -- ^ Tag
+              deriving (Show, Generic)
+              deriving (ToJSON)
+                via Generically Severity
 
 makeLenses ''MsgEnvelope
 
@@ -65,3 +83,16 @@ errorMsg s e = MsgEnvelope
     , _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

@@ -1,23 +1,84 @@
+{-# 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
+    , 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, Functor)
+    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)
@@ -37,30 +98,137 @@ data SrcSpan = SrcSpan
     !Int -- ^ Column
     !Int -- ^ Absolute
     !Int -- ^ Length
-    deriving Show
+    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 + lb - aa)
+            LT -> max sa (ab + sb - aa)
-            GT -> max sb (aa + la - ab)
+            GT -> max sb (aa + sa - ab)
 
--- | A synonym for '(<<=)' with a tighter precedence and left-associativity for
+--------------------------------------------------------------------------------
--- use with '(<~>)' in a sort of, comonadic pseudo-applicative style.
 
-(<<~) :: (Comonad w) => (w a -> b) -> w a -> w b
+data GetOrSet = Get | Set | GetSet
-(<<~) = (<<=)
 
-infixl 4 <<~
+class CanGet (k :: GetOrSet)
+class CanSet (k :: GetOrSet) where
 
--- | Similar to '(<*>)', but with a cokleisli arrow.
+instance CanGet Get
+instance CanGet GetSet
+instance CanSet Set
+instance CanSet GetSet
 
-(<~>) :: (Comonad w, Bind w) => w (w a -> b) -> w a -> w b
+data GetSetLens (k :: GetOrSet) s t a b :: Type where
-mc <~> ma = mc >>- \f -> ma =>> f
+    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
 
-infixl 4 <~>
+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,24 +1,28 @@
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE TupleSections, PatternSynonyms #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE UndecidableInstances #-}
 module Control.Monad.Errorful
-    ( ErrorfulT
+    ( ErrorfulT(..)
-    , runErrorfulT
     , 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 Data.HashSet                 (HashSet)
 import Data.HashSet                 qualified as H
-import Lens.Micro
+import Control.Lens
 ----------------------------------------------------------------------------------
 
 newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Maybe a, [e]) }
@@ -28,16 +32,24 @@ type Errorful e = ErrorfulT e Identity
 pattern Errorful :: (Maybe a, [e]) -> Errorful e a
 pattern Errorful a = ErrorfulT (Identity a)
 
+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
+    -- | Turn any wounds into fatals
+    bleedOut :: m a -> m a
 
 instance (Applicative m) => MonadErrorful e (ErrorfulT e m) where
     addWound e = ErrorfulT $ pure (Just (), [e])
     addFatal e = ErrorfulT $ pure (Nothing, [e])
+    bleedOut m = ErrorfulT $ runErrorfulT m <&> \case
+        (a, []) -> (a, [])
+        (_, es) -> (Nothing, es)
 
 instance MonadTrans (ErrorfulT e) where
     lift m = ErrorfulT ((\x -> (Just x,[])) <$> m)
@@ -46,7 +58,7 @@ instance (MonadIO m) => MonadIO (ErrorfulT e m) where
     liftIO = lift . liftIO
 
 instance (Functor m) => Functor (ErrorfulT e m) where
-    fmap f (ErrorfulT m) = ErrorfulT (m & mapped . _1 . _Just %~ f)
+    fmap f (ErrorfulT m) = ErrorfulT (m <&> _1 . _Just %~ f)
 
 instance (Applicative m) => Applicative (ErrorfulT e m) where
     pure a = ErrorfulT . pure $ (Just a, [])
@@ -59,21 +71,42 @@ instance (Monad m) => Monad (ErrorfulT e m) where
     ErrorfulT m >>= k = ErrorfulT $ do
         (a,es) <- m
         case a of
-            Just x      -> runErrorfulT (k x)
+            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 & mapped . _2 . mapped %~ f
+    m <&> _2 . mapped %~ f
 
 -- when microlens-pro drops we can write this as
---    mapErrorful f = coerced . mapped . _2 . mappd %~ f
+--    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 (StateT s m) where
+instance (Monad m, MonadErrorful e m) => MonadErrorful e (ReaderT r m) where
-    addWound = undefined
+    addWound = lift . addWound
-    addFatal = undefined
+    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

@@ -1,10 +1,15 @@
 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@
@@ -19,3 +24,14 @@ mapAccumLM k s t = swap <$> runStateT (traverse k' t) s
         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

@@ -10,12 +10,9 @@ import Core.Syntax
 import Core.TH
 ----------------------------------------------------------------------------------
 
--- fac3 = undefined
+letRecExample = undefined
--- sumList = undefined
--- constDivZero = undefined
--- idCase = 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;
 |]
 
@@ -149,14 +146,14 @@ caseBool1 = [coreProg|
     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
+    fac n = case ==# n 0 of
         { <1> -> 1
-        ; <0> -> (*#) n (fac ((-#) n 1))
+        ; <0> -> *# n (fac (-# n 1))
         };
 
     main = fac 3;
@@ -171,7 +168,7 @@ sumList = [coreProg|
         list = cons 1 (cons 2 (cons 3 nil));
         sum l = case l of
             { <0>      -> 0
-            ; <1> x xs -> (+#) x (sum xs)
+            ; <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,7 +184,7 @@ idCase = [coreProg|
         id x = x;
 
         main = id (case Pack{1 0} of
-            { <1> -> (+#) 2 3
+            { <1> -> +# 2 3
             })
     |]
 
@@ -197,7 +194,7 @@ namedBoolCase :: Program'
 namedBoolCase = [coreProg|
         {-# PackData True 1 0 #-}
         {-# PackData False 0 0 #-}
-        main = case (==#) 1 1 of
+        main = case ==# 1 1 of
             { True -> 123
             ; False -> 456
             }
@@ -207,8 +204,6 @@ namedConsCase :: Program'
 namedConsCase = [coreProg|
         {-# PackData Nil  0 0 #-}
         {-# PackData Cons 1 2 #-}
-        Nil = Pack{0 0};
-        Cons = Pack{1 2};
         foldr f z l = case l of
             { Nil       -> z
             ; Cons x xs -> f x (foldr f z xs)
@@ -245,3 +240,4 @@ namedConsCase = [coreProg|
 --         ]
 
 --}
+

src/Core/HindleyMilner.hs

@@ -10,27 +10,24 @@ module Core.HindleyMilner
     , check
     , checkCoreProg
     , checkCoreProgR
+    , checkCoreExprR
     , TypeError(..)
     , HMError
     )
     where
 ----------------------------------------------------------------------------------
-import Lens.Micro
-import Lens.Micro.Mtl
-import Lens.Micro.Platform
-import Data.Maybe               (fromMaybe)
-import Data.Text                qualified as T
-import Data.HashMap.Strict      qualified as H
-import Data.Foldable            (traverse_)
 import Compiler.RLPC
-import Control.Monad            (foldM, void, forM)
+import Data.Text qualified as T
-import Control.Monad.Errorful   (Errorful, addFatal)
+import Control.Monad.Errorful
-import Control.Monad.State
-import Control.Monad.Utils      (mapAccumLM)
-import Text.Printf
 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)]
@@ -38,8 +35,6 @@ type Context b = [(b, Type)]
 -- | Unannotated typing context, AKA our beloved Γ.
 type Context' = Context Name
 
--- TODO: Errorful monad?
-
 -- | Type error enum.
 data TypeError
     -- | Two types could not be unified
@@ -52,29 +47,13 @@ data TypeError
     deriving (Show, Eq)
 
 instance IsRlpcError TypeError where
-    liftRlpcError = \case
+    liftRlpcError = undefined
-        -- todo: use anti-parser instead of show
-        TyErrCouldNotUnify t u -> Text
-            [ T.pack $ printf "Could not match type `%s` with `%s`."
-                              (show t) (show u)
-            , "Expected: " <> tshow t
-            , "Got: " <> tshow u
-            ]
-        TyErrUntypedVariable n -> Text
-            [ "Untyped (likely undefined) variable `" <> n <> "`"
-            ]
-        TyErrRecursiveType t x -> Text
-            [ T.pack $ printf "recursive type error lol"
-            ]
-
-        where tshow = T.pack . show
 
 -- | Synonym for @Errorful [TypeError]@. This means an @HMError@ action may
 -- throw any number of fatal or nonfatal errors. Run with @runErrorful@.
 type HMError = Errorful TypeError
 
--- TODO: better errors. Errorful-esque, with cummulative errors instead of
+{--
--- instantly dying.
 
 -- | Assert that an expression unifies with a given type
 --
@@ -93,7 +72,7 @@ check g t1 e = do
 -- in the mean time all top-level binders must have a type annotation.
 checkCoreProg :: Program' -> HMError ()
 checkCoreProg p = scDefs
-            & traverse_ k
+                & traverse_ k
     where
         scDefs = p ^. programScDefs
         g = gatherTypeSigs p
@@ -105,10 +84,17 @@ checkCoreProg p = scDefs
              where scname = sc ^. _lhs._1
 
 -- | @checkCoreProgR p@ returns @p@ if @p@ successfully typechecks.
-checkCoreProgR :: Program' -> RLPC Program'
+checkCoreProgR :: forall m. (Monad m) => Program' -> RLPCT m Program'
-checkCoreProgR p = undefined
+checkCoreProgR p = (hoistRlpcT generalise . liftE . checkCoreProg $ p)
+                $> p
+    where
+        liftE = liftErrorful . mapErrorful (errorMsg (SrcSpan 0 0 0 0))
 
-{-# WARNING checkCoreProgR "unimpl" #-}
+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.
 --
@@ -271,9 +257,4 @@ demoContext =
     , ("False", TyCon "Bool")
     ]
 
-pprintType :: Type -> String
+--}
-pprintType (s :-> t) = "(" <> pprintType s <> " -> " <> pprintType t <> ")"
-pprintType TyFun = "(->)"
-pprintType (TyVar x) = x ^. unpacked
-pprintType (TyCon t) = t ^. unpacked
-

src/Core/Lex.x

@@ -20,12 +20,13 @@ 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 Compiler.Types
 -- TODO: unify Located definitions
-import Compiler.RlpcError   hiding (Located(..))
+import Compiler.RlpcError
-import Lens.Micro
+import Control.Lens
-import Lens.Micro.TH
 }
 
 %wrapper "monad-strict-text"
@@ -77,7 +78,7 @@ rlp :-
     "{"                     { constTok TokenLBrace }
     "}"                     { constTok TokenRBrace }
     ";"                     { constTok TokenSemicolon }
-    "::"                    { constTok TokenHasType }
+    ":"                     { constTok TokenHasType }
     "@"                     { constTok TokenTypeApp }
     "{-#"                   { constTok TokenLPragma `andBegin` pragma }
 
@@ -119,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
@@ -170,7 +169,7 @@ data SrcErrorType = SrcErrLexical String
 type Lexer = AlexInput -> Int -> Alex (Located CoreToken)
 
 lexWith :: (Text -> CoreToken) -> Lexer
-lexWith f (AlexPn _ y x,_,_,s) l = pure $ Located y x l (f $ T.take l s)
+lexWith f (AlexPn _ y x,_,_,s) l = pure . nolo . f . T.take l $ s
 
 -- | The main lexer driver.
 lexCore :: Text -> RLPC [Located CoreToken]
@@ -180,21 +179,24 @@ lexCore s = case m of
     where
         m = runAlex s lexStream
 
-lexCoreR :: Text -> RLPC [Located CoreToken]
+lexCoreR :: forall m. (Applicative m) => Text -> RLPCT m [Located CoreToken]
-lexCoreR = lexCore
+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' :: 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]
+        Located _ TokenEOF -> pure [l]
-        _                       -> (l:) <$> lexStream
+        _                  -> (l:) <$> lexStream
 
 data ParseError = ParErrLexical String
                 | ParErrParse
@@ -210,7 +212,7 @@ instance IsRlpcError ParseError where
 
 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

@@ -5,22 +5,24 @@ Description : Parser for the Core language
 -}
 {-# LANGUAGE OverloadedStrings, ViewPatterns #-}
 module Core.Parse
-    ( parseCore
+    ( parseCoreExpr
-    , parseCoreExpr
+    , parseCoreExprR
     , parseCoreProg
     , parseCoreProgR
     , module Core.Lex -- temp convenience
     , 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 Lens.Micro
+import Control.Monad
+import Control.Lens         hiding (snoc)
 import Data.Default.Class   (def)
 import Data.Hashable        (Hashable)
 import Data.List.Extra
@@ -28,65 +30,63 @@ 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 } { happyBind } { happyPure }
+%monad { P }
 
 %token
-      let             { Located _ _ _ TokenLet }
+      let             { Located _ TokenLet }
-      letrec          { Located _ _ _ TokenLetrec }
+      letrec          { Located _ TokenLetrec }
-      module          { Located _ _ _ TokenModule }
+      where           { Located _ TokenWhere }
-      where           { Located _ _ _ TokenWhere }
+      case            { Located _ TokenCase }
-      case            { Located _ _ _ TokenCase }
+      of              { Located _ TokenOf }
-      of              { Located _ _ _ TokenOf }
+      pack            { Located _ TokenPack } -- temp
-      pack            { Located _ _ _ TokenPack } -- temp
+      in              { Located _ TokenIn }
-      in              { Located _ _ _ TokenIn }
+      litint          { Located _ (TokenLitInt $$) }
-      litint          { Located _ _ _ (TokenLitInt $$) }
+      varname         { Located _ (TokenVarName $$) }
-      varname         { Located _ _ _ (TokenVarName $$) }
+      varsym          { Located _ (TokenVarSym $$) }
-      varsym          { Located _ _ _ (TokenVarSym $$) }
+      conname         { Located _ (TokenConName $$) }
-      conname         { Located _ _ _ (TokenConName $$) }
+      consym          { Located _ (TokenConSym $$) }
-      consym          { Located _ _ _ (TokenConSym $$) }
+      alttag          { Located _ (TokenAltTag $$) }
-      alttag          { Located _ _ _ (TokenAltTag $$) }
+      word            { Located _ (TokenWord $$) }
-      word            { Located _ _ _ (TokenWord $$) }
+      'λ'             { Located _ TokenLambda }
-      'λ'             { Located _ _ _ TokenLambda }
+      '->'            { Located _ TokenArrow }
-      '->'            { Located _ _ _ TokenArrow }
+      '='             { Located _ TokenEquals }
-      '='             { Located _ _ _ TokenEquals }
+      '@'             { Located _ TokenTypeApp }
-      '@'             { Located _ _ _ TokenTypeApp }
+      '('             { Located _ TokenLParen }
-      '('             { Located _ _ _ TokenLParen }
+      ')'             { Located _ TokenRParen }
-      ')'             { Located _ _ _ TokenRParen }
+      '{'             { Located _ TokenLBrace }
-      '{'             { Located _ _ _ TokenLBrace }
+      '}'             { Located _ TokenRBrace }
-      '}'             { Located _ _ _ TokenRBrace }
+      '{-#'           { Located _ TokenLPragma }
-      '{-#'           { Located _ _ _ TokenLPragma }
+      '#-}'           { Located _ TokenRPragma }
-      '#-}'           { Located _ _ _ TokenRPragma }
+      ';'             { Located _ TokenSemicolon }
-      ';'             { Located _ _ _ TokenSemicolon }
+      ':'             { Located _ TokenHasType }
-      '::'            { Located _ _ _ TokenHasType }
+      eof             { Located _ TokenEOF }
-      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         :: { Program Var }
-Program         : ScTypeSig ';' Program         { insTypeSig $1 $3 }
+                : TypedScDef ';' Program    { $3 & insTypeSig (fst $1)
-                | ScTypeSig OptSemi             { singletonTypeSig $1 }
+                                                 & insScDef (snd $1) }
-                | ScDef     ';' Program         { insScDef $1 $3 }
+                | TypedScDef OptSemi        { mempty & insTypeSig (fst $1)
-                | ScDef     OptSemi             { singletonScDef $1 }
+                                                     & insScDef (snd $1) }
-                | TLPragma  Program             {% doTLPragma $1 $2 }
+                | TLPragma Program          {% doTLPragma $1 $2 }
-                | TLPragma                      {% doTLPragma $1 mempty }
+                | TLPragma                  {% doTLPragma $1 mempty }
 
 TLPragma        :: { Pragma }
                 : '{-#' Words '#-}'             { Pragma $2 }
@@ -100,132 +100,152 @@ OptSemi         : ';'                           { () }
                 | {- epsilon -}                 { () }
 
 ScTypeSig       :: { (Name, Type) }
-ScTypeSig       : Var '::' Type                 { ($1,$3) }
+ScTypeSig       : Id ':' Type                   { ($1, $3) }
 
-ScDefs          :: { [ScDef Name] }
+TypedScDef      :: { (Var, ScDef Var) }
-ScDefs          : ScDef ';' ScDefs              { $1 : $3 }
+                : Id ':' Type ';' Id ParList '=' Expr
-                | ScDef ';'                     { [$1] }
+                            { (MkVar $1 $3, mkTypedScDef $1 $3 $5 $6 $8) }
-                | ScDef                         { [$1] }
 
-ScDef           :: { ScDef Name }
+-- ScDefs          :: { [ScDef PsName] }
-ScDef           : Var ParList '=' Expr          { ScDef $1 $2 $4 }
+-- ScDefs          : ScDef ';' ScDefs              { $1 : $3 }
-                -- hack to allow constructors to be compiled into scs
+--                 | ScDef ';'                     { [$1] }
-                | Con ParList '=' Expr          { ScDef $1 $2 $4 }
+--                 | ScDef                         { [$1] }
+-- 
+-- ScDef           :: { ScDef PsName }
+-- ScDef           : Id ParList '=' Expr   { ScDef (Left $1) $2
+--                                                 ($4 & binders %~ Right) }
 
 Type            :: { Type }
-Type            : Type1                         { $1 }
+                : 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 }
-                | Type1 '->' Type               { $1 :-> $3 }
-                -- do we want to allow symbolic names for tyvars and tycons?
                 | varname                       { TyVar $1 }
-                | conname                       { TyCon $1 }
+                | conname                       { if $1 == "Type"
+                                                    then TyKindType else TyCon $1 }
 
-ParList         :: { [Name] }
+ParList      :: { [Name] }
-ParList         : Var ParList                   { $1 : $2 }
+ParList      : varname ParList            { $1 : $2 }
-                | {- epsilon -}                 { [] }
+             | {- epsilon -}                 { [] }
 
-StandaloneExpr  :: { Expr Name }
+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     :: { Expr Var }
-Application     : Expr1 AppArgs                { foldl' App $1 $2 }
+Application     : Application AppArg           { App $1 $2 }
+                | Expr1       AppArg           { App $1 $2 }
 
-AppArgs         :: { [Expr Name] }
+AppArg          :: { Expr Var }
-AppArgs         : Expr1 AppArgs                 { $1 : $2 }
+                : '@' Type1                     { Type $2 }
-                | Expr1                         { [$1] }
+                | 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           :: { Alter Var }
-Alter           : alttag ParList '->' Expr      { Alter (AltTag  $1) $2 $4 }
+Alter           : alttag  AltParList '->' Expr     { Alter (AltTag  $1) $2 $4 }
-                | Con    ParList '->' Expr      { Alter (AltData $1) $2 $4 }
+                | conname AltParList '->' Expr     { Alter (AltData $1) $2 $4 }
 
-Expr1           :: { Expr Name }
+AltParList      :: { [Var] }
+                : Var AltParList                { $1 : $2 }
+                | {- epsilon -}                 { [] }
+
+Expr1           :: { Expr Var }
 Expr1           : litint                        { Lit $ IntL $1 }
                 | Id                            { Var $1 }
                 | PackCon                       { $1 }
                 | '(' Expr ')'                  { $2 }
 
-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 }
+                : varname                           { $1 }
-                | Con                                { $1 }
-
-Var             :: { Name }
-Var             : '(' varsym ')'                    { $2 }
-                | varname                           { $1 }
-
-Con             :: { Name }
-Con             : '(' consym ')'                    { $2 }
                 | conname                           { $1 }
 
+Var             :: { Var }
+Var             : '(' varname ':' Type ')'          { MkVar $2 $4 }
+
 {
 
-parseError :: [Located CoreToken] -> RLPC a
+parseError :: [Located CoreToken] -> P a
-parseError (Located y x l t : _) =
+parseError (Located _ t : _) =
-    error $ show y <> ":" <> show x
+    error $ "<line>" <> ":" <> "<col>"
          <> ": parse error at token `" <> show t <> "'"
 
-{-# WARNING parseError "unimpl" #-}
+exprPragma :: [String] -> RLPC (Expr Var)
-
-exprPragma :: [String] -> RLPC (Expr Name)
 exprPragma ("AST" : e) = undefined
 exprPragma _           = undefined
 
-{-# WARNING exprPragma "unimpl" #-}
+astPragma :: [String] -> RLPC (Expr Var)
-
-astPragma :: [String] -> RLPC (Expr Name)
 astPragma _ = undefined
 
-{-# WARNING astPragma "unimpl" #-}
+-- insTypeSig :: (Hashable b) => (b, Type) -> Program b -> Program b
+-- insTypeSig ts = programTypeSigs %~ uncurry H.insert ts
 
-insTypeSig :: (Hashable b) => (b, Type) -> Program b -> Program b
+insTypeSig :: Var -> Program Var -> Program Var
-insTypeSig ts = programTypeSigs %~ uncurry H.insert ts
+insTypeSig w@(MkVar _ t) = programTypeSigs %~ H.insert w t
 
-singletonTypeSig :: (Hashable b) => (b, Type) -> Program b
+-- singletonTypeSig :: (Hashable b) => (b, Type) -> Program b
-singletonTypeSig ts = insTypeSig ts mempty
+-- 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 :: (Hashable b) => ScDef b -> Program b
-singletonScDef sc = insScDef sc mempty
+-- singletonScDef sc = insScDef sc mempty
 
-parseCoreProgR :: [Located CoreToken] -> RLPC Program'
+parseCoreExprR :: (Monad m) => [Located CoreToken] -> RLPCT m (Expr Var)
-parseCoreProgR = parseCoreProg
+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
@@ -233,7 +253,7 @@ happyBind m k = m >>= k
 happyPure :: a -> RLPC a
 happyPure a = pure a
 
-doTLPragma :: Pragma -> Program' -> RLPC Program'
+doTLPragma :: Pragma -> Program Var -> P (Program Var)
 -- TODO: warn unrecognised pragma
 doTLPragma (Pragma []) p = pure p
 

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

@@ -5,42 +5,41 @@ Description : Core ASTs and the like
 {-# LANGUAGE PatternSynonyms, OverloadedStrings #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE DerivingStrategies, DerivingVia #-}
 -- for recursion-schemes
-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable
+{-# LANGUAGE DeriveTraversable, TypeFamilies #-}
-  , TemplateHaskell, TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE QuantifiedConstraints #-}
 module Core.Syntax
-    ( Expr(..)
+    (
-    , ExprF(..)
+    -- * Core AST
-    , ExprF'(..)
+      ExprF(..), ExprF'
-    , Type(..)
+    , ScDef(..), ScDef'
-    , pattern TyInt
+    , Program(..), Program'
-    , Lit(..)
+    , Type(..), Kind, pattern (:->), pattern TyInt
-    , pattern (:$)
+    , AlterF(..), Alter(..), Alter', AltCon(..)
-    , pattern (:@)
+    , pattern Binding, pattern Alter
-    , pattern (:->)
+    , Rec(..), Lit(..)
-    , Binding(..)
-    , AltCon(..)
-    , pattern (:=)
-    , Rec(..)
-    , Alter(..)
-    , Name
-    , Tag
-    , ScDef(..)
-    , Module(..)
-    , Program(..)
-    , Program'
     , Pragma(..)
-    , unliftScDef
+    -- ** Variables and identifiers
-    , programScDefs
+    , Name, Var(..), Tag, pattern (:^)
-    , programTypeSigs
+    , Binding, BindingF(..), pattern (:=), pattern (:$)
-    , programDataTags
+    , type Binding'
-    , Expr'
+    -- ** Working with the fixed point of ExprF
-    , ScDef'
+    , Expr, Expr'
-    , Alter'
+    , pattern Con, pattern Var, pattern App, pattern Lam, pattern Let
-    , Binding'
+    , pattern Case, pattern Type, pattern Lit
-    , HasRHS(_rhs)
+
-    , HasLHS(_lhs)
+    -- * 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
 ----------------------------------------------------------------------------------
@@ -48,163 +47,742 @@ import Data.Coerce
 import Data.Pretty
 import Data.List                    (intersperse)
 import Data.Function                ((&))
-import Data.Functor.Foldable
-import Data.Functor.Foldable.TH     (makeBaseFunctor)
 import Data.String
 import Data.HashMap.Strict          (HashMap)
 import Data.HashMap.Strict          qualified as H
 import Data.Hashable
+import Data.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 GHC.Generics
+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 Misc
-import Lens.Micro.TH                (makeLenses)
+import Misc.Lift1
-import Lens.Micro
+import Control.Lens
 ----------------------------------------------------------------------------------
 
-data Expr b = Var Name
+data ExprF b a = VarF Name
-            | Con Tag Int -- ^ Con Tag Arity
+               | ConF Tag Int -- ^ Con Tag Arity
-            | Case (Expr b) [Alter b]
+               | CaseF a [AlterF b a]
-            | Lam [b] (Expr b)
+               | LamF [b] a
-            | Let Rec [Binding b] (Expr b)
+               | LetF Rec [BindingF b a] a
-            | App (Expr b) (Expr b)
+               | AppF a a
-            | Lit Lit
+               | LitF Lit
-            deriving (Show, Read, Lift)
+               | TypeF Type
+               deriving (Functor, Foldable, Traversable)
 
-deriving instance (Eq b) => Eq (Expr b)
+type Expr b = Fix (ExprF b)
+
+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
           | TyCon Name
-          deriving (Show, Read, Lift, Eq)
+          | TyForall Var Type
+          | TyKindType
+          deriving (Show, Eq, Lift)
+
+type Kind = Type
+
+-- data TyCon = MkTyCon Name Kind
+--     deriving (Eq, Show, Lift)
+
+data Var = MkVar Name Type
+    deriving (Eq, Show, Lift, Generic)
+
+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#"
 
-infixl 2 :$
+class HasArrowSyntax s a b | s -> a b where
-pattern (:$) :: Expr b -> Expr b -> Expr b 
+    _arrowSyntax :: Prism' s (a, b)
-pattern f :$ x = App f x
 
-infixl 2 :@
+instance HasArrowSyntax Type Type Type where
-pattern (:@) :: Type -> Type -> Type
+    _arrowSyntax = prism make unmake where
-pattern f :@ x = TyApp f x
+        make (s,t) = TyFun `TyApp` s `TyApp` t
+
+        unmake (TyFun `TyApp` s `TyApp` t) = Right (s,t)
+        unmake s                           = Left s
 
 infixr 1 :->
-pattern (:->) :: Type -> Type -> Type
+pattern (:->) :: HasArrowSyntax s a b
-pattern a :-> b = TyApp (TyApp TyFun a) b
+              => a -> b -> s
+-- pattern (:->) :: Type -> Type -> Type
+pattern a :-> b <- (preview _arrowSyntax -> Just (a, b))
+    where a :-> b = _arrowSyntax # (a, b)
 
-{-# COMPLETE Binding :: Binding #-}
+data BindingF b a = BindingF b (ExprF b a)
-{-# COMPLETE (:=) :: Binding #-}
+    deriving (Functor, Foldable, Traversable)
-data Binding b = Binding b (Expr b)
-    deriving (Show, Read, Lift)
 
-deriving instance (Eq b) => Eq (Binding b)
+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)
+infixl 2 :$
-    deriving (Show, Read, Lift)
+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 Name
             | AltTag Tag
             | AltLit Lit
-            | Default
+            | AltDefault
-            deriving (Show, Read, Eq, Lift)
+            deriving (Show, Eq, Lift)
 
-data Lit = IntL Int
+newtype Lit = IntL Int
-    deriving (Show, Read, Eq, Lift)
+    deriving (Show, Eq, Lift)
 
 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 b -> Expr b
-unliftScDef (ScDef _ as e) = Lam as e
+-- unliftScDef (ScDef _ as e) = Lam as e
 
 data Module b = Module (Maybe (Name, [Name])) (Program b)
-    deriving (Show, Lift)
 
 data Program b = Program
     { _programScDefs   :: [ScDef b]
     , _programTypeSigs :: HashMap b Type
-    -- map constructors to their tag and arity
+    , _programDataTags :: HashMap Name (Tag, Int)
-    , _programDataTags :: HashMap b (Tag, Int)
+    -- ^ map constructors to their tag and arity
+    , _programTyCons   :: HashMap Name Kind
+    -- ^ map type constructors to their kind
     }
-    deriving (Show, Lift, Generic)
+    deriving (Generic)
     deriving (Semigroup, Monoid)
         via Generically (Program b)
 
 makeLenses ''Program
-makeBaseFunctor ''Expr
+-- 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 Alter' = Alter Name
-type Binding' = Binding Name
+-- type Binding' = Binding Name
 
-instance IsString (Expr b) where
+-- instance IsString (Expr b) where
-    fromString = Var . fromString
+--     fromString = Var . fromString
 
-instance IsString Type where
+lambdaLifting :: Iso (ScDef b) (ScDef b') (b, Expr b) (b', Expr b')
-    fromString "" = error "IsString Type string may not be empty"
+lambdaLifting = iso sa bt where
-    fromString s
+    sa (ScDef n [] e) = (n, e) where
-        | isUpper c     = TyCon . fromString $ s
+    sa (ScDef n as e) = (n, e') where
-        | otherwise     = TyVar . fromString $ s
+        e' = Lam as e
-        where (c:_) = s
+
+    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)
+        (\ (AlterF _ _ e) -> e)
-        (\ (Alter t as _) e' -> Alter t as 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
+instance HasRHS (BindingF b a) (BindingF b' a') (ExprF b a) (ExprF b' a')
-    _rhs = lens
-        (\ (_ := e) -> e)
-        (\ (k := _) e' -> k := e')
 
 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
+-- instance HasLHS (Binding b) (Binding b) b b where
-    _lhs = lens
+    -- _lhs = lens
-        (\ (k := _) -> k)
+    --     (\ (k := _) -> k)
-        (\ (_ := e) k' -> k' := e)
+    --     (\ (_ := 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,7 +5,8 @@ Description : Core quasiquoters
 module Core.TH
     ( coreExpr
     , coreProg
-    , coreProgT
+    -- , coreExprT
+    -- , coreProgT
     )
     where
 ----------------------------------------------------------------------------------
@@ -22,20 +23,30 @@ import Data.Text                    qualified as T
 import Core.Parse
 import Core.Lex
 import Core.Syntax
-import Core.HindleyMilner           (checkCoreProgR)
+import Core.HindleyMilner           (checkCoreProgR, checkCoreExprR)
 ----------------------------------------------------------------------------------
 
 coreProg :: QuasiQuoter
 coreProg = mkqq $ lexCoreR >=> parseCoreProgR
 
 coreExpr :: QuasiQuoter
-coreExpr = mkqq $ lexCoreR >=> parseCoreExpr
+coreExpr = mkqq $ lexCoreR >=> parseCoreExprR
 
 -- | Type-checked @coreProg@
-coreProgT :: QuasiQuoter
+-- coreProgT :: QuasiQuoter
-coreProgT = mkqq $ lexCoreR >=> parseCoreProgR >=> checkCoreProgR
+-- coreProgT = mkqq $ lexCoreR >=> parseCoreProgR >=> checkCoreProgR
 
-mkqq :: (Lift a) => (Text -> RLPC a) -> QuasiQuoter
+-- 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"
@@ -43,8 +54,6 @@ mkqq p = QuasiQuoter
     , quoteDec = error "core quasiquotes may only be used in expressions"
     }
 
-mkq :: (Lift a) => (Text -> RLPC a) -> String -> Q Exp
+mkq :: (Lift a) => (Text -> RLPCIO a) -> String -> Q Exp
-mkq parse s = case evalRLPC def (parse $ T.pack s) of
+mkq parse s = liftIO $ evalRLPCIO def (parse $ T.pack s) >>= lift
-    (Just a,  _) -> lift a
-    (Nothing, _) -> error "todo: aaahhbbhjhbdjhabsjh"
 

src/Core/Utils.hs

@@ -2,18 +2,16 @@ module Core.Utils
     ( programRhss
     , programGlobals
     , isAtomic
-    -- , insertModule
-    , extractProgram
     , freeVariables
     )
     where
 ----------------------------------------------------------------------------------
 import Data.Functor.Foldable.TH     (makeBaseFunctor)
 import Data.Functor.Foldable
-import Data.Set                     (Set)
+import Data.HashSet                 (HashSet)
-import Data.Set                     qualified as S
+import Data.HashSet                 qualified as S
 import Core.Syntax
-import Lens.Micro
+import Control.Lens
 import GHC.Exts                     (IsList(..))
 ----------------------------------------------------------------------------------
 
@@ -30,34 +28,10 @@ isAtomic _        = False
 
 ----------------------------------------------------------------------------------
 
--- TODO: export list awareness
+freeVariables :: Expr' -> HashSet Name
--- insertModule :: Module b -> Program b -> Program b
+freeVariables = undefined
--- insertModule (Module _ p) = programScDefs %~ (<>m)
+-- freeVariables = cata \case
-
+--     VarF n -> S.singleton n
-extractProgram :: Module b -> Program b
+--     CaseF e as -> e <> (foldMap f as)
-extractProgram (Module _ p) = p
+--         where f (AlterF _ bs e) = fold e `S.difference` S.fromList bs
-
-----------------------------------------------------------------------------------
-
-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 = bs ^.. each . _rhs :: [Expr']
-                ns = S.fromList $ bs ^.. each . _lhs
-                -- TODO: this feels a little wrong. maybe a different scheme is
-                -- appropriate
-                esFree = foldMap id $ freeVariables <$> es
-
-        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
 

src/Core2Core.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE ImplicitParams #-}
-{-# LANGUAGE LambdaCase #-}
 module Core2Core
     ( core2core
     , gmPrep
@@ -12,30 +11,62 @@ module Core2Core
 ----------------------------------------------------------------------------------
 import Data.Functor.Foldable
 import Data.Maybe               (fromJust)
-import Data.Set                 (Set)
+import Data.HashSet             (HashSet)
-import Data.Set                 qualified as S
+import Data.HashSet             qualified as S
 import Data.List
+import Data.Foldable
 import Control.Monad.Writer
 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.Platform
+
+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 & appFloater (floatNonStrictCases globals)
              & tagData
+             & defineData
+             & etaReduce
     where
         globals = p ^.. programScDefs . each . _lhs . _1
                 & S.fromList
 
+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
@@ -44,7 +75,7 @@ tagData p = let ?dt = p ^. programDataTags
     go x                = embed x
 
     tagAlts :: (?dt :: HashMap Name (Tag, Int)) => Alter' -> Alter'
-    tagAlts (Alter (AltData c) bs e) = Alter (AltTag tag) bs e
+    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
@@ -59,6 +90,7 @@ 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
@@ -66,7 +98,7 @@ runFloater = flip evalStateT ns >>> runWriter
 
 -- 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'
@@ -78,38 +110,39 @@ floatNonStrictCases g = goE
         goE e                   = goC e
 
         goC :: Expr' -> Floater Expr'
-        -- the only truly non-trivial case: when a case expr is found in a
+        goC = cataM \case
-        -- non-strict context, we float it into a supercombinator, give it a
+            -- the only truly non-trivial case: when a case expr is found in a
-        -- name consumed from the state, record the newly created sc within the
+            -- non-strict context, we float it into a supercombinator, give it a
-        -- Writer, and finally return an expression appropriately calling the sc
+            -- name consumed from the state, record the newly created sc within the
-        goC p@(Case e as)       = do
+            -- Writer, and finally return an expression appropriately calling the sc
-            n <- name
+            CaseF e as -> do
-            let (e',sc) = floatCase g n p
+                n <- name
-                altBodies = (\(Alter _ _ b) -> b) <$> as
+                let (e',sc) = floatCase g n (Case e as)
-            tell [sc]
+                    altBodies = (\(Alter _ _ b) -> b) <$> as
-            goE e
+                tell [sc]
-            traverse goE altBodies
+                goE e
-            pure e'
+                traverse_ goE altBodies
-        goC (f :$ x)            = (:$) <$> goC f <*> goC x
+                pure e'
-        goC (Let r bs e)        = Let r <$> bs' <*> goE e
+            t -> pure $ embed t
-            where bs' = travBs goC bs
-        goC (Lit l)             = pure (Lit l)
-        goC (Var k)             = pure (Var k)
-        goC (Con t as)          = pure (Con t as)
 
-        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
+        travBs c bs = undefined
-                    & traverse goC
+        -- ^ ??? what the fuck?
-                    & const (pure bs)
+        -- ^ 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(..)
+    ( Out(..), Out1(..)
-    , ISeq(..)
+    , outPrec1
-    , precPretty
+    , rout
-    , prettyPrint
+    , ttext
-    , prettyShow
+    , Showing(..)
-    , iShow
+    -- * Out-printing lens combinators
-    , iBracket
+    , hsepOf, vsepOf, vcatOf, vlinesOf
-    , withPrec
+    , module Prettyprinter
-    , bracketPrec
+    , 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
+class Out a where
-    pretty :: a -> ISeq
+    out :: a -> Doc ann
-    prettyPrec :: a -> Int -> ISeq
+    outPrec :: Int -> a -> Doc ann
 
-    {-# MINIMAL pretty | prettyPrec #-}
+    {-# MINIMAL out | outPrec #-}
-    pretty a = prettyPrec a 0
+    out = outPrec 0
-    prettyPrec a _ = iBracket (pretty a)
+    outPrec = const out
 
-precPretty :: (Pretty a) => Int -> a -> ISeq
+rout :: (IsString s, Out a) => a -> s
-precPretty = flip prettyPrec
+rout = fromString . show . out
 
-prettyPrint :: (Pretty a) => a -> IO ()
+-- instance Out (Doc ann) where
-prettyPrint = putStr . squash . pretty
+--     out = id
 
-prettyShow :: (Pretty a) => a -> String
+instance Out String where
-prettyShow = squash . pretty
+    out = pretty
 
-data ISeq where
+instance Out T.Text where
-    INil :: ISeq
+    out = pretty
-    IStr :: String -> ISeq
-    IAppend :: ISeq -> ISeq -> ISeq
-    IIndent :: ISeq -> ISeq
-    IBreak :: ISeq
 
-instance IsString ISeq where
+newtype Showing a = Showing a
-    fromString = IStr
 
-instance Semigroup ISeq where
+instance (Show a) => Out (Showing a) where
-    (<>) = IAppend
+    outPrec p (Showing a) = fromString $ showsPrec p a ""
 
-instance Monoid ISeq where
+deriving via Showing Int instance Out Int
-    mempty = INil
 
-squash :: ISeq -> String
+class (forall a. Out a => Out (f a)) => Out1 f where
-squash a = flatten 0 [(a,0)]
+    liftOutPrec :: (Int -> a -> Doc ann) -> Int -> f a -> Doc ann
 
-flatten :: Int -> [(ISeq, Int)] -> String
+outPrec1 :: (Out1 f, Out a) => Int -> f a -> Doc ann
-flatten _ []                      = ""
+outPrec1 = liftOutPrec outPrec
-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)
 
-iBracket :: ISeq -> ISeq
+instance (Out1 f, Out1 g, Out a) => Out (Sum f g a) where
-iBracket s = IStr "(" <> s <> IStr ")"
+    outPrec p (InL fa) = outPrec1 p fa
+    outPrec p (InR ga) = outPrec1 p ga
 
-withPrec :: Int -> ISeq -> Int -> ISeq
+instance (Out1 f, Out1 g) => Out1 (Sum f g) where
-withPrec n s p
+    liftOutPrec pr p (InL fa) = liftOutPrec pr p fa
-    | p > n     = iBracket s
+    liftOutPrec pr p (InR ga) = liftOutPrec pr p ga
-    | otherwise =          s
 
-bracketPrec :: Int -> Int -> ISeq -> ISeq
+instance (Out (f (Fix f))) => Out (Fix f) where
-bracketPrec n p s = withPrec n s p
+    outPrec d (Fix f) = outPrec d f
 
-iShow :: (Show a) => a -> ISeq
+instance (Out (f (Cofree f a)), Out a) => Out (Cofree f a) where
-iShow = IStr . show
+    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,23 +26,35 @@ import Data.List                    (mapAccumL)
 import Data.Maybe                   (fromMaybe, mapMaybe)
 import Data.Monoid                  (Endo(..))
 import Data.Tuple                   (swap)
-import Lens.Micro
+import Control.Lens
-import Lens.Micro.Extras            (view)
+import Data.Text.Lens               (IsText, packed, unpacked)
-import Lens.Micro.TH
-import Lens.Micro.Platform          (packed, unpacked)
-import Lens.Micro.Platform.Internal (IsText(..))
 import Text.Printf
-import Text.PrettyPrint             hiding ((<>))
-import Text.PrettyPrint.HughesPJ    (maybeParens)
 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
@@ -73,6 +90,7 @@ data Key = NameKey Name
          | ConstrKey Tag Int
          deriving (Show, Eq)
 
+-- >> [ref/Instr]
 data Instr = Unwind
            | PushGlobal Name
            | PushConstr Tag Int
@@ -87,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
@@ -135,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`
@@ -143,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
@@ -156,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
@@ -178,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          
+    Eval           -> evalI
-    Neg            -> negI           
+    Neg            -> negI
-    Add            -> addI           
+    Add            -> addI
-    Sub            -> subI           
+    Sub            -> subI
-    Mul            -> mulI           
+    Mul            -> mulI
-    Div            -> divI           
+    Div            -> divI
-    Equals         -> equalsI           
+    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#"
@@ -394,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
@@ -537,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 t [])
-        Just (NConstr 0 []) -> False
+            | 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
@@ -578,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])
@@ -681,14 +749,12 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
                 mconcat binders <> compileE g' e <> [Slide d]
             where
                 d = length bs
-                (g',binders) = mapAccumL compileBinder (argOffset d g) addressed
+                (g',binders) = mapAccumL compileBinder g bs
-                -- kinda gross. revisit this
-                addressed = bs `zip` reverse [0 .. d-1]
 
-                compileBinder :: Env -> (Binding', Int) -> (Env, Code)
+                compileBinder :: Env -> Binding' -> (Env, Code)
-                compileBinder m (k := v, a) = (m',c)
+                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
 
@@ -716,13 +782,15 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
         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 (AltTag t) as e) = (t, [Split n] <> c <> [Slide n])
@@ -755,13 +823,13 @@ 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 :: Stats -> Doc ann
-showStats sts = "==== Stats ============" $$ stats
+showStats sts = "==== Stats ============" <> line <> stats
     where
-        stats = text $ printf
+        stats = textt @String $ printf
             "Reductions      : %5d\n\
             \Prim Reductions : %5d\n\
             \Allocations     : %5d\n\
@@ -771,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 -------------------"
@@ -791,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
@@ -819,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
@@ -831,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)
+                entry = vsep [ "Stack : " <> showCodeShort c
-                     $$ ("Code  : " <> showStackShort s)
+                             , "Code  : " <> showStackShort s ]
 
-padInt :: Int -> Int -> Doc
+padInt :: Int -> Int -> Doc ann
-padInt m n = text (replicate (m - digitalWidth n) ' ') <> int n
+padInt m n = textt (replicate (m - digitalWidth n) ' ') <> int n
 
 maxWidth :: [Int] -> Int
 maxWidth ns = digitalWidth $ maximum ns
@@ -846,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 <> ": "
@@ -855,13 +921,12 @@ 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 _ _)   -> textt name
@@ -885,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 :: GmState -> (Name, Addr) -> Doc ann
-showSc st (k,a) = "Supercomb " <> qquotes (textt k) <> colon
+showSc st (k,a) = vcat [ "Supercomb " <> qquotes (textt k) <> colon
-               $$ code
+                       , code ]
     where
         code = case hLookup a (st ^. gmHeap) of
             Just (NGlobal _ c) -> showCode c
@@ -898,19 +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 :: Instr -> Doc ann
-showInstr (CaseJump alts) = "CaseJump" $$ nest pprTabstop alternatives
+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
+        alternatives = foldr (\a acc -> showAlt a <> line <> acc) mempty alts
-showInstr i = text $ show i
+showInstr i = textt $ show i
 
-textt :: (IsText a) => a -> Doc
+int = pretty
-textt t = t ^. unpacked & text
+
+textt :: (Pretty a) => a -> Doc ann
+textt = pretty
 
 ----------------------------------------------------------------------------------
 

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

@@ -8,9 +8,13 @@ module Rlp.Lex
     , Located(..)
     , lexToken
     , lexStream
+    , lexStream'
     , lexDebug
     , lexCont
     , popLexState
+    , programInitState
+    , runP'
+    , popLayout
     )
     where
 import Codec.Binary.UTF8.String (encodeChar)
@@ -25,9 +29,9 @@ import Data.Text                (Text)
 import Data.Text                qualified as T
 import Data.Word
 import Data.Default
-import Lens.Micro.Mtl
+import Control.Lens
-import Lens.Micro
 
+import Compiler.Types
 import Debug.Trace
 import Rlp.Parse.Types
 }
@@ -55,10 +59,10 @@ $asciisym       = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
 
 @reservedname = 
     case|data|do|import|in|let|letrec|module|of|where
-    |infixr|infixl|infix
+    |infixr|infixl|infix|forall
 
 @reservedop =
-    "=" | \\ | "->" | "|" | "::"
+    "=" | \\ | "->" | "|" | ":"
 
 rlp :-
     
@@ -83,6 +87,8 @@ $white_no_nl+       ;
 <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!
@@ -122,18 +128,25 @@ $white_no_nl+       ;
     ()                  { doBol }
 }
 
-<layout_let>
-{
-    \n                  { beginPush bol }
-    "{"                 { explicitLBrace }
-    "in"                { constToken TokenIn `thenDo` (popLexState *> popLayout) }
-    ()                  { doLayout }
-}
-
 <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 }
 }
 
@@ -145,16 +158,22 @@ lexReservedName = \case
     "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
+    ":"     -> TokenHasType
     "|"     -> TokenPipe
+    "->"    -> TokenArrow
+    "\\"    -> TokenLambda
+    s       -> error (show s)
 
 -- | @andBegin@, with the subtle difference that the start code is set
 --   /after/ the action
@@ -236,27 +255,9 @@ alexEOF = do
     pos <- getPos
     pure (Located (spanFromPos pos 0) TokenEOF)
 
-initParseState :: Text -> ParseState
-initParseState s = ParseState
-    { _psLayoutStack = []
-    -- IMPORTANT: the initial state is `bol` to begin the top-level layout,
-    -- which then returns to state 0 which continues the normal lexing process.
-    , _psLexState = [layout_top,0]
-    , _psInput = initAlexInput s
-    , _psOpTable = mempty
-    }
-
-initAlexInput :: Text -> AlexInput
-initAlexInput s = AlexInput
-    { _aiPrevChar   = '\0'
-    , _aiSource     = s
-    , _aiBytes      = []
-    , _aiPos        = (1,1,0)
-    }
-
 runP' :: P a -> Text -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
 runP' p s = runP p st where
-    st = initParseState s
+    st = initParseState [layout_top,0] s
 
 lexToken :: P (Located RlpToken)
 lexToken = do
@@ -278,11 +279,12 @@ lexCont :: (Located RlpToken -> P a) -> P a
 lexCont = (lexToken >>=)
 
 lexStream :: P [RlpToken]
-lexStream = do
+lexStream = fmap extract <$> lexStream'
-    t <- lexToken
+
-    case t of
+lexStream' :: P [Located RlpToken]
-        Located _ TokenEOF -> pure [TokenEOF]
+lexStream' = lexToken >>= \case
-        Located _ t        -> (t:) <$> lexStream
+    t@(Located _ TokenEOF) -> pure [t]
+    t                      -> (t:) <$> lexStream'
 
 lexDebug :: (Located RlpToken -> P a) -> P a
 lexDebug k = do
@@ -310,7 +312,7 @@ popLayout = do
     psLayoutStack %= (drop 1)
     case ctx of
         Just l      -> pure l
-        Nothing     -> error "uhh"
+        Nothing     -> error "popLayout: layout stack empty! this is a bug."
 
 pushLayout :: Layout -> P ()
 pushLayout l = do
@@ -329,6 +331,7 @@ 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)
@@ -337,19 +340,18 @@ cmpLayout = do
 doBol :: LexerAction (Located RlpToken)
 doBol inp l = do
     off <- cmpLayout
-    i <- indentLevel
-    traceM $ "i: " <> show i
     -- important that we pop the lex state lest we find our lexer diverging
-    popLexState
     case off of
         -- the line is aligned with the previous. it therefore belongs to the
         -- same list
-        EQ -> insertSemicolon
+        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 -> lexToken
+        GT -> popLexState *> lexToken
         -- the line is indented less than the previous, pop the layout stack and
-        -- insert a closing brace.
+        -- 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
@@ -368,10 +370,13 @@ explicitRBrace inp l = do
 doLayout :: LexerAction (Located RlpToken)
 doLayout _ _ = do
     i <- indentLevel
-    traceM $ "doLayout: i: " <> show i
+    -- traceM $ "doLayout: i: " <> show i
     pushLayout (Implicit i)
     popLexState
     insertLBrace
 
+programInitState :: Text -> ParseState
+programInitState = initParseState [layout_top,0]
+
 }
 

src/Rlp/Parse.y

@@ -2,15 +2,20 @@
 {-# 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 Lens.Micro.Platform
+import Control.Lens                 hiding (snoc, (.>), (<.), (<<~), (:<))
 import Data.List.Extra
 import Data.Fix
 import Data.Functor.Const
@@ -19,8 +24,10 @@ 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
@@ -29,6 +36,7 @@ import Data.Void
 %monad { P }
 %lexer { lexCont } { Located _ TokenEOF }
 %error { parseError }
+%errorhandlertype explist
 %tokentype { Located RlpToken }
 
 %token
@@ -37,6 +45,8 @@ import Data.Void
     consym          { Located _ (TokenConSym _) }
     varsym          { Located _ (TokenVarSym _) }
     data            { Located _ TokenData }
+    case            { Located _ TokenCase }
+    of              { Located _ TokenOf }
     litint          { Located _ (TokenLitInt _) }
     '='             { Located _ TokenEquals }
     '|'             { Located _ TokenPipe }
@@ -54,6 +64,7 @@ import Data.Void
     infixr          { Located _ TokenInfixR }
     infix           { Located _ TokenInfix }
     let             { Located _ TokenLet }
+    letrec          { Located _ TokenLetrec }
     in              { Located _ TokenIn }
 
 %nonassoc '='
@@ -62,131 +73,205 @@ import Data.Void
 
 %%
 
-StandaloneProgram   :: { RlpProgram RlpcPs }
+StandaloneProgram   :: { Program RlpcPs SrcSpan }
-StandaloneProgram   : '{' Decls  '}'        {% mkProgram $2 }
+StandaloneProgram   : layout0(Decl)         {% mkProgram $1 }
-                    | VL  DeclsV VR         {% mkProgram $2 }
 
-StandaloneExpr      :: { RlpExpr RlpcPs }
+StandaloneExpr      :: { Expr' RlpcPs SrcSpan }
-                    : VL Expr VR            { extract $2 }
+                    : VL Expr VR            { $2 }
 
 VL  :: { () }
 VL  : vlbrace       { () }
 
 VR  :: { () }
 VR  : vrbrace       { () }
-    | error         { () }
+    | error         {% void popLayout }
 
-Decls               :: { [Decl' RlpcPs] }
+VS                  :: { () }
-Decls               : Decl ';' Decls        { $1 : $3 }
+VS                  : ';'                   { () }
-                    | Decl ';'              { [$1] }
+                    | vsemi                 { () }
-                    | Decl                  { [$1] }
 
-DeclsV              :: { [Decl' RlpcPs] }
+Decl        :: { Decl RlpcPs SrcSpan }
-DeclsV              : Decl VS Decls         { $1 : $3 }
-                    | Decl VS               { [$1] }
-                    | Decl                  { [$1] }
-
-VS                  :: { Located RlpToken }
-VS                  : ';'                   { $1 }
-                    | vsemi                 { $1 }
-
-Decl        :: { Decl' RlpcPs }
             : FunDecl                   { $1 }
             | TySigDecl                 { $1 }
             | DataDecl                  { $1 }
             | InfixDecl                 { $1 }
 
-TySigDecl   :: { Decl' RlpcPs }
+TySigDecl   :: { Decl RlpcPs SrcSpan }
-            : Var '::' Type             { (\e -> TySigD [extract e]) <<~ $1 <~> $3 }
+            : Var '::' Type             { TySigD [$1] $3 }
 
-InfixDecl   :: { Decl' RlpcPs }
+InfixDecl   :: { Decl RlpcPs SrcSpan }
-            : InfixWord litint InfixOp  { $1 =>> \w ->
+            : InfixWord litint InfixOp  {% mkInfixD $1 ($2 ^. _litint) $3 }
-                                          InfixD (extract $1) (extractInt $ extract $2)
-                                          (extract $3) }
 
-InfixWord   :: { Located Assoc }
+InfixWord   :: { Assoc }
-            : infixl                    { $1 \$> InfixL }
+            : infixl                    { InfixL }
-            | infixr                    { $1 \$> InfixR }
+            | infixr                    { InfixR }
-            | infix                     { $1 \$> Infix  }
+            | infix                     { Infix }
 
-DataDecl    :: { Decl' RlpcPs }
+DataDecl    :: { Decl RlpcPs SrcSpan }
-            : data Con TyParams '=' DataCons    { $1 \$> DataD (extract $2) $3 $5 }
+            : data Con TyParams '=' DataCons    { DataD $2 $3 $5 }
 
 TyParams    :: { [PsName] }
             : {- epsilon -}             { [] }
-            | TyParams varname          { $1 `snoc` (extractName . extract $ $2) }
+            | TyParams varname          { $1 `snoc` extractName $2 }
 
 DataCons    :: { [ConAlt RlpcPs] }
             : DataCons '|' DataCon      { $1 `snoc` $3 }
             | DataCon                   { [$1] }
 
 DataCon     :: { ConAlt RlpcPs }
-            : Con Type1s                { ConAlt (extract $1) $2 }
+            : Con Type1s                { ConAlt $1 $2 }
 
-Type1s      :: { [RlpType' RlpcPs] }
+Type1s      :: { [Ty RlpcPs] }
             : {- epsilon -}             { [] }
             | Type1s Type1              { $1 `snoc` $2 }
 
-Type1       :: { RlpType' RlpcPs }
+Type1       :: { Ty RlpcPs }
             : '(' Type ')'              { $2 }
-            | conname                   { fmap ConT (mkPsName $1) }
+            | conname                   { ConT (extractName $1) }
-            | varname                   { fmap VarT (mkPsName $1) }
+            | varname                   { VarT (extractName $1) }
 
-Type        :: { RlpType' RlpcPs }
+Type        :: { Ty RlpcPs }
-            : Type '->' Type            { FunT <<~ $1 <~> $3 }
+            : Type '->' Type            { FunT $1 $3 }
-            | Type1                     { $1 }
+            | TypeApp                   { $1 }
 
-FunDecl     :: { Decl' RlpcPs }
+TypeApp     :: { Ty RlpcPs }
-FunDecl     : Var Params '=' Expr       { $4 =>> \e ->
+            : Type1                     { $1 }
-                                          FunD (extract $1) $2 e Nothing }
+            | TypeApp Type1             { AppT $1 $2 }
 
-Params      :: { [Pat' RlpcPs] }
+FunDecl     :: { Decl RlpcPs SrcSpan }
+FunDecl     : Var Params '=' Expr       { FunD $1 $2 $4 Nothing }
+
+Params      :: { [Pat RlpcPs] }
 Params      : {- epsilon -}             { [] }
             | Params Pat1               { $1 `snoc` $2 }
 
-Pat1        :: { Pat' RlpcPs }
+Pat         :: { Pat RlpcPs }
-            : Var                       { fmap VarP $1 }
+            : Con Pat1s                 { ConP $1 $2 }
-            | Lit                       { LitP <<= $1 }
+            | Pat1                      { $1 }
 
-Expr        :: { RlpExpr' RlpcPs }
+Pat1s       :: { [Pat RlpcPs] }
-            : Expr1 InfixOp Expr        { $2 =>> \o ->
+            : Pat1s Pat1                { $1 `snoc` $2 }
-                                          OAppE (extract o) $1 $3 }
+            | Pat1                      { [$1] }
-            | Expr1                     { $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 }
 
-LetExpr     :: { RlpExpr' RlpcPs }
+TempInfixExpr :: { Expr' RlpcPs SrcSpan }
-            : let layout1(Binding) in Expr { $1 \$> LetE $2 $4 }
+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 }
+Binding     :: { Binding' RlpcPs SrcSpan }
-            : Pat1 '=' Expr              { PatB <<~ $1 <~> $3 }
+            : Pat '=' Expr              { PatB $1 (view _unwrap $3) }
 
-Expr1       :: { RlpExpr' RlpcPs }
+Expr1       :: { Expr' RlpcPs SrcSpan }
-            : '(' Expr ')'              { $1 .> $2 <. $3 }
+            : '(' Expr ')'              { $2 }
-            | Lit                       { fmap LitE $1 }
+            | Lit                       { nolo' $ LitEF $1 }
-            | Var                       { fmap VarE $1 }
+            | Var                       { case $1 of Located ss _ -> ss :< VarEF $1 }
+            | Con                       { case $1 of Located ss _ -> ss :< VarEF $1 }
 
-InfixOp     :: { Located PsName }
+InfixOp     :: { PsName }
-            : consym                    { mkPsName $1 }
+            : consym                    { extractName $1 }
-            | varsym                    { mkPsName $1 }
+            | varsym                    { extractName $1 }
 
 -- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
-Lit         :: { Lit' RlpcPs }
+Lit         :: { Lit RlpcPs }
-            : litint                    { $1 <&> (IntL . (\ (TokenLitInt n) -> n)) }
+            : litint                    { $1 ^. to extract
+                                              . singular _TokenLitInt
+                                              . to IntL }
 
-Var         :: { Located PsName }
+Var         :: { PsName }
-Var         : varname                   { mkPsName $1 }
+Var         : varname                   { $1 <&> view (singular _TokenVarName) }
+            | varsym                    { $1 <&> view (singular _TokenVarSym) }
 
-Con         :: { Located PsName }
+Con         :: { PsName }
-            : conname                   { mkPsName $1 }
+            : 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
 
@@ -202,29 +287,48 @@ extractInt :: RlpToken -> Int
 extractInt (TokenLitInt n) = n
 extractInt _ = error "extractInt: ugh"
 
-mkProgram :: [Decl' RlpcPs] -> P (RlpProgram RlpcPs)
+mkProgram :: [Decl RlpcPs SrcSpan] -> P (Program RlpcPs SrcSpan)
 mkProgram ds = do
     pt <- use psOpTable
-    pure $ RlpProgram (associate pt <$> ds)
+    pure $ Program (associate pt <$> ds)
-
-parseError :: Located RlpToken -> P a
-parseError (Located ss t) = addFatal $
-    errorMsg ss RlpParErrUnexpectedToken
-
-mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs)
-mkInfixD a p n = do
-    let opl :: Lens' ParseState (Maybe OpInfo)
-        opl = psOpTable . at n
-    opl <~ (use opl >>= \case
-        Just o  -> addWoundHere l e >> pure (Just o) where
-            e = RlpParErrDuplicateInfixD n
-            l = T.length n
-        Nothing -> pure (Just (a,p))
-        )
-    pos <- use (psInput . aiPos)
-    pure $ Located (spanFromPos pos 0) (InfixD a p n)
 
 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

@@ -1,19 +1,37 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms, ViewPatterns, ImplicitParams #-}
 module Rlp.Parse.Associate
-    {-# WARNING "temporarily unimplemented" #-}
+    {-# 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 Lens.Micro
+import Data.Functor
+import Data.Text                        qualified as T
+import Text.Printf
+import Control.Lens
 import Rlp.Parse.Types
 import Rlp.Syntax
 --------------------------------------------------------------------------------
 
-associate x y = y
+associate :: OpTable -> Decl RlpcPs a -> Decl RlpcPs a
-{-# WARNING associate "temporarily undefined" #-}
+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

@@ -1,6 +1,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE UndecidableInstances #-}
 module Rlp.Parse.Types
     (
     -- * Trees That Grow
@@ -8,17 +9,19 @@ module Rlp.Parse.Types
 
     -- * 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
@@ -26,10 +29,13 @@ module Rlp.Parse.Types
     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
@@ -39,8 +45,8 @@ import Data.Functor.Classes
 import Data.HashMap.Strict          qualified as H
 import Data.Void
 import Data.Word                    (Word8)
-import Lens.Micro.TH
+import Data.Text                    qualified as T
-import Lens.Micro
+import Control.Lens                 hiding ((<<~))
 import Rlp.Syntax
 import Compiler.Types
 --------------------------------------------------------------------------------
@@ -49,26 +55,9 @@ import Compiler.Types
 
 data RlpcPs
 
-type instance XRec RlpcPs f = Located (f RlpcPs)
+type instance NameP RlpcPs = PsName
-type instance IdP RlpcPs = PsName
 
-type instance XFunD RlpcPs = ()
+type PsName = Located Text
-type instance XDataD RlpcPs = ()
-type instance XInfixD RlpcPs = ()
-type instance XTySigD RlpcPs = ()
-type instance XXDeclD RlpcPs = ()
-
-type instance XLetE RlpcPs = ()
-type instance XVarE RlpcPs = ()
-type instance XLamE RlpcPs = ()
-type instance XCaseE RlpcPs = ()
-type instance XIfE RlpcPs = ()
-type instance XAppE RlpcPs = ()
-type instance XLitE RlpcPs = ()
-type instance XParE RlpcPs = ()
-type instance XOAppE RlpcPs = ()
-
-type PsName = Text
 
 --------------------------------------------------------------------------------
 
@@ -106,19 +95,21 @@ data RlpToken
     -- literals
     = TokenLitInt Int
     -- identifiers
-    | TokenVarName Name
+    | TokenVarName Text
-    | TokenConName Name
+    | TokenConName Text
-    | TokenVarSym Name
+    | TokenVarSym Text
-    | TokenConSym Name
+    | TokenConSym Text
     -- reserved words
     | TokenData
     | TokenCase
     | TokenOf
     | TokenLet
+    | TokenLetrec
     | TokenIn
     | TokenInfixL
     | TokenInfixR
     | TokenInfix
+    | TokenForall
     -- reserved ops
     | TokenArrow
     | TokenPipe
@@ -139,12 +130,42 @@ data RlpToken
     | 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
@@ -183,15 +204,34 @@ data Layout = Explicit
 type OpTable = H.HashMap Name OpInfo
 type OpInfo = (Assoc, Int)
 
--- data WithLocation a = WithLocation [String] a
-
 data RlpParseError = RlpParErrOutOfBoundsPrecedence Int
                    | RlpParErrDuplicateInfixD Name
                    | RlpParErrLexical
-                   | RlpParErrUnexpectedToken
+                   | RlpParErrUnexpectedToken RlpToken [String]
-                   deriving (Eq, Ord, Show)
+                   | 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
 
 ----------------------------------------------------------------------------------
 
@@ -224,3 +264,34 @@ addFatalHere l e = P $ \st ->
             }
     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

@@ -1,244 +1,10 @@
--- recursion-schemes
-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable
-  , TemplateHaskell, TypeFamilies #-}
-{-# LANGUAGE OverloadedStrings, PatternSynonyms #-}
-{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}
-{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-}
 module Rlp.Syntax
-    (
+    ( module Rlp.Syntax.Backstage
-    -- * AST
+    , module Rlp.Syntax.Types
-      RlpProgram(..)
-    , Decl(..), Decl', RlpExpr(..), RlpExpr'
-    , Pat(..), Pat'
-    , Assoc(..)
-    , Lit(..), Lit'
-    , RlpType(..), RlpType'
-    , ConAlt(..)
-    , Binding(..), Binding'
-
-    -- * Trees That Grow boilerplate
-    -- ** Extension points
-    , IdP, XRec, UnXRec(..), MapXRec(..)
-    -- *** Decl
-    , XFunD, XTySigD, XInfixD, XDataD, XXDeclD
-    -- *** RlpExpr
-    , XLetE, XVarE, XLamE, XCaseE, XIfE, XAppE, XLitE
-    , XParE, XOAppE, XXRlpExprE
-    -- ** Pattern synonyms
-    -- *** Decl
-    , pattern FunD, pattern TySigD, pattern InfixD, pattern DataD
-    -- *** RlpExpr
-    , pattern LetE, pattern VarE, pattern LamE, pattern CaseE, pattern IfE
-    , pattern AppE, pattern LitE, pattern ParE, pattern OAppE
-    , pattern XRlpExprE
     )
     where
-----------------------------------------------------------------------------------
+--------------------------------------------------------------------------------
-import Data.Text                    (Text)
+import Rlp.Syntax.Backstage
-import Data.Text                    qualified as T
+import Rlp.Syntax.Types
-import Data.String                  (IsString(..))
-import Data.Functor.Foldable.TH     (makeBaseFunctor)
-import Data.Functor.Classes
-import Data.Kind                    (Type)
-import Lens.Micro
-import Lens.Micro.TH
-import Core.Syntax                  hiding (Lit, Type, Binding, Binding')
-import Core                         (HasRHS(..), HasLHS(..))
-----------------------------------------------------------------------------------
-
-data RlpModule p = RlpModule
-    { _rlpmodName       :: Text
-    , _rlpmodProgram    :: RlpProgram p
-    }
-
--- | dear god.
-type PhaseShow p =
-    ( Show (XRec p Pat), Show (XRec p RlpExpr)
-    , Show (XRec p Lit), Show (IdP p)
-    , Show (XRec p RlpType)
-    , Show (XRec p Binding)
-    )
-
-newtype RlpProgram p = RlpProgram [Decl' p]
-
-deriving instance (PhaseShow p, Show (XRec p Decl)) => Show (RlpProgram p)
-
-data RlpType p = FunConT
-               | FunT (RlpType' p) (RlpType' p)
-               | AppT (RlpType' p) (RlpType' p)
-               | VarT (IdP p)
-               | ConT (IdP p)
-
-type RlpType' p = XRec p RlpType
-
-deriving instance (PhaseShow p)
-                  => Show (RlpType p)
-
-data Decl p = FunD'   (XFunD p)    (IdP p) [Pat' p] (RlpExpr' p) (Maybe (Where p))
-            | TySigD' (XTySigD p)  [IdP p] (RlpType' p)
-            | DataD'  (XDataD p)   (IdP p) [IdP p] [ConAlt p]
-            | InfixD' (XInfixD p)  Assoc Int (IdP p)
-            | XDeclD' !(XXDeclD p)
-
-deriving instance
-    ( Show (XFunD p), Show (XTySigD p)
-    , Show (XDataD p), Show (XInfixD p)
-    , Show (XXDeclD p)
-    , PhaseShow p
-    ) 
-    => Show (Decl p)
-
-type family XFunD p
-type family XTySigD p
-type family XDataD p
-type family XInfixD p
-type family XXDeclD p
-
-pattern FunD   :: (XFunD p ~ ())
-               => (IdP p) -> [Pat' p] -> (RlpExpr' p) -> (Maybe (Where p))
-               -> Decl p
-pattern TySigD :: (XTySigD p ~ ()) => [IdP p] -> (RlpType' p) -> Decl p
-pattern DataD  :: (XDataD p ~ ()) => (IdP p) -> [IdP p] -> [ConAlt p] -> Decl p
-pattern InfixD :: (XInfixD p ~ ()) => Assoc -> Int -> (IdP p) -> Decl p
-pattern XDeclD :: (XXDeclD p ~ ()) => Decl p
-
-pattern FunD n as e wh = FunD' () n as e wh
-pattern TySigD ns t = TySigD' () ns t
-pattern DataD n as cs = DataD' () n as cs
-pattern InfixD a p n = InfixD' () a p n
-pattern XDeclD = XDeclD' ()
-
-type Decl' p = XRec p Decl
-
-data Assoc = InfixL
-           | InfixR
-           | Infix
-           deriving (Show)
-
-data ConAlt p = ConAlt (IdP p) [RlpType' p]
-
-deriving instance (Show (IdP p), Show (XRec p RlpType)) => Show (ConAlt p)
-
-data RlpExpr p = LetE'  (XLetE p) [Binding' p] (RlpExpr' p)
-               | VarE'  (XVarE p) (IdP p)
-               | LamE'  (XLamE p) [Pat p] (RlpExpr' p)
-               | CaseE' (XCaseE p) (RlpExpr' p) [(Alt p, Where p)]
-               | IfE'   (XIfE p) (RlpExpr' p) (RlpExpr' p) (RlpExpr' p)
-               | AppE'  (XAppE p) (RlpExpr' p) (RlpExpr' p)
-               | LitE'  (XLitE p) (Lit p)
-               | ParE'  (XParE p) (RlpExpr' p)
-               | OAppE' (XOAppE p) (IdP p) (RlpExpr' p) (RlpExpr' p)
-               | XRlpExprE' !(XXRlpExprE p)
-
-type family XLetE p
-type family XVarE p
-type family XLamE p
-type family XCaseE p
-type family XIfE p
-type family XAppE p
-type family XLitE p
-type family XParE p
-type family XOAppE p
-type family XXRlpExprE p
-
-pattern LetE :: (XLetE p ~ ()) => [Binding' p] -> RlpExpr' p -> RlpExpr p
-pattern VarE :: (XVarE p ~ ()) => IdP p -> RlpExpr p
-pattern LamE :: (XLamE p ~ ()) => [Pat p] -> RlpExpr' p -> RlpExpr p
-pattern CaseE :: (XCaseE p ~ ()) => RlpExpr' p -> [(Alt p, Where p)] -> RlpExpr p
-pattern IfE :: (XIfE p ~ ()) => RlpExpr' p -> RlpExpr' p -> RlpExpr' p -> RlpExpr p
-pattern AppE :: (XAppE p ~ ()) => RlpExpr' p -> RlpExpr' p -> RlpExpr p
-pattern LitE :: (XLitE p ~ ()) => Lit p -> RlpExpr p
-pattern ParE :: (XParE p ~ ()) => RlpExpr' p -> RlpExpr p
-pattern OAppE :: (XOAppE p ~ ()) => IdP p -> RlpExpr' p -> RlpExpr' p -> RlpExpr p
-pattern XRlpExprE :: (XXRlpExprE p ~ ()) => RlpExpr p
-
-pattern LetE bs e = LetE' () bs e
-pattern VarE n = VarE' () n
-pattern LamE as e = LamE' () as e
-pattern CaseE e as = CaseE' () e as
-pattern IfE c a b = IfE' () c a b
-pattern AppE f x = AppE' () f x
-pattern LitE l = LitE' () l
-pattern ParE e = ParE' () e
-pattern OAppE n a b = OAppE' () n a b
-pattern XRlpExprE = XRlpExprE' ()
-
-deriving instance
-    ( Show (XLetE p), Show (XVarE p), Show (XLamE p)
-    , Show (XCaseE p), Show (XIfE p), Show (XAppE p)
-    , Show (XLitE p), Show (XParE p), Show (XOAppE p)
-    , Show (XXRlpExprE p)
-    , PhaseShow p
-    ) => Show (RlpExpr p)
-
-type RlpExpr' p = XRec p RlpExpr
-
-class UnXRec p where
-    unXRec :: XRec p f -> f p
-
-class MapXRec p where
-    mapXRec :: (f p -> f' p') -> XRec p f -> XRec p' f'
-
-type family XRec p (f :: Type -> Type) = (r :: Type) | r -> p f
-
-type family IdP p
-
-type Where p = [Binding p]
-
--- do we want guards?
-data Alt p = AltA (Pat' p) (RlpExpr' p)
-
-deriving instance (PhaseShow p) => Show (Alt p)
-
-data Binding p = PatB (Pat' p) (RlpExpr' p)
-               | FunB (IdP p) [Pat' p] (RlpExpr' p)
-
-type Binding' p = XRec p Binding
-
-deriving instance (Show (XRec p Pat), Show (XRec p RlpExpr), Show (IdP p)
-                  ) => Show (Binding p)
-
-data Pat p = VarP (IdP p)
-           | LitP (Lit' p)
-           | ConP (IdP p) [Pat' p]
-
-deriving instance (PhaseShow p) => Show (Pat p)
-
-type Pat' p = XRec p Pat
-
-data Lit p = IntL Int
-           | CharL Char
-           | ListL [RlpExpr' p]
-
-deriving instance (PhaseShow p) => Show (Lit p)
-
-type Lit' p = XRec p Lit
-
--- instance HasLHS Alt Alt Pat Pat where
---     _lhs = lens
---         (\ (AltA p _) -> p)
---         (\ (AltA _ e) p' -> AltA p' e)
-
--- instance HasRHS Alt Alt RlpExpr RlpExpr where
---     _rhs = lens
---         (\ (AltA _ e) -> e)
---         (\ (AltA p _) e' -> AltA p e')
-
-makeBaseFunctor ''RlpExpr
-
--- showsTernaryWith :: (Int -> x -> ShowS)
---                  -> (Int -> y -> ShowS)
---                  -> (Int -> z -> ShowS)
---                  -> String -> Int
---                  -> x -> y -> z
---                  -> ShowS
--- showsTernaryWith sa sb sc name p a b c = showParen (p > 10)
---     $ showString name
---     . showChar ' ' . sa 11 a 
---     . showChar ' ' . sb 11 b
---     . showChar ' ' . sc 11 c
-
 --------------------------------------------------------------------------------
 
-makeLenses ''RlpModule
-

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 Control.Lens
-import Lens.Micro.TH
 import Data.Pretty
 import Data.Heap
 import Core.Examples

tst/Arith.hs

@@ -41,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

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