renamePrettily

whole-program inference

whole-program inference

whole-program inference

.ghci

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

Makefile_happysrcs

@@ -5,7 +5,7 @@ ALEX = alex
 ALEX_OPTS = -g
 
 SRC = src
-CABAL_BUILD = $(shell ./find-build.cl)
+CABAL_BUILD = $(shell ./find-build.clj)
 
 all: parsers lexers
 

README.md

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

@@ -0,0 +1,188 @@
+#+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 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]
+
+** TODO ~case~ inference                                               :feature:
+
+** DONE ADT support in Rlp/HindleyMilner.hs                            :feature:
+   CLOSED: [2024-03-28 Thu 11:55]
+
+** 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:
+
+** TODO update architecture diagram                                       :docs:
+
+** TODO pattern support; everywhere [0%]                                :feature:
+   - [ ] in the type-checker
+   - [ ] in the desugarer
+
+** TODO G-machine visualiser                                              :docs:
+
+** TODO 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)
+
+* 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
+
+** March Release Plan
+- [ ] Tests
+    - [ ] rl' parser
+    - [ ] Type inference
+- [X] Ditch TTG in favour of a simpler AST focusing on extendability via Fix, Free, 
+  Cofree, etc. rather than boilerplate-heavy type families
+- [X] rl' type inference
+- [X] Core type checking
+
+

app/CoreDriver.hs

@@ -10,15 +10,17 @@ import Control.Lens.Combinators
 
 import Core.Lex
 import Core.Parse
+import Core.SystemF
 import GM
 --------------------------------------------------------------------------------
 
 driver :: RLPCIO ()
 driver = forFiles_ $ \f ->
-    withSource f (lexCoreR >=> parseCoreProgR >=> evalProgR)
+    withSource f (lexCoreR >=> parseCoreProgR >=> lintCoreProgR >=> evalProgR)
 
 driverSource :: T.Text -> RLPCIO ()
-driverSource = lexCoreR >=> parseCoreProgR >=> evalProgR >=> printRes
+driverSource = lexCoreR >=> parseCoreProgR
+           >=> lintCoreProgR >=> evalProgR >=> printRes
     where
         printRes = liftIO . print . view _1
 

app/Main.hs

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

app/Server.hs

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

find-build.cl

@@ -1,8 +0,0 @@
-#!/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

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

rlp.cabal

@@ -16,6 +16,7 @@ tested-with:        GHC==9.6.2
 
 common warnings
 --    ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-unused-top-binds
+    ghc-options: -fdefer-typed-holes
 
 library
     import:           warnings
@@ -35,10 +36,10 @@ library
                     , Rlp.AltSyntax
                     , Rlp.AltParse
                     , Rlp.HindleyMilner
+                    , Rlp.HindleyMilner.Visual
                     , Rlp.HindleyMilner.Types
                     , Rlp.Syntax.Backstage
                     , Rlp.Syntax.Types
-                    , Rlp.Syntax.Good
                     -- , Rlp.Parse.Decls
                     , Rlp.Parse
                     , Rlp.Parse.Associate
@@ -56,17 +57,18 @@ library
                     , Control.Monad.Utils
                     , Misc
                     , Misc.Lift1
+                    , Misc.CofreeF
                     , Core.SystemF
 
     build-tool-depends: happy:happy, alex:alex
 
     -- other-extensions:
-    build-depends:    base >=4.17 && <4.20
+    build-depends:    base >=4.17 && <4.21
                     -- required for happy
                     , array >= 0.5.5 && < 0.6
                     , containers >= 0.6.7 && < 0.7
-                    , template-haskell >= 2.20.0 && < 2.21
+                    , template-haskell >= 2.20.0 && < 2.22
-                    , pretty >= 1.1.3 && < 1.2
+                    , prettyprinter
                     , data-default >= 0.7.1 && < 0.8
                     , data-default-class >= 0.1.2 && < 0.2
                     , hashable >= 1.4.3 && < 1.5
@@ -87,6 +89,8 @@ 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
@@ -107,6 +111,7 @@ executable rlpc
     main-is:          Main.hs
     other-modules:    RlpDriver
                     , CoreDriver
+                    , Server
 
     build-depends: base >=4.17.0.0 && <4.20.0.0
                  , rlp
@@ -115,6 +120,10 @@ executable rlpc
                  , unordered-containers >= 0.2.20 && < 0.3
                  , lens >=5.2.3 && <6.0
                  , text >= 2.0.2 && < 2.2
+                 , websockets
+                 , aeson
+                 , recursion-schemes >= 5.2.2 && < 5.3
+                 , comonad
 
     hs-source-dirs:   app
     default-language: GHC2021

src/Compiler/JustRun.hs

@@ -65,11 +65,11 @@ justTypeCheckCore s = typechk (T.pack s)
                     & rlpcToEither
     where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR
 
-makeItPretty :: (Pretty a) => Either e a -> Either e Doc
+makeItPretty :: (Out a) => Either e a -> Either e (Doc ann)
-makeItPretty = fmap pretty
+makeItPretty = fmap out
 
-makeItPretty' :: (Pretty (WithTerseBinds a)) => Either e a -> Either e Doc
+makeItPretty' :: (Out (WithTerseBinds a)) => Either e a -> Either e (Doc ann)
-makeItPretty' = fmap (pretty . WithTerseBinds)
+makeItPretty' = fmap (out . WithTerseBinds)
 
 rlpcToEither :: RLPC a -> Either [MsgEnvelope RlpcError] a
 rlpcToEither r = case evalRLPC def r of

src/Compiler/RLPC.hs

@@ -26,8 +26,9 @@ module Compiler.RLPC
     , DebugFlag(..), CompilerFlag(..)
     -- ** Lenses
     , rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage
+    , rlpcServer
     -- * Misc. MTL-style functions
-    , liftErrorful, liftMaybe, hoistRlpcT
+    , liftErrorful, liftEither, liftMaybe, hoistRlpcT
     -- * Misc. Rlpc Monad -related types
     , RLPCOptions(RLPCOptions), IsRlpcError(..), RlpcError(..)
     , MsgEnvelope(..), Severity(..)
@@ -54,6 +55,7 @@ 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
@@ -63,7 +65,6 @@ 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
@@ -111,6 +112,13 @@ 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 ->
@@ -123,6 +131,7 @@ data RLPCOptions = RLPCOptions
     , _rlpcEvaluator   :: Evaluator
     , _rlpcHeapTrigger :: Int
     , _rlpcLanguage    :: Maybe Language
+    , _rlpcServer      :: Bool
     , _rlpcInputFiles  :: [FilePath]
     }
     deriving Show
@@ -143,6 +152,7 @@ instance Default RLPCOptions where
         , _rlpcEvaluator = EvaluatorGM
         , _rlpcHeapTrigger = 200
         , _rlpcInputFiles = []
+        , _rlpcServer = False
         , _rlpcLanguage = Nothing
         }
 
@@ -203,7 +213,7 @@ renderRlpcErrs opts = (if don'tBother then id else filter byTag)
 
 prettyRlpcMsg :: MsgEnvelope RlpcError -> String
 prettyRlpcMsg m@(view msgSeverity -> SevDebug _) = prettyRlpcDebugMsg m
-prettyRlpcMsg m                                  = render $ docRlpcErr m
+prettyRlpcMsg m                                  = show $ docRlpcErr m
 
 prettyRlpcDebugMsg :: MsgEnvelope RlpcError -> String
 prettyRlpcDebugMsg msg =
@@ -213,10 +223,10 @@ prettyRlpcDebugMsg msg =
         Text ts = msg ^. msgDiagnostic
         SevDebug tag = msg ^. msgSeverity
 
-docRlpcErr :: MsgEnvelope RlpcError -> Doc
+docRlpcErr :: MsgEnvelope RlpcError -> Doc ann
-docRlpcErr msg = header
+docRlpcErr msg = vcat [ header
-                 $$ nest 2 bullets
+                      , nest 2 bullets
-                 $$ source
+                      , source ]
     where
         source = vcat $ zipWith (<+>) rule srclines
             where
@@ -231,11 +241,10 @@ docRlpcErr msg = 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,8 +24,11 @@ import Control.Monad.Errorful
 import Data.Text                (Text)
 import Data.Text                qualified as T
 import GHC.Exts                 (IsString(..))
-import Control.Lens
+import GHC.Generics
+import Control.Lens             hiding ((.=))
 import Compiler.Types
+
+import Data.Aeson
 ----------------------------------------------------------------------------------
 
 data MsgEnvelope e = MsgEnvelope
@@ -35,8 +38,17 @@ data MsgEnvelope e = MsgEnvelope
    }
    deriving (Functor, Show)
 
+instance (ToJSON e) => ToJSON (MsgEnvelope e) where
+    toJSON msg = object
+        [ "span" .= _msgSpan msg
+        , "severity" .= _msgSeverity msg
+        , "diagnostic" .= _msgDiagnostic msg
+        ]
+
 newtype RlpcError = Text [Text]
-               deriving Show
+    deriving (Show, Generic)
+    deriving (ToJSON)
+        via Generically [Text]
 
 instance IsString RlpcError where
     fromString = Text . pure . T.pack
@@ -50,7 +62,9 @@ instance IsRlpcError RlpcError where
 data Severity = SevWarning
               | SevError
               | SevDebug Text -- ^ Tag
-              deriving Show
+              deriving (Show, Generic)
+              deriving (ToJSON)
+                via Generically Severity
 
 makeLenses ''MsgEnvelope
 

src/Compiler/Types.hs

@@ -27,27 +27,32 @@ 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 Control.Lens                 hiding ((<<~), (:<))
+import Data.Aeson
+import Control.Lens                 hiding ((<<~), (:<), (.=))
 
 import Data.List.NonEmpty           (NonEmpty)
 import Data.Function                (on)
+import Misc.CofreeF
 --------------------------------------------------------------------------------
 
 -- | Token wrapped with a span (line, column, absolute, length)
 data Located a = Located SrcSpan a
     deriving (Show, Lift, Functor)
 
-pattern (:<$) :: a -> f b -> Trans.Cofree.CofreeF f a b
+instance ToJSON SrcSpan where
-pattern a :<$ b = a Trans.Cofree.:< b
+    toJSON (SrcSpan l c a s) = object
+        [ "line" .= l
+        , "column" .= c
+        , "abs" .= a
+        , "length" .= s]
 
 (<~>) :: a -> b -> SrcSpan
 (<~>) = undefined

src/Control/Monad/Errorful.hs

@@ -41,10 +41,15 @@ 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)
@@ -86,6 +91,7 @@ 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
@@ -96,6 +102,10 @@ instance (Monoid w, Monad m, MonadWriter w m) => MonadWriter w (ErrorfulT e m) 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,22 +16,9 @@ module Core.HindleyMilner
     )
     where
 ----------------------------------------------------------------------------------
-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 Data.Text qualified as T
-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
 ----------------------------------------------------------------------------------
 
@@ -60,21 +47,7 @@ data TypeError
     deriving (Show, Eq)
 
 instance IsRlpcError TypeError where
-    liftRlpcError = \case
+    liftRlpcError = undefined
-        -- todo: use anti-parser instead of show
-        TyErrCouldNotUnify t u -> Text
-            [ T.pack $ printf "Could not match type `%s` with `%s`."
-                              (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,8 +29,8 @@ module Core.Syntax
     , pattern Con, pattern Var, pattern App, pattern Lam, pattern Let
     , pattern Case, pattern Type, pattern Lit
 
-    -- * Pretty-printing
+    -- * pretty-printing
-    , Pretty(pretty), WithTerseBinds(..)
+    , Out(out), WithTerseBinds(..)
 
     -- * Optics
     , HasArrowSyntax(..)
@@ -59,7 +59,9 @@ import Data.Functor.Classes
 import Data.Text                    qualified as T
 import Data.Char
 import Data.These
-import GHC.Generics                 (Generic, Generic1, Generically(..))
+import Data.Aeson
+import GHC.Generics                 ( Generic, Generic1
+                                    , Generically(..), Generically1(..))
 import Text.Show.Deriving
 import Data.Eq.Deriving
 import Data.Kind                    qualified
@@ -110,7 +112,7 @@ type Kind = Type
 --     deriving (Eq, Show, Lift)
 
 data Var = MkVar Name Type
-    deriving (Eq, Show, Lift)
+    deriving (Eq, Show, Lift, Generic)
 
 pattern (:^) :: Name -> Type -> Var
 pattern n :^ t = MkVar n t
@@ -335,11 +337,11 @@ instance MakeTerse Var where
     type AsTerse Var = Name
     asTerse (MkVar n _) = n
 
-instance (Hashable b, Pretty b, Pretty (AsTerse b), MakeTerse b)
+instance (Hashable b, Out b, Out (AsTerse b), MakeTerse b)
-      => Pretty (WithTerseBinds (Program b)) where
+      => Out (WithTerseBinds (Program b)) where
-    pretty (WithTerseBinds p)
+    out (WithTerseBinds p)
-            = (datatags <> "\n")
+            = vsep [ (datatags <> "\n")
-          $+$ defs
+                   , defs ]
         where
             datatags = ifoldrOf (programDataTags . ifolded) cataDataTag mempty p
             defs = vlinesOf (programJoinedDefs . to prettyGroup) p
@@ -355,17 +357,17 @@ instance (Hashable b, Pretty b, Pretty (AsTerse b), MakeTerse b)
             thatSc = foldMap $ \sc ->
                 H.singleton (sc ^. _lhs . _1) (That sc)
 
-            prettyGroup :: These (b, Type) (ScDef b) -> Doc
+            prettyGroup :: These (b, Type) (ScDef b) -> Doc ann
             prettyGroup = bifoldr vs vs mempty
                         . bimap (uncurry prettyTySig')
-                                (pretty . WithTerseBinds)
+                                (out . WithTerseBinds)
-                where vs = vsepTerm ";"
+                where vs a b = a <> ";" <> line <> b
 
-            cataDataTag n (t,a) acc = prettyDataTag n t a $+$ acc
+            cataDataTag n (t,a) acc = prettyDataTag n t a <> line <> acc
 
-instance (Hashable b, Pretty b) => Pretty (Program b) where
+instance (Hashable b, Out b) => Out (Program b) where
-    pretty p = (datatags <> "\n")
+    out p = vsep [ datatags <> "\n"
-           $+$ defs
+                 , defs ]
         where
             datatags = ifoldrOf (programDataTags . ifolded) cataDataTag mempty p
             defs = vlinesOf (programJoinedDefs . to prettyGroup) p
@@ -381,139 +383,124 @@ instance (Hashable b, Pretty b) => Pretty (Program b) where
             thatSc = foldMap $ \sc ->
                 H.singleton (sc ^. _lhs . _1) (That sc)
 
-            prettyGroup :: These (b, Type) (ScDef b) -> Doc
+            prettyGroup :: These (b, Type) (ScDef b) -> Doc ann
             prettyGroup = bifoldr vs vs mempty
-                        . bimap (uncurry prettyTySig) pretty
+                        . bimap (uncurry prettyTySig) out
-                where vs = vsepTerm ";"
+                where vs a b = a <> ";" <> line <> b
 
-            cataDataTag n (t,a) acc = prettyDataTag n t a $+$ acc
+            cataDataTag n (t,a) acc = prettyDataTag n t a <> line <> acc
 
 unionThese :: These a b -> These a b -> These a b
 unionThese (This a) (That b) = These a b
 unionThese (That b) (This a) = These a b
 unionThese (These a b) _     = These a b
 
-prettyDataTag :: (Pretty n, Pretty t, Pretty a)
+prettyDataTag :: (Out n, Out t, Out a)
-              => n -> t -> a -> Doc
+              => n -> t -> a -> Doc ann
 prettyDataTag n t a =
     hsep ["{-#", "PackData", ttext n, ttext t, ttext a, "#-}"]
 
-prettyTySig :: (Pretty n, Pretty t) => n -> t -> Doc
+prettyTySig :: (Out n, Out t) => n -> t -> Doc ann
-prettyTySig n t = hsep [ttext n, ":", pretty t]
+prettyTySig n t = hsep [ttext n, ":", out t]
 
-prettyTySig' :: (MakeTerse n, Pretty (AsTerse n), Pretty t) => n -> t -> Doc
+prettyTySig' :: (MakeTerse n, Out (AsTerse n), Out t) => n -> t -> Doc ann
-prettyTySig' n t = hsep [ttext (asTerse n), ":", pretty t]
+prettyTySig' n t = hsep [ttext (asTerse n), ":", out t]
 
--- Pretty Type
+-- out Type
 -- TyApp | appPrec   | left
 -- (:->) | appPrec-1 | right
 
-instance Pretty Type where
+instance Out Type where
-    prettyPrec _ (TyVar n)   = ttext n
+    outPrec _ (TyVar n)   = ttext n
-    prettyPrec _ TyFun       = "(->)"
+    outPrec _ TyFun       = "(->)"
-    prettyPrec _ (TyCon n)   = ttext n
+    outPrec _ (TyCon n)   = ttext n
-    prettyPrec p (a :-> b)   = maybeParens (p>appPrec-1) $
+    outPrec p (a :-> b)   = maybeParens (p>appPrec-1) $
-        hsep [prettyPrec appPrec a, "->", prettyPrec (appPrec-1) b]
+        hsep [outPrec appPrec a, "->", outPrec (appPrec-1) b]
-    prettyPrec p (TyApp f x) = maybeParens (p>appPrec) $
+    outPrec p (TyApp f x) = maybeParens (p>appPrec) $
-        prettyPrec appPrec f <+> prettyPrec appPrec1 x
+        outPrec appPrec f <+> outPrec appPrec1 x
-    prettyPrec p (TyForall a m) = maybeParens (p>appPrec-2) $
+    outPrec p (TyForall a m) = maybeParens (p>appPrec-2) $
-        "∀" <+> (prettyPrec appPrec1 a <> ".") <+> pretty m
+        "∀" <+> (outPrec appPrec1 a <> ".") <+> out m
-    prettyPrec _ TyKindType = "Type"
+    outPrec _ TyKindType = "Type"
 
-instance (Pretty b, Pretty (AsTerse b), MakeTerse b)
+instance (Out b, Out (AsTerse b), MakeTerse b)
-      => Pretty (WithTerseBinds (ScDef b)) where
+      => Out (WithTerseBinds (ScDef b)) where
-    pretty (WithTerseBinds sc) = hsep [name, as, "=", hang empty 1 e]
+    out (WithTerseBinds sc) = hsep [name, as, "=", hang 1 e]
         where
             name = ttext $ sc ^. _lhs . _1 . to asTerse
             as = sc & hsepOf (_lhs . _2 . each . to asTerse . to ttext)
-            e = pretty $ sc ^. _rhs
+            e = out $ sc ^. _rhs
 
-instance (Pretty b) => Pretty (ScDef b) where
+instance (Out b) => Out (ScDef b) where
-    pretty sc = hsep [name, as, "=", hang empty 1 e]
+    out sc = hsep [name, as, "=", hang 1 e]
         where
             name = ttext $ sc ^. _lhs . _1
             as = sc & hsepOf (_lhs . _2 . each . to ttext)
-            e = pretty $ sc ^. _rhs
+            e = out $ sc ^. _rhs
 
--- Pretty Expr
+-- out Expr
 -- LamF | appPrec1 | right
 -- AppF | appPrec  | left
 
-instance (Pretty b, Pretty a) => Pretty (ExprF b a) where
+instance (Out b, Out a) => Out (ExprF b a) where
-    prettyPrec = prettyPrec1
+    outPrec = outPrec1
 
-    -- prettyPrec _ (VarF n) = ttext n
+instance (Out b) => Out1 (ExprF b) where
-    -- prettyPrec _ (ConF t a) = "Pack{" <> (ttext t <+> ttext a) <> "}"
+    liftOutPrec pr _ (VarF n) = ttext n
-    -- prettyPrec p (LamF bs e) = maybeParens (p>0) $
+    liftOutPrec pr _ (ConF t a) = "Pack{" <> (ttext t <+> ttext a) <> "}"
-    --     hsep ["λ", hsep (prettyPrec appPrec1 <$> bs), "->", pretty e]
+    liftOutPrec pr p (LamF bs e) = maybeParens (p>0) $
-    -- prettyPrec p (LetF r bs e) = maybeParens (p>0)
+        hsep ["λ", hsep (outPrec appPrec1 <$> bs), "->", pr 0 e]
-    --                            $ hsep [pretty r, explicitLayout bs]
+    liftOutPrec pr p (LetF r bs e) = maybeParens (p>0)
-    --                          $+$ hsep ["in", pretty e]
+                               $ vsep [ hsep [out r, bs']
-    -- prettyPrec p (AppF f x) = maybeParens (p>appPrec) $
+                                      , hsep ["in", pr 0 e] ]
-    --     prettyPrec appPrec f <+> prettyPrec appPrec1 x
+        where bs' = liftExplicitLayout (liftOutPrec pr 0) bs
-    -- prettyPrec p (LitF l) = prettyPrec p l
+    liftOutPrec pr p (AppF f x) = maybeParens (p>appPrec) $
-    -- prettyPrec p (CaseF e as) = maybeParens (p>0) $
-    --     "case" <+> pretty e <+> "of"
-    --     $+$ nest 2 (explicitLayout as)
-    -- prettyPrec p (TypeF t) = "@" <> prettyPrec appPrec1 t
-
-instance (Pretty b) => Pretty1 (ExprF b) where
-    liftPrettyPrec pr _ (VarF n) = ttext n
-    liftPrettyPrec pr _ (ConF t a) = "Pack{" <> (ttext t <+> ttext a) <> "}"
-    liftPrettyPrec pr p (LamF bs e) = maybeParens (p>0) $
-        hsep ["λ", hsep (prettyPrec appPrec1 <$> bs), "->", pr 0 e]
-    liftPrettyPrec pr p (LetF r bs e) = maybeParens (p>0)
-                               $ hsep [pretty r, bs']
-                             $+$ hsep ["in", pr 0 e]
-        where bs' = liftExplicitLayout (liftPrettyPrec pr 0) bs
-    liftPrettyPrec pr p (AppF f x) = maybeParens (p>appPrec) $
         pr appPrec f <+> pr appPrec1 x
-    liftPrettyPrec pr p (LitF l) = prettyPrec p l
+    liftOutPrec pr p (LitF l) = outPrec p l
-    liftPrettyPrec pr p (CaseF e as) = maybeParens (p>0) $
+    liftOutPrec pr p (CaseF e as) = maybeParens (p>0) $
-            "case" <+> pr 0 e <+> "of"
+            vsep [ "case" <+> pr 0 e <+> "of"
-            $+$ nest 2 as'
+                 , nest 2 as' ]
-        where as' = liftExplicitLayout (liftPrettyPrec pr 0) as
+        where as' = liftExplicitLayout (liftOutPrec pr 0) as
-    liftPrettyPrec pr p (TypeF t) = "@" <> prettyPrec appPrec1 t
+    liftOutPrec pr p (TypeF t) = "@" <> outPrec appPrec1 t
 
-instance Pretty Rec where
+instance Out Rec where
-    pretty Rec = "letrec"
+    out Rec = "letrec"
-    pretty NonRec = "let"
+    out NonRec = "let"
 
-instance (Pretty b, Pretty a) => Pretty (AlterF b a) where
+instance (Out b, Out a) => Out (AlterF b a) where
-    prettyPrec = prettyPrec1
+    outPrec = outPrec1
 
-instance (Pretty b) => Pretty1 (AlterF b) where
+instance (Out b) => Out1 (AlterF b) where
-    liftPrettyPrec pr _ (AlterF c as e) =
+    liftOutPrec pr _ (AlterF c as e) =
-        hsep [pretty c, hsep (pretty <$> as), "->", liftPrettyPrec pr 0 e]
+        hsep [out c, hsep (out <$> as), "->", liftOutPrec pr 0 e]
 
-instance Pretty AltCon where
+instance Out AltCon where
-    pretty (AltData n) = ttext n
+    out (AltData n) = ttext n
-    pretty (AltLit l) = pretty l
+    out (AltLit l) = out l
-    pretty (AltTag t) = "<" <> ttext t <> ">"
+    out (AltTag t) = "<" <> ttext t <> ">"
-    pretty AltDefault = "_"
+    out AltDefault = "_"
 
-instance Pretty Lit where
+instance Out Lit where
-    pretty (IntL n) = ttext n
+    out (IntL n) = ttext n
 
-instance (Pretty b, Pretty a) => Pretty (BindingF b a) where
+instance (Out b, Out a) => Out (BindingF b a) where
-    prettyPrec = prettyPrec1
+    outPrec = outPrec1
 
-instance Pretty b => Pretty1 (BindingF b) where
+instance Out b => Out1 (BindingF b) where
-    liftPrettyPrec pr _ (BindingF k v) = hsep [pretty k, "=", liftPrettyPrec pr 0 v]
+    liftOutPrec pr _ (BindingF k v) = hsep [out k, "=", liftOutPrec pr 0 v]
 
-liftExplicitLayout :: (a -> Doc) -> [a] -> Doc
+liftExplicitLayout :: (a -> Doc ann) -> [a] -> Doc ann
 liftExplicitLayout pr as = vcat inner <+> "}" where
     inner = zipWith (<+>) delims (pr <$> as)
     delims = "{" : repeat ";"
 
-explicitLayout :: (Pretty a) => [a] -> Doc
+explicitLayout :: (Out a) => [a] -> Doc ann
 explicitLayout as = vcat inner <+> "}" where
-    inner = zipWith (<+>) delims (pretty <$> as)
+    inner = zipWith (<+>) delims (out <$> as)
     delims = "{" : repeat ";"
 
-instance Pretty Var where
+instance Out Var where
-    prettyPrec p (MkVar n t) = maybeParens (p>0) $
+    outPrec p (MkVar n t) = maybeParens (p>0) $
-        hsep [pretty n, ":", pretty t]
+        hsep [out n, ":", out t]
 
 --------------------------------------------------------------------------------
 
@@ -780,3 +767,21 @@ 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,6 +2,7 @@
 {-# LANGUAGE OverloadedLists #-}
 module Core.SystemF
     ( lintCoreProgR
+    , kindOf
     )
     where
 --------------------------------------------------------------------------------
@@ -21,7 +22,7 @@ import Text.Printf
 import Control.Comonad
 import Control.Comonad.Cofree
 import Data.Fix
-import Data.Functor
+import Data.Functor                 hiding (unzip)
 
 import Control.Lens                 hiding ((:<))
 import Control.Lens.Unsound
@@ -43,7 +44,7 @@ data Gamma = Gamma
 makeLenses ''Gamma
 
 lintCoreProgR :: (Monad m) => Program Var -> RLPCT m (Program Name)
-lintCoreProgR = undefined
+lintCoreProgR = liftEither . (_Left %~ pure) . lint
 
 lintDontCheck :: Program Var -> Program Name
 lintDontCheck = binders %~ view (_MkVar . _1)
@@ -91,14 +92,14 @@ instance IsRlpcError SystemFError where
             undefinedVariableErr n
         SystemFErrorKindMismatch k k' ->
             Text [ T.pack $ printf "Could not match kind `%s' with `%s'"
-                                   (pretty k) (pretty k')
+                                   (out k) (out k')
                  ]
         SystemFErrorCouldNotMatch t t' ->
             Text [ T.pack $ printf "Could not match type `%s' with `%s'"
-                                   (pretty t) (pretty t')
+                                   (out t) (out t')
                  ]
 
-justLintCoreExpr = fmap (fmap (prettyPrec appPrec1)) . lintE demoContext
+justLintCoreExpr = fmap (fmap (outPrec appPrec1)) . lintE demoContext
 
 lintE :: Gamma -> Expr Var -> SysF ET
 lintE g = \case

src/Core2Core.hs

@@ -37,7 +37,7 @@ core2core p = undefined
 gmPrepR :: (Monad m) => Program' -> RLPCT m Program'
 gmPrepR p = do
     let p' = gmPrep p
-    addDebugMsg "dump-gm-preprocessed" $ render . pretty $ p'
+    addDebugMsg "dump-gm-preprocessed" $ show . out $ p'
     pure p'
 
 -- | G-machine-specific preprocessing.

src/Data/Pretty.hs

@@ -1,26 +1,26 @@
+{-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE QuantifiedConstraints, UndecidableInstances #-}
 module Data.Pretty
-    ( Pretty(..), Pretty1(..)
+    ( Out(..), Out1(..)
-    , prettyPrec1
+    , outPrec1
-    , rpretty
+    , rout
     , ttext
     , Showing(..)
-    -- * Pretty-printing lens combinators
+    -- * Out-printing lens combinators
-    , hsepOf, vsepOf, vcatOf, vlinesOf, vsepTerm
+    , hsepOf, vsepOf, vcatOf, vlinesOf
-    , vsep
+    , module Prettyprinter
-    , module Text.PrettyPrint
     , maybeParens
     , appPrec
     , appPrec1
     )
     where
 ----------------------------------------------------------------------------------
-import Text.PrettyPrint             hiding ((<>))
+import Prettyprinter
-import Text.PrettyPrint.HughesPJ    hiding ((<>))
 import Text.Printf
 import Data.String                  (IsString(..))
 import Data.Text.Lens               hiding ((:<))
 import Data.Monoid                  hiding (Sum)
+import Data.Bool
 import Control.Lens
 
 -- instances
@@ -30,83 +30,80 @@ import Data.Functor.Sum
 import Data.Fix                     (Fix(..))
 ----------------------------------------------------------------------------------
 
-class Pretty a where
+class Out a where
-    pretty :: a -> Doc
+    out :: a -> Doc ann
-    prettyPrec :: Int -> a -> Doc
+    outPrec :: Int -> a -> Doc ann
 
-    {-# MINIMAL pretty | prettyPrec #-}
+    {-# MINIMAL out | outPrec #-}
-    pretty = prettyPrec 0
+    out = outPrec 0
-    prettyPrec = const pretty
+    outPrec = const out
 
-rpretty :: (IsString s, Pretty a) => a -> s
+rout :: (IsString s, Out a) => a -> s
-rpretty = fromString . render . pretty
+rout = fromString . show . out
 
-instance Pretty String where
+-- instance Out (Doc ann) where
-    pretty = Text.PrettyPrint.text
+--     out = id
 
-instance Pretty T.Text where
+instance Out String where
-    pretty = Text.PrettyPrint.text . view unpacked
+    out = pretty
+
+instance Out T.Text where
+    out = pretty
 
 newtype Showing a = Showing a
 
-instance (Show a) => Pretty (Showing a) where
+instance (Show a) => Out (Showing a) where
-    prettyPrec p (Showing a) = fromString $ showsPrec p a ""
+    outPrec p (Showing a) = fromString $ showsPrec p a ""
 
-deriving via Showing Int instance Pretty Int
+deriving via Showing Int instance Out Int
 
-class (forall a. Pretty a => Pretty (f a)) => Pretty1 f where
+class (forall a. Out a => Out (f a)) => Out1 f where
-    liftPrettyPrec :: (Int -> a -> Doc) -> Int -> f a -> Doc
+    liftOutPrec :: (Int -> a -> Doc ann) -> Int -> f a -> Doc ann
 
-prettyPrec1 :: (Pretty1 f, Pretty a) => Int -> f a -> Doc
+outPrec1 :: (Out1 f, Out a) => Int -> f a -> Doc ann
-prettyPrec1 = liftPrettyPrec prettyPrec
+outPrec1 = liftOutPrec outPrec
 
-instance (Pretty1 f, Pretty1 g, Pretty a) => Pretty (Sum f g a) where
+instance (Out1 f, Out1 g, Out a) => Out (Sum f g a) where
-    prettyPrec p (InL fa) = prettyPrec1 p fa
+    outPrec p (InL fa) = outPrec1 p fa
-    prettyPrec p (InR ga) = prettyPrec1 p ga
+    outPrec p (InR ga) = outPrec1 p ga
 
-instance (Pretty1 f, Pretty1 g) => Pretty1 (Sum f g) where
+instance (Out1 f, Out1 g) => Out1 (Sum f g) where
-    liftPrettyPrec pr p (InL fa) = liftPrettyPrec pr p fa
+    liftOutPrec pr p (InL fa) = liftOutPrec pr p fa
-    liftPrettyPrec pr p (InR ga) = liftPrettyPrec pr p ga
+    liftOutPrec pr p (InR ga) = liftOutPrec pr p ga
 
-instance (Pretty (f (Fix f))) => Pretty (Fix f) where
+instance (Out (f (Fix f))) => Out (Fix f) where
-    prettyPrec d (Fix f) = prettyPrec d f
+    outPrec d (Fix f) = outPrec d f
-
--- instance (Pretty1 f) => Pretty (Fix f) where
---     prettyPrec d (Fix f) = prettyPrec1 d f
 
 --------------------------------------------------------------------------------
 
-ttext :: Pretty t => t -> Doc
+ttext :: Out t => t -> Doc ann
-ttext = pretty
+ttext = out
 
-hsepOf :: Getting (Endo Doc) s Doc -> s -> Doc
+hsepOf :: Getting (Endo (Doc ann)) s (Doc ann) -> s -> Doc ann
 hsepOf l = foldrOf l (<+>) mempty
 
-vsepOf :: Getting (Endo Doc) s Doc -> s -> Doc
+vsepOf :: _ -> s -> Doc ann
-vsepOf l = foldrOf l ($+$) mempty
+vsepOf l = vsep . toListOf l
 
-vcatOf :: Getting (Endo Doc) s Doc -> s -> Doc
+vcatOf :: _ -> s -> Doc ann
-vcatOf l = foldrOf l ($$) mempty
+vcatOf l = vcat . toListOf l
 
-vlinesOf :: Getting (Endo Doc) s Doc -> s -> Doc
+vlinesOf :: Getting (Endo (Doc ann)) s (Doc ann) -> s -> Doc ann
-vlinesOf l = foldrOf l (\a b -> a $+$ "" $+$ b) mempty
+vlinesOf l = foldrOf l (\a b -> a <> line <> b) mempty
 -- hack(?) to separate chunks with a blankline
 
-vsepTerm :: Doc -> Doc -> Doc -> Doc
-vsepTerm term a b = (a <> term) $+$ b
-
-vsep :: [Doc] -> Doc
-vsep = foldr ($+$) mempty
-
 --------------------------------------------------------------------------------
 
+maybeParens :: Bool -> Doc ann -> Doc ann
+maybeParens = bool id parens
+
 appPrec, appPrec1 :: Int
 appPrec  = 10
 appPrec1 = 11
 
-instance PrintfArg Doc where
+instance PrintfArg (Doc ann) where
     formatArg d fmt
-        | fmtChar (vFmt 'D' fmt) == 'D' = formatString (render d) fmt'
+        | fmtChar (vFmt 'D' fmt) == 'D' = formatString (show 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 $ render r ++ "\n"
+        renderOut r = hPutStrLn hio $ show 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" $ render r ++ "\n"
+        renderOut r = addDebugMsg "dump-eval" $ show 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 -> Doc
+qquotes :: Doc ann -> Doc ann
 qquotes d = "`" <> d <> "'"
 
-showStats :: Stats -> Doc
+showStats :: Stats -> Doc ann
-showStats sts = "==== Stats ============" $$ stats
+showStats sts = "==== Stats ============" <> line <> stats
     where
-        stats = text $ printf
+        stats = textt @String $ printf
             "Reductions      : %5d\n\
             \Prim Reductions : %5d\n\
             \Allocations     : %5d\n\
@@ -839,10 +839,10 @@ showStats sts = "==== Stats ============" $$ stats
             (sts ^. stsAllocations)
             (sts ^. stsGCCycles)
 
-showState :: GmState -> Doc
+showState :: GmState -> Doc ann
 showState st = vcat
         [ "==== GmState " <> int stnum <> " "
-            <> text (replicate (28 - 13 - 1 - digitalWidth stnum) '=')
+            <> textt (replicate (28 - 13 - 1 - digitalWidth stnum) '=')
         , "-- Next instructions -------"
         , info $ showCodeShort c
         , "-- Stack -------------------"
@@ -859,23 +859,23 @@ showState st = vcat
         -- indent data
         info = nest pprTabstop
 
-showCodeShort :: Code -> Doc
+showCodeShort :: Code -> Doc ann
 showCodeShort c = braces c'
     where
         c' | length c > 3 = list (showInstr <$> take 3 c) <> "; ..."
            | otherwise    = list (showInstr <$> c)
         list = hcat . punctuate "; "
 
-showStackShort :: Stack -> Doc
+showStackShort :: Stack -> Doc ann
 showStackShort s = brackets s'
     where
            -- no access to heap, otherwise we'd use showNodeAt
         s' | length s > 3 = list (showEntry <$> take 3 s) <> ", ..."
            | otherwise    = list (showEntry <$> s)
         list = hcat . punctuate ", "
-        showEntry = text . show
+        showEntry = textt . show
 
-showStack :: GmState -> Doc
+showStack :: GmState -> Doc ann
 showStack st = vcat $ uncurry showEntry <$> si
     where
         h = st ^. gmHeap
@@ -887,10 +887,9 @@ showStack st = vcat $ uncurry showEntry <$> si
         w = maxWidth (addresses h)
         showIndex n = padInt w n <> ": "
 
-        showEntry :: Int -> Addr -> Doc
         showEntry n a = showIndex n <> showNodeAt st a
 
-showDump :: GmState -> Doc
+showDump :: GmState -> Doc ann
 showDump st = vcat $ uncurry showEntry <$> di
     where
         d = st ^. gmDump
@@ -899,14 +898,13 @@ showDump st = vcat $ uncurry showEntry <$> di
         showIndex n = padInt w n <> ": "
         w = maxWidth (fst <$> di)
 
-        showEntry :: Int -> (Code, Stack) -> Doc
         showEntry n (c,s) = showIndex n <> nest pprTabstop entry
             where
-                entry = ("Stack : " <> showCodeShort c)
+                entry = vsep [ "Stack : " <> showCodeShort c
-                     $$ ("Code  : " <> showStackShort s)
+                             , "Code  : " <> showStackShort s ]
 
-padInt :: Int -> Int -> Doc
+padInt :: Int -> Int -> Doc ann
-padInt m n = text (replicate (m - digitalWidth n) ' ') <> int n
+padInt m n = textt (replicate (m - digitalWidth n) ' ') <> int n
 
 maxWidth :: [Int] -> Int
 maxWidth ns = digitalWidth $ maximum ns
@@ -914,7 +912,7 @@ maxWidth ns = digitalWidth $ maximum ns
 digitalWidth :: Int -> Int
 digitalWidth = length . show
 
-showHeap :: GmState -> Doc
+showHeap :: GmState -> Doc ann
 showHeap st = vcat $ showEntry <$> addrs
     where
         showAddr n = padInt w n <> ": "
@@ -923,13 +921,12 @@ showHeap st = vcat $ showEntry <$> addrs
         h = st ^. gmHeap
         addrs = addresses h
 
-        showEntry :: Addr -> Doc
         showEntry a = showAddr a <> showNodeAt st a
 
-showNodeAt :: GmState -> Addr -> Doc
+showNodeAt :: GmState -> Addr -> Doc ann
 showNodeAt = showNodeAtP 0
 
-showNodeAtP :: Int -> GmState -> Addr -> Doc
+showNodeAtP :: Int -> GmState -> Addr -> Doc ann
 showNodeAtP p st a = case hLookup a h of
     Just (NNum n)        -> int n <> "#"
     Just (NGlobal _ _)   -> textt name
@@ -953,9 +950,9 @@ showNodeAtP p st a = case hLookup a h of
         h = st ^. gmHeap
         pprec = maybeParens (p > 0)
 
-showSc :: GmState -> (Name, Addr) -> Doc
+showSc :: GmState -> (Name, Addr) -> Doc ann
-showSc st (k,a) = "Supercomb " <> qquotes (textt k) <> colon
+showSc st (k,a) = vcat [ "Supercomb " <> qquotes (textt k) <> colon
-               $$ code
+                       , code ]
     where
         code = case hLookup a (st ^. gmHeap) of
             Just (NGlobal _ c) -> showCode c
@@ -966,19 +963,21 @@ errTxtInvalidObject, errTxtInvalidAddress :: (IsString a) => a
 errTxtInvalidObject = "<invalid object>"
 errTxtInvalidAddress = "<invalid address>"
 
-showCode :: Code -> Doc
+showCode :: Code -> Doc ann
 showCode c = "Code" <+> braces instrs
     where instrs = vcat $ showInstr <$> c
 
-showInstr :: Instr -> Doc
+showInstr :: Instr -> Doc ann
-showInstr (CaseJump alts) = "CaseJump" $$ nest pprTabstop alternatives
+showInstr (CaseJump alts) = vcat [ "CaseJump", nest pprTabstop alternatives ]
     where
         showAlt (t,c) = "<" <> int t <> ">" <> showCodeShort c
-        alternatives = foldr (\a acc -> showAlt a $$ acc) mempty alts
+        alternatives = foldr (\a acc -> showAlt a <> line <> acc) mempty alts
-showInstr i = text $ show i
+showInstr i = textt $ show i
 
-textt :: (IsText a) => a -> Doc
+int = pretty
-textt t = t ^. unpacked & text
+
+textt :: (Pretty a) => a -> Doc ann
+textt = pretty
 
 ----------------------------------------------------------------------------------
 

src/Misc/CofreeF.hs

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

src/Rlp/AltParse.y

@@ -60,6 +60,7 @@ import Core.Syntax              qualified as Core
     let             { Located _ TokenLet }
     letrec          { Located _ TokenLetrec }
     in              { Located _ TokenIn }
+    forall          { Located _ TokenForall }
 
 %nonassoc '='
 %right '->'
@@ -145,6 +146,8 @@ CaseAlt             :: { Alter PsName (RlpExpr PsName) }
 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 }
@@ -155,6 +158,7 @@ Expr1               :: { RlpExpr PsName }
                                                   . singular _TokenLitInt
                                                   . to (Finl . Core.LitF . Core.IntL) }
                     | '(' Expr ')'          { $2 }
+                    | ConE                  { $1 }
 
 AppE                :: { RlpExpr PsName }
                     : AppE Expr1            { Finl $ Core.AppF $1 $2 }
@@ -163,6 +167,9 @@ AppE                :: { RlpExpr PsName }
 VarE                :: { RlpExpr PsName }
                     : Var                   { Finl $ Core.VarF $1 }
 
+ConE                :: { RlpExpr PsName }
+                    : Con                   { Finl $ Core.VarF $1 }
+
 Pat1s               :: { [Pat PsName] }
                     : list0(Pat1)           { $1 }
 
@@ -195,8 +202,9 @@ list0(p) : {- epsilon -}            { [] }
          | list0(p) p             { $1 `snoc` $2 }
 
 -- layout0(p : β) :: [β]
-layout0(p)  : '{' layout_list0(';',p) '}'   { $2 }
+layout0(p)  : '{' '}'                   { [] }
-            | VL  layout_list0(VS,p)  VR    { $2 }
+            | VL  VR                    { [] }
+            | layout1(p)                { $1 }
 
 -- layout_list0(sep : α, p : β) :: [β]
 layout_list0(sep,p) : p                          { [$1] }
@@ -205,6 +213,7 @@ layout_list0(sep,p) : p                          { [$1] }
 
 -- 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 : β) :: [β]
@@ -225,7 +234,9 @@ parseRlpExprR s = liftErrorful $ errorful (ma,es)
     where
         (_,es,ma) = runP' parseRlpExpr s
 
-parseError = error "explode"
+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

@@ -4,9 +4,12 @@ module Rlp.AltSyntax
     -- * AST
       Program(..), Decl(..), ExprF(..), Pat(..)
     , RlpExprF, RlpExpr, Binding(..), Alter(..)
-    , DataCon(..), Type(..)
+    , RlpExpr', RlpExprF', AnnotatedRlpExpr', Type'
-    , pattern IntT
+    , DataCon(..), Type(..), Kind
+    , pattern IntT, pattern TypeT
+    , Core.Rec(..)
 
+    , AnnotatedRlpExpr, TypedRlpExpr
     , TypeF(..)
 
     , Core.Name, PsName
@@ -15,26 +18,36 @@ module Rlp.AltSyntax
     -- * Optics
     , programDecls
     , _VarP, _FunB, _VarB
+    , _TySigD, _FunD
+    , _LetEF
+    , Core.applicants1, Core.arrowStops
 
     -- * Functor-related tools
     , Fix(..), Cofree(..), Sum(..), pattern Finl, pattern Finr
+
+    -- * Misc
+    , serialiseCofree
     )
     where
 --------------------------------------------------------------------------------
 import Data.Functor.Sum
 import Control.Comonad.Cofree
-import Data.Fix
+import Data.Fix                 hiding (cata)
+import Data.Functor.Foldable
 import Data.Function            (fix)
-import GHC.Generics             (Generic, Generic1)
+import GHC.Generics             ( Generic, Generic1
+                                , Generically(..), Generically1(..))
 import Data.Hashable
 import Data.Hashable.Lifted
 import GHC.Exts                 (IsString)
-import Control.Lens
+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
 
@@ -42,34 +55,59 @@ import Compiler.Types
 import Core.Syntax              qualified as Core
 --------------------------------------------------------------------------------
 
+type RlpExpr' = RlpExpr PsName
+type RlpExprF' = RlpExprF PsName
+type AnnotatedRlpExpr' = Cofree (RlpExprF 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
+    deriving (Show, Functor, Foldable, Traversable)
 
-programDecls :: Lens' (Program b a) [Decl b a]
+instance Extend (Decl b) where
-programDecls = lens (\ (Program ds) -> ds) (const Program)
+    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 b [b] [DataCon b]
+              | DataD Core.Name [Core.Name] [DataCon b]
-              | TySigD b (Type b)
+              | TySigD Core.Name (Type b)
-              deriving Show
+              deriving (Show, Functor, Foldable, Traversable)
 
-data DataCon b = DataCon b [Type b]
+data DataCon b = DataCon Core.Name [Type b]
     deriving (Show, Generic)
 
-data Type b = VarT b
+data Type b = VarT Core.Name
-            | ConT b
+            | 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
@@ -101,7 +139,7 @@ type RlpExpr b = Fix (RlpExprF b)
 data Pat b = VarP b
            | ConP b
            | AppP (Pat b) (Pat b)
-           deriving (Eq, Show, Generic)
+           deriving (Eq, Show, Generic, Generic1)
 
 deriveShow1 ''Alter
 deriveShow1 ''Binding
@@ -116,70 +154,92 @@ pattern Finr ga = Fix (InR ga)
 
 --------------------------------------------------------------------------------
 
-instance (Pretty b, Pretty a) => Pretty (ExprF b a) where
+instance (Out b, Out a) => Out (ExprF b a) where
-    prettyPrec = prettyPrec1
+    outPrec = outPrec1
 
-instance (Pretty b, Pretty a) => Pretty (Alter b a) where
+instance (Out b, Out a) => Out (Alter b a) where
-    prettyPrec = prettyPrec1
+    outPrec = outPrec1
 
-instance (Pretty b) => Pretty1 (Alter b) where
+instance (Out b) => Out1 (Alter b) where
-    liftPrettyPrec pr _ (Alter p e) =
+    liftOutPrec pr _ (Alter p e) =
-        hsep [ pretty p, "->", pr 0 e]
+        hsep [ out p, "->", pr 0 e]
 
-instance Pretty b => Pretty1 (ExprF b) where
+instance Out b => Out1 (ExprF b) where
-    liftPrettyPrec pr p (InfixEF o a b) = maybeParens (p>0) $
+    liftOutPrec pr p (InfixEF o a b) = maybeParens (p>0) $
-        pr 1 a <+> pretty o <+> pr 1 b
+        pr 1 a <+> out o <+> pr 1 b
-    liftPrettyPrec pr p (CaseEF e as) = maybeParens (p>0) $
+    liftOutPrec pr p (CaseEF e as) = maybeParens (p>0) $
-        hsep [ "case", pr 0 e, "of" ]
+        vsep [ hsep [ "case", pr 0 e, "of" ]
-        $+$ nest 2 (vcat $ liftPrettyPrec pr 0 <$> as)
+             , 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 (Pretty b, Pretty a) => Pretty (Decl b a) where
+instance (Out b, Out a) => Out (Decl b a) where
-    prettyPrec = prettyPrec1
+    outPrec = outPrec1
 
-instance (Pretty b) => Pretty1 (Decl b) where
+instance (Out b) => Out1 (Decl b) where
-    liftPrettyPrec pr _ (FunD f as e) =
+    liftOutPrec pr _ (FunD f as e) =
-        hsep [ ttext f, hsep (prettyPrec appPrec1 <$> as)
+        hsep [ ttext f, hsep (outPrec appPrec1 <$> as)
              , "=", pr 0 e ]
 
-    liftPrettyPrec _ _ (DataD f as []) =
+    liftOutPrec _ _ (DataD f as []) =
-        hsep [ "data", ttext f, hsep (pretty <$> as) ]
+        hsep [ "data", ttext f, hsep (out <$> as) ]
 
-    liftPrettyPrec _ _ (DataD f as ds) =
+    liftOutPrec _ _ (DataD f as ds) =
-        hsep [ "data", ttext f, hsep (pretty <$> as), cons ]
+        hsep [ "data", ttext f, hsep (out <$> as), cons ]
       where
-        cons = vcat $ zipWith (<+>) delims (pretty <$> ds)
+        cons = vcat $ zipWith (<+>) delims (out <$> ds)
         delims = "=" : repeat "|"
 
-    liftPrettyPrec _ _ (TySigD n t) =
+    liftOutPrec _ _ (TySigD n t) =
-        hsep [ ttext n, ":", pretty t ]
+        hsep [ ttext n, ":", out t ]
 
-instance (Pretty b) => Pretty (DataCon b) where
+instance (Out b) => Out (DataCon b) where
-    pretty (DataCon n as) = ttext n <+> hsep (prettyPrec appPrec1 <$> as)
+    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 (Pretty b) => Pretty (Type b) where
+instance (Out b) => Out (Type b) where
-    prettyPrec _ (VarT n) = ttext n
+    outPrec _ (VarT n) = ttext n
-    prettyPrec _ (ConT n) = ttext n
+    outPrec _ (ConT n) = ttext n
-    prettyPrec p (s Core.:-> t) = maybeParens (p>appPrec-1) $
+    outPrec p (s Core.:-> t) = maybeParens (p>arrPrec) $
-        hsep [ prettyPrec appPrec s, "->", prettyPrec (appPrec-1) t ]
+        hsep [ outPrec arrPrec1 s, "->", outPrec arrPrec t ]
-    prettyPrec p (AppT f x) = maybeParens (p>appPrec) $
+      where arrPrec = appPrec-1
-        prettyPrec appPrec f <+> prettyPrec appPrec1 x
+            arrPrec1 = appPrec
-    prettyPrec p FunT = maybeParens (p>0) "->"
+    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 (Pretty b) => Pretty (Pat b) where
+instance (Out b) => Out (Pat b) where
-    prettyPrec p (VarP b) = prettyPrec p b
+    outPrec p (VarP b) = outPrec p b
-    prettyPrec p (ConP b) = prettyPrec p b
+    outPrec p (ConP b) = outPrec p b
-    prettyPrec p (AppP c x) = maybeParens (p>appPrec) $
+    outPrec p (AppP c x) = maybeParens (p>appPrec) $
-        prettyPrec appPrec c <+> prettyPrec appPrec1 x
+        outPrec appPrec c <+> outPrec appPrec1 x
 
-instance (Pretty a, Pretty b) => Pretty (Program b a) where
+instance (Out a, Out b) => Out (Program b a) where
-    prettyPrec = prettyPrec1
+    outPrec = outPrec1
 
-instance (Pretty b) => Pretty1 (Program b) where
+instance (Out b) => Out1 (Program b) where
-    liftPrettyPrec pr p (Program ds) = vsep $ liftPrettyPrec pr p <$> ds
+    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)
@@ -217,3 +277,25 @@ 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 ]
+

src/Rlp/HindleyMilner.hs

@@ -1,39 +1,51 @@
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE TemplateHaskell #-}
 module Rlp.HindleyMilner
     ( typeCheckRlpProgR
-    , solve
     , TypeError(..)
-    , runHM'
+    , renamePrettily
-    , HM
     )
     where
 --------------------------------------------------------------------------------
-import Control.Lens             hiding (Context', Context, (:<), para)
+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.Arrow            ((>>>))
 import Control.Monad.Writer.Strict
+
+import Data.List
+import Data.Monoid
 import Data.Text                qualified as T
-import Data.Pretty
+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 GHC.Generics             (Generic, Generically(..))
+import Debug.Trace
 
-import Data.Functor
+import Data.Functor             hiding (unzip)
-import Data.Functor.Foldable
+import Data.Functor.Extend
-import Data.Fix                 hiding (cata, para)
+import Data.Functor.Foldable    hiding (fold)
+import Data.Fix                 hiding (cata, para, cataM)
 import Control.Comonad.Cofree
 import Control.Comonad
 
+import Effectful
+
 import Compiler.RLPC
 import Compiler.RlpcError
 import Rlp.AltSyntax            as Rlp
@@ -42,120 +54,271 @@ import Core.Syntax              (ExprF(..), Lit(..))
 import Rlp.HindleyMilner.Types
 --------------------------------------------------------------------------------
 
-fixCofree :: (Functor f, Functor g)
+-- | Annotate a structure with the result of a catamorphism at each level.
-          => Iso (Fix f) (Fix g) (Cofree f ()) (Cofree g b)
+--
-fixCofree = iso sa bt where
+--   Pretentious etymology: 'dendr-' means 'tree'
-    sa = foldFix (() :<)
-    bt (_ :< as) = Fix $ bt <$> as
 
-lookupVar :: PsName -> Context -> HM (Type PsName)
+dendroscribe :: (Functor f, Base t ~ f, Recursive t)
-lookupVar n g = case g ^. contextVars . at n of
+           => (f (Cofree f a) -> a) -> t -> Cofree f a
-    Just t -> pure t
+dendroscribe c (project -> f) = c f' :< f'
-    Nothing -> addFatal $ TyErrUntypedVariable n
+    where f' = dendroscribe c <$> f
 
-gather :: RlpExpr PsName -> HM (Type PsName, PartialJudgement)
+dendroscribeM :: (Traversable f, Monad m, Base t ~ f, Recursive t)
-gather e = look >>= (H.lookup e >>> maybe memoise pure)
+            => (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
-        memoise = do
+        cs = j & foldMapOf (assumptions . at n . each . each) \t' ->
-            r <- gather' e
+            [Equality t t']
-            add (H.singleton e r)
-            pure r
 
-gather' :: RlpExpr PsName -> HM (Type PsName, PartialJudgement)
+elimGenerally :: Name -> Type' -> Judgement -> Judgement
-gather' = \case
+elimGenerally n t j = j & assumptions %~ H.delete n
-    Finl (LitF (IntL _)) -> pure (IntT, mempty)
+                        & constraints <>~ cs
+    where
+        cs = j & foldMapOf (assumptions . at n . each . each) \t' ->
+            [ImplicitInstance mempty t' t]
 
-    Finl (VarF n) -> do
+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
-        let j = mempty & assumptions .~ H.singleton n [t]
+    pure (t, assume n t)
-        pure (t,j)
 
-    Finl (AppF f x) -> do
+gather (InL (AppF (tf,jf) (tx,jx))) = do
     tfx <- freshTv
-        (tf,jf) <- gather f
+    pure (tfx, jf <> jx <> equal tf (tx :-> tfx))
-        (tx,jx) <- gather x
-        let jtfx = mempty & constraints .~ [Equality tf (tx :-> tfx)]
-        pure (tfx, jf <> jx <> jtfx)
 
-    Finl (LamF [b] e) -> do
+gather (InL (LamF xs (te,je))) = do
-        tb <- freshTv
+    bs <- for xs (\x -> (x,) <$> freshTv)
-        (te,je) <- gather e
+    let j = je & forBinds elim bs
-        let cs = maybe [] (fmap $ Equality tb) (je ^. assumptions . at b)
+               & forBinds (const monomorphise) bs
-            as = je ^. assumptions & at b .~ Nothing
+        t = foldr (:->) te (bs ^.. each . _2)
-            j = mempty & constraints .~ cs & assumptions .~ as
-            t = tb :-> te
     pure (t, j)
-
-unify :: [Constraint] -> HM Context
-
-unify [] = pure mempty
-
-unify (Equality (sx :-> sy) (tx :-> ty) : cs) =
-    unify $ Equality sx tx : Equality sy ty : cs
-
--- elim
-unify (Equality (ConT s) (ConT t) : cs) | s == t = unify cs
-unify (Equality (VarT s) (VarT t) : cs) | s == t = unify cs
-
-unify (Equality (VarT s) t : cs)
-    | occurs s t = addFatal $ TyErrRecursiveType s t
-    | otherwise  = unify cs' <&> contextVars . at s ?~ t
   where
-    cs' = cs & each . constraintTypes %~ subst s t
+    elimBind (x,tx) j1 = elim x tx j1
 
--- swap
+gather (InR (LetEF NonRec (withoutPatterns -> bs) (te,je))) = do
-unify (Equality s (VarT t) : cs) = unify (Equality (VarT t) s : cs)
+    let j = foldr elimBind je bs
+    pure (te, j)
+  where
+    elimBind (x,(tx,jx)) j1 = elimGenerally x tx (jx <> j1)
 
-unify (Equality s t : _) = addFatal $ TyErrCouldNotUnify s t
+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
 
-annotate :: RlpExpr PsName
+forBinds :: (PsName -> Type' -> Judgement -> Judgement)
-         -> HM (Cofree (RlpExprF PsName) (Type PsName, PartialJudgement))
+         -> [(PsName, Type')] -> Judgement -> Judgement
-annotate = sequenceA . fixtend (gather . wrapFix)
+forBinds f bs j = foldr (uncurry f) j bs
 
-solveTree :: Cofree (RlpExprF PsName) (Type PsName, PartialJudgement)
+unify :: (Unique :> es)
-          -> HM (Type PsName)
+      => [Constraint] -> ErrorfulT TypeError (Eff es) Subst
-solveTree e = undefined
+unify [] = pure id
+unify (c:cs) = case c of
 
-infer1 :: RlpExpr PsName -> HM (Type PsName)
+    Equality (ConT a) (ConT b)
-infer1 e = do
+        | a == b
-    ((t,j) :< _) <- annotate e
+        -> unify cs
-    g <- unify (j ^. constraints)
-    pure $ ifoldrOf (contextVars . itraversed) subst t g
 
-solve = undefined
+    Equality (VarT a) (VarT b)
--- solve g e = do
+        | a == b
---     (t,j) <- gather e
+        -> unify cs
---     g' <- unify cs
---     pure $ ifoldrOf (contextVars . itraversed) subst t g'
 
-occurs :: PsName -> Type PsName -> Bool
+    Equality (VarT a) t
-occurs n = cata \case
+        | a `occurs` t
-    VarTF m | n == m -> True
+        -> error "recursive type"
-    t                -> or t
+        | otherwise
+        -> unify (subst a t <$> cs) <&> (. subst a t)
 
-subst :: PsName -> Type PsName -> Type PsName -> Type PsName
+    Equality t (VarT a)
-subst n t' = para \case
+        -> unify (Equality (VarT a) t : cs)
-    VarTF m | n == m -> t'
-    -- shadowing
-    ForallTF x (pre,post) | x == n    -> ForallT x pre
-                          | otherwise -> ForallT x post
-    t -> embed $ t <&> view _2
 
-prettyHM :: (Pretty a)
+    Equality (s :-> t) (s' :-> t')
-         => Either [TypeError] (a, [Constraint])
+        -> unify (Equality s s' : Equality t t' : cs)
-         -> Either [TypeError] (String, [String])
-prettyHM = over (mapped . _1) rpretty
-         . over (mapped . _2 . each) rpretty
 
-fixtend :: Functor f => (f (Fix f) -> b) -> Fix f -> Cofree f b
+    ImplicitInstance m s t
-fixtend c (Fix f) = c f :< fmap (fixtend c) f
+        | null $ (freeTvs t `S.difference` freeTvs m)
+                    `S.intersection` activeTvs cs
+        -> unify $ ExplicitInstance s (generalise (freeTvs m) t) : cs
 
-infer :: RlpExpr PsName -> HM (Cofree (RlpExprF PsName) (Type PsName))
+    ExplicitInstance s t -> do
-infer = undefined
+        t' <- lift $ instantiate t
+        unify $ Equality s t' : cs
 
-typeCheckRlpProgR :: (Monad m)
+    Equality a b
-                  => Program PsName (RlpExpr PsName)
+        -> addFatal $ TyErrCouldNotUnify a b
-                  -> RLPCT m (Program PsName
+
-                      (Cofree (RlpExprF PsName) (Type PsName)))
+    _ -> error $ "explode (typecheckr explsiong): " <> show c
-typeCheckRlpProgR = undefined
+
+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
+
+--------------------------------------------------------------------------------
+
+annotate :: (Unique :> es)
+         => RlpExpr' -> Eff es (Cofree RlpExprF' (Type', Judgement))
+annotate = 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
+
+annotateProg :: (Unique :> es)
+             => Program PsName RlpExpr'
+             -> Eff es (Program PsName
+                         (Cofree RlpExprF' (Type', Judgement)))
+annotateProg p = do
+    p' <- annotateDefs p
+    let bs = p' ^.. programDefs & each . _2 %~ (fst . extract)
+        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 <$> go k ds where
+    go k [] = pure []
+    go k (FunD n as e : ds) = (:) <$> refun as (k (n,e)) <*> go k ds
+    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

@@ -11,57 +11,45 @@ import Data.HashSet             qualified as S
 import GHC.Generics             (Generic(..), Generically(..))
 import Data.Kind                qualified
 import Data.Text                qualified as T
-import Control.Monad.Writer
+import Effectful.State.Static.Local
-import Control.Monad.Accum
+import Effectful.Labeled
-import Control.Monad.Trans.Accum
+import Effectful
-import Control.Monad.Errorful
-import Control.Monad.State
 import Text.Printf
 import Data.Pretty
 import Data.Function
 
-import Control.Lens             hiding (Context', Context)
+import Control.Lens             hiding (Context', Context, para)
+
+import Data.Functor.Foldable    hiding (fold)
+import Data.Foldable
 
 import Compiler.RlpcError
 import Rlp.AltSyntax
 --------------------------------------------------------------------------------
 
-newtype Context = Context
+-- | A polymorphic type
-    { _contextVars      :: HashMap PsName (Type PsName)
-    }
-    deriving (Show, Generic)
-    deriving (Semigroup, Monoid)
-        via Generically Context
 
-data Constraint = Equality (Type PsName) (Type PsName)
+type Scheme = Type'
-    deriving (Eq, Generic, Show)
 
-data PartialJudgement = PartialJudgement
+type Subst = Type' -> Type'
-    { _constraints :: [Constraint]
-    , _assumptions :: HashMap PsName [Type PsName]
-    }
-    deriving (Generic, Show)
-    deriving (Monoid)
-        via Generically PartialJudgement
 
-instance Semigroup PartialJudgement where
+data Constraint = Equality Type' Type'
-    a <> b = PartialJudgement
+                | ImplicitInstance (HashSet Type') Type' Type'
-        { _constraints = ((<>) `on` _constraints) a b
+                | ExplicitInstance Type' Scheme
-        , _assumptions = (H.unionWith (<>) `on` _assumptions) a b
+                deriving Show
-        }
 
-instance Hashable Constraint
+instance Out Constraint where
+    out (Equality s t) =
+        hsep [outPrec appPrec1 s, "~", outPrec appPrec1 t]
 
-type Memo = HashMap (RlpExpr PsName) (Type PsName, PartialJudgement)
+--------------------------------------------------------------------------------
-
-type HM = ErrorfulT TypeError (StateT Int (Accum Memo))
 
 -- | Type error enum.
 data TypeError
     -- | Two types could not be unified
-    = TyErrCouldNotUnify (Type Name) (Type Name)
+    = TyErrCouldNotUnify Type' Type'
     -- | @x@ could not be unified with @t@ because @x@ occurs in @t@
-    | TyErrRecursiveType Name (Type Name)
+    | TyErrRecursiveType Name Type'
     -- | Untyped, potentially undefined variable
     | TyErrUntypedVariable Name
     | TyErrMissingTypeSig Name
@@ -73,90 +61,115 @@ instance IsRlpcError TypeError where
         -- 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)
+                              (rout @String t) (rout @String u)
-            , "Expected: " <> rpretty t
+            , "Expected: " <> rout t
-            , "Got: " <> rpretty u
+            , "Got: " <> rout 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)
+                              (rout @String t) (rout @String x)
             ]
 
--- type Memo t = HashMap t (Type PsName, PartialJudgement)
+--------------------------------------------------------------------------------
 
--- newtype HM t a = HM { unHM :: Int -> Memo t -> (a, Int, Memo t) }
+type Unique = State Int
 
--- runHM :: (Hashable t) => HM t a -> (a, Memo t)
+runUnique :: Eff (Unique : es) a -> Eff es a
--- runHM hm = let (a,_,m) = unHM hm 0 mempty in (a,m)
+runUnique = evalState 0
 
--- instance Functor (HM t) where
+freshTv :: (Unique :> es) => Eff es (Type PsName)
---     fmap f (HM h) = HM \n m -> h n m & _1 %~ f
-
--- instance Applicative (HM t) where
---     pure a = HM \n m -> (a,n,m)
---     HM hf <*> HM ha = HM \n m ->
---         let (f',n',m') = hf n m
---             (a,n'',m'') = ha n' m'
---         in (f' a, n'', m'')
-
--- instance Monad (HM t) where
---     HM ha >>= k = HM \n m ->
---         let (a,n',m') = ha n m
---             (a',n'',m'') = unHM (k a) n' m'
---         in (a',n'', m'')
-
--- instance Hashable t => MonadWriter (Memo t) (HM t) where
---     -- IMPORTAN! (<>) is left-biased for HashMap! append `w` to the RIGHt!
---     writer (a,w) = HM \n m -> (a,n,m <> w)
---     listen ma = HM \n m ->
---         let (a,n',m') = unHM ma n m
---         in ((a,m'),n',m')
---     pass maww = HM \n m ->
---         let ((a,ww),n',m') = unHM maww n m
---         in (a,n',ww m')
-
--- instance MonadState Int (HM t) where
---     state f = HM \n m ->
---         let (a,n') = f n
---         in (a,n',m)
-
-freshTv :: HM (Type PsName)
 freshTv = do
     n <- get
-    modify succ
+    modify @Int succ
-    pure . VarT $ "$a" <> T.pack (show n)
+    pure (VarT $ tvNameOfInt n)
 
-runHM' :: HM a -> Either [TypeError] a
+tvNameOfInt :: Int -> PsName
-runHM' e = maybe (Left es) Right ma
+tvNameOfInt n = "$a" <> T.pack (show n)
-    where
-        ((ma,es),m) = (`runAccum` mempty) . (`evalStateT` 0) . runErrorfulT $ e
 
--- addConstraint :: Constraint -> HM ()
+--------------------------------------------------------------------------------
--- addConstraint = tell . pure
 
-makePrisms ''PartialJudgement
+-- | A 'Judgement' is a sort of "co-context" used in bottom-up inference. The
-makeLenses ''PartialJudgement
+--   typical algorithms J, W, and siblings pass some context Γ to the inference
-makeLenses ''Context
+--   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
 
-supplement :: [(PsName, Type PsName)] -> Context -> Context
-supplement bs = contextVars %~ (H.fromList bs <>)
-
-demoContext :: Context
-demoContext = Context
-    { _contextVars =
-        [ ("+#", IntT :-> IntT :-> IntT)
-        ]
-    }
-
-constraintTypes :: Traversal' Constraint (Type PsName)
-constraintTypes k (Equality s t) = Equality <$> k s <*> k t
-
-instance Pretty Constraint where
-    pretty (Equality s t) =
-        hsep [prettyPrec appPrec1 s, "~", prettyPrec appPrec1 t]
-

src/Rlp/HindleyMilner/Visual.hs

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

src/Rlp/Lex.x

@@ -59,7 +59,7 @@ $asciisym       = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
 
 @reservedname = 
     case|data|do|import|in|let|letrec|module|of|where
-    |infixr|infixl|infix
+    |infixr|infixl|infix|forall
 
 @reservedop =
     "=" | \\ | "->" | "|" | ":"
@@ -163,6 +163,7 @@ lexReservedName = \case
     "infix"     -> TokenInfix
     "infixl"    -> TokenInfixL
     "infixr"    -> TokenInfixR
+    "forall"    -> TokenForall
     s           -> error (show s)
 
 lexReservedOp :: Text -> RlpToken
@@ -330,6 +331,7 @@ insertRBrace    = {- traceM "inserting rbrace" >> -} insertToken TokenRBraceV
 cmpLayout :: P Ordering
 cmpLayout = do
     i <- indentLevel
+    -- traceM $ "i: " <> show i
     ctx <- preuse (psLayoutStack . _head)
     case ctx of
         Just (Implicit n) -> pure (i `compare` n)
@@ -338,8 +340,6 @@ 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/Types.hs

@@ -17,6 +17,7 @@ module Rlp.Parse.Types
     -- * Other parser types
     , RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
     , Located(..), PsName
+    , srcSpanLen
     -- ** Lenses
     , _TokenLitInt, _TokenVarName, _TokenConName, _TokenVarSym, _TokenConSym
     , aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
@@ -108,6 +109,7 @@ data RlpToken
     | TokenInfixL
     | TokenInfixR
     | TokenInfix
+    | TokenForall
     -- reserved ops
     | TokenArrow
     | TokenPipe
@@ -277,7 +279,7 @@ initAlexInput s = AlexInput
     { _aiPrevChar   = '\0'
     , _aiSource     = s
     , _aiBytes      = []
-    , _aiPos        = (1,0,0)
+    , _aiPos        = (1,1,0)
     }
 
 --------------------------------------------------------------------------------

src/Rlp/Syntax/Good.hs

@@ -1,56 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-module Rlp.Syntax.Good
-    ( Decl(..), Program(..)
-    , programDecls
-    , Mistake(..)
-    )
-    where
---------------------------------------------------------------------------------
-import Data.Kind
-import Control.Lens
-import Rlp.Syntax.Types (NameP)
-import Rlp.Syntax.Types qualified as Rlp
---------------------------------------------------------------------------------
-
-data Program b a = Program
-    { _programDecls :: [Decl b a]
-    }
-
-data Decl p a = FunD   (NameP p) [Rlp.Pat p] a
-              | TySigD [NameP p] (Rlp.Ty p)
-              | DataD  (NameP p) [NameP p] [Rlp.ConAlt p]
-              | InfixD Rlp.Assoc Int (NameP p)
-
-type Where p a = [Binding p a]
-
-data Binding p a = PatB (Rlp.Pat p) a
-    deriving (Functor, Foldable, Traversable)
-
-makeLenses ''Program
-
-class Mistake a where
-    type family Ammend a :: Type
-    ammendMistake :: a -> Ammend a
-
-instance Mistake (Rlp.Program p a) where
-    type Ammend (Rlp.Program p a) = Program p (Rlp.Expr' p a)
-
-    ammendMistake p = Program
-        { _programDecls = ammendMistake <$> Rlp._programDecls p
-        }
-
-instance Mistake (Rlp.Decl p a) where
-    type Ammend (Rlp.Decl p a) = Decl p (Rlp.Expr' p a)
-
-    ammendMistake = \case
-        Rlp.FunD n as e _  -> FunD n as e
-        Rlp.TySigD ns t    -> TySigD ns t
-        Rlp.DataD n as cs  -> DataD n as cs
-        Rlp.InfixD ass p n -> InfixD ass p n
-
-instance Mistake (Rlp.Binding p a) where
-    type Ammend (Rlp.Binding p a) = Binding p (Rlp.ExprF p a)
-
-    ammendMistake = \case
-        Rlp.PatB k v -> PatB k v
-

src/Rlp2Core.hs

@@ -12,8 +12,7 @@ import Control.Monad.Writer.CPS
 import Control.Monad.Utils
 import Control.Arrow
 import Control.Applicative
-import Control.Comonad
+import Control.Lens                     hiding ((:<))
-import Control.Lens
 import Compiler.RLPC
 import Data.List                        (mapAccumL, partition)
 import Data.Text                        (Text)
@@ -22,14 +21,17 @@ 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 Data.Fix                         hiding (cata, para, cataM)
+import Data.Functor.Bind
+import Data.Functor.Foldable
+import Control.Comonad
+
 import Effectful.State.Static.Local
 import Effectful.Labeled
 import Effectful
@@ -38,7 +40,7 @@ import Text.Show.Deriving
 import Core.Syntax                      as Core
 import Rlp.AltSyntax                    as Rlp
 import Compiler.Types
-import Data.Pretty                      (render, pretty)
+import Data.Pretty
 --------------------------------------------------------------------------------
 
 type Tree a = Either Name (Name, Branch a)
@@ -59,42 +61,57 @@ deriveShow1 ''Branch
 
 --------------------------------------------------------------------------------
 
-desugarRlpProgR :: forall m a. (Monad m)
+-- desugarRlpProgR :: forall m a. (Monad m)
-                => Rlp.Program PsName a
+--                 => Rlp.Program PsName (TypedRlpExpr PsName)
-                -> RLPCT m Core.Program'
+--                 -> RLPCT m (Core.Program Var)
-desugarRlpProgR p = do
+-- desugarRlpProgR p = do
-    let p' = desugarRlpProg p
+--     let p' = desugarRlpProg p
-    addDebugMsg "dump-desugared" $ render (pretty p')
+--     addDebugMsg "dump-desugared" $ show (out p')
-    pure p'
+--     pure p'
 
-desugarRlpProg = undefined
+desugarRlpProgR = undefined
+
+desugarRlpProg :: Rlp.Program PsName (TypedRlpExpr PsName) -> Core.Program Var
+desugarRlpProg = rlpProgToCore
 
 desugarRlpExpr = undefined
 
+type NameSupply = Labeled "NameSupply" (State [Name])
+
 runNameSupply :: Text -> Eff (NameSupply ': es) a -> Eff es a
-runNameSupply pre = undefined -- evalState [ pre <> "_" <> tshow name | name <- [0..] ]
+runNameSupply pre = runLabeled $ evalState [ pre <> "_" <> tshow name | name <- [0..] ]
+    where tshow = T.pack . show
 
 -- 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 (RlpExpr PsName) -> Program'
+rlpProgToCore :: Rlp.Program PsName (TypedRlpExpr PsName) -> Core.Program Var
 rlpProgToCore = foldMapOf (programDecls . each) declToCore
 
-declToCore :: Rlp.Decl PsName (RlpExpr PsName) -> Program'
+declToCore :: Rlp.Decl PsName (TypedRlpExpr PsName) -> Core.Program Var
 
--- assume all arguments are VarP's for now
+-- assume full eta-expansion for now
-declToCore (FunD b as e) = mempty & programScDefs .~ [ScDef b as' e']
+declToCore (FunD b [] e) = mempty & programScDefs .~ [ScDef b' [] undefined]
     where
-        as' = as ^.. each . singular _VarP
+        b' = MkVar b (typeToCore $ extract e)
         e' = runPureEff . runNameSupply b . exprToCore $ e
 
-type NameSupply = State [Name]
+typeToCore :: Rlp.Type PsName -> Core.Type
+typeToCore (VarT n) = TyVar n
 
 exprToCore :: (NameSupply :> es)
-           => RlpExpr PsName -> Eff es Core.Expr'
+           => TypedRlpExpr PsName
-exprToCore = foldFixM \case
+           -> Eff es (Cofree (Core.ExprF Var) Core.Type)
-    InL e -> pure $ Fix e
+exprToCore = undefined
-    InR e -> rlpExprToCore e
+
+annotateVar :: Core.Type -> Core.ExprF PsName a -> Core.ExprF Var a
+
+-- fixed 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'

visualisers/hmvis/.gitignore

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

visualisers/hmvis/package.json

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

visualisers/hmvis/public/css/main.css

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

visualisers/hmvis/public/css/solarized.css

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

visualisers/hmvis/public/index.html

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

visualisers/hmvis/shadow-cljs.edn

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

visualisers/hmvis/src/hmvis/annotated.cljs

@@ -0,0 +1,142 @@
+(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 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]]
+    :else [:code "<expr>"]))
+
+(def rainbow-cycle (cycle ["red"
+                           "orange"
+                           "yellow"
+                           "green"
+                           "blue"
+                           "violet"]))
+
+(defn render-decl [{name :name body :body}]
+  [:code {:key name :display "block"}
+           (str name " = ") [Expr rainbow-cycle 0 body] #_ (render-expr body)
+           [:br]])
+
+(defn TypeChecker []
+  [:div
+   (map render-decl (or @tc-input []))])
+
+; (defn init []
+;   (rdom/render [type-checker]
+;                (js/document.querySelector "#output")))
+

visualisers/hmvis/src/hmvis/ppr.cljs

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

visualisers/hmvis/src/main.cljs

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