From 1b56a7a62792897bad9d5b69c3d6b9f2cb1be8b1 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Sun, 3 Mar 2024 14:09:10 -0700 Subject: [PATCH] pretty --- Makefile_happysrcs | 6 +- rlp.cabal | 2 + src/Compiler/JustRun.hs | 19 ++++- src/Compiler/Types.hs | 23 +++--- src/Core/Syntax.hs | 68 +++++++++++----- src/Data/Pretty.hs | 37 +++++++-- src/Rlp/AltParse.y | 172 ++++++++++++++++++++++++++++++++++++++++ src/Rlp/AltSyntax.hs | 91 +++++++++++++++++++++ src/Rlp/Parse/Types.hs | 4 +- src/Rlp2Core.hs | 10 ++- 10 files changed, 383 insertions(+), 49 deletions(-) create mode 100644 src/Rlp/AltParse.y create mode 100644 src/Rlp/AltSyntax.hs diff --git a/Makefile_happysrcs b/Makefile_happysrcs index 13e9e2a..e04f458 100644 --- a/Makefile_happysrcs +++ b/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 $@ diff --git a/rlp.cabal b/rlp.cabal index 49239d0..33fc93f 100644 --- a/rlp.cabal +++ b/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 diff --git a/src/Compiler/JustRun.hs b/src/Compiler/JustRun.hs index 9888bcc..edb276b 100644 --- a/src/Compiler/JustRun.hs +++ b/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 - p <- evalRLPCIO def (parseRlpProgR >=> desugarRlpProgR $ T.pack s) - withFile "/tmp/t.log" WriteMode $ hdbgProg p +justHdbg = undefined +-- justHdbg s = do +-- 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 diff --git a/src/Compiler/Types.hs b/src/Compiler/Types.hs index 58be658..3f8a015 100644 --- a/src/Compiler/Types.hs +++ b/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) --- => a -> b -> b --- a ~> b = -(~>) = undefined +(~>) :: (CanGet k, CanSet k', HasLocation k a, HasLocation k' b) + => a -> b -> b +a ~> b = b & fromSet getSetLocation .~ (a ^. fromGet getSetLocation) +-- (~>) = undefined infixl 4 ~> @@ -97,15 +95,15 @@ data SrcSpan = SrcSpan !Int -- ^ Length deriving (Show, Eq, Lift) -tupling :: Iso' SrcSpan (Int, Int, Int, Int) -tupling = iso (\ (SrcSpan a b c d) -> (a,b,c,d)) +_SrcSpan :: Iso' SrcSpan (Int, Int, Int, Int) +_SrcSpan = iso (\ (SrcSpan a b c d) -> (a,b,c,d)) (\ (a,b,c,d) -> SrcSpan a b c d) srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen :: Lens' SrcSpan Int -srcSpanLine = tupling . _1 -srcSpanColumn = tupling . _2 -srcSpanAbs = tupling . _3 -srcSpanLen = tupling . _4 +srcSpanLine = _SrcSpan . _1 +srcSpanColumn = _SrcSpan . _2 +srcSpanAbs = _SrcSpan . _3 +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 + diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs index 5efb560..454118b 100644 --- a/src/Core/Syntax.hs +++ b/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 _ (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 + prettyPrec = prettyPrec1 + + -- 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 - pretty (AlterF c as e) = - hsep [pretty c, hsep (pretty <$> as), "->", pretty e] + 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 @@ -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 diff --git a/src/Data/Pretty.hs b/src/Data/Pretty.hs index 13cfab0..820a934 100644 --- a/src/Data/Pretty.hs +++ b/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 - , vcatOf - , vlinesOf - , vsepTerm + , hsepOf, vsepOf, vcatOf, vlinesOf, vsepTerm + , vsep , 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 diff --git a/src/Rlp/AltParse.y b/src/Rlp/AltParse.y new file mode 100644 index 0000000..277c4b7 --- /dev/null +++ b/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" + +} diff --git a/src/Rlp/AltSyntax.hs b/src/Rlp/AltSyntax.hs new file mode 100644 index 0000000..4e6f033 --- /dev/null +++ b/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 + diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index 20c9c99..05ee780 100644 --- a/src/Rlp/Parse/Types.hs +++ b/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) } -------------------------------------------------------------------------------- diff --git a/src/Rlp2Core.hs b/src/Rlp2Core.hs index 2395d22..e65607c 100644 --- a/src/Rlp2Core.hs +++ b/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