X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=16ed88d38d8cafe251a4d1d9f9536878934c9eb7;hp=ffc1f44053a3a3a534cbf361ecc5e07d3ea9dbd8;hb=17b297d97d327620ed6bfab942f8992b2446f1bf;hpb=90dc9026b091be5cca5da4c6cbd3713ecc493361 diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index ffc1f44..16ed88d 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -8,6 +8,13 @@ -- --------------------------------------------------------------------------- { +{-# OPTIONS_GHC -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings +-- for details + module Parser ( parseModule, parseStmt, parseIdentifier, parseType, parseHeader ) where @@ -35,6 +42,7 @@ import StaticFlags ( opt_SccProfilingOn, opt_Hpc ) import Type ( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind ) import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), Activation(..), defaultInlineSpec ) +import DynFlags import OrdList import HaddockParse import {-# SOURCE #-} HaddockLex hiding ( Token ) @@ -52,6 +60,17 @@ import Control.Monad ( mplus ) {- ----------------------------------------------------------------------------- +24 Februar 2006 + +Conflicts: 33 shift/reduce + 1 reduce/reduce + +The reduce/reduce conflict is weird. It's between tyconsym and consym, and I +would think the two should never occur in the same context. + + -=chak + +----------------------------------------------------------------------------- 31 December 2006 Conflicts: 34 shift/reduce @@ -189,7 +208,6 @@ incorrect. 'data' { L _ ITdata } 'default' { L _ ITdefault } 'deriving' { L _ ITderiving } - 'derive' { L _ ITderive } 'do' { L _ ITdo } 'else' { L _ ITelse } 'hiding' { L _ IThiding } @@ -334,6 +352,7 @@ identifier :: { Located RdrName } | qcon { $1 } | qvarop { $1 } | qconop { $1 } + | '(' '->' ')' { LL $ getRdrName funTyCon } ----------------------------------------------------------------------------- -- Module Header @@ -350,10 +369,10 @@ module :: { Located (HsModule RdrName) } {% fileSrcSpan >>= \ loc -> case $1 of { (opt, info, doc) -> return (L loc (HsModule (Just $3) $5 (fst $7) (snd $7) $4 opt info doc) )}} - | missing_module_keyword top close + | body2 {% fileSrcSpan >>= \ loc -> return (L loc (HsModule Nothing Nothing - (fst $2) (snd $2) Nothing Nothing emptyHaddockModInfo + (fst $1) (snd $1) Nothing Nothing emptyHaddockModInfo Nothing)) } optdoc :: { (Maybe String, HaddockModInfo RdrName, Maybe (HsDoc RdrName)) } @@ -374,6 +393,10 @@ body :: { ([LImportDecl RdrName], [LHsDecl RdrName]) } : '{' top '}' { $2 } | vocurly top close { $2 } +body2 :: { ([LImportDecl RdrName], [LHsDecl RdrName]) } + : '{' top '}' { $2 } + | missing_module_keyword top close { $2 } + top :: { ([LImportDecl RdrName], [LHsDecl RdrName]) } : importdecls { (reverse $1,[]) } | importdecls ';' cvtopdecls { (reverse $1,$3) } @@ -603,7 +626,7 @@ ty_decl :: { LTyClDecl RdrName } (unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } } -- data/newtype family - | data_or_newtype 'family' tycl_hdr opt_kind_sig + | 'data' 'family' tycl_hdr opt_kind_sig {% do { let {(ctxt, tc, tvs, tparms) = unLoc $3} ; checkTyVars tparms -- no type pattern ; unless (null (unLoc ctxt)) $ -- and no context @@ -611,8 +634,7 @@ ty_decl :: { LTyClDecl RdrName } "A family declaration cannot have a context" ; return $ L (comb3 $1 $2 $4) - (TyFamily (DataFamily (unLoc $1)) tc tvs - (unLoc $4)) } } + (TyFamily DataFamily tc tvs (unLoc $4)) } } -- data/newtype instance declaration | data_or_newtype 'instance' tycl_hdr constrs deriving @@ -667,7 +689,7 @@ at_decl_cls :: { LTyClDecl RdrName } } } -- data/newtype family declaration - | data_or_newtype tycl_hdr opt_kind_sig + | 'data' tycl_hdr opt_kind_sig {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2} ; checkTyVars tparms -- no type pattern ; unless (null (unLoc ctxt)) $ -- and no context @@ -675,8 +697,7 @@ at_decl_cls :: { LTyClDecl RdrName } "A family declaration cannot have a context" ; return $ L (comb3 $1 $2 $3) - (TyFamily (DataFamily (unLoc $1)) tc tvs - (unLoc $3)) + (TyFamily DataFamily tc tvs (unLoc $3)) } } -- Associate type instances @@ -741,7 +762,7 @@ tycl_hdr :: { Located (LHsContext RdrName, -- Glasgow extension: stand-alone deriving declarations stand_alone_deriving :: { LDerivDecl RdrName } - : 'derive' 'instance' inst_type {% checkDerivDecl (LL (DerivDecl $3)) } + : 'deriving' 'instance' inst_type {% checkDerivDecl (LL (DerivDecl $3)) } ----------------------------------------------------------------------------- -- Nested declarations @@ -1123,7 +1144,7 @@ forall :: { Located [LHsTyVarBndr RdrName] } : 'forall' tv_bndrs '.' { LL $2 } | {- empty -} { noLoc [] } -constr_stuff :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrName)) } +constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) } -- We parse the constructor declaration -- C t1 t2 -- as a btype (treating C as a type constructor) and then convert C to be @@ -1136,7 +1157,7 @@ constr_stuff :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrN | oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.LL } | btype conop btype { LL ($2, InfixCon $1 $3) } -constr_stuff_record :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrName)) } +constr_stuff_record :: { Located (Located RdrName, HsConDeclDetails RdrName) } : oqtycon '{' '}' {% mkRecCon $1 [] >>= return.sL (comb2 $1 $>) } | oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.sL (comb2 $1 $>) } @@ -1257,7 +1278,7 @@ exp10 :: { LHsExpr RdrName } | 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 } | 'if' exp 'then' exp 'else' exp { LL $ HsIf $2 $4 $6 } | 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) } - | '-' fexp { LL $ mkHsNegApp $2 } + | '-' fexp { LL $ NegApp $2 noSyntaxExpr } | 'do' stmtlist {% let loc = comb2 $1 $2 in checkDo loc (unLoc $2) >>= \ (stmts,body) -> @@ -1283,7 +1304,8 @@ exp10 :: { LHsExpr RdrName } | fexp { $1 } scc_annot :: { Located FastString } - : '_scc_' STRING { LL $ getSTRING $2 } + : '_scc_' STRING {% (addWarning Opt_WarnDeprecations (getLoc $1) (text "_scc_ is deprecated; use an SCC pragma instead")) >>= \_ -> + (return $ LL $ getSTRING $2) } | '{-# SCC' STRING '#-}' { LL $ getSTRING $2 } hpc_annot :: { Located (FastString,(Int,Int),(Int,Int)) } @@ -1308,9 +1330,8 @@ aexp :: { LHsExpr RdrName } | aexp1 { $1 } aexp1 :: { LHsExpr RdrName } - : aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) - (reverse $3); - return (LL r) }} + : aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) $3 + ; return (LL r) }} | aexp2 { $1 } -- Here was the syntax for type applications that I was planning @@ -1352,8 +1373,9 @@ aexp2 :: { LHsExpr RdrName } | '[|' exp '|]' { LL $ HsBracket (ExpBr $2) } | '[t|' ctype '|]' { LL $ HsBracket (TypBr $2) } | '[p|' infixexp '|]' {% checkPattern $2 >>= \p -> - return (LL $ HsBracket (PatBr p)) } - | '[d|' cvtopbody '|]' { LL $ HsBracket (DecBr (mkGroup $2)) } + return (LL $ HsBracket (PatBr p)) } + | '[d|' cvtopbody '|]' {% checkDecBrGroup $2 >>= \g -> + return (LL $ HsBracket (DecBr g)) } -- arrow notation extension | '(|' aexp2 cmdargs '|)' { LL $ HsArrForm $2 Nothing (reverse $3) } @@ -1434,12 +1456,12 @@ quals :: { Located [LStmt RdrName] } parr :: { LHsExpr RdrName } : { noLoc (ExplicitPArr placeHolderType []) } - | exp { L1 $ ExplicitPArr placeHolderType [$1] } + | texp { L1 $ ExplicitPArr placeHolderType [$1] } | lexps { L1 $ ExplicitPArr placeHolderType (reverse (unLoc $1)) } - | exp '..' exp { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) } - | exp ',' exp '..' exp { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) } - | exp pquals { sL (comb2 $1 $>) $ mkHsDo PArrComp (reverse (unLoc $2)) $1 } + | texp '..' exp { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) } + | texp ',' exp '..' exp { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) } + | texp pquals { sL (comb2 $1 $>) $ mkHsDo PArrComp (reverse (unLoc $2)) $1 } -- We are reusing `lexps' and `pquals' from the list case. @@ -1481,7 +1503,7 @@ gdpat :: { LGRHS RdrName } -- Bangs inside are parsed as infix operator applications, so that -- we parse them right when bang-patterns are off pat :: { LPat RdrName } -pat : infixexp {% checkPattern $1 } +pat : exp {% checkPattern $1 } | '!' aexp {% checkPattern (LL (SectionR (L1 (HsVar bang_RDR)) $2)) } apat :: { LPat RdrName } @@ -1521,9 +1543,6 @@ maybe_stmt :: { Maybe (LStmt RdrName) } stmt :: { LStmt RdrName } : qual { $1 } --- What is this next production doing? I have no clue! SLPJ Dec06 - | infixexp '->' exp {% checkPattern $3 >>= \p -> - return (LL $ mkBindStmt p $1) } | 'rec' stmtlist { LL $ mkRecStmt (unLoc $2) } qual :: { LStmt RdrName } @@ -1534,16 +1553,21 @@ qual :: { LStmt RdrName } ----------------------------------------------------------------------------- -- Record Field Update/Construction -fbinds :: { HsRecordBinds RdrName } +fbinds :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) } : fbinds1 { $1 } - | {- empty -} { [] } + | {- empty -} { ([], False) } -fbinds1 :: { HsRecordBinds RdrName } - : fbinds1 ',' fbind { $3 : $1 } - | fbind { [$1] } +fbinds1 :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) } + : fbind ',' fbinds1 { case $3 of (flds, dd) -> ($1 : flds, dd) } + | fbind { ([$1], False) } + | '..' { ([], True) } -fbind :: { (Located RdrName, LHsExpr RdrName) } - : qvar '=' exp { ($1,$3) } +fbind :: { HsRecField RdrName (LHsExpr RdrName) } + : qvar '=' exp { HsRecField $1 $3 False } + | qvar { HsRecField $1 (L (getLoc $1) (HsVar (unLoc $1))) True } + -- Here's where we say that plain 'x' + -- means exactly 'x = x'. The pun-flag boolean is + -- there so we can still print it right ----------------------------------------------------------------------------- -- Implicit Parameter Bindings @@ -1741,7 +1765,6 @@ special_id : 'as' { L1 FSLIT("as") } | 'qualified' { L1 FSLIT("qualified") } | 'hiding' { L1 FSLIT("hiding") } - | 'derive' { L1 FSLIT("derive") } | 'export' { L1 FSLIT("export") } | 'label' { L1 FSLIT("label") } | 'dynamic' { L1 FSLIT("dynamic") }