Commit e6191d1c authored by Alan Zimmerman's avatar Alan Zimmerman

ApiAnnotations : strings in warnings do not return SourceText

Summary:
The strings used in a WARNING pragma are captured via

    strings :: { Located ([AddAnn],[Located FastString]) }
        : STRING { sL1 $1 ([],[L (gl $1) (getSTRING $1)]) }
    ..

The STRING token has a method getSTRINGs that returns the original
source text for a string.

A warning of the form

    {-# WARNING Logic
              , mkSolver
              , mkSimpleSolver
              , mkSolverForLogic
              , solverSetParams
              , solverPush
              , solverPop
              , solverReset
              , solverGetNumScopes
              , solverAssertCnstr
              , solverAssertAndTrack
              , solverCheck
              , solverCheckAndGetModel
              , solverGetReasonUnknown
              "New Z3 API support is still incomplete and fragile: \
              \you may experience segmentation faults!"
      #-}

returns the concatenated warning string rather than the original source.

This patch now deals with all remaining instances of getSTRING to bring
in a SourceText for each.

This updates the haddock submodule as well, for the AST change.

Test Plan: ./validate

Reviewers: hvr, austin, goldfire

Reviewed By: austin

Subscribers: bgamari, thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D907

GHC Trac Issues: #10313
parent 7dd0ea74
...@@ -268,14 +268,18 @@ initialVersion = 1 ...@@ -268,14 +268,18 @@ initialVersion = 1
-- reason/explanation from a WARNING or DEPRECATED pragma -- reason/explanation from a WARNING or DEPRECATED pragma
-- For SourceText usage, see note [Pragma source text] -- For SourceText usage, see note [Pragma source text]
data WarningTxt = WarningTxt (Located SourceText) [Located FastString] data WarningTxt = WarningTxt (Located SourceText)
| DeprecatedTxt (Located SourceText) [Located FastString] [Located (SourceText,FastString)]
| DeprecatedTxt (Located SourceText)
[Located (SourceText,FastString)]
deriving (Eq, Data, Typeable) deriving (Eq, Data, Typeable)
instance Outputable WarningTxt where instance Outputable WarningTxt where
ppr (WarningTxt _ ws) = doubleQuotes (vcat (map (ftext . unLoc) ws)) ppr (WarningTxt _ ws)
ppr (DeprecatedTxt _ ds) = text "Deprecated:" <+> = doubleQuotes (vcat (map (ftext . snd . unLoc) ws))
doubleQuotes (vcat (map (ftext . unLoc) ds)) ppr (DeprecatedTxt _ ds)
= text "Deprecated:" <+>
doubleQuotes (vcat (map (ftext . snd . unLoc) ds))
{- {-
************************************************************************ ************************************************************************
......
...@@ -79,9 +79,9 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty ...@@ -79,9 +79,9 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty
; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty
; let ((call_args, arg_hints), cmm_target) ; let ((call_args, arg_hints), cmm_target)
= case target of = case target of
StaticTarget _ _ False -> StaticTarget _ _ _ False ->
panic "cgForeignCall: unexpected FFI value import" panic "cgForeignCall: unexpected FFI value import"
StaticTarget lbl mPkgId True StaticTarget _ lbl mPkgId True
-> let labelSource -> let labelSource
= case mPkgId of = case mPkgId of
Nothing -> ForeignLabelInThisPackage Nothing -> ForeignLabelInThisPackage
......
...@@ -372,7 +372,7 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs)) ...@@ -372,7 +372,7 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
fn_name = idName fn_id fn_name = idName fn_id
final_rhs = simpleOptExpr rhs'' -- De-crap it final_rhs = simpleOptExpr rhs'' -- De-crap it
rule = mkRule False {- Not auto -} is_local rule = mkRule False {- Not auto -} is_local
(unLoc name) act fn_name final_bndrs args (snd $ unLoc name) act fn_name final_bndrs args
final_rhs final_rhs
inline_shadows_rule -- Function can be inlined before rule fires inline_shadows_rule -- Function can be inlined before rule fires
...@@ -391,7 +391,7 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs)) ...@@ -391,7 +391,7 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
; when inline_shadows_rule $ ; when inline_shadows_rule $
warnDs (vcat [ hang (ptext (sLit "Rule") warnDs (vcat [ hang (ptext (sLit "Rule")
<+> doubleQuotes (ftext $ unLoc name) <+> doubleQuotes (ftext $ snd $ unLoc name)
<+> ptext (sLit "may never fire")) <+> ptext (sLit "may never fire"))
2 (ptext (sLit "because") <+> quotes (ppr fn_id) 2 (ptext (sLit "because") <+> quotes (ppr fn_id)
<+> ptext (sLit "might inline first")) <+> ptext (sLit "might inline first"))
......
...@@ -37,6 +37,7 @@ import TysPrim ...@@ -37,6 +37,7 @@ import TysPrim
import TyCon import TyCon
import TysWiredIn import TysWiredIn
import BasicTypes import BasicTypes
import FastString ( unpackFS )
import Literal import Literal
import PrelNames import PrelNames
import VarSet import VarSet
...@@ -95,7 +96,7 @@ dsCCall lbl args may_gc result_ty ...@@ -95,7 +96,7 @@ dsCCall lbl args may_gc result_ty
uniq <- newUnique uniq <- newUnique
dflags <- getDynFlags dflags <- getDynFlags
let let
target = StaticTarget lbl Nothing True target = StaticTarget (unpackFS lbl) lbl Nothing True
the_fcall = CCall (CCallSpec target CCallConv may_gc) the_fcall = CCall (CCallSpec target CCallConv may_gc)
the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty
return (foldr ($) (res_wrapper the_prim_app) arg_wrappers) return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
......
...@@ -302,7 +302,7 @@ dsExpr (HsSCC _ cc expr@(L loc _)) = do ...@@ -302,7 +302,7 @@ dsExpr (HsSCC _ cc expr@(L loc _)) = do
mod_name <- getModule mod_name <- getModule
count <- goptM Opt_ProfCountEntries count <- goptM Opt_ProfCountEntries
uniq <- newUnique uniq <- newUnique
Tick (ProfNote (mkUserCC cc mod_name loc uniq) count True) Tick (ProfNote (mkUserCC (snd cc) mod_name loc uniq) count True)
<$> dsLExpr expr <$> dsLExpr expr
else dsLExpr expr else dsLExpr expr
......
...@@ -108,7 +108,7 @@ dsForeigns' fos = do ...@@ -108,7 +108,7 @@ dsForeigns' fos = do
return (h, c, [], bs) return (h, c, [], bs)
do_decl (ForeignExport (L _ id) _ co do_decl (ForeignExport (L _ id) _ co
(CExport (L _ (CExportStatic ext_nm cconv)) _)) = do (CExport (L _ (CExportStatic _ ext_nm cconv)) _)) = do
(h, c, _, _) <- dsFExport id co ext_nm cconv False (h, c, _, _) <- dsFExport id co ext_nm cconv False
return (h, c, [id], []) return (h, c, [id], [])
...@@ -223,13 +223,18 @@ dsFCall fn_id co fcall mDeclHeader = do ...@@ -223,13 +223,18 @@ dsFCall fn_id co fcall mDeclHeader = do
dflags <- getDynFlags dflags <- getDynFlags
(fcall', cDoc) <- (fcall', cDoc) <-
case fcall of case fcall of
CCall (CCallSpec (StaticTarget cName mPackageKey isFun) CApiConv safety) -> CCall (CCallSpec (StaticTarget _ cName mPackageKey isFun)
CApiConv safety) ->
do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName) do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)
let fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageKey True) CApiConv safety) let fcall' = CCall (CCallSpec
(StaticTarget (unpackFS wrapperName)
wrapperName mPackageKey
True)
CApiConv safety)
c = includes c = includes
$$ fun_proto <+> braces (cRet <> semi) $$ fun_proto <+> braces (cRet <> semi)
includes = vcat [ text "#include <" <> ftext h <> text ">" includes = vcat [ text "#include <" <> ftext h <> text ">"
| Header h <- nub headers ] | Header _ h <- nub headers ]
fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
cRet cRet
| isVoidRes = cCall | isVoidRes = cCall
...@@ -713,7 +718,7 @@ toCType = f False ...@@ -713,7 +718,7 @@ toCType = f False
-- Note that we aren't looking through type synonyms or -- Note that we aren't looking through type synonyms or
-- anything, as it may be the synonym that is annotated. -- anything, as it may be the synonym that is annotated.
| TyConApp tycon _ <- t | TyConApp tycon _ <- t
, Just (CType _ mHeader cType) <- tyConCType_maybe tycon , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon
= (mHeader, ftext cType) = (mHeader, ftext cType)
-- If we don't know a C type for this type, then try looking -- If we don't know a C type for this type, then try looking
-- through one layer of type synonym etc. -- through one layer of type synonym etc.
......
...@@ -483,15 +483,17 @@ repForD (L loc (ForeignImport name typ _ (CImport (L _ cc) (L _ s) mch cis _))) ...@@ -483,15 +483,17 @@ repForD (L loc (ForeignImport name typ _ (CImport (L _ cc) (L _ s) mch cis _)))
where where
conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls)) conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
conv_cimportspec (CFunction DynamicTarget) = return "dynamic" conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
conv_cimportspec (CFunction (StaticTarget fs _ True)) = return (unpackFS fs) conv_cimportspec (CFunction (StaticTarget _ fs _ True))
conv_cimportspec (CFunction (StaticTarget _ _ False)) = panic "conv_cimportspec: values not supported yet" = return (unpackFS fs)
conv_cimportspec (CFunction (StaticTarget _ _ _ False))
= panic "conv_cimportspec: values not supported yet"
conv_cimportspec CWrapper = return "wrapper" conv_cimportspec CWrapper = return "wrapper"
static = case cis of static = case cis of
CFunction (StaticTarget _ _ _) -> "static " CFunction (StaticTarget _ _ _ _) -> "static "
_ -> "" _ -> ""
chStr = case mch of chStr = case mch of
Nothing -> "" Nothing -> ""
Just (Header h) -> unpackFS h ++ " " Just (Header _ h) -> unpackFS h ++ " "
repForD decl = notHandled "Foreign declaration" (ppr decl) repForD decl = notHandled "Foreign declaration" (ppr decl)
repCCallConv :: CCallConv -> DsM (Core TH.Callconv) repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
...@@ -525,7 +527,7 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _)) ...@@ -525,7 +527,7 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
; ss <- mkGenSyms bndr_names ; ss <- mkGenSyms bndr_names
; rule1 <- addBinds ss $ ; rule1 <- addBinds ss $
do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs
; n' <- coreStringLit $ unpackFS $ unLoc n ; n' <- coreStringLit $ unpackFS $ snd $ unLoc n
; act' <- repPhases act ; act' <- repPhases act
; lhs' <- repLE lhs ; lhs' <- repLE lhs
; rhs' <- repLE rhs ; rhs' <- repLE rhs
......
...@@ -1017,9 +1017,9 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l ...@@ -1017,9 +1017,9 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
DynamicTarget DynamicTarget
-> return (False, panic "ByteCodeGen.generateCCall(dyn)") -> return (False, panic "ByteCodeGen.generateCCall(dyn)")
StaticTarget _ _ False -> StaticTarget _ _ _ False ->
panic "generateCCall: unexpected FFI value import" panic "generateCCall: unexpected FFI value import"
StaticTarget target _ True StaticTarget _ target _ True
-> do res <- ioToBc (lookupStaticPtr stdcall_adj_target) -> do res <- ioToBc (lookupStaticPtr stdcall_adj_target)
return (True, res) return (True, res)
where where
......
...@@ -491,7 +491,8 @@ cvtForD (ImportF callconv safety from nm ty) ...@@ -491,7 +491,8 @@ cvtForD (ImportF callconv safety from nm ty)
cvtForD (ExportF callconv as nm ty) cvtForD (ExportF callconv as nm ty)
= do { nm' <- vNameL nm = do { nm' <- vNameL nm
; ty' <- cvtType ty ; ty' <- cvtType ty
; let e = CExport (noLoc (CExportStatic (mkFastString as) ; let e = CExport (noLoc (CExportStatic as
(mkFastString as)
(cvt_conv callconv))) (cvt_conv callconv)))
(noLoc as) (noLoc as)
; return $ ForeignExport nm' ty' noForeignExportCoercionYet e } ; return $ ForeignExport nm' ty' noForeignExportCoercionYet e }
...@@ -542,7 +543,7 @@ cvtPragmaD (RuleP nm bndrs lhs rhs phases) ...@@ -542,7 +543,7 @@ cvtPragmaD (RuleP nm bndrs lhs rhs phases)
; lhs' <- cvtl lhs ; lhs' <- cvtl lhs
; rhs' <- cvtl rhs ; rhs' <- cvtl rhs
; returnJustL $ Hs.RuleD ; returnJustL $ Hs.RuleD
$ HsRules "{-# RULES" [noLoc $ HsRule (noLoc nm') act bndrs' $ HsRules "{-# RULES" [noLoc $ HsRule (noLoc (nm,nm')) act bndrs'
lhs' placeHolderNames lhs' placeHolderNames
rhs' placeHolderNames] rhs' placeHolderNames]
} }
......
...@@ -1414,11 +1414,11 @@ instance Outputable ForeignImport where ...@@ -1414,11 +1414,11 @@ instance Outputable ForeignImport where
where where
pp_hdr = case mHeader of pp_hdr = case mHeader of
Nothing -> empty Nothing -> empty
Just (Header header) -> ftext header Just (Header _ header) -> ftext header
pprCEntity (CLabel lbl) = pprCEntity (CLabel lbl) =
ptext (sLit "static") <+> pp_hdr <+> char '&' <> ppr lbl ptext (sLit "static") <+> pp_hdr <+> char '&' <> ppr lbl
pprCEntity (CFunction (StaticTarget lbl _ isFun)) = pprCEntity (CFunction (StaticTarget _ lbl _ isFun)) =
ptext (sLit "static") ptext (sLit "static")
<+> pp_hdr <+> pp_hdr
<+> (if isFun then empty else ptext (sLit "value")) <+> (if isFun then empty else ptext (sLit "value"))
...@@ -1428,7 +1428,7 @@ instance Outputable ForeignImport where ...@@ -1428,7 +1428,7 @@ instance Outputable ForeignImport where
pprCEntity (CWrapper) = ptext (sLit "wrapper") pprCEntity (CWrapper) = ptext (sLit "wrapper")
instance Outputable ForeignExport where instance Outputable ForeignExport where
ppr (CExport (L _ (CExportStatic lbl cconv)) _) = ppr (CExport (L _ (CExportStatic _ lbl cconv)) _) =
ppr cconv <+> char '"' <> ppr lbl <> char '"' ppr cconv <+> char '"' <> ppr lbl <> char '"'
{- {-
...@@ -1450,8 +1450,9 @@ deriving instance (DataId name) => Data (RuleDecls name) ...@@ -1450,8 +1450,9 @@ deriving instance (DataId name) => Data (RuleDecls name)
type LRuleDecl name = Located (RuleDecl name) type LRuleDecl name = Located (RuleDecl name)
data RuleDecl name data RuleDecl name
= HsRule -- Source rule = HsRule -- Source rule
(Located RuleName) -- Rule name (Located (SourceText,RuleName)) -- Rule name
-- Note [Pragma source text] in BasicTypes
Activation Activation
[LRuleBndr name] -- Forall'd vars; after typechecking this [LRuleBndr name] -- Forall'd vars; after typechecking this
-- includes tyvars -- includes tyvars
...@@ -1494,7 +1495,7 @@ instance OutputableBndr name => Outputable (RuleDecls name) where ...@@ -1494,7 +1495,7 @@ instance OutputableBndr name => Outputable (RuleDecls name) where
instance OutputableBndr name => Outputable (RuleDecl name) where instance OutputableBndr name => Outputable (RuleDecl name) where
ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs) ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs)
= sep [text "{-# RULES" <+> doubleQuotes (ftext $ unLoc name) = sep [text "{-# RULES" <+> doubleQuotes (ftext $ snd $ unLoc name)
<+> ppr act, <+> ppr act,
nest 4 (pp_forall <+> pprExpr (unLoc lhs)), nest 4 (pp_forall <+> pprExpr (unLoc lhs)),
nest 4 (equals <+> pprExpr (unLoc rhs) <+> text "#-}") ] nest 4 (equals <+> pprExpr (unLoc rhs) <+> text "#-}") ]
......
...@@ -344,15 +344,15 @@ data HsExpr id ...@@ -344,15 +344,15 @@ data HsExpr id
-- For details on above see note [Api annotations] in ApiAnnotation -- For details on above see note [Api annotations] in ApiAnnotation
| HsSCC SourceText -- Note [Pragma source text] in BasicTypes | HsSCC SourceText -- Note [Pragma source text] in BasicTypes
FastString -- "set cost centre" SCC pragma (SourceText,FastString) -- "set cost centre" SCC pragma
(LHsExpr id) -- expr whose cost is to be measured (LHsExpr id) -- expr whose cost is to be measured
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@, -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@,
-- 'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@ -- 'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@
-- For details on above see note [Api annotations] in ApiAnnotation -- For details on above see note [Api annotations] in ApiAnnotation
| HsCoreAnn SourceText -- Note [Pragma source text] in BasicTypes | HsCoreAnn SourceText -- Note [Pragma source text] in BasicTypes
FastString -- hdaume: core annotation (SourceText,FastString) -- hdaume: core annotation
(LHsExpr id) (LHsExpr id)
----------------------------------------------------------- -----------------------------------------------------------
...@@ -458,7 +458,8 @@ data HsExpr id ...@@ -458,7 +458,8 @@ data HsExpr id
-- For details on above see note [Api annotations] in ApiAnnotation -- For details on above see note [Api annotations] in ApiAnnotation
| HsTickPragma -- A pragma introduced tick | HsTickPragma -- A pragma introduced tick
SourceText -- Note [Pragma source text] in BasicTypes SourceText -- Note [Pragma source text] in BasicTypes
(FastString,(Int,Int),(Int,Int)) -- external span for this tick ((SourceText,FastString),(Int,Int),(Int,Int))
-- external span for this tick
(LHsExpr id) (LHsExpr id)
--------------------------------------- ---------------------------------------
...@@ -587,7 +588,7 @@ ppr_expr (HsLit lit) = ppr lit ...@@ -587,7 +588,7 @@ ppr_expr (HsLit lit) = ppr lit
ppr_expr (HsOverLit lit) = ppr lit ppr_expr (HsOverLit lit) = ppr lit
ppr_expr (HsPar e) = parens (ppr_lexpr e) 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] = vcat [ptext (sLit "HsCoreAnn") <+> ftext s, ppr_lexpr e]
ppr_expr (HsApp e1 e2) ppr_expr (HsApp e1 e2)
...@@ -708,7 +709,7 @@ ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e ...@@ -708,7 +709,7 @@ ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e
ppr_expr (EAsPat v e) = ppr v <> 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 (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 "#-}"), = sep [ ptext (sLit "{-# SCC") <+> doubleQuotes (ftext lbl) <+> ptext (sLit "#-}"),
pprParendExpr expr ] pprParendExpr expr ]
......
...@@ -44,7 +44,7 @@ data ImportDecl name ...@@ -44,7 +44,7 @@ data ImportDecl name
ideclSourceSrc :: Maybe SourceText, ideclSourceSrc :: Maybe SourceText,
-- Note [Pragma source text] in BasicTypes -- Note [Pragma source text] in BasicTypes
ideclName :: Located ModuleName, -- ^ Module name. ideclName :: Located ModuleName, -- ^ Module name.
ideclPkgQual :: Maybe FastString, -- ^ Package qualifier. ideclPkgQual :: Maybe (SourceText,FastString), -- ^ Package qualifier.
ideclSource :: Bool, -- ^ True <=> {-\# SOURCE \#-} import ideclSource :: Bool, -- ^ True <=> {-\# SOURCE \#-} import
ideclSafe :: Bool, -- ^ True => safe import ideclSafe :: Bool, -- ^ True => safe import
ideclQualified :: Bool, -- ^ True => qualified ideclQualified :: Bool, -- ^ True => qualified
...@@ -96,8 +96,8 @@ instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name) ...@@ -96,8 +96,8 @@ instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name)
pp_implicit False = empty pp_implicit False = empty
pp_implicit True = ptext (sLit ("(implicit)")) pp_implicit True = ptext (sLit ("(implicit)"))
pp_pkg Nothing = empty pp_pkg Nothing = empty
pp_pkg (Just p) = doubleQuotes (ftext p) pp_pkg (Just (_,p)) = doubleQuotes (ftext p)
pp_qual False = empty pp_qual False = empty
pp_qual True = ptext (sLit "qualified") pp_qual True = ptext (sLit "qualified")
......
...@@ -1332,7 +1332,7 @@ checkDependencies hsc_env summary iface ...@@ -1332,7 +1332,7 @@ checkDependencies hsc_env summary iface
this_pkg = thisPackage (hsc_dflags hsc_env) this_pkg = thisPackage (hsc_dflags hsc_env)
dep_missing (L _ (ImportDecl { ideclName = L _ mod, ideclPkgQual = pkg })) = do dep_missing (L _ (ImportDecl { ideclName = L _ mod, ideclPkgQual = pkg })) = do
find_res <- liftIO $ findImportedModule hsc_env mod pkg find_res <- liftIO $ findImportedModule hsc_env mod (fmap snd pkg)
let reason = moduleNameString mod ++ " changed" let reason = moduleNameString mod ++ " changed"
case find_res of case find_res of
FoundModule h -> check_mod reason (fr_mod h) FoundModule h -> check_mod reason (fr_mod h)
......
...@@ -226,7 +226,7 @@ processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node) ...@@ -226,7 +226,7 @@ processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node)
-- Emit a dependency for each import -- Emit a dependency for each import
; let do_imps is_boot idecls = sequence_ ; let do_imps is_boot idecls = sequence_
[ do_imp loc is_boot (ideclPkgQual i) mod [ do_imp loc is_boot (fmap snd $ ideclPkgQual i) mod
| L loc i <- idecls, | L loc i <- idecls,
let mod = unLoc (ideclName i), let mod = unLoc (ideclName i),
mod `notElem` excl_mods ] mod `notElem` excl_mods ]
......
...@@ -1695,7 +1695,8 @@ msDeps s = ...@@ -1695,7 +1695,8 @@ msDeps s =
++ [ (m,NotBoot) | m <- ms_home_imps s ] ++ [ (m,NotBoot) | m <- ms_home_imps s ]
home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName] home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName]
home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ] home_imps imps = [ ideclName i | L _ i <- imps,
isLocal (fmap snd $ ideclPkgQual i) ]
where isLocal Nothing = True where isLocal Nothing = True
isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special
isLocal _ = False isLocal _ = False
......
...@@ -811,7 +811,7 @@ hscCheckSafeImports tcg_env = do ...@@ -811,7 +811,7 @@ hscCheckSafeImports tcg_env = do
warns dflags rules = listToBag $ map (warnRules dflags) rules warns dflags rules = listToBag $ map (warnRules dflags) rules
warnRules dflags (L loc (HsRule n _ _ _ _ _ _)) = warnRules dflags (L loc (HsRule n _ _ _ _ _ _)) =
mkPlainWarnMsg dflags loc $ mkPlainWarnMsg dflags loc $
text "Rule \"" <> ftext (unLoc n) <> text "\" ignored" $+$ text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$
text "User defined rules are disabled under Safe Haskell" text "User defined rules are disabled under Safe Haskell"
-- | Validate that safe imported modules are actually safe. For modules in the -- | Validate that safe imported modules are actually safe. For modules in the
......
...@@ -776,10 +776,10 @@ maybe_safe :: { ([AddAnn],Bool) } ...@@ -776,10 +776,10 @@ maybe_safe :: { ([AddAnn],Bool) }
: 'safe' { ([mj AnnSafe $1],True) } : 'safe' { ([mj AnnSafe $1],True) }
| {- empty -} { ([],False) } | {- empty -} { ([],False) }
maybe_pkg :: { ([AddAnn],Maybe FastString) } maybe_pkg :: { ([AddAnn],Maybe (SourceText,FastString)) }
: STRING {% let pkgFS = getSTRING $1 in : STRING {% let pkgFS = getSTRING $1 in
if looksLikePackageName (unpackFS pkgFS) if looksLikePackageName (unpackFS pkgFS)
then return ([mj AnnPackageName $1], Just pkgFS) then return ([mj AnnPackageName $1], Just (getSTRINGs $1,pkgFS))
else parseErrorSDoc (getLoc $1) $ vcat [ else parseErrorSDoc (getLoc $1) $ vcat [
text "parse error" <> colon <+> quotes (ppr pkgFS), text "parse error" <> colon <+> quotes (ppr pkgFS),
text "Version number or non-alphanumeric" <+> text "Version number or non-alphanumeric" <+>
...@@ -1119,12 +1119,12 @@ tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) } ...@@ -1119,12 +1119,12 @@ tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) }
capi_ctype :: { Maybe (Located CType) } capi_ctype :: { Maybe (Located CType) }
capi_ctype : '{-# CTYPE' STRING STRING '#-}' capi_ctype : '{-# CTYPE' STRING STRING '#-}'
{% ajs (Just (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRING $2))) {% ajs (Just (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2)))
(getSTRING $3)))) (getSTRINGs $3,getSTRING $3))))
[mo $1,mj AnnHeader $2,mj AnnVal $3,mc $4] } [mo $1,mj AnnHeader $2,mj AnnVal $3,mc $4] }
| '{-# CTYPE' STRING '#-}' | '{-# CTYPE' STRING '#-}'
{% ajs (Just (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRING $2)))) {% ajs (Just (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRINGs $2, getSTRING $2))))
[mo $1,mj AnnVal $2,mc $3] } [mo $1,mj AnnVal $2,mc $3] }
| { Nothing } | { Nothing }
...@@ -1378,7 +1378,7 @@ rules :: { OrdList (LRuleDecl RdrName) } ...@@ -1378,7 +1378,7 @@ rules :: { OrdList (LRuleDecl RdrName) }
rule :: { LRuleDecl RdrName } rule :: { LRuleDecl RdrName }
: STRING rule_activation rule_forall infixexp '=' exp : STRING rule_activation rule_forall infixexp '=' exp
{%ams (sLL $1 $> $ (HsRule (L (gl $1) (getSTRING $1)) {%ams (sLL $1 $> $ (HsRule (L (gl $1) (getSTRINGs $1,getSTRING $1))
((snd $2) `orElse` AlwaysActive) ((snd $2) `orElse` AlwaysActive)
(snd $3) $4 placeHolderNames $6 (snd $3) $4 placeHolderNames $6
placeHolderNames)) placeHolderNames))
...@@ -1444,15 +1444,15 @@ deprecation :: { OrdList (LWarnDecl RdrName) } ...@@ -1444,15 +1444,15 @@ deprecation :: { OrdList (LWarnDecl RdrName) }
{% amsu (sLL $1 $> $ (Warning (unLoc $1) (DeprecatedTxt (noLoc "") $ snd $ unLoc $2))) {% amsu (sLL $1 $> $ (Warning (unLoc $1) (DeprecatedTxt (noLoc "") $ snd $ unLoc $2)))
(fst $ unLoc $2) } (fst $ unLoc $2) }
strings :: { Located ([AddAnn],[Located FastString]) } strings :: { Located ([AddAnn],[Located (SourceText,FastString)]) }
: STRING { sL1 $1 ([],[L (gl $1) (getSTRING $1)]) } : STRING { sL1 $1 ([],[L (gl $1) (getSTRINGs $1,getSTRING $1)]) }
| '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) } | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) }
stringlist :: { Located (OrdList (Located FastString)) } stringlist :: { Located (OrdList (Located (SourceText,FastString))) }
: stringlist ',' STRING {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >> : stringlist ',' STRING {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >>
return (sLL $1 $> (unLoc $1 `snocOL` return (sLL $1 $> (unLoc $1 `snocOL`
(L (gl $3) (getSTRING $3)))) } (L (gl $3) (getSTRINGs $3,getSTRING $3)))) }
| STRING { sLL $1 $> (unitOL (L (gl $1) (getSTRING $1))) } | STRING { sLL $1 $> (unitOL (L (gl $1) (getSTRINGs $1,getSTRING $1))) }
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Annotations -- Annotations
...@@ -1500,12 +1500,12 @@ safety :: { Located Safety } ...@@ -1500,12 +1500,12 @@ safety :: { Located Safety }
| 'interruptible' { sLL $1 $> PlayInterruptible } | 'interruptible' { sLL $1 $> PlayInterruptible }
fspec :: { Located ([AddAnn] fspec :: { Located ([AddAnn]
,(Located FastString, Located RdrName, LHsType RdrName)) } ,(Located (SourceText,FastString), Located RdrName, LHsType RdrName)) }
: STRING var '::' sigtypedoc { sLL $1 $> ([mj AnnDcolon $3] : STRING var '::' sigtypedoc { sLL $1 $> ([mj AnnDcolon $3]
,(L (getLoc $1) ,(L (getLoc $1)
(getSTRING $1), $2, $4)) } (getSTRINGs $1,getSTRING $1), $2, $4)) }
| var '::' sigtypedoc { sLL $1 $> ([mj AnnDcolon $2] | var '::' sigtypedoc { sLL $1 $> ([mj AnnDcolon $2]
,(noLoc nilFS, $1, $3)) } ,(noLoc ("",nilFS), $1, $3)) }
-- if the entity string is missing, it defaults to the empty string; -- if the entity string is missing, it defaults to the empty string;
-- the meaning of an empty entity string depends on the calling -- the meaning of an empty entity string depends on the calling
-- convention -- convention
...@@ -2191,7 +2191,7 @@ exp10 :: { LHsExpr RdrName } ...@@ -2191,7 +2191,7 @@ exp10 :: { LHsExpr RdrName }
-- TODO: is LL right here? -- TODO: is LL right here?
[mj AnnProc $1,mj AnnRarrow $3] } [mj AnnProc $1,mj AnnRarrow $3] }
| '{-# CORE' STRING '#-}' exp {% ams (sLL $1 $> $ HsCoreAnn (getCORE_PRAGs $1) (getSTRING $2) $4) | '{-# CORE' STRING '#-}' exp {% ams (sLL $1 $> $ HsCoreAnn (getCORE_PRAGs $1) (getSTRINGs $2,getSTRING $2) $4)
[mo $1,mj AnnVal $2 [mo $1,mj AnnVal $2
,mc $3] } ,mc $3] }
-- hdaume: core annotation -- hdaume: core annotation
...@@ -2232,16 +2232,16 @@ optSemi :: { ([Located a],Bool) } ...@@ -2232,16 +2232,16 @@ optSemi :: { ([Located a],Bool) }
: ';' { ([$1],True) } : ';' { ([$1],True) }
| {- empty -} { ([],False) } | {- empty -} { ([],False) }
scc_annot :: { Located (([AddAnn],SourceText),FastString) } scc_annot :: { Located (([AddAnn],SourceText),(SourceText,FastString)) }