From 6c7393261e723af3651f47bcee9af8db6bb6cf17 Mon Sep 17 00:00:00 2001
From: Sylvain HENRY <hsyl20@gmail.com>
Date: Fri, 14 Oct 2016 10:43:30 -0400
Subject: [PATCH] Check for empty entity string in "prim" foreign imports

Foreign imports with "prim" convention require a valid symbol identifier
(see linked issue). We check this.

Fix line too long

Test Plan: Validate

Reviewers: austin, bgamari

Reviewed By: bgamari

Subscribers: thomie

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

GHC Trac Issues: #12355
---
 compiler/parser/RdrHsSyn.hs                   | 58 ++++++++++++-------
 testsuite/tests/codeGen/should_compile/all.T  |  2 +-
 testsuite/tests/ffi/should_fail/T10461.stderr |  2 +-
 3 files changed, 38 insertions(+), 24 deletions(-)

diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 4fc1c9c274..3c1792b29c 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -1301,28 +1301,42 @@ mkImport :: Located CCallConv
          -> Located Safety
          -> (Located StringLiteral, Located RdrName, LHsSigType RdrName)
          -> P (HsDecl RdrName)
-mkImport (L lc cconv) (L ls safety) (L loc (StringLiteral esrc entity), v, ty)
-  | cconv == PrimCallConv                      = do
-  let funcTarget = CFunction (StaticTarget esrc entity Nothing True)
-      importSpec = CImport (L lc PrimCallConv) (L ls safety) Nothing funcTarget
-                           (L loc esrc)
-  return (ForD (ForeignImport { fd_name = v, fd_sig_ty = ty
-                              , fd_co = noForeignImportCoercionYet
-                              , fd_fi = importSpec }))
-  | cconv == JavaScriptCallConv = do
-  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 { fd_name = v, fd_sig_ty = ty
-                              , fd_co = noForeignImportCoercionYet
-                              , fd_fi = importSpec }))
-  | otherwise = do
-    case parseCImport (L lc cconv) (L ls safety) (mkExtName (unLoc v))
-                      (unpackFS entity) (L loc (unpackFS entity)) of
-      Nothing         -> parseErrorSDoc loc (text "Malformed entity string")
-      Just importSpec -> return (ForD (ForeignImport { fd_name = v, fd_sig_ty = ty
-                                                     , fd_co = noForeignImportCoercionYet
-                                                     , fd_fi = importSpec }))
+mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =
+    case cconv of
+      L _ CCallConv          -> mkCImport
+      L _ CApiConv           -> mkCImport
+      L _ StdCallConv        -> mkCImport
+      L _ PrimCallConv       -> mkOtherImport
+      L _ JavaScriptCallConv -> mkOtherImport
+  where
+    -- Parse a C-like entity string of the following form:
+    --   "[static] [chname] [&] [cid]" | "dynamic" | "wrapper"
+    -- If 'cid' is missing, the function name 'v' is used instead as symbol
+    -- name (cf section 8.5.1 in Haskell 2010 report).
+    mkCImport = do
+      let e = unpackFS entity
+      case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc e) of
+        Nothing         -> parseErrorSDoc loc (text "Malformed entity string")
+        Just importSpec -> returnSpec importSpec
+
+    -- currently, all the other import conventions only support a symbol name in
+    -- the entity string. If it is missing, we use the function name instead.
+    mkOtherImport = returnSpec importSpec
+      where
+        entity'    = if nullFS entity
+                        then mkExtName (unLoc v)
+                        else entity
+        funcTarget = CFunction (StaticTarget esrc entity' Nothing True)
+        importSpec = CImport cconv safety Nothing funcTarget (L loc esrc)
+
+    returnSpec spec = return $ ForD $ ForeignImport
+          { fd_name   = v
+          , fd_sig_ty = ty
+          , fd_co     = noForeignImportCoercionYet
+          , fd_fi     = spec
+          }
+
+
 
 -- the string "foo" is ambiguous: either a header or a C identifier.  The
 -- C identifier case comes first in the alternatives below, so we pick
diff --git a/testsuite/tests/codeGen/should_compile/all.T b/testsuite/tests/codeGen/should_compile/all.T
index dad755e288..e3fad1895d 100644
--- a/testsuite/tests/codeGen/should_compile/all.T
+++ b/testsuite/tests/codeGen/should_compile/all.T
@@ -37,4 +37,4 @@ test('T10667', [ when((arch('powerpc64') or arch('powerpc64le')),
                       expect_broken(11261))],
      compile, ['-g'])
 test('T12115', normal, compile, [''])
-test('T12355', when(not opsys('darwin'), expect_broken(12355)), compile, [''])
+test('T12355', normal, compile, [''])
diff --git a/testsuite/tests/ffi/should_fail/T10461.stderr b/testsuite/tests/ffi/should_fail/T10461.stderr
index 7962582fe2..fae0f50b14 100644
--- a/testsuite/tests/ffi/should_fail/T10461.stderr
+++ b/testsuite/tests/ffi/should_fail/T10461.stderr
@@ -4,4 +4,4 @@ T10461.hs:6:1: error:
       ‘Word#’ cannot be marshalled in a foreign call
       To marshal unlifted types, use UnliftedFFITypes
     When checking declaration:
-      foreign import prim safe "static " cheneycopy :: Any -> Word#
+      foreign import prim safe "static cheneycopy" cheneycopy :: Any -> Word#
-- 
GitLab