inline-c 0.5.3.4 → 0.5.4.0

raw patch · 13 files changed

+780/−364 lines, 13 filesdep +hashablePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: hashable

API changes (from Hackage documentation)

Files

• README.md +3/−0
• changelog.md +1/−0
• inline-c.cabal +5/−1
• src/Language/C/Inline/Context.hs +59/−40
• src/Language/C/Inline/HaskellIdentifier.hs +166/−0
• src/Language/C/Inline/Internal.hs +74/−38
• src/Language/C/Types.hs +58/−43
• src/Language/C/Types/Parse.hs +316/−202
• test/Language/C/Inline/ContextSpec.hs +1/−1
• test/Language/C/Inline/ParseSpec.hs +36/−12
• test/Language/C/Types/ParseSpec.hs +21/−9
• test/tests.c +32/−17
• test/tests.hs +8/−1

@@ -136,6 +136,9 @@ Here, the Haskell variable `n` is captured right where we need it using `$(int n)`.  Standard anti-quotation (we'll talk about additional ones later) consists of a `$` followed by a C declaration in parenthesis.+Note that any valid Haskell identifiers can be used when anti-quoting,+including ones including constructors, qualified names, names containing+unicode, etc.  For each anti-quotation, a variable with a matching type is expected in the Haskell environment.  In this case `inline-c` expects a variable

@@ -1,3 +1,4 @@+- 0.5.4.0: Allow Haskell identifiers in anti-quotes.  See issue #23. - 0.5.3.4: Fix `bsCtx` docs. - 0.5.3.3:   * Fix errors when using parallel builds.  See issue #22.

@@ -1,5 +1,5 @@ name:                inline-c-version:             0.5.3.4+version:             0.5.4.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@@ -24,6 +24,7 @@ library   exposed-modules:     Language.C.Inline                      , Language.C.Inline.Context+                     , Language.C.Inline.HaskellIdentifier                      , Language.C.Inline.Internal                      , Language.C.Inline.Unsafe                      , Language.C.Types@@ -39,6 +40,7 @@                      , cryptohash                      , directory                      , filepath+                     , hashable                      , mtl                      , parsec >= 3                      , parsers@@ -61,6 +63,7 @@   build-depends:       base >=4 && <5                      , ansi-wl-pprint                      , containers+                     , hashable                      , hspec >= 2                      , inline-c                      , parsers@@ -69,6 +72,7 @@                      , regex-posix                      , template-haskell                      , transformers+                     , unordered-containers                      , vector   default-language:    Haskell2010   ghc-options:         -Wall

@@ -24,7 +24,7 @@   , Purity(..)   , convertType   , CArray-  , isTypeName+  , typeNamesFromTypesTable      -- * 'AntiQuoter'   , AntiQuoter(..)@@ -47,9 +47,10 @@ import           Control.Monad.Trans.Maybe (MaybeT, runMaybeT) import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS-import qualified Data.Map as Map import           Data.Int (Int8, Int16, Int32, Int64)+import qualified Data.Map as Map import           Data.Monoid ((<>))+import           Data.Traversable (traverse) import           Data.Typeable (Typeable) import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as VM@@ -59,6 +60,7 @@ import           Foreign.Storable (Storable) import qualified Language.Haskell.TH as TH import qualified Text.Parser.Token as Parser+import qualified Data.HashSet as HashSet  #if __GLASGOW_HASKELL__ < 710 import           Data.Monoid (Monoid(..))@@ -66,6 +68,7 @@  import           Language.C.Inline.FunPtr import qualified Language.C.Types as C+import           Language.C.Inline.HaskellIdentifier  -- | A mapping from 'C.TypeSpecifier's to Haskell types.  Needed both to -- parse C types, and to convert them to Haskell types.@@ -89,12 +92,15 @@ -- Where @XXX@ is the name of the antiquoter and @YYY@ is something -- parseable by the respective 'aqParser'. data AntiQuoter a = AntiQuoter-  { aqParser :: forall m. C.CParser m => m (String, C.Type, a)+  { aqParser :: forall m. C.CParser HaskellIdentifier m => m (C.CIdentifier, C.Type C.CIdentifier, a)     -- ^ Parses the body of the antiquotation, returning a hint for the name to     -- assign to the variable that will replace the anti-quotation, the type of     -- said variable, and some arbitrary data which will then be fed to     -- 'aqMarshaller'.-  , aqMarshaller :: Purity -> TypesTable -> C.Type -> a -> TH.Q (TH.Type, TH.Exp)+    --+    -- The 'C.Type' has 'Void' as an identifier type to make sure that+    -- no names appear in it.+  , aqMarshaller :: Purity -> TypesTable -> C.Type C.CIdentifier -> a -> TH.Q (TH.Type, TH.Exp)     -- ^ Takes the requested purity, the current 'TypesTable', and the     -- type and the body returned by 'aqParser'.     --@@ -229,13 +235,13 @@ convertType   :: Purity   -> TypesTable-  -> C.Type+  -> C.Type C.CIdentifier   -> TH.Q (Maybe TH.Type) convertType purity cTypes = runMaybeT . go   where     goDecl = go . C.parameterDeclarationType -    go :: C.Type -> MaybeT TH.Q TH.Type+    go :: C.Type C.CIdentifier -> MaybeT TH.Q TH.Type     go cTy = case cTy of       C.TypeSpecifier _specs cSpec ->         case Map.lookup cSpec cTypes of@@ -262,21 +268,22 @@     buildArr (hsPar : hsPars) hsRetType =       [t| $(return hsPar) -> $(buildArr hsPars hsRetType) |] -isTypeName :: TypesTable -> C.Identifier -> Bool-isTypeName cTypes id' = Map.member (C.TypeName id') cTypes+typeNamesFromTypesTable :: TypesTable -> C.TypeNames+typeNamesFromTypesTable cTypes = HashSet.fromList+  [ id' | C.TypeName id' <- Map.keys cTypes ]  ------------------------------------------------------------------------ -- Useful contexts -getHsVariable :: String -> String -> TH.ExpQ+getHsVariable :: String -> HaskellIdentifier -> TH.ExpQ getHsVariable err s = do-  mbHsName <- TH.lookupValueName s+  mbHsName <- TH.lookupValueName $ unHaskellIdentifier s   case mbHsName of-    Nothing -> fail $ "Cannot capture Haskell variable " ++ s +++    Nothing -> fail $ "Cannot capture Haskell variable " ++ unHaskellIdentifier s ++                       ", because it's not in scope. (" ++ err ++ ")"     Just hsName -> TH.varE hsName -convertType_ :: String -> Purity -> TypesTable -> C.Type -> TH.Q TH.Type+convertType_ :: String -> Purity -> TypesTable -> C.Type C.CIdentifier -> TH.Q TH.Type convertType_ err purity cTypes cTy = do   mbHsType <- convertType purity cTypes cTy   case mbHsType of@@ -300,15 +307,9 @@   { ctxAntiQuoters = Map.fromList [("fun", SomeAntiQuoter funPtrAntiQuoter)]   } -funPtrAntiQuoter :: AntiQuoter String+funPtrAntiQuoter :: AntiQuoter HaskellIdentifier funPtrAntiQuoter = AntiQuoter-  { aqParser = do-      cTy <- Parser.parens C.parseParameterDeclaration-      case C.parameterDeclarationId cTy of-        Nothing -> fail "Every captured function must be named (funCtx)"-        Just id' -> do-         let s = C.unIdentifier id'-         return (s, C.parameterDeclarationType cTy, s)+  { aqParser = cDeclAqParser   , aqMarshaller = \purity cTypes cTy cId -> do       hsTy <- convertType_ "funCtx" purity cTypes cTy       hsExp <- getHsVariable "funCtx" cId@@ -366,15 +367,9 @@   vecCtxLength = VM.length   vecCtxUnsafeWith = VM.unsafeWith -vecPtrAntiQuoter :: AntiQuoter String+vecPtrAntiQuoter :: AntiQuoter HaskellIdentifier vecPtrAntiQuoter = AntiQuoter-  { aqParser = do-      cTy <- Parser.parens C.parseParameterDeclaration-      case C.parameterDeclarationId cTy of-        Nothing -> fail "Every captured vector must be named (vecCtx)"-        Just id' -> do-         let s = C.unIdentifier id'-         return (s, C.parameterDeclarationType cTy, s)+  { aqParser = cDeclAqParser   , aqMarshaller = \purity cTypes cTy cId -> do       hsTy <- convertType_ "vecCtx" purity cTypes cTy       hsExp <- getHsVariable "vecCtx" cId@@ -382,12 +377,12 @@       return (hsTy, hsExp')   } -vecLenAntiQuoter :: AntiQuoter String+vecLenAntiQuoter :: AntiQuoter HaskellIdentifier vecLenAntiQuoter = AntiQuoter   { aqParser = do-      cId <- C.parseIdentifier-      let s = C.unIdentifier cId-      return (s, C.TypeSpecifier mempty (C.Long C.Signed), s)+      hId <- C.parseIdentifier+      let cId = mangleHaskellIdentifier hId+      return (cId, C.TypeSpecifier mempty (C.Long C.Signed), hId)   , aqMarshaller = \_purity _cTypes cTy cId -> do       case cTy of         C.TypeSpecifier _ (C.Long C.Signed) -> do@@ -413,12 +408,12 @@       ]   } -bsPtrAntiQuoter :: AntiQuoter String+bsPtrAntiQuoter :: AntiQuoter HaskellIdentifier bsPtrAntiQuoter = AntiQuoter   { aqParser = do-      cId <- C.parseIdentifier-      let s = C.unIdentifier cId-      return (s, C.Ptr [] (C.TypeSpecifier mempty (C.Char Nothing)), s)+      hId <- C.parseIdentifier+      let cId = mangleHaskellIdentifier hId+      return (cId, C.Ptr [] (C.TypeSpecifier mempty (C.Char Nothing)), hId)   , aqMarshaller = \_purity _cTypes cTy cId -> do       case cTy of         C.Ptr _ (C.TypeSpecifier _ (C.Char Nothing)) -> do@@ -430,12 +425,12 @@           fail "impossible: got type different from `unsigned char' (bsCtx)"   } -bsLenAntiQuoter :: AntiQuoter String+bsLenAntiQuoter :: AntiQuoter HaskellIdentifier bsLenAntiQuoter = AntiQuoter   { aqParser = do-      cId <- C.parseIdentifier-      let s = C.unIdentifier cId-      return (s, C.TypeSpecifier mempty (C.Long C.Signed), s)+      hId <- C.parseIdentifier+      let cId = mangleHaskellIdentifier hId+      return (cId, C.TypeSpecifier mempty (C.Long C.Signed), hId)   , aqMarshaller = \_purity _cTypes cTy cId -> do       case cTy of         C.TypeSpecifier _ (C.Long C.Signed) -> do@@ -447,3 +442,27 @@         _ -> do           fail "impossible: got type different from `long' (bsCtx)"   }++-- Utils+------------------------------------------------------------------------++cDeclAqParser+  :: C.CParser HaskellIdentifier m+  => m (C.CIdentifier, C.Type C.CIdentifier, HaskellIdentifier)+cDeclAqParser = do+  cTy <- Parser.parens C.parseParameterDeclaration+  case C.parameterDeclarationId cTy of+    Nothing -> fail "Every captured function must be named (funCtx)"+    Just hId -> do+     let cId = mangleHaskellIdentifier hId+     cTy' <- deHaskellifyCType $ C.parameterDeclarationType cTy+     return (cId, cTy', hId)++deHaskellifyCType+  :: C.CParser HaskellIdentifier m+  => C.Type HaskellIdentifier -> m (C.Type C.CIdentifier)+deHaskellifyCType = traverse $ \hId -> do+  case C.cIdentifierFromString (unHaskellIdentifier hId) of+    Left err -> fail $ "Illegal Haskell identifier " ++ unHaskellIdentifier hId +++                       " in C type:\n" ++ err+    Right x -> return x

@@ -0,0 +1,166 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Language.C.Inline.HaskellIdentifier+  ( HaskellIdentifier+  , unHaskellIdentifier+  , haskellIdentifierFromString+  , haskellCParserContext+  , parseHaskellIdentifier+  , mangleHaskellIdentifier+  ) where++import           Control.Applicative ((<*), (<$>))+import           Control.Applicative ((<|>), (<*>))+import           Control.Monad (when, msum, void)+import           Data.Char (ord)+import qualified Data.HashSet as HashSet+import           Data.Hashable (Hashable)+import           Data.List (intercalate, partition, intersperse)+import           Data.Monoid ((<>))+import           Data.String (IsString(..))+import           Data.Typeable (Typeable)+import           Numeric (showHex)+import qualified Test.QuickCheck as QC+import           Text.Parser.Char (upper, lower, digit, char)+import           Text.Parser.Combinators (many, eof, try, unexpected, (<?>))+import           Text.Parser.Token (IdentifierStyle(..), highlight, TokenParsing)+import qualified Text.Parser.Token.Highlight as Highlight+import qualified Text.PrettyPrint.ANSI.Leijen as PP++import qualified Language.C.Types.Parse as C++-- | A possibly qualified Haskell identifier.+newtype HaskellIdentifier = HaskellIdentifier {unHaskellIdentifier :: String}+  deriving (Typeable, Eq, Ord, Show, Hashable)++instance IsString HaskellIdentifier where+  fromString s =+    case haskellIdentifierFromString 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 =+  case C.runCParser cpc "haskellIdentifierFromString" s (parseHaskellIdentifier <* eof) of+    Left err -> Left $ show err+    Right x -> Right x+  where+    cpc = haskellCParserContext HashSet.empty++haskellCParserContext :: C.TypeNames -> C.CParserContext HaskellIdentifier+haskellCParserContext typeNames = C.CParserContext+  { C.cpcTypeNames = typeNames+  , C.cpcParseIdent = parseHaskellIdentifier+  , C.cpcIdentName = "Haskell identifier"+  , C.cpcIdentToString = unHaskellIdentifier+  }++-- | See+-- <https://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-160002.2>.+haskellIdentStyle :: C.CParser i m => IdentifierStyle m+haskellIdentStyle = IdentifierStyle+  { _styleName = "Haskell identifier"+  , _styleStart = small+  , _styleLetter = small <|> large <|> digit <|> char '\''+  , _styleReserved = haskellReservedWords+  , _styleHighlight = Highlight.Identifier+  , _styleReservedHighlight = Highlight.ReservedIdentifier+  }+  where+    small = lower <|> char '_'+    large = upper++-- We disallow both Haskell reserved words and C reserved words.+haskellReservedWords :: HashSet.HashSet String+haskellReservedWords = C.cReservedWords <> HashSet.fromList+  [ "case", "class", "data", "default", "deriving", "do", "else"+  , "foreign", "if", "import", "in", "infix", "infixl"+  , "infixr", "instance", "let", "module", "newtype", "of"+  , "then", "type", "where"+  ]++-- | See+-- <https://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-160002.2>.+parseHaskellIdentifier :: forall i m. C.CParser i m => m HaskellIdentifier+parseHaskellIdentifier = do+  segments <- go+  return $ HaskellIdentifier $ intercalate "." segments+  where+    small = lower <|> char '_'+    large = upper++    conid :: m String+    conid = try $ highlight Highlight.Identifier $+      ((:) <$> large <*> many (small <|> large <|> digit <|> char '\'')) <?> "Haskell constructor"++    varid :: m String+    varid = identNoLex haskellIdentStyle++    go = msum+      [ do con <- conid+           msum+             [ do void $ char '.'+                  (con :) <$> go+             , return [con]+             ]+      , do var <- varid+           return [var]+      ]++-- | Mangles an 'HaskellIdentifier' to produce a valid 'C.CIdentifier'+-- which still sort of resembles the 'HaskellIdentifier'.+mangleHaskellIdentifier :: HaskellIdentifier -> C.CIdentifier+mangleHaskellIdentifier (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+    Left err -> error $ "mangleHaskellIdentifier: produced bad C identifier\n" ++ err+    Right x -> x+  where+    (valid, invalid) = partition (`elem` C.cIdentLetter) hs++    mangled = concat $ intersperse "_" $ map (`showHex` "") $ map ord invalid++-- 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)+  when (HashSet.member name (_styleReserved s)) $ unexpected $ "reserved " ++ _styleName s ++ " " ++ show name+  return name++-- Arbitrary instance+------------------------------------------------------------------------++instance QC.Arbitrary HaskellIdentifier where+  arbitrary = do+    modIds <- QC.listOf arbitraryModId+    id_ <- QC.oneof [arbitraryConId, arbitraryVarId]+    if null modIds && HashSet.member id_ haskellReservedWords+      then QC.arbitrary+      else return $ HaskellIdentifier $ intercalate "." $ modIds ++ [id_]+    where+      arbitraryModId = arbitraryConId++      arbitraryConId =+        ((:) <$> QC.elements large <*> QC.listOf (QC.elements (small ++ large ++ digit' ++ ['\''])))++      arbitraryVarId =+        ((:) <$> QC.elements small <*> QC.listOf (QC.elements (small ++ large ++ digit' ++ ['\''])))++      -- We currently do not generate unicode identifiers.+      large = ['A'..'Z']+      small = ['a'..'z'] ++ ['_']+      digit' = ['0'..'9']

@@ -58,6 +58,7 @@ import           Data.Foldable (forM_) import qualified Data.Map as Map import           Data.Maybe (fromMaybe)+import           Data.Traversable (for) import           Data.Typeable (Typeable, cast) import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as TH@@ -75,9 +76,10 @@ import           Text.PrettyPrint.ANSI.Leijen ((<+>)) import qualified Text.PrettyPrint.ANSI.Leijen as PP -import qualified Language.C.Types as C import           Language.C.Inline.Context import           Language.C.Inline.FunPtr+import           Language.C.Inline.HaskellIdentifier+import qualified Language.C.Types as C  data ModuleState = ModuleState   { msContext :: Context@@ -276,9 +278,9 @@   -- ^ Safety of the foreign call   -> TH.TypeQ   -- ^ Type of the foreign call-  -> C.Type+  -> C.Type C.CIdentifier   -- ^ Return type of the C expr-  -> [(C.Identifier, C.Type)]+  -> [(C.CIdentifier, C.Type C.CIdentifier)]   -- ^ Parameters of the C expr   -> String   -- ^ The C expression@@ -308,9 +310,9 @@   -- ^ Safety of the foreign call   -> TH.TypeQ   -- ^ Type of the foreign call-  -> C.Type+  -> C.Type C.CIdentifier   -- ^ Return type of the C expr-  -> [(C.Identifier, C.Type)]+  -> [(C.CIdentifier, C.Type C.CIdentifier)]   -- ^ Parameters of the C expr   -> String   -- ^ The C items@@ -319,7 +321,11 @@   let mkParam (id', paramTy) = C.ParameterDeclaration (Just id') paramTy   let proto = C.Proto cRetType (map mkParam cParams)   funName <- uniqueCName $ show proto ++ cItems-  let decl = C.ParameterDeclaration (Just (C.Identifier funName)) proto+  cFunName <- case C.cIdentifierFromString funName of+    Left err -> fail $ "inlineItems: impossible, generated bad C identifier " +++                       "funName:\n" ++ err+    Right x -> return x+  let decl = C.ParameterDeclaration (Just cFunName) proto   let defs =         prettyOneLine decl ++ " {\n" ++         cItems ++ "\n}\n"@@ -334,13 +340,13 @@ -- Parsing  runParserInQ-  :: String -> C.IsTypeName -> (forall m. C.CParser m => m a) -> TH.Q a-runParserInQ s isTypeName' p = do+  :: String -> C.TypeNames -> (forall m. C.CParser HaskellIdentifier m => m a) -> TH.Q a+runParserInQ s typeNames' p = do   loc <- TH.location   let (line, col) = TH.loc_start loc   let parsecLoc = Parsec.newPos (TH.loc_filename loc) line col   let p' = lift (Parsec.setPosition parsecLoc) *> p <* lift Parser.eof-  case C.runCParser isTypeName' (TH.loc_filename loc) s p' of+  case C.runCParser (haskellCParserContext typeNames') (TH.loc_filename loc) s p' of     Left err -> do       -- TODO consider prefixing with "error while parsing C" or similar       fail $ show err@@ -364,49 +370,43 @@ fromSomeEq (SomeEq x) = cast x  data ParameterType-  = Plain String                -- The name of the captured variable+  = Plain HaskellIdentifier                -- The name of the captured variable   | AntiQuote AntiQuoterId SomeEq   deriving (Show, Eq)  data ParseTypedC = ParseTypedC-  { ptcReturnType :: C.Type-  , ptcParameters :: [(C.Identifier, C.Type, ParameterType)]+  { ptcReturnType :: C.Type C.CIdentifier+  , ptcParameters :: [(C.CIdentifier, C.Type C.CIdentifier, ParameterType)]   , ptcBody :: String   } +-- To parse C declarations, we're faced with a bit of a problem: we want+-- to parse the anti-quotations so that Haskell identifiers are+-- accepted, but we want them to appear only as the root of+-- declarations.  For this reason, we parse allowing Haskell identifiers+-- everywhere, and then we "purge" Haskell identifiers everywhere but at+-- the root. parseTypedC-  :: forall m. C.CParser m+  :: forall m. C.CParser HaskellIdentifier m   => AntiQuoters -> m ParseTypedC   -- ^ Returns the return type, the captured variables, and the body. parseTypedC antiQs = do   -- Parse return type (consume spaces first)   Parser.spaces-  cRetType <- C.parseType+  cRetType <- purgeHaskellIdentifiers =<< C.parseType   -- Parse the body   void $ Parser.char '{'   (cParams, cBody) <- evalStateT parseBody 0   return $ ParseTypedC cRetType cParams cBody   where-    parseBody :: StateT Int m ([(C.Identifier, C.Type, ParameterType)], String)+    parseBody+      :: StateT Int m ([(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String)     parseBody = do       -- Note that this code does not use "lexing" combinators (apart       -- when appropriate) because we want to make sure to preserve       -- whitespace after we substitute things.       s <- Parser.manyTill Parser.anyChar $            Parser.lookAhead (Parser.char '}' <|> Parser.char '$')-      let parseEscapedDollar = do-            void $ Parser.char '$'-            return ([], "$")-      let parseTypedCapture = do-            void $ Parser.symbolic '('-            decl <- C.parseParameterDeclaration-            s' <- case C.parameterDeclarationId decl of-              Nothing -> fail $ pretty80 $-                "Un-named captured variable in decl" <+> PP.pretty decl-              Just id' -> return $ C.unIdentifier id'-            id' <- freshId s'-            void $ Parser.char ')'-            return ([(id', C.parameterDeclarationType decl, Plain s')], C.unIdentifier id')       (decls, s') <- msum         [ do Parser.try $ do -- Try because we might fail to parse the 'eof'                 -- 'symbolic' because we want to consume whitespace@@ -424,20 +424,56 @@       return (decls, s ++ s')       where -    parseAntiQuote :: StateT Int m ([(C.Identifier, C.Type, ParameterType)], String)+    parseAntiQuote+      :: StateT Int m ([(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String)     parseAntiQuote = msum       [ do void $ Parser.try (Parser.string $ antiQId ++ ":") Parser.<?> "anti quoter id"            (s, cTy, x) <- aqParser antiQ            id' <- freshId s-           return ([(id', cTy, AntiQuote antiQId (toSomeEq x))], C.unIdentifier id')+           return ([(id', cTy, AntiQuote antiQId (toSomeEq x))], C.unCIdentifier id')       | (antiQId, SomeAntiQuoter antiQ) <- Map.toList antiQs       ] +    parseEscapedDollar :: StateT Int m ([a], String)+    parseEscapedDollar = do+      void $ Parser.char '$'+      return ([], "$")++    parseTypedCapture+      :: StateT Int m ([(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String)+    parseTypedCapture = do+      void $ Parser.symbolic '('+      decl <- C.parseParameterDeclaration+      declType <- purgeHaskellIdentifiers $ C.parameterDeclarationType decl+      -- Purge the declaration type of all the Haskell identifiers.+      hId <- case C.parameterDeclarationId decl of+        Nothing -> fail $ pretty80 $+          "Un-named captured variable in decl" <+> PP.pretty decl+        Just hId -> return hId+      id' <- freshId $ mangleHaskellIdentifier hId+      void $ Parser.char ')'+      return ([(id', declType, Plain hId)], C.unCIdentifier id')+     freshId s = do       c <- get       put $ c + 1-      return $ C.Identifier $ s ++ "_inline_c_" ++ show c+      case C.cIdentifierFromString (C.unCIdentifier s ++ "_inline_c_" ++ show c) of+        Left _err -> error "freshId: The impossible happened"+        Right x -> return x +    -- The @m@ is polymorphic because we use this both for the plain+    -- parser and the StateT parser we use above.  We only need 'fail'.+    purgeHaskellIdentifiers+      :: forall n. (Applicative n, Monad n)+      => C.Type HaskellIdentifier -> n (C.Type C.CIdentifier)+    purgeHaskellIdentifiers cTy = for cTy $ \hsIdent -> do+      let hsIdentS = unHaskellIdentifier hsIdent+      case C.cIdentifierFromString 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+        Right cIdent -> return cIdent+ quoteCode   :: (String -> TH.ExpQ)   -- ^ The parser@@ -451,23 +487,23 @@  genericQuote   :: Purity-  -> (TH.TypeQ -> C.Type -> [(C.Identifier, C.Type)] -> String -> TH.ExpQ)-  -- ^ Function taking that something and building an expression, see-  -- 'inlineExp' for other args.+  -> (TH.TypeQ -> C.Type C.CIdentifier -> [(C.CIdentifier, C.Type C.CIdentifier)] -> String -> TH.ExpQ)+  -- ^ Function building an Haskell expression, see 'inlineExp' for+  -- guidance on the other args.   -> TH.QuasiQuoter genericQuote purity build = quoteCode $ \s -> do     ctx <- getContext     ParseTypedC cType cParams cExp <--      runParserInQ s (isTypeName (ctxTypesTable ctx)) $ parseTypedC $ ctxAntiQuoters ctx+      runParserInQ s (typeNamesFromTypesTable (ctxTypesTable ctx)) $ parseTypedC $ ctxAntiQuoters ctx     hsType <- cToHs ctx cType     hsParams <- forM cParams $ \(_cId, cTy, parTy) -> do       case parTy of         Plain s' -> do           hsTy <- cToHs ctx cTy-          mbHsName <- TH.lookupValueName s'+          mbHsName <- TH.lookupValueName $ unHaskellIdentifier s'           hsExp <- case mbHsName of             Nothing -> do-              fail $ "Cannot capture Haskell variable " ++ s' +++              fail $ "Cannot capture Haskell variable " ++ unHaskellIdentifier s' ++                      ", because it's not in scope. (genericQuote)"             Just hsName -> do               hsExp <- TH.varE hsName@@ -492,7 +528,7 @@       Pure -> [| unsafePerformIO $(return ioCall) |]       IO -> return ioCall   where-    cToHs :: Context -> C.Type -> TH.TypeQ+    cToHs :: Context -> C.Type C.CIdentifier -> TH.TypeQ     cToHs ctx cTy = do       mbHsTy <- convertType purity (ctxTypesTable ctx) cTy       case mbHsTy of

@@ -1,12 +1,15 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}  -- | Views of C datatypes. While "Language.C.Types.Parse" defines datatypes for@@ -21,7 +24,9 @@  module Language.C.Types   ( -- * Types-    P.Identifier(..)+    P.CIdentifier+  , P.unCIdentifier+  , P.cIdentifierFromString   , P.StorageClassSpecifier(..)   , P.TypeQualifier(..)   , P.FunctionSpecifier(..)@@ -33,8 +38,10 @@   , ParameterDeclaration(..)      -- * Parsing-  , P.IsTypeName+  , P.TypeNames   , P.CParser+  , P.CParserContext+  , P.cCParserContext   , P.runCParser   , P.quickCParser   , P.quickCParser_@@ -56,9 +63,11 @@ import           Control.Arrow (second) import           Control.Monad (when, unless, forM_) import           Control.Monad.State (execState, modify)+import           Data.Foldable (Foldable) import           Data.List (partition) import           Data.Maybe (fromMaybe) import           Data.Monoid ((<>))+import           Data.Traversable (Traversable) import           Data.Typeable (Typeable) import           Text.PrettyPrint.ANSI.Leijen ((</>), (<+>)) import qualified Text.PrettyPrint.ANSI.Leijen as PP@@ -83,9 +92,9 @@   | Float   | Double   | LDouble-  | TypeName P.Identifier-  | Struct P.Identifier-  | Enum P.Identifier+  | TypeName P.CIdentifier+  | Struct P.CIdentifier+  | Enum P.CIdentifier   deriving (Typeable, Show, Eq, Ord)  data Specifiers = Specifiers@@ -100,22 +109,22 @@   mappend (Specifiers x1 y1 z1) (Specifiers x2 y2 z2) =     Specifiers (x1 ++ x2) (y1 ++ y2) (z1 ++ z2) -data Type+data Type i   = TypeSpecifier Specifiers TypeSpecifier-  | Ptr [P.TypeQualifier] Type-  | Array P.ArrayType Type-  | Proto Type [ParameterDeclaration]-  deriving (Typeable, Show, Eq)+  | Ptr [P.TypeQualifier] (Type i)+  | Array (P.ArrayType i) (Type i)+  | Proto (Type i) [ParameterDeclaration i]+  deriving (Typeable, Show, Eq, Functor, Foldable, Traversable)  data Sign   = Signed   | Unsigned   deriving (Typeable, Show, Eq, Ord) -data ParameterDeclaration = ParameterDeclaration-  { parameterDeclarationId :: Maybe P.Identifier-  , parameterDeclarationType :: Type-  } deriving (Typeable, Show, Eq)+data ParameterDeclaration i = ParameterDeclaration+  { parameterDeclarationId :: Maybe i+  , parameterDeclarationType :: (Type i)+  } deriving (Typeable, Show, Eq, Functor, Foldable, Traversable)  ------------------------------------------------------------------------ -- Conversion@@ -130,15 +139,16 @@ failConversion = Left  untangleParameterDeclaration-  :: P.ParameterDeclaration -> Either UntangleErr ParameterDeclaration+  :: P.ParameterDeclaration i -> Either UntangleErr (ParameterDeclaration i) untangleParameterDeclaration P.ParameterDeclaration{..} = do   (specs, tySpec) <- untangleDeclarationSpecifiers parameterDeclarationSpecifiers   let baseTy = TypeSpecifier specs tySpec   (mbS, ty) <- case parameterDeclarationDeclarator of-    Left decltor -> do+    P.IsDeclarator decltor -> do       (s, ty) <- untangleDeclarator baseTy decltor       return (Just s, ty)-    Right decltor -> (Nothing, ) <$> untangleAbstractDeclarator baseTy decltor+    P.IsAbstractDeclarator decltor ->+      (Nothing, ) <$> untangleAbstractDeclarator baseTy decltor   return $ ParameterDeclaration mbS ty  untangleDeclarationSpecifiers@@ -220,14 +230,14 @@   return (Specifiers pStorage pTyQuals pFunSpecs, tySpec)  untangleDeclarator-  :: Type -> P.Declarator -> Either UntangleErr (P.Identifier, Type)+  :: forall i. Type i -> P.Declarator i -> Either UntangleErr (i, Type i) untangleDeclarator ty0 (P.Declarator ptrs0 directDecltor) = go ty0 ptrs0   where-    go :: Type -> [P.Pointer] -> Either UntangleErr (P.Identifier, Type)+    go :: Type i -> [P.Pointer] -> Either UntangleErr (i, Type i)     go ty [] = goDirect ty directDecltor     go ty (P.Pointer quals : ptrs) = go (Ptr quals ty) ptrs -    goDirect :: Type -> P.DirectDeclarator -> Either UntangleErr (P.Identifier, Type)+    goDirect :: Type i -> P.DirectDeclarator i -> Either UntangleErr (i, Type i)     goDirect ty direct0 = case direct0 of       P.DeclaratorRoot s -> return (s, ty)       P.ArrayOrProto direct (P.Array arrayType) ->@@ -239,17 +249,17 @@         untangleDeclarator ty decltor  untangleAbstractDeclarator-  :: Type -> P.AbstractDeclarator -> Either UntangleErr Type+  :: forall i. Type i -> P.AbstractDeclarator i -> Either UntangleErr (Type i) untangleAbstractDeclarator ty0 (P.AbstractDeclarator ptrs0 mbDirectDecltor) =   go ty0 ptrs0   where-    go :: Type -> [P.Pointer] -> Either UntangleErr Type+    go :: Type i -> [P.Pointer] -> Either UntangleErr (Type i)     go ty [] = case mbDirectDecltor of       Nothing -> return ty       Just directDecltor -> goDirect ty directDecltor     go ty (P.Pointer quals : ptrs) = go (Ptr quals ty) ptrs -    goDirect :: Type -> P.DirectAbstractDeclarator -> Either UntangleErr Type+    goDirect :: Type i -> P.DirectAbstractDeclarator i -> Either UntangleErr (Type i)     goDirect ty direct0 = case direct0 of       P.ArrayOrProtoThere direct (P.Array arrayType) ->         goDirect (Array arrayType ty) direct@@ -267,15 +277,16 @@ ------------------------------------------------------------------------ -- Tangling -tangleParameterDeclaration :: ParameterDeclaration -> P.ParameterDeclaration+tangleParameterDeclaration+  :: forall i. ParameterDeclaration i -> P.ParameterDeclaration i tangleParameterDeclaration (ParameterDeclaration mbId ty00) =     uncurry P.ParameterDeclaration $ case mbId of-      Nothing -> second Right $ goAbstractDirect ty00 Nothing-      Just id' -> second Left $ goConcreteDirect ty00 $ P.DeclaratorRoot id'+      Nothing -> second P.IsAbstractDeclarator $ goAbstractDirect ty00 Nothing+      Just id' -> second P.IsDeclarator $ goConcreteDirect ty00 $ P.DeclaratorRoot id'   where     goAbstractDirect-      :: Type -> Maybe P.DirectAbstractDeclarator-      -> ([P.DeclarationSpecifier], P.AbstractDeclarator)+      :: Type i -> Maybe (P.DirectAbstractDeclarator i)+      -> ([P.DeclarationSpecifier], P.AbstractDeclarator i)     goAbstractDirect ty0 mbDirect = case ty0 of       TypeSpecifier specifiers tySpec ->         let declSpecs = tangleTypeSpecifier specifiers tySpec@@ -298,8 +309,8 @@             goAbstractDirect ty $ Just $ P.ArrayOrProtoThere decltor proto      goAbstract-      :: Type -> [P.Pointer] -> Maybe P.DirectAbstractDeclarator-      -> ([P.DeclarationSpecifier], P.AbstractDeclarator)+      :: Type i -> [P.Pointer] -> Maybe (P.DirectAbstractDeclarator i)+      -> ([P.DeclarationSpecifier], P.AbstractDeclarator i)     goAbstract ty0 ptrs mbDirect = case ty0 of       TypeSpecifier specifiers tySpec ->         let declSpecs = tangleTypeSpecifier specifiers tySpec@@ -314,8 +325,8 @@           P.AbstractDeclarator ptrs mbDirect      goConcreteDirect-      :: Type -> P.DirectDeclarator-      -> ([P.DeclarationSpecifier], P.Declarator)+      :: Type i -> P.DirectDeclarator i+      -> ([P.DeclarationSpecifier], P.Declarator i)     goConcreteDirect ty0 direct = case ty0 of       TypeSpecifier specifiers tySpec ->         let declSpecs = tangleTypeSpecifier specifiers tySpec@@ -329,8 +340,8 @@           P.Proto $ map tangleParameterDeclaration params      goConcrete-      :: Type -> [P.Pointer] -> P.DirectDeclarator-      -> ([P.DeclarationSpecifier], P.Declarator)+      :: Type i -> [P.Pointer] -> P.DirectDeclarator i+      -> ([P.DeclarationSpecifier], P.Declarator i)     goConcrete ty0 ptrs direct = case ty0 of       TypeSpecifier specifiers tySpec ->         let declSpecs = tangleTypeSpecifier specifiers tySpec@@ -371,14 +382,14 @@ ------------------------------------------------------------------------ -- To english -describeParameterDeclaration :: ParameterDeclaration -> PP.Doc+describeParameterDeclaration :: PP.Pretty i => ParameterDeclaration i -> PP.Doc describeParameterDeclaration (ParameterDeclaration mbId ty) =   let idDoc = case mbId of         Nothing -> ""         Just id' -> PP.pretty id' <+> "is a "   in idDoc <> describeType ty -describeType :: Type -> PP.Doc+describeType :: PP.Pretty i => Type i -> PP.Doc describeType ty0 = case ty0 of   TypeSpecifier specs tySpec -> engSpecs specs <> PP.pretty tySpec   Ptr quals ty -> engQuals quals <> "ptr to" <+> describeType ty@@ -412,25 +423,29 @@ -- Convenient parsing  untangleParameterDeclaration'-  :: P.CParser m => P.ParameterDeclaration -> m ParameterDeclaration+  :: (P.CParser i m, PP.Pretty i)+  => P.ParameterDeclaration i -> m (ParameterDeclaration i) untangleParameterDeclaration' pDecl =   case untangleParameterDeclaration pDecl of     Left err -> fail $ pretty80 $       "Error while parsing declaration:" </> PP.pretty err </> PP.pretty pDecl     Right x -> return x -parseParameterDeclaration :: P.CParser m => m ParameterDeclaration+parseParameterDeclaration+  :: (P.CParser i m, PP.Pretty i) => m (ParameterDeclaration i) parseParameterDeclaration =   untangleParameterDeclaration' =<< P.parameter_declaration -parseParameterList :: P.CParser m => m [ParameterDeclaration]+parseParameterList+  :: (P.CParser i m, PP.Pretty i)+  => m [ParameterDeclaration i] parseParameterList =   mapM untangleParameterDeclaration' =<< P.parameter_list -parseIdentifier :: P.CParser m => m P.Identifier+parseIdentifier :: P.CParser i m => m i parseIdentifier = P.identifier_no_lex -parseType :: P.CParser m => m Type+parseType :: (P.CParser i m, PP.Pretty i) => m (Type i) parseType = parameterDeclarationType <$> parseParameterDeclaration  ------------------------------------------------------------------------@@ -466,10 +481,10 @@     NoDataTypes specs ->       "No data types in " </> PP.prettyList specs -instance PP.Pretty ParameterDeclaration where+instance PP.Pretty i => PP.Pretty (ParameterDeclaration i) where   pretty = PP.pretty . tangleParameterDeclaration -instance PP.Pretty Type where+instance PP.Pretty i => PP.Pretty (Type i) where   pretty ty =     PP.pretty $ tangleParameterDeclaration $ ParameterDeclaration Nothing ty 

@@ -1,7 +1,11 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}@@ -24,16 +28,23 @@ -- @'parameter_declaration'@.  module Language.C.Types.Parse-  ( -- * Parser type-    CParser-  , IsTypeName+  ( -- * Parser configuration+    TypeNames+  , CParserContext(..)+    -- ** Default configuration+  , CIdentifier+  , unCIdentifier+  , cIdentifierFromString+  , cCParserContext++    -- * Parser type+  , CParser   , runCParser   , quickCParser   , quickCParser_      -- * Types and parsing-  , Identifier(..)-  , identifier+  -- , identifier   , identifier_no_lex   , DeclarationSpecifier(..)   , declaration_specifiers@@ -56,6 +67,7 @@   , Pointer(..)   , pointer   , ParameterDeclaration(..)+  , DeclaratorOrAbstractDeclarator(..)   , parameter_declaration   , parameter_list   , AbstractDeclarator(..)@@ -67,18 +79,24 @@     -- $yacc      -- * Testing utilities+  , cIdentStart+  , cIdentLetter+  , cReservedWords   , ParameterDeclarationWithTypeNames(..)+  , arbitraryParameterDeclarationWithTypeNames   ) where  import           Control.Applicative import           Control.Monad (msum, void, MonadPlus, unless, when)-import           Control.Monad.Reader (MonadReader, ask, runReaderT, ReaderT)+import           Control.Monad.Reader (MonadReader, runReaderT, ReaderT, asks, ask)+import           Data.Foldable (Foldable) import           Data.Functor.Identity (Identity) import qualified Data.HashSet as HashSet+import           Data.Hashable (Hashable) import           Data.Maybe (mapMaybe) import           Data.Monoid ((<>))-import qualified Data.Set as Set import           Data.String (IsString(..))+import           Data.Traversable (Traversable) import           Data.Typeable (Typeable) import qualified Test.QuickCheck as QC import qualified Text.Parsec as Parsec@@ -91,73 +109,115 @@ import qualified Text.PrettyPrint.ANSI.Leijen as PP  --------------------------------------------------------------------------- Parser+-- Config --- | Function used to determine whether an 'C.Id' is a type name.-type IsTypeName = Identifier -> Bool+-- | A collection of named types (typedefs)+type TypeNames = HashSet.HashSet CIdentifier +data CParserContext i = CParserContext+  { cpcIdentName :: String+  , cpcTypeNames :: TypeNames+    -- ^ Function used to determine whether an identifier is a type name.+  , cpcParseIdent :: forall m. CParser i m => m i+    -- ^ Parses an identifier, *without consuming whitespace afterwards*.+  , cpcIdentToString :: i -> String+  }++-- | A type for C identifiers.+newtype CIdentifier = CIdentifier {unCIdentifier :: String}+  deriving (Typeable, Eq, Ord, Show, Hashable)++cIdentifierFromString :: String -> Either String CIdentifier+cIdentifierFromString 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+    Left err -> Left $ show err+    Right x -> Right $ CIdentifier x++instance IsString CIdentifier where+  fromString s =+    case cIdentifierFromString s of+      Left err -> error $ "CIdentifier fromString: invalid string " ++ show s ++ "\n" ++ err+      Right x -> x++cCParserContext :: TypeNames -> CParserContext CIdentifier+cCParserContext typeNames = CParserContext+  { cpcTypeNames = typeNames+  , cpcParseIdent = cidentifier_no_lex+  , cpcIdentToString = unCIdentifier+  , cpcIdentName = "C identifier"+  }++------------------------------------------------------------------------+-- Parser+ -- | All the parsing is done using the type classes provided by the -- @parsers@ package. You can use the parsing routines with any of the parsers -- that implement the classes, such as @parsec@ or @trifecta@. ----- The 'MonadReader' with 'IsTypeName' is required for parsing C, see--- <http://en.wikipedia.org/wiki/The_lexer_hack>.-type CParser m = (Monad m, Functor m, Applicative m, MonadPlus m, Parsing m, CharParsing m, TokenParsing m, LookAheadParsing m, MonadReader IsTypeName m)+-- We parametrize the parsing by the type of the variable identifiers,+-- @i@.  We do so because we use this parser to implement anti-quoters+-- referring to Haskell variables, and thus we need to parse Haskell+-- identifiers in certain positions.+type CParser i m =+  ( Monad m+  , Functor m+  , Applicative m+  , MonadPlus m+  , Parsing m+  , CharParsing m+  , TokenParsing m+  , LookAheadParsing m+  , MonadReader (CParserContext i) m+  , Hashable i+  )  -- | Runs a @'CParser'@ using @parsec@. runCParser   :: Parsec.Stream s Identity Char-  => IsTypeName-  -- ^ Function determining if an identifier is a type name.+  => CParserContext i   -> String   -- ^ Source name.   -> s   -- ^ String to parse.-  -> (ReaderT IsTypeName (Parsec.Parsec s ()) a)-  -- ^ Parser.  Anything with type @forall m. CParser m => m a@ is a+  -> (ReaderT (CParserContext i) (Parsec.Parsec s ()) a)+  -- ^ Parser.  Anything with type @forall m. CParser i m => m a@ is a   -- valid argument.   -> Either Parsec.ParseError a-runCParser isTypeName fn s p = Parsec.parse (runReaderT p isTypeName) fn s+runCParser typeNames fn s p = Parsec.parse (runReaderT p typeNames) fn s  -- | Useful for quick testing.  Uses @\"quickCParser\"@ as source name, and throws -- an 'error' if parsing fails. quickCParser-  :: IsTypeName-  -- ^ Function determining if an identifier is a type name.+  :: CParserContext i   -> String   -- ^ String to parse.-  -> (ReaderT IsTypeName (Parsec.Parsec String ()) a)-  -- ^ Parser.  Anything with type @forall m. CParser m => m a@ is a+  -> (ReaderT (CParserContext i) (Parsec.Parsec String ()) a)+  -- ^ Parser.  Anything with type @forall m. CParser i m => m a@ is a   -- valid argument.   -> a-quickCParser isTypeName s p = case runCParser isTypeName "quickCParser" s p of+quickCParser typeNames s p = case runCParser typeNames "quickCParser" s p of   Left err -> error $ "quickCParser: " ++ show err   Right x -> x --- | Like 'quickCParser', but uses @'const' 'False'@ as 'IsTypeName'.+-- | Like 'quickCParser', but uses @'cCParserContext' ('const' 'False')@ as+-- 'CParserContext'. quickCParser_   :: String   -- ^ String to parse.-  -> (ReaderT IsTypeName (Parsec.Parsec String ()) a)-  -- ^ Parser.  Anything with type @forall m. CParser m => m a@ is a+  -> (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 (const False)--newtype Identifier = Identifier {unIdentifier :: String}-  deriving (Typeable, Eq, Ord, Show)--instance IsString Identifier where-  fromString s =-    case runCParser (const False) "fromString" s (identifier_no_lex <* eof) of-      Left _err -> error $ "Identifier fromString: invalid string " ++ show s-      Right x -> x--identLetter :: CParser m => m Char-identLetter = oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['_']+quickCParser_ = quickCParser (cCParserContext HashSet.empty) -reservedWords :: HashSet.HashSet String-reservedWords = HashSet.fromList+cReservedWords :: HashSet.HashSet String+cReservedWords = HashSet.fromList   [ "auto", "else", "long", "switch"   , "break", "enum", "register", "typedef"   , "case", "extern", "return", "union"@@ -168,12 +228,18 @@   , "do", "int", "struct", "double"   ] -identStyle :: CParser m => IdentifierStyle m-identStyle = IdentifierStyle+cIdentStart :: [Char]+cIdentStart = ['a'..'z'] ++ ['A'..'Z'] ++ ['_']++cIdentLetter :: [Char]+cIdentLetter = ['a'..'z'] ++ ['A'..'Z'] ++ ['_'] ++ ['0'..'9']++cIdentStyle :: (TokenParsing m, Monad m) => IdentifierStyle m+cIdentStyle = IdentifierStyle   { _styleName = "C identifier"-  , _styleStart = identLetter-  , _styleLetter = identLetter <|> digit-  , _styleReserved = reservedWords+  , _styleStart = oneOf cIdentStart+  , _styleLetter = oneOf cIdentLetter+  , _styleReserved = cReservedWords   , _styleHighlight = Highlight.Identifier   , _styleReservedHighlight = Highlight.ReservedIdentifier   }@@ -185,7 +251,7 @@   | FunctionSpecifier FunctionSpecifier   deriving (Typeable, Eq, Show) -declaration_specifiers :: forall m. CParser m => m [DeclarationSpecifier]+declaration_specifiers :: CParser i m => m [DeclarationSpecifier] declaration_specifiers = many1 $ msum   [ StorageClassSpecifier <$> storage_class_specifier   , TypeSpecifier <$> type_specifier@@ -201,13 +267,13 @@   | REGISTER   deriving (Typeable, Eq, Show) -storage_class_specifier :: CParser m => m StorageClassSpecifier+storage_class_specifier :: CParser i m => m StorageClassSpecifier storage_class_specifier = msum-  [ TYPEDEF <$ reserve identStyle "typedef"-  , EXTERN <$ reserve identStyle "extern"-  , STATIC <$ reserve identStyle "static"-  , AUTO <$ reserve identStyle "auto"-  , REGISTER <$ reserve identStyle "register"+  [ TYPEDEF <$ reserve cIdentStyle "typedef"+  , EXTERN <$ reserve cIdentStyle "extern"+  , STATIC <$ reserve cIdentStyle "static"+  , AUTO <$ reserve cIdentStyle "auto"+  , REGISTER <$ reserve cIdentStyle "register"   ]  data TypeSpecifier@@ -220,101 +286,127 @@   | DOUBLE   | SIGNED   | UNSIGNED-  | Struct Identifier-  | Enum Identifier-  | TypeName Identifier+  | Struct CIdentifier+  | Enum CIdentifier+  | TypeName CIdentifier   deriving (Typeable, Eq, Show) -type_specifier :: CParser m => m TypeSpecifier+type_specifier :: CParser i m => m TypeSpecifier type_specifier = msum-  [ VOID <$ reserve identStyle "void"-  , CHAR <$ reserve identStyle "char"-  , SHORT <$ reserve identStyle "short"-  , INT <$ reserve identStyle "int"-  , LONG <$ reserve identStyle "long"-  , FLOAT <$ reserve identStyle "float"-  , DOUBLE <$ reserve identStyle "double"-  , SIGNED <$ reserve identStyle "signed"-  , UNSIGNED <$ reserve identStyle "unsigned"-  , Struct <$> (reserve identStyle "struct" >> identifier)-  , Enum <$> (reserve identStyle "enum" >> identifier)+  [ VOID <$ reserve cIdentStyle "void"+  , CHAR <$ reserve cIdentStyle "char"+  , SHORT <$ reserve cIdentStyle "short"+  , INT <$ reserve cIdentStyle "int"+  , LONG <$ reserve cIdentStyle "long"+  , FLOAT <$ reserve cIdentStyle "float"+  , DOUBLE <$ reserve cIdentStyle "double"+  , SIGNED <$ reserve cIdentStyle "signed"+  , UNSIGNED <$ reserve cIdentStyle "unsigned"+  , Struct <$> (reserve cIdentStyle "struct" >> cidentifier)+  , Enum <$> (reserve cIdentStyle "enum" >> cidentifier)   , TypeName <$> type_name   ] -identifier :: CParser m => m Identifier-identifier =-  try (do s <- ident identStyle-          isTypeName <- ask-          when (isTypeName s) $-            fail "expecting identifier, got type name"-          return s)-  <?> "identifier"+identifier :: CParser i m => m i+identifier = token identifier_no_lex -type_name :: CParser m => m Identifier-type_name =-  try (do s <- ident identStyle-          isTypeName <- ask-          unless (isTypeName s) $-            fail "expecting type name, got identifier"-          return s)-  <?> "type name"+isTypeName :: TypeNames -> String -> Bool+isTypeName typeNames id_ =+  case cIdentifierFromString 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 +identifier_no_lex :: CParser i m => m i+identifier_no_lex = try $ do+  ctx <- ask+  id_ <- cpcParseIdent ctx <?> cpcIdentName ctx+  when (isTypeName (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++-- | 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+  typeNames <- asks cpcTypeNames+  when (HashSet.member s typeNames) $+    unexpected $ "type name " ++ unCIdentifier s+  return s++cidentifier :: CParser i m => m CIdentifier+cidentifier = token cidentifier_no_lex++type_name :: CParser i m => m CIdentifier+type_name = try $ do+  s <- ident cIdentStyle <?> "type name"+  typeNames <- asks cpcTypeNames+  unless (HashSet.member s typeNames) $+    unexpected $ "identifier  " ++ unCIdentifier s+  return s+ data TypeQualifier   = CONST   | RESTRICT   | VOLATILE   deriving (Typeable, Eq, Show) -type_qualifier :: CParser m => m TypeQualifier+type_qualifier :: CParser i m => m TypeQualifier type_qualifier = msum-  [ CONST <$ reserve identStyle "const"-  , RESTRICT <$ reserve identStyle "restrict"-  , VOLATILE <$ reserve identStyle "volatile"+  [ CONST <$ reserve cIdentStyle "const"+  , RESTRICT <$ reserve cIdentStyle "restrict"+  , VOLATILE <$ reserve cIdentStyle "volatile"   ]  data FunctionSpecifier   = INLINE   deriving (Typeable, Eq, Show) -function_specifier :: CParser m => m FunctionSpecifier+function_specifier :: CParser i m => m FunctionSpecifier function_specifier = msum-  [ INLINE <$ reserve identStyle "inline"+  [ INLINE <$ reserve cIdentStyle "inline"   ] -data Declarator = Declarator+data Declarator i = Declarator   { declaratorPointers :: [Pointer]-  , declaratorDirect :: DirectDeclarator-  } deriving (Typeable, Eq, Show)+  , declaratorDirect :: (DirectDeclarator i)+  } deriving (Typeable, Eq, Show, Functor, Foldable, Traversable) -declarator :: CParser m => m Declarator+declarator :: CParser i m => m (Declarator i) declarator = (Declarator <$> many pointer <*> direct_declarator) <?> "declarator" -data DirectDeclarator-  = DeclaratorRoot Identifier-  | ArrayOrProto DirectDeclarator ArrayOrProto-  | DeclaratorParens Declarator-  deriving (Typeable, Eq, Show)+data DirectDeclarator i+  = DeclaratorRoot i+  | ArrayOrProto (DirectDeclarator i) (ArrayOrProto i)+  | DeclaratorParens (Declarator i)+  deriving (Typeable, Eq, Show, Functor, Foldable, Traversable) -data ArrayOrProto-  = Array ArrayType-  | Proto [ParameterDeclaration] -- We don't include old prototypes.-  deriving (Typeable, Eq, Show)+data ArrayOrProto i+  = Array (ArrayType i)+  | Proto [ParameterDeclaration i] -- We don't include old prototypes.+  deriving (Eq, Show, Typeable, Functor, Foldable, Traversable) -array_or_proto :: CParser m => m ArrayOrProto+array_or_proto :: CParser i m => m (ArrayOrProto i) array_or_proto = msum   [ Array <$> brackets array_type   , Proto <$> parens parameter_list   ]  -- TODO handle more stuff in array brackets-data ArrayType+data ArrayType i   = VariablySized   | Unsized   | SizedByInteger Integer-  | SizedByIdentifier Identifier-  deriving (Typeable, Eq, Show)+  | SizedByIdentifier i+  deriving (Typeable, Eq, Show, Functor, Foldable, Traversable) -array_type :: CParser m => m ArrayType+array_type :: CParser i m => m (ArrayType i) array_type = msum   [ VariablySized <$ symbolic '*'   , SizedByInteger <$> natural@@ -322,50 +414,55 @@   , return Unsized   ] -direct_declarator :: CParser m => m DirectDeclarator-direct_declarator =-  (do ddecltor <- msum-        [ DeclaratorRoot <$> identifier-        , DeclaratorParens <$> parens declarator-        ]-      aops <- many array_or_proto-      return $ foldl ArrayOrProto ddecltor aops)+direct_declarator :: CParser i m => m (DirectDeclarator i)+direct_declarator = do+  ddecltor <- msum+    [ DeclaratorRoot <$> identifier+    , DeclaratorParens <$> parens declarator+    ]+  aops <- many array_or_proto+  return $ foldl ArrayOrProto ddecltor aops  data Pointer   = Pointer [TypeQualifier]   deriving (Typeable, Eq, Show) -pointer :: CParser m => m Pointer+pointer :: CParser i m => m Pointer pointer = do   void $ symbolic '*'   Pointer <$> many type_qualifier -parameter_list :: CParser m => m [ParameterDeclaration]+parameter_list :: CParser i m => m [ParameterDeclaration i] parameter_list =   sepBy parameter_declaration $ symbolic ',' -data ParameterDeclaration = ParameterDeclaration+data ParameterDeclaration i = ParameterDeclaration   { parameterDeclarationSpecifiers :: [DeclarationSpecifier]-  , parameterDeclarationDeclarator :: Either Declarator AbstractDeclarator-  } deriving (Typeable, Eq, Show)+  , parameterDeclarationDeclarator :: DeclaratorOrAbstractDeclarator i+  } deriving (Eq, Show, Typeable, Functor, Foldable, Traversable) -parameter_declaration :: CParser m => m ParameterDeclaration+data DeclaratorOrAbstractDeclarator i+  = IsDeclarator (Declarator i)+  | IsAbstractDeclarator (AbstractDeclarator i)+  deriving (Eq, Show, Typeable, Functor, Foldable, Traversable)++parameter_declaration :: CParser i m => m (ParameterDeclaration i) parameter_declaration =   ParameterDeclaration     <$> declaration_specifiers     <*> mbabstract   where    mbabstract =-     Left <$> try declarator <|>-     Right <$> try abstract_declarator <|>-     return (Right (AbstractDeclarator [] Nothing))+     IsDeclarator <$> try declarator <|>+     IsAbstractDeclarator <$> try abstract_declarator <|>+     return (IsAbstractDeclarator (AbstractDeclarator [] Nothing)) -data AbstractDeclarator = AbstractDeclarator+data AbstractDeclarator i = AbstractDeclarator   { abstractDeclaratorPointers :: [Pointer]-  , abstractDeclaratorDirect :: Maybe DirectAbstractDeclarator-  } deriving (Typeable, Eq, Show)+  , abstractDeclaratorDirect :: Maybe (DirectAbstractDeclarator i)+  } deriving (Typeable, Eq, Show, Functor, Foldable, Traversable) -abstract_declarator :: CParser m => m AbstractDeclarator+abstract_declarator :: CParser i m => m (AbstractDeclarator i) abstract_declarator = do   ptrs <- many pointer   -- If there are no pointers, there must be an abstract declarator.@@ -374,37 +471,26 @@         else (Just <$> try direct_abstract_declarator) <|> return Nothing   AbstractDeclarator ptrs <$> p -data DirectAbstractDeclarator-  = ArrayOrProtoHere ArrayOrProto-  | ArrayOrProtoThere DirectAbstractDeclarator ArrayOrProto-  | AbstractDeclaratorParens AbstractDeclarator-  deriving (Typeable, Eq, Show)--direct_abstract_declarator :: CParser m => m DirectAbstractDeclarator-direct_abstract_declarator =-  (do ddecltor <- msum-        [ try (ArrayOrProtoHere <$> array_or_proto)-        , AbstractDeclaratorParens <$> parens abstract_declarator-        ] <?> "array, prototype, or parenthesised abstract declarator"-      aops <- many array_or_proto-      return $ foldl ArrayOrProtoThere ddecltor aops)+data DirectAbstractDeclarator i+  = ArrayOrProtoHere (ArrayOrProto i)+  | ArrayOrProtoThere (DirectAbstractDeclarator i) (ArrayOrProto i)+  | AbstractDeclaratorParens (AbstractDeclarator i)+  deriving (Typeable, Eq, Show, Functor, Foldable, Traversable) --- | This parser parses an 'Id' and nothing else -- it does not consume--- trailing spaces and the like.-identifier_no_lex :: CParser m => m Identifier-identifier_no_lex =-  try (do s <- Identifier <$> ((:) <$> identLetter <*> many (identLetter <|> digit))-          isTypeName <- ask-          when (isTypeName s) $-            fail "expecting identifier, got type name"-          return s)-  <?> "identifier"+direct_abstract_declarator :: CParser i m => m (DirectAbstractDeclarator i)+direct_abstract_declarator = do+  ddecltor <- msum+    [ try (ArrayOrProtoHere <$> array_or_proto)+    , AbstractDeclaratorParens <$> parens abstract_declarator+    ] <?> "array, prototype, or parenthesised abstract declarator"+  aops <- many array_or_proto+  return $ foldl ArrayOrProtoThere ddecltor aops  ------------------------------------------------------------------------ -- Pretty printing -instance Pretty Identifier where-  pretty = PP.text . unIdentifier+instance Pretty CIdentifier where+  pretty = PP.text . unCIdentifier  instance Pretty DeclarationSpecifier where   pretty dspec = case dspec of@@ -446,7 +532,7 @@   pretty funSpec = case funSpec of     INLINE -> "inline" -instance Pretty Declarator where+instance Pretty i => Pretty (Declarator i) where   pretty (Declarator ptrs ddecltor) = case ptrs of     [] -> pretty ddecltor     _:_ -> prettyPointers ptrs <+> pretty ddecltor@@ -458,13 +544,13 @@ instance Pretty Pointer where   pretty (Pointer tyQual) = "*" <> hsep (map pretty tyQual) -instance Pretty DirectDeclarator where+instance Pretty i => Pretty (DirectDeclarator i) where   pretty decltor = case decltor of     DeclaratorRoot x -> pretty x     DeclaratorParens x -> "(" <> pretty x <> ")"     ArrayOrProto ddecltor aorp -> pretty ddecltor <> pretty aorp -instance Pretty ArrayOrProto where+instance Pretty i => Pretty (ArrayOrProto i) where   pretty aorp = case aorp of     Array x -> "[" <> pretty x <> "]"     Proto x -> "(" <> prettyParams x <> ")"@@ -475,29 +561,29 @@   [x] -> pretty x   x : xs'@(_:_) -> pretty x <> "," <+> prettyParams xs' -instance Pretty ArrayType where+instance Pretty i => Pretty (ArrayType i) where   pretty at = case at of     VariablySized -> "*"     SizedByInteger n -> pretty n     SizedByIdentifier s -> pretty s     Unsized -> "" -instance Pretty ParameterDeclaration where+instance Pretty i => Pretty (ParameterDeclaration i) where   pretty (ParameterDeclaration declSpecs decltor) = case declSpecs of     [] -> decltorDoc     _:_ -> hsep (map pretty declSpecs) <+> decltorDoc     where       decltorDoc = case decltor of-        Left x -> pretty x-        Right x -> pretty x+        IsDeclarator x -> pretty x+        IsAbstractDeclarator x -> pretty x -instance Pretty AbstractDeclarator where+instance Pretty i => Pretty (AbstractDeclarator i) where   pretty (AbstractDeclarator ptrs mbDecltor) = case (ptrs, mbDecltor) of     (_, Nothing) -> prettyPointers ptrs     ([], Just x) -> pretty x     (_:_, Just x) -> prettyPointers ptrs <+> pretty x -instance Pretty DirectAbstractDeclarator where+instance Pretty i => Pretty (DirectAbstractDeclarator i) where   pretty ddecltor = case ddecltor of     AbstractDeclaratorParens x -> "(" <> pretty x <> ")"     ArrayOrProtoHere aop -> pretty aop@@ -522,30 +608,37 @@ halveSize :: QC.Gen a -> QC.Gen a halveSize m = QC.sized $ \n -> QC.resize (n `div` 2) m -arbitraryIdentifier :: QC.Gen Identifier-arbitraryIdentifier = do-    s <- ((:) <$> QC.elements letters <*> QC.listOf (QC.elements (letters ++ digits)))-    if HashSet.member s reservedWords-      then arbitraryIdentifier-      else return $ Identifier s-  where-    letters = ['a'..'z'] ++ ['A'..'Z'] ++ ['_']-    digits = ['0'..'9']+instance QC.Arbitrary CIdentifier where+  arbitrary = do+    s <- ((:) <$> QC.elements cIdentStart <*> QC.listOf (QC.elements cIdentLetter))+    if HashSet.member s cReservedWords+      then QC.arbitrary+      else return $ CIdentifier s  -- | Type used to generate an 'QC.Arbitrary' 'ParameterDeclaration' with -- arbitrary allowed type names.-data ParameterDeclarationWithTypeNames = ParameterDeclarationWithTypeNames-  { pdwtnTypeNames :: Set.Set Identifier-  , pdwtnParameterDeclaration :: ParameterDeclaration+data ParameterDeclarationWithTypeNames i = ParameterDeclarationWithTypeNames+  { pdwtnTypeNames :: HashSet.HashSet CIdentifier+  , pdwtnParameterDeclaration :: (ParameterDeclaration i)   } deriving (Typeable, Eq, Show) -instance QC.Arbitrary ParameterDeclarationWithTypeNames where-  arbitrary = do-    names <- Set.fromList <$> QC.listOf arbitraryIdentifier-    decl <- arbitraryParameterDeclarationFrom names+data (QC.Arbitrary i) => ArbitraryContext i = ArbitraryContext+  { acTypeNames :: TypeNames+  , acIdentToString :: i -> String+  }++arbitraryParameterDeclarationWithTypeNames+  :: (QC.Arbitrary i, Hashable i)+  => (i -> String)+  -> QC.Gen (ParameterDeclarationWithTypeNames i)+arbitraryParameterDeclarationWithTypeNames identToString = do+    names <- HashSet.fromList <$> QC.listOf QC.arbitrary+    let ctx = ArbitraryContext names identToString+    decl <- arbitraryParameterDeclarationFrom ctx     return $ ParameterDeclarationWithTypeNames names decl -arbitraryDeclarationSpecifierFrom :: Set.Set Identifier -> QC.Gen DeclarationSpecifier+arbitraryDeclarationSpecifierFrom+  :: (QC.Arbitrary i, Hashable i) => ArbitraryContext i -> QC.Gen DeclarationSpecifier arbitraryDeclarationSpecifierFrom typeNames = QC.oneof $   [ StorageClassSpecifier <$> QC.arbitrary   , TypeQualifier <$> QC.arbitrary@@ -562,8 +655,8 @@     , return REGISTER     ] -arbitraryTypeSpecifierFrom :: Set.Set Identifier -> QC.Gen TypeSpecifier-arbitraryTypeSpecifierFrom typeNames = QC.oneof $+arbitraryTypeSpecifierFrom :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen TypeSpecifier+arbitraryTypeSpecifierFrom ctx = QC.oneof $   [ return VOID   , return CHAR   , return SHORT@@ -573,10 +666,10 @@   , return DOUBLE   , return SIGNED   , return UNSIGNED-  , Struct <$> arbitraryIdentifierFrom typeNames-  , Enum <$> arbitraryIdentifierFrom typeNames-  ] ++ if Set.null typeNames then []-       else [TypeName <$> QC.elements (Set.toList typeNames)]+  , Struct <$> arbitraryCIdentifierFrom ctx+  , Enum <$> arbitraryCIdentifierFrom ctx+  ] ++ if HashSet.null (acTypeNames ctx) then []+       else [TypeName <$> QC.elements (HashSet.toList (acTypeNames ctx))]  instance QC.Arbitrary TypeQualifier where   arbitrary = QC.oneof@@ -590,18 +683,26 @@     [ return INLINE     ] -arbitraryDeclaratorFrom :: Set.Set Identifier -> QC.Gen Declarator+arbitraryDeclaratorFrom+  :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (Declarator i) arbitraryDeclaratorFrom typeNames = halveSize $   Declarator <$> QC.arbitrary <*> arbitraryDirectDeclaratorFrom typeNames -arbitraryIdentifierFrom :: Set.Set Identifier -> QC.Gen Identifier-arbitraryIdentifierFrom typeNames = do-  id' <- arbitraryIdentifier-  if Set.member id' typeNames-    then arbitraryIdentifierFrom typeNames+arbitraryCIdentifierFrom+  :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen CIdentifier+arbitraryCIdentifierFrom ctx =+  arbitraryIdentifierFrom ctx{acIdentToString = unCIdentifier}++arbitraryIdentifierFrom+  :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen i+arbitraryIdentifierFrom ctx = do+  id' <- QC.arbitrary+  if isTypeName (acTypeNames ctx) (acIdentToString ctx id')+    then arbitraryIdentifierFrom ctx     else return id' -arbitraryDirectDeclaratorFrom :: Set.Set Identifier -> QC.Gen DirectDeclarator+arbitraryDirectDeclaratorFrom+  :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (DirectDeclarator i) arbitraryDirectDeclaratorFrom typeNames = halveSize $ oneOfSized $   [ Anyhow $ DeclaratorRoot <$> arbitraryIdentifierFrom typeNames   , IfPositive $ DeclaratorParens <$> arbitraryDeclaratorFrom typeNames@@ -610,13 +711,14 @@       <*> arbitraryArrayOrProtoFrom typeNames   ] -arbitraryArrayOrProtoFrom :: Set.Set Identifier -> QC.Gen ArrayOrProto+arbitraryArrayOrProtoFrom+  :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (ArrayOrProto i) arbitraryArrayOrProtoFrom typeNames = halveSize $ oneOfSized $   [ Anyhow $ Array <$> arbitraryArrayTypeFrom typeNames   , IfPositive $ Proto <$> QC.listOf (arbitraryParameterDeclarationFrom typeNames)   ] -arbitraryArrayTypeFrom :: Set.Set Identifier -> QC.Gen ArrayType+arbitraryArrayTypeFrom :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (ArrayType i) arbitraryArrayTypeFrom typeNames = QC.oneof   [ return VariablySized   , SizedByInteger . QC.getNonNegative <$> QC.arbitrary@@ -627,16 +729,18 @@ instance QC.Arbitrary Pointer where   arbitrary = Pointer <$> QC.arbitrary -arbitraryParameterDeclarationFrom :: Set.Set Identifier -> QC.Gen ParameterDeclaration+arbitraryParameterDeclarationFrom+  :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (ParameterDeclaration i) arbitraryParameterDeclarationFrom typeNames = halveSize $   ParameterDeclaration     <$> QC.listOf1 (arbitraryDeclarationSpecifierFrom typeNames)     <*> QC.oneof-          [ Left <$> arbitraryDeclaratorFrom typeNames-          , Right <$> arbitraryAbstractDeclaratorFrom typeNames+          [ IsDeclarator <$> arbitraryDeclaratorFrom typeNames+          , IsAbstractDeclarator <$> arbitraryAbstractDeclaratorFrom typeNames           ] -arbitraryAbstractDeclaratorFrom :: Set.Set Identifier -> QC.Gen AbstractDeclarator+arbitraryAbstractDeclaratorFrom+  :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (AbstractDeclarator i) arbitraryAbstractDeclaratorFrom typeNames = halveSize $ do   ptrs <- QC.arbitrary   decl <- if null ptrs@@ -648,7 +752,7 @@   return $ AbstractDeclarator ptrs decl  arbitraryDirectAbstractDeclaratorFrom-  :: Set.Set Identifier -> QC.Gen DirectAbstractDeclarator+  :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (DirectAbstractDeclarator i) arbitraryDirectAbstractDeclaratorFrom typeNames = halveSize $ oneOfSized $   [ Anyhow $ ArrayOrProtoHere <$> arbitraryArrayOrProtoFrom typeNames   , IfPositive $ AbstractDeclaratorParens <$> arbitraryAbstractDeclaratorFrom typeNames@@ -660,7 +764,7 @@ ------------------------------------------------------------------------ -- Utils -many1 :: CParser m => m a -> m [a]+many1 :: CParser i m => m a -> m [a] many1 p = (:) <$> p <*> many p  ------------------------------------------------------------------------@@ -806,3 +910,13 @@ -- 	printf("\n%*s\n%*s\n", column, "^", column, s); -- } -- @++-- 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)+  when (HashSet.member name (_styleReserved s)) $ unexpected $ "reserved " ++ _styleName s ++ " " ++ show name+  return name

@@ -90,7 +90,7 @@       x `Hspec.shouldBe` y      assertParse p s =-      case C.runCParser (isTypeName baseTypes) "spec" s (lift spaces *> p <* lift eof) of+      case C.runCParser (C.cCParserContext (typeNamesFromTypesTable baseTypes)) "spec" s (lift spaces *> p <* lift eof) of         Left err -> error $ "Parse error (assertParse): " ++ show err         Right x -> x 

@@ -9,23 +9,25 @@ {-# LANGUAGE OverloadedStrings #-} module Language.C.Inline.ParseSpec (spec) where +import           Control.Exception (evaluate)+import           Control.Monad (void) import           Control.Monad.Trans.Class (lift)+import qualified Data.HashSet as HashSet+import           Data.Monoid ((<>)) import qualified Test.Hspec as Hspec import           Text.Parser.Char import           Text.Parser.Combinators import           Text.RawString.QQ (r)-import           Control.Monad (void)-import           Control.Exception (evaluate)-import           Data.Monoid ((<>)) import           Text.Regex.Posix ((=~))  #if __GLASGOW_HASKELL__ < 710 import           Control.Applicative ((<*), (*>)) #endif -import qualified Language.C.Types as C-import           Language.C.Inline.Internal import           Language.C.Inline.Context+import           Language.C.Inline.HaskellIdentifier+import           Language.C.Inline.Internal+import qualified Language.C.Types as C  spec :: Hspec.SpecWith () spec = do@@ -51,31 +53,53 @@       retType `Hspec.shouldBe` (cty "double (*)(double)")       params `shouldMatchParameters` []       cExp `shouldMatchBody` " &cos "+    Hspec.it "parses Haskell identifier (1)" $ do+      (retType, params, cExp) <- goodParse [r| double { $(double x') } |]+      retType `Hspec.shouldBe` (cty "double")+      params `shouldMatchParameters` [(cty "double", Plain "x'")]+      cExp `shouldMatchBody` " x[a-z0-9_]+ "+    Hspec.it "parses Haskell identifier (2)" $ do+      (retType, params, cExp) <- goodParse [r| double { $(double ä') } |]+      retType `Hspec.shouldBe` (cty "double")+      params `shouldMatchParameters` [(cty "double", Plain "ä'")]+      cExp `shouldMatchBody` " [a-z0-9_]+ "+    Hspec.it "parses Haskell identifier (3)" $ do+      (retType, params, cExp) <- goodParse [r| int { $(int Foo.bar) } |]+      retType `Hspec.shouldBe` (cty "int")+      params `shouldMatchParameters` [(cty "int", Plain "Foo.bar")]+      cExp `shouldMatchBody` " Foobar[a-z0-9_]+ "+    Hspec.it "does not parse Haskell identifier in bad position" $ do+      badParse [r| double (*)(double Foo.bar) { 3.0 } |]   where     ctx = baseCtx <> funCtx -    assertParse p s =-      case C.runCParser (const False) "spec" s (lift spaces *> p <* lift eof) of+    assertParse ctxF p s =+      case C.runCParser (ctxF HashSet.empty) "spec" s (lift spaces *> p <* lift eof) of         Left err -> error $ "Parse error (assertParse): " ++ show err         Right x -> x      -- We use show + length to fully evaluate the result -- there     -- might be exceptions hiding.  TODO get rid of exceptions.-    strictParse :: String -> IO (C.Type, [(C.Identifier, C.Type, ParameterType)], String)+    strictParse+      :: String+      -> IO (C.Type C.CIdentifier, [(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String)     strictParse s = do       let ParseTypedC retType pars body =-            assertParse (parseTypedC (ctxAntiQuoters ctx)) s+            assertParse haskellCParserContext (parseTypedC (ctxAntiQuoters ctx)) s       void $ evaluate $ length $ show (retType, pars, body)       return (retType, pars, body)      goodParse = strictParse     badParse s = strictParse s `Hspec.shouldThrow` Hspec.anyException -    cty :: String -> C.Type-    cty s = C.parameterDeclarationType $ assertParse C.parseParameterDeclaration s+    cty :: String -> C.Type C.CIdentifier+    cty s = C.parameterDeclarationType $+      assertParse C.cCParserContext C.parseParameterDeclaration s      shouldMatchParameters-      :: [(C.Identifier, C.Type, ParameterType)] -> [(C.Type, ParameterType)] -> Hspec.Expectation+      :: [(C.CIdentifier, C.Type C.CIdentifier, ParameterType)]+      -> [(C.Type C.CIdentifier, ParameterType)]+      -> Hspec.Expectation     shouldMatchParameters pars pars' =       [(x, y) | (_, x, y) <- pars] `Hspec.shouldMatchList` pars' 

@@ -8,7 +8,7 @@  import           Control.Applicative import           Control.Monad.Trans.Class (lift)-import qualified Data.Set as Set+import           Data.Hashable (Hashable) import qualified Test.Hspec as Hspec import qualified Test.QuickCheck as QC import           Text.Parser.Char@@ -17,30 +17,42 @@  import           Language.C.Types.Parse import qualified Language.C.Types as Types+import           Language.C.Inline.HaskellIdentifier  import Prelude -- Fix for 7.10 unused warnings.  spec :: Hspec.SpecWith () spec = do-  Hspec.it "parses everything which is pretty-printable (QuickCheck)" $ do-    QC.property $ \(ParameterDeclarationWithTypeNames typeNames ty) ->-      isGoodType ty QC.==>-        let ty' = assertParse (`Set.member` typeNames) parameter_declaration (prettyOneLine ty)+  Hspec.it "parses everything which is pretty-printable (C)" $ do+    QC.property $ do+      ParameterDeclarationWithTypeNames typeNames ty <-+        arbitraryParameterDeclarationWithTypeNames unCIdentifier+      return $ isGoodType ty QC.==>+        let ty' = assertParse (cCParserContext typeNames) parameter_declaration (prettyOneLine ty)         in Types.untangleParameterDeclaration ty == Types.untangleParameterDeclaration ty'+  Hspec.it "parses everything which is pretty-printable (Haskell)" $ do+    QC.property $ do+      ParameterDeclarationWithTypeNames typeNames ty <-+        arbitraryParameterDeclarationWithTypeNames unHaskellIdentifier+      return $ isGoodType ty QC.==>+        let ty' = assertParse (haskellCParserContext typeNames) parameter_declaration (prettyOneLine ty)+        in Types.untangleParameterDeclaration ty == Types.untangleParameterDeclaration ty'  ------------------------------------------------------------------------ -- Utils -assertParse :: IsTypeName -> (forall m. CParser m => m a) -> String -> a-assertParse isTypeName p s =-  case runCParser isTypeName "spec" s (lift spaces *> p <* lift eof) of+assertParse+  :: (Hashable i)+  => 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     Right x -> x  prettyOneLine :: PP.Pretty a => a -> String prettyOneLine x = PP.displayS (PP.renderCompact (PP.pretty x)) "" -isGoodType :: ParameterDeclaration -> Bool+isGoodType :: ParameterDeclaration i -> Bool isGoodType ty = case Types.untangleParameterDeclaration ty of   Left _ -> False   Right _ -> True

@@ -15,7 +15,7 @@   int francescos_add(int x, int y) { int z = x + y; return z; }  -int inline_c_0_af51326c4d54f2333cd5e65d63fa1335afd44e7f(int x) {+int inline_c_0_23225c6b2d15328585f210dc2f989269e95d08ee(int x) {  return x + 3;  } @@ -25,17 +25,17 @@ }  -int inline_c_2_16f19661d53c3abae15931d85a5e2829ecb039aa(int x_inline_c_0, int y_inline_c_1) {+int inline_c_2_5fdbbe6da0475522165cd251c48497d38f4710fb(int x_inline_c_0, int y_inline_c_1) { return ( x_inline_c_0 + y_inline_c_1 + 5 ); }  -int inline_c_3_40bee96de703884c6b206e411631395b9aef5976(int x_inline_c_0, int y_inline_c_1) {+int inline_c_3_856f16273cbef2af269b645953d316cb9426784c(int x_inline_c_0, int y_inline_c_1) { return ( x_inline_c_0 + 10 + y_inline_c_1 ); }  -int inline_c_4_e6943496092d6a4a410b30efda2403f1340ee8cc(int x_inline_c_0, int y_inline_c_1) {+int inline_c_4_f58397f6204cd35d25406cea930cdd76127e7a8d(int x_inline_c_0, int y_inline_c_1) { return ( 7 + x_inline_c_0 + y_inline_c_1 ); } @@ -45,32 +45,32 @@ }  -ptrdiff_t inline_c_6_205199db60839b9d17460a63202ca3a0d6589aa2(ptrdiff_t x_inline_c_0) {+ptrdiff_t inline_c_6_4475cd73db749194709e394483ff3e5205688ff8(ptrdiff_t x_inline_c_0) {  char a[2]; return &a[1] - &a[0] + x_inline_c_0;  }  -size_t inline_c_7_5640bf10f132d090b52c2634f9fa93226d58c551() {+size_t inline_c_7_9782c357435fb488c3166bf10e839da13328001e() { return ( sizeof (char) ); }  -uintmax_t inline_c_8_da095360497f4bbf3922f50d0b0548c2dd7cbed9() {+uintmax_t inline_c_8_c0df91f70bbf1f85671339d1bdc524414e112cc2() { return ( UINTMAX_MAX ); }  -int16_t inline_c_9_23a275cc563910c289d0dbf8e770ede22fe97bbb(int16_t x_inline_c_0) {+int16_t inline_c_9_9e29ba00e56a81c765067e09a3136fa5232d49a0(int16_t x_inline_c_0) { return ( 1 + x_inline_c_0 ); }  -uint32_t inline_c_10_02eb7fd8875e35241b9f7b725499139c4289aeab(uint32_t y_inline_c_0) {+uint32_t inline_c_10_08a42fa8f755a36db897898b73bb7aab5b1b58e1(uint32_t y_inline_c_0) { return ( y_inline_c_0 * 7 ); }  -int inline_c_11_71dfd9b850f6e2091e021139a58b74df94cd7303(int (* ackermannPtr_inline_c_0)(int , int ), int x_inline_c_1, int y_inline_c_2) {+int inline_c_11_4ffe4d055df0966eedc85f08247aa8880402694a(int (* ackermannPtr_inline_c_0)(int , int ), int x_inline_c_1, int y_inline_c_2) { return ( ackermannPtr_inline_c_0(x_inline_c_1, y_inline_c_2) ); } @@ -80,27 +80,27 @@ }  -int inline_c_13_b58cd0af8a50791fe277023774ffe88ee7e037bd(int (* ackermann__inline_c_0)(int , int ), int x_inline_c_1, int y_inline_c_2) {+int inline_c_13_55555bbb777d25d03fef0a6d6ce9193474a74a35(int (* ackermann__inline_c_0)(int , int ), int x_inline_c_1, int y_inline_c_2) { return ( ackermann__inline_c_0(x_inline_c_1, y_inline_c_2) ); }  -int inline_c_14_71dfd9b850f6e2091e021139a58b74df94cd7303(int (* ackermannPtr_inline_c_0)(int , int ), int x_inline_c_1, int y_inline_c_2) {+int inline_c_14_4ffe4d055df0966eedc85f08247aa8880402694a(int (* ackermannPtr_inline_c_0)(int , int ), int x_inline_c_1, int y_inline_c_2) { return ( ackermannPtr_inline_c_0(x_inline_c_1, y_inline_c_2) ); }  -int inline_c_15_8ef64f450bca60833a113574529facc22cb4a0a0(int (* ackermann_inline_c_0)(int , int ), int x_inline_c_1, int y_inline_c_2) {+int inline_c_15_b7d965842e65c49fcc08b03f70454988290e61e4(int (* ackermann_inline_c_0)(int , int ), int x_inline_c_1, int y_inline_c_2) { return ( ackermann_inline_c_0(x_inline_c_1, y_inline_c_2) ); }  -double inline_c_16_05403b76080812d04e00ce2b31b2068dad1b2342(double (* fun_inline_c_0)(double )) {+double inline_c_16_5dce1654ef6186acdb189a6ce36f0a66660eb346(double (* fun_inline_c_0)(double )) { return ( fun_inline_c_0(3.0) ); }  -int inline_c_17_963ff572b13b7aaee0f9f8092a567eb35a8c2088(int n_inline_c_0, int * ptr_inline_c_1) {+int inline_c_17_8d0f093895f51773152915c33b75c7aafd8f4f45(int n_inline_c_0, int * ptr_inline_c_1) {          int i;         int x = 0;@@ -112,7 +112,7 @@ }  -int inline_c_18_e2ee2f14cc17b81ea1e818bb96b23439a1810c23(long vec_inline_c_0, int * vec_inline_c_1) {+int inline_c_18_62ce8aade5e693f134c6a5c9add3523edab1a63e(long vec_inline_c_0, int * vec_inline_c_1) {          int i;         int x = 0;@@ -124,7 +124,7 @@ }  -int inline_c_19_17d13d6f2f87c2401476aaf41e06593689723baf(long bs_inline_c_0, char * bs_inline_c_1) {+int inline_c_19_75f1401fb8545756b6d329a5352a252bf52db946(long bs_inline_c_0, char * bs_inline_c_1) {            int i, bits = 0;           for (i = 0; i < bs_inline_c_0; i++) {@@ -133,5 +133,20 @@           }           return bits;         +}+++int inline_c_20_6fa3d382d3ab7f6d57eec7fbfe64e87fbc2a0ca9(int x_27_inline_c_0) {+return ( x_27_inline_c_0 );+}+++int inline_c_21_dbf060cb8fa2b86c6c6838ef9b645ac20f38ba79(int _e4_inline_c_0) {+return ( _e4_inline_c_0 );+}+++int inline_c_22_2421969c444755bea2c6f2060e0921ce7f3d16d7(int PreludemaxBound_2e_inline_c_0) {+return ( PreludemaxBound_2e_inline_c_0 ); } 

@@ -2,10 +2,12 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-}+import           Control.Monad (void) import           Data.Monoid ((<>)) import qualified Data.Vector.Storable.Mutable as V import           Foreign.C.Types import qualified Language.Haskell.TH as TH+import           Prelude import qualified Test.Hspec as Hspec import           Text.RawString.QQ (r) @@ -184,4 +186,9 @@           return bits;         } |]       bits `Hspec.shouldBe` 16-+    Hspec.it "Haskell identifiers" $ do+      let x' = 3+      void $ [C.exp| int { $(int x') } |]+      let ä = 3+      void $ [C.exp| int { $(int ä) } |]+      void $ [C.exp| int { $(int Prelude.maxBound) } |]