pretty
This commit is contained in:
crumbtoo
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
172
src/Rlp/AltParse.y
Normal file
172
src/Rlp/AltParse.y
Normal file
@@ -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"
|
||||
|
||||
}
|
||||
91
src/Rlp/AltSyntax.hs
Normal file
91
src/Rlp/AltSyntax.hs
Normal file
@@ -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
|
||||
|
||||
@@ -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)
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
Reference in New Issue
Block a user