module Language.C.Types.Parse
(
CParser
, IsTypeName
, runCParser
, quickCParser
, quickCParser_
, Identifier(..)
, identifier
, identifier_no_lex
, DeclarationSpecifier(..)
, declaration_specifiers
, StorageClassSpecifier(..)
, storage_class_specifier
, TypeSpecifier(..)
, type_specifier
, TypeQualifier(..)
, type_qualifier
, FunctionSpecifier(..)
, function_specifier
, Declarator(..)
, declarator
, DirectDeclarator(..)
, direct_declarator
, ArrayOrProto(..)
, array_or_proto
, ArrayType(..)
, array_type
, Pointer(..)
, pointer
, ParameterDeclaration(..)
, parameter_declaration
, parameter_list
, AbstractDeclarator(..)
, abstract_declarator
, DirectAbstractDeclarator(..)
, direct_abstract_declarator
, ParameterDeclarationWithTypeNames(..)
) where
import Control.Applicative
import Control.Monad (msum, void, MonadPlus, unless, when)
import Control.Monad.Reader (MonadReader, ask, runReaderT, ReaderT)
import Data.Functor.Identity (Identity)
import qualified Data.HashSet as HashSet
import Data.Maybe (mapMaybe)
import Data.Monoid ((<>))
import qualified Data.Set as Set
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
import Text.Parser.LookAhead
import Text.Parser.Token
import qualified Text.Parser.Token.Highlight as Highlight
import Text.PrettyPrint.ANSI.Leijen (Pretty(..), (<+>), Doc, hsep)
import qualified Text.PrettyPrint.ANSI.Leijen as PP
type IsTypeName = Identifier -> Bool
type CParser m = (Monad m, Functor m, Applicative m, MonadPlus m, Parsing m, CharParsing m, TokenParsing m, LookAheadParsing m, MonadReader IsTypeName m)
runCParser
:: Parsec.Stream s Identity Char
=> IsTypeName
-> String
-> s
-> (ReaderT IsTypeName (Parsec.Parsec s ()) a)
-> Either Parsec.ParseError a
runCParser isTypeName fn s p = Parsec.parse (runReaderT p isTypeName) fn s
quickCParser
:: IsTypeName
-> String
-> (ReaderT IsTypeName (Parsec.Parsec String ()) a)
-> a
quickCParser isTypeName s p = case runCParser isTypeName "quickCParser" s p of
Left err -> error $ "quickCParser: " ++ show err
Right x -> x
quickCParser_
:: String
-> (ReaderT IsTypeName (Parsec.Parsec String ()) a)
-> 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'] ++ ['_']
reservedWords :: HashSet.HashSet String
reservedWords = HashSet.fromList
[ "auto", "else", "long", "switch"
, "break", "enum", "register", "typedef"
, "case", "extern", "return", "union"
, "char", "float", "short", "unsigned"
, "const", "for", "signed", "void"
, "continue", "goto", "sizeof", "volatile"
, "default", "if", "static", "while"
, "do", "int", "struct", "double"
]
identStyle :: CParser m => IdentifierStyle m
identStyle = IdentifierStyle
{ _styleName = "C identifier"
, _styleStart = identLetter
, _styleLetter = identLetter <|> digit
, _styleReserved = reservedWords
, _styleHighlight = Highlight.Identifier
, _styleReservedHighlight = Highlight.ReservedIdentifier
}
data DeclarationSpecifier
= StorageClassSpecifier StorageClassSpecifier
| TypeSpecifier TypeSpecifier
| TypeQualifier TypeQualifier
| FunctionSpecifier FunctionSpecifier
deriving (Typeable, Eq, Show)
declaration_specifiers :: forall m. CParser m => m [DeclarationSpecifier]
declaration_specifiers = many1 $ msum
[ StorageClassSpecifier <$> storage_class_specifier
, TypeSpecifier <$> type_specifier
, TypeQualifier <$> type_qualifier
, FunctionSpecifier <$> function_specifier
]
data StorageClassSpecifier
= TYPEDEF
| EXTERN
| STATIC
| AUTO
| REGISTER
deriving (Typeable, Eq, Show)
storage_class_specifier :: CParser 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"
]
data TypeSpecifier
= VOID
| CHAR
| SHORT
| INT
| LONG
| FLOAT
| DOUBLE
| SIGNED
| UNSIGNED
| Struct Identifier
| Enum Identifier
| TypeName Identifier
deriving (Typeable, Eq, Show)
type_specifier :: CParser 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)
, 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"
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"
data TypeQualifier
= CONST
| RESTRICT
| VOLATILE
deriving (Typeable, Eq, Show)
type_qualifier :: CParser m => m TypeQualifier
type_qualifier = msum
[ CONST <$ reserve identStyle "const"
, RESTRICT <$ reserve identStyle "restrict"
, VOLATILE <$ reserve identStyle "volatile"
]
data FunctionSpecifier
= INLINE
deriving (Typeable, Eq, Show)
function_specifier :: CParser m => m FunctionSpecifier
function_specifier = msum
[ INLINE <$ reserve identStyle "inline"
]
data Declarator = Declarator
{ declaratorPointers :: [Pointer]
, declaratorDirect :: DirectDeclarator
} deriving (Typeable, Eq, Show)
declarator :: CParser m => m Declarator
declarator = (Declarator <$> many pointer <*> direct_declarator) <?> "declarator"
data DirectDeclarator
= DeclaratorRoot Identifier
| ArrayOrProto DirectDeclarator ArrayOrProto
| DeclaratorParens Declarator
deriving (Typeable, Eq, Show)
data ArrayOrProto
= Array ArrayType
| Proto [ParameterDeclaration]
deriving (Typeable, Eq, Show)
array_or_proto :: CParser m => m ArrayOrProto
array_or_proto = msum
[ Array <$> brackets array_type
, Proto <$> parens parameter_list
]
data ArrayType
= VariablySized
| Unsized
| SizedByInteger Integer
| SizedByIdentifier Identifier
deriving (Typeable, Eq, Show)
array_type :: CParser m => m ArrayType
array_type = msum
[ VariablySized <$ symbolic '*'
, SizedByInteger <$> natural
, SizedByIdentifier <$> identifier
, 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)
data Pointer
= Pointer [TypeQualifier]
deriving (Typeable, Eq, Show)
pointer :: CParser m => m Pointer
pointer = do
void $ symbolic '*'
Pointer <$> many type_qualifier
parameter_list :: CParser m => m [ParameterDeclaration]
parameter_list =
sepBy parameter_declaration $ symbolic ','
data ParameterDeclaration = ParameterDeclaration
{ parameterDeclarationSpecifiers :: [DeclarationSpecifier]
, parameterDeclarationDeclarator :: Either Declarator AbstractDeclarator
} deriving (Typeable, Eq, Show)
parameter_declaration :: CParser m => m ParameterDeclaration
parameter_declaration =
ParameterDeclaration
<$> declaration_specifiers
<*> mbabstract
where
mbabstract =
Left <$> try declarator <|>
Right <$> try abstract_declarator <|>
return (Right (AbstractDeclarator [] Nothing))
data AbstractDeclarator = AbstractDeclarator
{ abstractDeclaratorPointers :: [Pointer]
, abstractDeclaratorDirect :: Maybe DirectAbstractDeclarator
} deriving (Typeable, Eq, Show)
abstract_declarator :: CParser m => m AbstractDeclarator
abstract_declarator = do
ptrs <- many pointer
let p = if null ptrs
then Just <$> direct_abstract_declarator
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)
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"
instance Pretty Identifier where
pretty = PP.text . unIdentifier
instance Pretty DeclarationSpecifier where
pretty dspec = case dspec of
StorageClassSpecifier x -> pretty x
TypeSpecifier x -> pretty x
TypeQualifier x -> pretty x
FunctionSpecifier x -> pretty x
instance Pretty StorageClassSpecifier where
pretty storage = case storage of
TYPEDEF -> "typedef"
EXTERN -> "extern"
STATIC -> "static"
AUTO -> "auto"
REGISTER -> "register"
instance Pretty TypeSpecifier where
pretty tySpec = case tySpec of
VOID -> "void"
CHAR -> "char"
SHORT -> "short"
INT -> "int"
LONG -> "long"
FLOAT -> "float"
DOUBLE -> "double"
SIGNED -> "signed"
UNSIGNED -> "unsigned"
Struct x -> "struct" <+> pretty x
Enum x -> "enum" <+> pretty x
TypeName x -> pretty x
instance Pretty TypeQualifier where
pretty tyQual = case tyQual of
CONST -> "const"
RESTRICT -> "restrict"
VOLATILE -> "volatile"
instance Pretty FunctionSpecifier where
pretty funSpec = case funSpec of
INLINE -> "inline"
instance Pretty Declarator where
pretty (Declarator ptrs ddecltor) = case ptrs of
[] -> pretty ddecltor
_:_ -> prettyPointers ptrs <+> pretty ddecltor
prettyPointers :: [Pointer] -> Doc
prettyPointers [] = ""
prettyPointers (x : xs) = pretty x <> prettyPointers xs
instance Pretty Pointer where
pretty (Pointer tyQual) = "*" <> hsep (map pretty tyQual)
instance Pretty DirectDeclarator 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
pretty aorp = case aorp of
Array x -> "[" <> pretty x <> "]"
Proto x -> "(" <> prettyParams x <> ")"
prettyParams :: (Pretty a) => [a] -> Doc
prettyParams xs = case xs of
[] -> ""
[x] -> pretty x
x : xs'@(_:_) -> pretty x <> "," <+> prettyParams xs'
instance Pretty ArrayType where
pretty at = case at of
VariablySized -> "*"
SizedByInteger n -> pretty n
SizedByIdentifier s -> pretty s
Unsized -> ""
instance Pretty ParameterDeclaration 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
instance Pretty AbstractDeclarator 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
pretty ddecltor = case ddecltor of
AbstractDeclaratorParens x -> "(" <> pretty x <> ")"
ArrayOrProtoHere aop -> pretty aop
ArrayOrProtoThere ddecltor' aop -> pretty ddecltor' <> pretty aop
data OneOfSized a
= Anyhow a
| IfPositive a
deriving (Typeable, Eq, Show)
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
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']
data ParameterDeclarationWithTypeNames = ParameterDeclarationWithTypeNames
{ pdwtnTypeNames :: Set.Set Identifier
, pdwtnParameterDeclaration :: ParameterDeclaration
} deriving (Typeable, Eq, Show)
instance QC.Arbitrary ParameterDeclarationWithTypeNames where
arbitrary = do
names <- Set.fromList <$> QC.listOf arbitraryIdentifier
decl <- arbitraryParameterDeclarationFrom names
return $ ParameterDeclarationWithTypeNames names decl
arbitraryDeclarationSpecifierFrom :: Set.Set Identifier -> 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 :: Set.Set Identifier -> QC.Gen TypeSpecifier
arbitraryTypeSpecifierFrom typeNames = QC.oneof $
[ return VOID
, return CHAR
, return SHORT
, return INT
, return LONG
, return FLOAT
, return DOUBLE
, return SIGNED
, return UNSIGNED
, Struct <$> arbitraryIdentifierFrom typeNames
, Enum <$> arbitraryIdentifierFrom typeNames
] ++ if Set.null typeNames then []
else [TypeName <$> QC.elements (Set.toList typeNames)]
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 :: Set.Set Identifier -> QC.Gen Declarator
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
else return id'
arbitraryDirectDeclaratorFrom :: Set.Set Identifier -> QC.Gen DirectDeclarator
arbitraryDirectDeclaratorFrom typeNames = halveSize $ oneOfSized $
[ Anyhow $ DeclaratorRoot <$> arbitraryIdentifierFrom typeNames
, IfPositive $ DeclaratorParens <$> arbitraryDeclaratorFrom typeNames
, IfPositive $ ArrayOrProto
<$> arbitraryDirectDeclaratorFrom typeNames
<*> arbitraryArrayOrProtoFrom typeNames
]
arbitraryArrayOrProtoFrom :: Set.Set Identifier -> QC.Gen ArrayOrProto
arbitraryArrayOrProtoFrom typeNames = halveSize $ oneOfSized $
[ Anyhow $ Array <$> arbitraryArrayTypeFrom typeNames
, IfPositive $ Proto <$> QC.listOf (arbitraryParameterDeclarationFrom typeNames)
]
arbitraryArrayTypeFrom :: Set.Set Identifier -> QC.Gen ArrayType
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 :: Set.Set Identifier -> QC.Gen ParameterDeclaration
arbitraryParameterDeclarationFrom typeNames = halveSize $
ParameterDeclaration
<$> QC.listOf1 (arbitraryDeclarationSpecifierFrom typeNames)
<*> QC.oneof
[ Left <$> arbitraryDeclaratorFrom typeNames
, Right <$> arbitraryAbstractDeclaratorFrom typeNames
]
arbitraryAbstractDeclaratorFrom :: Set.Set Identifier -> QC.Gen AbstractDeclarator
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
:: Set.Set Identifier -> QC.Gen DirectAbstractDeclarator
arbitraryDirectAbstractDeclaratorFrom typeNames = halveSize $ oneOfSized $
[ Anyhow $ ArrayOrProtoHere <$> arbitraryArrayOrProtoFrom typeNames
, IfPositive $ AbstractDeclaratorParens <$> arbitraryAbstractDeclaratorFrom typeNames
, IfPositive $ ArrayOrProtoThere
<$> arbitraryDirectAbstractDeclaratorFrom typeNames
<*> arbitraryArrayOrProtoFrom typeNames
]
many1 :: CParser m => m a -> m [a]
many1 p = (:) <$> p <*> many p