Commit 1b7dfd7f authored by Ian Lynagh's avatar Ian Lynagh

Small refactoring: Use (Maybe Header) rather than FastString

parent 5d7fd293
......@@ -127,8 +127,8 @@ dsFImport :: Id
-> Coercion
-> ForeignImport
-> DsM ([Binding], SDoc, SDoc)
dsFImport id co (CImport cconv safety header spec) = do
(ids, h, c) <- dsCImport id co spec cconv safety header
dsFImport id co (CImport cconv safety mHeader spec) = do
(ids, h, c) <- dsCImport id co spec cconv safety mHeader
return (ids, h, c)
dsCImport :: Id
......@@ -136,7 +136,7 @@ dsCImport :: Id
-> CImportSpec
-> CCallConv
-> Safety
-> FastString -- header
-> Maybe Header
-> DsM ([Binding], SDoc, SDoc)
dsCImport id co (CLabel cid) cconv _ _ = do
let ty = pFst $ coercionKind co
......@@ -156,8 +156,8 @@ dsCImport id co (CLabel cid) cconv _ _ = do
dsCImport id co (CFunction target) cconv@PrimCallConv safety _
= dsPrimCall id co (CCall (CCallSpec target cconv safety))
dsCImport id co (CFunction target) cconv safety header
= dsFCall id co (CCall (CCallSpec target cconv safety)) header
dsCImport id co (CFunction target) cconv safety mHeader
= dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader
dsCImport id co CWrapper cconv _ _
= dsFExportDynamic id co cconv
......@@ -184,9 +184,9 @@ fun_type_arg_stdcall_info _other_conv _
%************************************************************************
\begin{code}
dsFCall :: Id -> Coercion -> ForeignCall -> FastString
dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
-> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
dsFCall fn_id co fcall headerFilename = do
dsFCall fn_id co fcall mDeclHeader = do
let
ty = pFst $ coercionKind co
(tvs, fun_ty) = tcSplitForAllTys ty
......@@ -217,7 +217,7 @@ dsFCall fn_id co fcall headerFilename = do
c = includes
$$ fun_proto <+> braces (cRet <> semi)
includes = vcat [ text "#include <" <> ftext h <> text ">"
| h <- nub headers ]
| Header h <- nub headers ]
fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
cRet
| isVoidRes = cCall
......@@ -239,10 +239,8 @@ dsFCall fn_id co fcall headerFilename = do
argTypes = if null argTypeList
then text "void"
else hsep $ punctuate comma argTypeList
mHeaders' = mHeader : mHeaders
headers = if nullFS headerFilename
then catMaybes mHeaders'
else headerFilename : catMaybes mHeaders'
mHeaders' = mDeclHeader : mHeader : mHeaders
headers = catMaybes mHeaders'
argVals = hsep $ punctuate comma
[ char 'a' <> int n
| (_, n) <- zip arg_tys [1..] ]
......@@ -676,7 +674,7 @@ showStgType t = text "Hs" <> text (showFFIType t)
showFFIType :: Type -> String
showFFIType t = getOccString (getName (typeTyCon t))
toCType :: Type -> (Maybe FastString, SDoc)
toCType :: Type -> (Maybe Header, SDoc)
toCType = f False
where f voidOK t
-- First, if we have (Ptr t) of (FunPtr t), then we need to
......
......@@ -338,15 +338,13 @@ repInstD (L loc (ClsInstDecl ty binds _ ats)) -- Ignore user pragmas for now
Just (tvs, cxt, cls, tys) = splitHsInstDeclTy_maybe (unLoc ty)
repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
repForD (L loc (ForeignImport name typ _ (CImport cc s ch cis)))
repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis)))
= do MkC name' <- lookupLOcc name
MkC typ' <- repLTy typ
MkC cc' <- repCCallConv cc
MkC s' <- repSafety s
cis' <- conv_cimportspec cis
MkC str <- coreStringLit $ static
++ unpackFS ch ++ " "
++ cis'
MkC str <- coreStringLit (static ++ chStr ++ cis')
dec <- rep2 forImpDName [cc', s', str, name', typ']
return (loc, dec)
where
......@@ -357,6 +355,9 @@ repForD (L loc (ForeignImport name typ _ (CImport cc s ch cis)))
static = case cis of
CFunction (StaticTarget _ _) -> "static "
_ -> ""
chStr = case mch of
Nothing -> ""
Just (Header h) -> unpackFS h ++ " "
repForD decl = notHandled "Foreign declaration" (ppr decl)
repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
......
......@@ -985,7 +985,7 @@ data ForeignImport = -- import of a C entity
--
CImport CCallConv -- ccall or stdcall
Safety -- interruptible, safe or unsafe
FastString -- name of C header
(Maybe Header) -- name of C header
CImportSpec -- details of the C entity
deriving (Data, Typeable)
......@@ -1015,11 +1015,13 @@ instance OutputableBndr name => Outputable (ForeignDecl name) where
2 (dcolon <+> ppr ty)
instance Outputable ForeignImport where
ppr (CImport cconv safety header spec) =
ppr (CImport cconv safety mHeader spec) =
ppr cconv <+> ppr safety <+>
char '"' <> pprCEntity spec <> char '"'
where
pp_hdr = if nullFS header then empty else ftext header
pp_hdr = case mHeader of
Nothing -> empty
Just (Header header) -> ftext header
pprCEntity (CLabel lbl) =
ptext (sLit "static") <+> pp_hdr <+> char '&' <> ppr lbl
......
......@@ -741,8 +741,8 @@ tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) }
| type { L1 (Nothing, $1) }
capi_ctype :: { Maybe CType }
capi_ctype : '{-# CTYPE' STRING STRING '#-}' { Just (CType (Just (getSTRING $2)) (getSTRING $3)) }
| '{-# CTYPE' STRING '#-}' { Just (CType Nothing (getSTRING $2)) }
capi_ctype : '{-# CTYPE' STRING STRING '#-}' { Just (CType (Just (Header (getSTRING $2))) (getSTRING $3)) }
| '{-# CTYPE' STRING '#-}' { Just (CType Nothing (getSTRING $2)) }
| { Nothing }
-----------------------------------------------------------------------------
......
......@@ -916,7 +916,7 @@ mkImport :: CCallConv
mkImport cconv safety (L loc entity, v, ty)
| cconv == PrimCallConv = do
let funcTarget = CFunction (StaticTarget entity Nothing)
importSpec = CImport PrimCallConv safety nilFS funcTarget
importSpec = CImport PrimCallConv safety Nothing funcTarget
return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
| otherwise = do
......@@ -936,11 +936,11 @@ parseCImport cconv safety nm str =
parse = do
skipSpaces
r <- choice [
string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)),
string "wrapper" >> return (mk nilFS CWrapper),
string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)),
string "wrapper" >> return (mk Nothing CWrapper),
optional (string "static" >> skipSpaces) >>
(mk nilFS <$> cimp nm) +++
(do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm)
(mk Nothing <$> cimp nm) +++
(do h <- munch1 hdr_char; skipSpaces; mk (Just (Header (mkFastString h))) <$> cimp nm)
]
skipSpaces
return r
......
......@@ -15,7 +15,7 @@ module ForeignCall (
CCallTarget(..), isDynamicTarget,
CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
CType(..),
Header(..), CType(..),
) where
import FastString
......@@ -230,9 +230,13 @@ instance Outputable CCallSpec where
\end{code}
\begin{code}
-- The filename for a C header file
newtype Header = Header FastString
deriving (Eq, Data, Typeable)
-- | A C type, used in CAPI FFI calls
data CType = CType (Maybe FastString) -- header to include for this type
FastString -- the type itself
data CType = CType (Maybe Header) -- header to include for this type
FastString -- the type itself
deriving (Data, Typeable)
\end{code}
......@@ -324,4 +328,9 @@ instance Binary CType where
get bh = do mh <- get bh
fs <- get bh
return (CType mh fs)
instance Binary Header where
put_ bh (Header h) = put_ bh h
get bh = do h <- get bh
return (Header h)
\end{code}
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment