system F

HasLocation

.ghci

@@ -1,6 +1,5 @@
 -- repl extensions
 :set -XOverloadedStrings
-:set -XQuasiQuotes
 
 --------------------------------------------------------------------------------
 

Makefile_happysrcs

@@ -5,20 +5,16 @@ ALEX = alex
 ALEX_OPTS = -g
 
 SRC = src
-CABAL_BUILD = $(shell ./find-build.clj)
+CABAL_BUILD = $(shell ./find-build.cl)
 
 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

@@ -0,0 +1,165 @@
+# rl'
+
+`rlp` (ruelang') will be a lazily-evaluated purely-functional language heavily
+imitating Haskell.
+
+### Architecture
+
+![rlpc architecture diagram](/rlpc.drawio.svg)
+
+### 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
+
+#### TLDR
+
+```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
+```
+
+#### Options
+
+```sh
+Usage: rlpc [-l|--log FILE] [-d DEBUG FLAG] [-f COMPILATION FLAG] 
+            [-e|--evaluator gm|ti] [--heap-trigger INT] [-x|--language rlp|core]
+            FILES...
+```
+
+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
+
+### Potential Features
+Listed in order of importance.
+- [x] ADTs
+- [x] First-class functions
+- [x] Higher-kinded types
+- [ ] Typeclasses
+- [x] Parametric polymorphism
+- [x] Hindley-Milner type inference
+- [ ] Newtype coercion
+- [ ] Parallelism
+
+### Milestones
+(This list is incomplete.)
+
+Items are marked off not as they are 100% implemented, but rather once I
+consider them stable enough that completion is soley a matter of getting
+around to it -- no tough design decisions, theorising, etc. remain. For
+example, as of writing this, the rl' frontend parser is not fully featured,
+yet it is marked off on this list; finishing it would require cranking out
+the remaining grammatical rules, and no work on complex tasks like layout
+parsing remains.
+
+- [ ] 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)
+    - [x] Core linter (Type-checker)
+    - [ ] Core2Core pass (optimisations and misc. preprocessing)
+        - [x] GM prep
+            - [x] Non-strict case-floating
+        - [ ] Let-floating
+        - [ ] TCO
+        - [ ] DCE
+- [ ] Frontend
+    - [x] High-level language
+        - [x] AST
+        - [x] Lexer
+        - [x] Parser
+    - [x] 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
+
+### ~~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
+
+### March Release Plan
+- [ ] Tests
+    - [ ] rl' parser
+    - [ ] rl' lexer
+- [ ] Ditch TTG in favour of a simpler AST focusing on extendability via Fix, Free, 
+  Cofree, etc. rather than boilerplate-heavy type families
+
+### Indefinite Release Plan
+
+This list is more concrete than the milestones, but likely further in the future
+than the other release plans.
+
+- [ ] Overall codebase cleaning
+    - [ ] Complete all TODOs
+    - [ ] Replace mtl with effectful
+- [ ] rl' type-checker
+- [ ] Stable rl' to Core
+- [ ] Core polish
+    - [ ] Better, stable parser
+    - [ ] Better, stable lexer
+    - [ ] Less hacky handling of named data
+    - [ ] Less hacky pragmas
+- [ ] Choose a target. LLVM, JS, C, and WASM are currently top contenders
+- [ ] https://proglangdesign.net/wiki/challenges
+

README.org

@@ -1,223 +0,0 @@
-#+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

@@ -10,17 +10,15 @@ 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)
+    withSource f (lexCoreR >=> parseCoreProgR >=> evalProgR)
 
 driverSource :: T.Text -> RLPCIO ()
-driverSource = lexCoreR >=> parseCoreProgR
+driverSource = lexCoreR >=> parseCoreProgR >=> evalProgR >=> printRes
-           >=> lintCoreProgR >=> evalProgR >=> printRes
     where
         printRes = liftIO . print . view _1
 

app/Main.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Main where
 ----------------------------------------------------------------------------------
-import Control.Lens             hiding (argument)
 import Compiler.RLPC
 import Compiler.RlpcError
 import Control.Exception
@@ -24,7 +23,6 @@ import Control.Lens.Combinators hiding (argument)
 
 import CoreDriver               qualified
 import RlpDriver                qualified
-import Server                   qualified
 ----------------------------------------------------------------------------------
 
 optParser :: ParserInfo RLPCOptions
@@ -76,11 +74,7 @@ options = RLPCOptions
         <> metavar "rlp|core"
         <> help "the language to be compiled -- see README"
         )
-    <*> switch
+    <*> some (argument str $ metavar "FILES...")
-        (  long "server"
-        <> short 's'
-        )
-    <*> many (argument str $ metavar "FILES...")
     where
         infixr 9 #
         f # x = f x
@@ -113,9 +107,7 @@ mmany v = liftA2 (<>) v (mmany v)
 main :: IO ()
 main = do
     opts <- execParser optParser
-    if opts ^. rlpcServer
+    void $ evalRLPCIO opts dispatch
-    then Server.server
-    else void $ evalRLPCIO opts dispatch
 
 dispatch :: RLPCIO ()
 dispatch = getLang >>= \case

app/RlpDriver.hs

@@ -15,5 +15,5 @@ import GM
 
 driver :: RLPCIO ()
 driver = forFiles_ $ \f ->
-    withSource f (parseRlpProgR >=> undefined >=> desugarRlpProgR >=> evalProgR)
+    withSource f (parseRlpProgR >=> desugarRlpProgR >=> evalProgR)
 

app/Server.hs

@@ -1,115 +0,0 @@
-{-# 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/post-mortem.rst

@@ -1,6 +0,0 @@
-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.
-

find-build.cl

@@ -0,0 +1,8 @@
+#!/usr/bin/env sbcl --script
+
+(let* ((paths (directory "dist-newstyle/build/*/*/rlp-*/build/"))
+       (n (length paths)))
+  (cond ((< 1 n) (error ">1 build directories found. run `cabal clean`."))
+        ((< n 1) (error "no build directories found. this shouldn't happen lol"))
+        (t       (format t "~A" (car paths)))))
+

find-build.clj

@@ -1,13 +0,0 @@
-#!/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,7 +16,6 @@ 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
@@ -33,11 +32,6 @@ 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
@@ -56,25 +50,23 @@ library
                     , 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.21
+    build-depends:    base >=4.17 && <4.20
                     -- required for happy
                     , array >= 0.5.5 && < 0.6
                     , containers >= 0.6.7 && < 0.7
-                    , template-haskell >= 2.20.0 && < 2.23
+                    , template-haskell >= 2.20.0 && < 2.21
                     , pretty >= 1.1.3 && < 1.2
                     , data-default >= 0.7.1 && < 0.8
                     , data-default-class >= 0.1.2 && < 0.2
                     , hashable >= 1.4.3 && < 1.5
                     , mtl >= 2.3.1 && < 2.4
-                    , text >= 2.0.2 && < 2.3
+                    , text >= 2.0.2 && < 2.2
                     , unordered-containers >= 0.2.20 && < 0.3
                     , recursion-schemes >= 5.2.2 && < 5.3
                     , data-fix >= 0.3.2 && < 0.4
@@ -89,8 +81,6 @@ library
                     , 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
@@ -111,7 +101,6 @@ executable rlpc
     main-is:          Main.hs
     other-modules:    RlpDriver
                     , CoreDriver
-                    , Server
 
     build-depends: base >=4.17.0.0 && <4.20.0.0
                  , rlp
@@ -119,7 +108,7 @@ executable rlpc
                  , mtl >= 2.3.1 && < 2.4
                  , unordered-containers >= 0.2.20 && < 0.3
                  , lens >=5.2.3 && <6.0
-                 , text >= 2.0.2 && < 2.3
+                 , text >= 2.0.2 && < 2.2
 
     hs-source-dirs:   app
     default-language: GHC2021

rlpc.drawio

@@ -1,6 +1,6 @@
-<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">
+<mxfile host="app.diagrams.net" modified="2024-02-08T07:33:52.268Z" agent="Mozilla/5.0 (Macintosh; Intel Mac OS X 10.15; rv:122.0) Gecko/20100101 Firefox/122.0" etag="_2ex2NLQLCDMU70EmKFT" version="23.0.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">
+    <mxGraphModel dx="1629" dy="2189" 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" />
@@ -22,13 +22,13 @@
         <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">
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-58" value="Rlp.Parse&lt;br&gt;&lt;div&gt;(src/Rlp/Parse.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">
+        <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" edge="1" source="l7NxJpuHm0Jx_7flO9iA-59">
           <mxGeometry relative="1" as="geometry">
             <mxPoint x="111.49666666666668" y="147.72" as="sourcePoint" />
             <mxPoint x="69.26631355932203" y="83.84879190161169" as="targetPoint" />
@@ -48,18 +48,18 @@
             <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">
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-77" value="&lt;div&gt;RlpProgram&#39; RlpcPs&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">
+        <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;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-56" source="l7NxJpuHm0Jx_7flO9iA-58" target="l7NxJpuHm0Jx_7flO9iA-59">
           <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">
+        <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;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-56">
           <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">
@@ -68,195 +68,185 @@
         <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">
+        <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;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-69">
           <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">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-6" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
-          <mxGeometry x="904" y="68.42105263157895" width="244.8600518134714" height="697.8947368421053" as="geometry" />
+          <mxGeometry x="904" y="68.42105263157895" width="186.6" 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">
+        <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;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
           <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">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-8" value="GM" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
-          <mxGeometry x="10" y="70" width="220" height="260.78" as="geometry" />
+          <mxGeometry x="9.568013810372213" y="356.90796215152363" width="167.46559322033886" height="82.98740890928475" 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">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-9" value="TM" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
-          <mxGeometry x="26" y="91.58" width="184" height="37.03" as="geometry" />
+          <mxGeometry x="9.562261652542377" y="263.9548629430177" width="167.46559322033886" height="82.98740890928475" 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">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-10" value="TIM" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
-          <mxGeometry x="26" y="211.58" width="184" height="37.03" as="geometry" />
+          <mxGeometry x="9.56226165254238" y="168.9311122835313" width="167.46559322033886" height="82.98740890928475" 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">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-11" value="STG" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
-          <mxGeometry width="50" height="50" relative="1" as="geometry">
+          <mxGeometry x="9.56720338983051" y="73.90736162404495" width="167.46559322033886" height="82.98740890928475" 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">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-12" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
-          <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">
+        <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;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-12">
           <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">
+        <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;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-12">
           <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">
+        <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;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-12">
           <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">
+        <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;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-12">
           <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">
+        <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;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-12">
           <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">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-20" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
+          <mxGeometry x="1240" y="68.42105263157895" width="186.6" height="697.8947368421053" as="geometry" />
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-21" value="&lt;font face=&quot;Helvetica&quot;&gt;Some target&lt;br&gt;&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-20">
+          <mxGeometry width="186.6" height="107.07065060420568" 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;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-2" source="MMc0v0DIyy0xya0iXp__-1" target="MMc0v0DIyy0xya0iXp__-12">
           <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">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-28" value="&lt;font face=&quot;Courier New&quot;&gt;Program&#39;&lt;/font&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];" vertex="1" connectable="0" parent="MMc0v0DIyy0xya0iXp__-27">
           <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">
+        <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;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-2" source="MMc0v0DIyy0xya0iXp__-12" target="MMc0v0DIyy0xya0iXp__-6">
           <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">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-31" value="&lt;font face=&quot;Courier New&quot;&gt;Program&#39;&lt;/font&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];" vertex="1" connectable="0" parent="MMc0v0DIyy0xya0iXp__-30">
           <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">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-32" value="" 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;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-2" source="MMc0v0DIyy0xya0iXp__-6" target="MMc0v0DIyy0xya0iXp__-20">
+          <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__-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=[];" vertex="1" connectable="0" parent="MMc0v0DIyy0xya0iXp__-32">
+          <mxGeometry x="0.0406" y="1" relative="1" as="geometry">
+            <mxPoint as="offset" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-35" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
           <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">
+        <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;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-35">
           <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">
+        <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;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-35">
           <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">
+        <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;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-35">
           <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">
+        <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;" edge="1" parent="MMc0v0DIyy0xya0iXp__-35" source="MMc0v0DIyy0xya0iXp__-41" target="MMc0v0DIyy0xya0iXp__-42">
           <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">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-51" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
           <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">
+        <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;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-51">
           <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">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-46" value="(currently unimplemented)" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-72">
           <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">
+        <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;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-46">
           <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">
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-80" value="" style="endArrow=classic;html=1;rounded=0;" parent="l7NxJpuHm0Jx_7flO9iA-72" source="l7NxJpuHm0Jx_7flO9iA-74" 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">
+        <mxCell id="l7NxJpuHm0Jx_7flO9iA-81" value="&lt;font face=&quot;Courier New&quot;&gt;RlpProgram&#39; RlpcPs&lt;br&gt;&lt;/font&gt;" style="edgeLabel;resizable=0;html=1;align=center;verticalAlign=middle;" parent="l7NxJpuHm0Jx_7flO9iA-80" connectable="0" vertex="1">
+          <mxGeometry relative="1" as="geometry">
+            <mxPoint x="6" as="offset" />
+          </mxGeometry>
+        </mxCell>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-49" value="" style="endArrow=classic;html=1;rounded=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-72" source="MMc0v0DIyy0xya0iXp__-46" target="l7NxJpuHm0Jx_7flO9iA-69">
           <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">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-50" value="&lt;font face=&quot;Courier New&quot;&gt;RlpProgram&#39; RlpcTc&lt;/font&gt;" style="edgeLabel;resizable=0;html=1;align=center;verticalAlign=middle;" connectable="0" vertex="1" parent="MMc0v0DIyy0xya0iXp__-49">
           <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">
+        <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;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-72">
           <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">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-58" value="" style="endArrow=classic;html=1;rounded=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-72" source="MMc0v0DIyy0xya0iXp__-42" target="MMc0v0DIyy0xya0iXp__-57">
           <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">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-59" value="Program&#39;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];fontFamily=Courier New;" vertex="1" connectable="0" parent="MMc0v0DIyy0xya0iXp__-58">
           <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">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-60" value="" style="endArrow=classic;html=1;rounded=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-72" source="MMc0v0DIyy0xya0iXp__-57" target="MMc0v0DIyy0xya0iXp__-15">
           <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">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-61" value="Program&#39;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];fontFamily=Courier New;" vertex="1" connectable="0" parent="MMc0v0DIyy0xya0iXp__-60">
           <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">
+        <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;" vertex="1" parent="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">
+        <mxCell id="MMc0v0DIyy0xya0iXp__-29" value="&lt;div&gt;&lt;font face=&quot;Helvetica&quot;&gt;???&lt;/font&gt;&lt;/div&gt;" style="rounded=0;whiteSpace=wrap;html=1;fillColor=#fff2cc;strokeColor=#d6b656;fontFamily=Courier New;" vertex="1" parent="1">
+          <mxGeometry x="1420" y="730" 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;" edge="1" parent="1" source="MMc0v0DIyy0xya0iXp__-26" target="MMc0v0DIyy0xya0iXp__-41">
           <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>
+        <mxCell id="MMc0v0DIyy0xya0iXp__-62" value="" style="endArrow=classic;html=1;rounded=0;" edge="1" parent="1" source="MMc0v0DIyy0xya0iXp__-20" target="MMc0v0DIyy0xya0iXp__-29">
+          <mxGeometry width="50" height="50" relative="1" as="geometry">
+            <mxPoint x="1060" y="650" as="sourcePoint" />
+            <mxPoint x="1110" y="600" as="targetPoint" />
+          </mxGeometry>
+        </mxCell>
       </root>
     </mxGraphModel>
   </diagram>

src/Compiler/JustRun.hs

@@ -10,10 +10,8 @@ types such as @RLPC@ or @Text@.
 module Compiler.JustRun
     ( justLexCore
     , justParseCore
-    , justParseRlp
     , justTypeCheckCore
     , justHdbg
-    , justInferRlp
     , makeItPretty, makeItPretty'
     )
     where
@@ -31,19 +29,15 @@ import Data.Text                        qualified as T
 import Data.Function                    ((&))
 import System.IO
 import GM
+import Rlp.Parse
 import Rlp2Core
 import Data.Pretty
-
-import Rlp.AltParse
-import Rlp.AltSyntax                    qualified as Rlp
-import Rlp.HindleyMilner
 ----------------------------------------------------------------------------------
 
 justHdbg :: String -> IO GmState
-justHdbg = undefined
+justHdbg s = do
--- justHdbg s = do
+    p <- evalRLPCIO def (parseRlpProgR >=> desugarRlpProgR $ T.pack s)
---     p <- evalRLPCIO def (parseRlpProgR >=> desugarRlpProgR $ T.pack s)
+    withFile "/tmp/t.log" WriteMode $ hdbgProg p
---     withFile "/tmp/t.log" WriteMode $ hdbgProg p
 
 justLexCore :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
 justLexCore s = lexCoreR (T.pack s)
@@ -55,29 +49,16 @@ justParseCore s = parse (T.pack s)
                 & rlpcToEither
     where parse = lexCoreR @Identity >=> parseCoreProgR
 
-justParseRlp :: String
-             -> Either [MsgEnvelope RlpcError]
-                       (Rlp.Program Name (Rlp.RlpExpr Name))
-justParseRlp s = parse (T.pack s)
-               & rlpcToEither
-    where parse = parseRlpProgR @Identity
-
 justTypeCheckCore :: String -> Either [MsgEnvelope RlpcError] Program'
 justTypeCheckCore s = typechk (T.pack s)
                     & rlpcToEither
     where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR
 
-justInferRlp :: String
+makeItPretty :: (Pretty a) => Either e a -> Either e Doc
-              -> Either [MsgEnvelope RlpcError]
+makeItPretty = fmap pretty
-                  (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' :: (Pretty (WithTerseBinds a)) => Either e a -> Either e Doc
-makeItPretty = fmap out
+makeItPretty' = fmap (pretty . WithTerseBinds)
-
-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

src/Compiler/RLPC.hs

@@ -26,9 +26,8 @@ module Compiler.RLPC
     , DebugFlag(..), CompilerFlag(..)
     -- ** Lenses
     , rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage
-    , rlpcServer
     -- * Misc. MTL-style functions
-    , liftErrorful, liftEither, liftMaybe, hoistRlpcT
+    , liftErrorful, liftMaybe, hoistRlpcT
     -- * Misc. Rlpc Monad -related types
     , RLPCOptions(RLPCOptions), IsRlpcError(..), RlpcError(..)
     , MsgEnvelope(..), Severity(..)
@@ -55,7 +54,6 @@ 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
@@ -65,6 +63,7 @@ import Data.Text                qualified as T
 import Data.Text.IO             qualified as T
 import System.IO
 import Text.ANSI                qualified as Ansi
+import Text.PrettyPrint         hiding ((<>))
 import Control.Lens
 import Data.Text.Lens           (packed, unpacked, IsText)
 import System.Exit
@@ -112,13 +111,6 @@ 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 ->
@@ -131,7 +123,6 @@ data RLPCOptions = RLPCOptions
     , _rlpcEvaluator   :: Evaluator
     , _rlpcHeapTrigger :: Int
     , _rlpcLanguage    :: Maybe Language
-    , _rlpcServer      :: Bool
     , _rlpcInputFiles  :: [FilePath]
     }
     deriving Show
@@ -152,7 +143,6 @@ instance Default RLPCOptions where
         , _rlpcEvaluator = EvaluatorGM
         , _rlpcHeapTrigger = 200
         , _rlpcInputFiles = []
-        , _rlpcServer = False
         , _rlpcLanguage = Nothing
         }
 
@@ -213,7 +203,7 @@ renderRlpcErrs opts = (if don'tBother then id else filter byTag)
 
 prettyRlpcMsg :: MsgEnvelope RlpcError -> String
 prettyRlpcMsg m@(view msgSeverity -> SevDebug _) = prettyRlpcDebugMsg m
-prettyRlpcMsg m                                  = show $ docRlpcErr m
+prettyRlpcMsg m                                  = render $ docRlpcErr m
 
 prettyRlpcDebugMsg :: MsgEnvelope RlpcError -> String
 prettyRlpcDebugMsg msg =
@@ -223,10 +213,10 @@ prettyRlpcDebugMsg msg =
         Text ts = msg ^. msgDiagnostic
         SevDebug tag = msg ^. msgSeverity
 
-docRlpcErr :: MsgEnvelope RlpcError -> Doc ann
+docRlpcErr :: MsgEnvelope RlpcError -> Doc
-docRlpcErr msg = vcat [ header
+docRlpcErr msg = header
-                      , nest 2 bullets
+                 $$ nest 2 bullets
-                      , source ]
+                 $$ source
     where
         source = vcat $ zipWith (<+>) rule srclines
             where
@@ -241,10 +231,11 @@ docRlpcErr msg = vcat [ header
                         <> errorColour "error" <> msgColour ":"
 
         bullets = let Text ts = msg ^. msgDiagnostic
-                  in vcat $ ("•" <>) . hang 2 . ttext . msgColour <$> ts
+                  in vcat $ hang "•" 2 . ttext . msgColour <$> ts
 
         msgColour = Ansi.white . Ansi.bold
         errorColour = Ansi.red . Ansi.bold
+        ttext = text . T.unpack
         tshow :: (Show a) => a -> Text
         tshow = T.pack . show
 

src/Compiler/RlpcError.hs

@@ -24,11 +24,8 @@ import Control.Monad.Errorful
 import Data.Text                (Text)
 import Data.Text                qualified as T
 import GHC.Exts                 (IsString(..))
-import GHC.Generics
+import Control.Lens
-import Control.Lens             hiding ((.=))
 import Compiler.Types
-
-import Data.Aeson
 ----------------------------------------------------------------------------------
 
 data MsgEnvelope e = MsgEnvelope
@@ -38,17 +35,8 @@ 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, Generic)
+               deriving Show
-    deriving (ToJSON)
-        via Generically [Text]
 
 instance IsString RlpcError where
     fromString = Text . pure . T.pack
@@ -62,9 +50,7 @@ instance IsRlpcError RlpcError where
 data Severity = SevWarning
               | SevError
               | SevDebug Text -- ^ Tag
-              deriving (Show, Generic)
+              deriving Show
-              deriving (ToJSON)
-                via Generically Severity
 
 makeLenses ''MsgEnvelope
 

src/Compiler/Types.hs

@@ -27,42 +27,39 @@ import Language.Haskell.TH.Syntax   (Lift)
 
 import Control.Comonad
 import Control.Comonad.Cofree
+import Control.Comonad.Trans.Cofree qualified as Trans.Cofree
+import Control.Comonad.Trans.Cofree (CofreeF)
 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 Control.Lens                 hiding ((<<~), (:<), (.=))
 
 import Data.List.NonEmpty           (NonEmpty)
 import Data.Function                (on)
-import Misc.CofreeF
 --------------------------------------------------------------------------------
 
 -- | Token wrapped with a span (line, column, absolute, length)
 data Located a = Located SrcSpan a
     deriving (Show, Lift, Functor)
 
-instance ToJSON SrcSpan where
+data Floc f = Floc SrcSpan (f (Floc f))
-    toJSON (SrcSpan l c a s) = object
+
-        [ "line" .= l
+pattern (:<$) :: a -> f b -> Trans.Cofree.CofreeF f a b
-        , "column" .= c
+pattern a :<$ b = a Trans.Cofree.:< b
-        , "abs" .= a
-        , "length" .= s]
 
 (<~>) :: a -> b -> SrcSpan
 (<~>) = undefined
 
 infixl 5 <~>
 
-(~>) :: (CanGet k, CanSet k', HasLocation k a, HasLocation k' b)
+-- (~>) :: (CanGet k, CanSet k', HasLocation k a, HasLocation k' b)
-     => a -> b -> b
+--      => a -> b -> b
-a ~> b = b & fromSet getSetLocation .~ (a ^. fromGet getSetLocation)
+-- a ~> b = 
--- (~>) = undefined
+(~>) = undefined
 
 infixl 4 ~>
 
@@ -100,15 +97,15 @@ data SrcSpan = SrcSpan
     !Int -- ^ Length
     deriving (Show, Eq, Lift)
 
-_SrcSpan :: Iso' SrcSpan (Int, Int, Int, Int)
+tupling :: Iso' SrcSpan (Int, Int, Int, Int)
-_SrcSpan = iso (\ (SrcSpan a b c d) -> (a,b,c,d))
+tupling = 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
+srcSpanLine = tupling . _1
-srcSpanColumn = _SrcSpan . _2
+srcSpanColumn = tupling . _2
-srcSpanAbs = _SrcSpan . _3
+srcSpanAbs = tupling . _3
-srcSpanLen = _SrcSpan . _4
+srcSpanLen = tupling . _4
 
 -- | debug tool
 nolo :: a -> Located a
@@ -231,4 +228,3 @@ lochead afs (Located ss fss) = ss :< unwrap (lochead afs $ Located ss fss)
 --------------------------------------------------------------------------------
 
 makePrisms ''Located
-

src/Control/Monad/Errorful.hs

@@ -14,9 +14,7 @@ module Control.Monad.Errorful
     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
@@ -41,15 +39,10 @@ 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)
@@ -91,22 +84,4 @@ hoistErrorfulT nt (ErrorfulT m) = ErrorfulT (nt m)
 instance (Monad m, MonadErrorful e m) => MonadErrorful e (ReaderT r m) where
     addWound = lift . addWound
     addFatal = lift . addFatal
-    bleedOut = mapReaderT bleedOut
-
-instance (Monad m, MonadState s m) => MonadState s (ErrorfulT e m) where
-    state = lift . state
-
-instance (Monoid w, Monad m, MonadWriter w m) => MonadWriter w (ErrorfulT e m) where
-    tell = lift . tell
-    listen (ErrorfulT m) = ErrorfulT $ listen m <&> \ ((ma,es),w) ->
-        ((,w) <$> ma, es)
-    pass (ErrorfulT m) = undefined
-
-instance (Monad m, MonadReader r m) => MonadReader r (ErrorfulT e m) where
-    ask      = lift ask
-    local rr = hoistErrorfulT (local rr)
-
-instance (Monoid w, Monad m, MonadAccum w m)
-      => MonadAccum w (ErrorfulT e m) where
-    accum = lift . accum
 

src/Core/HindleyMilner.hs

@@ -16,9 +16,22 @@ module Core.HindleyMilner
     )
     where
 ----------------------------------------------------------------------------------
-import Compiler.RLPC
+import Control.Lens             hiding (Context', Context)
+import Data.Maybe               (fromMaybe)
 import Data.Text                qualified as T
+import Data.Pretty              (rpretty)
+import Data.HashMap.Strict      qualified as H
+import Data.Foldable            (traverse_)
+import Data.Functor
+import Data.Functor.Identity
+import Compiler.RLPC
+import Compiler.Types
+import Compiler.RlpcError
+import Control.Monad            (foldM, void, forM)
 import Control.Monad.Errorful
+import Control.Monad.State
+import Control.Monad.Utils      (mapAccumLM, generalise)
+import Text.Printf
 import Core.Syntax
 ----------------------------------------------------------------------------------
 
@@ -47,7 +60,21 @@ data TypeError
     deriving (Show, Eq)
 
 instance IsRlpcError TypeError where
-    liftRlpcError = undefined
+    liftRlpcError = \case
+        -- todo: use anti-parser instead of show
+        TyErrCouldNotUnify t u -> Text
+            [ T.pack $ printf "Could not match type `%s` with `%s`."
+                              (rpretty @String t) (rpretty @String u)
+            , "Expected: " <> rpretty t
+            , "Got: " <> rpretty u
+            ]
+        TyErrUntypedVariable n -> Text
+            [ "Untyped (likely undefined) variable `" <> n <> "`"
+            ]
+        TyErrRecursiveType t x -> Text
+            [ T.pack $ printf "Recursive type: `%s' occurs in `%s'"
+                              (rpretty @String t) (rpretty @String x)
+            ]
 
 -- | Synonym for @Errorful [TypeError]@. This means an @HMError@ action may
 -- throw any number of fatal or nonfatal errors. Run with @runErrorful@.

src/Core/Syntax.hs

@@ -29,15 +29,14 @@ module Core.Syntax
     , pattern Con, pattern Var, pattern App, pattern Lam, pattern Let
     , pattern Case, pattern Type, pattern Lit
 
-    -- * pretty-printing
+    -- * Pretty-printing
-    , Out(out), WithTerseBinds(..)
+    , Pretty(pretty), WithTerseBinds(..)
 
     -- * Optics
-    , HasArrowSyntax(..)
+    , programScDefs, programTypeSigs, programDataTags
-    , programScDefs, programTypeSigs, programDataTags, programTyCons
+    , formalising
-    , formalising, lambdaLifting
     , HasRHS(_rhs), HasLHS(_lhs)
-    , _BindingF, _MkVar, _ScDef
+    , _BindingF, _MkVar
     -- ** Classy optics
     , HasBinders(..), HasArrowStops(..), HasApplicants1(..), HasApplicants(..)
     )
@@ -51,7 +50,6 @@ 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
@@ -59,9 +57,7 @@ import Data.Functor.Classes
 import Data.Text                    qualified as T
 import Data.Char
 import Data.These
-import Data.Aeson
+import GHC.Generics                 (Generic, Generically(..))
-import GHC.Generics                 ( Generic, Generic1
-                                    , Generically(..), Generically1(..))
 import Text.Show.Deriving
 import Data.Eq.Deriving
 import Data.Kind                    qualified
@@ -112,7 +108,7 @@ type Kind = Type
 --     deriving (Eq, Show, Lift)
 
 data Var = MkVar Name Type
-    deriving (Eq, Show, Lift, Generic)
+    deriving (Eq, Show, Lift)
 
 pattern (:^) :: Name -> Type -> Var
 pattern n :^ t = MkVar n t
@@ -147,22 +143,9 @@ pattern Lit t = Fix (LitF t)
 pattern TyInt :: Type
 pattern TyInt = TyCon "Int#"
 
-class HasArrowSyntax s a b | s -> a b where
-    _arrowSyntax :: Prism' s (a, b)
-
-instance HasArrowSyntax Type Type Type where
-    _arrowSyntax = prism make unmake where
-        make (s,t) = TyFun `TyApp` s `TyApp` t
-
-        unmake (TyFun `TyApp` s `TyApp` t) = Right (s,t)
-        unmake s                           = Left s
-
 infixr 1 :->
-pattern (:->) :: HasArrowSyntax s a b
+pattern (:->) :: Type -> Type -> Type
-              => a -> b -> s
+pattern a :-> b = TyApp (TyApp TyFun a) b
--- pattern (:->) :: Type -> Type -> Type
-pattern a :-> b <- (preview _arrowSyntax -> Just (a, b))
-    where a :-> b = _arrowSyntax # (a, b)
 
 data BindingF b a = BindingF b (ExprF b a)
     deriving (Functor, Foldable, Traversable)
@@ -233,8 +216,6 @@ data Program b = Program
     , _programTypeSigs :: HashMap b Type
     , _programDataTags :: HashMap Name (Tag, Int)
     -- ^ map constructors to their tag and arity
-    , _programTyCons   :: HashMap Name Kind
-    -- ^ map type constructors to their kind
     }
     deriving (Generic)
     deriving (Semigroup, Monoid)
@@ -261,15 +242,6 @@ type ScDef' = ScDef Name
 -- instance IsString (Expr b) where
 --     fromString = Var . fromString
 
-lambdaLifting :: Iso (ScDef b) (ScDef b') (b, Expr b) (b', Expr b')
-lambdaLifting = iso sa bt where
-    sa (ScDef n [] e) = (n, e) where
-    sa (ScDef n as e) = (n, e') where
-        e' = Lam as e
-
-    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
@@ -338,11 +310,11 @@ instance MakeTerse Var where
     type AsTerse Var = Name
     asTerse (MkVar n _) = n
 
-instance (Hashable b, Out b, Out (AsTerse b), MakeTerse b)
+instance (Hashable b, Pretty b, Pretty (AsTerse b), MakeTerse b)
-      => Out (WithTerseBinds (Program b)) where
+      => Pretty (WithTerseBinds (Program b)) where
-    out (WithTerseBinds p)
+    pretty (WithTerseBinds p)
-            = vsep [ (datatags <> "\n")
+            = (datatags <> "\n")
-                   , defs ]
+          $+$ defs
         where
             datatags = ifoldrOf (programDataTags . ifolded) cataDataTag mempty p
             defs = vlinesOf (programJoinedDefs . to prettyGroup) p
@@ -358,17 +330,17 @@ instance (Hashable b, Out b, Out (AsTerse b), MakeTerse b)
             thatSc = foldMap $ \sc ->
                 H.singleton (sc ^. _lhs . _1) (That sc)
 
-            prettyGroup :: These (b, Type) (ScDef b) -> Doc ann
+            prettyGroup :: These (b, Type) (ScDef b) -> Doc
             prettyGroup = bifoldr vs vs mempty
                         . bimap (uncurry prettyTySig')
-                                (out . WithTerseBinds)
+                                (pretty . WithTerseBinds)
-                where vs a b = a <> ";" <> line <> b
+                where vs = vsepTerm ";"
 
-            cataDataTag n (t,a) acc = prettyDataTag n t a <> line <> acc
+            cataDataTag n (t,a) acc = prettyDataTag n t a $+$ acc
 
-instance (Hashable b, Out b) => Out (Program b) where
+instance (Hashable b, Pretty b) => Pretty (Program b) where
-    out p = vsep [ datatags <> "\n"
+    pretty p = (datatags <> "\n")
-                 , defs ]
+           $+$ defs
         where
             datatags = ifoldrOf (programDataTags . ifolded) cataDataTag mempty p
             defs = vlinesOf (programJoinedDefs . to prettyGroup) p
@@ -384,124 +356,111 @@ instance (Hashable b, Out b) => Out (Program b) where
             thatSc = foldMap $ \sc ->
                 H.singleton (sc ^. _lhs . _1) (That sc)
 
-            prettyGroup :: These (b, Type) (ScDef b) -> Doc ann
+            prettyGroup :: These (b, Type) (ScDef b) -> Doc
             prettyGroup = bifoldr vs vs mempty
-                        . bimap (uncurry prettyTySig) out
+                        . bimap (uncurry prettyTySig) pretty
-                where vs a b = a <> ";" <> line <> b
+                where vs = vsepTerm ";"
 
-            cataDataTag n (t,a) acc = prettyDataTag n t a <> line <> acc
+            cataDataTag n (t,a) acc = prettyDataTag n t a $+$ 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)
+prettyDataTag :: (Pretty n, Pretty t, Pretty a)
-              => n -> t -> a -> Doc ann
+              => n -> t -> a -> Doc
 prettyDataTag n t a =
     hsep ["{-#", "PackData", ttext n, ttext t, ttext a, "#-}"]
 
-prettyTySig :: (Out n, Out t) => n -> t -> Doc ann
+prettyTySig :: (Pretty n, Pretty t) => n -> t -> Doc
-prettyTySig n t = hsep [ttext n, ":", out t]
+prettyTySig n t = hsep [ttext n, ":", pretty t]
 
-prettyTySig' :: (MakeTerse n, Out (AsTerse n), Out t) => n -> t -> Doc ann
+prettyTySig' :: (MakeTerse n, Pretty (AsTerse n), Pretty t) => n -> t -> Doc
-prettyTySig' n t = hsep [ttext (asTerse n), ":", out t]
+prettyTySig' n t = hsep [ttext (asTerse n), ":", pretty t]
 
--- out Type
+-- Pretty Type
 -- TyApp | appPrec   | left
 -- (:->) | appPrec-1 | right
 
-instance Out Type where
+instance Pretty Type where
-    outPrec _ (TyVar n)   = ttext n
+    prettyPrec _ (TyVar n)   = ttext n
-    outPrec _ TyFun       = "(->)"
+    prettyPrec _ TyFun       = "(->)"
-    outPrec _ (TyCon n)   = ttext n
+    prettyPrec _ (TyCon n)   = ttext n
-    outPrec p (a :-> b)   = maybeParens (p>appPrec-1) $
+    prettyPrec p (a :-> b)   = maybeParens (p>appPrec-1) $
-        hsep [outPrec appPrec a, "->", outPrec (appPrec-1) b]
+        hsep [prettyPrec appPrec a, "->", prettyPrec (appPrec-1) b]
-    outPrec p (TyApp f x) = maybeParens (p>appPrec) $
+    prettyPrec p (TyApp f x) = maybeParens (p>appPrec) $
-        outPrec appPrec f <+> outPrec appPrec1 x
+        prettyPrec appPrec f <+> prettyPrec appPrec1 x
-    outPrec p (TyForall a m) = maybeParens (p>appPrec-2) $
+    prettyPrec p (TyForall a m) = maybeParens (p>appPrec-2) $
-        "∀" <+> (outPrec appPrec1 a <> ".") <+> out m
+        "∀" <+> (prettyPrec appPrec1 a <> ".") <+> pretty m
-    outPrec _ TyKindType = "Type"
+    prettyPrec _ TyKindType = "Type"
 
-instance (Out b, Out (AsTerse b), MakeTerse b)
+instance (Pretty b, Pretty (AsTerse b), MakeTerse b)
-      => Out (WithTerseBinds (ScDef b)) where
+      => Pretty (WithTerseBinds (ScDef b)) where
-    out (WithTerseBinds sc) = hsep [name, as, "=", hang 1 e]
+    pretty (WithTerseBinds sc) = hsep [name, as, "=", hang empty 1 e]
         where
             name = ttext $ sc ^. _lhs . _1 . to asTerse
             as = sc & hsepOf (_lhs . _2 . each . to asTerse . to ttext)
-            e = out $ sc ^. _rhs
+            e = pretty $ sc ^. _rhs
 
-instance (Out b) => Out (ScDef b) where
+instance (Pretty b) => Pretty (ScDef b) where
-    out sc = hsep [name, as, "=", hang 1 e]
+    pretty sc = hsep [name, as, "=", hang empty 1 e]
         where
             name = ttext $ sc ^. _lhs . _1
             as = sc & hsepOf (_lhs . _2 . each . to ttext)
-            e = out $ sc ^. _rhs
+            e = pretty $ sc ^. _rhs
 
--- out Expr
+instance (Pretty (f (Fix f))) => Pretty (Fix f) where
+    prettyPrec d (Fix f) = prettyPrec d f
+
+-- Pretty Expr
 -- LamF | appPrec1 | right
 -- AppF | appPrec  | left
 
-instance (Out b, Out a) => Out (ExprF b a) where
+instance (Pretty b, Pretty a) => Pretty (ExprF b a) where
-    outPrec = outPrec1
+    prettyPrec _ (VarF n) = ttext n
+    prettyPrec _ (ConF t a) = "Pack{" <> (ttext t <+> ttext a) <> "}"
+    prettyPrec p (LamF bs e) = maybeParens (p>0) $
+        hsep ["λ", hsep (prettyPrec appPrec1 <$> bs), "->", pretty e]
+    prettyPrec p (LetF r bs e) = maybeParens (p>0)
+                               $ hsep [pretty r, explicitLayout bs]
+                             $+$ hsep ["in", pretty e]
+    prettyPrec p (AppF f x) = maybeParens (p>appPrec) $
+        prettyPrec appPrec f <+> prettyPrec appPrec1 x
+    prettyPrec p (LitF l) = prettyPrec p l
+    prettyPrec p (CaseF e as) = maybeParens (p>0) $
+        "case" <+> pretty e <+> "of"
+        $+$ nest 2 (explicitLayout as)
+    prettyPrec p (TypeF t) = "@" <> prettyPrec appPrec1 t
 
-instance (Out b) => Out1 (ExprF b) where
+instance Pretty Rec where
-    liftOutPrec pr _ (VarF n) = ttext n
+    pretty Rec = "letrec"
-    liftOutPrec pr _ (ConF t a) = "Pack{" <> (ttext t <+> ttext a) <> "}"
+    pretty NonRec = "let"
-    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
+instance (Pretty b, Pretty a) => Pretty (AlterF b a) where
-    out Rec = "letrec"
+    pretty (AlterF c as e) =
-    out NonRec = "let"
+        hsep [pretty c, hsep (pretty <$> as), "->", pretty e]
 
-instance (Out b, Out a) => Out (AlterF b a) where
+instance Pretty AltCon where
-    outPrec = outPrec1
+    pretty (AltData n) = ttext n
+    pretty (AltLit l) = pretty l
+    pretty (AltTag t) = "<" <> ttext t <> ">"
+    pretty AltDefault = "_"
 
-instance (Out b) => Out1 (AlterF b) where
+instance Pretty Lit where
-    liftOutPrec pr _ (AlterF c as e) =
+    pretty (IntL n) = ttext n
-        hsep [out c, hsep (out <$> as), "->", liftOutPrec pr 0 e]
 
-instance Out AltCon where
+instance (Pretty b, Pretty a) => Pretty (BindingF b a) where
-    out (AltData n) = ttext n
+    pretty (BindingF k v) = hsep [pretty k, "=", pretty v]
-    out (AltLit l) = out l
-    out (AltTag t) = "<" <> ttext t <> ">"
-    out AltDefault = "_"
 
-instance Out Lit where
+explicitLayout :: (Pretty a) => [a] -> Doc
-    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)
+    inner = zipWith (<+>) delims (pretty <$> as)
     delims = "{" : repeat ";"
 
-instance Out Var where
+instance Pretty Var where
-    outPrec p (MkVar n t) = maybeParens (p>0) $
+    prettyPrec p (MkVar n t) = maybeParens (p>0) $
-        hsep [out n, ":", out t]
+        hsep [pretty n, ":", pretty t]
 
 --------------------------------------------------------------------------------
 
@@ -600,24 +559,15 @@ 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)
+    lift1 (VarF k)      = liftCon 'VarF (lift k)
-    liftLift lf (AppF f x)    = liftCon2 'AppF (lf f) (lf x)
+    lift1 (AppF f x)    = liftCon2 'AppF (lift f) (lift x)
-    liftLift lf (LamF b e)    = liftCon2 'LamF (lift b) (lf e)
+    lift1 (LamF b e)    = liftCon2 'LamF (lift b) (lift e)
-    liftLift lf (LetF r bs e) = liftCon3 'LetF (lift r) bs' (lf e)
+    lift1 (LetF r bs e) = liftCon3 'LetF (lift r) (lift bs) (lift e)
-        where bs' = liftLift (liftLift lf) bs
+    lift1 (CaseF e as)  = liftCon2 'CaseF (lift e) (lift as)
-    liftLift lf (CaseF e as)  = liftCon2 'CaseF (lf e) as'
+    lift1 (TypeF t)     = liftCon 'TypeF (lift t)
-        where as' = liftLift (liftLift lf) as
+    lift1 (LitF l)      = liftCon 'LitF (lift l)
-    liftLift lf (TypeF t)     = liftCon 'TypeF (lift t)
+    lift1 (ConF t a)    = liftCon2 'ConF (lift t) (lift a)
-    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)
@@ -671,7 +621,6 @@ instance (Hashable b, Hashable b')
         <$> 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
@@ -743,46 +692,4 @@ 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

@@ -2,7 +2,6 @@
 {-# LANGUAGE OverloadedLists #-}
 module Core.SystemF
     ( lintCoreProgR
-    , kindOf
     )
     where
 --------------------------------------------------------------------------------
@@ -22,7 +21,7 @@ import Text.Printf
 import Control.Comonad
 import Control.Comonad.Cofree
 import Data.Fix
-import Data.Functor                 hiding (unzip)
+import Data.Functor
 
 import Control.Lens                 hiding ((:<))
 import Control.Lens.Unsound
@@ -44,38 +43,10 @@ data Gamma = Gamma
 makeLenses ''Gamma
 
 lintCoreProgR :: (Monad m) => Program Var -> RLPCT m (Program Name)
-lintCoreProgR = liftEither . (_Left %~ pure) . lint
+lintCoreProgR = undefined
 
-lintDontCheck :: Program Var -> Program Name
+lint :: Program Var -> Program Name
-lintDontCheck = binders %~ view (_MkVar . _1)
+lint = undefined
-
-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
 
@@ -92,14 +63,14 @@ instance IsRlpcError SystemFError where
             undefinedVariableErr n
         SystemFErrorKindMismatch k k' ->
             Text [ T.pack $ printf "Could not match kind `%s' with `%s'"
-                                   (out k) (out k')
+                                   (pretty k) (pretty k')
                  ]
         SystemFErrorCouldNotMatch t t' ->
             Text [ T.pack $ printf "Could not match type `%s' with `%s'"
-                                   (out t) (out t')
+                                   (pretty t) (pretty t')
                  ]
 
-justLintCoreExpr = fmap (fmap (outPrec appPrec1)) . lintE demoContext
+justLintCoreExpr = fmap (fmap (prettyPrec appPrec1)) . lintE demoContext
 
 lintE :: Gamma -> Expr Var -> SysF ET
 lintE g = \case
@@ -179,11 +150,6 @@ lintE g = \case
                 | 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

src/Core/Utils.hs

@@ -8,8 +8,8 @@ module Core.Utils
 ----------------------------------------------------------------------------------
 import Data.Functor.Foldable.TH     (makeBaseFunctor)
 import Data.Functor.Foldable
-import Data.HashSet                 (HashSet)
+import Data.Set                     (Set)
-import Data.HashSet                 qualified as S
+import Data.Set                     qualified as S
 import Core.Syntax
 import Control.Lens
 import GHC.Exts                     (IsList(..))
@@ -28,10 +28,29 @@ isAtomic _        = False
 
 ----------------------------------------------------------------------------------
 
-freeVariables :: Expr' -> HashSet Name
+freeVariables :: Expr b -> Set b
 freeVariables = undefined
--- freeVariables = cata \case
+
---     VarF n -> S.singleton n
+-- freeVariables :: Expr' -> Set Name
---     CaseF e as -> e <> (foldMap f as)
+-- freeVariables = cata go
---         where f (AlterF _ bs e) = fold e `S.difference` S.fromList bs
+--     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)
+--                 asFree = foldMap (freeVariables . 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

@@ -11,8 +11,8 @@ module Core2Core
 ----------------------------------------------------------------------------------
 import Data.Functor.Foldable
 import Data.Maybe               (fromJust)
-import Data.HashSet             (HashSet)
+import Data.Set                 (Set)
-import Data.HashSet             qualified as S
+import Data.Set                 qualified as S
 import Data.List
 import Data.Foldable
 import Control.Monad.Writer
@@ -22,8 +22,6 @@ import Data.Text                qualified as T
 import Data.HashMap.Strict      (HashMap)
 import Numeric                  (showHex)
 
-import Misc.MonadicRecursionSchemes
-
 import Data.Pretty
 import Compiler.RLPC
 import Control.Lens
@@ -39,7 +37,7 @@ core2core p = undefined
 gmPrepR :: (Monad m) => Program' -> RLPCT m Program'
 gmPrepR p = do
     let p' = gmPrep p
-    addDebugMsg "dump-gm-preprocessed" $ show . out $ p'
+    addDebugMsg "dump-gm-preprocessed" $ render . pretty $ p'
     pure p'
 
 -- | G-machine-specific preprocessing.
@@ -48,14 +46,10 @@ 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)
 
@@ -98,7 +92,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 :: HashSet Name -> Expr' -> Floater Expr'
+floatNonStrictCases :: Set Name -> Expr' -> Floater Expr'
 floatNonStrictCases g = goE
     where
         goE :: Expr' -> Floater Expr'
@@ -110,20 +104,24 @@ floatNonStrictCases g = goE
         goE e                   = goC e
 
         goC :: Expr' -> Floater Expr'
-        goC = cataM \case
         -- the only truly non-trivial case: when a case expr is found in a
         -- non-strict context, we float it into a supercombinator, give it a
         -- name consumed from the state, record the newly created sc within the
         -- Writer, and finally return an expression appropriately calling the sc
-            CaseF e as -> do
+        goC p@(Case e as)       = do
             n <- name
-                let (e',sc) = floatCase g n (Case e as)
+            let (e',sc) = floatCase g n p
                 altBodies = (\(Alter _ _ b) -> b) <$> as
             tell [sc]
             goE e
             traverse_ goE altBodies
             pure e'
-            t -> pure $ embed t
+        goC (App f x)           = App <$> goC f <*> goC x
+        goC (Let r bs e)        = Let r <$> bs' <*> goE e
+            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 . Data.List.uncons)
 
@@ -134,15 +132,10 @@ floatNonStrictCases g = goE
         -- ^ ??? what the fuck?
         -- ^ 24/02/22: what is this shit lol?
 
-etaReduce :: Program' -> Program'
-etaReduce = programScDefs . each %~ \case
-    ScDef n as (Lam bs e) -> ScDef n (as ++ bs) e
-    ScDef n as e -> ScDef n as e
-
 -- when provided with a case expr, floatCase will float the case into a
 -- supercombinator of its free variables. the sc is returned along with an
 -- expression that calls the sc with the necessary arguments
-floatCase :: HashSet Name -> Name -> Expr' -> (Expr', ScDef')
+floatCase :: Set Name -> Name -> Expr' -> (Expr', ScDef')
 floatCase g n c@(Case e as) = (e', sc)
     where
         sc = ScDef n caseFrees c

src/Data/Pretty.hs

@@ -1,113 +1,90 @@
-{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE QuantifiedConstraints #-}
-{-# LANGUAGE QuantifiedConstraints, UndecidableInstances #-}
 module Data.Pretty
-    ( Out(..), Out1(..)
+    ( Pretty(..)
-    , outPrec1
+    , rpretty
-    , rout
     , ttext
-    , Showing(..)
+    -- * Pretty-printing lens combinators
-    -- * Out-printing lens combinators
+    , hsepOf, vsepOf
-    , hsepOf, vsepOf, vcatOf, vlinesOf
+    , vcatOf
-    , module Prettyprinter
+    , vlinesOf
+    , vsepTerm
+    , module Text.PrettyPrint
     , maybeParens
     , appPrec
     , appPrec1
     )
     where
 ----------------------------------------------------------------------------------
-import Prettyprinter
+import Text.PrettyPrint             hiding ((<>))
+import Text.PrettyPrint.HughesPJ    hiding ((<>))
 import Text.Printf
 import Data.String                  (IsString(..))
 import Data.Text.Lens               hiding ((:<))
-import Data.Monoid                  hiding (Sum)
+import Data.Monoid
-import Data.Bool
+import Control.Lens
-import Control.Lens                 hiding ((:<))
 
 -- instances
 import Control.Comonad.Cofree
 import Data.Text                    qualified as T
-import Data.Functor.Sum
-import Data.Fix                     (Fix(..))
 ----------------------------------------------------------------------------------
 
-class Out a where
+class Pretty a where
-    out :: a -> Doc ann
+    pretty :: a -> Doc
-    outPrec :: Int -> a -> Doc ann
+    prettyPrec :: Int -> a -> Doc
 
-    {-# MINIMAL out | outPrec #-}
+    {-# MINIMAL pretty | prettyPrec #-}
-    out = outPrec 0
+    pretty = prettyPrec 0
-    outPrec = const out
+    prettyPrec = const pretty
 
-rout :: (IsString s, Out a) => a -> s
+rpretty :: (IsString s, Pretty a) => a -> s
-rout = fromString . show . out
+rpretty = fromString . render . pretty
 
--- instance Out (Doc ann) where
+instance Pretty String where
---     out = id
+    pretty = Text.PrettyPrint.text
 
-instance Out String where
+instance Pretty T.Text where
-    out = pretty
+    pretty = Text.PrettyPrint.text . view unpacked
-
-instance Out T.Text where
-    out = pretty
 
 newtype Showing a = Showing a
 
-instance (Show a) => Out (Showing a) where
+instance (Show a) => Pretty (Showing a) where
-    outPrec p (Showing a) = fromString $ showsPrec p a ""
+    prettyPrec p (Showing a) = fromString $ showsPrec p a ""
 
-deriving via Showing Int instance Out Int
+deriving via Showing Int instance Pretty Int
 
-class (forall a. Out a => Out (f a)) => Out1 f where
+class (forall a. Pretty a => Pretty (f a)) => Pretty1 f where
-    liftOutPrec :: (Int -> a -> Doc ann) -> Int -> f a -> Doc ann
+    liftPrettyPrec :: (Int -> a -> Doc) -> f a -> Doc
-
-outPrec1 :: (Out1 f, Out a) => Int -> f a -> Doc ann
-outPrec1 = liftOutPrec outPrec
-
-instance (Out1 f, Out1 g, Out a) => Out (Sum f g a) where
-    outPrec p (InL fa) = outPrec1 p fa
-    outPrec p (InR ga) = outPrec1 p ga
-
-instance (Out1 f, Out1 g) => Out1 (Sum f g) where
-    liftOutPrec pr p (InL fa) = liftOutPrec pr p fa
-    liftOutPrec pr p (InR ga) = liftOutPrec pr p ga
-
-instance (Out (f (Fix f))) => Out (Fix f) where
-    outPrec d (Fix f) = outPrec d f
-
-instance (Out (f (Cofree f a)), Out a) => Out (Cofree f a) where
-    outPrec d (a :< f) = maybeParens (d>0) $
-        hsep [outPrec 0 f, ":", outPrec 0 a]
 
 --------------------------------------------------------------------------------
 
-ttext :: Out t => t -> Doc ann
+ttext :: Pretty t => t -> Doc
-ttext = out
+ttext = pretty
 
-hsepOf :: Getting (Endo (Doc ann)) s (Doc ann) -> s -> Doc ann
+hsepOf :: Getting (Endo Doc) s Doc -> s -> Doc
 hsepOf l = foldrOf l (<+>) mempty
 
-vsepOf :: _ -> s -> Doc ann
+vsepOf :: Getting (Endo Doc) s Doc -> s -> Doc
-vsepOf l = vsep . toListOf l
+vsepOf l = foldrOf l ($+$) mempty
 
-vcatOf :: _ -> s -> Doc ann
+vcatOf :: Getting (Endo Doc) s Doc -> s -> Doc
-vcatOf l = vcat . toListOf l
+vcatOf l = foldrOf l ($$) mempty
 
-vlinesOf :: Getting (Endo (Doc ann)) s (Doc ann) -> s -> Doc ann
+vlinesOf :: Getting (Endo Doc) s Doc -> s -> Doc
-vlinesOf l = foldrOf l (\a b -> a <> line <> b) mempty
+vlinesOf l = foldrOf l (\a b -> a $+$ "" $+$ b) mempty
 -- hack(?) to separate chunks with a blankline
 
---------------------------------------------------------------------------------
+vsepTerm :: Doc -> Doc -> Doc -> Doc
+vsepTerm term a b = (a <> term) $+$ b
 
-maybeParens :: Bool -> Doc ann -> Doc ann
+--------------------------------------------------------------------------------
-maybeParens = bool id parens
 
 appPrec, appPrec1 :: Int
 appPrec  = 10
 appPrec1 = 11
 
-instance PrintfArg (Doc ann) where
+instance PrintfArg Doc where
     formatArg d fmt
-        | fmtChar (vFmt 'D' fmt) == 'D' = formatString (show d) fmt'
+        | fmtChar (vFmt 'D' fmt) == 'D' = formatString (render d) fmt'
         | otherwise                     = errorBadFormat $ fmtChar fmt
       where
         fmt' = fmt { fmtChar = 's', fmtPrecision = Nothing }

src/GM.hs

@@ -29,9 +29,9 @@ import Data.Tuple                   (swap)
 import Control.Lens
 import Data.Text.Lens               (IsText, packed, unpacked)
 import Text.Printf
+import Text.PrettyPrint             hiding ((<>))
+import Text.PrettyPrint.HughesPJ    (maybeParens)
 import Data.Foldable                (traverse_)
-import Prettyprinter
-import Data.Pretty
 import System.IO                    (Handle, hPutStrLn)
 -- TODO: an actual output system
 -- TODO: an actual output system
@@ -165,7 +165,7 @@ hdbgProg p hio = do
     renderOut . showStats $ sts
     pure final
     where
-        renderOut r = hPutStrLn hio $ show r ++ "\n"
+        renderOut r = hPutStrLn hio $ render r ++ "\n"
 
         states = eval $ compile p
         final = last states
@@ -182,7 +182,7 @@ evalProgR p = do
     renderOut . showStats $ sts
     pure (res, sts)
     where
-        renderOut r = addDebugMsg "dump-eval" $ show r ++ "\n"
+        renderOut r = addDebugMsg "dump-eval" $ render r ++ "\n"
         states = eval . compile $ p
         final = last states
 
@@ -823,13 +823,13 @@ showCon t n = printf "Pack{%d %d}" t n ^. packed
 pprTabstop :: Int
 pprTabstop = 4
 
-qquotes :: Doc ann -> Doc ann
+qquotes :: Doc -> Doc
 qquotes d = "`" <> d <> "'"
 
-showStats :: Stats -> Doc ann
+showStats :: Stats -> Doc
-showStats sts = "==== Stats ============" <> line <> stats
+showStats sts = "==== Stats ============" $$ stats
     where
-        stats = textt @String $ printf
+        stats = text $ printf
             "Reductions      : %5d\n\
             \Prim Reductions : %5d\n\
             \Allocations     : %5d\n\
@@ -839,10 +839,10 @@ showStats sts = "==== Stats ============" <> line <> stats
             (sts ^. stsAllocations)
             (sts ^. stsGCCycles)
 
-showState :: GmState -> Doc ann
+showState :: GmState -> Doc
 showState st = vcat
         [ "==== GmState " <> int stnum <> " "
-            <> textt (replicate (28 - 13 - 1 - digitalWidth stnum) '=')
+            <> text (replicate (28 - 13 - 1 - digitalWidth stnum) '=')
         , "-- Next instructions -------"
         , info $ showCodeShort c
         , "-- Stack -------------------"
@@ -859,23 +859,23 @@ showState st = vcat
         -- indent data
         info = nest pprTabstop
 
-showCodeShort :: Code -> Doc ann
+showCodeShort :: Code -> Doc
 showCodeShort c = braces c'
     where
         c' | length c > 3 = list (showInstr <$> take 3 c) <> "; ..."
            | otherwise    = list (showInstr <$> c)
         list = hcat . punctuate "; "
 
-showStackShort :: Stack -> Doc ann
+showStackShort :: Stack -> Doc
 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 = textt . show
+        showEntry = text . show
 
-showStack :: GmState -> Doc ann
+showStack :: GmState -> Doc
 showStack st = vcat $ uncurry showEntry <$> si
     where
         h = st ^. gmHeap
@@ -887,9 +887,10 @@ 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 ann
+showDump :: GmState -> Doc
 showDump st = vcat $ uncurry showEntry <$> di
     where
         d = st ^. gmDump
@@ -898,13 +899,14 @@ 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 = vsep [ "Stack : " <> showCodeShort c
+                entry = ("Stack : " <> showCodeShort c)
-                             , "Code  : " <> showStackShort s ]
+                     $$ ("Code  : " <> showStackShort s)
 
-padInt :: Int -> Int -> Doc ann
+padInt :: Int -> Int -> Doc
-padInt m n = textt (replicate (m - digitalWidth n) ' ') <> int n
+padInt m n = text (replicate (m - digitalWidth n) ' ') <> int n
 
 maxWidth :: [Int] -> Int
 maxWidth ns = digitalWidth $ maximum ns
@@ -912,7 +914,7 @@ maxWidth ns = digitalWidth $ maximum ns
 digitalWidth :: Int -> Int
 digitalWidth = length . show
 
-showHeap :: GmState -> Doc ann
+showHeap :: GmState -> Doc
 showHeap st = vcat $ showEntry <$> addrs
     where
         showAddr n = padInt w n <> ": "
@@ -921,12 +923,13 @@ 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 ann
+showNodeAt :: GmState -> Addr -> Doc
 showNodeAt = showNodeAtP 0
 
-showNodeAtP :: Int -> GmState -> Addr -> Doc ann
+showNodeAtP :: Int -> GmState -> Addr -> Doc
 showNodeAtP p st a = case hLookup a h of
     Just (NNum n)        -> int n <> "#"
     Just (NGlobal _ _)   -> textt name
@@ -950,9 +953,9 @@ showNodeAtP p st a = case hLookup a h of
         h = st ^. gmHeap
         pprec = maybeParens (p > 0)
 
-showSc :: GmState -> (Name, Addr) -> Doc ann
+showSc :: GmState -> (Name, Addr) -> Doc
-showSc st (k,a) = vcat [ "Supercomb " <> qquotes (textt k) <> colon
+showSc st (k,a) = "Supercomb " <> qquotes (textt k) <> colon
-                       , code ]
+               $$ code
     where
         code = case hLookup a (st ^. gmHeap) of
             Just (NGlobal _ c) -> showCode c
@@ -963,21 +966,19 @@ errTxtInvalidObject, errTxtInvalidAddress :: (IsString a) => a
 errTxtInvalidObject = "<invalid object>"
 errTxtInvalidAddress = "<invalid address>"
 
-showCode :: Code -> Doc ann
+showCode :: Code -> Doc
 showCode c = "Code" <+> braces instrs
     where instrs = vcat $ showInstr <$> c
 
-showInstr :: Instr -> Doc ann
+showInstr :: Instr -> Doc
-showInstr (CaseJump alts) = vcat [ "CaseJump", nest pprTabstop alternatives ]
+showInstr (CaseJump alts) = "CaseJump" $$ nest pprTabstop alternatives
     where
         showAlt (t,c) = "<" <> int t <> ">" <> showCodeShort c
-        alternatives = foldr (\a acc -> showAlt a <> line <> acc) mempty alts
+        alternatives = foldr (\a acc -> showAlt a $$ acc) mempty alts
-showInstr i = textt $ show i
+showInstr i = text $ show i
 
-int = pretty
+textt :: (IsText a) => a -> Doc
-
+textt t = t ^. unpacked & text
-textt :: (Pretty a) => a -> Doc ann
-textt = pretty
 
 ----------------------------------------------------------------------------------
 

src/Misc/CofreeF.hs

@@ -1,13 +0,0 @@
-{-# 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

@@ -1,6 +1,6 @@
 {-# LANGUAGE TemplateHaskell #-}
 module Misc.Lift1
-    ( Lift1(..), lift1
+    ( Lift1(..)
     , liftCon, liftCon2, liftCon3
     , Lift(..)
     )
@@ -13,17 +13,11 @@ 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
+    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))
@@ -44,11 +38,4 @@ liftCon3 n a b c = do
 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

@@ -1,14 +0,0 @@
-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

@@ -1,243 +0,0 @@
-{
-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

@@ -1,326 +0,0 @@
-{-# 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

@@ -1,373 +0,0 @@
-{-# 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

@@ -1,175 +0,0 @@
-{-# 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

@@ -1,30 +0,0 @@
-{-# 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

@@ -14,7 +14,6 @@ module Rlp.Lex
     , popLexState
     , programInitState
     , runP'
-    , popLayout
     )
     where
 import Codec.Binary.UTF8.String (encodeChar)
@@ -59,10 +58,10 @@ $asciisym       = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
 
 @reservedname = 
     case|data|do|import|in|let|letrec|module|of|where
-    |infixr|infixl|infix|forall
+    |infixr|infixl|infix
 
 @reservedop =
-    "=" | \\ | "->" | "|" | ":"
+    "=" | \\ | "->" | "|" | "::"
 
 rlp :-
     
@@ -163,16 +162,14 @@ lexReservedName = \case
     "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
@@ -331,7 +328,6 @@ 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)
@@ -340,6 +336,8 @@ 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
     case off of
         -- the line is aligned with the previous. it therefore belongs to the

src/Rlp/Parse.y

@@ -84,7 +84,7 @@ VL  : vlbrace       { () }
 
 VR  :: { () }
 VR  : vrbrace       { () }
-    | error         {% void popLayout }
+    | error         { () }
 
 VS                  :: { () }
 VS                  : ';'                   { () }

src/Rlp/Parse/Types.hs

@@ -17,9 +17,8 @@ module Rlp.Parse.Types
     -- * Other parser types
     , RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
     , Located(..), PsName
-    , srcSpanLen
     -- ** Lenses
-    , _TokenLitInt, _TokenVarName, _TokenConName, _TokenVarSym, _TokenConSym
+    , _TokenLitInt, _TokenVarName, _TokenConName, _TokenVarSym
     , aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
 
     -- * Error handling
@@ -109,7 +108,6 @@ data RlpToken
     | TokenInfixL
     | TokenInfixR
     | TokenInfix
-    | TokenForall
     -- reserved ops
     | TokenArrow
     | TokenPipe

src/Rlp/Syntax/Types.hs

@@ -15,7 +15,7 @@ module Rlp.Syntax.Types
     , Rec(..)
     , Lit(..)
     , Pat(..)
-    , Decl(..), Decl'
+    , Decl(..)
     , Program(..)
     , Where
 
@@ -23,8 +23,6 @@ module Rlp.Syntax.Types
     , Cofree(..)
     , Trans.Cofree.CofreeF
     , SrcSpan(..)
-
-    , programDecls
     )
     where
 ----------------------------------------------------------------------------------

src/Rlp/TH.hs

@@ -13,14 +13,16 @@ import Control.Monad.IO.Class
 import Control.Monad
 
 import Compiler.RLPC
-import Rlp.AltParse
+import Rlp.Parse
 --------------------------------------------------------------------------------
 
 rlpProg :: QuasiQuoter
-rlpProg = mkqq parseRlpProgR
+rlpProg = undefined
+-- rlpProg = mkqq parseRlpProgR
 
 rlpExpr :: QuasiQuoter
-rlpExpr = mkqq parseRlpExprR
+rlpExpr = undefined
+-- rlpExpr = mkqq parseRlpExprR
 
 mkq :: (Lift a) => (Text -> RLPCIO a) -> String -> Q Exp
 mkq parse = evalAndParse >=> lift where

src/Rlp2Core.hs

@@ -12,7 +12,8 @@ import Control.Monad.Writer.CPS
 import Control.Monad.Utils
 import Control.Arrow
 import Control.Applicative
-import Control.Lens                     hiding ((:<))
+import Control.Comonad
+import Control.Lens
 import Compiler.RLPC
 import Data.List                        (mapAccumL, partition)
 import Data.Text                        (Text)
@@ -21,18 +22,12 @@ import Data.HashMap.Strict              qualified as H
 import Data.Monoid                      (Endo(..))
 import Data.Either                      (partitionEithers)
 import Data.Foldable
+import Data.Fix
 import Data.Maybe                       (fromJust, fromMaybe)
+import Data.Functor.Bind
 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
@@ -40,11 +35,18 @@ import Effectful
 import Text.Show.Deriving
 
 import Core.Syntax                      as Core
-import Rlp.AltSyntax                    as Rlp
 import Compiler.Types
-import Data.Pretty
+import Data.Pretty                      (render, pretty)
+import Rlp.Syntax                       as Rlp
+import Rlp.Parse.Types                  (RlpcPs, PsName)
 --------------------------------------------------------------------------------
 
+desugarRlpProgR = undefined
+desugarRlpProg = undefined
+desugarRlpExpr = undefined
+
+{--
+
 type Tree a = Either Name (Name, Branch a)
 
 -- | Rose tree branch representing "nested" "patterns" in the Core language. That
@@ -63,150 +65,180 @@ deriveShow1 ''Branch
 
 --------------------------------------------------------------------------------
 
--- desugarRlpProgR :: forall m a. (Monad m)
+desugarRlpProgR :: forall m. (Monad m) => RlpProgram RlpcPs -> RLPCT m Program'
---                 => Rlp.Program PsName (TypedRlpExpr PsName)
+desugarRlpProgR p = do
---                 -> RLPCT m (Core.Program Var)
+    let p' = desugarRlpProg p
--- desugarRlpProgR p = do
+    addDebugMsg "dump-desugared" $ render (pretty p')
---     let p' = desugarRlpProg p
+    pure p'
---     addDebugMsg "dump-desugared" $ show (out p')
---     pure p'
 
-desugarRlpProgR = undefined
+desugarRlpProg :: RlpProgram RlpcPs -> Program'
-
-desugarRlpProg :: Rlp.Program PsName (TypedRlpExpr PsName) -> Core.Program Var
 desugarRlpProg = rlpProgToCore
 
-desugarRlpExpr = undefined
+desugarRlpExpr :: RlpExpr RlpcPs -> Expr'
-
+desugarRlpExpr = runPureEff . runNameSupply "anon" . exprToCore
-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 :: RlpProgram RlpcPs -> Program'
-rlpProgToCore = foldMapOf (programDecls . each) declToCore
+rlpProgToCore = foldMapOf (progDecls . each) declToCore
 
---------------------------------------------------------------------------------
+declToCore :: Decl' RlpcPs -> Program'
 
-declToCore :: Rlp.Decl PsName TypedRlpExpr' -> Core.Program Var
+declToCore (TySigD'' ns t) = mempty &
+    programTypeSigs .~ H.fromList [ (n, typeToCore t) | n <- ns ]
 
-declToCore (DataD n as ds)
+declToCore (DataD'' n as ds) = fold . getZipList $
-    = foldMap (uncurry $ conToCore t) ([0..] `zip` ds)
+    constructorToCore t' <$> ZipList [0..] <*> ZipList ds
-   <> single programTyCons (H.singleton n k)
     where
-    as' = TyVar <$> as
+        -- create the appropriate type from the declared constructor and its
-    k = foldr (:->) t as'
+        -- arguments
-    t = foldl TyApp (TyCon n) as'
+        t' = foldl TyApp (TyCon n) (TyVar . dsNameToName <$> as)
 
--- assume full eta-expansion for now
+-- TODO: where-binds
-declToCore (FunD b [] e) = single programScDefs $
+declToCore fd@(FunD'' n as e _) = mempty & programScDefs .~ [ScDef n' as' e']
-    [ScDef b' [] e']
     where
-    b' = MkVar b (typeToCore $ extract e)
+        n' = dsNameToName n
-    e' = runPureEff . runNameSupply b . cataM exprToCore . retype $ e
+        e' = runPureEff . runNameSupply n . exprToCore . unXRec $ e
+        as' = as <&> \case
+            (unXRec -> VarP k) -> dsNameToName k
+            _                  -> error "no patargs yet"
 
-conToCore :: Core.Type -> Int -> DataCon PsName -> Core.Program Var
+type NameSupply = Labeled NameSupplyLabel (State [IdP RlpcPs])
-conToCore t tag (DataCon b as)
+type NameSupplyLabel = "expr-name-supply"
-    = single programScDefs [ScDef b' [] $ Con tag arity]
+
+exprToCore :: forall es. (NameSupply :> es) => RlpExpr RlpcPs -> Eff es Expr'
+
+exprToCore (VarE n) = pure $ Var (dsNameToName n)
+
+exprToCore (AppE a b) = (liftA2 App `on` exprToCore . unXRec) a b
+
+exprToCore (OAppE f a b) = (liftA2 mkApp `on` exprToCore . unXRec) a b
     where
-    arity = lengthOf arrowStops t - 1
+        mkApp s t = (Var f `App` s) `App` t
-    b' = MkVar b t
 
-dummyExpr :: Text -> Core.Expr b
+exprToCore (CaseE (unXRec -> e) as) = do
-dummyExpr a = Var ("<" <> a <> ">")
+    e' <- exprToCore e
+    Case e' <$> caseAltToCore `traverse` as
 
-stripTypes :: Core.Program Var -> Core.Program Name
+exprToCore (LetE bs e) = letToCore NonRec bs e
-stripTypes p = Core.Program
+exprToCore (LetrecE bs e) = letToCore Rec bs e
-    { _programTyCons = p ^. programTyCons 
-    , _programDataTags = p ^. programDataTags
-    , _programScDefs =  p ^. programScDefs
-            & each . binders %~ (\ (MkVar n _) -> n)
-    -- TEMP
-    , _programTypeSigs = mempty
-    }
 
---------------------------------------------------------------------------------
+exprToCore (LitE l) = litToCore l
 
--- | convert rl' types to Core types, annotate binders, and strip excess type
+letToCore :: forall es. (NameSupply :> es)
--- info.
+          => Rec -> [Rlp.Binding' RlpcPs] -> RlpExpr' RlpcPs -> Eff es Expr'
-retype :: Cofree RlpExprF' (Rlp.Type PsName) -> RlpExpr Var
+letToCore r bs e = do
-retype = (_extract %~ unquantify) >>> fmap typeToCore >>> cata \case
+    -- TODO: preserve binder order.
-    t :<$ InL (LamF bs e)
+    (bs',as) <- getParts
-        -> Finl (LamF bs' e)
+    let insbs | null bs'  = pure
+              | otherwise = pure . Let r bs'
+    appKendo (foldMap Kendo (as `snoc` insbs)) <=< exprToCore $ unXRec e
   where
-        bs' = zipWith MkVar bs (t ^.. arrowStops)
+    -- partition & map the list of binders into:
+    --  bs'   : the let-binds that may be directly translated to Core
+    --          let-binds (we do exactly that). this is all the binders that
+    --          are a simple variable rather than a pattern match.
+    -- and as : the let-binds that may **not** be directly translated to
+    --          Core let-exprs. they get turned into case alternates.
+    getParts = traverse f bs <&> partitionEithers
 
-    t :<$ InL (VarF n)
+    f :: Rlp.Binding' RlpcPs
-        -> Finl (VarF n)
+      -> Eff es (Either Core.Binding' (Expr' -> Eff es Expr'))
+    f (PatB'' (VarP'' n) e) = Left . (n :=) <$> exprToCore (unXRec e)
+    f (PatB'' p          e) = pure $ Right (caseify p e)
 
-    t :<$ InR (LetEF r bs e)
+litToCore :: (NameSupply :> es) => Rlp.Lit RlpcPs -> Eff es Expr'
-        -> Finr (LetEF r _ _)
+litToCore (Rlp.IntL n) = pure . Lit $ Core.IntL n
 
-    t :<$ InR (CaseEF e as)
+{-
-        -> _
+let C x = y
+in e
 
-unquantify :: Rlp.Type b
+case y of
-           -> Rlp.Type b
+    C x -> e
-unquantify (ForallT _ x) = unquantify x
+ -}
-unquantify x             = x
 
-typeToCore :: Rlp.Type PsName -> Core.Type
+caseify :: (NameSupply :> es)
-typeToCore = cata \case
+        => Pat' RlpcPs -> RlpExpr' RlpcPs -> Expr' -> Eff es Expr'
-    VarTF n   -> TyVar n
+caseify p (unXRec -> e) i =
-    ConTF n   -> TyCon n
+    Case <$> exprToCore e <*> ((:[]) <$> alt)
-    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
+    alt = conToRose (unXRec p) <&> foldFix (branchToCore i)
-    b2b (VarB (VarP k) v) = Binding k v
+
+-- TODO: where-binds
+caseAltToCore :: (HasCallStack, NameSupply :> es)
+              => (Alt RlpcPs, Where RlpcPs) -> Eff es Alter'
+caseAltToCore (AltA (unXRec -> p) e, wh) = do
+    e' <- exprToCore . unXRec $ e
+    conToRose p <&> foldFix (branchToCore e')
+
+altToCore :: (NameSupply :> es)
+          => Alt RlpcPs -> Eff es Alter'
+altToCore (AltA p e) = altToCore' p e
+
+altToCore' :: (NameSupply :> es)
+           => Pat' RlpcPs -> RlpExpr' RlpcPs -> Eff es Alter'
+altToCore' (unXRec -> p) (unXRec -> e) = do
+    e' <- exprToCore e
+    conToRose p <&> foldFix (branchToCore e')
+
+conToRose :: forall es. (HasCallStack, NameSupply :> es) => Pat RlpcPs -> Eff es Rose
+conToRose (ConP cn as) = Fix . Branch cn <$> patToForrest `traverse` as
+    where
+        patToForrest :: Pat' RlpcPs -> Eff es (Tree Rose)
+        patToForrest (VarP'' x) = pure $ Left (dsNameToName x)
+        patToForrest p@(ConP'' _ _) =
+            Right <$> liftA2 (,) uniqueName br
+          where
+            br = unwrapFix <$> conToRose (unXRec p)
+conToRose s = error $ "conToRose: not a ConP!: " <> show s
+
+branchToCore :: Expr' -> Branch Alter' -> Alter'
+branchToCore e (Branch cn as) = Alter (AltData cn) myBinds e'
+    where
+        -- gather binders for the /current/ pattern, and build an expression
+        -- matching subpatterns
+        (e', myBinds) = mapAccumL f e as
+
+        f :: Expr' -> Tree Alter' -> (Expr', Name)
+        f e (Left n)       = (e, dsNameToName n)
+        f e (Right (n,cs)) = (e', dsNameToName n) where
+            e' = Case (Var $ dsNameToName n) [branchToCore e cs]
+
+runNameSupply :: IdP RlpcPs -> Eff (NameSupply ': es) a -> Eff es a
+runNameSupply n = runLabeled @NameSupplyLabel (evalState ns) where
+    ns = [ "$" <> n <> "_" <> T.pack (show k) | k <- [0..] ]
+
+-- | debug helper
+
+nameSupply :: [IdP RlpcPs]
+nameSupply = [ T.pack $ "$x_" <> show n | n <- [0..] ]
+
+uniqueName :: (NameSupply :> es) => Eff es (IdP RlpcPs)
+uniqueName = labeled @NameSupplyLabel @(State [IdP RlpcPs]) $
+    state @[IdP RlpcPs] (fromMaybe err . uncons)
+  where
+    err = error "NameSupply ran out of names! This shound never happen.\
+                \ The caller of runNameSupply is responsible."
+
+constructorToCore :: Type -> Tag -> ConAlt RlpcPs -> Program'
+constructorToCore t tag (ConAlt cn as) =
+    mempty & programTypeSigs . at cn ?~ foldr (:->) t as'
+           & programDataTags . at cn ?~ (tag, length as)
+    where
+        as' = typeToCore <$> as
+
+typeToCore :: RlpType' RlpcPs -> Type
+typeToCore FunConT''    = TyFun
+typeToCore (FunT'' s t) = typeToCore s :-> typeToCore t
+typeToCore (AppT'' s t) = TyApp (typeToCore s) (typeToCore t)
+typeToCore (ConT'' n)   = TyCon (dsNameToName n)
+typeToCore (VarT'' x)   = TyVar (dsNameToName x)
+
+-- | Forwards-compatiblity if IdP RlpDs is changed
+dsNameToName :: IdP RlpcPs -> Name
+dsNameToName = id
+
+-}
 

tst/Rlp/HindleyMilnerSpec.hs

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

visualisers/hmvis/.gitignore

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

visualisers/hmvis/package.json

@@ -1,11 +0,0 @@
-{
-  "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

@@ -1,99 +0,0 @@
-@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

@@ -1,303 +0,0 @@
-@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

@@ -1,22 +0,0 @@
-<!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

@@ -1,27 +0,0 @@
-;; 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

@@ -1,154 +0,0 @@
-(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

@@ -1,41 +0,0 @@
-(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

@@ -1,103 +0,0 @@
-(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"))
-