wxdirect-0.13.1: 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 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 lines <- readHeaderFile fname
declss <- mapM (parseDecl fname) (pairComments lines)
-- putStrLn ("ok.")
return (concat declss)
-- flaky but suitable.
readHeaderFile :: FilePath -> IO [String]
readHeaderFile fname
= do putStrLn ("parsing: " ++ fname)
input <- readFile fname
lls <- mapM readIncludeFile (flattenComments (lines input))
return (concat lls)
where
pathName
= reverse $ dropWhile (\c -> not (elem c "/\\")) $ reverse fname
readIncludeFile line
| isPrefixOf "#include \"" line
= readHeaderFile (pathName ++ includePath)
where
includePath = takeWhile (/='"') $ tail $ dropWhile (/='"') line
readIncludeFile line
= return [line]
-- flaky, but suitable
flattenComments :: [String] -> [String]
flattenComments lines
= case lines of
(('/':'*':xs):xss) -> let (incomment,comment:rest) = span (not . endsComment) lines
in (concat (incomment ++ [comment]) : flattenComments rest)
xs : xss -> xs : flattenComments xss
[] -> []
where
endsComment line = isPrefixOf "/*" (dropWhile isSpace (reverse line))
pairComments :: [String] -> [(String,String)]
pairComments lines
= case lines 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 "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 "TArrayIntOutVoid"; return (ArrayIntOut 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
= do a1 <- identifier
comma
a2 <- identifier
return [a1,a2]
pargs3
= do a1 <- identifier
comma
a2 <- identifier
comma
a3 <- identifier
return [a1,a2,a3]
pargs4
= do a1 <- identifier
comma
a2 <- identifier
comma
a3 <- identifier
comma
a4 <- identifier
return [a1,a2,a3,a4]
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 "TByteString"; return (ByteString Strict)
<|> do reserved "TByteStringLazy"; return (ByteString Lazy)
pargType3
= do reserved "TColorRGB"; return (ColorRGB CChar)
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"
,"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 = P.whiteSpace lexer
lexeme = P.lexeme lexer
symbol = P.symbol lexer
parens = P.parens lexer
semi = P.semi lexer
comma = P.comma lexer
commaSep = P.commaSep lexer
identifier = P.identifier lexer
reserved = P.reserved lexer