diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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. diff --git a/inline-c.cabal b/inline-c.cabal --- a/inline-c.cabal +++ b/inline-c.cabal @@ -1,5 +1,5 @@ name: inline-c -version: 0.6.0.3 +version: 0.6.0.4 synopsis: Write Haskell source files including C code inline. No FFI required. description: See . 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 diff --git a/src/Language/C/Inline/HaskellIdentifier.hs b/src/Language/C/Inline/HaskellIdentifier.hs --- a/src/Language/C/Inline/HaskellIdentifier.hs +++ b/src/Language/C/Inline/HaskellIdentifier.hs @@ -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'] diff --git a/src/Language/C/Types/Parse.hs b/src/Language/C/Types/Parse.hs --- a/src/Language/C/Types/Parse.hs +++ b/src/Language/C/Types/Parse.hs @@ -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 diff --git a/test/Language/C/Types/ParseSpec.hs b/test/Language/C/Types/ParseSpec.hs --- a/test/Language/C/Types/ParseSpec.hs +++ b/test/Language/C/Types/ParseSpec.hs @@ -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']