Rewrite the foreign import string parser using ReadP

And kill the duplicate one in HsSyn.Convert

2 files changed, 50 insertions, 120 deletions

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 9928420045..c443fcf7de 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -22,7 +22,6 @@ import Type
 import TysWiredIn
 import BasicTypes as Hs
 import ForeignCall
-import Char
 import List
 import Unique
 import MonadUtils
@@ -325,15 +324,15 @@ noExistentials = []
 
 cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
 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 cis
-	; return $ ForeignImport nm' ty' i }
-
+  | Just impspec <- parseCImport (cvt_conv callconv) safety' 
+                                 (mkFastString (TH.nameBase nm)) from
+  = do { nm' <- vNameL nm
+       ; ty' <- cvtType ty
+       ; return (ForeignImport nm' ty' impspec)
+       }
   | otherwise
-  = failWith $ text (show from)<+> ptext (sLit "is not a valid ccall impent")
-  where 
+  = failWith $ text (show from) <+> ptext (sLit "is not a valid ccall impent")
+  where
     safety' = case safety of
                      Unsafe     -> PlayRisky
                      Safe       -> PlaySafe False
@@ -349,61 +348,6 @@ cvt_conv :: TH.Callconv -> CCallConv
 cvt_conv TH.CCall   = CCallConv
 cvt_conv TH.StdCall = StdCallConv
 
-parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec)
-parse_ccall_impent nm s
- = case lex_ccall_impent s of
-       Just ["dynamic"] -> Just (nilFS, CFunction DynamicTarget)
-       Just ["wrapper"] -> Just (nilFS, CWrapper)
-       Just ("static":ts) -> parse_ccall_impent_static nm ts
-       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
- = 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 == '_')
-
-          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
-lex_ccall_impent (' ':xs) = lex_ccall_impent xs
-lex_ccall_impent ('\t':xs) = lex_ccall_impent xs
-lex_ccall_impent xs = case span is_valid xs of
-                          ("", _) -> Nothing
-                          (t, xs') -> fmap (t:) $ lex_ccall_impent xs'
-    where is_valid :: Char -> Bool
-          is_valid c = isAscii c && (isAlphaNum c || c `elem` "._")
-
 ------------------------------------------
 --              Pragmas
 ------------------------------------------
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index a914bbaa59..9d7f80c17d 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -25,6 +25,7 @@ module RdrHsSyn (
 	mkImport,            -- CallConv -> Safety 
 			      -- -> (FastString, RdrName, RdrNameHsType)
 			      -- -> P RdrNameHsDecl
+        parseCImport,
 	mkExport,            -- CallConv
 			      -- -> (FastString, RdrName, RdrNameHsType)
 			      -- -> P RdrNameHsDecl
@@ -32,7 +33,7 @@ module RdrHsSyn (
 	mkGadtDecl,          -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
 	mkSimpleConDecl, 
 	mkDeprecatedGadtRecordDecl,
-			      
+
 	-- Bunch of functions in the parser monad for 
 	-- checking and constructing values
 	checkPrecP, 	      -- Int -> P Int
@@ -74,8 +75,12 @@ import OrdList		( OrdList, fromOL )
 import Bag		( Bag, emptyBag, snocBag, consBag, foldrBag )
 import Outputable
 import FastString
+import Maybes
 
-import List		( isSuffixOf, nubBy )
+import Control.Applicative ((<$>))       
+import Text.ParserCombinators.ReadP as ReadP
+import Data.List        ( nubBy )
+import Data.Char        ( isAscii, isAlphaNum, isAlpha )
 
 #include "HsVersions.h"
 \end{code}
@@ -975,68 +980,49 @@ mkImport :: CallConv
 	 -> Safety 
 	 -> (Located FastString, Located RdrName, LHsType RdrName) 
 	 -> P (HsDecl RdrName)
-mkImport (CCall  cconv) safety (entity, v, ty)
+mkImport (CCall  cconv) safety (L loc entity, v, ty)
   | cconv == PrimCallConv                      = do
-  let funcTarget = CFunction (StaticTarget (unLoc entity))
+  let funcTarget = CFunction (StaticTarget entity)
       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))
+    case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
+      Nothing         -> parseError loc "Malformed entity string"
+      Just importSpec -> return (ForD (ForeignImport v ty importSpec))
 mkImport (DNCall      ) _      (entity, v, ty) = do
   spec <- parseDImport entity
   return $ ForD (ForeignImport v ty (DNImport spec))
 
--- parse the entity string of a foreign import declaration for the `ccall' or
--- `stdcall' calling convention'
---
-parseCImport :: Located FastString
-	     -> CCallConv 
-	     -> Safety 
-	     -> Located RdrName
-	     -> P ForeignImport
-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 (CFunction DynamicTarget)
-  | entity == fsLit "wrapper" =
-    return $ CImport cconv safety nilFS CWrapper
-  | otherwise		       = parse0 (unpackFS entity)
-    where
-      -- using the static keyword?
-      parse0 (' ':                    rest) = parse0 rest
-      parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
-      parse0                          rest  = parse1 rest
-      -- check for header file name
-      parse1     ""               = parse4 ""    nilFS        False
-      parse1     (' ':rest)       = parse1 rest
-      parse1 str@('&':_   )       = parse2 str   nilFS
-      parse1 str
-	| ".h" `isSuffixOf` first = parse2 rest  (mkFastString first)
-        | otherwise               = parse4 str   nilFS        False
-        where
-	  (first, rest) = break (\c -> c == ' ' || c == '&') str
-      -- check for address operator (indicating a label import)
-      parse2     ""         header = parse4 ""   header False
-      parse2     (' ':rest) header = parse2 rest header
-      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 = 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 = return $
-        CImport cconv safety header (CFunction (StaticTarget cid))
-      build cid header True  = return $
-        CImport cconv safety header (CLabel                  cid )
+-- the string "foo" is ambigous: either a header or a C identifier.  The
+-- C identifier case comes first in the alternatives below, so we pick
+-- that one.
+parseCImport :: CCallConv -> Safety -> FastString -> String
+             -> Maybe ForeignImport
+parseCImport cconv safety nm str =
+ listToMaybe $ map fst $ filter (null.snd) $ 
+     readP_to_S parse str
+ where
+   parse = choice [
+          string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)),
+          string "wrapper" >> return (mk nilFS CWrapper),
+          optional (string "static" >> skipSpaces) >> 
+           (mk nilFS <$> cimp nm) +++
+           (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm)
+       ]
+
+   mk = CImport cconv safety
+
+   hdr_char c = isAscii c && (isAlphaNum c || c `elem` "._")
+   id_char  c = isAlphaNum c || c == '_'
+
+   cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
+             +++ ((CFunction . StaticTarget) <$> cid)
+          where 
+            cid = return nm +++
+                  (do c  <- satisfy (\c -> isAlpha c || c == '_')
+                      cs <-  many (satisfy id_char)
+                      return (mkFastString (c:cs)))
+
 
 --
 -- Unravel a dotnet spec string.