From 6d4585a46be7ca8bcb2955b4a206db616b01b11e Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Tue, 20 Feb 2024 11:52:44 -0700 Subject: [PATCH] ohhhhhhhh --- src/Rlp/Parse.y | 14 ++++---- src/Rlp/Syntax/Backstage.hs | 11 ++++--- src/Rlp/Syntax/Types.hs | 65 +++++++++++++++++++------------------ 3 files changed, 49 insertions(+), 41 deletions(-) diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index 3a41ceb..d706ce4 100644 --- a/src/Rlp/Parse.y +++ b/src/Rlp/Parse.y @@ -183,9 +183,8 @@ CaseExpr :: { Expr' RlpcPs SrcSpan } : case Expr of layout0(Alt) { nolo' $ CaseEF $2 $4 } -- TODO: where-binds -Alt :: { Alt RlpcPs } - : Pat '->' Expr { AltA $1 (collapse . strip $ $3) - Nothing } +Alt :: { Alt' RlpcPs SrcSpan } + : Pat '->' Expr { undefined } -- layout0(p : β) :: [β] layout0(p) : '{' layout_list0(';',p) '}' { $2 } @@ -204,8 +203,8 @@ layout1(p) : '{' layout_list1(';',p) '}' { $2 } layout_list1(sep,p) : p { [$1] } | layout_list1(sep,p) sep p { $1 `snoc` $3 } -Binding :: { Binding RlpcPs } - : Pat '=' Expr { PatB $1 (collapse . strip $ $3) } +Binding :: { Binding RlpcPs (Cofree (ExprF RlpcPs) SrcSpan) } + : Pat '=' Expr { undefined } Expr1 :: { Expr' RlpcPs SrcSpan } : '(' Expr ')' { $2 } @@ -232,7 +231,10 @@ Con :: { PsName } { -parseRlpProgR :: Text -> RLPCT m (Program ) +parseRlpProgR :: Text -> RLPCT m (Program RlpcPs SrcSpan) +parseRlpProgR = undefined + +parseRlpExprR :: Text -> RLPCT m (Expr' RlpcPs SrcSpan) parseRlpExprR = undefined mkInfixD :: Assoc -> Int -> PsName -> P (Decl RlpcPs SrcSpan) diff --git a/src/Rlp/Syntax/Backstage.hs b/src/Rlp/Syntax/Backstage.hs index ee0b477..a9ae01e 100644 --- a/src/Rlp/Syntax/Backstage.hs +++ b/src/Rlp/Syntax/Backstage.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Rlp.Syntax.Backstage - ( strip, collapse + ( strip ) where -------------------------------------------------------------------------------- @@ -15,6 +15,12 @@ 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) @@ -27,6 +33,3 @@ deriving instance (Show (NameP p), Show a) => Show (Program p a) strip :: Functor f => Cofree f a -> Fix f strip (_ :< as) = Fix $ strip <$> as -collapse :: Fix (ExprF b) -> Expr b -collapse = cata embed - diff --git a/src/Rlp/Syntax/Types.hs b/src/Rlp/Syntax/Types.hs index ee09907..6d2dea0 100644 --- a/src/Rlp/Syntax/Types.hs +++ b/src/Rlp/Syntax/Types.hs @@ -8,10 +8,10 @@ module Rlp.Syntax.Types , SimpleP , Assoc(..) , ConAlt(..) - , Alt(..) + , Alt(..), Alt' , Ty(..) - , Binding(..) - , Expr(..), Expr', ExprF(..) + , Binding(..), Binding' + , Expr', ExprF(..) , Rec(..) , Lit(..) , Pat(..) @@ -54,19 +54,16 @@ type instance NameP SimpleP = String type family NameP p -data Expr p = LetE Rec [Binding p] (Expr p) - | VarE (NameP p) - | LamE [Pat p] (Expr p) - | CaseE (Expr p) [Alt p] - | IfE (Expr p) (Expr p) (Expr p) - | AppE (Expr p) (Expr p) - | LitE (Lit p) - | ParE (Expr p) - | InfixE (NameP p) (Expr p) (Expr p) - deriving (Generic) - -deriving instance (Lift (NameP p)) => Lift (Expr p) -deriving instance (Show (NameP p)) => Show (Expr 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] @@ -88,38 +85,44 @@ data Pat p = VarP (NameP p) deriving instance (Lift (NameP p)) => Lift (Pat p) deriving instance (Show (NameP p)) => Show (Pat p) -data Binding p = PatB (Pat p) (Expr p) - -deriving instance (Lift (NameP p)) => Lift (Binding p) -deriving instance (Show (NameP p)) => Show (Binding p) - data Lit p = IntL Int deriving Show deriving instance (Lift (NameP p)) => Lift (Lit p) -data Alt p = AltA (Pat p) (Expr p) (Maybe (Where p)) - -deriving instance (Show (NameP p)) => Show (Alt p) -deriving instance (Lift (NameP p)) => Lift (Alt p) - -type Where p = [Binding p] - data Assoc = InfixL | InfixR | Infix deriving (Lift, Show) -makeBaseFunctor ''Expr - 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)) +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)