diff options
Diffstat (limited to 'compiler/parser/Parser.y.pp')
| -rw-r--r-- | compiler/parser/Parser.y.pp | 304 |
1 files changed, 171 insertions, 133 deletions
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 18651b97c2..9d087068bf 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -26,8 +26,16 @@ throw away inlinings as it would normally do in -O0 mode. -- CPP tricks because we want the directives in the output of the -- first CPP pass. +-- +-- Clang note, 6/17/2013 by aseipp: It is *extremely* important (for +-- some reason) that there be a line of whitespace between the two +-- definitions here, and the subsequent use of __IF_GHC_77__ - this +-- seems to be a bug in clang or something, where having the line of +-- whitespace will make the preprocessor correctly format the rendered +-- lines in the 'two step' CPP pass. No, this is not a joke. #define __IF_GHC_77__ #if __GLASGOW_HASKELL__ >= 707 -#define __ENDIF__ #endif +#define __ENDIF__ #endif + __IF_GHC_77__ -- Required on x86 to avoid the register allocator running out of -- stack slots when compiling this module with -fPIC -dynamic. @@ -51,6 +59,7 @@ import Type ( funTyCon ) import ForeignCall import OccName ( varName, dataName, tcClsName, tvName ) import DataCon ( DataCon, dataConName ) +import CoAxiom ( Role(..) ) import SrcLoc import Module import Kind ( Kind, liftedTypeKind, unliftedTypeKind, mkArrowKind ) @@ -145,7 +154,7 @@ Conflicts: 38 shift/reduce (1.25) (x::T -> T) -> .. -- Rhs is ... 10 for ambiguity in 'e :: a `b` c'. Does this mean [States 11, 253] - (e::a) `b` c, or + (e::a) `b` c, or (e :: (a `b` c)) As well as `b` we can have !, VARSYM, QCONSYM, and CONSYM, hence 5 cases Same duplication between states 11 and 253 as the previous case @@ -170,7 +179,7 @@ Conflicts: 38 shift/reduce (1.25) 1 for ambiguity when the source file starts with "-- | doc". We need another token of lookahead to determine if a top declaration or the 'module' keyword - follows. Shift parses as if the 'module' keyword follows. + follows. Shift parses as if the 'module' keyword follows. -- --------------------------------------------------------------------------- -- Adding location info @@ -221,9 +230,9 @@ incorrect. %token '_' { L _ ITunderscore } -- Haskell keywords 'as' { L _ ITas } - 'case' { L _ ITcase } - 'class' { L _ ITclass } - 'data' { L _ ITdata } + 'case' { L _ ITcase } + 'class' { L _ ITclass } + 'data' { L _ ITdata } 'default' { L _ ITdefault } 'deriving' { L _ ITderiving } 'do' { L _ ITdo } @@ -249,7 +258,7 @@ incorrect. 'forall' { L _ ITforall } -- GHC extension keywords 'foreign' { L _ ITforeign } 'export' { L _ ITexport } - 'label' { L _ ITlabel } + 'label' { L _ ITlabel } 'dynamic' { L _ ITdynamic } 'safe' { L _ ITsafe } 'interruptible' { L _ ITinterruptible } @@ -265,6 +274,9 @@ incorrect. 'group' { L _ ITgroup } -- for list transform extension 'by' { L _ ITby } -- for list transform extension 'using' { L _ ITusing } -- for list transform extension + 'N' { L _ ITnominal } -- Nominal role + 'R' { L _ ITrepresentational } -- Representational role + 'P' { L _ ITphantom } -- Phantom role '{-# INLINE' { L _ (ITinline_prag _ _) } '{-# SPECIALISE' { L _ ITspec_prag } @@ -343,7 +355,7 @@ incorrect. STRING { L _ (ITstring _) } INTEGER { L _ (ITinteger _) } RATIONAL { L _ (ITrational _) } - + PRIMCHAR { L _ (ITprimchar _) } PRIMSTRING { L _ (ITprimstring _) } PRIMINTEGER { L _ (ITprimint _) } @@ -356,11 +368,11 @@ incorrect. DOCNAMED { L _ (ITdocCommentNamed _) } DOCSECTION { L _ (ITdocSection _ _) } --- Template Haskell -'[|' { L _ ITopenExpQuote } -'[p|' { L _ ITopenPatQuote } -'[t|' { L _ ITopenTypQuote } -'[d|' { L _ ITopenDecQuote } +-- Template Haskell +'[|' { L _ ITopenExpQuote } +'[p|' { L _ ITopenPatQuote } +'[t|' { L _ ITopenTypQuote } +'[d|' { L _ ITopenDecQuote } '|]' { L _ ITcloseQuote } TH_ID_SPLICE { L _ (ITidEscape _) } -- $x '$(' { L _ ITparenEscape } -- $( exp ) @@ -461,34 +473,34 @@ header_body2 :: { [LImportDecl RdrName] } -- The Export List maybeexports :: { Maybe [LIE RdrName] } - : '(' exportlist ')' { Just $2 } + : '(' exportlist ')' { Just (fromOL $2) } | {- empty -} { Nothing } -exportlist :: { [LIE RdrName] } - : expdoclist ',' expdoclist { $1 ++ $3 } +exportlist :: { OrdList (LIE RdrName) } + : expdoclist ',' expdoclist { $1 `appOL` $3 } | exportlist1 { $1 } -exportlist1 :: { [LIE RdrName] } - : expdoclist export expdoclist ',' exportlist { $1 ++ ($2 : $3) ++ $5 } - | expdoclist export expdoclist { $1 ++ ($2 : $3) } +exportlist1 :: { OrdList (LIE RdrName) } + : expdoclist export expdoclist ',' exportlist1 { $1 `appOL` $2 `appOL` $3 `appOL` $5 } + | expdoclist export expdoclist { $1 `appOL` $2 `appOL` $3 } | expdoclist { $1 } -expdoclist :: { [LIE RdrName] } - : exp_doc expdoclist { $1 : $2 } - | {- empty -} { [] } +expdoclist :: { OrdList (LIE RdrName) } + : exp_doc expdoclist { $1 `appOL` $2 } + | {- empty -} { nilOL } -exp_doc :: { LIE RdrName } - : docsection { L1 (case (unLoc $1) of (n, doc) -> IEGroup n doc) } - | docnamed { L1 (IEDocNamed ((fst . unLoc) $1)) } - | docnext { L1 (IEDoc (unLoc $1)) } +exp_doc :: { OrdList (LIE RdrName) } + : docsection { unitOL (L1 (case (unLoc $1) of (n, doc) -> IEGroup n doc)) } + | docnamed { unitOL (L1 (IEDocNamed ((fst . unLoc) $1))) } + | docnext { unitOL (L1 (IEDoc (unLoc $1))) } -- No longer allow things like [] and (,,,) to be exported -- They are built in syntax, always available -export :: { LIE RdrName } - : qcname_ext export_subspec { LL (mkModuleImpExp (unLoc $1) - (unLoc $2)) } - | 'module' modid { LL (IEModuleContents (unLoc $2)) } +export :: { OrdList (LIE RdrName) } + : qcname_ext export_subspec { unitOL (LL (mkModuleImpExp (unLoc $1) + (unLoc $2))) } + | 'module' modid { unitOL (LL (IEModuleContents (unLoc $2))) } export_subspec :: { Located ImpExpSubSpec } : {- empty -} { L0 ImpExpAbs } @@ -523,7 +535,7 @@ importdecls :: { [LImportDecl RdrName] } | {- empty -} { [] } importdecl :: { LImportDecl RdrName } - : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec + : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec { L (comb4 $1 $6 $7 $8) $ ImportDecl { ideclName = $6, ideclPkgQual = $5 , ideclSource = $2, ideclSafe = $3 @@ -555,8 +567,8 @@ maybeimpspec :: { Located (Maybe (Bool, [LIE RdrName])) } | {- empty -} { noLoc Nothing } impspec :: { Located (Bool, [LIE RdrName]) } - : '(' exportlist ')' { LL (False, $2) } - | 'hiding' '(' exportlist ')' { LL (True, $3) } + : '(' exportlist ')' { LL (False, fromOL $2) } + | 'hiding' '(' exportlist ')' { LL (True, fromOL $3) } ----------------------------------------------------------------------------- -- Fixity Declarations @@ -594,17 +606,17 @@ topdecl :: { OrdList (LHsDecl RdrName) } | '{-# RULES' rules '#-}' { $2 } | '{-# VECTORISE' qvar '=' exp '#-}' { unitOL $ LL $ VectD (HsVect $2 $4) } | '{-# NOVECTORISE' qvar '#-}' { unitOL $ LL $ VectD (HsNoVect $2) } - | '{-# VECTORISE' 'type' gtycon '#-}' - { unitOL $ LL $ + | '{-# VECTORISE' 'type' gtycon '#-}' + { unitOL $ LL $ VectD (HsVectTypeIn False $3 Nothing) } - | '{-# VECTORISE_SCALAR' 'type' gtycon '#-}' - { unitOL $ LL $ + | '{-# VECTORISE_SCALAR' 'type' gtycon '#-}' + { unitOL $ LL $ VectD (HsVectTypeIn True $3 Nothing) } - | '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}' - { unitOL $ LL $ + | '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}' + { unitOL $ LL $ VectD (HsVectTypeIn False $3 (Just $5)) } - | '{-# VECTORISE_SCALAR' 'type' gtycon '=' gtycon '#-}' - { unitOL $ LL $ + | '{-# VECTORISE_SCALAR' 'type' gtycon '=' gtycon '#-}' + { unitOL $ LL $ VectD (HsVectTypeIn True $3 (Just $5)) } | '{-# VECTORISE' 'class' gtycon '#-}' { unitOL $ LL $ VectD (HsVectClassIn $3) } | annotation { unitOL $1 } @@ -612,9 +624,9 @@ topdecl :: { OrdList (LHsDecl RdrName) } -- Template Haskell Extension -- The $(..) form is one possible form of infixexp - -- but we treat an arbitrary expression just as if + -- but we treat an arbitrary expression just as if -- it had a $(..) wrapped around it - | infixexp { unitOL (LL $ mkTopSpliceDecl $1) } + | infixexp { unitOL (LL $ mkTopSpliceDecl $1) } -- Type classes -- @@ -632,30 +644,30 @@ ty_decl :: { LTyClDecl RdrName } -- Instead we just say b is out of scope -- -- Note the use of type for the head; this allows - -- infix type constructors to be declared + -- infix type constructors to be declared {% mkTySynonym (comb2 $1 $4) $2 $4 } -- type family declarations - | 'type' 'family' type opt_kind_sig + | 'type' 'family' type opt_kind_sig where_type_family -- Note the use of type for the head; this allows -- infix type constructors to be declared - {% do { L loc decl <- mkFamDecl (comb3 $1 $3 $4) TypeFamily $3 (unLoc $4) + {% do { L loc decl <- mkFamDecl (comb4 $1 $3 $4 $5) (unLoc $5) $3 (unLoc $4) ; return (L loc (FamDecl decl)) } } -- ordinary data type or newtype declaration | data_or_newtype capi_ctype tycl_hdr constrs deriving - {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3 + {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3 Nothing (reverse (unLoc $4)) (unLoc $5) } - -- We need the location on tycl_hdr in case + -- We need the location on tycl_hdr in case -- constrs and deriving are both empty -- ordinary GADT declaration - | data_or_newtype capi_ctype tycl_hdr opt_kind_sig + | data_or_newtype capi_ctype tycl_hdr opt_kind_sig gadt_constrlist deriving - {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3 + {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3 (unLoc $4) (unLoc $5) (unLoc $6) } - -- We need the location on tycl_hdr in case + -- We need the location on tycl_hdr in case -- constrs and deriving are both empty -- data/newtype family @@ -676,9 +688,6 @@ inst_decl :: { LInstDecl RdrName } {% do { L loc tfi <- mkTyFamInst (comb2 $1 $3) $3 ; return (L loc (TyFamInstD { tfid_inst = tfi })) } } - | 'type' 'instance' 'where' ty_fam_inst_eqn_list - { LL (TyFamInstD { tfid_inst = mkTyFamInstGroup (unLoc $4) }) } - -- data/newtype instance declaration | data_or_newtype 'instance' tycl_hdr constrs deriving {% do { L loc d <- mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) Nothing $3 @@ -686,21 +695,28 @@ inst_decl :: { LInstDecl RdrName } ; return (L loc (DataFamInstD { dfid_inst = d })) } } -- GADT instance declaration - | data_or_newtype 'instance' tycl_hdr opt_kind_sig + | data_or_newtype 'instance' tycl_hdr opt_kind_sig gadt_constrlist deriving {% do { L loc d <- mkFamInstData (comb4 $1 $3 $5 $6) (unLoc $1) Nothing $3 (unLoc $4) (unLoc $5) (unLoc $6) ; return (L loc (DataFamInstD { dfid_inst = d })) } } - --- Type instance groups + +-- Closed type families + +where_type_family :: { Located (FamilyInfo RdrName) } + : {- empty -} { noLoc OpenTypeFamily } + | 'where' ty_fam_inst_eqn_list + { LL (ClosedTypeFamily (reverse (unLoc $2))) } ty_fam_inst_eqn_list :: { Located [LTyFamInstEqn RdrName] } : '{' ty_fam_inst_eqns '}' { LL (unLoc $2) } | vocurly ty_fam_inst_eqns close { $2 } + | '{' '..' '}' { LL [] } + | vocurly '..' close { let L loc _ = $2 in L loc [] } ty_fam_inst_eqns :: { Located [LTyFamInstEqn RdrName] } - : ty_fam_inst_eqn ';' ty_fam_inst_eqns { LL ($1 : unLoc $3) } + : ty_fam_inst_eqns ';' ty_fam_inst_eqn { LL ($3 : unLoc $1) } | ty_fam_inst_eqns ';' { LL (unLoc $1) } | ty_fam_inst_eqn { LL [$1] } @@ -708,7 +724,8 @@ ty_fam_inst_eqn :: { LTyFamInstEqn RdrName } : type '=' ctype -- Note the use of type for the head; this allows -- infix type constructors and type patterns - {% mkTyFamInstEqn (comb2 $1 $3) $1 $3 } + {% do { eqn <- mkTyFamInstEqn $1 $3 + ; return (LL eqn) } } -- Associated type family declarations -- @@ -717,14 +734,14 @@ ty_fam_inst_eqn :: { LTyFamInstEqn RdrName } -- -- * They also need to be separate from instances; otherwise, data family -- declarations without a kind signature cause parsing conflicts with empty --- data declarations. +-- data declarations. -- at_decl_cls :: { LHsDecl RdrName } -- family declarations : 'type' type opt_kind_sig -- Note the use of type for the head; this allows -- infix type constructors to be declared. - {% do { L loc decl <- mkFamDecl (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3) + {% do { L loc decl <- mkFamDecl (comb3 $1 $2 $3) OpenTypeFamily $2 (unLoc $3) ; return (L loc (TyClD (FamDecl decl))) } } | 'data' type opt_kind_sig @@ -750,14 +767,14 @@ at_decl_inst :: { LTyFamInstDecl RdrName } adt_decl_inst :: { LDataFamInstDecl RdrName } -- data/newtype instance declaration : data_or_newtype capi_ctype tycl_hdr constrs deriving - {% mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3 + {% mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3 Nothing (reverse (unLoc $4)) (unLoc $5) } -- GADT instance declaration - | data_or_newtype capi_ctype tycl_hdr opt_kind_sig + | data_or_newtype capi_ctype tycl_hdr opt_kind_sig gadt_constrlist deriving - {% mkFamInstData (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3 + {% mkFamInstData (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3 (unLoc $4) (unLoc $5) (unLoc $6) } data_or_newtype :: { Located NewOrData } @@ -838,7 +855,7 @@ decls_inst :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed | decl_inst { $1 } | {- empty -} { noLoc nilOL } -decllist_inst +decllist_inst :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed : '{' decls_inst '}' { LL (unLoc $2) } | vocurly decls_inst close { $2 } @@ -853,7 +870,7 @@ where_inst :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed -- Declarations in binding groups other than classes and instances -- -decls :: { Located (OrdList (LHsDecl RdrName)) } +decls :: { Located (OrdList (LHsDecl RdrName)) } : decls ';' decl { let { this = unLoc $3; rest = unLoc $1; these = rest `appOL` this } @@ -892,12 +909,12 @@ rules :: { OrdList (LHsDecl RdrName) } rule :: { LHsDecl RdrName } : STRING rule_activation rule_forall infixexp '=' exp - { LL $ RuleD (HsRule (getSTRING $1) - ($2 `orElse` AlwaysActive) + { LL $ RuleD (HsRule (getSTRING $1) + ($2 `orElse` AlwaysActive) $3 $4 placeHolderNames $6 placeHolderNames) } -- Rules can be specified to be NeverActive, unlike inline/specialize pragmas -rule_activation :: { Maybe Activation } +rule_activation :: { Maybe Activation } : {- empty -} { Nothing } | rule_explicit_activation { Just $1 } @@ -967,7 +984,7 @@ annotation :: { LHsDecl RdrName } fdecl :: { LHsDecl RdrName } fdecl : 'import' callconv safety fspec {% mkImport $2 $3 (unLoc $4) >>= return.LL } - | 'import' callconv fspec + | 'import' callconv fspec {% do { d <- mkImport $2 PlaySafe (unLoc $3); return (LL d) } } | 'export' callconv fspec @@ -1022,22 +1039,19 @@ sigtypes1 :: { [LHsType RdrName] } -- Always HsForAllTys ----------------------------------------------------------------------------- -- Types -infixtype :: { LHsType RdrName } - : btype qtyconop type { LL $ mkHsOpTy $1 $2 $3 } - | btype tyvarop type { LL $ mkHsOpTy $1 $2 $3 } - strict_mark :: { Located HsBang } : '!' { L1 (HsUserBang Nothing True) } | '{-# UNPACK' '#-}' { LL (HsUserBang (Just True) False) } | '{-# NOUNPACK' '#-}' { LL (HsUserBang (Just False) True) } | '{-# UNPACK' '#-}' '!' { LL (HsUserBang (Just True) True) } | '{-# NOUNPACK' '#-}' '!' { LL (HsUserBang (Just False) True) } - -- Although UNPAACK with no '!' is illegal, we get a + -- Although UNPACK with no '!' is illegal, we get a -- better error message if we parse it here -- A ctype is a for-all type ctype :: { LHsType RdrName } - : 'forall' tv_bndrs '.' ctype { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 } + : 'forall' tv_bndrs '.' ctype {% hintExplicitForall (getLoc $1) >> + return (LL $ mkExplicitHsForAllTy $2 (noLoc []) $4) } | context '=>' ctype { LL $ mkImplicitHsForAllTy $1 $3 } -- A type of form (context => type) is an *implicit* HsForAllTy | ipvar '::' type { LL (HsIParamTy (unLoc $1) $3) } @@ -1045,17 +1059,18 @@ ctype :: { LHsType RdrName } ---------------------- -- Notes for 'ctypedoc' --- It would have been nice to simplify the grammar by unifying `ctype` and +-- It would have been nice to simplify the grammar by unifying `ctype` and -- ctypedoc` into one production, allowing comments on types everywhere (and -- rejecting them after parsing, where necessary). This is however not possible -- since it leads to ambiguity. The reason is the support for comments on record --- fields: +-- fields: -- data R = R { field :: Int -- ^ comment on the field } -- If we allow comments on types here, it's not clear if the comment applies -- to 'field' or to 'Int'. So we must use `ctype` to describe the type. ctypedoc :: { LHsType RdrName } - : 'forall' tv_bndrs '.' ctypedoc { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 } + : 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall (getLoc $1) >> + return (LL $ mkExplicitHsForAllTy $2 (noLoc []) $4) } | context '=>' ctypedoc { LL $ mkImplicitHsForAllTy $1 $3 } -- A type of form (context => type) is an *implicit* HsForAllTy | ipvar '::' type { LL (HsIParamTy (unLoc $1) $3) } @@ -1068,7 +1083,7 @@ ctypedoc :: { LHsType RdrName } -- (Eq a, Ord a) -- looks so much like a tuple type. We can't tell until we find the => --- We have the t1 ~ t2 form both in 'context' and in type, +-- We have the t1 ~ t2 form both in 'context' and in type, -- to permit an individual equational constraint without parenthesis. -- Thus for some reason we allow f :: a~b => blah -- but not f :: ?x::Int => blah @@ -1112,12 +1127,13 @@ atype :: { LHsType RdrName } | '{' fielddecls '}' {% checkRecordSyntax (LL $ HsRecTy $2) } -- Constructor sigs only | '(' ')' { LL $ HsTupleTy HsBoxedOrConstraintTuple [] } | '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy HsBoxedOrConstraintTuple ($2:$4) } - | '(#' '#)' { LL $ HsTupleTy HsUnboxedTuple [] } + | '(#' '#)' { LL $ HsTupleTy HsUnboxedTuple [] } | '(#' comma_types1 '#)' { LL $ HsTupleTy HsUnboxedTuple $2 } | '[' ctype ']' { LL $ HsListTy $2 } | '[:' ctype ':]' { LL $ HsPArrTy $2 } | '(' ctype ')' { LL $ HsParTy $2 } | '(' ctype '::' kind ')' { LL $ HsKindSig $2 $4 } + | atype '@' role { LL $ HsRoleAnnot $1 (unLoc $3) } | quasiquote { L1 (HsQuasiQuoteTy (unLoc $1)) } | '$(' exp ')' { LL $ mkHsSpliceTy $2 } | TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $ @@ -1155,8 +1171,8 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] } | {- empty -} { [] } tv_bndr :: { LHsTyVarBndr RdrName } - : tyvar { L1 (UserTyVar (unLoc $1)) } - | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) $4) } + : tyvar { L1 (HsTyVarBndr (unLoc $1) Nothing Nothing) } + | '(' tyvar '::' kind ')' { LL (HsTyVarBndr (unLoc $2) (Just $4) Nothing) } fds :: { Located [Located (FunDep RdrName)] } : {- empty -} { noLoc [] } @@ -1174,6 +1190,11 @@ varids0 :: { Located [RdrName] } : {- empty -} { noLoc [] } | varids0 tyvar { LL (unLoc $2 : unLoc $1) } +role :: { Located Role } + : 'N' { LL Nominal } + | 'R' { LL Representational } + | 'P' { LL Phantom } + ----------------------------------------------------------------------------- -- Kinds @@ -1250,7 +1271,7 @@ gadt_constrs :: { Located [LConDecl RdrName] } gadt_constr :: { [LConDecl RdrName] } -- Returns a list because of: C,D :: ty : con_list '::' sigtype - { map (sL (comb2 $1 $3)) (mkGadtDecl (unLoc $1) $3) } + { map (sL (comb2 $1 $3)) (mkGadtDecl (unLoc $1) $3) } -- Deprecated syntax for GADT record declarations | oqtycon '{' fielddecls '}' '::' sigtype @@ -1266,12 +1287,12 @@ constrs1 :: { Located [LConDecl RdrName] } | constr { L1 [$1] } constr :: { LConDecl RdrName } - : maybe_docnext forall context '=>' constr_stuff maybe_docprev - { let (con,details) = unLoc $5 in + : maybe_docnext forall context '=>' constr_stuff maybe_docprev + { let (con,details) = unLoc $5 in addConDoc (L (comb4 $2 $3 $4 $5) (mkSimpleConDecl con (unLoc $2) $3 details)) ($1 `mplus` $6) } | maybe_docnext forall constr_stuff maybe_docprev - { let (con,details) = unLoc $3 in + { let (con,details) = unLoc $3 in addConDoc (L (comb2 $2 $3) (mkSimpleConDecl con (unLoc $2) (noLoc []) details)) ($1 `mplus` $4) } @@ -1280,7 +1301,7 @@ forall :: { Located [LHsTyVarBndr RdrName] } | {- empty -} { noLoc [] } constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) } --- We parse the constructor declaration +-- We parse the constructor declaration -- C t1 t2 -- as a btype (treating C as a type constructor) and then convert C to be -- a data constructor. Reason: it might continue like this: @@ -1301,7 +1322,7 @@ fielddecls1 :: { [ConDeclField RdrName] } | fielddecl { $1 } fielddecl :: { [ConDeclField RdrName] } -- A list because of f,g :: Int - : maybe_docnext sig_vars '::' ctype maybe_docprev { [ ConDeclField fld $4 ($1 `mplus` $5) + : maybe_docnext sig_vars '::' ctype maybe_docprev { [ ConDeclField fld $4 ($1 `mplus` $5) | fld <- reverse (unLoc $2) ] } -- We allow the odd-looking 'inst_type' in a deriving clause, so that @@ -1311,10 +1332,10 @@ fielddecl :: { [ConDeclField RdrName] } -- A list because of f,g :: Int deriving :: { Located (Maybe [LHsType RdrName]) } : {- empty -} { noLoc Nothing } | 'deriving' qtycon { let { L loc tv = $2 } - in LL (Just [L loc (HsTyVar tv)]) } + in LL (Just [L loc (HsTyVar tv)]) } | 'deriving' '(' ')' { LL (Just []) } | 'deriving' '(' inst_types1 ')' { LL (Just $3) } - -- Glasgow extension: allow partial + -- Glasgow extension: allow partial -- applications in derivings ----------------------------------------------------------------------------- @@ -1333,12 +1354,12 @@ There's an awkward overlap with a type signature. Consider 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: - + { (^^) :: Int->Int ; } Type signature; only var allowed { (^^) :: Int->Int = ... ; } Value defn with result signature; qvar allowed (because of instance decls) - + We can't tell whether to reduce var to qvar until after we've read the signatures. -} @@ -1379,20 +1400,20 @@ gdrh :: { LGRHS RdrName (LHsExpr RdrName) } : '|' guardquals '=' exp { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 } sigdecl :: { Located (OrdList (LHsDecl RdrName)) } - : + : -- See Note [Declaration/signature overlap] for why we need infixexp here infixexp '::' sigtypedoc - {% do s <- checkValSig $1 $3 + {% do s <- checkValSig $1 $3 ; return (LL $ unitOL (LL $ SigD s)) } | var ',' sig_vars '::' sigtypedoc { LL $ toOL [ LL $ SigD (TypeSig ($1 : unLoc $3) $5) ] } | infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1)))) | n <- unLoc $3 ] } - | '{-# INLINE' activation qvar '#-}' + | '{-# INLINE' activation qvar '#-}' { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) } | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}' { let inl_prag = mkInlinePragma (EmptyInlineSpec, FunLike) $2 - in LL $ toOL [ LL $ SigD (SpecSig $3 t inl_prag) + in LL $ toOL [ LL $ SigD (SpecSig $3 t inl_prag) | t <- $5] } | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}' { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlinePragma (getSPEC_INLINE $1) $2)) @@ -1400,7 +1421,7 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) } | '{-# SPECIALISE' 'instance' inst_type '#-}' { LL $ unitOL (LL $ SigD (SpecInstSig $3)) } -activation :: { Maybe Activation } +activation :: { Maybe Activation } : {- empty -} { Nothing } | explicit_activation { Just $1 } @@ -1434,7 +1455,7 @@ infixexp :: { LHsExpr RdrName } | infixexp qop exp10 { LL (OpApp $1 $2 (panic "fixity") $3) } exp10 :: { LHsExpr RdrName } - : '\\' apat apats opt_asig '->' exp + : '\\' apat apats opt_asig '->' exp { LL $ HsLam (mkMatchGroup [LL $ Match ($2:$3) $4 (unguardedGRHSs $6) ]) } @@ -1461,8 +1482,8 @@ exp10 :: { LHsExpr RdrName } then HsTickPragma (unLoc $1) $2 else HsPar $2 } } - | 'proc' aexp '->' exp - {% checkPattern empty $2 >>= \ p -> + | 'proc' aexp '->' exp + {% checkPattern empty $2 >>= \ p -> checkCommand $4 >>= \ cmd -> return (LL $ HsProc p (LL $ HsCmdTop cmd placeHolderType placeHolderType undefined)) } @@ -1531,20 +1552,20 @@ aexp2 :: { LHsExpr RdrName } | '[' list ']' { LL (unLoc $2) } | '[:' parr ':]' { LL (unLoc $2) } | '_' { L1 EWildPat } - + -- Template Haskell Extension - | TH_ID_SPLICE { L1 $ HsSpliceE (mkHsSplice - (L1 $ HsVar (mkUnqual varName - (getTH_ID_SPLICE $1)))) } - | '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } + | TH_ID_SPLICE { L1 $ HsSpliceE (mkHsSplice + (L1 $ HsVar (mkUnqual varName + (getTH_ID_SPLICE $1)))) } + | '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } | SIMPLEQUOTE qvar { LL $ HsBracket (VarBr True (unLoc $2)) } | SIMPLEQUOTE qcon { LL $ HsBracket (VarBr True (unLoc $2)) } | TH_TY_QUOTE tyvar { LL $ HsBracket (VarBr False (unLoc $2)) } | TH_TY_QUOTE gtycon { LL $ HsBracket (VarBr False (unLoc $2)) } - | '[|' exp '|]' { LL $ HsBracket (ExpBr $2) } - | '[t|' ctype '|]' { LL $ HsBracket (TypBr $2) } + | '[|' exp '|]' { LL $ HsBracket (ExpBr $2) } + | '[t|' ctype '|]' { LL $ HsBracket (TypBr $2) } | '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p -> return (LL $ HsBracket (PatBr p)) } | '[d|' cvtopbody '|]' { LL $ HsBracket (DecBrL $2) } @@ -1572,7 +1593,7 @@ cvtopdecls0 :: { [LHsDecl RdrName] } ----------------------------------------------------------------------------- -- Tuple expressions --- "texp" is short for tuple expressions: +-- "texp" is short for tuple expressions: -- things that can appear unparenthesized as long as they're -- inside parens or delimitted by commas texp :: { LHsExpr RdrName } @@ -1623,9 +1644,9 @@ list :: { LHsExpr RdrName } | texp ',' exp '..' { LL $ ArithSeq noPostTcExpr Nothing (FromThen $1 $3) } | texp '..' exp { LL $ ArithSeq noPostTcExpr Nothing (FromTo $1 $3) } | texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr Nothing (FromThenTo $1 $3 $5) } - | texp '|' flattenedpquals + | texp '|' flattenedpquals {% checkMonadComp >>= \ ctxt -> - return (sL (comb2 $1 $>) $ + return (sL (comb2 $1 $>) $ mkHsComp ctxt (unLoc $3) $1) } lexps :: { Located [LHsExpr RdrName] } @@ -1638,10 +1659,10 @@ lexps :: { Located [LHsExpr RdrName] } flattenedpquals :: { Located [LStmt RdrName (LHsExpr RdrName)] } : pquals { case (unLoc $1) of [qs] -> L1 qs - -- We just had one thing in our "parallel" list so + -- We just had one thing in our "parallel" list so -- we simply return that thing directly - - qss -> L1 [L1 $ ParStmt [ParStmtBlock qs undefined noSyntaxExpr | qs <- qss] + + qss -> L1 [L1 $ ParStmt [ParStmtBlock qs undefined noSyntaxExpr | qs <- qss] noSyntaxExpr noSyntaxExpr] -- We actually found some actual parallel lists so -- we wrap them into as a ParStmt @@ -1651,7 +1672,7 @@ pquals :: { Located [[LStmt RdrName (LHsExpr RdrName)]] } : squals '|' pquals { L (getLoc $2) (reverse (unLoc $1) : unLoc $3) } | squals { L (getLoc $1) [reverse (unLoc $1)] } -squals :: { Located [LStmt RdrName (LHsExpr RdrName)] } -- In reverse order, because the last +squals :: { Located [LStmt RdrName (LHsExpr RdrName)] } -- In reverse order, because the last -- one can "grab" the earlier ones : squals ',' transformqual { LL [L (getLoc $3) ((unLoc $3) (reverse (unLoc $1)))] } | squals ',' qual { LL ($3 : unLoc $1) } @@ -1689,7 +1710,7 @@ transformqual :: { Located ([LStmt RdrName (LHsExpr RdrName)] -> Stmt RdrName (L parr :: { LHsExpr RdrName } : { noLoc (ExplicitPArr placeHolderType []) } | texp { L1 $ ExplicitPArr placeHolderType [$1] } - | lexps { L1 $ ExplicitPArr placeHolderType + | lexps { L1 $ ExplicitPArr placeHolderType (reverse (unLoc $1)) } | texp '..' exp { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) } | texp ',' exp '..' exp { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) } @@ -1754,7 +1775,7 @@ bindpat :: { LPat RdrName } bindpat : exp {% checkPattern (text "Possibly caused by a missing 'do'?") $1 } | '!' aexp {% checkPattern (text "Possibly caused by a missing 'do'?") (LL (SectionR (L1 (HsVar bang_RDR)) $2)) } -apat :: { LPat RdrName } +apat :: { LPat RdrName } apat : aexp {% checkPattern empty $1 } | '!' aexp {% checkPattern empty (LL (SectionR (L1 (HsVar bang_RDR)) $2)) } @@ -1783,7 +1804,7 @@ stmts_help :: { Located [LStmt RdrName (LHsExpr RdrName)] } -- might be empty : ';' stmts { LL (unLoc $2) } | {- empty -} { noLoc [] } --- For typing stmts at the GHCi prompt, where +-- For typing stmts at the GHCi prompt, where -- the input may consist of just comments. maybe_stmt :: { Maybe (LStmt RdrName (LHsExpr RdrName)) } : stmt { Just $1 } @@ -1806,10 +1827,10 @@ fbinds :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) } | {- empty -} { ([], False) } fbinds1 :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) } - : fbind ',' fbinds1 { case $3 of (flds, dd) -> ($1 : flds, dd) } + : fbind ',' fbinds1 { case $3 of (flds, dd) -> ($1 : flds, dd) } | fbind { ([$1], False) } | '..' { ([], True) } - + fbind :: { HsRecField RdrName (LHsExpr RdrName) } : qvar '=' texp { HsRecField $1 $3 False } -- RHS is a 'texp', allowing view patterns (Trac #6038) @@ -1872,7 +1893,7 @@ sysdcon :: { Located DataCon } -- Wired in data constructors | '[' ']' { LL nilDataCon } conop :: { Located RdrName } - : consym { $1 } + : consym { $1 } | '`' conid '`' { LL (unLoc $2) } qconop :: { Located RdrName } @@ -1883,7 +1904,7 @@ qconop :: { Located RdrName } -- Type constructors --- See Note [Unit tuples] in HsTypes for the distinction +-- See Note [Unit tuples] in HsTypes for the distinction -- between gtycon and ntgtycon gtycon :: { Located RdrName } -- A "general" qualified tycon, including unit tuples : ntgtycon { $1 } @@ -1915,7 +1936,7 @@ qtycon :: { Located RdrName } -- Qualified or unqualified | tycon { $1 } tycon :: { Located RdrName } -- Unqualified - : CONID { L1 $! mkUnqual tcClsName (getCONID $1) } + : upcase_id { L1 $! mkUnqual tcClsName (unLoc $1) } qtyconsym :: { Located RdrName } : QCONSYM { L1 $! mkQual tcClsName (getQCONSYM $1) } @@ -1966,8 +1987,8 @@ tyvar : tyvarid { $1 } tyvarop :: { Located RdrName } tyvarop : '`' tyvarid '`' { LL (unLoc $2) } - | '.' {% parseErrorSDoc (getLoc $1) - (vcat [ptext (sLit "Illegal symbol '.' in type"), + | '.' {% parseErrorSDoc (getLoc $1) + (vcat [ptext (sLit "Illegal symbol '.' in type"), ptext (sLit "Perhaps you intended -XRankNTypes or similar flag"), ptext (sLit "to enable explicit-forall syntax: forall <tvs>. <type>")]) } @@ -1980,7 +2001,7 @@ tyvarid :: { Located RdrName } | 'interruptible' { L1 $! mkUnqual tvName (fsLit "interruptible") } ----------------------------------------------------------------------------- --- Variables +-- Variables var :: { Located RdrName } : varid { $1 } @@ -2028,10 +2049,10 @@ varsym_no_minus :: { Located RdrName } -- varsym not including '-' | special_sym { L1 $ mkUnqual varName (unLoc $1) } --- These special_ids are treated as keywords in various places, +-- These special_ids are treated as keywords in various places, -- but as ordinary ids elsewhere. 'special_id' collects all these -- except 'unsafe', 'interruptible', 'forall', and 'family' whose treatment differs --- depending on context +-- depending on context special_id :: { Located FastString } special_id : 'as' { L1 (fsLit "as") } @@ -2060,7 +2081,7 @@ qconid :: { Located RdrName } -- Qualified or unqualified | PREFIXQCONSYM { L1 $! mkQual dataName (getPREFIXQCONSYM $1) } conid :: { Located RdrName } - : CONID { L1 $ mkUnqual dataName (getCONID $1) } + : upcase_id { L1 $ mkUnqual dataName (unLoc $1) } qconsym :: { Located RdrName } -- Qualified or unqualified : consym { $1 } @@ -2097,7 +2118,7 @@ close :: { () } -- Miscellaneous (mostly renamings) modid :: { Located ModuleName } - : CONID { L1 $ mkModuleNameFS (getCONID $1) } + : upcase_id { L1 $ mkModuleNameFS (unLoc $1) } | QCONID { L1 $ let (mod,c) = getQCONID $1 in mkModuleNameFS (mkFastString @@ -2108,6 +2129,12 @@ commas :: { Int } -- One or more commas : commas ',' { $1 + 1 } | ',' { 1 } +upcase_id :: { Located FastString } + : CONID { L1 $! getCONID $1 } + | 'N' { L1 (fsLit "N") } + | 'R' { L1 (fsLit "R") } + | 'P' { L1 (fsLit "P") } + ----------------------------------------------------------------------------- -- Documentation comments @@ -2119,7 +2146,7 @@ docprev :: { LHsDocString } docnamed :: { Located (String, HsDocString) } : DOCNAMED {% - let string = getDOCNAMED $1 + let string = getDOCNAMED $1 (name, rest) = break isSpace string in return (L1 (name, HsDocString (mkFastString rest))) } @@ -2204,8 +2231,8 @@ sL span a = span `seq` a `seq` L span a -- make a point SrcSpan at line 1, column 0. Strictly speaking we should -- try to find the span of the whole file (ToDo). fileSrcSpan :: P SrcSpan -fileSrcSpan = do - l <- getSrcLoc; +fileSrcSpan = do + l <- getSrcLoc; let loc = mkSrcLoc (srcLocFile l) 1 1; return (mkSrcSpan loc loc) @@ -2215,4 +2242,15 @@ hintMultiWayIf span = do mwiEnabled <- liftM ((Opt_MultiWayIf `xopt`) . dflags) getPState unless mwiEnabled $ parseErrorSDoc span $ text "Multi-way if-expressions need -XMultiWayIf turned on" + +-- Hint about explicit-forall, assuming UnicodeSyntax is on +hintExplicitForall :: SrcSpan -> P () +hintExplicitForall span = do + forall <- extension explicitForallEnabled + rulePrag <- extension inRulePrag + unless (forall || rulePrag) $ parseErrorSDoc span $ vcat + [ text "Illegal symbol '∀' in type" + , text "Perhaps you intended -XRankNTypes or similar flag" + , text "to enable explicit-forall syntax: ∀ <tvs>. <type>" + ] } |