X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=d5314e4b21969f3c4d6df94cd785fde0fe917c1e;hp=6de95f8278cab731f7802a2723d2514a64a65ebb;hb=831a35dd00faff195cf938659c2dd736192b865f;hpb=67cb409159fa9136dff942b8baaec25909416022 diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 6de95f8..d5314e4 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -8,25 +8,31 @@ -- --------------------------------------------------------------------------- { -{-# OPTIONS -w #-} +{-# OPTIONS -Wwarn #-} -- 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/Commentary/CodingStyle#Warnings -- for details +{-# OPTIONS_GHC -O0 -fno-ignore-interface-pragmas #-} +{- +Careful optimisation of the parser: we don't want to throw everything +at it, because that takes too long and doesn't buy much, but we do want +to inline certain key external functions, so we instruct GHC not to +throw away inlinings as it would normally do in -O0 mode. +-} + module Parser ( parseModule, parseStmt, parseIdentifier, parseType, parseHeader ) where -#define INCLUDE #include -INCLUDE "HsVersions.h" - import HsSyn import RdrHsSyn -import HscTypes ( IsBootInterface, DeprecTxt ) +import HscTypes ( IsBootInterface, WarningTxt(..) ) import Lexer import RdrName import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon, + unboxedSingletonTyCon, unboxedSingletonDataCon, listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR ) import Type ( funTyCon ) import ForeignCall ( Safety(..), CExportSpec(..), CLabelString, @@ -41,7 +47,7 @@ import Module import StaticFlags ( opt_SccProfilingOn, opt_Hpc ) import Type ( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind ) import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), - Activation(..), defaultInlineSpec ) + Activation(..), RuleMatchInfo(..), defaultInlineSpec ) import DynFlags import OrdList import HaddockParse @@ -248,6 +254,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 } @@ -256,7 +263,9 @@ incorrect. '{-# SCC' { L _ ITscc_prag } '{-# GENERATED' { L _ ITgenerated_prag } '{-# DEPRECATED' { L _ ITdeprecated_prag } + '{-# WARNING' { L _ ITwarning_prag } '{-# UNPACK' { L _ ITunpack_prag } + '{-# ANN' { L _ ITann_prag } '#-}' { L _ ITclose_prag } '..' { L _ ITdotdot } -- reserved symbols @@ -307,6 +316,8 @@ incorrect. QCONID { L _ (ITqconid _) } QVARSYM { L _ (ITqvarsym _) } QCONSYM { L _ (ITqconsym _) } + PREFIXQVARSYM { L _ (ITprefixqvarsym _) } + PREFIXQCONSYM { L _ (ITprefixqconsym _) } IPDUPVARID { L _ (ITdupipvarid _) } -- GHC extension @@ -318,6 +329,7 @@ incorrect. PRIMCHAR { L _ (ITprimchar _) } PRIMSTRING { L _ (ITprimstring _) } PRIMINTEGER { L _ (ITprimint _) } + PRIMWORD { L _ (ITprimword _) } PRIMFLOAT { L _ (ITprimfloat _) } PRIMDOUBLE { L _ (ITprimdouble _) } @@ -336,6 +348,7 @@ TH_ID_SPLICE { L _ (ITidEscape _) } -- $x '$(' { L _ ITparenEscape } -- $( exp ) TH_VAR_QUOTE { L _ ITvarQuote } -- 'x TH_TY_QUOTE { L _ ITtyQuote } -- ''T +TH_QUASIQUOTE { L _ (ITquasiQuote _) } %monad { P } { >>= } { return } %lexer { lexer } { L _ ITeof } @@ -367,7 +380,7 @@ identifier :: { Located RdrName } -- know what they are doing. :-) module :: { Located (HsModule RdrName) } - : maybedocheader 'module' modid maybemoddeprec maybeexports 'where' body + : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body {% fileSrcSpan >>= \ loc -> case $1 of { (info, doc) -> return (L loc (HsModule (Just $3) $5 (fst $7) (snd $7) $4 info doc) )}} @@ -378,15 +391,16 @@ module :: { Located (HsModule RdrName) } Nothing)) } maybedocheader :: { (HaddockModInfo RdrName, Maybe (HsDoc RdrName)) } - : moduleheader { (fst $1, snd $1) } + : moduleheader { $1 } | {- empty -} { (emptyHaddockModInfo, Nothing) } missing_module_keyword :: { () } : {- empty -} {% pushCurrentContext } -maybemoddeprec :: { Maybe DeprecTxt } - : '{-# DEPRECATED' STRING '#-}' { Just (getSTRING $2) } - | {- empty -} { Nothing } +maybemodwarning :: { Maybe WarningTxt } + : '{-# DEPRECATED' STRING '#-}' { Just (DeprecatedTxt (getSTRING $2)) } + | '{-# WARNING' STRING '#-}' { Just (WarningTxt (getSTRING $2)) } + | {- empty -} { Nothing } body :: { ([LImportDecl RdrName], [LHsDecl RdrName]) } : '{' top '}' { $2 } @@ -408,7 +422,7 @@ cvtopdecls :: { [LHsDecl RdrName] } -- Module declaration & imports only header :: { Located (HsModule RdrName) } - : maybedocheader 'module' modid maybemoddeprec maybeexports 'where' header_body + : maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body {% fileSrcSpan >>= \ loc -> case $1 of { (info, doc) -> return (L loc (HsModule (Just $3) $5 $7 [] $4 info doc))}} @@ -485,13 +499,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 } @@ -542,8 +560,10 @@ topdecl :: { OrdList (LHsDecl RdrName) } | stand_alone_deriving { unitOL (LL (DerivD (unLoc $1))) } | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) } | 'foreign' fdecl { unitOL (LL (unLoc $2)) } - | '{-# DEPRECATED' deprecations '#-}' { $2 } + | '{-# DEPRECATED' deprecations '#-}' { $2 } + | '{-# WARNING' warnings '#-}' { $2 } | '{-# RULES' rules '#-}' { $2 } + | annotation { unitOL $1 } | decl { unLoc $1 } -- Template Haskell Extension @@ -569,7 +589,7 @@ cl_decl :: { LTyClDecl RdrName } -- 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) @@ -606,8 +626,8 @@ ty_decl :: { LTyClDecl RdrName } | data_or_newtype tycl_hdr constrs deriving {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2} ; checkTyVars tparms -- no type pattern - ; return $ - L (comb4 $1 $2 $3 $4) + ; return $! + sL (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) @@ -619,8 +639,8 @@ ty_decl :: { LTyClDecl RdrName } deriving {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2} ; checkTyVars tparms -- can have type pats - ; return $ - L (comb4 $1 $2 $4 $5) + ; return $! + sL (comb4 $1 $2 $4 $5) (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) (unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } } @@ -754,7 +774,7 @@ tycl_hdr :: { Located (LHsContext RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName]) } : context '=>' type {% checkTyClHdr $1 $3 >>= return.LL } - | type {% checkTyClHdr (noLoc []) $1 >>= return.L1 } + | type {% checkTyClHdr (noLoc []) $1 >>= return.L1 } ----------------------------------------------------------------------------- -- Stand-alone deriving @@ -820,7 +840,11 @@ where_inst :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed -- Declarations in binding groups other than classes and instances -- decls :: { Located (OrdList (LHsDecl RdrName)) } - : decls ';' decl { LL (unLoc $1 `appOL` unLoc $3) } + : decls ';' decl { let { this = unLoc $3; + rest = unLoc $1; + these = rest `appOL` this } + in rest `seq` this `seq` these `seq` + LL these } | decls ';' { LL (unLoc $1) } | decl { $1 } | {- empty -} { noLoc nilOL } @@ -879,7 +903,19 @@ rule_var :: { RuleBndr RdrName } | '(' varid '::' ctype ')' { RuleBndrSig $2 $4 } ----------------------------------------------------------------------------- --- Deprecations (c.f. rules) +-- Warnings and deprecations (c.f. rules) + +warnings :: { OrdList (LHsDecl RdrName) } + : warnings ';' warning { $1 `appOL` $3 } + | warnings ';' { $1 } + | warning { $1 } + | {- empty -} { nilOL } + +-- SUP: TEMPORARY HACK, not checking for `module Foo' +warning :: { OrdList (LHsDecl RdrName) } + : namelist STRING + { toOL [ LL $ WarningD (Warning n (WarningTxt (getSTRING $2))) + | n <- unLoc $1 ] } deprecations :: { OrdList (LHsDecl RdrName) } : deprecations ';' deprecation { $1 `appOL` $3 } @@ -889,10 +925,17 @@ deprecations :: { OrdList (LHsDecl RdrName) } -- SUP: TEMPORARY HACK, not checking for `module Foo' deprecation :: { OrdList (LHsDecl RdrName) } - : depreclist STRING - { toOL [ LL $ DeprecD (Deprecation n (getSTRING $2)) + : namelist STRING + { 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 @@ -954,26 +997,9 @@ sig_vars :: { Located [Located RdrName] } -- Types infixtype :: { LHsType RdrName } - : btype qtyconop gentype { LL $ HsOpTy $1 $2 $3 } - | btype tyvarop gentype { LL $ HsOpTy $1 $2 $3 } - -infixtypedoc :: { LHsType RdrName } - : infixtype { $1 } - | infixtype docprev { LL $ HsDocTy $1 $2 } + : btype qtyconop type { LL $ HsOpTy $1 $2 $3 } + | btype tyvarop type { LL $ HsOpTy $1 $2 $3 } -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 } @@ -981,41 +1007,67 @@ 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)) } @@ -1219,12 +1271,13 @@ decl :: { Located (OrdList (LHsDecl RdrName)) } return (LL $ unitOL $ LL $ ValD ( PatBind (LL $ BangPat pat) (unLoc $3) placeHolderType placeHolderNames)) } } - | infixexp opt_sig rhs {% do { r <- checkValDef $1 $2 $3; - return (LL $ unitOL (LL $ ValD r)) } } + | infixexp opt_sig rhs {% do { r <- checkValDef $1 $2 $3; + let { l = comb2 $1 $> }; + return $! (sL l (unitOL $! (sL l $ ValD r))) } } | docdecl { LL $ unitOL $1 } rhs :: { Located (GRHSs RdrName) } - : '=' exp wherebinds { L (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) } + : '=' exp wherebinds { sL (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) } | gdrhs wherebinds { LL $ GRHSs (reverse (unLoc $1)) (unLoc $2) } gdrhs :: { Located [LGRHS RdrName] } @@ -1244,12 +1297,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)) } @@ -1303,9 +1358,9 @@ exp10 :: { LHsExpr RdrName } | fexp { $1 } scc_annot :: { Located FastString } - : '_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 } + : '_scc_' STRING {% (addWarning Opt_WarnWarningsDeprecations (getLoc $1) (text "_scc_ is deprecated; use an SCC pragma instead")) >>= \_ -> + ( do scc <- getSCC $2; return $ LL scc ) } + | '{-# SCC' STRING '#-}' {% do scc <- getSCC $2; return $ LL scc } hpc_annot :: { Located (FastString,(Int,Int),(Int,Int)) } : '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' @@ -1338,7 +1393,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 } @@ -1367,6 +1422,11 @@ aexp2 :: { LHsExpr RdrName } (getTH_ID_SPLICE $1)))) } -- $x | '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } -- $( exp ) + | TH_QUASIQUOTE { let { loc = getLoc $1 + ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1 + ; quoterId = mkUnqual varName quoter + } + in sL loc $ HsQuasiQuoteE (mkHsQuasiQuote quoterId quoteSpan quote) } | TH_VAR_QUOTE qvar { LL $ HsBracket (VarBr (unLoc $2)) } | TH_VAR_QUOTE qcon { LL $ HsBracket (VarBr (unLoc $2)) } | TH_TY_QUOTE tyvar { LL $ HsBracket (VarBr (unLoc $2)) } @@ -1396,16 +1456,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] } @@ -1429,7 +1500,7 @@ list :: { LHsExpr RdrName } | texp '|' flattenedpquals { sL (comb2 $1 $>) $ mkHsDo ListComp (unLoc $3) $1 } lexps :: { Located [LHsExpr RdrName] } - : lexps ',' texp { LL ($3 : unLoc $1) } + : lexps ',' texp { LL (((:) $! $3) $! unLoc $1) } | texp ',' texp { LL [$3,$1] } ----------------------------------------------------------------------------- @@ -1617,9 +1688,10 @@ fbind :: { HsRecField RdrName (LHsExpr RdrName) } -- Implicit Parameter Bindings dbinds :: { Located [LIPBind RdrName] } - : dbinds ';' dbind { LL ($3 : unLoc $1) } + : dbinds ';' dbind { let { this = $3; rest = unLoc $1 } + in rest `seq` this `seq` LL (this : rest) } | dbinds ';' { LL (unLoc $1) } - | dbind { L1 [$1] } + | dbind { let this = $1 in this `seq` L1 [this] } -- | {- empty -} { [] } dbind :: { LIPBind RdrName } @@ -1629,15 +1701,15 @@ ipvar :: { Located (IPName RdrName) } : IPDUPVARID { L1 (IPName (mkUnqual varName (getIPDUPVARID $1))) } ----------------------------------------------------------------------------- --- Deprecations +-- Warnings and deprecations -depreclist :: { Located [RdrName] } -depreclist : deprec_var { L1 [unLoc $1] } - | deprec_var ',' depreclist { LL (unLoc $1 : unLoc $3) } +namelist :: { Located [RdrName] } +namelist : name_var { L1 [unLoc $1] } + | name_var ',' namelist { LL (unLoc $1 : unLoc $3) } -deprec_var :: { Located RdrName } -deprec_var : var { $1 } - | con { $1 } +name_var :: { Located RdrName } +name_var : var { $1 } + | con { $1 } ----------------------------------------- -- Data constructors @@ -1655,6 +1727,8 @@ con :: { Located RdrName } sysdcon :: { Located DataCon } -- Wired in data constructors : '(' ')' { LL unitDataCon } | '(' commas ')' { LL $ tupleCon Boxed $2 } + | '(#' '#)' { LL $ unboxedSingletonDataCon } + | '(#' commas '#)' { LL $ tupleCon Unboxed $2 } | '[' ']' { LL nilDataCon } conop :: { Located RdrName } @@ -1672,6 +1746,8 @@ gtycon :: { Located RdrName } -- A "general" qualified tycon : oqtycon { $1 } | '(' ')' { LL $ getRdrName unitTyCon } | '(' commas ')' { LL $ getRdrName (tupleTyCon Boxed $2) } + | '(#' '#)' { LL $ getRdrName unboxedSingletonTyCon } + | '(#' commas '#)' { LL $ getRdrName (tupleTyCon Unboxed $2) } | '(' '->' ')' { LL $ getRdrName funTyCon } | '[' ']' { LL $ listTyCon_RDR } | '[:' ':]' { LL $ parrTyCon_RDR } @@ -1686,6 +1762,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 @@ -1735,13 +1812,18 @@ 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) } | special_id { L1 $! mkUnqual tvName (unLoc $1) } - | 'unsafe' { L1 $! mkUnqual tvName FSLIT("unsafe") } - | 'safe' { L1 $! mkUnqual tvName FSLIT("safe") } - | 'threadsafe' { L1 $! mkUnqual tvName FSLIT("threadsafe") } + | 'unsafe' { L1 $! mkUnqual tvName (fsLit "unsafe") } + | 'safe' { L1 $! mkUnqual tvName (fsLit "safe") } + | 'threadsafe' { L1 $! mkUnqual tvName (fsLit "threadsafe") } tyvarsym :: { Located RdrName } -- Does not include "!", because that is used for strictness marks @@ -1766,19 +1848,17 @@ 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 } - | '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") } + | 'unsafe' { L1 $! mkUnqual varName (fsLit "unsafe") } + | 'safe' { L1 $! mkUnqual varName (fsLit "safe") } + | 'threadsafe' { L1 $! mkUnqual varName (fsLit "threadsafe") } + | 'forall' { L1 $! mkUnqual varName (fsLit "forall") } + | 'family' { L1 $! mkUnqual varName (fsLit "family") } qvarsym :: { Located RdrName } : varsym { $1 } @@ -1793,7 +1873,7 @@ qvarsym1 : QVARSYM { L1 $ mkQual varName (getQVARSYM $1) } varsym :: { Located RdrName } : varsym_no_minus { $1 } - | '-' { L1 $ mkUnqual varName FSLIT("-") } + | '-' { L1 $ mkUnqual varName (fsLit "-") } varsym_no_minus :: { Located RdrName } -- varsym not including '-' : VARSYM { L1 $ mkUnqual varName (getVARSYM $1) } @@ -1806,26 +1886,27 @@ varsym_no_minus :: { Located RdrName } -- varsym not including '-' -- depending on context special_id :: { Located FastString } special_id - : 'as' { L1 FSLIT("as") } - | 'qualified' { L1 FSLIT("qualified") } - | 'hiding' { L1 FSLIT("hiding") } - | 'export' { L1 FSLIT("export") } - | 'label' { L1 FSLIT("label") } - | 'dynamic' { L1 FSLIT("dynamic") } - | 'stdcall' { L1 FSLIT("stdcall") } - | 'ccall' { L1 FSLIT("ccall") } + : 'as' { L1 (fsLit "as") } + | 'qualified' { L1 (fsLit "qualified") } + | 'hiding' { L1 (fsLit "hiding") } + | 'export' { L1 (fsLit "export") } + | 'label' { L1 (fsLit "label") } + | 'dynamic' { L1 (fsLit "dynamic") } + | 'stdcall' { L1 (fsLit "stdcall") } + | 'ccall' { L1 (fsLit "ccall") } special_sym :: { Located FastString } -special_sym : '!' { L1 FSLIT("!") } - | '.' { L1 FSLIT(".") } - | '*' { L1 FSLIT("*") } +special_sym : '!' { L1 (fsLit "!") } + | '.' { L1 (fsLit ".") } + | '*' { L1 (fsLit "*") } ----------------------------------------------------------------------------- -- Data constructors 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) } @@ -1848,6 +1929,7 @@ literal :: { Located HsLit } : CHAR { L1 $ HsChar $ getCHAR $1 } | STRING { L1 $ HsString $ getSTRING $1 } | PRIMINTEGER { L1 $ HsIntPrim $ getPRIMINTEGER $1 } + | PRIMWORD { L1 $ HsWordPrim $ getPRIMWORD $1 } | PRIMCHAR { L1 $ HsCharPrim $ getPRIMCHAR $1 } | PRIMSTRING { L1 $ HsStringPrim $ getPRIMSTRING $1 } | PRIMFLOAT { L1 $ HsFloatPrim $ getPRIMFLOAT $1 } @@ -1896,7 +1978,7 @@ docnamed :: { Located (String, (HsDoc RdrName)) } MyLeft err -> parseError (getLoc $1) err; MyRight doc -> return (L1 (name, doc)) } } -docsection :: { Located (n, HsDoc RdrName) } +docsection :: { Located (Int, HsDoc RdrName) } : DOCSECTION {% let (n, doc) = getDOCSECTION $1 in case parseHaddockString (tokenise doc) of { MyLeft err -> parseError (getLoc $1) err; @@ -1933,6 +2015,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 @@ -1941,10 +2025,12 @@ getRATIONAL (L _ (ITrational x)) = x getPRIMCHAR (L _ (ITprimchar x)) = x getPRIMSTRING (L _ (ITprimstring x)) = x getPRIMINTEGER (L _ (ITprimint x)) = x +getPRIMWORD (L _ (ITprimword x)) = x 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 @@ -1952,21 +2038,31 @@ getDOCPREV (L _ (ITdocCommentPrev x)) = x getDOCNAMED (L _ (ITdocCommentNamed x)) = x getDOCSECTION (L _ (ITdocSection n x)) = (n, x) +getSCC :: Located Token -> P FastString +getSCC lt = do let s = getSTRING lt + err = "Spaces are not allowed in SCCs" + -- We probably actually want to be more restrictive than this + if ' ' `elem` unpackFS s + then failSpanMsgP (getLoc lt) (text err) + else return s + -- Utilities for combining source spans comb2 :: Located a -> Located b -> SrcSpan -comb2 = combineLocs +comb2 a b = a `seq` b `seq` combineLocs a b comb3 :: Located a -> Located b -> Located c -> SrcSpan -comb3 a b c = combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c)) +comb3 a b c = a `seq` b `seq` c `seq` + combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c)) comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan -comb4 a b c d = combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $ - combineSrcSpans (getLoc c) (getLoc d) +comb4 a b c d = a `seq` b `seq` c `seq` d `seq` + (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $ + combineSrcSpans (getLoc c) (getLoc d)) -- strict constructor version: {-# INLINE sL #-} sL :: SrcSpan -> a -> Located a -sL span a = span `seq` L span a +sL span a = span `seq` a `seq` L span a -- Make a source location for the file. We're a bit lazy here and just -- make a point SrcSpan at line 1, column 0. Strictly speaking we should