X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=adabb756abc975dcbdc7289ecb3fec5f5e9f591a;hp=060eeac87b1aff4cdb0365f06519c60efd54cca9;hb=911ab82c2a7c1aaf8feb78731f0bae588d244e14;hpb=1ed54200532d9a9b1b58ac914dae28c1ecb48699 diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 060eeac..adabb75 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -44,7 +44,7 @@ import FastString import Maybes ( orElse ) import Outputable -import Control.Monad ( when ) +import Control.Monad ( unless ) import GHC.Exts import Data.Char import Control.Monad ( mplus ) @@ -52,6 +52,28 @@ 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 + 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 + +----------------------------------------------------------------------------- 6 December 2006 Conflicts: 32 shift/reduce @@ -208,7 +230,6 @@ incorrect. 'threadsafe' { L _ ITthreadsafe } 'unsafe' { L _ ITunsafe } 'mdo' { L _ ITmdo } - 'iso' { L _ ITiso } 'family' { L _ ITfamily } 'stdcall' { L _ ITstdcallconv } 'ccall' { L _ ITccallconv } @@ -340,10 +361,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)) } @@ -364,6 +385,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) } @@ -547,7 +572,7 @@ ty_decl :: { LTyClDecl RdrName } -- infix type constructors to be declared {% do { (tc, tvs, _) <- checkSynHdr $2 False ; return (L (comb2 $1 $4) - (TySynonym tc tvs Nothing $4)) + (TySynonym tc tvs Nothing $4)) } } -- type family declarations @@ -556,11 +581,8 @@ ty_decl :: { LTyClDecl RdrName } -- infix type constructors to be declared -- {% do { (tc, tvs, _) <- checkSynHdr $3 False - ; let kind = case unLoc $4 of - Nothing -> liftedTypeKind - Just ki -> ki ; return (L (comb3 $1 $3 $4) - (TyFunction tc tvs False kind)) + (TyFamily TypeFamily tc tvs (unLoc $4))) } } -- type instance declarations @@ -596,16 +618,15 @@ 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 - ; let kind = case unLoc $4 of - Nothing -> liftedTypeKind - Just ki -> ki + ; checkTyVars tparms -- no type pattern + ; unless (null (unLoc ctxt)) $ -- and no context + parseError (getLoc ctxt) + "A family declaration cannot have a context" ; return $ L (comb3 $1 $2 $4) - (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) - (Just kind) [] Nothing) } } + (TyFamily DataFamily tc tvs (unLoc $4)) } } -- data/newtype instance declaration | data_or_newtype 'instance' tycl_hdr constrs deriving @@ -645,11 +666,8 @@ at_decl_cls :: { LTyClDecl RdrName } -- infix type constructors to be declared -- {% do { (tc, tvs, _) <- checkSynHdr $2 False - ; let kind = case unLoc $3 of - Nothing -> liftedTypeKind - Just ki -> ki ; return (L (comb3 $1 $2 $3) - (TyFunction tc tvs False kind)) + (TyFamily TypeFamily tc tvs (unLoc $3))) } } -- default type instance @@ -663,16 +681,16 @@ 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 - ; let kind = case unLoc $3 of - Nothing -> liftedTypeKind - Just ki -> ki + ; checkTyVars tparms -- no type pattern + ; unless (null (unLoc ctxt)) $ -- and no context + parseError (getLoc ctxt) + "A family declaration cannot have a context" ; return $ L (comb3 $1 $2 $3) - (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) - (Just kind) [] Nothing) } } + (TyFamily DataFamily tc tvs (unLoc $3)) + } } -- Associate type instances -- @@ -709,10 +727,6 @@ at_decl_inst :: { LTyClDecl RdrName } (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) (unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } } -opt_iso :: { Bool } - : { False } - | 'iso' { True } - data_or_newtype :: { Located NewOrData } : 'data' { L1 DataType } | 'newtype' { L1 NewType } @@ -1122,7 +1136,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 @@ -1135,7 +1149,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 $>) } @@ -1256,7 +1270,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) -> @@ -1307,9 +1321,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 @@ -1324,6 +1337,9 @@ aexp2 :: { LHsExpr RdrName } : ipvar { L1 (HsIPVar $! unLoc $1) } | qcname { L1 (HsVar $! unLoc $1) } | literal { L1 (HsLit $! unLoc $1) } +-- This will enable overloaded strings permanently. Normally the renamer turns HsString +-- into HsOverLit when -foverloaded-strings is on. +-- | STRING { L1 (HsOverLit $! mkHsIsString (getSTRING $1)) } | INTEGER { L1 (HsOverLit $! mkHsIntegral (getINTEGER $1)) } | RATIONAL { L1 (HsOverLit $! mkHsFractional (getRATIONAL $1)) } | '(' exp ')' { LL (HsPar $2) } @@ -1348,8 +1364,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) } @@ -1430,12 +1447,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. @@ -1477,7 +1494,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 } @@ -1517,9 +1534,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 } @@ -1530,16 +1544,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 @@ -1706,7 +1725,6 @@ varid_no_unsafe :: { Located RdrName } : VARID { L1 $! mkUnqual varName (getVARID $1) } | special_id { L1 $! mkUnqual varName (unLoc $1) } | 'forall' { L1 $! mkUnqual varName FSLIT("forall") } - | 'iso' { L1 $! mkUnqual varName FSLIT("iso") } | 'family' { L1 $! mkUnqual varName FSLIT("family") } qvarsym :: { Located RdrName } @@ -1731,7 +1749,7 @@ varsym_no_minus :: { Located RdrName } -- varsym not including '-' -- These special_ids are treated as keywords in various places, -- but as ordinary ids elsewhere. 'special_id' collects all these --- except 'unsafe', 'forall', 'family', and 'iso' whose treatment differs +-- except 'unsafe', 'forall', and 'family' whose treatment differs -- depending on context special_id :: { Located FastString } special_id @@ -1776,7 +1794,7 @@ consym :: { Located RdrName } literal :: { Located HsLit } : CHAR { L1 $ HsChar $ getCHAR $1 } - | STRING { L1 $ HsString $ getSTRING $1 } + | STRING { L1 $ HsString $ getSTRING $1 } | PRIMINTEGER { L1 $ HsIntPrim $ getPRIMINTEGER $1 } | PRIMCHAR { L1 $ HsCharPrim $ getPRIMCHAR $1 } | PRIMSTRING { L1 $ HsStringPrim $ getPRIMSTRING $1 }