|
|
- {
- {-# LANGUAGE FlexibleContexts, FlexibleInstances, ViewPatterns #-}
- module Frontend.Autogen.Parser where
-
- import qualified Data.Text as T
- import Data.Maybe
-
- import Frontend.Parser.Foreign
- import Frontend.Lexer.Wrapper
- import Frontend.Autogen.Lexer
- import Frontend.Lexer.Tokens
- import Frontend.Parser.Posn
- import Frontend.Syntax
-
- import qualified Prelude
- import Prelude hiding (span)
-
- import Debug.Trace
-
- import Control.Monad
-
- import Errors
- }
-
- %name exp 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 _ _) _ _ }
-
- VARSYM { Token (TokUnqualOp VarId _) _ _ }
- CONSYM { Token (TokUnqualOp ConId _) _ _ }
-
- QVARSYM { Token (TokQualOp VarId _ _) _ _ }
- QCONSYM { Token (TokQualOp 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 _ _ }
- '`' { Token TokTick _ _ }
-
- 'let' { Token TokLet _ _ }
- 'in' { Token TokIn _ _ }
- 'data' { Token TokData _ _ }
- 'case' { Token TokCase _ _ }
- 'of' { Token TokOf _ _ }
- 'module' { Token TokModule _ _ }
- 'where' { Token TokWhere _ _ }
-
- 'import' { Token TokImport _ _ }
- 'as' { Token TokAs _ _ }
- 'qualified' { Token TokQualified _ _ }
-
- 'foreign' { Token TokForeign _ _ }
- 'export' { Token TokExport _ _ }
- 'safe' { Token TokSafe _ _ }
- 'unsafe' { Token TokUnsafe _ _ }
- 'ccall' { Token TokCCall _ _ }
-
- %%
-
- Exp :: { Exp }
- : InfixExp '::' Type { span $1 $3 $ Annot $1 $3 }
- | InfixExp { $1 }
-
- InfixExp :: { Exp }
- : LeftExp {- ... -} { $1 }
- | LeftExp qop InfixExp { span $1 $3 $ Infix $1 $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 }
- | gcon { span $1 $1 $ Con $1 }
- | '(' CommaList1(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 }
- | gtycon { span $1 $1 $ Tycon $1 }
- | '[' Type ']' { span $1 $3 $ Tylist $2 }
- | '(' CommaList1(Type) ')' { span $1 $3 $ makeTupleType $2 }
-
- Pat :: { Pat }
- : Lpat { $1 }
-
- Lpat :: { Pat }
- : Apat { $1 }
- | gcon Apat List(Apat) { span $1 (endOfListPos $2 $3) (ConPat $1 ($2 : $3)) }
- | Lpat qconop Pat { span $1 $3 $ InfixPat $1 $2 $3 }
-
- Apat :: { Pat }
- : VAR { span $1 $1 $ Var (getVar $1) }
- | gcon { span $1 $1 $ ConPat $1 [] }
- | '_' { span $1 $1 $ Wildcard }
- | '(' CommaList1(Pat) ')' { span $1 $3 $ makeTuplePattern $2 }
-
- Decl :: { Decl }
- : CommaList1(VAR) '::' Type { TySig (getVar `fmap` $1) $3 (startPosn (head $1)) (endPosn $3) }
- | VAR Apat List(Apat) Rhs { FunDecl (getVar $1) ($2:$3) $4 (startPosn $1) (endPosn $4) }
- | Pat Rhs { PatDecl $1 $2 (startPosn $1) (endPosn $2) }
-
- Rhs :: { Rhs }
- : '=' Exp { BareRhs $2 [] (startPosn $1) (endPosn $2) }
- | '=' Exp 'where' LaidOutList(Decl) { BareRhs $2 (thd $4) (startPosn $1) (endPosn $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)
- {% do { (imports,items) <- spanModuleItems (thd $5)
- ; pure $ Module { moduleName = toModId (getVar $2)
- , moduleExports = fst $3
- , moduleImports = imports
- , moduleItems = items }
- }
- }
-
- ImportExportList :: { (Maybe [NamespacedItem ParsedVar], Maybe Posn) }
- : {-empty-} { (Nothing, Nothing) }
- | '(' CommaList(NSItem) ')' { (Just $2, Just (endPosn $3)) }
-
- NSItem :: { NamespacedItem ParsedVar }
- : VAR { IEVar (getVar $1) }
- | CON { IECon (getVar $1) }
- | 'module' CON { IEModule (getVar $2) }
-
- ModItem :: { Item }
- : Decl { ModDecl $1 (startPosn $1) (endPosn $1) }
- | Import { ModImport $1 (startPosn $1) (endPosn $1) }
- | 'foreign' FfiItem { ModFfi $2 (startPosn $1) (endPosn $2) }
-
- Import :: { ModuleImport ParsedVar }
- : 'import' modid ImportExportList
- { Import $2 (fst $3) False Nothing (startPosn $1) (fromMaybe (endPosn $2) (snd $3)) }
-
- | 'import' modid ImportExportList 'as' CON
- { Import $2 (fst $3) False (Just (getVar $5)) (startPosn $1) (endPosn $5) }
-
- | 'import' 'qualified' modid ImportExportList
- { Import $3 (fst $4) True Nothing (startPosn $1) (fromMaybe (endPosn $3) (snd $4)) }
-
- | 'import' 'qualified' modid ImportExportList 'as' CON
- { Import $3 (fst $4) True (Just (getVar $6)) (startPosn $1) (endPosn $6) }
-
- FfiItem :: { FfiItem ParsedVar }
- : 'import' CallConv Safety Entity VAR '::' Type
- -- 1 2 3 4 5 6 7
- {% do { ffiDesc <- traverse parseForeignItem $4
- ; pure $ FfiImport
- { fiVarName = getVar $5
- , fiType = $7
- , fiCallConv = $2
- , fiSafety = $3
- , fiItem = ffiDesc
- , fiBegin = startPosn $1
- , fiEnd = endPosn $7 }
- } }
- | 'import' CallConv VAR error
- {% do { state <- getUserState
- ; (here, _, _, _) <- alexGetInput
- ; let vartk = $3
- ; case lastToken state of
- Just tok -> alexThrow $ \fn ->
- emptyError { errorMessage = "malformed foreign import (did you spell safe/unsafe incorrectly?)"
- , errorInlineDesc = Just "this token was interpreted as a variable name"
- , errorBegin = startPosn vartk
- , errorEnd = startPosn vartk
- , errorFilename = fn
- , errorPointers = pointTo tok tok "so this token should have been part of a type signature"
- }
- Nothing -> alexError "no last token?"
- }
- }
- | 'export' CallConv Entity VAR '::' Type
- -- 1 2 3 4 5 6
- {% do { ffiDesc <-
- case $3 of
- Nothing -> pure Nothing
- Just x ->
- let Posn l c = startPosn x
- in parseCid (Posn l (c + 1)) 0 (getString x)
- ; pure $ FfiExport
- { fiVarName = getVar $4
- , fiType = $6
- , fiCallConv = $2
- , fiExpCid = ffiDesc
- , fiBegin = startPosn $1
- , fiEnd = endPosn $6 }
- } }
-
- Safety :: { Maybe FfiSafety }
- : {-empty-} { Nothing }
- | 'safe' { Just Safe }
- | 'unsafe' { Just Unsafe }
-
- CallConv :: { FfiCallConv }
- : 'ccall' { CC_CCall }
- | error
- {% do { state <- getUserState
- ; (here, _, _, _) <- alexGetInput
- ; case lastToken state of
- Just tok -> alexThrow $ \fn ->
- emptyError { errorMessage = "ahc only supports the 'ccall' calling convention"
- , errorInlineDesc = Just ("unexpected " ++ show (tokenClass tok))
- , errorBegin = startPosn tok
- , errorEnd = here
- , errorFilename = fn
- }
- Nothing -> alexError "no last token?"
- }
- }
-
- Entity :: { Maybe Token }
- : {-empty-} { Nothing }
- | STRING { Just $1 }
-
- Opt(p)
- : { () }
- | p { () }
-
- Semis
- : ';' Semis { () }
- | ';' { () }
-
- qvarid :: { ParsedVar }
- qvarid
- : VAR { getVar $1 }
- | QVAR { getVar $1 }
-
- qvar :: { ParsedVar }
- : qvarid { $1 }
- | '(' qvarsym ')' { span $1 $3 $2 }
-
- qconid :: { ParsedVar }
- qconid
- : CON { getVar $1 }
- | QCON { getVar $1 }
-
- qcon :: { ParsedVar }
- qcon
- : qconid { $1 }
- | '(' qconsym ')' { span $1 $3 $2 }
-
- qvarsym :: { ParsedVar }
- qvarsym : VARSYM { getVar $1 }
- | QVARSYM { getVar $1 }
-
- qconsym :: { ParsedVar }
- qconsym : CONSYM { getVar $1 }
- | QCONSYM { getVar $1 }
-
- qvarop :: { ParsedVar }
- : qvarsym { $1 }
- | '`' qvar '`' { span $1 $3 $2 }
-
- qconop :: { ParsedVar }
- : qconsym { $1 }
- | '`' qcon '`' { span $1 $3 $2 }
-
- qop :: { ParsedVar }
- : qvarop { $1 }
- | qconop { $1 }
-
- gcon :: { ParsedVar }
- : qcon { $1 }
- | '(' Commas ')' { BuiltinId { varId = tupleConSymName $2
- , varBuiltin = BuiltinTuple $2
- , varBegin = startPosn $1
- , varEnd = endPosn $3 }
- }
-
- | '[' ']' { BuiltinId { varId = T.pack "[]"
- , varBuiltin = BuiltinNil
- , varBegin = startPosn $1
- , varEnd = endPosn $2 }
- }
-
- gtycon :: { ParsedVar }
- : gcon { $1 }
- | '(' '->' ')' { BuiltinId { varId = T.pack "[]"
- , varBuiltin = BuiltinArrow
- , varBegin = startPosn $1
- , varEnd = endPosn $2 }
- }
-
- Commas :: { Int }
- : {- empty -} { 0 }
- | ',' Commas { (let x = $2 in x `seq` 1 + x) }
-
- modid : qconid { 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 = do
- tok <- alexMonadScan
- mapUserState $ \s -> s { lastToken = Just tok }
- cont tok
-
- parseError (token, expected) = do
- (here, _, _, _) <- alexGetInput
- alexThrow $ \fn -> emptyError { errorMessage = "expecting one of: " ++ unwords expected
- , errorInlineDesc = Just ("unexpected " ++ show (tokenClass token))
- , errorBegin = startPosn token
- , errorEnd = here
- , errorFilename = fn
- }
-
- 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 tok@(Token (TokQualOp _ p s) _ _) = QualVar { varId = s, varPrefix = p, varBegin = startPosn tok, varEnd = endPosn tok }
- getVar tok@(Token (TokUnqualOp _ 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] =
- case x of
- SPType ParenType{} _ _ -> x
- _ -> ParenType x
- makeTupleType xs = Tytup xs
-
- makeTuplePattern [x] =
- case x of
- SPPat ParenPat{} _ _ -> x
- _ -> ParenPat x
- makeTuplePattern xs = TupPat xs
-
- makeTuple [x] =
- case x of
- SPExpr ParenExp{} _ _ -> x
- _ -> ParenExp x
- makeTuple xs = Tuple xs
-
- spanModuleItems xs = do
- let
- isImport (ModImport _ _ _) = True
- isImport _ = False
-
- (imports, items) = Prelude.span isImport xs
-
- forM_ items $ \x -> case x of
- ModImport _ start end ->
- alexThrow $ \fname ->
- emptyError { errorMessage = "all import statements should be at the top of the file."
- , errorInlineDesc = Just "unexpected import statement"
- , errorFilename = fname
- , errorBegin = start
- , errorEnd = end
- }
- _ -> pure ()
-
- pure (map itemImport imports, items)
-
- tupleConSymName :: Int -> T.Text
- tupleConSymName n = T.singleton '(' <> T.replicate n (T.singleton ',') <> T.singleton ')'
-
- endOfListPos :: HasPosn x => x -> [x] -> Posn
- endOfListPos x [] = endPosn x
- endOfListPos _ xs = endPosn (last xs)
-
- }
|