inline-c 0.8.0.1 → 0.9.0.0

raw patch · 11 files changed

+285/−110 lines, 11 filesdep +splitPVP ok

version bump matches the API change (PVP)

Dependencies added: split

API changes (from Hackage documentation)

Files

• README.md +5/−5
• inline-c.cabal +2/−1
• src/Language/C/Inline/Context.hs +52/−11
• src/Language/C/Inline/HaskellIdentifier.hs +10/−9
• src/Language/C/Inline/Internal.hs +15/−9
• src/Language/C/Types.hs +67/−40
• src/Language/C/Types/Parse.hs +76/−20
• test/Language/C/Inline/ContextSpec.hs +25/−2
• test/Language/C/Inline/ParseSpec.hs +2/−2
• test/Language/C/Types/ParseSpec.hs +24/−8
• test/tests.hs +7/−3

@@ -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) 

@@ -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 <https://github.com/fpco/inline-c/blob/master/README.md>. license:             MIT@@ -70,6 +70,7 @@                      , transformers                      , unordered-containers                      , vector+                     , split   default-language:    Haskell2010   ghc-options:         -Wall   cc-options:          -Wall -Werror

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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<int>") [t| Vec CInt |]+  Hspec.it "converts std::vector" $ do+    shouldBeType (cty "std::vector<int>") [t| Vec CInt |]+  Hspec.it "converts std::vector*" $ do+    shouldBeType (cty "std::vector<int>*") [t| Ptr (Vec CInt) |]+  Hspec.it "converts array" $ do+    shouldBeType (cty "array<int,10>") [t| Ary '(CInt,10) |]+  Hspec.it "converts array*" $ do+    shouldBeType (cty "array<int,10>*") [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|])+                 ]

@@ -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)]

@@ -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 <https://github.com/fpco/inline-c/pull/97#issuecomment-538648101>+          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' 

@@ -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"