Replace (SourceText,FastString) with StringLiteral data type

Summary:
Phab:D907 introduced SourceText for a number of data types, by replacing
FastString with (SourceText,FastString). Since this has an Outputable
instance, no warnings are generated when ppr is called on it, but
unexpected output is generated. See Phab:D1096 for an example of this.

Replace the (SourceText,FastString) tuples with a new data type,
```lang=hs
data StringLiteral = StringLiteral SourceText FastString
```

Update haddock submodule accordingly

Test Plan: ./validate

Reviewers: hvr, austin, rwbarton, trofi, bgamari

Reviewed By: trofi, bgamari

Subscribers: thomie, trofi, rwbarton, mpickering

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

GHC Trac Issues: #10692

14 files changed, 92 insertions, 63 deletions

diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs
index a256ac15b0..a3033dba94 100644
--- a/compiler/basicTypes/BasicTypes.hs
+++ b/compiler/basicTypes/BasicTypes.hs
@@ -27,7 +27,7 @@ module BasicTypes(
 
         FunctionOrData(..),
 
-        WarningTxt(..),
+        WarningTxt(..), StringLiteral(..),
 
         Fixity(..), FixityDirection(..),
         defaultFixity, maxPrecedence, minPrecedence,
@@ -268,20 +268,30 @@ initialVersion = 1
 ************************************************************************
 -}
 
+-- |A String Literal in the source, including its original raw format for use by
+-- source to source manipulation tools.
+data StringLiteral = StringLiteral
+                       { sl_st :: SourceText, -- literal raw source.
+                                              -- See not [Literal source text]
+                         sl_fs :: FastString  -- literal string value
+                       } deriving (Data, Typeable)
+
+instance Eq StringLiteral where
+  (StringLiteral _ a) == (StringLiteral _ b) = a == b
+
 -- reason/explanation from a WARNING or DEPRECATED pragma
--- For SourceText usage, see note [Pragma source text]
 data WarningTxt = WarningTxt (Located SourceText)
-                             [Located (SourceText,FastString)]
+                             [Located StringLiteral]
                 | DeprecatedTxt (Located SourceText)
-                                [Located (SourceText,FastString)]
+                                [Located StringLiteral]
     deriving (Eq, Data, Typeable)
 
 instance Outputable WarningTxt where
     ppr (WarningTxt    _ ws)
-                            = doubleQuotes (vcat (map (ftext . snd . unLoc) ws))
+                         = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws))
     ppr (DeprecatedTxt _ ds)
-                            = text "Deprecated:" <+>
-                              doubleQuotes (vcat (map (ftext . snd . unLoc) ds))
+                         = text "Deprecated:" <+>
+                           doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds))
 
 {-
 ************************************************************************
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index a6cb98d372..433a13ee37 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -302,7 +302,7 @@ dsExpr (HsSCC _ cc expr@(L loc _)) = do
         mod_name <- getModule
         count <- goptM Opt_ProfCountEntries
         uniq <- newUnique
-        Tick (ProfNote (mkUserCC (snd cc) mod_name loc uniq) count True)
+        Tick (ProfNote (mkUserCC (sl_fs cc) mod_name loc uniq) count True)
                <$> dsLExpr expr
       else dsLExpr expr
 
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index ecb4a02321..8fbe257b83 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -350,15 +350,15 @@ data HsExpr id
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | HsSCC       SourceText            -- Note [Pragma source text] in BasicTypes
-                (SourceText,FastString) -- "set cost centre" SCC pragma
-                (LHsExpr id)            -- expr whose cost is to be measured
+                StringLiteral         -- "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
-                (SourceText,FastString) -- hdaume: core annotation
+                StringLiteral         -- hdaume: core annotation
                 (LHsExpr id)
 
   -----------------------------------------------------------
@@ -464,7 +464,7 @@ 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
-     ((SourceText,FastString),(Int,Int),(Int,Int))
+     (StringLiteral,(Int,Int),(Int,Int))
                                       -- external span for this tick
      (LHsExpr id)
 
@@ -595,7 +595,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 _ (StringLiteral _ s) e)
   = vcat [ptext (sLit "HsCoreAnn") <+> ftext s, ppr_lexpr e]
 
 ppr_expr (HsApp e1 e2)
@@ -716,7 +716,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 _ (StringLiteral _ lbl) expr)
   = sep [ ptext (sLit "{-# SCC") <+> doubleQuotes (ftext lbl) <+> ptext (sLit "#-}"),
           pprParendExpr expr ]
 
@@ -750,7 +750,7 @@ ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
 ppr_expr (HsTickPragma _ externalSrcLoc exp)
   = pprTicks (ppr exp) $
     hcat [ptext (sLit "tickpragma<"),
-          ppr externalSrcLoc,
+          pprExternalSrcLoc externalSrcLoc,
           ptext (sLit ">("),
           ppr exp,
           ptext (sLit ")")]
@@ -770,6 +770,10 @@ ppr_expr (HsArrForm op _ args)
   = hang (ptext (sLit "(|") <+> ppr_lexpr op)
          4 (sep (map (pprCmdArg.unLoc) args) <+> ptext (sLit "|)"))
 
+pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc
+pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4))
+  = ppr (src,(n1,n2),(n3,n4))
+
 {-
 HsSyn records exactly where the user put parens, with HsPar.
 So generally speaking we print without adding any parens.
diff --git a/compiler/hsSyn/HsImpExp.hs b/compiler/hsSyn/HsImpExp.hs
index 810fc67603..14579821e8 100644
--- a/compiler/hsSyn/HsImpExp.hs
+++ b/compiler/hsSyn/HsImpExp.hs
@@ -13,7 +13,7 @@ module HsImpExp where
 import Module           ( ModuleName )
 import HsDoc            ( HsDocString )
 import OccName          ( HasOccName(..), isTcOcc, isSymOcc )
-import BasicTypes       ( SourceText )
+import BasicTypes       ( SourceText, StringLiteral(..) )
 
 import Outputable
 import FastString
@@ -44,14 +44,14 @@ data ImportDecl name
       ideclSourceSrc :: Maybe SourceText,
                                  -- Note [Pragma source text] in BasicTypes
       ideclName      :: Located ModuleName, -- ^ Module name.
-      ideclPkgQual   :: Maybe (SourceText,FastString),  -- ^ Package qualifier.
-      ideclSource    :: Bool,              -- ^ True <=> {-\# SOURCE \#-} import
-      ideclSafe      :: Bool,               -- ^ True => safe import
-      ideclQualified :: Bool,               -- ^ True => qualified
-      ideclImplicit  :: Bool,               -- ^ True => implicit import (of Prelude)
-      ideclAs        :: Maybe ModuleName,   -- ^ as Module
+      ideclPkgQual   :: Maybe StringLiteral,  -- ^ Package qualifier.
+      ideclSource    :: Bool,          -- ^ True <=> {-\# SOURCE \#-} import
+      ideclSafe      :: Bool,          -- ^ True => safe import
+      ideclQualified :: Bool,          -- ^ True => qualified
+      ideclImplicit  :: Bool,          -- ^ True => implicit import (of Prelude)
+      ideclAs        :: Maybe ModuleName,  -- ^ as Module
       ideclHiding    :: Maybe (Bool, Located [LIE name])
-                                            -- ^ (True => hiding, names)
+                                       -- ^ (True => hiding, names)
     }
      -- ^
      --  'ApiAnnotation.AnnKeywordId's
@@ -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 (StringLiteral _ 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 2b8a21272e..6771925094 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -1331,7 +1331,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 (fmap snd pkg)
+     find_res <- liftIO $ findImportedModule hsc_env mod (fmap sl_fs pkg)
      let reason = moduleNameString mod ++ " changed"
      case find_res of
         FoundModule h -> check_mod reason (fr_mod h)
diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs
index c51feeb491..026afc6eb6 100644
--- a/compiler/main/DriverMkDepend.hs
+++ b/compiler/main/DriverMkDepend.hs
@@ -30,6 +30,7 @@ import Panic
 import SrcLoc
 import Data.List
 import FastString
+import BasicTypes ( StringLiteral(..) )
 
 import Exception
 import ErrUtils
@@ -226,7 +227,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 (fmap snd $ ideclPkgQual i) mod
+                    [ do_imp loc is_boot (fmap sl_fs $ 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 89cab9ef3a..fbeb631cc8 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -1696,7 +1696,7 @@ msDeps s =
 
 home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName]
 home_imps imps = [ ideclName i |  L _ i <- imps,
-                                  isLocal (fmap snd $ ideclPkgQual i) ]
+                                  isLocal (fmap sl_fs $ ideclPkgQual i) ]
   where isLocal Nothing = True
         isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special
         isLocal _ = False
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 815c8cb798..b1863856a3 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -807,10 +807,10 @@ maybe_safe :: { ([AddAnn],Bool) }
         : 'safe'                                { ([mj AnnSafe $1],True) }
         | {- empty -}                           { ([],False) }
 
-maybe_pkg :: { ([AddAnn],Maybe (SourceText,FastString)) }
+maybe_pkg :: { ([AddAnn],Maybe StringLiteral) }
         : STRING  {% let pkgFS = getSTRING $1 in
                      if looksLikePackageName (unpackFS pkgFS)
-                        then return ([mj AnnPackageName $1], Just (getSTRINGs $1,pkgFS))
+                        then return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS))
                         else parseErrorSDoc (getLoc $1) $ vcat [
                              text "parse error" <> colon <+> quotes (ppr pkgFS),
                              text "Version number or non-alphanumeric" <+>
@@ -1465,15 +1465,15 @@ deprecation :: { OrdList (LWarnDecl RdrName) }
              {% amsu (sLL $1 $> $ (Warning (unLoc $1) (DeprecatedTxt (noLoc "") $ snd $ unLoc $2)))
                      (fst $ unLoc $2) }
 
-strings :: { Located ([AddAnn],[Located (SourceText,FastString)]) }
-    : STRING { sL1 $1 ([],[L (gl $1) (getSTRINGs $1,getSTRING $1)]) }
+strings :: { Located ([AddAnn],[Located StringLiteral]) }
+    : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) }
     | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) }
 
-stringlist :: { Located (OrdList (Located (SourceText,FastString))) }
+stringlist :: { Located (OrdList (Located StringLiteral)) }
     : stringlist ',' STRING {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >>
                                return (sLL $1 $> (unLoc $1 `snocOL`
-                                                  (L (gl $3) (getSTRINGs $3,getSTRING $3)))) }
-    | STRING                { sLL $1 $> (unitOL (L (gl $1) (getSTRINGs $1,getSTRING $1))) }
+                                                  (L (gl $3) (getStringLiteral $3)))) }
+    | STRING                { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) }
 
 -----------------------------------------------------------------------------
 -- Annotations
@@ -1521,12 +1521,12 @@ safety :: { Located Safety }
         | 'interruptible'               { sLL $1 $> PlayInterruptible }
 
 fspec :: { Located ([AddAnn]
-                    ,(Located (SourceText,FastString), Located RdrName, LHsType RdrName)) }
+                    ,(Located StringLiteral, Located RdrName, LHsType RdrName)) }
        : STRING var '::' sigtypedoc     { sLL $1 $> ([mj AnnDcolon $3]
                                              ,(L (getLoc $1)
-                                                    (getSTRINGs $1,getSTRING $1), $2, $4)) }
+                                                    (getStringLiteral $1), $2, $4)) }
        |        var '::' sigtypedoc     { sLL $1 $> ([mj AnnDcolon $2]
-                                             ,(noLoc ("",nilFS), $1, $3)) }
+                                             ,(noLoc (StringLiteral "" 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
@@ -2228,7 +2228,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) (getSTRINGs $2,getSTRING $2) $4)
+        | '{-# CORE' STRING '#-}' exp  {% ams (sLL $1 $> $ HsCoreAnn (getCORE_PRAGs $1) (getStringLiteral $2) $4)
                                               [mo $1,mj AnnVal $2
                                               ,mc $3] }
                                           -- hdaume: core annotation
@@ -2269,16 +2269,16 @@ optSemi :: { ([Located a],Bool) }
         : ';'         { ([$1],True) }
         | {- empty -} { ([],False) }
 
-scc_annot :: { Located (([AddAnn],SourceText),(SourceText,FastString)) }
+scc_annot :: { Located (([AddAnn],SourceText),StringLiteral) }
         : '{-# SCC' STRING '#-}'      {% do scc <- getSCC $2
                                             ; return $ sLL $1 $>
                                                (([mo $1,mj AnnValStr $2
-                                                ,mc $3],getSCC_PRAGs $1),(getSTRINGs $2,scc)) }
+                                                ,mc $3],getSCC_PRAGs $1),(StringLiteral (getSTRINGs $2) scc)) }
         | '{-# SCC' VARID  '#-}'      { sLL $1 $> (([mo $1,mj AnnVal $2
                                          ,mc $3],getSCC_PRAGs $1)
-                                        ,(unpackFS $ getVARID $2,getVARID $2)) }
+                                        ,(StringLiteral (unpackFS $ getVARID $2) (getVARID $2))) }
 
-hpc_annot :: { Located (([AddAnn],SourceText),((SourceText,FastString),(Int,Int),(Int,Int))) }
+hpc_annot :: { Located (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,Int))) }
       : '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
                                       { sLL $1 $> $ (([mo $1,mj AnnVal $2
                                               ,mj AnnVal $3,mj AnnColon $4
@@ -2286,7 +2286,7 @@ hpc_annot :: { Located (([AddAnn],SourceText),((SourceText,FastString),(Int,Int)
                                               ,mj AnnVal $7,mj AnnColon $8
                                               ,mj AnnVal $9,mc $10],
                                                 getGENERATED_PRAGs $1)
-                                              ,((getSTRINGs $2,getSTRING $2)
+                                              ,((getStringLiteral $2)
                                                ,( fromInteger $ getINTEGER $3
                                                 , fromInteger $ getINTEGER $5
                                                 )
@@ -3214,6 +3214,7 @@ getOVERLAPS_PRAGs     (L _ (IToverlaps_prag     src)) = src
 getINCOHERENT_PRAGs   (L _ (ITincoherent_prag   src)) = src
 getCTYPEs             (L _ (ITctype             src)) = src
 
+getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l)
 
 getSCC :: Located Token -> P FastString
 getSCC lt = do let s = getSTRING lt
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 357512be33..ab3f17d182 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -1226,9 +1226,9 @@ mkInlinePragma src (inl, match_info) mb_act
 --
 mkImport :: Located CCallConv
          -> Located Safety
-         -> (Located (SourceText,FastString), Located RdrName, LHsType RdrName)
+         -> (Located StringLiteral, Located RdrName, LHsType RdrName)
          -> P (HsDecl RdrName)
-mkImport (L lc cconv) (L ls safety) (L loc (esrc,entity), v, ty)
+mkImport (L lc cconv) (L ls safety) (L loc (StringLiteral esrc entity), v, ty)
   | cconv == PrimCallConv                      = do
   let funcTarget = CFunction (StaticTarget esrc entity Nothing True)
       importSpec = CImport (L lc PrimCallConv) (L ls safety) Nothing funcTarget
@@ -1305,9 +1305,9 @@ parseCImport cconv safety nm str sourceText =
 -- construct a foreign export declaration
 --
 mkExport :: Located CCallConv
-         -> (Located (SourceText,FastString), Located RdrName, LHsType RdrName)
+         -> (Located StringLiteral, Located RdrName, LHsType RdrName)
          -> P (HsDecl RdrName)
-mkExport (L lc cconv) (L le (esrc,entity), v, ty) = do
+mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty) = do
   return $ ForD (ForeignExport v ty noForeignExportCoercionYet
                  (CExport (L lc (CExportStatic esrc entity' cconv))
                           (L le (unpackFS entity))))
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index aeb0388673..9e5108a27b 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -36,7 +36,7 @@ import RdrHsSyn        ( setRdrNameSpace )
 import Outputable
 import Maybes
 import SrcLoc
-import BasicTypes      ( TopLevelFlag(..) )
+import BasicTypes      ( TopLevelFlag(..), StringLiteral(..) )
 import ErrUtils
 import Util
 import FastString
@@ -216,7 +216,7 @@ rnImportDecl this_mod
                            -- 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" ||
+             Just (StringLiteral _ pkg_fs) -> pkg_fs == fsLit "this" ||
                             fsToPackageKey pkg_fs == modulePackageKey this_mod))
          (addErr (ptext (sLit "A module cannot import itself:") <+> ppr imp_mod_name))
 
@@ -229,7 +229,7 @@ rnImportDecl this_mod
            | otherwise  -> whenWOptM Opt_WarnMissingImportList $
                            addWarn (missingImportListWarn imp_mod_name)
 
-    ifaces <- loadSrcInterface doc imp_mod_name want_boot (fmap snd mb_pkg)
+    ifaces <- loadSrcInterface doc imp_mod_name want_boot (fmap sl_fs mb_pkg)
 
     -- Compiler sanity check: if the import didn't say
     -- {-# SOURCE #-} we should not get a hi-boot file
@@ -1581,7 +1581,8 @@ 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 (fmap snd mb_pkg)
+           ; ifaces <- loadSrcInterface doc mod_name is_boot
+                                        (fmap sl_fs mb_pkg)
            ; let lies = map (L l) (concatMap (to_ie ifaces) used)
            ; return (L l (decl { ideclHiding = Just (False, L l lies) })) }
       where
@@ -1788,11 +1789,11 @@ missingImportListItem ie
 moduleWarn :: ModuleName -> WarningTxt -> SDoc
 moduleWarn mod (WarningTxt _ txt)
   = sep [ ptext (sLit "Module") <+> quotes (ppr mod) <> ptext (sLit ":"),
-          nest 2 (vcat (map (ppr . snd . unLoc) txt)) ]
+          nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ]
 moduleWarn mod (DeprecatedTxt _ txt)
   = sep [ ptext (sLit "Module") <+> quotes (ppr mod)
                                 <+> ptext (sLit "is deprecated:"),
-          nest 2 (vcat (map (ppr . snd . unLoc) txt)) ]
+          nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ]
 
 packageImportErr :: SDoc
 packageImportErr
diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index f889a4c067..8f0d8e50dc 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -901,6 +901,15 @@ instance Binary WarningTxt where
                       d <- get bh
                       return (DeprecatedTxt s d)
 
+instance Binary StringLiteral where
+  put_ bh (StringLiteral st fs) = do
+            put_ bh st
+            put_ bh fs
+  get bh = do
+            st <- get bh
+            fs <- get bh
+            return (StringLiteral st fs)
+
 instance Binary a => Binary (GenLocated SrcSpan a) where
     put_ bh (L l x) = do
             put_ bh l
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index d834523cff..2dcedb0b0b 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -1580,7 +1580,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 (fmap snd $ ideclPkgQual d)
+         = do e <- gtry $ GHC.findModule mod_name (fmap sl_fs $ ideclPkgQual d)
               case e :: Either SomeException Module of
                 Left _  -> return False
                 Right m -> return (not (isHomeModule m))
@@ -1756,7 +1756,7 @@ guessCurrentModule cmd
        case (head imports) of
           IIModule m -> GHC.findModule m Nothing
           IIDecl d   -> GHC.findModule (unLoc (ideclName d))
-                                       (fmap snd $ ideclPkgQual d)
+                                       (fmap sl_fs $ ideclPkgQual d)
 
 -- without bang, show items in context of their parents and omit children
 -- with bang, show class methods and data constructors separately, and
@@ -1953,7 +1953,7 @@ checkAdd ii = do
     IIDecl d -> do
        let modname = unLoc (ideclName d)
            pkgqual = ideclPkgQual d
-       m <- GHC.lookupModule modname (fmap snd pkgqual)
+       m <- GHC.lookupModule modname (fmap sl_fs pkgqual)
        when safe $ do
            t <- GHC.isModuleTrusted m
            when (not t) $ throwGhcException $ ProgramError $ ""
diff --git a/testsuite/tests/ghc-api/annotations/stringSource.hs b/testsuite/tests/ghc-api/annotations/stringSource.hs
index 9d82c9d0b3..1e8af17072 100644
--- a/testsuite/tests/ghc-api/annotations/stringSource.hs
+++ b/testsuite/tests/ghc-api/annotations/stringSource.hs
@@ -57,13 +57,14 @@ testOneFile libdir fileName = do
                               ) ast
 
      doWarningTxt :: WarningTxt -> [(String,[Located (SourceText,FastString)])]
-     doWarningTxt ((WarningTxt _ ss))    = [("w",ss)]
-     doWarningTxt ((DeprecatedTxt _ ss)) = [("d",ss)]
+     doWarningTxt ((WarningTxt _ ss))    = [("w",map conv ss)]
+     doWarningTxt ((DeprecatedTxt _ ss)) = [("d",map conv ss)]
 
      doImportDecl :: ImportDecl RdrName
                   -> [(String,[Located (SourceText,FastString)])]
      doImportDecl (ImportDecl _ _ Nothing _ _ _ _ _ _) = []
-     doImportDecl (ImportDecl _ _ (Just ss) _ _ _ _ _ _) = [("i",[noLoc ss])]
+     doImportDecl (ImportDecl _ _ (Just ss) _ _ _ _ _ _)
+                                                     = [("i",[conv (noLoc ss)])]
 
      doCType :: CType -> [(String,[Located (SourceText,FastString)])]
      doCType (CType src (Just (Header hs hf)) c)
@@ -79,11 +80,13 @@ testOneFile libdir fileName = do
      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 (HsCoreAnn src ss _) = [("co",[conv (noLoc ss)])]
+     doHsExpr (HsSCC     src ss _) = [("sc",[conv (noLoc ss)])]
+     doHsExpr (HsTickPragma src (ss,_,_) _) = [("tp",[conv (noLoc ss)])]
      doHsExpr _ = []
 
+     conv (GHC.L l (StringLiteral st fs)) = GHC.L l (st,fs)
+
 showAnns anns = "[\n" ++ (intercalate "\n"
    $ map (\((s,k),v)
               -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n"))
diff --git a/utils/haddock b/utils/haddock
-Subproject 5eb0785cde60997f072c3bdfefaf8c389c96d42
+Subproject 3436273f6e87d9358f6c23ad5b6b2838ce57389