From 7d42f9b64109737b9ebacc867ed845b350ff41f4 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Sun, 28 Jan 2024 17:54:39 -0700 Subject: [PATCH] at long last more no more undefineds --- src/Rlp/Lex.x | 6 +- src/Rlp/Parse.y | 65 ++++++++++++---------- src/Rlp/Parse/Types.hs | 18 ------ src/Rlp/Syntax.hs | 121 +++++++++-------------------------------- 4 files changed, 65 insertions(+), 145 deletions(-) diff --git a/src/Rlp/Lex.x b/src/Rlp/Lex.x index a22a66f..9229b8b 100644 --- a/src/Rlp/Lex.x +++ b/src/Rlp/Lex.x @@ -57,7 +57,7 @@ $asciisym = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:] |infixr|infixl|infix @reservedop = - "=" | \\ | "->" | "|" + "=" | \\ | "->" | "|" | "::" rlp :- @@ -187,8 +187,8 @@ pushLexState :: Int -> P () pushLexState n = psLexState %= (n:) readInt :: Text -> Int -readInt = T.foldr f 0 where - f c n = digitToInt c + 10*n +readInt = T.foldl f 0 where + f n c = 10*n + digitToInt c constToken :: RlpToken -> LexerAction (Located RlpToken) constToken t inp l = do diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index 6eb6a3e..67e1b5d 100644 --- a/src/Rlp/Parse.y +++ b/src/Rlp/Parse.y @@ -38,6 +38,7 @@ import Data.Void litint { Located _ (TokenLitInt _) } '=' { Located _ TokenEquals } '|' { Located _ TokenPipe } + '::' { Located _ TokenHasType } ';' { Located _ TokenSemicolon } '(' { Located _ TokenLParen } ')' { Located _ TokenRParen } @@ -82,74 +83,75 @@ VS : ';' { $1 } Decl :: { Decl' RlpcPs } : FunDecl { $1 } + | TySigDecl { $1 } | DataDecl { $1 } | InfixDecl { $1 } -InfixDecl :: { Decl' RlpcPs } - : InfixWord litint InfixOp {% mkInfixD $1 (intOfToken $2) $3 } +TySigDecl :: { Decl' RlpcPs } + : Var '::' Type { (\e -> TySigD [extract e]) <<~ $1 <~> $3 } -InfixWord :: { Assoc } - : infixl { InfixL } - | infixr { InfixR } - | infix { Infix } +InfixDecl :: { Decl' RlpcPs } + : InfixWord litint InfixOp { $1 =>> \w -> + InfixD (extract $1) (extractInt $ extract $2) + (extract $3) } + +InfixWord :: { Located Assoc } + : infixl { $1 \$> InfixL } + | infixr { $1 \$> InfixR } + | infix { $1 \$> Infix } DataDecl :: { Decl' RlpcPs } - : data Con TyParams '=' DataCons { $1 =>> \_ -> DataD' (extract $2) $3 $5 } + : data Con TyParams '=' DataCons { $1 \$> DataD (extract $2) $3 $5 } TyParams :: { [PsName] } : {- epsilon -} { [] } - | TyParams varname { $1 `snoc` extract (mkPsName $2) } + | TyParams varname { $1 `snoc` (extractName . extract $ $2) } DataCons :: { [ConAlt RlpcPs] } : DataCons '|' DataCon { $1 `snoc` $3 } | DataCon { [$1] } DataCon :: { ConAlt RlpcPs } - : Con Type1s { undefined } + : Con Type1s { ConAlt (extract $1) $2 } -Type1s :: { [RlpType RlpcPs] } +Type1s :: { [RlpType' RlpcPs] } : {- epsilon -} { [] } | Type1s Type1 { $1 `snoc` $2 } Type1 :: { RlpType' RlpcPs } : '(' Type ')' { $2 } - | conname { undefined } - | varname { undefined } + | conname { fmap ConT (mkPsName $1) } + | varname { fmap VarT (mkPsName $1) } Type :: { RlpType' RlpcPs } - : Type '->' Type { undefined } + : Type '->' Type { FunT <<~ $1 <~> $3 } | Type1 { $1 } FunDecl :: { Decl' RlpcPs } FunDecl : Var Params '=' Expr { $4 =>> \e -> - FunD' (extract $1) $2 e Nothing } + FunD (extract $1) $2 e Nothing } Params :: { [Pat' RlpcPs] } Params : {- epsilon -} { [] } | Params Pat1 { $1 `snoc` $2 } Pat1 :: { Pat' RlpcPs } - : Var { undefined } + : Var { fmap VarP $1 } | Lit { LitP <<= $1 } Expr :: { RlpExpr' RlpcPs } - : Expr1 varsym Expr { undefined } + : Expr1 InfixOp Expr { $2 =>> \o -> + OAppE (extract o) $1 $3 } | Expr1 { $1 } Expr1 :: { RlpExpr' RlpcPs } : '(' Expr ')' { $1 .> $2 <. $3 } - | Lit { fmap LitE' $1 } - | Var { fmap VarE' $1 } - --- TODO: happy prefers left-associativity. doing such would require adjusting --- the code in Rlp.Parse.Associate to expect left-associative input rather than --- right. -InfixExpr :: { RlpExpr' RlpcPs } - : Expr1 varsym Expr { undefined } + | Lit { fmap LitE $1 } + | Var { fmap VarE $1 } InfixOp :: { Located PsName } - : consym { undefined } - | varsym { undefined } + : consym { mkPsName $1 } + | varsym { mkPsName $1 } -- TODO: microlens-pro save me microlens-pro (rewrite this with prisms) Lit :: { Lit' RlpcPs } @@ -164,13 +166,20 @@ Con :: { Located PsName } { mkPsName :: Located RlpToken -> Located PsName -mkPsName = fmap $ \case +mkPsName = fmap extractName + +extractName :: RlpToken -> PsName +extractName = \case TokenVarName n -> n TokenConName n -> n TokenConSym n -> n TokenVarSym n -> n _ -> error "mkPsName: not an identifier" +extractInt :: RlpToken -> Int +extractInt (TokenLitInt n) = n +extractInt _ = error "extractInt: ugh" + mkProgram :: [Decl' RlpcPs] -> P (RlpProgram RlpcPs) mkProgram ds = do pt <- use psOpTable @@ -191,7 +200,7 @@ mkInfixD a p n = do Nothing -> pure (Just (a,p)) ) pos <- use (psInput . aiPos) - pure $ Located (spanFromPos pos 0) (InfixD' a p n) + pure $ Located (spanFromPos pos 0) (InfixD a p n) intOfToken :: Located RlpToken -> Int intOfToken (Located _ (TokenLitInt n)) = n diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index 37c3aee..9c91493 100644 --- a/src/Rlp/Parse/Types.hs +++ b/src/Rlp/Parse/Types.hs @@ -54,24 +54,6 @@ data RlpcPs type instance XRec RlpcPs f = Located (f RlpcPs) type instance IdP RlpcPs = PsName -type instance XInfixD RlpcPs = () -type instance XFunD RlpcPs = () -type instance XDataD RlpcPs = () -type instance XTySigD RlpcPs = () -type instance XXDecl RlpcPs = () - -type instance XLetE 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 XXRlpExpr RlpcPs = () -type instance XLitE RlpcPs = () - type PsName = Text -------------------------------------------------------------------------------- diff --git a/src/Rlp/Syntax.hs b/src/Rlp/Syntax.hs index 66d2d3b..25b20e8 100644 --- a/src/Rlp/Syntax.hs +++ b/src/Rlp/Syntax.hs @@ -15,21 +15,8 @@ module Rlp.Syntax , RlpType(..), RlpType' , ConAlt(..) - -- * Pattern synonyms for unused extensions - -- ** Decl - , pattern InfixD', pattern FunD', pattern DataD' - -- ** RlpExpr - , pattern ParE', pattern VarE', pattern LitE' - -- ** RlpType - , pattern FunT', pattern AppT' - -- * Trees That Grow extensions , UnXRec(..), MapXRec(..), XRec, IdP - -- ** RlpExpr - , XLetE, XVarE, XConE, XLamE, XCaseE, XIfE, XAppE, XLitE, XParE, XOAppE - , XXRlpExpr - -- ** Decl - , XFunD, XTySigD, XDataD, XInfixD, XXDecl ) where ---------------------------------------------------------------------------------- @@ -38,9 +25,10 @@ import Data.Text qualified as T import Data.String (IsString(..)) import Data.Functor.Foldable.TH (makeBaseFunctor) import Data.Functor.Classes +import Data.Kind (Type) import Lens.Micro import Lens.Micro.TH -import Core.Syntax hiding (Lit, Binding) +import Core.Syntax hiding (Lit, Type, Binding) import Core (HasRHS(..), HasLHS(..)) ---------------------------------------------------------------------------------- @@ -60,56 +48,23 @@ newtype RlpProgram p = RlpProgram [Decl' p] deriving instance (PhaseShow p, Show (XRec p Decl)) => Show (RlpProgram p) -data RlpType p = FunT (XFunT p) - | AppT (XAppT p) (RlpType' p) (RlpType' p) - | VarT (XVarT p) (IdP p) - | ConT (XConT p) (IdP p) +data RlpType p = FunConT + | FunT (RlpType' p) (RlpType' p) + | AppT (RlpType' p) (RlpType' p) + | VarT (IdP p) + | ConT (IdP p) type RlpType' p = XRec p RlpType -deriving instance (PhaseShow p, Show (XFunT p), Show (XAppT p), Show (XVarT p) - ,Show (XConT p)) +deriving instance (PhaseShow p) => Show (RlpType p) -type family XFunT p -type family XAppT p -type family XVarT p -type family XConT p +data Decl p = FunD (IdP p) [Pat' p] (RlpExpr' p) (Maybe (Where p)) + | TySigD [IdP p] (RlpType' p) + | DataD (IdP p) [IdP p] [ConAlt p] + | InfixD Assoc Int (IdP p) -pattern FunT' :: (XFunT p ~ ()) => RlpType p -pattern FunT' = FunT () - -pattern AppT' :: (XAppT p ~ ()) => RlpType' p -> RlpType' p -> RlpType p -pattern AppT' s t = AppT () s t - -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) - | XDecl !(XXDecl p) - -deriving instance ( Show (XFunD p), Show (XTySigD p) - , Show (XDataD p), Show (XInfixD p) - , Show (XXDecl p), Show (IdP p) - , PhaseShow p - ) => Show (Decl p) - -type family XFunD p -type family XTySigD p -type family XDataD p -type family XInfixD p -type family XXDecl p - -pattern FunD' :: (XFunD p ~ ()) - => IdP p -> [Pat' p] -> RlpExpr' p -> (Maybe (Where p)) - -> Decl p -pattern FunD' n as e wh = FunD () n as e wh - -pattern InfixD' :: (XInfixD p ~ ()) => Assoc -> Int -> (IdP p) -> Decl p -pattern InfixD' a p n = InfixD () a p n - -pattern DataD' :: (XDataD p ~ ()) => IdP p -> [IdP p] -> [ConAlt p] -> Decl p -pattern DataD' n as ds = DataD () n as ds +deriving instance (Show (IdP p), PhaseShow p) => Show (Decl p) type Decl' p = XRec p Decl @@ -122,22 +77,17 @@ data ConAlt p = ConAlt (IdP p) [RlpType' p] deriving instance (Show (IdP p), Show (XRec p RlpType)) => Show (ConAlt p) -data RlpExpr p = LetE (XLetE 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) - | XRlpExpr !(XXRlpExpr p) +data RlpExpr p = LetE [Binding p] (RlpExpr' p) + | VarE (IdP p) + | LamE [Pat p] (RlpExpr' p) + | CaseE (RlpExpr' p) [(Alt p, Where p)] + | IfE (RlpExpr' p) (RlpExpr' p) (RlpExpr' p) + | AppE (RlpExpr' p) (RlpExpr' p) + | LitE (Lit p) + | ParE (RlpExpr' p) + | OAppE (IdP p) (RlpExpr' p) (RlpExpr' p) -deriving instance - ( Show (XLetE 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 (XXRlpExpr p), PhaseShow p) - => Show (RlpExpr p) +deriving instance (PhaseShow p) => Show (RlpExpr p) type RlpExpr' p = XRec p RlpExpr @@ -145,33 +95,12 @@ class UnXRec p where unXRec :: XRec p f -> f p class MapXRec p where - mapXRec :: (f p -> f p) -> XRec p f -> XRec p f + mapXRec :: (f p -> f' p') -> XRec p f -> XRec p' f' -type family XRec p (f :: * -> *) = (r :: *) | r -> p f - -type family XLetE p -type family XVarE p -type family XConE 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 XXRlpExpr p +type family XRec p (f :: Type -> Type) = (r :: Type) | r -> p f type family IdP p -pattern ParE' :: (XParE p ~ ()) => RlpExpr' p -> RlpExpr p -pattern ParE' e = ParE () e - -pattern LitE' :: (XLitE p ~ ()) => Lit p -> RlpExpr p -pattern LitE' e = LitE () e - -pattern VarE' :: (XVarE p ~ ()) => IdP p -> RlpExpr p -pattern VarE' e = VarE () e - type Where p = [Binding p] -- do we want guards?