wxdirect-0.90.1.0: src/ParseC.hs
-----------------------------------------------------------------------------------------
{-| Module : ParseC
Copyright : (c) Daan Leijen 2003
License : BSD-style
Maintainer : wxhaskell-devel@lists.sourceforge.net
Stability : provisional
Portability : portable
Parse the wxc C header files.
-}
-----------------------------------------------------------------------------------------
module ParseC( parseC, readHeaderFile ) where
import Data.Char( isSpace )
import Data.List( isPrefixOf )
import Data.Functor( (<$>) )
import System.Process( readProcess )
import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language
import Types
{-----------------------------------------------------------------------------------------
Parse C
-----------------------------------------------------------------------------------------}
parseC :: FilePath -> IO [Decl]
parseC fname
= do contents <- readHeaderFile fname
declss <- mapM (parseDecl fname) (pairComments contents)
return (concat declss)
readHeaderFile :: FilePath -> IO [String]
readHeaderFile fname =
do
includeDirectories <- getIncludeDirectories
putStrLn ("Preprocessing and parsing file: " ++ fname ++
",\n using include directories: " ++ (unwords includeDirectories))
flattenComments . filter (not . isPrefixOf "#") . lines <$>
readProcess
"cpp"
( includeDirectories ++
[ "-C" -- Keep the comments
, "-DWXC_TYPES_H" -- Make sure wxc_types.h is not included,
-- so the type macros are not replaced
-- (the parser scans for certain macros)
, fname -- The file to process
]
)
""
getIncludeDirectories :: IO [String]
getIncludeDirectories =
filter (isPrefixOf "-I") . words <$>
readProcess "wx-config" ["--cppflags"] ""
-- flaky, but suitable
flattenComments :: [String] -> [String]
flattenComments inputLines
= case inputLines of
(('/':'*':_):_) -> let (incomment,comment:rest) = span (not . endsComment) inputLines
in (concat (incomment ++ [comment]) : flattenComments rest)
xs : xss -> xs : flattenComments xss
[] -> []
where
endsComment line = isPrefixOf "/*" (dropWhile isSpace (reverse line))
pairComments :: [String] -> [(String,String)]
pairComments inputLines
= case inputLines of
('/':'*':'*':xs) : ys : xss | not (classDef ys) -> (reverse (drop 2 (reverse xs)),ys) : pairComments xss
xs : xss | not (classDef xs) -> ("",xs) : pairComments xss
| otherwise -> pairComments xss
[] -> []
where
classDef xs = isPrefixOf "TClassDef" xs
parseDecl :: FilePath -> (String,String) -> IO [Decl]
parseDecl fname (comment,line)
= case parse pdecl fname line of
Left err -> do putStrLn ("ignore: parse error : " ++ show err ++ ", on : " ++ line)
return []
Right mbd -> case mbd of
Just d -> return [d{ declComment = comment }]
Nothing -> return [] -- empty line
{-----------------------------------------------------------------------------------------
Parse declaration
-----------------------------------------------------------------------------------------}
-- parse a declaration: return Nothing on an empty declaration
pdecl :: Parser (Maybe Decl)
pdecl
= do whiteSpace
x <- (do f <- pfundecl; return (Just f)) <|> return Nothing
eof
return x
pfundecl :: Parser Decl
pfundecl
= do optional (reserved "EXPORT")
declRet' <- ptype
optional (reserved "_stdcall" <|> reserved "__cdecl")
declName' <- identifier <?> "function name"
declArgs' <- pargs
_ <- semi
return (Decl declName' declRet' declArgs' "")
<?> "function declaration"
pargs :: Parser [Arg]
pargs
= parens (commaSep parg)
<?> "arguments"
parg :: Parser Arg
parg
= pargTypes
<|> do argType' <- ptype
argName' <- identifier
return (Arg [argName'] argType')
<?> "argument"
ptype :: Parser Type
ptype
= do tp <- patomtype
stars <- many (symbol "*")
return (foldr (\_ tp' -> Ptr tp') tp stars)
<?> "type"
patomtype :: Parser Type
patomtype
= do reserved "void"; return Void
<|> do reserved "int"; return (Int CInt)
<|> do reserved "char"; return Char
<|> do reserved "long"; return (Int CLong)
<|> do reserved "double"; return Double
<|> do reserved "float"; return Float
<|> do reserved "size_t"; return (Int SizeT)
<|> do reserved "time_t"; return (Int TimeT)
<|> do reserved "uint8_t"; return Word8
<|> do reserved "uint32_t"; return Word32
<|> do reserved "uint64_t"; return Word64
<|> do reserved "intptr_t"; return IntPtr
<|> do reserved "int64_t"; return Int64
<|> do reserved "TIntPtr"; return IntPtr
<|> do reserved "TInt64"; return Int64
<|> do reserved "TUInt"; return Word
<|> do reserved "TUInt8"; return Word8
<|> do reserved "TUInt32"; return Word32
<|> do reserved "TBool"; return Bool
<|> do reserved "TBoolInt"; return Bool
<|> do reserved "TChar"; return Char
<|> do reserved "TString"; return (String CChar)
<|> do reserved "TStringVoid"; return (String CVoid)
<|> do reserved "TStringOut"; return (StringOut CChar)
<|> do reserved "TStringOutVoid"; return (StringOut CVoid)
<|> do reserved "TStringLen"; return StringLen
<|> do reserved "TByteData"; return Char
<|> do reserved "TByteStringOut"; return (ByteStringOut Strict)
<|> do reserved "TByteStringLazyOut"; return (ByteStringOut Lazy)
<|> do reserved "TByteStringLen"; return ByteStringLen
<|> do reserved "TArrayLen"; return ArrayLen
<|> do reserved "TArrayStringOut"; return (ArrayStringOut CChar)
<|> do reserved "TArrayStringOutVoid"; return (ArrayStringOut CVoid)
<|> do reserved "TArrayIntOut"; return (ArrayIntOut CInt)
<|> do reserved "TArrayIntPtrOut"; return (ArrayIntPtrOut CInt)
<|> do reserved "TArrayIntOutVoid"; return (ArrayIntOut CVoid)
<|> do reserved "TArrayIntPtrOutVoid"; return (ArrayIntPtrOut CVoid)
<|> do reserved "TClosureFun"; return (Fun "Ptr fun -> Ptr state -> Ptr (TEvent evt) -> IO ()")
<|> do reserved "TClass"
name <- parens identifier
return (Object name)
<|> do reserved "TSelf"
name <- parens identifier
return (Object name)
<|> do reserved "TClassRef"
name <- parens identifier
return (RefObject name)
<|> do reserved "TArrayObjectOut"
name <- parens identifier
return (ArrayObjectOut name CObject)
<|> do reserved "TArrayObjectOutVoid"
name <- parens identifier
return (ArrayObjectOut name CVoid)
pargTypes :: Parser Arg
pargTypes
= do tp <- pargType2
argnames <- parens pargs2
return (Arg argnames tp)
<|>
do tp <- pargType3
argnames <- parens pargs3
return (Arg argnames tp)
<|>
do tp <- pargType4
argnames <- parens pargs4
return (Arg argnames tp)
<|>
do reserved "TArrayObject"
parens (do n <- identifier
_ <- comma
tp <- identifier
_ <- comma
p <- identifier
return (Arg [n,p] (ArrayObject tp CVoid)))
pargs2 :: Parser [String]
pargs2
= do a1 <- identifier
_ <- comma
a2 <- identifier
return [a1,a2]
pargs3 :: Parser [String]
pargs3
= do a1 <- identifier
_ <- comma
a2 <- identifier
_ <- comma
a3 <- identifier
return [a1,a2,a3]
pargs4 :: Parser [String]
pargs4
= do a1 <- identifier
_ <- comma
a2 <- identifier
_ <- comma
a3 <- identifier
_ <- comma
a4 <- identifier
return [a1,a2,a3,a4]
pargType2 :: Parser Type
pargType2
= do reserved "TPoint"; return (Point CInt)
<|> do reserved "TSize"; return (Size CInt)
<|> do reserved "TVector"; return (Vector CInt)
<|> do reserved "TPointDouble"; return (Point CDouble)
<|> do reserved "TPointLong"; return (Point CLong)
<|> do reserved "TSizeDouble"; return (Size CDouble)
<|> do reserved "TVectorDouble"; return (Vector CDouble)
<|> do reserved "TPointOut"; return (PointOut CInt)
<|> do reserved "TSizeOut"; return (SizeOut CInt)
<|> do reserved "TVectorOut"; return (VectorOut CInt)
<|> do reserved "TPointOutDouble"; return (PointOut CDouble)
<|> do reserved "TPointOutVoid"; return (PointOut CVoid)
<|> do reserved "TSizeOutDouble"; return (SizeOut CDouble)
<|> do reserved "TSizeOutVoid"; return (SizeOut CVoid)
<|> do reserved "TVectorOutDouble"; return (VectorOut CDouble)
<|> do reserved "TVectorOutVoid"; return (VectorOut CVoid)
<|> do reserved "TArrayString"; return (ArrayString CChar)
<|> do reserved "TArrayInt"; return (ArrayInt CInt)
<|> do reserved "TArrayIntPtr"; return (ArrayIntPtr CInt)
<|> do reserved "TByteString"; return (ByteString Strict)
<|> do reserved "TByteStringLazy"; return (ByteString Lazy)
pargType3 :: Parser Type
pargType3
= do reserved "TColorRGB"; return (ColorRGB CChar)
pargType4 :: Parser Type
pargType4
= do reserved "TRect"; return (Rect CInt)
<|> do reserved "TRectDouble"; return (Rect CDouble)
<|> do reserved "TRectOut"; return (RectOut CInt)
<|> do reserved "TRectOutDouble"; return (RectOut CDouble)
<|> do reserved "TRectOutVoid"; return (RectOut CVoid)
{-----------------------------------------------------------------------------------------
The lexer
-----------------------------------------------------------------------------------------}
lexer :: P.TokenParser ()
lexer
= P.makeTokenParser $
emptyDef
{ commentStart = "/*"
, commentEnd = "*/"
, commentLine = "#" -- ignore pre-processor stuff, but fail to recognise "//"
, nestedComments = False
, identStart = letter <|> char '_'
, identLetter = alphaNum <|> oneOf "_'"
, caseSensitive = True
, reservedNames = ["void","int","long","float","double","char","size_t","time_t","_stdcall","__cdecl"
,"TChar","TBool"
,"TIntPtr"
,"TClass","TSelf","TClassRef"
,"TByteData","TByteString","TByteStringOut","TByteStringLen"
,"TString","TStringOut","TStringLen", "TStringVoid"
,"TPoint","TSize","TVector","TRect"
,"TPointOut","TSizeOut","TVectorOut","TRectOut"
,"TPointOutVoid","TSizeOutVoid","TVectorOutVoid","TRectOutVoid"
,"TClosureFun"
,"TPointDouble", "TPointLong", "TSizeDouble", "TVectorDouble", "TRectDouble"
,"TPointOutDouble", "TSizeOutDouble", "TVectorOutDouble", "TRectOutDouble"
,"TArrayLen","TArrayStringOut","TArrayStringOutVoid","TArrayObjectOut","TArrayObjectOutVoid"
,"TColorRGB"
,"EXPORT"
]
}
whiteSpace :: Parser ()
whiteSpace = P.whiteSpace lexer
symbol :: String -> Parser String
symbol = P.symbol lexer
parens :: Parser a -> Parser a
parens = P.parens lexer
semi :: Parser String
semi = P.semi lexer
comma :: Parser String
comma = P.comma lexer
commaSep :: Parser a -> Parser [a]
commaSep = P.commaSep lexer
identifier :: Parser String
identifier = P.identifier lexer
reserved :: String -> Parser ()
reserved = P.reserved lexer