at long last
more no more undefineds
This commit is contained in:
crumbtoo
@@ -57,7 +57,7 @@ $asciisym = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
|
|||||||
|infixr|infixl|infix
|
|infixr|infixl|infix
|
||||||
|
|
||||||
@reservedop =
|
@reservedop =
|
||||||
"=" | \\ | "->" | "|"
|
"=" | \\ | "->" | "|" | "::"
|
||||||
|
|
||||||
rlp :-
|
rlp :-
|
||||||
|
|
||||||
@@ -187,8 +187,8 @@ pushLexState :: Int -> P ()
|
|||||||
pushLexState n = psLexState %= (n:)
|
pushLexState n = psLexState %= (n:)
|
||||||
|
|
||||||
readInt :: Text -> Int
|
readInt :: Text -> Int
|
||||||
readInt = T.foldr f 0 where
|
readInt = T.foldl f 0 where
|
||||||
f c n = digitToInt c + 10*n
|
f n c = 10*n + digitToInt c
|
||||||
|
|
||||||
constToken :: RlpToken -> LexerAction (Located RlpToken)
|
constToken :: RlpToken -> LexerAction (Located RlpToken)
|
||||||
constToken t inp l = do
|
constToken t inp l = do
|
||||||
|
|||||||
@@ -38,6 +38,7 @@ import Data.Void
|
|||||||
litint { Located _ (TokenLitInt _) }
|
litint { Located _ (TokenLitInt _) }
|
||||||
'=' { Located _ TokenEquals }
|
'=' { Located _ TokenEquals }
|
||||||
'|' { Located _ TokenPipe }
|
'|' { Located _ TokenPipe }
|
||||||
|
'::' { Located _ TokenHasType }
|
||||||
';' { Located _ TokenSemicolon }
|
';' { Located _ TokenSemicolon }
|
||||||
'(' { Located _ TokenLParen }
|
'(' { Located _ TokenLParen }
|
||||||
')' { Located _ TokenRParen }
|
')' { Located _ TokenRParen }
|
||||||
@@ -82,74 +83,75 @@ VS : ';' { $1 }
|
|||||||
|
|
||||||
Decl :: { Decl' RlpcPs }
|
Decl :: { Decl' RlpcPs }
|
||||||
: FunDecl { $1 }
|
: FunDecl { $1 }
|
||||||
|
| TySigDecl { $1 }
|
||||||
| DataDecl { $1 }
|
| DataDecl { $1 }
|
||||||
| InfixDecl { $1 }
|
| InfixDecl { $1 }
|
||||||
|
|
||||||
InfixDecl :: { Decl' RlpcPs }
|
TySigDecl :: { Decl' RlpcPs }
|
||||||
: InfixWord litint InfixOp {% mkInfixD $1 (intOfToken $2) $3 }
|
: Var '::' Type { (\e -> TySigD [extract e]) <<~ $1 <~> $3 }
|
||||||
|
|
||||||
InfixWord :: { Assoc }
|
InfixDecl :: { Decl' RlpcPs }
|
||||||
: infixl { InfixL }
|
: InfixWord litint InfixOp { $1 =>> \w ->
|
||||||
| infixr { InfixR }
|
InfixD (extract $1) (extractInt $ extract $2)
|
||||||
| infix { Infix }
|
(extract $3) }
|
||||||
|
|
||||||
|
InfixWord :: { Located Assoc }
|
||||||
|
: infixl { $1 \$> InfixL }
|
||||||
|
| infixr { $1 \$> InfixR }
|
||||||
|
| infix { $1 \$> Infix }
|
||||||
|
|
||||||
DataDecl :: { Decl' RlpcPs }
|
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] }
|
TyParams :: { [PsName] }
|
||||||
: {- epsilon -} { [] }
|
: {- epsilon -} { [] }
|
||||||
| TyParams varname { $1 `snoc` extract (mkPsName $2) }
|
| TyParams varname { $1 `snoc` (extractName . extract $ $2) }
|
||||||
|
|
||||||
DataCons :: { [ConAlt RlpcPs] }
|
DataCons :: { [ConAlt RlpcPs] }
|
||||||
: DataCons '|' DataCon { $1 `snoc` $3 }
|
: DataCons '|' DataCon { $1 `snoc` $3 }
|
||||||
| DataCon { [$1] }
|
| DataCon { [$1] }
|
||||||
|
|
||||||
DataCon :: { ConAlt RlpcPs }
|
DataCon :: { ConAlt RlpcPs }
|
||||||
: Con Type1s { undefined }
|
: Con Type1s { ConAlt (extract $1) $2 }
|
||||||
|
|
||||||
Type1s :: { [RlpType RlpcPs] }
|
Type1s :: { [RlpType' RlpcPs] }
|
||||||
: {- epsilon -} { [] }
|
: {- epsilon -} { [] }
|
||||||
| Type1s Type1 { $1 `snoc` $2 }
|
| Type1s Type1 { $1 `snoc` $2 }
|
||||||
|
|
||||||
Type1 :: { RlpType' RlpcPs }
|
Type1 :: { RlpType' RlpcPs }
|
||||||
: '(' Type ')' { $2 }
|
: '(' Type ')' { $2 }
|
||||||
| conname { undefined }
|
| conname { fmap ConT (mkPsName $1) }
|
||||||
| varname { undefined }
|
| varname { fmap VarT (mkPsName $1) }
|
||||||
|
|
||||||
Type :: { RlpType' RlpcPs }
|
Type :: { RlpType' RlpcPs }
|
||||||
: Type '->' Type { undefined }
|
: Type '->' Type { FunT <<~ $1 <~> $3 }
|
||||||
| Type1 { $1 }
|
| Type1 { $1 }
|
||||||
|
|
||||||
FunDecl :: { Decl' RlpcPs }
|
FunDecl :: { Decl' RlpcPs }
|
||||||
FunDecl : Var Params '=' Expr { $4 =>> \e ->
|
FunDecl : Var Params '=' Expr { $4 =>> \e ->
|
||||||
FunD' (extract $1) $2 e Nothing }
|
FunD (extract $1) $2 e Nothing }
|
||||||
|
|
||||||
Params :: { [Pat' RlpcPs] }
|
Params :: { [Pat' RlpcPs] }
|
||||||
Params : {- epsilon -} { [] }
|
Params : {- epsilon -} { [] }
|
||||||
| Params Pat1 { $1 `snoc` $2 }
|
| Params Pat1 { $1 `snoc` $2 }
|
||||||
|
|
||||||
Pat1 :: { Pat' RlpcPs }
|
Pat1 :: { Pat' RlpcPs }
|
||||||
: Var { undefined }
|
: Var { fmap VarP $1 }
|
||||||
| Lit { LitP <<= $1 }
|
| Lit { LitP <<= $1 }
|
||||||
|
|
||||||
Expr :: { RlpExpr' RlpcPs }
|
Expr :: { RlpExpr' RlpcPs }
|
||||||
: Expr1 varsym Expr { undefined }
|
: Expr1 InfixOp Expr { $2 =>> \o ->
|
||||||
|
OAppE (extract o) $1 $3 }
|
||||||
| Expr1 { $1 }
|
| Expr1 { $1 }
|
||||||
|
|
||||||
Expr1 :: { RlpExpr' RlpcPs }
|
Expr1 :: { RlpExpr' RlpcPs }
|
||||||
: '(' Expr ')' { $1 .> $2 <. $3 }
|
: '(' Expr ')' { $1 .> $2 <. $3 }
|
||||||
| Lit { fmap LitE' $1 }
|
| Lit { fmap LitE $1 }
|
||||||
| Var { fmap VarE' $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 }
|
|
||||||
|
|
||||||
InfixOp :: { Located PsName }
|
InfixOp :: { Located PsName }
|
||||||
: consym { undefined }
|
: consym { mkPsName $1 }
|
||||||
| varsym { undefined }
|
| varsym { mkPsName $1 }
|
||||||
|
|
||||||
-- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
|
-- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
|
||||||
Lit :: { Lit' RlpcPs }
|
Lit :: { Lit' RlpcPs }
|
||||||
@@ -164,13 +166,20 @@ Con :: { Located PsName }
|
|||||||
{
|
{
|
||||||
|
|
||||||
mkPsName :: Located RlpToken -> Located PsName
|
mkPsName :: Located RlpToken -> Located PsName
|
||||||
mkPsName = fmap $ \case
|
mkPsName = fmap extractName
|
||||||
|
|
||||||
|
extractName :: RlpToken -> PsName
|
||||||
|
extractName = \case
|
||||||
TokenVarName n -> n
|
TokenVarName n -> n
|
||||||
TokenConName n -> n
|
TokenConName n -> n
|
||||||
TokenConSym n -> n
|
TokenConSym n -> n
|
||||||
TokenVarSym n -> n
|
TokenVarSym n -> n
|
||||||
_ -> error "mkPsName: not an identifier"
|
_ -> error "mkPsName: not an identifier"
|
||||||
|
|
||||||
|
extractInt :: RlpToken -> Int
|
||||||
|
extractInt (TokenLitInt n) = n
|
||||||
|
extractInt _ = error "extractInt: ugh"
|
||||||
|
|
||||||
mkProgram :: [Decl' RlpcPs] -> P (RlpProgram RlpcPs)
|
mkProgram :: [Decl' RlpcPs] -> P (RlpProgram RlpcPs)
|
||||||
mkProgram ds = do
|
mkProgram ds = do
|
||||||
pt <- use psOpTable
|
pt <- use psOpTable
|
||||||
@@ -191,7 +200,7 @@ mkInfixD a p n = do
|
|||||||
Nothing -> pure (Just (a,p))
|
Nothing -> pure (Just (a,p))
|
||||||
)
|
)
|
||||||
pos <- use (psInput . aiPos)
|
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 RlpToken -> Int
|
||||||
intOfToken (Located _ (TokenLitInt n)) = n
|
intOfToken (Located _ (TokenLitInt n)) = n
|
||||||
|
|||||||
@@ -54,24 +54,6 @@ data RlpcPs
|
|||||||
type instance XRec RlpcPs f = Located (f RlpcPs)
|
type instance XRec RlpcPs f = Located (f RlpcPs)
|
||||||
type instance IdP RlpcPs = PsName
|
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
|
type PsName = Text
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|||||||
@@ -15,21 +15,8 @@ module Rlp.Syntax
|
|||||||
, RlpType(..), RlpType'
|
, RlpType(..), RlpType'
|
||||||
, ConAlt(..)
|
, 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
|
-- * Trees That Grow extensions
|
||||||
, UnXRec(..), MapXRec(..), XRec, IdP
|
, UnXRec(..), MapXRec(..), XRec, IdP
|
||||||
-- ** RlpExpr
|
|
||||||
, XLetE, XVarE, XConE, XLamE, XCaseE, XIfE, XAppE, XLitE, XParE, XOAppE
|
|
||||||
, XXRlpExpr
|
|
||||||
-- ** Decl
|
|
||||||
, XFunD, XTySigD, XDataD, XInfixD, XXDecl
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
@@ -38,9 +25,10 @@ import Data.Text qualified as T
|
|||||||
import Data.String (IsString(..))
|
import Data.String (IsString(..))
|
||||||
import Data.Functor.Foldable.TH (makeBaseFunctor)
|
import Data.Functor.Foldable.TH (makeBaseFunctor)
|
||||||
import Data.Functor.Classes
|
import Data.Functor.Classes
|
||||||
|
import Data.Kind (Type)
|
||||||
import Lens.Micro
|
import Lens.Micro
|
||||||
import Lens.Micro.TH
|
import Lens.Micro.TH
|
||||||
import Core.Syntax hiding (Lit, Binding)
|
import Core.Syntax hiding (Lit, Type, Binding)
|
||||||
import Core (HasRHS(..), HasLHS(..))
|
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)
|
deriving instance (PhaseShow p, Show (XRec p Decl)) => Show (RlpProgram p)
|
||||||
|
|
||||||
data RlpType p = FunT (XFunT p)
|
data RlpType p = FunConT
|
||||||
| AppT (XAppT p) (RlpType' p) (RlpType' p)
|
| FunT (RlpType' p) (RlpType' p)
|
||||||
| VarT (XVarT p) (IdP p)
|
| AppT (RlpType' p) (RlpType' p)
|
||||||
| ConT (XConT p) (IdP p)
|
| VarT (IdP p)
|
||||||
|
| ConT (IdP p)
|
||||||
|
|
||||||
type RlpType' p = XRec p RlpType
|
type RlpType' p = XRec p RlpType
|
||||||
|
|
||||||
deriving instance (PhaseShow p, Show (XFunT p), Show (XAppT p), Show (XVarT p)
|
deriving instance (PhaseShow p)
|
||||||
,Show (XConT p))
|
|
||||||
=> Show (RlpType p)
|
=> Show (RlpType p)
|
||||||
|
|
||||||
type family XFunT p
|
data Decl p = FunD (IdP p) [Pat' p] (RlpExpr' p) (Maybe (Where p))
|
||||||
type family XAppT p
|
| TySigD [IdP p] (RlpType' p)
|
||||||
type family XVarT p
|
| DataD (IdP p) [IdP p] [ConAlt p]
|
||||||
type family XConT p
|
| InfixD Assoc Int (IdP p)
|
||||||
|
|
||||||
pattern FunT' :: (XFunT p ~ ()) => RlpType p
|
deriving instance (Show (IdP p), PhaseShow p) => Show (Decl 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
|
|
||||||
|
|
||||||
type Decl' p = XRec p Decl
|
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)
|
deriving instance (Show (IdP p), Show (XRec p RlpType)) => Show (ConAlt p)
|
||||||
|
|
||||||
data RlpExpr p = LetE (XLetE p) [Binding p] (RlpExpr' p)
|
data RlpExpr p = LetE [Binding p] (RlpExpr' p)
|
||||||
| VarE (XVarE p) (IdP p)
|
| VarE (IdP p)
|
||||||
| LamE (XLamE p) [Pat p] (RlpExpr' p)
|
| LamE [Pat p] (RlpExpr' p)
|
||||||
| CaseE (XCaseE p) (RlpExpr' p) [(Alt p, Where p)]
|
| CaseE (RlpExpr' p) [(Alt p, Where p)]
|
||||||
| IfE (XIfE p) (RlpExpr' p) (RlpExpr' p) (RlpExpr' p)
|
| IfE (RlpExpr' p) (RlpExpr' p) (RlpExpr' p)
|
||||||
| AppE (XAppE p) (RlpExpr' p) (RlpExpr' p)
|
| AppE (RlpExpr' p) (RlpExpr' p)
|
||||||
| LitE (XLitE p) (Lit p)
|
| LitE (Lit p)
|
||||||
| ParE (XParE p) (RlpExpr' p)
|
| ParE (RlpExpr' p)
|
||||||
| OAppE (XOAppE p) (IdP p) (RlpExpr' p) (RlpExpr' p)
|
| OAppE (IdP p) (RlpExpr' p) (RlpExpr' p)
|
||||||
| XRlpExpr !(XXRlpExpr p)
|
|
||||||
|
|
||||||
deriving instance
|
deriving instance (PhaseShow p) => Show (RlpExpr p)
|
||||||
( 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)
|
|
||||||
|
|
||||||
type RlpExpr' p = XRec p RlpExpr
|
type RlpExpr' p = XRec p RlpExpr
|
||||||
|
|
||||||
@@ -145,33 +95,12 @@ class UnXRec p where
|
|||||||
unXRec :: XRec p f -> f p
|
unXRec :: XRec p f -> f p
|
||||||
|
|
||||||
class MapXRec p where
|
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 XRec p (f :: Type -> Type) = (r :: Type) | 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 IdP p
|
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]
|
type Where p = [Binding p]
|
||||||
|
|
||||||
-- do we want guards?
|
-- do we want guards?
|
||||||
|
|||||||
Reference in New Issue
Block a user