diff options
69 files changed, 1734 insertions, 1090 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 diff --git a/testsuite/tests/ghc-api/annotations/AnnotationLet.hs b/testsuite/tests/ghc-api/annotations/AnnotationLet.hs index de30f8baaf..ad67b927f4 100644 --- a/testsuite/tests/ghc-api/annotations/AnnotationLet.hs +++ b/testsuite/tests/ghc-api/annotations/AnnotationLet.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeOperators #-} module AnnotationLet (foo) where { @@ -8,5 +9,9 @@ foo = let a _ = 2 b = 2 in a b - +; +infixr 8 + +; +data ((f + g)) a = InL (f a) | InR (g a) +; } diff --git a/testsuite/tests/ghc-api/annotations/Makefile b/testsuite/tests/ghc-api/annotations/Makefile index 821aaa06ac..421154ea25 100644 --- a/testsuite/tests/ghc-api/annotations/Makefile +++ b/testsuite/tests/ghc-api/annotations/Makefile @@ -4,6 +4,7 @@ include $(TOP)/mk/test.mk clean: rm -f *.o *.hi + rm -f annotations comments parseTree annotations: rm -f annotations.o annotations.hi diff --git a/testsuite/tests/ghc-api/annotations/annotations.stdout b/testsuite/tests/ghc-api/annotations/annotations.stdout index 2142674f9b..e465403483 100644 --- a/testsuite/tests/ghc-api/annotations/annotations.stdout +++ b/testsuite/tests/ghc-api/annotations/annotations.stdout @@ -1,41 +1,35 @@ [ -(AK AnnotationLet.hs:1:1 AnnClose = [AnnotationLet.hs:12:1]) +(AK AnnotationLet.hs:1:1 AnnCloseC = [AnnotationLet.hs:17:1]) -(AK AnnotationLet.hs:1:1 AnnModule = [AnnotationLet.hs:1:1-6]) +(AK AnnotationLet.hs:1:1 AnnModule = [AnnotationLet.hs:2:1-6]) -(AK AnnotationLet.hs:1:1 AnnOpen = [AnnotationLet.hs:3:1]) +(AK AnnotationLet.hs:1:1 AnnOpenC = [AnnotationLet.hs:4:1]) -(AK AnnotationLet.hs:1:1 AnnSemi = [AnnotationLet.hs:5:1]) +(AK AnnotationLet.hs:1:1 AnnWhere = [AnnotationLet.hs:2:28-32]) -(AK AnnotationLet.hs:1:1 AnnWhere = [AnnotationLet.hs:1:28-32]) +(AK AnnotationLet.hs:2:22-26 AnnCloseP = [AnnotationLet.hs:2:26]) -(AK AnnotationLet.hs:1:22-26 AnnClose = [AnnotationLet.hs:1:26]) +(AK AnnotationLet.hs:2:22-26 AnnOpenP = [AnnotationLet.hs:2:22]) -(AK AnnotationLet.hs:1:22-26 AnnOpen = [AnnotationLet.hs:1:22]) +(AK AnnotationLet.hs:5:1-32 AnnAs = [AnnotationLet.hs:5:28-29]) -(AK AnnotationLet.hs:1:23-25 AnnVal = [AnnotationLet.hs:1:23-25]) +(AK AnnotationLet.hs:5:1-32 AnnImport = [AnnotationLet.hs:5:1-6]) -(AK AnnotationLet.hs:4:1-32 AnnAs = [AnnotationLet.hs:4:28-29]) +(AK AnnotationLet.hs:5:1-32 AnnQualified = [AnnotationLet.hs:5:8-16]) -(AK AnnotationLet.hs:4:1-32 AnnImport = [AnnotationLet.hs:4:1-6]) +(AK AnnotationLet.hs:5:1-32 AnnSemi = [AnnotationLet.hs:6:1]) -(AK AnnotationLet.hs:4:1-32 AnnQualified = [AnnotationLet.hs:4:8-16]) +(AK AnnotationLet.hs:5:1-32 AnnVal = [AnnotationLet.hs:5:31-32]) -(AK AnnotationLet.hs:4:1-32 AnnVal = [AnnotationLet.hs:4:31-32]) +(AK AnnotationLet.hs:(7,1)-(11,12) AnnEqual = [AnnotationLet.hs:7:5]) -(AK AnnotationLet.hs:(6,1)-(10,12) AnnEqual = [AnnotationLet.hs:6:5]) +(AK AnnotationLet.hs:(7,1)-(11,12) AnnFunId = [AnnotationLet.hs:7:1-3]) -(AK AnnotationLet.hs:(6,1)-(10,12) AnnFunId = [AnnotationLet.hs:6:1-3]) +(AK AnnotationLet.hs:(7,1)-(11,12) AnnSemi = [AnnotationLet.hs:12:1]) -(AK AnnotationLet.hs:(6,7)-(10,12) AnnIn = [AnnotationLet.hs:10:7-8]) +(AK AnnotationLet.hs:(7,7)-(11,12) AnnIn = [AnnotationLet.hs:11:7-8]) -(AK AnnotationLet.hs:(6,7)-(10,12) AnnLet = [AnnotationLet.hs:6:7-9]) - -(AK AnnotationLet.hs:7:9-15 AnnEqual = [AnnotationLet.hs:7:13]) - -(AK AnnotationLet.hs:7:9-15 AnnFunId = [AnnotationLet.hs:7:9]) - -(AK AnnotationLet.hs:7:9-15 AnnSemi = [AnnotationLet.hs:8:9]) +(AK AnnotationLet.hs:(7,7)-(11,12) AnnLet = [AnnotationLet.hs:7:7-9]) (AK AnnotationLet.hs:8:9-15 AnnEqual = [AnnotationLet.hs:8:13]) @@ -43,13 +37,53 @@ (AK AnnotationLet.hs:8:9-15 AnnSemi = [AnnotationLet.hs:9:9]) -(AK AnnotationLet.hs:9:9-13 AnnEqual = [AnnotationLet.hs:9:11]) +(AK AnnotationLet.hs:9:9-15 AnnEqual = [AnnotationLet.hs:9:13]) + +(AK AnnotationLet.hs:9:9-15 AnnFunId = [AnnotationLet.hs:9:9]) + +(AK AnnotationLet.hs:9:9-15 AnnSemi = [AnnotationLet.hs:10:9]) + +(AK AnnotationLet.hs:10:9-13 AnnEqual = [AnnotationLet.hs:10:11]) + +(AK AnnotationLet.hs:10:9-13 AnnFunId = [AnnotationLet.hs:10:9]) + +(AK AnnotationLet.hs:13:1-10 AnnInfix = [AnnotationLet.hs:13:1-6]) + +(AK AnnotationLet.hs:13:1-10 AnnSemi = [AnnotationLet.hs:14:1]) + +(AK AnnotationLet.hs:13:1-10 AnnVal = [AnnotationLet.hs:13:8]) + +(AK AnnotationLet.hs:15:1-40 AnnCloseP = [AnnotationLet.hs:15:14, AnnotationLet.hs:15:13]) + +(AK AnnotationLet.hs:15:1-40 AnnData = [AnnotationLet.hs:15:1-4]) + +(AK AnnotationLet.hs:15:1-40 AnnEqual = [AnnotationLet.hs:15:18]) + +(AK AnnotationLet.hs:15:1-40 AnnOpenP = [AnnotationLet.hs:15:6, AnnotationLet.hs:15:7]) + +(AK AnnotationLet.hs:15:1-40 AnnSemi = [AnnotationLet.hs:16:1]) + +(AK AnnotationLet.hs:15:6-14 AnnCloseP = [AnnotationLet.hs:15:14]) + +(AK AnnotationLet.hs:15:6-14 AnnOpenP = [AnnotationLet.hs:15:6]) + +(AK AnnotationLet.hs:15:7-13 AnnCloseP = [AnnotationLet.hs:15:13]) + +(AK AnnotationLet.hs:15:7-13 AnnOpenP = [AnnotationLet.hs:15:7]) + +(AK AnnotationLet.hs:15:20-28 AnnVbar = [AnnotationLet.hs:15:30]) + +(AK AnnotationLet.hs:15:24-28 AnnCloseP = [AnnotationLet.hs:15:28]) + +(AK AnnotationLet.hs:15:24-28 AnnOpenP = [AnnotationLet.hs:15:24]) + +(AK AnnotationLet.hs:15:36-40 AnnCloseP = [AnnotationLet.hs:15:40]) -(AK AnnotationLet.hs:9:9-13 AnnFunId = [AnnotationLet.hs:9:9]) +(AK AnnotationLet.hs:15:36-40 AnnOpenP = [AnnotationLet.hs:15:36]) -(AK <no location info> AnnEofPos = [AnnotationLet.hs:13:1]) +(AK <no location info> AnnEofPos = [AnnotationLet.hs:18:1]) ] -[AnnotationLet.hs:1:1-6] +[AnnotationLet.hs:2:1-6] [] AnnotationLet.hs:1:1 diff --git a/testsuite/tests/ghc-api/annotations/parseTree.stdout b/testsuite/tests/ghc-api/annotations/parseTree.stdout index cf8b82e029..0638608c6b 100644 --- a/testsuite/tests/ghc-api/annotations/parseTree.stdout +++ b/testsuite/tests/ghc-api/annotations/parseTree.stdout @@ -11,21 +11,17 @@ (AnnotationTuple.hs:15:25, [m], ()), (AnnotationTuple.hs:15:26, [m], ())] [ -(AK AnnotationTuple.hs:1:1 AnnClose = [AnnotationTuple.hs:16:1]) +(AK AnnotationTuple.hs:1:1 AnnCloseC = [AnnotationTuple.hs:16:1]) (AK AnnotationTuple.hs:1:1 AnnModule = [AnnotationTuple.hs:2:1-6]) -(AK AnnotationTuple.hs:1:1 AnnOpen = [AnnotationTuple.hs:4:1]) - -(AK AnnotationTuple.hs:1:1 AnnSemi = [AnnotationTuple.hs:6:1]) +(AK AnnotationTuple.hs:1:1 AnnOpenC = [AnnotationTuple.hs:4:1]) (AK AnnotationTuple.hs:1:1 AnnWhere = [AnnotationTuple.hs:2:30-34]) -(AK AnnotationTuple.hs:2:24-28 AnnClose = [AnnotationTuple.hs:2:28]) - -(AK AnnotationTuple.hs:2:24-28 AnnOpen = [AnnotationTuple.hs:2:24]) +(AK AnnotationTuple.hs:2:24-28 AnnCloseP = [AnnotationTuple.hs:2:28]) -(AK AnnotationTuple.hs:2:25-27 AnnVal = [AnnotationTuple.hs:2:25-27]) +(AK AnnotationTuple.hs:2:24-28 AnnOpenP = [AnnotationTuple.hs:2:24]) (AK AnnotationTuple.hs:5:1-32 AnnAs = [AnnotationTuple.hs:5:28-29]) @@ -33,6 +29,8 @@ (AK AnnotationTuple.hs:5:1-32 AnnQualified = [AnnotationTuple.hs:5:8-16]) +(AK AnnotationTuple.hs:5:1-32 AnnSemi = [AnnotationTuple.hs:6:1]) + (AK AnnotationTuple.hs:5:1-32 AnnVal = [AnnotationTuple.hs:5:31-32]) (AK AnnotationTuple.hs:(7,1)-(10,14) AnnEqual = [AnnotationTuple.hs:7:5]) @@ -55,15 +53,19 @@ (AK AnnotationTuple.hs:9:9-13 AnnFunId = [AnnotationTuple.hs:9:9]) +(AK AnnotationTuple.hs:10:10-14 AnnVal = [AnnotationTuple.hs:10:12]) + (AK AnnotationTuple.hs:13:1-72 AnnEqual = [AnnotationTuple.hs:13:5]) (AK AnnotationTuple.hs:13:1-72 AnnFunId = [AnnotationTuple.hs:13:1-3]) (AK AnnotationTuple.hs:13:1-72 AnnSemi = [AnnotationTuple.hs:14:1]) -(AK AnnotationTuple.hs:13:19-53 AnnClose = [AnnotationTuple.hs:13:53]) +(AK AnnotationTuple.hs:13:7-72 AnnVal = [AnnotationTuple.hs:13:13]) + +(AK AnnotationTuple.hs:13:19-53 AnnCloseP = [AnnotationTuple.hs:13:53]) -(AK AnnotationTuple.hs:13:19-53 AnnOpen = [AnnotationTuple.hs:13:19]) +(AK AnnotationTuple.hs:13:19-53 AnnOpenP = [AnnotationTuple.hs:13:19]) (AK AnnotationTuple.hs:13:20 AnnComma = [AnnotationTuple.hs:13:21]) @@ -73,9 +75,9 @@ (AK AnnotationTuple.hs:13:39 AnnComma = [AnnotationTuple.hs:13:39]) -(AK AnnotationTuple.hs:13:41-52 AnnClose = [AnnotationTuple.hs:13:52]) +(AK AnnotationTuple.hs:13:41-52 AnnCloseS = [AnnotationTuple.hs:13:52]) -(AK AnnotationTuple.hs:13:41-52 AnnOpen = [AnnotationTuple.hs:13:41]) +(AK AnnotationTuple.hs:13:41-52 AnnOpenS = [AnnotationTuple.hs:13:41]) (AK AnnotationTuple.hs:13:42 AnnComma = [AnnotationTuple.hs:13:43]) @@ -83,23 +85,23 @@ (AK AnnotationTuple.hs:13:48 AnnComma = [AnnotationTuple.hs:13:49]) -(AK AnnotationTuple.hs:13:55-72 AnnClose = [AnnotationTuple.hs:13:72]) +(AK AnnotationTuple.hs:13:55-72 AnnCloseS = [AnnotationTuple.hs:13:72]) -(AK AnnotationTuple.hs:13:55-72 AnnOpen = [AnnotationTuple.hs:13:55]) +(AK AnnotationTuple.hs:13:55-72 AnnOpenS = [AnnotationTuple.hs:13:55]) (AK AnnotationTuple.hs:13:56-62 AnnComma = [AnnotationTuple.hs:13:63]) -(AK AnnotationTuple.hs:13:61-62 AnnClose = [AnnotationTuple.hs:13:62]) +(AK AnnotationTuple.hs:13:61-62 AnnCloseP = [AnnotationTuple.hs:13:62]) -(AK AnnotationTuple.hs:13:61-62 AnnOpen = [AnnotationTuple.hs:13:61]) +(AK AnnotationTuple.hs:13:61-62 AnnOpenP = [AnnotationTuple.hs:13:61]) (AK AnnotationTuple.hs:15:1-41 AnnEqual = [AnnotationTuple.hs:15:5]) (AK AnnotationTuple.hs:15:1-41 AnnFunId = [AnnotationTuple.hs:15:1-3]) -(AK AnnotationTuple.hs:15:7-27 AnnClose = [AnnotationTuple.hs:15:27]) +(AK AnnotationTuple.hs:15:7-27 AnnCloseP = [AnnotationTuple.hs:15:27]) -(AK AnnotationTuple.hs:15:7-27 AnnOpen = [AnnotationTuple.hs:15:7]) +(AK AnnotationTuple.hs:15:7-27 AnnOpenP = [AnnotationTuple.hs:15:7]) (AK AnnotationTuple.hs:15:8 AnnComma = [AnnotationTuple.hs:15:9]) @@ -113,13 +115,13 @@ (AK AnnotationTuple.hs:15:26 AnnComma = [AnnotationTuple.hs:15:26]) -(AK AnnotationTuple.hs:15:33-41 AnnClose = [AnnotationTuple.hs:15:41]) +(AK AnnotationTuple.hs:15:33-41 AnnCloseP = [AnnotationTuple.hs:15:41]) -(AK AnnotationTuple.hs:15:33-41 AnnOpen = [AnnotationTuple.hs:15:33]) +(AK AnnotationTuple.hs:15:33-41 AnnOpenP = [AnnotationTuple.hs:15:33]) -(AK AnnotationTuple.hs:15:39-40 AnnClose = [AnnotationTuple.hs:15:40]) +(AK AnnotationTuple.hs:15:39-40 AnnCloseP = [AnnotationTuple.hs:15:40]) -(AK AnnotationTuple.hs:15:39-40 AnnOpen = [AnnotationTuple.hs:15:39]) +(AK AnnotationTuple.hs:15:39-40 AnnOpenP = [AnnotationTuple.hs:15:39]) (AK <no location info> AnnEofPos = [AnnotationTuple.hs:21:1]) ] diff --git a/testsuite/tests/ghc-api/landmines/landmines.stdout b/testsuite/tests/ghc-api/landmines/landmines.stdout index 5d9fd71ea2..fc538141bb 100644 --- a/testsuite/tests/ghc-api/landmines/landmines.stdout +++ b/testsuite/tests/ghc-api/landmines/landmines.stdout @@ -1,4 +1,4 @@ -(9,9,6) -(46,42,0) -(11,10,6) -(7,7,6) +(10,9,6) +(49,45,0) +(12,10,6) +(8,7,6) diff --git a/utils/haddock b/utils/haddock -Subproject 04cf63d0195837ed52075ed7d2676e71831e8a0 +Subproject d61bbc75890e4eb0ad508b9c2a27b91f691213e |