Commit e6191d1c authored by Alan Zimmerman's avatar Alan Zimmerman

ApiAnnotations : strings in warnings do not return SourceText

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

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

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

A warning of the form

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

returns the concatenated warning string rather than the original source.

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

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

Test Plan: ./validate

Reviewers: hvr, austin, goldfire

Reviewed By: austin

Subscribers: bgamari, thomie, mpickering

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

GHC Trac Issues: #10313
parent 7dd0ea74
......@@ -268,14 +268,18 @@ initialVersion = 1
-- 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))
{-
************************************************************************
......
......@@ -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
......
......@@ -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"))
......
......@@ -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)
......
......@@ -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
......
......@@ -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.
......
......@@ -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
......
......@@ -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
......
......@@ -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]
}
......
......@@ -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 "#-}") ]
......
......@@ -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 ]
......
......@@ -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")
......
......@@ -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)
......
......@@ -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 ]
......
......@@ -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
......
......@@ -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
......
......@@ -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
)
......
......@@ -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)
......
......@@ -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