summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2015-06-01 14:16:41 +0200
committerAlan Zimmerman <alan.zimm@gmail.com>2015-06-01 14:16:41 +0200
commite6191d1cc37e98785af8b309100ea840084fa3ba (patch)
tree94af94a1d98cf4bd5f7efd8bfc5d9696d3b02821 /compiler
parent7dd0ea7428379df848e3d13528921b39b7bf5b95 (diff)
downloadhaskell-e6191d1cc37e98785af8b309100ea840084fa3ba.tar.gz
ApiAnnotations : strings in warnings do not return SourceText
Summary: The strings used in a WARNING pragma are captured via strings :: { Located ([AddAnn],[Located FastString]) } : STRING { sL1 $1 ([],[L (gl $1) (getSTRING $1)]) } .. The STRING token has a method getSTRINGs that returns the original source text for a string. A warning of the form {-# WARNING Logic , mkSolver , mkSimpleSolver , mkSolverForLogic , solverSetParams , solverPush , solverPop , solverReset , solverGetNumScopes , solverAssertCnstr , solverAssertAndTrack , solverCheck , solverCheckAndGetModel , solverGetReasonUnknown "New Z3 API support is still incomplete and fragile: \ \you may experience segmentation faults!" #-} returns the concatenated warning string rather than the original source. This patch now deals with all remaining instances of getSTRING to bring in a SourceText for each. This updates the haddock submodule as well, for the AST change. Test Plan: ./validate Reviewers: hvr, austin, goldfire Reviewed By: austin Subscribers: bgamari, thomie, mpickering Differential Revision: https://phabricator.haskell.org/D907 GHC Trac Issues: #10313
Diffstat (limited to 'compiler')
-rw-r--r--compiler/basicTypes/BasicTypes.hs14
-rw-r--r--compiler/codeGen/StgCmmForeign.hs4
-rw-r--r--compiler/deSugar/Desugar.hs4
-rw-r--r--compiler/deSugar/DsCCall.hs3
-rw-r--r--compiler/deSugar/DsExpr.hs2
-rw-r--r--compiler/deSugar/DsForeign.hs15
-rw-r--r--compiler/deSugar/DsMeta.hs12
-rw-r--r--compiler/ghci/ByteCodeGen.hs4
-rw-r--r--compiler/hsSyn/Convert.hs5
-rw-r--r--compiler/hsSyn/HsDecls.hs13
-rw-r--r--compiler/hsSyn/HsExpr.hs13
-rw-r--r--compiler/hsSyn/HsImpExp.hs6
-rw-r--r--compiler/iface/MkIface.hs2
-rw-r--r--compiler/main/DriverMkDepend.hs2
-rw-r--r--compiler/main/GhcMake.hs3
-rw-r--r--compiler/main/HscMain.hs2
-rw-r--r--compiler/parser/Parser.y40
-rw-r--r--compiler/parser/RdrHsSyn.hs19
-rw-r--r--compiler/prelude/ForeignCall.hs38
-rw-r--r--compiler/prelude/TysWiredIn.hs22
-rw-r--r--compiler/rename/RnNames.hs8
-rw-r--r--compiler/rename/RnSource.hs9
-rw-r--r--compiler/stgSyn/CoreToStg.hs3
-rw-r--r--compiler/typecheck/TcForeign.hs8
-rw-r--r--compiler/typecheck/TcRules.hs10
25 files changed, 145 insertions, 116 deletions
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs
index 682317b2f3..fe6c2a4834 100644
--- a/compiler/basicTypes/BasicTypes.hs
+++ b/compiler/basicTypes/BasicTypes.hs
@@ -268,14 +268,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 c8e3f64b03..2e84560f9e 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 90121a0f5f..19ac062ce9 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 37c927dddd..66f1758a03 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 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 cd78a18332..7c6e62cda1 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 34ef0e808e..010af3c833 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -483,15 +483,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)
@@ -525,7 +527,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 ae453c0ccd..347b3987f2 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 38c5101173..da7fcdeae1 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -491,7 +491,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 }
@@ -542,7 +543,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 48cc8356c4..9233f4fde1 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -1414,11 +1414,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"))
@@ -1428,7 +1428,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 '"'
{-
@@ -1450,8 +1450,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
@@ -1494,7 +1495,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 e9171a4f66..16205d7322 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)
-----------------------------------------------------------
@@ -458,7 +458,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)
---------------------------------------
@@ -587,7 +588,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)
@@ -708,7 +709,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 9a2cd35c91..e897daa3b6 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -1332,7 +1332,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
FoundModule h -> check_mod reason (fr_mod h)
diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs
index 1b4d1ac3f1..c51feeb491 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 7dcf379538..89cab9ef3a 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -1695,7 +1695,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 5ae104b1da..2ac2041502 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -811,7 +811,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 63fc5f9c94..2739e10fb2 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -776,10 +776,10 @@ maybe_safe :: { ([AddAnn],Bool) }
: 'safe' { ([mj AnnSafe $1],True) }
| {- empty -} { ([],False) }
-maybe_pkg :: { ([AddAnn],Maybe FastString) }
+maybe_pkg :: { ([AddAnn],Maybe (SourceText,FastString)) }
: STRING {% let pkgFS = getSTRING $1 in
if looksLikePackageName (unpackFS pkgFS)
- then return ([mj AnnPackageName $1], Just pkgFS)
+ then return ([mj AnnPackageName $1], Just (getSTRINGs $1,pkgFS))
else parseErrorSDoc (getLoc $1) $ vcat [
text "parse error" <> colon <+> quotes (ppr pkgFS),
text "Version number or non-alphanumeric" <+>
@@ -1119,12 +1119,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 }
@@ -1378,7 +1378,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))
@@ -1444,15 +1444,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
@@ -1500,12 +1500,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
@@ -2191,7 +2191,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
@@ -2232,16 +2232,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
@@ -2249,7 +2249,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 d3d3b7af90..98fa8f7608 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -1472,21 +1472,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))
@@ -1515,7 +1515,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
@@ -1544,7 +1544,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
@@ -1555,13 +1556,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 e7f882b86e..657660a735 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.
@@ -194,7 +198,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)
@@ -205,7 +209,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
@@ -218,11 +222,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
--
@@ -233,11 +238,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
@@ -270,13 +275,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
@@ -290,8 +297,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
@@ -300,10 +308,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
@@ -336,6 +345,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 34c1838997..5ab8654f06 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -589,8 +589,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
@@ -602,8 +602,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
@@ -612,8 +612,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
@@ -622,8 +622,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
@@ -632,8 +632,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
@@ -693,7 +693,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 0aa33add9e..7ed96711b0 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -215,8 +215,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))
@@ -229,7 +229,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
@@ -1596,7 +1596,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 d7c135eaba..3b745af25d 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -431,8 +431,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
{-
*********************************************************
@@ -727,10 +728,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 d76f256900..dc70851205 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 4e426453a7..45b6479676 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 084e5dea5a..3ac160ec3d 100644
--- a/compiler/typecheck/TcRules.hs
+++ b/compiler/typecheck/TcRules.hs
@@ -56,7 +56,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]
@@ -76,7 +76,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
@@ -97,7 +97,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
@@ -114,7 +114,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
, ic_wanted = rhs_wanted
, ic_status = IC_Unsolved
, 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
@@ -128,7 +128,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
, ic_wanted = other_lhs_wanted
, ic_status = IC_Unsolved
, ic_binds = lhs_binds_var
- , ic_info = RuleSkol (unLoc name)
+ , ic_info = RuleSkol (snd $ unLoc name)
, ic_env = lcl_env }
; return (HsRule name act
View Lorry Controller Status