|
{
|
|
{-# LANGUAGE FlexibleContexts, FlexibleInstances, ViewPatterns #-}
|
|
module Frontend.Autogen.Parser where
|
|
|
|
import qualified Data.Text as T
|
|
import Data.Maybe
|
|
|
|
import Frontend.Lexer.Wrapper
|
|
import Frontend.Lexer.Tokens
|
|
import Frontend.Parser.Posn
|
|
import Frontend.Syntax
|
|
import Frontend.Autogen.Lexer
|
|
|
|
import qualified Prelude
|
|
import Prelude hiding (span)
|
|
|
|
import Debug.Trace
|
|
|
|
import Control.Monad
|
|
}
|
|
|
|
%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 (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) }
|
|
|
|
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) }
|
|
|
|
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
|
|
|
|
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 ->
|
|
ParseError { parseErrorMessage = "all import statements should be at the top of the file."
|
|
, parseErrorInlineDesc = Just "unexpected import statement"
|
|
, parseErrorFilename = fname
|
|
, parseErrorBegin = start
|
|
, parseErrorEnd = end
|
|
}
|
|
_ -> pure ()
|
|
|
|
pure (map itemImport imports, items)
|
|
}
|