Abbie's Haskell compiler
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 

276 lines
7.7 KiB

{
{-# 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)
}