some
This commit is contained in:
crumbtoo
@@ -9,13 +9,13 @@ import Rlp.Lex
|
||||
import Rlp.Syntax
|
||||
import Rlp.Parse.Types
|
||||
import Rlp.Parse.Associate
|
||||
import Lens.Micro
|
||||
import Lens.Micro.Mtl
|
||||
import Lens.Micro.Platform ()
|
||||
import Lens.Micro.Platform
|
||||
import Data.List.Extra
|
||||
import Data.Fix
|
||||
import Data.Functor.Const
|
||||
import Data.Functor
|
||||
import Data.Text qualified as T
|
||||
import Data.Void
|
||||
}
|
||||
|
||||
%name parseRlpProg StandaloneProgram
|
||||
@@ -26,12 +26,12 @@ import Data.Text qualified as T
|
||||
%tokentype { Located RlpToken }
|
||||
|
||||
%token
|
||||
varname { Located _ (TokenVarName $$) }
|
||||
conname { Located _ (TokenConName $$) }
|
||||
consym { Located _ (TokenConSym $$) }
|
||||
varsym { Located _ (TokenVarSym $$) }
|
||||
varname { Located _ (TokenVarName _) }
|
||||
conname { Located _ (TokenConName _) }
|
||||
consym { Located _ (TokenConSym _) }
|
||||
varsym { Located _ (TokenVarSym _) }
|
||||
data { Located _ TokenData }
|
||||
litint { Located _ (TokenLitInt $$) }
|
||||
litint { Located _ (TokenLitInt _) }
|
||||
'=' { Located _ TokenEquals }
|
||||
'|' { Located _ TokenPipe }
|
||||
';' { Located _ TokenSemicolon }
|
||||
@@ -51,7 +51,7 @@ import Data.Text qualified as T
|
||||
|
||||
%%
|
||||
|
||||
StandaloneProgram :: { RlpProgram' }
|
||||
StandaloneProgram :: { RlpProgram RlpcPs }
|
||||
StandaloneProgram : '{' Decls '}' {% mkProgram $2 }
|
||||
| VL DeclsV VR {% mkProgram $2 }
|
||||
|
||||
@@ -62,12 +62,12 @@ VR :: { () }
|
||||
VR : vrbrace { () }
|
||||
| error { () }
|
||||
|
||||
Decls :: { [PartialDecl'] }
|
||||
Decls :: { [Decl' RlpcPs] }
|
||||
Decls : Decl ';' Decls { $1 : $3 }
|
||||
| Decl ';' { [$1] }
|
||||
| Decl { [$1] }
|
||||
|
||||
DeclsV :: { [PartialDecl'] }
|
||||
DeclsV :: { [Decl' RlpcPs] }
|
||||
DeclsV : Decl VS Decls { $1 : $3 }
|
||||
| Decl VS { [$1] }
|
||||
| Decl { [$1] }
|
||||
@@ -76,12 +76,12 @@ VS :: { Located RlpToken }
|
||||
VS : ';' { $1 }
|
||||
| vsemi { $1 }
|
||||
|
||||
Decl :: { PartialDecl' }
|
||||
Decl :: { Decl' RlpcPs }
|
||||
: FunDecl { $1 }
|
||||
| DataDecl { $1 }
|
||||
| InfixDecl { $1 }
|
||||
|
||||
InfixDecl :: { PartialDecl' }
|
||||
InfixDecl :: { Decl' RlpcPs }
|
||||
: InfixWord litint InfixOp {% mkInfixD $1 $2 $3 }
|
||||
|
||||
InfixWord :: { Assoc }
|
||||
@@ -89,18 +89,18 @@ InfixWord :: { Assoc }
|
||||
| infixr { InfixR }
|
||||
| infix { Infix }
|
||||
|
||||
DataDecl :: { PartialDecl' }
|
||||
DataDecl :: { Decl' RlpcPs }
|
||||
: data Con TyParams '=' DataCons { DataD $2 $3 $5 }
|
||||
|
||||
TyParams :: { [Name] }
|
||||
TyParams :: { [PsName] }
|
||||
: {- epsilon -} { [] }
|
||||
| TyParams varname { $1 `snoc` $2 }
|
||||
|
||||
DataCons :: { [ConAlt] }
|
||||
DataCons :: { [ConAlt RlpcPs] }
|
||||
: DataCons '|' DataCon { $1 `snoc` $3 }
|
||||
| DataCon { [$1] }
|
||||
|
||||
DataCon :: { ConAlt }
|
||||
DataCon :: { ConAlt RlpcPs }
|
||||
: Con Type1s { ConAlt $1 $2 }
|
||||
|
||||
Type1s :: { [Type] }
|
||||
@@ -116,22 +116,22 @@ Type :: { Type }
|
||||
: Type '->' Type { $1 :-> $3 }
|
||||
| Type1 { $1 }
|
||||
|
||||
FunDecl :: { PartialDecl' }
|
||||
FunDecl : Var Params '=' Expr { FunD $1 $2 (Const $4) Nothing }
|
||||
FunDecl :: { Decl' RlpcPs }
|
||||
FunDecl : Var Params '=' Expr { FunD $1 $2 $4 Nothing }
|
||||
|
||||
Params :: { [Pat'] }
|
||||
Params :: { [Pat' RlpcPs] }
|
||||
Params : {- epsilon -} { [] }
|
||||
| Params Pat1 { $1 `snoc` $2 }
|
||||
|
||||
Pat1 :: { Pat' }
|
||||
Pat1 :: { Pat' RlpcPs }
|
||||
: Var { VarP $1 }
|
||||
| Lit { LitP $1 }
|
||||
|
||||
Expr :: { PartialExpr' }
|
||||
Expr :: { RlpExpr' RlpcPs }
|
||||
: Expr1 varsym Expr { Fix $ B $2 (unFix $1) (unFix $3) }
|
||||
| Expr1 { $1 }
|
||||
|
||||
Expr1 :: { PartialExpr' }
|
||||
Expr1 :: { RlpExpr' RlpcPs }
|
||||
: '(' Expr ')' { wrapFix . Par . unwrapFix $ $2 }
|
||||
| Lit { Fix . E $ LitEF $1 }
|
||||
| Var { Fix . E $ VarEF $1 }
|
||||
@@ -139,34 +139,43 @@ Expr1 :: { PartialExpr' }
|
||||
-- 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 :: { PartialExpr' }
|
||||
InfixExpr :: { RlpExpr' RlpcPs }
|
||||
: Expr1 varsym Expr { Fix $ B $2 (unFix $1) (unFix $3) }
|
||||
|
||||
InfixOp :: { Name }
|
||||
InfixOp :: { PsName }
|
||||
: consym { $1 }
|
||||
| varsym { $1 }
|
||||
|
||||
Lit :: { Lit' }
|
||||
Lit : litint { IntL $1 }
|
||||
-- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
|
||||
Lit :: { Lit' RlpcPs }
|
||||
: litint { $1 <&> (IntL . (\ (TokenLitInt n) -> n)) }
|
||||
|
||||
Var :: { VarId }
|
||||
Var : varname { NameVar $1 }
|
||||
Var :: { Located PsName }
|
||||
Var : varname { mkPsName $1 }
|
||||
|
||||
Con :: { ConId }
|
||||
: conname { NameCon $1 }
|
||||
Con :: { Located PsName }
|
||||
: conname { mkPsName $1 }
|
||||
|
||||
{
|
||||
|
||||
mkProgram :: [PartialDecl'] -> P RlpProgram'
|
||||
mkPsName :: Located RlpToken -> Located PsName
|
||||
mkPsName = fmap $ \case
|
||||
TokenVarName n -> n
|
||||
TokenConName n -> n
|
||||
TokenConSym n -> n
|
||||
TokenVarSym n -> n
|
||||
_ -> error "mkPsName: not an identifier"
|
||||
|
||||
mkProgram :: [Decl' RlpcPs] -> P (RlpProgram RlpcPs)
|
||||
mkProgram ds = do
|
||||
pt <- use psOpTable
|
||||
pure $ RlpProgram (associate pt <$> ds)
|
||||
|
||||
parseError :: Located RlpToken -> P a
|
||||
parseError (Located ((l,c),s) t) = addFatal $
|
||||
parseError (Located (l,c,s) t) = addFatal $
|
||||
errorMsg (SrcSpan l c s) RlpParErrUnexpectedToken
|
||||
|
||||
mkInfixD :: Assoc -> Int -> Name -> P PartialDecl'
|
||||
mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs)
|
||||
mkInfixD a p n = do
|
||||
let opl :: Lens' ParseState (Maybe OpInfo)
|
||||
opl = psOpTable . at n
|
||||
@@ -176,6 +185,7 @@ mkInfixD a p n = do
|
||||
l = T.length n
|
||||
Nothing -> pure (Just (a,p))
|
||||
)
|
||||
pure $ InfixD a p n
|
||||
pos <- use (psInput . aiPos)
|
||||
pure $ Located (spanFromPos pos 0) (InfixD' a p n)
|
||||
|
||||
}
|
||||
|
||||
Reference in New Issue
Block a user