HaRe-0.6: tools/base/parse/extras/HsParser.y
-- $Id: HsParser.y,v 1.16 2001/11/24 04:55:36 hallgren Exp $
-- New Low-level Haskell Parser
-- Bill Harrison and Emir Pasalic and Andrew Moran and Thomas Hallgren
--
-- Note:
-- This parser is based on Simon Marlow and Sven Panne's (1997,1998) Haskell
-- grammar for Happy.
-- The parser does not correspond strictly to the grammar of standard
-- Haskell. Rather, it relies on a number of postprocessing steps that
-- (1) validate the rather leaky terms produced by the and discard invalid
-- programs
-- (2) perform a small amount of rewriting (e.g., for infix operator
-- precedences)
{
module HsParser (parse) where
import Syntax
import SyntaxUtil
import ParseMonad
import Lexer
import LexUtil(readInteger, readRational)
import ParseUtil
--import Rewrite
import IOExts
import Char(showLitChar)
}
%token
VARID { VarId $$ }
QVARID { QVarId $$ }
CONID { ConId $$ }
QCONID { QConId $$ }
'-' { VarSym "-" }
VARSYM { VarSym $$ }
CONSYM { ConSym $$ }
QVARSYM { QVarSym $$ }
QCONSYM { QConSym $$ }
QMODID { QModId $$ }
INT { IntTok $$ }
RATIONAL { FloatTok $$ }
CHAR { Character $$ }
STRING { StringTok $$ }
--- Symbols --------------------------
'(' { LeftParen }
')' { RightParen }
';' { SemiColon }
'{' { LeftCurly }
'}' { RightCurly }
vccurly { VRightCurly } -- a virtual close brace
'[' { LeftSquare }
']' { RightSquare }
',' { Comma }
'_' { Underscore }
'`' { BackQuote }
'.' { Period } -- must be a token so it can matched in
-- property quantifier expressions; it
-- must be turned into an id when not
-- matched thus, or used in a float.
--- Reserved operators ----------------
'..' { DotDot }
'::' { DoubleColon }
'=' { Equals }
'\\' { Backslash }
'|' { Bar }
'<-' { LeftArrow }
'->' { RightArrow }
'@' { At }
'~' { Tilde }
'=>' { DoubleArrow }
-- '-' { Minus }
'!' { Exclamation }
--- Reserved Ids ----------------------
'as' { KW_As }
'case' { KW_Case }
'class' { KW_Class }
'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 }
'primitive' { KW_Primitive }
{-
-- Additions for property syntax
'property' { KW_Property }
'All' { KW_QAll }
'Ex' { KW_QExists }
'AllDef' { KW_QAllDef }
'ExU' { KW_QExistsU }
-}
%monad { PM } { thenPM } { returnPM }
%lexer { lexer } { EOF }
%name parse
%tokentype { Token }
%%
{-
-----------------------------------------------------------------------------
Module Header
-}
module :: { HsModuleR }
: srcloc 'module' modid maybeexports 'where' body
{ hsModule $1 $3 $4 $6 }
| srcloc body { hsModule $1 main_mod Nothing $2 }
body :: { ([HsImportDecl], [HsDecl]) }
: '{' bodyaux '}' { $2 }
| open bodyaux close { $2 }
bodyaux :: { ([HsImportDecl], [HsDecl]) }
: impdecls ';' topdecls optsemi { ($1, $3) }
| topdecls optsemi { ([], $1) }
| impdecls optsemi { ($1, []) }
| {- empty -} { ([], []) }
optsemi :: { () }
: ';' { () }
| {- 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 ';' 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, [HsImportSpec]) }
: impspec { Just $1 }
| {- empty -} { Nothing }
impspec :: { (Bool, [HsImportSpec]) }
: '(' optimportlist maybecomma ')' { (False, reverse $2) }
| 'hiding' '(' optimportlist maybecomma ')' { (True, reverse $3) }
optimportlist :: { [HsImportSpec] }
: maybecomma { [] }
| importlist maybecomma { $1 }
importlist :: { [HsImportSpec] }
: importlist ',' import { $3 : $1 }
| import { [$1] }
import :: { HsImportSpec }
: var { HsIVar $1 }
| tyconorcls { HsIAbs $1 }
| tyconorcls '(' '..' ')' { HsIThingAll $1 }
| tyconorcls '(' ')' { HsIThingWith $1 [] }
| tyconorcls '(' cnames ')' { HsIThingWith $1 (reverse $3) }
cnames :: { [HsName] }
: cnames ',' cname { $3 : $1 }
| cname { [$1] }
cname :: { HsName }
: var { $1 }
| con { $1 }
{-
-----------------------------------------------------------------------------
Top-level declarations.
-}
topdecls :: { [HsDecl] }
: topdecls ';' topdecl { funCons $3 $1 }
| topdecl { [$1] }
{-
-----------------------------------------------------------------------------
Fixity Declarations
checkPrec has been eliminated; fixities may now be negative => must be added
to the static check.
-}
fix :: { HsDecl }
: infix srcloc prec ops { hsInfixDecl $2 (HsFixity $1 $3) $4 }
prec :: { Int }
: {- empty -} { 9 }
| INT { fromInteger (readInteger $1) }
infix :: { HsAssoc }
: 'infix' { HsAssocNone }
| 'infixl' { HsAssocLeft }
| 'infixr' { HsAssocRight }
ops :: { [HsIdent] }
: op ',' ops { $1 : $3 }
| 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] }
: topdecls ';' topdecl { funCons $3 $1 }
| topdecl { [$1] }
-}
topdecl :: { HsDecl }
: 'type' tyconparams srcloc '=' type
{ hsTypeDecl $3 $2 $5 }
| 'data' srcloc ctyconparams '=' constrs deriving
{ hsDataDecl $2 (fst $3) (snd $3) (reverse $5) $6 }
| 'newtype' srcloc ctyconparams '=' constr deriving
{ hsNewTypeDecl $2 (fst $3) (snd $3) $5 $6 }
| 'class' srcloc ctype optfundeps optcbody
{ hsClassDecl $2 (fst $3) (snd $3) $4 $5 }
| 'instance' srcloc ctype optvaldefs
{ hsInstDecl $2 (fst $3) (snd $3) $4 }
| 'default' srcloc type
{ hsDefaultDecl $2 $3 }
-- Hugs compatibility
| 'data' srcloc ctybinding
{ hsPrimitiveTypeDecl $2 (fst $3) (snd $3) }
| 'primitive' srcloc var '::' type
{ hsPrimitiveBind $2 $3 $5 }
| decl { $1 }
optfundeps :: { HsFunDeps HsType }
: { [] }
| '|' fundeps { $2 }
fundeps :: { HsFunDeps HsType }
: fundep { [$1] }
| fundep ',' fundeps { $1:$3 }
fundep :: { HsFunDep HsType }
: tyvars '->' tyvars { ($1,$3) }
tyvars :: { [HsType] }
: { [] }
| typarams { $1 }
decls :: { [HsDecl] }
: decls1 optsemi { reverse $1 }
| optsemi { [] }
decls1 :: { [HsDecl] }
: decls1 ';' decl { funCons $3 $1 }
| decl { [$1] }
decl :: { HsDecl }
: signdecl { $1 }
| fix { $1 }
| valdef { $1 }
{-
-- Property declarations
| propdecl { $1 }
-}
decllist :: { [HsDecl] }
: '{' decls '}' { $2 }
| open decls close { $2 }
signdecl :: { HsDecl }
: vars srcloc '::' ctype
{ hsTypeSig $2 (reverse $1) (fst $4) (snd $4) }
{-
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:
{ (+) :: ... } A "signdecl" where everything to the left of the
:: is parsed as "vars" which should allow only var
{ (+) x y = ... } A "valdef" where everything to the left of the
= is parsed as an "infixexp" which (incorrectly
in this context) allows a "qvar", since "infixexp"
is also used to parse patterns where "qvar" is
allowed
This leads to a shift/reduce-conflict. The parser must decide without too much
lookahead. By allowing a qvar as the first thing in "vars" the parser shifts
(until it sees a "," or a "::") and doesn't get confused. Without this,
deciding what to do with requires more lookahead. So let's allow "qvar" in
"vars" and then check for ourselves afterwards that this didn't happen.
-}
vars :: { [HsName] }
: vars ',' var { $3 : $1 }
| qvar {% case $1 of
Qual _ _ -> parseError "bad qvar in vars."
_ -> return [$1]
}
{-
-----------------------------------------------------------------------------
Types
-}
type :: { HsType }
: btype '->' type { hsTyFun $1 $3 }
| btype { $1 }
btype :: { HsType }
: btype atype { hsTyApp $1 $2 }
| atype { $1 }
atype :: { HsType }
: gtycon { hsTyCon $1 }
| tyvar { hsTyVar $1 }
| '(' types ')' { hsTyTuple (reverse $2) }
| '[' type ']' { hsTyApp list_tycon $2 }
| '(' type ')' { $2 }
gtycon :: { HsName }
: qtycon { $1 }
| '(' ')' { unit_tycon_name }
| '[' ']' { list_tycon_name }
| '(' '->' ')' { fun_tycon_name }
| '(' commas ')' { tuple_tycon_name $2 }
{- There is no need to qualify special syntax, since it *always* refers to
things defined in Prelude... /TH
-- These next three are not strictly Haskell 98, but are accepted by
-- GHC. Their omission from the report seems to be a bug, since
-- without this, one cannot import the Prelude qualified and refer to
-- the type construtors (), [], or the tuple type constructors.
| QMODID '.' '(' ')' { qualify $1 "()" }
| QMODID '.' '[' ']' { qualify $1 "[]" }
| QMODID '.' '(' commas ')' { qualify $1 (tuple $4) }
-}
{-
(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 :: { ([HsType],HsType) }
: type '=>' type { (reverse (tupleTypeToContext $1), $3) }
| type { ([], $1) }
types :: { [HsType] }
: types ',' type { $3 : $1 }
| type ',' type { [$3, $1] }
ctyconparams :: { ([HsType], [HsType]) }
: type '=>' tyconparams { (reverse (tupleTypeToContext $1), $3) }
| tyconparams { ([], $1) }
-- Replacing tycon with gtycon as an experiment: /TH
tyconparams :: { [HsType] }
: gtycon typarams { hsTyCon $1 : reverse $2 }
| gtycon { [hsTyCon $1] }
typarams :: { [HsType] }
: typarams tyvar { hsTyVar $2 : $1 }
| tyvar { [hsTyVar $1] }
ctybinding :: { ([HsType], HsName) }
: ctyconparams {% case snd $1 of
[Typ (HsTyCon nm)] -> return (fst $1,nm)
_ -> parseError "Primitive types are not allowed to have parameters" }
{-
-----------------------------------------------------------------------------
Datatype declarations
-}
constrs :: { [HsConDecl HsType ] }
: constrs '|' constr { $3 : $1 }
| constr { [$1] }
constr :: { HsConDecl HsType }
: srcloc scontype { HsConDecl $1 (fst $2) (snd $2) }
| srcloc sbtype conop sbtype { HsConDecl $1 $3 [$2, $4] }
| srcloc con '{' fielddecls '}'
{ HsRecDecl $1 $2 (reverse $4) }
scontype :: { (HsName, [HsBangType HsType]) }
: btype {% do { (c, ts) <- splitTyConApp $1 ;
return (c, map HsUnBangedType ts)
}
}
| scontype1 { $1 }
-- | '(' qconsym ')' satypes { ($2,$4) }
scontype1 :: { (HsName, [HsBangType HsType]) }
: btype '!' atype
{% do { (c, ts) <- splitTyConApp $1 ;
return (c, map HsUnBangedType ts ++ [HsBangedType $3])
}
}
| scontype1 satype
{ (fst $1, snd $1 ++ [$2] ) }
{-
satypes :: { [HsBangType HsType] }
: { [] }
| satype satypes { $1:$2 }
-}
satype :: { HsBangType HsType }
: atype { HsUnBangedType $1 }
| '!' atype { HsBangedType $2 }
sbtype :: { HsBangType HsType }
: btype { HsUnBangedType $1 }
| '!' atype { HsBangedType $2 }
fielddecls :: { [([HsName], HsBangType HsType)] }
: fielddecls ',' fielddecl { $3 : $1 }
| fielddecl { [$1] }
fielddecl :: { ([HsName], HsBangType HsType) }
: vars '::' stype { (reverse $1, $3) }
stype :: { HsBangType HsType}
: type { HsUnBangedType $1 }
| '!' atype { HsBangedType $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' '{' cbody '}' { $3 }
| 'where' open cbody close { $3 }
| {- empty -} { [] }
cbody :: { [HsDecl] }
: cmethods ';' cdefaults optsemi { reverse $1 ++ reverse $3 }
| cmethods optsemi { reverse $1 }
| optsemi { [] }
cmethods :: { [HsDecl] }
: cmethods ';' signdecl { funCons $3 $1 }
| signdecl { [$1] }
cdefaults :: { [HsDecl] }
: cdefaults ';' valdef { funCons $3 $1 }
| valdef { [$1] }
{-
-----------------------------------------------------------------------------
Instance declarations
-}
optvaldefs :: { [HsDecl] }
: 'where' '{' valdefs '}' { $3 }
| 'where' open valdefs close { $3 }
| {- empty -} { [] }
{-
Recycling...
-}
valdefs :: { [HsDecl] }
: cdefaults optsemi { reverse $1 }
| optsemi { [] }
{-
-----------------------------------------------------------------------------
Value definitions
-}
{-
valdef :: { HsDecl }
: infixexp srcloc rhs optwheredecls
{% if isPatternExp $1
then mkValDef $1 $2 $3 $4
else mkFunDef $1 $2 $3 $4
}
-}
valdef :: { HsDecl }
: funlhs srcloc rhs optwheredecls { mkFunDef' $1 $2 $3 $4 }
| infixpat srcloc rhs optwheredecls { hsPatBind $2 $1 $3 $4 }
funlhs :: { (HsName,[HsPat]) }
: qvar apats1 { ($1,$2) }
| infixpat qvarop infixpat { ($2,[$1,$3]) }
| '(' funlhs ')' apats { (fst $2,snd $2++$4) }
-- ^ Haskell 98 requires apats1 (at least one apat)
optwheredecls :: { [HsDecl] }
: 'where' decllist { $2 }
| {- empty -} { [] }
rhs :: { HsRhs HsExp }
: '=' exp { HsBody $2 }
| gdrhss { HsGuard (reverse $1) }
gdrhss :: { [(SrcLoc, HsExp, HsExp)] }
: gdrhss gdrhs { $2 : $1 }
| gdrhs { [$1] }
gdrhs :: { (SrcLoc, HsExp, HsExp) }
: '|' exp srcloc '=' exp { ($3, $2, $5) }
{-
-----------------------------------------------------------------------------
Expressions
-}
exp :: { HsExp }
: infixexp '::' srcloc ctype { hsExpTypeSig $3 $1 (fst $4) (snd $4) }
| infixexp { $1 }
infixexp :: { HsExp }
: exp10 { $1 }
| infixexp qop exp10 { hsInfixApp $1 $2 $3 }
{-
From MPJ's Tool0 Hugs98 parser.y:
| qfier pats '.' exp {$$ = gc4(ap(QUANTIFY,
ap($1,
pair(rev($2),
pair($3,$4)))));}
-}
exp10 :: { HsExp }
: '\\' apats '->' exp { hsLambda $2 $4 }
{-% do { ps <- mapM expToPat $2 ;
return (hsLambda (reverse ps) $4)
}
-}
{-
| quant pats '.' exp
{% do { ps <- mapM expToPat $2 ;
return (hsPropQuant (reverse ps) $4)
}
}
-}
| 'let' decllist 'in' exp { hsLet $2 $4 }
| 'if' exp 'then' exp 'else' exp { hsIf $2 $4 $6 }
| 'case' exp 'of' altslist { hsCase $2 $4 }
| '-' fexp { hsNegApp $2 }
| 'do' stmtlist { hsDo (atoms2Stmt $2) }
| fexp { $1 }
fexp :: { HsExp }
: fexp aexp { hsApp $1 $2 }
| aexp { $1 }
{-
aexps :: { [HsExp] }
: aexps aexp { $2 : $1 }
| aexp { [$1] }
-}
{-
Note: The first alternative of aexp is not neccessarily a record update, it
could be a labeled construction, too.
-}
aexp :: { HsExp }
: aexp '{' fbinds '}' { mkRecord $1 (reverse $3) }
| aexp1 { $1 }
aexp1 :: { HsExp }
: qvar { hsEVar ($1 :: HsName) }
| gcon { $1 }
| literal { hsLit $1 }
| '(' exp ')' { hsParen $2 }
| '(' texps ')' { hsTuple (reverse $2) }
| '[' list ']' { $2 }
| '(' infixexp qop ')' { hsLeftSection $2 $3 }
| '(' qop infixexp ')' { hsRightSection $2 $3 }
| qvar '@' aexp1 { hsAsPat $1 $3 }
| '_' { hsWildCard }
| '~' aexp1 { hsIrrPat $2 }
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 (atoms2Stmt (reverse $3 ++ [HsQualifierAtom $1])) }
lexps :: { [HsExp] }
: lexps ',' exp { $3 : $1 }
| exp ',' exp { [$3,$1] }
{-
-----------------------------------------------------------------------------
List comprehensions
-}
quals :: { [HsStmtAtom HsExp HsPat [HsDecl] ] }
: quals ',' qual { $3 : $1 }
| qual { [$1] }
qual :: { HsStmtAtom HsExp HsPat [HsDecl] }
: infixexp '<-' exp {% do { p <- expToPat $1 ;
return (HsGeneratorAtom p $3)
}
}
| exp { HsQualifierAtom $1 }
| 'let' decllist { HsLetStmtAtom $2 }
{-
-----------------------------------------------------------------------------
Case alternatives
-}
altslist :: { [HsAlt HsExp HsPat [HsDecl]] }
: '{' alts optsemi '}' { reverse $2 }
| open alts optsemi close { reverse $2 }
alts :: { [HsAlt HsExp HsPat [HsDecl]] }
: alts ';' alt { $3 : $1 }
| alt { [$1] }
alt :: { HsAlt HsExp HsPat [HsDecl] }
: infixpat srcloc rhscasealts { HsAlt $2 $1 $3 [] }
{-% do { p <- expToPat $1 ;
return (HsAlt $2 p $3 [])
}
-}
| infixpat srcloc rhscasealts 'where' decllist { HsAlt $2 $1 $3 $5 }
{-% do { p <- expToPat $1 ;
return (HsAlt $2 p $3 $5)
}
-}
rhscasealts :: { HsRhs HsExp }
: '->' exp { HsBody $2 }
| gdcaserhss { HsGuard (reverse $1) }
gdcaserhss :: { [(SrcLoc, HsExp, HsExp)] }
: gdcaserhss gdcaserhs { $2 : $1 }
| gdcaserhs { [$1] }
gdcaserhs :: { (SrcLoc, HsExp, HsExp) }
: '|' srcloc exp '->' exp { ($2, $3, $5) }
{-
-----------------------------------------------------------------------------
Statement sequences
-}
stmtlist :: { [HsStmtAtom HsExp HsPat [HsDecl]] }
: '{' stmts '}' { $2 }
| open stmts close { $2 }
stmts :: { [HsStmtAtom HsExp HsPat [HsDecl]] }
: stmts1 ';' exp { reverse (HsQualifierAtom $3 : $1) }
| exp { [HsQualifierAtom $1] }
stmts1 :: { [HsStmtAtom HsExp HsPat [HsDecl]] }
: stmts1 ';' qual { $3 : $1 }
| qual { [$1] }
--- Record Field Update/Construction -------------------------------------------
fbinds :: { [HsFieldUpdate HsExp] }
: { [] }
| fbinds1 { $1 }
fbinds1 :: { [HsFieldUpdate HsExp] }
: fbinds1 ',' fbind { $3 : $1 }
| fbind { [$1] }
fbind :: { HsFieldUpdate HsExp }
: qvar '=' exp { HsFieldUpdate $1 $3 }
-- | qvar { HsFieldBind $1 }
--- Patterns -------------------------------------------------------------------
pat :: { HsPat }
: infixpat { $1 }
-- | n+k
infixpat :: { HsPat }
: pat10 { $1 }
| infixpat qconop pat10 { hsPInfixApp $1 (HsCon $2) $3 }
pat10 :: { HsPat }
: qcon apats1 { hsPApp $1 $2 } -- should be gcon...
| '-' numlit { hsPNeg (hsPLit $2) }
| apat { $1 }
apat :: { HsPat }
: qvar { hsPVar $1 }
| qvar '@' apat { hsPAsPat $1 $3 }
| qcon { hsPCon $1 } -- should be gcon...
| '(' ')' { hsPCon (qualify "Prelude" "()") }
| qcon '{' fpats '}' { hsPRec $1 $3 }
| literal { hsPLit $1 }
| '_' { hsPWildCard }
| '(' pat ')' { hsPParen $2 }
| '(' tpats ')' { hsPTuple $2 }
| '[' lpats ']' { hsPList $2 }
| '~' apat { hsPIrrPat $2 }
apats1 :: { [HsPat] }
: apat apats { $1 : $2 }
apats :: { [HsPat] }
: { [] }
| apat apats { $1 : $2 }
fpats :: { [HsPatField HsPat] }
: { [] }
| fpats1 { $1 }
fpats1 :: { [HsPatField HsPat] }
: fpat ',' fpats1 { $1 : $3 }
| fpat { [$1] }
fpat :: { HsPatField HsPat }
: qvar '=' pat { HsPFieldPat $1 $3 }
tpats :: { [HsPat] }
: pat ',' tpats { $1 : $3 }
| pat ',' pat { [$1, $3] }
lpats :: { [HsPat] }
: { [] }
| lpats1 { $1 }
lpats1 :: { [HsPat] }
: pat ',' lpats { $1 : $3 }
| pat { [$1] }
{-
-----------------------------------------------------------------------------
Variables, Constructors and Operators.
-}
gcon :: { HsExp }
: '(' ')' { hsECon (qualify "Prelude" "()") }
| '[' ']' { hsList [] }
| '(' commas ')' { hsECon (qualify "Prelude" (tuple $2)) }
-- These next three are not strictly Haskell 98, but are accepted by
-- GHC. Their omission from the report seems to be a bug, since
-- without this, one cannot import the Prelude qualified and refer to
-- the values (), [], or the tuple constructors. It's unclear what
-- effect of qualifying the nil list would actually have, since it is
-- otherwise treated separately (i.e., there is no VARSYM called
-- "[]"). Since it can't reused, according to the report, I have
-- treated the same as an unqualified [], ignoring the qualifying
-- module. AKM
| QMODID '.' '(' ')' { hsECon (qualify $1 "()") }
| QMODID '.' '[' ']' { hsList [] }
| QMODID '.' '(' commas ')' { hsECon (qualify $1 (tuple $4)) }
| qcon { hsECon $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 :: { HsIdent }
: varop { hsVar $1 }
| conop { hsCon $1 }
qop :: { HsIdent }
: qvarop { hsVar $1 }
| qconop { hsCon $1 }
{-
qopm :: { HsIdent }
: qvaropm { hsVar $1 }
| qconop { hsCon $1 }
-}
qvarid :: { HsName }
: varid { $1 }
| QVARID { uncurry (Qual . Module) $1 }
varid :: { HsName }
: VARID { UnQual $1 }
| 'as' { as_name }
| 'qualified' { qualified_name }
| 'hiding' { hiding_name }
qconid :: { HsName }
: conid { $1 }
| QCONID { uncurry (Qual . Module) $1 }
qtycon :: { HsName }
: tycon { $1 }
| QCONID { uncurry (Qual . Module) $1 }
conid :: { HsName }
: CONID { UnQual $1 }
qconsym :: { HsName }
: consym { $1 }
| QCONSYM { uncurry (Qual . Module) $1 }
consym :: { HsName }
: CONSYM { UnQual $1 }
qvarsym :: { HsName }
: varsym { $1 }
| qvarsym1 { $1 }
{-
qvarsymm :: { HsName }
: varsymm { $1 }
| qvarsym1 { $1 }
-}
varsym :: { HsName }
: VARSYM { UnQual $1 }
| '-' { minus_name }
| '!' { pling_name }
| '.' { period_name }
{-
varsymm :: { HsName } -- varsym not including '-'
: VARSYM { UnQual $1 }
| '!' { pling_name }
| '.' { period_name }
-}
qvarsym1 :: { HsName }
: QVARSYM { uncurry (Qual . Module) $1 }
literal :: { HsLiteral }
: numlit { $1 }
| CHAR { HsChar $1 }
| STRING { HsString $1 }
numlit :: { HsLiteral }
: INT { HsInt (readInteger $1) }
| RATIONAL { HsFrac (readRational $1) }
srcloc :: { SrcLoc } : {% getSrcLoc }
--- Layout ---------------------------------------------------------------------
open :: { () }
: {% do { SrcLoc _ _ c <- getSrcLoc ;
pushContext (Layout c)
}
}
close :: { () }
: vccurly { () } -- context popped in lexer.
| error {% popContext }
--- Miscellaneous (mostly renamings) -------------------------------------------
modid :: { Module }
: CONID { Module $1 }
tyconorcls :: { HsName }
: conid { $1 }
tycon :: { HsName }
: conid { $1 }
qtyconorcls :: { HsName }
: qtycon { $1 }
qtycls :: { HsName }
: qtycon { $1 }
tyvar :: { HsName }
: varid { $1 }
{-
-----------------------------------------------------------------------------
Property declarations
-----------------------------------------------------------------------------
From MPJ's Tool0 Hugs98 parser.y file:
gendecl : PROPERTY pLhs '=' exp {$$ = gc4(ap(PROP,ap($2,ap($3,$4))));}
| PROPERTY error {syntaxError("property decl");}
;
pLhs : pLhs varid {$$ = gc2(ap($1,$2));}
| CONID {$$ = $1;}
| error {syntaxError("property defn lhs");}
;
qfier : QALL {$$ = gc1(quantAll);}
| QEX {$$ = gc1(quantEx);}
| QALLDEF {$$ = gc1(quantAlldef);}
| QEXU {$$ = gc1(quantExu);}
;
-}
{-
propdecl :: { HsDecl }
: 'property' quant pLhs '=' exp { hsProp $2 $3 $5 }
quant :: { HsQuantifier }
: 'All' { hsPropForall }
| 'Ex' { hsPropExists }
| 'AllDef' { hsPropForallDefined }
| 'ExU' { hsPropExistsUnique }
pLhs :: { [HsName] }
: pLhs varid { $2 : $1 }
| conid { [$1] }
-}
{-
-----------------------------------------------------------------------------
-}
{
happyError = parseError "parse error"
}