Allow a header to be specified in a CTYPE pragma

You can now say
    data {-# CTYPE "some_header.h" "the C type" #-} Foo = ...

I think it's rare that this will actually be needed. If the
header for a CAPI FFI import includes a
    void f(ctype x);
prototype then ctype must already be defined.

However, if the header only has
    #define f(p) p->j
then the type need not be defined.

But either way, it seems good practice for us to specify the header that
we need.

4 files changed, 46 insertions, 30 deletions

diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 55b2b234e3..a24e8a29d6 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -214,11 +214,10 @@ dsFCall fn_id co fcall headerFilename = do
                                     mkFastString "_" `appendFS`
                                     cName
                       fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId) CApiConv safety)
-                      c = include
+                      c = includes
                        $$ fun_proto <+> braces (cRet <> semi)
-                      include
-                       | nullFS headerFilename = empty
-                       | otherwise = text "#include <" <> ftext headerFilename <> text ">"
+                      includes = vcat [ text "#include <" <> ftext h <> text ">"
+                                      | h <- nub headers ]
                       fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
                       cRet
                        | isVoidRes =                   cCall
@@ -228,14 +227,22 @@ dsFCall fn_id co fcall headerFilename = do
                                    Just (_ioTyCon, res_ty) -> res_ty
                                    Nothing                 -> io_res_ty
                       isVoidRes = raw_res_ty `eqType` unitTy
-                      cResType | isVoidRes = text "void"
-                               | otherwise = toCType raw_res_ty
+                      (mHeader, cResType)
+                       | isVoidRes = (Nothing, text "void")
+                       | otherwise = toCType raw_res_ty
                       pprCconv = ccallConvAttribute CApiConv
-                      argTypes
-                       | null arg_tys = text "void"
-                       | otherwise = hsep $ punctuate comma
-                                         [ toCType t <+> char 'a' <> int n
-                                         | (t, n) <- zip arg_tys [1..] ]
+                      mHeadersArgTypeList
+                          = [ (header, cType <+> char 'a' <> int n)
+                            | (t, n) <- zip arg_tys [1..]
+                            , let (header, cType) = toCType t ]
+                      (mHeaders, argTypeList) = unzip mHeadersArgTypeList
+                      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'
                       argVals = hsep $ punctuate comma
                                     [ char 'a' <> int n
                                     | (_, n) <- zip arg_tys [1..] ]
@@ -498,7 +505,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
                 SDoc,           -- C type
                 Type,           -- Haskell type
                 CmmType)]       -- the CmmType
-  arg_info  = [ let stg_type = toCType ty in
+  arg_info  = [ let stg_type = showStgType ty in
                 (arg_cname n stg_type,
                  stg_type,
                  ty,
@@ -535,7 +542,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
   res_hty_is_unit = res_hty `eqType` unitTy     -- Look through any newtypes
 
   cResType | res_hty_is_unit = text "void"
-           | otherwise       = toCType res_hty
+           | otherwise       = showStgType res_hty
 
   -- when the return type is integral and word-sized or smaller, it
   -- must be assigned as type ffi_arg (#3516).  To see what type
@@ -663,10 +670,13 @@ mkHObj t = text "rts_mk" <> text (showFFIType t)
 unpackHObj :: Type -> SDoc
 unpackHObj t = text "rts_get" <> text (showFFIType t)
 
+showStgType :: Type -> SDoc
+showStgType t = text "Hs" <> text (showFFIType t)
+
 showFFIType :: Type -> String
 showFFIType t = getOccString (getName (typeTyCon t))
 
-toCType :: Type -> SDoc
+toCType :: Type -> (Maybe FastString, SDoc)
 toCType = f False
     where f voidOK t
            -- First, if we have (Ptr t) of (FunPtr t), then we need to
@@ -674,21 +684,23 @@ toCType = f False
            -- know a type for t, then "void" is fine, though.
            | Just (ptr, [t']) <- splitTyConApp_maybe t
            , tyConName ptr `elem` [ptrTyConName, funPtrTyConName]
-              = f True t' <> char '*'
+              = case f True t' of
+                (mh, cType') ->
+                    (mh, cType' <> char '*')
            -- Otherwise, if we have a type constructor application, then
            -- see if there is a C type associated with that constructor.
            -- 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 cType) <- tyConCType_maybe tycon
-              = ftext cType
+           , 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.
            | Just t' <- coreView t
               = f voidOK t'
            -- Otherwise we don't know the C type. If we are allowing
            -- void then return that; otherwise something has gone wrong.
-           | voidOK = ptext (sLit "void")
+           | voidOK = (Nothing, ptext (sLit "void"))
            | otherwise
               = pprPanic "toCType" (ppr t)
 
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index f29364a872..bb370978c4 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -741,8 +741,9 @@ tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) }
         | type                          { L1 (Nothing, $1) }
 
 capi_ctype :: { Maybe CType }
-capi_ctype : '{-# CTYPE' STRING '#-}'      { Just (CType (getSTRING $2)) }
-           |                               { Nothing }
+capi_ctype : '{-# CTYPE' STRING STRING '#-}' { Just (CType (Just (getSTRING $2)) (getSTRING $3)) }
+           | '{-# CTYPE'        STRING '#-}' { Just (CType Nothing               (getSTRING $2)) }
+           |                                 { Nothing }
 
 -----------------------------------------------------------------------------
 -- Stand-alone deriving
diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs
index f99f134aab..3fd0a183e5 100644
--- a/compiler/prelude/ForeignCall.lhs
+++ b/compiler/prelude/ForeignCall.lhs
@@ -231,7 +231,8 @@ instance Outputable CCallSpec where
 
 \begin{code}
 -- | A C type, used in CAPI FFI calls
-newtype CType = CType FastString
+data CType = CType (Maybe FastString) -- header to include for this type
+                   FastString         -- the type itself
     deriving (Data, Typeable)
 \end{code}
 
@@ -318,7 +319,9 @@ instance Binary CCallConv where
               _ -> do return CApiConv
 
 instance Binary CType where
-    put_ bh (CType fs) = put_ bh fs
-    get bh = do fs <- get bh
-                return (CType fs)
+    put_ bh (CType mh fs) = do put_ bh mh
+                               put_ bh fs
+    get bh = do mh <- get bh
+                fs <- get bh
+                return (CType mh fs)
 \end{code}
diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index d7cfc58765..7d4edfd40d 100644
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -460,7 +460,7 @@ charTy :: Type
 charTy = mkTyConTy charTyCon
 
 charTyCon :: TyCon
-charTyCon   = pcNonRecDataTyCon charTyConName (Just (CType (fsLit "HsChar")))
+charTyCon   = pcNonRecDataTyCon charTyConName (Just (CType Nothing (fsLit "HsChar")))
                                 [] [charDataCon]
 charDataCon :: DataCon
 charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon
@@ -496,7 +496,7 @@ intTy :: Type
 intTy = mkTyConTy intTyCon 
 
 intTyCon :: TyCon
-intTyCon = pcNonRecDataTyCon intTyConName (Just (CType (fsLit "HsInt"))) [] [intDataCon]
+intTyCon = pcNonRecDataTyCon intTyConName (Just (CType Nothing (fsLit "HsInt"))) [] [intDataCon]
 intDataCon :: DataCon
 intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon
 \end{code}
@@ -506,7 +506,7 @@ wordTy :: Type
 wordTy = mkTyConTy wordTyCon 
 
 wordTyCon :: TyCon
-wordTyCon = pcNonRecDataTyCon wordTyConName (Just (CType (fsLit "HsWord"))) [] [wordDataCon]
+wordTyCon = pcNonRecDataTyCon wordTyConName (Just (CType Nothing (fsLit "HsWord"))) [] [wordDataCon]
 wordDataCon :: DataCon
 wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon
 \end{code}
@@ -516,7 +516,7 @@ floatTy :: Type
 floatTy	= mkTyConTy floatTyCon
 
 floatTyCon :: TyCon
-floatTyCon   = pcNonRecDataTyCon floatTyConName   (Just (CType (fsLit "HsFloat"))) [] [floatDataCon]
+floatTyCon   = pcNonRecDataTyCon floatTyConName   (Just (CType Nothing (fsLit "HsFloat"))) [] [floatDataCon]
 floatDataCon :: DataCon
 floatDataCon = pcDataCon         floatDataConName [] [floatPrimTy] floatTyCon
 \end{code}
@@ -526,7 +526,7 @@ doubleTy :: Type
 doubleTy = mkTyConTy doubleTyCon
 
 doubleTyCon :: TyCon
-doubleTyCon = pcNonRecDataTyCon doubleTyConName (Just (CType (fsLit "HsDouble"))) [] [doubleDataCon]
+doubleTyCon = pcNonRecDataTyCon doubleTyConName (Just (CType Nothing (fsLit "HsDouble"))) [] [doubleDataCon]
 
 doubleDataCon :: DataCon
 doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon
@@ -587,7 +587,7 @@ boolTy = mkTyConTy boolTyCon
 
 boolTyCon :: TyCon
 boolTyCon = pcTyCon True NonRecursive boolTyConName
-                    (Just (CType (fsLit "HsBool")))
+                    (Just (CType Nothing (fsLit "HsBool")))
                     [] [falseDataCon, trueDataCon]
 
 falseDataCon, trueDataCon :: DataCon