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)
(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
cis' <- conv_cimportspec cis
MkC str <- coreStringLit $ static
++ unpackFS ch ++ " "
- ++ unpackFS cn ++ " "
++ cis'
dec <- rep2 forImpDName [cc', s', str, name', typ']
return (loc, dec)
| 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
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
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
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)) =
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))
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?
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.
_ -> 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
; 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
_ -> 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
projects / ghc-hetmet.git / commitdiff