pretty

Makefile_happysrcs

@@ -9,12 +9,16 @@ CABAL_BUILD = $(shell ./find-build.cl)
 
 all: parsers lexers
 
-parsers: $(CABAL_BUILD)/Rlp/Parse.hs $(CABAL_BUILD)/Core/Parse.hs
+parsers: $(CABAL_BUILD)/Rlp/Parse.hs $(CABAL_BUILD)/Core/Parse.hs \
+		$(CABAL_BUILD)/Rlp/AltParse.hs
 lexers: $(CABAL_BUILD)/Rlp/Lex.hs $(CABAL_BUILD)/Core/Lex.hs
 
 $(CABAL_BUILD)/Rlp/Parse.hs: $(SRC)/Rlp/Parse.y
 	$(HAPPY) $(HAPPY_OPTS) $< -o $@
 
+$(CABAL_BUILD)/Rlp/AltParse.hs: $(SRC)/Rlp/AltParse.y
+	$(HAPPY) $(HAPPY_OPTS) $< -o $@
+
 $(CABAL_BUILD)/Rlp/Lex.hs: $(SRC)/Rlp/Lex.x
 	$(ALEX) $(ALEX_OPTS) $< -o $@
 

rlp.cabal

@@ -32,6 +32,8 @@ library
                     , Core.HindleyMilner
                     , Control.Monad.Errorful
                     , Rlp.Syntax
+                    , Rlp.AltSyntax
+                    , Rlp.AltParse
                     , Rlp.Syntax.Backstage
                     , Rlp.Syntax.Types
                     -- , Rlp.Parse.Decls

src/Compiler/JustRun.hs

@@ -10,6 +10,7 @@ types such as @RLPC@ or @Text@.
 module Compiler.JustRun
     ( justLexCore
     , justParseCore
+    , justParseRlp
     , justTypeCheckCore
     , justHdbg
     , makeItPretty, makeItPretty'
@@ -29,15 +30,18 @@ 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 s = do
+justHdbg = undefined
-    p <- evalRLPCIO def (parseRlpProgR >=> desugarRlpProgR $ T.pack s)
+-- justHdbg s = do
-    withFile "/tmp/t.log" WriteMode $ hdbgProg p
+--     p <- evalRLPCIO def (parseRlpProgR >=> desugarRlpProgR $ T.pack s)
+--     withFile "/tmp/t.log" WriteMode $ hdbgProg p
 
 justLexCore :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
 justLexCore s = lexCoreR (T.pack s)
@@ -49,6 +53,13 @@ justParseCore s = parse (T.pack s)
                 & rlpcToEither
     where parse = lexCoreR @Identity >=> parseCoreProgR
 
+justParseRlp :: String
+             -> Either [MsgEnvelope RlpcError]
+                       (Rlp.Program Name (Rlp.RlpExpr Name))
+justParseRlp s = parse (T.pack s)
+               & rlpcToEither
+    where parse = parseRlpProgR @Identity
+
 justTypeCheckCore :: String -> Either [MsgEnvelope RlpcError] Program'
 justTypeCheckCore s = typechk (T.pack s)
                     & rlpcToEither

src/Compiler/Types.hs

@@ -46,8 +46,6 @@ import Data.Function                (on)
 data Located a = Located SrcSpan a
     deriving (Show, Lift, Functor)
 
-data Floc f = Floc SrcSpan (f (Floc f))
-
 pattern (:<$) :: a -> f b -> Trans.Cofree.CofreeF f a b
 pattern a :<$ b = a Trans.Cofree.:< b
 
@@ -56,10 +54,10 @@ pattern a :<$ b = a Trans.Cofree.:< b
 
 infixl 5 <~>
 
--- (~>) :: (CanGet k, CanSet k', HasLocation k a, HasLocation k' b)
+(~>) :: (CanGet k, CanSet k', HasLocation k a, HasLocation k' b)
---      => a -> b -> b
+     => a -> b -> b
--- a ~> b = 
+a ~> b = b & fromSet getSetLocation .~ (a ^. fromGet getSetLocation)
-(~>) = undefined
+-- (~>) = undefined
 
 infixl 4 ~>
 
@@ -97,15 +95,15 @@ data SrcSpan = SrcSpan
     !Int -- ^ Length
     deriving (Show, Eq, Lift)
 
-tupling :: Iso' SrcSpan (Int, Int, Int, Int)
+_SrcSpan :: Iso' SrcSpan (Int, Int, Int, Int)
-tupling = iso (\ (SrcSpan a b c d) -> (a,b,c,d))
+_SrcSpan = iso (\ (SrcSpan a b c d) -> (a,b,c,d))
               (\ (a,b,c,d) -> SrcSpan a b c d)
 
 srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen :: Lens' SrcSpan Int
-srcSpanLine = tupling . _1
+srcSpanLine = _SrcSpan . _1
-srcSpanColumn = tupling . _2
+srcSpanColumn = _SrcSpan . _2
-srcSpanAbs = tupling . _3
+srcSpanAbs = _SrcSpan . _3
-srcSpanLen = tupling . _4
+srcSpanLen = _SrcSpan . _4
 
 -- | debug tool
 nolo :: a -> Located a
@@ -228,3 +226,4 @@ lochead afs (Located ss fss) = ss :< unwrap (lochead afs $ Located ss fss)
 --------------------------------------------------------------------------------
 
 makePrisms ''Located
+

src/Core/Syntax.hs

@@ -420,36 +420,56 @@ instance (Pretty b) => Pretty (ScDef b) where
             as = sc & hsepOf (_lhs . _2 . each . to ttext)
             e = pretty $ sc ^. _rhs
 
-instance (Pretty (f (Fix f))) => Pretty (Fix f) where
-    prettyPrec d (Fix f) = prettyPrec d f
-
 -- Pretty Expr
 -- LamF | appPrec1 | right
 -- AppF | appPrec  | left
 
 instance (Pretty b, Pretty a) => Pretty (ExprF b a) where
-    prettyPrec _ (VarF n) = ttext n
+    prettyPrec = prettyPrec1
-    prettyPrec _ (ConF t a) = "Pack{" <> (ttext t <+> ttext a) <> "}"
+
-    prettyPrec p (LamF bs e) = maybeParens (p>0) $
+    -- prettyPrec _ (VarF n) = ttext n
-        hsep ["λ", hsep (prettyPrec appPrec1 <$> bs), "->", pretty e]
+    -- prettyPrec _ (ConF t a) = "Pack{" <> (ttext t <+> ttext a) <> "}"
-    prettyPrec p (LetF r bs e) = maybeParens (p>0)
+    -- prettyPrec p (LamF bs e) = maybeParens (p>0) $
-                               $ hsep [pretty r, explicitLayout bs]
+    --     hsep ["λ", hsep (prettyPrec appPrec1 <$> bs), "->", pretty e]
-                             $+$ hsep ["in", pretty e]
+    -- prettyPrec p (LetF r bs e) = maybeParens (p>0)
-    prettyPrec p (AppF f x) = maybeParens (p>appPrec) $
+    --                            $ hsep [pretty r, explicitLayout bs]
-        prettyPrec appPrec f <+> prettyPrec appPrec1 x
+    --                          $+$ hsep ["in", pretty e]
-    prettyPrec p (LitF l) = prettyPrec p l
+    -- prettyPrec p (AppF f x) = maybeParens (p>appPrec) $
-    prettyPrec p (CaseF e as) = maybeParens (p>0) $
+    --     prettyPrec appPrec f <+> prettyPrec appPrec1 x
-        "case" <+> pretty e <+> "of"
+    -- prettyPrec p (LitF l) = prettyPrec p l
-        $+$ nest 2 (explicitLayout as)
+    -- prettyPrec p (CaseF e as) = maybeParens (p>0) $
-    prettyPrec p (TypeF t) = "@" <> prettyPrec appPrec1 t
+    --     "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
-    pretty (AlterF c as e) =
+    prettyPrec = prettyPrec1
-        hsep [pretty c, hsep (pretty <$> as), "->", pretty e]
+
+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
@@ -461,7 +481,15 @@ instance Pretty Lit where
     pretty (IntL n) = ttext n
 
 instance (Pretty b, Pretty a) => Pretty (BindingF b a) where
-    pretty (BindingF k v) = hsep [pretty k, "=", pretty v]
+    prettyPrec = prettyPrec1
+
+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

src/Data/Pretty.hs

@@ -1,13 +1,12 @@
-{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE QuantifiedConstraints, UndecidableInstances #-}
 module Data.Pretty
-    ( Pretty(..)
+    ( Pretty(..), Pretty1(..)
+    , prettyPrec1
     , rpretty
     , ttext
     -- * Pretty-printing lens combinators
-    , hsepOf, vsepOf
+    , hsepOf, vsepOf, vcatOf, vlinesOf, vsepTerm
-    , vcatOf
+    , vsep
-    , vlinesOf
-    , vsepTerm
     , module Text.PrettyPrint
     , maybeParens
     , appPrec
@@ -20,12 +19,14 @@ import Text.PrettyPrint.HughesPJ    hiding ((<>))
 import Text.Printf
 import Data.String                  (IsString(..))
 import Data.Text.Lens               hiding ((:<))
-import Data.Monoid
+import Data.Monoid                  hiding (Sum)
 import Control.Lens
 
 -- instances
 import Control.Comonad.Cofree
 import Data.Text                    qualified as T
+import Data.Functor.Sum
+import Data.Fix                     (Fix(..))
 ----------------------------------------------------------------------------------
 
 class Pretty a where
@@ -53,7 +54,24 @@ 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) -> f a -> Doc
+    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
 
 --------------------------------------------------------------------------------
 
@@ -76,6 +94,9 @@ vlinesOf l = foldrOf l (\a b -> a $+$ "" $+$ b) mempty
 vsepTerm :: Doc -> Doc -> Doc -> Doc
 vsepTerm term a b = (a <> term) $+$ b
 
+vsep :: [Doc] -> Doc
+vsep = foldr ($+$) mempty
+
 --------------------------------------------------------------------------------
 
 appPrec, appPrec1 :: Int

src/Rlp/AltParse.y

@@ -0,0 +1,172 @@
+{
+module Rlp.AltParse
+    ( parseRlpProg
+    , parseRlpProgR
+    , 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 _ 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 }
+               : litint                  { undefined }
+
+VL  :: { () }
+VL  : vlbrace       { () }
+
+VR  :: { () }
+VR  : vrbrace       { () }
+    | error         { () }
+
+VS                  :: { () }
+VS                  : ';'                   { () }
+                    | vsemi                 { () }
+
+Decl                :: { Decl PsName (RlpExpr PsName) }
+                    : FunD                  { $1 }
+                    | DataD                 { $1 }
+
+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 }
+
+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 }
+
+AppE                :: { RlpExpr PsName }
+                    : AppE VarE             { Finl $ Core.AppF $1 $2 }
+                    | VarE                  { $1 }
+
+VarE                :: { RlpExpr PsName }
+                    : Var                   { Finl $ Core.VarF $1 }
+
+Pat1s               :: { [Pat PsName] }
+                    : list0(Pat1)           { $1 }
+
+Pat1                :: { Pat PsName }
+                    : Var                   { VarP $1 }
+
+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
+
+parseError = error "explode"
+
+}

src/Rlp/AltSyntax.hs

@@ -0,0 +1,91 @@
+{-# LANGUAGE TemplateHaskell, PatternSynonyms #-}
+module Rlp.AltSyntax
+    (
+    -- * AST
+      Program(..), Decl(..), ExprF(..), Pat(..)
+    , RlpExprF, RlpExpr
+    , DataCon(..), Type(..)
+
+    , Core.Name, PsName
+
+    -- * Functor-related tools
+    , Fix(..), Cofree(..), Sum(..), pattern Finl, pattern Finr
+    )
+    where
+--------------------------------------------------------------------------------
+import Data.Functor.Sum
+import Control.Comonad.Cofree
+import Data.Fix
+
+import Text.Show.Deriving
+import Data.Text                qualified as T
+import Data.Pretty
+
+import Compiler.Types
+import Core.Syntax              qualified as Core
+--------------------------------------------------------------------------------
+
+type PsName = T.Text
+
+newtype Program b a = Program [Decl b a]
+    deriving Show
+
+data Decl b a = FunD b [Pat b] a
+              | DataD b [b] [DataCon b]
+              deriving Show
+
+data DataCon b = DataCon b [Type b]
+    deriving Show
+
+data Type b = VarT b
+            | ConT b
+            | AppT (Type b) (Type b)
+            | FunT
+            deriving Show
+
+data ExprF b a = InfixEF b a a
+
+-- 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
+    deriving Show
+
+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 => Pretty1 (ExprF b) where
+    liftPrettyPrec pr p (InfixEF o a b) = maybeParens (p>0) $
+        pr 1 a <+> pretty o <+> pr 1 b
+
+instance (Pretty b, Pretty a) => Pretty (Decl b a) where
+    prettyPrec = prettyPrec1
+
+instance (Pretty b) => Pretty1 (Decl b) where
+    liftPrettyPrec pr p (FunD f as e) = maybeParens (p>0) $
+        hsep [ ttext f, hsep (prettyPrec appPrec1 <$> as)
+             , "=", pr 0 e ]
+
+instance (Pretty b) => Pretty (Pat b) where
+    prettyPrec p (VarP b) = prettyPrec p b
+
+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
+

src/Rlp/Parse/Types.hs

@@ -18,7 +18,7 @@ module Rlp.Parse.Types
     , RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
     , Located(..), PsName
     -- ** Lenses
-    , _TokenLitInt, _TokenVarName, _TokenConName, _TokenVarSym
+    , _TokenLitInt, _TokenVarName, _TokenConName, _TokenVarSym, _TokenConSym
     , aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
 
     -- * Error handling
@@ -277,7 +277,7 @@ initAlexInput s = AlexInput
     { _aiPrevChar   = '\0'
     , _aiSource     = s
     , _aiBytes      = []
-    , _aiPos        = (1,1,0)
+    , _aiPos        = (1,0,0)
     }
 
 --------------------------------------------------------------------------------

src/Rlp2Core.hs

@@ -28,6 +28,7 @@ import Data.Functor.Bind
 import Data.Function                    (on)
 import GHC.Stack
 import Debug.Trace
+import Numeric
 
 import Effectful.State.Static.Local
 import Effectful.Labeled
@@ -71,9 +72,10 @@ desugarRlpProg :: Rlp.Program RlpcPs SrcSpan -> Core.Program'
 desugarRlpProg = rlpProgToCore
 
 desugarRlpExpr :: Rlp.Expr' RlpcPs SrcSpan -> Core.Expr'
-desugarRlpExpr = runPureEff . runNameSupply "anon" . exprToCore
+desugarRlpExpr = runPureEff . runNameSupply "anon" . undefined
 
-runNameSupply = undefined
+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
@@ -84,5 +86,9 @@ rlpProgToCore = foldMapOf (programDecls . each) declToCore
 declToCore :: Rlp.Decl RlpcPs SrcSpan -> Program'
 declToCore = undefined
 
+type NameSupply = State [Name]
+
+exprToCore :: (NameSupply :> es)
+           => Rlp.ExprF RlpcPs a -> Eff es Core.Expr'
 exprToCore = undefined