From b62f4e789fa4aea34ce6e857d512905054023417 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Thu, 23 Jul 2009 15:21:38 +0000 Subject: [PATCH] Rewrite the foreign import string parser using ReadP And kill the duplicate one in HsSyn.Convert --- compiler/hsSyn/Convert.lhs | 72 ++++--------------------------- compiler/parser/RdrHsSyn.lhs | 98 ++++++++++++++++++------------------------ 2 files changed, 50 insertions(+), 120 deletions(-) diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 9928420..c443fcf 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 a914bba..9d7f80c 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. -- 1.7.10.4