at long last
more no more undefineds
This commit is contained in:
crumbtoo
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
@@ -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?
|
||||
|
||||
Reference in New Issue
Block a user