summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/basicTypes/BasicTypes.hs24
-rw-r--r--compiler/deSugar/DsExpr.hs2
-rw-r--r--compiler/hsSyn/HsExpr.hs18
-rw-r--r--compiler/hsSyn/HsImpExp.hs20
-rw-r--r--compiler/iface/MkIface.hs2
-rw-r--r--compiler/main/DriverMkDepend.hs3
-rw-r--r--compiler/main/GhcMake.hs2
-rw-r--r--compiler/parser/Parser.y33
-rw-r--r--compiler/parser/RdrHsSyn.hs8
-rw-r--r--compiler/rename/RnNames.hs13
-rw-r--r--compiler/utils/Binary.hs9
-rw-r--r--ghc/InteractiveUI.hs6
-rw-r--r--testsuite/tests/ghc-api/annotations/stringSource.hs15
m---------utils/haddock0
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
View Lorry Controller Status