Fix #3319, and do various tidyups at the same time

 - converting a THSyn FFI declaration to HsDecl was broken; fixed
 - pretty-printing of FFI declarations was variously bogus; fixed
 - there was an unused "library" field in CImport; removed

6 files changed, 68 insertions, 64 deletions

diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 9dea2ade73..9127676cf2 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -124,7 +124,7 @@ because it exposes the boxing to the call site.
 dsFImport :: Id
 	  -> ForeignImport
 	  -> DsM ([Binding], SDoc, SDoc)
-dsFImport id (CImport cconv safety _ _ spec) = do
+dsFImport id (CImport cconv safety _ spec) = do
     (ids, h, c) <- dsCImport id spec cconv safety
     return (ids, h, c)
 
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 2b982b3b0c..2de2cae080 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -333,7 +333,7 @@ repInstD' (L loc (InstDecl ty binds _ ats))	-- Ignore user pragmas for now
    (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
 
 repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
-repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis)))
+repForD (L loc (ForeignImport name typ (CImport cc s ch cis)))
  = do MkC name' <- lookupLOcc name
       MkC typ' <- repLTy typ
       MkC cc' <- repCCallConv cc
@@ -341,7 +341,6 @@ repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis)))
       cis' <- conv_cimportspec cis
       MkC str <- coreStringLit $ static
                               ++ unpackFS ch ++ " "
-                              ++ unpackFS cn ++ " "
                               ++ cis'
       dec <- rep2 forImpDName [cc', s', str, name', typ']
       return (loc, dec)
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index b4d897dfb7..31a0bca2c8 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -319,7 +319,7 @@ cvtForD (ImportF callconv safety from nm ty)
   | Just (c_header, cis) <- parse_ccall_impent (TH.nameBase nm) from
   = do	{ nm' <- vNameL nm
 	; ty' <- cvtType ty
-	; let i = CImport (cvt_conv callconv) safety' c_header nilFS cis
+	; let i = CImport (cvt_conv callconv) safety' c_header cis
 	; return $ ForeignImport nm' ty' i }
 
   | otherwise
@@ -349,26 +349,41 @@ parse_ccall_impent nm s
        Just ts -> parse_ccall_impent_static nm ts
        Nothing -> Nothing
 
+-- XXX we should be sharing code with RdrHsSyn.parseCImport
 parse_ccall_impent_static :: String
                           -> [String]
                           -> Maybe (FastString, CImportSpec)
 parse_ccall_impent_static nm ts
- = let ts' = case ts of
-                 [       "&", cid] -> [       cid]
-                 [fname, "&"     ] -> [fname     ]
-                 [fname, "&", cid] -> [fname, cid]
-                 _                 -> ts
-   in case ts' of
-          [       cid] | is_cid cid -> Just (nilFS,              mk_cid cid)
-          [fname, cid] | is_cid cid -> Just (mkFastString fname, mk_cid cid)
-          [          ]              -> Just (nilFS,              mk_cid nm)
-          [fname     ]              -> Just (mkFastString fname, mk_cid nm)
-          _                         -> Nothing
+ = case ts of
+     [               ] -> mkFun nilFS                 nm
+     [       "&", cid] -> mkLbl nilFS                 cid
+     [fname, "&"     ] -> mkLbl (mkFastString fname)  nm
+     [fname, "&", cid] -> mkLbl (mkFastString fname)  cid
+     [       "&"     ] -> mkLbl nilFS                 nm
+     [fname,      cid] -> mkFun (mkFastString fname)  cid
+     [            cid]
+          | is_cid cid -> mkFun nilFS                 cid
+          | otherwise  -> mkFun (mkFastString cid)    nm
+           -- tricky case when there's a single string: "foo.h" is a header,
+           -- but "foo" is a C identifier, and we tell the difference by
+           -- checking for a valid C identifier (see is_cid below).
+     _anything_else    -> Nothing
+
     where is_cid :: String -> Bool
           is_cid x = all (/= '.') x && (isAlpha (head x) || head x == '_')
-          mk_cid :: String -> CImportSpec
-          mk_cid  = CFunction . StaticTarget . mkFastString
 
+          mkLbl :: FastString -> String -> Maybe (FastString, CImportSpec)
+          mkLbl fname lbl  = Just (fname, CLabel (mkFastString lbl))
+
+          mkFun :: FastString -> String -> Maybe (FastString, CImportSpec)
+          mkFun fname lbl  = Just (fname, CFunction (StaticTarget (mkFastString lbl)))
+
+-- This code is tokenising something like "foo.h &bar", eg.
+--   ""           -> Just []
+--   "foo.h"      -> Just ["foo.h"]
+--   "foo.h &bar" -> Just ["foo.h","&","bar"]
+--   "&"          -> Just ["&"]
+-- Nothing is returned for a parse error.
 lex_ccall_impent :: String -> Maybe [String]
 lex_ccall_impent "" = Just []
 lex_ccall_impent ('&':xs) = fmap ("&":) $ lex_ccall_impent xs
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 832f6165ff..83bd6d59cf 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -904,7 +904,6 @@ data ForeignImport = -- import of a C entity
 		     CImport  CCallConv	      -- ccall or stdcall
 			      Safety	      -- safe or unsafe
 			      FastString      -- name of C header
-			      FastString      -- name of library object
 			      CImportSpec     -- details of the C entity
 
                      -- import of a .NET function
@@ -944,22 +943,19 @@ instance OutputableBndr name => Outputable (ForeignDecl name) where
 instance Outputable ForeignImport where
   ppr (DNImport			        spec) = 
     ptext (sLit "dotnet") <+> ppr spec
-  ppr (CImport  cconv safety header lib spec) =
+  ppr (CImport  cconv safety header spec) =
     ppr cconv <+> ppr safety <+> 
-    char '"' <> pprCEntity header lib spec <> char '"'
+    char '"' <> pprCEntity spec <> char '"'
     where
-      pprCEntity header lib (CLabel lbl) = 
-        ptext (sLit "static") <+> ftext header <+> char '&' <>
-	pprLib lib <> ppr lbl
-      pprCEntity header lib (CFunction (StaticTarget lbl)) = 
-        ptext (sLit "static") <+> ftext header <+> char '&' <>
-	pprLib lib <> ppr lbl
-      pprCEntity _      _   (CFunction (DynamicTarget)) =
+      pp_hdr = if nullFS header then empty else ftext header
+
+      pprCEntity (CLabel lbl) = 
+        ptext (sLit "static") <+> pp_hdr <+> char '&' <> ppr lbl
+      pprCEntity (CFunction (StaticTarget lbl)) = 
+        ptext (sLit "static") <+> pp_hdr <+> ppr lbl
+      pprCEntity (CFunction (DynamicTarget)) =
         ptext (sLit "dynamic")
-      pprCEntity _      _   (CWrapper) = ptext (sLit "wrapper")
-      --
-      pprLib lib | nullFS lib = empty
-		 | otherwise  = char '[' <> ppr lib <> char ']'
+      pprCEntity (CWrapper) = ptext (sLit "wrapper")
 
 instance Outputable ForeignExport where
   ppr (CExport  (CExportStatic lbl cconv)) = 
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index c1c5972b6f..bd8299b9bb 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -960,11 +960,11 @@ mkImport :: CallConv
 mkImport (CCall  cconv) safety (entity, v, ty)
   | cconv == PrimCallConv                      = do
   let funcTarget = CFunction (StaticTarget (unLoc entity))
-      importSpec = CImport PrimCallConv safety nilFS nilFS funcTarget
-  return (ForD (ForeignImport v ty importSpec))
-mkImport (CCall  cconv) safety (entity, v, ty) = do
-  importSpec <- parseCImport entity cconv safety v
+      importSpec = CImport PrimCallConv safety nilFS funcTarget
   return (ForD (ForeignImport v ty importSpec))
+  | otherwise = do
+    importSpec <- parseCImport entity cconv safety v
+    return (ForD (ForeignImport v ty importSpec))
 mkImport (DNCall      ) _      (entity, v, ty) = do
   spec <- parseDImport entity
   return $ ForD (ForeignImport v ty (DNImport spec))
@@ -980,9 +980,9 @@ parseCImport :: Located FastString
 parseCImport (L loc entity) cconv safety v
   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
   | entity == fsLit "dynamic" = 
-    return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
+    return $ CImport cconv safety nilFS (CFunction DynamicTarget)
   | entity == fsLit "wrapper" =
-    return $ CImport cconv safety nilFS nilFS CWrapper
+    return $ CImport cconv safety nilFS CWrapper
   | otherwise		       = parse0 (unpackFS entity)
     where
       -- using the static keyword?
@@ -990,41 +990,35 @@ parseCImport (L loc entity) cconv safety v
       parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
       parse0                          rest  = parse1 rest
       -- check for header file name
-      parse1     ""               = parse4 ""    nilFS        False nilFS
+      parse1     ""               = parse4 ""    nilFS        False
       parse1     (' ':rest)       = parse1 rest
       parse1 str@('&':_   )       = parse2 str   nilFS
-      parse1 str@('[':_   )       = parse3 str   nilFS        False
       parse1 str
 	| ".h" `isSuffixOf` first = parse2 rest  (mkFastString first)
-        | otherwise               = parse4 str   nilFS        False nilFS
+        | otherwise               = parse4 str   nilFS        False
         where
-	  (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
+	  (first, rest) = break (\c -> c == ' ' || c == '&') str
       -- check for address operator (indicating a label import)
-      parse2     ""         header = parse4 ""   header False nilFS
+      parse2     ""         header = parse4 ""   header False
       parse2     (' ':rest) header = parse2 rest header
-      parse2     ('&':rest) header = parse3 rest header True
-      parse2 str@('[':_   ) header = parse3 str	 header False
-      parse2 str	    header = parse4 str	 header False nilFS
-      -- check for library object name
-      parse3 (' ':rest) header isLbl = parse3 rest header isLbl
-      parse3 ('[':rest) header isLbl = 
-        case break (== ']') rest of 
-	  (lib, ']':rest)           -> parse4 rest header isLbl (mkFastString lib)
-	  _			    -> parseError loc "Missing ']' in entity"
-      parse3 str	header isLbl = parse4 str  header isLbl nilFS
+      parse2     ('&':rest) header = parse3 rest header
+      parse2 str	    header = parse4 str	 header False
+      -- eat spaces after '&'
+      parse3 (' ':rest) header = parse3 rest header 
+      parse3 str	header = parse4 str  header True
       -- check for name of C function
-      parse4 ""         header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
-      parse4 (' ':rest) header isLbl lib = parse4 rest         	       header isLbl lib
-      parse4 str	header isLbl lib
-        | all (== ' ') rest              = build (mkFastString first)  header isLbl lib
-	| otherwise			 = parseError loc "Malformed entity string"
+      parse4 ""         header isLbl = build (mkExtName (unLoc v)) header isLbl
+      parse4 (' ':rest) header isLbl = parse4 rest         	   header isLbl
+      parse4 str	header isLbl
+        | all (== ' ') rest = build (mkFastString first)  header isLbl
+	| otherwise         = parseError loc "Malformed entity string"
         where
 	  (first, rest) = break (== ' ') str
       --
-      build cid header False lib = return $
-        CImport cconv safety header lib (CFunction (StaticTarget cid))
-      build cid header True  lib = return $
-        CImport cconv safety header lib (CLabel                  cid )
+      build cid header False = return $
+        CImport cconv safety header (CFunction (StaticTarget cid))
+      build cid header True  = return $
+        CImport cconv safety header (CLabel                  cid )
 
 --
 -- Unravel a dotnet spec string.
diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index 52b1ec61f1..f51000d72a 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -108,7 +108,7 @@ tcCheckFIType _ arg_tys res_ty (DNImport spec) = do
        _ -> return ()
     return (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
 
-tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ _ (CLabel _))
+tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _))
   = ASSERT( null arg_tys )
     do { checkCg checkCOrAsm
        ; checkSafety safety
@@ -116,7 +116,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ _ (CLabel _))
        ; return idecl }	     -- NB check res_ty not sig_ty!
        	 	      	     --    In case sig_ty is (forall a. ForeignPtr a)
 
-tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ CWrapper) = do
+tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do
    	-- Foreign wrapper (former f.e.d.)
    	-- The type must be of the form ft -> IO (FunPtr ft), where ft is a
    	-- valid foreign type.  For legacy reasons ft -> IO (Ptr ft) as well
@@ -135,7 +135,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ CWrapper) =
         _ -> addErrTc (illegalForeignTyErr empty sig_ty)
     return idecl
 
-tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
+tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction target))
   | isDynamicTarget target = do -- Foreign import dynamic
       checkCg checkCOrAsmOrInterp
       checkCConv cconv