Rewrite the foreign import string parser using ReadP

And kill the duplicate one in HsSyn.Convert

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 9928420..c443fcf 100644 (file)
--- 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 TysWiredIn
 import BasicTypes as Hs
 import ForeignCall

-import Char

 import List
 import Unique
 import MonadUtils
 import List
 import Unique
 import MonadUtils

@@ -325,15 +324,15 @@ noExistentials = []
 
 cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
 cvtForD (ImportF callconv safety from nm ty)
 
 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
   | 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
     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
 
 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
 ------------------------------------------
 ------------------------------------------
 --              Pragmas
 ------------------------------------------

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index a914bba..9d7f80c 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -25,6 +25,7 @@ module RdrHsSyn (
        mkImport,            -- CallConv -> Safety 
                              -- -> (FastString, RdrName, RdrNameHsType)
                              -- -> P RdrNameHsDecl
        mkImport,            -- CallConv -> Safety 
                              -- -> (FastString, RdrName, RdrNameHsType)
                              -- -> P RdrNameHsDecl

+        parseCImport,

        mkExport,            -- CallConv
                              -- -> (FastString, RdrName, RdrNameHsType)
                              -- -> P RdrNameHsDecl
        mkExport,            -- CallConv
                              -- -> (FastString, RdrName, RdrNameHsType)
                              -- -> P RdrNameHsDecl

@@ -32,7 +33,7 @@ module RdrHsSyn (
        mkGadtDecl,          -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
        mkSimpleConDecl, 
        mkDeprecatedGadtRecordDecl,
        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
        -- 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 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}
 
 #include "HsVersions.h"
 \end{code}

@@ -975,68 +980,49 @@ mkImport :: CallConv
         -> Safety 
         -> (Located FastString, Located RdrName, LHsType RdrName) 
         -> P (HsDecl RdrName)
         -> 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
   | 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 = 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))
 
 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.
 
 --
 -- Unravel a dotnet spec string.