Small refactoring: Use (Maybe Header) rather than FastString

6 files changed, 40 insertions, 30 deletions

diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index a24e8a29d6..46c4a54a5c 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -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
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 4105a9e56c..181a25eb4d 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -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)
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index e9403104e6..142d53f378 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -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
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index bb370978c4..62fdeddf28 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -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 }
 
 -----------------------------------------------------------------------------
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 56c643d190..890c3794d1 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -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
diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs
index 3fd0a183e5..0a8db5c5a5 100644
--- a/compiler/prelude/ForeignCall.lhs
+++ b/compiler/prelude/ForeignCall.lhs
@@ -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}