ApiAnnotations : strings in warnings do not return SourceTextwip/api-annots-7.10-3

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

(cherry picked from commit e6191d1cc37e98785af8b309100ea840084fa3ba)

Conflicts:
	compiler/parser/Parser.y
	compiler/typecheck/TcRules.hs
	utils/haddock

34 files changed, 389 insertions, 119 deletions

diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs
index ee34b215cb..8d71864f41 100644
--- a/compiler/basicTypes/BasicTypes.hs
+++ b/compiler/basicTypes/BasicTypes.hs
@@ -264,14 +264,18 @@ initialVersion = 1
 
 -- reason/explanation from a WARNING or DEPRECATED pragma
 -- For SourceText usage, see note [Pragma source text]
-data WarningTxt = WarningTxt (Located SourceText) [Located FastString]
-                | DeprecatedTxt (Located SourceText) [Located FastString]
+data WarningTxt = WarningTxt (Located SourceText)
+                             [Located (SourceText,FastString)]
+                | DeprecatedTxt (Located SourceText)
+                                [Located (SourceText,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 . snd . unLoc) ws))
+    ppr (DeprecatedTxt _ ds)
+                            = text "Deprecated:" <+>
+                              doubleQuotes (vcat (map (ftext . snd . unLoc) ds))
 
 {-
 ************************************************************************
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index c38519ed13..285e92c2ed 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -79,9 +79,9 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty
         ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty
         ; let ((call_args, arg_hints), cmm_target)
                 = case target of
-                   StaticTarget _   _      False ->
+                   StaticTarget _ _   _      False ->
                        panic "cgForeignCall: unexpected FFI value import"
-                   StaticTarget lbl mPkgId True
+                   StaticTarget _ lbl mPkgId True
                      -> let labelSource
                                 = case mPkgId of
                                         Nothing         -> ForeignLabelInThisPackage
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
index e4181b9bdb..c5e52b6fa4 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -372,7 +372,7 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
               fn_name   = idName fn_id
               final_rhs = simpleOptExpr rhs''    -- De-crap it
               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
 
               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))
 
         ; when inline_shadows_rule $
           warnDs (vcat [ hang (ptext (sLit "Rule")
-                               <+> doubleQuotes (ftext $ unLoc name)
+                               <+> doubleQuotes (ftext $ snd $ unLoc name)
                                <+> ptext (sLit "may never fire"))
                             2 (ptext (sLit "because") <+> quotes (ppr fn_id)
                                <+> ptext (sLit "might inline first"))
diff --git a/compiler/deSugar/DsCCall.hs b/compiler/deSugar/DsCCall.hs
index 5c5fde0b14..cb48e62061 100644
--- a/compiler/deSugar/DsCCall.hs
+++ b/compiler/deSugar/DsCCall.hs
@@ -37,6 +37,7 @@ import TysPrim
 import TyCon
 import TysWiredIn
 import BasicTypes
+import FastString ( unpackFS )
 import Literal
 import PrelNames
 import VarSet
@@ -95,7 +96,7 @@ dsCCall lbl args may_gc result_ty
        uniq <- newUnique
        dflags <- getDynFlags
        let
-           target = StaticTarget lbl Nothing True
+           target = StaticTarget (unpackFS lbl) lbl Nothing True
            the_fcall    = CCall (CCallSpec target CCallConv may_gc)
            the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty
        return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 0cd609e8ef..8d81015904 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -307,7 +307,7 @@ 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)
+        Tick (ProfNote (mkUserCC (snd cc) mod_name loc uniq) count True)
                <$> dsLExpr expr
       else dsLExpr expr
 
diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs
index 715e1ce087..b0eb8c03f1 100644
--- a/compiler/deSugar/DsForeign.hs
+++ b/compiler/deSugar/DsForeign.hs
@@ -108,7 +108,7 @@ dsForeigns' fos = do
       return (h, c, [], bs)
 
    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
       return (h, c, [id], [])
 
@@ -223,13 +223,18 @@ dsFCall fn_id co fcall mDeclHeader = do
     dflags <- getDynFlags
     (fcall', cDoc) <-
               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)
-                  let fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageKey True) CApiConv safety)
+                  let fcall' = CCall (CCallSpec
+                                      (StaticTarget (unpackFS wrapperName)
+                                                    wrapperName mPackageKey
+                                                    True)
+                                      CApiConv safety)
                       c = includes
                        $$ fun_proto <+> braces (cRet <> semi)
                       includes = vcat [ text "#include <" <> ftext h <> text ">"
-                                      | Header h <- nub headers ]
+                                      | Header _ h <- nub headers ]
                       fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
                       cRet
                        | isVoidRes =                   cCall
@@ -713,7 +718,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 63b65398eb..ea475331eb 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -488,15 +488,17 @@ repForD (L loc (ForeignImport name typ _ (CImport (L _ cc) (L _ s) mch cis _)))
  where
     conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
     conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
-    conv_cimportspec (CFunction (StaticTarget fs _ True)) = return (unpackFS fs)
-    conv_cimportspec (CFunction (StaticTarget _  _ False)) = panic "conv_cimportspec: values not supported yet"
+    conv_cimportspec (CFunction (StaticTarget _ fs _ True))
+                            = return (unpackFS fs)
+    conv_cimportspec (CFunction (StaticTarget _ _  _ False))
+                            = panic "conv_cimportspec: values not supported yet"
     conv_cimportspec CWrapper = return "wrapper"
     static = case cis of
-                 CFunction (StaticTarget _ _ _) -> "static "
+                 CFunction (StaticTarget _ _ _ _) -> "static "
                  _ -> ""
     chStr = case mch of
             Nothing -> ""
-            Just (Header h) -> unpackFS h ++ " "
+            Just (Header _ h) -> unpackFS h ++ " "
 repForD decl = notHandled "Foreign declaration" (ppr decl)
 
 repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
@@ -530,7 +532,7 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
        ; ss <- mkGenSyms bndr_names
        ; rule1 <- addBinds ss $
                   do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs
-                     ; n'   <- coreStringLit $ unpackFS $ unLoc n
+                     ; n'   <- coreStringLit $ unpackFS $ snd $ unLoc n
                      ; act' <- repPhases act
                      ; lhs' <- repLE lhs
                      ; rhs' <- repLE rhs
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index de5b84e464..98d31eb26f 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -1017,9 +1017,9 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
                  DynamicTarget
                     -> return (False, panic "ByteCodeGen.generateCCall(dyn)")
 
-                 StaticTarget _ _ False ->
+                 StaticTarget _ _ _ False ->
                      panic "generateCCall: unexpected FFI value import"
-                 StaticTarget target _ True
+                 StaticTarget _ target _ True
                     -> do res <- ioToBc (lookupStaticPtr stdcall_adj_target)
                           return (True, res)
                    where
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 03c9bf5024..b72823bc9d 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -494,7 +494,8 @@ cvtForD (ImportF callconv safety from nm ty)
 cvtForD (ExportF callconv as nm ty)
   = do  { nm' <- vNameL nm
         ; ty' <- cvtType ty
-        ; let e = CExport (noLoc (CExportStatic (mkFastString as)
+        ; let e = CExport (noLoc (CExportStatic as
+                                                (mkFastString as)
                                                 (cvt_conv callconv)))
                                                 (noLoc as)
         ; return $ ForeignExport nm' ty' noForeignExportCoercionYet e }
@@ -545,7 +546,7 @@ cvtPragmaD (RuleP nm bndrs lhs rhs phases)
        ; lhs'   <- cvtl lhs
        ; rhs'   <- cvtl rhs
        ; returnJustL $ Hs.RuleD
-            $ HsRules "{-# RULES" [noLoc $ HsRule (noLoc nm') act bndrs'
+            $ HsRules "{-# RULES" [noLoc $ HsRule (noLoc (nm,nm')) act bndrs'
                                                   lhs' placeHolderNames
                                                   rhs' placeHolderNames]
        }
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 4e94b3e33f..43f17bc007 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -1417,11 +1417,11 @@ instance Outputable ForeignImport where
     where
       pp_hdr = case mHeader of
                Nothing -> empty
-               Just (Header header) -> ftext header
+               Just (Header _ header) -> ftext header
 
       pprCEntity (CLabel lbl) =
         ptext (sLit "static") <+> pp_hdr <+> char '&' <> ppr lbl
-      pprCEntity (CFunction (StaticTarget lbl _ isFun)) =
+      pprCEntity (CFunction (StaticTarget _ lbl _ isFun)) =
             ptext (sLit "static")
         <+> pp_hdr
         <+> (if isFun then empty else ptext (sLit "value"))
@@ -1431,7 +1431,7 @@ instance Outputable ForeignImport where
       pprCEntity (CWrapper) = ptext (sLit "wrapper")
 
 instance Outputable ForeignExport where
-  ppr (CExport  (L _ (CExportStatic lbl cconv)) _) =
+  ppr (CExport  (L _ (CExportStatic _ lbl cconv)) _) =
     ppr cconv <+> char '"' <> ppr lbl <> char '"'
 
 {-
@@ -1453,8 +1453,9 @@ deriving instance (DataId name) => Data (RuleDecls name)
 type LRuleDecl name = Located (RuleDecl name)
 
 data RuleDecl name
-  = HsRule                      -- Source rule
-        (Located RuleName)      -- Rule name
+  = HsRule                             -- Source rule
+        (Located (SourceText,RuleName)) -- Rule name
+               -- Note [Pragma source text] in BasicTypes
         Activation
         [LRuleBndr name]        -- Forall'd vars; after typechecking this
                                 --   includes tyvars
@@ -1497,7 +1498,7 @@ instance OutputableBndr name => Outputable (RuleDecls name) where
 
 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)
+        = sep [text "{-# RULES" <+> doubleQuotes (ftext $ snd $ unLoc name)
                                 <+> ppr act,
                nest 4 (pp_forall <+> pprExpr (unLoc lhs)),
                nest 4 (equals <+> pprExpr (unLoc rhs) <+> text "#-}") ]
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index 7a66a50d46..efc95cf3ee 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -344,15 +344,15 @@ data HsExpr id
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | HsSCC       SourceText            -- Note [Pragma source text] in BasicTypes
-                FastString            -- "set cost centre" SCC pragma
-                (LHsExpr id)          -- expr whose cost is to be measured
+                (SourceText,FastString) -- "set cost centre" SCC pragma
+                (LHsExpr id)            -- expr whose cost is to be measured
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@,
   --             'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | HsCoreAnn   SourceText            -- Note [Pragma source text] in BasicTypes
-                FastString            -- hdaume: core annotation
+                (SourceText,FastString) -- hdaume: core annotation
                 (LHsExpr id)
 
   -----------------------------------------------------------
@@ -462,7 +462,8 @@ data HsExpr id
   -- For details on above see note [Api annotations] in ApiAnnotation
   | HsTickPragma                      -- A pragma introduced tick
      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)
 
   ---------------------------------------
@@ -591,7 +592,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)
@@ -713,7 +714,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 ]
 
diff --git a/compiler/hsSyn/HsImpExp.hs b/compiler/hsSyn/HsImpExp.hs
index 42b374abfc..810fc67603 100644
--- a/compiler/hsSyn/HsImpExp.hs
+++ b/compiler/hsSyn/HsImpExp.hs
@@ -44,7 +44,7 @@ data ImportDecl name
       ideclSourceSrc :: Maybe SourceText,
                                  -- Note [Pragma source text] in BasicTypes
       ideclName      :: Located ModuleName, -- ^ Module name.
-      ideclPkgQual   :: Maybe FastString,  -- ^ Package qualifier.
+      ideclPkgQual   :: Maybe (SourceText,FastString),  -- ^ Package qualifier.
       ideclSource    :: Bool,              -- ^ True <=> {-\# SOURCE \#-} import
       ideclSafe      :: Bool,               -- ^ True => safe import
       ideclQualified :: Bool,               -- ^ True => qualified
@@ -96,8 +96,8 @@ instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name)
         pp_implicit False = empty
         pp_implicit True = ptext (sLit ("(implicit)"))
 
-        pp_pkg Nothing  = empty
-        pp_pkg (Just p) = doubleQuotes (ftext p)
+        pp_pkg Nothing      = empty
+        pp_pkg (Just (_,p)) = doubleQuotes (ftext p)
 
         pp_qual False   = empty
         pp_qual True    = ptext (sLit "qualified")
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 564a4de43e..fb24206183 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -1321,7 +1321,7 @@ checkDependencies hsc_env summary iface
    this_pkg = thisPackage (hsc_dflags hsc_env)
 
    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"
      case find_res of
         Found _ mod
diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs
index 03545d4828..310007d000 100644
--- a/compiler/main/DriverMkDepend.hs
+++ b/compiler/main/DriverMkDepend.hs
@@ -226,7 +226,7 @@ processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node)
                 -- Emit a dependency for each import
 
         ; 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,
                       let mod = unLoc (ideclName i),
                       mod `notElem` excl_mods ]
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 5f3e31545f..ee0dc49ea3 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -1681,7 +1681,8 @@ msDeps s =
         ++ [ (m,NotBoot) | m <- ms_home_imps s ]
 
 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
         isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special
         isLocal _ = False
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 6908893582..163c81bbac 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -822,7 +822,7 @@ hscCheckSafeImports tcg_env = do
     warns dflags rules = listToBag $ map (warnRules dflags) rules
     warnRules dflags (L loc (HsRule n _ _ _ _ _ _)) =
         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"
 
 -- | Validate that safe imported modules are actually safe.  For modules in the
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index bc2bed8ad2..0fe9206407 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -650,9 +650,9 @@ maybe_safe :: { ([AddAnn],Bool) }
         : 'safe'                                { ([mj AnnSafe $1],True) }
         | {- empty -}                           { ([],False) }
 
-maybe_pkg :: { ([AddAnn],Maybe FastString) }
+maybe_pkg :: { ([AddAnn],Maybe (SourceText,FastString)) }
         : STRING                                { ([mj AnnPackageName $1]
-                                                  ,Just (getSTRING $1)) }
+                                                  ,Just (getSTRINGs $1,getSTRING $1)) }
         | {- empty -}                           { ([],Nothing) }
 
 optqualified :: { ([AddAnn],Bool) }
@@ -987,12 +987,12 @@ tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) }
 
 capi_ctype :: { Maybe (Located CType) }
 capi_ctype : '{-# CTYPE' STRING STRING '#-}'
-                       {% ajs (Just (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRING $2)))
-                                        (getSTRING $3))))
+                       {% ajs (Just (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2)))
+                                        (getSTRINGs $3,getSTRING $3))))
                               [mo $1,mj AnnHeader $2,mj AnnVal $3,mc $4] }
 
            | '{-# 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] }
 
            |           { Nothing }
@@ -1246,7 +1246,7 @@ rules   :: { OrdList (LRuleDecl RdrName) }
 
 rule    :: { LRuleDecl RdrName }
         : 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 $3) $4 placeHolderNames $6
                                   placeHolderNames))
@@ -1312,15 +1312,15 @@ deprecation :: { OrdList (LWarnDecl RdrName) }
              {% 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)]) }
+strings :: { Located ([AddAnn],[Located (SourceText,FastString)]) }
+    : STRING { sL1 $1 ([],[L (gl $1) (getSTRINGs $1,getSTRING $1)]) }
     | '[' 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) >>
                                return (sLL $1 $> (unLoc $1 `snocOL`
-                                                  (L (gl $3) (getSTRING $3)))) }
-    | STRING                { sLL $1 $> (unitOL (L (gl $1) (getSTRING $1))) }
+                                                  (L (gl $3) (getSTRINGs $3,getSTRING $3)))) }
+    | STRING                { sLL $1 $> (unitOL (L (gl $1) (getSTRINGs $1,getSTRING $1))) }
 
 -----------------------------------------------------------------------------
 -- Annotations
@@ -1368,12 +1368,12 @@ safety :: { Located Safety }
         | 'interruptible'               { sLL $1 $> PlayInterruptible }
 
 fspec :: { Located ([AddAnn]
-                    ,(Located FastString, Located RdrName, LHsType RdrName)) }
+                    ,(Located (SourceText,FastString), Located RdrName, LHsType RdrName)) }
        : STRING var '::' sigtypedoc     { sLL $1 $> ([mj AnnDcolon $3]
                                              ,(L (getLoc $1)
-                                                    (getSTRING $1), $2, $4)) }
+                                                    (getSTRINGs $1,getSTRING $1), $2, $4)) }
        |        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;
          -- the meaning of an empty entity string depends on the calling
          -- convention
@@ -2059,7 +2059,7 @@ exp10 :: { LHsExpr RdrName }
                                             -- TODO: is LL right here?
                                [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
                                               ,mc $3] }
                                           -- hdaume: core annotation
@@ -2100,16 +2100,16 @@ optSemi :: { ([Located a],Bool) }
         : ';'         { ([$1],True) }
         | {- empty -} { ([],False) }
 
-scc_annot :: { Located (([AddAnn],SourceText),FastString) }
+scc_annot :: { Located (([AddAnn],SourceText),(SourceText,FastString)) }
         : '{-# SCC' STRING '#-}'      {% do scc <- getSCC $2
                                             ; return $ sLL $1 $>
                                                (([mo $1,mj AnnValStr $2
-                                                ,mc $3],getSCC_PRAGs $1),scc) }
+                                                ,mc $3],getSCC_PRAGs $1),(getSTRINGs $2,scc)) }
         | '{-# SCC' VARID  '#-}'      { sLL $1 $> (([mo $1,mj AnnVal $2
                                          ,mc $3],getSCC_PRAGs $1)
-                                        ,(getVARID $2)) }
+                                        ,(unpackFS $ getVARID $2,getVARID $2)) }
 
-hpc_annot :: { Located (([AddAnn],SourceText),(FastString,(Int,Int),(Int,Int))) }
+hpc_annot :: { Located (([AddAnn],SourceText),((SourceText,FastString),(Int,Int),(Int,Int))) }
       : '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
                                       { sLL $1 $> $ (([mo $1,mj AnnVal $2
                                               ,mj AnnVal $3,mj AnnColon $4
@@ -2117,7 +2117,7 @@ hpc_annot :: { Located (([AddAnn],SourceText),(FastString,(Int,Int),(Int,Int)))
                                               ,mj AnnVal $7,mj AnnColon $8
                                               ,mj AnnVal $9,mc $10],
                                                 getGENERATED_PRAGs $1)
-                                              ,(getSTRING $2
+                                              ,((getSTRINGs $2,getSTRING $2)
                                                ,( fromInteger $ getINTEGER $3
                                                 , fromInteger $ getINTEGER $5
                                                 )
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index cc019d14bf..15ba75f804 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -1381,21 +1381,21 @@ mkInlinePragma src (inl, match_info) mb_act
 --
 mkImport :: Located CCallConv
          -> Located Safety
-         -> (Located FastString, Located RdrName, LHsType RdrName)
+         -> (Located (SourceText,FastString), Located RdrName, LHsType RdrName)
          -> P (HsDecl RdrName)
-mkImport (L lc cconv) (L ls safety) (L loc entity, v, ty)
+mkImport (L lc cconv) (L ls safety) (L loc (esrc,entity), v, ty)
   | Just loc <- maybeLocation $ findWildcards ty
     = parseErrorSDoc loc $
       text "Wildcard not allowed" $$
       text "In foreign import declaration" <+>
       quotes (ppr v) $$ ppr ty
   | cconv == PrimCallConv                      = do
-  let funcTarget = CFunction (StaticTarget entity Nothing True)
+  let funcTarget = CFunction (StaticTarget esrc entity Nothing True)
       importSpec = CImport (L lc PrimCallConv) (L ls safety) Nothing funcTarget
                            (L loc (unpackFS entity))
   return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
   | cconv == JavaScriptCallConv = do
-  let funcTarget = CFunction (StaticTarget entity Nothing True)
+  let funcTarget = CFunction (StaticTarget esrc entity Nothing True)
       importSpec = CImport (L lc JavaScriptCallConv) (L ls safety) Nothing
                            funcTarget (L loc (unpackFS entity))
   return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
@@ -1424,7 +1424,7 @@ parseCImport cconv safety nm str sourceText =
              ((mk Nothing <$> cimp nm) +++
               (do h <- munch1 hdr_char
                   skipSpaces
-                  mk (Just (Header (mkFastString h))) <$> cimp nm))
+                  mk (Just (Header h (mkFastString h))) <$> cimp nm))
          ]
        skipSpaces
        return r
@@ -1453,7 +1453,8 @@ parseCImport cconv safety nm str sourceText =
                                              return False)
                               _ -> return True
                      cid' <- cid
-                     return (CFunction (StaticTarget cid' Nothing isFun)))
+                     return (CFunction (StaticTarget (unpackFS cid') cid'
+                                        Nothing isFun)))
           where
             cid = return nm +++
                   (do c  <- satisfy id_first_char
@@ -1464,13 +1465,13 @@ parseCImport cconv safety nm str sourceText =
 -- construct a foreign export declaration
 --
 mkExport :: Located CCallConv
-         -> (Located FastString, Located RdrName, LHsType RdrName)
+         -> (Located (SourceText,FastString), Located RdrName, LHsType RdrName)
          -> P (HsDecl RdrName)
-mkExport (L lc cconv) (L le entity, v, ty) = do
+mkExport (L lc cconv) (L le (esrc,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))
+                 (CExport (L lc (CExportStatic esrc entity' cconv))
                           (L le (unpackFS entity))))
   where
     entity' | nullFS entity = mkExtName (unLoc v)
diff --git a/compiler/prelude/ForeignCall.hs b/compiler/prelude/ForeignCall.hs
index 907640b462..309f6ce5fb 100644
--- a/compiler/prelude/ForeignCall.hs
+++ b/compiler/prelude/ForeignCall.hs
@@ -90,6 +90,8 @@ playInterruptible _ = False
 
 data CExportSpec
   = CExportStatic               -- foreign export ccall foo :: ty
+        SourceText              -- of the CLabelString.
+                                -- See note [Pragma source text] in BasicTypes
         CLabelString            -- C Name of exported function
         CCallConv
   deriving (Data, Typeable)
@@ -108,6 +110,8 @@ data CCallSpec
 data CCallTarget
   -- An "unboxed" ccall# to named function in a particular package.
   = StaticTarget
+        SourceText                -- of the CLabelString.
+                                  -- See note [Pragma source text] in BasicTypes
         CLabelString                    -- C-land name of label.
 
         (Maybe PackageKey)              -- What package the function is in.
@@ -198,7 +202,7 @@ isCLabelString lbl
 -- Printing into C files:
 
 instance Outputable CExportSpec where
-  ppr (CExportStatic str _) = pprCLabelString str
+  ppr (CExportStatic _ str _) = pprCLabelString str
 
 instance Outputable CCallSpec where
   ppr (CCallSpec fun cconv safety)
@@ -209,7 +213,7 @@ instance Outputable CCallSpec where
       gc_suf | playSafe safety = text "_GC"
              | otherwise       = empty
 
-      ppr_fun (StaticTarget fn mPkgId isFun)
+      ppr_fun (StaticTarget _ fn mPkgId isFun)
         = text (if isFun then "__pkg_ccall"
                          else "__pkg_ccall_value")
        <> gc_suf
@@ -222,11 +226,12 @@ instance Outputable CCallSpec where
         = text "__dyn_ccall" <> gc_suf <+> text "\"\""
 
 -- The filename for a C header file
-newtype Header = Header FastString
+-- Note [Pragma source text] in BasicTypes
+data Header = Header SourceText FastString
     deriving (Eq, Data, Typeable)
 
 instance Outputable Header where
-    ppr (Header h) = quotes $ ppr h
+    ppr (Header _ h) = quotes $ ppr h
 
 -- | A C type, used in CAPI FFI calls
 --
@@ -237,11 +242,11 @@ instance Outputable Header where
 -- For details on above see note [Api annotations] in ApiAnnotation
 data CType = CType SourceText -- Note [Pragma source text] in BasicTypes
                    (Maybe Header) -- header to include for this type
-                   FastString     -- the type itself
+                   (SourceText,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
@@ -274,13 +279,15 @@ instance Binary Safety where
               _ -> do return PlayRisky
 
 instance Binary CExportSpec where
-    put_ bh (CExportStatic aa ab) = do
+    put_ bh (CExportStatic ss aa ab) = do
+            put_ bh ss
             put_ bh aa
             put_ bh ab
     get bh = do
+          ss <- get bh
           aa <- get bh
           ab <- get bh
-          return (CExportStatic aa ab)
+          return (CExportStatic ss aa ab)
 
 instance Binary CCallSpec where
     put_ bh (CCallSpec aa ab ac) = do
@@ -294,8 +301,9 @@ instance Binary CCallSpec where
           return (CCallSpec aa ab ac)
 
 instance Binary CCallTarget where
-    put_ bh (StaticTarget aa ab ac) = do
+    put_ bh (StaticTarget ss aa ab ac) = do
             putByte bh 0
+            put_ bh ss
             put_ bh aa
             put_ bh ab
             put_ bh ac
@@ -304,10 +312,11 @@ instance Binary CCallTarget where
     get bh = do
             h <- getByte bh
             case h of
-              0 -> do aa <- get bh
+              0 -> do ss <- get bh
+                      aa <- get bh
                       ab <- get bh
                       ac <- get bh
-                      return (StaticTarget aa ab ac)
+                      return (StaticTarget ss aa ab ac)
               _ -> do return DynamicTarget
 
 instance Binary CCallConv where
@@ -340,6 +349,7 @@ instance Binary CType where
                 return (CType s mh fs)
 
 instance Binary Header where
-    put_ bh (Header h) = put_ bh h
-    get bh = do h <- get bh
-                return (Header h)
+    put_ bh (Header s h) = put_ bh s >> put_ bh h
+    get bh = do s <- get bh
+                h <- get bh
+                return (Header s h)
diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs
index 6181415bbf..5fb352adb5 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -536,8 +536,8 @@ charTy = mkTyConTy charTyCon
 
 charTyCon :: TyCon
 charTyCon   = pcNonRecDataTyCon charTyConName
-                                (Just (CType "" Nothing (fsLit "HsChar")))
-                                [] [charDataCon]
+                       (Just (CType "" Nothing ("HsChar",fsLit "HsChar")))
+                       [] [charDataCon]
 charDataCon :: DataCon
 charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon
 
@@ -549,8 +549,8 @@ intTy = mkTyConTy intTyCon
 
 intTyCon :: TyCon
 intTyCon = pcNonRecDataTyCon intTyConName
-                             (Just (CType "" Nothing (fsLit "HsInt"))) []
-                             [intDataCon]
+                            (Just (CType "" Nothing ("HsInt",fsLit "HsInt"))) []
+                            [intDataCon]
 intDataCon :: DataCon
 intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon
 
@@ -559,8 +559,8 @@ wordTy = mkTyConTy wordTyCon
 
 wordTyCon :: TyCon
 wordTyCon = pcNonRecDataTyCon wordTyConName
-                              (Just (CType "" Nothing (fsLit "HsWord"))) []
-                              [wordDataCon]
+                      (Just (CType "" Nothing ("HsWord", fsLit "HsWord"))) []
+                      [wordDataCon]
 wordDataCon :: DataCon
 wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon
 
@@ -569,8 +569,8 @@ floatTy = mkTyConTy floatTyCon
 
 floatTyCon :: TyCon
 floatTyCon   = pcNonRecDataTyCon floatTyConName
-                                 (Just (CType "" Nothing (fsLit "HsFloat"))) []
-                                 [floatDataCon]
+                      (Just (CType "" Nothing ("HsFloat", fsLit "HsFloat"))) []
+                      [floatDataCon]
 floatDataCon :: DataCon
 floatDataCon = pcDataCon         floatDataConName [] [floatPrimTy] floatTyCon
 
@@ -579,8 +579,8 @@ doubleTy = mkTyConTy doubleTyCon
 
 doubleTyCon :: TyCon
 doubleTyCon = pcNonRecDataTyCon doubleTyConName
-                                (Just (CType "" Nothing (fsLit "HsDouble"))) []
-                                [doubleDataCon]
+                      (Just (CType "" Nothing ("HsDouble",fsLit "HsDouble"))) []
+                      [doubleDataCon]
 
 doubleDataCon :: DataCon
 doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon
@@ -640,7 +640,7 @@ boolTy = mkTyConTy boolTyCon
 
 boolTyCon :: TyCon
 boolTyCon = pcTyCon True NonRecursive True boolTyConName
-                    (Just (CType "" Nothing (fsLit "HsBool")))
+                    (Just (CType "" Nothing ("HsBool", fsLit "HsBool")))
                     [] [falseDataCon, trueDataCon]
 
 falseDataCon, trueDataCon :: DataCon
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index 2818db82e4..a45d7b8cd4 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -192,8 +192,8 @@ rnImportDecl this_mod
                            -- check that "<pkg>" is "this" (which is magic)
                            -- or the name of this_mod's package.  Yurgh!
                            -- c.f. GHC.findModule, and Trac #9997
-             Nothing     -> True
-             Just pkg_fs -> pkg_fs == fsLit "this" ||
+             Nothing         -> True
+             Just (_,pkg_fs) -> pkg_fs == fsLit "this" ||
                             fsToPackageKey pkg_fs == modulePackageKey this_mod))
          (addErr (ptext (sLit "A module cannot import itself:") <+> ppr imp_mod_name))
 
@@ -206,7 +206,7 @@ rnImportDecl this_mod
            | otherwise  -> whenWOptM Opt_WarnMissingImportList $
                            addWarn (missingImportListWarn imp_mod_name)
 
-    ifaces <- loadSrcInterface doc imp_mod_name want_boot mb_pkg
+    ifaces <- loadSrcInterface doc imp_mod_name want_boot (fmap snd mb_pkg)
 
     -- Compiler sanity check: if the import didn't say
     -- {-# SOURCE #-} we should not get a hi-boot file
@@ -1558,7 +1558,7 @@ printMinimalImports imports_w_usage
       = do { let ImportDecl { ideclName    = L _ mod_name
                             , ideclSource  = is_boot
                             , ideclPkgQual = mb_pkg } = decl
-           ; ifaces <- loadSrcInterface doc mod_name is_boot mb_pkg
+           ; ifaces <- loadSrcInterface doc mod_name is_boot (fmap snd mb_pkg)
            ; let lies = map (L l) (concatMap (to_ie ifaces) used)
            ; return (L l (decl { ideclHiding = Just (False, L l lies) })) }
       where
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index b4117e8724..0578bec23e 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -432,8 +432,9 @@ patchCImportSpec packageKey spec
 patchCCallTarget :: PackageKey -> CCallTarget -> CCallTarget
 patchCCallTarget packageKey callTarget =
   case callTarget of
-  StaticTarget label Nothing isFun -> StaticTarget label (Just packageKey) isFun
-  _                                -> callTarget
+  StaticTarget src label Nothing isFun
+                              -> StaticTarget src label (Just packageKey) isFun
+  _                           -> callTarget
 
 {-
 *********************************************************
@@ -728,10 +729,10 @@ rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
        ; checkDupRdrNames rdr_names_w_loc
        ; checkShadowedRdrNames rdr_names_w_loc
        ; names <- newLocalBndrsRn rdr_names_w_loc
-       ; bindHsRuleVars (unLoc rule_name) vars names $ \ vars' ->
+       ; bindHsRuleVars (snd $ unLoc rule_name) vars names $ \ vars' ->
     do { (lhs', fv_lhs') <- rnLExpr lhs
        ; (rhs', fv_rhs') <- rnLExpr rhs
-       ; checkValidRule (unLoc rule_name) names lhs' fv_lhs'
+       ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'
        ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
                  fv_lhs' `plusFV` fv_rhs') } }
   where
diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
index 20bbf3b729..4d2219ca5c 100644
--- a/compiler/stgSyn/CoreToStg.hs
+++ b/compiler/stgSyn/CoreToStg.hs
@@ -579,7 +579,8 @@ coreToStgApp _ f args ticks = do
                                     StgOpApp (StgPrimOp op) args' res_ty
 
                 -- A call to some primitive Cmm function.
-                FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId) True) PrimCallConv _))
+                FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)
+                                          PrimCallConv _))
                                  -> ASSERT( saturated )
                                     StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty
 
diff --git a/compiler/typecheck/TcForeign.hs b/compiler/typecheck/TcForeign.hs
index b38716231a..ce3463a12f 100644
--- a/compiler/typecheck/TcForeign.hs
+++ b/compiler/typecheck/TcForeign.hs
@@ -321,7 +321,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
       checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
       checkMissingAmpersand dflags arg_tys res_ty
       case target of
-          StaticTarget _ _ False
+          StaticTarget _ _ _ False
            | not (null arg_tys) ->
               addErrTc (text "`value' imports cannot have function types")
           _ -> return ()
@@ -331,7 +331,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
 -- This makes a convenient place to check
 -- that the C identifier is valid for C
 checkCTarget :: CCallTarget -> TcM ()
-checkCTarget (StaticTarget str _ _) = do
+checkCTarget (StaticTarget _ str _ _) = do
     checkCg checkCOrAsmOrLlvmOrInterp
     checkTc (isCLabelString str) (badCName str)
 
@@ -397,13 +397,13 @@ tcFExport d = pprPanic "tcFExport" (ppr d)
 -- ------------ Checking argument types for foreign export ----------------------
 
 tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport
-tcCheckFEType sig_ty (CExport (L l (CExportStatic str cconv)) src) = do
+tcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do
     checkCg checkCOrAsmOrLlvm
     checkTc (isCLabelString str) (badCName str)
     cconv' <- checkCConv cconv
     checkForeignArgs isFFIExternalTy arg_tys
     checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty
-    return (CExport (L l (CExportStatic str cconv')) src)
+    return (CExport (L l (CExportStatic esrc str cconv')) src)
   where
       -- Drop the foralls before inspecting n
       -- the structure of the foreign type.
diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs
index 96de43ea3b..8a73f24706 100644
--- a/compiler/typecheck/TcRules.hs
+++ b/compiler/typecheck/TcRules.hs
@@ -128,7 +128,7 @@ tcRuleDecls (HsRules src decls)
 
 tcRule :: RuleDecl Name -> TcM (RuleDecl TcId)
 tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
-  = addErrCtxt (ruleCtxt $ unLoc name)  $
+  = addErrCtxt (ruleCtxt $ snd $ unLoc name)  $
     do { traceTc "---- Rule ------" (ppr name)
 
         -- Note [Typechecking rules]
@@ -147,7 +147,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
                   ; (rhs', rhs_wanted) <- captureConstraints (tcMonoExpr rhs rule_ty)
                   ; return (lhs', lhs_wanted, rhs', rhs_wanted, rule_ty) }
 
-       ; (lhs_evs, other_lhs_wanted) <- simplifyRule (unLoc name) 
+       ; (lhs_evs, other_lhs_wanted) <- simplifyRule (snd $ unLoc name)
                                                      (bndr_wanted `andWC` lhs_wanted)
                                                      rhs_wanted
 
@@ -168,7 +168,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
        ; gbls  <- tcGetGlobalTyVars   -- Even though top level, there might be top-level
                                       -- monomorphic bindings from the MR; test tc111
        ; qtkvs <- quantifyTyVars gbls forall_tvs
-       ; traceTc "tcRule" (vcat [ doubleQuotes (ftext $ unLoc name)
+       ; traceTc "tcRule" (vcat [ doubleQuotes (ftext $ snd $ unLoc name)
                                 , ppr forall_tvs
                                 , ppr qtkvs
                                 , ppr rule_ty
@@ -185,7 +185,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
                                   , ic_wanted = rhs_wanted
                                   , ic_insol  = insolubleWC rhs_wanted
                                   , ic_binds  = rhs_binds_var
-                                  , ic_info   = RuleSkol (unLoc name)
+                                  , ic_info   = RuleSkol (snd $ unLoc name)
                                   , ic_env    = lcl_env }
 
            -- For the LHS constraints we must solve the remaining constraints
@@ -199,7 +199,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
                                   , ic_wanted = other_lhs_wanted
                                   , ic_insol  = insolubleWC other_lhs_wanted
                                   , ic_binds  = lhs_binds_var
-                                  , ic_info   = RuleSkol (unLoc name)
+                                  , ic_info   = RuleSkol (snd $ unLoc name)
                                   , ic_env    = lcl_env }
 
        ; return (HsRule name act
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 06fbc57990..553a730155 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -1511,7 +1511,7 @@ keepPackageImports = filterM is_pkg_import
      is_pkg_import :: InteractiveImport -> GHCi Bool
      is_pkg_import (IIModule _) = return False
      is_pkg_import (IIDecl d)
-         = do e <- gtry $ GHC.findModule mod_name (ideclPkgQual d)
+         = do e <- gtry $ GHC.findModule mod_name (fmap snd $ ideclPkgQual d)
               case e :: Either SomeException Module of
                 Left _  -> return False
                 Right m -> return (not (isHomeModule m))
@@ -1686,7 +1686,8 @@ guessCurrentModule cmd
           CmdLineError (':' : cmd ++ ": no current module")
        case (head imports) of
           IIModule m -> GHC.findModule m Nothing
-          IIDecl d   -> GHC.findModule (unLoc (ideclName d)) (ideclPkgQual d)
+          IIDecl d   -> GHC.findModule (unLoc (ideclName d))
+                                       (fmap snd $ ideclPkgQual d)
 
 -- without bang, show items in context of their parents and omit children
 -- with bang, show class methods and data constructors separately, and
@@ -1883,7 +1884,7 @@ checkAdd ii = do
     IIDecl d -> do
        let modname = unLoc (ideclName d)
            pkgqual = ideclPkgQual d
-       m <- GHC.lookupModule modname pkgqual
+       m <- GHC.lookupModule modname (fmap snd pkgqual)
        when safe $ do
            t <- GHC.isModuleTrusted m
            when (not t) $ throwGhcException $ ProgramError $ ""
diff --git a/testsuite/tests/ghc-api/annotations/.gitignore b/testsuite/tests/ghc-api/annotations/.gitignore
index 3b2ea550ac..9880335dcc 100644
--- a/testsuite/tests/ghc-api/annotations/.gitignore
+++ b/testsuite/tests/ghc-api/annotations/.gitignore
@@ -17,6 +17,7 @@ t10357
 t10358
 t10396
 t10399
+stringSource
 *.hi
 *.o
 *.run.*
diff --git a/testsuite/tests/ghc-api/annotations/Makefile b/testsuite/tests/ghc-api/annotations/Makefile
index 51a64c32d1..6cba9d4589 100644
--- a/testsuite/tests/ghc-api/annotations/Makefile
+++ b/testsuite/tests/ghc-api/annotations/Makefile
@@ -164,3 +164,9 @@ T10399:
 		-outputdir tmp_T10399 \
     t10399
 	./t10399 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10399
+
+.PHONY: T10313
+T10313:
+	rm -f stringSource.o stringSource.hi
+	'$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc stringSource
+	./stringSource "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10313
diff --git a/testsuite/tests/ghc-api/annotations/T10313.stderr b/testsuite/tests/ghc-api/annotations/T10313.stderr
new file mode 100644
index 0000000000..a71eaf7897
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/T10313.stderr
@@ -0,0 +1,28 @@
+
+Test10313.hs:9:13:
+    The deprecation for ‘solverCheckAndGetModel’
+      lacks an accompanying binding
+
+Test10313.hs:15:16:
+    Multiple warning declarations for ‘Logic’
+    also at  Test10313.hs:9:13-17
+
+Test10313.hs:15:16:
+    The deprecation for ‘solverCheckAndGetModel’
+      lacks an accompanying binding
+
+Test10313.hs:16:13:
+    Multiple warning declarations for ‘solverCheckAndGetModel’
+    also at  Test10313.hs:10:13-34
+
+Test10313.hs:30:15: Not in scope: data constructor ‘Bitstream’
+
+Test10313.hs:32:7: Not in scope: ‘S.concatMap’
+
+Test10313.hs:32:19: Not in scope: ‘stream’
+
+Test10313.hs:32:27: Not in scope: ‘GV.stream’
+
+Test10313.hs:33:7: Not in scope: ‘S.sized’
+
+Test10313.hs:34:7: Not in scope: data constructor ‘Exact’
diff --git a/testsuite/tests/ghc-api/annotations/T10313.stdout b/testsuite/tests/ghc-api/annotations/T10313.stdout
new file mode 100644
index 0000000000..a2680a9582
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/T10313.stdout
@@ -0,0 +1,27 @@
+[([i], [([", b, \, x, 6, 1, s, e, "], base)]),
+ ([w],
+  [([", N, e, w,  , Z, 3,  , A, P, I,  , s, u, p, p, o, r, t,  , i,
+     s,  , s, t, i, l, l,  , i, n, c, o, m, p, l, e, t, e,  , a, n, d,
+      , f, r, a, g, i, l, e, :,  , \, 
+,  ,  ,  ,  ,  ,  ,  ,  ,  ,  ,
+     \, y, o, u,  , m, a, y,  , e, x, p, e, r, i, e, n, c, e,  , s, e,
+     g, m, e, n, t, a, t, i, o, n,  , f, a, u, l, t, s, !, "],
+    New Z3 API support is still incomplete and fragile: you may experience segmentation faults!)]),
+ ([d],
+  [([", D, e, p, r, e, c, a, t, i, o, n, :,  , \, 
+,  ,  ,  ,  ,  ,
+      ,  ,  ,  ,  , \, y, o, u,  , m, a, y,  , e, x, p, e, r, i, e, n,
+     c, e,  , s, e, g, m, e, n, t, a, t, i, o, n,  , f, a, u, l, t, s,
+     !, "],
+    Deprecation: you may experience segmentation faults!)]),
+ ([c],
+  [([", f, o, o, \, x, 6, 3, "], fooc),
+   ([", b, \, x, 6, 1, r, "], bar)]),
+ ([r], [([", f, o, o, 1, \, x, 6, 7, "], foo1g)]),
+ ([s, t], [([", a, \, x, 6, 2, "], ab)]),
+ ([c, o],
+  [([", S, t, r, i, c, t,  , B, i, t, s, t, r, e, a, m,  , s, t, r,
+     e, \, x, 6, 1, m, "],
+    Strict Bitstream stream)]),
+ ([s, c], [([", f, o, o, \, x, 6, 4, "], food)]),
+ ([t, p], [([", f, o, o, b, \, x, 6, 1, r, "], foobar)])]
diff --git a/testsuite/tests/ghc-api/annotations/Test10313.hs b/testsuite/tests/ghc-api/annotations/Test10313.hs
new file mode 100644
index 0000000000..5faa00649f
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/Test10313.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE MagicHash, UnliftedFFITypes #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Test10313 where
+
+import "b\x61se" Data.List
+
+{-# WARNING Logic
+          , solverCheckAndGetModel
+          "New Z3 API support is still incomplete and fragile: \
+          \you may experience segmentation faults!"
+  #-}
+
+{-# Deprecated Logic
+          , solverCheckAndGetModel
+          "Deprecation: \
+          \you may experience segmentation faults!"
+  #-}
+
+data {-# Ctype "foo\x63" "b\x61r" #-} Logic = Logic
+
+-- Should warn
+foo1 x = x
+{-# RULES "foo1\x67" [ 1] forall x. foo1 x = x #-}
+
+foreign import prim unsafe "a\x62" a :: IO Int
+
+{-# INLINE strictStream #-}
+strictStream (Bitstream l v)
+    = {-# CORE "Strict Bitstream stre\x61m" #-}
+      S.concatMap stream (GV.stream v)
+      `S.sized`
+      Exact l
+
+b = {-# SCC "foo\x64"   #-} 006
+
+c = {-# GENERATED "foob\x61r" 1 : 2  -  3 :   4 #-} 0.00
diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T
index 57f0e9ce37..f6cb955745 100644
--- a/testsuite/tests/ghc-api/annotations/all.T
+++ b/testsuite/tests/ghc-api/annotations/all.T
@@ -17,3 +17,4 @@ test('T10278',      normal, run_command, ['$MAKE -s --no-print-directory T10278'
 test('T10354',      normal, run_command, ['$MAKE -s --no-print-directory T10354'])
 test('T10396',      normal, run_command, ['$MAKE -s --no-print-directory T10396'])
 test('T10399',      normal, run_command, ['$MAKE -s --no-print-directory T10399'])
+test('T10313',      normal, run_command, ['$MAKE -s --no-print-directory T10313'])
diff --git a/testsuite/tests/ghc-api/annotations/stringSource.hs b/testsuite/tests/ghc-api/annotations/stringSource.hs
new file mode 100644
index 0000000000..9d82c9d0b3
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/stringSource.hs
@@ -0,0 +1,139 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+-- This program must be called with GHC's libdir as the single command line
+-- argument.
+module Main where
+
+-- import Data.Generics
+import Data.Data
+import Data.List
+import System.IO
+import GHC
+import BasicTypes
+import DynFlags
+import FastString
+import ForeignCall
+import MonadUtils
+import Outputable
+import HsDecls
+import Bag (filterBag,isEmptyBag)
+import System.Directory (removeFile)
+import System.Environment( getArgs )
+import qualified Data.Map as Map
+import Data.Dynamic ( fromDynamic,Dynamic )
+
+main::IO()
+main = do
+        [libdir,fileName] <- getArgs
+        testOneFile libdir fileName
+
+testOneFile libdir fileName = do
+       ((anns,cs),p) <- runGhc (Just libdir) $ do
+                        dflags <- getSessionDynFlags
+                        setSessionDynFlags dflags
+                        let mn =mkModuleName fileName
+                        addTarget Target { targetId = TargetModule mn
+                                         , targetAllowObjCode = True
+                                         , targetContents = Nothing }
+                        load LoadAllTargets
+                        modSum <- getModSummary mn
+                        p <- parseModule modSum
+                        return (pm_annotations p,p)
+
+       let tupArgs = gq (pm_parsed_source p)
+
+       putStrLn (pp tupArgs)
+       -- putStrLn (intercalate "\n" [showAnns anns])
+
+    where
+     gq ast = everything (++) ([] `mkQ` doWarningTxt
+                               `extQ` doImportDecl
+                               `extQ` doCType
+                               `extQ` doRuleDecl
+                               `extQ` doCCallTarget
+                               `extQ` doHsExpr
+                              ) ast
+
+     doWarningTxt :: WarningTxt -> [(String,[Located (SourceText,FastString)])]
+     doWarningTxt ((WarningTxt _ ss))    = [("w",ss)]
+     doWarningTxt ((DeprecatedTxt _ ss)) = [("d",ss)]
+
+     doImportDecl :: ImportDecl RdrName
+                  -> [(String,[Located (SourceText,FastString)])]
+     doImportDecl (ImportDecl _ _ Nothing _ _ _ _ _ _) = []
+     doImportDecl (ImportDecl _ _ (Just ss) _ _ _ _ _ _) = [("i",[noLoc ss])]
+
+     doCType :: CType -> [(String,[Located (SourceText,FastString)])]
+     doCType (CType src (Just (Header hs hf)) c)
+                                    = [("c",[noLoc (hs,hf),noLoc c])]
+     doCType (CType src Nothing  c) = [("c",[noLoc c])]
+
+     doRuleDecl :: RuleDecl RdrName
+                -> [(String,[Located (SourceText,FastString)])]
+     doRuleDecl (HsRule ss _ _ _ _ _ _) = [("r",[ss])]
+
+     doCCallTarget :: CCallTarget
+                   -> [(String,[Located (SourceText,FastString)])]
+     doCCallTarget (StaticTarget s f _ _) = [("st",[(noLoc (s,f))])]
+
+     doHsExpr :: HsExpr RdrName -> [(String,[Located (SourceText,FastString)])]
+     doHsExpr (HsCoreAnn src ss _) = [("co",[noLoc ss])]
+     doHsExpr (HsSCC     src ss _) = [("sc",[noLoc ss])]
+     doHsExpr (HsTickPragma src (ss,_,_) _) = [("tp",[noLoc ss])]
+     doHsExpr _ = []
+
+showAnns anns = "[\n" ++ (intercalate "\n"
+   $ map (\((s,k),v)
+              -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n"))
+   $ Map.toList anns)
+    ++ "]\n"
+
+pp a = showPpr unsafeGlobalDynFlags a
+
+-- ---------------------------------------------------------------------
+
+-- Copied from syb for the test
+
+
+-- | Generic queries of type \"r\",
+--   i.e., take any \"a\" and return an \"r\"
+--
+type GenericQ r = forall a. Data a => a -> r
+
+
+-- | Make a generic query;
+--   start from a type-specific case;
+--   return a constant otherwise
+--
+mkQ :: ( Typeable a
+       , Typeable b
+       )
+    => r
+    -> (b -> r)
+    -> a
+    -> r
+(r `mkQ` br) a = case cast a of
+                        Just b  -> br b
+                        Nothing -> r
+
+-- | Extend a generic query by a type-specific case
+extQ :: ( Typeable a
+        , Typeable b
+        )
+     => (a -> q)
+     -> (b -> q)
+     -> a
+     -> q
+extQ f g a = maybe (f a) g (cast a)
+
+
+-- | Summarise all nodes in top-down, left-to-right order
+everything :: (r -> r -> r) -> GenericQ r -> GenericQ r
+
+-- Apply f to x to summarise top-level node;
+-- use gmapQ to recurse into immediate subterms;
+-- use ordinary foldl to reduce list of intermediate results
+
+everything k f x = foldl k (f x) (gmapQ (everything k f) x)
diff --git a/utils/haddock b/utils/haddock
-Subproject bf31846b9f7280b5e75f09e91ca18c4ced37af0
+Subproject 81affaaf19ea33ad07bc7d5c15a949644a10c76