{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.C.Types.ParseSpec (spec) where import Control.Applicative import Control.Monad.Trans.Class (lift) import Data.Hashable (Hashable) import qualified Test.Hspec as Hspec import qualified Test.Hspec.QuickCheck import qualified Test.QuickCheck as QC 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 Data.List.Split (splitOn) 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 () -- modifyMaxDiscardRatio: -- 'isGoodType' and 'isGoodHaskellIdentifierType' usually make it within the -- discard ratio of 10, but we increase the ratio to avoid spurious build failures spec = Test.Hspec.QuickCheck.modifyMaxDiscardRatio (const 20) $ do Hspec.it "parses everything which is pretty-printable (C)" $ do #if MIN_VERSION_QuickCheck(2,9,0) QC.property $ QC.again $ do -- Work around #else QC.property $ do #endif ParameterDeclarationWithTypeNames typeNames ty <- arbitraryParameterDeclarationWithTypeNames unCIdentifier return $ isGoodType ty QC.==> let ty' = assertParse (cCParserContext True typeNames) parameter_declaration (prettyOneLine ty) in Types.untangleParameterDeclaration ty == Types.untangleParameterDeclaration ty' Hspec.it "parses everything which is pretty-printable (Haskell)" $ do #if MIN_VERSION_QuickCheck(2,9,0) QC.property $ QC.again $ do -- Work around #else QC.property $ do #endif ParameterDeclarationWithTypeNames typeNames ty <- arbitraryParameterDeclarationWithTypeNames unHaskellIdentifier return $ isGoodHaskellIdentifierType typeNames ty QC.==> let ty' = assertParse (haskellCParserContext True typeNames) parameter_declaration (prettyOneLine ty) in Types.untangleParameterDeclaration ty == Types.untangleParameterDeclaration ty' ------------------------------------------------------------------------ -- Utils 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 ++ " parsed string " ++ show s ++ " with type names " ++ show (cpcTypeNames ctx) Right x -> x prettyOneLine :: PP.Pretty a => a -> String prettyOneLine x = PP.displayS (PP.renderCompact (PP.pretty x)) "" isGoodType :: ParameterDeclaration i -> Bool isGoodType ty = case Types.untangleParameterDeclaration ty of Left{} -> False Right{} -> True isGoodHaskellIdentifierType :: TypeNames -> ParameterDeclaration HaskellIdentifier -> Bool isGoodHaskellIdentifierType typeNames ty0 = case Types.untangleParameterDeclaration ty0 of Left{} -> False Right ty -> case Types.parameterDeclarationId ty of Nothing -> True Just i -> let -- see leadingSegment : _ = splitOn "." (unHaskellIdentifier i) in case cIdentifierFromString True leadingSegment of Left{} -> True Right seg -> not (seg `HashSet.member` typeNames) ------------------------------------------------------------------------ -- Arbitrary 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 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 True (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 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']