diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -18,7 +18,7 @@ ## Getting started Let's say we want to compute the cosine of a number using C from -Haskell. `inline-c` let's you write this function call inline, without +Haskell. `inline-c` lets you write this function call inline, without any need for a binding to the foreign function: ``` @@ -48,7 +48,7 @@ A `C.exp` quasiquotation always includes a type annotation for the inline C expression. This annotation determines the type of the quasiquotation in Haskell. Out of the box, `inline-c` knows how to map -many common C types to Haskell type. In this case, +many common C types to Haskell types. In this case, ``` [C.exp| double { cos(1) } |] :: IO CDouble @@ -227,9 +227,9 @@ ## ByteStrings -The `bs-len` and `bs-ptr` ant-quoters in the `C.bsCtx` context work +The `bs-len` and `bs-ptr` anti-quoters in the `C.bsCtx` context work exactly the same as the `vec-len` and `vec-ptr` counterparts, but with -strict `ByteString`s. The only difference is that it is no necessary to +strict `ByteString`s. The only difference is that it is not necessary to specify the type of the pointer from C -- it is always going to be `char *`: @@ -267,7 +267,7 @@ {-# LANGUAGE TemplateHaskell #-} import qualified Language.C.Inline as C --- To use the function pointer anti-quoter, we need the 'C.funCtx along with +-- To use the function pointer anti-quoter, we need the 'C.funCtx' along with -- the 'C.baseCtx'. C.context (C.baseCtx <> C.funCtx) diff --git a/inline-c.cabal b/inline-c.cabal --- a/inline-c.cabal +++ b/inline-c.cabal @@ -1,5 +1,5 @@ name: inline-c -version: 0.8.0.1 +version: 0.9.0.0 synopsis: Write Haskell source files including C code inline. No FFI required. description: See . license: MIT @@ -70,6 +70,7 @@ , transformers , unordered-containers , vector + , split default-language: Haskell2010 ghc-options: -Wall cc-options: -Wall -Werror diff --git a/src/Language/C/Inline/Context.hs b/src/Language/C/Inline/Context.hs --- a/src/Language/C/Inline/Context.hs +++ b/src/Language/C/Inline/Context.hs @@ -1,14 +1,20 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- | A 'Context' is used to define the capabilities of the Template Haskell code -- that handles the inline C code. See the documentation of the data type for @@ -43,7 +49,7 @@ ) where import Control.Applicative ((<|>)) -import Control.Monad (mzero) +import Control.Monad (mzero, forM) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) import qualified Data.ByteString as BS @@ -64,6 +70,7 @@ import qualified Text.Parser.Token as Parser import qualified Data.HashSet as HashSet + #if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup, (<>)) #else @@ -153,6 +160,7 @@ -- when generating C++ code. , ctxForeignSrcLang :: Maybe TH.ForeignSrcLang -- ^ TH.LangC by default + , ctxEnableCpp :: Bool } @@ -163,6 +171,7 @@ , ctxAntiQuoters = ctxAntiQuoters ctx1 <> ctxAntiQuoters ctx2 , ctxOutput = ctxOutput ctx1 <|> ctxOutput ctx2 , ctxForeignSrcLang = ctxForeignSrcLang ctx1 <|> ctxForeignSrcLang ctx2 + , ctxEnableCpp = ctxEnableCpp ctx1 || ctxEnableCpp ctx2 } #endif @@ -172,6 +181,7 @@ , ctxAntiQuoters = mempty , ctxOutput = Nothing , ctxForeignSrcLang = Nothing + , ctxEnableCpp = False } #if !MIN_VERSION_base(4,11,0) @@ -180,6 +190,7 @@ , ctxAntiQuoters = ctxAntiQuoters ctx1 <> ctxAntiQuoters ctx2 , ctxOutput = ctxOutput ctx1 <|> ctxOutput ctx2 , ctxForeignSrcLang = ctxForeignSrcLang ctx1 <|> ctxForeignSrcLang ctx2 + , ctxEnableCpp = ctxEnableCpp ctx1 || ctxEnableCpp ctx2 } #endif @@ -201,6 +212,7 @@ -- along with its documentation's section headers. -- -- Integral types + , (C.Bool, [t| CBool |]) , (C.Char Nothing, [t| CChar |]) , (C.Char (Just C.Signed), [t| CSChar |]) , (C.Char (Just C.Unsigned), [t| CUChar |]) @@ -263,7 +275,30 @@ goDecl = go . C.parameterDeclarationType go :: C.Type C.CIdentifier -> MaybeT TH.Q TH.Type - go cTy = case cTy of + go cTy = do + case cTy of + C.TypeSpecifier _specs (C.Template ident' cTys) -> do +-- let symbol = TH.LitT (TH.StrTyLit (C.unCIdentifier ident')) + symbol <- case Map.lookup (C.TypeName ident') cTypes of + Nothing -> mzero + Just ty -> return ty + hsTy <- forM cTys $ \cTys' -> go (C.TypeSpecifier undefined cTys') + case hsTy of + (a:[]) -> + lift [t| $(symbol) $(return a) |] + (a:b:[]) -> + lift [t| $(symbol) '($(return a),$(return b))|] + (a:b:c:[]) -> + lift [t| $(symbol) '($(return a),$(return b),$(return c))|] + (a:b:c:d:[]) -> + lift [t| $(symbol) '($(return a),$(return b),$(return c),$(return d))|] + (a:b:c:d:e:[]) -> + lift [t| $(symbol) '($(return a),$(return b),$(return c),$(return d),$(return e))|] + [] -> fail $ "Can not find template parameters." + _ -> fail $ "Find too many template parameters. num = " ++ show (length hsTy) + C.TypeSpecifier _specs (C.TemplateConst num) -> do + let n = (TH.LitT (TH.NumTyLit (read num))) + lift [t| $(return n) |] C.TypeSpecifier _specs cSpec -> case Map.lookup cSpec cTypes of Nothing -> mzero @@ -451,7 +486,8 @@ vecLenAntiQuoter = AntiQuoter { aqParser = do hId <- C.parseIdentifier - let cId = mangleHaskellIdentifier hId + useCpp <- C.parseEnableCpp + let cId = mangleHaskellIdentifier useCpp hId return (cId, C.TypeSpecifier mempty (C.Long C.Signed), hId) , aqMarshaller = \_purity _cTypes cTy cId -> do case cTy of @@ -486,7 +522,8 @@ bsPtrAntiQuoter = AntiQuoter { aqParser = do hId <- C.parseIdentifier - let cId = mangleHaskellIdentifier hId + useCpp <- C.parseEnableCpp + let cId = mangleHaskellIdentifier useCpp hId return (cId, C.Ptr [] (C.TypeSpecifier mempty (C.Char Nothing)), hId) , aqMarshaller = \_purity _cTypes cTy cId -> do case cTy of @@ -503,7 +540,8 @@ bsLenAntiQuoter = AntiQuoter { aqParser = do hId <- C.parseIdentifier - let cId = mangleHaskellIdentifier hId + useCpp <- C.parseEnableCpp + let cId = mangleHaskellIdentifier useCpp hId return (cId, C.TypeSpecifier mempty (C.Long C.Signed), hId) , aqMarshaller = \_purity _cTypes cTy cId -> do case cTy of @@ -521,7 +559,8 @@ bsCStrAntiQuoter = AntiQuoter { aqParser = do hId <- C.parseIdentifier - let cId = mangleHaskellIdentifier hId + useCpp <- C.parseEnableCpp + let cId = mangleHaskellIdentifier useCpp hId return (cId, C.Ptr [] (C.TypeSpecifier mempty (C.Char Nothing)), hId) , aqMarshaller = \_purity _cTypes cTy cId -> do case cTy of @@ -543,10 +582,11 @@ => m (C.CIdentifier, C.Type C.CIdentifier, HaskellIdentifier) cDeclAqParser = do cTy <- Parser.parens C.parseParameterDeclaration + useCpp <- C.parseEnableCpp case C.parameterDeclarationId cTy of Nothing -> fail "Every captured function must be named (funCtx)" Just hId -> do - let cId = mangleHaskellIdentifier hId + let cId = mangleHaskellIdentifier useCpp hId cTy' <- deHaskellifyCType $ C.parameterDeclarationType cTy return (cId, cTy', hId) @@ -554,7 +594,8 @@ :: C.CParser HaskellIdentifier m => C.Type HaskellIdentifier -> m (C.Type C.CIdentifier) deHaskellifyCType = traverse $ \hId -> do - case C.cIdentifierFromString (unHaskellIdentifier hId) of + useCpp <- C.parseEnableCpp + case C.cIdentifierFromString useCpp (unHaskellIdentifier hId) of Left err -> fail $ "Illegal Haskell identifier " ++ unHaskellIdentifier hId ++ " in C type:\n" ++ err Right x -> return x diff --git a/src/Language/C/Inline/HaskellIdentifier.hs b/src/Language/C/Inline/HaskellIdentifier.hs --- a/src/Language/C/Inline/HaskellIdentifier.hs +++ b/src/Language/C/Inline/HaskellIdentifier.hs @@ -44,27 +44,28 @@ instance IsString HaskellIdentifier where fromString s = - case haskellIdentifierFromString s of + case haskellIdentifierFromString True s of Left err -> error $ "HaskellIdentifier fromString: invalid string " ++ s ++ ":\n" ++ err Right x -> x instance PP.Pretty HaskellIdentifier where pretty = PP.text . unHaskellIdentifier -haskellIdentifierFromString :: String -> Either String HaskellIdentifier -haskellIdentifierFromString s = +haskellIdentifierFromString :: Bool -> String -> Either String HaskellIdentifier +haskellIdentifierFromString useCpp s = case C.runCParser cpc "haskellIdentifierFromString" s (parseHaskellIdentifier <* eof) of Left err -> Left $ show err Right x -> Right x where - cpc = haskellCParserContext HashSet.empty + cpc = haskellCParserContext useCpp HashSet.empty -haskellCParserContext :: C.TypeNames -> C.CParserContext HaskellIdentifier -haskellCParserContext typeNames = C.CParserContext +haskellCParserContext :: Bool -> C.TypeNames -> C.CParserContext HaskellIdentifier +haskellCParserContext useCpp typeNames = C.CParserContext { C.cpcTypeNames = typeNames , C.cpcParseIdent = parseHaskellIdentifier , C.cpcIdentName = "Haskell identifier" , C.cpcIdentToString = unHaskellIdentifier + , C.cpcEnableCpp = useCpp } -- | See @@ -121,15 +122,15 @@ -- | Mangles an 'HaskellIdentifier' to produce a valid 'C.CIdentifier' -- which still sort of resembles the 'HaskellIdentifier'. -mangleHaskellIdentifier :: HaskellIdentifier -> C.CIdentifier -mangleHaskellIdentifier (HaskellIdentifier hs) = +mangleHaskellIdentifier :: Bool -> HaskellIdentifier -> C.CIdentifier +mangleHaskellIdentifier useCpp (HaskellIdentifier hs) = -- The leading underscore if we have no valid chars is because then -- we'd have an identifier starting with numbers. let cs = (if null valid then "_" else "") ++ valid ++ (if null mangled || null valid then "" else "_") ++ mangled - in case C.cIdentifierFromString cs of + in case C.cIdentifierFromString useCpp cs of Left err -> error $ "mangleHaskellIdentifier: produced bad C identifier\n" ++ err Right x -> x where diff --git a/src/Language/C/Inline/Internal.hs b/src/Language/C/Inline/Internal.hs --- a/src/Language/C/Inline/Internal.hs +++ b/src/Language/C/Inline/Internal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} @@ -155,7 +156,11 @@ Nothing -> fail "inline-c: ModuleState not present (initialiseModuleState)" Just ms -> return ms let lang = fromMaybe TH.LangC (ctxForeignSrcLang context) +#if MIN_VERSION_base(4,12,0) + TH.addForeignSource lang (concat (reverse (msFileChunks ms))) +#else TH.addForeignFile lang (concat (reverse (msFileChunks ms))) +#endif let moduleState = ModuleState { msContext = context , msGeneratedNames = 0 @@ -392,8 +397,9 @@ inlineItems callSafety funPtr mbPostfix loc type_ cRetType cParams cItems = do let mkParam (id', paramTy) = C.ParameterDeclaration (Just id') paramTy let proto = C.Proto cRetType (map mkParam cParams) + ctx <- getContext funName <- uniqueCName mbPostfix - cFunName <- case C.cIdentifierFromString funName of + cFunName <- case C.cIdentifierFromString (ctxEnableCpp ctx) funName of Left err -> fail $ "inlineItems: impossible, generated bad C identifier " ++ "funName:\n" ++ err Right x -> return x @@ -463,9 +469,9 @@ -- the root. parseTypedC :: forall m. C.CParser HaskellIdentifier m - => AntiQuoters -> m ParseTypedC + => Bool -> AntiQuoters -> m ParseTypedC -- ^ Returns the return type, the captured variables, and the body. -parseTypedC antiQs = do +parseTypedC useCpp antiQs = do -- Parse return type (consume spaces first) Parser.spaces cRetType <- purgeHaskellIdentifiers =<< C.parseType @@ -525,14 +531,14 @@ Nothing -> fail $ pretty80 $ "Un-named captured variable in decl" <+> PP.pretty decl Just hId -> return hId - id' <- freshId $ mangleHaskellIdentifier hId + id' <- freshId $ mangleHaskellIdentifier useCpp hId void $ Parser.char ')' return ([(id', declType, Plain hId)], C.unCIdentifier id') freshId s = do c <- get put $ c + 1 - case C.cIdentifierFromString (C.unCIdentifier s ++ "_inline_c_" ++ show c) of + case C.cIdentifierFromString useCpp (C.unCIdentifier s ++ "_inline_c_" ++ show c) of Left _err -> error "freshId: The impossible happened" Right x -> return x @@ -547,7 +553,7 @@ => C.Type HaskellIdentifier -> n (C.Type C.CIdentifier) purgeHaskellIdentifiers cTy = for cTy $ \hsIdent -> do let hsIdentS = unHaskellIdentifier hsIdent - case C.cIdentifierFromString hsIdentS of + case C.cIdentifierFromString useCpp hsIdentS of Left err -> fail $ "Haskell identifier " ++ hsIdentS ++ " in illegal position" ++ "in C type\n" ++ pretty80 cTy ++ "\n" ++ "A C identifier was expected, but:\n" ++ err @@ -575,8 +581,8 @@ here <- TH.location ParseTypedC cType cParams cExp <- runParserInQ s - (haskellCParserContext (typeNamesFromTypesTable (ctxTypesTable ctx))) - (parseTypedC (ctxAntiQuoters ctx)) + (haskellCParserContext (ctxEnableCpp ctx) (typeNamesFromTypesTable (ctxTypesTable ctx))) + (parseTypedC (ctxEnableCpp ctx) (ctxAntiQuoters ctx)) hsType <- cToHs ctx cType hsParams <- forM cParams $ \(_cId, cTy, parTy) -> do case parTy of @@ -648,7 +654,7 @@ funPtrQuote callSafety = quoteCode $ \code -> do loc <- TH.location ctx <- getContext - FunPtrDecl{..} <- runParserInQ code (C.cCParserContext (typeNamesFromTypesTable (ctxTypesTable ctx))) parse + FunPtrDecl{..} <- runParserInQ code (C.cCParserContext (ctxEnableCpp ctx) (typeNamesFromTypesTable (ctxTypesTable ctx))) parse hsRetType <- cToHs ctx funPtrReturnType hsParams <- forM funPtrParameters (\(_ident, typ_) -> cToHs ctx typ_) let hsFunType = convertCFunSig hsRetType hsParams diff --git a/src/Language/C/Types.hs b/src/Language/C/Types.hs --- a/src/Language/C/Types.hs +++ b/src/Language/C/Types.hs @@ -48,6 +48,7 @@ , parseParameterDeclaration , parseParameterList , parseIdentifier + , parseEnableCpp , parseType -- * Convert to and from high-level views @@ -61,9 +62,10 @@ ) where import Control.Arrow (second) -import Control.Monad (when, unless, forM_) +import Control.Monad (when, unless, forM_, forM) import Control.Monad.State (execState, modify) -import Data.List (partition) +import Control.Monad.Reader (ask) +import Data.List (partition, intersperse) import Data.Maybe (fromMaybe) import Data.Typeable (Typeable) import Text.PrettyPrint.ANSI.Leijen ((), (<+>)) @@ -89,6 +91,7 @@ data TypeSpecifier = Void + | Bool | Char (Maybe Sign) | Short Sign | Int Sign @@ -100,6 +103,8 @@ | TypeName P.CIdentifier | Struct P.CIdentifier | Enum P.CIdentifier + | Template P.CIdentifier [TypeSpecifier] + | TemplateConst String deriving (Typeable, Show, Eq, Ord) data Specifiers = Specifiers @@ -203,43 +208,54 @@ unless (null specs) $ illegalSpecifiers "expecting no specifiers" let checkNoLength = when (longs > 0 || shorts > 0) $ illegalSpecifiers "unexpected long/short" - tySpec <- case dataType of - P.TypeName s -> do - checkNoSpecs - return $ TypeName s - P.Struct s -> do - checkNoSpecs - return $ Struct s - P.Enum s -> do - checkNoSpecs - return $ Enum s - P.VOID -> do - checkNoSpecs - return Void - P.CHAR -> do - checkNoLength - return $ Char mbSign - P.INT | longs == 0 && shorts == 0 -> do - return $ Int sign - P.INT | longs == 1 -> do - return $ Long sign - P.INT | longs == 2 -> do - return $ LLong sign - P.INT | shorts == 1 -> do - return $ Short sign - P.INT -> do - illegalSpecifiers "too many long/short" - P.FLOAT -> do - checkNoLength - return Float - P.DOUBLE -> do - if longs == 1 - then return LDouble - else do + let type2type dat = case dat of + P.Template s args -> do + checkNoSpecs + args' <- forM args type2type + return $ Template s args' + P.TemplateConst s -> do + checkNoSpecs + return $ TemplateConst s + P.TypeName s -> do + checkNoSpecs + return $ TypeName s + P.Struct s -> do + checkNoSpecs + return $ Struct s + P.Enum s -> do + checkNoSpecs + return $ Enum s + P.VOID -> do + checkNoSpecs + return Void + P.BOOL -> do checkNoLength - return Double - _ -> do - error $ "untangleDeclarationSpecifiers impossible: " ++ show dataType + return $ Bool + P.CHAR -> do + checkNoLength + return $ Char mbSign + P.INT | longs == 0 && shorts == 0 -> do + return $ Int sign + P.INT | longs == 1 -> do + return $ Long sign + P.INT | longs == 2 -> do + return $ LLong sign + P.INT | shorts == 1 -> do + return $ Short sign + P.INT -> do + illegalSpecifiers "too many long/short" + P.FLOAT -> do + checkNoLength + return Float + P.DOUBLE -> do + if longs == 1 + then return LDouble + else do + checkNoLength + return Double + _ -> do + error $ "untangleDeclarationSpecifiers impossible: " ++ show dataType + tySpec <- type2type dataType return (Specifiers pStorage pTyQuals pFunSpecs, tySpec) untangleDeclarator @@ -368,8 +384,9 @@ tangleTypeSpecifier :: Specifiers -> TypeSpecifier -> [P.DeclarationSpecifier] tangleTypeSpecifier (Specifiers storages tyQuals funSpecs) tySpec = - let pTySpecs = case tySpec of + let pTySpecs ty = case ty of Void -> [P.VOID] + Bool -> [P.BOOL] Char Nothing -> [P.CHAR] Char (Just Signed) -> [P.SIGNED, P.CHAR] Char (Just Unsigned) -> [P.UNSIGNED, P.CHAR] @@ -387,10 +404,12 @@ TypeName s -> [P.TypeName s] Struct s -> [P.Struct s] Enum s -> [P.Enum s] + Template s types -> [P.Template s (concat (map pTySpecs types))] + TemplateConst s -> [P.TemplateConst s] in map P.StorageClassSpecifier storages ++ map P.TypeQualifier tyQuals ++ map P.FunctionSpecifier funSpecs ++ - map P.TypeSpecifier pTySpecs + map P.TypeSpecifier (pTySpecs tySpec) ------------------------------------------------------------------------ -- To english @@ -458,6 +477,11 @@ parseIdentifier :: P.CParser i m => m i parseIdentifier = P.identifier_no_lex +parseEnableCpp :: P.CParser i m => m Bool +parseEnableCpp = do + ctx <- ask + return (P.cpcEnableCpp ctx) + parseType :: (P.CParser i m, PP.Pretty i) => m (Type i) parseType = parameterDeclarationType <$> parseParameterDeclaration @@ -467,6 +491,7 @@ instance PP.Pretty TypeSpecifier where pretty tySpec = case tySpec of Void -> "void" + Bool -> "bool" Char Nothing -> "char" Char (Just Signed) -> "signed char" Char (Just Unsigned) -> "unsigned char" @@ -484,6 +509,8 @@ TypeName s -> PP.pretty s Struct s -> "struct" <+> PP.pretty s Enum s -> "enum" <+> PP.pretty s + Template s args -> PP.pretty s <+> "<" <+> mconcat (intersperse "," (map PP.pretty args)) <+> ">" + TemplateConst s -> PP.pretty s instance PP.Pretty UntangleErr where pretty err = case err of diff --git a/src/Language/C/Types/Parse.hs b/src/Language/C/Types/Parse.hs --- a/src/Language/C/Types/Parse.hs +++ b/src/Language/C/Types/Parse.hs @@ -89,6 +89,7 @@ import Control.Applicative import Control.Monad (msum, void, MonadPlus, unless, when) import Control.Monad.Reader (MonadReader, runReaderT, ReaderT, asks, ask) +import Data.List (intersperse) import Data.Functor.Identity (Identity) import qualified Data.HashSet as HashSet import Data.Hashable (Hashable) @@ -122,36 +123,38 @@ , cpcParseIdent :: forall m. CParser i m => m i -- ^ Parses an identifier, *without consuming whitespace afterwards*. , cpcIdentToString :: i -> String + , cpcEnableCpp :: Bool } -- | A type for C identifiers. newtype CIdentifier = CIdentifier {unCIdentifier :: String} deriving (Typeable, Eq, Ord, Show, Hashable) -cIdentifierFromString :: String -> Either String CIdentifier -cIdentifierFromString s = +cIdentifierFromString :: Bool -> String -> Either String CIdentifier +cIdentifierFromString useCpp s = -- Note: it's important not to use 'cidentifier_raw' here, otherwise -- we go in a loop: -- -- @ -- cIdentifierFromString => fromString => cIdentifierFromString => ... -- @ - case Parsec.parse (identNoLex cIdentStyle <* eof) "cIdentifierFromString" s of + case Parsec.parse (identNoLex useCpp cIdentStyle <* eof) "cIdentifierFromString" s of Left err -> Left $ show err Right x -> Right $ CIdentifier x instance IsString CIdentifier where fromString s = - case cIdentifierFromString s of + case cIdentifierFromString True s of Left err -> error $ "CIdentifier fromString: invalid string " ++ show s ++ "\n" ++ err Right x -> x -cCParserContext :: TypeNames -> CParserContext CIdentifier -cCParserContext typeNames = CParserContext +cCParserContext :: Bool -> TypeNames -> CParserContext CIdentifier +cCParserContext useCpp typeNames = CParserContext { cpcTypeNames = typeNames , cpcParseIdent = cidentifier_no_lex , cpcIdentToString = unCIdentifier , cpcIdentName = "C identifier" + , cpcEnableCpp = useCpp } ------------------------------------------------------------------------ @@ -212,13 +215,14 @@ -- | Like 'quickCParser', but uses @'cCParserContext' ('const' 'False')@ as -- 'CParserContext'. quickCParser_ - :: String + :: Bool + -> String -- ^ String to parse. -> (ReaderT (CParserContext CIdentifier) (Parsec.Parsec String ()) a) -- ^ Parser. Anything with type @forall m. CParser i m => m a@ is a -- valid argument. -> a -quickCParser_ = quickCParser (cCParserContext HashSet.empty) +quickCParser_ useCpp = quickCParser (cCParserContext useCpp HashSet.empty) cReservedWords :: HashSet.HashSet String cReservedWords = HashSet.fromList @@ -282,6 +286,7 @@ data TypeSpecifier = VOID + | BOOL | CHAR | SHORT | INT @@ -293,11 +298,14 @@ | Struct CIdentifier | Enum CIdentifier | TypeName CIdentifier + | Template CIdentifier [TypeSpecifier] + | TemplateConst String deriving (Typeable, Eq, Show) type_specifier :: CParser i m => m TypeSpecifier type_specifier = msum [ VOID <$ reserve cIdentStyle "void" + , BOOL <$ reserve cIdentStyle "bool" , CHAR <$ reserve cIdentStyle "char" , SHORT <$ reserve cIdentStyle "short" , INT <$ reserve cIdentStyle "int" @@ -308,15 +316,16 @@ , UNSIGNED <$ reserve cIdentStyle "unsigned" , Struct <$> (reserve cIdentStyle "struct" >> cidentifier) , Enum <$> (reserve cIdentStyle "enum" >> cidentifier) + , template_parser , TypeName <$> type_name ] identifier :: CParser i m => m i identifier = token identifier_no_lex -isTypeName :: TypeNames -> String -> Bool -isTypeName typeNames id_ = - case cIdentifierFromString id_ of +isTypeName :: Bool -> TypeNames -> String -> Bool +isTypeName useCpp typeNames id_ = + case cIdentifierFromString useCpp id_ of -- If it's not a valid C identifier, then it's definitely not a C type name. Left _err -> False Right s -> HashSet.member s typeNames @@ -325,20 +334,21 @@ identifier_no_lex = try $ do ctx <- ask id_ <- cpcParseIdent ctx cpcIdentName ctx - when (isTypeName (cpcTypeNames ctx) (cpcIdentToString ctx id_)) $ + when (isTypeName (cpcEnableCpp ctx) (cpcTypeNames ctx) (cpcIdentToString ctx id_)) $ unexpected $ "type name " ++ cpcIdentToString ctx id_ return id_ -- | Same as 'cidentifier_no_lex', but does not check that the -- identifier is not a type name. -cidentifier_raw :: (TokenParsing m, Monad m) => m CIdentifier -cidentifier_raw = identNoLex cIdentStyle +cidentifier_raw :: (TokenParsing m, Monad m) => Bool -> m CIdentifier +cidentifier_raw useCpp = identNoLex useCpp cIdentStyle -- | This parser parses a 'CIdentifier' and nothing else -- it does not consume -- trailing spaces and the like. cidentifier_no_lex :: CParser i m => m CIdentifier cidentifier_no_lex = try $ do - s <- cidentifier_raw + ctx <- ask + s <- cidentifier_raw (cpcEnableCpp ctx) typeNames <- asks cpcTypeNames when (HashSet.member s typeNames) $ unexpected $ "type name " ++ unCIdentifier s @@ -349,12 +359,38 @@ type_name :: CParser i m => m CIdentifier type_name = try $ do - s <- ident cIdentStyle "type name" + ctx <- ask + s <- ident' (cpcEnableCpp ctx) cIdentStyle "type name" typeNames <- asks cpcTypeNames unless (HashSet.member s typeNames) $ unexpected $ "identifier " ++ unCIdentifier s return s +templateParser :: (Monad m, CharParsing m, CParser i m) => IdentifierStyle m -> m TypeSpecifier +templateParser s = parse' + where + parse' = do + id' <- cidentParserWithNamespace + _ <- string "<" + args <- templateArgParser + _ <- string ">" + return $ Template (CIdentifier id') args + cidentParser = ((:) <$> _styleStart s <*> many (_styleLetter s) _styleName s) + cidentParserWithNamespace = + try (concat <$> sequence [cidentParser, (string "::"), cidentParserWithNamespace]) <|> + cidentParser + templateArgType = try type_specifier <|> (TemplateConst <$> (many $ oneOf ['0'..'9'])) + templateArgParser' = do + t <- templateArgType + _ <- string "," + tt <- templateArgParser + return $ t:tt + templateArgParser = + try (templateArgParser') <|> ((:) <$> templateArgType <*> return []) + +template_parser :: CParser i m => m TypeSpecifier +template_parser = try $ templateParser cIdentStyle "template name" + data TypeQualifier = CONST | RESTRICT @@ -514,6 +550,7 @@ instance Pretty TypeSpecifier where pretty tySpec = case tySpec of VOID -> "void" + BOOL -> "bool" CHAR -> "char" SHORT -> "short" INT -> "int" @@ -525,6 +562,8 @@ Struct x -> "struct" <+> pretty x Enum x -> "enum" <+> pretty x TypeName x -> pretty x + Template x args -> pretty x <+> "<" <+> mconcat (intersperse "," (map pretty args)) <+> ">" + TemplateConst x -> pretty x instance Pretty TypeQualifier where pretty tyQual = case tyQual of @@ -746,9 +785,26 @@ -- Utils ------------------------------------------------------------------------ -identNoLex :: (TokenParsing m, Monad m, IsString s) => IdentifierStyle m -> m s -identNoLex s = fmap fromString $ try $ do - name <- highlight (_styleHighlight s) - ((:) <$> _styleStart s <*> many (_styleLetter s) _styleName s) +cppIdentParser :: (Monad m, CharParsing m) => Bool -> IdentifierStyle m -> m [Char] +cppIdentParser useCpp s = cidentParserWithNamespace + where + cidentParser = ((:) <$> _styleStart s <*> many (_styleLetter s) _styleName s) + cidentParserWithNamespace = + if useCpp + then + try (concat <$> sequence [cidentParser, (string "::"), cidentParserWithNamespace]) <|> + cidentParser + else + cidentParser + +identNoLex :: (TokenParsing m, Monad m, IsString s) => Bool -> IdentifierStyle m -> m s +identNoLex useCpp s = fmap fromString $ try $ do + name <- highlight (_styleHighlight s) (cppIdentParser useCpp s) + when (HashSet.member name (_styleReserved s)) $ unexpected $ "reserved " ++ _styleName s ++ " " ++ show name + return name + +ident' :: (TokenParsing m, Monad m, IsString s) => Bool -> IdentifierStyle m -> m s +ident' useCpp s = fmap fromString $ token $ try $ do + name <- highlight (_styleHighlight s) (cppIdentParser useCpp s) when (HashSet.member name (_styleReserved s)) $ unexpected $ "reserved " ++ _styleName s ++ " " ++ show name return name diff --git a/test/Language/C/Inline/ContextSpec.hs b/test/Language/C/Inline/ContextSpec.hs --- a/test/Language/C/Inline/ContextSpec.hs +++ b/test/Language/C/Inline/ContextSpec.hs @@ -6,10 +6,12 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DataKinds #-} module Language.C.Inline.ContextSpec (spec) where import Control.Monad.Trans.Class (lift) import Data.Word +import qualified Data.Map as Map import qualified Test.Hspec as Hspec import Text.Parser.Char import Text.Parser.Combinators @@ -22,14 +24,21 @@ #endif import qualified Language.C.Types as C +import qualified Language.C.Types.Parse as P import Language.C.Inline.Context +import GHC.Exts( IsString(..) ) +data Vec a +data Ary a + spec :: Hspec.SpecWith () spec = do Hspec.it "converts simple type correctly (1)" $ do shouldBeType (cty "int") [t| CInt |] Hspec.it "converts simple type correctly (2)" $ do shouldBeType (cty "char") [t| CChar |] + Hspec.it "converts bool" $ do + shouldBeType (cty "bool") [t| CBool |] Hspec.it "converts void" $ do shouldBeType (cty "void") [t| () |] Hspec.it "converts standard library types (1)" $ do @@ -77,6 +86,16 @@ shouldBeType (cty "char *(*(**foo [])(int x))[]") [t| CArray (Ptr (FunPtr (CInt -> IO (Ptr (CArray (Ptr CChar)))))) |] + Hspec.it "converts vector" $ do + shouldBeType (cty "vector") [t| Vec CInt |] + Hspec.it "converts std::vector" $ do + shouldBeType (cty "std::vector") [t| Vec CInt |] + Hspec.it "converts std::vector*" $ do + shouldBeType (cty "std::vector*") [t| Ptr (Vec CInt) |] + Hspec.it "converts array" $ do + shouldBeType (cty "array") [t| Ary '(CInt,10) |] + Hspec.it "converts array*" $ do + shouldBeType (cty "array*") [t| Ptr (Ary '(CInt,10)) |] where goodConvert cTy = do mbHsTy <- TH.runQ $ convertType IO baseTypes cTy @@ -90,10 +109,14 @@ x `Hspec.shouldBe` y assertParse p s = - case C.runCParser (C.cCParserContext (typeNamesFromTypesTable baseTypes)) "spec" s (lift spaces *> p <* lift eof) of + case C.runCParser (C.cCParserContext True (typeNamesFromTypesTable baseTypes)) "spec" s (lift spaces *> p <* lift eof) of Left err -> error $ "Parse error (assertParse): " ++ show err Right x -> x cty s = C.parameterDeclarationType $ assertParse C.parseParameterDeclaration s - baseTypes = ctxTypesTable baseCtx + baseTypes = ctxTypesTable baseCtx `mappend` Map.fromList [ + (C.TypeName (fromString "vector" :: P.CIdentifier), [t|Vec|]), + (C.TypeName (fromString "std::vector" :: P.CIdentifier), [t|Vec|]), + (C.TypeName (fromString "array" :: P.CIdentifier), [t|Ary|]) + ] diff --git a/test/Language/C/Inline/ParseSpec.hs b/test/Language/C/Inline/ParseSpec.hs --- a/test/Language/C/Inline/ParseSpec.hs +++ b/test/Language/C/Inline/ParseSpec.hs @@ -85,7 +85,7 @@ -> IO (C.Type C.CIdentifier, [(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String) strictParse s = do let ParseTypedC retType pars body = - assertParse haskellCParserContext (parseTypedC (ctxAntiQuoters ctx)) s + assertParse (haskellCParserContext True) (parseTypedC True (ctxAntiQuoters ctx)) s void $ evaluate $ length $ show (retType, pars, body) return (retType, pars, body) @@ -94,7 +94,7 @@ cty :: String -> C.Type C.CIdentifier cty s = C.parameterDeclarationType $ - assertParse C.cCParserContext C.parseParameterDeclaration s + assertParse (C.cCParserContext True) C.parseParameterDeclaration s shouldMatchParameters :: [(C.CIdentifier, C.Type C.CIdentifier, ParameterType)] diff --git a/test/Language/C/Types/ParseSpec.hs b/test/Language/C/Types/ParseSpec.hs --- a/test/Language/C/Types/ParseSpec.hs +++ b/test/Language/C/Types/ParseSpec.hs @@ -20,6 +20,7 @@ import Data.List (intercalate) import Data.String (fromString) import Data.Maybe (mapMaybe) +import Data.List.Split (splitOn) import Language.C.Types.Parse import qualified Language.C.Types as Types @@ -38,7 +39,7 @@ ParameterDeclarationWithTypeNames typeNames ty <- arbitraryParameterDeclarationWithTypeNames unCIdentifier return $ isGoodType ty QC.==> - let ty' = assertParse (cCParserContext typeNames) parameter_declaration (prettyOneLine ty) + let ty' = assertParse (cCParserContext True typeNames) parameter_declaration (prettyOneLine ty) in Types.untangleParameterDeclaration ty == Types.untangleParameterDeclaration ty' Hspec.it "parses everything which is pretty-printable (Haskell)" $ do #if MIN_VERSION_QuickCheck(2,9,0) @@ -48,8 +49,8 @@ #endif ParameterDeclarationWithTypeNames typeNames ty <- arbitraryParameterDeclarationWithTypeNames unHaskellIdentifier - return $ isGoodType ty QC.==> - let ty' = assertParse (haskellCParserContext typeNames) parameter_declaration (prettyOneLine ty) + return $ isGoodHaskellIdentifierType typeNames ty QC.==> + let ty' = assertParse (haskellCParserContext True typeNames) parameter_declaration (prettyOneLine ty) in Types.untangleParameterDeclaration ty == Types.untangleParameterDeclaration ty' ------------------------------------------------------------------------ @@ -60,17 +61,32 @@ => CParserContext i -> (forall m. CParser i m => m a) -> String -> a assertParse ctx p s = case runCParser ctx "spec" s (lift spaces *> p <* lift eof) of - Left err -> error $ "Parse error (assertParse): " ++ show err + Left err -> error $ "Parse error (assertParse): " ++ show err ++ " parsed string " ++ show s ++ " with type names " ++ show (cpcTypeNames ctx) Right x -> x prettyOneLine :: PP.Pretty a => a -> String prettyOneLine x = PP.displayS (PP.renderCompact (PP.pretty x)) "" isGoodType :: ParameterDeclaration i -> Bool -isGoodType ty = case Types.untangleParameterDeclaration ty of - Left _ -> False - Right _ -> True +isGoodType ty = + case Types.untangleParameterDeclaration ty of + Left{} -> False + Right{} -> True +isGoodHaskellIdentifierType :: TypeNames -> ParameterDeclaration HaskellIdentifier -> Bool +isGoodHaskellIdentifierType typeNames ty0 = + case Types.untangleParameterDeclaration ty0 of + Left{} -> False + Right ty -> + case Types.parameterDeclarationId ty of + Nothing -> True + Just i -> let + -- see + leadingSegment : _ = splitOn "." (unHaskellIdentifier i) + in case cIdentifierFromString True leadingSegment of + Left{} -> True + Right seg -> not (seg `HashSet.member` typeNames) + ------------------------------------------------------------------------ -- Arbitrary @@ -179,7 +195,7 @@ :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen i arbitraryIdentifierFrom ctx = do id' <- QC.arbitrary - if isTypeName (acTypeNames ctx) (acIdentToString ctx id') + if isTypeName True (acTypeNames ctx) (acIdentToString ctx id') then arbitraryIdentifierFrom ctx else return id' diff --git a/test/tests.hs b/test/tests.hs --- a/test/tests.hs +++ b/test/tests.hs @@ -66,8 +66,8 @@ Nothing -- no postfix here [t| CInt -> CInt |] - (C.quickCParser_ "int" C.parseType) - [("x", C.quickCParser_ "int" C.parseType)] + (C.quickCParser_ True "int" C.parseType) + [("x", C.quickCParser_ True "int" C.parseType)] [r| return x + 3; |]) c_add3 1 `Hspec.shouldBe` 1 + 3 Hspec.it "inlineExp" $ do @@ -77,7 +77,7 @@ TH.Safe here [t| CInt |] - (C.quickCParser_ "int" C.parseType) + (C.quickCParser_ True "int" C.parseType) [] [r| 1 + 4 |]) x `Hspec.shouldBe` 1 + 4 @@ -223,3 +223,7 @@ [C.exp| void { $(void (*fp)(int *))($(int *x_ptr)) } |] x <- peek x_ptr x `Hspec.shouldBe` 42 + Hspec.it "cpp namespace identifiers" $ do + C.cIdentifierFromString True "Test::Test" `Hspec.shouldBe` Right "Test::Test" + Hspec.it "cpp template identifiers" $ do + C.cIdentifierFromString True "std::vector" `Hspec.shouldBe` Right "std::vector"