inline-c 0.6.0.3 → 0.6.0.4

raw patch · 5 files changed

+206/−203 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• changelog.md +1/−0
• inline-c.cabal +2/−2
• src/Language/C/Inline/HaskellIdentifier.hs +3/−24
• src/Language/C/Types/Parse.hs +1/−176
• test/Language/C/Types/ParseSpec.hs +199/−1

@@ -1,3 +1,4 @@+- 0.6.0.4: Remove QuickCheck dependency - 0.6.0.3: Remove cryptohash dependencies - 0.6.0.2: Update haddock - 0.6.0.0: Use `addDependentFile` so separate compilation is not needed.

@@ -1,5 +1,5 @@ name:                inline-c-version:             0.6.0.3+version:             0.6.0.4 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@@ -33,7 +33,6 @@   other-modules:       Language.C.Inline.FunPtr   ghc-options:         -Wall   build-depends:       base >=4.7 && <5-                     , QuickCheck                      , ansi-wl-pprint                      , bytestring                      , containers@@ -57,6 +56,7 @@                      , Language.C.Inline.ParseSpec                      , Language.C.Types.ParseSpec   build-depends:       base >=4 && <5+                     , QuickCheck                      , ansi-wl-pprint                      , containers                      , hashable

@@ -11,6 +11,9 @@   , haskellCParserContext   , parseHaskellIdentifier   , mangleHaskellIdentifier++    -- * for testing+  , haskellReservedWords   ) where  import           Control.Applicative ((<|>))@@ -23,7 +26,6 @@ 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)@@ -145,26 +147,3 @@   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']

@@ -83,8 +83,7 @@   , cIdentStart   , cIdentLetter   , cReservedWords-  , ParameterDeclarationWithTypeNames(..)-  , arbitraryParameterDeclarationWithTypeNames+  , isTypeName   ) where  import           Control.Applicative@@ -93,11 +92,9 @@ import           Data.Functor.Identity (Identity) import qualified Data.HashSet as HashSet import           Data.Hashable (Hashable)-import           Data.Maybe (mapMaybe) import           Data.Monoid ((<>)) import           Data.String (IsString(..)) import           Data.Typeable (Typeable)-import qualified Test.QuickCheck as QC import qualified Text.Parsec as Parsec import           Text.Parser.Char import           Text.Parser.Combinators@@ -592,178 +589,6 @@     AbstractDeclaratorParens x -> "(" <> pretty x <> ")"     ArrayOrProtoHere aop -> pretty aop     ArrayOrProtoThere ddecltor' aop -> pretty ddecltor' <> pretty aop----------------------------------------------------------------------------- Arbitrary--data OneOfSized a-  = Anyhow a-  | IfPositive a-  deriving (Typeable, Eq, Show)---- | Precondition: there is at least one 'Anyhow' in the list.-oneOfSized :: [OneOfSized (QC.Gen a)] -> QC.Gen a-oneOfSized xs = QC.sized $ \n -> do-  let f (Anyhow a) = Just a-      f (IfPositive x) | n > 0 = Just x-      f (IfPositive _) = Nothing-  QC.oneof $ mapMaybe f xs--halveSize :: QC.Gen a -> QC.Gen a-halveSize m = QC.sized $ \n -> QC.resize (n `div` 2) m--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 i = ParameterDeclarationWithTypeNames-  { pdwtnTypeNames :: HashSet.HashSet CIdentifier-  , pdwtnParameterDeclaration :: (ParameterDeclaration i)-  } deriving (Typeable, Eq, Show)--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-  :: (QC.Arbitrary i, Hashable i) => ArbitraryContext i -> QC.Gen DeclarationSpecifier-arbitraryDeclarationSpecifierFrom typeNames = QC.oneof $-  [ StorageClassSpecifier <$> QC.arbitrary-  , TypeQualifier <$> QC.arbitrary-  , FunctionSpecifier <$> QC.arbitrary-  , TypeSpecifier <$> arbitraryTypeSpecifierFrom typeNames-  ]--instance QC.Arbitrary StorageClassSpecifier where-  arbitrary = QC.oneof-    [ return TYPEDEF-    , return EXTERN-    , return STATIC-    , return AUTO-    , return REGISTER-    ]--arbitraryTypeSpecifierFrom :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen TypeSpecifier-arbitraryTypeSpecifierFrom ctx = QC.oneof $-  [ return VOID-  , return CHAR-  , return SHORT-  , return INT-  , return LONG-  , return FLOAT-  , return DOUBLE-  , return SIGNED-  , return UNSIGNED-  , 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-    [ return CONST-    , return RESTRICT-    , return VOLATILE-    ]--instance QC.Arbitrary FunctionSpecifier where-  arbitrary = QC.oneof-    [ return INLINE-    ]--arbitraryDeclaratorFrom-  :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (Declarator i)-arbitraryDeclaratorFrom typeNames = halveSize $-  Declarator <$> QC.arbitrary <*> arbitraryDirectDeclaratorFrom 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-  :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (DirectDeclarator i)-arbitraryDirectDeclaratorFrom typeNames = halveSize $ oneOfSized $-  [ Anyhow $ DeclaratorRoot <$> arbitraryIdentifierFrom typeNames-  , IfPositive $ DeclaratorParens <$> arbitraryDeclaratorFrom typeNames-  , IfPositive $ ArrayOrProto-      <$> arbitraryDirectDeclaratorFrom typeNames-      <*> arbitraryArrayOrProtoFrom typeNames-  ]--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 :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (ArrayType i)-arbitraryArrayTypeFrom typeNames = QC.oneof-  [ return VariablySized-  , SizedByInteger . QC.getNonNegative <$> QC.arbitrary-  , SizedByIdentifier <$> arbitraryIdentifierFrom typeNames-  , return Unsized-  ]--instance QC.Arbitrary Pointer where-  arbitrary = Pointer <$> QC.arbitrary--arbitraryParameterDeclarationFrom-  :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (ParameterDeclaration i)-arbitraryParameterDeclarationFrom typeNames = halveSize $-  ParameterDeclaration-    <$> QC.listOf1 (arbitraryDeclarationSpecifierFrom typeNames)-    <*> QC.oneof-          [ IsDeclarator <$> arbitraryDeclaratorFrom typeNames-          , IsAbstractDeclarator <$> arbitraryAbstractDeclaratorFrom typeNames-          ]--arbitraryAbstractDeclaratorFrom-  :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (AbstractDeclarator i)-arbitraryAbstractDeclaratorFrom typeNames = halveSize $ do-  ptrs <- QC.arbitrary-  decl <- if null ptrs-    then Just <$> arbitraryDirectAbstractDeclaratorFrom typeNames-    else oneOfSized-      [ Anyhow $ return Nothing-      , IfPositive $ Just <$> arbitraryDirectAbstractDeclaratorFrom typeNames-      ]-  return $ AbstractDeclarator ptrs decl--arbitraryDirectAbstractDeclaratorFrom-  :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (DirectAbstractDeclarator i)-arbitraryDirectAbstractDeclaratorFrom typeNames = halveSize $ oneOfSized $-  [ Anyhow $ ArrayOrProtoHere <$> arbitraryArrayOrProtoFrom typeNames-  , IfPositive $ AbstractDeclaratorParens <$> arbitraryAbstractDeclaratorFrom typeNames-  , IfPositive $ ArrayOrProtoThere-      <$> arbitraryDirectAbstractDeclaratorFrom typeNames-      <*> arbitraryArrayOrProtoFrom typeNames-  ]  ------------------------------------------------------------------------ -- Utils

@@ -4,7 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-}-+{-# OPTIONS_GHC -fno-warn-orphans #-} module Language.C.Types.ParseSpec (spec) where  import           Control.Applicative@@ -15,6 +15,11 @@ import           Text.Parser.Char import           Text.Parser.Combinators import qualified Text.PrettyPrint.ANSI.Leijen as PP+import           Data.Typeable (Typeable)+import qualified Data.HashSet as HashSet+import           Data.List (intercalate)+import           Data.String (fromString)+import           Data.Maybe (mapMaybe)  import           Language.C.Types.Parse import qualified Language.C.Types as Types@@ -65,3 +70,196 @@ isGoodType ty = case Types.untangleParameterDeclaration ty of   Left _ -> False   Right _ -> True++------------------------------------------------------------------------+-- Arbitrary++data OneOfSized a+  = Anyhow a+  | IfPositive a+  deriving (Typeable, Eq, Show)++-- | Precondition: there is at least one 'Anyhow' in the list.+oneOfSized :: [OneOfSized (QC.Gen a)] -> QC.Gen a+oneOfSized xs = QC.sized $ \n -> do+  let f (Anyhow a) = Just a+      f (IfPositive x) | n > 0 = Just x+      f (IfPositive _) = Nothing+  QC.oneof $ mapMaybe f xs++halveSize :: QC.Gen a -> QC.Gen a+halveSize m = QC.sized $ \n -> QC.resize (n `div` 2) m++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 $ fromString s++-- | Type used to generate an 'QC.Arbitrary' 'ParameterDeclaration' with+-- arbitrary allowed type names.+data ParameterDeclarationWithTypeNames i = ParameterDeclarationWithTypeNames+  { _pdwtnTypeNames :: HashSet.HashSet CIdentifier+  , _pdwtnParameterDeclaration :: (ParameterDeclaration i)+  } deriving (Typeable, Eq, Show)++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+  :: (QC.Arbitrary i, Hashable i) => ArbitraryContext i -> QC.Gen DeclarationSpecifier+arbitraryDeclarationSpecifierFrom typeNames = QC.oneof $+  [ StorageClassSpecifier <$> QC.arbitrary+  , TypeQualifier <$> QC.arbitrary+  , FunctionSpecifier <$> QC.arbitrary+  , TypeSpecifier <$> arbitraryTypeSpecifierFrom typeNames+  ]++instance QC.Arbitrary StorageClassSpecifier where+  arbitrary = QC.oneof+    [ return TYPEDEF+    , return EXTERN+    , return STATIC+    , return AUTO+    , return REGISTER+    ]++arbitraryTypeSpecifierFrom :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen TypeSpecifier+arbitraryTypeSpecifierFrom ctx = QC.oneof $+  [ return VOID+  , return CHAR+  , return SHORT+  , return INT+  , return LONG+  , return FLOAT+  , return DOUBLE+  , return SIGNED+  , return UNSIGNED+  , 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+    [ return CONST+    , return RESTRICT+    , return VOLATILE+    ]++instance QC.Arbitrary FunctionSpecifier where+  arbitrary = QC.oneof+    [ return INLINE+    ]++arbitraryDeclaratorFrom+  :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (Declarator i)+arbitraryDeclaratorFrom typeNames = halveSize $+  Declarator <$> QC.arbitrary <*> arbitraryDirectDeclaratorFrom 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+  :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (DirectDeclarator i)+arbitraryDirectDeclaratorFrom typeNames = halveSize $ oneOfSized $+  [ Anyhow $ DeclaratorRoot <$> arbitraryIdentifierFrom typeNames+  , IfPositive $ DeclaratorParens <$> arbitraryDeclaratorFrom typeNames+  , IfPositive $ ArrayOrProto+      <$> arbitraryDirectDeclaratorFrom typeNames+      <*> arbitraryArrayOrProtoFrom typeNames+  ]++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 :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (ArrayType i)+arbitraryArrayTypeFrom typeNames = QC.oneof+  [ return VariablySized+  , SizedByInteger . QC.getNonNegative <$> QC.arbitrary+  , SizedByIdentifier <$> arbitraryIdentifierFrom typeNames+  , return Unsized+  ]++instance QC.Arbitrary Pointer where+  arbitrary = Pointer <$> QC.arbitrary++arbitraryParameterDeclarationFrom+  :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (ParameterDeclaration i)+arbitraryParameterDeclarationFrom typeNames = halveSize $+  ParameterDeclaration+    <$> QC.listOf1 (arbitraryDeclarationSpecifierFrom typeNames)+    <*> QC.oneof+          [ IsDeclarator <$> arbitraryDeclaratorFrom typeNames+          , IsAbstractDeclarator <$> arbitraryAbstractDeclaratorFrom typeNames+          ]++arbitraryAbstractDeclaratorFrom+  :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (AbstractDeclarator i)+arbitraryAbstractDeclaratorFrom typeNames = halveSize $ do+  ptrs <- QC.arbitrary+  decl <- if null ptrs+    then Just <$> arbitraryDirectAbstractDeclaratorFrom typeNames+    else oneOfSized+      [ Anyhow $ return Nothing+      , IfPositive $ Just <$> arbitraryDirectAbstractDeclaratorFrom typeNames+      ]+  return $ AbstractDeclarator ptrs decl++arbitraryDirectAbstractDeclaratorFrom+  :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (DirectAbstractDeclarator i)+arbitraryDirectAbstractDeclaratorFrom typeNames = halveSize $ oneOfSized $+  [ Anyhow $ ArrayOrProtoHere <$> arbitraryArrayOrProtoFrom typeNames+  , IfPositive $ AbstractDeclaratorParens <$> arbitraryAbstractDeclaratorFrom typeNames+  , IfPositive $ ArrayOrProtoThere+      <$> arbitraryDirectAbstractDeclaratorFrom typeNames+      <*> arbitraryArrayOrProtoFrom typeNames+  ]++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 $ fromString $ 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']