X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=fd5b02c83bb426fdc742e3c55efd297676692c2d;hp=3b51e5841845de141519f628fbc23282085b7770;hb=9ba922ee06b048774d7a82964867ff768a78126e;hpb=836b1e90821aacc9d1e09fe78085f911597274c8 diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 3b51e58..fd5b02c 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -8,7 +8,15 @@ -- --------------------------------------------------------------------------- { -{-# OPTIONS -Wwarn -w #-} +{-# OPTIONS -Wwarn -w -XNoMonomorphismRestriction #-} +-- The NoMonomorphismRestriction deals with a Happy infelicity +-- With OutsideIn's more conservativ monomorphism restriction +-- we aren't generalising +-- notHappyAtAll = error "urk" +-- which is terrible. Switching off the restriction allows +-- the generalisation. Better would be to make Happy generate +-- an appropriate signature. + -- 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 @@ -48,8 +56,7 @@ import StaticFlags ( opt_SccProfilingOn, opt_Hpc ) import Type ( Kind, liftedTypeKind, unliftedTypeKind ) import Coercion ( mkArrowKind ) import Class ( FunDep ) -import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), - Activation(..), RuleMatchInfo(..), defaultInlinePragma ) +import BasicTypes import DynFlags import OrdList import HaddockUtils @@ -241,6 +248,7 @@ incorrect. 'dynamic' { L _ ITdynamic } 'safe' { L _ ITsafe } 'threadsafe' { L _ ITthreadsafe } -- ToDo: remove deprecated alias + 'interruptible' { L _ ITinterruptible } 'unsafe' { L _ ITunsafe } 'mdo' { L _ ITmdo } 'family' { L _ ITfamily } @@ -253,8 +261,7 @@ incorrect. 'by' { L _ ITby } -- for list transform extension 'using' { L _ ITusing } -- for list transform extension - '{-# INLINE' { L _ (ITinline_prag _) } - '{-# INLINE_CONLIKE' { L _ (ITinline_conlike_prag _) } + '{-# INLINE' { L _ (ITinline_prag _ _) } '{-# SPECIALISE' { L _ ITspec_prag } '{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _) } '{-# SOURCE' { L _ ITsource_prag } @@ -697,9 +704,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, LHsType RdrName) } - : context '=>' type { LL ($1, $3) } - | type { L1 (noLoc [], $1) } +tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) } + : context '=>' type { LL (Just $1, $3) } + | type { L1 (Nothing, $1) } ----------------------------------------------------------------------------- -- Stand-alone deriving @@ -783,8 +790,8 @@ decllist :: { Located (OrdList (LHsDecl RdrName)) } 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)) } + | '{' dbinds '}' { LL (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) } + | vocurly dbinds close { L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) } wherebinds :: { Located (HsLocalBinds RdrName) } -- May have implicit parameters -- No type declarations @@ -890,6 +897,7 @@ callconv :: { CCallConv } safety :: { Safety } : 'unsafe' { PlayRisky } | 'safe' { PlaySafe False } + | 'interruptible' { PlayInterruptible } | 'threadsafe' { PlaySafe True } -- deprecated alias fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) } @@ -936,7 +944,7 @@ infixtype :: { LHsType RdrName } strict_mark :: { Located HsBang } : '!' { L1 HsStrict } - | '{-# UNPACK' '#-}' '!' { LL HsUnbox } + | '{-# UNPACK' '#-}' '!' { LL HsUnpack } -- A ctype is a for-all type ctype :: { LHsType RdrName } @@ -1230,14 +1238,12 @@ 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 (mkInlinePragma $2 FunLike (getINLINE $1)))) } - | '{-# INLINE_CONLIKE' activation qvar '#-}' - { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma $2 ConLike (getINLINE_CONLIKE $1)))) } + { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) } | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}' { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlinePragma) | t <- $4] } | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}' - { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlinePragma $2 FunLike (getSPEC_INLINE $1))) + { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlinePragma (getSPEC_INLINE $1) $2)) | t <- $5] } | '{-# SPECIALISE' 'instance' inst_type '#-}' { LL $ unitOL (LL $ SigD (SpecInstSig $3)) } @@ -1269,7 +1275,9 @@ exp10 :: { LHsExpr RdrName } (unguardedGRHSs $6) ]) } | 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 } - | 'if' exp 'then' exp 'else' exp { LL $ HsIf $2 $4 $6 } + | 'if' exp optSemi 'then' exp optSemi 'else' exp + {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >> + return (LL $ mkHsIf $2 $5 $8) } | 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) } | '-' fexp { LL $ NegApp $2 noSyntaxExpr } @@ -1296,6 +1304,10 @@ exp10 :: { LHsExpr RdrName } -- hdaume: core annotation | fexp { $1 } +optSemi :: { Bool } + : ';' { True } + | {- empty -} { False } + scc_annot :: { Located FastString } : '_scc_' STRING {% (addWarning Opt_WarnWarningsDeprecations (getLoc $1) (text "_scc_ is deprecated; use an SCC pragma instead")) >>= \_ -> ( do scc <- getSCC $2; return $ LL scc ) } @@ -1633,11 +1645,10 @@ fbinds1 :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) } | '..' { ([], True) } fbind :: { HsRecField RdrName (LHsExpr RdrName) } - : qvar '=' exp { HsRecField $1 $3 False } - | qvar { HsRecField $1 (L (getLoc $1) placeHolderPunRhs) True } - -- Here's where we say that plain 'x' - -- means exactly 'x = x'. The pun-flag boolean is - -- there so we can still print it right + : qvar '=' exp { HsRecField $1 $3 False } + | qvar { HsRecField $1 placeHolderPunRhs True } + -- In the punning case, use a place-holder + -- The renamer fills in the final value ----------------------------------------------------------------------------- -- Implicit Parameter Bindings @@ -1782,6 +1793,7 @@ tyvarid :: { Located RdrName } | special_id { L1 $! mkUnqual tvName (unLoc $1) } | 'unsafe' { L1 $! mkUnqual tvName (fsLit "unsafe") } | 'safe' { L1 $! mkUnqual tvName (fsLit "safe") } + | 'interruptible' { L1 $! mkUnqual tvName (fsLit "interruptible") } | 'threadsafe' { L1 $! mkUnqual tvName (fsLit "threadsafe") } tyvarsym :: { Located RdrName } @@ -1815,6 +1827,7 @@ varid :: { Located RdrName } | special_id { L1 $! mkUnqual varName (unLoc $1) } | 'unsafe' { L1 $! mkUnqual varName (fsLit "unsafe") } | 'safe' { L1 $! mkUnqual varName (fsLit "safe") } + | 'interruptible' { L1 $! mkUnqual varName (fsLit "interruptible") } | 'threadsafe' { L1 $! mkUnqual varName (fsLit "threadsafe") } | 'forall' { L1 $! mkUnqual varName (fsLit "forall") } | 'family' { L1 $! mkUnqual varName (fsLit "family") } @@ -1841,7 +1854,7 @@ varsym_no_minus :: { Located RdrName } -- varsym not including '-' -- These special_ids are treated as keywords in various places, -- but as ordinary ids elsewhere. 'special_id' collects all these --- except 'unsafe', 'forall', and 'family' whose treatment differs +-- except 'unsafe', 'interruptible', 'forall', and 'family' whose treatment differs -- depending on context special_id :: { Located FastString } special_id @@ -1975,9 +1988,9 @@ 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 +getINLINE (L _ (ITinline_prag inl conl)) = (inl,conl) +getSPEC_INLINE (L _ (ITspec_inline_prag True)) = (Inline, FunLike) +getSPEC_INLINE (L _ (ITspec_inline_prag False)) = (NoInline,FunLike) getDOCNEXT (L _ (ITdocCommentNext x)) = x getDOCPREV (L _ (ITdocCommentPrev x)) = x