X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=cbc3bcbf61edce46745f7318dff50e8040764887;hp=86ce98c0dd7f67e7ec9bcb14fe17de5a1c1cd93c;hb=432b9c9322181a3644083e3c19b7e240d90659e7;hpb=cae75f82226638691cfa1e85fc168f4b65ddce4d diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 86ce98c..cbc3bcb 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -8,7 +8,7 @@ -- --------------------------------------------------------------------------- { -{-# OPTIONS -w #-} +{-# OPTIONS -Wwarn -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 @@ -46,8 +46,9 @@ import SrcLoc ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans, import Module import StaticFlags ( opt_SccProfilingOn, opt_Hpc ) import Type ( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind ) +import Class ( FunDep ) import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), - Activation(..), defaultInlineSpec ) + Activation(..), RuleMatchInfo(..), defaultInlineSpec ) import DynFlags import OrdList import HaddockParse @@ -240,12 +241,13 @@ incorrect. 'label' { L _ ITlabel } 'dynamic' { L _ ITdynamic } 'safe' { L _ ITsafe } - 'threadsafe' { L _ ITthreadsafe } + 'threadsafe' { L _ ITthreadsafe } -- ToDo: remove deprecated alias 'unsafe' { L _ ITunsafe } 'mdo' { L _ ITmdo } 'family' { L _ ITfamily } 'stdcall' { L _ ITstdcallconv } 'ccall' { L _ ITccallconv } + 'prim' { L _ ITprimcallconv } 'dotnet' { L _ ITdotnet } 'proc' { L _ ITproc } -- for arrow notation extension 'rec' { L _ ITrec } -- for arrow notation extension @@ -254,6 +256,7 @@ incorrect. 'using' { L _ ITusing } -- for list transform extension '{-# INLINE' { L _ (ITinline_prag _) } + '{-# INLINE_CONLIKE' { L _ (ITinline_conlike_prag _) } '{-# SPECIALISE' { L _ ITspec_prag } '{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _) } '{-# SOURCE' { L _ ITsource_prag } @@ -264,6 +267,7 @@ incorrect. '{-# DEPRECATED' { L _ ITdeprecated_prag } '{-# WARNING' { L _ ITwarning_prag } '{-# UNPACK' { L _ ITunpack_prag } + '{-# ANN' { L _ ITann_prag } '#-}' { L _ ITclose_prag } '..' { L _ ITdotdot } -- reserved symbols @@ -314,6 +318,8 @@ incorrect. QCONID { L _ (ITqconid _) } QVARSYM { L _ (ITqvarsym _) } QCONSYM { L _ (ITqconsym _) } + PREFIXQVARSYM { L _ (ITprefixqvarsym _) } + PREFIXQCONSYM { L _ (ITprefixqconsym _) } IPDUPVARID { L _ (ITdupipvarid _) } -- GHC extension @@ -495,13 +501,17 @@ importdecls :: { [LImportDecl RdrName] } | {- empty -} { [] } importdecl :: { LImportDecl RdrName } - : 'import' maybe_src optqualified modid maybeas maybeimpspec - { L (comb4 $1 $4 $5 $6) (ImportDecl $4 $2 $3 (unLoc $5) (unLoc $6)) } + : 'import' maybe_src optqualified maybe_pkg modid maybeas maybeimpspec + { L (comb4 $1 $5 $6 $7) (ImportDecl $5 $4 $2 $3 (unLoc $6) (unLoc $7)) } maybe_src :: { IsBootInterface } : '{-# SOURCE' '#-}' { True } | {- empty -} { False } +maybe_pkg :: { Maybe FastString } + : STRING { Just (getSTRING $1) } + | {- empty -} { Nothing } + optqualified :: { Bool } : 'qualified' { True } | {- empty -} { False } @@ -555,6 +565,7 @@ topdecl :: { OrdList (LHsDecl RdrName) } | '{-# DEPRECATED' deprecations '#-}' { $2 } | '{-# WARNING' warnings '#-}' { $2 } | '{-# RULES' rules '#-}' { $2 } + | annotation { unitOL $1 } | decl { unLoc $1 } -- Template Haskell Extension @@ -566,21 +577,13 @@ topdecl :: { OrdList (LHsDecl RdrName) } -- Type classes -- cl_decl :: { LTyClDecl RdrName } - : 'class' tycl_hdr fds where_cls - {% do { let { (binds, sigs, ats, docs) = - 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 docs) } } + : 'class' tycl_hdr fds where_cls {% mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 $4 } -- Type declarations (toplevel) -- ty_decl :: { LTyClDecl RdrName } -- ordinary type synonyms - : 'type' type '=' ctype + : 'type' type '=' ctypedoc -- 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) @@ -588,87 +591,53 @@ ty_decl :: { LTyClDecl RdrName } -- -- 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)) - } } + {% mkTySynonym (comb2 $1 $4) False $2 $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 - ; return (L (comb3 $1 $3 $4) - (TyFamily TypeFamily tc tvs (unLoc $4))) - } } + {% mkTyFamily (comb3 $1 $3 $4) TypeFamily $3 (unLoc $4) } -- 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)) - } } + {% mkTySynonym (comb2 $1 $5) True $3 $5 } -- ordinary data type or newtype declaration | data_or_newtype tycl_hdr constrs deriving - {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2} - ; checkTyVars tparms -- no type pattern - ; return $! - sL (comb4 $1 $2 $3 $4) + {% mkTyData (comb4 $1 $2 $3 $4) (unLoc $1) False $2 + Nothing (reverse (unLoc $3)) (unLoc $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 - {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2} - ; checkTyVars tparms -- can have type pats - ; return $! - sL (comb4 $1 $2 $4 $5) - (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) - (unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } } + {% mkTyData (comb4 $1 $2 $4 $5) (unLoc $1) False $2 + (unLoc $3) (reverse (unLoc $5)) (unLoc $6) } + -- We need the location on tycl_hdr in case + -- constrs and deriving are both empty -- data/newtype family - | '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 - parseError (getLoc ctxt) - "A family declaration cannot have a context" - ; return $ - L (comb3 $1 $2 $4) - (TyFamily DataFamily tc tvs (unLoc $4)) } } + | 'data' 'family' type opt_kind_sig + {% mkTyFamily (comb3 $1 $2 $4) DataFamily $3 (unLoc $4) } -- 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)) } } + {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $3 + 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 family declarations + {% mkTyData (comb4 $1 $3 $6 $7) (unLoc $1) True $3 + (unLoc $4) (reverse (unLoc $6)) (unLoc $7) } + +-- Associated type family declarations -- -- * They have a different syntax than on the toplevel (no family special -- identifier). @@ -682,68 +651,38 @@ at_decl_cls :: { LTyClDecl RdrName } : '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 - ; return (L (comb3 $1 $2 $3) - (TyFamily TypeFamily tc tvs (unLoc $3))) - } } + {% mkTyFamily (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3) } -- default type instance | '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)) - } } + {% mkTySynonym (comb2 $1 $4) True $2 $4 } -- data/newtype family declaration - | '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 - parseError (getLoc ctxt) - "A family declaration cannot have a context" - ; return $ - L (comb3 $1 $2 $3) - (TyFamily DataFamily tc tvs (unLoc $3)) - } } - --- Associate type instances + | 'data' type opt_kind_sig + {% mkTyFamily (comb3 $1 $2 $3) DataFamily $2 (unLoc $3) } + +-- Associated type instances -- at_decl_inst :: { LTyClDecl RdrName } -- 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)) - } } + {% mkTySynonym (comb2 $1 $4) True $2 $4 } -- 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)) } } + {% mkTyData (comb4 $1 $2 $3 $4) (unLoc $1) True $2 + 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)) } } + {% mkTyData (comb4 $1 $2 $5 $6) (unLoc $1) True $2 + (unLoc $3) (reverse (unLoc $5)) (unLoc $6) } data_or_newtype :: { Located NewOrData } : 'data' { L1 DataType } @@ -760,12 +699,9 @@ opt_kind_sig :: { Located (Maybe Kind) } -- (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], - [LHsType RdrName]) } - : context '=>' type {% checkTyClHdr $1 $3 >>= return.LL } - | type {% checkTyClHdr (noLoc []) $1 >>= return.L1 } +tycl_hdr :: { Located (LHsContext RdrName, LHsType RdrName) } + : context '=>' type { LL ($1, $3) } + | type { L1 (noLoc [], $1) } ----------------------------------------------------------------------------- -- Stand-alone deriving @@ -920,6 +856,13 @@ deprecation :: { OrdList (LHsDecl RdrName) } { toOL [ LL $ WarningD (Warning n (DeprecatedTxt (getSTRING $2))) | n <- unLoc $1 ] } +----------------------------------------------------------------------------- +-- Annotations +annotation :: { LHsDecl RdrName } + : '{-# ANN' name_var aexp '#-}' { LL (AnnD $ HsAnnotation (ValueAnnProvenance (unLoc $2)) $3) } + | '{-# ANN' 'type' tycon aexp '#-}' { LL (AnnD $ HsAnnotation (TypeAnnProvenance (unLoc $3)) $4) } + | '{-# ANN' 'module' aexp '#-}' { LL (AnnD $ HsAnnotation ModuleAnnProvenance $3) } + ----------------------------------------------------------------------------- -- Foreign import and export declarations @@ -936,12 +879,13 @@ fdecl : 'import' callconv safety fspec callconv :: { CallConv } : 'stdcall' { CCall StdCallConv } | 'ccall' { CCall CCallConv } + | 'prim' { CCall PrimCallConv} | 'dotnet' { DNCall } safety :: { Safety } : 'unsafe' { PlayRisky } | 'safe' { PlaySafe False } - | 'threadsafe' { PlaySafe True } + | 'threadsafe' { PlaySafe True } -- deprecated alias fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) } : STRING var '::' sigtypedoc { LL (L (getLoc $1) (getSTRING $1), $2, $4) } @@ -961,15 +905,12 @@ opt_asig :: { Maybe (LHsType RdrName) } : {- empty -} { Nothing } | '::' atype { Just $2 } -sigtypes1 :: { [LHsType RdrName] } - : sigtype { [ $1 ] } - | sigtype ',' sigtypes1 { $1 : $3 } - -sigtype :: { LHsType RdrName } +sigtype :: { LHsType RdrName } -- Always a HsForAllTy, + -- to tell the renamer where to generalise : ctype { L1 (mkImplicitHsForAllTy (noLoc []) $1) } -- Wrap an Implicit forall if there isn't one there already -sigtypedoc :: { LHsType RdrName } +sigtypedoc :: { LHsType RdrName } -- Always a HsForAllTy : ctypedoc { L1 (mkImplicitHsForAllTy (noLoc []) $1) } -- Wrap an Implicit forall if there isn't one there already @@ -977,30 +918,17 @@ sig_vars :: { Located [Located RdrName] } : sig_vars ',' var { LL ($3 : unLoc $1) } | var { L1 [$1] } +sigtypes1 :: { [LHsType RdrName] } -- Always HsForAllTys + : sigtype { [ $1 ] } + | sigtype ',' sigtypes1 { $1 : $3 } + ----------------------------------------------------------------------------- -- Types infixtype :: { LHsType RdrName } - : btype qtyconop gentype { LL $ HsOpTy $1 $2 $3 } - | btype tyvarop gentype { LL $ HsOpTy $1 $2 $3 } + : btype qtyconop type { LL $ HsOpTy $1 $2 $3 } + | btype tyvarop type { LL $ HsOpTy $1 $2 $3 } -infixtypedoc :: { LHsType RdrName } - : infixtype { $1 } - | infixtype docprev { LL $ HsDocTy $1 $2 } - -gentypedoc :: { LHsType RdrName } - : btype { $1 } - | btypedoc { $1 } - | infixtypedoc { $1 } - | btype '->' ctypedoc { LL $ HsFunTy $1 $3 } - | btypedoc '->' ctypedoc { LL $ HsFunTy $1 $3 } - -ctypedoc :: { LHsType RdrName } - : 'forall' tv_bndrs '.' ctypedoc { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 } - | context '=>' ctypedoc { LL $ mkImplicitHsForAllTy $1 $3 } - -- A type of form (context => type) is an *implicit* HsForAllTy - | gentypedoc { $1 } - strict_mark :: { Located HsBang } : '!' { L1 HsStrict } | '{-# UNPACK' '#-}' '!' { LL HsUnbox } @@ -1008,51 +936,82 @@ strict_mark :: { Located HsBang } -- A ctype is a for-all type ctype :: { LHsType RdrName } : 'forall' tv_bndrs '.' ctype { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 } - | context '=>' type { LL $ mkImplicitHsForAllTy $1 $3 } + | context '=>' ctype { LL $ mkImplicitHsForAllTy $1 $3 } + -- A type of form (context => type) is an *implicit* HsForAllTy + | ipvar '::' type { LL (HsPredTy (HsIParam (unLoc $1) $3)) } + | type { $1 } + +---------------------- +-- Notes for 'ctypedoc' +-- 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: +-- 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 } + | context '=>' ctypedoc { LL $ mkImplicitHsForAllTy $1 $3 } -- A type of form (context => type) is an *implicit* HsForAllTy - | type { $1 } + | ipvar '::' type { LL (HsPredTy (HsIParam (unLoc $1) $3)) } + | typedoc { $1 } +---------------------- +-- Notes for 'context' -- We parse a context as a btype so that we don't get reduce/reduce -- errors in ctype. The basic problem is that -- (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 here and in gentype, to permit an individual --- equational constraint without parenthesis. + +-- 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 context :: { LHsContext RdrName } : btype '~' btype {% checkContext (LL $ HsPredTy (HsEqualP $1 $3)) } | btype {% checkContext $1 } type :: { LHsType RdrName } - : ipvar '::' gentype { LL (HsPredTy (HsIParam (unLoc $1) $3)) } - | gentype { $1 } - -gentype :: { LHsType RdrName } : btype { $1 } - | btype qtyconop gentype { LL $ HsOpTy $1 $2 $3 } - | btype tyvarop gentype { LL $ HsOpTy $1 $2 $3 } + | btype qtyconop type { LL $ HsOpTy $1 $2 $3 } + | btype tyvarop type { LL $ HsOpTy $1 $2 $3 } | btype '->' ctype { LL $ HsFunTy $1 $3 } | btype '~' btype { LL $ HsPredTy (HsEqualP $1 $3) } +typedoc :: { LHsType RdrName } + : btype { $1 } + | btype docprev { LL $ HsDocTy $1 $2 } + | btype qtyconop type { LL $ HsOpTy $1 $2 $3 } + | btype qtyconop type docprev { LL $ HsDocTy (L (comb3 $1 $2 $3) (HsOpTy $1 $2 $3)) $4 } + | btype tyvarop type { LL $ HsOpTy $1 $2 $3 } + | btype tyvarop type docprev { LL $ HsDocTy (L (comb3 $1 $2 $3) (HsOpTy $1 $2 $3)) $4 } + | btype '->' ctypedoc { LL $ HsFunTy $1 $3 } + | btype docprev '->' ctypedoc { LL $ HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2)) $4 } + | btype '~' btype { LL $ HsPredTy (HsEqualP $1 $3) } + btype :: { LHsType RdrName } : btype atype { LL $ HsAppTy $1 $2 } | atype { $1 } -btypedoc :: { LHsType RdrName } - : btype atype docprev { LL $ HsDocTy (L (comb2 $1 $2) (HsAppTy $1 $2)) $3 } - | atype docprev { LL $ HsDocTy $1 $2 } - atype :: { LHsType RdrName } : gtycon { L1 (HsTyVar (unLoc $1)) } | tyvar { L1 (HsTyVar (unLoc $1)) } - | strict_mark atype { LL (HsBangTy (unLoc $1) $2) } + | strict_mark atype { LL (HsBangTy (unLoc $1) $2) } -- Constructor sigs only + | '{' fielddecls '}' { LL $ HsRecTy $2 } -- Constructor sigs only | '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy Boxed ($2:$4) } | '(#' comma_types1 '#)' { LL $ HsTupleTy Unboxed $2 } | '[' ctype ']' { LL $ HsListTy $2 } | '[:' ctype ':]' { LL $ HsPArrTy $2 } | '(' ctype ')' { LL $ HsParTy $2 } | '(' ctype '::' kind ')' { LL $ HsKindSig $2 (unLoc $4) } + | '$(' exp ')' { LL $ HsSpliceTy (mkHsSplice $2 ) } + | TH_ID_SPLICE { LL $ HsSpliceTy (mkHsSplice + (L1 $ HsVar (mkUnqual varName + (getTH_ID_SPLICE $1)))) } -- $x -- Generics | INTEGER { L1 (HsNumTy (getINTEGER $1)) } @@ -1084,15 +1043,15 @@ tv_bndr :: { LHsTyVarBndr RdrName } | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) (unLoc $4)) } -fds :: { Located [Located ([RdrName], [RdrName])] } +fds :: { Located [Located (FunDep RdrName)] } : {- empty -} { noLoc [] } | '|' fds1 { LL (reverse (unLoc $2)) } -fds1 :: { Located [Located ([RdrName], [RdrName])] } +fds1 :: { Located [Located (FunDep RdrName)] } : fds1 ',' fd { LL ($3 : unLoc $1) } | fd { L1 [$1] } -fd :: { Located ([RdrName], [RdrName]) } +fd :: { Located (FunDep RdrName) } : varids0 '->' varids0 { L (comb3 $1 $2 $3) (reverse (unLoc $1), reverse (unLoc $3)) } @@ -1121,9 +1080,9 @@ gadt_constrlist :: { Located [LConDecl RdrName] } | vocurly gadt_constrs close { $2 } gadt_constrs :: { Located [LConDecl RdrName] } - : gadt_constrs ';' gadt_constr { LL ($3 : unLoc $1) } + : gadt_constrs ';' gadt_constr { sL (comb2 $1 (head $3)) ($3 ++ unLoc $1) } | gadt_constrs ';' { $1 } - | gadt_constr { L1 [$1] } + | gadt_constr { sL (getLoc (head $1)) $1 } -- We allow the following forms: -- C :: Eq a => a -> T a @@ -1131,24 +1090,14 @@ gadt_constrs :: { Located [LConDecl RdrName] } -- D { x,y :: a } :: T a -- forall a. Eq a => D { x,y :: a } :: T a -gadt_constr :: { LConDecl RdrName } - : con '::' sigtype - { LL (mkGadtDecl $1 $3) } - -- Syntax: Maybe merge the record stuff with the single-case above? - -- (to kill the mostly harmless reduce/reduce error) - -- XXX revisit audreyt - | constr_stuff_record '::' sigtype - { let (con,details) = unLoc $1 in - LL (ConDecl con Implicit [] (noLoc []) details (ResTyGADT $3) Nothing) } -{- - | forall context '=>' constr_stuff_record '::' sigtype - { let (con,details) = unLoc $4 in - LL (ConDecl con Implicit (unLoc $1) $2 details (ResTyGADT $6) Nothing ) } - | forall constr_stuff_record '::' sigtype - { let (con,details) = unLoc $2 in - LL (ConDecl con Implicit (unLoc $1) (noLoc []) details (ResTyGADT $4) Nothing) } --} +gadt_constr :: { [LConDecl RdrName] } + : con_list '::' sigtype + { map (sL (comb2 $1 $3)) (mkGadtDecl (unLoc $1) $3) } + -- Deprecated syntax for GADT record declarations + | oqtycon '{' fielddecls '}' '::' sigtype + {% do { cd <- mkDeprecatedGadtRecordDecl (comb2 $1 $6) $1 $3 $6 + ; return [cd] } } constrs :: { Located [LConDecl RdrName] } : {- empty; a GHC extension -} { noLoc [] } @@ -1161,10 +1110,12 @@ constrs1 :: { Located [LConDecl RdrName] } constr :: { LConDecl RdrName } : maybe_docnext forall context '=>' constr_stuff maybe_docprev { let (con,details) = unLoc $5 in - L (comb4 $2 $3 $4 $5) (ConDecl con Explicit (unLoc $2) $3 details ResTyH98 ($1 `mplus` $6)) } + 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 - L (comb2 $2 $3) (ConDecl con Explicit (unLoc $2) (noLoc []) details ResTyH98 ($1 `mplus` $4)) } + addConDoc (L (comb2 $2 $3) (mkSimpleConDecl con (unLoc $2) (noLoc []) details)) + ($1 `mplus` $4) } forall :: { Located [LHsTyVarBndr RdrName] } : 'forall' tv_bndrs '.' { LL $2 } @@ -1178,21 +1129,22 @@ constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) } -- C t1 t2 %: D Int -- in which case C really would be a type constructor. We can't resolve this -- ambiguity till we come across the constructor oprerator :% (or not, more usually) - : btype {% mkPrefixCon $1 [] >>= return.LL } - | oqtycon '{' '}' {% mkRecCon $1 [] >>= return.LL } - | oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.LL } - | btype conop btype { LL ($2, InfixCon $1 $3) } + : btype {% splitCon $1 >>= return.LL } + | btype conop btype { LL ($2, InfixCon $1 $3) } -constr_stuff_record :: { Located (Located RdrName, HsConDeclDetails RdrName) } - : oqtycon '{' '}' {% mkRecCon $1 [] >>= return.sL (comb2 $1 $>) } - | oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.sL (comb2 $1 $>) } +fielddecls :: { [ConDeclField RdrName] } + : {- empty -} { [] } + | fielddecls1 { $1 } -fielddecls :: { [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] } - : fielddecl maybe_docnext ',' maybe_docprev fielddecls { addFieldDoc (unLoc $1) $4 : addFieldDocs $5 $2 } - | fielddecl { [unLoc $1] } +fielddecls1 :: { [ConDeclField RdrName] } + : fielddecl maybe_docnext ',' maybe_docprev fielddecls1 + { [ addFieldDoc f $4 | f <- $1 ] ++ addFieldDocs $5 $2 } + -- This adds the doc $4 to each field separately + | fielddecl { $1 } -fielddecl :: { Located ([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName)) } - : maybe_docnext sig_vars '::' ctype maybe_docprev { L (comb3 $2 $3 $4) (reverse (unLoc $2), $4, $1 `mplus` $5) } +fielddecl :: { [ConDeclField RdrName] } -- A list because of f,g :: Int + : 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 -- we can do deriving( forall a. C [a] ) in a newtype (GHC extension). @@ -1272,12 +1224,14 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) } | infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1)))) | n <- unLoc $3 ] } | '{-# INLINE' activation qvar '#-}' - { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 (getINLINE $1)))) } + { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 FunLike (getINLINE $1)))) } + | '{-# INLINE_CONLIKE' activation qvar '#-}' + { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 ConLike (getINLINE_CONLIKE $1)))) } | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}' { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlineSpec) | t <- $4] } | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}' - { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 (getSPEC_INLINE $1))) + { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 FunLike (getSPEC_INLINE $1))) | t <- $5] } | '{-# SPECIALISE' 'instance' inst_type '#-}' { LL $ unitOL (LL $ SigD (SpecInstSig $3)) } @@ -1366,7 +1320,7 @@ aexp1 :: { LHsExpr RdrName } -- so it's not enabled yet. -- But this case *is* used for the left hand side of a generic definition, -- which is parsed as an expression before being munged into a pattern - | qcname '{|' gentype '|}' { LL $ HsApp (sL (getLoc $1) (HsVar (unLoc $1))) + | qcname '{|' type '|}' { LL $ HsApp (sL (getLoc $1) (HsVar (unLoc $1))) (sL (getLoc $3) (HsType $3)) } aexp2 :: { LHsExpr RdrName } @@ -1429,16 +1383,27 @@ cvtopdecls0 :: { [LHsDecl RdrName] } : {- empty -} { [] } | cvtopdecls { $1 } --- tuple expressions: things that can appear unparenthesized as long as they're +-- "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 } : exp { $1 } - -- Technically, this should only be used for bang patterns, - -- but we can be a little more liberal here and avoid parens - -- inside tuples - | infixexp qop { LL $ SectionL $1 $2 } + + -- Note [Parsing sections] + -- ~~~~~~~~~~~~~~~~~~~~~~~ + -- We include left and right sections here, which isn't + -- technically right according to Haskell 98. For example + -- (3 +, True) isn't legal + -- However, we want to parse bang patterns like + -- (!x, !y) + -- and it's convenient to do so here as a section + -- Then when converting expr to pattern we unravel it again + -- Meanwhile, the renamer checks that real sections appear + -- inside parens. + | infixexp qop { LL $ SectionL $1 $2 } | qopm infixexp { LL $ SectionR $1 $2 } - -- view patterns get parenthesized above + + -- View patterns get parenthesized above | exp '->' exp { LL $ EViewPat $1 $3 } texps :: { [LHsExpr RdrName] } @@ -1686,6 +1651,10 @@ con :: { Located RdrName } | '(' consym ')' { LL (unLoc $2) } | sysdcon { L1 $ nameRdrName (dataConName (unLoc $1)) } +con_list :: { Located [Located RdrName] } +con_list : con { L1 [$1] } + | con ',' con_list { LL ($1 : unLoc $3) } + sysdcon :: { Located DataCon } -- Wired in data constructors : '(' ')' { LL unitDataCon } | '(' commas ')' { LL $ tupleCon Boxed $2 } @@ -1724,6 +1693,7 @@ qtyconop :: { Located RdrName } -- Qualified or unqualified qtycon :: { Located RdrName } -- Qualified or unqualified : QCONID { L1 $! mkQual tcClsName (getQCONID $1) } + | PREFIXQCONSYM { L1 $! mkQual tcClsName (getPREFIXQCONSYM $1) } | tycon { $1 } tycon :: { Located RdrName } -- Unqualified @@ -1773,6 +1743,11 @@ tyvar : tyvarid { $1 } tyvarop :: { Located RdrName } tyvarop : '`' tyvarid '`' { LL (unLoc $2) } | tyvarsym { $1 } + | '.' {% 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 . ")]) + } tyvarid :: { Located RdrName } : VARID { L1 $! mkUnqual tvName (getVARID $1) } @@ -1804,17 +1779,15 @@ qvar :: { Located RdrName } qvarid :: { Located RdrName } : varid { $1 } - | QVARID { L1 $ mkQual varName (getQVARID $1) } + | QVARID { L1 $! mkQual varName (getQVARID $1) } + | PREFIXQVARSYM { L1 $! mkQual varName (getPREFIXQVARSYM $1) } varid :: { Located RdrName } - : varid_no_unsafe { $1 } + : VARID { L1 $! mkUnqual varName (getVARID $1) } + | special_id { L1 $! mkUnqual varName (unLoc $1) } | 'unsafe' { L1 $! mkUnqual varName (fsLit "unsafe") } | 'safe' { L1 $! mkUnqual varName (fsLit "safe") } | 'threadsafe' { L1 $! mkUnqual varName (fsLit "threadsafe") } - -varid_no_unsafe :: { Located RdrName } - : VARID { L1 $! mkUnqual varName (getVARID $1) } - | special_id { L1 $! mkUnqual varName (unLoc $1) } | 'forall' { L1 $! mkUnqual varName (fsLit "forall") } | 'family' { L1 $! mkUnqual varName (fsLit "family") } @@ -1852,6 +1825,7 @@ special_id | 'dynamic' { L1 (fsLit "dynamic") } | 'stdcall' { L1 (fsLit "stdcall") } | 'ccall' { L1 (fsLit "ccall") } + | 'prim' { L1 (fsLit "prim") } special_sym :: { Located FastString } special_sym : '!' { L1 (fsLit "!") } @@ -1863,7 +1837,8 @@ special_sym : '!' { L1 (fsLit "!") } qconid :: { Located RdrName } -- Qualified or unqualified : conid { $1 } - | QCONID { L1 $ mkQual dataName (getQCONID $1) } + | QCONID { L1 $! mkQual dataName (getQCONID $1) } + | PREFIXQCONSYM { L1 $! mkQual dataName (getPREFIXQCONSYM $1) } conid :: { Located RdrName } : CONID { L1 $ mkUnqual dataName (getCONID $1) } @@ -1972,6 +1947,8 @@ getQVARID (L _ (ITqvarid x)) = x getQCONID (L _ (ITqconid x)) = x getQVARSYM (L _ (ITqvarsym x)) = x getQCONSYM (L _ (ITqconsym x)) = x +getPREFIXQVARSYM (L _ (ITprefixqvarsym x)) = x +getPREFIXQCONSYM (L _ (ITprefixqconsym x)) = x getIPDUPVARID (L _ (ITdupipvarid x)) = x getCHAR (L _ (ITchar x)) = x getSTRING (L _ (ITstring x)) = x @@ -1985,6 +1962,7 @@ getPRIMFLOAT (L _ (ITprimfloat x)) = x getPRIMDOUBLE (L _ (ITprimdouble x)) = x getTH_ID_SPLICE (L _ (ITidEscape x)) = x getINLINE (L _ (ITinline_prag b)) = b +getINLINE_CONLIKE (L _ (ITinline_conlike_prag b)) = b getSPEC_INLINE (L _ (ITspec_inline_prag b)) = b getDOCNEXT (L _ (ITdocCommentNext x)) = x