From e63824e03533d279a2e60c850f17554c4840011e Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Thu, 15 Feb 2024 18:27:04 -0700 Subject: [PATCH] no-ttg --- src/Rlp/Parse.y | 21 ++- src/Rlp/Parse/Associate.hs | 2 +- src/Rlp/Parse/Types.hs | 33 +--- src/Rlp/Syntax.hs | 363 +++++-------------------------------- src/Rlp/TH.hs | 6 +- src/Rlp2Core.hs | 8 + 6 files changed, 80 insertions(+), 353 deletions(-) diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index 9f4a52f..e6043a0 100644 --- a/src/Rlp/Parse.y +++ b/src/Rlp/Parse.y @@ -248,6 +248,11 @@ Con :: { Located PsName } { +parseRlpProgR = undefined +parseRlpExprR = undefined + +{-- + parseRlpExprR :: (Monad m) => Text -> RLPCT m (RlpExpr RlpcPs) parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st where @@ -281,10 +286,6 @@ mkProgram ds = do pt <- use psOpTable 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) @@ -308,5 +309,17 @@ tempInfixExprErr (Located a _) (Located b _) = , "In the mean time, don't mix any infix operators." ] +--} + +mkPsName = undefined +tempInfixExprErr = undefined +extractName = undefined +extractInt = undefined +mkProgram = undefined + +parseError :: (Located RlpToken, [String]) -> P a +parseError ((Located ss t), exp) = addFatal $ + errorMsg ss (RlpParErrUnexpectedToken t exp) + } diff --git a/src/Rlp/Parse/Associate.hs b/src/Rlp/Parse/Associate.hs index e261ca3..d4d13e4 100644 --- a/src/Rlp/Parse/Associate.hs +++ b/src/Rlp/Parse/Associate.hs @@ -16,7 +16,7 @@ import Rlp.Parse.Types import Rlp.Syntax -------------------------------------------------------------------------------- -associate :: OpTable -> Decl' RlpcPs -> Decl' RlpcPs +associate :: OpTable -> Decl RlpcPs -> Decl RlpcPs associate _ p = p {-# WARNING associate "unimplemented" #-} diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index 46020f0..61238b1 100644 --- a/src/Rlp/Parse/Types.hs +++ b/src/Rlp/Parse/Types.hs @@ -53,35 +53,10 @@ import Compiler.Types data RlpcPs -type instance XRec RlpcPs a = Located a -type instance IdP RlpcPs = PsName - -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 instance NameP RlpcPs = PsName type PsName = Text -instance MapXRec RlpcPs where - mapXRec = fmap - -instance UnXRec RlpcPs where - unXRec = extract - -------------------------------------------------------------------------------- spanFromPos :: Position -> Int -> SrcSpan @@ -281,13 +256,13 @@ initAlexInput s = AlexInput -------------------------------------------------------------------------------- -deriving instance Lift (RlpProgram RlpcPs) +deriving instance Lift (Program RlpcPs) deriving instance Lift (Decl RlpcPs) deriving instance Lift (Pat RlpcPs) deriving instance Lift (Lit RlpcPs) -deriving instance Lift (RlpExpr RlpcPs) +deriving instance Lift (Expr RlpcPs) deriving instance Lift (Binding RlpcPs) -deriving instance Lift (RlpType RlpcPs) +deriving instance Lift (Ty RlpcPs) deriving instance Lift (Alt RlpcPs) deriving instance Lift (ConAlt RlpcPs) diff --git a/src/Rlp/Syntax.hs b/src/Rlp/Syntax.hs index e3aebc1..acc3f91 100644 --- a/src/Rlp/Syntax.hs +++ b/src/Rlp/Syntax.hs @@ -6,44 +6,17 @@ {-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-} module Rlp.Syntax ( - -- * AST - RlpProgram(..) - , progDecls - , Decl(..), Decl', RlpExpr(..), RlpExpr', RlpExprF(..) - , Pat(..), Pat' - , Alt(..), Where + NameP , 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'' + , Alt(..) + , Ty(..) + , Binding(..) + , Expr(..) + , Lit(..) + , Pat(..) + , Decl(..) + , Program(..) ) where ---------------------------------------------------------------------------------- @@ -58,305 +31,61 @@ 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(..)) +import Core.Syntax qualified as Core +import Core (Rec(..), HasRHS(..), HasLHS(..)) ---------------------------------------------------------------------------------- -data RlpModule p = RlpModule - { _rlpmodName :: Text - , _rlpmodProgram :: RlpProgram p - } +type PsName = Text +type family NameP 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)) - ) +data Program p -newtype RlpProgram p = RlpProgram [Decl' p] +data Decl p = FunD (NameP p) [Pat p] (Expr p) (Maybe (Where p)) + | TySigD [NameP p] (Ty p) + | DataD (NameP p) [NameP p] [ConAlt p] + | InfixD Assoc Int (NameP p) -progDecls :: Lens' (RlpProgram p) [Decl' p] -progDecls = lens - (\ (RlpProgram ds) -> ds) - (const RlpProgram) +deriving instance (Show (NameP p)) => Show (Decl p) -deriving instance (PhaseShow p, Show (XRec p (Decl p))) => Show (RlpProgram 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) -data RlpType p = FunConT - | FunT (RlpType' p) (RlpType' p) - | AppT (RlpType' p) (RlpType' p) - | VarT (IdP p) - | ConT (IdP p) +deriving instance (Show (NameP p)) => Show (Expr p) -type RlpType' p = XRec p (RlpType p) +data ConAlt p = ConAlt (NameP p) [Ty 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 +deriving instance (Show (NameP p)) => Show (ConAlt 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) +data Ty p + deriving Show -deriving instance (PhaseShow p) - => Show (RlpType p) +data Pat p = VarP (NameP p) + | LitP (Lit p) + | ConP (NameP p) [Pat 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 (NameP p)) => Show (Pat p) -deriving instance - ( Show (XFunD p), Show (XTySigD p) - , Show (XDataD p), Show (XInfixD p) - , Show (XXDeclD p) - , PhaseShow p - ) - => Show (Decl p) +data Binding p = PatB (Pat p) (Expr p) -type family XFunD p -type family XTySigD p -type family XDataD p -type family XInfixD p -type family XXDeclD p +deriving instance (Show (NameP p)) => Show (Binding 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 +data Lit p = IntL Int + deriving Show -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' () +data Alt p = AltA (Pat p) (Expr p) (Maybe (Where p)) -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) +deriving instance (Show (NameP p)) => Show (Alt 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 +data Assoc = InfixL | InfixR | Infix + deriving (Lift, Show) diff --git a/src/Rlp/TH.hs b/src/Rlp/TH.hs index eb4d44c..47cd0d2 100644 --- a/src/Rlp/TH.hs +++ b/src/Rlp/TH.hs @@ -17,10 +17,12 @@ import Rlp.Parse -------------------------------------------------------------------------------- rlpProg :: QuasiQuoter -rlpProg = mkqq parseRlpProgR +rlpProg = undefined +-- rlpProg = mkqq parseRlpProgR rlpExpr :: QuasiQuoter -rlpExpr = mkqq parseRlpExprR +rlpExpr = undefined +-- rlpExpr = mkqq parseRlpExprR mkq :: (Lift a) => (Text -> RLPCIO a) -> String -> Q Exp mkq parse = evalAndParse >=> lift where diff --git a/src/Rlp2Core.hs b/src/Rlp2Core.hs index cf8a2a7..4f3bea4 100644 --- a/src/Rlp2Core.hs +++ b/src/Rlp2Core.hs @@ -41,6 +41,12 @@ import Rlp.Syntax as Rlp import Rlp.Parse.Types (RlpcPs, PsName) -------------------------------------------------------------------------------- +desugarRlpProgR = undefined +desugarRlpProg = undefined +desugarRlpExpr = undefined + +{-- + type Tree a = Either Name (Name, Branch a) -- | Rose tree branch representing "nested" "patterns" in the Core language. That @@ -234,3 +240,5 @@ typeToCore (VarT'' x) = TyVar (dsNameToName x) dsNameToName :: IdP RlpcPs -> Name dsNameToName = id +-} +