From e9cab1ddaf3faff7aa5efe869cedeb08628076c2 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Thu, 15 Feb 2024 18:27:04 -0700 Subject: [PATCH 01/10] 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 +-} + From caeec216b5ebe12aa48272438513827f5a33f40a Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Fri, 16 Feb 2024 15:11:08 -0700 Subject: [PATCH 02/10] no-ttg --- rlp.cabal | 1 + src/Rlp/Parse.y | 237 ++++++++++++++++++++--------------------- src/Rlp/Parse/Types.hs | 18 ++-- src/Rlp/Syntax.hs | 39 +++++-- 4 files changed, 157 insertions(+), 138 deletions(-) diff --git a/rlp.cabal b/rlp.cabal index e1a30be..77b6522 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -73,6 +73,7 @@ library , effectful-core ^>=2.3.0.0 , deriving-compat ^>=0.6.0 , these >=0.2 && <2.0 + , free hs-source-dirs: src default-language: GHC2021 diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index e6043a0..1f28755 100644 --- a/src/Rlp/Parse.y +++ b/src/Rlp/Parse.y @@ -71,180 +71,175 @@ import Compiler.Types %% -StandaloneProgram :: { RlpProgram RlpcPs } -StandaloneProgram : '{' Decls '}' {% mkProgram $2 } - | VL DeclsV VR {% mkProgram $2 } +StandaloneProgram :: { Program RlpcPs } +StandaloneProgram : '{' Decls '}' { undefined } + | VL DeclsV VR { undefined } -StandaloneExpr :: { RlpExpr RlpcPs } - : VL Expr VR { extract $2 } +StandaloneExpr :: { Expr RlpcPs } + : VL Expr VR { undefined } VL :: { () } -VL : vlbrace { () } +VL : vlbrace { undefined } VR :: { () } -VR : vrbrace { () } - | error { () } +VR : vrbrace { undefined } + | error { undefined } -Decls :: { [Decl' RlpcPs] } -Decls : Decl ';' Decls { $1 : $3 } - | Decl ';' { [$1] } - | Decl { [$1] } +Decls :: { [Decl RlpcPs] } +Decls : Decl ';' Decls { undefined } + | Decl ';' { undefined } + | Decl { undefined } -DeclsV :: { [Decl' RlpcPs] } -DeclsV : Decl VS DeclsV { $1 : $3 } - | Decl VS { [$1] } - | Decl { [$1] } +DeclsV :: { [Decl RlpcPs] } +DeclsV : Decl VS DeclsV { undefined } + | Decl VS { undefined } + | Decl { undefined } VS :: { Located RlpToken } -VS : ';' { $1 } - | vsemi { $1 } +VS : ';' { undefined } + | vsemi { undefined } -Decl :: { Decl' RlpcPs } - : FunDecl { $1 } - | TySigDecl { $1 } - | DataDecl { $1 } - | InfixDecl { $1 } +Decl :: { Decl RlpcPs } + : FunDecl { undefined } + | TySigDecl { undefined } + | DataDecl { undefined } + | InfixDecl { undefined } -TySigDecl :: { Decl' RlpcPs } - : Var '::' Type { (\e -> TySigD [extract e]) <<~ $1 <~> $3 } +TySigDecl :: { Decl RlpcPs } + : Var '::' Type { undefined } -InfixDecl :: { Decl' RlpcPs } - : InfixWord litint InfixOp { $1 =>> \w -> - InfixD (extract $1) (extractInt $ extract $2) - (extract $3) } +InfixDecl :: { Decl RlpcPs } + : InfixWord litint InfixOp { undefined } InfixWord :: { Located Assoc } - : infixl { $1 \$> InfixL } - | infixr { $1 \$> InfixR } - | infix { $1 \$> Infix } + : infixl { undefined } + | infixr { undefined } + | infix { undefined } -DataDecl :: { Decl' RlpcPs } - : data Con TyParams '=' DataCons { $1 \$> DataD (extract $2) $3 $5 } +DataDecl :: { Decl RlpcPs } + : data Con TyParams '=' DataCons { undefined } TyParams :: { [PsName] } - : {- epsilon -} { [] } - | TyParams varname { $1 `snoc` (extractName . extract $ $2) } + : {- epsilon -} { undefined } + | TyParams varname { undefined } DataCons :: { [ConAlt RlpcPs] } - : DataCons '|' DataCon { $1 `snoc` $3 } - | DataCon { [$1] } + : DataCons '|' DataCon { undefined } + | DataCon { undefined } DataCon :: { ConAlt RlpcPs } - : Con Type1s { ConAlt (extract $1) $2 } + : Con Type1s { undefined } -Type1s :: { [RlpType' RlpcPs] } - : {- epsilon -} { [] } - | Type1s Type1 { $1 `snoc` $2 } +Type1s :: { [Ty RlpcPs] } + : {- epsilon -} { undefined } + | Type1s Type1 { undefined } -Type1 :: { RlpType' RlpcPs } - : '(' Type ')' { $2 } - | conname { fmap ConT (mkPsName $1) } - | varname { fmap VarT (mkPsName $1) } +Type1 :: { Ty RlpcPs } + : '(' Type ')' { undefined } + | conname { undefined } + | varname { undefined } -Type :: { RlpType' RlpcPs } - : Type '->' Type { FunT <<~ $1 <~> $3 } - | TypeApp { $1 } +Type :: { Ty RlpcPs } + : Type '->' Type { undefined } + | TypeApp { undefined } -TypeApp :: { RlpType' RlpcPs } - : Type1 { $1 } - | TypeApp Type1 { AppT <<~ $1 <~> $2 } +TypeApp :: { Ty RlpcPs } + : Type1 { undefined } + | TypeApp Type1 { undefined } -FunDecl :: { Decl' RlpcPs } -FunDecl : Var Params '=' Expr { $4 =>> \e -> - FunD (extract $1) $2 e Nothing } +FunDecl :: { Decl RlpcPs } +FunDecl : Var Params '=' Expr { undefined } -Params :: { [Pat' RlpcPs] } -Params : {- epsilon -} { [] } - | Params Pat1 { $1 `snoc` $2 } +Params :: { [Pat RlpcPs] } +Params : {- epsilon -} { undefined } + | Params Pat1 { undefined } -Pat :: { Pat' RlpcPs } - : Con Pat1s { $1 =>> \cn -> - ConP (extract $1) $2 } - | Pat1 { $1 } +Pat :: { Pat RlpcPs } + : Con Pat1s { undefined } + | Pat1 { undefined } -Pat1s :: { [Pat' RlpcPs] } - : Pat1s Pat1 { $1 `snoc` $2 } - | Pat1 { [$1] } +Pat1s :: { [Pat RlpcPs] } + : Pat1s Pat1 { undefined } + | Pat1 { undefined } -Pat1 :: { Pat' RlpcPs } - : Con { fmap (`ConP` []) $1 } - | Var { fmap VarP $1 } - | Lit { LitP <<= $1 } - | '(' Pat ')' { $1 .> $2 <. $3 } +Pat1 :: { Pat RlpcPs } + : Con { undefined } + | Var { undefined } + | Lit { undefined } + | '(' Pat ')' { undefined } -Expr :: { RlpExpr' RlpcPs } +Expr :: { Expr RlpcPs } -- infixities delayed till next release :( - -- : Expr1 InfixOp Expr { $2 =>> \o -> - -- OAppE (extract o) $1 $3 } - : TempInfixExpr { $1 } - | LetExpr { $1 } - | CaseExpr { $1 } - | AppExpr { $1 } + -- : Expr1 InfixOp Expr { undefined } + : TempInfixExpr { undefined } + | LetExpr { undefined } + | CaseExpr { undefined } + | AppExpr { undefined } -TempInfixExpr :: { RlpExpr' RlpcPs } -TempInfixExpr : Expr1 InfixOp TempInfixExpr {% tempInfixExprErr $1 $3 } - | Expr1 InfixOp Expr1 { $2 =>> \o -> - OAppE (extract o) $1 $3 } +TempInfixExpr :: { Expr RlpcPs } +TempInfixExpr : Expr1 InfixOp TempInfixExpr { undefined } + | Expr1 InfixOp Expr1 { undefined } -AppExpr :: { RlpExpr' RlpcPs } - : Expr1 { $1 } - | AppExpr Expr1 { AppE <<~ $1 <~> $2 } +AppExpr :: { Expr RlpcPs } + : Expr1 { undefined } + | AppExpr Expr1 { undefined } -LetExpr :: { RlpExpr' RlpcPs } - : let layout1(Binding) in Expr { $1 \$> LetE $2 $4 } - | letrec layout1(Binding) in Expr { $1 \$> LetrecE $2 $4 } +LetExpr :: { Expr RlpcPs } + : let layout1(Binding) in Expr { undefined } + | letrec layout1(Binding) in Expr { undefined } -CaseExpr :: { RlpExpr' RlpcPs } - : case Expr of layout0(CaseAlt) - { CaseE <<~ $2 <#> $4 } +CaseExpr :: { Expr RlpcPs } + : case Expr of layout0(CaseAlt) { undefined } -- TODO: where-binds CaseAlt :: { (Alt RlpcPs, Where RlpcPs) } - : Alt { ($1, []) } + : Alt { undefined } Alt :: { Alt RlpcPs } - : Pat '->' Expr { AltA $1 $3 } + : Pat '->' Expr { undefined } -- layout0(p : β) :: [β] -layout0(p) : '{' layout_list0(';',p) '}' { $2 } - | VL layout_list0(VS,p) VR { $2 } +layout0(p) : '{' layout_list0(';',p) '}' { undefined } + | VL layout_list0(VS,p) VR { undefined } -- layout_list0(sep : α, p : β) :: [β] -layout_list0(sep,p) : p { [$1] } - | layout_list1(sep,p) sep p { $1 `snoc` $3 } - | {- epsilon -} { [] } +layout_list0(sep,p) : p { undefined } + | layout_list1(sep,p) sep p { undefined } + | {- epsilon -} { undefined } -- layout1(p : β) :: [β] -layout1(p) : '{' layout_list1(';',p) '}' { $2 } - | VL layout_list1(VS,p) VR { $2 } +layout1(p) : '{' layout_list1(';',p) '}' { undefined } + | VL layout_list1(VS,p) VR { undefined } -- layout_list1(sep : α, p : β) :: [β] -layout_list1(sep,p) : p { [$1] } - | layout_list1(sep,p) sep p { $1 `snoc` $3 } +layout_list1(sep,p) : p { undefined } + | layout_list1(sep,p) sep p { undefined } -Binding :: { Binding' RlpcPs } - : Pat '=' Expr { PatB <<~ $1 <~> $3 } +Binding :: { Binding RlpcPs } + : Pat '=' Expr { undefined } -Expr1 :: { RlpExpr' RlpcPs } - : '(' Expr ')' { $1 .> $2 <. $3 } - | Lit { fmap LitE $1 } - | Var { fmap VarE $1 } - | Con { fmap VarE $1 } +Expr1 :: { Expr RlpcPs } + : '(' Expr ')' { undefined } + | Lit { undefined } + | Var { undefined } + | Con { undefined } InfixOp :: { Located PsName } - : consym { mkPsName $1 } - | varsym { mkPsName $1 } + : consym { undefined } + | varsym { undefined } -- TODO: microlens-pro save me microlens-pro (rewrite this with prisms) -Lit :: { Lit' RlpcPs } - : litint { $1 <&> (IntL . (\ (TokenLitInt n) -> n)) } +Lit :: { Lit RlpcPs } + : litint { undefined } Var :: { Located PsName } -Var : varname { mkPsName $1 } - | varsym { mkPsName $1 } +Var : varname { undefined } + | varsym { undefined } Con :: { Located PsName } - : conname { mkPsName $1 } + : conname { undefined } + +--} { @@ -253,12 +248,12 @@ parseRlpExprR = undefined {-- -parseRlpExprR :: (Monad m) => Text -> RLPCT m (RlpExpr RlpcPs) +parseRlpExprR :: (Monad m) => Text -> RLPCT m (Expr RlpcPs) parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st where st = programInitState s -parseRlpProgR :: (Monad m) => Text -> RLPCT m (RlpProgram RlpcPs) +parseRlpProgR :: (Monad m) => Text -> RLPCT m (Program RlpcPs) parseRlpProgR s = do a <- liftErrorful $ pToErrorful parseRlpProg st addDebugMsg @_ @String "dump-parsed" $ show a @@ -281,12 +276,12 @@ extractInt :: RlpToken -> Int extractInt (TokenLitInt n) = n extractInt _ = error "extractInt: ugh" -mkProgram :: [Decl' RlpcPs] -> P (RlpProgram RlpcPs) +mkProgram :: [Decl RlpcPs] -> P (Program RlpcPs) mkProgram ds = do pt <- use psOpTable - pure $ RlpProgram (associate pt <$> ds) + pure $ Program (associate pt <$> ds) -mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs) +mkInfixD :: Assoc -> Int -> PsName -> P (Decl RlpcPs) mkInfixD a p n = do let opl :: Lens' ParseState (Maybe OpInfo) opl = psOpTable . at n @@ -302,7 +297,7 @@ mkInfixD a p n = do intOfToken :: Located RlpToken -> Int intOfToken (Located _ (TokenLitInt n)) = n -tempInfixExprErr :: RlpExpr' RlpcPs -> RlpExpr' RlpcPs -> P a +tempInfixExprErr :: Expr RlpcPs -> Expr RlpcPs -> P a tempInfixExprErr (Located a _) (Located b _) = addFatal $ errorMsg (a <> b) $ RlpParErrOther [ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :(" diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index 61238b1..4b3cbe1 100644 --- a/src/Rlp/Parse/Types.hs +++ b/src/Rlp/Parse/Types.hs @@ -256,13 +256,13 @@ initAlexInput s = AlexInput -------------------------------------------------------------------------------- -deriving instance Lift (Program RlpcPs) -deriving instance Lift (Decl RlpcPs) -deriving instance Lift (Pat RlpcPs) -deriving instance Lift (Lit RlpcPs) -deriving instance Lift (Expr RlpcPs) -deriving instance Lift (Binding RlpcPs) -deriving instance Lift (Ty RlpcPs) -deriving instance Lift (Alt RlpcPs) -deriving instance Lift (ConAlt RlpcPs) +-- deriving instance Lift (Program RlpcPs) +-- deriving instance Lift (Decl RlpcPs) +-- deriving instance Lift (Pat RlpcPs) +-- deriving instance Lift (Lit RlpcPs) +-- deriving instance Lift (Expr RlpcPs) +-- deriving instance Lift (Binding 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 acc3f91..a22d9b6 100644 --- a/src/Rlp/Syntax.hs +++ b/src/Rlp/Syntax.hs @@ -1,8 +1,6 @@ -- recursion-schemes -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable - , TemplateHaskell, TypeFamilies #-} +{-# LANGUAGE DeriveTraversable, TemplateHaskell, TypeFamilies #-} {-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-} -{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-} module Rlp.Syntax ( @@ -17,20 +15,24 @@ module Rlp.Syntax , Pat(..) , Decl(..) , Program(..) + , Where ) where ---------------------------------------------------------------------------------- import Data.Text (Text) import Data.Text qualified as T import Data.String (IsString(..)) -import Data.Functor.Foldable -import Data.Functor.Foldable.TH (makeBaseFunctor) import Data.Functor.Classes import Data.Functor.Identity import Data.Kind (Type) import GHC.Generics import Language.Haskell.TH.Syntax (Lift) import Control.Lens + +import Control.Comonad.Cofree +import Data.Functor.Foldable +import Data.Functor.Foldable.TH (makeBaseFunctor) + import Core.Syntax qualified as Core import Core (Rec(..), HasRHS(..), HasLHS(..)) ---------------------------------------------------------------------------------- @@ -38,13 +40,18 @@ import Core (Rec(..), HasRHS(..), HasLHS(..)) type PsName = Text type family NameP p -data Program p +data Program p = Program + { _programDecls :: [Decl p] + } + +deriving instance (Show (NameP p)) => Show (Program 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) +deriving instance (Lift (NameP p)) => Lift (Decl p) deriving instance (Show (NameP p)) => Show (Decl p) data Expr p = LetE Rec [Binding p] (Expr p) @@ -58,34 +65,50 @@ data Expr p = LetE Rec [Binding p] (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 ConAlt p = ConAlt (NameP p) [Ty p] +deriving instance (Lift (NameP p)) => Lift (ConAlt p) deriving instance (Show (NameP p)) => Show (ConAlt p) -data Ty p - deriving Show +data Ty p = TyCon (NameP p) + +deriving instance (Show (NameP p)) => Show (Ty p) +deriving instance (Lift (NameP p)) => Lift (Ty p) data Pat p = VarP (NameP p) | LitP (Lit p) | ConP (NameP p) [Pat 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 +makeLenses ''Program + +type Expr' p = Cofree (ExprF p) + From da81a5a98e7d50abf2ac39229a56ac2e971d1bfb Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Fri, 16 Feb 2024 16:13:40 -0700 Subject: [PATCH 03/10] SrcSpan --- rlp.cabal | 4 ++- src/Compiler/RLPC.hs | 4 +-- src/Compiler/Types.hs | 47 ++++++++------------------- src/Rlp/Parse/Types.hs | 2 -- src/Rlp/Syntax.hs | 13 +++++++- tst/Compiler/TypesSpec.hs | 67 +++++++++++++++++++++++++++++++++++++++ 6 files changed, 98 insertions(+), 39 deletions(-) create mode 100644 tst/Compiler/TypesSpec.hs diff --git a/rlp.cabal b/rlp.cabal index 77b6522..d0e2b76 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -73,7 +73,7 @@ library , effectful-core ^>=2.3.0.0 , deriving-compat ^>=0.6.0 , these >=0.2 && <2.0 - , free + , free >=5.2 hs-source-dirs: src default-language: GHC2021 @@ -117,8 +117,10 @@ test-suite rlp-test , QuickCheck , hspec ==2.* , microlens + , lens >=5.2.3 && <6.0 other-modules: Arith , GMSpec , Core.HindleyMilnerSpec + , Compiler.TypesSpec build-tool-depends: hspec-discover:hspec-discover diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs index fb599fc..1ea0ddd 100644 --- a/src/Compiler/RLPC.hs +++ b/src/Compiler/RLPC.hs @@ -220,9 +220,9 @@ docRlpcErr msg = header rule = repeat (ttext . Ansi.blue . Ansi.bold $ "|") srclines = ["", "", ""] filename = msgColour "" - pos = msgColour $ tshow (msg ^. msgSpan . srcspanLine) + pos = msgColour $ tshow (msg ^. msgSpan . srcSpanLine) <> ":" - <> tshow (msg ^. msgSpan . srcspanColumn) + <> tshow (msg ^. msgSpan . srcSpanColumn) header = ttext $ filename <> msgColour ":" <> pos <> msgColour ": " <> errorColour "error" <> msgColour ":" diff --git a/src/Compiler/Types.hs b/src/Compiler/Types.hs index 607a0db..106c5cc 100644 --- a/src/Compiler/Types.hs +++ b/src/Compiler/Types.hs @@ -1,12 +1,11 @@ {-# LANGUAGE TemplateHaskell #-} module Compiler.Types ( SrcSpan(..) - , srcspanLine, srcspanColumn, srcspanAbs, srcspanLen + , srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen , Located(..) , _Located , located , nolo - , (<<~), (<~>), (<#>) -- * Re-exports , Comonad @@ -18,7 +17,7 @@ module Compiler.Types import Control.Comonad import Data.Functor.Apply import Data.Functor.Bind -import Control.Lens hiding ((<<~)) +import Control.Lens hiding ((<<~)) import Language.Haskell.TH.Syntax (Lift) -------------------------------------------------------------------------------- @@ -47,53 +46,35 @@ data SrcSpan = SrcSpan !Int -- ^ Column !Int -- ^ Absolute !Int -- ^ Length - deriving (Show, Lift) + deriving (Show, Eq, Lift) tupling :: Iso' SrcSpan (Int, Int, Int, Int) tupling = 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, srcSpanColumn, srcSpanAbs, srcSpanLen :: Lens' SrcSpan Int +srcSpanLine = tupling . _1 +srcSpanColumn = tupling . _2 +srcSpanAbs = tupling . _3 +srcSpanLen = tupling . _4 -- | debug tool nolo :: a -> Located a nolo = Located (SrcSpan 0 0 0 0) instance Semigroup SrcSpan where + -- multiple identities? what are the consequences of this...? + SrcSpan _ _ _ 0 <> SrcSpan l c a s = SrcSpan l c a s + SrcSpan l c a s <> SrcSpan _ _ _ 0 = SrcSpan l c a s + SrcSpan la ca aa sa <> SrcSpan lb cb ab sb = SrcSpan l c a s where l = min la lb c = min ca cb a = min aa ab s = case aa `compare` ab of EQ -> max sa sb - LT -> max sa (ab + lb - aa) - GT -> max sb (aa + la - ab) - --- | A synonym for '(<<=)' with a tighter precedence and left-associativity for --- use with '(<~>)' in a sort of, comonadic pseudo-applicative style. - -(<<~) :: (Comonad w) => (w a -> b) -> w a -> w b -(<<~) = (<<=) - -infixl 4 <<~ - --- | Similar to '(<*>)', but with a cokleisli arrow. - -(<~>) :: (Comonad w, Bind w) => w (w a -> b) -> w a -> w b -mc <~> ma = mc >>- \f -> ma =>> f - -infixl 4 <~> - --- this is getting silly - -(<#>) :: (Functor f) => f (a -> b) -> a -> f b -fab <#> a = fmap ($ a) fab - -infixl 4 <#> + LT -> max sa (ab + sb - aa) + GT -> max sb (aa + sa - ab) makePrisms ''Located diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index 4b3cbe1..c449aea 100644 --- a/src/Rlp/Parse/Types.hs +++ b/src/Rlp/Parse/Types.hs @@ -19,8 +19,6 @@ module Rlp.Parse.Types -- ** Lenses , aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn - , (<<~), (<~>) - -- * Error handling , MsgEnvelope(..), RlpcError(..), RlpParseError(..) , addFatal, addWound, addFatalHere, addWoundHere diff --git a/src/Rlp/Syntax.hs b/src/Rlp/Syntax.hs index a22d9b6..fb9f2c0 100644 --- a/src/Rlp/Syntax.hs +++ b/src/Rlp/Syntax.hs @@ -10,12 +10,18 @@ module Rlp.Syntax , Alt(..) , Ty(..) , Binding(..) - , Expr(..) + , Expr(..), Expr', ExprF(..) , Lit(..) , Pat(..) , Decl(..) , Program(..) , Where + + -- * Re-exports + , Cofree(..) + , Trans.Cofree.CofreeF + , pattern (:<$) + , SrcSpan(..) ) where ---------------------------------------------------------------------------------- @@ -29,10 +35,12 @@ import GHC.Generics import Language.Haskell.TH.Syntax (Lift) import Control.Lens +import Control.Comonad.Trans.Cofree qualified as Trans.Cofree import Control.Comonad.Cofree import Data.Functor.Foldable import Data.Functor.Foldable.TH (makeBaseFunctor) +import Compiler.Types (SrcSpan(..)) import Core.Syntax qualified as Core import Core (Rec(..), HasRHS(..), HasLHS(..)) ---------------------------------------------------------------------------------- @@ -105,6 +113,9 @@ type Where p = [Binding p] data Assoc = InfixL | InfixR | Infix deriving (Lift, Show) +pattern (:<$) :: a -> f b -> Trans.Cofree.CofreeF f a b +pattern a :<$ b = a Trans.Cofree.:< b + -------------------------------------------------------------------------------- makeBaseFunctor ''Expr diff --git a/tst/Compiler/TypesSpec.hs b/tst/Compiler/TypesSpec.hs new file mode 100644 index 0000000..15e175b --- /dev/null +++ b/tst/Compiler/TypesSpec.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE ParallelListComp #-} +module Compiler.TypesSpec + ( spec + ) + where +-------------------------------------------------------------------------------- +import Control.Lens.Combinators +import Data.Function ((&)) + +import Test.QuickCheck +import Test.Hspec + +import Compiler.Types (SrcSpan(..), srcSpanAbs, srcSpanLen) +-------------------------------------------------------------------------------- + +spec :: Spec +spec = do + describe "SrcSpan" $ do + -- it "associates under closure" + -- prop_SrcSpan_mul_associative + it "commutes under closure" + prop_SrcSpan_mul_commutative + it "equals itself when squared" + prop_SrcSpan_mul_square_eq + +prop_SrcSpan_mul_associative :: Property +prop_SrcSpan_mul_associative = property $ \a b c -> + -- very crudely approximate when overflow will occur; bail we think it + -- will + (([a,b,c] :: [SrcSpan]) & allOf (each . (srcSpanAbs <> srcSpanLen)) + (< (maxBound @Int `div` 3))) + ==> (a <> b) <> c === a <> (b <> c :: SrcSpan) + +prop_SrcSpan_mul_commutative :: Property +prop_SrcSpan_mul_commutative = property $ \a b -> + a <> b === (b <> a :: SrcSpan) + +prop_SrcSpan_mul_square_eq :: Property +prop_SrcSpan_mul_square_eq = property $ \a -> + a <> a === (a :: SrcSpan) + +instance Arbitrary SrcSpan where + arbitrary = do + l <- chooseInt (1, maxBound) + c <- chooseInt (1, maxBound) + a <- chooseInt (0, maxBound) + `suchThat` (\n -> n >= pred l + pred c) + s <- chooseInt (0, maxBound) + pure $ SrcSpan l c a s + + shrink (SrcSpan l c a s) = + [ SrcSpan l' c' a' s' + | (l',c',a',s') <- shrinkParts + , l' >= 1 + , c' >= 1 + , a' >= pred l' + pred c' + ] + where + -- shfl as = unsafePerformIO (generate $ shuffle as) + shrinkParts = + [ (l',c',a',s') + | l' <- shrinkIntegral l + | c' <- shrinkIntegral c + | a' <- shrinkIntegral a + | s' <- shrinkIntegral s + ] + From 910cf66468f90b23641e6a68e411b2a974b96c79 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Fri, 16 Feb 2024 17:22:24 -0700 Subject: [PATCH 04/10] HasLocation HasLocation --- src/Compiler/Types.hs | 50 +++++++++++++++++++++++++++++++++--- src/Rlp/Parse.y | 57 +++++++++++++++++------------------------- src/Rlp/Parse/Types.hs | 9 +++++-- src/Rlp/Syntax.hs | 3 +-- 4 files changed, 77 insertions(+), 42 deletions(-) diff --git a/src/Compiler/Types.hs b/src/Compiler/Types.hs index 106c5cc..aeb5eef 100644 --- a/src/Compiler/Types.hs +++ b/src/Compiler/Types.hs @@ -1,12 +1,16 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances, QuantifiedConstraints #-} module Compiler.Types ( SrcSpan(..) , srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen , Located(..) + , HasLocation(location) , _Located - , located , nolo + , (<~>), (~>) + -- * Re-exports , Comonad , Apply @@ -14,19 +18,38 @@ module Compiler.Types ) where -------------------------------------------------------------------------------- +import Language.Haskell.TH.Syntax (Lift) + import Control.Comonad +import Control.Comonad.Cofree import Data.Functor.Apply import Data.Functor.Bind +import Data.Semigroup.Foldable +import Data.Kind import Control.Lens hiding ((<<~)) -import Language.Haskell.TH.Syntax (Lift) + +import Data.List.NonEmpty (NonEmpty) -------------------------------------------------------------------------------- -- | Token wrapped with a span (line, column, absolute, length) data Located a = Located SrcSpan a deriving (Show, Lift, Functor) -located :: Lens (Located a) (Located b) a b -located = lens extract ($>) +class GetLocation s where + srcspan :: s -> SrcSpan + +class HasLocation s where + location :: Lens' s SrcSpan + +(<~>) :: a -> b -> SrcSpan +(<~>) = undefined + +infixl 5 <~> + +(~>) :: a -> b -> b +(~>) = undefined + +infixl 4 ~> instance Apply Located where liftF2 f (Located sa p) (Located sb q) @@ -78,3 +101,22 @@ instance Semigroup SrcSpan where makePrisms ''Located +-------------------------------------------------------------------------------- + +instance (GetLocation a) => GetLocation (NonEmpty a) where + srcspan = foldMap1 srcspan + +instance GetLocation SrcSpan where + srcspan = id + +instance (Functor f) => GetLocation (Cofree f SrcSpan) where + srcspan = extract + +-------------------------------------------------------------------------------- + +instance HasLocation SrcSpan where + location = id + +instance (Functor f) => HasLocation (Cofree f SrcSpan) where + location = _extract + diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index 1f28755..ec61798 100644 --- a/src/Rlp/Parse.y +++ b/src/Rlp/Parse.y @@ -72,32 +72,21 @@ import Compiler.Types %% StandaloneProgram :: { Program RlpcPs } -StandaloneProgram : '{' Decls '}' { undefined } - | VL DeclsV VR { undefined } +StandaloneProgram : layout0(Decl) { Program $1 } StandaloneExpr :: { Expr RlpcPs } - : VL Expr VR { undefined } + : VL Expr VR { $2 } VL :: { () } -VL : vlbrace { undefined } +VL : vlbrace { () } VR :: { () } -VR : vrbrace { undefined } - | error { undefined } +VR : vrbrace { () } + | error { () } -Decls :: { [Decl RlpcPs] } -Decls : Decl ';' Decls { undefined } - | Decl ';' { undefined } - | Decl { undefined } - -DeclsV :: { [Decl RlpcPs] } -DeclsV : Decl VS DeclsV { undefined } - | Decl VS { undefined } - | Decl { undefined } - -VS :: { Located RlpToken } -VS : ';' { undefined } - | vsemi { undefined } +VS :: { () } +VS : ';' { () } + | vsemi { () } Decl :: { Decl RlpcPs } : FunDecl { undefined } @@ -148,7 +137,7 @@ TypeApp :: { Ty RlpcPs } | TypeApp Type1 { undefined } FunDecl :: { Decl RlpcPs } -FunDecl : Var Params '=' Expr { undefined } +FunDecl : Var Params '=' Expr { FunD $1 $2 $4 Nothing } Params :: { [Pat RlpcPs] } Params : {- epsilon -} { undefined } @@ -199,21 +188,21 @@ Alt :: { Alt RlpcPs } : Pat '->' Expr { undefined } -- layout0(p : β) :: [β] -layout0(p) : '{' layout_list0(';',p) '}' { undefined } - | VL layout_list0(VS,p) VR { undefined } +layout0(p) : '{' layout_list0(';',p) '}' { $2 } + | VL layout_list0(VS,p) VR { $2 } -- layout_list0(sep : α, p : β) :: [β] -layout_list0(sep,p) : p { undefined } - | layout_list1(sep,p) sep p { undefined } - | {- epsilon -} { undefined } +layout_list0(sep,p) : p { [$1] } + | layout_list1(sep,p) sep p { $1 `snoc` $3 } + | {- epsilon -} { [] } -- layout1(p : β) :: [β] -layout1(p) : '{' layout_list1(';',p) '}' { undefined } - | VL layout_list1(VS,p) VR { undefined } +layout1(p) : '{' layout_list1(';',p) '}' { $2 } + | VL layout_list1(VS,p) VR { $2 } -- layout_list1(sep : α, p : β) :: [β] -layout_list1(sep,p) : p { undefined } - | layout_list1(sep,p) sep p { undefined } +layout_list1(sep,p) : p { [$1] } + | layout_list1(sep,p) sep p { $1 `snoc` $3 } Binding :: { Binding RlpcPs } : Pat '=' Expr { undefined } @@ -230,17 +219,17 @@ InfixOp :: { Located PsName } -- TODO: microlens-pro save me microlens-pro (rewrite this with prisms) Lit :: { Lit RlpcPs } - : litint { undefined } + : litint { $1 ^. to extract + . singular _TokenLitInt + . to IntL } -Var :: { Located PsName } +Var :: { PsName } Var : varname { undefined } | varsym { undefined } -Con :: { Located PsName } +Con :: { PsName } : conname { undefined } ---} - { parseRlpProgR = undefined diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index c449aea..10a5fd9 100644 --- a/src/Rlp/Parse/Types.hs +++ b/src/Rlp/Parse/Types.hs @@ -17,7 +17,7 @@ module Rlp.Parse.Types , RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction , Located(..), PsName -- ** Lenses - , aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn + , _TokenLitInt, aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn -- * Error handling , MsgEnvelope(..), RlpcError(..), RlpParseError(..) @@ -53,7 +53,7 @@ data RlpcPs type instance NameP RlpcPs = PsName -type PsName = Text +type PsName = Located Text -------------------------------------------------------------------------------- @@ -125,6 +125,11 @@ data RlpToken | TokenEOF deriving (Show) +_TokenLitInt :: Prism' RlpToken Int +_TokenLitInt = prism TokenLitInt $ \case + TokenLitInt n -> Right n + x -> Left x + newtype P a = P { runP :: ParseState -> (ParseState, [MsgEnvelope RlpParseError], Maybe a) diff --git a/src/Rlp/Syntax.hs b/src/Rlp/Syntax.hs index fb9f2c0..9a4676b 100644 --- a/src/Rlp/Syntax.hs +++ b/src/Rlp/Syntax.hs @@ -40,12 +40,11 @@ import Control.Comonad.Cofree import Data.Functor.Foldable import Data.Functor.Foldable.TH (makeBaseFunctor) -import Compiler.Types (SrcSpan(..)) +import Compiler.Types (SrcSpan(..), Located(..)) import Core.Syntax qualified as Core import Core (Rec(..), HasRHS(..), HasLHS(..)) ---------------------------------------------------------------------------------- -type PsName = Text type family NameP p data Program p = Program From 9297d815d68bc2f108345269778b806d43da6947 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Fri, 16 Feb 2024 18:23:02 -0700 Subject: [PATCH 05/10] something --- src/Compiler/Types.hs | 1 + src/Rlp/Parse.y | 43 ++++++++++++++++++++++++------------------- src/Rlp/Syntax.hs | 3 ++- 3 files changed, 27 insertions(+), 20 deletions(-) diff --git a/src/Compiler/Types.hs b/src/Compiler/Types.hs index aeb5eef..4d66da1 100644 --- a/src/Compiler/Types.hs +++ b/src/Compiler/Types.hs @@ -5,6 +5,7 @@ module Compiler.Types ( SrcSpan(..) , srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen , Located(..) + , GetLocation(srcspan) , HasLocation(location) , _Located , nolo diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index ec61798..a4e6b91 100644 --- a/src/Rlp/Parse.y +++ b/src/Rlp/Parse.y @@ -98,12 +98,12 @@ TySigDecl :: { Decl RlpcPs } : Var '::' Type { undefined } InfixDecl :: { Decl RlpcPs } - : InfixWord litint InfixOp { undefined } + : InfixWord litint InfixOp { mkInfixD $1 ($2 ^. _litint) $3 } InfixWord :: { Located Assoc } - : infixl { undefined } - | infixr { undefined } - | infix { undefined } + : infixl { $1 \$> InfixL } + | infixr { $1 \$> InfixR } + | infix { $1 \$> Infix } DataDecl :: { Decl RlpcPs } : data Con TyParams '=' DataCons { undefined } @@ -213,7 +213,7 @@ Expr1 :: { Expr RlpcPs } | Var { undefined } | Con { undefined } -InfixOp :: { Located PsName } +InfixOp :: { PsName } : consym { undefined } | varsym { undefined } @@ -234,7 +234,20 @@ Con :: { PsName } parseRlpProgR = undefined parseRlpExprR = undefined - + +mkInfixD :: Assoc -> Int -> PsName -> P (Decl RlpcPs) +mkInfixD a p ln@(Located ss n) = do + let opl :: Lens' ParseState (Maybe OpInfo) + opl = psOpTable . at n + opl <~ (use opl >>= \case + Just o -> addWoundHere l e >> pure (Just o) where + e = RlpParErrDuplicateInfixD n + l = T.length n + Nothing -> pure (Just (a,p)) + ) + pos <- use (psInput . aiPos) + pure $ InfixD a p ln + {-- parseRlpExprR :: (Monad m) => Text -> RLPCT m (Expr RlpcPs) @@ -270,19 +283,6 @@ mkProgram ds = do pt <- use psOpTable pure $ Program (associate pt <$> ds) -mkInfixD :: Assoc -> Int -> PsName -> P (Decl RlpcPs) -mkInfixD a p n = do - let opl :: Lens' ParseState (Maybe OpInfo) - opl = psOpTable . at n - opl <~ (use opl >>= \case - Just o -> addWoundHere l e >> pure (Just o) where - e = RlpParErrDuplicateInfixD n - l = T.length n - Nothing -> pure (Just (a,p)) - ) - pos <- use (psInput . aiPos) - pure $ Located (spanFromPos pos 0) (InfixD a p n) - intOfToken :: Located RlpToken -> Int intOfToken (Located _ (TokenLitInt n)) = n @@ -295,6 +295,11 @@ tempInfixExprErr (Located a _) (Located b _) = --} +_litint :: Getter (Located RlpToken) Int +_litint = to extract + . singular _TokenLitInt + . to IntL + mkPsName = undefined tempInfixExprErr = undefined extractName = undefined diff --git a/src/Rlp/Syntax.hs b/src/Rlp/Syntax.hs index 9a4676b..0e0870e 100644 --- a/src/Rlp/Syntax.hs +++ b/src/Rlp/Syntax.hs @@ -13,7 +13,7 @@ module Rlp.Syntax , Expr(..), Expr', ExprF(..) , Lit(..) , Pat(..) - , Decl(..) + , Decl(..), Decl' , Program(..) , Where @@ -121,4 +121,5 @@ makeBaseFunctor ''Expr makeLenses ''Program type Expr' p = Cofree (ExprF p) +type Decl' p = Cofree (Const (Decl p)) From 820bd7cdbc13e78d39904eef5334b9091bd14827 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Sat, 17 Feb 2024 01:56:29 -0700 Subject: [PATCH 06/10] backstage --- rlp.cabal | 2 + src/Rlp/Parse.y | 41 ++++++------ src/Rlp/Parse/Associate.hs | 2 +- src/Rlp/Parse/Types.hs | 2 + src/Rlp/Syntax.hs | 125 ++--------------------------------- src/Rlp/Syntax/Backstage.hs | 24 +++++++ src/Rlp/Syntax/Types.hs | 126 ++++++++++++++++++++++++++++++++++++ 7 files changed, 180 insertions(+), 142 deletions(-) create mode 100644 src/Rlp/Syntax/Backstage.hs create mode 100644 src/Rlp/Syntax/Types.hs diff --git a/rlp.cabal b/rlp.cabal index d0e2b76..7b67721 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -32,6 +32,8 @@ library , Core.HindleyMilner , Control.Monad.Errorful , Rlp.Syntax + , Rlp.Syntax.Backstage + , Rlp.Syntax.Types -- , Rlp.Parse.Decls , Rlp.Parse , Rlp.Parse.Associate diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index a4e6b91..6546667 100644 --- a/src/Rlp/Parse.y +++ b/src/Rlp/Parse.y @@ -71,11 +71,11 @@ import Compiler.Types %% -StandaloneProgram :: { Program RlpcPs } +StandaloneProgram :: { Program RlpcPs SrcSpan } StandaloneProgram : layout0(Decl) { Program $1 } StandaloneExpr :: { Expr RlpcPs } - : VL Expr VR { $2 } + : VL Expr VR { undefined } VL :: { () } VL : vlbrace { () } @@ -88,24 +88,24 @@ VS :: { () } VS : ';' { () } | vsemi { () } -Decl :: { Decl RlpcPs } - : FunDecl { undefined } - | TySigDecl { undefined } - | DataDecl { undefined } - | InfixDecl { undefined } +Decl :: { Decl RlpcPs SrcSpan } + : FunDecl { $1 } + | TySigDecl { $1 } + | DataDecl { $1 } + | InfixDecl { $1 } -TySigDecl :: { Decl RlpcPs } - : Var '::' Type { undefined } +TySigDecl :: { Decl RlpcPs SrcSpan } + : Var '::' Type { TySigD [$1] $3 } -InfixDecl :: { Decl RlpcPs } - : InfixWord litint InfixOp { mkInfixD $1 ($2 ^. _litint) $3 } +InfixDecl :: { Decl RlpcPs SrcSpan } + : InfixWord litint InfixOp {% mkInfixD $1 ($2 ^. _litint) $3 } -InfixWord :: { Located Assoc } - : infixl { $1 \$> InfixL } - | infixr { $1 \$> InfixR } - | infix { $1 \$> Infix } +InfixWord :: { Assoc } + : infixl { InfixL } + | infixr { InfixR } + | infix { Infix } -DataDecl :: { Decl RlpcPs } +DataDecl :: { Decl RlpcPs SrcSpan } : data Con TyParams '=' DataCons { undefined } TyParams :: { [PsName] } @@ -136,7 +136,7 @@ TypeApp :: { Ty RlpcPs } : Type1 { undefined } | TypeApp Type1 { undefined } -FunDecl :: { Decl RlpcPs } +FunDecl :: { Decl RlpcPs SrcSpan } FunDecl : Var Params '=' Expr { FunD $1 $2 $4 Nothing } Params :: { [Pat RlpcPs] } @@ -157,7 +157,7 @@ Pat1 :: { Pat RlpcPs } | Lit { undefined } | '(' Pat ')' { undefined } -Expr :: { Expr RlpcPs } +Expr :: { Expr' RlpcPs SrcSpan } -- infixities delayed till next release :( -- : Expr1 InfixOp Expr { undefined } : TempInfixExpr { undefined } @@ -235,7 +235,7 @@ Con :: { PsName } parseRlpProgR = undefined parseRlpExprR = undefined -mkInfixD :: Assoc -> Int -> PsName -> P (Decl RlpcPs) +mkInfixD :: Assoc -> Int -> PsName -> P (Decl RlpcPs SrcSpan) mkInfixD a p ln@(Located ss n) = do let opl :: Lens' ParseState (Maybe OpInfo) opl = psOpTable . at n @@ -278,7 +278,7 @@ extractInt :: RlpToken -> Int extractInt (TokenLitInt n) = n extractInt _ = error "extractInt: ugh" -mkProgram :: [Decl RlpcPs] -> P (Program RlpcPs) +mkProgram :: [Decl RlpcPs SrcSpan] -> P (Program RlpcPs SrcSpan) mkProgram ds = do pt <- use psOpTable pure $ Program (associate pt <$> ds) @@ -298,7 +298,6 @@ tempInfixExprErr (Located a _) (Located b _) = _litint :: Getter (Located RlpToken) Int _litint = to extract . singular _TokenLitInt - . to IntL mkPsName = undefined tempInfixExprErr = undefined diff --git a/src/Rlp/Parse/Associate.hs b/src/Rlp/Parse/Associate.hs index d4d13e4..efdb091 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 a -> Decl RlpcPs a associate _ p = p {-# WARNING associate "unimplemented" #-} diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index 10a5fd9..76a5440 100644 --- a/src/Rlp/Parse/Types.hs +++ b/src/Rlp/Parse/Types.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE UndecidableInstances #-} module Rlp.Parse.Types ( -- * Trees That Grow @@ -26,6 +27,7 @@ module Rlp.Parse.Types where -------------------------------------------------------------------------------- import Core.Syntax (Name) +import Text.Show.Deriving import Control.Monad import Control.Monad.State.Strict import Control.Monad.Errorful diff --git a/src/Rlp/Syntax.hs b/src/Rlp/Syntax.hs index 0e0870e..bbf0160 100644 --- a/src/Rlp/Syntax.hs +++ b/src/Rlp/Syntax.hs @@ -1,125 +1,10 @@ --- recursion-schemes -{-# LANGUAGE DeriveTraversable, TemplateHaskell, TypeFamilies #-} -{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-} -{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-} module Rlp.Syntax - ( - NameP - , Assoc(..) - , ConAlt(..) - , Alt(..) - , Ty(..) - , Binding(..) - , Expr(..), Expr', ExprF(..) - , Lit(..) - , Pat(..) - , Decl(..), Decl' - , Program(..) - , Where - - -- * Re-exports - , Cofree(..) - , Trans.Cofree.CofreeF - , pattern (:<$) - , SrcSpan(..) + ( module Rlp.Syntax.Backstage + , module Rlp.Syntax.Types ) where ----------------------------------------------------------------------------------- -import Data.Text (Text) -import Data.Text qualified as T -import Data.String (IsString(..)) -import Data.Functor.Classes -import Data.Functor.Identity -import Data.Kind (Type) -import GHC.Generics -import Language.Haskell.TH.Syntax (Lift) -import Control.Lens - -import Control.Comonad.Trans.Cofree qualified as Trans.Cofree -import Control.Comonad.Cofree -import Data.Functor.Foldable -import Data.Functor.Foldable.TH (makeBaseFunctor) - -import Compiler.Types (SrcSpan(..), Located(..)) -import Core.Syntax qualified as Core -import Core (Rec(..), HasRHS(..), HasLHS(..)) ----------------------------------------------------------------------------------- - -type family NameP p - -data Program p = Program - { _programDecls :: [Decl p] - } - -deriving instance (Show (NameP p)) => Show (Program 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) - -deriving instance (Lift (NameP p)) => Lift (Decl p) -deriving instance (Show (NameP p)) => Show (Decl 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 ConAlt p = ConAlt (NameP p) [Ty p] - -deriving instance (Lift (NameP p)) => Lift (ConAlt p) -deriving instance (Show (NameP p)) => Show (ConAlt p) - -data Ty p = TyCon (NameP p) - -deriving instance (Show (NameP p)) => Show (Ty p) -deriving instance (Lift (NameP p)) => Lift (Ty p) - -data Pat p = VarP (NameP p) - | LitP (Lit p) - | ConP (NameP p) [Pat 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) - -pattern (:<$) :: a -> f b -> Trans.Cofree.CofreeF f a b -pattern a :<$ b = a Trans.Cofree.:< b - +-------------------------------------------------------------------------------- +import Rlp.Syntax.Backstage +import Rlp.Syntax.Types -------------------------------------------------------------------------------- -makeBaseFunctor ''Expr -makeLenses ''Program - -type Expr' p = Cofree (ExprF p) -type Decl' p = Cofree (Const (Decl p)) - diff --git a/src/Rlp/Syntax/Backstage.hs b/src/Rlp/Syntax/Backstage.hs new file mode 100644 index 0000000..ee7fc51 --- /dev/null +++ b/src/Rlp/Syntax/Backstage.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +module Rlp.Syntax.Backstage + ( + ) + where +-------------------------------------------------------------------------------- +import Data.Functor.Classes +import Rlp.Syntax.Types +import Text.Show.Deriving +import Language.Haskell.TH.Syntax (Lift) +-------------------------------------------------------------------------------- + +-- oprhan instances because TH + +instance (Show (NameP p)) => Show1 (ExprF p) where + liftShowsPrec = $(makeLiftShowsPrec ''ExprF) + +deriving instance (Lift (NameP p), Lift a) => Lift (Expr' p a) +deriving instance (Lift (NameP p), Lift a) => Lift (Decl p a) +deriving instance (Show (NameP p), Show a) => Show (Decl p a) + +deriving instance (Show (NameP p), Show a) => Show (Program p a) + diff --git a/src/Rlp/Syntax/Types.hs b/src/Rlp/Syntax/Types.hs new file mode 100644 index 0000000..ae908c4 --- /dev/null +++ b/src/Rlp/Syntax/Types.hs @@ -0,0 +1,126 @@ +-- recursion-schemes +{-# LANGUAGE DeriveTraversable, TemplateHaskell, TypeFamilies #-} +{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-} +module Rlp.Syntax.Types + ( + NameP + , Assoc(..) + , ConAlt(..) + , Alt(..) + , Ty(..) + , Binding(..) + , Expr(..), Expr', ExprF(..) + , Lit(..) + , Pat(..) + , Decl(..) + , Program(..) + , Where + + -- * Re-exports + , Cofree(..) + , Trans.Cofree.CofreeF + , pattern (:<$) + , SrcSpan(..) + ) + where +---------------------------------------------------------------------------------- +import Data.Text (Text) +import Data.Text qualified as T +import Data.String (IsString(..)) +import Data.Functor.Classes +import Data.Functor.Identity +import Data.Functor.Compose +import Data.Fix +import Data.Kind (Type) +import GHC.Generics +import Language.Haskell.TH.Syntax (Lift) +import Control.Lens + +import Control.Comonad.Trans.Cofree qualified as Trans.Cofree +import Control.Comonad.Cofree +import Data.Functor.Foldable +import Data.Functor.Foldable.TH (makeBaseFunctor) + +import Compiler.Types (SrcSpan(..), Located(..)) +import Core.Syntax qualified as Core +import Core (Rec(..), HasRHS(..), HasLHS(..)) +---------------------------------------------------------------------------------- + +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 ConAlt p = ConAlt (NameP p) [Ty p] + +deriving instance (Lift (NameP p)) => Lift (ConAlt p) +deriving instance (Show (NameP p)) => Show (ConAlt p) + +data Ty p = TyCon (NameP p) + +deriving instance (Show (NameP p)) => Show (Ty p) +deriving instance (Lift (NameP p)) => Lift (Ty p) + +data Pat p = VarP (NameP p) + | LitP (Lit p) + | ConP (NameP p) [Pat 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) + +pattern (:<$) :: a -> f b -> Trans.Cofree.CofreeF f a b +pattern a :<$ b = a Trans.Cofree.:< b + +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 Program p a = Program + { _programDecls :: [Decl p a] + } + +data Decl p a = FunD (NameP p) [Pat p] (Expr' p a) (Maybe (Where p)) + | TySigD [NameP p] (Ty p) + | DataD (NameP p) [NameP p] [ConAlt p] + | InfixD Assoc Int (NameP p) + +type Expr' p = Cofree (ExprF p) + +makeLenses ''Program + + From 66c3d878c2b13cd2093361bd2cd76acce24cf71f Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Tue, 20 Feb 2024 11:10:33 -0700 Subject: [PATCH 07/10] i want to fucking die --- src/Compiler/Types.hs | 169 +++++++++++++++++++++++++++++------- src/Rlp/Lex.x | 13 +-- src/Rlp/Parse.y | 91 ++++++++++--------- src/Rlp/Parse/Types.hs | 32 +++++-- src/Rlp/Syntax/Backstage.hs | 10 ++- src/Rlp/Syntax/Types.hs | 23 +++-- 6 files changed, 248 insertions(+), 90 deletions(-) diff --git a/src/Compiler/Types.hs b/src/Compiler/Types.hs index 4d66da1..58be658 100644 --- a/src/Compiler/Types.hs +++ b/src/Compiler/Types.hs @@ -1,19 +1,23 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances, QuantifiedConstraints #-} +{-# LANGUAGE PatternSynonyms #-} module Compiler.Types ( SrcSpan(..) , srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen + , pattern (:<$) , Located(..) - , GetLocation(srcspan) - , HasLocation(location) + , HasLocation(..) , _Located - , nolo + , nolo, nolo' - , (<~>), (~>) + , (<~>), (~>), (~~>), (<~~) + + , comb2, comb3, comb4 + , lochead -- * Re-exports - , Comonad + , Comonad(extract) , Apply , Bind ) @@ -23,35 +27,56 @@ import Language.Haskell.TH.Syntax (Lift) import Control.Comonad import Control.Comonad.Cofree +import Control.Comonad.Trans.Cofree qualified as Trans.Cofree +import Control.Comonad.Trans.Cofree (CofreeF) import Data.Functor.Apply import Data.Functor.Bind +import Data.Functor.Compose +import Data.Functor.Foldable import Data.Semigroup.Foldable +import Data.Fix hiding (cata, ana) import Data.Kind -import Control.Lens hiding ((<<~)) +import Control.Lens hiding ((<<~), (:<)) import Data.List.NonEmpty (NonEmpty) +import Data.Function (on) -------------------------------------------------------------------------------- -- | Token wrapped with a span (line, column, absolute, length) data Located a = Located SrcSpan a deriving (Show, Lift, Functor) -class GetLocation s where - srcspan :: s -> SrcSpan +data Floc f = Floc SrcSpan (f (Floc f)) -class HasLocation s where - location :: Lens' s SrcSpan +pattern (:<$) :: a -> f b -> Trans.Cofree.CofreeF f a b +pattern a :<$ b = a Trans.Cofree.:< b (<~>) :: a -> b -> SrcSpan (<~>) = undefined infixl 5 <~> -(~>) :: a -> b -> b +-- (~>) :: (CanGet k, CanSet k', HasLocation k a, HasLocation k' b) +-- => a -> b -> b +-- a ~> b = (~>) = undefined infixl 4 ~> +-- (~~>) :: (CanGet k, HasLocation k a, CanSet k', HasLocation k' b) +-- => (a -> b) -> a -> b +-- (~~>) :: (f SrcSpan -> b) -> Cofree f SrcSpan -> Cofree f SrcSpan +-- f ~~> (ss :< as) = ss :< f as +(~~>) = undefined + +infixl 3 ~~> + +-- (<~~) :: (GetLocation a, HasLocation b) => (a -> b) -> a -> b +-- a <~~ b = a b & location <>~ srcspan b +(<~~) = undefined + +infixr 2 <~~ + instance Apply Located where liftF2 f (Located sa p) (Located sb q) = Located (sa <> sb) (p `f` q) @@ -86,6 +111,9 @@ srcSpanLen = tupling . _4 nolo :: a -> Located a nolo = Located (SrcSpan 0 0 0 0) +nolo' :: f (Cofree f SrcSpan) -> Cofree f SrcSpan +nolo' as = SrcSpan 0 0 0 0 :< as + instance Semigroup SrcSpan where -- multiple identities? what are the consequences of this...? SrcSpan _ _ _ 0 <> SrcSpan l c a s = SrcSpan l c a s @@ -100,24 +128,103 @@ instance Semigroup SrcSpan where LT -> max sa (ab + sb - aa) GT -> max sb (aa + sa - ab) +-------------------------------------------------------------------------------- + +data GetOrSet = Get | Set | GetSet + +class CanGet (k :: GetOrSet) +class CanSet (k :: GetOrSet) where + +instance CanGet Get +instance CanGet GetSet +instance CanSet Set +instance CanSet GetSet + +data GetSetLens (k :: GetOrSet) s t a b :: Type where + Getter_ :: (s -> a) -> GetSetLens Get s t a b + Setter_ :: ((a -> b) -> s -> t) -> GetSetLens Set s t a b + GetterSetter :: (CanGet k', CanSet k') + => (s -> a) -> (s -> b -> t) -> GetSetLens k' s t a b + +type GetSetLens' k s a = GetSetLens k s s a a + +class HasLocation k s | s -> k where + -- location :: (Access k f, Functor f) => LensLike' f s SrcSpan + getSetLocation :: GetSetLens' k s SrcSpan + +type family Access (k :: GetOrSet) f where + Access GetSet f = Functor f + Access Set f = Settable f + Access Get f = (Functor f, Contravariant f) + +instance HasLocation GetSet SrcSpan where + getSetLocation = GetterSetter id (flip const) + -- location = fromGetSetLens getSetLocation + +instance (CanSet k, HasLocation k a) => HasLocation Set (r -> a) where + getSetLocation = Setter_ $ \ss ra r -> ra r & fromSet getSetLocation %~ ss + -- location = fromSet getSetLocation + +instance (HasLocation k a) => HasLocation k (Cofree f a) where + getSetLocation = case getSetLocation @_ @a of + Getter_ sa -> Getter_ $ \ (s :< _) -> sa s + Setter_ abst -> Setter_ $ \ss (s :< as) -> abst ss s :< as + GetterSetter sa sbt -> GetterSetter sa' sbt' where + sa' (s :< _) = sa s + sbt' (s :< as) b = sbt s b :< as + +location :: (Access k f, Functor f, HasLocation k s) + => LensLike' f s SrcSpan +location = fromGetSetLens getSetLocation + +fromGetSetLens :: (Access k f, Functor f) => GetSetLens' k s a -> LensLike' f s a +fromGetSetLens gsl = case gsl of + Getter_ sa -> to sa + Setter_ abst -> setting abst + GetterSetter sa sbt -> lens sa sbt + +fromGet :: (CanGet k) => GetSetLens k s t a b -> Getter s a +fromGet (Getter_ sa) = to sa +fromGet (GetterSetter sa _) = to sa + +fromSet :: (CanSet k) => GetSetLens k s t a b -> Setter s t a b +fromSet (Setter_ abst) = setting abst +fromSet (GetterSetter sa sbt) = lens sa sbt + +fromGetSet :: (CanGet k, CanSet k) => GetSetLens k s t a b -> Lens s t a b +fromGetSet (GetterSetter sa sbt) = lens sa sbt + +-------------------------------------------------------------------------------- + +comb2 :: (Functor f, Semigroup m) + => (Cofree f m -> Cofree f m -> f (Cofree f m)) + -> Cofree f m -> Cofree f m -> Cofree f m +comb2 f a b = ss :< f a b + where ss = a `mextract` b + +comb3 :: (Functor f, Semigroup m) + => (Cofree f m -> Cofree f m -> Cofree f m -> f (Cofree f m)) + -> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m +comb3 f a b c = ss :< f a b c + where ss = a `mapply` b `mextract` c + +comb4 :: (Functor f, Semigroup m) + => (Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m + -> f (Cofree f m)) + -> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m +comb4 f a b c d = ss :< f a b c d + where ss = a `mapply` b `mapply` c `mextract` d + +mextract :: (Comonad w, Semigroup m) => w m -> w m -> m +mextract = (<>) `on` extract + +mapply :: (Comonad w, Semigroup m) => w m -> w m -> w m +mapply a b = b <&> (<> extract a) + +lochead :: Functor f + => (f SrcSpan -> f SrcSpan) -> Located (f SrcSpan) -> Cofree f SrcSpan +lochead afs (Located ss fss) = ss :< unwrap (lochead afs $ Located ss fss) + +-------------------------------------------------------------------------------- + makePrisms ''Located - --------------------------------------------------------------------------------- - -instance (GetLocation a) => GetLocation (NonEmpty a) where - srcspan = foldMap1 srcspan - -instance GetLocation SrcSpan where - srcspan = id - -instance (Functor f) => GetLocation (Cofree f SrcSpan) where - srcspan = extract - --------------------------------------------------------------------------------- - -instance HasLocation SrcSpan where - location = id - -instance (Functor f) => HasLocation (Cofree f SrcSpan) where - location = _extract - diff --git a/src/Rlp/Lex.x b/src/Rlp/Lex.x index ed12fcc..93cac61 100644 --- a/src/Rlp/Lex.x +++ b/src/Rlp/Lex.x @@ -8,6 +8,7 @@ module Rlp.Lex , Located(..) , lexToken , lexStream + , lexStream' , lexDebug , lexCont , popLexState @@ -29,6 +30,7 @@ import Data.Word import Data.Default import Control.Lens +import Compiler.Types import Debug.Trace import Rlp.Parse.Types } @@ -274,11 +276,12 @@ lexCont :: (Located RlpToken -> P a) -> P a lexCont = (lexToken >>=) lexStream :: P [RlpToken] -lexStream = do - t <- lexToken - case t of - Located _ TokenEOF -> pure [TokenEOF] - Located _ t -> (t:) <$> lexStream +lexStream = fmap extract <$> lexStream' + +lexStream' :: P [Located RlpToken] +lexStream' = lexToken >>= \case + t@(Located _ TokenEOF) -> pure [t] + t -> (t:) <$> lexStream' lexDebug :: (Located RlpToken -> P a) -> P a lexDebug k = do diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index 6546667..b14763c 100644 --- a/src/Rlp/Parse.y +++ b/src/Rlp/Parse.y @@ -5,15 +5,17 @@ module Rlp.Parse , parseRlpProgR , parseRlpExpr , parseRlpExprR + , runP' ) where import Compiler.RlpcError import Compiler.RLPC +import Control.Comonad.Cofree import Rlp.Lex import Rlp.Syntax import Rlp.Parse.Types import Rlp.Parse.Associate -import Control.Lens hiding (snoc, (.>), (<.), (<<~)) +import Control.Lens hiding (snoc, (.>), (<.), (<<~), (:<)) import Data.List.Extra import Data.Fix import Data.Functor.Const @@ -74,8 +76,8 @@ import Compiler.Types StandaloneProgram :: { Program RlpcPs SrcSpan } StandaloneProgram : layout0(Decl) { Program $1 } -StandaloneExpr :: { Expr RlpcPs } - : VL Expr VR { undefined } +StandaloneExpr :: { Expr' RlpcPs SrcSpan } + : VL Expr VR { $2 } VL :: { () } VL : vlbrace { () } @@ -106,45 +108,45 @@ InfixWord :: { Assoc } | infix { Infix } DataDecl :: { Decl RlpcPs SrcSpan } - : data Con TyParams '=' DataCons { undefined } + : data Con TyParams '=' DataCons { DataD $2 $3 $5 } TyParams :: { [PsName] } - : {- epsilon -} { undefined } - | TyParams varname { undefined } + : {- epsilon -} { [] } + | TyParams varname { $1 `snoc` extractName $2 } DataCons :: { [ConAlt RlpcPs] } - : DataCons '|' DataCon { undefined } - | DataCon { undefined } + : DataCons '|' DataCon { $1 `snoc` $3 } + | DataCon { [$1] } DataCon :: { ConAlt RlpcPs } - : Con Type1s { undefined } + : Con Type1s { ConAlt $1 $2 } Type1s :: { [Ty RlpcPs] } - : {- epsilon -} { undefined } - | Type1s Type1 { undefined } + : {- epsilon -} { [] } + | Type1s Type1 { $1 `snoc` $2 } Type1 :: { Ty RlpcPs } - : '(' Type ')' { undefined } - | conname { undefined } - | varname { undefined } + : '(' Type ')' { $2 } + | conname { ConT (extractName $1) } + | varname { VarT (extractName $1) } Type :: { Ty RlpcPs } - : Type '->' Type { undefined } - | TypeApp { undefined } + : Type '->' Type { FunT $1 $3 } + | TypeApp { $1 } TypeApp :: { Ty RlpcPs } - : Type1 { undefined } - | TypeApp Type1 { undefined } + : Type1 { $1 } + | TypeApp Type1 { AppT $1 $2 } FunDecl :: { Decl RlpcPs SrcSpan } FunDecl : Var Params '=' Expr { FunD $1 $2 $4 Nothing } Params :: { [Pat RlpcPs] } -Params : {- epsilon -} { undefined } - | Params Pat1 { undefined } +Params : {- epsilon -} { [] } + | Params Pat1 { $1 `snoc` $2 } Pat :: { Pat RlpcPs } - : Con Pat1s { undefined } + : Con Pat1s { $1 } | Pat1 { undefined } Pat1s :: { [Pat RlpcPs] } @@ -160,18 +162,18 @@ Pat1 :: { Pat RlpcPs } Expr :: { Expr' RlpcPs SrcSpan } -- infixities delayed till next release :( -- : Expr1 InfixOp Expr { undefined } - : TempInfixExpr { undefined } - | LetExpr { undefined } - | CaseExpr { undefined } - | AppExpr { undefined } + : AppExpr { $1 } + -- | TempInfixExpr { undefined } + -- | LetExpr { undefined } + -- | CaseExpr { undefined } -TempInfixExpr :: { Expr RlpcPs } +TempInfixExpr :: { Expr' RlpcPs SrcSpan } TempInfixExpr : Expr1 InfixOp TempInfixExpr { undefined } - | Expr1 InfixOp Expr1 { undefined } + | Expr1 InfixOp Expr1 { undefined } -AppExpr :: { Expr RlpcPs } - : Expr1 { undefined } - | AppExpr Expr1 { undefined } +AppExpr :: { Expr' RlpcPs SrcSpan } + : Expr1 { $1 } + | AppExpr Expr1 { comb2 AppEF $1 $2 } LetExpr :: { Expr RlpcPs } : let layout1(Binding) in Expr { undefined } @@ -205,17 +207,17 @@ layout_list1(sep,p) : p { [$1] } | layout_list1(sep,p) sep p { $1 `snoc` $3 } Binding :: { Binding RlpcPs } - : Pat '=' Expr { undefined } + : Pat '=' Expr { PatB $1 (collapse . strip $ $3) } -Expr1 :: { Expr RlpcPs } - : '(' Expr ')' { undefined } - | Lit { undefined } - | Var { undefined } - | Con { undefined } +Expr1 :: { Expr' RlpcPs SrcSpan } + : '(' Expr ')' { $2 } + | Lit { nolo' $ LitEF $1 } + | Var { case $1 of Located ss _ -> ss :< VarEF $1 } + | Con { case $1 of Located ss _ -> ss :< VarEF $1 } InfixOp :: { PsName } - : consym { undefined } - | varsym { undefined } + : consym { extractName $1 } + | varsym { extractName $1 } -- TODO: microlens-pro save me microlens-pro (rewrite this with prisms) Lit :: { Lit RlpcPs } @@ -224,11 +226,11 @@ Lit :: { Lit RlpcPs } . to IntL } Var :: { PsName } -Var : varname { undefined } - | varsym { undefined } +Var : varname { $1 <&> view (singular _TokenVarName) } + | varsym { $1 <&> view (singular _TokenVarSym) } Con :: { PsName } - : conname { undefined } + : conname { $1 <&> view (singular _TokenConName) } { @@ -301,10 +303,15 @@ _litint = to extract mkPsName = undefined tempInfixExprErr = undefined -extractName = undefined extractInt = undefined mkProgram = undefined +extractName :: Located RlpToken -> PsName +extractName (Located ss (TokenVarSym n)) = Located ss n +extractName (Located ss (TokenVarName n)) = Located ss n +extractName (Located ss (TokenConName n)) = Located ss n +extractName (Located ss (TokenConSym n)) = Located ss n + parseError :: (Located RlpToken, [String]) -> P a parseError ((Located ss t), exp) = addFatal $ errorMsg ss (RlpParErrUnexpectedToken t exp) diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index 76a5440..20c9c99 100644 --- a/src/Rlp/Parse/Types.hs +++ b/src/Rlp/Parse/Types.hs @@ -18,7 +18,8 @@ module Rlp.Parse.Types , RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction , Located(..), PsName -- ** Lenses - , _TokenLitInt, aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn + , _TokenLitInt, _TokenVarName, _TokenConName, _TokenVarSym + , aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn -- * Error handling , MsgEnvelope(..), RlpcError(..), RlpParseError(..) @@ -93,10 +94,10 @@ data RlpToken -- literals = TokenLitInt Int -- identifiers - | TokenVarName Name - | TokenConName Name - | TokenVarSym Name - | TokenConSym Name + | TokenVarName Text + | TokenConName Text + | TokenVarSym Text + | TokenConSym Text -- reserved words | TokenData | TokenCase @@ -132,6 +133,26 @@ _TokenLitInt = prism TokenLitInt $ \case TokenLitInt n -> Right n x -> Left x +_TokenVarName :: Prism' RlpToken Text +_TokenVarName = prism TokenVarName $ \case + TokenVarName n -> Right n + x -> Left x + +_TokenVarSym :: Prism' RlpToken Text +_TokenVarSym = prism TokenVarSym $ \case + TokenVarSym n -> Right n + x -> Left x + +_TokenConName :: Prism' RlpToken Text +_TokenConName = prism TokenConName $ \case + TokenConName n -> Right n + x -> Left x + +_TokenConSym :: Prism' RlpToken Text +_TokenConSym = prism TokenConSym $ \case + TokenConSym n -> Right n + x -> Left x + newtype P a = P { runP :: ParseState -> (ParseState, [MsgEnvelope RlpParseError], Maybe a) @@ -261,6 +282,7 @@ initAlexInput s = AlexInput -------------------------------------------------------------------------------- + -- deriving instance Lift (Program RlpcPs) -- deriving instance Lift (Decl RlpcPs) -- deriving instance Lift (Pat RlpcPs) diff --git a/src/Rlp/Syntax/Backstage.hs b/src/Rlp/Syntax/Backstage.hs index ee7fc51..ee0b477 100644 --- a/src/Rlp/Syntax/Backstage.hs +++ b/src/Rlp/Syntax/Backstage.hs @@ -1,11 +1,13 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Rlp.Syntax.Backstage - ( + ( strip, collapse ) where -------------------------------------------------------------------------------- +import Data.Fix hiding (cata) import Data.Functor.Classes +import Data.Functor.Foldable import Rlp.Syntax.Types import Text.Show.Deriving import Language.Haskell.TH.Syntax (Lift) @@ -22,3 +24,9 @@ deriving instance (Show (NameP p), Show a) => Show (Decl p a) 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 ae908c4..603c25b 100644 --- a/src/Rlp/Syntax/Types.hs +++ b/src/Rlp/Syntax/Types.hs @@ -5,6 +5,7 @@ module Rlp.Syntax.Types ( NameP + , SimpleP , Assoc(..) , ConAlt(..) , Alt(..) @@ -20,7 +21,6 @@ module Rlp.Syntax.Types -- * Re-exports , Cofree(..) , Trans.Cofree.CofreeF - , pattern (:<$) , SrcSpan(..) ) where @@ -35,7 +35,7 @@ import Data.Fix import Data.Kind (Type) import GHC.Generics import Language.Haskell.TH.Syntax (Lift) -import Control.Lens +import Control.Lens hiding ((:<)) import Control.Comonad.Trans.Cofree qualified as Trans.Cofree import Control.Comonad.Cofree @@ -47,6 +47,10 @@ import Core.Syntax qualified as Core import Core (Rec(..), HasRHS(..), HasLHS(..)) ---------------------------------------------------------------------------------- +data SimpleP + +type instance NameP SimpleP = String + type family NameP p data Expr p = LetE Rec [Binding p] (Expr p) @@ -68,7 +72,10 @@ data ConAlt p = ConAlt (NameP p) [Ty p] deriving instance (Lift (NameP p)) => Lift (ConAlt p) deriving instance (Show (NameP p)) => Show (ConAlt p) -data Ty p = TyCon (NameP p) +data Ty p = ConT (NameP p) + | VarT (NameP p) + | FunT (Ty p) (Ty p) + | AppT (Ty p) (Ty p) deriving instance (Show (NameP p)) => Show (Ty p) deriving instance (Lift (NameP p)) => Lift (Ty p) @@ -100,9 +107,6 @@ type Where p = [Binding p] data Assoc = InfixL | InfixR | Infix deriving (Lift, Show) -pattern (:<$) :: a -> f b -> Trans.Cofree.CofreeF f a b -pattern a :<$ b = a Trans.Cofree.:< b - makeBaseFunctor ''Expr deriving instance (Show (NameP p), Show a) => Show (ExprF p a) @@ -123,4 +127,11 @@ type Expr' p = Cofree (ExprF p) makeLenses ''Program +loccof :: Iso' (Cofree f SrcSpan) (Located (f (Cofree f SrcSpan))) +loccof = iso sa bt where + sa :: Cofree f SrcSpan -> Located (f (Cofree f SrcSpan)) + sa (ss :< as) = Located ss as + + bt :: Located (f (Cofree f SrcSpan)) -> Cofree f SrcSpan + bt (Located ss as) = ss :< as From 13e8701b8ae3c12785bd4e11e16765c6c03b08a5 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Tue, 20 Feb 2024 11:26:35 -0700 Subject: [PATCH 08/10] why did i do this to myself --- src/Rlp/Parse.y | 44 ++++++++++++++++++++--------------------- src/Rlp/Syntax/Types.hs | 1 + 2 files changed, 22 insertions(+), 23 deletions(-) diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index b14763c..3a41ceb 100644 --- a/src/Rlp/Parse.y +++ b/src/Rlp/Parse.y @@ -146,48 +146,46 @@ Params : {- epsilon -} { [] } | Params Pat1 { $1 `snoc` $2 } Pat :: { Pat RlpcPs } - : Con Pat1s { $1 } - | Pat1 { undefined } + : Con Pat1s { ConP $1 $2 } + | Pat1 { $1 } Pat1s :: { [Pat RlpcPs] } - : Pat1s Pat1 { undefined } - | Pat1 { undefined } + : Pat1s Pat1 { $1 `snoc` $2 } + | Pat1 { [$1] } Pat1 :: { Pat RlpcPs } - : Con { undefined } - | Var { undefined } - | Lit { undefined } - | '(' Pat ')' { undefined } + : Con { ConP $1 [] } + | Var { VarP $1 } + | Lit { LitP $1 } + | '(' Pat ')' { $2 } Expr :: { Expr' RlpcPs SrcSpan } -- infixities delayed till next release :( -- : Expr1 InfixOp Expr { undefined } : AppExpr { $1 } - -- | TempInfixExpr { undefined } - -- | LetExpr { undefined } - -- | CaseExpr { undefined } + | TempInfixExpr { $1 } + | LetExpr { $1 } + | CaseExpr { $1 } TempInfixExpr :: { Expr' RlpcPs SrcSpan } -TempInfixExpr : Expr1 InfixOp TempInfixExpr { undefined } - | Expr1 InfixOp Expr1 { undefined } +TempInfixExpr : Expr1 InfixOp TempInfixExpr {% tempInfixExprErr } + | Expr1 InfixOp Expr1 { nolo' $ InfixEF $2 $1 $3 } AppExpr :: { Expr' RlpcPs SrcSpan } : Expr1 { $1 } | AppExpr Expr1 { comb2 AppEF $1 $2 } -LetExpr :: { Expr RlpcPs } - : let layout1(Binding) in Expr { undefined } - | letrec layout1(Binding) in Expr { undefined } +LetExpr :: { Expr' RlpcPs SrcSpan } + : let layout1(Binding) in Expr { nolo' $ LetEF NonRec $2 $4 } + | letrec layout1(Binding) in Expr { nolo' $ LetEF Rec $2 $4 } -CaseExpr :: { Expr RlpcPs } - : case Expr of layout0(CaseAlt) { undefined } +CaseExpr :: { Expr' RlpcPs SrcSpan } + : case Expr of layout0(Alt) { nolo' $ CaseEF $2 $4 } -- TODO: where-binds -CaseAlt :: { (Alt RlpcPs, Where RlpcPs) } - : Alt { undefined } - Alt :: { Alt RlpcPs } - : Pat '->' Expr { undefined } + : Pat '->' Expr { AltA $1 (collapse . strip $ $3) + Nothing } -- layout0(p : β) :: [β] layout0(p) : '{' layout_list0(';',p) '}' { $2 } @@ -234,7 +232,7 @@ Con :: { PsName } { -parseRlpProgR = undefined +parseRlpProgR :: Text -> RLPCT m (Program ) parseRlpExprR = undefined mkInfixD :: Assoc -> Int -> PsName -> P (Decl RlpcPs SrcSpan) diff --git a/src/Rlp/Syntax/Types.hs b/src/Rlp/Syntax/Types.hs index 603c25b..ee09907 100644 --- a/src/Rlp/Syntax/Types.hs +++ b/src/Rlp/Syntax/Types.hs @@ -12,6 +12,7 @@ module Rlp.Syntax.Types , Ty(..) , Binding(..) , Expr(..), Expr', ExprF(..) + , Rec(..) , Lit(..) , Pat(..) , Decl(..) From e63e34a3d81d9c4eda9a5989f5e88cfdc2ecd985 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Tue, 20 Feb 2024 11:52:44 -0700 Subject: [PATCH 09/10] 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) From 09f393af893c1f5f7a8bfe349276c7f6e7399f5a Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Tue, 20 Feb 2024 14:34:42 -0700 Subject: [PATCH 10/10] good enough --- src/Rlp/Parse.y | 40 +++++++++++++++++++++++++++------------- src/Rlp/Syntax/Types.hs | 2 ++ 2 files changed, 29 insertions(+), 13 deletions(-) diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index d706ce4..85103cb 100644 --- a/src/Rlp/Parse.y +++ b/src/Rlp/Parse.y @@ -74,7 +74,7 @@ import Compiler.Types %% StandaloneProgram :: { Program RlpcPs SrcSpan } -StandaloneProgram : layout0(Decl) { Program $1 } +StandaloneProgram : layout0(Decl) {% mkProgram $1 } StandaloneExpr :: { Expr' RlpcPs SrcSpan } : VL Expr VR { $2 } @@ -168,7 +168,7 @@ Expr :: { Expr' RlpcPs SrcSpan } | CaseExpr { $1 } TempInfixExpr :: { Expr' RlpcPs SrcSpan } -TempInfixExpr : Expr1 InfixOp TempInfixExpr {% tempInfixExprErr } +TempInfixExpr : Expr1 InfixOp TempInfixExpr {% tempInfixExprErr $1 $3 } | Expr1 InfixOp Expr1 { nolo' $ InfixEF $2 $1 $3 } AppExpr :: { Expr' RlpcPs SrcSpan } @@ -184,7 +184,7 @@ CaseExpr :: { Expr' RlpcPs SrcSpan } -- TODO: where-binds Alt :: { Alt' RlpcPs SrcSpan } - : Pat '->' Expr { undefined } + : Pat '->' Expr { AltA $1 (view _unwrap $3) Nothing } -- layout0(p : β) :: [β] layout0(p) : '{' layout_list0(';',p) '}' { $2 } @@ -203,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 (Cofree (ExprF RlpcPs) SrcSpan) } - : Pat '=' Expr { undefined } +Binding :: { Binding' RlpcPs SrcSpan } + : Pat '=' Expr { PatB $1 (view _unwrap $3) } Expr1 :: { Expr' RlpcPs SrcSpan } : '(' Expr ')' { $2 } @@ -231,11 +231,18 @@ Con :: { PsName } { -parseRlpProgR :: Text -> RLPCT m (Program RlpcPs SrcSpan) -parseRlpProgR = undefined +parseRlpProgR :: (Monad m) => Text -> RLPCT m (Program RlpcPs SrcSpan) +parseRlpProgR s = do + a <- liftErrorful $ pToErrorful parseRlpProg st + addDebugMsg @_ @String "dump-parsed" $ show a + pure a + where + st = programInitState s -parseRlpExprR :: Text -> RLPCT m (Expr' RlpcPs SrcSpan) -parseRlpExprR = undefined +parseRlpExprR :: (Monad m) => Text -> RLPCT m (Expr' RlpcPs SrcSpan) +parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st + where + st = programInitState s mkInfixD :: Assoc -> Int -> PsName -> P (Decl RlpcPs SrcSpan) mkInfixD a p ln@(Located ss n) = do @@ -301,10 +308,17 @@ _litint :: Getter (Located RlpToken) Int _litint = to extract . singular _TokenLitInt -mkPsName = undefined -tempInfixExprErr = undefined -extractInt = undefined -mkProgram = undefined +tempInfixExprErr :: Expr' RlpcPs SrcSpan -> Expr' RlpcPs SrcSpan -> P a +tempInfixExprErr (a :< _) (b :< _) = + addFatal $ errorMsg (a <> b) $ RlpParErrOther + [ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :(" + , "In the mean time, don't mix any infix operators." + ] + +mkProgram :: [Decl RlpcPs SrcSpan] -> P (Program RlpcPs SrcSpan) +mkProgram ds = do + pt <- use psOpTable + pure $ Program (associate pt <$> ds) extractName :: Located RlpToken -> PsName extractName (Located ss (TokenVarSym n)) = Located ss n diff --git a/src/Rlp/Syntax/Types.hs b/src/Rlp/Syntax/Types.hs index 6d2dea0..1f57f9e 100644 --- a/src/Rlp/Syntax/Types.hs +++ b/src/Rlp/Syntax/Types.hs @@ -127,6 +127,8 @@ data Decl p a = FunD (NameP p) [Pat p] (Expr' p a) (Maybe (Where p a)) | DataD (NameP p) [NameP p] [ConAlt p] | InfixD Assoc Int (NameP p) +type Decl' p a = Decl p (Cofree (ExprF p) a) + type Expr' p = Cofree (ExprF p) makeLenses ''Program