|
|
- {
- {-# LANGUAGE FlexibleContexts, FlexibleInstances, ViewPatterns #-}
- module Frontend.Autogen.Parser where
-
- import qualified Data.Text as T
-
- import Frontend.Lexer.Tokens
- import Frontend.Parser.Posn
- import Frontend.Syntax
- import Frontend.Autogen.Lexer
-
- import Prelude hiding (span)
-
- import Debug.Trace
-
- }
-
- %name parseExp Exp
- %name parseMod Module
- %name parseType Type
-
- %tokentype { Token }
-
- %monad { Alex }
- %lexer { lexer } { Token TokEof _ _ }
-
- %errorhandlertype explist
- %error { parseError }
-
- %token
- VAR { Token (TokUnqual VarId _) _ _ }
- CON { Token (TokUnqual ConId _) _ _ }
-
- QVAR { Token (TokQual VarId _ _) _ _ }
- QCON { Token (TokQual ConId _ _) _ _ }
- STRING { Token (TokString _) _ _ }
- 'eof' { Token TokEof _ _ }
-
- '(' { Token TokOParen _ _ }
- ')' { Token TokCParen _ _ }
-
- '{' { Token TokOBrace _ _ }
- '}' { Token TokCBrace _ _ }
-
- START { Token TokLStart _ _ }
- END { Token TokLEnd _ _ }
-
- '[' { Token TokOSquare _ _ }
- ']' { Token TokCSquare _ _ }
-
- '{-#' { Token TokOPragma _ _ }
- '#-}' { Token TokCPragma _ _ }
-
- '\\' { Token TokLambda _ _ }
-
- '->' { Token TokArrow _ _ }
- '_' { Token TokUnder _ _ }
- '::' { Token TokDoubleColon _ _ }
- ';' { Token TokSemi _ _ }
- '=' { Token TokEqual _ _ }
- ',' { Token TokComma _ _ }
-
- 'let' { Token TokLet _ _ }
- 'in' { Token TokIn _ _ }
- 'data' { Token TokData _ _ }
- 'case' { Token TokCase _ _ }
- 'module' { Token TokModule _ _ }
- 'where' { Token TokWhere _ _ }
-
- 'import' { Token TokImport _ _ }
- 'as' { Token TokAs _ _ }
- 'qualified' { Token TokQualified _ _ }
-
- %%
-
- Exp :: { Exp }
- : InfixExp '::' Type { span $1 $3 $ Annot $1 $3 }
- | InfixExp { $1 }
-
- InfixExp :: { Exp }
- : LeftExp {- ... -} { $1 }
- -- | LeftExp qop InfixExp { Infix $1 (getVar $2) $3 }
-
- LeftExp :: { Exp }
- : '\\' Apat List(Apat) '->' Exp { span $1 $5 (makeLams ($2:$3) $5) }
- | 'let' LaidOutList(Decl) 'in' Exp { span $1 $4 $ Let (thd $2) $4 }
- | FuncExp { $1 }
-
- FuncExp :: { Exp }
- : FuncExp Aexp { span $1 $2 $ App $1 $2 }
- | Aexp { $1 }
-
- Aexp :: { Exp }
- : qvar { span $1 $1 $ Ref $1 }
- | qcon { span $1 $1 $ Con $1 }
- | '(' CommaList(Exp) ')' { span $1 $3 $ makeTuple $2 }
- | STRING { span $1 $1 $ Literal (LitString (getString $1)) }
-
- Type :: { Type }
- : Btype '->' Type { span $1 $3 $ Tyarr $1 $3 }
- | Btype { $1 }
-
- Btype :: { Type }
- : Btype Atype { span $1 $2 $ Tyapp $1 $2 }
- | Atype { $1 }
-
- Atype :: { Type }
- : qvar { span $1 $1 $ Tyvar $1 }
- | qcon { span $1 $1 $ Tycon $1 }
- | '(' CommaList(Type) ')' { span $1 $3 $ makeTupleType $2 }
-
- Pat :: { Pat }
- : Lpat { $1 }
-
- Lpat :: { Pat }
- : Apat { $1 }
-
- Apat :: { Pat }
- : VAR { span $1 $1 $ Var (getVar $1) }
- | '_' { span $1 $1 $ Wildcard }
- | '(' CommaList(Pat) ')' { span $1 $3 $ makeTuplePattern $2 }
-
- Decl :: { Decl }
- : CommaList1(VAR) '::' Type { TySig (getVar `fmap` $1) $3 }
- | VAR Apat List(Apat) Rhs { FunDecl (getVar $1) ($2:$3) $4 }
- | Pat Rhs { PatDecl $1 $2 }
-
- Rhs :: { Rhs }
- : '=' Exp { BareRhs $2 [] }
- | '=' Exp 'where' LaidOutList(Decl) { BareRhs $2 (thd $4) }
-
- LaidOutList(p)
- : START Opt(Semis) LOLContents(p, END) { (startPosn $1, lolEnd $3, lolList $3) }
- | '{' Opt(Semis) LOLContents(p, '}') { (startPosn $1, lolEnd $3, lolList $3) }
-
- LOLContents(p, End)
- : p Semis LOLContents(p,End) { lolCons $1 $3 }
- | p Opt(Semis) End { lolCons $1 (emptyLol $3) }
- | Opt(Semis) End { emptyLol $2 }
-
- Module :: { Module }
- : 'module' CON ImportExportList 'where' LaidOutList(ModItem)
- { Module { moduleName = toModId (getVar $2)
- , moduleExports = $3
- , moduleItems = thd $5 }
- }
-
- ImportExportList :: { Maybe [NamespacedItem ParsedVar] }
- : {-empty-} { Nothing }
- | '(' CommaList(NSItem) ')' { Just $2 }
-
- NSItem :: { NamespacedItem ParsedVar }
- : VAR { IEVar (getVar $1) }
- | CON { IECon (getVar $1) }
- | 'module' CON { IEModule (getVar $2) }
-
- ModItem :: { Item }
- : Decl { ModDecl $1 }
- | Import { ModImport $1 }
-
- Import :: { ModuleImport ParsedVar }
- : 'import' modid ImportExportList
- { Import $2 $3 False Nothing }
-
- | 'import' modid ImportExportList 'as' CON
- { Import $2 $3 False (Just (getVar $5)) }
-
- | 'import' 'qualified' modid ImportExportList
- { Import $3 $4 True Nothing }
-
- | 'import' 'qualified' modid ImportExportList 'as' CON
- { Import $3 $4 True (Just (getVar $6)) }
-
- Opt(p)
- : { () }
- | p { () }
-
- Semis
- : ';' Semis { () }
- | ';' { () }
-
- -- TODO: qualified names
- qvar :: { ParsedVar }
- qvar : VAR { getVar $1 }
- | QVAR { getVar $1 }
-
- qcon : CON { getVar $1 }
- | QCON { getVar $1 }
-
- modid : qcon { toModId $1 }
-
- List(p)
- : {-empty-} { [] }
- | p List(p) { $1:$2 }
-
- CommaList(p)
- : {-empty-} { [] }
- | p { [$1] }
- | p ',' CommaList(p) { $1:$3 }
-
- CommaList1(p)
- : p { [$1] }
- | p ',' CommaList(p) { $1:$3 }
-
- Block(p)
- : START p END { (startPosn $1, endPosn $3, $2) }
- | '{' p '}' { (startPosn $1, endPosn $3, $2) }
-
- {
-
- type Exp = FeExpr ParsedVar
- type Pat = FePat ParsedVar
- type Decl = FeDecl ParsedVar
- type Type = FeType ParsedVar
- type Rhs = FeRhs ParsedVar
- type Module = FeModule ParsedVar
- type Item = ModuleItem ParsedVar
-
- lexer cont = alexMonadScan >>= cont
-
- parseError x = alexError (show x)
-
- makeLams xs b = foldr Lam b xs
-
- getVar :: Token -> ParsedVar
- getVar tok@(Token (TokQual _ p s) _ _) = QualVar { varId = s, varPrefix = p, varBegin = startPosn tok, varEnd = endPosn tok }
- getVar tok@(Token (TokUnqual _ s) _ _) = UnqualVar { varId = s, varBegin = startPosn tok, varEnd = endPosn tok }
- getVar _ = error "getVar non-var"
-
- getString (Token (TokString s) _ _) = s
- getString _ = error "getString non-string"
-
- data LOL a = LOL { lolEnd :: Posn, lolList :: [a] }
-
- emptyLol :: HasPosn x => x -> LOL a
- emptyLol t = LOL (endPosn t) []
-
- lolCons :: a -> LOL a -> LOL a
- lolCons x (LOL p xs) = LOL p (x:xs)
-
- makeTupleType [x] = ParenType x
- makeTupleType xs = Tytup xs
-
- makeTuplePattern [x] = ParenPat x
- makeTuplePattern xs = TupPat xs
-
- makeTuple [x] = ParenExp x
- makeTuple xs = Tuple xs
- }
|