diff options
| author | Alan Zimmerman <alan.zimm@gmail.com> | 2015-01-15 13:11:21 -0600 |
|---|---|---|
| committer | Austin Seipp <austin@well-typed.com> | 2015-01-16 10:16:05 -0600 |
| commit | 11881ec6f8d4db881671173441df87c2457409f4 (patch) | |
| tree | a03777d178fc04dea082e7b12f2c7cf2dfa97ff3 /compiler | |
| parent | fffbf0627c2c2ee4bc49f9d26a226b39a066945e (diff) | |
| download | haskell-11881ec6f8d4db881671173441df87c2457409f4.tar.gz | |
API Annotations tweaks.
Summary:
HsTyLit now has SourceText
Update documentation of HsSyn to reflect which annotations are attached to which element.
Ensure that the parser always keeps HsSCC and HsTickPragma values, to
be ignored in the desugar phase if not needed
Bringing in SourceText for pragmas
Add Location in NPlusKPat
Add Location in FunDep
Make RecCon payload Located
Explicitly add AnnVal to RdrName where it is compound
Add Location in IPBind
Add Location to name in IEThingAbs
Add Maybe (Located id,Bool) to Match to track fun_id,infix
This includes converting Match into a record and adding a note about why
the fun_id needs to be replicated in the Match.
Add Location in KindedTyVar
Sort out semi-colons for parsing
- import statements
- stmts
- decls
- decls_cls
- decls_inst
This updates the haddock submodule.
Test Plan: ./validate
Reviewers: hvr, austin, goldfire, simonpj
Reviewed By: simonpj
Subscribers: thomie, carter
Differential Revision: https://phabricator.haskell.org/D538
Diffstat (limited to 'compiler')
63 files changed, 1639 insertions, 1037 deletions
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs index f4b7e80e51..5bbc0ce3b4 100644 --- a/compiler/basicTypes/BasicTypes.hs +++ b/compiler/basicTypes/BasicTypes.hs @@ -84,7 +84,9 @@ module BasicTypes( FractionalLit(..), negateFractionalLit, integralFractionalLit, - HValue(..) + HValue(..), + + SourceText ) where import FastString @@ -263,14 +265,15 @@ initialVersion = 1 -} -- reason/explanation from a WARNING or DEPRECATED pragma -data WarningTxt = WarningTxt [Located FastString] - | DeprecatedTxt [Located FastString] +-- For SourceText usage, see note [Pragma source text] +data WarningTxt = WarningTxt (Located SourceText) [Located FastString] + | DeprecatedTxt (Located SourceText) [Located FastString] deriving (Eq, Data, Typeable) instance Outputable WarningTxt where - ppr (WarningTxt ws) = doubleQuotes (vcat (map (ftext . unLoc) ws)) - ppr (DeprecatedTxt ds) = text "Deprecated:" <+> - doubleQuotes (vcat (map (ftext . unLoc) ds)) + ppr (WarningTxt _ ws) = doubleQuotes (vcat (map (ftext . unLoc) ws)) + ppr (DeprecatedTxt _ ds) = text "Deprecated:" <+> + doubleQuotes (vcat (map (ftext . unLoc) ds)) {- ************************************************************************ @@ -448,6 +451,13 @@ instance Outputable Origin where -- | The semantics allowed for overlapping instances for a particular -- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.lhs`) for a -- explanation of the `isSafeOverlap` field. +-- +-- - 'ApiAnnotation.AnnKeywordId' : +-- 'ApiAnnotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or +-- @'\{-\# OVERLAPPING'@ or +-- @'\{-\# OVERLAPS'@ or +-- @'\{-\# INCOHERENT'@, +-- 'ApiAnnotation.AnnClose' @`\#-\}`@, data OverlapFlag = OverlapFlag { overlapMode :: OverlapMode , isSafeOverlap :: Bool @@ -460,27 +470,29 @@ setOverlapModeMaybe f (Just m) = f { overlapMode = m } hasOverlappableFlag :: OverlapMode -> Bool hasOverlappableFlag mode = case mode of - Overlappable -> True - Overlaps -> True - Incoherent -> True - _ -> False + Overlappable _ -> True + Overlaps _ -> True + Incoherent _ -> True + _ -> False hasOverlappingFlag :: OverlapMode -> Bool hasOverlappingFlag mode = case mode of - Overlapping -> True - Overlaps -> True - Incoherent -> True - _ -> False + Overlapping _ -> True + Overlaps _ -> True + Incoherent _ -> True + _ -> False data OverlapMode -- See Note [Rules for instance lookup] in InstEnv - = NoOverlap + = NoOverlap SourceText + -- See Note [Pragma source text] -- ^ This instance must not overlap another `NoOverlap` instance. -- However, it may be overlapped by `Overlapping` instances, -- and it may overlap `Overlappable` instances. - | Overlappable + | Overlappable SourceText + -- See Note [Pragma source text] -- ^ Silently ignore this instance if you find a -- more specific one that matches the constraint -- you are trying to resolve @@ -494,7 +506,8 @@ data OverlapMode -- See Note [Rules for instance lookup] in InstEnv -- its ambiguous which to choose) - | Overlapping + | Overlapping SourceText + -- See Note [Pragma source text] -- ^ Silently ignore any more general instances that may be -- used to solve the constraint. -- @@ -507,10 +520,12 @@ data OverlapMode -- See Note [Rules for instance lookup] in InstEnv -- it is ambiguous which to choose) - | Overlaps + | Overlaps SourceText + -- See Note [Pragma source text] -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. - | Incoherent + | Incoherent SourceText + -- See Note [Pragma source text] -- ^ Behave like Overlappable and Overlapping, and in addition pick -- an an arbitrary one if there are multiple matching candidates, and -- don't worry about later instantiation @@ -529,11 +544,11 @@ instance Outputable OverlapFlag where ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag) instance Outputable OverlapMode where - ppr NoOverlap = empty - ppr Overlappable = ptext (sLit "[overlappable]") - ppr Overlapping = ptext (sLit "[overlapping]") - ppr Overlaps = ptext (sLit "[overlap ok]") - ppr Incoherent = ptext (sLit "[incoherent]") + ppr (NoOverlap _) = empty + ppr (Overlappable _) = ptext (sLit "[overlappable]") + ppr (Overlapping _) = ptext (sLit "[overlapping]") + ppr (Overlaps _) = ptext (sLit "[overlap ok]") + ppr (Incoherent _) = ptext (sLit "[incoherent]") pprSafeOverlap :: Bool -> SDoc pprSafeOverlap True = ptext $ sLit "[safe]" @@ -768,6 +783,72 @@ failed Failed = True {- ************************************************************************ * * +\subsection{Source Text} +* * +************************************************************************ +Keeping Source Text for source to source conversions + +Note [Pragma source text] +~~~~~~~~~~~~~~~~~~~~~~~~~ + +The lexer does a case-insensitive match for pragmas, as well as +accepting both UK and US spelling variants. + +So + + {-# SPECIALISE #-} + {-# SPECIALIZE #-} + {-# Specialize #-} + +will all generate ITspec_prag token for the start of the pragma. + +In order to be able to do source to source conversions, the original +source text for the token needs to be preserved, hence the +`SourceText` field. + +So the lexer will then generate + + ITspec_prag "{ -# SPECIALISE" + ITspec_prag "{ -# SPECIALIZE" + ITspec_prag "{ -# Specialize" + +for the cases above. + [without the space between '{' and '-', otherwise this comment won't parse] + + +Note [literal source text] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The lexer/parser converts literals from their original source text +versions to an appropriate internal representation. This is a problem +for tools doing source to source conversions, so the original source +text is stored in literals where this can occur. + +Motivating examples for HsLit + + HsChar '\n', '\x20` + HsCharPrim '\x41`# + HsString "\x20\x41" == " A" + HsStringPrim "\x20"# + HsInt 001 + HsIntPrim 002# + HsWordPrim 003## + HsInt64Prim 004## + HsWord64Prim 005## + HsInteger 006 + +For OverLitVal + + HsIntegral 003,0x001 + HsIsString "\x41nd" +-} + +type SourceText = String -- Note [literal source text],[Pragma source text] + + +{- +************************************************************************ +* * \subsection{Activation} * * ************************************************************************ @@ -800,7 +881,8 @@ data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] data InlinePragma -- Note [InlinePragma] = InlinePragma - { inl_inline :: InlineSpec + { inl_src :: SourceText -- Note [Pragma source text] + , inl_inline :: InlineSpec , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n -- explicit (non-type, non-dictionary) args @@ -890,7 +972,8 @@ isEmptyInlineSpec _ = False defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma :: InlinePragma -defaultInlinePragma = InlinePragma { inl_act = AlwaysActive +defaultInlinePragma = InlinePragma { inl_src = "{-# INLINE" + , inl_act = AlwaysActive , inl_rule = FunLike , inl_inline = EmptyInlineSpec , inl_sat = Nothing } diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index 200bf21fed..cd4fe71993 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs @@ -453,6 +453,7 @@ data HsBang = HsNoBang -- Equivalent to (HsSrcBang Nothing False) | HsSrcBang -- What the user wrote in the source code + (Maybe SourceText) -- Note [Pragma source text] in BasicTypes (Maybe Bool) -- Just True {-# UNPACK #-} -- Just False {-# NOUNPACK #-} -- Nothing no pragma @@ -574,11 +575,11 @@ instance Data.Data DataCon where dataTypeOf _ = mkNoRepType "DataCon" instance Outputable HsBang where - ppr HsNoBang = empty - ppr (HsSrcBang prag bang) = pp_unpk prag <+> ppWhen bang (char '!') - ppr (HsUnpack Nothing) = ptext (sLit "Unpk") - ppr (HsUnpack (Just co)) = ptext (sLit "Unpk") <> parens (ppr co) - ppr HsStrict = ptext (sLit "SrictNotUnpacked") + ppr HsNoBang = empty + ppr (HsSrcBang _ prag bang) = pp_unpk prag <+> ppWhen bang (char '!') + ppr (HsUnpack Nothing) = ptext (sLit "Unpk") + ppr (HsUnpack (Just co)) = ptext (sLit "Unpk") <> parens (ppr co) + ppr HsStrict = ptext (sLit "SrictNotUnpacked") pp_unpk :: Maybe Bool -> SDoc pp_unpk Nothing = empty @@ -593,16 +594,16 @@ instance Outputable StrictnessMark where eqHsBang :: HsBang -> HsBang -> Bool eqHsBang HsNoBang HsNoBang = True eqHsBang HsStrict HsStrict = True -eqHsBang (HsSrcBang u1 b1) (HsSrcBang u2 b2) = u1==u2 && b1==b2 +eqHsBang (HsSrcBang _ u1 b1) (HsSrcBang _ u2 b2) = u1==u2 && b1==b2 eqHsBang (HsUnpack Nothing) (HsUnpack Nothing) = True eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) = eqType (coercionType c1) (coercionType c2) eqHsBang _ _ = False isBanged :: HsBang -> Bool -isBanged HsNoBang = False -isBanged (HsSrcBang _ bang) = bang -isBanged (HsUnpack {}) = True -isBanged (HsStrict {}) = True +isBanged HsNoBang = False +isBanged (HsSrcBang _ _ bang) = bang +isBanged (HsUnpack {}) = True +isBanged (HsStrict {}) = True isMarkedStrict :: StrictnessMark -> Bool isMarkedStrict NotMarkedStrict = False diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs index 7f24faad3b..34fd0aa60b 100644 --- a/compiler/basicTypes/MkId.hs +++ b/compiler/basicTypes/MkId.hs @@ -595,11 +595,11 @@ dataConArgRep dataConArgRep _ _ arg_ty HsNoBang = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) -dataConArgRep _ _ arg_ty (HsSrcBang _ False) -- No '!' +dataConArgRep _ _ arg_ty (HsSrcBang _ _ False) -- No '!' = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) dataConArgRep dflags fam_envs arg_ty - (HsSrcBang unpk_prag True) -- {-# UNPACK #-} ! + (HsSrcBang _ unpk_prag True) -- {-# UNPACK #-} ! | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas -- Don't unpack if we aren't optimising; rather arbitrarily, -- we use -fomit-iface-pragmas as the indication @@ -727,11 +727,11 @@ isUnpackableType fam_envs ty -- NB: dataConSrcBangs gives the *user* request; -- We'd get a black hole if we used dataConImplBangs - attempt_unpack (HsUnpack {}) = True - attempt_unpack (HsSrcBang (Just unpk) bang) = bang && unpk - attempt_unpack (HsSrcBang Nothing bang) = bang -- Be conservative - attempt_unpack HsStrict = False - attempt_unpack HsNoBang = False + attempt_unpack (HsUnpack {}) = True + attempt_unpack (HsSrcBang _ (Just unpk) bang) = bang && unpk + attempt_unpack (HsSrcBang _ Nothing bang) = bang -- Be conservative + attempt_unpack HsStrict = False + attempt_unpack HsNoBang = False {- Note [Unpack one-wide fields] diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs index 71135d05d1..5db0a9d7b3 100644 --- a/compiler/basicTypes/RdrName.hs +++ b/compiler/basicTypes/RdrName.hs @@ -86,6 +86,20 @@ import Data.Data -- | Do not use the data constructors of RdrName directly: prefer the family -- of functions that creates them, such as 'mkRdrUnqual' +-- +-- - Note: A Located RdrName will only have API Annotations if it is a +-- compound one, +-- e.g. +-- +-- > `bar` +-- > ( ~ ) +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', +-- 'ApiAnnotation.AnnOpen' @'('@ or @'['@ or @'[:'@, +-- 'ApiAnnotation.AnnClose' @')'@ or @']'@ or @':]'@,, +-- 'ApiAnnotation.AnnBackquote' @'`'@, +-- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnTildehsh', +-- 'ApiAnnotation.AnnTilde', data RdrName = Unqual OccName -- ^ Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs index 03e415b816..4f6cc1a17d 100644 --- a/compiler/basicTypes/SrcLoc.hs +++ b/compiler/basicTypes/SrcLoc.hs @@ -1,6 +1,11 @@ -- (c) The University of Glasgow, 1992-2006 +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} -- Workaround for Trac #5252 crashes the bootstrap compiler without -O -- When the earliest compiler we want to boostrap with is @@ -77,6 +82,10 @@ import Util import Outputable import FastString +#if __GLASGOW_HASKELL__ < 709 +import Data.Foldable ( Foldable ) +import Data.Traversable ( Traversable ) +#endif import Data.Bits import Data.Data import Data.List @@ -515,6 +524,8 @@ pprUserRealSpan show_path (SrcSpanPoint src_path line col) -- | We attach SrcSpans to lots of things, so let's have a datatype for it. data GenLocated l e = L l e deriving (Eq, Ord, Typeable, Data) +deriving instance Foldable (GenLocated l) +deriving instance Traversable (GenLocated l) type Located e = GenLocated SrcSpan e type RealLocated e = GenLocated RealSrcSpan e diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index 7284db3bc8..3d53e698d8 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -452,11 +452,11 @@ get_lit :: Pat id -> Maybe HsLit -- It doesn't matter which one, because they will only be compared -- with other HsLits gotten in the same way get_lit (LitPat lit) = Just lit -get_lit (NPat (OverLit { ol_val = HsIntegral src i}) mb _) +get_lit (NPat (L _ (OverLit { ol_val = HsIntegral src i})) mb _) = Just (HsIntPrim src (mb_neg negate mb i)) -get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) +get_lit (NPat (L _ (OverLit { ol_val = HsFractional f })) mb _) = Just (HsFloatPrim (mb_neg negateFractionalLit mb f)) -get_lit (NPat (OverLit { ol_val = HsIsString src s }) _ _) +get_lit (NPat (L _ (OverLit { ol_val = HsIsString src s })) _ _) = Just (HsStringPrim src (fastStringToByteString s)) get_lit _ = Nothing @@ -727,7 +727,7 @@ tidy_pat (TuplePat ps boxity tys) where arity = length ps -tidy_pat (NPat lit mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq +tidy_pat (NPat (L _ lit) mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq tidy_pat (LitPat lit) = tidy_lit_pat lit tidy_pat (ConPatIn {}) = panic "Check.tidy_pat: ConPatIn" diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index d81599d30e..b44e9d8fa4 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -567,7 +567,7 @@ addTickHsExpr (HsTick t e) = addTickHsExpr (HsBinTick t0 t1 e) = liftM (HsBinTick t0 t1) (addTickLHsExprNever e) -addTickHsExpr (HsTickPragma _ (L pos e0)) = do +addTickHsExpr (HsTickPragma _ _ (L pos e0)) = do e2 <- allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 return $ unLoc e2 @@ -575,12 +575,14 @@ addTickHsExpr (PArrSeq ty arith_seq) = liftM2 PArrSeq (return ty) (addTickArithSeqInfo arith_seq) -addTickHsExpr (HsSCC nm e) = - liftM2 HsSCC +addTickHsExpr (HsSCC src nm e) = + liftM3 HsSCC + (return src) (return nm) (addTickLHsExpr e) -addTickHsExpr (HsCoreAnn nm e) = - liftM2 HsCoreAnn +addTickHsExpr (HsCoreAnn src nm e) = + liftM3 HsCoreAnn + (return src) (return nm) (addTickLHsExpr e) addTickHsExpr e@(HsBracket {}) = return e @@ -614,10 +616,10 @@ addTickMatchGroup is_lam mg@(MG { mg_alts = matches }) = do return $ mg { mg_alts = matches' } addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id)) -addTickMatch isOneOfMany isLambda (Match pats opSig gRHSs) = +addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) = bindLocals (collectPatsBinders pats) $ do gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs - return $ Match pats opSig gRHSs' + return $ Match mf pats opSig gRHSs' addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id)) addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do @@ -829,10 +831,10 @@ addTickCmdMatchGroup mg@(MG { mg_alts = matches }) = do return $ mg { mg_alts = matches' } addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id)) -addTickCmdMatch (Match pats opSig gRHSs) = +addTickCmdMatch (Match mf pats opSig gRHSs) = bindLocals (collectPatsBinders pats) $ do gRHSs' <- addTickCmdGRHSs gRHSs - return $ Match pats opSig gRHSs' + return $ Match mf pats opSig gRHSs' addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id)) addTickCmdGRHSs (GRHSs guarded local_binds) = do @@ -1204,7 +1206,7 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals") matchesOneOfMany :: [LMatch Id body] -> Bool matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 where - matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss + matchCount (L _ (Match _ _pats _ty (GRHSs grhss _binds))) = length grhss type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index 70fa88e657..e4181b9bdb 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -461,12 +461,12 @@ by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS). -} dsVect :: LVectDecl Id -> DsM CoreVect -dsVect (L loc (HsVect (L _ v) rhs)) +dsVect (L loc (HsVect _ (L _ v) rhs)) = putSrcSpanDs loc $ do { rhs' <- dsLExpr rhs ; return $ Vect v rhs' } -dsVect (L _loc (HsNoVect (L _ v))) +dsVect (L _loc (HsNoVect _ (L _ v))) = return $ NoVect v dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon)) = return $ VectType isScalar tycon' rhs_tycon @@ -474,11 +474,11 @@ dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon)) tycon' | Just ty <- coreView $ mkTyConTy tycon , (tycon', []) <- splitTyConApp ty = tycon' | otherwise = tycon -dsVect vd@(L _ (HsVectTypeIn _ _ _)) +dsVect vd@(L _ (HsVectTypeIn _ _ _ _)) = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd) dsVect (L _loc (HsVectClassOut cls)) = return $ VectClass (classTyCon cls) -dsVect vc@(L _ (HsVectClassIn _)) +dsVect vc@(L _ (HsVectClassIn _ _)) = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc) dsVect (L _loc (HsVectInstOut inst)) = return $ VectInst (instanceDFunId inst) diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 8f5b30e73d..220ed3cbad 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -399,7 +399,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do -- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd dsCmd ids local_vars stack_ty res_ty - (HsCmdLam (MG { mg_alts = [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] })) + (HsCmdLam (MG { mg_alts = [L _ (Match _ pats _ + (GRHSs [L _ (GRHS [] body)] _ ))] })) env_ids = do let pat_vars = mkVarSet (collectPatsBinders pats) @@ -1046,7 +1047,7 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys" -- List of leaf expressions, with set of variables bound in each leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)] -leavesMatch (L _ (Match pats _ (GRHSs grhss binds))) +leavesMatch (L _ (Match _ pats _ (GRHSs grhss binds))) = let defined_vars = mkVarSet (collectPatsBinders pats) `unionVarSet` @@ -1065,11 +1066,11 @@ replaceLeavesMatch -> LMatch Id (Located (body Id)) -- the matches of a case command -> ([Located (body' Id)], -- remaining leaf expressions LMatch Id (Located (body' Id))) -- updated match -replaceLeavesMatch _res_ty leaves (L loc (Match pat mt (GRHSs grhss binds))) +replaceLeavesMatch _res_ty leaves (L loc (Match mf pat mt (GRHSs grhss binds))) = let (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss in - (leaves', L loc (Match pat mt (GRHSs grhss' binds))) + (leaves', L loc (Match mf pat mt (GRHSs grhss' binds))) replaceLeavesGRHS :: [Located (body' Id)] -- replacement leaf expressions of that type diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 4bffdbc06a..3b176a5847 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -300,13 +300,18 @@ dsExpr (ExplicitTuple tup_args boxity) mkCoreConApps (tupleCon (boxityNormalTupleSort boxity) (length tup_args)) (map (Type . exprType) args ++ args) } -dsExpr (HsSCC cc expr@(L loc _)) = do - mod_name <- getModule - count <- goptM Opt_ProfCountEntries - uniq <- newUnique - Tick (ProfNote (mkUserCC cc mod_name loc uniq) count True) <$> dsLExpr expr - -dsExpr (HsCoreAnn _ expr) +dsExpr (HsSCC _ cc expr@(L loc _)) = do + dflags <- getDynFlags + if gopt Opt_SccProfilingOn dflags + then do + mod_name <- getModule + count <- goptM Opt_ProfCountEntries + uniq <- newUnique + Tick (ProfNote (mkUserCC cc mod_name loc uniq) count True) + <$> dsLExpr expr + else dsLExpr expr + +dsExpr (HsCoreAnn _ _ expr) = dsLExpr expr dsExpr (HsCase discrim matches) @@ -669,13 +674,18 @@ dsExpr (HsBinTick ixT ixF e) = do mkBinaryTickBox ixT ixF e2 } +dsExpr (HsTickPragma _ _ expr) = do + dflags <- getDynFlags + if gopt Opt_Hpc dflags + then panic "dsExpr:HsTickPragma" + else dsLExpr expr + -- HsSyn constructs that just shouldn't be here: dsExpr (ExprWithTySig {}) = panic "dsExpr:ExprWithTySig" dsExpr (HsBracket {}) = panic "dsExpr:HsBracket" dsExpr (HsQuasiQuoteE {}) = panic "dsExpr:HsQuasiQuoteE" dsExpr (HsArrApp {}) = panic "dsExpr:HsArrApp" dsExpr (HsArrForm {}) = panic "dsExpr:HsArrForm" -dsExpr (HsTickPragma {}) = panic "dsExpr:HsTickPragma" dsExpr (EWildPat {}) = panic "dsExpr:EWildPat" dsExpr (EAsPat {}) = panic "dsExpr:EAsPat" dsExpr (EViewPat {}) = panic "dsExpr:EViewPat" @@ -684,6 +694,7 @@ dsExpr (HsType {}) = panic "dsExpr:HsType" dsExpr (HsDo {}) = panic "dsExpr:HsDo" + findField :: [LHsRecField Id arg] -> Name -> [arg] findField rbinds lbl = [rhs | L _ (HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs }) <- rbinds diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs index 0ae14f8d1d..715e1ce087 100644 --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -713,7 +713,7 @@ toCType = f False -- Note that we aren't looking through type synonyms or -- anything, as it may be the synonym that is annotated. | TyConApp tycon _ <- t - , Just (CType mHeader cType) <- tyConCType_maybe tycon + , Just (CType _ mHeader cType) <- tyConCType_maybe tycon = (mHeader, ftext cType) -- If we don't know a C type for this type, then try looking -- through one layer of type synonym etc. diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index b7445a8e2b..63b65398eb 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -147,9 +147,11 @@ repTopDs group@(HsGroup { hs_valds = valds ; fix_ds <- mapM repFixD fixds ; _ <- mapM no_default_decl defds ; for_ds <- mapM repForD fords - ; _ <- mapM no_warn warnds + ; _ <- mapM no_warn (concatMap (wd_warnings . unLoc) + warnds) ; ann_ds <- mapM repAnnD annds - ; rule_ds <- mapM repRuleD ruleds + ; rule_ds <- mapM repRuleD (concatMap (rds_rules . unLoc) + ruleds) ; _ <- mapM no_vect vects ; _ <- mapM no_doc docs @@ -361,7 +363,7 @@ mk_extra_tvs tc tvs defn = do { uniq <- newUnique ; let { occ = mkTyVarOccFS (fsLit "t") ; nm = mkInternalName uniq occ loc - ; hs_tv = L loc (KindedTyVar nm kind) } + ; hs_tv = L loc (KindedTyVar (noLoc nm) kind) } ; hs_tvs <- go rest ; return (hs_tv : hs_tvs) } @@ -374,13 +376,14 @@ mk_extra_tvs tc tvs defn ------------------------- -- represent fundeps -- -repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep]) +repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep]) repLFunDeps fds = repList funDepTyConName repLFunDep fds -repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep) -repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName lookupBinder xs - ys' <- repList nameTyConName lookupBinder ys - repFunDep xs' ys' +repLFunDep :: Located (FunDep (Located Name)) -> DsM (Core TH.FunDep) +repLFunDep (L _ (xs, ys)) + = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs + ys' <- repList nameTyConName (lookupBinder . unLoc) ys + repFunDep xs' ys' -- represent family declaration flavours -- @@ -550,17 +553,17 @@ repRuleBndr (L _ (RuleBndrSig n (HsWB { hswb_cts = ty }))) ; rep2 typedRuleVarName [n', ty'] } repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ) -repAnnD (L loc (HsAnnotation ann_prov (L _ exp))) +repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp))) = do { target <- repAnnProv ann_prov ; exp' <- repE exp ; dec <- repPragAnn target exp' ; return (loc, dec) } repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget) -repAnnProv (ValueAnnProvenance n) +repAnnProv (ValueAnnProvenance (L _ n)) = do { MkC n' <- globalVar n -- ANNs are allowed only at top-level ; rep2 valueAnnotationName [ n' ] } -repAnnProv (TypeAnnProvenance n) +repAnnProv (TypeAnnProvenance (L _ n)) = do { MkC n' <- globalVar n ; rep2 typeAnnotationName [ n' ] } repAnnProv ModuleAnnProvenance @@ -619,7 +622,7 @@ mkGadtCtxt :: [Name] -- Tyvars of the data type -- This function is fiddly, but not really hard mkGadtCtxt _ ResTyH98 = return ([], []) -mkGadtCtxt data_tvs (ResTyGADT res_ty) +mkGadtCtxt data_tvs (ResTyGADT _ res_ty) | Just (_, tys) <- hsTyGetAppHead_maybe res_ty , data_tvs `equalLength` tys = return (go [] [] (data_tvs `zip` tys)) @@ -651,9 +654,9 @@ repBangTy ty= do rep2 strictTypeName [s, t] where (str, ty') = case ty of - L _ (HsBangTy (HsSrcBang (Just True) True) ty) -> (unpackedName, ty) - L _ (HsBangTy (HsSrcBang _ True) ty) -> (isStrictName, ty) - _ -> (notStrictName, ty) + L _ (HsBangTy (HsSrcBang _ (Just True) True) ty) -> (unpackedName, ty) + L _ (HsBangTy (HsSrcBang _ _ True) ty) -> (isStrictName, ty) + _ -> (notStrictName, ty) ------------------------------------------------------- -- Deriving clause @@ -695,7 +698,7 @@ rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc rep_sig (L loc (SpecSig nm tys ispec)) = concatMapM (\t -> rep_specialise nm t ispec loc) tys -rep_sig (L loc (SpecInstSig ty)) = rep_specialiseInst ty loc +rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty loc rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty rep_ty_sig :: Name -> SrcSpan -> LHsType Name -> Located Name @@ -913,11 +916,11 @@ repTy (HsTyLit lit) = do repTy ty = notHandled "Exotic form of type" (ppr ty) repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ) -repTyLit (HsNumTy i) = do iExpr <- mkIntegerExpr i - rep2 numTyLitName [iExpr] -repTyLit (HsStrTy s) = do { s' <- mkStringExprFS s - ; rep2 strTyLitName [s'] - } +repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i + rep2 numTyLitName [iExpr] +repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s + ; rep2 strTyLitName [s'] + } -- represent a kind -- @@ -1104,7 +1107,7 @@ repE e = notHandled "Expression form" (ppr e) -- Building representations of auxillary structures like Match, Clause, Stmt, repMatchTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ) -repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) = +repMatchTup (L _ (Match _ [p] _ (GRHSs guards wheres))) = do { ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { ; p1 <- repLP p @@ -1116,7 +1119,7 @@ repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) = repMatchTup _ = panic "repMatchTup: case alt with more than one arg" repClauseTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ) -repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) = +repClauseTup (L _ (Match _ ps _ (GRHSs guards wheres))) = do { ss1 <- mkGenSyms (collectPatsBinders ps) ; addBinds ss1 $ do { ps1 <- repLPs ps @@ -1268,8 +1271,10 @@ rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ) -- Note GHC treats declarations of a variable (not a pattern) -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match -- with an empty list of patterns -rep_bind (L loc (FunBind { fun_id = fn, - fun_matches = MG { mg_alts = [L _ (Match [] _ (GRHSs guards wheres))] } })) +rep_bind (L loc (FunBind + { fun_id = fn, + fun_matches = MG { mg_alts = [L _ (Match _ [] _ + (GRHSs guards wheres))] } })) = do { (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; fn' <- lookupLBinder fn @@ -1328,7 +1333,7 @@ rep_bind (L _ dec@(PatSynBind {})) = notHandled "pattern synonyms" (ppr dec) -- (\ p1 .. pn -> exp) by causing an error. repLambda :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ExpQ) -repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds))) +repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds))) = do { let bndrs = collectPatsBinders ps ; ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( @@ -1380,7 +1385,7 @@ repP (ConPatIn dc details) ; MkC p <- repLP (hsRecFieldArg fld) ; rep2 fieldPatName [v,p] } -repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a } +repP (NPat (L _ l) Nothing _) = do { a <- repOverloadedLiteral l; repPlit a } repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p) @@ -1848,7 +1853,7 @@ repConstr con (PrefixCon ps) = do arg_tys <- repList strictTypeQTyConName repBangTy ps rep2 normalCName [unC con, unC arg_tys] -repConstr con (RecCon ips) +repConstr con (RecCon (L _ ips)) = do { args <- concatMapM rep_ip ips ; arg_vtys <- coreList varStrictTypeQTyConName args ; rep2 recCName [unC con, unC arg_vtys] } diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index 5089f86298..c8e30f18a7 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -575,7 +575,7 @@ tidy1 _ (LitPat lit) = return (idDsWrapper, tidyLitPat lit) -- NPats: we *might* be able to replace these w/ a simpler form -tidy1 _ (NPat lit mb_neg eq) +tidy1 _ (NPat (L _ lit) mb_neg eq) = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq) -- Everything else goes through unchanged... @@ -803,7 +803,7 @@ matchWrapper ctxt (MG { mg_alts = matches matchEquations ctxt new_vars eqns_info rhs_ty ; return (new_vars, result_expr) } where - mk_eqn_info (L _ (Match pats _ grhss)) + mk_eqn_info (L _ (Match _ pats _ grhss)) = do { let upats = map unLoc pats ; match_result <- dsGRHSs ctxt upats grhss rhs_ty ; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) } @@ -1062,8 +1062,9 @@ patGroup _ (ConPatOut { pat_con = con }) = case unLoc con of RealDataCon dcon -> PgCon dcon PatSynCon psyn -> PgSyn psyn patGroup dflags (LitPat lit) = PgLit (hsLitKey dflags lit) -patGroup _ (NPat olit mb_neg _) = PgN (hsOverLitKey olit (isJust mb_neg)) -patGroup _ (NPlusKPat _ olit _ _) = PgNpK (hsOverLitKey olit False) +patGroup _ (NPat (L _ olit) mb_neg _) + = PgN (hsOverLitKey olit (isJust mb_neg)) +patGroup _ (NPlusKPat _ (L _ olit) _ _) = PgNpK (hsOverLitKey olit False) patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) patGroup _ (ListPat _ _ (Just _)) = PgOverloadedList diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs index 914b21016c..25021f56c5 100644 --- a/compiler/deSugar/MatchLit.hs +++ b/compiler/deSugar/MatchLit.hs @@ -324,7 +324,7 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _ _ -> Nothing tidyNPat _ over_lit mb_neg eq - = NPat over_lit mb_neg eq + = NPat (noLoc over_lit) mb_neg eq {- ************************************************************************ @@ -417,7 +417,7 @@ litValKey (HsIsString _ s) neg = ASSERT( not neg) MachStr matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal - = do { let NPat lit mb_neg eq_chk = firstPat eqn1 + = do { let NPat (L _ lit) mb_neg eq_chk = firstPat eqn1 ; lit_expr <- dsOverLit lit ; neg_lit <- case mb_neg of Nothing -> return lit_expr @@ -450,7 +450,7 @@ We generate: matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- All NPlusKPats, for the *same* literal k matchNPlusKPats (var:vars) ty (eqn1:eqns) - = do { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1 + = do { let NPlusKPat (L _ n1) (L _ lit) ge minus = firstPat eqn1 ; ge_expr <- dsExpr ge ; minus_expr <- dsExpr minus ; lit_expr <- dsOverLit lit diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 97e64ecfd0..200ec8fdd6 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -493,7 +493,6 @@ compiler_stage2_dll0_MODULES = \ CoreUnfold \ CoreUtils \ CostCentre \ - Ctype \ DataCon \ Demand \ Digraph \ @@ -532,7 +531,6 @@ compiler_stage2_dll0_MODULES = \ InstEnv \ Kind \ Lexeme \ - Lexer \ ListSetOps \ Literal \ Maybes \ diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 92af65170f..28742d46c0 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -41,6 +41,8 @@ import Control.Monad( unless, liftM, ap ) import Control.Applicative (Applicative(..)) #endif +import Data.Char ( chr ) +import Data.Word ( Word8 ) import Data.Maybe( catMaybes ) import Language.Haskell.TH as TH hiding (sigP) import Language.Haskell.TH.Syntax as TH @@ -418,7 +420,7 @@ cvtConstr (RecC c varstrtys) ; cxt' <- returnL [] ; args' <- mapM cvt_id_arg varstrtys ; returnL $ mkSimpleConDecl c' noExistentials cxt' - (RecCon args') } + (RecCon (noLoc args')) } cvtConstr (InfixC st1 c st2) = do { c' <- cNameL c @@ -436,8 +438,12 @@ cvtConstr (ForallC tvs ctxt con) cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName) cvt_arg (NotStrict, ty) = cvtType ty -cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsSrcBang Nothing True) ty' } -cvt_arg (Unpacked, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsSrcBang (Just True) True) ty' } +cvt_arg (IsStrict, ty) + = do { ty' <- cvtType ty + ; returnL $ HsBangTy (HsSrcBang Nothing Nothing True) ty' } +cvt_arg (Unpacked, ty) + = do { ty' <- cvtType ty + ; returnL $ HsBangTy (HsSrcBang Nothing (Just True) True) ty' } cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (LConDeclField RdrName) cvt_id_arg (i, str, ty) @@ -455,8 +461,10 @@ cvtDerivs cs = do { cs' <- mapM cvt_one cs cvt_one c = do { c' <- tconName c ; returnL $ HsTyVar c' } -cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName)) -cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') } +cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName))) +cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs + ; ys' <- mapM tName ys + ; returnL (map noLoc xs', map noLoc ys') } noExistentials :: [LHsTyVarBndr RdrName] noExistentials = [] @@ -469,7 +477,7 @@ cvtForD :: Foreign -> CvtM (ForeignDecl RdrName) cvtForD (ImportF callconv safety from nm ty) | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety') (mkFastString (TH.nameBase nm)) - from (noLoc (mkFastString from)) + from (noLoc from) = do { nm' <- vNameL nm ; ty' <- cvtType ty ; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec) @@ -487,7 +495,7 @@ cvtForD (ExportF callconv as nm ty) ; ty' <- cvtType ty ; let e = CExport (noLoc (CExportStatic (mkFastString as) (cvt_conv callconv))) - (noLoc (mkFastString as)) + (noLoc as) ; return $ ForeignExport nm' ty' noForeignExportCoercionYet e } cvt_conv :: TH.Callconv -> CCallConv @@ -505,7 +513,8 @@ cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl RdrName)) cvtPragmaD (InlineP nm inline rm phases) = do { nm' <- vNameL nm ; let dflt = dfltActivation inline - ; let ip = InlinePragma { inl_inline = cvtInline inline + ; let ip = InlinePragma { inl_src = "{-# INLINE" + , inl_inline = cvtInline inline , inl_rule = cvtRuleMatch rm , inl_act = cvtPhases phases dflt , inl_sat = Nothing } @@ -517,7 +526,8 @@ cvtPragmaD (SpecialiseP nm ty inline phases) ; let (inline', dflt) = case inline of Just inline1 -> (cvtInline inline1, dfltActivation inline1) Nothing -> (EmptyInlineSpec, AlwaysActive) - ; let ip = InlinePragma { inl_inline = inline' + ; let ip = InlinePragma { inl_src = "{-# INLINE" + , inl_inline = inline' , inl_rule = Hs.FunLike , inl_act = cvtPhases phases dflt , inl_sat = Nothing } @@ -525,7 +535,7 @@ cvtPragmaD (SpecialiseP nm ty inline phases) cvtPragmaD (SpecialiseInstP ty) = do { ty' <- cvtType ty - ; returnJustL $ Hs.SigD $ SpecInstSig ty' } + ; returnJustL $ Hs.SigD $ SpecInstSig "{-# SPECIALISE" ty' } cvtPragmaD (RuleP nm bndrs lhs rhs phases) = do { let nm' = mkFastString nm @@ -533,9 +543,10 @@ cvtPragmaD (RuleP nm bndrs lhs rhs phases) ; bndrs' <- mapM cvtRuleBndr bndrs ; lhs' <- cvtl lhs ; rhs' <- cvtl rhs - ; returnJustL $ Hs.RuleD $ HsRule (noLoc nm') act bndrs' - lhs' placeHolderNames - rhs' placeHolderNames + ; returnJustL $ Hs.RuleD + $ HsRules "{-# RULES" [noLoc $ HsRule (noLoc nm') act bndrs' + lhs' placeHolderNames + rhs' placeHolderNames] } cvtPragmaD (AnnP target exp) @@ -544,11 +555,11 @@ cvtPragmaD (AnnP target exp) ModuleAnnotation -> return ModuleAnnProvenance TypeAnnotation n -> do n' <- tconName n - return (TypeAnnProvenance n') + return (TypeAnnProvenance (noLoc n')) ValueAnnotation n -> do n' <- vcName n - return (ValueAnnProvenance n') - ; returnJustL $ Hs.AnnD $ HsAnnotation target' exp' + return (ValueAnnProvenance (noLoc n')) + ; returnJustL $ Hs.AnnD $ HsAnnotation "{-# ANN" target' exp' } cvtPragmaD (LineP line file) @@ -603,7 +614,7 @@ cvtClause (Clause ps body wheres) = do { ps' <- cvtPats ps ; g' <- cvtGuard body ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) wheres - ; returnL $ Hs.Match ps' Nothing (GRHSs g' ds') } + ; returnL $ Hs.Match Nothing ps' Nothing (GRHSs g' ds') } ------------------------------------------------------------------- @@ -816,7 +827,7 @@ cvtMatch (TH.Match p body decs) = do { p' <- cvtPat p ; g' <- cvtGuard body ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs - ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') } + ; returnL $ Hs.Match Nothing [p'] Nothing (GRHSs g' decs') } cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)] cvtGuard (GuardedB pairs) = mapM cvtpair pairs @@ -831,13 +842,13 @@ cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs cvtOverLit :: Lit -> CvtM (HsOverLit RdrName) cvtOverLit (IntegerL i) - = do { force i; return $ mkHsIntegral "" i placeHolderType} + = do { force i; return $ mkHsIntegral (show i) i placeHolderType} cvtOverLit (RationalL r) = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType} cvtOverLit (StringL s) = do { let { s' = mkFastString s } ; force s' - ; return $ mkHsIsString "" s' placeHolderType + ; return $ mkHsIsString s s' placeHolderType } cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal" -- An Integer is like an (overloaded) '3' in a Haskell source program @@ -865,22 +876,25 @@ allCharLs xs go _ _ = Nothing cvtLit :: Lit -> CvtM HsLit -cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim "" i } -cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim "" w } +cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim (show i) i } +cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim (show w) w } cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim (cvtFractionalLit f) } cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) } -cvtLit (CharL c) = do { force c; return $ HsChar "" c } +cvtLit (CharL c) = do { force c; return $ HsChar (show c) c } cvtLit (StringL s) = do { let { s' = mkFastString s } ; force s' ; return $ HsString s s' } cvtLit (StringPrimL s) = do { let { s' = BS.pack s } ; force s' - ; return $ HsStringPrim "" s' } + ; return $ HsStringPrim (w8ToString s) s' } cvtLit _ = panic "Convert.cvtLit: Unexpected literal" -- cvtLit should not be called on IntegerL, RationalL -- That precondition is established right here in -- Convert.lhs, hence panic +w8ToString :: [Word8] -> String +w8ToString ws = map (\w -> chr (fromIntegral w)) ws + cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName] cvtPats pats = mapM cvtPat pats @@ -890,7 +904,7 @@ cvtPat pat = wrapL (cvtp pat) cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName) cvtp (TH.LitP l) | overloadedLit l = do { l' <- cvtOverLit l - ; return (mkNPat l' Nothing) } + ; return (mkNPat (noLoc l') Nothing) } -- Not right for negative patterns; -- need to think about that! | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' } @@ -953,7 +967,7 @@ cvt_tv (TH.PlainTV nm) cvt_tv (TH.KindedTV nm ki) = do { nm' <- tName nm ; ki' <- cvtKind ki - ; returnL $ KindedTyVar nm' ki' } + ; returnL $ KindedTyVar (noLoc nm') ki' } cvtRole :: TH.Role -> Maybe Coercion.Role cvtRole TH.NominalR = Just Coercion.Nominal @@ -1064,8 +1078,8 @@ split_ty_app ty = go ty [] go f as = return (f,as) cvtTyLit :: TH.TyLit -> HsTyLit -cvtTyLit (NumTyLit i) = HsNumTy i -cvtTyLit (StrTyLit s) = HsStrTy (fsLit s) +cvtTyLit (NumTyLit i) = HsNumTy (show i) i +cvtTyLit (StrTyLit s) = HsStrTy s (fsLit s) cvtKind :: TH.Kind -> CvtM (LHsKind RdrName) cvtKind = cvtTypeKind "kind" diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index 5528c3ff5a..b848af1ba6 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -138,7 +138,7 @@ data HsBindLR idL idR -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', FunBind { - fun_id :: Located idL, + fun_id :: Located idL, -- Note [fun_id in Match] in HsExpr fun_infix :: Bool, -- ^ True => infix declaration @@ -212,8 +212,9 @@ data HsBindLR idL idR | PatSynBind (PatSynBind idL idR) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', - -- 'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnWhere' - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' + -- 'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual', + -- 'ApiAnnotation.AnnWhere' + -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@ deriving (Typeable) deriving instance (DataId idL, DataId idR) @@ -239,6 +240,10 @@ data ABExport id , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas } deriving (Data, Typeable) +-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', +-- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow' +-- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen' @'{'@, +-- 'ApiAnnotation.AnnClose' @'}'@, data PatSynBind idL idR = PSB { psb_id :: Located idL, -- ^ Name of the pattern synonym psb_fvs :: PostRn idR NameSet, -- ^ See Note [Bind free vars] @@ -556,13 +561,14 @@ type LIPBind id = Located (IPBind id) -- | Implicit parameter bindings. -- +-- These bindings start off as (Left "x") in the parser and stay +-- that way until after type-checking when they are replaced with +-- (Right d), where "d" is the name of the dictionary holding the +-- evidence for the implicit parameter. +-- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual' -{- These bindings start off as (Left "x") in the parser and stay -that way until after type-checking when they are replaced with -(Right d), where "d" is the name of the dictionary holding the -evidence for the implicit parameter. -} data IPBind id - = IPBind (Either HsIPName id) (LHsExpr id) + = IPBind (Either (Located HsIPName) id) (LHsExpr id) deriving (Typeable) deriving instance (DataId name) => Data (IPBind name) @@ -573,8 +579,8 @@ instance (OutputableBndr id) => Outputable (HsIPBinds id) where instance (OutputableBndr id) => Outputable (IPBind id) where ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) where name = case lr of - Left ip -> pprBndr LetBind ip - Right id -> pprBndr LetBind id + Left (L _ ip) -> pprBndr LetBind ip + Right id -> pprBndr LetBind id {- ************************************************************************ @@ -650,7 +656,8 @@ data Sig name -- -- > {#- INLINE f #-} -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpen' @'{-\# INLINE'@ and @'['@, -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnTilde', -- 'ApiAnnotation.AnnClose' @@ -662,9 +669,11 @@ data Sig name -- > {-# SPECIALISE f :: Int -> Int #-} -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde', - -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnClose', - -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose', + -- 'ApiAnnotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@, + -- 'ApiAnnotation.AnnTilde', + -- 'ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnClose' @']'@ and @'\#-}'@, + -- 'ApiAnnotation.AnnDcolon' | SpecSig (Located name) -- Specialise a function or datatype ... [LHsType name] -- ... to these types InlinePragma -- The pragma on SPECIALISE_INLINE form. @@ -680,7 +689,8 @@ data Sig name -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose' - | SpecInstSig (LHsType name) + | SpecInstSig SourceText (LHsType name) + -- Note [Pragma source text] in BasicTypes -- | A minimal complete definition pragma -- @@ -689,7 +699,8 @@ data Sig name -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnVbar','ApiAnnotation.AnnComma', -- 'ApiAnnotation.AnnClose' - | MinimalSig (BooleanFormula (Located name)) + | MinimalSig SourceText (BooleanFormula (Located name)) + -- Note [Pragma source text] in BasicTypes deriving (Typeable) deriving instance (DataId name) => Data (Sig name) @@ -796,8 +807,9 @@ ppr_sig (FixSig fix_sig) = ppr fix_sig ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec (unLoc var) (interpp'SP ty) inl) ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var)) -ppr_sig (SpecInstSig ty) = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty) -ppr_sig (MinimalSig bf) = pragBrackets (pprMinimalSig bf) +ppr_sig (SpecInstSig _ ty) + = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty) +ppr_sig (MinimalSig _ bf) = pragBrackets (pprMinimalSig bf) ppr_sig (PatSynSig name (flag, qtvs) (L _ prov) (L _ req) ty) = pprPatSynSig (unLoc name) False -- TODO: is_bindir (pprHsForAll flag qtvs (noLoc [])) diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 4b54a8d702..6fcfa6724d 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -38,13 +38,15 @@ module HsDecls ( TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts, DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, TyFamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn, + HsTyPats, LClsInstDecl, ClsInstDecl(..), -- ** Standalone deriving declarations DerivDecl(..), LDerivDecl, -- ** @RULE@ declarations - RuleDecl(..), LRuleDecl, RuleBndr(..),LRuleBndr, + LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, RuleBndr(..),LRuleBndr, collectRuleBndrSigTys, + flattenRuleDecls, -- ** @VECTORISE@ declarations VectDecl(..), LVectDecl, lvectDeclName, lvectInstDecl, @@ -64,6 +66,7 @@ module HsDecls ( DocDecl(..), LDocDecl, docDeclDoc, -- ** Deprecations WarnDecl(..), LWarnDecl, + WarnDecls(..), LWarnDecls, -- ** Annotations AnnDecl(..), LAnnDecl, AnnProvenance(..), annProvenanceName_maybe, @@ -130,9 +133,9 @@ data HsDecl id | SigD (Sig id) | DefD (DefaultDecl id) | ForD (ForeignDecl id) - | WarningD (WarnDecl id) + | WarningD (WarnDecls id) | AnnD (AnnDecl id) - | RuleD (RuleDecl id) + | RuleD (RuleDecls id) | VectD (VectDecl id) | SpliceD (SpliceDecl id) | DocD (DocDecl) @@ -179,9 +182,9 @@ data HsGroup id hs_defds :: [LDefaultDecl id], hs_fords :: [LForeignDecl id], - hs_warnds :: [LWarnDecl id], + hs_warnds :: [LWarnDecls id], hs_annds :: [LAnnDecl id], - hs_ruleds :: [LRuleDecl id], + hs_ruleds :: [LRuleDecls id], hs_vects :: [LVectDecl id], hs_docs :: [LDocDecl] @@ -497,10 +500,11 @@ data TyClDecl name | ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context... tcdLName :: Located name, -- ^ Name of the class tcdTyVars :: LHsTyVarBndrs name, -- ^ Class type variables - tcdFDs :: [Located (FunDep name)], -- ^ Functional deps + tcdFDs :: [Located (FunDep (Located name))], + -- ^ Functional deps tcdSigs :: [LSig name], -- ^ Methods' signatures tcdMeths :: LHsBinds name, -- ^ Default methods - tcdATs :: [LFamilyDecl name], -- ^ Associated types; ie + tcdATs :: [LFamilyDecl name], -- ^ Associated types; tcdATDefs :: [LTyFamDefltEqn name], -- ^ Associated type defaults tcdDocs :: [LDocDecl], -- ^ Haddock docs tcdFVs :: PostRn name NameSet @@ -889,23 +893,25 @@ data ConDecl name } deriving (Typeable) deriving instance (DataId name) => Data (ConDecl name) -type HsConDeclDetails name = HsConDetails (LBangType name) [LConDeclField name] +type HsConDeclDetails name + = HsConDetails (LBangType name) (Located [LConDeclField name]) hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name] hsConDeclArgTys (PrefixCon tys) = tys hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] -hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) flds +hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds) data ResType ty - = ResTyH98 -- Constructor was declared using Haskell 98 syntax - | ResTyGADT ty -- Constructor was declared using GADT-style syntax, - -- and here is its result type + = ResTyH98 -- Constructor was declared using Haskell 98 syntax + | ResTyGADT SrcSpan ty -- Constructor was declared using GADT-style syntax, + -- and here is its result type, and the SrcSpan + -- of the original sigtype, for API Annotations deriving (Data, Typeable) instance Outputable ty => Outputable (ResType ty) where -- Debugging only - ppr ResTyH98 = ptext (sLit "ResTyH98") - ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> ppr ty + ppr ResTyH98 = ptext (sLit "ResTyH98") + ppr (ResTyGADT _ ty) = ptext (sLit "ResTyGADT") <+> ppr ty pp_data_defn :: OutputableBndr name => (HsContext name -> SDoc) -- Printing the header @@ -937,7 +943,7 @@ instance Outputable NewOrData where ppr DataType = ptext (sLit "data") pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc -pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax +pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ _ } : _) -- In GADT syntax = hang (ptext (sLit "where")) 2 (vcat (map ppr cs)) pp_condecls cs -- In H98 syntax = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs)) @@ -955,20 +961,21 @@ pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs ppr_details (PrefixCon tys) = hsep (pprPrefixOcc cons : map (pprParendHsType . unLoc) tys) ppr_details (RecCon fields) = ppr_con_names cons - <+> pprConDeclFields fields + <+> pprConDeclFields (unLoc fields) pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs , con_cxt = cxt, con_details = PrefixCon arg_tys - , con_res = ResTyGADT res_ty }) + , con_res = ResTyGADT _ res_ty }) = ppr_con_names cons <+> dcolon <+> sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)] where mk_fun_ty a b = noLoc (HsFunTy a b) pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs - , con_cxt = cxt, con_details = RecCon fields, con_res = ResTyGADT res_ty }) + , con_cxt = cxt, con_details = RecCon fields + , con_res = ResTyGADT _ res_ty }) = sep [ppr_con_names cons <+> dcolon <+> pprHsForAll expl tvs cxt, - pprConDeclFields fields <+> arrow <+> ppr res_ty] + pprConDeclFields (unLoc fields) <+> arrow <+> ppr res_ty] pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {} }) = pprConDecl (decl { con_details = PrefixCon [ty1,ty2] }) @@ -1190,11 +1197,11 @@ ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc ppOverlapPragma mb = case mb of Nothing -> empty - Just (L _ NoOverlap) -> ptext (sLit "{-# NO_OVERLAP #-}") - Just (L _ Overlappable) -> ptext (sLit "{-# OVERLAPPABLE #-}") - Just (L _ Overlapping) -> ptext (sLit "{-# OVERLAPPING #-}") - Just (L _ Overlaps) -> ptext (sLit "{-# OVERLAPS #-}") - Just (L _ Incoherent) -> ptext (sLit "{-# INCOHERENT #-}") + Just (L _ (NoOverlap _)) -> ptext (sLit "{-# NO_OVERLAP #-}") + Just (L _ (Overlappable _)) -> ptext (sLit "{-# OVERLAPPABLE #-}") + Just (L _ (Overlapping _)) -> ptext (sLit "{-# OVERLAPPING #-}") + Just (L _ (Overlaps _)) -> ptext (sLit "{-# OVERLAPS #-}") + Just (L _ (Incoherent _)) -> ptext (sLit "{-# INCOHERENT #-}") @@ -1333,9 +1340,9 @@ data ForeignImport = -- import of a C entity -- CImport (Located CCallConv) -- ccall or stdcall (Located Safety) -- interruptible, safe or unsafe - (Maybe Header) -- name of C header - CImportSpec -- details of the C entity - (Located FastString) -- original source text for + (Maybe Header) -- name of C header + CImportSpec -- details of the C entity + (Located SourceText) -- original source text for -- the C entity deriving (Data, Typeable) @@ -1352,7 +1359,7 @@ data CImportSpec = CLabel CLabelString -- import address of a C label -- data ForeignExport = CExport (Located CExportSpec) -- contains the calling -- convention - (Located FastString) -- original source text for + (Located SourceText) -- original source text for -- the C entity deriving (Data, Typeable) @@ -1399,6 +1406,14 @@ instance Outputable ForeignExport where ************************************************************************ -} +type LRuleDecls name = Located (RuleDecls name) + + -- Note [Pragma source text] in BasicTypes +data RuleDecls name = HsRules { rds_src :: SourceText + , rds_rules :: [LRuleDecl name] } + deriving (Typeable) +deriving instance (DataId name) => Data (RuleDecls name) + type LRuleDecl name = Located (RuleDecl name) data RuleDecl name @@ -1412,13 +1427,18 @@ data RuleDecl name (Located (HsExpr name)) -- RHS (PostRn name NameSet) -- Free-vars from the RHS -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual', - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnVal', - -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnTilde', + -- - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde', + -- 'ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnClose', -- 'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot', + -- 'ApiAnnotation.AnnEqual', deriving (Typeable) deriving instance (DataId name) => Data (RuleDecl name) +flattenRuleDecls :: [LRuleDecls name] -> [LRuleDecl name] +flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls + type LRuleBndr name = Located (RuleBndr name) data RuleBndr name = RuleBndr (Located name) @@ -1432,6 +1452,9 @@ deriving instance (DataId name) => Data (RuleBndr name) collectRuleBndrSigTys :: [RuleBndr name] -> [HsWithBndrs name (LHsType name)] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] +instance OutputableBndr name => Outputable (RuleDecls name) where + ppr (HsRules _ rules) = ppr rules + instance OutputableBndr name => Outputable (RuleDecl name) where ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs) = sep [text "{-# RULES" <+> doubleQuotes (ftext $ unLoc name) @@ -1467,15 +1490,18 @@ type LVectDecl name = Located (VectDecl name) data VectDecl name = HsVect + SourceText -- Note [Pragma source text] in BasicTypes (Located name) (LHsExpr name) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnClose' | HsNoVect + SourceText -- Note [Pragma source text] in BasicTypes (Located name) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnClose' | HsVectTypeIn -- pre type-checking + SourceText -- Note [Pragma source text] in BasicTypes Bool -- 'TRUE' => SCALAR declaration (Located name) (Maybe (Located name)) -- 'Nothing' => no right-hand side @@ -1487,6 +1513,7 @@ data VectDecl name TyCon (Maybe TyCon) -- 'Nothing' => no right-hand side | HsVectClassIn -- pre type-checking + SourceText -- Note [Pragma source text] in BasicTypes (Located name) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnClass','ApiAnnotation.AnnClose', @@ -1500,14 +1527,16 @@ data VectDecl name deriving instance (DataId name) => Data (VectDecl name) lvectDeclName :: NamedThing name => LVectDecl name -> Name -lvectDeclName (L _ (HsVect (L _ name) _)) = getName name -lvectDeclName (L _ (HsNoVect (L _ name))) = getName name -lvectDeclName (L _ (HsVectTypeIn _ (L _ name) _)) = getName name -lvectDeclName (L _ (HsVectTypeOut _ tycon _)) = getName tycon -lvectDeclName (L _ (HsVectClassIn (L _ name))) = getName name -lvectDeclName (L _ (HsVectClassOut cls)) = getName cls -lvectDeclName (L _ (HsVectInstIn _)) = panic "HsDecls.lvectDeclName: HsVectInstIn" -lvectDeclName (L _ (HsVectInstOut _)) = panic "HsDecls.lvectDeclName: HsVectInstOut" +lvectDeclName (L _ (HsVect _ (L _ name) _)) = getName name +lvectDeclName (L _ (HsNoVect _ (L _ name))) = getName name +lvectDeclName (L _ (HsVectTypeIn _ _ (L _ name) _)) = getName name +lvectDeclName (L _ (HsVectTypeOut _ tycon _)) = getName tycon +lvectDeclName (L _ (HsVectClassIn _ (L _ name))) = getName name +lvectDeclName (L _ (HsVectClassOut cls)) = getName cls +lvectDeclName (L _ (HsVectInstIn _)) + = panic "HsDecls.lvectDeclName: HsVectInstIn" +lvectDeclName (L _ (HsVectInstOut _)) + = panic "HsDecls.lvectDeclName: HsVectInstOut" lvectInstDecl :: LVectDecl name -> Bool lvectInstDecl (L _ (HsVectInstIn _)) = True @@ -1515,19 +1544,19 @@ lvectInstDecl (L _ (HsVectInstOut _)) = True lvectInstDecl _ = False instance OutputableBndr name => Outputable (VectDecl name) where - ppr (HsVect v rhs) + ppr (HsVect _ v rhs) = sep [text "{-# VECTORISE" <+> ppr v, nest 4 $ pprExpr (unLoc rhs) <+> text "#-}" ] - ppr (HsNoVect v) + ppr (HsNoVect _ v) = sep [text "{-# NOVECTORISE" <+> ppr v <+> text "#-}" ] - ppr (HsVectTypeIn False t Nothing) + ppr (HsVectTypeIn _ False t Nothing) = sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ] - ppr (HsVectTypeIn False t (Just t')) + ppr (HsVectTypeIn _ False t (Just t')) = sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ] - ppr (HsVectTypeIn True t Nothing) + ppr (HsVectTypeIn _ True t Nothing) = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ] - ppr (HsVectTypeIn True t (Just t')) + ppr (HsVectTypeIn _ True t (Just t')) = sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ] ppr (HsVectTypeOut False t Nothing) = sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ] @@ -1537,7 +1566,7 @@ instance OutputableBndr name => Outputable (VectDecl name) where = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ] ppr (HsVectTypeOut True t (Just t')) = sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ] - ppr (HsVectClassIn c) + ppr (HsVectClassIn _ c) = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ] ppr (HsVectClassOut c) = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ] @@ -1583,11 +1612,24 @@ docDeclDoc (DocGroup _ d) = d We use exported entities for things to deprecate. -} + +type LWarnDecls name = Located (WarnDecls name) + + -- Note [Pragma source text] in BasicTypes +data WarnDecls name = Warnings { wd_src :: SourceText + , wd_warnings :: [LWarnDecl name] + } + deriving (Data, Typeable) + + type LWarnDecl name = Located (WarnDecl name) -data WarnDecl name = Warning name WarningTxt +data WarnDecl name = Warning [Located name] WarningTxt deriving (Data, Typeable) +instance OutputableBndr name => Outputable (WarnDecls name) where + ppr (Warnings _ decls) = ppr decls + instance OutputableBndr name => Outputable (WarnDecl name) where ppr (Warning thing txt) = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"] @@ -1602,7 +1644,9 @@ instance OutputableBndr name => Outputable (WarnDecl name) where type LAnnDecl name = Located (AnnDecl name) -data AnnDecl name = HsAnnotation (AnnProvenance name) (Located (HsExpr name)) +data AnnDecl name = HsAnnotation + SourceText -- Note [Pragma source text] in BasicTypes + (AnnProvenance name) (Located (HsExpr name)) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnType' -- 'ApiAnnotation.AnnModule' @@ -1611,24 +1655,27 @@ data AnnDecl name = HsAnnotation (AnnProvenance name) (Located (HsExpr name)) deriving instance (DataId name) => Data (AnnDecl name) instance (OutputableBndr name) => Outputable (AnnDecl name) where - ppr (HsAnnotation provenance expr) + ppr (HsAnnotation _ provenance expr) = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] - -data AnnProvenance name = ValueAnnProvenance name - | TypeAnnProvenance name +data AnnProvenance name = ValueAnnProvenance (Located name) + | TypeAnnProvenance (Located name) | ModuleAnnProvenance - deriving (Data, Typeable, Functor, Foldable, Traversable) + deriving (Data, Typeable, Functor) +deriving instance Foldable AnnProvenance +deriving instance Traversable AnnProvenance annProvenanceName_maybe :: AnnProvenance name -> Maybe name -annProvenanceName_maybe (ValueAnnProvenance name) = Just name -annProvenanceName_maybe (TypeAnnProvenance name) = Just name +annProvenanceName_maybe (ValueAnnProvenance (L _ name)) = Just name +annProvenanceName_maybe (TypeAnnProvenance (L _ name)) = Just name annProvenanceName_maybe ModuleAnnProvenance = Nothing pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc pprAnnProvenance ModuleAnnProvenance = ptext (sLit "ANN module") -pprAnnProvenance (ValueAnnProvenance name) = ptext (sLit "ANN") <+> ppr name -pprAnnProvenance (TypeAnnProvenance name) = ptext (sLit "ANN type") <+> ppr name +pprAnnProvenance (ValueAnnProvenance (L _ name)) + = ptext (sLit "ANN") <+> ppr name +pprAnnProvenance (TypeAnnProvenance (L _ name)) + = ptext (sLit "ANN type") <+> ppr name {- ************************************************************************ diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 129ed80d33..e5dbd3ca2b 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -141,6 +141,7 @@ data HsExpr id -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', -- 'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnClose' + | HsApp (LHsExpr id) (LHsExpr id) -- ^ Application -- | Operator applications: @@ -161,12 +162,8 @@ data HsExpr id | NegApp (LHsExpr id) (SyntaxExpr id) - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' - -- - Note: if 'ApiAnnotation.AnnVal' is present this is actually an - -- inactive 'HsSCC' - -- - Note: if multiple 'ApiAnnotation.AnnVal' are - -- present this is actually an inactive 'HsTickPragma' + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, + -- 'ApiAnnotation.AnnClose' @')'@ | HsPar (LHsExpr id) -- ^ Parenthesised expr; see Note [Parens in HsSyn] | SectionL (LHsExpr id) -- operand; see Note [Sections in HsSyn] @@ -183,14 +180,14 @@ data HsExpr id Boxity -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', - -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' + -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnClose' @'}'@ | HsCase (LHsExpr id) (MatchGroup id (LHsExpr id)) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf', -- 'ApiAnnotation.AnnSemi', - -- 'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi2', + -- 'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi', -- 'ApiAnnotation.AnnElse', | HsIf (Maybe (SyntaxExpr id)) -- cond function -- Nothing => use the built-in 'if' @@ -208,8 +205,8 @@ data HsExpr id -- | let(rec) -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet', - -- 'ApiAnnotation.AnnIn','ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' + -- 'ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn' | HsLet (HsLocalBinds id) (LHsExpr id) @@ -225,8 +222,8 @@ data HsExpr id -- | Syntactic list: [a,b,c,...] -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, + -- 'ApiAnnotation.AnnClose' @']'@ | ExplicitList (PostTc id Type) -- Gives type of components of list (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromListN witness @@ -234,18 +231,18 @@ data HsExpr id -- | Syntactic parallel array: [:e1, ..., en:] -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@, -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnComma', -- 'ApiAnnotation.AnnVbar' - -- 'ApiAnnotation.AnnClose' + -- 'ApiAnnotation.AnnClose' @':]'@ | ExplicitPArr (PostTc id Type) -- type of elements of the parallel array [LHsExpr id] -- | Record construction -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@ | RecordCon (Located id) -- The constructor. After type checking -- it's the dataConWrapId of the constructor PostTcExpr -- Data con Id applied to type args @@ -253,8 +250,8 @@ data HsExpr id -- | Record update -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@ | RecordUpd (LHsExpr id) (HsRecordBinds id) -- (HsMatchGroup Id) -- Filled in by the type checker to be @@ -285,27 +282,37 @@ data HsExpr id -- | Arithmetic sequence -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnComma', - -- 'ApiAnnotation.AnnClose' + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, + -- 'ApiAnnotation.AnnComma','ApiAnnotation.AnnDotdot', + -- 'ApiAnnotation.AnnClose' @']'@ | ArithSeq PostTcExpr (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromList witness (ArithSeqInfo id) -- | Arithmetic sequence for parallel array + -- + -- > [:e1..e2:] or [:e1, e2..e3:] + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@, + -- 'ApiAnnotation.AnnComma','ApiAnnotation.AnnDotdot', + -- 'ApiAnnotation.AnnVbar', + -- 'ApiAnnotation.AnnClose' @':]'@ | PArrSeq - PostTcExpr -- [:e1..e2:] or [:e1, e2..e3:] + PostTcExpr (ArithSeqInfo id) - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' - | HsSCC FastString -- "set cost centre" SCC pragma - (LHsExpr id) -- expr whose cost is to be measured - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' - | HsCoreAnn FastString -- hdaume: core annotation + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# SCC'@, + -- 'ApiAnnotation.AnnVal' or 'ApiAnnotation.AnnValStr', + -- 'ApiAnnotation.AnnClose' @'\#-}'@ + | HsSCC SourceText -- Note [Pragma source text] in BasicTypes + FastString -- "set cost centre" SCC pragma + (LHsExpr id) -- expr whose cost is to be measured + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@, + -- 'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@ + | HsCoreAnn SourceText -- Note [Pragma source text] in BasicTypes + FastString -- hdaume: core annotation (LHsExpr id) ----------------------------------------------------------- @@ -349,6 +356,7 @@ data HsExpr id --------------------------------------- -- static pointers extension + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic', | HsStatic (LHsExpr id) --------------------------------------- @@ -368,8 +376,8 @@ data HsExpr id Bool -- True => right-to-left (f -< arg) -- False => left-to-right (arg >- f) - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(|'@, + -- 'ApiAnnotation.AnnClose' @'|)'@ | HsArrForm -- Command formation, (| e cmd1 .. cmdn |) (LHsExpr id) -- the operator -- after type-checking, a type abstraction to be @@ -391,15 +399,16 @@ data HsExpr id (LHsExpr id) -- sub-expression -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal2', - -- 'ApiAnnotation.AnnColon','ApiAnnotation.AnnVal3', + -- 'ApiAnnotation.AnnOpen' @'{-\# GENERATED'@, + -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnColon','ApiAnnotation.AnnVal', -- 'ApiAnnotation.AnnMinus', - -- 'ApiAnnotation.AnnVal4','ApiAnnotation.AnnColon2', - -- 'ApiAnnotation.AnnVal5', - -- 'ApiAnnotation.AnnClose' - | HsTickPragma -- A pragma introduced tick - (FastString,(Int,Int),(Int,Int)) -- external span for this tick + -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnColon', + -- 'ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnClose' @'\#-}'@ + | HsTickPragma -- A pragma introduced tick + SourceText -- Note [Pragma source text] in BasicTypes + (FastString,(Int,Int),(Int,Int)) -- external span for this tick (LHsExpr id) --------------------------------------- @@ -520,7 +529,7 @@ ppr_expr (HsLit lit) = ppr lit ppr_expr (HsOverLit lit) = ppr lit ppr_expr (HsPar e) = parens (ppr_lexpr e) -ppr_expr (HsCoreAnn s e) +ppr_expr (HsCoreAnn _ s e) = vcat [ptext (sLit "HsCoreAnn") <+> ftext s, ppr_lexpr e] ppr_expr (HsApp e1 e2) @@ -642,7 +651,7 @@ ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e ppr_expr (EViewPat p e) = ppr p <+> ptext (sLit "->") <+> ppr e -ppr_expr (HsSCC lbl expr) +ppr_expr (HsSCC _ lbl expr) = sep [ ptext (sLit "{-# SCC") <+> doubleQuotes (ftext lbl) <+> ptext (sLit "#-}"), pprParendExpr expr ] @@ -674,7 +683,7 @@ ppr_expr (HsBinTick tickIdTrue tickIdFalse exp) ppr tickIdFalse, ptext (sLit ">("), ppr exp,ptext (sLit ")")] -ppr_expr (HsTickPragma externalSrcLoc exp) +ppr_expr (HsTickPragma _ externalSrcLoc exp) = pprTicks (ppr exp) $ hcat [ptext (sLit "tickpragma<"), ppr externalSrcLoc, @@ -770,6 +779,9 @@ We re-use HsExpr to represent these. type LHsCmd id = Located (HsCmd id) data HsCmd id + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.Annlarrowtail', + -- 'ApiAnnotation.Annrarrowtail','ApiAnnotation.AnnLarrowtail', + -- 'ApiAnnotation.AnnRarrowtail' = HsCmdArrApp -- Arrow tail, or arrow application (f -< arg) (LHsExpr id) -- arrow expression, f (LHsExpr id) -- input expression, arg @@ -779,6 +791,8 @@ data HsCmd id Bool -- True => right-to-left (f -< arg) -- False => left-to-right (arg >- f) + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(|'@, + -- 'ApiAnnotation.AnnClose' @'|)'@ | HsCmdArrForm -- Command formation, (| e cmd1 .. cmdn |) (LHsExpr id) -- the operator -- after type-checking, a type abstraction to be @@ -791,22 +805,40 @@ data HsCmd id (LHsExpr id) | HsCmdLam (MatchGroup id (LHsCmd id)) -- kappa + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', + -- 'ApiAnnotation.AnnRarrow', | HsCmdPar (LHsCmd id) -- parenthesised command + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, + -- 'ApiAnnotation.AnnClose' @')'@ | HsCmdCase (LHsExpr id) (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', + -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnClose' @'}'@ | HsCmdIf (Maybe (SyntaxExpr id)) -- cond function (LHsExpr id) -- predicate (LHsCmd id) -- then part (LHsCmd id) -- else part + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf', + -- 'ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnElse', | HsCmdLet (HsLocalBinds id) -- let(rec) (LHsCmd id) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet', + -- 'ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn' | HsCmdDo [CmdLStmt id] (PostTc id Type) -- Type of the whole expression + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', + -- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnVbar', + -- 'ApiAnnotation.AnnClose' | HsCmdCast TcCoercion -- A simpler version of HsWrap in HsExpr (HsCmd id) -- If cmd :: arg1 --> res @@ -818,8 +850,8 @@ deriving instance (DataId id) => Data (HsCmd id) data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp deriving (Data, Typeable) -{- -Top-level command, introducing a new arrow. + +{- | Top-level command, introducing a new arrow. This may occur inside a proc (where the stack is empty) or as an argument of a command-forming operator. -} @@ -968,14 +1000,44 @@ type LMatch id body = Located (Match id body) -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a -- list data Match id body - = Match - [LPat id] -- The patterns - (Maybe (LHsType id)) -- A type signature for the result of the match - -- Nothing after typechecking - (GRHSs id body) - deriving (Typeable) + = Match { + m_fun_id_infix :: (Maybe (Located id,Bool)), + -- fun_id and fun_infix for functions with multiple equations + -- only present for a RdrName. See note [fun_id in Match] + m_pats :: [LPat id], -- The patterns + m_type :: (Maybe (LHsType id)), + -- A type signature for the result of the match + -- Nothing after typechecking + m_grhss :: (GRHSs id body) + } deriving (Typeable) deriving instance (Data body,DataId id) => Data (Match id body) +{- +Note [fun_id in Match] +~~~~~~~~~~~~~~~~~~~~~~ + +The parser initially creates a FunBind with a single Match in it for +every function definition it sees. + +These are then grouped together by getMonoBind into a single FunBind, +where all the Matches are combined. + +In the process, all the original FunBind fun_id's bar one are +discarded, including the locations. + +This causes a problem for source to source conversions via API +Annotations, so the original fun_ids and infix flags are preserved in +the Match, when it originates from a FunBind. + +Example infix function definition requiring individual API Annotations + + (&&& ) [] [] = [] + xs &&& [] = xs + ( &&& ) [] ys = ys + + +-} + isEmptyMatchGroup :: MatchGroup id body -> Bool isEmptyMatchGroup (MG { mg_alts = ms }) = null ms @@ -987,7 +1049,7 @@ matchGroupArity (MG { mg_alts = alts }) | otherwise = panic "matchGroupArity" hsLMatchPats :: LMatch id body -> [LPat id] -hsLMatchPats (L _ (Match pats _ _)) = pats +hsLMatchPats (L _ (Match _ pats _ _)) = pats -- | GRHSs are used both for pattern bindings and for Matches -- @@ -1031,7 +1093,7 @@ pprPatBind pat (grhss) pprMatch :: (OutputableBndr idL, OutputableBndr idR, Outputable body) => HsMatchContext idL -> Match idR body -> SDoc -pprMatch ctxt (Match pats maybe_ty grhss) +pprMatch ctxt (Match _ pats maybe_ty grhss) = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats) , nest 2 ppr_maybe_ty , nest 2 (pprGRHSs ctxt grhss) ] @@ -1136,6 +1198,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) (PostTc idR Type) -- Element type of the RHS (used for arrows) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet' + -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@, | LetStmt (HsLocalBindsLR idL idR) -- ParStmts only occur in a list/monad comprehension diff --git a/compiler/hsSyn/HsImpExp.hs b/compiler/hsSyn/HsImpExp.hs index 166dddc10e..892202ffe2 100644 --- a/compiler/hsSyn/HsImpExp.hs +++ b/compiler/hsSyn/HsImpExp.hs @@ -13,6 +13,7 @@ module HsImpExp where import Module ( ModuleName ) import HsDoc ( HsDocString ) import OccName ( HasOccName(..), isTcOcc, isSymOcc ) +import BasicTypes ( SourceText ) import Outputable import FastString @@ -39,6 +40,8 @@ type LImportDecl name = Located (ImportDecl name) -- | A single Haskell @import@ declaration. data ImportDecl name = ImportDecl { + ideclSourceSrc :: Maybe SourceText, + -- Note [Pragma source text] in BasicTypes ideclName :: Located ModuleName, -- ^ Module name. ideclPkgQual :: Maybe FastString, -- ^ Package qualifier. ideclSource :: Bool, -- ^ True <=> {-\# SOURCE \#-} import @@ -68,6 +71,7 @@ data ImportDecl name simpleImportDecl :: ModuleName -> ImportDecl name simpleImportDecl mn = ImportDecl { + ideclSourceSrc = Nothing, ideclName = noLoc mn, ideclPkgQual = Nothing, ideclSource = False, @@ -131,7 +135,7 @@ data IE name = IEVar (Located name) -- ^ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnPattern', -- 'ApiAnnotation.AnnType' - | IEThingAbs name -- ^ Class/Type (can't tell) + | IEThingAbs (Located name) -- ^ Class/Type (can't tell) -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnPattern', -- 'ApiAnnotation.AnnType','ApiAnnotation.AnnVal' | IEThingAll (Located name) -- ^ Class/Type plus all methods/constructors @@ -156,14 +160,14 @@ data IE name ieName :: IE name -> name ieName (IEVar (L _ n)) = n -ieName (IEThingAbs n) = n +ieName (IEThingAbs (L _ n)) = n ieName (IEThingWith (L _ n) _) = n ieName (IEThingAll (L _ n)) = n ieName _ = panic "ieName failed pattern match!" ieNames :: IE a -> [a] ieNames (IEVar (L _ n) ) = [n] -ieNames (IEThingAbs n ) = [n] +ieNames (IEThingAbs (L _ n) ) = [n] ieNames (IEThingAll (L _ n) ) = [n] ieNames (IEThingWith (L _ n) ns) = n : map unLoc ns ieNames (IEModuleContents _ ) = [] @@ -180,7 +184,7 @@ pprImpExp name = type_pref <+> pprPrefixOcc name instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where ppr (IEVar var) = pprPrefixOcc (unLoc var) - ppr (IEThingAbs thing) = pprImpExp thing + ppr (IEThingAbs thing) = pprImpExp (unLoc thing) ppr (IEThingAll thing) = hcat [pprImpExp (unLoc thing), text "(..)"] ppr (IEThingWith thing withs) = pprImpExp (unLoc thing) <> parens (fsep (punctuate comma diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs index 5e673ad1f4..90e79d13c3 100644 --- a/compiler/hsSyn/HsLit.hs +++ b/compiler/hsSyn/HsLit.hs @@ -19,12 +19,11 @@ module HsLit where #include "HsVersions.h" import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr ) -import BasicTypes ( FractionalLit(..) ) +import BasicTypes ( FractionalLit(..),SourceText ) import Type ( Type ) import Outputable import FastString import PlaceHolder ( PostTc,PostRn,DataId ) -import Lexer ( SourceText ) import Data.ByteString (ByteString) import Data.Data hiding ( Fixity ) @@ -37,7 +36,8 @@ import Data.Data hiding ( Fixity ) ************************************************************************ -} --- Note [literal source text] for SourceText fields in the following +-- Note [literal source text] in BasicTypes for SourceText fields in +-- the following data HsLit = HsChar SourceText Char -- Character | HsCharPrim SourceText Char -- Unboxed character @@ -84,7 +84,8 @@ data HsOverLit id -- An overloaded literal deriving (Typeable) deriving instance (DataId id) => Data (HsOverLit id) --- Note [literal source text] for SourceText fields in the following +-- Note [literal source text] in BasicTypes for SourceText fields in +-- the following data OverLitVal = HsIntegral !SourceText !Integer -- Integer-looking literals; | HsFractional !FractionalLit -- Frac-looking literals @@ -95,36 +96,6 @@ overLitType :: HsOverLit a -> PostTc a Type overLitType = ol_type {- -Note [literal source text] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The lexer/parser converts literals from their original source text -versions to an appropriate internal representation. This is a problem -for tools doing source to source conversions, so the original source -text is stored in literals where this can occur. - -Motivating examples for HsLit - - HsChar '\n', '\x20` - HsCharPrim '\x41`# - HsString "\x20\x41" == " A" - HsStringPrim "\x20"# - HsInt 001 - HsIntPrim 002# - HsWordPrim 003## - HsInt64Prim 004## - HsWord64Prim 005## - HsInteger 006 - -For OverLitVal - - HsIntegral 003,0x001 - HsIsString "\x41nd" - - - - - Note [ol_rebindable] ~~~~~~~~~~~~~~~~~~~~ The ol_rebindable field is True if this literal is actually diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index f38665f209..ea8f62500b 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -67,10 +67,17 @@ data Pat id | VarPat id -- Variable | LazyPat (LPat id) -- Lazy pattern + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' + | AsPat (Located id) (LPat id) -- As pattern + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' + | ParPat (LPat id) -- Parenthesised pattern -- See Note [Parens in HsSyn] in HsExpr + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, + -- 'ApiAnnotation.AnnClose' @')'@ | BangPat (LPat id) -- Bang pattern + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang' ------------ Lists, tuples, arrays --------------- | ListPat [LPat id] -- Syntactic list @@ -79,6 +86,8 @@ data Pat id -- For OverloadedLists a Just (ty,fn) gives -- overall type of the pattern, and the toList -- function to convert the scrutinee to a list value + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, + -- 'ApiAnnotation.AnnClose' @']'@ | TuplePat [LPat id] -- Tuple sub-patterns Boxity -- UnitPat is TuplePat [] @@ -99,9 +108,14 @@ data Pat id -- of the tuple is of type 'a' not Int. See selectMatchVar -- (June 14: I'm not sure this comment is right; the sub-patterns -- will be wrapped in CoPats, no?) + -- ^ - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpen' @'('@ or @'(#'@, + -- 'ApiAnnotation.AnnClose' @')'@ or @'#)'@ | PArrPat [LPat id] -- Syntactic parallel array (PostTc id Type) -- The type of the elements + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@, + -- 'ApiAnnotation.AnnClose' @':]'@ ------------ Constructor patterns --------------- | ConPatIn (Located id) @@ -124,6 +138,7 @@ data Pat id } ------------ View patterns --------------- + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow' | ViewPat (LHsExpr id) (LPat id) (PostTc id Type) -- The overall type of the pattern @@ -131,6 +146,8 @@ data Pat id -- for hsPatType. ------------ Pattern splices --------------- + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@ + -- 'ApiAnnotation.AnnClose' @')'@ | SplicePat (HsSplice id) ------------ Quasiquoted patterns --------------- @@ -143,17 +160,19 @@ data Pat id | NPat -- Used for all overloaded literals, -- including overloaded strings with -XOverloadedStrings - (HsOverLit id) -- ALWAYS positive + (Located (HsOverLit id)) -- ALWAYS positive (Maybe (SyntaxExpr id)) -- Just (Name of 'negate') for negative -- patterns, Nothing otherwise (SyntaxExpr id) -- Equality checker, of type t->t->Bool + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@ | NPlusKPat (Located id) -- n+k pattern - (HsOverLit id) -- It'll always be an HsIntegral + (Located (HsOverLit id)) -- It'll always be an HsIntegral (SyntaxExpr id) -- (>=) function, of type t->t->Bool (SyntaxExpr id) -- Name of '-' (see RnEnv.lookupSyntaxName) ------------ Pattern type signatures --------------- + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' | SigPatIn (LPat id) -- Pattern with a type signature (HsWithBndrs id (LHsType id)) -- Signature can bind both -- kind and type vars diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 41142bb053..ce1d319e65 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -132,6 +132,7 @@ See also Note [Kind and type-variable binders] in RnTypes -} type LHsContext name = Located (HsContext name) + -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnUnit' type HsContext name = [LHsType name] @@ -216,7 +217,7 @@ data HsTyVarBndr name name | KindedTyVar - name + (Located name) (LHsKind name) -- The user-supplied kind signature -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', @@ -233,11 +234,6 @@ isHsKindedTyVar (KindedTyVar {}) = True hsTvbAllKinded :: LHsTyVarBndrs name -> Bool hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvBndrs --------------------------------------------------- --- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon', --- 'ApiAnnotation.AnnTilde','ApiAnnotation.AnnRarrow', --- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', --- 'ApiAnnotation.AnnComma' data HsType name = HsForAllTy HsExplicitFlag -- Renamer leaves this flag unchanged, to record the way -- the user wrote it originally, so that the printer can @@ -253,73 +249,119 @@ data HsType name (LHsType name) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall', -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' + | HsTyVar name -- Type variable, type constructor, or data constructor -- see Note [Promotions (HsTyVar)] + -- ^ - 'ApiAnnotation.AnnKeywordId' : None | HsAppTy (LHsType name) (LHsType name) + -- ^ - 'ApiAnnotation.AnnKeywordId' : None | HsFunTy (LHsType name) -- function type (LHsType name) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow', | HsListTy (LHsType name) -- Element type + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, + -- 'ApiAnnotation.AnnClose' @']'@ | HsPArrTy (LHsType name) -- Elem. type of parallel array: [:t:] + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@, + -- 'ApiAnnotation.AnnClose' @':]'@ | HsTupleTy HsTupleSort [LHsType name] -- Element types (length gives arity) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(' or '(#'@, + -- 'ApiAnnotation.AnnClose' @')' or '#)'@ | HsOpTy (LHsType name) (LHsTyOp name) (LHsType name) + -- ^ - 'ApiAnnotation.AnnKeywordId' : None | HsParTy (LHsType name) -- See Note [Parens in HsSyn] in HsExpr -- Parenthesis preserved for the precedence re-arrangement in RnTypes -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, + -- 'ApiAnnotation.AnnClose' @')'@ | HsIParamTy HsIPName -- (?x :: ty) (LHsType name) -- Implicit parameters as they occur in contexts + -- ^ + -- > (?x :: ty) + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' | HsEqTy (LHsType name) -- ty1 ~ ty2 (LHsType name) -- Always allowed even without TypeOperators, and has special kinding rule + -- ^ + -- > ty1 ~ ty2 + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' | HsKindSig (LHsType name) -- (ty :: kind) (LHsKind name) -- A type with a kind signature + -- ^ + -- > (ty :: kind) + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, + -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' @')'@ | HsQuasiQuoteTy (HsQuasiQuote name) + -- ^ - 'ApiAnnotation.AnnKeywordId' : None | HsSpliceTy (HsSplice name) (PostTc name Kind) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@, + -- 'ApiAnnotation.AnnClose' @')'@ | HsDocTy (LHsType name) LHsDocString -- A documented type + -- ^ - 'ApiAnnotation.AnnKeywordId' : None | HsBangTy HsSrcBang (LHsType name) -- Bang-style type annotations - | HsRecTy [LConDeclField name] -- Only in data type declarations + -- ^ - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@, + -- 'ApiAnnotation.AnnClose' @'#-}'@ + -- 'ApiAnnotation.AnnBang' @\'!\'@ + + | HsRecTy [LConDeclField name] -- Only in data type declarations + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnClose' @'}'@ | HsCoreTy Type -- An escape hatch for tunnelling a *closed* -- Core Type through HsSyn. + -- ^ - 'ApiAnnotation.AnnKeywordId' : None | HsExplicitListTy -- A promoted explicit list (PostTc name Kind) -- See Note [Promoted lists and tuples] [LHsType name] + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'["@, + -- 'ApiAnnotation.AnnClose' @']'@ | HsExplicitTupleTy -- A promoted explicit tuple [PostTc name Kind] -- See Note [Promoted lists and tuples] [LHsType name] + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'("@, + -- 'ApiAnnotation.AnnClose' @')'@ | HsTyLit HsTyLit -- A promoted numeric literal. + -- ^ - 'ApiAnnotation.AnnKeywordId' : None | HsWrapTy HsTyWrapper (HsType name) -- only in typechecker output + -- ^ - 'ApiAnnotation.AnnKeywordId' : None | HsWildcardTy -- A type wildcard + -- ^ - 'ApiAnnotation.AnnKeywordId' : None | HsNamedWildcardTy name -- A named wildcard + -- ^ - 'ApiAnnotation.AnnKeywordId' : None deriving (Typeable) deriving instance (DataId name) => Data (HsType name) - +-- Note [literal source text] in BasicTypes for SourceText fields in +-- the following data HsTyLit - = HsNumTy Integer - | HsStrTy FastString + = HsNumTy SourceText Integer + | HsStrTy SourceText FastString deriving (Data, Typeable) data HsTyWrapper @@ -504,8 +546,8 @@ hsExplicitTvs _ = [] --------------------- hsTyVarName :: HsTyVarBndr name -> name -hsTyVarName (UserTyVar n) = n -hsTyVarName (KindedTyVar n _) = n +hsTyVarName (UserTyVar n) = n +hsTyVarName (KindedTyVar (L _ n) _) = n hsLTyVarName :: LHsTyVarBndr name -> name hsLTyVarName = hsTyVarName . unLoc @@ -812,5 +854,5 @@ ppr_fun_ty ctxt_prec ty1 ty2 -------------------------- ppr_tylit :: HsTyLit -> SDoc -ppr_tylit (HsNumTy i) = integer i -ppr_tylit (HsStrTy s) = text (show s) +ppr_tylit (HsNumTy _ i) = integer i +ppr_tylit (HsStrTy _ s) = text (show s) diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index 398aafdb01..4a80ebd34d 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -122,7 +122,7 @@ mkHsPar e = L (getLoc e) (HsPar e) mkSimpleMatch :: [LPat id] -> Located (body id) -> LMatch id (Located (body id)) mkSimpleMatch pats rhs = L loc $ - Match pats Nothing (unguardedGRHSs rhs) + Match Nothing pats Nothing (unguardedGRHSs rhs) where loc = case pats of [] -> getLoc rhs @@ -202,8 +202,8 @@ mkHsDo :: HsStmtContext Name -> [ExprLStmt RdrName] -> HsExpr RdrName mkHsComp :: HsStmtContext Name -> [ExprLStmt RdrName] -> LHsExpr RdrName -> HsExpr RdrName -mkNPat :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id -mkNPlusKPat :: Located id -> HsOverLit id -> Pat id +mkNPat :: Located (HsOverLit id) -> Maybe (SyntaxExpr id) -> Pat id +mkNPlusKPat :: Located id -> Located (HsOverLit id) -> Pat id mkLastStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR)) mkBodyStmt :: Located (bodyR RdrName) @@ -460,10 +460,11 @@ toHsType ty to_hs_type (FunTy arg res) = ASSERT( not (isConstraintKind (typeKind arg)) ) nlHsFunTy (toHsType arg) (toHsType res) to_hs_type t@(ForAllTy {}) = pprPanic "toHsType" (ppr t) - to_hs_type (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy n) - to_hs_type (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy s) + to_hs_type (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy "" n) + to_hs_type (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy "" s) - mk_hs_tvb tv = noLoc $ KindedTyVar (getRdrName tv) (toHsKind (tyVarKind tv)) + mk_hs_tvb tv = noLoc $ KindedTyVar (noLoc (getRdrName tv)) + (toHsKind (tyVarKind tv)) toHsKind :: Kind -> LHsKind RdrName toHsKind = toHsType @@ -564,7 +565,7 @@ mk_easy_FunBind loc fun pats expr ------------ mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id (LHsExpr id) mkMatch pats expr binds - = noLoc (Match (map paren pats) Nothing + = noLoc (Match Nothing (map paren pats) Nothing (GRHSs (unguardedRHS noSrcSpan expr) binds)) where paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp) @@ -831,7 +832,8 @@ hsConDeclsBinders cons = go id cons -- avoid circumventing detection of duplicate fields (#9156) L loc (ConDecl { con_names = names, con_details = RecCon flds }) -> (map (L loc . unLoc) names) ++ r' ++ go remSeen' rs - where r' = remSeen (concatMap (cd_fld_names . unLoc) flds) + where r' = remSeen (concatMap (cd_fld_names . unLoc) + (unLoc flds)) remSeen' = foldr (.) remSeen [deleteBy ((==) `on` unLoc) v | v <- r'] L loc (ConDecl { con_names = names }) -> (map (L loc . unLoc) names) ++ go remSeen rs diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 877ae74448..a17f3a9593 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -245,7 +245,8 @@ module GHC ( -- * API Annotations ApiAnns,AnnKeywordId(..),AnnotationComment(..), - getAnnotation, getAnnotationComments, + getAnnotation, getAndRemoveAnnotation, + getAnnotationComments, getAndRemoveAnnotationComments, -- * Miscellaneous --sessionHscEnv, diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index d09a43eb7c..3473a4ab88 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -110,7 +110,8 @@ mkPrelImports this_mod loc implicit_prelude import_decls preludeImportDecl :: LImportDecl RdrName preludeImportDecl - = L loc $ ImportDecl { ideclName = L loc pRELUDE_NAME, + = L loc $ ImportDecl { ideclSourceSrc = Nothing, + ideclName = L loc pRELUDE_NAME, ideclPkgQual = Nothing, ideclSource = False, ideclSafe = False, -- Not a safe import diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 42acd1a725..c1675dd299 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -1085,7 +1085,11 @@ markUnsafeInfer tcg_env whyUnsafe = do text str <+> text "is not allowed in Safe Haskell"] | otherwise = [] badInsts insts = concat $ map badInst insts - badInst ins | overlapMode (is_flag ins) /= NoOverlap + + checkOverlap (NoOverlap _) = False + checkOverlap _ = True + + badInst ins | checkOverlap (overlapMode (is_flag ins)) = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $ ppr (overlapMode $ is_flag ins) <+> text "overlap mode isn't allowed in Safe Haskell"] diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 4fdfa950e3..3b28635028 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -2386,6 +2386,7 @@ ms_imps ms = -- text, such as those induced by the use of plugins (the -plgFoo -- flag) mk_additional_import mod_nm = noLoc $ ImportDecl { + ideclSourceSrc = Nothing, ideclName = noLoc mod_nm, ideclPkgQual = Nothing, ideclSource = False, diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 959b7e83a9..70c61f2215 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -990,6 +990,7 @@ dynCompileExpr :: GhcMonad m => String -> m Dynamic dynCompileExpr expr = do iis <- getContext let importDecl = ImportDecl { + ideclSourceSrc = Nothing, ideclName = noLoc (mkModuleName "Data.Dynamic"), ideclPkgQual = Nothing, ideclSource = False, diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs index 510f3dc580..60f917222f 100644 --- a/compiler/parser/ApiAnnotation.hs +++ b/compiler/parser/ApiAnnotation.hs @@ -1,8 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} module ApiAnnotation ( - getAnnotation, - getAnnotationComments, + getAnnotation, getAndRemoveAnnotation, + getAnnotationComments,getAndRemoveAnnotationComments, ApiAnns, ApiAnnKey, AnnKeywordId(..), @@ -132,28 +132,65 @@ getAnnotation (anns,_) span ann Nothing -> [] Just ss -> ss +-- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan' +-- of the annotated AST element, and the known type of the annotation. +-- The list is removed from the annotations. +getAndRemoveAnnotation :: ApiAnns -> SrcSpan -> AnnKeywordId + -> ([SrcSpan],ApiAnns) +getAndRemoveAnnotation (anns,cs) span ann + = case Map.lookup (span,ann) anns of + Nothing -> ([],(anns,cs)) + Just ss -> (ss,(Map.delete (span,ann) anns,cs)) + -- |Retrieve the comments allocated to the current 'SrcSpan' +-- +-- Note: A given 'SrcSpan' may appear in multiple AST elements, +-- beware of duplicates getAnnotationComments :: ApiAnns -> SrcSpan -> [Located AnnotationComment] getAnnotationComments (_,anns) span = case Map.lookup span anns of Just cs -> cs Nothing -> [] +-- |Retrieve the comments allocated to the current 'SrcSpan', and +-- remove them from the annotations +getAndRemoveAnnotationComments :: ApiAnns -> SrcSpan + -> ([Located AnnotationComment],ApiAnns) +getAndRemoveAnnotationComments (anns,canns) span = + case Map.lookup span canns of + Just cs -> (cs,(anns,Map.delete span canns)) + Nothing -> ([],(anns,canns)) + -- -------------------------------------------------------------------- --- | Note: in general the names of these are taken from the +-- | API Annotations exist so that tools can perform source to source +-- conversions of Haskell code. They are used to keep track of the +-- various syntactic keywords that are not captured in the existing +-- AST. +-- +-- The annotations, together with original source comments are made +-- available in the @'pm_annotations'@ field of @'GHC.ParsedModule'@. +-- Comments are only retained if @'Opt_KeepRawTokenStream'@ is set in +-- @'DynFlags.DynFlags'@ before parsing. +-- +-- Note: in general the names of these are taken from the -- corresponding token, unless otherwise noted -- See note [Api annotations] above for details of the usage data AnnKeywordId = AnnAs | AnnAt | AnnBang -- ^ '!' + | AnnBackquote -- ^ '`' | AnnBy | AnnCase -- ^ case or lambda case | AnnClass - | AnnClose -- ^ '}' or ']' or ')' or '#)' etc + | AnnClose -- ^ '\#)' or '\#-}' etc + | AnnCloseC -- ^ '}' + | AnnCloseP -- ^ ')' + | AnnCloseS -- ^ ']' | AnnColon - | AnnComma + | AnnComma -- ^ as a list separator + | AnnCommaTuple -- ^ in a RdrName for a tuple | AnnDarrow -- ^ '=>' | AnnData | AnnDcolon -- ^ '::' @@ -186,7 +223,10 @@ data AnnKeywordId | AnnModule | AnnNewtype | AnnOf - | AnnOpen -- ^ '{' or '[' or '(' or '(#' etc + | AnnOpen -- ^ '(\#' or '{-\# LANGUAGE' etc + | AnnOpenC -- ^ '{' + | AnnOpenP -- ^ '(' + | AnnOpenS -- ^ '[' | AnnPackageName | AnnPattern | AnnProc @@ -196,12 +236,15 @@ data AnnKeywordId | AnnRole | AnnSafe | AnnSemi -- ^ ';' + | AnnStatic -- ^ 'static' | AnnThen | AnnTilde -- ^ '~' | AnnTildehsh -- ^ '~#' | AnnType + | AnnUnit -- ^ '()' for types | AnnUsing | AnnVal -- ^ e.g. INTEGER + | AnnValStr -- ^ String value, will need quotes when output | AnnVbar -- ^ '|' | AnnWhere | Annlarrowtail -- ^ '-<' diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 596f3bd1cf..495605e70c 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -56,7 +56,7 @@ {-# OPTIONS_GHC -funbox-strict-fields #-} module Lexer ( - Token(..), SourceText, lexer, pragState, mkPState, PState(..), + Token(..), lexer, pragState, mkPState, PState(..), P(..), ParseResult(..), getSrcLoc, getPState, getDynFlags, withThisPackage, failLocMsgP, failSpanMsgP, srcParseFail, @@ -73,7 +73,7 @@ module Lexer ( sccProfilingOn, hpcEnabled, addWarning, lexTokenStream, - addAnnotation + addAnnotation,AddAnn,mkParensApiAnn ) where -- base @@ -112,7 +112,8 @@ import DynFlags -- compiler/basicTypes import SrcLoc import Module -import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) ) +import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..), + SourceText ) -- compiler/parser import Ctype @@ -507,8 +508,6 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } { -type SourceText = String -- Note [literal source text] in HsLit - -- ----------------------------------------------------------------------------- -- The token type @@ -560,34 +559,34 @@ data Token | ITpattern | ITstatic - -- Pragmas - | ITinline_prag InlineSpec RuleMatchInfo - | ITspec_prag -- SPECIALISE - | ITspec_inline_prag Bool -- SPECIALISE INLINE (or NOINLINE) - | ITsource_prag - | ITrules_prag - | ITwarning_prag - | ITdeprecated_prag + -- Pragmas, see note [Pragma source text] in BasicTypes + | ITinline_prag SourceText InlineSpec RuleMatchInfo + | ITspec_prag SourceText -- SPECIALISE + | ITspec_inline_prag SourceText Bool -- SPECIALISE INLINE (or NOINLINE) + | ITsource_prag SourceText + | ITrules_prag SourceText + | ITwarning_prag SourceText + | ITdeprecated_prag SourceText | ITline_prag - | ITscc_prag - | ITgenerated_prag - | ITcore_prag -- hdaume: core annotations - | ITunpack_prag - | ITnounpack_prag - | ITann_prag + | ITscc_prag SourceText + | ITgenerated_prag SourceText + | ITcore_prag SourceText -- hdaume: core annotations + | ITunpack_prag SourceText + | ITnounpack_prag SourceText + | ITann_prag SourceText | ITclose_prag | IToptions_prag String | ITinclude_prag String | ITlanguage_prag - | ITvect_prag - | ITvect_scalar_prag - | ITnovect_prag - | ITminimal_prag - | IToverlappable_prag -- instance overlap mode - | IToverlapping_prag -- instance overlap mode - | IToverlaps_prag -- instance overlap mode - | ITincoherent_prag -- instance overlap mode - | ITctype + | ITvect_prag SourceText + | ITvect_scalar_prag SourceText + | ITnovect_prag SourceText + | ITminimal_prag SourceText + | IToverlappable_prag SourceText -- instance overlap mode + | IToverlapping_prag SourceText -- instance overlap mode + | IToverlaps_prag SourceText -- instance overlap mode + | ITincoherent_prag SourceText -- instance overlap mode + | ITctype SourceText | ITdotdot -- reserved symbols | ITcolon @@ -640,15 +639,15 @@ data Token | ITdupipvarid FastString -- GHC extension: implicit param: ?x - | ITchar SourceText Char -- Note [literal source text] in HsLit - | ITstring SourceText FastString -- Note [literal source text] in HsLit - | ITinteger SourceText Integer -- Note [literal source text] in HsLit - | ITrational FractionalLit + | ITchar SourceText Char -- Note [literal source text] in BasicTypes + | ITstring SourceText FastString -- Note [literal source text] in BasicTypes + | ITinteger SourceText Integer -- Note [literal source text] in BasicTypes + | ITrational FractionalLit - | ITprimchar SourceText Char -- Note [literal source text] in HsLit - | ITprimstring SourceText ByteString -- Note [literal source text] in HsLit - | ITprimint SourceText Integer -- Note [literal source text] in HsLit - | ITprimword SourceText Integer -- Note [literal source text] in HsLit + | ITprimchar SourceText Char -- Note [literal source text] in BasicTypes + | ITprimstring SourceText ByteString -- Note [literal source text] @BasicTypes + | ITprimint SourceText Integer -- Note [literal source text] in BasicTypes + | ITprimword SourceText Integer -- Note [literal source text] in BasicTypes | ITprimfloat FractionalLit | ITprimdouble FractionalLit @@ -702,6 +701,7 @@ data Token instance Outputable Token where ppr x = text (show x) + -- the bitmap provided as the third component indicates whether the -- corresponding extension keyword is valid under the extension options -- provided to the compiler; if the extension corresponding to *any* of the @@ -1029,9 +1029,10 @@ withLexedDocType lexDocComment = do -- RULES pragmas turn on the forall and '.' keywords, and we turn them -- off again at the end of the pragma. rulePrag :: Action -rulePrag span _buf _len = do +rulePrag span buf len = do setExts (.|. xbit InRulePragBit) - return (L span ITrules_prag) + let !src = lexemeToString buf len + return (L span (ITrules_prag src)) endPrag :: Action endPrag span _buf _len = do @@ -2518,36 +2519,38 @@ ignoredPrags = Map.fromList (map ignored pragmas) -- CFILES is a hugs-only thing. pragmas = options_pragmas ++ ["cfiles", "contract"] -oneWordPrags = Map.fromList([("rules", rulePrag), - ("inline", token (ITinline_prag Inline FunLike)), - ("inlinable", token (ITinline_prag Inlinable FunLike)), - ("inlineable", token (ITinline_prag Inlinable FunLike)), +oneWordPrags = Map.fromList([ + ("rules", rulePrag), + ("inline", strtoken (\s -> (ITinline_prag s Inline FunLike))), + ("inlinable", strtoken (\s -> (ITinline_prag s Inlinable FunLike))), + ("inlineable", strtoken (\s -> (ITinline_prag s Inlinable FunLike))), -- Spelling variant - ("notinline", token (ITinline_prag NoInline FunLike)), - ("specialize", token ITspec_prag), - ("source", token ITsource_prag), - ("warning", token ITwarning_prag), - ("deprecated", token ITdeprecated_prag), - ("scc", token ITscc_prag), - ("generated", token ITgenerated_prag), - ("core", token ITcore_prag), - ("unpack", token ITunpack_prag), - ("nounpack", token ITnounpack_prag), - ("ann", token ITann_prag), - ("vectorize", token ITvect_prag), - ("novectorize", token ITnovect_prag), - ("minimal", token ITminimal_prag), - ("overlaps", token IToverlaps_prag), - ("overlappable", token IToverlappable_prag), - ("overlapping", token IToverlapping_prag), - ("incoherent", token ITincoherent_prag), - ("ctype", token ITctype)]) - -twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)), - ("notinline conlike", token (ITinline_prag NoInline ConLike)), - ("specialize inline", token (ITspec_inline_prag True)), - ("specialize notinline", token (ITspec_inline_prag False)), - ("vectorize scalar", token ITvect_scalar_prag)]) + ("notinline", strtoken (\s -> (ITinline_prag s NoInline FunLike))), + ("specialize", strtoken (\s -> ITspec_prag s)), + ("source", strtoken (\s -> ITsource_prag s)), + ("warning", strtoken (\s -> ITwarning_prag s)), + ("deprecated", strtoken (\s -> ITdeprecated_prag s)), + ("scc", strtoken (\s -> ITscc_prag s)), + ("generated", strtoken (\s -> ITgenerated_prag s)), + ("core", strtoken (\s -> ITcore_prag s)), + ("unpack", strtoken (\s -> ITunpack_prag s)), + ("nounpack", strtoken (\s -> ITnounpack_prag s)), + ("ann", strtoken (\s -> ITann_prag s)), + ("vectorize", strtoken (\s -> ITvect_prag s)), + ("novectorize", strtoken (\s -> ITnovect_prag s)), + ("minimal", strtoken (\s -> ITminimal_prag s)), + ("overlaps", strtoken (\s -> IToverlaps_prag s)), + ("overlappable", strtoken (\s -> IToverlappable_prag s)), + ("overlapping", strtoken (\s -> IToverlapping_prag s)), + ("incoherent", strtoken (\s -> ITincoherent_prag s)), + ("ctype", strtoken (\s -> ITctype s))]) + +twoWordPrags = Map.fromList([ + ("inline conlike", strtoken (\s -> (ITinline_prag s Inline ConLike))), + ("notinline conlike", strtoken (\s -> (ITinline_prag s NoInline ConLike))), + ("specialize inline", strtoken (\s -> (ITspec_inline_prag s True))), + ("specialize notinline", strtoken (\s -> (ITspec_inline_prag s False))), + ("vectorize scalar", strtoken (\s -> ITvect_scalar_prag s))]) dispatch_pragmas :: Map String Action -> Action dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of @@ -2585,6 +2588,10 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag)) %************************************************************************ -} +-- |Encapsulated call to addAnnotation, requiring only the SrcSpan of +-- the AST element the annotation belongs to +type AddAnn = (SrcSpan -> P ()) + addAnnotation :: SrcSpan -> AnnKeywordId -> SrcSpan -> P () addAnnotation l a v = do addAnnotationOnly l a v @@ -2595,6 +2602,22 @@ addAnnotationOnly l a v = P $ \s -> POk s { annotations = ((l,a), [v]) : annotations s } () +-- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate +-- 'AddAnn' values for the opening and closing bordering on the start +-- and end of the span +mkParensApiAnn :: SrcSpan -> [AddAnn] +mkParensApiAnn (UnhelpfulSpan _) = [] +mkParensApiAnn s@(RealSrcSpan ss) = [mj AnnOpenP lo,mj AnnCloseP lc] + where + mj a l = (\s -> addAnnotation s a l) + f = srcSpanFile ss + sl = srcSpanStartLine ss + sc = srcSpanStartCol ss + el = srcSpanEndLine ss + ec = srcSpanEndCol ss + lo = mkSrcSpan (srcSpanStart s) (mkSrcLoc f sl (sc+1)) + lc = mkSrcSpan (mkSrcLoc f el (ec - 1)) (srcSpanEnd s) + queueComment :: Located Token -> P() queueComment c = P $ \s -> POk s { comment_q = commentToAnnotation c : comment_q s diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 36b27cf919..9e3d5ff14e 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -310,29 +310,29 @@ See https://ghc.haskell.org/trac/ghc/wiki/GhcAstAnnotations for some background. 'pattern' { L _ ITpattern } -- for pattern synonyms 'static' { L _ ITstatic } -- for static pointers extension - '{-# INLINE' { L _ (ITinline_prag _ _) } - '{-# SPECIALISE' { L _ ITspec_prag } - '{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _) } - '{-# SOURCE' { L _ ITsource_prag } - '{-# RULES' { L _ ITrules_prag } - '{-# CORE' { L _ ITcore_prag } -- hdaume: annotated core - '{-# SCC' { L _ ITscc_prag } - '{-# GENERATED' { L _ ITgenerated_prag } - '{-# DEPRECATED' { L _ ITdeprecated_prag } - '{-# WARNING' { L _ ITwarning_prag } - '{-# UNPACK' { L _ ITunpack_prag } - '{-# NOUNPACK' { L _ ITnounpack_prag } - '{-# ANN' { L _ ITann_prag } - '{-# VECTORISE' { L _ ITvect_prag } - '{-# VECTORISE_SCALAR' { L _ ITvect_scalar_prag } - '{-# NOVECTORISE' { L _ ITnovect_prag } - '{-# MINIMAL' { L _ ITminimal_prag } - '{-# CTYPE' { L _ ITctype } - '{-# OVERLAPPING' { L _ IToverlapping_prag } - '{-# OVERLAPPABLE' { L _ IToverlappable_prag } - '{-# OVERLAPS' { L _ IToverlaps_prag } - '{-# INCOHERENT' { L _ ITincoherent_prag } - '#-}' { L _ ITclose_prag } + '{-# INLINE' { L _ (ITinline_prag _ _ _) } + '{-# SPECIALISE' { L _ (ITspec_prag _) } + '{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _ _) } + '{-# SOURCE' { L _ (ITsource_prag _) } + '{-# RULES' { L _ (ITrules_prag _) } + '{-# CORE' { L _ (ITcore_prag _) } -- hdaume: annotated core + '{-# SCC' { L _ (ITscc_prag _)} + '{-# GENERATED' { L _ (ITgenerated_prag _) } + '{-# DEPRECATED' { L _ (ITdeprecated_prag _) } + '{-# WARNING' { L _ (ITwarning_prag _) } + '{-# UNPACK' { L _ (ITunpack_prag _) } + '{-# NOUNPACK' { L _ (ITnounpack_prag _) } + '{-# ANN' { L _ (ITann_prag _) } + '{-# VECTORISE' { L _ (ITvect_prag _) } + '{-# VECTORISE_SCALAR' { L _ (ITvect_scalar_prag _) } + '{-# NOVECTORISE' { L _ (ITnovect_prag _) } + '{-# MINIMAL' { L _ (ITminimal_prag _) } + '{-# CTYPE' { L _ (ITctype _) } + '{-# OVERLAPPING' { L _ (IToverlapping_prag _) } + '{-# OVERLAPPABLE' { L _ (IToverlappable_prag _) } + '{-# OVERLAPS' { L _ (IToverlaps_prag _) } + '{-# INCOHERENT' { L _ (ITincoherent_prag _) } + '#-}' { L _ ITclose_prag } '..' { L _ ITdotdot } -- reserved symbols ':' { L _ ITcolon } @@ -446,7 +446,8 @@ identifier :: { Located RdrName } | qcon { $1 } | qvarop { $1 } | qconop { $1 } - | '(' '->' ')' { sLL $1 $> $ getRdrName funTyCon } + | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon) + [mj AnnOpenP $1,mj AnnRarrow $2,mj AnnCloseP $3] } ----------------------------------------------------------------------------- -- Module Header @@ -480,31 +481,37 @@ missing_module_keyword :: { () } maybemodwarning :: { Maybe (Located WarningTxt) } : '{-# DEPRECATED' strings '#-}' - {% ajs (Just (sLL $1 $> $ DeprecatedTxt $ snd $ unLoc $2)) - (mo $1:mc $1: (fst $ unLoc $2)) } + {% ajs (Just (sLL $1 $> $ DeprecatedTxt (sL1 $1 (getDEPRECATED_PRAGs $1)) (snd $ unLoc $2))) + (mo $1:mc $3: (fst $ unLoc $2)) } | '{-# WARNING' strings '#-}' - {% ajs (Just (sLL $1 $> $ WarningTxt $ snd $ unLoc $2)) + {% ajs (Just (sLL $1 $> $ WarningTxt (sL1 $1 (getWARNING_PRAGs $1)) (snd $ unLoc $2))) (mo $1:mc $3 : (fst $ unLoc $2)) } | {- empty -} { Nothing } body :: { ([AddAnn] ,([LImportDecl RdrName], [LHsDecl RdrName])) } - : '{' top '}' { (mo $1:mc $3:(fst $2) + : '{' top '}' { (moc $1:mcc $3:(fst $2) , snd $2) } | vocurly top close { (fst $2, snd $2) } body2 :: { ([AddAnn] ,([LImportDecl RdrName], [LHsDecl RdrName])) } - : '{' top '}' { (mo $1:mc $3 + : '{' top '}' { (moc $1:mcc $3 :(fst $2), snd $2) } | missing_module_keyword top close { ([],snd $2) } top :: { ([AddAnn] ,([LImportDecl RdrName], [LHsDecl RdrName])) } - : importdecls { ([] - ,(reverse $1,[]))} - | importdecls ';' cvtopdecls { ([mj AnnSemi $2] - ,(reverse $1,$3))} + : importdecls { (fst $1 + ,(reverse $ snd $1,[]))} + | importdecls ';' cvtopdecls {% if null (snd $1) + then return ((mj AnnSemi $2:(fst $1)) + ,(reverse $ snd $1,$3)) + else do + { addAnnotation (gl $ head $ snd $1) + AnnSemi (gl $2) + ; return (fst $1 + ,(reverse $ snd $1,$3)) }} | cvtopdecls { ([],([],$1)) } cvtopdecls :: { [LHsDecl RdrName] } @@ -524,18 +531,18 @@ header :: { Located (HsModule RdrName) } Nothing)) } header_body :: { [LImportDecl RdrName] } - : '{' importdecls { $2 } - | vocurly importdecls { $2 } + : '{' importdecls { snd $2 } + | vocurly importdecls { snd $2 } header_body2 :: { [LImportDecl RdrName] } - : '{' importdecls { $2 } - | missing_module_keyword importdecls { $2 } + : '{' importdecls { snd $2 } + | missing_module_keyword importdecls { snd $2 } ----------------------------------------------------------------------------- -- The Export List maybeexports :: { (Maybe (Located [LIE RdrName])) } - : '(' exportlist ')' {% ams (sLL $1 $> ()) [mo $1,mc $3] >> + : '(' exportlist ')' {% ams (sLL $1 $> ()) [mop $1,mcp $3] >> return (Just (sLL $1 $> (fromOL $2))) } | {- empty -} { Nothing } @@ -575,10 +582,10 @@ export :: { OrdList (LIE RdrName) } export_subspec :: { Located ([AddAnn],ImpExpSubSpec) } : {- empty -} { sL0 ([],ImpExpAbs) } - | '(' '..' ')' { sLL $1 $> ([mo $1,mc $3,mj AnnDotdot $2] + | '(' '..' ')' { sLL $1 $> ([mop $1,mcp $3,mj AnnDotdot $2] , ImpExpAll) } - | '(' ')' { sLL $1 $> ([mo $1,mc $2],ImpExpList []) } - | '(' qcnames ')' { sLL $1 $> ([mo $1,mc $3],ImpExpList (reverse $2)) } + | '(' ')' { sLL $1 $> ([mop $1,mcp $2],ImpExpList []) } + | '(' qcnames ')' { sLL $1 $> ([mop $1,mcp $3],ImpExpList (reverse $2)) } qcnames :: { [Located RdrName] } -- A reversed list : qcnames ',' qcname_ext {% (aa (head $1) (AnnComma, $2)) >> @@ -587,7 +594,7 @@ qcnames :: { [Located RdrName] } -- A reversed list qcname_ext :: { Located RdrName } -- Variable or data constructor -- or tagged type constructor - : qcname {% ams $1 [mj AnnVal $1] } + : qcname { $1 } | 'type' qcname {% amms (mkTypeImpExp (sLL $1 $> (unLoc $2))) [mj AnnType $1,mj AnnVal $2] } @@ -602,29 +609,39 @@ qcname :: { Located RdrName } -- Variable or data constructor -- import decls can be *empty*, or even just a string of semicolons -- whereas topdecls must contain at least one topdecl. -importdecls :: { [LImportDecl RdrName] } - : importdecls ';' importdecl {% (asl $1 $2 $3) >> - return ($3 : $1) } - | importdecls ';' {% addAnnotation (gl $ head $1) AnnSemi (gl $2) - -- AZ: can $1 above ever be [] due to the {- empty -} production? - >> return $1 } - | importdecl { [$1] } - | {- empty -} { [] } +importdecls :: { ([AddAnn],[LImportDecl RdrName]) } + : importdecls ';' importdecl + {% if null (snd $1) + then return (mj AnnSemi $2:fst $1,$3 : snd $1) + else do + { addAnnotation (gl $ head $ snd $1) + AnnSemi (gl $2) + ; return (fst $1,$3 : snd $1) } } + | importdecls ';' {% if null (snd $1) + then return ((mj AnnSemi $2:fst $1),snd $1) + else do + { addAnnotation (gl $ head $ snd $1) + AnnSemi (gl $2) + ; return $1} } + | importdecl { ([],[$1]) } + | {- empty -} { ([],[]) } importdecl :: { LImportDecl RdrName } : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec {% ams (L (comb4 $1 $6 (snd $7) $8) $ - ImportDecl { ideclName = $6, ideclPkgQual = snd $5 + ImportDecl { ideclSourceSrc = snd $ fst $2 + , ideclName = $6, ideclPkgQual = snd $5 , ideclSource = snd $2, ideclSafe = snd $3 , ideclQualified = snd $4, ideclImplicit = False , ideclAs = unLoc (snd $7) , ideclHiding = unLoc $8 }) - ((mj AnnImport $1 : fst $2 ++ fst $3 ++ fst $4 + ((mj AnnImport $1 : (fst $ fst $2) ++ fst $3 ++ fst $4 ++ fst $5 ++ fst $7)) } -maybe_src :: { ([AddAnn],IsBootInterface) } - : '{-# SOURCE' '#-}' { ([mo $1,mc $2],True) } - | {- empty -} { ([],False) } +maybe_src :: { (([AddAnn],Maybe SourceText),IsBootInterface) } + : '{-# SOURCE' '#-}' { (([mo $1,mc $2],Just (getSOURCE_PRAGs $1)) + ,True) } + | {- empty -} { (([],Nothing),False) } maybe_safe :: { ([AddAnn],Bool) } : 'safe' { ([mj AnnSafe $1],True) } @@ -649,12 +666,12 @@ maybeimpspec :: { Located (Maybe (Bool, Located [LIE RdrName])) } | {- empty -} { noLoc Nothing } impspec :: { Located (Bool, Located [LIE RdrName]) } - : '(' exportlist ')' {% ams (sLL $1 $> (False, - sLL $1 $> $ fromOL $2)) - [mo $1,mc $3] } - | 'hiding' '(' exportlist ')' {% ams (sLL $1 $> (True, - sLL $1 $> $ fromOL $3)) - [mj AnnHiding $1,mo $2,mc $4] } + : '(' exportlist ')' {% ams (sLL $1 $> (False, + sLL $1 $> $ fromOL $2)) + [mop $1,mcp $3] } + | 'hiding' '(' exportlist ')' {% ams (sLL $1 $> (True, + sLL $1 $> $ fromOL $3)) + [mj AnnHiding $1,mop $2,mcp $4] } ----------------------------------------------------------------------------- -- Fixity Declarations @@ -670,9 +687,9 @@ infix :: { Located FixityDirection } | 'infixr' { sL1 $1 InfixR } ops :: { Located (OrdList (Located RdrName)) } - : ops ',' op {% addAnnotation (gl $3) AnnComma (gl $2) >> - return (sLL $1 $> (unitOL $3 `appOL` (unLoc $1)))} - | op { sL1 $1 (unitOL $1) } + : ops ',' op {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >> + return (sLL $1 $> ((unLoc $1) `appOL` unitOL $3))} + | op { sL1 $1 (unitOL $1) } ----------------------------------------------------------------------------- -- Top-Level Declarations @@ -693,38 +710,41 @@ topdecl :: { OrdList (LHsDecl RdrName) } | 'default' '(' comma_types0 ')' {% do { def <- checkValidDefaults $3 ; amsu (sLL $1 $> (DefD def)) [mj AnnDefault $1 - ,mo $2,mc $4] }} - | 'foreign' fdecl {% amsu (sLL $1 $> (unLoc $2)) - [mj AnnForeign $1] } - | '{-# DEPRECATED' deprecations '#-}' { $2 } -- ++AZ++ TODO - | '{-# WARNING' warnings '#-}' { $2 } -- ++AZ++ TODO - | '{-# RULES' rules '#-}' { $2 } -- ++AZ++ TODO - | '{-# VECTORISE' qvar '=' exp '#-}' {% amsu (sLL $1 $> $ VectD (HsVect $2 $4)) + ,mop $2,mcp $4] }} + | 'foreign' fdecl {% amsu (sLL $1 $> (snd $ unLoc $2)) + (mj AnnForeign $1:(fst $ unLoc $2)) } + | '{-# DEPRECATED' deprecations '#-}' {% amsu (sLL $1 $> $ WarningD (Warnings (getDEPRECATED_PRAGs $1) (fromOL $2))) + [mo $1,mc $3] } + | '{-# WARNING' warnings '#-}' {% amsu (sLL $1 $> $ WarningD (Warnings (getWARNING_PRAGs $1) (fromOL $2))) + [mo $1,mc $3] } + | '{-# RULES' rules '#-}' {% amsu (sLL $1 $> $ RuleD (HsRules (getRULES_PRAGs $1) (fromOL $2))) + [mo $1,mc $3] } + | '{-# VECTORISE' qvar '=' exp '#-}' {% amsu (sLL $1 $> $ VectD (HsVect (getVECT_PRAGs $1) $2 $4)) [mo $1,mj AnnEqual $3 ,mc $5] } - | '{-# NOVECTORISE' qvar '#-}' {% amsu (sLL $1 $> $ VectD (HsNoVect $2)) + | '{-# NOVECTORISE' qvar '#-}' {% amsu (sLL $1 $> $ VectD (HsNoVect (getNOVECT_PRAGs $1) $2)) [mo $1,mc $3] } | '{-# VECTORISE' 'type' gtycon '#-}' {% amsu (sLL $1 $> $ - VectD (HsVectTypeIn False $3 Nothing)) + VectD (HsVectTypeIn (getVECT_PRAGs $1) False $3 Nothing)) [mo $1,mj AnnType $2,mc $4] } | '{-# VECTORISE_SCALAR' 'type' gtycon '#-}' {% amsu (sLL $1 $> $ - VectD (HsVectTypeIn True $3 Nothing)) + VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs $1) True $3 Nothing)) [mo $1,mj AnnType $2,mc $4] } | '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}' {% amsu (sLL $1 $> $ - VectD (HsVectTypeIn False $3 (Just $5))) + VectD (HsVectTypeIn (getVECT_PRAGs $1) False $3 (Just $5))) [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] } | '{-# VECTORISE_SCALAR' 'type' gtycon '=' gtycon '#-}' {% amsu (sLL $1 $> $ - VectD (HsVectTypeIn True $3 (Just $5))) + VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs $1) True $3 (Just $5))) [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] } | '{-# VECTORISE' 'class' gtycon '#-}' - {% amsu (sLL $1 $> $ VectD (HsVectClassIn $3)) + {% amsu (sLL $1 $> $ VectD (HsVectClassIn (getVECT_PRAGs $1) $3)) [mo $1,mj AnnClass $2,mc $4] } | annotation { unitOL $1 } | decl_no_th { unLoc $1 } @@ -740,7 +760,7 @@ topdecl :: { OrdList (LHsDecl RdrName) } cl_decl :: { LTyClDecl RdrName } : 'class' tycl_hdr fds where_cls {% amms (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (snd $ unLoc $4)) - (mj AnnClass $1: (fst $ unLoc $4)) } + (mj AnnClass $1:(fst $ unLoc $3)++(fst $ unLoc $4)) } -- Type declarations (toplevel) -- @@ -827,13 +847,13 @@ inst_decl :: { LInstDecl RdrName } :(fst $ unLoc $6)) } overlap_pragma :: { Maybe (Located OverlapMode) } - : '{-# OVERLAPPABLE' '#-}' {% ajs (Just (sLL $1 $> Overlappable)) + : '{-# OVERLAPPABLE' '#-}' {% ajs (Just (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1)))) [mo $1,mc $2] } - | '{-# OVERLAPPING' '#-}' {% ajs (Just (sLL $1 $> Overlapping)) + | '{-# OVERLAPPING' '#-}' {% ajs (Just (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1)))) [mo $1,mc $2] } - | '{-# OVERLAPS' '#-}' {% ajs (Just (sLL $1 $> Overlaps)) + | '{-# OVERLAPS' '#-}' {% ajs (Just (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1)))) [mo $1,mc $2] } - | '{-# INCOHERENT' '#-}' {% ajs (Just (sLL $1 $> Incoherent)) + | '{-# INCOHERENT' '#-}' {% ajs (Just (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1)))) [mo $1,mc $2] } | {- empty -} { Nothing } @@ -847,12 +867,12 @@ where_type_family :: { Located ([AddAnn],FamilyInfo RdrName) } ,ClosedTypeFamily (reverse (snd $ unLoc $2))) } ty_fam_inst_eqn_list :: { Located ([AddAnn],[LTyFamInstEqn RdrName]) } - : '{' ty_fam_inst_eqns '}' { sLL $1 $> ([mo $1,mc $3] + : '{' ty_fam_inst_eqns '}' { sLL $1 $> ([moc $1,mcc $3] ,unLoc $2) } | vocurly ty_fam_inst_eqns close { let L loc _ = $2 in L loc ([],unLoc $2) } - | '{' '..' '}' { sLL $1 $> ([mo $1,mj AnnDotdot $2 - ,mc $3],[]) } + | '{' '..' '}' { sLL $1 $> ([moc $1,mj AnnDotdot $2 + ,mcc $3],[]) } | vocurly '..' close { let L loc _ = $2 in L loc ([mj AnnDotdot $2],[]) } @@ -868,8 +888,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 - {% do { eqn <- mkTyFamInstEqn $1 $3 - ; aa (sLL $1 $> eqn) (AnnEqual, $2) } } + {% do { (eqn,ann) <- mkTyFamInstEqn $1 $3 + ; ams (sLL $1 $> eqn) (mj AnnEqual $2:ann) } } -- Associated type family declarations -- @@ -951,21 +971,19 @@ opt_kind_sig :: { Located (Maybe (LHsKind RdrName)) } -- T Int [a] -- for associated types -- Rather a lot of inlining here, else we get reduce/reduce errors tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) } - : context '=>' type {% return (L (comb2 $1 $2) (unLoc $1)) - >>= \c@(L l _) -> - (addAnnotation l AnnDarrow (gl $2)) - >> (return (sLL $1 $> (Just c, $3))) + : context '=>' type {% addAnnotation (gl $1) AnnDarrow (gl $2) + >> (return (sLL $1 $> (Just $1, $3))) } | type { sL1 $1 (Nothing, $1) } capi_ctype :: { Maybe (Located CType) } capi_ctype : '{-# CTYPE' STRING STRING '#-}' - {% ajs (Just (sLL $1 $> (CType (Just (Header (getSTRING $2))) + {% ajs (Just (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRING $2))) (getSTRING $3)))) [mo $1,mj AnnHeader $2,mj AnnVal $3,mc $4] } | '{-# CTYPE' STRING '#-}' - {% ajs (Just (sLL $1 $> (CType Nothing (getSTRING $2)))) + {% ajs (Just (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRING $2)))) [mo $1,mj AnnVal $2,mc $3] } | { Nothing } @@ -1037,10 +1055,10 @@ vars0 :: { [Located RdrName] } where_decls :: { Located ([AddAnn] , Located (OrdList (LHsDecl RdrName))) } - : 'where' '{' decls '}' { sLL $1 $> ([mj AnnWhere $1,mo $2 - ,mc $4],$3) } - | 'where' vocurly decls close { L (comb2 $1 $3) ([mj AnnWhere $1] - ,$3) } + : 'where' '{' decls '}' { sLL $1 $> ((mj AnnWhere $1:moc $2 + :mcc $4:(fst $ unLoc $3)),sL1 $3 (snd $ unLoc $3)) } + | 'where' vocurly decls close { L (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3)) + ,sL1 $3 (snd $ unLoc $3)) } pattern_synonym_sig :: { LSig RdrName } : 'pattern' con '::' ptype {% do { let (flag, qtvs, prov, req, ty) = snd $ unLoc $4 @@ -1084,21 +1102,27 @@ decl_cls : at_decl_cls { sLL $1 $> (unitOL $1) } ; ams (sLL $1 $> $ unitOL (sLL $1 $> $ SigD (GenericSig l ty))) [mj AnnDefault $1,mj AnnDcolon $3] } } -decls_cls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed - : decls_cls ';' decl_cls {% addAnnotation (oll (unLoc $1)) AnnSemi (gl $2) - >> return (sLL $1 $> ((unLoc $1) `appOL` - unLoc $3)) } - | decls_cls ';' {% addAnnotation (oll (unLoc $1)) AnnSemi (gl $2) +decls_cls :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) } -- Reversed + : decls_cls ';' decl_cls {% if isNilOL (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + , unLoc $3)) + else ams (lastOL (snd $ unLoc $1)) [mj AnnSemi $2] + >> return (sLL $1 $> (fst $ unLoc $1 + ,(snd $ unLoc $1) `appOL` unLoc $3)) } + | decls_cls ';' {% if isNilOL (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + ,snd $ unLoc $1)) + else ams (lastOL (snd $ unLoc $1)) [mj AnnSemi $2] >> return (sLL $1 $> (unLoc $1)) } - | decl_cls { $1 } - | {- empty -} { noLoc nilOL } + | decl_cls { sL1 $1 ([],unLoc $1) } + | {- empty -} { noLoc ([],nilOL) } decllist_cls :: { Located ([AddAnn] , OrdList (LHsDecl RdrName)) } -- Reversed - : '{' decls_cls '}' { sLL $1 $> ([mo $1,mc $3] - ,unLoc $2) } - | vocurly decls_cls close { L (gl $2) ([],unLoc $2) } + : '{' decls_cls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2) + ,snd $ unLoc $2) } + | vocurly decls_cls close { $2 } -- Class body -- @@ -1116,20 +1140,27 @@ decl_inst :: { Located (OrdList (LHsDecl RdrName)) } decl_inst : at_decl_inst { sLL $1 $> (unitOL (sL1 $1 (InstD (unLoc $1)))) } | decl { $1 } -decls_inst :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed - : decls_inst ';' decl_inst {% addAnnotation (oll $ unLoc $1) AnnSemi (gl $2) +decls_inst :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) } -- Reversed + : decls_inst ';' decl_inst {% if isNilOL (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + , unLoc $3)) + else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] >> return - (sLL $1 $> ((unLoc $1) `appOL` unLoc $3)) } - | decls_inst ';' {% addAnnotation (oll $ unLoc $1) AnnSemi (gl $2) + (sLL $1 $> (fst $ unLoc $1 + ,(snd $ unLoc $1) `appOL` unLoc $3)) } + | decls_inst ';' {% if isNilOL (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + ,snd $ unLoc $1)) + else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] >> return (sLL $1 $> (unLoc $1)) } - | decl_inst { $1 } - | {- empty -} { noLoc nilOL } + | decl_inst { sL1 $1 ([],unLoc $1) } + | {- empty -} { noLoc ([],nilOL) } decllist_inst :: { Located ([AddAnn] , OrdList (LHsDecl RdrName)) } -- Reversed - : '{' decls_inst '}' { sLL $1 $> ([mo $1,mc $3],unLoc $2) } - | vocurly decls_inst close { L (gl $2) ([],unLoc $2) } + : '{' decls_inst '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2),snd $ unLoc $2) } + | vocurly decls_inst close { L (gl $2) (unLoc $2) } -- Instance body -- @@ -1143,22 +1174,29 @@ where_inst :: { Located ([AddAnn] -- Declarations in binding groups other than classes and instances -- -decls :: { Located (OrdList (LHsDecl RdrName)) } - : decls ';' decl {% addAnnotation (oll $ unLoc $1) AnnSemi (gl $2) +decls :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) } + : decls ';' decl {% if isNilOL (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + , unLoc $3)) + else do ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] >> return ( let { this = unLoc $3; - rest = unLoc $1; - these = rest `appOL` this } - in rest `seq` this `seq` these `seq` - sLL $1 $> these) } - | decls ';' {% addAnnotation (oll $ unLoc $1) AnnSemi (gl $2) + rest = snd $ unLoc $1; + these = rest `appOL` this } + in rest `seq` this `seq` these `seq` + (sLL $1 $> (fst $ unLoc $1,these))) } + | decls ';' {% if isNilOL (snd $ unLoc $1) + then return (sLL $1 $> ((mj AnnSemi $2:(fst $ unLoc $1) + ,snd $ unLoc $1))) + else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] >> return (sLL $1 $> (unLoc $1)) } - | decl { $1 } - | {- empty -} { noLoc nilOL } + | decl { sL1 $1 ([],unLoc $1) } + | {- empty -} { noLoc ([],nilOL) } decllist :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) } - : '{' decls '}' { sLL $1 $> ([mo $1,mc $3],unLoc $2) } - | vocurly decls close { L (gl $2) ([],unLoc $2) } + : '{' decls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2) + ,snd $ unLoc $2) } + | vocurly decls close { L (gl $2) (fst $ unLoc $2,snd $ unLoc $2) } -- Binding groups other than those of class and instance declarations -- @@ -1169,7 +1207,7 @@ binds :: { Located ([AddAnn],HsLocalBinds RdrName) } ; return (sL1 $1 (fst $ unLoc $1 ,HsValBinds val_binds)) } } - | '{' dbinds '}' { sLL $1 $> ([mo $1,mc $3] + | '{' dbinds '}' { sLL $1 $> ([moc $1,mcc $3] ,HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) } @@ -1189,7 +1227,7 @@ wherebinds :: { Located ([AddAnn],HsLocalBinds RdrName) } ----------------------------------------------------------------------------- -- Transformation Rules -rules :: { OrdList (LHsDecl RdrName) } +rules :: { OrdList (LRuleDecl RdrName) } : rules ';' rule {% addAnnotation (oll $1) AnnSemi (gl $2) >> return ($1 `snocOL` $3) } | rules ';' {% addAnnotation (oll $1) AnnSemi (gl $2) @@ -1197,9 +1235,9 @@ rules :: { OrdList (LHsDecl RdrName) } | rule { unitOL $1 } | {- empty -} { nilOL } -rule :: { LHsDecl RdrName } +rule :: { LRuleDecl RdrName } : STRING rule_activation rule_forall infixexp '=' exp - {%ams (sLL $1 $> $ RuleD (HsRule (L (gl $1) (getSTRING $1)) + {%ams (sLL $1 $> $ (HsRule (L (gl $1) (getSTRING $1)) ((snd $2) `orElse` AlwaysActive) (snd $3) $4 placeHolderNames $6 placeHolderNames)) @@ -1212,11 +1250,11 @@ rule_activation :: { ([AddAnn],Maybe Activation) } rule_explicit_activation :: { ([AddAnn] ,Activation) } -- In brackets - : '[' INTEGER ']' { ([mo $1,mj AnnVal $2,mc $3] + : '[' INTEGER ']' { ([mos $1,mj AnnVal $2,mcs $3] ,ActiveAfter (fromInteger (getINTEGER $2))) } - | '[' '~' INTEGER ']' { ([mo $1,mj AnnTilde $2,mj AnnVal $3,mc $4] + | '[' '~' INTEGER ']' { ([mos $1,mj AnnTilde $2,mj AnnVal $3,mcs $4] ,ActiveBefore (fromInteger (getINTEGER $3))) } - | '[' '~' ']' { ([mo $1,mj AnnTilde $2,mc $3] + | '[' '~' ']' { ([mos $1,mj AnnTilde $2,mcs $3] ,NeverActive) } rule_forall :: { ([AddAnn],[LRuleBndr RdrName]) } @@ -1228,15 +1266,15 @@ rule_var_list :: { [LRuleBndr RdrName] } | rule_var rule_var_list { $1 : $2 } rule_var :: { LRuleBndr RdrName } - : varid { sLL $1 $> (RuleBndr $1) } - | '(' varid '::' ctype ')' {% ams (sLL $1 $> (RuleBndrSig $2 - (mkHsWithBndrs $4))) - [mo $1,mj AnnDcolon $3,mc $5] } + : varid { sLL $1 $> (RuleBndr $1) } + | '(' varid '::' ctype ')' {% ams (sLL $1 $> (RuleBndrSig $2 + (mkHsWithBndrs $4))) + [mop $1,mj AnnDcolon $3,mcp $5] } ----------------------------------------------------------------------------- -- Warnings and deprecations (c.f. rules) -warnings :: { OrdList (LHsDecl RdrName) } +warnings :: { OrdList (LWarnDecl RdrName) } : warnings ';' warning {% addAnnotation (oll $1) AnnSemi (gl $2) >> return ($1 `appOL` $3) } | warnings ';' {% addAnnotation (oll $1) AnnSemi (gl $2) @@ -1245,12 +1283,12 @@ warnings :: { OrdList (LHsDecl RdrName) } | {- empty -} { nilOL } -- SUP: TEMPORARY HACK, not checking for `module Foo' -warning :: { OrdList (LHsDecl RdrName) } +warning :: { OrdList (LWarnDecl RdrName) } : namelist strings - { toOL [ sLL $1 $> $ WarningD (Warning n (WarningTxt $ snd $ unLoc $2)) - | n <- unLoc $1 ] } + {% amsu (sLL $1 $> (Warning (unLoc $1) (WarningTxt (noLoc "") $ snd $ unLoc $2))) + (fst $ unLoc $2) } -deprecations :: { OrdList (LHsDecl RdrName) } +deprecations :: { OrdList (LWarnDecl RdrName) } : deprecations ';' deprecation {% addAnnotation (oll $1) AnnSemi (gl $2) >> return ($1 `appOL` $3) } @@ -1260,17 +1298,17 @@ deprecations :: { OrdList (LHsDecl RdrName) } | {- empty -} { nilOL } -- SUP: TEMPORARY HACK, not checking for `module Foo' -deprecation :: { OrdList (LHsDecl RdrName) } +deprecation :: { OrdList (LWarnDecl RdrName) } : namelist strings - { toOL [ sLL $1 $> $ WarningD (Warning n (DeprecatedTxt $ snd $ unLoc $2)) - | n <- unLoc $1 ] } + {% amsu (sLL $1 $> $ (Warning (unLoc $1) (DeprecatedTxt (noLoc "") $ snd $ unLoc $2))) + (fst $ unLoc $2) } strings :: { Located ([AddAnn],[Located FastString]) } : STRING { sL1 $1 ([],[L (gl $1) (getSTRING $1)]) } - | '[' stringlist ']' { sLL $1 $> $ ([mo $1,mc $3],fromOL (unLoc $2)) } + | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) } stringlist :: { Located (OrdList (Located FastString)) } - : stringlist ',' STRING {% addAnnotation (gl $3) AnnComma (gl $2) >> + : stringlist ',' STRING {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >> return (sLL $1 $> (unLoc $1 `snocOL` (L (gl $3) (getSTRING $3)))) } | STRING { sLL $1 $> (unitOL (L (gl $1) (getSTRING $1))) } @@ -1279,14 +1317,17 @@ stringlist :: { Located (OrdList (Located FastString)) } -- Annotations annotation :: { LHsDecl RdrName } : '{-# ANN' name_var aexp '#-}' {% ams (sLL $1 $> (AnnD $ HsAnnotation - (ValueAnnProvenance (unLoc $2)) $3)) + (getANN_PRAGs $1) + (ValueAnnProvenance $2) $3)) [mo $1,mc $4] } | '{-# ANN' 'type' tycon aexp '#-}' {% ams (sLL $1 $> (AnnD $ HsAnnotation - (TypeAnnProvenance (unLoc $3)) $4)) + (getANN_PRAGs $1) + (TypeAnnProvenance $3) $4)) [mo $1,mj AnnType $2,mc $5] } | '{-# ANN' 'module' aexp '#-}' {% ams (sLL $1 $> (AnnD $ HsAnnotation + (getANN_PRAGs $1) ModuleAnnProvenance $3)) [mo $1,mj AnnModule $2,mc $4] } @@ -1294,16 +1335,16 @@ annotation :: { LHsDecl RdrName } ----------------------------------------------------------------------------- -- Foreign import and export declarations -fdecl :: { LHsDecl RdrName } +fdecl :: { Located ([AddAnn],HsDecl RdrName) } fdecl : 'import' callconv safety fspec - {% mkImport $2 $3 (snd $ unLoc $4) >>= \i -> - ams (sLL $1 $> i) (mj AnnImport $1 : (fst $ unLoc $4)) } + {% mkImport $2 $3 (snd $ unLoc $4) >>= \i -> + return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $4),i)) } | 'import' callconv fspec - {% do { d <- mkImport $2 (noLoc PlaySafe) (snd $ unLoc $3); - ams (sLL $1 $> d) (mj AnnImport $1 : (fst $ unLoc $3)) } } + {% do { d <- mkImport $2 (noLoc PlaySafe) (snd $ unLoc $3); + return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $3),d)) }} | 'export' callconv fspec - {% mkExport $2 (snd $ unLoc $3) >>= \i -> - ams (sLL $1 $> i) (mj AnnExport $1 : (fst $ unLoc $3)) } + {% mkExport $2 (snd $ unLoc $3) >>= \i -> + return (sLL $1 $> (mj AnnExport $1 : (fst $ unLoc $3),i) ) } callconv :: { Located CCallConv } : 'stdcall' { sLL $1 $> StdCallConv } @@ -1349,9 +1390,10 @@ sigtypedoc :: { LHsType RdrName } -- Always a HsForAllTy -- Wrap an Implicit forall if there isn't one there already sig_vars :: { Located [Located RdrName] } -- Returned in reversed order - : sig_vars ',' var {% addAnnotation (gl $3) AnnComma (gl $2) - >> return (sLL $1 $> ($3 : unLoc $1)) } - | var { sL1 $1 [$1] } + : sig_vars ',' var {% addAnnotation (gl $ head $ unLoc $1) + AnnComma (gl $2) + >> return (sLL $1 $> ($3 : unLoc $1)) } + | var { sL1 $1 [$1] } sigtypes1 :: { (OrdList (LHsType RdrName)) } -- Always HsForAllTys : sigtype { unitOL $1 } @@ -1362,11 +1404,16 @@ sigtypes1 :: { (OrdList (LHsType RdrName)) } -- Always HsForAllTys -- Types strict_mark :: { Located ([AddAnn],HsBang) } - : '!' { sL1 $1 ([], HsSrcBang Nothing True) } - | '{-# UNPACK' '#-}' { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just True) False) } - | '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just False) False) } - | '{-# UNPACK' '#-}' '!' { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just True) True) } - | '{-# NOUNPACK' '#-}' '!' { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just False) True) } + : '!' { sL1 $1 ([mj AnnBang $1] + ,HsSrcBang Nothing Nothing True) } + | '{-# UNPACK' '#-}' { sLL $1 $> ([mo $1,mc $2] + ,HsSrcBang (Just $ getUNPACK_PRAGs $1) (Just True) False) } + | '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1,mc $2] + ,HsSrcBang (Just $ getNOUNPACK_PRAGs $1) (Just False) False) } + | '{-# UNPACK' '#-}' '!' { sLL $1 $> ([mo $1,mc $2,mj AnnBang $3] + ,HsSrcBang (Just $ getUNPACK_PRAGs $1) (Just True) True) } + | '{-# NOUNPACK' '#-}' '!' { sLL $1 $> ([mo $1,mc $2,mj AnnBang $3] + ,HsSrcBang (Just $ getNOUNPACK_PRAGs $1) (Just False) True) } -- Although UNPACK with no '!' is illegal, we get a -- better error message if we parse it here @@ -1376,12 +1423,12 @@ ctype :: { LHsType RdrName } ams (sLL $1 $> $ mkExplicitHsForAllTy $2 (noLoc []) $4) [mj AnnForall $1,mj AnnDot $3] } - | context '=>' ctype {% ams (sLL $1 $> $ mkQualifiedHsForAllTy - $1 $3) - [mj AnnDarrow $2] } - | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3)) - [mj AnnVal $1,mj AnnDcolon $2] } - | type { $1 } + | context '=>' ctype {% addAnnotation (gl $1) AnnDarrow (gl $2) + >> return (sLL $1 $> $ + mkQualifiedHsForAllTy $1 $3) } + | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3)) + [mj AnnVal $1,mj AnnDcolon $2] } + | type { $1 } ---------------------- -- Notes for 'ctypedoc' @@ -1399,11 +1446,12 @@ ctypedoc :: { LHsType RdrName } ams (sLL $1 $> $ mkExplicitHsForAllTy $2 (noLoc []) $4) [mj AnnForall $1,mj AnnDot $3] } - | context '=>' ctypedoc {% ams (sLL $1 $> $ mkQualifiedHsForAllTy $1 $3) - [mj AnnDarrow $2] } - | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3)) - [mj AnnDcolon $2] } - | typedoc { $1 } + | context '=>' ctypedoc {% addAnnotation (gl $1) AnnDarrow (gl $2) + >> return (sLL $1 $> $ + mkQualifiedHsForAllTy $1 $3) } + | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3)) + [mj AnnDcolon $2] } + | typedoc { $1 } ---------------------- -- Notes for 'context' @@ -1420,7 +1468,12 @@ context :: { LHsContext RdrName } : btype '~' btype {% amms (checkContext (sLL $1 $> $ HsEqTy $1 $3)) [mj AnnTilde $2] } - | btype {% checkContext $1 } + | btype {% do { ctx <- checkContext $1 + ; if null (unLoc ctx) + then addAnnotation (gl $1) AnnUnit (gl $1) + else return () + ; return ctx + } } type :: { LHsType RdrName } : btype { $1 } @@ -1469,22 +1522,24 @@ atype :: { LHsType RdrName } | '{' fielddecls '}' {% amms (checkRecordSyntax (sLL $1 $> $ HsRecTy $2)) -- Constructor sigs only - [mo $1,mc $3] } + [moc $1,mcc $3] } | '(' ')' {% ams (sLL $1 $> $ HsTupleTy HsBoxedOrConstraintTuple []) - [mo $1,mc $2] } - | '(' ctype ',' comma_types1 ')' {% ams (sLL $1 $> $ HsTupleTy + [mop $1,mcp $2] } + | '(' ctype ',' comma_types1 ')' {% addAnnotation (gl $2) AnnComma + (gl $3) >> + ams (sLL $1 $> $ HsTupleTy HsBoxedOrConstraintTuple ($2 : $4)) - [mo $1,mj AnnComma $3,mc $5] } + [mop $1,mcp $5] } | '(#' '#)' {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple []) [mo $1,mc $2] } | '(#' comma_types1 '#)' {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple $2) [mo $1,mc $3] } - | '[' ctype ']' {% ams (sLL $1 $> $ HsListTy $2) [mo $1,mc $3] } + | '[' ctype ']' {% ams (sLL $1 $> $ HsListTy $2) [mos $1,mcs $3] } | '[:' ctype ':]' {% ams (sLL $1 $> $ HsPArrTy $2) [mo $1,mc $3] } - | '(' ctype ')' {% ams (sLL $1 $> $ HsParTy $2) [mo $1,mc $3] } + | '(' ctype ')' {% ams (sLL $1 $> $ HsParTy $2) [mop $1,mcp $3] } | '(' ctype '::' kind ')' {% ams (sLL $1 $> $ HsKindSig $2 $4) - [mo $1,mj AnnDcolon $3,mc $5] } + [mop $1,mj AnnDcolon $3,mcp $5] } | quasiquote { sL1 $1 (HsQuasiQuoteTy (unLoc $1)) } | '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTy $2) [mo $1,mc $3] } @@ -1493,23 +1548,28 @@ atype :: { LHsType RdrName } -- see Note [Promotion] for the followings | SIMPLEQUOTE qcon { sLL $1 $> $ HsTyVar $ unLoc $2 } | SIMPLEQUOTE '(' ctype ',' comma_types1 ')' - {% ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5)) - [mo $2,mj AnnComma $4,mc $6] } + {% addAnnotation (gl $3) AnnComma (gl $4) >> + ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5)) + [mop $2,mcp $6] } | SIMPLEQUOTE '[' comma_types0 ']' {% ams (sLL $1 $> $ HsExplicitListTy placeHolderKind $3) - [mo $2,mc $4] } + [mos $2,mcs $4] } | SIMPLEQUOTE var { sLL $1 $> $ HsTyVar $ unLoc $2 } -- Two or more [ty, ty, ty] must be a promoted list type, just as -- if you had written '[ty, ty, ty] -- (One means a list type, zero means the list type constructor, -- so you have to quote those.) - | '[' ctype ',' comma_types1 ']' {% ams (sLL $1 $> $ HsExplicitListTy + | '[' ctype ',' comma_types1 ']' {% addAnnotation (gl $2) AnnComma + (gl $3) >> + ams (sLL $1 $> $ HsExplicitListTy placeHolderKind ($2 : $4)) - [mo $1, mj AnnComma $3,mc $5] } - | INTEGER { sLL $1 $> $ HsTyLit $ HsNumTy $ getINTEGER $1 } - | STRING { sLL $1 $> $ HsTyLit $ HsStrTy $ getSTRING $1 } - | '_' { sL1 $1 $ HsWildcardTy } + [mos $1,mcs $5] } + | INTEGER { sLL $1 $> $ HsTyLit $ HsNumTy (getINTEGERs $1) + (getINTEGER $1) } + | STRING { sLL $1 $> $ HsTyLit $ HsStrTy (getSTRINGs $1) + (getSTRING $1) } + | '_' { sL1 $1 $ HsWildcardTy } -- An inst_type is what occurs in the head of an instance decl -- e.g. (Foo a, Gaz b) => Wibble a b @@ -1539,28 +1599,28 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] } tv_bndr :: { LHsTyVarBndr RdrName } : tyvar { sL1 $1 (UserTyVar (unLoc $1)) } - | '(' tyvar '::' kind ')' {% ams (sLL $1 $> (KindedTyVar (unLoc $2) $4)) - [mo $1,mj AnnDcolon $3 - ,mc $5] } + | '(' tyvar '::' kind ')' {% ams (sLL $1 $> (KindedTyVar $2 $4)) + [mop $1,mj AnnDcolon $3 + ,mcp $5] } -fds :: { Located [Located (FunDep RdrName)] } - : {- empty -} { noLoc [] } - | '|' fds1 {% ams (sLL $1 $> (reverse (unLoc $2))) - [mj AnnVbar $1] } +fds :: { Located ([AddAnn],[Located (FunDep (Located RdrName))]) } + : {- empty -} { noLoc ([],[]) } + | '|' fds1 { (sLL $1 $> ([mj AnnVbar $1] + ,reverse (unLoc $2))) } -fds1 :: { Located [Located (FunDep RdrName)] } - : fds1 ',' fd {% addAnnotation (gl $3) AnnComma (gl $2) - >> return (sLL $1 $> ($3 : unLoc $1)) } - | fd { sL1 $1 [$1] } +fds1 :: { Located [Located (FunDep (Located RdrName))] } + : fds1 ',' fd {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) + >> return (sLL $1 $> ($3 : unLoc $1)) } + | fd { sL1 $1 [$1] } -fd :: { Located (FunDep RdrName) } +fd :: { Located (FunDep (Located RdrName)) } : varids0 '->' varids0 {% ams (L (comb3 $1 $2 $3) (reverse (unLoc $1), reverse (unLoc $3))) [mj AnnRarrow $2] } -varids0 :: { Located [RdrName] } +varids0 :: { Located [Located RdrName] } : {- empty -} { noLoc [] } - | varids0 tyvar { sLL $1 $> (unLoc $2 : unLoc $1) } + | varids0 tyvar { sLL $1 $> ($2 : unLoc $1) } ----------------------------------------------------------------------------- -- Kinds @@ -1577,19 +1637,20 @@ bkind :: { LHsKind RdrName } akind :: { LHsKind RdrName } : '*' { sL1 $1 $ HsTyVar (nameRdrName liftedTypeKindTyConName) } | '(' kind ')' {% ams (sLL $1 $> $ HsParTy $2) - [mo $1,mc $3] } + [mop $1,mcp $3] } | pkind { $1 } | tyvar { sL1 $1 $ HsTyVar (unLoc $1) } pkind :: { LHsKind RdrName } -- promoted type, see Note [Promotion] : qtycon { sL1 $1 $ HsTyVar $ unLoc $1 } | '(' ')' {% ams (sLL $1 $> $ HsTyVar $ getRdrName unitTyCon) - [mo $1,mc $2] } - | '(' kind ',' comma_kinds1 ')' {% ams (sLL $1 $> $ HsTupleTy HsBoxedTuple - ( $2 : $4)) - [mo $1,mj AnnComma $3,mc $5] } + [mop $1,mcp $2] } + | '(' kind ',' comma_kinds1 ')' + {% addAnnotation (gl $2) AnnComma (gl $3) >> + ams (sLL $1 $> $ HsTupleTy HsBoxedTuple ( $2 : $4)) + [mop $1,mcp $5] } | '[' kind ']' {% ams (sLL $1 $> $ HsListTy $2) - [mo $1,mc $3] } + [mos $1,mcs $3] } comma_kinds1 :: { [LHsKind RdrName] } : kind { [$1] } @@ -1631,8 +1692,8 @@ gadt_constrlist :: { Located ([AddAnn] ,[LConDecl RdrName]) } -- Returned in order : 'where' '{' gadt_constrs '}' { L (comb2 $1 $3) ([mj AnnWhere $1 - ,mo $2 - ,mc $4] + ,moc $2 + ,mcc $4] , unLoc $3) } | 'where' vocurly gadt_constrs close { L (comb2 $1 $3) ([mj AnnWhere $1] @@ -1661,10 +1722,10 @@ gadt_constr :: { LConDecl RdrName } -- Deprecated syntax for GADT record declarations | oqtycon '{' fielddecls '}' '::' sigtype - {% do { cd <- mkDeprecatedGadtRecordDecl (comb2 $1 $6) $1 $3 $6 + {% do { cd <- mkDeprecatedGadtRecordDecl (comb2 $1 $6) $1 (noLoc $3) $6 ; cd' <- checkRecordSyntax cd ; ams (L (comb2 $1 $6) (unLoc cd')) - [mo $2,mc $4,mj AnnDcolon $5] } } + [moc $2,mcc $4,mj AnnDcolon $5] } } constrs :: { Located ([AddAnn],[LConDecl RdrName]) } : maybe_docnext '=' constrs1 { L (comb2 $2 $3) ([mj AnnEqual $2] @@ -1672,7 +1733,7 @@ constrs :: { Located ([AddAnn],[LConDecl RdrName]) } constrs1 :: { Located [LConDecl RdrName] } : constrs1 maybe_docnext '|' maybe_docprev constr - {% addAnnotation (gl $5) AnnVbar (gl $3) + {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $3) >> return (sLL $1 $> (addConDoc $5 $2 : addConDocFirst (unLoc $1) $4)) } | constr { sL1 $1 [$1] } @@ -1733,10 +1794,10 @@ deriving :: { Located (Maybe (Located [LHsType RdrName])) } [L loc (HsTyVar tv)])))) [mj AnnDeriving $1] } | 'deriving' '(' ')' {% aljs (sLL $1 $> (Just (sLL $1 $> []))) - [mj AnnDeriving $1,mo $2,mc $3] } + [mj AnnDeriving $1,mop $2,mcp $3] } | 'deriving' '(' inst_types1 ')' {% aljs (sLL $1 $> (Just (sLL $1 $> $3))) - [mj AnnDeriving $1,mo $2,mc $4] } + [mj AnnDeriving $1,mop $2,mcp $4] } -- Glasgow extension: allow partial -- applications in derivings @@ -1777,7 +1838,7 @@ docdecld :: { LDocDecl } decl_no_th :: { Located (OrdList (LHsDecl RdrName)) } : sigdecl { $1 } - | '!' aexp rhs {% do { let { e = sLL $1 $> (SectionR (sLL $1 $> (HsVar bang_RDR)) $2) }; + | '!' aexp rhs {% do { let { e = sLL $1 $> (SectionR (sL1 $1 (HsVar bang_RDR)) $2) }; pat <- checkPattern empty e; _ <- ams (sLL $1 $> ()) (mj AnnBang $1:(fst $ unLoc $3)); @@ -1837,8 +1898,9 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) } | var ',' sig_vars '::' sigtypedoc {% do { ty <- checkPartialTypeSignature $5 ; let sig = TypeSig ($1 : reverse (unLoc $3)) ty PlaceHolder + ; addAnnotation (gl $1) AnnComma (gl $2) ; ams (sLL $1 $> $ toOL [ sLL $1 $> $ SigD sig ]) - [mj AnnComma $2,mj AnnDcolon $4] } } + [mj AnnDcolon $4] } } | infix prec ops {% ams (sLL $1 $> $ toOL [ sLL $1 $> $ SigD @@ -1850,29 +1912,33 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) } | '{-# INLINE' activation qvar '#-}' {% ams (sLL $1 $> $ unitOL (sLL $1 $> $ SigD (InlineSig $3 - (mkInlinePragma (getINLINE $1) (snd $2))))) - (mo $1:mc $4:fst $2) } + (mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1) + (snd $2))))) + ((mo $1:fst $2) ++ [mc $4]) } | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}' {% ams ( - let inl_prag = mkInlinePragma (EmptyInlineSpec, FunLike) (snd $2) + let inl_prag = mkInlinePragma (getSPEC_PRAGs $1) + (EmptyInlineSpec, FunLike) (snd $2) in sLL $1 $> $ toOL [ sLL $1 $> $ SigD (SpecSig $3 (fromOL $5) inl_prag) ]) (mo $1:mj AnnDcolon $4:mc $6:(fst $2)) } | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}' {% ams (sLL $1 $> $ toOL [ sLL $1 $> $ SigD (SpecSig $3 (fromOL $5) - (mkInlinePragma (getSPEC_INLINE $1) (snd $2))) ]) + (mkInlinePragma (getSPEC_INLINE_PRAGs $1) + (getSPEC_INLINE $1) (snd $2))) ]) (mo $1:mj AnnDcolon $4:mc $6:(fst $2)) } | '{-# SPECIALISE' 'instance' inst_type '#-}' - {% ams (sLL $1 $> $ unitOL (sLL $1 $> $ SigD (SpecInstSig $3))) + {% ams (sLL $1 $> $ unitOL (sLL $1 $> + $ SigD (SpecInstSig (getSPEC_PRAGs $1) $3))) [mo $1,mj AnnInstance $2,mc $4] } -- AZ TODO: Do we need locations in the name_formula_opt? -- A minimal complete definition | '{-# MINIMAL' name_boolformula_opt '#-}' - {% ams (sLL $1 $> $ unitOL (sLL $1 $> $ SigD (MinimalSig (snd $2)))) + {% ams (sLL $1 $> $ unitOL (sLL $1 $> $ SigD (MinimalSig (getMINIMAL_PRAGs $1) (snd $2)))) (mo $1:mc $3:fst $2) } activation :: { ([AddAnn],Maybe Activation) } @@ -1880,10 +1946,10 @@ activation :: { ([AddAnn],Maybe Activation) } | explicit_activation { (fst $1,Just (snd $1)) } explicit_activation :: { ([AddAnn],Activation) } -- In brackets - : '[' INTEGER ']' { ([mj AnnOpen $1,mj AnnVal $2,mj AnnClose $3] + : '[' INTEGER ']' { ([mj AnnOpenS $1,mj AnnVal $2,mj AnnCloseS $3] ,ActiveAfter (fromInteger (getINTEGER $2))) } - | '[' '~' INTEGER ']' { ([mj AnnOpen $1,mj AnnTilde $2,mj AnnVal $3 - ,mj AnnClose $4] + | '[' '~' INTEGER ']' { ([mj AnnOpenS $1,mj AnnTilde $2,mj AnnVal $3 + ,mj AnnCloseS $4] ,ActiveBefore (fromInteger (getINTEGER $3))) } ----------------------------------------------------------------------------- @@ -1917,14 +1983,18 @@ exp :: { LHsExpr RdrName } | infixexp { $1 } infixexp :: { LHsExpr RdrName } - : exp10 { $1 } - | infixexp qop exp10 { sLL $1 $> (OpApp $1 $2 placeHolderFixity $3) } + : exp10 { $1 } + | infixexp qop exp10 {% ams (sLL $1 $> + (OpApp $1 $2 placeHolderFixity $3)) + [mj AnnVal $2] } + -- AnnVal annotation for NPlusKPat, which discards the operator + exp10 :: { LHsExpr RdrName } : '\\' apat apats opt_asig '->' exp {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource - [sLL $1 $> $ Match ($2:$3) (snd $4) (unguardedGRHSs $6)])) - [mj AnnLam $1,mj AnnRarrow $5] } + [sLL $1 $> $ Match Nothing ($2:$3) (snd $4) (unguardedGRHSs $6)])) + (mj AnnLam $1:mj AnnRarrow $5:(fst $4)) } | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4) (mj AnnLet $1:mj AnnIn $3 :(fst $ unLoc $2)) } @@ -1958,18 +2028,11 @@ exp10 :: { LHsExpr RdrName } (mkHsDo MDoExpr (snd $ unLoc $2))) (mj AnnMdo $1:(fst $ unLoc $2)) } - | scc_annot exp {% do { on <- extension sccProfilingOn - ; ams (sLL $1 $> $ if on - then HsSCC (snd $ unLoc $1) $2 - else HsPar $2) - (fst $ unLoc $1) } } + | scc_annot exp {% ams (sLL $1 $> $ HsSCC (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) + (fst $ fst $ unLoc $1) } - | hpc_annot exp {% do { on <- extension hpcEnabled - ; ams (sLL $1 $> $ if on - then HsTickPragma - (snd $ unLoc $1) $2 - else HsPar $2) - (fst $ unLoc $1) } } + | hpc_annot exp {% ams (sLL $1 $> $ HsTickPragma (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) + (fst $ fst $ unLoc $1) } | 'proc' aexp '->' exp {% checkPattern empty $2 >>= \ p -> @@ -1979,7 +2042,7 @@ exp10 :: { LHsExpr RdrName } -- TODO: is LL right here? [mj AnnProc $1,mj AnnRarrow $3] } - | '{-# CORE' STRING '#-}' exp {% ams (sLL $1 $> $ HsCoreAnn (getSTRING $2) $4) + | '{-# CORE' STRING '#-}' exp {% ams (sLL $1 $> $ HsCoreAnn (getCORE_PRAGs $1) (getSTRING $2) $4) [mo $1,mj AnnVal $2 ,mc $3] } -- hdaume: core annotation @@ -2020,22 +2083,23 @@ optSemi :: { ([Located a],Bool) } : ';' { ([$1],True) } | {- empty -} { ([],False) } -scc_annot :: { Located ([AddAnn],FastString) } +scc_annot :: { Located (([AddAnn],SourceText),FastString) } : '{-# SCC' STRING '#-}' {% do scc <- getSCC $2 ; return $ sLL $1 $> - ([mo $1,mj AnnVal $2 - ,mc $3],scc) } - | '{-# SCC' VARID '#-}' { sLL $1 $> ([mo $1,mj AnnVal $2 - ,mc $3] + (([mo $1,mj AnnValStr $2 + ,mc $3],getSCC_PRAGs $1),scc) } + | '{-# SCC' VARID '#-}' { sLL $1 $> (([mo $1,mj AnnVal $2 + ,mc $3],getSCC_PRAGs $1) ,(getVARID $2)) } -hpc_annot :: { Located ([AddAnn],(FastString,(Int,Int),(Int,Int))) } +hpc_annot :: { Located (([AddAnn],SourceText),(FastString,(Int,Int),(Int,Int))) } : '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' - { sLL $1 $> $ ([mo $1,mj AnnVal $2 + { sLL $1 $> $ (([mo $1,mj AnnVal $2 ,mj AnnVal $3,mj AnnColon $4 ,mj AnnVal $5,mj AnnMinus $6 ,mj AnnVal $7,mj AnnColon $8 - ,mj AnnVal $9,mc $10] + ,mj AnnVal $9,mc $10], + getGENERATED_PRAGs $1) ,(getSTRING $2 ,( fromInteger $ getINTEGER $3 , fromInteger $ getINTEGER $5 @@ -2048,7 +2112,8 @@ hpc_annot :: { Located ([AddAnn],(FastString,(Int,Int),(Int,Int))) } fexp :: { LHsExpr RdrName } : fexp aexp { sLL $1 $> $ HsApp $1 $2 } - | 'static' aexp { sLL $1 $> $ HsStatic $2 } + | 'static' aexp {% ams (sLL $1 $> $ HsStatic $2) + [mj AnnStatic $1] } | aexp { $1 } aexp :: { LHsExpr RdrName } @@ -2059,7 +2124,7 @@ aexp :: { LHsExpr RdrName } aexp1 :: { LHsExpr RdrName } : aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) (snd $3) - ; _ <- ams (sLL $1 $> ()) (mo $2:mc $4:(fst $3)) + ; _ <- ams (sLL $1 $> ()) (moc $2:mcc $4:(fst $3)) ; checkRecordSyntax (sLL $1 $> r) }} | aexp2 { $1 } @@ -2080,9 +2145,9 @@ aexp2 :: { LHsExpr RdrName } -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't -- correct Haskell (you'd have to write '((+ 3), (4 -))') -- but the less cluttered version fell out of having texps. - | '(' texp ')' {% ams (sLL $1 $> (HsPar $2)) [mo $1,mc $3] } + | '(' texp ')' {% ams (sLL $1 $> (HsPar $2)) [mop $1,mcp $3] } | '(' tup_exprs ')' {% ams (sLL $1 $> (ExplicitTuple $2 Boxed)) - [mo $1,mc $3] } + [mop $1,mcp $3] } | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple [L (gl $2) (Present $2)] Unboxed)) @@ -2090,7 +2155,7 @@ aexp2 :: { LHsExpr RdrName } | '(#' tup_exprs '#)' {% ams (sLL $1 $> (ExplicitTuple $2 Unboxed)) [mo $1,mc $3] } - | '[' list ']' {% ams (sLL $1 $> (snd $2)) (mo $1:mc $3:(fst $2)) } + | '[' list ']' {% ams (sLL $1 $> (snd $2)) (mos $1:mcs $3:(fst $2)) } | '[:' parr ':]' {% ams (sLL $1 $> (snd $2)) (mo $1:mc $3:(fst $2)) } | '_' { sL1 $1 EWildPat } @@ -2139,8 +2204,8 @@ acmd :: { LHsCmdTop RdrName } placeHolderType placeHolderType []) } cvtopbody :: { ([AddAnn],[LHsDecl RdrName]) } - : '{' cvtopdecls0 '}' { ([mj AnnOpen $1 - ,mj AnnClose $3],$2) } + : '{' cvtopdecls0 '}' { ([mj AnnOpenC $1 + ,mj AnnCloseC $3],$2) } | vocurly cvtopdecls0 close { ([],$2) } cvtopdecls0 :: { [LHsDecl RdrName] } @@ -2265,7 +2330,7 @@ squals :: { Located [LStmt RdrName (LHsExpr RdrName)] } -- In reverse order, b {% addAnnotation (gl $ last $ unLoc $1) AnnComma (gl $2) >> return (sLL $1 $> [L (getLoc $3) ((unLoc $3) (reverse (unLoc $1)))]) } | squals ',' qual - {% addAnnotation (gl $ last $ unLoc $1) AnnComma (gl $2) >> + {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> return (sLL $1 $> ($3 : unLoc $1)) } | transformqual { sLL $1 $> [L (getLoc $1) ((unLoc $1) [])] } | qual { sL1 $1 [$1] } @@ -2326,37 +2391,50 @@ guardquals :: { Located [LStmt RdrName (LHsExpr RdrName)] } : guardquals1 { L (getLoc $1) (reverse (unLoc $1)) } guardquals1 :: { Located [LStmt RdrName (LHsExpr RdrName)] } - : guardquals1 ',' qual {% ams (sLL $1 $> ($3 : unLoc $1)) [mj AnnComma $2] } + : guardquals1 ',' qual {% addAnnotation (gl $ last $ unLoc $1) AnnComma + (gl $2) >> + return (sLL $1 $> ($3 : unLoc $1)) } | qual { sL1 $1 [$1] } ----------------------------------------------------------------------------- -- Case alternatives altslist :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) } - : '{' alts '}' { sLL $1 $> ([mo $1,mc $3],(reverse (unLoc $2))) } - - | vocurly alts close { L (getLoc $2) ([],(reverse (unLoc $2))) } - | '{' '}' { noLoc ([mo $1,mc $2],[]) } + : '{' alts '}' { sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) + ,(reverse (snd $ unLoc $2))) } + | vocurly alts close { L (getLoc $2) (fst $ unLoc $2 + ,(reverse (snd $ unLoc $2))) } + | '{' '}' { noLoc ([moc $1,mcc $2],[]) } | vocurly close { noLoc ([],[]) } -alts :: { Located [LMatch RdrName (LHsExpr RdrName)] } - : alts1 { sL1 $1 (unLoc $1) } - | ';' alts {% ams (sLL $1 $> (unLoc $2)) - [mj AnnSemi (head $ unLoc $2)] } - -alts1 :: { Located [LMatch RdrName (LHsExpr RdrName)] } - : alts1 ';' alt {% ams (sLL $1 $> ($3 : unLoc $1)) [mj AnnSemi $3] } - | alts1 ';' {% ams (sLL $1 $> (unLoc $1)) - [mj AnnSemi (last $ unLoc $1)] } - | alt { sL1 $1 [$1] } +alts :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) } + : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)) + ,snd $ unLoc $2) } + +alts1 :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) } + : alts1 ';' alt {% if null (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + ,[$3])) + else (ams (head $ snd $ unLoc $1) + (mj AnnSemi $2:(fst $ unLoc $1)) + >> return (sLL $1 $> ([],$3 : (snd $ unLoc $1))) ) } + | alts1 ';' {% if null (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + ,snd $ unLoc $1)) + else (ams (head $ snd $ unLoc $1) + (mj AnnSemi $2:(fst $ unLoc $1)) + >> return (sLL $1 $> ([],snd $ unLoc $1))) } + | alt { sL1 $1 ([],[$1]) } alt :: { LMatch RdrName (LHsExpr RdrName) } - : pat opt_sig alt_rhs { sLL $1 $> (Match [$1] (snd $2) (unLoc $3)) } + : pat opt_sig alt_rhs {%ams (sLL $1 $> (Match Nothing [$1] (snd $2) + (snd $ unLoc $3))) + (fst $ unLoc $3)} -alt_rhs :: { Located (GRHSs RdrName (LHsExpr RdrName)) } - : ralt wherebinds {% ams (sLL $1 $> (GRHSs (unLoc $1) - (snd $ unLoc $2))) - (fst $ unLoc $2) } +alt_rhs :: { Located ([AddAnn],GRHSs RdrName (LHsExpr RdrName)) } + : ralt wherebinds { sLL $1 $> (fst $ unLoc $2, + GRHSs (unLoc $1) (snd $ unLoc $2)) } ralt :: { Located [LGRHS RdrName (LHsExpr RdrName)] } : '->' exp {% ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2)) @@ -2379,7 +2457,7 @@ gdpatssemi :: { Located [LGRHS RdrName (LHsExpr RdrName)] } -- generate the open brace in addition to the vertical bar in the lexer, and -- we don't need it. ifgdpats :: { Located ([AddAnn],[LGRHS RdrName (LHsExpr RdrName)]) } - : '{' gdpatssemi '}' { sLL $1 $> ([mo $1,mc $3],unLoc $2) } + : '{' gdpatssemi '}' { sLL $1 $> ([moc $1,mcc $3],unLoc $2) } | gdpatssemi close { sL1 $1 ([],unLoc $1) } gdpat :: { LGRHS RdrName (LHsExpr RdrName) } @@ -2420,10 +2498,10 @@ apats :: { [LPat RdrName] } -- Statement sequences stmtlist :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) } - : '{' stmts '}' { sLL $1 $> ((mo $1:mc $3:(fst $ unLoc $2)) - ,(snd $ unLoc $2)) } + : '{' stmts '}' { sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) + ,(reverse $ snd $ unLoc $2)) } -- AZ:performance of reverse? | vocurly stmts close { L (gl $2) (fst $ unLoc $2 - ,snd $ unLoc $2) } + ,reverse $ snd $ unLoc $2) } -- do { ;; s ; s ; ; s ;; } -- The last Stmt should be an expression, but that's hard to enforce @@ -2431,21 +2509,24 @@ stmtlist :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) } -- So we use BodyStmts throughout, and switch the last one over -- in ParseUtils.checkDo instead -- AZ: TODO check that we can retrieve multiple semis. -stmts :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) } - : stmt stmts_help { sLL $1 $> (fst $ unLoc $2,($1 : (snd $ unLoc $2))) } - | ';' stmts {% if null (snd $ unLoc $2) - then ams (sLL $1 $> ([mj AnnSemi $1],snd $ unLoc $2)) [] - else ams (sLL $1 $> ([],snd $ unLoc $2)) [mj AnnSemi $1] } +stmts :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) } + : stmts ';' stmt {% if null (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + ,$3 : (snd $ unLoc $1))) + else do + { ams (head $ snd $ unLoc $1) [mj AnnSemi $2] + ; return $ sLL $1 $> (fst $ unLoc $1,$3 :(snd $ unLoc $1)) }} + + | stmts ';' {% if null (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1),snd $ unLoc $1)) + else do + { ams (head $ snd $ unLoc $1) + [mj AnnSemi $2] + ; return $1 } } + | stmt { sL1 $1 ([],[$1]) } | {- empty -} { noLoc ([],[]) } -stmts_help :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) } - -- might be empty - : ';' stmts {% if null (snd $ unLoc $2) - then ams (sLL $1 $> ([mj AnnSemi $1],snd $ unLoc $2)) [] - else ams (sLL $1 $> ([],snd $ unLoc $2)) [mj AnnSemi $1] } - - | {- empty -} { noLoc ([],[]) } -- For typing stmts at the GHCi prompt, where -- the input may consist of just comments. @@ -2456,14 +2537,14 @@ maybe_stmt :: { Maybe (LStmt RdrName (LHsExpr RdrName)) } stmt :: { LStmt RdrName (LHsExpr RdrName) } : qual { $1 } | 'rec' stmtlist {% ams (sLL $1 $> $ mkRecStmt (snd $ unLoc $2)) - [mj AnnRec $1] } + (mj AnnRec $1:(fst $ unLoc $2)) } qual :: { LStmt RdrName (LHsExpr RdrName) } : bindpat '<-' exp {% ams (sLL $1 $> $ mkBindStmt $1 $3) [mj AnnLarrow $2] } | exp { sL1 $1 $ mkBodyStmt $1 } | 'let' binds {% ams (sLL $1 $>$ LetStmt (snd $ unLoc $2)) - [mj AnnLet $1] } + (mj AnnLet $1:(fst $ unLoc $2)) } ----------------------------------------------------------------------------- -- Record Field Update/Construction @@ -2504,7 +2585,7 @@ dbinds :: { Located [LIPBind RdrName] } -- | {- empty -} { [] } dbind :: { LIPBind RdrName } -dbind : ipvar '=' exp {% ams (sLL $1 $> (IPBind (Left (unLoc $1)) $3)) +dbind : ipvar '=' exp {% ams (sLL $1 $> (IPBind (Left $1) $3)) [mj AnnEqual $2] } ipvar :: { Located HsIPName } @@ -2529,13 +2610,13 @@ name_boolformula_and :: { ([AddAnn],BooleanFormula (Located RdrName)) } { ((mj AnnComma $2:fst $1)++(fst $3), mkAnd [snd $1,snd $3]) } name_boolformula_atom :: { ([AddAnn],BooleanFormula (Located RdrName)) } - : '(' name_boolformula ')' { ([mo $1,mc $3],snd $2) } + : '(' name_boolformula ')' { ([mop $1,mcp $3],snd $2) } | name_var { ([],mkVar $1) } --- AZ TODO: warnings/deprecations are incompletely annotated -namelist :: { Located [RdrName] } -namelist : name_var { sL1 $1 [unLoc $1] } - | name_var ',' namelist { sLL $1 $> (unLoc $1 : unLoc $3) } +namelist :: { Located [Located RdrName] } +namelist : name_var { sL1 $1 [$1] } + | name_var ',' namelist {% addAnnotation (gl $1) AnnComma (gl $2) >> + return (sLL $1 $> ($1 : unLoc $3)) } name_var :: { Located RdrName } name_var : var { $1 } @@ -2545,35 +2626,42 @@ name_var : var { $1 } -- Data constructors qcon :: { Located RdrName } : qconid { $1 } - | '(' qconsym ')' {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] } + | '(' qconsym ')' {% ams (sLL $1 $> (unLoc $2)) + [mop $1,mj AnnVal $2,mcp $3] } | sysdcon { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) } -- The case of '[:' ':]' is part of the production `parr' con :: { Located RdrName } : conid { $1 } - | '(' consym ')' {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] } + | '(' consym ')' {% ams (sLL $1 $> (unLoc $2)) + [mop $1,mj AnnVal $2,mcp $3] } | sysdcon { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) } con_list :: { Located [Located RdrName] } con_list : con { sL1 $1 [$1] } - | con ',' con_list {% ams (sLL $1 $> ($1 : unLoc $3)) [mj AnnComma $2] } + | con ',' con_list {% addAnnotation (gl $1) AnnComma (gl $2) >> + return (sLL $1 $> ($1 : unLoc $3)) } sysdcon :: { Located DataCon } -- Wired in data constructors - : '(' ')' {% ams (sLL $1 $> unitDataCon) [mo $1,mc $2] } + : '(' ')' {% ams (sLL $1 $> unitDataCon) [mop $1,mcp $2] } | '(' commas ')' {% ams (sLL $1 $> $ tupleCon BoxedTuple (snd $2 + 1)) - (mo $1:mc $3:(mcommas (fst $2))) } + (mop $1:mcp $3:(mcommas (fst $2))) } | '(#' '#)' {% ams (sLL $1 $> $ unboxedUnitDataCon) [mo $1,mc $2] } | '(#' commas '#)' {% ams (sLL $1 $> $ tupleCon UnboxedTuple (snd $2 + 1)) (mo $1:mc $3:(mcommas (fst $2))) } - | '[' ']' {% ams (sLL $1 $> nilDataCon) [mo $1,mc $2] } + | '[' ']' {% ams (sLL $1 $> nilDataCon) [mos $1,mcs $2] } conop :: { Located RdrName } : consym { $1 } - | '`' conid '`' {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] } + | '`' conid '`' {% ams (sLL $1 $> (unLoc $2)) + [mj AnnBackquote $1,mj AnnVal $2 + ,mj AnnBackquote $3] } qconop :: { Located RdrName } : qconsym { $1 } - | '`' qconid '`' {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] } + | '`' qconid '`' {% ams (sLL $1 $> (unLoc $2)) + [mj AnnBackquote $1,mj AnnVal $2 + ,mj AnnBackquote $3] } ---------------------------------------------------------------------------- -- Type constructors @@ -2584,7 +2672,7 @@ qconop :: { Located RdrName } gtycon :: { Located RdrName } -- A "general" qualified tycon, including unit tuples : ntgtycon { $1 } | '(' ')' {% ams (sLL $1 $> $ getRdrName unitTyCon) - [mo $1,mc $2] } + [mop $1,mcp $2] } | '(#' '#)' {% ams (sLL $1 $> $ getRdrName unboxedUnitTyCon) [mo $1,mc $2] } @@ -2592,48 +2680,51 @@ ntgtycon :: { Located RdrName } -- A "general" qualified tycon, excluding unit : oqtycon { $1 } | '(' commas ')' {% ams (sLL $1 $> $ getRdrName (tupleTyCon BoxedTuple (snd $2 + 1))) - (mo $1:mc $3:(mcommas (fst $2))) } + (mop $1:mcp $3:(mcommas (fst $2))) } | '(#' commas '#)' {% ams (sLL $1 $> $ getRdrName (tupleTyCon UnboxedTuple (snd $2 + 1))) (mo $1:mc $3:(mcommas (fst $2))) } | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon) - [mo $1,mj AnnRarrow $2,mc $3] } - | '[' ']' {% ams (sLL $1 $> $ listTyCon_RDR) [mo $1,mc $2] } + [mop $1,mj AnnRarrow $2,mcp $3] } + | '[' ']' {% ams (sLL $1 $> $ listTyCon_RDR) [mos $1,mcs $2] } | '[:' ':]' {% ams (sLL $1 $> $ parrTyCon_RDR) [mo $1,mc $2] } | '(' '~#' ')' {% ams (sLL $1 $> $ getRdrName eqPrimTyCon) - [mo $1,mj AnnTildehsh $2,mc $3] } + [mop $1,mj AnnTildehsh $2,mcp $3] } oqtycon :: { Located RdrName } -- An "ordinary" qualified tycon; -- These can appear in export lists : qtycon { $1 } - | '(' qtyconsym ')' {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] } + | '(' qtyconsym ')' {% ams (sLL $1 $> (unLoc $2)) + [mop $1,mj AnnVal $2,mcp $3] } | '(' '~' ')' {% ams (sLL $1 $> $ eqTyCon_RDR) - [mo $1,mj AnnTilde $2,mc $3] } + [mop $1,mj AnnTilde $2,mcp $3] } qtyconop :: { Located RdrName } -- Qualified or unqualified : qtyconsym { $1 } - | '`' qtycon '`' {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] } + | '`' qtycon '`' {% ams (sLL $1 $> (unLoc $2)) + [mj AnnBackquote $1,mj AnnVal $2 + ,mj AnnBackquote $3] } qtycon :: { Located RdrName } -- Qualified or unqualified - : QCONID { sL1 $1 $! mkQual tcClsName (getQCONID $1) } - | PREFIXQCONSYM { sL1 $1 $! mkQual tcClsName (getPREFIXQCONSYM $1) } - | tycon { $1 } + : QCONID { sL1 $1 $! mkQual tcClsName (getQCONID $1) } + | PREFIXQCONSYM { sL1 $1 $! mkQual tcClsName (getPREFIXQCONSYM $1) } + | tycon { $1 } tycon :: { Located RdrName } -- Unqualified - : CONID { sL1 $1 $! mkUnqual tcClsName (getCONID $1) } + : CONID { sL1 $1 $! mkUnqual tcClsName (getCONID $1) } qtyconsym :: { Located RdrName } - : QCONSYM { sL1 $1 $! mkQual tcClsName (getQCONSYM $1) } - | QVARSYM { sL1 $1 $! mkQual tcClsName (getQVARSYM $1) } - | tyconsym { $1 } + : QCONSYM { sL1 $1 $! mkQual tcClsName (getQCONSYM $1) } + | QVARSYM { sL1 $1 $! mkQual tcClsName (getQVARSYM $1) } + | tyconsym { $1 } -- Does not include "!", because that is used for strictness marks -- or ".", because that separates the quantified type vars from the rest tyconsym :: { Located RdrName } - : CONSYM { sL1 $1 $! mkUnqual tcClsName (getCONSYM $1) } - | VARSYM { sL1 $1 $! mkUnqual tcClsName (getVARSYM $1) } - | '*' { sL1 $1 $! mkUnqual tcClsName (fsLit "*") } - | '-' { sL1 $1 $! mkUnqual tcClsName (fsLit "-") } + : CONSYM { sL1 $1 $! mkUnqual tcClsName (getCONSYM $1) } + | VARSYM { sL1 $1 $! mkUnqual tcClsName (getVARSYM $1) } + | '*' { sL1 $1 $! mkUnqual tcClsName (fsLit "*") } + | '-' { sL1 $1 $! mkUnqual tcClsName (fsLit "-") } ----------------------------------------------------------------------------- @@ -2645,7 +2736,9 @@ op :: { Located RdrName } -- used in infix decls varop :: { Located RdrName } : varsym { $1 } - | '`' varid '`' {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] } + | '`' varid '`' {% ams (sLL $1 $> (unLoc $2)) + [mj AnnBackquote $1,mj AnnVal $2 + ,mj AnnBackquote $3] } qop :: { LHsExpr RdrName } -- used in sections : qvarop { sL1 $1 $ HsVar (unLoc $1) } @@ -2657,11 +2750,15 @@ qopm :: { LHsExpr RdrName } -- used in sections qvarop :: { Located RdrName } : qvarsym { $1 } - | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] } + | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2)) + [mj AnnBackquote $1,mj AnnVal $2 + ,mj AnnBackquote $3] } qvaropm :: { Located RdrName } : qvarsym_no_minus { $1 } - | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] } + | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2)) + [mj AnnBackquote $1,mj AnnVal $2 + ,mj AnnBackquote $3] } ----------------------------------------------------------------------------- -- Type variables @@ -2670,7 +2767,9 @@ tyvar :: { Located RdrName } tyvar : tyvarid { $1 } tyvarop :: { Located RdrName } -tyvarop : '`' tyvarid '`' {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] } +tyvarop : '`' tyvarid '`' {% ams (sLL $1 $> (unLoc $2)) + [mj AnnBackquote $1,mj AnnVal $2 + ,mj AnnBackquote $3] } | '.' {% parseErrorSDoc (getLoc $1) (vcat [ptext (sLit "Illegal symbol '.' in type"), ptext (sLit "Perhaps you intended to use RankNTypes or a similar language"), @@ -2678,44 +2777,47 @@ tyvarop : '`' tyvarid '`' {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] } } tyvarid :: { Located RdrName } - : VARID { sL1 $1 $! mkUnqual tvName (getVARID $1) } - | special_id { sL1 $1 $! mkUnqual tvName (unLoc $1) } - | 'unsafe' { sL1 $1 $! mkUnqual tvName (fsLit "unsafe") } - | 'safe' { sL1 $1 $! mkUnqual tvName (fsLit "safe") } - | 'interruptible' { sL1 $1 $! mkUnqual tvName (fsLit "interruptible") } + : VARID { sL1 $1 $! mkUnqual tvName (getVARID $1) } + | special_id { sL1 $1 $! mkUnqual tvName (unLoc $1) } + | 'unsafe' { sL1 $1 $! mkUnqual tvName (fsLit "unsafe") } + | 'safe' { sL1 $1 $! mkUnqual tvName (fsLit "safe") } + | 'interruptible' { sL1 $1 $! mkUnqual tvName (fsLit "interruptible") } ----------------------------------------------------------------------------- -- Variables var :: { Located RdrName } : varid { $1 } - | '(' varsym ')' {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] } + | '(' varsym ')' {% ams (sLL $1 $> (unLoc $2)) + [mop $1,mj AnnVal $2,mcp $3] } qvar :: { Located RdrName } : qvarid { $1 } - | '(' varsym ')' {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] } - | '(' qvarsym1 ')' {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] } + | '(' varsym ')' {% ams (sLL $1 $> (unLoc $2)) + [mop $1,mj AnnVal $2,mcp $3] } + | '(' qvarsym1 ')' {% ams (sLL $1 $> (unLoc $2)) + [mop $1,mj AnnVal $2,mcp $3] } -- We've inlined qvarsym here so that the decision about -- whether it's a qvar or a var can be postponed until -- *after* we see the close paren. qvarid :: { Located RdrName } - : varid { $1 } - | QVARID { sL1 $1 $! mkQual varName (getQVARID $1) } - | PREFIXQVARSYM { sL1 $1 $! mkQual varName (getPREFIXQVARSYM $1) } + : varid { $1 } + | QVARID { sL1 $1 $! mkQual varName (getQVARID $1) } + | PREFIXQVARSYM { sL1 $1 $! mkQual varName (getPREFIXQVARSYM $1) } -- Note that 'role' and 'family' get lexed separately regardless of -- the use of extensions. However, because they are listed here, this -- is OK and they can be used as normal varids. varid :: { Located RdrName } - : VARID { sL1 $1 $! mkUnqual varName (getVARID $1) } - | special_id { sL1 $1 $! mkUnqual varName (unLoc $1) } - | 'unsafe' { sL1 $1 $! mkUnqual varName (fsLit "unsafe") } - | 'safe' { sL1 $1 $! mkUnqual varName (fsLit "safe") } - | 'interruptible' { sL1 $1 $! mkUnqual varName (fsLit "interruptible") } - | 'forall' { sL1 $1 $! mkUnqual varName (fsLit "forall") } - | 'family' { sL1 $1 $! mkUnqual varName (fsLit "family") } - | 'role' { sL1 $1 $! mkUnqual varName (fsLit "role") } + : VARID { sL1 $1 $! mkUnqual varName (getVARID $1) } + | special_id { sL1 $1 $! mkUnqual varName (unLoc $1) } + | 'unsafe' { sL1 $1 $! mkUnqual varName (fsLit "unsafe") } + | 'safe' { sL1 $1 $! mkUnqual varName (fsLit "safe") } + | 'interruptible' { sL1 $1 $! mkUnqual varName (fsLit "interruptible")} + | 'forall' { sL1 $1 $! mkUnqual varName (fsLit "forall") } + | 'family' { sL1 $1 $! mkUnqual varName (fsLit "family") } + | 'role' { sL1 $1 $! mkUnqual varName (fsLit "role") } qvarsym :: { Located RdrName } : varsym { $1 } @@ -2733,8 +2835,8 @@ varsym :: { Located RdrName } | '-' { sL1 $1 $ mkUnqual varName (fsLit "-") } varsym_no_minus :: { Located RdrName } -- varsym not including '-' - : VARSYM { sL1 $1 $ mkUnqual varName (getVARSYM $1) } - | special_sym { sL1 $1 $ mkUnqual varName (unLoc $1) } + : VARSYM { sL1 $1 $ mkUnqual varName (getVARSYM $1) } + | special_sym { sL1 $1 $ mkUnqual varName (unLoc $1) } -- These special_ids are treated as keywords in various places, @@ -2757,7 +2859,7 @@ special_id | 'group' { sL1 $1 (fsLit "group") } special_sym :: { Located FastString } -special_sym : '!' { sL1 $1 (fsLit "!") } +special_sym : '!' {% ams (sL1 $1 (fsLit "!")) [mj AnnBang $1] } | '.' { sL1 $1 (fsLit ".") } | '*' { sL1 $1 (fsLit "*") } @@ -2765,22 +2867,22 @@ special_sym : '!' { sL1 $1 (fsLit "!") } -- Data constructors qconid :: { Located RdrName } -- Qualified or unqualified - : conid { $1 } - | QCONID { sL1 $1 $! mkQual dataName (getQCONID $1) } - | PREFIXQCONSYM { sL1 $1 $! mkQual dataName (getPREFIXQCONSYM $1) } + : conid { $1 } + | QCONID { sL1 $1 $! mkQual dataName (getQCONID $1) } + | PREFIXQCONSYM { sL1 $1 $! mkQual dataName (getPREFIXQCONSYM $1) } conid :: { Located RdrName } - : CONID { sL1 $1 $ mkUnqual dataName (getCONID $1) } + : CONID { sL1 $1 $ mkUnqual dataName (getCONID $1) } qconsym :: { Located RdrName } -- Qualified or unqualified - : consym { $1 } - | QCONSYM { sL1 $1 $ mkQual dataName (getQCONSYM $1) } + : consym { $1 } + | QCONSYM { sL1 $1 $ mkQual dataName (getQCONSYM $1) } consym :: { Located RdrName } - : CONSYM { sL1 $1 $ mkUnqual dataName (getCONSYM $1) } + : CONSYM { sL1 $1 $ mkUnqual dataName (getCONSYM $1) } -- ':' means only list cons - | ':' { sL1 $1 $ consDataCon_RDR } + | ':' { sL1 $1 $ consDataCon_RDR } ----------------------------------------------------------------------------- @@ -2881,9 +2983,9 @@ getPRIMFLOAT (L _ (ITprimfloat x)) = x getPRIMDOUBLE (L _ (ITprimdouble x)) = x getTH_ID_SPLICE (L _ (ITidEscape x)) = x getTH_ID_TY_SPLICE (L _ (ITidTyEscape x)) = x -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) +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 @@ -2898,6 +3000,29 @@ getPRIMSTRINGs (L _ (ITprimstring src _)) = src getPRIMINTEGERs (L _ (ITprimint src _)) = src getPRIMWORDs (L _ (ITprimword src _)) = src +-- See Note [Pragma source text] in BasicTypes for the following +getINLINE_PRAGs (L _ (ITinline_prag src _ _)) = src +getSPEC_PRAGs (L _ (ITspec_prag src)) = src +getSPEC_INLINE_PRAGs (L _ (ITspec_inline_prag src _)) = src +getSOURCE_PRAGs (L _ (ITsource_prag src)) = src +getRULES_PRAGs (L _ (ITrules_prag src)) = src +getWARNING_PRAGs (L _ (ITwarning_prag src)) = src +getDEPRECATED_PRAGs (L _ (ITdeprecated_prag src)) = src +getSCC_PRAGs (L _ (ITscc_prag src)) = src +getGENERATED_PRAGs (L _ (ITgenerated_prag src)) = src +getCORE_PRAGs (L _ (ITcore_prag src)) = src +getUNPACK_PRAGs (L _ (ITunpack_prag src)) = src +getNOUNPACK_PRAGs (L _ (ITnounpack_prag src)) = src +getANN_PRAGs (L _ (ITann_prag src)) = src +getVECT_PRAGs (L _ (ITvect_prag src)) = src +getVECT_SCALAR_PRAGs (L _ (ITvect_scalar_prag src)) = src +getNOVECT_PRAGs (L _ (ITnovect_prag src)) = src +getMINIMAL_PRAGs (L _ (ITminimal_prag src)) = src +getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src +getOVERLAPPING_PRAGs (L _ (IToverlapping_prag src)) = src +getOVERLAPS_PRAGs (L _ (IToverlaps_prag src)) = src +getINCOHERENT_PRAGs (L _ (ITincoherent_prag src)) = src +getCTYPEs (L _ (ITctype src)) = src getSCC :: Located Token -> P FastString @@ -2986,10 +3111,6 @@ in ApiAnnotation.hs -} --- |Encapsulated call to addAnnotation, requiring only the SrcSpan of --- the AST element the annotation belongs to -type AddAnn = (SrcSpan -> P ()) - -- |Construct an AddAnn from the annotation keyword and the location -- of the keyword mj :: AnnKeywordId -> Located e -> AddAnn @@ -3032,10 +3153,22 @@ mo,mc :: Located Token -> SrcSpan -> P () mo ll = mj AnnOpen ll mc ll = mj AnnClose ll +moc,mcc :: Located Token -> SrcSpan -> P () +moc ll = mj AnnOpenC ll +mcc ll = mj AnnCloseC ll + +mop,mcp :: Located Token -> SrcSpan -> P () +mop ll = mj AnnOpenP ll +mcp ll = mj AnnCloseP ll + +mos,mcs :: Located Token -> SrcSpan -> P () +mos ll = mj AnnOpenS ll +mcs ll = mj AnnCloseS ll + -- |Given a list of the locations of commas, provide a [AddAnn] with an AnnComma -- entry for each SrcSpan mcommas :: [SrcSpan] -> [AddAnn] -mcommas ss = map (\s -> mj AnnComma (L s ())) ss +mcommas ss = map (\s -> mj AnnCommaTuple (L s ())) ss -- |Add the annotation to an AST element wrapped in a Just ajl :: Located (Maybe (Located a)) -> AnnKeywordId -> SrcSpan @@ -3050,16 +3183,16 @@ aljs a@(L _ (Just (L l _))) bs = (mapM_ (\a -> a l) bs) >> return a -- |Add all [AddAnn] to an AST element wrapped in a Just ajs a@(Just (L l _)) bs = (mapM_ (\a -> a l) bs) >> return a --- |Get the location of the last element of a OrdList, or noLoc +-- |Get the location of the last element of a OrdList, or noSrcSpan oll :: OrdList (Located a) -> SrcSpan -oll l = case fromOL l of - [] -> noSrcSpan - xs -> getLoc (last xs) +oll l = + if isNilOL l then noSrcSpan + else getLoc (lastOL l) -- |Add a semicolon annotation in the right place in a list. If the -- leading list is empty, add it to the tail asl :: [Located a] -> Located b -> Located a -> P() -asl [] (L ls _) (L l _) = addAnnotation l AnnSemi ls +asl [] (L ls _) (L l _) = addAnnotation l AnnSemi ls asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 7628227d99..a1d9885727 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -72,7 +72,8 @@ import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, import OccName ( tcClsName, isVarNameSpace ) import Name ( Name ) import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo, - InlinePragma(..), InlineSpec(..), Origin(..) ) + InlinePragma(..), InlineSpec(..), Origin(..), + SourceText ) import TcEvidence ( idHsWrapper ) import Lexer import TysWiredIn ( unitTyCon, unitDataCon ) @@ -88,6 +89,7 @@ import Outputable import FastString import Maybes import Util +import ApiAnnotation import Control.Applicative ((<$>)) import Control.Monad @@ -126,20 +128,22 @@ mkInstD (L loc d) = L loc (InstD d) mkClassDecl :: SrcSpan -> Located (Maybe (LHsContext RdrName), LHsType RdrName) - -> Located [Located (FunDep RdrName)] + -> Located (a,[Located (FunDep (Located RdrName))]) -> OrdList (LHsDecl RdrName) -> P (LTyClDecl RdrName) mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls ; let cxt = fromMaybe (noLoc []) mcxt - ; (cls, tparams) <- checkTyClHdr tycl_hdr + ; (cls, tparams,ann) <- checkTyClHdr tycl_hdr + ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan -- Partial type signatures are not allowed in a class definition ; checkNoPartialSigs sigs cls ; tyvars <- checkTyVarsP (ptext (sLit "class")) whereDots cls tparams ; at_defs <- mapM (eitherToP . mkATDefault) at_insts ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars, - tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds, + tcdFDs = snd (unLoc fds), tcdSigs = sigs, + tcdMeths = binds, tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs, tcdFVs = placeHolderNames })) } @@ -188,7 +192,7 @@ checkNoPartialCon con_decls = (hsConDeclArgTys details) ] where err con_decl = text "A constructor cannot have a partial type:" $$ ppr con_decl - containsWildcardRes (ResTyGADT ty) = findWildcards ty + containsWildcardRes (ResTyGADT _ ty) = findWildcards ty containsWildcardRes ResTyH98 = notFound -- | Check that the given type does not contain wildcards, and is thus not a @@ -265,7 +269,8 @@ mkTyData :: SrcSpan -> Maybe (Located [LHsType RdrName]) -> P (LTyClDecl RdrName) mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv - = do { (tc, tparams) <- checkTyClHdr tycl_hdr + = do { (tc, tparams,ann) <- checkTyClHdr tycl_hdr + ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars, @@ -299,7 +304,8 @@ mkTySynonym :: SrcSpan -> LHsType RdrName -- RHS -> P (LTyClDecl RdrName) mkTySynonym loc lhs rhs - = do { (tc, tparams) <- checkTyClHdr lhs + = do { (tc, tparams,ann) <- checkTyClHdr lhs + ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; tyvars <- checkTyVarsP (ptext (sLit "type")) equalsDots tc tparams ; let err = text "In type synonym" <+> quotes (ppr tc) <> colon <+> ppr rhs @@ -309,9 +315,9 @@ mkTySynonym loc lhs rhs mkTyFamInstEqn :: LHsType RdrName -> LHsType RdrName - -> P (TyFamInstEqn RdrName) + -> P (TyFamInstEqn RdrName,[AddAnn]) mkTyFamInstEqn lhs rhs - = do { (tc, tparams) <- checkTyClHdr lhs + = do { (tc, tparams,ann) <- checkTyClHdr lhs ; let err xhs = hang (text "In type family instance equation of" <+> quotes (ppr tc) <> colon) 2 (ppr xhs) @@ -319,7 +325,8 @@ mkTyFamInstEqn lhs rhs ; checkNoPartialType (err rhs) rhs ; return (TyFamEqn { tfe_tycon = tc , tfe_pats = mkHsWithBndrs tparams - , tfe_rhs = rhs }) } + , tfe_rhs = rhs }, + ann) } mkDataFamInst :: SrcSpan -> NewOrData @@ -330,7 +337,8 @@ mkDataFamInst :: SrcSpan -> Maybe (Located [LHsType RdrName]) -> P (LInstDecl RdrName) mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv - = do { (tc, tparams) <- checkTyClHdr tycl_hdr + = do { (tc, tparams,ann) <- checkTyClHdr tycl_hdr + ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv ; return (L loc (DataFamInstD ( DataFamInstDecl { dfid_tycon = tc, dfid_pats = mkHsWithBndrs tparams @@ -349,7 +357,8 @@ mkFamDecl :: SrcSpan -> Maybe (LHsKind RdrName) -- Optional kind signature -> P (LTyClDecl RdrName) mkFamDecl loc info lhs ksig - = do { (tc, tparams) <- checkTyClHdr lhs + = do { (tc, tparams,ann) <- checkTyClHdr lhs + ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams ; return (L loc (FamDecl (FamilyDecl { fdInfo = info, fdLName = tc , fdTyVars = tyvars, fdKindSig = ksig }))) } @@ -504,7 +513,7 @@ getMonoBind bind binds = (bind, binds) has_args :: [LMatch RdrName (LHsExpr RdrName)] -> Bool has_args [] = panic "RdrHsSyn:has_args" -has_args ((L _ (Match args _ _)) : _) = not (null args) +has_args ((L _ (Match _ args _ _)) : _) = not (null args) -- Don't group together FunBinds if they have -- no arguments. This is necessary now that variable bindings -- with no arguments are now treated as FunBinds rather @@ -540,7 +549,7 @@ splitCon ty -- See Note [Unit tuples] in HsTypes split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty) - mk_rest [L _ (HsRecTy flds)] = RecCon flds + mk_rest [L l (HsRecTy flds)] = RecCon (L l flds) mk_rest ts = PrefixCon ts recordPatSynErr :: SrcSpan -> LPat RdrName -> P a @@ -560,8 +569,9 @@ mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) = do { unless (name == patsyn_name) $ wrongNameBindingErr loc decl ; match <- case details of - PrefixCon pats -> return $ Match pats Nothing rhs - InfixCon pat1 pat2 -> return $ Match [pat1, pat2] Nothing rhs + PrefixCon pats -> return $ Match Nothing pats Nothing rhs + InfixCon pat1 pat2 -> + return $ Match Nothing [pat1, pat2] Nothing rhs RecCon{} -> recordPatSynErr loc pat ; return $ L loc match } fromDecl (L loc decl) = extraDeclErr loc decl @@ -578,7 +588,7 @@ mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) = mkDeprecatedGadtRecordDecl :: SrcSpan -> Located RdrName - -> [LConDeclField RdrName] + -> Located [LConDeclField RdrName] -> LHsType RdrName -> P (LConDecl RdrName) -- This one uses the deprecated syntax @@ -592,7 +602,7 @@ mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty , con_qvars = mkHsQTvs [] , con_cxt = noLoc [] , con_details = RecCon flds - , con_res = ResTyGADT res_ty + , con_res = ResTyGADT loc res_ty , con_doc = Nothing })) } mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName] @@ -620,12 +630,13 @@ mkGadtDecl _ ty@(L _ (HsForAllTy _ (Just l) _ _ _)) = parseErrorSDoc l $ text "A constructor cannot have a partial type:" $$ ppr ty -mkGadtDecl names (L _ (HsForAllTy imp Nothing qvars cxt tau)) +mkGadtDecl names (L ls (HsForAllTy imp Nothing qvars cxt tau)) = return $ mk_gadt_con names where (details, res_ty) -- See Note [Sorting out the result type] = case tau of - L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds, res_ty) + L _ (HsFunTy (L l (HsRecTy flds)) res_ty) + -> (RecCon (L l flds), res_ty) _other -> (PrefixCon [], tau) mk_gadt_con names @@ -635,7 +646,7 @@ mkGadtDecl names (L _ (HsForAllTy imp Nothing qvars cxt tau)) , con_qvars = qvars , con_cxt = cxt , con_details = details - , con_res = ResTyGADT res_ty + , con_res = ResTyGADT ls res_ty , con_doc = Nothing } mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty) @@ -689,8 +700,8 @@ checkTyVars pp_what equals_or_where tc tparms where -- Check that the name space is correct! - chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) - | isRdrTyVar tv = return (L l (KindedTyVar tv k)) + chk (L l (HsKindSig (L lv (HsTyVar tv)) k)) + | isRdrTyVar tv = return (L l (KindedTyVar (L lv tv) k)) chk (L l (HsTyVar tv)) | isRdrTyVar tv = return (L l (UserTyVar tv)) chk t@(L loc _) @@ -729,25 +740,28 @@ checkRecordSyntax lr@(L loc r) checkTyClHdr :: LHsType RdrName -> P (Located RdrName, -- the head symbol (type or class name) - [LHsType RdrName]) -- parameters of head symbol + [LHsType RdrName], -- parameters of head symbol + [AddAnn]) -- API Annotation for HsParTy when stripping parens -- Well-formedness check and decomposition of type and class heads. -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn]) -- Int :*: Bool into (:*:, [Int, Bool]) -- returning the pieces checkTyClHdr ty - = goL ty [] + = goL ty [] [] where - goL (L l ty) acc = go l ty acc - - go l (HsTyVar tc) acc - | isRdrTc tc = return (L l tc, acc) - go _ (HsOpTy t1 (_, ltc@(L _ tc)) t2) acc - | isRdrTc tc = return (ltc, t1:t2:acc) - go _ (HsParTy ty) acc = goL ty acc - go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc) - go l (HsTupleTy _ []) [] = return (L l (getRdrName unitTyCon), []) + goL (L l ty) acc ann = go l ty acc ann + + go l (HsTyVar tc) acc ann + | isRdrTc tc = return (L l tc, acc, ann) + go _ (HsOpTy t1 (_, ltc@(L _ tc)) t2) acc ann + | isRdrTc tc = return (ltc, t1:t2:acc, ann) + go l (HsParTy ty) acc ann = goL ty acc (ann ++ mkParensApiAnn l) + go _ (HsAppTy t1 t2) acc ann = goL t1 (t2:acc) ann + go l (HsTupleTy _ []) [] ann = return (L l (getRdrName unitTyCon), [],ann) -- See Note [Unit tuples] in HsTypes - go l _ _ = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty) + go l _ _ _ + = parseErrorSDoc l (text "Malformed head of type or class declaration:" + <+> ppr ty) checkContext :: LHsType RdrName -> P (LHsContext RdrName) checkContext (L l orig_t) @@ -808,14 +822,16 @@ checkAPat msg loc e0 = do -- Overloaded numeric patterns (e.g. f 0 x = x) -- Negation is recorded separately, so that the literal is zero or +ve -- NB. Negative *primitive* literals are already handled by the lexer - HsOverLit pos_lit -> return (mkNPat pos_lit Nothing) - NegApp (L _ (HsOverLit pos_lit)) _ - -> return (mkNPat pos_lit (Just noSyntaxExpr)) + HsOverLit pos_lit -> return (mkNPat (L loc pos_lit) Nothing) + NegApp (L l (HsOverLit pos_lit)) _ + -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr)) - SectionR (L _ (HsVar bang)) e -- (! x) + SectionR (L lb (HsVar bang)) e -- (! x) | bang == bang_RDR -> do { bang_on <- extension bangPatEnabled - ; if bang_on then checkLPat msg e >>= (return . BangPat) + ; if bang_on then do { e' <- checkLPat msg e + ; addAnnotation loc AnnBang lb + ; return (BangPat e') } else parseErrorSDoc loc (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e0) } ELazyPat e -> checkLPat msg e >>= (return . LazyPat) @@ -835,9 +851,9 @@ checkAPat msg loc e0 = do -- n+k patterns OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ - (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}}))) + (L lloc (HsOverLit lit@(OverLit {ol_val = HsIntegral {}}))) | xopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR) - -> return (mkNPlusKPat (L nloc n) lit) + -> return (mkNPlusKPat (L nloc n) (L lloc lit)) OpApp l op _fix r -> do l <- checkLPat msg l r <- checkLPat msg r @@ -919,7 +935,8 @@ checkFunBind :: SDoc checkFunBind msg lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) = do ps <- checkPatterns msg pats let match_span = combineSrcSpans lhs_loc rhs_span - return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)]) + return (makeFunBind fun is_infix + [L match_span (Match (Just (fun,is_infix)) ps opt_sig grhss)]) -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. @@ -1272,9 +1289,9 @@ checkCmdMatchGroup :: MatchGroup RdrName (LHsExpr RdrName) -> P (MatchGroup RdrN checkCmdMatchGroup mg@(MG { mg_alts = ms }) = do ms' <- mapM (locMap $ const convert) ms return $ mg { mg_alts = ms' } - where convert (Match pat mty grhss) = do + where convert (Match mf pat mty grhss) = do grhss' <- checkCmdGRHSs grhss - return $ Match pat mty grhss' + return $ Match mf pat mty grhss' checkCmdGRHSs :: GRHSs RdrName (LHsExpr RdrName) -> P (GRHSs RdrName (LHsCmd RdrName)) checkCmdGRHSs (GRHSs grhss binds) = do @@ -1321,11 +1338,13 @@ mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) } -mkInlinePragma :: (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma +mkInlinePragma :: String -> (InlineSpec, RuleMatchInfo) -> Maybe Activation + -> InlinePragma -- The (Maybe Activation) is because the user can omit -- the activation spec (and usually does) -mkInlinePragma (inl, match_info) mb_act - = InlinePragma { inl_inline = inl +mkInlinePragma src (inl, match_info) mb_act + = InlinePragma { inl_src = src -- Note [Pragma source text] in BasicTypes + , inl_inline = inl , inl_sat = Nothing , inl_act = act , inl_rule = match_info } @@ -1355,16 +1374,16 @@ mkImport (L lc cconv) (L ls safety) (L loc entity, v, ty) | cconv == PrimCallConv = do let funcTarget = CFunction (StaticTarget entity Nothing True) importSpec = CImport (L lc PrimCallConv) (L ls safety) Nothing funcTarget - (L loc entity) + (L loc (unpackFS entity)) return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec)) | cconv == JavaScriptCallConv = do let funcTarget = CFunction (StaticTarget entity Nothing True) importSpec = CImport (L lc JavaScriptCallConv) (L ls safety) Nothing - funcTarget (L loc entity) + funcTarget (L loc (unpackFS entity)) return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec)) | otherwise = do case parseCImport (L lc cconv) (L ls safety) (mkExtName (unLoc v)) - (unpackFS entity) (L loc entity) of + (unpackFS entity) (L loc (unpackFS entity)) of Nothing -> parseErrorSDoc loc (text "Malformed entity string") Just importSpec -> return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec)) @@ -1372,7 +1391,7 @@ mkImport (L lc cconv) (L ls safety) (L loc entity, v, ty) -- C identifier case comes first in the alternatives below, so we pick -- that one. parseCImport :: Located CCallConv -> Located Safety -> FastString -> String - -> Located FastString + -> Located SourceText -> Maybe ForeignImport parseCImport cconv safety nm str sourceText = listToMaybe $ map fst $ filter (null.snd) $ @@ -1433,7 +1452,8 @@ mkExport (L lc cconv) (L le entity, v, ty) = do checkNoPartialType (ptext (sLit "In foreign export declaration") <+> quotes (ppr v) $$ ppr ty) ty return $ ForD (ForeignExport v ty noForeignExportCoercionYet - (CExport (L lc (CExportStatic entity' cconv)) (L le entity))) + (CExport (L lc (CExportStatic entity' cconv)) + (L le (unpackFS entity)))) where entity' | nullFS entity = mkExtName (unLoc v) | otherwise = entity @@ -1457,7 +1477,7 @@ mkModuleImpExp n@(L l name) subs = case subs of ImpExpAbs | isVarNameSpace (rdrNameSpace name) -> IEVar n - | otherwise -> IEThingAbs nameT + | otherwise -> IEThingAbs (L l nameT) ImpExpAll -> IEThingAll (L l nameT) ImpExpList xs -> IEThingWith (L l nameT) xs diff --git a/compiler/prelude/ForeignCall.hs b/compiler/prelude/ForeignCall.hs index 9afc249276..5b053032bd 100644 --- a/compiler/prelude/ForeignCall.hs +++ b/compiler/prelude/ForeignCall.hs @@ -22,6 +22,7 @@ import FastString import Binary import Outputable import Module +import BasicTypes ( SourceText ) import Data.Char import Data.Data @@ -224,12 +225,17 @@ instance Outputable Header where ppr (Header h) = quotes $ ppr h -- | A C type, used in CAPI FFI calls -data CType = CType (Maybe Header) -- header to include for this type +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CTYPE'@, +-- 'ApiAnnotation.AnnHeader','ApiAnnotation.AnnVal', +-- 'ApiAnnotation.AnnClose' @'\#-}'@, +data CType = CType SourceText -- Note [Pragma source text] in BasicTypes + (Maybe Header) -- header to include for this type FastString -- the type itself deriving (Data, Typeable) instance Outputable CType where - ppr (CType mh ct) = hDoc <+> ftext ct + ppr (CType _ mh ct) = hDoc <+> ftext ct where hDoc = case mh of Nothing -> empty Just h -> ppr h @@ -319,11 +325,13 @@ instance Binary CCallConv where _ -> do return JavaScriptCallConv instance Binary CType where - put_ bh (CType mh fs) = do put_ bh mh - put_ bh fs - get bh = do mh <- get bh + put_ bh (CType s mh fs) = do put_ bh s + put_ bh mh + put_ bh fs + get bh = do s <- get bh + mh <- get bh fs <- get bh - return (CType mh fs) + return (CType s mh fs) instance Binary Header where put_ bh (Header h) = put_ bh h diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index ccebe539d2..6181415bbf 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -536,7 +536,7 @@ charTy = mkTyConTy charTyCon charTyCon :: TyCon charTyCon = pcNonRecDataTyCon charTyConName - (Just (CType Nothing (fsLit "HsChar"))) + (Just (CType "" Nothing (fsLit "HsChar"))) [] [charDataCon] charDataCon :: DataCon charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon @@ -548,7 +548,9 @@ intTy :: Type intTy = mkTyConTy intTyCon intTyCon :: TyCon -intTyCon = pcNonRecDataTyCon intTyConName (Just (CType Nothing (fsLit "HsInt"))) [] [intDataCon] +intTyCon = pcNonRecDataTyCon intTyConName + (Just (CType "" Nothing (fsLit "HsInt"))) [] + [intDataCon] intDataCon :: DataCon intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon @@ -556,7 +558,9 @@ wordTy :: Type wordTy = mkTyConTy wordTyCon wordTyCon :: TyCon -wordTyCon = pcNonRecDataTyCon wordTyConName (Just (CType Nothing (fsLit "HsWord"))) [] [wordDataCon] +wordTyCon = pcNonRecDataTyCon wordTyConName + (Just (CType "" Nothing (fsLit "HsWord"))) [] + [wordDataCon] wordDataCon :: DataCon wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon @@ -564,7 +568,9 @@ floatTy :: Type floatTy = mkTyConTy floatTyCon floatTyCon :: TyCon -floatTyCon = pcNonRecDataTyCon floatTyConName (Just (CType Nothing (fsLit "HsFloat"))) [] [floatDataCon] +floatTyCon = pcNonRecDataTyCon floatTyConName + (Just (CType "" Nothing (fsLit "HsFloat"))) [] + [floatDataCon] floatDataCon :: DataCon floatDataCon = pcDataCon floatDataConName [] [floatPrimTy] floatTyCon @@ -572,7 +578,9 @@ doubleTy :: Type doubleTy = mkTyConTy doubleTyCon doubleTyCon :: TyCon -doubleTyCon = pcNonRecDataTyCon doubleTyConName (Just (CType Nothing (fsLit "HsDouble"))) [] [doubleDataCon] +doubleTyCon = pcNonRecDataTyCon doubleTyConName + (Just (CType "" Nothing (fsLit "HsDouble"))) [] + [doubleDataCon] doubleDataCon :: DataCon doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon @@ -632,7 +640,7 @@ boolTy = mkTyConTy boolTyCon boolTyCon :: TyCon boolTyCon = pcTyCon True NonRecursive True boolTyConName - (Just (CType Nothing (fsLit "HsBool"))) + (Just (CType "" Nothing (fsLit "HsBool"))) [] [falseDataCon, trueDataCon] falseDataCon, trueDataCon :: DataCon diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index 46d36a720f..7a9dcae6ae 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -826,9 +826,9 @@ renameSig ctxt sig@(GenericSig vs ty) ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty ; return (GenericSig new_v new_ty, fvs) } -renameSig _ (SpecInstSig ty) +renameSig _ (SpecInstSig src ty) = do { (new_ty, fvs) <- rnLHsType SpecInstSigCtx ty - ; return (SpecInstSig new_ty,fvs) } + ; return (SpecInstSig src new_ty,fvs) } -- {-# SPECIALISE #-} pragmas can refer to imported Ids -- so, in the top-level case (when mb_names is Nothing) @@ -854,9 +854,9 @@ renameSig ctxt sig@(FixSig (FixitySig vs f)) = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs ; return (FixSig (FixitySig new_vs f), emptyFVs) } -renameSig ctxt sig@(MinimalSig bf) +renameSig ctxt sig@(MinimalSig s bf) = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf - return (MinimalSig new_bf, emptyFVs) + return (MinimalSig s new_bf, emptyFVs) renameSig ctxt sig@(PatSynSig v (flag, qtvs) prov req ty) = do { v' <- lookupSigOccRn ctxt sig v @@ -978,7 +978,7 @@ rnMatch' :: Outputable (body RdrName) => HsMatchContext Name -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) -> Match RdrName (Located (body RdrName)) -> RnM (Match Name (Located (body Name)), FreeVars) -rnMatch' ctxt rnBody match@(Match pats maybe_rhs_sig grhss) +rnMatch' ctxt rnBody match@(Match _mf pats maybe_rhs_sig grhss) = do { -- Result type signatures are no longer supported case maybe_rhs_sig of Nothing -> return () @@ -989,7 +989,7 @@ rnMatch' ctxt rnBody match@(Match pats maybe_rhs_sig grhss) ; rnPats ctxt pats $ \ pats' -> do { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss - ; return (Match pats' Nothing grhss', grhss_fvs) }} + ; return (Match Nothing pats' Nothing grhss', grhss_fvs) }} emptyCaseErr :: HsMatchContext Name -> SDoc emptyCaseErr ctxt = hang (ptext (sLit "Empty list of alternatives in") <+> pp_ctxt) diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index f210b5a929..ced1b432e3 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -183,16 +183,16 @@ rnExpr expr@(SectionR {}) = do { addErr (sectionErr expr); rnSection expr } --------------------------------------------- -rnExpr (HsCoreAnn ann expr) +rnExpr (HsCoreAnn src ann expr) = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsCoreAnn ann expr', fvs_expr) } + ; return (HsCoreAnn src ann expr', fvs_expr) } -rnExpr (HsSCC lbl expr) +rnExpr (HsSCC src lbl expr) = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsSCC lbl expr', fvs_expr) } -rnExpr (HsTickPragma info expr) + ; return (HsSCC src lbl expr', fvs_expr) } +rnExpr (HsTickPragma src info expr) = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsTickPragma info expr', fvs_expr) } + ; return (HsTickPragma src info expr', fvs_expr) } rnExpr (HsLam matches) = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches @@ -559,7 +559,7 @@ methodNamesMatch :: MatchGroup Name (LHsCmd Name) -> FreeVars methodNamesMatch (MG { mg_alts = ms }) = plusFVs (map do_one ms) where - do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss + do_one (L _ (Match _ _ _ grhss)) = methodNamesGRHSs grhss ------------------------------------------------- -- gaw 2004 diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index 84a56f0b0d..102deb0b4e 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -755,7 +755,7 @@ filterImports ifaces decl_spec (Just (want_hiding, L l import_items)) AvailTC parent [name])], warns) - IEThingAbs tc + IEThingAbs (L l tc) | want_hiding -- hiding ( C ) -- Here the 'C' can be a data constructor -- *or* a type/class, or even both @@ -764,10 +764,10 @@ filterImports ifaces decl_spec (Just (want_hiding, L l import_items)) in case catIELookupM [ tc_name, dc_name ] of [] -> failLookupWith BadImport - names -> return ([mkIEThingAbs name | name <- names], []) + names -> return ([mkIEThingAbs l name | name <- names], []) | otherwise -> do nameAvail <- lookup_name tc - return ([mkIEThingAbs nameAvail], []) + return ([mkIEThingAbs l nameAvail], []) IEThingWith (L l rdr_tc) rdr_ns -> do (name, AvailTC _ ns, mb_parent) <- lookup_name rdr_tc @@ -801,8 +801,10 @@ filterImports ifaces decl_spec (Just (want_hiding, L l import_items)) -- all errors. where - mkIEThingAbs (n, av, Nothing ) = (IEThingAbs n, trimAvail av n) - mkIEThingAbs (n, _, Just parent) = (IEThingAbs n, AvailTC parent [n]) + mkIEThingAbs l (n, av, Nothing ) = (IEThingAbs (L l n), + trimAvail av n) + mkIEThingAbs l (n, _, Just parent) = (IEThingAbs (L l n), + AvailTC parent [n]) handle_bad_import m = catchIELookup m $ \err -> case err of BadImport | want_hiding -> return ([], [BadImportW]) @@ -1133,11 +1135,11 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod = do gre <- lookupGreRn rdr return (IEVar (L l (gre_name gre)), greExportAvail gre) - lookup_ie (IEThingAbs rdr) + lookup_ie (IEThingAbs (L l rdr)) = do gre <- lookupGreRn rdr let name = gre_name gre avail = greExportAvail gre - return (IEThingAbs name, avail) + return (IEThingAbs (L l name), avail) lookup_ie ie@(IEThingAll (L l rdr)) = do name <- lookupGlobalOccRn rdr @@ -1417,7 +1419,7 @@ findImportUsage imports rdr_env rdrs add_unused :: IE Name -> NameSet -> NameSet add_unused (IEVar (L _ n)) acc = add_unused_name n acc - add_unused (IEThingAbs n) acc = add_unused_name n acc + add_unused (IEThingAbs (L _ n)) acc = add_unused_name n acc add_unused (IEThingAll (L _ n)) acc = add_unused_all n acc add_unused (IEThingWith (L _ p) ns) acc = add_unused_with p (map unLoc ns) acc @@ -1568,7 +1570,7 @@ printMinimalImports imports_w_usage to_ie _ (Avail n) = [IEVar (noLoc n)] to_ie _ (AvailTC n [m]) - | n==m = [IEThingAbs n] + | n==m = [IEThingAbs (noLoc n)] to_ie ifaces (AvailTC n ns) = case [xs | iface <- ifaces , AvailTC x xs <- mi_exports iface @@ -1771,10 +1773,10 @@ missingImportListItem ie = ptext (sLit "The import item") <+> quotes (ppr ie) <+> ptext (sLit "does not have an explicit import list") moduleWarn :: ModuleName -> WarningTxt -> SDoc -moduleWarn mod (WarningTxt txt) +moduleWarn mod (WarningTxt _ txt) = sep [ ptext (sLit "Module") <+> quotes (ppr mod) <> ptext (sLit ":"), nest 2 (vcat (map ppr txt)) ] -moduleWarn mod (DeprecatedTxt txt) +moduleWarn mod (DeprecatedTxt _ txt) = sep [ ptext (sLit "Module") <+> quotes (ppr mod) <+> ptext (sLit "is deprecated:"), nest 2 (vcat (map ppr txt)) ] diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 7f593f1398..cdd180bc22 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -381,28 +381,30 @@ rnPatAndThen mk (LitPat lit) | HsString src s <- lit = do { ovlStr <- liftCps (xoptM Opt_OverloadedStrings) ; if ovlStr - then rnPatAndThen mk (mkNPat (mkHsIsString src s placeHolderType) + then rnPatAndThen mk + (mkNPat (noLoc (mkHsIsString src s placeHolderType)) Nothing) else normal_lit } | otherwise = normal_lit where normal_lit = do { liftCps (rnLit lit); return (LitPat lit) } -rnPatAndThen _ (NPat lit mb_neg _eq) +rnPatAndThen _ (NPat (L l lit) mb_neg _eq) = do { lit' <- liftCpsFV $ rnOverLit lit ; mb_neg' <- liftCpsFV $ case mb_neg of Nothing -> return (Nothing, emptyFVs) Just _ -> do { (neg, fvs) <- lookupSyntaxName negateName ; return (Just neg, fvs) } ; eq' <- liftCpsFV $ lookupSyntaxName eqName - ; return (NPat lit' mb_neg' eq') } + ; return (NPat (L l lit') mb_neg' eq') } -rnPatAndThen mk (NPlusKPat rdr lit _ _) - = do { new_name <- newPatLName mk rdr +rnPatAndThen mk (NPlusKPat rdr (L l lit) _ _) + = do { new_name <- newPatName mk rdr ; lit' <- liftCpsFV $ rnOverLit lit ; minus <- liftCpsFV $ lookupSyntaxName minusName ; ge <- liftCpsFV $ lookupSyntaxName geName - ; return (NPlusKPat new_name lit' ge minus) } + ; return (NPlusKPat (L (nameSrcSpan new_name) new_name) + (L l lit') ge minus) } -- The Report says that n+k patterns must be in Integral rnPatAndThen mk (AsPat rdr pat) diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index d9536fbfae..ac86fc3227 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -168,7 +168,7 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls, (rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ; (rn_rule_decls, src_fvs3) <- setXOptM Opt_ScopedTypeVariables $ - rnList rnHsRuleDecl rule_decls ; + rnList rnHsRuleDecls rule_decls ; -- Inside RULES, scoped type variables are on (rn_vect_decls, src_fvs4) <- rnList rnHsVectDecl vect_decls ; (rn_foreign_decls, src_fvs5) <- rnList rnHsForeignDecl foreign_decls ; @@ -308,11 +308,11 @@ gather them together. -} -- checks that the deprecations are defined locally, and that there are no duplicates -rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings +rnSrcWarnDecls :: NameSet -> [LWarnDecls RdrName] -> RnM Warnings rnSrcWarnDecls _ [] = return NoWarnings -rnSrcWarnDecls bndr_set decls +rnSrcWarnDecls bndr_set decls' = do { -- check for duplicates ; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups in addErrAt loc (dupWarnDecl lrdr' rdr)) @@ -320,17 +320,21 @@ rnSrcWarnDecls bndr_set decls ; pairs_s <- mapM (addLocM rn_deprec) decls ; return (WarnSome ((concat pairs_s))) } where + decls = concatMap (\(L _ d) -> wd_warnings d) decls' + sig_ctxt = TopSigCtxt bndr_set True -- True <=> Can give deprecations for class ops and record sels - rn_deprec (Warning rdr_name txt) + rn_deprec (Warning rdr_names txt) -- ensures that the names are defined locally - = do { names <- lookupLocalTcNames sig_ctxt what rdr_name + = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc) + rdr_names ; return [(nameOccName name, txt) | name <- names] } what = ptext (sLit "deprecation") - warn_rdr_dups = findDupRdrNames (map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls) + warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning ns _)) -> ns) + decls findDupRdrNames :: [Located RdrName] -> [[Located RdrName]] findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) @@ -354,12 +358,13 @@ dupWarnDecl (L loc _) rdr_name -} rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars) -rnAnnDecl ann@(HsAnnotation provenance expr) +rnAnnDecl ann@(HsAnnotation s provenance expr) = addErrCtxt (annCtxt ann) $ do { (provenance', provenance_fvs) <- rnAnnProvenance provenance ; (expr', expr_fvs) <- setStage (Splice False) $ rnLExpr expr - ; return (HsAnnotation provenance' expr', provenance_fvs `plusFV` expr_fvs) } + ; return (HsAnnotation s provenance' expr', + provenance_fvs `plusFV` expr_fvs) } rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars) rnAnnProvenance provenance = do @@ -712,6 +717,11 @@ standaloneDerivErr ********************************************************* -} +rnHsRuleDecls :: RuleDecls RdrName -> RnM (RuleDecls Name, FreeVars) +rnHsRuleDecls (HsRules src rules) + = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules + ; return (HsRules src rn_rules,fvs) } + rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars) rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs) = do { let rdr_names_w_loc = map get_var vars @@ -832,35 +842,35 @@ badRuleLhsErr name lhs bad_e rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars) -- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly -- typecheck a complex right-hand side without invoking 'vectType' from the vectoriser. -rnHsVectDecl (HsVect var rhs@(L _ (HsVar _))) +rnHsVectDecl (HsVect s var rhs@(L _ (HsVar _))) = do { var' <- lookupLocatedOccRn var ; (rhs', fv_rhs) <- rnLExpr rhs - ; return (HsVect var' rhs', fv_rhs `addOneFV` unLoc var') + ; return (HsVect s var' rhs', fv_rhs `addOneFV` unLoc var') } -rnHsVectDecl (HsVect _var _rhs) +rnHsVectDecl (HsVect _ _var _rhs) = failWith $ vcat [ ptext (sLit "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma") , ptext (sLit "must be an identifier") ] -rnHsVectDecl (HsNoVect var) +rnHsVectDecl (HsNoVect s var) = do { var' <- lookupLocatedTopBndrRn var -- only applies to local (not imported) names - ; return (HsNoVect var', unitFV (unLoc var')) + ; return (HsNoVect s var', unitFV (unLoc var')) } -rnHsVectDecl (HsVectTypeIn isScalar tycon Nothing) +rnHsVectDecl (HsVectTypeIn s isScalar tycon Nothing) = do { tycon' <- lookupLocatedOccRn tycon - ; return (HsVectTypeIn isScalar tycon' Nothing, unitFV (unLoc tycon')) + ; return (HsVectTypeIn s isScalar tycon' Nothing, unitFV (unLoc tycon')) } -rnHsVectDecl (HsVectTypeIn isScalar tycon (Just rhs_tycon)) +rnHsVectDecl (HsVectTypeIn s isScalar tycon (Just rhs_tycon)) = do { tycon' <- lookupLocatedOccRn tycon ; rhs_tycon' <- lookupLocatedOccRn rhs_tycon - ; return ( HsVectTypeIn isScalar tycon' (Just rhs_tycon') + ; return ( HsVectTypeIn s isScalar tycon' (Just rhs_tycon') , mkFVs [unLoc tycon', unLoc rhs_tycon']) } rnHsVectDecl (HsVectTypeOut _ _ _) = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'" -rnHsVectDecl (HsVectClassIn cls) +rnHsVectDecl (HsVectClassIn s cls) = do { cls' <- lookupLocatedOccRn cls - ; return (HsVectClassIn cls', unitFV (unLoc cls')) + ; return (HsVectClassIn s cls', unitFV (unLoc cls')) } rnHsVectDecl (HsVectClassOut _) = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'" @@ -1310,8 +1320,8 @@ rnConDecl decl@(ConDecl { con_names = names, con_qvars = tvs ; rdr_env <- getLocalRdrEnv ; let arg_tys = hsConDeclArgTys details (free_kvs, free_tvs) = case res_ty of - ResTyH98 -> filterInScope rdr_env (get_rdr_tvs arg_tys) - ResTyGADT ty -> get_rdr_tvs (ty : arg_tys) + ResTyH98 -> filterInScope rdr_env (get_rdr_tvs arg_tys) + ResTyGADT _ ty -> get_rdr_tvs (ty : arg_tys) -- With an Explicit forall, check for unused binders -- With Implicit, find the mentioned ones, and use them as binders @@ -1341,12 +1351,12 @@ rnConDecl decl@(ConDecl { con_names = names, con_qvars = tvs get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys) rnConResult :: HsDocContext -> [Name] - -> HsConDetails (LHsType Name) [LConDeclField Name] + -> HsConDetails (LHsType Name) (Located [LConDeclField Name]) -> ResType (LHsType RdrName) - -> RnM (HsConDetails (LHsType Name) [LConDeclField Name], + -> RnM (HsConDetails (LHsType Name) (Located [LConDeclField Name]), ResType (LHsType Name), FreeVars) rnConResult _ _ details ResTyH98 = return (details, ResTyH98, emptyFVs) -rnConResult doc _con details (ResTyGADT ty) +rnConResult doc _con details (ResTyGADT ls ty) = do { (ty', fvs) <- rnLHsType doc ty ; let (arg_tys, res_ty) = splitHsFunType ty' -- We can finally split it up, @@ -1359,14 +1369,14 @@ rnConResult doc _con details (ResTyGADT ty) RecCon {} -> do { unless (null arg_tys) (addErr (badRecResTy (docOfHsDocContext doc))) - ; return (details, ResTyGADT res_ty, fvs) } + ; return (details, ResTyGADT ls res_ty, fvs) } - PrefixCon {} -> return (PrefixCon arg_tys, ResTyGADT res_ty, fvs) } + PrefixCon {} -> return (PrefixCon arg_tys, ResTyGADT ls res_ty, fvs)} rnConDeclDetails - :: HsDocContext - -> HsConDetails (LHsType RdrName) [LConDeclField RdrName] - -> RnM (HsConDetails (LHsType Name) [LConDeclField Name], FreeVars) + :: HsDocContext + -> HsConDetails (LHsType RdrName) (Located [LConDeclField RdrName]) + -> RnM (HsConDetails (LHsType Name) (Located [LConDeclField Name]), FreeVars) rnConDeclDetails doc (PrefixCon tys) = do { (new_tys, fvs) <- rnLHsTypes doc tys ; return (PrefixCon new_tys, fvs) } @@ -1376,11 +1386,11 @@ rnConDeclDetails doc (InfixCon ty1 ty2) ; (new_ty2, fvs2) <- rnLHsType doc ty2 ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } -rnConDeclDetails doc (RecCon fields) +rnConDeclDetails doc (RecCon (L l fields)) = do { (new_fields, fvs) <- rnConDeclFields doc fields -- No need to check for duplicate fields -- since that is done by RnNames.extendGlobalRdrEnvRn - ; return (RecCon new_fields, fvs) } + ; return (RecCon (L l new_fields), fvs) } ------------------------------------------------- deprecRecSyntax :: ConDecl RdrName -> SDoc @@ -1430,7 +1440,8 @@ extendRecordFieldEnv tycl_decls inst_decls get_con (ConDecl { con_names = cons, con_details = RecCon flds }) (RecFields env fld_set) = do { cons' <- mapM lookup cons - ; flds' <- mapM lookup (concatMap (cd_fld_names . unLoc) flds) + ; flds' <- mapM lookup (concatMap (cd_fld_names . unLoc) + (unLoc flds)) ; let env' = foldl (\e c -> extendNameEnv e c flds') env cons' fld_set' = extendNameSetList fld_set flds' @@ -1445,7 +1456,8 @@ extendRecordFieldEnv tycl_decls inst_decls ********************************************************* -} -rnFds :: [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)] +rnFds :: [Located (FunDep (Located RdrName))] + -> RnM [Located (FunDep (Located Name))] rnFds fds = mapM (wrapLocM rn_fds) fds where @@ -1454,11 +1466,13 @@ rnFds fds ; tys2' <- rnHsTyVars tys2 ; return (tys1', tys2') } -rnHsTyVars :: [RdrName] -> RnM [Name] +rnHsTyVars :: [Located RdrName] -> RnM [Located Name] rnHsTyVars tvs = mapM rnHsTyVar tvs -rnHsTyVar :: RdrName -> RnM Name -rnHsTyVar tyvar = lookupOccRn tyvar +rnHsTyVar :: Located RdrName -> RnM (Located Name) +rnHsTyVar (L l tyvar) = do + tyvar' <- lookupOccRn tyvar + return (L l tyvar') {- ********************************************************* diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 9eb2581748..8d3b79704b 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -265,8 +265,8 @@ rnHsTyKi isType _ tyLit@(HsTyLit t) ; when (negLit t) (addErr negLitErr) ; return (HsTyLit t, emptyFVs) } where - negLit (HsStrTy _) = False - negLit (HsNumTy i) = i < 0 + negLit (HsStrTy _ _) = False + negLit (HsNumTy _ i) = i < 0 negLitErr = ptext (sLit "Illegal literal in type (type literals must not be negative):") <+> ppr tyLit rnHsTyKi isType doc (HsAppTy ty1 ty2) @@ -425,12 +425,12 @@ bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside rn_tv_bndr (L loc (UserTyVar rdr)) = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr ; return (L loc (UserTyVar nm), emptyFVs) } - rn_tv_bndr (L loc (KindedTyVar rdr kind)) + rn_tv_bndr (L loc (KindedTyVar (L lv rdr) kind)) = do { sig_ok <- xoptM Opt_KindSignatures ; unless sig_ok (badSigErr False doc kind) ; nm <- newTyVarNameRn mb_assoc rdr_env loc rdr ; (kind', fvs) <- rnLHsKind doc kind - ; return (L loc (KindedTyVar nm kind'), fvs) } + ; return (L loc (KindedTyVar (L lv nm) kind'), fvs) } -- Check for duplicate or shadowed tyvar bindrs ; checkDupRdrNames tv_names_w_loc @@ -740,7 +740,7 @@ checkPrecMatch :: Name -> MatchGroup Name body -> RnM () checkPrecMatch op (MG { mg_alts = ms }) = mapM_ check ms where - check (L _ (Match (L l1 p1 : L l2 p2 :_) _ _)) + check (L _ (Match _ (L l1 p1 : L l2 p2 :_) _ _)) = setSrcSpan (combineSrcSpans l1 l2) $ do checkPrec op p1 False checkPrec op p2 True diff --git a/compiler/stranal/WorkWrap.hs b/compiler/stranal/WorkWrap.hs index eedababb43..7a94c1b3f3 100644 --- a/compiler/stranal/WorkWrap.hs +++ b/compiler/stranal/WorkWrap.hs @@ -335,7 +335,8 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs Just (work_demands, wrap_fn, work_fn) -> do work_uniq <- getUniqueM let work_rhs = work_fn rhs - work_prag = InlinePragma { inl_inline = inl_inline inl_prag + work_prag = InlinePragma { inl_src = "{-# INLINE" + , inl_inline = inl_inline inl_prag , inl_sat = Nothing , inl_act = wrap_act , inl_rule = FunLike } @@ -365,7 +366,8 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs wrap_act = ActiveAfter 0 wrap_rhs = wrap_fn work_id - wrap_prag = InlinePragma { inl_inline = Inline + wrap_prag = InlinePragma { inl_src = "{-# INLINE" + , inl_inline = Inline , inl_sat = Nothing , inl_act = wrap_act , inl_rule = rule_match_info } diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index 6b08822824..524c80635d 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -426,9 +426,9 @@ getOverlapFlag overlap_mode incoherent_ok = xopt Opt_IncoherentInstances dflags use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags , overlapMode = x } - default_oflag | incoherent_ok = use Incoherent - | overlap_ok = use Overlaps - | otherwise = use NoOverlap + default_oflag | incoherent_ok = use (Incoherent "") + | overlap_ok = use (Overlaps "") + | otherwise = use (NoOverlap "") final_oflag = setOverlapModeMaybe default_oflag overlap_mode ; return final_oflag } diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs index ca04569f28..474630b789 100644 --- a/compiler/typecheck/TcAnnotations.hs +++ b/compiler/typecheck/TcAnnotations.hs @@ -41,7 +41,7 @@ tcAnnotations :: [LAnnDecl Name] -> TcM [Annotation] tcAnnotations anns = mapM tcAnnotation anns tcAnnotation :: LAnnDecl Name -> TcM Annotation -tcAnnotation (L loc ann@(HsAnnotation provenance expr)) = do +tcAnnotation (L loc ann@(HsAnnotation _ provenance expr)) = do -- Work out what the full target of this annotation was mod <- getModule let target = annProvenanceToTarget mod provenance @@ -50,9 +50,9 @@ tcAnnotation (L loc ann@(HsAnnotation provenance expr)) = do setSrcSpan loc $ addErrCtxt (annCtxt ann) $ runAnnotation target expr annProvenanceToTarget :: Module -> AnnProvenance Name -> AnnTarget Name -annProvenanceToTarget _ (ValueAnnProvenance name) = NamedTarget name -annProvenanceToTarget _ (TypeAnnProvenance name) = NamedTarget name -annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod +annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) = NamedTarget name +annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name +annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod #endif annCtxt :: OutputableBndr id => AnnDecl id -> SDoc diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs index b4c3bcc60f..9ad65722cd 100644 --- a/compiler/typecheck/TcArrows.hs +++ b/compiler/typecheck/TcArrows.hs @@ -234,7 +234,9 @@ tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty) -- D;G |-a (\x.cmd) : (t,stk) --> res tc_cmd env - (HsCmdLam (MG { mg_alts = [L mtch_loc (match@(Match pats _maybe_rhs_sig grhss))], mg_origin = origin })) + (HsCmdLam (MG { mg_alts = [L mtch_loc + (match@(Match _ pats _maybe_rhs_sig grhss))], + mg_origin = origin })) (cmd_stk, res_ty) = addErrCtxt (pprMatchInCtxt match_ctxt match) $ do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk @@ -244,7 +246,7 @@ tc_cmd env tcPats LambdaExpr pats arg_tys $ tc_grhss grhss cmd_stk' res_ty - ; let match' = L mtch_loc (Match pats' Nothing grhss') + ; let match' = L mtch_loc (Match Nothing pats' Nothing grhss') arg_tys = map hsLPatType pats' cmd' = HsCmdLam (MG { mg_alts = [match'], mg_arg_tys = arg_tys , mg_res_ty = res_ty, mg_origin = origin }) diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index d1f3619d42..c0011b9a00 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -237,12 +237,12 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) } where - ips = [ip | L _ (IPBind (Left ip) _) <- ip_binds] + ips = [ip | L _ (IPBind (Left (L _ ip)) _) <- ip_binds] -- I wonder if we should do these one at at time -- Consider ?x = 4 -- ?y = ?x + 1 - tc_ip_bind ipClass (IPBind (Left ip) expr) + tc_ip_bind ipClass (IPBind (Left (L _ ip)) expr) = do { ty <- newFlexiTyVarTy openTypeKind ; let p = mkStrLitTy $ hsIPNameFS ip ; ip_id <- newDict ipClass [ p, ty ] @@ -1138,12 +1138,12 @@ tcVect :: VectDecl Name -> TcM (VectDecl TcId) -- during type checking. Instead, constrain the rhs of a vectorisation declaration to be a single -- identifier (this is checked in 'rnHsVectDecl'). Fix this by enabling the use of 'vectType' -- from the vectoriser here. -tcVect (HsVect name rhs) +tcVect (HsVect s name rhs) = addErrCtxt (vectCtxt name) $ do { var <- wrapLocM tcLookupId name ; let L rhs_loc (HsVar rhs_var_name) = rhs ; rhs_id <- tcLookupId rhs_var_name - ; return $ HsVect var (L rhs_loc (HsVar rhs_id)) + ; return $ HsVect s var (L rhs_loc (HsVar rhs_id)) } {- OLD CODE: @@ -1172,12 +1172,12 @@ tcVect (HsVect name rhs) ; return $ HsVect (L loc id') (Just rhsWrapped) } -} -tcVect (HsNoVect name) +tcVect (HsNoVect s name) = addErrCtxt (vectCtxt name) $ do { var <- wrapLocM tcLookupId name - ; return $ HsNoVect var + ; return $ HsNoVect s var } -tcVect (HsVectTypeIn isScalar lname rhs_name) +tcVect (HsVectTypeIn _ isScalar lname rhs_name) = addErrCtxt (vectCtxt lname) $ do { tycon <- tcLookupLocatedTyCon lname ; checkTc ( not isScalar -- either we have a non-SCALAR declaration @@ -1191,7 +1191,7 @@ tcVect (HsVectTypeIn isScalar lname rhs_name) } tcVect (HsVectTypeOut _ _ _) = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'" -tcVect (HsVectClassIn lname) +tcVect (HsVectClassIn _ lname) = addErrCtxt (vectCtxt lname) $ do { cls <- tcLookupLocatedClass lname ; return $ HsVectClassOut cls @@ -1684,8 +1684,8 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn restricted (PatSynBind {}) = panic "isRestrictedGroup/unrestricted PatSynBind" restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds" - restricted_match (MG { mg_alts = L _ (Match [] _ _) : _ }) = True - restricted_match _ = False + restricted_match (MG { mg_alts = L _ (Match _ [] _ _) : _ }) = True + restricted_match _ = False -- No args => like a pattern binding -- Some args => a function binding diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs index e113682112..4d6b3ce5b0 100644 --- a/compiler/typecheck/TcClassDcl.hs +++ b/compiler/typecheck/TcClassDcl.hs @@ -328,8 +328,8 @@ findMinimalDef :: [LSig Name] -> Maybe ClassMinimalDef findMinimalDef = firstJusts . map toMinimalDef where toMinimalDef :: LSig Name -> Maybe ClassMinimalDef - toMinimalDef (L _ (MinimalSig bf)) = Just (fmap unLoc bf) - toMinimalDef _ = Nothing + toMinimalDef (L _ (MinimalSig _ bf)) = Just (fmap unLoc bf) + toMinimalDef _ = Nothing {- Note [Polymorphic methods] diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index a3a9be3f80..360cd085d4 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -161,17 +161,17 @@ tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty ; return (HsPar expr') } -tcExpr (HsSCC lbl expr) res_ty +tcExpr (HsSCC src lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty - ; return (HsSCC lbl expr') } + ; return (HsSCC src lbl expr') } -tcExpr (HsTickPragma info expr) res_ty +tcExpr (HsTickPragma src info expr) res_ty = do { expr' <- tcMonoExpr expr res_ty - ; return (HsTickPragma info expr') } + ; return (HsTickPragma src info expr') } -tcExpr (HsCoreAnn lbl expr) res_ty +tcExpr (HsCoreAnn src lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty - ; return (HsCoreAnn lbl expr') } + ; return (HsCoreAnn src lbl expr') } tcExpr (HsOverLit lit) res_ty = do { lit' <- newOverloadedLit (LiteralOrigin lit) lit res_ty diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs index b4f9ae08ac..2c90c17baa 100644 --- a/compiler/typecheck/TcGenGenerics.hs +++ b/compiler/typecheck/TcGenGenerics.hs @@ -125,7 +125,7 @@ metaTyConsToDerivStuff tc metaDts = (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc mk_inst clas tc dfun_name = mkLocalInstance (mkDictFunId dfun_name [] [] clas tys) - OverlapFlag { overlapMode = NoOverlap + OverlapFlag { overlapMode = (NoOverlap "") , isSafeOverlap = safeLanguageOn dflags } [] clas tys where diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 27ba99beb7..3fa890112d 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -93,7 +93,7 @@ hsPatType (TuplePat _ bx tys) = mkTupleTy (boxityNormalTupleSort bx) tys hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys }) = conLikeResTy con tys hsPatType (SigPatOut _ ty) = ty -hsPatType (NPat lit _ _) = overLitType lit +hsPatType (NPat (L _ lit) _ _) = overLitType lit hsPatType (NPlusKPat id _ _ _) = idType (unLoc id) hsPatType (CoPat _ _ ty) = ty hsPatType p = pprPanic "hsPatType" (ppr p) @@ -541,10 +541,10 @@ zonkMatchGroup env zBody (MG { mg_alts = ms, mg_arg_tys = arg_tys, mg_res_ty = r zonkMatch :: ZonkEnv -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) -> LMatch TcId (Located (body TcId)) -> TcM (LMatch Id (Located (body Id))) -zonkMatch env zBody (L loc (Match pats _ grhss)) +zonkMatch env zBody (L loc (Match mf pats _ grhss)) = do { (env1, new_pats) <- zonkPats env pats ; new_grhss <- zonkGRHSs env1 zBody grhss - ; return (L loc (Match new_pats Nothing new_grhss)) } + ; return (L loc (Match mf new_pats Nothing new_grhss)) } ------------------------------------------------------------------------- zonkGRHSs :: ZonkEnv @@ -731,18 +731,18 @@ zonkExpr env (PArrSeq expr info) new_info <- zonkArithSeq env info return (PArrSeq new_expr new_info) -zonkExpr env (HsSCC lbl expr) +zonkExpr env (HsSCC src lbl expr) = do new_expr <- zonkLExpr env expr - return (HsSCC lbl new_expr) + return (HsSCC src lbl new_expr) -zonkExpr env (HsTickPragma info expr) +zonkExpr env (HsTickPragma src info expr) = do new_expr <- zonkLExpr env expr - return (HsTickPragma info new_expr) + return (HsTickPragma src info new_expr) -- hdaume: core annotations -zonkExpr env (HsCoreAnn lbl expr) +zonkExpr env (HsCoreAnn src lbl expr) = do new_expr <- zonkLExpr env expr - return (HsCoreAnn lbl new_expr) + return (HsCoreAnn src lbl new_expr) -- arrow notation extensions zonkExpr env (HsProc pat body) @@ -996,7 +996,8 @@ zonkRecFields env (HsRecFields flds dd) , hsRecFieldArg = new_expr })) } ------------------------------------------------------------------------- -mapIPNameTc :: (a -> TcM b) -> Either HsIPName a -> TcM (Either HsIPName b) +mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a + -> TcM (Either (Located HsIPName) b) mapIPNameTc _ (Left x) = return (Left x) mapIPNameTc f (Right x) = do r <- f x return (Right r) @@ -1096,18 +1097,19 @@ zonk_pat env (SigPatOut pat ty) ; (env', pat') <- zonkPat env pat ; return (env', SigPatOut pat' ty') } -zonk_pat env (NPat lit mb_neg eq_expr) +zonk_pat env (NPat (L l lit) mb_neg eq_expr) = do { lit' <- zonkOverLit env lit ; mb_neg' <- fmapMaybeM (zonkExpr env) mb_neg ; eq_expr' <- zonkExpr env eq_expr - ; return (env, NPat lit' mb_neg' eq_expr') } + ; return (env, NPat (L l lit') mb_neg' eq_expr') } -zonk_pat env (NPlusKPat (L loc n) lit e1 e2) +zonk_pat env (NPlusKPat (L loc n) (L l lit) e1 e2) = do { n' <- zonkIdBndr env n ; lit' <- zonkOverLit env lit ; e1' <- zonkExpr env e1 ; e2' <- zonkExpr env e2 - ; return (extendIdZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') } + ; return (extendIdZonkEnv1 env n', + NPlusKPat (L loc n') (L l lit') e1' e2') } zonk_pat env (CoPat co_fn pat ty) = do { (env', co_fn') <- zonkCoFn env co_fn @@ -1204,21 +1206,21 @@ zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id] zonkVects env = mapM (wrapLocM (zonkVect env)) zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id) -zonkVect env (HsVect v e) +zonkVect env (HsVect s v e) = do { v' <- wrapLocM (zonkIdBndr env) v ; e' <- zonkLExpr env e - ; return $ HsVect v' e' + ; return $ HsVect s v' e' } -zonkVect env (HsNoVect v) +zonkVect env (HsNoVect s v) = do { v' <- wrapLocM (zonkIdBndr env) v - ; return $ HsNoVect v' + ; return $ HsNoVect s v' } zonkVect _env (HsVectTypeOut s t rt) = return $ HsVectTypeOut s t rt -zonkVect _ (HsVectTypeIn _ _ _) = panic "TcHsSyn.zonkVect: HsVectTypeIn" +zonkVect _ (HsVectTypeIn _ _ _ _) = panic "TcHsSyn.zonkVect: HsVectTypeIn" zonkVect _env (HsVectClassOut c) = return $ HsVectClassOut c -zonkVect _ (HsVectClassIn _) = panic "TcHsSyn.zonkVect: HsVectClassIn" +zonkVect _ (HsVectClassIn _ _) = panic "TcHsSyn.zonkVect: HsVectClassIn" zonkVect _env (HsVectInstOut i) = return $ HsVectInstOut i zonkVect _ (HsVectInstIn _) = panic "TcHsSyn.zonkVect: HsVectInstIn" diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 1221b7f384..937b5e8edb 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -522,12 +522,12 @@ tc_hs_type ty@(HsSpliceTy {}) _exp_kind tc_hs_type (HsWrapTy {}) _exp_kind = panic "tc_hs_type HsWrapTy" -- We kind checked something twice -tc_hs_type hs_ty@(HsTyLit (HsNumTy n)) exp_kind +tc_hs_type hs_ty@(HsTyLit (HsNumTy _ n)) exp_kind = do { checkExpectedKind hs_ty typeNatKind exp_kind ; checkWiredInTyCon typeNatKindCon ; return (mkNumLitTy n) } -tc_hs_type hs_ty@(HsTyLit (HsStrTy s)) exp_kind +tc_hs_type hs_ty@(HsTyLit (HsStrTy _ s)) exp_kind = do { checkExpectedKind hs_ty typeSymbolKind exp_kind ; checkWiredInTyCon typeSymbolKindCon ; return (mkStrLitTy s) } @@ -958,7 +958,7 @@ kcHsTyVarBndrs cusk (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside _ | cusk -> return liftedTypeKind | otherwise -> newMetaKindVar ; return (n, kind) } - kc_hs_tv (KindedTyVar n k) + kc_hs_tv (KindedTyVar (L _ n) k) = do { kind <- tcLHsKind k -- In an associated type decl, the type variable may already -- be in scope; in that case we want to make sure its kind @@ -1103,7 +1103,7 @@ kcTyClTyVars name (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside kc_tv :: LHsTyVarBndr Name -> Kind -> TcM (Name, Kind) kc_tv (L _ (UserTyVar n)) exp_k = return (n, exp_k) - kc_tv (L _ (KindedTyVar n hs_k)) exp_k + kc_tv (L _ (KindedTyVar (L _ n) hs_k)) exp_k = do { k <- tcLHsKind hs_k ; checkKind k exp_k ; return (n, exp_k) } @@ -1144,9 +1144,10 @@ tcTyClTyVars tycon (HsQTvs { hsq_kvs = hs_kvs, hsq_tvs = hs_tvs }) thing_inside -- type T b_30 a_29 :: * -- Here the a_29 is shared tc_hs_tv (L _ (UserTyVar n)) kind = return (mkTyVar n kind) - tc_hs_tv (L _ (KindedTyVar n hs_k)) kind = do { tc_kind <- tcLHsKind hs_k - ; checkKind kind tc_kind - ; return (mkTyVar n kind) } + tc_hs_tv (L _ (KindedTyVar (L _ n) hs_k)) kind + = do { tc_kind <- tcLHsKind hs_k + ; checkKind kind tc_kind + ; return (mkTyVar n kind) } ----------------------------------- tcDataKindSig :: Kind -> TcM [TyVar] diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 7d897beee9..44441011c4 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -432,7 +432,9 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- (deriving can't be used there) && not (isHsBootOrSig (tcg_src env)) - overlapCheck ty = overlapMode (is_flag $ iSpec ty) /= NoOverlap + overlapCheck ty = case overlapMode (is_flag $ iSpec ty) of + NoOverlap _ -> False + _ -> True genInstCheck ty = is_cls_nm (iSpec ty) `elem` genericClassNames genInstErr i = hang (ptext (sLit $ "Generic instances can only be " ++ "derived in Safe Haskell.") $+$ @@ -1801,7 +1803,7 @@ tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) ------------------------------ tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag -tcSpecInst dfun_id prag@(SpecInstSig hs_ty) +tcSpecInst dfun_id prag@(SpecInstSig _ hs_ty) = addErrCtxt (spec_ctxt prag) $ do { (tyvars, theta, clas, tys) <- tcHsInstHead SpecInstCtxt hs_ty ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index af80e2e8c1..386a08d282 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -185,11 +185,11 @@ tcMatch :: (Outputable (body Name)) => TcMatchCtxt body tcMatch ctxt pat_tys rhs_ty match = wrapLocM (tc_match ctxt pat_tys rhs_ty) match where - tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss) + tc_match ctxt pat_tys rhs_ty match@(Match _ pats maybe_rhs_sig grhss) = add_match_ctxt match $ do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $ tc_grhss ctxt maybe_rhs_sig grhss rhs_ty - ; return (Match pats' Nothing grhss') } + ; return (Match Nothing pats' Nothing grhss') } tc_grhss ctxt Nothing grhss rhs_ty = tcGRHSs ctxt grhss rhs_ty -- No result signature @@ -857,4 +857,4 @@ checkArgs fun (MG { mg_alts = match1:matches }) bad_matches = [m | m <- matches, args_in_match m /= n_args1] args_in_match :: LMatch Name body -> Int - args_in_match (L _ (Match pats _ _)) = length pats + args_in_match (L _ (Match _ pats _ _)) = length pats diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index 819d3ecc94..f2a1341b2a 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -591,7 +591,7 @@ tc_pat _ (LitPat simple_lit) pat_ty thing_inside ------------------------ -- Overloaded patterns: n, and n+k -tc_pat _ (NPat over_lit mb_neg eq) pat_ty thing_inside +tc_pat _ (NPat (L l over_lit) mb_neg eq) pat_ty thing_inside = do { let orig = LiteralOrigin over_lit ; lit' <- newOverloadedLit orig over_lit pat_ty ; eq' <- tcSyntaxOp orig eq (mkFunTys [pat_ty, pat_ty] boolTy) @@ -602,9 +602,9 @@ tc_pat _ (NPat over_lit mb_neg eq) pat_ty thing_inside do { neg' <- tcSyntaxOp orig neg (mkFunTy pat_ty pat_ty) ; return (Just neg') } ; res <- thing_inside - ; return (NPat lit' mb_neg' eq', res) } + ; return (NPat (L l lit') mb_neg' eq', res) } -tc_pat penv (NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside +tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) ge minus) pat_ty thing_inside = do { (co, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) ; let pat_ty' = idType bndr_id orig = LiteralOrigin lit @@ -613,7 +613,7 @@ tc_pat penv (NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside -- The '>=' and '-' parts are re-mappable syntax ; ge' <- tcSyntaxOp orig ge (mkFunTys [pat_ty', pat_ty'] boolTy) ; minus' <- tcSyntaxOp orig minus (mkFunTys [pat_ty', pat_ty'] pat_ty') - ; let pat' = NPlusKPat (L nm_loc bndr_id) lit' ge' minus' + ; let pat' = NPlusKPat (L nm_loc bndr_id) (L loc lit') ge' minus' -- The Report says that n+k patterns must be in Integral -- We may not want this when using re-mappable syntax, though (ToDo?) diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index f572f78ae0..ce897fa0e6 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -523,8 +523,9 @@ tcPatToExpr args = go ; return (ExplicitTuple (map (noLoc . Present) exprs) box) } go1 (LitPat lit) = return $ HsLit lit - go1 (NPat n Nothing _) = return $ HsOverLit n - go1 (NPat n (Just neg) _) = return $ noLoc neg `HsApp` noLoc (HsOverLit n) + go1 (NPat (L _ n) Nothing _) = return $ HsOverLit n + go1 (NPat (L _ n) (Just neg) _) + = return $ noLoc neg `HsApp` noLoc (HsOverLit n) go1 (SigPatIn pat (HsWB ty _ _ wcs)) = do { expr <- go pat ; return $ ExprWithTySig expr ty wcs } diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index ea8f90c52d..16d0ef617c 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -1200,7 +1200,8 @@ tcTopSrcDecls boot_details -- bindings, rules, foreign decls ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds , tcg_sigs = tcg_sigs tcg_env `unionNameSet` sig_names - , tcg_rules = tcg_rules tcg_env ++ rules + , tcg_rules = tcg_rules tcg_env + ++ flattenRuleDecls rules , tcg_vects = tcg_vects tcg_env ++ vects , tcg_anns = tcg_anns tcg_env ++ annotations , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs index 927eda596d..53b8c896da 100644 --- a/compiler/typecheck/TcRules.hs +++ b/compiler/typecheck/TcRules.hs @@ -46,8 +46,13 @@ an example (test simplCore/should_compile/rule2.hs) produced by Roman: He wanted the rule to typecheck. -} -tcRules :: [LRuleDecl Name] -> TcM [LRuleDecl TcId] -tcRules decls = mapM (wrapLocM tcRule) decls +tcRules :: [LRuleDecls Name] -> TcM [LRuleDecls TcId] +tcRules decls = mapM (wrapLocM tcRuleDecls) decls + +tcRuleDecls :: RuleDecls Name -> TcM (RuleDecls TcId) +tcRuleDecls (HsRules src decls) + = do { tc_decls <- mapM (wrapLocM tcRule) decls + ; return (HsRules src tc_decls) } tcRule :: RuleDecl Name -> TcM (RuleDecl TcId) tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 8144029fa5..0850a0ec41 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -1664,12 +1664,12 @@ reifyFixity name conv_dir BasicTypes.InfixN = TH.InfixN reifyStrict :: DataCon.HsSrcBang -> TH.Strict -reifyStrict HsNoBang = TH.NotStrict -reifyStrict (HsSrcBang _ False) = TH.NotStrict -reifyStrict (HsSrcBang (Just True) True) = TH.Unpacked -reifyStrict (HsSrcBang _ True) = TH.IsStrict -reifyStrict HsStrict = TH.IsStrict -reifyStrict (HsUnpack {}) = TH.Unpacked +reifyStrict HsNoBang = TH.NotStrict +reifyStrict (HsSrcBang _ _ False) = TH.NotStrict +reifyStrict (HsSrcBang _ (Just True) True) = TH.Unpacked +reifyStrict (HsSrcBang _ _ True) = TH.IsStrict +reifyStrict HsStrict = TH.IsStrict +reifyStrict (HsUnpack {}) = TH.Unpacked ------------------------------ lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 27e2d45a03..b765129d0d 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -651,8 +651,8 @@ tcTyClDecl1 _parent rec_info -- NB: Order is important due to the call to `mkGlobalThings' when -- tying the the type and class declaration type checking knot. where - tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM tc_fd_tyvar tvs1 ; - ; tvs2' <- mapM tc_fd_tyvar tvs2 ; + tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM (tc_fd_tyvar . unLoc) tvs1 ; + ; tvs2' <- mapM (tc_fd_tyvar . unLoc) tvs2 ; ; return (tvs1', tvs2') } tc_fd_tyvar name -- Scoped kind variables are bound to unification variables -- which are now fixed, so we can zonk @@ -1135,8 +1135,8 @@ dataDeclChecks tc_name new_or_data stupid_theta cons ----------------------------------- consUseGadtSyntax :: [LConDecl a] -> Bool -consUseGadtSyntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = True -consUseGadtSyntax _ = False +consUseGadtSyntax (L _ (ConDecl { con_res = ResTyGADT _ _ }) : _) = True +consUseGadtSyntax _ = False -- All constructors have same shape ----------------------------------- @@ -1176,16 +1176,18 @@ tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl -- Data types -- ResTyGADT: *all* the quantified type variables -- c.f. the comment on con_qvars in HsDecls ; tkvs <- case res_ty of - ResTyH98 -> quantifyTyVars (mkVarSet tmpl_tvs) (tyVarsOfTypes (ctxt++arg_tys)) - ResTyGADT res_ty -> quantifyTyVars emptyVarSet (tyVarsOfTypes (res_ty:ctxt++arg_tys)) + ResTyH98 -> quantifyTyVars (mkVarSet tmpl_tvs) + (tyVarsOfTypes (ctxt++arg_tys)) + ResTyGADT _ res_ty -> quantifyTyVars emptyVarSet + (tyVarsOfTypes (res_ty:ctxt++arg_tys)) -- Zonk to Types ; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv tkvs ; arg_tys <- zonkTcTypeToTypes ze arg_tys ; ctxt <- zonkTcTypeToTypes ze ctxt ; res_ty <- case res_ty of - ResTyH98 -> return ResTyH98 - ResTyGADT ty -> ResTyGADT <$> zonkTcTypeToType ze ty + ResTyH98 -> return ResTyH98 + ResTyGADT ls ty -> ResTyGADT ls <$> zonkTcTypeToType ze ty ; let (univ_tvs, ex_tvs, eq_preds, res_ty') = rejigConRes tmpl_tvs res_tmpl qtkvs res_ty @@ -1206,14 +1208,14 @@ tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl -- Data types tcConIsInfix :: Name - -> HsConDetails (LHsType Name) [LConDeclField Name] + -> HsConDetails (LHsType Name) (Located [LConDeclField Name]) -> ResType Type -> TcM Bool tcConIsInfix _ details ResTyH98 = case details of InfixCon {} -> return True _ -> return False -tcConIsInfix con details (ResTyGADT _) +tcConIsInfix con details (ResTyGADT _ _) = case details of InfixCon {} -> return True RecCon {} -> return False @@ -1240,7 +1242,7 @@ tcConArgs new_or_data (RecCon fields) ; return (field_names, btys') } where -- We need a one-to-one mapping from field_names to btys - combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f)) fields + combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f)) (unLoc fields) explode (ns,ty) = zip (map unLoc ns) (repeat ty) exploded = concatMap explode combined (field_names,btys) = unzip exploded @@ -1254,8 +1256,8 @@ tcConArg new_or_data bty tcConRes :: ResType (LHsType Name) -> TcM (ResType Type) tcConRes ResTyH98 = return ResTyH98 -tcConRes (ResTyGADT res_ty) = do { res_ty' <- tcHsLiftedType res_ty - ; return (ResTyGADT res_ty') } +tcConRes (ResTyGADT ls res_ty) = do { res_ty' <- tcHsLiftedType res_ty + ; return (ResTyGADT ls res_ty') } {- Note [Infix GADT constructors] @@ -1323,7 +1325,7 @@ rejigConRes tmpl_tvs res_ty dc_tvs ResTyH98 -- data T a b c = forall d e. MkT ... -- The {a,b,c} are tc_tvs, and {d,e} are dc_tvs -rejigConRes tmpl_tvs res_tmpl dc_tvs (ResTyGADT res_ty) +rejigConRes tmpl_tvs res_tmpl dc_tvs (ResTyGADT _ res_ty) -- E.g. data T [a] b c where -- MkT :: forall x y z. T [(x,y)] z z -- Then we generate @@ -1589,7 +1591,7 @@ checkValidDataCon dflags existential_ok tc con } where ctxt = ConArgCtxt (dataConName con) - check_bang (HsSrcBang (Just want_unpack) has_bang, rep_bang, n) + check_bang (HsSrcBang _ (Just want_unpack) has_bang, rep_bang, n) | want_unpack, not has_bang = addWarnTc (bad_bang n (ptext (sLit "UNPACK pragma lacks '!'"))) | want_unpack diff --git a/compiler/types/Class.hs b/compiler/types/Class.hs index 946ed3d345..9ccece9802 100644 --- a/compiler/types/Class.hs +++ b/compiler/types/Class.hs @@ -78,8 +78,14 @@ data Class } deriving Typeable -type FunDep a = ([a],[a]) -- e.g. class C a b c | a b -> c, a c -> b where... - -- Here fun-deps are [([a,b],[c]), ([a,c],[b])] +-- | e.g. +-- +-- > class C a b c | a b -> c, a c -> b where... +-- +-- Here fun-deps are [([a,b],[c]), ([a,c],[b])] +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'', +type FunDep a = ([a],[a]) type ClassOpItem = (Id, DefMeth) -- Selector function; contains unfolding diff --git a/compiler/types/InstEnv.hs b/compiler/types/InstEnv.hs index c5d89533c8..da34cf8361 100644 --- a/compiler/types/InstEnv.hs +++ b/compiler/types/InstEnv.hs @@ -804,7 +804,7 @@ lookupInstEnv' ie vis_mods cls tys -- Does not match, so next check whether the things unify -- See Note [Overlapping instances] and Note [Incoherent instances] - | Incoherent <- overlapMode oflag + | Incoherent _ <- overlapMode oflag = find ms us rest | otherwise @@ -890,7 +890,9 @@ lookupInstEnv (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = v --------------- is_incoherent :: InstMatch -> Bool -is_incoherent (inst, _) = overlapMode (is_flag inst) == Incoherent +is_incoherent (inst, _) = case overlapMode (is_flag inst) of + Incoherent _ -> True + _ -> False --------------- insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch] diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index a83e613029..9b0d0cdca1 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -775,18 +775,20 @@ instance Binary Activation where return (ActiveAfter ab) instance Binary InlinePragma where - put_ bh (InlinePragma a b c d) = do + put_ bh (InlinePragma s a b c d) = do + put_ bh s put_ bh a put_ bh b put_ bh c put_ bh d get bh = do + s <- get bh a <- get bh b <- get bh c <- get bh d <- get bh - return (InlinePragma a b c d) + return (InlinePragma s a b c d) instance Binary RuleMatchInfo where put_ bh FunLike = putByte bh 0 @@ -832,19 +834,19 @@ instance Binary RecFlag where _ -> do return NonRecursive instance Binary OverlapMode where - put_ bh NoOverlap = putByte bh 0 - put_ bh Overlaps = putByte bh 1 - put_ bh Incoherent = putByte bh 2 - put_ bh Overlapping = putByte bh 3 - put_ bh Overlappable = putByte bh 4 + put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s + put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s + put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s + put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s + put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s get bh = do h <- getByte bh case h of - 0 -> return NoOverlap - 1 -> return Overlaps - 2 -> return Incoherent - 3 -> return Overlapping - 4 -> return Overlappable + 0 -> (get bh) >>= \s -> return $ NoOverlap s + 1 -> (get bh) >>= \s -> return $ Overlaps s + 2 -> (get bh) >>= \s -> return $ Incoherent s + 3 -> (get bh) >>= \s -> return $ Overlapping s + 4 -> (get bh) >>= \s -> return $ Overlappable s _ -> panic ("get OverlapMode" ++ show h) @@ -880,20 +882,24 @@ instance Binary Fixity where return (Fixity aa ab) instance Binary WarningTxt where - put_ bh (WarningTxt w) = do + put_ bh (WarningTxt s w) = do putByte bh 0 + put_ bh s put_ bh w - put_ bh (DeprecatedTxt d) = do + put_ bh (DeprecatedTxt s d) = do putByte bh 1 + put_ bh s put_ bh d get bh = do h <- getByte bh case h of - 0 -> do w <- get bh - return (WarningTxt w) - _ -> do d <- get bh - return (DeprecatedTxt d) + 0 -> do s <- get bh + w <- get bh + return (WarningTxt s w) + _ -> do s <- get bh + d <- get bh + return (DeprecatedTxt s d) instance Binary a => Binary (GenLocated SrcSpan a) where put_ bh (L l x) = do diff --git a/compiler/utils/OrdList.hs b/compiler/utils/OrdList.hs index 9e735e7d80..4591b55978 100644 --- a/compiler/utils/OrdList.hs +++ b/compiler/utils/OrdList.hs @@ -12,7 +12,7 @@ can be appended in linear time. {-# LANGUAGE CPP #-} module OrdList ( OrdList, - nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, + nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL, mapOL, fromOL, toOL, foldrOL, foldlOL ) where @@ -51,6 +51,7 @@ snocOL :: OrdList a -> a -> OrdList a consOL :: a -> OrdList a -> OrdList a appOL :: OrdList a -> OrdList a -> OrdList a concatOL :: [OrdList a] -> OrdList a +lastOL :: OrdList a -> a nilOL = None unitOL as = One as @@ -58,6 +59,13 @@ snocOL as b = Snoc as b consOL a bs = Cons a bs concatOL aas = foldr appOL None aas +lastOL None = panic "lastOL" +lastOL (One a) = a +lastOL (Many as) = last as +lastOL (Cons _ as) = lastOL as +lastOL (Snoc _ a) = a +lastOL (Two _ as) = lastOL as + isNilOL None = True isNilOL _ = False |