diagrams

Makefile_happysrcs

@@ -1,24 +1,19 @@
-GHC_VERSION = $(shell ghc --numeric-version)
 HAPPY = happy
 HAPPY_OPTS = -a -g -c -i/tmp/t.info
 ALEX = alex
 ALEX_OPTS = -g
 
 SRC = src
-CABAL_BUILD = $(shell ./find-build.cl)
+CABAL_BUILD = dist-newstyle/build/x86_64-osx/ghc-9.6.2/rlp-0.1.0.0/build
 
 all: parsers lexers
 
-parsers: $(CABAL_BUILD)/Rlp/Parse.hs $(CABAL_BUILD)/Core/Parse.hs \
+parsers: $(CABAL_BUILD)/Rlp/Parse.hs $(CABAL_BUILD)/Core/Parse.hs
-		$(CABAL_BUILD)/Rlp/AltParse.hs
 lexers: $(CABAL_BUILD)/Rlp/Lex.hs $(CABAL_BUILD)/Core/Lex.hs
 
 $(CABAL_BUILD)/Rlp/Parse.hs: $(SRC)/Rlp/Parse.y
 	$(HAPPY) $(HAPPY_OPTS) $< -o $@
 
-$(CABAL_BUILD)/Rlp/AltParse.hs: $(SRC)/Rlp/AltParse.y
-	$(HAPPY) $(HAPPY_OPTS) $< -o $@
-
 $(CABAL_BUILD)/Rlp/Lex.hs: $(SRC)/Rlp/Lex.x
 	$(ALEX) $(ALEX_OPTS) $< -o $@
 

app/Main.hs

@@ -74,6 +74,11 @@ options = RLPCOptions
         <> metavar "rlp|core"
         <> help "the language to be compiled -- see README"
         )
+    <*> flag False True
+        (  long "render"
+        <> short 'r'
+        <> help "render a diagram of each GM state"
+        )
     <*> some (argument str $ metavar "FILES...")
     where
         infixr 9 #

examples/Core/factorial.cr

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

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

rlp.cabal

@@ -22,6 +22,9 @@ library
     exposed-modules:  Core
                     , TI
                     , GM
+                    , GM.Visual
+                    , GM.Types
+                    , GM.Print
                     , Compiler.RLPC
                     , Compiler.RlpcError
                     , Compiler.JustRun
@@ -32,13 +35,6 @@ library
                     , Core.HindleyMilner
                     , Control.Monad.Errorful
                     , Rlp.Syntax
-                    , Rlp.AltSyntax
-                    , Rlp.AltParse
-                    , Rlp.HindleyMilner
-                    , Rlp.HindleyMilner.Types
-                    , Rlp.Syntax.Backstage
-                    , Rlp.Syntax.Types
-                    , Rlp.Syntax.Good
                     -- , Rlp.Parse.Decls
                     , Rlp.Parse
                     , Rlp.Parse.Associate
@@ -49,14 +45,10 @@ library
                     , Data.Heap
                     , Data.Pretty
                     , Core.Parse
-                    , Core.Parse.Types
                     , Core.Lex
                     , Core2Core
                     , Rlp2Core
                     , Control.Monad.Utils
-                    , Misc
-                    , Misc.Lift1
-                    , Core.SystemF
 
     build-tool-depends: happy:happy, alex:alex
 
@@ -71,8 +63,7 @@ library
                     , data-default-class >= 0.1.2 && < 0.2
                     , hashable >= 1.4.3 && < 1.5
                     , mtl >= 2.3.1 && < 2.4
-                    , transformers
+                    , text >= 2.0.2 && < 2.1
-                    , text >= 2.0.2 && < 2.2
                     , unordered-containers >= 0.2.20 && < 0.3
                     , recursion-schemes >= 5.2.2 && < 5.3
                     , data-fix >= 0.3.2 && < 0.4
@@ -85,8 +76,9 @@ library
                     , effectful-core ^>=2.3.0.0
                     , deriving-compat ^>=0.6.0
                     , these >=0.2 && <2.0
-                    , free >=5.2
+                    , diagrams
-                    , bifunctors >=5.2
+                    , diagrams-lib
+                    , diagrams-cairo
 
     hs-source-dirs:   src
     default-language: GHC2021
@@ -100,7 +92,6 @@ library
         DerivingVia
         StandaloneDeriving
         DerivingStrategies
-        BlockArguments
 
 executable rlpc
     import:           warnings
@@ -114,7 +105,7 @@ executable rlpc
                  , mtl >= 2.3.1 && < 2.4
                  , unordered-containers >= 0.2.20 && < 0.3
                  , lens >=5.2.3 && <6.0
-                 , text >= 2.0.2 && < 2.2
+                 , text >= 2.0.2 && < 2.1
 
     hs-source-dirs:   app
     default-language: GHC2021
@@ -131,10 +122,8 @@ test-suite rlp-test
                  , QuickCheck
                  , hspec            ==2.*
                  , microlens
-                 , lens >=5.2.3 && <6.0
     other-modules: Arith
                  , GMSpec
                  , Core.HindleyMilnerSpec
-                 , Compiler.TypesSpec
     build-tool-depends: hspec-discover:hspec-discover
 

src/Compiler/JustRun.hs

@@ -10,17 +10,15 @@ types such as @RLPC@ or @Text@.
 module Compiler.JustRun
     ( justLexCore
     , justParseCore
-    , justParseRlp
     , justTypeCheckCore
     , justHdbg
-    , makeItPretty, makeItPretty'
     )
     where
 ----------------------------------------------------------------------------------
 import Core.Lex
 import Core.Parse
 import Core.HindleyMilner
-import Core.Syntax
+import Core.Syntax                      (Program')
 import Compiler.RLPC
 import Control.Arrow                    ((>>>))
 import Control.Monad                    ((>=>), void)
@@ -30,47 +28,30 @@ import Data.Text                        qualified as T
 import Data.Function                    ((&))
 import System.IO
 import GM
+import Rlp.Parse
 import Rlp2Core
-import Data.Pretty
-
-import Rlp.AltParse
-import Rlp.AltSyntax                    qualified as Rlp
 ----------------------------------------------------------------------------------
 
 justHdbg :: String -> IO GmState
-justHdbg = undefined
+justHdbg s = do
--- justHdbg s = do
+    p <- evalRLPCIO def (parseRlpProgR >=> desugarRlpProgR $ T.pack s)
---     p <- evalRLPCIO def (parseRlpProgR >=> desugarRlpProgR $ T.pack s)
+    withFile "/tmp/t.log" WriteMode $ hdbgProg p
---     withFile "/tmp/t.log" WriteMode $ hdbgProg p
 
 justLexCore :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
 justLexCore s = lexCoreR (T.pack s)
               & mapped . each %~ extract
               & rlpcToEither
 
-justParseCore :: String -> Either [MsgEnvelope RlpcError] (Program Var)
+justParseCore :: String -> Either [MsgEnvelope RlpcError] Program'
 justParseCore s = parse (T.pack s)
                 & rlpcToEither
-    where parse = lexCoreR @Identity >=> parseCoreProgR
+    where parse = lexCoreR >=> parseCoreProgR
-
-justParseRlp :: String
-             -> Either [MsgEnvelope RlpcError]
-                       (Rlp.Program Name (Rlp.RlpExpr Name))
-justParseRlp s = parse (T.pack s)
-               & rlpcToEither
-    where parse = parseRlpProgR @Identity
 
 justTypeCheckCore :: String -> Either [MsgEnvelope RlpcError] Program'
 justTypeCheckCore s = typechk (T.pack s)
                     & rlpcToEither
     where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR
 
-makeItPretty :: (Pretty a) => Either e a -> Either e Doc
-makeItPretty = fmap pretty
-
-makeItPretty' :: (Pretty (WithTerseBinds a)) => Either e a -> Either e Doc
-makeItPretty' = fmap (pretty . WithTerseBinds)
-
 rlpcToEither :: RLPC a -> Either [MsgEnvelope RlpcError] a
 rlpcToEither r = case evalRLPC def r of
     (Just a,   _) -> Right a

src/Compiler/RLPC.hs

@@ -27,7 +27,7 @@ module Compiler.RLPC
     -- ** Lenses
     , rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage
     -- * Misc. MTL-style functions
-    , liftErrorful, liftMaybe, hoistRlpcT
+    , liftErrorful, hoistRlpcT
     -- * Misc. Rlpc Monad -related types
     , RLPCOptions(RLPCOptions), IsRlpcError(..), RlpcError(..)
     , MsgEnvelope(..), Severity(..)
@@ -108,9 +108,6 @@ evalRLPCT opt r = runRLPCT r
 liftErrorful :: (Monad m, IsRlpcError e) => ErrorfulT (MsgEnvelope e) m a -> RLPCT m a
 liftErrorful e = RLPCT $ lift (fmap liftRlpcError `mapErrorful` e)
 
-liftMaybe :: (Monad m) => Maybe a -> RLPCT m a
-liftMaybe m = RLPCT . lift . ErrorfulT . pure $ (m, [])
-
 hoistRlpcT :: (forall a. m a -> n a)
          -> RLPCT m a -> RLPCT n a
 hoistRlpcT f rma = RLPCT $ ReaderT $ \opt ->
@@ -123,6 +120,7 @@ data RLPCOptions = RLPCOptions
     , _rlpcEvaluator   :: Evaluator
     , _rlpcHeapTrigger :: Int
     , _rlpcLanguage    :: Maybe Language
+    , _rlpcRender      :: Bool
     , _rlpcInputFiles  :: [FilePath]
     }
     deriving Show
@@ -144,6 +142,7 @@ instance Default RLPCOptions where
         , _rlpcHeapTrigger = 200
         , _rlpcInputFiles = []
         , _rlpcLanguage = Nothing
+        , _rlpcRender = False
         }
 
 -- debug flags are passed with -dFLAG
@@ -223,9 +222,9 @@ docRlpcErr msg = header
                 rule = repeat (ttext . Ansi.blue . Ansi.bold $ "|")
                 srclines = ["", "<problematic source code>", ""]
         filename = msgColour "<input>"
-        pos = msgColour $ tshow (msg ^. msgSpan . srcSpanLine)
+        pos = msgColour $ tshow (msg ^. msgSpan . srcspanLine)
                        <> ":"
-                       <> tshow (msg ^. msgSpan . srcSpanColumn)
+                       <> tshow (msg ^. msgSpan . srcspanColumn)
 
         header = ttext $ filename <> msgColour ":" <> pos <> msgColour ": "
                         <> errorColour "error" <> msgColour ":"

src/Compiler/RlpcError.hs

@@ -14,9 +14,6 @@ module Compiler.RlpcError
     -- * Located Comonad
     , Located(..)
     , SrcSpan(..)
-
-    -- * Common error messages
-    , undefinedVariableErr
     )
     where
 ----------------------------------------------------------------------------------
@@ -77,8 +74,3 @@ debugMsg tag e = MsgEnvelope
     , _msgSeverity = SevDebug tag
     }
 
-undefinedVariableErr :: Text -> RlpcError
-undefinedVariableErr n = Text
-    [ "Variable not in scope: `" <> n <> "'."
-    ]
-

src/Compiler/Types.hs

@@ -1,79 +1,33 @@
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE UndecidableInstances, QuantifiedConstraints #-}
-{-# LANGUAGE PatternSynonyms #-}
 module Compiler.Types
     ( SrcSpan(..)
-    , srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen
+    , srcspanLine, srcspanColumn, srcspanAbs, srcspanLen
-    , pattern (:<$)
     , Located(..)
-    , HasLocation(..)
     , _Located
-    , nolo, nolo'
+    , located
-
+    , nolo
-    , (<~>), (~>), (~~>), (<~~)
+    , (<<~), (<~>), (<#>)
-
-    , comb2, comb3, comb4
-    , lochead
 
     -- * Re-exports
-    , Comonad(extract)
+    , Comonad
     , Apply
     , Bind
     )
     where
 --------------------------------------------------------------------------------
-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 Control.Lens             hiding ((<<~))
-import Data.Functor.Foldable
+import Language.Haskell.TH.Syntax   (Lift)
-import Data.Semigroup.Foldable
-import Data.Fix                     hiding (cata, ana)
-import Data.Kind
-import Control.Lens                 hiding ((<<~), (:<))
-
-import Data.List.NonEmpty           (NonEmpty)
-import Data.Function                (on)
 --------------------------------------------------------------------------------
 
 -- | 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
+located :: Lens (Located a) (Located b) a b
-pattern a :<$ b = a Trans.Cofree.:< b
+located = lens extract ($>)
-
-(<~>) :: a -> b -> SrcSpan
-(<~>) = undefined
-
-infixl 5 <~>
-
-(~>) :: (CanGet k, CanSet k', HasLocation k a, HasLocation k' b)
-     => a -> b -> b
-a ~> b = b & fromSet getSetLocation .~ (a ^. fromGet getSetLocation)
--- (~>) = undefined
-
-infixl 4 ~>
-
--- (~~>) :: (CanGet k, HasLocation k a, CanSet k', HasLocation k' b)
---       => (a -> b) -> a -> b
--- (~~>) :: (f SrcSpan -> b) -> Cofree f SrcSpan -> Cofree f SrcSpan
--- f ~~> (ss :< as) = ss :< f as
-(~~>) = undefined
-
-infixl 3 ~~>
-
--- (<~~) :: (GetLocation a, HasLocation b) => (a -> b) -> a -> b
--- a <~~ b = a b & location <>~ srcspan b
-(<~~) = undefined
-
-infixr 2 <~~
 
 instance Apply Located where
     liftF2 f (Located sa p) (Located sb q)
@@ -93,137 +47,53 @@ data SrcSpan = SrcSpan
     !Int -- ^ Column
     !Int -- ^ Absolute
     !Int -- ^ Length
-    deriving (Show, Eq, Lift)
+    deriving (Show, Lift)
 
-_SrcSpan :: Iso' SrcSpan (Int, Int, Int, Int)
+tupling :: Iso' SrcSpan (Int, Int, Int, Int)
-_SrcSpan = iso (\ (SrcSpan a b c d) -> (a,b,c,d))
+tupling = iso (\ (SrcSpan a b c d) -> (a,b,c,d))
               (\ (a,b,c,d) -> SrcSpan a b c d)
 
-srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen :: Lens' SrcSpan Int
+srcspanLine, srcspanColumn, srcspanAbs, srcspanLen :: Lens' SrcSpan Int
-srcSpanLine = _SrcSpan . _1
+srcspanLine = tupling . _1
-srcSpanColumn = _SrcSpan . _2
+srcspanColumn = tupling . _2
-srcSpanAbs = _SrcSpan . _3
+srcspanAbs = tupling . _3
-srcSpanLen = _SrcSpan . _4
+srcspanLen = tupling . _4
 
 -- | debug tool
 nolo :: a -> Located a
 nolo = Located (SrcSpan 0 0 0 0)
 
-nolo' :: f (Cofree f SrcSpan) -> Cofree f SrcSpan
-nolo' as = SrcSpan 0 0 0 0 :< as
-
 instance Semigroup SrcSpan where
-    -- multiple identities? what are the consequences of this...?
-    SrcSpan _ _ _ 0 <> SrcSpan l c a s = SrcSpan l c a s
-    SrcSpan l c a s <> SrcSpan _ _ _ 0 = SrcSpan l c a s
-
     SrcSpan la ca aa sa <> SrcSpan lb cb ab sb = SrcSpan l c a s where
         l = min la lb
         c = min ca cb
         a = min aa ab
         s = case aa `compare` ab of
             EQ -> max sa sb
-            LT -> max sa (ab + sb - aa)
+            LT -> max sa (ab + lb - aa)
-            GT -> max sb (aa + sa - ab)
+            GT -> max sb (aa + la - ab)
 
---------------------------------------------------------------------------------
+-- | A synonym for '(<<=)' with a tighter precedence and left-associativity for
+-- use with '(<~>)' in a sort of, comonadic pseudo-applicative style.
 
-data GetOrSet = Get | Set | GetSet
+(<<~) :: (Comonad w) => (w a -> b) -> w a -> w b
+(<<~) = (<<=)
 
-class CanGet (k :: GetOrSet)
+infixl 4 <<~
-class CanSet (k :: GetOrSet) where
 
-instance CanGet Get
+-- | Similar to '(<*>)', but with a cokleisli arrow.
-instance CanGet GetSet
-instance CanSet Set
-instance CanSet GetSet
 
-data GetSetLens (k :: GetOrSet) s t a b :: Type where
+(<~>) :: (Comonad w, Bind w) => w (w a -> b) -> w a -> w b
-    Getter_      :: (s -> a)             -> GetSetLens Get s t a b
+mc <~> ma = mc >>- \f -> ma =>> f
-    Setter_      :: ((a -> b) -> s -> t) -> GetSetLens Set s t a b
-    GetterSetter :: (CanGet k', CanSet k')
-                 => (s -> a) -> (s -> b -> t) -> GetSetLens k' s t a b
 
-type GetSetLens' k s a = GetSetLens k s s a a
+infixl 4 <~>
 
-class HasLocation k s | s -> k where
+-- this is getting silly
-    -- location :: (Access k f, Functor f) => LensLike' f s SrcSpan
-    getSetLocation :: GetSetLens' k s SrcSpan
 
-type family Access (k :: GetOrSet) f where
+(<#>) :: (Functor f) => f (a -> b) -> a -> f b
-    Access GetSet f = Functor f
+fab <#> a = fmap ($ a) fab
-    Access Set f = Settable f
-    Access Get f = (Functor f, Contravariant f)
 
-instance HasLocation GetSet SrcSpan where
+infixl 4 <#>
-    getSetLocation = GetterSetter id (flip const)
-    -- location = fromGetSetLens getSetLocation
-
-instance (CanSet k, HasLocation k a) => HasLocation Set (r -> a) where
-    getSetLocation = Setter_ $ \ss ra r -> ra r & fromSet getSetLocation %~ ss
-    -- location = fromSet getSetLocation
-
-instance (HasLocation k a) => HasLocation k (Cofree f a) where
-    getSetLocation = case getSetLocation @_ @a of
-        Getter_ sa -> Getter_ $ \ (s :< _) -> sa s
-        Setter_ abst -> Setter_ $ \ss (s :< as) -> abst ss s :< as
-        GetterSetter sa sbt -> GetterSetter sa' sbt' where
-            sa' (s :< _) = sa s
-            sbt' (s :< as) b = sbt s b :< as
-
-location :: (Access k f, Functor f, HasLocation k s)
-         => LensLike' f s SrcSpan
-location = fromGetSetLens getSetLocation
-
-fromGetSetLens :: (Access k f, Functor f) => GetSetLens' k s a -> LensLike' f s a
-fromGetSetLens gsl = case gsl of
-    Getter_ sa          -> to sa
-    Setter_ abst        -> setting abst
-    GetterSetter sa sbt -> lens sa sbt
-
-fromGet :: (CanGet k) => GetSetLens k s t a b -> Getter s a
-fromGet (Getter_ sa)        = to sa
-fromGet (GetterSetter sa _) = to sa
-
-fromSet :: (CanSet k) => GetSetLens k s t a b -> Setter s t a b
-fromSet (Setter_ abst)        = setting abst
-fromSet (GetterSetter sa sbt) = lens sa sbt
-
-fromGetSet :: (CanGet k, CanSet k) => GetSetLens k s t a b -> Lens s t a b
-fromGetSet (GetterSetter sa sbt) = lens sa sbt
-
---------------------------------------------------------------------------------
-
-comb2 :: (Functor f, Semigroup m)
-      => (Cofree f m -> Cofree f m -> f (Cofree f m))
-      -> Cofree f m -> Cofree f m -> Cofree f m
-comb2 f a b = ss :< f a b
-    where ss = a `mextract` b
-
-comb3 :: (Functor f, Semigroup m)
-      => (Cofree f m -> Cofree f m -> Cofree f m -> f (Cofree f m))
-      -> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m
-comb3 f a b c = ss :< f a b c
-    where ss = a `mapply` b `mextract` c
-
-comb4 :: (Functor f, Semigroup m)
-      => (Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m
-         -> f (Cofree f m))
-      -> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m
-comb4 f a b c d = ss :< f a b c d
-    where ss = a `mapply` b `mapply` c `mextract` d
-
-mextract :: (Comonad w, Semigroup m) => w m -> w m -> m
-mextract = (<>) `on` extract
-
-mapply :: (Comonad w, Semigroup m) => w m -> w m -> w m
-mapply a b = b <&> (<> extract a)
-
-lochead :: Functor f
-        => (f SrcSpan -> f SrcSpan) -> Located (f SrcSpan) -> Cofree f SrcSpan
-lochead afs (Located ss fss) = ss :< unwrap (lochead afs $ Located ss fss)
-
---------------------------------------------------------------------------------
 
 makePrisms ''Located
 

src/Control/Monad/Errorful.hs

@@ -14,9 +14,7 @@ module Control.Monad.Errorful
     where
 ----------------------------------------------------------------------------------
 import Control.Monad.State.Strict
-import Control.Monad.Writer
 import Control.Monad.Reader
-import Control.Monad.Accum
 import Control.Monad.Trans
 import Data.Functor.Identity
 import Data.Coerce
@@ -87,16 +85,3 @@ instance (Monad m, MonadErrorful e m) => MonadErrorful e (ReaderT r m) where
     addWound = lift . addWound
     addFatal = lift . addFatal
 
-instance (Monad m, MonadState s m) => MonadState s (ErrorfulT e m) where
-    state = lift . state
-
-instance (Monoid w, Monad m, MonadWriter w m) => MonadWriter w (ErrorfulT e m) where
-    tell = lift . tell
-    listen (ErrorfulT m) = ErrorfulT $ listen m <&> \ ((ma,es),w) ->
-        ((,w) <$> ma, es)
-    pass (ErrorfulT m) = undefined
-
-instance (Monoid w, Monad m, MonadAccum w m)
-      => MonadAccum w (ErrorfulT e m) where
-    accum = lift . accum
-

src/Core.hs

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

src/Core/Examples.hs

@@ -10,9 +10,12 @@ import Core.Syntax
 import Core.TH
 ----------------------------------------------------------------------------------
 
-letRecExample = undefined
+-- fac3 = undefined
+-- sumList = undefined
+-- constDivZero = undefined
+-- idCase = undefined
 
-{--
+---
 
 letrecExample :: Program'
 letrecExample = [coreProg|

src/Core/HindleyMilner.hs

@@ -35,12 +35,6 @@ import Text.Printf
 import Core.Syntax
 ----------------------------------------------------------------------------------
 
-infer = undefined
-check = undefined
-checkCoreProg = undefined
-checkCoreProgR = undefined
-checkCoreExprR = undefined
-
 -- | Annotated typing context -- I have a feeling we're going to want this in the
 -- future.
 type Context b = [(b, Type)]
@@ -80,8 +74,6 @@ instance IsRlpcError TypeError where
 -- throw any number of fatal or nonfatal errors. Run with @runErrorful@.
 type HMError = Errorful TypeError
 
-{--
-
 -- | Assert that an expression unifies with a given type
 --
 -- >>> let e = [coreProg|3|]
@@ -284,4 +276,3 @@ demoContext =
     , ("False", TyCon "Bool")
     ]
 
---}

src/Core/Lex.x

@@ -78,7 +78,7 @@ rlp :-
     "{"                     { constTok TokenLBrace }
     "}"                     { constTok TokenRBrace }
     ";"                     { constTok TokenSemicolon }
-    ":"                     { constTok TokenHasType }
+    "::"                    { constTok TokenHasType }
     "@"                     { constTok TokenTypeApp }
     "{-#"                   { constTok TokenLPragma `andBegin` pragma }
 

src/Core/Parse.y

@@ -5,12 +5,14 @@ Description : Parser for the Core language
 -}
 {-# LANGUAGE OverloadedStrings, ViewPatterns #-}
 module Core.Parse
-    ( parseCoreExpr
+    ( parseCore
+    , parseCoreExpr
     , parseCoreExprR
     , parseCoreProg
     , parseCoreProgR
     , module Core.Lex -- temp convenience
     , SrcError
+    , Module
     )
     where
 
@@ -30,19 +32,19 @@ import Data.Text.IO         qualified as TIO
 import Data.Text            (Text)
 import Data.Text            qualified as T
 import Data.HashMap.Strict  qualified as H
-
-import Core.Parse.Types
 }
 
+%name parseCore Module
 %name parseCoreExpr StandaloneExpr
 %name parseCoreProg StandaloneProgram
 %tokentype { Located CoreToken }
 %error { parseError }
-%monad { P }
+%monad { RLPC } { happyBind } { happyPure }
 
 %token
       let             { Located _ TokenLet }
       letrec          { Located _ TokenLetrec }
+      module          { Located _ TokenModule }
       where           { Located _ TokenWhere }
       case            { Located _ TokenCase }
       of              { Located _ TokenOf }
@@ -66,27 +68,29 @@ import Core.Parse.Types
       '{-#'           { Located _ TokenLPragma }
       '#-}'           { Located _ TokenRPragma }
       ';'             { Located _ TokenSemicolon }
-      ':'             { Located _ TokenHasType }
+      '::'            { Located _ TokenHasType }
       eof             { Located _ TokenEOF }
 
-%right '->'
-
 %%
 
+Module          :: { Module Name }
+Module          : module conname where Program Eof { Module (Just ($2, [])) $4 }
+                | Program Eof                      { Module Nothing $1 }
+
 Eof             :: { () }
 Eof             : eof           { () }
                 | error         { () }
 
-StandaloneProgram :: { Program Var }
+StandaloneProgram :: { Program Name }
 StandaloneProgram : Program eof                 { $1 }
 
-Program         :: { Program Var }
+Program         :: { Program Name }
-                : TypedScDef ';' Program    { $3 & insTypeSig (fst $1)
+Program         : ScTypeSig ';' Program         { insTypeSig $1 $3 }
-                                                 & insScDef (snd $1) }
+                | ScTypeSig OptSemi             { singletonTypeSig $1 }
-                | TypedScDef OptSemi        { mempty & insTypeSig (fst $1)
+                | ScDef     ';' Program         { insScDef $1 $3 }
-                                                     & insScDef (snd $1) }
+                | ScDef     OptSemi             { singletonScDef $1 }
-                | TLPragma Program          {% doTLPragma $1 $2 }
+                | TLPragma  Program             {% doTLPragma $1 $2 }
-                | TLPragma                  {% doTLPragma $1 mempty }
+                | TLPragma                      {% doTLPragma $1 mempty }
 
 TLPragma        :: { Pragma }
                 : '{-#' Words '#-}'             { Pragma $2 }
@@ -100,152 +104,140 @@ OptSemi         : ';'                           { () }
                 | {- epsilon -}                 { () }
 
 ScTypeSig       :: { (Name, Type) }
-ScTypeSig       : Id ':' Type                   { ($1, $3) }
+ScTypeSig       : Var '::' Type                 { ($1,$3) }
 
-TypedScDef      :: { (Var, ScDef Var) }
+ScDefs          :: { [ScDef Name] }
-                : Id ':' Type ';' Id ParList '=' Expr
+ScDefs          : ScDef ';' ScDefs              { $1 : $3 }
-                            { (MkVar $1 $3, mkTypedScDef $1 $3 $5 $6 $8) }
+                | ScDef ';'                     { [$1] }
+                | ScDef                         { [$1] }
 
--- ScDefs          :: { [ScDef PsName] }
+ScDef           :: { ScDef Name }
--- ScDefs          : ScDef ';' ScDefs              { $1 : $3 }
+ScDef           : Var ParList '=' Expr          { ScDef $1 $2 $4 }
---                 | ScDef ';'                     { [$1] }
+                -- hack to allow constructors to be compiled into scs
---                 | ScDef                         { [$1] }
+                | Con ParList '=' Expr          { ScDef $1 $2 $4 }
--- 
--- ScDef           :: { ScDef PsName }
--- ScDef           : Id ParList '=' Expr   { ScDef (Left $1) $2
---                                                 ($4 & binders %~ Right) }
 
 Type            :: { Type }
-                : TypeApp '->' TypeApp              { $1 :-> $3 }
+Type            : Type1                         { $1 }
-                | TypeApp                         { $1 }
-
-TypeApp         :: { Type }
-                : TypeApp Type1                 { TyApp $1 $2 }
-                | Type1                         { $1 }
-
--- do we want to allow symbolic names for tyvars and tycons?
 
 Type1           :: { Type }
 Type1           : '(' Type ')'                  { $2 }
+                | Type1 '->' Type               { $1 :-> $3 }
+                -- do we want to allow symbolic names for tyvars and tycons?
                 | varname                       { TyVar $1 }
-                | conname                       { if $1 == "Type"
+                | conname                       { TyCon $1 }
-                                                    then TyKindType else TyCon $1 }
 
-ParList      :: { [Name] }
+ParList         :: { [Name] }
-ParList      : varname ParList            { $1 : $2 }
+ParList         : Var ParList                   { $1 : $2 }
-             | {- epsilon -}                 { [] }
+                | {- epsilon -}                 { [] }
 
-StandaloneExpr  :: { Expr Var }
+StandaloneExpr  :: { Expr Name }
 StandaloneExpr  : Expr eof                      { $1 }
 
-Expr            :: { Expr Var }
+Expr            :: { Expr Name }
 Expr            : LetExpr                       { $1 }
                 | 'λ' Binders '->' Expr         { Lam $2 $4 }
                 | Application                   { $1 }
                 | CaseExpr                      { $1 }
                 | Expr1                         { $1 }
 
-LetExpr         :: { Expr Var }
+LetExpr         :: { Expr Name }
 LetExpr         : let    '{'   Bindings '}'    in Expr { Let NonRec $3 $6 }
                 | letrec '{'   Bindings '}'    in Expr { Let Rec $3 $6 }
 
-Binders         :: { [Var] }
+Binders         :: { [Name] }
 Binders         : Var Binders                  { $1 : $2 }
                 | Var                          { [$1] }
 
-Application     :: { Expr Var }
+Application     :: { Expr Name }
-Application     : Application AppArg           { App $1 $2 }
+Application     : Expr1 AppArgs                { foldl' App $1 $2 }
-                | Expr1       AppArg           { App $1 $2 }
 
-AppArg          :: { Expr Var }
+AppArgs         :: { [Expr Name] }
-                : '@' Type1                     { Type $2 }
+AppArgs         : Expr1 AppArgs                 { $1 : $2 }
-                | Expr1                         { $1 }
+                | Expr1                         { [$1] }
 
-CaseExpr        :: { Expr Var }
+CaseExpr        :: { Expr Name }
 CaseExpr        : case Expr of '{' Alters '}'   { Case $2 $5 }
 
-Alters          :: { [Alter Var] }
+Alters          :: { [Alter Name] }
 Alters          : Alter ';' Alters              { $1 : $3 }
                 | Alter ';'                     { [$1] }
                 | Alter                         { [$1] }
 
-Alter           :: { Alter Var }
+Alter           :: { Alter Name }
-Alter           : alttag  AltParList '->' Expr     { Alter (AltTag  $1) $2 $4 }
+Alter           : alttag ParList '->' Expr      { Alter (AltTag  $1) $2 $4 }
-                | conname AltParList '->' Expr     { Alter (AltData $1) $2 $4 }
+                | Con    ParList '->' Expr      { Alter (AltData $1) $2 $4 }
 
-AltParList      :: { [Var] }
+Expr1           :: { Expr Name }
-                : Var AltParList                { $1 : $2 }
-                | {- epsilon -}                 { [] }
-
-Expr1           :: { Expr Var }
 Expr1           : litint                        { Lit $ IntL $1 }
                 | Id                            { Var $1 }
                 | PackCon                       { $1 }
                 | '(' Expr ')'                  { $2 }
 
-PackCon         :: { Expr Var }
+PackCon         :: { Expr Name }
 PackCon         : pack '{' litint litint '}'    { Con $3 $4 }
 
-Bindings        :: { [Binding Var] }
+Bindings        :: { [Binding Name] }
 Bindings        : Binding ';' Bindings          { $1 : $3 }
                 | Binding ';'                   { [$1] }
                 | Binding                       { [$1] }
 
-Binding         :: { Binding Var }
+Binding         :: { Binding Name }
 Binding         : Var '=' Expr                  { $1 := $3 }
 
 Id              :: { Name }
-                : varname                           { $1 }
+Id              : Var                                { $1 }
-                | conname                           { $1 }
+                | Con                                { $1 }
 
-Var             :: { Var }
+Var             :: { Name }
-Var             : '(' varname ':' Type ')'          { MkVar $2 $4 }
+Var             : varname                           { $1 }
+                | varsym                            { $1 }
+
+Con             :: { Name }
+Con             : conname                           { $1 }
+                | consym                            { $1 }
 
 {
 
-parseError :: [Located CoreToken] -> P a
+parseError :: [Located CoreToken] -> RLPC a
 parseError (Located _ t : _) =
     error $ "<line>" <> ":" <> "<col>"
          <> ": parse error at token `" <> show t <> "'"
 
-exprPragma :: [String] -> RLPC (Expr Var)
+{-# WARNING parseError "unimpl" #-}
+
+exprPragma :: [String] -> RLPC (Expr Name)
 exprPragma ("AST" : e) = undefined
 exprPragma _           = undefined
 
-astPragma :: [String] -> RLPC (Expr Var)
+{-# WARNING exprPragma "unimpl" #-}
+
+astPragma :: [String] -> RLPC (Expr Name)
 astPragma _ = undefined
 
--- insTypeSig :: (Hashable b) => (b, Type) -> Program b -> Program b
+{-# WARNING astPragma "unimpl" #-}
--- insTypeSig ts = programTypeSigs %~ uncurry H.insert ts
 
-insTypeSig :: Var -> Program Var -> Program Var
+insTypeSig :: (Hashable b) => (b, Type) -> Program b -> Program b
-insTypeSig w@(MkVar _ t) = programTypeSigs %~ H.insert w t
+insTypeSig ts = programTypeSigs %~ uncurry H.insert ts
 
--- singletonTypeSig :: (Hashable b) => (b, Type) -> Program b
+singletonTypeSig :: (Hashable b) => (b, Type) -> Program b
--- singletonTypeSig ts = insTypeSig ts mempty
+singletonTypeSig ts = insTypeSig ts mempty
 
 insScDef :: (Hashable b) => ScDef b -> Program b -> Program b
 insScDef sc = programScDefs %~ (sc:)
 
--- singletonScDef :: (Hashable b) => ScDef b -> Program b
+singletonScDef :: (Hashable b) => ScDef b -> Program b
--- singletonScDef sc = insScDef sc mempty
+singletonScDef sc = insScDef sc mempty
 
-parseCoreExprR :: (Monad m) => [Located CoreToken] -> RLPCT m (Expr Var)
+parseCoreExprR :: (Monad m) => [Located CoreToken] -> RLPCT m Expr'
-parseCoreExprR = liftMaybe . snd . flip runP def . parseCoreExpr
+parseCoreExprR = hoistRlpcT generalise . parseCoreExpr
 
-parseCoreProgR :: forall m. (Monad m)
+parseCoreProgR :: forall m. (Monad m) => [Located CoreToken] -> RLPCT m Program'
-               => [Located CoreToken] -> RLPCT m (Program Var)
+parseCoreProgR = ddumpast <=< (hoistRlpcT generalise . parseCoreProg)
-parseCoreProgR s = do
+    where
-    let p = runP (parseCoreProg s) def
+        ddumpast :: Program' -> RLPCT m Program'
-    case p of
+        ddumpast p = do
-        (st, Just a) -> do
+            addDebugMsg "dump-parsed-core" . show $ p
-            ddumpast a
+            pure p
-            pure a
-  where
-    ddumpast :: Show a => Program a -> RLPCT m (Program a)
-    ddumpast p = do
-        addDebugMsg "dump-parsed-core" . show $ p
-        pure p
 
 happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b
 happyBind m k = m >>= k
@@ -253,7 +245,7 @@ happyBind m k = m >>= k
 happyPure :: a -> RLPC a
 happyPure a = pure a
 
-doTLPragma :: Pragma -> Program Var -> P (Program Var)
+doTLPragma :: Pragma -> Program' -> RLPC Program'
 -- TODO: warn unrecognised pragma
 doTLPragma (Pragma []) p = pure p
 

src/Core/Parse/Types.hs

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

src/Core/Syntax.hs

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

src/Core/SystemF.hs

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

src/Core/TH.hs

@@ -5,8 +5,8 @@ Description : Core quasiquoters
 module Core.TH
     ( coreExpr
     , coreProg
-    -- , coreExprT
+    , coreExprT
-    -- , coreProgT
+    , coreProgT
     )
     where
 ----------------------------------------------------------------------------------
@@ -33,18 +33,16 @@ coreExpr :: QuasiQuoter
 coreExpr = mkqq $ lexCoreR >=> parseCoreExprR
 
 -- | Type-checked @coreProg@
--- coreProgT :: QuasiQuoter
+coreProgT :: QuasiQuoter
--- coreProgT = mkqq $ lexCoreR >=> parseCoreProgR >=> checkCoreProgR
+coreProgT = mkqq $ lexCoreR >=> parseCoreProgR >=> checkCoreProgR
 
--- coreExprT :: QuasiQuoter
+coreExprT :: QuasiQuoter
--- coreExprT = mkqq $ lexCoreR >=> parseCoreExprR >=> checkCoreExprR g
+coreExprT = mkqq $ lexCoreR >=> parseCoreExprR >=> checkCoreExprR g
---     where
+    where
---         g = [ ("+#", TyInt :-> TyInt :-> TyInt)
+        g = [ ("+#", TyCon "Int#" :-> TyCon "Int#" :-> TyCon "Int#")
---             , ("id", TyForall (MkVar "a" TyKindType) $
+            , ("id", TyCon "a" :-> TyCon "a")
---                     TyVar "a" :-> TyVar "a")
+            , ("fix", (TyCon "a" :-> TyCon "a") :-> TyCon "a")
---             , ("fix", TyForall (MkVar "a" TyKindType) $
+            ]
---                     (TyVar "a" :-> TyVar "a") :-> TyVar "a")
---             ]
 
 mkqq :: (Lift a) => (Text -> RLPCIO a) -> QuasiQuoter
 mkqq p = QuasiQuoter

src/Core/Utils.hs

@@ -2,6 +2,8 @@ module Core.Utils
     ( programRhss
     , programGlobals
     , isAtomic
+    -- , insertModule
+    , extractProgram
     , freeVariables
     )
     where
@@ -28,29 +30,34 @@ isAtomic _        = False
 
 ----------------------------------------------------------------------------------
 
-freeVariables :: Expr b -> Set b
+-- TODO: export list awareness
-freeVariables = undefined
+-- insertModule :: Module b -> Program b -> Program b
+-- insertModule (Module _ p) = programScDefs %~ (<>m)
 
--- freeVariables :: Expr' -> Set Name
+extractProgram :: Module b -> Program b
--- freeVariables = cata go
+extractProgram (Module _ p) = p
---     where
---         go :: ExprF Name (Set Name) -> Set Name
---         go (VarF k)         = S.singleton k
---         -- TODO: collect free vars in rhss of bs
---         go (LetF _ bs e)    = (e `S.union` esFree) `S.difference` ns
---             where
---                 es = bs ^.. each . _rhs :: [Expr']
---                 ns = S.fromList $ bs ^.. each . _lhs
---                 -- TODO: this feels a little wrong. maybe a different scheme is
---                 -- appropriate
---                 esFree = foldMap id $ freeVariables <$> es
 
---         go (CaseF e as)     = e `S.union` asFree
+----------------------------------------------------------------------------------
---             where
+
---                 -- asFree = foldMap id $ freeVariables <$> (fmap altToLam as)
+freeVariables :: Expr' -> Set Name
---                 asFree = foldMap (freeVariables . altToLam) as
+freeVariables = cata go
---                 -- we map alts to lambdas to avoid writing a 'freeVariablesAlt'
+    where
---                 altToLam (Alter _ ns e) = Lam ns e
+        go :: ExprF Name (Set Name) -> Set Name
---         go (LamF bs e)      = e `S.difference` (S.fromList bs)
+        go (VarF k)         = S.singleton k
---         go e                = foldMap id e
+        -- TODO: collect free vars in rhss of bs
+        go (LetF _ bs e)    = (e `S.union` esFree) `S.difference` ns
+            where
+                es = bs ^.. each . _rhs :: [Expr']
+                ns = S.fromList $ bs ^.. each . _lhs
+                -- TODO: this feels a little wrong. maybe a different scheme is
+                -- appropriate
+                esFree = foldMap id $ freeVariables <$> es
+
+        go (CaseF e as)     = e `S.union` asFree
+            where
+                asFree = foldMap id $ freeVariables <$> (fmap altToLam as)
+                -- we map alts to lambdas to avoid writing a 'freeVariablesAlt'
+                altToLam (Alter _ ns e) = Lam ns e
+        go (LamF bs e)      = e `S.difference` (S.fromList bs)
+        go e                = foldMap id e
 

src/Core2Core.hs

@@ -116,7 +116,7 @@ floatNonStrictCases g = goE
             goE e
             traverse_ goE altBodies
             pure e'
-        goC (App f x)           = App <$> goC f <*> goC x
+        goC (f :$ x)            = (:$) <$> goC f <*> goC x
         goC (Let r bs e)        = Let r <$> bs' <*> goE e
             where bs' = travBs goC bs
         goC (Lit l)             = pure (Lit l)
@@ -128,9 +128,10 @@ floatNonStrictCases g = goE
         -- extract the right-hand sides of a list of bindings, traverse each
         -- one, and return the original list of bindings
         travBs :: (Expr' -> Floater Expr') -> [Binding'] -> Floater [Binding']
-        travBs c bs = undefined
+        travBs c bs = bs ^.. each . _rhs
+                    & traverse goC
+                    & const (pure bs)
         -- ^ ??? what the fuck?
-        -- ^ 24/02/22: what is this shit lol?
 
 -- when provided with a case expr, floatCase will float the case into a
 -- supercombinator of its free variables. the sc is returned along with an

src/Data/Pretty.hs

@@ -1,17 +1,13 @@
-{-# LANGUAGE QuantifiedConstraints, UndecidableInstances #-}
 module Data.Pretty
-    ( Pretty(..), Pretty1(..)
+    ( Pretty(..)
-    , prettyPrec1
     , rpretty
     , ttext
-    , Showing(..)
     -- * Pretty-printing lens combinators
-    , hsepOf, vsepOf, vcatOf, vlinesOf, vsepTerm
+    , hsepOf, vsepOf
-    , vsep
+    , vcatOf
+    , vlinesOf
     , module Text.PrettyPrint
     , maybeParens
-    , appPrec
-    , appPrec1
     )
     where
 ----------------------------------------------------------------------------------
@@ -19,15 +15,10 @@ import Text.PrettyPrint             hiding ((<>))
 import Text.PrettyPrint.HughesPJ    hiding ((<>))
 import Text.Printf
 import Data.String                  (IsString(..))
-import Data.Text.Lens               hiding ((:<))
+import Data.Text.Lens
-import Data.Monoid                  hiding (Sum)
+import Data.Monoid
-import Control.Lens
-
--- instances
-import Control.Comonad.Cofree
 import Data.Text                    qualified as T
-import Data.Functor.Sum
+import Control.Lens
-import Data.Fix                     (Fix(..))
 ----------------------------------------------------------------------------------
 
 class Pretty a where
@@ -36,7 +27,7 @@ class Pretty a where
 
     {-# MINIMAL pretty | prettyPrec #-}
     pretty = prettyPrec 0
-    prettyPrec = const pretty
+    prettyPrec a _ = pretty a
 
 rpretty :: (IsString s, Pretty a) => a -> s
 rpretty = fromString . render . pretty
@@ -54,26 +45,6 @@ instance (Show a) => Pretty (Showing a) where
 
 deriving via Showing Int instance Pretty Int
 
-class (forall a. Pretty a => Pretty (f a)) => Pretty1 f where
-    liftPrettyPrec :: (Int -> a -> Doc) -> Int -> f a -> Doc
-
-prettyPrec1 :: (Pretty1 f, Pretty a) => Int -> f a -> Doc
-prettyPrec1 = liftPrettyPrec prettyPrec
-
-instance (Pretty1 f, Pretty1 g, Pretty a) => Pretty (Sum f g a) where
-    prettyPrec p (InL fa) = prettyPrec1 p fa
-    prettyPrec p (InR ga) = prettyPrec1 p ga
-
-instance (Pretty1 f, Pretty1 g) => Pretty1 (Sum f g) where
-    liftPrettyPrec pr p (InL fa) = liftPrettyPrec pr p fa
-    liftPrettyPrec pr p (InR ga) = liftPrettyPrec pr p ga
-
-instance (Pretty (f (Fix f))) => Pretty (Fix f) where
-    prettyPrec d (Fix f) = prettyPrec d f
-
--- instance (Pretty1 f) => Pretty (Fix f) where
---     prettyPrec d (Fix f) = prettyPrec1 d f
-
 --------------------------------------------------------------------------------
 
 ttext :: Pretty t => t -> Doc
@@ -92,22 +63,3 @@ vlinesOf :: Getting (Endo Doc) s Doc -> s -> Doc
 vlinesOf l = foldrOf l (\a b -> a $+$ "" $+$ b) mempty
 -- hack(?) to separate chunks with a blankline
 
-vsepTerm :: Doc -> Doc -> Doc -> Doc
-vsepTerm term a b = (a <> term) $+$ b
-
-vsep :: [Doc] -> Doc
-vsep = foldr ($+$) mempty
-
---------------------------------------------------------------------------------
-
-appPrec, appPrec1 :: Int
-appPrec  = 10
-appPrec1 = 11
-
-instance PrintfArg Doc where
-    formatArg d fmt
-        | fmtChar (vFmt 'D' fmt) == 'D' = formatString (render d) fmt'
-        | otherwise                     = errorBadFormat $ fmtChar fmt
-      where
-        fmt' = fmt { fmtChar = 's', fmtPrecision = Nothing }
-

src/GM.hs

@@ -11,6 +11,11 @@ module GM
     , evalProgR
     , GmState(..)
     , gmCode, gmStack, gmDump, gmHeap, gmEnv, gmStats
+    , stsReductions
+    , stsPrimReductions
+    , stsAllocations
+    , stsDereferences
+    , stsGCCycles
     , Node(..)
     , showState
     , gmEvalProg
@@ -29,10 +34,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 System.IO                    (Handle, hPutStrLn)
+import Text.PrettyPrint             (render)
 -- TODO: an actual output system
 -- TODO: an actual output system
 -- TODO: an actual output system
@@ -41,9 +45,12 @@ import System.IO.Unsafe             (unsafePerformIO)
 import Data.String                  (IsString)
 import Data.Heap
 import Debug.Trace
+
 import Compiler.RLPC
 import Core2Core
 import Core
+import GM.Types
+import GM.Print
 ----------------------------------------------------------------------------------
 
 tag_Unit_unit :: Int
@@ -55,105 +62,19 @@ tag_Bool_True = 1
 tag_Bool_False :: Int
 tag_Bool_False = 0
 
-{-}
-
-hdbgProg = undefined
-evalProg = undefined
-
-data Node = NNum Int
-          | NAp Addr Addr
-          | NInd Addr
-          | NUninitialised
-          | NConstr Tag [Addr] -- NConstr Tag Components
-          | NMarked Node
-          deriving (Show, Eq)
-
---}
-
-data GmState = GmState
-    { _gmCode   :: Code
-    , _gmStack  :: Stack
-    , _gmDump   :: Dump
-    , _gmHeap   :: GmHeap
-    , _gmEnv    :: Env
-    , _gmStats  :: Stats
-    }
-    deriving Show
-
-type Code = [Instr]
-type Stack = [Addr]
-type Dump = [(Code, Stack)]
-type Env = [(Key, Addr)]
-type GmHeap = Heap Node
-
-data Key = NameKey Name
-         | ConstrKey Tag Int
-         deriving (Show, Eq)
-
--- >> [ref/Instr]
-data Instr = Unwind
-           | PushGlobal Name
-           | PushConstr Tag Int
-           | PushInt Int
-           | Push Int
-           | MkAp
-           | Slide Int
-           | Update Int
-           | Pop Int
-           | Alloc Int
-           | Eval
-           -- arith
-           | Neg | Add | Sub | Mul | Div
-           -- comparison
-           | Equals | Lesser | GreaterEq
-           | Pack Tag Int -- Pack Tag Arity
-           | CaseJump [(Tag, Code)]
-           | Split Int
-           | Print
-           | Halt
-           deriving (Show, Eq)
--- << [ref/Instr]
-
-data Node = NNum Int
-          | NAp Addr Addr
-          -- NGlobal is the GM equivalent of NSupercomb. rather than storing a
-          -- template to be instantiated, NGlobal holds the global's arity and
-          -- the pre-compiled code :3
-          | NGlobal Int Code
-          | NInd Addr
-          | NUninitialised
-          | NConstr Tag [Addr] -- NConstr Tag Components
-          | NMarked Node
-          deriving (Show, Eq)
-
--- TODO: log executed instructions
-data Stats = Stats
-    { _stsReductions     :: Int
-    , _stsPrimReductions :: Int
-    , _stsAllocations    :: Int
-    , _stsDereferences   :: Int
-    , _stsGCCycles       :: Int
-    }
-    deriving Show
-
-instance Default Stats where
-    def = Stats 0 0 0 0 0
-
--- TODO: _gmGlobals should not have a setter
-makeLenses ''GmState
-makeLenses ''Stats
-pure []
-
 ----------------------------------------------------------------------------------
 
-evalProg :: Program' -> Maybe (Node, Stats)
+evalProg :: Program' -> [GmState]
-evalProg p = res <&> (,sts)
+evalProg = eval . compile
-    where
+
-        final = eval (compile p) & last
+-- evalProg :: Program' -> Maybe (Node, Stats)
-        h = final ^. gmHeap
+-- evalProg p = res <&> (,sts)
-        sts = final ^. gmStats
+--     where
-        resAddr = final ^. gmStack ^? _head
+--         final = eval (compile p) & last
-        res = resAddr >>= flip hLookup h
+--         h = final ^. gmHeap
+--         sts = final ^. gmStats
+--         resAddr = final ^. gmStack ^? _head
+--         res = resAddr >>= flip hLookup h
 
 hdbgProg :: Program' -> Handle -> IO GmState
 hdbgProg p hio = do
@@ -815,185 +736,8 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
         argOffset :: Int -> Env -> Env
         argOffset n = each . _2 %~ (+n)
 
-showCon :: (IsText a) => Tag -> Int -> a
-showCon t n = printf "Pack{%d %d}" t n ^. packed
-
 ----------------------------------------------------------------------------------
 
-pprTabstop :: Int
-pprTabstop = 4
-
-qquotes :: Doc -> Doc
-qquotes d = "`" <> d <> "'"
-
-showStats :: Stats -> Doc
-showStats sts = "==== Stats ============" $$ stats
-    where
-        stats = text $ printf
-            "Reductions      : %5d\n\
-            \Prim Reductions : %5d\n\
-            \Allocations     : %5d\n\
-            \GC Cycles       : %5d"
-            (sts ^. stsReductions)
-            (sts ^. stsPrimReductions)
-            (sts ^. stsAllocations)
-            (sts ^. stsGCCycles)
-
-showState :: GmState -> Doc
-showState st = vcat
-        [ "==== GmState " <> int stnum <> " "
-            <> text (replicate (28 - 13 - 1 - digitalWidth stnum) '=')
-        , "-- Next instructions -------"
-        , info $ showCodeShort c
-        , "-- Stack -------------------"
-        , info $ showStack st
-        , "-- Heap --------------------"
-        , info $ showHeap st
-        , "-- Dump --------------------"
-        , info $ showDump st
-        ]
-    where
-        stnum = st ^. (gmStats . stsReductions)
-        c = st ^. gmCode
-
-        -- indent data
-        info = nest pprTabstop
-
-showCodeShort :: Code -> Doc
-showCodeShort c = braces c'
-    where
-        c' | length c > 3 = list (showInstr <$> take 3 c) <> "; ..."
-           | otherwise    = list (showInstr <$> c)
-        list = hcat . punctuate "; "
-
-showStackShort :: Stack -> Doc
-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
-
-showStack :: GmState -> Doc
-showStack st = vcat $ uncurry showEntry <$> si
-    where
-        h = st ^. gmHeap
-        s = st ^. gmStack
-
-        -- stack with labeled indices
-        si = [0..] `zip` s
-
-        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 st = vcat $ uncurry showEntry <$> di
-    where
-        d = st ^. gmDump
-        di = [0..] `zip` d
-
-        showIndex n = padInt w n <> ": "
-        w = maxWidth (fst <$> di)
-
-        showEntry :: Int -> (Code, Stack) -> Doc
-        showEntry n (c,s) = showIndex n <> nest pprTabstop entry
-            where
-                entry = ("Stack : " <> showCodeShort c)
-                     $$ ("Code  : " <> showStackShort s)
-
-padInt :: Int -> Int -> Doc
-padInt m n = text (replicate (m - digitalWidth n) ' ') <> int n
-
-maxWidth :: [Int] -> Int
-maxWidth ns = digitalWidth $ maximum ns
-
-digitalWidth :: Int -> Int
-digitalWidth = length . show
-
-showHeap :: GmState -> Doc
-showHeap st = vcat $ showEntry <$> addrs
-    where
-        showAddr n = padInt w n <> ": "
-
-        w = maxWidth addrs
-        h = st ^. gmHeap
-        addrs = addresses h
-
-        showEntry :: Addr -> Doc
-        showEntry a = showAddr a <> showNodeAt st a
-
-showNodeAt :: GmState -> Addr -> Doc
-showNodeAt = showNodeAtP 0
-
-showNodeAtP :: Int -> GmState -> Addr -> Doc
-showNodeAtP p st a = case hLookup a h of
-    Just (NNum n)        -> int n <> "#"
-    Just (NGlobal _ _)   -> textt name
-        where
-            g = st ^. gmEnv
-            name = case lookup a (swap <$> g) of
-                Just (NameKey n)     -> n
-                Just (ConstrKey t n) -> showCon t n
-                _                    -> errTxtInvalidAddress
-    -- TODO: left-associativity
-    Just (NAp f x)       -> pprec $ showNodeAtP (p+1) st f
-                                <+> showNodeAtP (p+1) st x
-    Just (NInd a')       -> pprec $ "NInd -> " <> showNodeAtP (p+1) st a'
-    Just (NConstr t as)  -> pprec $ "NConstr"
-                                <+> int t
-                                <+> brackets (list $ showNodeAtP 0 st <$> as)
-        where list = hcat . punctuate ", "
-    Just NUninitialised  -> "<uninitialised>"
-    Nothing              -> errTxtInvalidAddress
-    where
-        h = st ^. gmHeap
-        pprec = maybeParens (p > 0)
-
-showSc :: GmState -> (Name, Addr) -> Doc
-showSc st (k,a) = "Supercomb " <> qquotes (textt k) <> colon
-               $$ code
-    where
-        code = case hLookup a (st ^. gmHeap) of
-            Just (NGlobal _ c) -> showCode c
-            Just _             -> errTxtInvalidObject
-            Nothing            -> errTxtInvalidAddress
-
-errTxtInvalidObject, errTxtInvalidAddress :: (IsString a) => a
-errTxtInvalidObject = "<invalid object>"
-errTxtInvalidAddress = "<invalid address>"
-
-showCode :: Code -> Doc
-showCode c = "Code" <+> braces instrs
-    where instrs = vcat $ showInstr <$> c
-
-showInstr :: Instr -> Doc
-showInstr (CaseJump alts) = "CaseJump" $$ nest pprTabstop alternatives
-    where
-        showAlt (t,c) = "<" <> int t <> ">" <> showCodeShort c
-        alternatives = foldr (\a acc -> showAlt a $$ acc) mempty alts
-showInstr i = text $ show i
-
-textt :: (IsText a) => a -> Doc
-textt t = t ^. unpacked & text
-
-----------------------------------------------------------------------------------
-
-lookupN :: Name -> Env -> Maybe Addr
-lookupN k = lookup (NameKey k)
-
-lookupC :: Tag -> Int -> Env -> Maybe Addr
-lookupC t n = lookup (ConstrKey t n)
-
-----------------------------------------------------------------------------------
-
-gc :: GmState -> GmState
-gc st = (sweepNodes . markNodes $ st)
-      & gmStats . stsGCCycles %~ succ
-
 markNodes :: GmState -> GmState
 markNodes st = st & gmHeap %~ thread (markFrom <$> roots)
     where
@@ -1036,6 +780,18 @@ sweepNodes st = st & gmHeap %~ thread (f <$> addresses h)
 thread :: [a -> a] -> (a -> a)
 thread = appEndo . foldMap Endo
 
+gc :: GmState -> GmState
+gc st = (sweepNodes . markNodes $ st)
+      & gmStats . stsGCCycles %~ succ
+
+--------------------------------------------------------------------------------
+
+lookupN :: Name -> Env -> Maybe Addr
+lookupN k = lookup (NameKey k)
+
+lookupC :: Tag -> Int -> Env -> Maybe Addr
+lookupC t n = lookup (ConstrKey t n)
+
 ----------------------------------------------------------------------------------
 
 gmEvalProg :: Program' -> GmState
@@ -1047,12 +803,11 @@ finalStateOf f = f . gmEvalProg
 resultOf :: Program' -> Maybe Node
 resultOf p = do
     a <- res
-    n <- hLookup a h
+    hLookup a h
-    pure n
+  where
-    where
+    res = st ^? gmStack . _head
-        res = st ^? gmStack . _head
+    st = gmEvalProg p
-        st = gmEvalProg p
+    h = st ^. gmHeap
-        h = st ^. gmHeap
 
 resultOfExpr :: Expr' -> Maybe Node
 resultOfExpr e = resultOf $

src/GM/Print.hs

@@ -0,0 +1,186 @@
+module GM.Print
+    ( showState
+    , showStats
+    , showNodeAt
+    )
+    where
+--------------------------------------------------------------------------------
+import Data.Monoid
+import Data.String              (IsString(..))
+import Data.Text.Lens           (IsText, packed, unpacked)
+import Text.Printf
+
+import Text.PrettyPrint             hiding ((<>))
+import Text.PrettyPrint.HughesPJ    (maybeParens)
+import Control.Lens
+
+import Data.Heap
+import Core.Syntax
+import GM.Types
+--------------------------------------------------------------------------------
+
+pprTabstop :: Int
+pprTabstop = 4
+
+qquotes :: Doc -> Doc
+qquotes d = "`" <> d <> "'"
+
+showStats :: Stats -> Doc
+showStats sts = "==== Stats ============" $$ stats
+    where
+        stats = text $ printf
+            "Reductions      : %5d\n\
+            \Prim Reductions : %5d\n\
+            \Allocations     : %5d\n\
+            \GC Cycles       : %5d"
+            (sts ^. stsReductions)
+            (sts ^. stsPrimReductions)
+            (sts ^. stsAllocations)
+            (sts ^. stsGCCycles)
+
+showState :: GmState -> Doc
+showState st = vcat
+        [ "==== GmState " <> int stnum <> " "
+            <> text (replicate (28 - 13 - 1 - digitalWidth stnum) '=')
+        , "-- Next instructions -------"
+        , info $ showCodeShort c
+        , "-- Stack -------------------"
+        , info $ showStack st
+        , "-- Heap --------------------"
+        , info $ showHeap st
+        , "-- Dump --------------------"
+        , info $ showDump st
+        ]
+    where
+        stnum = st ^. (gmStats . stsReductions)
+        c = st ^. gmCode
+
+        -- indent data
+        info = nest pprTabstop
+
+showCodeShort :: Code -> Doc
+showCodeShort c = braces c'
+    where
+        c' | length c > 3 = list (showInstr <$> take 3 c) <> "; ..."
+           | otherwise    = list (showInstr <$> c)
+        list = hcat . punctuate "; "
+
+showStackShort :: Stack -> Doc
+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
+
+showStack :: GmState -> Doc
+showStack st = vcat $ uncurry showEntry <$> si
+    where
+        h = st ^. gmHeap
+        s = st ^. gmStack
+
+        -- stack with labeled indices
+        si = [0..] `zip` s
+
+        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 st = vcat $ uncurry showEntry <$> di
+    where
+        d = st ^. gmDump
+        di = [0..] `zip` d
+
+        showIndex n = padInt w n <> ": "
+        w = maxWidth (fst <$> di)
+
+        showEntry :: Int -> (Code, Stack) -> Doc
+        showEntry n (c,s) = showIndex n <> nest pprTabstop entry
+            where
+                entry = ("Stack : " <> showCodeShort c)
+                     $$ ("Code  : " <> showStackShort s)
+
+padInt :: Int -> Int -> Doc
+padInt m n = text (replicate (m - digitalWidth n) ' ') <> int n
+
+maxWidth :: [Int] -> Int
+maxWidth ns = digitalWidth $ maximum ns
+
+digitalWidth :: Int -> Int
+digitalWidth = length . show
+
+showHeap :: GmState -> Doc
+showHeap st = vcat $ showEntry <$> addrs
+    where
+        showAddr n = padInt w n <> ": "
+
+        w = maxWidth addrs
+        h = st ^. gmHeap
+        addrs = addresses h
+
+        showEntry :: Addr -> Doc
+        showEntry a = showAddr a <> showNodeAt st a
+
+showNodeAt :: GmState -> Addr -> Doc
+showNodeAt = showNodeAtP 0
+
+showNodeAtP :: Int -> GmState -> Addr -> Doc
+showNodeAtP p st a = case hLookup a h of
+    Just (NNum n)        -> int n <> "#"
+    Just (NGlobal _ _)   -> textt name
+        where
+            g = st ^. gmEnv
+            name = case lookup a (view swapped <$> g) of
+                Just (NameKey n)     -> n
+                Just (ConstrKey t n) -> showCon t n
+                _                    -> errTxtInvalidAddress
+    -- TODO: left-associativity
+    Just (NAp f x)       -> pprec $ showNodeAtP (p+1) st f
+                                <+> showNodeAtP (p+1) st x
+    Just (NInd a')       -> pprec $ "NInd -> " <> showNodeAtP (p+1) st a'
+    Just (NConstr t as)  -> pprec $ "NConstr"
+                                <+> int t
+                                <+> brackets (list $ showNodeAtP 0 st <$> as)
+        where list = hcat . punctuate ", "
+    Just NUninitialised  -> "<uninitialised>"
+    Nothing              -> errTxtInvalidAddress
+    where
+        h = st ^. gmHeap
+        pprec = maybeParens (p > 0)
+
+showSc :: GmState -> (Name, Addr) -> Doc
+showSc st (k,a) = "Supercomb " <> qquotes (textt k) <> colon
+               $$ code
+    where
+        code = case hLookup a (st ^. gmHeap) of
+            Just (NGlobal _ c) -> showCode c
+            Just _             -> errTxtInvalidObject
+            Nothing            -> errTxtInvalidAddress
+
+errTxtInvalidObject, errTxtInvalidAddress :: (IsString a) => a
+errTxtInvalidObject = "<invalid object>"
+errTxtInvalidAddress = "<invalid address>"
+
+showCode :: Code -> Doc
+showCode c = "Code" <+> braces instrs
+    where instrs = vcat $ showInstr <$> c
+
+showInstr :: Instr -> Doc
+showInstr (CaseJump alts) = "CaseJump" $$ nest pprTabstop alternatives
+    where
+        showAlt (t,c) = "<" <> int t <> ">" <> showCodeShort c
+        alternatives = foldr (\a acc -> showAlt a $$ acc) mempty alts
+showInstr i = text $ show i
+
+textt :: (IsText a) => a -> Doc
+textt t = t ^. unpacked & text
+
+----------------------------------------------------------------------------------
+
+showCon :: (IsText a) => Tag -> Int -> a
+showCon t n = printf "Pack{%d %d}" t n ^. packed
+

src/GM/Types.hs

@@ -0,0 +1,83 @@
+{-# LANGUAGE TemplateHaskell #-}
+module GM.Types where
+--------------------------------------------------------------------------------
+import Control.Lens.Combinators
+import Data.Heap
+import Data.Default
+
+import Core.Syntax
+--------------------------------------------------------------------------------
+
+data GmState = GmState
+    { _gmCode   :: Code
+    , _gmStack  :: Stack
+    , _gmDump   :: Dump
+    , _gmHeap   :: GmHeap
+    , _gmEnv    :: Env
+    , _gmStats  :: Stats
+    }
+    deriving Show
+
+type Code = [Instr]
+type Stack = [Addr]
+type Dump = [(Code, Stack)]
+type Env = [(Key, Addr)]
+type GmHeap = Heap Node
+
+data Key = NameKey Name
+         | ConstrKey Tag Int
+         deriving (Show, Eq)
+
+-- >> [ref/Instr]
+data Instr = Unwind
+           | PushGlobal Name
+           | PushConstr Tag Int
+           | PushInt Int
+           | Push Int
+           | MkAp
+           | Slide Int
+           | Update Int
+           | Pop Int
+           | Alloc Int
+           | Eval
+           -- arith
+           | Neg | Add | Sub | Mul | Div
+           -- comparison
+           | Equals | Lesser | GreaterEq
+           | Pack Tag Int -- Pack Tag Arity
+           | CaseJump [(Tag, Code)]
+           | Split Int
+           | Print
+           | Halt
+           deriving (Show, Eq)
+-- << [ref/Instr]
+
+data Node = NNum Int
+          | NAp Addr Addr
+          -- NGlobal is the GM equivalent of NSupercomb. rather than storing a
+          -- template to be instantiated, NGlobal holds the global's arity and
+          -- the pre-compiled code :3
+          | NGlobal Int Code
+          | NInd Addr
+          | NUninitialised
+          | NConstr Tag [Addr] -- NConstr Tag Components
+          | NMarked Node
+          deriving (Show, Eq)
+
+-- TODO: log executed instructions
+data Stats = Stats
+    { _stsReductions     :: Int
+    , _stsPrimReductions :: Int
+    , _stsAllocations    :: Int
+    , _stsDereferences   :: Int
+    , _stsGCCycles       :: Int
+    }
+    deriving Show
+
+instance Default Stats where
+    def = Stats 0 0 0 0 0
+
+-- TODO: _gmGlobals should not have a setter
+makeLenses ''GmState
+makeLenses ''Stats
+

src/GM/Visual.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+module GM.Visual
+    ( renderGmState
+    )
+    where
+--------------------------------------------------------------------------------
+import Text.Printf
+import Data.Function            ((&), on)
+import Text.PrettyPrint         qualified as P
+
+import Diagrams.Prelude
+import Diagrams.Backend.Cairo
+
+import GM.Types
+import GM.Print
+--------------------------------------------------------------------------------
+
+renderGmState :: GmState -> IO ()
+renderGmState st = renderCairo path size (drawState st)
+    where
+        size = mkSizeSpec2D (Just 1000) (Just 1000)
+        path = printf "/tmp/render/%04d.png" n
+        n = st ^. gmStats . stsReductions
+
+drawState :: GmState -> Diagram B
+drawState = drawStack
+
+drawStack :: GmState -> Diagram B
+drawStack st = st & vcatOf (gmStack . each . to cell)
+    where
+        cell a = rect 10 5
+              <> text (printf "%04x: %s" a (P.render . showNodeAt st $ a))
+
+vcatOf :: (InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a, Monoid' a)
+       => Getting (Endo [a]) s a -> s -> a
+vcatOf l = vcat . (^.. l)
+
+newtype Vap a = Vap { getVap :: a }
+
+instance (InSpace V2 n a, Juxtaposable a, Semigroup a)
+         => Semigroup (Vap a) where (<>) = (Vap .) . ((===) `on` getVap)
+instance (InSpace V2 n a, Juxtaposable a, Monoid a)
+         => Monoid (Vap a) where mempty = Vap mempty
+
+newtype Hap a = Hap { getHap :: a }
+
+instance (InSpace V2 n a, Juxtaposable a, Semigroup a)
+         => Semigroup (Hap a) where (<>) = (Hap .) . ((|||) `on` getHap)
+instance (InSpace V2 n a, Juxtaposable a, Monoid a)
+         => Monoid (Hap a) where mempty = Hap mempty
+

src/Misc.hs

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

src/Misc/Lift1.hs

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

src/Rlp/AltParse.y

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

src/Rlp/AltSyntax.hs

@@ -1,219 +0,0 @@
-{-# LANGUAGE TemplateHaskell, PatternSynonyms #-}
-module Rlp.AltSyntax
-    (
-    -- * AST
-      Program(..), Decl(..), ExprF(..), Pat(..)
-    , RlpExprF, RlpExpr, Binding(..), Alter(..)
-    , DataCon(..), Type(..)
-    , pattern IntT
-
-    , TypeF(..)
-
-    , Core.Name, PsName
-    , pattern (Core.:->)
-
-    -- * Optics
-    , programDecls
-    , _VarP, _FunB, _VarB
-
-    -- * Functor-related tools
-    , Fix(..), Cofree(..), Sum(..), pattern Finl, pattern Finr
-    )
-    where
---------------------------------------------------------------------------------
-import Data.Functor.Sum
-import Control.Comonad.Cofree
-import Data.Fix
-import Data.Function            (fix)
-import GHC.Generics             (Generic, Generic1)
-import Data.Hashable
-import Data.Hashable.Lifted
-import GHC.Exts                 (IsString)
-import Control.Lens
-
-import Data.Functor.Foldable.TH
-import Text.Show.Deriving
-import Data.Eq.Deriving
-import Data.Text                qualified as T
-import Data.Pretty
-import Misc.Lift1
-
-import Compiler.Types
-import Core.Syntax              qualified as Core
---------------------------------------------------------------------------------
-
-type PsName = T.Text
-
-newtype Program b a = Program [Decl b a]
-    deriving Show
-
-programDecls :: Lens' (Program b a) [Decl b a]
-programDecls = lens (\ (Program ds) -> ds) (const Program)
-
-data Decl b a = FunD b [Pat b] a
-              | DataD b [b] [DataCon b]
-              | TySigD b (Type b)
-              deriving Show
-
-data DataCon b = DataCon b [Type b]
-    deriving (Show, Generic)
-
-data Type b = VarT b
-            | ConT b
-            | AppT (Type b) (Type b)
-            | FunT
-            | ForallT b (Type b)
-            deriving (Show, Eq, Generic, Functor, Foldable, Traversable)
-
-instance (Hashable b) => Hashable (Type b)
-
-pattern IntT :: (IsString b, Eq b) => Type b
-pattern IntT = ConT "Int#"
-
-instance Core.HasArrowSyntax (Type b) (Type b) (Type b) where
-    _arrowSyntax = prism make unmake where
-        make (s,t) = FunT `AppT` s `AppT` t
-
-        unmake (FunT `AppT` s `AppT` t) = Right (s,t)
-        unmake s                        = Left s
-
-data ExprF b a = InfixEF b a a
-               | LetEF Core.Rec [Binding b a] a
-               | CaseEF a [Alter b a]
-               deriving (Functor, Foldable, Traversable)
-               deriving (Eq, Generic, Generic1)
-
-data Alter b a = Alter (Pat b) a
-               deriving (Show, Functor, Foldable, Traversable)
-               deriving (Eq, Generic, Generic1)
-
-data Binding b a = FunB b [Pat b] a
-                 | VarB (Pat b) a
-                 deriving (Show, Functor, Foldable, Traversable)
-                 deriving (Eq, Generic, Generic1)
-
--- type Expr b = Cofree (ExprF b)
-
-type RlpExprF b = Sum (Core.ExprF b) (ExprF b)
-
-type RlpExpr b = Fix (RlpExprF b)
-
-data Pat b = VarP b
-           | ConP b
-           | AppP (Pat b) (Pat b)
-           deriving (Eq, Show, Generic)
-
-deriveShow1 ''Alter
-deriveShow1 ''Binding
-deriveShow1 ''ExprF
-deriving instance (Show b, Show a) => Show (ExprF b a)
-
-pattern Finl :: f (Fix (Sum f g)) -> Fix (Sum f g)
-pattern Finl fa = Fix (InL fa)
-
-pattern Finr :: g (Fix (Sum f g)) -> Fix (Sum f g)
-pattern Finr ga = Fix (InR ga)
-
---------------------------------------------------------------------------------
-
-instance (Pretty b, Pretty a) => Pretty (ExprF b a) where
-    prettyPrec = prettyPrec1
-
-instance (Pretty b, Pretty a) => Pretty (Alter b a) where
-    prettyPrec = prettyPrec1
-
-instance (Pretty b) => Pretty1 (Alter b) where
-    liftPrettyPrec pr _ (Alter p e) =
-        hsep [ pretty p, "->", pr 0 e]
-
-instance Pretty b => Pretty1 (ExprF b) where
-    liftPrettyPrec pr p (InfixEF o a b) = maybeParens (p>0) $
-        pr 1 a <+> pretty o <+> pr 1 b
-    liftPrettyPrec pr p (CaseEF e as) = maybeParens (p>0) $
-        hsep [ "case", pr 0 e, "of" ]
-        $+$ nest 2 (vcat $ liftPrettyPrec pr 0 <$> as)
-
-instance (Pretty b, Pretty a) => Pretty (Decl b a) where
-    prettyPrec = prettyPrec1
-
-instance (Pretty b) => Pretty1 (Decl b) where
-    liftPrettyPrec pr _ (FunD f as e) =
-        hsep [ ttext f, hsep (prettyPrec appPrec1 <$> as)
-             , "=", pr 0 e ]
-
-    liftPrettyPrec _ _ (DataD f as []) =
-        hsep [ "data", ttext f, hsep (pretty <$> as) ]
-
-    liftPrettyPrec _ _ (DataD f as ds) =
-        hsep [ "data", ttext f, hsep (pretty <$> as), cons ]
-      where
-        cons = vcat $ zipWith (<+>) delims (pretty <$> ds)
-        delims = "=" : repeat "|"
-
-    liftPrettyPrec _ _ (TySigD n t) =
-        hsep [ ttext n, ":", pretty t ]
-
-instance (Pretty b) => Pretty (DataCon b) where
-    pretty (DataCon n as) = ttext n <+> hsep (prettyPrec appPrec1 <$> as)
-
--- (->) is given prec `appPrec-1`
-instance (Pretty b) => Pretty (Type b) where
-    prettyPrec _ (VarT n) = ttext n
-    prettyPrec _ (ConT n) = ttext n
-    prettyPrec p (s Core.:-> t) = maybeParens (p>appPrec-1) $
-        hsep [ prettyPrec appPrec s, "->", prettyPrec (appPrec-1) t ]
-    prettyPrec p (AppT f x) = maybeParens (p>appPrec) $
-        prettyPrec appPrec f <+> prettyPrec appPrec1 x
-    prettyPrec p FunT = maybeParens (p>0) "->"
-
-instance (Pretty b) => Pretty (Pat b) where
-    prettyPrec p (VarP b) = prettyPrec p b
-    prettyPrec p (ConP b) = prettyPrec p b
-    prettyPrec p (AppP c x) = maybeParens (p>appPrec) $
-        prettyPrec appPrec c <+> prettyPrec appPrec1 x
-
-instance (Pretty a, Pretty b) => Pretty (Program b a) where
-    prettyPrec = prettyPrec1
-
-instance (Pretty b) => Pretty1 (Program b) where
-    liftPrettyPrec pr p (Program ds) = vsep $ liftPrettyPrec pr p <$> ds
-
-makePrisms ''Pat
-makePrisms ''Binding
-
-deriving instance (Lift b, Lift a) => Lift (Program b a)
-deriving instance (Lift b, Lift a) => Lift (Decl b a)
-deriving instance (Lift b) => Lift (Pat b)
-deriving instance (Lift b) => Lift (DataCon b)
-deriving instance (Lift b) => Lift (Type b)
-
-instance Lift b => Lift1 (Binding b) where
-    liftLift lf (VarB b a) = liftCon2 'VarB (lift b) (lf a)
-
-instance Lift b => Lift1 (Alter b) where
-    liftLift lf (Alter b a) = liftCon2 'Alter (lift b) (lf a)
-
-instance Lift b => Lift1 (ExprF b) where
-    liftLift lf (InfixEF o a b) =
-        liftCon3 'InfixEF (lift o) (lf a) (lf b)
-    liftLift lf (LetEF r bs e) =
-        liftCon3 'LetEF (lift r) bs' (lf e)
-      where bs' = liftLift (liftLift lf) bs
-    liftLift lf (CaseEF e as) =
-        liftCon2 'CaseEF (lf e) as'
-      where as' = liftLift (liftLift lf) as
-
-deriveEq1 ''Binding
-deriveEq1 ''Alter
-deriveEq1 ''ExprF
-
-instance (Hashable b) => Hashable (Pat b)
-instance (Hashable b, Hashable a) => Hashable (Binding b a)
-instance (Hashable b, Hashable a) => Hashable (Alter b a)
-instance (Hashable b, Hashable a) => Hashable (ExprF b a)
-instance (Hashable b) => Hashable1 (Alter b)
-instance (Hashable b) => Hashable1 (Binding b)
-instance (Hashable b) => Hashable1 (ExprF b)
-
-makeBaseFunctor ''Type
-

src/Rlp/HindleyMilner.hs

@@ -1,161 +0,0 @@
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE TemplateHaskell #-}
-module Rlp.HindleyMilner
-    ( typeCheckRlpProgR
-    , solve
-    , TypeError(..)
-    , runHM'
-    , HM
-    )
-    where
---------------------------------------------------------------------------------
-import Control.Lens             hiding (Context', Context, (:<), para)
-import Control.Monad.Errorful
-import Control.Monad.State
-import Control.Monad.Accum
-import Control.Monad
-import Control.Arrow            ((>>>))
-import Control.Monad.Writer.Strict
-import Data.Text                qualified as T
-import Data.Pretty
-import Data.Hashable
-import Data.HashMap.Strict      (HashMap)
-import Data.HashMap.Strict      qualified as H
-import Data.HashSet             (HashSet)
-import Data.HashSet             qualified as S
-import Data.Maybe               (fromMaybe)
-import Data.Traversable
-import GHC.Generics             (Generic(..), Generically(..))
-
-import Data.Functor
-import Data.Functor.Foldable
-import Data.Fix                 hiding (cata, para)
-import Control.Comonad.Cofree
-import Control.Comonad
-
-import Compiler.RLPC
-import Compiler.RlpcError
-import Rlp.AltSyntax            as Rlp
-import Core.Syntax              qualified as Core
-import Core.Syntax              (ExprF(..), Lit(..))
-import Rlp.HindleyMilner.Types
---------------------------------------------------------------------------------
-
-fixCofree :: (Functor f, Functor g)
-          => Iso (Fix f) (Fix g) (Cofree f ()) (Cofree g b)
-fixCofree = iso sa bt where
-    sa = foldFix (() :<)
-    bt (_ :< as) = Fix $ bt <$> as
-
-lookupVar :: PsName -> Context -> HM (Type PsName)
-lookupVar n g = case g ^. contextVars . at n of
-    Just t -> pure t
-    Nothing -> addFatal $ TyErrUntypedVariable n
-
-gather :: RlpExpr PsName -> HM (Type PsName, PartialJudgement)
-gather e = look >>= (H.lookup e >>> maybe memoise pure)
-    where
-        memoise = do
-            r <- gather' e
-            add (H.singleton e r)
-            pure r
-
-gather' :: RlpExpr PsName -> HM (Type PsName, PartialJudgement)
-gather' = \case
-    Finl (LitF (IntL _)) -> pure (IntT, mempty)
-
-    Finl (VarF n) -> do
-        t <- freshTv
-        let j = mempty & assumptions .~ H.singleton n [t]
-        pure (t,j)
-
-    Finl (AppF f x) -> do
-        tfx <- freshTv
-        (tf,jf) <- gather f
-        (tx,jx) <- gather x
-        let jtfx = mempty & constraints .~ [Equality tf (tx :-> tfx)]
-        pure (tfx, jf <> jx <> jtfx)
-
-    Finl (LamF [b] e) -> do
-        tb <- freshTv
-        (te,je) <- gather e
-        let cs = maybe [] (fmap $ Equality tb) (je ^. assumptions . at b)
-            as = je ^. assumptions & at b .~ Nothing
-            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
-
--- swap
-unify (Equality s (VarT t) : cs) = unify (Equality (VarT t) s : cs)
-
-unify (Equality s t : _) = addFatal $ TyErrCouldNotUnify s t
-
-annotate :: RlpExpr PsName
-         -> HM (Cofree (RlpExprF PsName) (Type PsName, PartialJudgement))
-annotate = sequenceA . fixtend (gather . wrapFix)
-
-solveTree :: Cofree (RlpExprF PsName) (Type PsName, PartialJudgement)
-          -> HM (Type PsName)
-solveTree e = undefined
-
-infer1 :: RlpExpr PsName -> HM (Type PsName)
-infer1 e = do
-    ((t,j) :< _) <- annotate e
-    g <- unify (j ^. constraints)
-    pure $ ifoldrOf (contextVars . itraversed) subst t g
-
-solve = undefined
--- solve g e = do
---     (t,j) <- gather e
---     g' <- unify cs
---     pure $ ifoldrOf (contextVars . itraversed) subst t g'
-
-occurs :: PsName -> Type PsName -> Bool
-occurs n = cata \case
-    VarTF m | n == m -> True
-    t                -> or t
-
-subst :: PsName -> Type PsName -> Type PsName -> Type PsName
-subst n t' = para \case
-    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)
-         => Either [TypeError] (a, [Constraint])
-         -> 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
-fixtend c (Fix f) = c f :< fmap (fixtend c) f
-
-infer :: RlpExpr PsName -> HM (Cofree (RlpExprF PsName) (Type PsName))
-infer = undefined
-
-typeCheckRlpProgR :: (Monad m)
-                  => Program PsName (RlpExpr PsName)
-                  -> RLPCT m (Program PsName
-                      (Cofree (RlpExprF PsName) (Type PsName)))
-typeCheckRlpProgR = undefined
-

src/Rlp/HindleyMilner/Types.hs

@@ -1,162 +0,0 @@
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE TemplateHaskell #-}
-module Rlp.HindleyMilner.Types
-    where
---------------------------------------------------------------------------------
-import Data.Hashable
-import Data.HashMap.Strict      (HashMap)
-import Data.HashMap.Strict      qualified as H
-import Data.HashSet             (HashSet)
-import Data.HashSet             qualified as S
-import GHC.Generics             (Generic(..), Generically(..))
-import Data.Kind                qualified
-import Data.Text                qualified as T
-import Control.Monad.Writer
-import Control.Monad.Accum
-import Control.Monad.Trans.Accum
-import Control.Monad.Errorful
-import Control.Monad.State
-import Text.Printf
-import Data.Pretty
-import Data.Function
-
-import Control.Lens             hiding (Context', Context)
-
-import Compiler.RlpcError
-import Rlp.AltSyntax
---------------------------------------------------------------------------------
-
-newtype Context = Context
-    { _contextVars      :: HashMap PsName (Type PsName)
-    }
-    deriving (Show, Generic)
-    deriving (Semigroup, Monoid)
-        via Generically Context
-
-data Constraint = Equality (Type PsName) (Type PsName)
-    deriving (Eq, Generic, Show)
-
-data PartialJudgement = PartialJudgement
-    { _constraints :: [Constraint]
-    , _assumptions :: HashMap PsName [Type PsName]
-    }
-    deriving (Generic, Show)
-    deriving (Monoid)
-        via Generically PartialJudgement
-
-instance Semigroup PartialJudgement where
-    a <> b = PartialJudgement
-        { _constraints = ((<>) `on` _constraints) a b
-        , _assumptions = (H.unionWith (<>) `on` _assumptions) a b
-        }
-
-instance Hashable Constraint
-
-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)
-    -- | @x@ could not be unified with @t@ because @x@ occurs in @t@
-    | TyErrRecursiveType Name (Type Name)
-    -- | Untyped, potentially undefined variable
-    | TyErrUntypedVariable Name
-    | TyErrMissingTypeSig Name
-    | TyErrNonHomogenousCaseAlternatives (RlpExpr PsName)
-    deriving (Show)
-
-instance IsRlpcError TypeError where
-    liftRlpcError = \case
-        -- todo: use anti-parser instead of show
-        TyErrCouldNotUnify t u -> Text
-            [ T.pack $ printf "Could not match type `%s` with `%s`."
-                              (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)
-            ]
-
--- type Memo t = HashMap t (Type PsName, PartialJudgement)
-
--- newtype HM t a = HM { unHM :: Int -> Memo t -> (a, Int, Memo t) }
-
--- runHM :: (Hashable t) => HM t a -> (a, Memo t)
--- runHM hm = let (a,_,m) = unHM hm 0 mempty in (a,m)
-
--- instance Functor (HM t) where
---     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
-    pure . VarT $ "$a" <> T.pack (show n)
-
-runHM' :: HM a -> Either [TypeError] a
-runHM' e = maybe (Left es) Right ma
-    where
-        ((ma,es),m) = (`runAccum` mempty) . (`evalStateT` 0) . runErrorfulT $ e
-
--- addConstraint :: Constraint -> HM ()
--- addConstraint = tell . pure
-
-makePrisms ''PartialJudgement
-makeLenses ''PartialJudgement
-makeLenses ''Context
-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/Lex.x

@@ -8,13 +8,11 @@ module Rlp.Lex
     , Located(..)
     , lexToken
     , lexStream
-    , lexStream'
     , lexDebug
     , lexCont
     , popLexState
     , programInitState
     , runP'
-    , popLayout
     )
     where
 import Codec.Binary.UTF8.String (encodeChar)
@@ -31,7 +29,6 @@ import Data.Word
 import Data.Default
 import Control.Lens
 
-import Compiler.Types
 import Debug.Trace
 import Rlp.Parse.Types
 }
@@ -62,7 +59,7 @@ $asciisym       = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
     |infixr|infixl|infix
 
 @reservedop =
-    "=" | \\ | "->" | "|" | ":"
+    "=" | \\ | "->" | "|" | "::"
 
 rlp :-
     
@@ -168,10 +165,9 @@ lexReservedName = \case
 lexReservedOp :: Text -> RlpToken
 lexReservedOp = \case
     "="     -> TokenEquals
-    ":"     -> TokenHasType
+    "::"    -> TokenHasType
     "|"     -> TokenPipe
     "->"    -> TokenArrow
-    "\\"    -> TokenLambda
     s       -> error (show s)
 
 -- | @andBegin@, with the subtle difference that the start code is set
@@ -278,12 +274,11 @@ lexCont :: (Located RlpToken -> P a) -> P a
 lexCont = (lexToken >>=)
 
 lexStream :: P [RlpToken]
-lexStream = fmap extract <$> lexStream'
+lexStream = do
-
+    t <- lexToken
-lexStream' :: P [Located RlpToken]
+    case t of
-lexStream' = lexToken >>= \case
+        Located _ TokenEOF -> pure [TokenEOF]
-    t@(Located _ TokenEOF) -> pure [t]
+        Located _ t        -> (t:) <$> lexStream
-    t        -> (t:) <$> lexStream'
 
 lexDebug :: (Located RlpToken -> P a) -> P a
 lexDebug k = do

src/Rlp/Parse.y

@@ -5,17 +5,15 @@ module Rlp.Parse
     , parseRlpProgR
     , parseRlpExpr
     , parseRlpExprR
-    , runP'
     )
     where
 import Compiler.RlpcError
 import Compiler.RLPC
-import Control.Comonad.Cofree
 import Rlp.Lex
 import Rlp.Syntax
 import Rlp.Parse.Types
 import Rlp.Parse.Associate
-import Control.Lens                 hiding (snoc, (.>), (<.), (<<~), (:<))
+import Control.Lens                 hiding (snoc, (.>), (<.), (<<~))
 import Data.List.Extra
 import Data.Fix
 import Data.Functor.Const
@@ -73,118 +71,139 @@ import Compiler.Types
 
 %%
 
-StandaloneProgram   :: { Program RlpcPs SrcSpan }
+StandaloneProgram   :: { RlpProgram RlpcPs }
-StandaloneProgram   : layout0(Decl)         {% mkProgram $1 }
+StandaloneProgram   : '{' Decls  '}'        {% mkProgram $2 }
+                    | VL  DeclsV VR         {% mkProgram $2 }
 
-StandaloneExpr      :: { Expr' RlpcPs SrcSpan }
+StandaloneExpr      :: { RlpExpr RlpcPs }
-                    : VL Expr VR            { $2 }
+                    : VL Expr VR            { extract $2 }
 
 VL  :: { () }
 VL  : vlbrace       { () }
 
 VR  :: { () }
 VR  : vrbrace       { () }
-    | error         {% void popLayout }
+    | error         { () }
 
-VS                  :: { () }
+Decls               :: { [Decl' RlpcPs] }
-VS                  : ';'                   { () }
+Decls               : Decl ';' Decls        { $1 : $3 }
-                    | vsemi                 { () }
+                    | Decl ';'              { [$1] }
+                    | Decl                  { [$1] }
 
-Decl        :: { Decl RlpcPs SrcSpan }
+DeclsV              :: { [Decl' RlpcPs] }
+DeclsV              : Decl VS DeclsV        { $1 : $3 }
+                    | Decl VS               { [$1] }
+                    | Decl                  { [$1] }
+
+VS                  :: { Located RlpToken }
+VS                  : ';'                   { $1 }
+                    | vsemi                 { $1 }
+
+Decl        :: { Decl' RlpcPs }
             : FunDecl                   { $1 }
             | TySigDecl                 { $1 }
             | DataDecl                  { $1 }
             | InfixDecl                 { $1 }
 
-TySigDecl   :: { Decl RlpcPs SrcSpan }
+TySigDecl   :: { Decl' RlpcPs }
-            : Var '::' Type             { TySigD [$1] $3 }
+            : Var '::' Type             { (\e -> TySigD [extract e]) <<~ $1 <~> $3 }
 
-InfixDecl   :: { Decl RlpcPs SrcSpan }
+InfixDecl   :: { Decl' RlpcPs }
-            : InfixWord litint InfixOp  {% mkInfixD $1 ($2 ^. _litint) $3 }
+            : InfixWord litint InfixOp  { $1 =>> \w ->
+                                          InfixD (extract $1) (extractInt $ extract $2)
+                                          (extract $3) }
 
-InfixWord   :: { Assoc }
+InfixWord   :: { Located Assoc }
-            : infixl                    { InfixL }
+            : infixl                    { $1 \$> InfixL }
-            | infixr                    { InfixR }
+            | infixr                    { $1 \$> InfixR }
-            | infix                     { Infix }
+            | infix                     { $1 \$> Infix  }
 
-DataDecl    :: { Decl RlpcPs SrcSpan }
+DataDecl    :: { Decl' RlpcPs }
-            : data Con TyParams '=' DataCons    { DataD $2 $3 $5 }
+            : data Con TyParams '=' DataCons    { $1 \$> DataD (extract $2) $3 $5 }
 
 TyParams    :: { [PsName] }
             : {- epsilon -}             { [] }
-            | TyParams varname          { $1 `snoc` extractName $2 }
+            | TyParams varname          { $1 `snoc` (extractName . extract $ $2) }
 
 DataCons    :: { [ConAlt RlpcPs] }
             : DataCons '|' DataCon      { $1 `snoc` $3 }
             | DataCon                   { [$1] }
 
 DataCon     :: { ConAlt RlpcPs }
-            : Con Type1s                { ConAlt $1 $2 }
+            : Con Type1s                { ConAlt (extract $1) $2 }
 
-Type1s      :: { [Ty RlpcPs] }
+Type1s      :: { [RlpType' RlpcPs] }
             : {- epsilon -}             { [] }
             | Type1s Type1              { $1 `snoc` $2 }
 
-Type1       :: { Ty RlpcPs }
+Type1       :: { RlpType' RlpcPs }
             : '(' Type ')'              { $2 }
-            | conname                   { ConT (extractName $1) }
+            | conname                   { fmap ConT (mkPsName $1) }
-            | varname                   { VarT (extractName $1) }
+            | varname                   { fmap VarT (mkPsName $1) }
 
-Type        :: { Ty RlpcPs }
+Type        :: { RlpType' RlpcPs }
-            : Type '->' Type            { FunT $1 $3 }
+            : Type '->' Type            { FunT <<~ $1 <~> $3 }
             | TypeApp                   { $1 }
 
-TypeApp     :: { Ty RlpcPs }
+TypeApp     :: { RlpType' RlpcPs }
             : Type1                     { $1 }
-            | TypeApp Type1             { AppT $1 $2 }
+            | TypeApp Type1             { AppT <<~ $1 <~> $2 }
 
-FunDecl     :: { Decl RlpcPs SrcSpan }
+FunDecl     :: { Decl' RlpcPs }
-FunDecl     : Var Params '=' Expr       { FunD $1 $2 $4 Nothing }
+FunDecl     : Var Params '=' Expr       { $4 =>> \e ->
+                                          FunD (extract $1) $2 e Nothing }
 
-Params      :: { [Pat RlpcPs] }
+Params      :: { [Pat' RlpcPs] }
 Params      : {- epsilon -}             { [] }
             | Params Pat1               { $1 `snoc` $2 }
 
-Pat         :: { Pat RlpcPs }
+Pat         :: { Pat' RlpcPs }
-            : Con Pat1s                 { ConP $1 $2 }
+            : Con Pat1s                 { $1 =>> \cn ->
+                                          ConP (extract $1) $2 }
             | Pat1                      { $1 }
 
-Pat1s       :: { [Pat RlpcPs] }
+Pat1s       :: { [Pat' RlpcPs] }
             : Pat1s Pat1                { $1 `snoc` $2 }
             | Pat1                      { [$1] }
 
-Pat1        :: { Pat RlpcPs }
+Pat1        :: { Pat' RlpcPs }
-            : Con                       { ConP $1 [] }
+            : Con                       { fmap (`ConP` []) $1 }
-            | Var                       { VarP $1 }
+            | Var                       { fmap VarP $1 }
-            | Lit                       { LitP $1 }
+            | Lit                       { LitP <<= $1 }
-            | '(' Pat ')'               { $2 }
+            | '(' Pat ')'               { $1 .> $2 <. $3 }
 
-Expr        :: { Expr' RlpcPs SrcSpan }
+Expr        :: { RlpExpr' RlpcPs }
             -- infixities delayed till next release :(
-            -- : Expr1 InfixOp Expr        { undefined }
+            -- : Expr1 InfixOp Expr        { $2 =>> \o ->
-            : AppExpr                   { $1 }
+            --                              OAppE (extract o) $1 $3 }
-            | TempInfixExpr             { $1 }
+            : TempInfixExpr             { $1 }
             | LetExpr                   { $1 }
             | CaseExpr                  { $1 }
+            | AppExpr                   { $1 }
 
-TempInfixExpr :: { Expr' RlpcPs SrcSpan }
+TempInfixExpr :: { RlpExpr' RlpcPs }
 TempInfixExpr : Expr1 InfixOp TempInfixExpr {% tempInfixExprErr $1 $3 }
-              | Expr1 InfixOp Expr1         { nolo' $ InfixEF $2 $1 $3 }
+              | Expr1 InfixOp Expr1 { $2 =>> \o ->
+                                      OAppE (extract o) $1 $3 }
 
-AppExpr     :: { Expr' RlpcPs SrcSpan }
+AppExpr     :: { RlpExpr' RlpcPs }
             : Expr1                     { $1 }
-            | AppExpr Expr1             { comb2 AppEF $1 $2 }
+            | AppExpr Expr1             { AppE <<~ $1 <~> $2 }
 
-LetExpr     :: { Expr' RlpcPs SrcSpan }
+LetExpr     :: { RlpExpr' RlpcPs }
-            : let layout1(Binding) in Expr      { nolo' $ LetEF NonRec $2 $4 }
+            : let layout1(Binding) in Expr      { $1 \$> LetE $2 $4 }
-            | letrec layout1(Binding) in Expr   { nolo' $ LetEF Rec $2 $4 }
+            | letrec layout1(Binding) in Expr   { $1 \$> LetrecE $2 $4 }
 
-CaseExpr    :: { Expr' RlpcPs SrcSpan }
+CaseExpr    :: { RlpExpr' RlpcPs }
-            : case Expr of layout0(Alt)     { nolo' $ CaseEF $2 $4 }
+            : case Expr of layout0(CaseAlt)
+                { CaseE <<~ $2 <#> $4 }
 
 -- TODO: where-binds
-Alt         :: { Alt' RlpcPs SrcSpan }
+CaseAlt     :: { (Alt RlpcPs, Where RlpcPs) }
-            : Pat '->' Expr                 { AltA $1 (view _unwrap $3) Nothing }
+            : Alt                           { ($1, []) }
+
+Alt         :: { Alt RlpcPs }
+            : Pat '->' Expr                 { AltA $1 $3 }
 
 -- layout0(p : β) :: [β]
 layout0(p)  : '{' layout_list0(';',p) '}'   { $2 }
@@ -203,68 +222,38 @@ layout1(p)  : '{' layout_list1(';',p) '}'   { $2 }
 layout_list1(sep,p) : p                          { [$1] }
                     | layout_list1(sep,p) sep p  { $1 `snoc` $3 }
 
-Binding     :: { Binding' RlpcPs SrcSpan }
+Binding     :: { Binding' RlpcPs }
-            : Pat '=' Expr              { PatB $1 (view _unwrap $3) }
+            : Pat '=' Expr              { PatB <<~ $1 <~> $3 }
 
-Expr1       :: { Expr' RlpcPs SrcSpan }
+Expr1       :: { RlpExpr' RlpcPs }
-            : '(' Expr ')'              { $2 }
+            : '(' Expr ')'              { $1 .> $2 <. $3 }
-            | Lit                       { nolo' $ LitEF $1 }
+            | Lit                       { fmap LitE $1 }
-            | Var                       { case $1 of Located ss _ -> ss :< VarEF $1 }
+            | Var                       { fmap VarE $1 }
-            | Con                       { case $1 of Located ss _ -> ss :< VarEF $1 }
+            | Con                       { fmap VarE $1 }
 
-InfixOp     :: { PsName }
+InfixOp     :: { Located PsName }
-            : consym                    { extractName $1 }
+            : consym                    { mkPsName $1 }
-            | varsym                    { extractName $1 }
+            | varsym                    { mkPsName $1 }
 
 -- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
-Lit         :: { Lit RlpcPs }
+Lit         :: { Lit' RlpcPs }
-            : litint                    { $1 ^. to extract
+            : litint                    { $1 <&> (IntL . (\ (TokenLitInt n) -> n)) }
-                                              . singular _TokenLitInt
-                                              . to IntL }
 
-Var         :: { PsName }
+Var         :: { Located PsName }
-Var         : varname                   { $1 <&> view (singular _TokenVarName) }
+Var         : varname                   { mkPsName $1 }
-            | varsym                    { $1 <&> view (singular _TokenVarSym) }
+            | varsym                    { mkPsName $1 }
 
-Con         :: { PsName }
+Con         :: { Located PsName }
-            : conname                   { $1 <&> view (singular _TokenConName) }
+            : conname                   { mkPsName $1 }
 
 {
 
-parseRlpProgR :: (Monad m) => Text -> RLPCT m (Program RlpcPs SrcSpan)
+parseRlpExprR :: (Monad m) => Text -> RLPCT m (RlpExpr RlpcPs)
-parseRlpProgR s = do
-    a <- liftErrorful $ pToErrorful parseRlpProg st
-    addDebugMsg @_ @String "dump-parsed" $ show a
-    pure a
-  where
-    st = programInitState s
-
-parseRlpExprR :: (Monad m) => Text -> RLPCT m (Expr' RlpcPs SrcSpan)
 parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st
     where
         st = programInitState s
 
-mkInfixD :: Assoc -> Int -> PsName -> P (Decl RlpcPs SrcSpan)
+parseRlpProgR :: (Monad m) => Text -> RLPCT m (RlpProgram RlpcPs)
-mkInfixD a p ln@(Located ss n) = do
-    let opl :: Lens' ParseState (Maybe OpInfo)
-        opl = psOpTable . at n
-    opl <~ (use opl >>= \case
-        Just o  -> addWoundHere l e >> pure (Just o) where
-            e = RlpParErrDuplicateInfixD n
-            l = T.length n
-        Nothing -> pure (Just (a,p))
-        )
-    pos <- use (psInput . aiPos)
-    pure $ InfixD a p ln
-
-{--
-
-parseRlpExprR :: (Monad m) => Text -> RLPCT m (Expr RlpcPs)
-parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st
-    where
-        st = programInitState s
-
-parseRlpProgR :: (Monad m) => Text -> RLPCT m (Program RlpcPs)
 parseRlpProgR s = do
     a <- liftErrorful $ pToErrorful parseRlpProg st
     addDebugMsg @_ @String "dump-parsed" $ show a
@@ -287,48 +276,37 @@ extractInt :: RlpToken -> Int
 extractInt (TokenLitInt n) = n
 extractInt _ = error "extractInt: ugh"
 
-mkProgram :: [Decl RlpcPs SrcSpan] -> P (Program RlpcPs SrcSpan)
+mkProgram :: [Decl' RlpcPs] -> P (RlpProgram RlpcPs)
 mkProgram ds = do
     pt <- use psOpTable
-    pure $ Program (associate pt <$> ds)
+    pure $ RlpProgram (associate pt <$> ds)
+
+parseError :: (Located RlpToken, [String]) -> P a
+parseError ((Located ss t), exp) = addFatal $
+    errorMsg ss (RlpParErrUnexpectedToken t exp)
+
+mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs)
+mkInfixD a p n = do
+    let opl :: Lens' ParseState (Maybe OpInfo)
+        opl = psOpTable . at n
+    opl <~ (use opl >>= \case
+        Just o  -> addWoundHere l e >> pure (Just o) where
+            e = RlpParErrDuplicateInfixD n
+            l = T.length n
+        Nothing -> pure (Just (a,p))
+        )
+    pos <- use (psInput . aiPos)
+    pure $ Located (spanFromPos pos 0) (InfixD a p n)
 
 intOfToken :: Located RlpToken -> Int
 intOfToken (Located _ (TokenLitInt n)) = n
 
-tempInfixExprErr :: Expr RlpcPs -> Expr RlpcPs -> P a
+tempInfixExprErr :: RlpExpr' RlpcPs -> RlpExpr' RlpcPs -> P a
 tempInfixExprErr (Located a _) (Located b _) =
     addFatal $ errorMsg (a <> b) $ RlpParErrOther
         [ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :("
         , "In the mean time, don't mix any infix operators."
         ]
 
---}
-
-_litint :: Getter (Located RlpToken) Int
-_litint = to extract
-        . singular _TokenLitInt
-
-tempInfixExprErr :: Expr' RlpcPs SrcSpan -> Expr' RlpcPs SrcSpan -> P a
-tempInfixExprErr (a :< _) (b :< _) =
-    addFatal $ errorMsg (a <> b) $ RlpParErrOther
-        [ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :("
-        , "In the mean time, don't mix any infix operators."
-        ]
-
-mkProgram :: [Decl RlpcPs SrcSpan] -> P (Program RlpcPs SrcSpan)
-mkProgram ds = do
-    pt <- use psOpTable
-    pure $ Program (associate pt <$> ds)
-
-extractName :: Located RlpToken -> PsName
-extractName (Located ss (TokenVarSym n)) = Located ss n
-extractName (Located ss (TokenVarName n)) = Located ss n
-extractName (Located ss (TokenConName n)) = Located ss n
-extractName (Located ss (TokenConSym n)) = Located ss n
-
-parseError :: (Located RlpToken, [String]) -> P a
-parseError ((Located ss t), exp) = addFatal $
-    errorMsg ss (RlpParErrUnexpectedToken t exp)
-
 }
 

src/Rlp/Parse/Associate.hs

@@ -16,7 +16,7 @@ import Rlp.Parse.Types
 import Rlp.Syntax
 --------------------------------------------------------------------------------
 
-associate :: OpTable -> Decl RlpcPs a -> Decl RlpcPs a
+associate :: OpTable -> Decl' RlpcPs -> Decl' RlpcPs
 associate _ p = p
 
 {-# WARNING associate "unimplemented" #-}

src/Rlp/Parse/Types.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE UndecidableInstances #-}
 module Rlp.Parse.Types
     (
     -- * Trees That Grow
@@ -18,9 +17,10 @@ module Rlp.Parse.Types
     , RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
     , Located(..), PsName
     -- ** Lenses
-    , _TokenLitInt, _TokenVarName, _TokenConName, _TokenVarSym, _TokenConSym
     , aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
 
+    , (<<~), (<~>)
+
     -- * Error handling
     , MsgEnvelope(..), RlpcError(..), RlpParseError(..)
     , addFatal, addWound, addFatalHere, addWoundHere
@@ -28,7 +28,6 @@ module Rlp.Parse.Types
     where
 --------------------------------------------------------------------------------
 import Core.Syntax                  (Name)
-import Text.Show.Deriving
 import Control.Monad
 import Control.Monad.State.Strict
 import Control.Monad.Errorful
@@ -54,9 +53,34 @@ import Compiler.Types
 
 data RlpcPs
 
-type instance NameP RlpcPs = PsName
+type instance XRec RlpcPs a = Located a
+type instance IdP RlpcPs = PsName
 
-type PsName = Located Text
+type instance XFunD RlpcPs = ()
+type instance XDataD RlpcPs = ()
+type instance XInfixD RlpcPs = ()
+type instance XTySigD RlpcPs = ()
+type instance XXDeclD RlpcPs = ()
+
+type instance XLetE RlpcPs = ()
+type instance XLetrecE RlpcPs = ()
+type instance XVarE RlpcPs = ()
+type instance XLamE RlpcPs = ()
+type instance XCaseE RlpcPs = ()
+type instance XIfE RlpcPs = ()
+type instance XAppE RlpcPs = ()
+type instance XLitE RlpcPs = ()
+type instance XParE RlpcPs = ()
+type instance XOAppE RlpcPs = ()
+type instance XXRlpExprE RlpcPs = ()
+
+type PsName = Text
+
+instance MapXRec RlpcPs where
+    mapXRec = fmap
+
+instance UnXRec RlpcPs where
+    unXRec = extract
 
 --------------------------------------------------------------------------------
 
@@ -94,10 +118,10 @@ data RlpToken
     -- literals
     = TokenLitInt Int
     -- identifiers
-    | TokenVarName Text
+    | TokenVarName Name
-    | TokenConName Text
+    | TokenConName Name
-    | TokenVarSym Text
+    | TokenVarSym Name
-    | TokenConSym Text
+    | TokenConSym Name
     -- reserved words
     | TokenData
     | TokenCase
@@ -128,31 +152,6 @@ data RlpToken
     | TokenEOF
     deriving (Show)
 
-_TokenLitInt :: Prism' RlpToken Int
-_TokenLitInt = prism TokenLitInt $ \case
-    TokenLitInt n -> Right n
-    x             -> Left x
-
-_TokenVarName :: Prism' RlpToken Text
-_TokenVarName = prism TokenVarName $ \case
-    TokenVarName n -> Right n
-    x              -> Left x
-
-_TokenVarSym :: Prism' RlpToken Text
-_TokenVarSym = prism TokenVarSym $ \case
-    TokenVarSym n -> Right n
-    x              -> Left x
-
-_TokenConName :: Prism' RlpToken Text
-_TokenConName = prism TokenConName $ \case
-    TokenConName n -> Right n
-    x              -> Left x
-
-_TokenConSym :: Prism' RlpToken Text
-_TokenConSym = prism TokenConSym $ \case
-    TokenConSym n -> Right n
-    x              -> Left x
-
 newtype P a = P {
         runP :: ParseState
              -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
@@ -277,19 +276,18 @@ initAlexInput s = AlexInput
     { _aiPrevChar   = '\0'
     , _aiSource     = s
     , _aiBytes      = []
-    , _aiPos        = (1,0,0)
+    , _aiPos        = (1,1,0)
     }
 
 --------------------------------------------------------------------------------
 
-
+deriving instance Lift (RlpProgram RlpcPs)
--- deriving instance Lift (Program RlpcPs)
+deriving instance Lift (Decl RlpcPs)
--- deriving instance Lift (Decl RlpcPs)
+deriving instance Lift (Pat RlpcPs)
--- deriving instance Lift (Pat RlpcPs)
+deriving instance Lift (Lit RlpcPs)
--- deriving instance Lift (Lit RlpcPs)
+deriving instance Lift (RlpExpr RlpcPs)
--- deriving instance Lift (Expr RlpcPs)
+deriving instance Lift (Binding RlpcPs)
--- deriving instance Lift (Binding RlpcPs)
+deriving instance Lift (RlpType RlpcPs)
--- deriving instance Lift (Ty RlpcPs)
+deriving instance Lift (Alt RlpcPs)
--- deriving instance Lift (Alt RlpcPs)
+deriving instance Lift (ConAlt RlpcPs)
--- deriving instance Lift (ConAlt RlpcPs)
 

src/Rlp/Syntax.hs

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

src/Rlp/Syntax/Backstage.hs

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

src/Rlp/Syntax/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/Rlp/Syntax/Types.hs

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

src/Rlp/TH.hs

@@ -13,7 +13,7 @@ import Control.Monad.IO.Class
 import Control.Monad
 
 import Compiler.RLPC
-import Rlp.AltParse
+import Rlp.Parse
 --------------------------------------------------------------------------------
 
 rlpProg :: QuasiQuoter

src/Rlp2Core.hs

@@ -28,7 +28,6 @@ import Data.Functor.Bind
 import Data.Function                    (on)
 import GHC.Stack
 import Debug.Trace
-import Numeric
 
 import Effectful.State.Static.Local
 import Effectful.Labeled
@@ -36,9 +35,10 @@ import Effectful
 import Text.Show.Deriving
 
 import Core.Syntax                      as Core
-import Rlp.AltSyntax                    as Rlp
 import Compiler.Types
 import Data.Pretty                      (render, pretty)
+import Rlp.Syntax                       as Rlp
+import Rlp.Parse.Types                  (RlpcPs, PsName)
 --------------------------------------------------------------------------------
 
 type Tree a = Either Name (Name, Branch a)
@@ -59,49 +59,178 @@ deriveShow1 ''Branch
 
 --------------------------------------------------------------------------------
 
-desugarRlpProgR :: forall m a. (Monad m)
+desugarRlpProgR :: forall m. (Monad m) => RlpProgram RlpcPs -> RLPCT m Program'
-                => Rlp.Program PsName a
-                -> RLPCT m Core.Program'
 desugarRlpProgR p = do
     let p' = desugarRlpProg p
     addDebugMsg "dump-desugared" $ render (pretty p')
     pure p'
 
-desugarRlpProg = undefined
+desugarRlpProg :: RlpProgram RlpcPs -> Program'
+desugarRlpProg = rlpProgToCore
 
-desugarRlpExpr = undefined
+desugarRlpExpr :: RlpExpr RlpcPs -> Expr'
-
+desugarRlpExpr = runPureEff . runNameSupply "anon" . exprToCore
-runNameSupply :: Text -> Eff (NameSupply ': es) a -> Eff es a
-runNameSupply pre = undefined -- evalState [ pre <> "_" <> tshow name | name <- [0..] ]
 
 -- 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 :: RlpProgram RlpcPs -> Program'
-rlpProgToCore = foldMapOf (programDecls . each) declToCore
+rlpProgToCore = foldMapOf (progDecls . each) declToCore
 
-declToCore :: Rlp.Decl PsName (RlpExpr PsName) -> Program'
+declToCore :: Decl' RlpcPs -> Program'
 
--- assume all arguments are VarP's for now
+declToCore (TySigD'' ns t) = mempty &
-declToCore (FunD b as e) = mempty & programScDefs .~ [ScDef b as' e']
+    programTypeSigs .~ H.fromList [ (n, typeToCore t) | n <- ns ]
+
+declToCore (DataD'' n as ds) = fold . getZipList $
+    constructorToCore t' <$> ZipList [0..] <*> ZipList ds
     where
-        as' = as ^.. each . singular _VarP
+        -- create the appropriate type from the declared constructor and its
-        e' = runPureEff . runNameSupply b . exprToCore $ e
+        -- arguments
+        t' = foldl TyApp (TyCon n) (TyVar . dsNameToName <$> as)
 
-type NameSupply = State [Name]
+-- TODO: where-binds
+declToCore fd@(FunD'' n as e _) = mempty & programScDefs .~ [ScDef n' as' e']
+    where
+        n' = dsNameToName n
+        e' = runPureEff . runNameSupply n . exprToCore . unXRec $ e
+        as' = as <&> \case
+            (unXRec -> VarP k) -> dsNameToName k
+            _                  -> error "no patargs yet"
 
-exprToCore :: (NameSupply :> es)
+type NameSupply = Labeled NameSupplyLabel (State [IdP RlpcPs])
-           => RlpExpr PsName -> Eff es Core.Expr'
+type NameSupplyLabel = "expr-name-supply"
-exprToCore = foldFixM \case
-    InL e -> pure $ Fix e
-    InR e -> rlpExprToCore e
 
-rlpExprToCore :: (NameSupply :> es)
+exprToCore :: forall es. (NameSupply :> es) => RlpExpr RlpcPs -> Eff es Expr'
-           => Rlp.ExprF PsName Core.Expr' -> Eff es Core.Expr'
 
--- assume all binders are simple variable patterns for now
+exprToCore (VarE n) = pure $ Var (dsNameToName n)
-rlpExprToCore (LetEF r bs e) = pure $ Let r bs' e
+
+exprToCore (AppE a b) = (liftA2 App `on` exprToCore . unXRec) a b
+
+exprToCore (OAppE f a b) = (liftA2 mkApp `on` exprToCore . unXRec) a b
+    where
+        mkApp s t = (Var f `App` s) `App` t
+
+exprToCore (CaseE (unXRec -> e) as) = do
+    e' <- exprToCore e
+    Case e' <$> caseAltToCore `traverse` as
+
+exprToCore (LetE bs e) = letToCore NonRec bs e
+exprToCore (LetrecE bs e) = letToCore Rec bs e
+
+exprToCore (LitE l) = litToCore l
+
+letToCore :: forall es. (NameSupply :> es)
+          => Rec -> [Rlp.Binding' RlpcPs] -> RlpExpr' RlpcPs -> Eff es Expr'
+letToCore r bs e = do
+    -- TODO: preserve binder order.
+    (bs',as) <- getParts
+    let insbs | null bs'  = pure
+              | otherwise = pure . Let r bs'
+    appKendo (foldMap Kendo (as `snoc` insbs)) <=< exprToCore $ unXRec e
   where
-    bs' = b2b <$> bs
+    -- partition & map the list of binders into:
-    b2b (VarB (VarP k) v) = Binding k v
+    --  bs'   : the let-binds that may be directly translated to Core
+    --          let-binds (we do exactly that). this is all the binders that
+    --          are a simple variable rather than a pattern match.
+    -- and as : the let-binds that may **not** be directly translated to
+    --          Core let-exprs. they get turned into case alternates.
+    getParts = traverse f bs <&> partitionEithers
+
+    f :: Rlp.Binding' RlpcPs
+      -> Eff es (Either Core.Binding' (Expr' -> Eff es Expr'))
+    f (PatB'' (VarP'' n) e) = Left . (n :=) <$> exprToCore (unXRec e)
+    f (PatB'' p          e) = pure $ Right (caseify p e)
+
+litToCore :: (NameSupply :> es) => Rlp.Lit RlpcPs -> Eff es Expr'
+litToCore (Rlp.IntL n) = pure . Lit $ Core.IntL n
+
+{-
+let C x = y
+in e
+
+case y of
+    C x -> e
+ -}
+
+caseify :: (NameSupply :> es)
+        => Pat' RlpcPs -> RlpExpr' RlpcPs -> Expr' -> Eff es Expr'
+caseify p (unXRec -> e) i =
+    Case <$> exprToCore e <*> ((:[]) <$> alt)
+  where
+    alt = conToRose (unXRec p) <&> foldFix (branchToCore i)
+
+-- TODO: where-binds
+caseAltToCore :: (HasCallStack, NameSupply :> es)
+              => (Alt RlpcPs, Where RlpcPs) -> Eff es Alter'
+caseAltToCore (AltA (unXRec -> p) e, wh) = do
+    e' <- exprToCore . unXRec $ e
+    conToRose p <&> foldFix (branchToCore e')
+
+altToCore :: (NameSupply :> es)
+          => Alt RlpcPs -> Eff es Alter'
+altToCore (AltA p e) = altToCore' p e
+
+altToCore' :: (NameSupply :> es)
+           => Pat' RlpcPs -> RlpExpr' RlpcPs -> Eff es Alter'
+altToCore' (unXRec -> p) (unXRec -> e) = do
+    e' <- exprToCore e
+    conToRose p <&> foldFix (branchToCore e')
+
+conToRose :: forall es. (HasCallStack, NameSupply :> es) => Pat RlpcPs -> Eff es Rose
+conToRose (ConP cn as) = Fix . Branch cn <$> patToForrest `traverse` as
+    where
+        patToForrest :: Pat' RlpcPs -> Eff es (Tree Rose)
+        patToForrest (VarP'' x) = pure $ Left (dsNameToName x)
+        patToForrest p@(ConP'' _ _) =
+            Right <$> liftA2 (,) uniqueName br
+          where
+            br = unwrapFix <$> conToRose (unXRec p)
+conToRose s = error $ "conToRose: not a ConP!: " <> show s
+
+branchToCore :: Expr' -> Branch Alter' -> Alter'
+branchToCore e (Branch cn as) = Alter (AltData cn) myBinds e'
+    where
+        -- gather binders for the /current/ pattern, and build an expression
+        -- matching subpatterns
+        (e', myBinds) = mapAccumL f e as
+
+        f :: Expr' -> Tree Alter' -> (Expr', Name)
+        f e (Left n)       = (e, dsNameToName n)
+        f e (Right (n,cs)) = (e', dsNameToName n) where
+            e' = Case (Var $ dsNameToName n) [branchToCore e cs]
+
+runNameSupply :: IdP RlpcPs -> Eff (NameSupply ': es) a -> Eff es a
+runNameSupply n = runLabeled @NameSupplyLabel (evalState ns) where
+    ns = [ "$" <> n <> "_" <> T.pack (show k) | k <- [0..] ]
+
+-- | debug helper
+
+nameSupply :: [IdP RlpcPs]
+nameSupply = [ T.pack $ "$x_" <> show n | n <- [0..] ]
+
+uniqueName :: (NameSupply :> es) => Eff es (IdP RlpcPs)
+uniqueName = labeled @NameSupplyLabel @(State [IdP RlpcPs]) $
+    state @[IdP RlpcPs] (fromMaybe err . uncons)
+  where
+    err = error "NameSupply ran out of names! This shound never happen.\
+                \ The caller of runNameSupply is responsible."
+
+constructorToCore :: Type -> Tag -> ConAlt RlpcPs -> Program'
+constructorToCore t tag (ConAlt cn as) =
+    mempty & programTypeSigs . at cn ?~ foldr (:->) t as'
+           & programDataTags . at cn ?~ (tag, length as)
+    where
+        as' = typeToCore <$> as
+
+typeToCore :: RlpType' RlpcPs -> Type
+typeToCore FunConT''    = TyFun
+typeToCore (FunT'' s t) = typeToCore s :-> typeToCore t
+typeToCore (AppT'' s t) = TyApp (typeToCore s) (typeToCore t)
+typeToCore (ConT'' n)   = TyCon (dsNameToName n)
+typeToCore (VarT'' x)   = TyVar (dsNameToName x)
+
+-- | Forwards-compatiblity if IdP RlpDs is changed
+dsNameToName :: IdP RlpcPs -> Name
+dsNameToName = id
 

tst/Compiler/TypesSpec.hs

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

tst/Rlp/HindleyMilnerSpec.hs

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