X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=a72b47b27d62373ee328ae7fe74df233dcb4e610;hb=3ad8f84f6a75f240383e62a14472d14eb372dcd1;hp=898d45c5e9614ae22cb60e4bc774e2371312a4c0;hpb=a8839bb4c0a25a961ea315fa2cfdcc78b44b8878;p=ghc-hetmet.git diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 898d45c..a72b47b 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -39,12 +39,24 @@ import OrdList import FastString import Maybes ( orElse ) +import Monad ( when ) import Outputable import GLAEXTS } {- ----------------------------------------------------------------------------- +26 July 2006 + +Conflicts: 37 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 + +----------------------------------------------------------------------------- Conflicts: 36 shift/reduce (1.25) 10 for abiguity in 'if x then y else z + 1' [State 178] @@ -102,6 +114,7 @@ and LL. Each of these macros can be thought of as having type They each add a SrcSpan to their argument. L0 adds 'noSrcSpan', used for empty productions + -- This doesn't seem to work anymore -=chak L1 for a production with a single token on the lhs. Grabs the SrcSpan from that token. @@ -146,6 +159,7 @@ incorrect. 'deriving' { L _ ITderiving } 'do' { L _ ITdo } 'else' { L _ ITelse } + 'for' { L _ ITfor } 'hiding' { L _ IThiding } 'if' { L _ ITif } 'import' { L _ ITimport } @@ -164,7 +178,7 @@ incorrect. 'where' { L _ ITwhere } '_scc_' { L _ ITscc } -- ToDo: remove - 'forall' { L _ ITforall } -- GHC extension keywords + 'forall' { L _ ITforall } -- GHC extension keywords 'foreign' { L _ ITforeign } 'export' { L _ ITexport } 'label' { L _ ITlabel } @@ -173,6 +187,8 @@ incorrect. 'threadsafe' { L _ ITthreadsafe } 'unsafe' { L _ ITunsafe } 'mdo' { L _ ITmdo } + 'iso' { L _ ITiso } + 'family' { L _ ITfamily } 'stdcall' { L _ ITstdcallconv } 'ccall' { L _ ITccallconv } 'dotnet' { L _ ITdotnet } @@ -240,7 +256,6 @@ incorrect. QCONSYM { L _ (ITqconsym _) } IPDUPVARID { L _ (ITdupipvarid _) } -- GHC extension - IPSPLITVARID { L _ (ITsplitipvarid _) } -- GHC extension CHAR { L _ (ITchar _) } STRING { L _ (ITstring _) } @@ -362,12 +377,20 @@ export :: { LIE RdrName } | 'module' modid { LL (IEModuleContents (unLoc $2)) } qcnames :: { [RdrName] } - : qcnames ',' qcname { unLoc $3 : $1 } - | qcname { [unLoc $1] } + : qcnames ',' qcname_ext { unLoc $3 : $1 } + | qcname_ext { [unLoc $1] } +qcname_ext :: { Located RdrName } -- Variable or data constructor + -- or tagged type constructor + : qcname { $1 } + | 'type' qcon { sL (comb2 $1 $2) + (setRdrNameSpace (unLoc $2) + tcClsName) } + +-- Cannot pull into qcname_ext, as qcname is also used in expression. qcname :: { Located RdrName } -- Variable or data constructor - : qvar { $1 } - | qcon { $1 } + : qvar { $1 } + | qcon { $1 } ----------------------------------------------------------------------------- -- Import Declarations @@ -430,7 +453,8 @@ topdecls :: { OrdList (LHsDecl RdrName) } | topdecl { $1 } topdecl :: { OrdList (LHsDecl RdrName) } - : tycl_decl { unitOL (L1 (TyClD (unLoc $1))) } + : cl_decl { unitOL (L1 (TyClD (unLoc $1))) } + | ty_decl { unitOL (L1 (TyClD (unLoc $1))) } | 'instance' inst_type where { let (binds,sigs) = cvBindsAndSigs (unLoc $3) in unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs))) } @@ -446,57 +470,237 @@ topdecl :: { OrdList (LHsDecl RdrName) } L1 $ HsVar (mkUnqual varName (getTH_ID_SPLICE $1)) )) } -tycl_decl :: { LTyClDecl RdrName } - : 'type' type '=' ctype - -- Note type on the left of the '='; this allows - -- infix type constructors to be declared - -- - -- Note ctype, not sigtype, on the right +-- Type classes +-- +cl_decl :: { LTyClDecl RdrName } + : 'class' tycl_hdr fds where + {% do { let { (binds, sigs, ats) = + cvBindsAndSigs (unLoc $4) + ; (ctxt, tc, tvs, tparms) = unLoc $2} + ; checkTyVars tparms -- only type vars allowed + ; checkKindSigs ats + ; return $ L (comb4 $1 $2 $3 $4) + (mkClassDecl (ctxt, tc, tvs) + (unLoc $3) sigs binds ats) } } + +-- Type declarations (toplevel) +-- +ty_decl :: { LTyClDecl RdrName } + -- ordinary type synonyms + : 'type' type '=' ctype + -- Note ctype, not sigtype, on the right of '=' -- We allow an explicit for-all but we don't insert one -- in type Foo a = (b,b) -- Instead we just say b is out of scope - {% do { (tc,tvs) <- checkSynHdr $2 - ; return (LL (TySynonym tc tvs $4)) } } - + -- + -- Note the use of type for the head; this allows + -- infix type constructors to be declared + {% do { (tc, tvs, _) <- checkSynHdr $2 False + ; return (L (comb2 $1 $4) + (TySynonym tc tvs Nothing $4)) + } } + + -- type family declarations + | 'type' 'family' type opt_kind_sig + -- Note the use of type for the head; this allows + -- 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)) + } } + + -- type instance declarations + | 'type' 'instance' type '=' ctype + -- Note the use of type for the head; this allows + -- infix type constructors and type patterns + -- + {% do { (tc, tvs, typats) <- checkSynHdr $3 True + ; return (L (comb2 $1 $5) + (TySynonym tc tvs (Just typats) $5)) + } } + + -- ordinary data type or newtype declaration | data_or_newtype tycl_hdr constrs deriving - { L (comb4 $1 $2 $3 $4) -- We need the location on tycl_hdr - -- in case constrs and deriving are both empty - (mkTyData (unLoc $1) (unLoc $2) Nothing (reverse (unLoc $3)) (unLoc $4)) } - + {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2} + ; checkTyVars tparms -- no type pattern + ; return $ + L (comb4 $1 $2 $3 $4) + -- We need the location on tycl_hdr in case + -- constrs and deriving are both empty + (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) + Nothing (reverse (unLoc $3)) (unLoc $4)) } } + + -- ordinary GADT declaration | data_or_newtype tycl_hdr opt_kind_sig 'where' gadt_constrlist deriving - { L (comb4 $1 $2 $4 $5) - (mkTyData (unLoc $1) (unLoc $2) $3 (reverse (unLoc $5)) (unLoc $6)) } + {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2} + ; checkTyVars tparms -- can have type pats + ; return $ + L (comb4 $1 $2 $4 $5) + (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) + (unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } } + + -- data/newtype family + | data_or_newtype '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 + ; return $ + L (comb3 $1 $2 $4) + (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) + (Just kind) [] Nothing) } } + + -- data/newtype instance declaration + | data_or_newtype 'instance' tycl_hdr constrs deriving + {% do { let {(ctxt, tc, tvs, tparms) = unLoc $3} + -- can have type pats + ; return $ + L (comb4 $1 $3 $4 $5) + -- We need the location on tycl_hdr in case + -- constrs and deriving are both empty + (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) + Nothing (reverse (unLoc $4)) (unLoc $5)) } } + + -- GADT instance declaration + | data_or_newtype 'instance' tycl_hdr opt_kind_sig + 'where' gadt_constrlist + deriving + {% do { let {(ctxt, tc, tvs, tparms) = unLoc $3} + -- can have type pats + ; return $ + L (comb4 $1 $3 $6 $7) + (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) + (unLoc $4) (reverse (unLoc $6)) (unLoc $7)) } } + +-- Associate type declarations +-- +at_decl :: { LTyClDecl RdrName } + -- type family declarations + : 'type' type opt_kind_sig + -- Note the use of type for the head; this allows + -- 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)) + } } + + -- type instance declarations + | 'type' type '=' ctype + -- Note the use of type for the head; this allows + -- infix type constructors and type patterns + -- + {% do { (tc, tvs, typats) <- checkSynHdr $2 True + ; return (L (comb2 $1 $4) + (TySynonym tc tvs (Just typats) $4)) + } } + + -- data/newtype family + | data_or_newtype tycl_hdr '::' kind + {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2} + ; checkTyVars tparms -- no type pattern + ; return $ + L (comb3 $1 $2 $4) + (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) + (Just (unLoc $4)) [] Nothing) } } + + -- data/newtype instance declaration + | data_or_newtype tycl_hdr constrs deriving + {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2} + -- can have type pats + ; return $ + L (comb4 $1 $2 $3 $4) + -- We need the location on tycl_hdr in case + -- constrs and deriving are both empty + (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) + Nothing (reverse (unLoc $3)) (unLoc $4)) } } + + -- GADT instance declaration + | data_or_newtype tycl_hdr opt_kind_sig + 'where' gadt_constrlist + deriving + {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2} + -- can have type pats + ; return $ + L (comb4 $1 $2 $5 $6) + (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) + (unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } } - | 'class' tycl_hdr fds where - { let - (binds,sigs) = cvBindsAndSigs (unLoc $4) - in - L (comb4 $1 $2 $3 $4) (mkClassDecl (unLoc $2) (unLoc $3) sigs - binds) } +opt_iso :: { Bool } + : { False } + | 'iso' { True } data_or_newtype :: { Located NewOrData } : 'data' { L1 DataType } | 'newtype' { L1 NewType } -opt_kind_sig :: { Maybe Kind } - : { Nothing } - | '::' kind { Just $2 } +opt_kind_sig :: { Located (Maybe Kind) } + : { noLoc Nothing } + | '::' kind { LL (Just (unLoc $2)) } --- tycl_hdr parses the header of a type or class decl, +-- tycl_hdr parses the header of a class or data type decl, -- which takes the form -- T a b -- Eq a => T a -- (Eq a, Ord b) => T a b +-- T Int [a] -- for associated types -- Rather a lot of inlining here, else we get reduce/reduce errors -tycl_hdr :: { Located (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName]) } +tycl_hdr :: { Located (LHsContext RdrName, + Located RdrName, + [LHsTyVarBndr RdrName], + [LHsType RdrName]) } : context '=>' type {% checkTyClHdr $1 $3 >>= return.LL } | type {% checkTyClHdr (noLoc []) $1 >>= return.L1 } ----------------------------------------------------------------------------- +-- Stand-alone deriving + +-- Glasgow extension: stand-alone deriving declarations +stand_alone_deriving :: { LDerivDecl RdrName } + : 'deriving' qtycon 'for' qtycon {% do { p <- checkInstType (fmap HsTyVar $2) + ; checkDerivDecl (LL (DerivDecl p $4)) } } + + | 'deriving' '(' inst_type ')' 'for' qtycon {% checkDerivDecl (LL (DerivDecl $3 $6)) } + +----------------------------------------------------------------------------- -- Nested declarations +-- Type declaration or value declaration +-- +tydecl :: { Located (OrdList (LHsDecl RdrName)) } +tydecl : at_decl { LL (unitOL (L1 (TyClD (unLoc $1)))) } + | decl { $1 } + +tydecls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed + : tydecls ';' tydecl { LL (unLoc $1 `appOL` unLoc $3) } + | tydecls ';' { LL (unLoc $1) } + | tydecl { $1 } + | {- empty -} { noLoc nilOL } + + +tydecllist + :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed + : '{' tydecls '}' { LL (unLoc $2) } + | vocurly tydecls close { $2 } + +-- Form of the body of class and instance declarations +-- +where :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed + -- No implicit parameters + -- May have type declarations + : 'where' tydecllist { LL (unLoc $2) } + | {- empty -} { noLoc nilOL } + decls :: { Located (OrdList (LHsDecl RdrName)) } : decls ';' decl { LL (unLoc $1 `appOL` unLoc $3) } | decls ';' { LL (unLoc $1) } @@ -508,17 +712,16 @@ decllist :: { Located (OrdList (LHsDecl RdrName)) } : '{' decls '}' { LL (unLoc $2) } | vocurly decls close { $2 } -where :: { Located (OrdList (LHsDecl RdrName)) } - -- No implicit parameters - : 'where' decllist { LL (unLoc $2) } - | {- empty -} { noLoc nilOL } - +-- Binding groups other than those of class and instance declarations +-- binds :: { Located (HsLocalBinds RdrName) } -- May have implicit parameters + -- No type declarations : decllist { L1 (HsValBinds (cvBindGroup (unLoc $1))) } | '{' dbinds '}' { LL (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) } | vocurly dbinds close { L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) } wherebinds :: { Located (HsLocalBinds RdrName) } -- May have implicit parameters + -- No type declarations : 'where' binds { LL (unLoc $2) } | {- empty -} { noLoc emptyLocalBinds } @@ -670,7 +873,7 @@ atype :: { LHsType RdrName } | '[' ctype ']' { LL $ HsListTy $2 } | '[:' ctype ':]' { LL $ HsPArrTy $2 } | '(' ctype ')' { LL $ HsParTy $2 } - | '(' ctype '::' kind ')' { LL $ HsKindSig $2 $4 } + | '(' ctype '::' kind ')' { LL $ HsKindSig $2 (unLoc $4) } -- Generics | INTEGER { L1 (HsNumTy (getINTEGER $1)) } @@ -699,7 +902,8 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] } tv_bndr :: { LHsTyVarBndr RdrName } : tyvar { L1 (UserTyVar (unLoc $1)) } - | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) $4) } + | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) + (unLoc $4)) } fds :: { Located [Located ([RdrName], [RdrName])] } : {- empty -} { noLoc [] } @@ -720,14 +924,14 @@ varids0 :: { Located [RdrName] } ----------------------------------------------------------------------------- -- Kinds -kind :: { Kind } +kind :: { Located Kind } : akind { $1 } - | akind '->' kind { mkArrowKind $1 $3 } + | akind '->' kind { LL (mkArrowKind (unLoc $1) (unLoc $3)) } -akind :: { Kind } - : '*' { liftedTypeKind } - | '!' { unliftedTypeKind } - | '(' kind ')' { $2 } +akind :: { Located Kind } + : '*' { L1 liftedTypeKind } + | '!' { L1 unliftedTypeKind } + | '(' kind ')' { LL (unLoc $2) } ----------------------------------------------------------------------------- @@ -1187,8 +1391,7 @@ dbind :: { LIPBind RdrName } dbind : ipvar '=' exp { LL (IPBind (unLoc $1) $3) } ipvar :: { Located (IPName RdrName) } - : IPDUPVARID { L1 (Dupable (mkUnqual varName (getIPDUPVARID $1))) } - | IPSPLITVARID { L1 (Linear (mkUnqual varName (getIPSPLITVARID $1))) } + : IPDUPVARID { L1 (IPName (mkUnqual varName (getIPDUPVARID $1))) } ----------------------------------------------------------------------------- -- Deprecations @@ -1340,6 +1543,8 @@ 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 } : varsym { $1 } @@ -1363,7 +1568,8 @@ 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' and 'forall' whose treatment differs depending on context +-- except 'unsafe', 'forall', 'family', and 'iso' whose treatment differs +-- depending on context special_id :: { Located FastString } special_id : 'as' { L1 FSLIT("as") } @@ -1450,7 +1656,6 @@ getQCONID (L _ (ITqconid x)) = x getQVARSYM (L _ (ITqvarsym x)) = x getQCONSYM (L _ (ITqconsym x)) = x getIPDUPVARID (L _ (ITdupipvarid x)) = x -getIPSPLITVARID (L _ (ITsplitipvarid x)) = x getCHAR (L _ (ITchar x)) = x getSTRING (L _ (ITstring x)) = x getINTEGER (L _ (ITinteger x)) = x