ajhc-0.8.0.1: src/FrontEnd/HsParser.y
{-# OPTIONS_GHC -w -XNoOverloadedStrings #-} {- -*- Haskell -*- -}
-- -----------------------------------------------------------------------------
-- $Id: HsParser.ly,v 1.4 2001/11/25 08:52:13 bjpop Exp $
-- (c) Simon Marlow, Sven Panne 1997-2000
-- Modified by John Meacham
-- Haskell grammar.
-- -----------------------------------------------------------------------------
-- ToDo: Is (,) valid as exports? We don't allow it.
-- ToDo: Check exactly which names must be qualified with Prelude (commas and friends)
-- ToDo: Inst (MPCs?)
-- ToDo: Polish constr a bit
-- ToDo: Ugly: infixexp is used for lhs, pat, exp0, ...
-- ToDo: Differentiate between record updates and labeled construction.
{
module FrontEnd.HsParser (parse, parseHsStmt) where
import FrontEnd.HsSyn
import FrontEnd.ParseMonad
import FrontEnd.Lexer
import FrontEnd.ParseUtils hiding(readInteger,readRational)
import FrontEnd.SrcLoc
import Name.Names
import Name.Name
import Control.Monad (liftM, liftM2)
import Debug.Trace (trace)
}
-- -----------------------------------------------------------------------------
-- Conflicts: 10 shift/reduce
-- 7 for abiguity in 'if x then y else z + 1'
-- (shift parses as 'if x then y else (z + 1)', as per longest-parse rule)
-- 1 for ambiguity in 'if x then y else z :: T'
-- (shift parses as 'if x then y else (z :: T)', as per longest-parse rule)
-- 2 for ambiguity in 'case x of y :: a -> b'
-- (don't know whether to reduce 'a' as a btype or shift the '->'.
-- conclusion: bogus expression anyway, doesn't matter)
-- -----------------------------------------------------------------------------
%token
VARID { VarId $$ }
QVARID { QVarId $$ }
CONID { ConId $$ }
QCONID { QConId $$ }
VARSYM { VarSym $$ }
CONSYM { ConSym $$ }
QVARSYM { QVarSym $$ }
QCONSYM { QConSym $$ }
INT { IntTok $$ }
UINT { UIntTok $$ }
RATIONAL { FloatTok $$ }
CHAR { Character $$ }
UCHAR { UCharacter $$ }
STRING { StringTok $$ }
USTRING { UStringTok $$ }
PRAGMAOPTIONS { PragmaOptions $$ }
PRAGMASTART { PragmaStart $$ }
PRAGMACTYPE { PragmaExp "CTYPE" }
PRAGMAINLINE { PragmaInline $$ }
PRAGMARULES { PragmaRules $$ }
PRAGMASPECIALIZE { PragmaSpecialize $$ }
PRAGMAEND { PragmaEnd }
-- Symbols
'(' { LeftParen }
')' { RightParen }
'(#' { LeftUParen }
'#)' { RightUParen }
';' { SemiColon }
'{' { LeftCurly }
'}' { RightCurly }
vccurly { VRightCurly } -- a virtual close brace
'[' { LeftSquare }
']' { RightSquare }
',' { Comma }
'_' { Underscore }
'`' { BackQuote }
-- Reserved operators
'..' { DotDot }
'::' { DoubleColon }
'=' { Equals }
'\\' { Backslash }
'|' { Bar }
'<-' { LeftArrow }
'->' { RightArrow }
'@' { At }
'~' { Tilde }
'=>' { DoubleArrow }
'-' { Minus }
'!' { Exclamation }
'bang!' { BangExclamation }
'?' { Quest }
'??' { QuestQuest }
'*!' { StarBang }
'*' { Star }
'#' { Hash }
'.' { Dot }
-- Reserved Ids
'as' { KW_As }
'case' { KW_Case }
'class' { KW_Class }
'alias' { KW_Alias }
'data' { KW_Data }
'default' { KW_Default }
'deriving' { KW_Deriving }
'do' { KW_Do }
'else' { KW_Else }
'hiding' { KW_Hiding }
'if' { KW_If }
'import' { KW_Import }
'in' { KW_In }
'infix' { KW_Infix }
'infixl' { KW_InfixL }
'infixr' { KW_InfixR }
'instance' { KW_Instance }
'let' { KW_Let }
'module' { KW_Module }
'newtype' { KW_NewType }
'of' { KW_Of }
'then' { KW_Then }
'type' { KW_Type }
'where' { KW_Where }
'qualified' { KW_Qualified }
'foreign' { KW_Foreign }
'forall' { KW_Forall }
'exists' { KW_Exists }
'kind' { KW_Kind }
'family' { KW_Family }
'closed' { KW_Closed }
%monad { P } { thenP } { returnP }
%lexer { lexer } { EOF }
%name parse module
%name parseHsStmt qual
%tokentype { Token }
%%
-- -----------------------------------------------------------------------------
-- Module Header
module :: { HsModule }
: srcloc modulep { $2 { hsModuleSrcLoc = $1, hsModuleOptions = [] } }
| srcloc PRAGMAOPTIONS module { $3 { hsModuleSrcLoc = $1, hsModuleOptions = hsModuleOptions $3 ++ $2 } }
modulep :: { HsModule }
: 'module' modid maybeexports 'where' body { HsModule { hsModuleName = $2, hsModuleExports = $3, hsModuleImports = (fst $5), hsModuleDecls = (snd $5)
, hsModuleSrcLoc = error "hsModuleSrcLoc not set", hsModuleOptions = error "hsModuleOptions not set" } }
| body { HsModule { hsModuleName = main_mod, hsModuleExports = Just [HsEVar (toName Val "main")], hsModuleImports = (fst $1), hsModuleDecls = (snd $1)
, hsModuleSrcLoc = error "hsModuleSrcLoc not set", hsModuleOptions = error "hsModuleOptions not set" } }
body :: { ([HsImportDecl],[HsDecl]) }
: '{' bodyaux '}' { $2 }
| layout_on bodyaux close { $2 }
bodyaux :: { ([HsImportDecl],[HsDecl]) }
: optsemis impdecls semis topdecls { (reverse $2, fixupHsDecls $4) }
| optsemis topdecls { ([], fixupHsDecls $2) }
| optsemis impdecls optsemis { (reverse $2, []) }
| optsemis { ([], []) }
optsemi :: { () }
: ';' { () }
| {- empty -} { () }
semis :: { () }
: optsemis ';' { () }
optsemis :: { () }
: semis { () }
| {- empty -} { () }
-- -----------------------------------------------------------------------------
-- The Export List
maybeexports :: { Maybe [HsExportSpec] }
: exports { Just $1 }
| {- empty -} { Nothing }
exports :: { [HsExportSpec] }
: '(' exportlist maybecomma ')' { reverse $2 }
| '(' ')' { [] }
maybecomma :: { () }
: ',' { () }
| {- empty -} { () }
exportlist :: { [HsExportSpec] }
: exportlist ',' export { $3 : $1 }
| export { [$1] }
export :: { HsExportSpec }
: qvar { HsEVar $1 }
| qtyconorcls { HsEAbs $1 }
| qtyconorcls '(' '..' ')' { HsEThingAll $1 }
| qtyconorcls '(' ')' { HsEThingWith $1 [] }
| qtyconorcls '(' qcnames ')' { HsEThingWith $1 (reverse $3) }
| 'module' modid { HsEModuleContents $2 }
qcnames :: { [HsName] }
: qcnames ',' qcname { $3 : $1 }
| qcname { [$1] }
qcname :: { HsName }
: qvar { $1 }
| qcon { $1 }
-- -----------------------------------------------------------------------------
-- Import Declarations
impdecls :: { [HsImportDecl] }
: impdecls semis impdecl { $3 : $1 }
| impdecl { [$1] }
impdecl :: { HsImportDecl }
: 'import' srcloc optqualified modid maybeas maybeimpspec
{ HsImportDecl $2 $4 $3 $5 $6 }
optqualified :: { Bool }
: 'qualified' { True }
| {- empty -} { False }
maybeas :: { Maybe Module }
: 'as' modid { Just $2 }
| {- empty -} { Nothing }
maybeimpspec :: { Maybe (Bool, [HsExportSpec]) }
: impspec { Just $1 }
| {- empty -} { Nothing }
impspec :: { (Bool, [HsExportSpec]) }
: '(' importlist maybecomma ')' { (False, reverse $2) }
| '(' ')' { (False, []) }
| 'hiding' '(' importlist maybecomma ')' { (True, reverse $3) }
| 'hiding' '(' ')' { (True, []) }
importlist :: { [HsExportSpec] }
: importlist ',' import { $3 : $1 }
| import { [$1] }
import :: { HsExportSpec }
: var { HsEVar $1 }
| tyconorcls { HsEAbs $1 }
| tyconorcls '(' '..' ')' { HsEThingAll $1 }
| tyconorcls '(' ')' { HsEThingWith $1 [] }
| tyconorcls '(' cnames ')' { HsEThingWith $1 (reverse $3) }
| 'class' import { HsEQualified ClassName $2 }
| 'type' import { HsEQualified TypeConstructor $2 }
| 'kind' import { HsEQualified SortName $2 }
cnames :: { [HsName] }
: cnames ',' cname { $3 : $1 }
| cname { [$1] }
cname :: { HsName }
: var { $1 }
| con { $1 }
-- -----------------------------------------------------------------------------
-- Fixity Declarations
fixdecl :: { HsDecl }
: srcloc infix prec ops { HsInfixDecl $1 $2 $3 (reverse $4) }
prec :: { Int }
: {- empty -} { 9 }
| INT {% checkPrec $1 `thenP` \p ->
returnP (fromInteger (readInteger p)) }
infix :: { HsAssoc }
: 'infix' { HsAssocNone }
| 'infixl' { HsAssocLeft }
| 'infixr' { HsAssocRight }
ops :: { [HsName] }
: ops ',' op { $3 : $1 }
| op { [$1] }
-- -----------------------------------------------------------------------------
-- Top-Level Declarations
-- Note: The report allows topdecls to be empty. This would result in another
-- shift/reduce-conflict, so we don't handle this case here, but in bodyaux.
topdecls :: { [HsDecl] }
: topdecls1 optsemis { reverse $1 } -- TODO checkRevDecls
topdecls1 :: { [HsDecl] }
: topdecls1 semis topdecl { $3 : $1 }
| topdecl { [$1] }
mkind :: { Maybe HsKind }
: '::' kind { Just $2 }
| { Nothing }
mCTYPE :: { Maybe String }
: PRAGMACTYPE STRING PRAGMAEND { Just $2 }
| { Nothing }
topdecl :: { HsDecl }
: 'data' mCTYPE ctype srcloc deriving
{% checkDataHeader $3 `thenP` \(cs,c,t) ->
returnP hsDataDecl { hsDeclSrcLoc = $4, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclDerives = $5, hsDeclCTYPE = $2 } }
| 'data' mCTYPE ctype '::' kind srcloc deriving
{% checkDataHeader $3 `thenP` \(cs,c,t) ->
returnP hsDataDecl { hsDeclSrcLoc = $6, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclDerives = $7, hsDeclHasKind = Just $5, hsDeclCTYPE = $2 } }
| 'data' 'family' simpletype srcloc mkind
{ HsTypeFamilyDecl $4 True (fst $3) (snd $3) $5 }
| 'type' 'family' simpletype srcloc mkind
{ HsTypeFamilyDecl $4 False (fst $3) (snd $3) $5 }
| 'data' 'kind' ctype srcloc '=' constrs deriving
{% checkDataHeader $3 `thenP` \(cs,c,t) ->
returnP hsDataDecl { hsDeclDeclType = DeclTypeKind, hsDeclSrcLoc = $4, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclDerives = $7, hsDeclCons = reverse $6 } }
| 'data' mCTYPE ctype srcloc '=' constrs deriving
{% checkDataHeader $3 `thenP` \(cs,c,t) ->
returnP hsDataDecl { hsDeclSrcLoc = $4, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclDerives = $7, hsDeclCons = reverse $6, hsDeclCTYPE = $2 } }
| 'newtype' mCTYPE ctype srcloc '=' constr deriving
{% checkDataHeader $3 `thenP` \(cs,c,t) ->
returnP hsNewTypeDecl { hsDeclSrcLoc = $4, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclCons = [$6], hsDeclDerives = $7, hsDeclCTYPE = $2} }
| 'class' srcloc classhead optfundep optcbody
{ HsClassDecl $2 $3 $5 }
| 'class' 'alias' srcloc conid varids '=' carhs optcbody
{% let
{ (cxt, clss) = $7;
ret = HsClassAliasDecl { hsDeclSrcLoc = $3, hsDeclName = $4, hsDeclTypeArgs = map HsTyVar $5, hsDeclContext = cxt, hsDeclClasses = clss, hsDeclDecls =$8 }
} in trace ("\n"++show ret++"\n") (return ret)
}
| 'instance' srcloc classhead optvaldefs
{ HsInstDecl $2 $3 $4 }
| 'deriving' 'instance' srcloc classhead
{ HsDeclDeriving $3 $4 }
| 'default' srcloc type
{ HsDefaultDecl $2 $3 }
| pinfixexp srcloc '<-' exp {% checkPattern $1 `thenP` \p ->
returnP (HsActionDecl $2 p $4) }
| 'foreign' srcloc 'import' varids mstring '::' ctype
{% doForeign $2 (toName Val "import":reverse $4) $5 $7 }
| 'foreign' srcloc varids mstring '::' ctype
{% doForeign $2 (reverse $3) $4 $6 }
| 'foreign' srcloc varids mstring '::' ctype '=' exp
{% doForeignEq $2 (reverse $3) $4 $6 $8 }
| PRAGMARULES rules PRAGMAEND
{ HsPragmaRules $ map (\x -> x { hsRuleIsMeta = $1 }) (reverse $2) }
| srcloc PRAGMASPECIALIZE var '::' type PRAGMAEND
{ HsPragmaSpecialize { hsDeclSrcLoc = $1, hsDeclBool = $2, hsDeclName = $3, hsDeclType = $5
, hsDeclUniq = error "hsDeclUniq not set" } }
| srcloc PRAGMASPECIALIZE conid var '::' type PRAGMAEND
{ HsPragmaSpecialize { hsDeclSrcLoc = $1, hsDeclBool = $2, hsDeclName = $4, hsDeclType = $6
, hsDeclUniq = error "hsDeclUniq not set" } }
| decl { $1 }
rule :: { HsRule }
: srcloc STRING mfreevars exp '=' exp
{ HsRule { hsRuleSrcLoc = $1, hsRuleString = $2, hsRuleFreeVars = $3, hsRuleLeftExpr = $4, hsRuleRightExpr = $6
, hsRuleUniq = error "hsRuleUniq not set", hsRuleIsMeta = error "hsRuleIsMeta not set" } }
rules :: { [HsRule] }
: rules ';'rule { $3 : $1 }
| rules ';' { $1 }
| rule { [$1] }
| {- empty -} { [] }
mfreevars :: { [(HsName,Maybe HsType)] }
: 'forall' vbinds '.' { $2 }
| { [] }
vbinds :: { [(HsName,Maybe HsType)] }
: vbinds '(' var '::' type ')' { ($3,Just $5) : $1 }
| vbinds var { ($2,Nothing) : $1 }
| { [] }
decls :: { [HsDecl] }
: optsemis decls1 optsemis { fixupHsDecls ( reverse $2 ) }
| optsemis { [] }
decls1 :: { [HsDecl] }
: decls1 semis decl { $3 : $1 }
| decl { [$1] }
decl :: { HsDecl }
: signdecl { $1 }
| fixdecl { $1 }
| valdef { $1 }
| pragmaprops { $1 }
decllist :: { [HsDecl] }
: '{' decls '}' { $2 }
| layout_on decls close { $2 }
signdecl :: { HsDecl }
: vars srcloc '::' ctype { HsTypeSig $2 (reverse $1) $4 }
pragmainline :: { HsDecl }
: PRAGMAINLINE srcloc optphasesn vars PRAGMAEND { HsPragmaProps $2 $1 $4 }
optphasesn :: { (Bool, Maybe Int) }
: '~' optphases { (True, $2) }
| optphases { (False, $1) }
optphases :: { Maybe Int }
: '[' INT ']' { (Just (readInteger $2)) }
| { Nothing }
pragmaprops :: { HsDecl }
: PRAGMASTART srcloc vars PRAGMAEND { HsPragmaProps $2 $1 $3 }
--pragmaexp :: { Located HsPragmaExp }
-- : PRAGMAEXP srcloc texps srcloc PRAGMAEND
-- { located ($2,$4) $ HsPragmaExp $1 $3 }
-- ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var
-- instead of qvar, we get another shift/reduce-conflict. Consider the
-- following programs:
-- { (+) :: ... } only var
-- { (+) x y = ... } could (incorrectly) be qvar
-- We re-use expressions for patterns, so a qvar would be allowed in patterns
-- instead of a var only (which would be correct). But deciding what the + is,
-- would require more lookahead. So let's check for ourselves...
vars :: { [HsName] }
: vars ',' var { $3 : $1 }
| qvar {% checkUnQual $1 `thenP` \n ->
returnP [n] }
-- FFI parts
mstring :: { Maybe (String,HsName) }
mstring : STRING var { Just ($1,$2) }
| {- empty -} { Nothing }
-- -----------------------------------------------------------------------------
-- Types
type :: { HsType }
: btype '->' type { HsTyFun $1 $3 }
| btype { $1 }
| 'forall' tbinds '.' ctype { HsTyForall { hsTypeVars = reverse $2, hsTypeType = $4 } }
| 'exists' tbinds '.' ctype { HsTyExists { hsTypeVars = reverse $2, hsTypeType = $4 } }
tbinds :: { [HsTyVarBind] }
: tbinds tbind { $2 : $1 }
| tbind { [$1] }
tbind :: { HsTyVarBind }
: srcloc varid { hsTyVarBind { hsTyVarBindSrcLoc = $1, hsTyVarBindName = $2 } }
| srcloc '(' varid '::' kind ')' { hsTyVarBind { hsTyVarBindSrcLoc = $1, hsTyVarBindName = $3, hsTyVarBindKind = Just $5 } }
kind :: { HsKind }
: bkind { $1 }
| bkind '->' kind { HsKindFn $1 $3 }
bkind :: { HsKind }
: '(' kind ')' { $2 }
| '*' { hsKindStar }
| '#' { hsKindHash }
| '!' { hsKindBang }
| 'bang!' { hsKindBang }
| '*!' { hsKindStarBang }
| '?' { hsKindQuest }
| '??' { hsKindQuestQuest }
| qconid { HsKind $1 }
btype :: { HsType }
: btype atype { HsTyApp $1 $2 }
| atype { $1 }
atype :: { HsType }
: gtycon { HsTyCon $1 }
| tyvar { HsTyVar $1 }
| '(' types ')' { HsTyTuple (reverse $2) }
| '(#' '#)' { HsTyUnboxedTuple [] }
| '(#' type '#)' { HsTyUnboxedTuple [$2] }
| '(#' types '#)' { HsTyUnboxedTuple (reverse $2) }
| '[' type ']' { HsTyApp list_tycon $2 }
| '(' ktype ')' { $2 }
| '(' type '=' type ')' { HsTyEq $2 $4 }
ktype :: { HsType }
: srcloc atype '::' kind srcloc { HsTyExpKind { hsTyLType = located ($1,$5) $2, hsTyKind = $4 } }
| type { $1 }
gtycon :: { HsName }
: qcon { $1 }
| '(' ')' { unit_tycon_name }
| '(' '->' ')' { fun_tycon_name }
| '[' ']' { list_tycon_name }
| '(' commas ')' { tuple_tycon_name $2 }
-- (Slightly edited) Comment from GHC's hsparser.y:
-- "context => type" vs "type" is a problem, because you can't distinguish between
-- foo :: (Baz a, Baz a)
-- bar :: (Baz a, Baz a) => [a] -> [a] -> [a]
-- with one token of lookahead. The HACK is to parse the context as a btype
-- (more specifically as a tuple type), then check that it has the right form
-- C a, or (C1 a, C2 b, ... Cn z) and convert it into a context. Blaach!
ctype :: { HsQualType }
: context '=>' type { HsQualType $1 $3 }
| type { HsQualType [] $1 }
context :: { HsContext }
: btype {% checkContext $1 }
carhs :: { (HsContext, HsContext) }
: btype '=>' btype {% liftM2 (,) (checkContext $1) (checkContext $3) }
| btype {% liftM ((,) []) (checkContext $1) }
classhead :: { HsClassHead }
: ctype {% qualTypeToClassHead $1 }
types :: { [HsType] }
: types ',' type { $3 : $1 }
| type ',' type { [$3, $1] }
simpletype :: { (HsName, [HsType]) }
: tycon atypes { ($1,reverse $2) }
atypes :: { [HsType] }
: atypes atype { $2 : $1 }
| {- empty -} { [] }
-- -----------------------------------------------------------------------------
-- Datatype declarations
constrs :: { [HsConDecl] }
: constrs '|' constr { $3 : $1 }
| constr { [$1] }
constr :: { HsConDecl }
: srcloc mexists scontype { HsConDecl { hsConDeclSrcLoc = $1, hsConDeclName = (fst $3), hsConDeclConArg = (snd $3), hsConDeclExists = $2 } }
| srcloc mexists sbtype conop sbtype { HsConDecl { hsConDeclSrcLoc = $1, hsConDeclName = $4, hsConDeclConArg = [$3,$5], hsConDeclExists = $2 } }
| srcloc mexists con '{' fielddecls '}'
{ HsRecDecl { hsConDeclSrcLoc = $1, hsConDeclName = $3, hsConDeclRecArg = (reverse $5), hsConDeclExists = $2 } }
| srcloc mexists con '{' '}'
{ HsRecDecl { hsConDeclSrcLoc = $1, hsConDeclName = $3, hsConDeclRecArg = [], hsConDeclExists = $2 } }
mexists :: { [HsTyVarBind] }
: 'exists' tbinds '.' { $2 }
| 'forall' tbinds '.' { $2 } -- Allowed for GHC compatability
| { [] }
scontype :: { (HsName, [HsBangType]) }
: btype {% splitTyConApp $1 `thenP` \(c,ts) ->
returnP (c,map HsUnBangedTy ts) }
| scontype1 { $1 }
scontype1 :: { (HsName, [HsBangType]) }
: btype '!' atype {% splitTyConApp $1 `thenP` \(c,ts) ->
returnP (c,map HsUnBangedTy ts++
[HsBangedTy $3]) }
| btype 'bang!' atype {% splitTyConApp $1 `thenP` \(c,ts) ->
returnP (c,map HsUnBangedTy ts++
[HsBangedTy $3]) }
| scontype1 satype { (fst $1, snd $1 ++ [$2] ) }
satype :: { HsBangType }
: atype { HsUnBangedTy $1 }
| '!' atype { HsBangedTy $2 }
| 'bang!' atype { HsBangedTy $2 }
sbtype :: { HsBangType }
: btype { HsUnBangedTy $1 }
| '!' atype { HsBangedTy $2 }
| 'bang!' atype { HsBangedTy $2 }
fielddecls :: { [([HsName],HsBangType)] }
: fielddecls ',' fielddecl { $3 : $1 }
| fielddecl { [$1] }
fielddecl :: { ([HsName],HsBangType) }
: vars '::' stype { (reverse $1, $3) }
stype :: { HsBangType }
: type { HsUnBangedTy $1 }
| '!' atype { HsBangedTy $2 }
| 'bang!' atype { HsBangedTy $2 }
deriving :: { [HsName] }
: {- empty -} { [] }
| 'deriving' qtycls { [$2] }
| 'deriving' '(' ')' { [] }
| 'deriving' '(' dclasses ')' { reverse $3 }
dclasses :: { [HsName] }
: dclasses ',' qtycls { $3 : $1 }
| qtycls { [$1] }
-- -----------------------------------------------------------------------------
-- Class declarations
optcbody :: { [HsDecl] }
: 'where' decllist { fixupHsDecls $2 }
| {- empty -} { [] }
cdefaults :: { [HsDecl] }
: cdefaults ';' valdef { $3 : $1 }
| valdef { [$1] }
-- -----------------------------------------------------------------------------
-- Functional dependencies
optfundep :: { [([HsName],[HsName])] }
: {- empty -} { [] }
| '|' fundeps { reverse $2 }
fundeps :: { [([HsName],[HsName])] }
: fundeps ',' fundep { ($3:$1) }
| fundep { [$1] }
fundep :: { ([HsName],[HsName]) }
: varids '->' varids { ($1,$3) }
varids :: { [HsName] }
: {- empty -} { [] }
| varids varid { ($2:$1) }
-- -----------------------------------------------------------------------------
-- Instance declarations
optvaldefs :: { [HsDecl] }
: 'where' '{' valdefs '}' { $3 }
| 'where' layout_on valdefs close { $3 }
| {- empty -} { [] }
-- Recycling...
valdefs :: { [HsDecl] }
: cdefaults optsemi { fixupHsDecls (reverse $1) }
| optsemi { [] }
-- -----------------------------------------------------------------------------
-- Value definitions
valdef :: { HsDecl }
: 'type' simpletype srcloc '=' type
{ HsTypeDecl $3 (fst $2) (snd $2) $5 }
-- | 'data' simpletype srcloc
-- { HsTypeFamilyDecl $3 True (fst $2) (snd $2) Nothing }
-- | 'data' simpletype srcloc '::' kind
-- { HsTypeFamilyDecl $3 True (fst $2) (snd $2) (Just $5) }
| 'type' simpletype srcloc
{ HsTypeFamilyDecl $3 False (fst $2) (snd $2) Nothing }
| 'type' simpletype srcloc '::' kind
{ HsTypeFamilyDecl $3 False (fst $2) (snd $2) (Just $5) }
| pinfixexp srcloc rhs optwhere {% checkValDef $2 $1 $3 $4}
| srcloc PRAGMASPECIALIZE 'instance' type PRAGMAEND
{ HsPragmaSpecialize { hsDeclSrcLoc = $1, hsDeclBool = $2, hsDeclName = nameName u_instance , hsDeclType = $4
, hsDeclUniq = error "hsDeclUniq not set" } }
| pragmainline { $1 }
optwhere :: { [HsDecl] }
: 'where' decllist { $2 }
| {- empty -} { [] }
rhs :: { HsRhs }
: '=' exp {% checkExpr $2 `thenP` \e ->
returnP (HsUnGuardedRhs e) }
| gdrhs { HsGuardedRhss (reverse $1) }
gdrhs :: { [HsGuardedRhs] }
: gdrhs gdrh { $2 : $1 }
| gdrh { [$1] }
gdrh :: { HsGuardedRhs }
: '|' exp srcloc '=' exp {% checkExpr $2 `thenP` \g ->
checkExpr $5 `thenP` \e ->
returnP (HsGuardedRhs $3 g e) }
-- -----------------------------------------------------------------------------
-- Expressions
exp :: { HsExp }
: infixexp '::' srcloc ctype { HsExpTypeSig $3 $1 $4 }
| infixexp { $1 }
infixexp :: { HsExp }
: exp10 { $1 }
| infixexp qop exp10 { HsInfixApp $1 $2 $3 }
exp10 :: { HsExp }
: '\\' aexps srcloc '->' exp {% checkPatterns (reverse $2) `thenP` \ps ->
returnP (HsLambda $3 ps $5) }
| 'let' decllist 'in' exp { HsLet $2 $4 }
-- -- > | 'if' exp 'then' exp 'else' exp { HsIf $2 $4 $6 }
| 'if' exp optsemi 'then' exp optsemi 'else' exp { HsIf $2 $5 $8 }
| 'case' exp 'of' altslist { HsCase $2 $4 }
| '-' fexp { HsNegApp $2 }
| 'do' stmtlist { HsDo $2 }
| fexp { $1 }
fexp :: { HsExp }
: fexp aexp { HsApp $1 $2 }
| aexp { $1 }
aexps :: { [HsExp] }
: aexps aexp { $2 : $1 }
| aexp { [$1] }
-- UGLY: Because patterns and expressions are mixed, aexp has to be split into
-- two rules: One left-recursive and one right-recursive. Otherwise we get two
-- reduce/reduce-errors (for as-patterns and irrefutable patters).
-- Note: The first alternative of aexp is not neccessarily a record update, it
-- could be a labeled construction, too.
aexp :: { HsExp }
: aexp '{' fbinds '}' {% mkRecConstrOrUpdate $1 (reverse $3) }
| aexp1 { $1 }
-- Even though the variable in an as-pattern cannot be qualified, we use
-- qvar here to avoid a shift/reduce conflict, and then check it ourselves
-- (as for vars above).
aexp1 :: { HsExp }
: qvar { HsVar $1 }
| gcon { $1 }
| literal { $1 }
| '(' exp ')' { HsParen $2 }
| '(' texps ')' { HsTuple (reverse $2) }
| '(#' '#)' { HsUnboxedTuple [] }
| '(#' exp '#)' { HsUnboxedTuple [$2] }
| '(#' texps '#)' { HsUnboxedTuple (reverse $2) }
| '[' list ']' { $2 }
| '(' infixexp qop ')' { HsLeftSection $3 $2 }
| '(' qopm infixexp ')' { HsRightSection $3 $2 }
| qvar '@' aexp {% checkUnQual $1 `thenP` \n ->
returnP (HsAsPat n $3) }
| srcloc '_' { HsWildCard $1 }
| '~' srcloc aexp1 srcloc { HsIrrPat $ located ($2,$4) $3 }
| 'bang!' srcloc aexp1 srcloc { HsBangPat $ located ($2,$4) $3 }
commas :: { Int }
: commas ',' { $1 + 1 }
| ',' { 1 }
texps :: { [HsExp] }
: texps ',' exp { $3 : $1 }
| exp ',' exp { [$3,$1] }
-- -----------------------------------------------------------------------------
-- List expressions
-- The rules below are little bit contorted to keep lexps left-recursive while
-- avoiding another shift/reduce-conflict.
list :: { HsExp }
: exp { HsList [$1] }
| lexps { HsList (reverse $1) }
| exp '..' { HsEnumFrom $1 }
| exp ',' exp '..' { HsEnumFromThen $1 $3 }
| exp '..' exp { HsEnumFromTo $1 $3 }
| exp ',' exp '..' exp { HsEnumFromThenTo $1 $3 $5 }
| exp '|' quals { HsListComp $1 (reverse $3) }
lexps :: { [HsExp] }
: lexps ',' exp { $3 : $1 }
| exp ',' exp { [$3,$1] }
-- -----------------------------------------------------------------------------
-- Expressions
pexp :: { HsExp }
: pinfixexp '::' srcloc ctype { HsExpTypeSig $3 $1 $4 }
| pinfixexp { $1 }
pinfixexp :: { HsExp }
: pexp10 { $1 }
| pinfixexp qop pexp10 { HsInfixApp $1 $2 $3 }
pexp10 :: { HsExp }
: '-' pfexp { HsNegApp $2 }
| pfexp { $1 }
pfexp :: { HsExp }
: pfexp paexp { HsApp $1 $2 }
| paexp { $1 }
-- UGLY: Because patterns and expressions are mixed, aexp has to be split into
-- two rules: One left-recursive and one right-recursive. Otherwise we get two
-- reduce/reduce-errors (for as-patterns and irrefutable patters).
-- Note: The first alternative of aexp is not neccessarily a record update, it
-- could be a labeled construction, too.
paexp :: { HsExp }
: paexp '{' pfbinds '}' {% mkRecConstrOrUpdate $1 (reverse $3) }
| paexp '{' '}' {% mkRecConstrOrUpdate $1 [] }
| paexp1 { $1 }
-- Even though the variable in an as-pattern cannot be qualified, we use
-- qvar here to avoid a shift/reduce conflict, and then check it ourselves
-- (as for vars above).
paexp1 :: { HsExp }
: qvar { HsVar $1 }
| gcon { $1 }
| literal { $1 }
| '(' pexp ')' { HsParen $2 }
| '(' ptexps ')' { HsTuple (reverse $2) }
| '(#' '#)' { HsUnboxedTuple [] }
| '(#' pexp '#)' { HsUnboxedTuple [$2] }
| '(#' ptexps '#)' { HsUnboxedTuple (reverse $2) }
| '[' plist ']' { $2 }
| '(' pinfixexp qop ')' { HsLeftSection $3 $2 }
| '(' qopm pinfixexp ')' { HsRightSection $3 $2 }
| qvar '@' paexp {% checkUnQual $1 `thenP` \n ->
returnP (HsAsPat n $3) }
| srcloc '_' { HsWildCard $1 }
| '~' srcloc paexp1 srcloc { HsIrrPat $ located ($2,$4) $3 }
| 'bang!' srcloc paexp1 srcloc { HsBangPat $ located ($2,$4) $3 }
ptexps :: { [HsExp] }
: ptexps ',' pexp { $3 : $1 }
| pexp ',' pexp { [$3,$1] }
-- -----------------------------------------------------------------------------
-- List expressions
-- The rules below are little bit contorted to keep lexps left-recursive while
-- avoiding another shift/reduce-conflict.
plist :: { HsExp }
: pexp { HsList [$1] }
| plexps { HsList (reverse $1) }
plexps :: { [HsExp] }
: plexps ',' pexp { $3 : $1 }
| pexp ',' pexp { [$3,$1] }
-- -----------------------------------------------------------------------------
-- List comprehensions
quals :: { [HsStmt] }
: quals ',' qual { $3 : $1 }
| qual { [$1] }
qual :: { HsStmt }
: exp srcloc '<-' exp {% checkPattern $1 `thenP` \p ->
returnP (HsGenerator $2 p $4) }
| exp { HsQualifier $1 }
| 'let' decllist { HsLetStmt $2 }
-- -----------------------------------------------------------------------------
-- Case alternatives
altslist :: { [HsAlt] }
: '{' alts optsemi '}' { reverse $2 }
| layout_on alts optsemi close { reverse $2 }
alts :: { [HsAlt] }
: alts ';' alt { $3 : $1 }
| alt { [$1] }
alt :: { HsAlt }
: pinfixexp srcloc ralt optwhere {% checkPattern $1 `thenP` \p ->
returnP (HsAlt $2 p $3 $4) }
ralt :: { HsRhs }
: '->' exp { HsUnGuardedRhs $2 }
| gdpats { HsGuardedRhss (reverse $1) }
gdpats :: { [HsGuardedRhs] }
: gdpats gdpat { $2 : $1 }
| gdpat { [$1] }
gdpat :: { HsGuardedRhs }
: '|' exp srcloc '->' exp { HsGuardedRhs $3 $2 $5 }
-- -----------------------------------------------------------------------------
-- Statement sequences
stmtlist :: { [HsStmt] }
: '{' stmts '}' { $2 }
| layout_on stmts close { $2 }
stmts :: { [HsStmt] }
: stmt stmts1 { $1:$2 }
| ';' stmts { $2 }
| {- empty -} { [] }
stmts1 :: { [HsStmt] }
: ';' stmts { $2 }
| { [] }
stmt :: { HsStmt }
: qual { $1 }
-- -----------------------------------------------------------------------------
-- Record Field Update/Construction
fbinds :: { [HsFieldUpdate] }
: fbinds ',' fbind { $3 : $1 }
| fbind { [$1] }
fbind :: { HsFieldUpdate }
: qvar '=' exp { HsFieldUpdate $1 $3 }
pfbinds :: { [HsFieldUpdate] }
: pfbinds ',' pfbind { $3 : $1 }
| pfbind { [$1] }
pfbind :: { HsFieldUpdate }
: qvar '=' pexp { HsFieldUpdate $1 $3 }
-- -----------------------------------------------------------------------------
-- Variables, Constructors and Operators.
gcon :: { HsExp }
: '(' ')' { unit_con }
| '[' ']' { HsList [] }
| '(' commas ')' { tuple_con $2 }
| qcon { HsCon $1 }
var :: { HsName }
: varid { $1 }
| '(' varsym ')' { $2 }
qvar :: { HsName }
: qvarid { $1 }
| '(' qvarsym ')' { $2 }
con :: { HsName }
: conid { $1 }
| '(' consym ')' { $2 }
qcon :: { HsName }
: qconid { $1 }
| '(' qconsym ')' { $2 }
varop :: { HsName }
: varsym { $1 }
| '`' varid '`' { $2 }
qvarop :: { HsName }
: qvarsym { $1 }
| '`' qvarid '`' { $2 }
qvaropm :: { HsName }
: qvarsymm { $1 }
| '`' qvarid '`' { $2 }
conop :: { HsName }
: consym { $1 }
| '`' conid '`' { $2 }
qconop :: { HsName }
: qconsym { $1 }
| '`' qconid '`' { $2 }
op :: { HsName }
: varop { $1 }
| conop { $1 }
qop :: { HsExp }
: qvarop { HsVar $1 }
| qconop { HsCon $1 }
qopm :: { HsExp }
: qvaropm { HsVar $1 }
| qconop { HsCon $1 }
qvarid :: { HsName }
: varid { $1 }
| QVARID { $1 }
varid :: { HsName }
: VARID { $1 }
| 'as' { as_name }
| 'alias' { toName UnknownType "alias" }
| 'kind' { toName UnknownType "kind" }
| 'closed' { toName UnknownType "closed" }
| 'family' { toName UnknownType "family" }
| 'qualified' { qualified_name }
| 'hiding' { hiding_name }
| 'forall' { toName UnknownType "forall" }
| 'exists' { toName UnknownType "exists" }
qconid :: { HsName }
: conid { $1 }
| QCONID { $1 }
conid :: { HsName }
: CONID { $1 }
qconsym :: { HsName }
: consym { $1 }
| QCONSYM { $1 }
consym :: { HsName }
: CONSYM { $1 }
qvarsym :: { HsName }
: varsym { $1 }
| qvarsym1 { $1 }
qvarsymm :: { HsName }
: varsymm { $1 }
| qvarsym1 { $1 }
varsym :: { HsName }
: VARSYM { $1 }
| '-' { minus_name }
| '!' { pling_name }
| 'bang!' { pling_name }
| '?' { toName UnknownType "?" }
| '??' { toName UnknownType "??" }
| '*!' { toName UnknownType "*!" }
| '*' { star_name }
| '#' { hash_name }
| '.' { dot_name }
varsymm :: { HsName } -- varsym not including '-'
: VARSYM { $1 }
| '!' { pling_name }
| 'bang!' { pling_name }
| '*' { star_name }
| '#' { hash_name }
| '.' { dot_name }
qvarsym1 :: { HsName }
: QVARSYM { $1 }
literal :: { HsExp }
: INT { HsLit (HsInt (readInteger $1)) }
| UINT { HsLit (HsIntPrim (readInteger $1)) }
| CHAR { HsLit (HsChar $1) }
| UCHAR { HsLit (HsCharPrim $1) }
| RATIONAL { HsLit (HsFrac (readRational $1)) }
| STRING { HsLit (HsString $1) }
| USTRING { HsLit (HsStringPrim $1) }
srcloc :: { SrcLoc } : {% getSrcLoc }
-- -----------------------------------------------------------------------------
-- Layout
close :: { () }
: vccurly { () } -- context popped in lexer.
| error {% popContext }
layout_on :: { () } : {% getSrcLoc `thenP` \sl ->
pushCurrentContext }
-- pushCurrentContext (Layout (srcLocColumn sl)) }
-- -----------------------------------------------------------------------------
-- Miscellaneous (mostly renamings)
modid :: { Module }
: CONID { toModule $ show $1 }
| QCONID { toModule $ show $1 } -- (fst $1 ++ "." ++ snd $1) }
tyconorcls :: { HsName }
: conid { $1 }
tycon :: { HsName }
: conid { $1 }
qtyconorcls :: { HsName }
: qconid { $1 }
qtycls :: { HsName }
: qconid { $1 }
tyvar :: { HsName }
: varid { $1 }
-- -----------------------------------------------------------------------------
{
{-# NOINLINE parse #-}
{-# NOINLINE parseHsStmt #-}
parse :: P HsModule
parseHsStmt :: P HsStmt
happyError = parseError "Parse error"
--hsSymbol x = HsIdent x
readInteger x = fromIntegral x
readRational x = x
as_name = toName UnknownType "as"
derive_name = toName UnknownType "derive"
qualified_name = toName UnknownType "qualified"
hiding_name = toName UnknownType "hiding"
minus_name = toName UnknownType "-"
pling_name = toName UnknownType "!"
star_name = toName UnknownType "*"
hash_name = toName UnknownType "#"
dot_name = toName UnknownType "."
prelude_mod = toModule "Prelude"
main_mod = toModule "Main"
tuple_con_name i = toName DataConstructor (toModule "Jhc.Prim.Prim","("++replicate i ','++")")
unit_con = HsCon { {-hsExpSrcSpan = bogusSrcSpan,-} hsExpName = dc_Unit }
tuple_con i = HsCon { {-hsExpSrcSpan = bogusSrcSpan,-} hsExpName = (tuple_con_name i) }
unit_tycon_name = tc_Unit
fun_tycon_name = tc_Arrow
list_tycon_name = toName UnknownType "[]"
tuple_tycon_name i = tuple_con_name i
list_tycon = HsTyCon list_tycon_name
toUnqualName n = toName UnknownType (Nothing :: Maybe Module,n)
}