wxdirect 0.90.1.1 → 0.91.0.0
raw patch · 12 files changed
+3362/−3359 lines, 12 filesdep ~process
Dependency ranges changed: process
Files
- src/Classes.hs +459/−459
- src/CompileClassInfo.hs +161/−161
- src/CompileClassTypes.hs +74/−74
- src/CompileClasses.hs +687/−687
- src/CompileHeader.hs +256/−256
- src/DeriveTypes.hs +735/−735
- src/HaskellNames.hs +191/−191
- src/IOExtra.hs +24/−24
- src/Main.hs +233/−233
- src/ParseC.hs +336/−333
- src/Types.hs +139/−139
- wxdirect.cabal +67/−67
src/Classes.hs view
@@ -1,459 +1,459 @@-------------------------------------------------------------------------------------------{-| Module : Classes- Copyright : (c) Daan Leijen 2003- License : BSD-style-- Maintainer : wxhaskell-devel@lists.sourceforge.net- Stability : provisional- Portability : portable-- Defines most of the classes in wxWidgets.--}-------------------------------------------------------------------------------------------module Classes( isClassName, isBuiltin, haskellClassDefs- , objectClassNames, classNames- , classExtends- , getWxcDir, setWxcDir- -- * Class info- , ClassInfo(..)- , classInfo- , classIsManaged- , findManaged- , managedClasses- ) where--import qualified Data.Set as Set-import qualified Data.Map as Map-import Text.Parsec.Prim hiding ( try )-import HaskellNames( haskellTypeName, isBuiltin )-import Types---- to parse a class hierarchy-import Text.ParserCombinators.Parsec-import ParseC( readHeaderFile )---- unsafe hack :-(-import System.IO.Unsafe( unsafePerformIO )-import Data.IORef------ urk, ugly hack to make "classes" function pure.-{-# NOINLINE wxcdir #-}-wxcdir :: IORef String-wxcdir- = unsafePerformIO $- do newIORef ("../wxc")--getWxcDir :: IO String-getWxcDir- = readIORef wxcdir--setWxcDir :: String -> IO ()-setWxcDir dir- = writeIORef wxcdir dir--{------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------}-{--ignoreClasses :: Set.Set String-ignoreClasses- = Set.fromList ["wxFile", "wxDir", "wxString", "wxManagedPtr"]--}--classes :: [Class]-classes- = unsafePerformIO $- do - -- urk, ugly hack.- wxcdir' <- getWxcDir- cs <- parseClassDefs (wxcdir' ++ "/include/wxc.h")- return cs---mergeClasses :: [Class] -> [Class] -> [Class]-mergeClasses xs ys- = foldr (\c cs -> mergeClass c cs) xs ys---mergeClass :: Class -> [Class] -> [Class]-mergeClass cls [] = [cls]-mergeClass cls1@(Class name1 subs1) (cls2@(Class name2 subs2) : cs)- | name1 == name2 = Class name2 (mergeClasses subs1 subs2) : cs- | otherwise = cls2:mergeClass cls1 cs---{------------------------------------------------------------------------------------------ Managed classes------------------------------------------------------------------------------------------}-data ClassInfo = ClassInfo{ classWxName :: String- , withSelf :: String -> String- , withPtr :: String- , withResult :: String- , withRef :: String- , objDelete :: String- , classTypeName :: String -> String- }- -classIsManaged :: String -> Bool-classIsManaged name- = case findManaged name of- Just _ -> True- Nothing -> False--classInfo :: String -> ClassInfo-classInfo name- = case findManaged name of- Just info -> info- Nothing -> standardInfo name--findManaged :: String -> Maybe ClassInfo-findManaged name- = find managedClasses- where- find [] = Nothing- find (info:rest) | classWxName info == name = Just info- | otherwise = find rest---standardInfo :: String -> ClassInfo-standardInfo name- = ClassInfo name (\methodName -> "withObjectRef " ++ methodName) "withObjectPtr" "withObjectResult" - "" "objectDelete" (\typevar -> haskellTypeName name ++ " " ++ typevar)--managedClasses :: [ClassInfo]-managedClasses - = -- standard reference objects with a distinguished static object. (i.e. wxNullBitmap)- map standardNull - ["Bitmap"- ,"Cursor"- ,"Icon"- ,"Font"- ,"Pen"- ,"Brush"- ] ++-- -- standard reference objects- map standardRef- ["Image"- ,"FontData"- ,"ListItem"- ,"PrintData"- ,"PrintDialogData"- ,"PageSetupDialogData"] ++-- -- standard reference object, but not a subclass of wxObject- [ ClassInfo "wxDateTime" (affix "withObjectRef") "withObjectPtr" "withManagedDateTimeResult" - "withRefDateTime" "dateTimeDelete" (affix "DateTime")- , ClassInfo "wxGridCellCoordsArray" (affix "withObjectRef") "withObjectPtr" - "withManagedGridCellCoordsArrayResult" - "withRefGridCellCoordsArray" "gridCellCoordsArrayDelete" (affix "GridCellCoordsArray")- ] ++--- -- managed objects (that are not passed by reference)- map standard- ["Sound"] ++-- -- translated directly to a Haskell datatype- [ ClassInfo "wxColour" (affix "withColourRef") "withColourPtr" "withManagedColourResult"- "withRefColour" "const (return ())" (const "Color")- , ClassInfo "wxString" (affix "withStringRef") "withStringPtr" "withManagedStringResult"- "withRefString" "const (return ())" (const "String")- , ClassInfo "wxPoint" (affix "withPointRef") "withPointPtr" "withWxPointResult"- "withRefPoint" "const (return ())" (const "Point")- , ClassInfo "wxSize" (affix "withSizeRef") "withSizePtr" "withWxSizeResult"- "withRefSize" "const (return ())" (const "Size")- , ClassInfo "wxRect" (affix "withWxRectRef") "withWxRectPtr" "withWxRectResult"- "withRefRect" "const (return ())" (const "Rect")- , ClassInfo "wxTreeItemId" (affix "withTreeItemIdRef") "withTreeItemIdPtr" "withManagedTreeItemIdResult"- "withRefTreeItemId" "const (return ())" (const "TreeItem")- ]--- where- standardNull name- = (standardRef name){ withResult = "withManaged" ++ name ++ "Result" }-- standardRef name- = (standard name){ withRef = "withRef" ++ name }-- standard name- = ClassInfo ("wx" ++ name) (affix "withObjectRef") "withObjectPtr" "withManagedObjectResult" - "" "objectDelete" (affix name)- - affix name arg- = name ++ " " ++ arg--{------------------------------------------------------------------------------------------ Classes------------------------------------------------------------------------------------------}-data Class- = Class String [Class]- deriving Eq--instance Show Class where- showsPrec _ c- = showString (showClass 0 c)---{--showClasses :: [Class] -> String-showClasses cs- = unlines (map (showClass 0) cs)--}--showClass :: Int -> Class -> [Char]-showClass indent (Class name subs)- = (replicate indent '\t' ++ name ++ concatMap ("\n"++) (map (showClass (indent+1)) subs))--isClassName :: String -> Bool-isClassName s- = Set.member s classNames--objectClassNames :: [String]-objectClassNames- = case filter isObject classes of- [classObject] -> flatten classObject- _ -> []- where- flatten (Class name derived)- = name : concatMap flatten derived-- isObject (Class name _derived)- = (name == "wxObject")---classNames :: Set.Set String-classNames- = Set.unions (map flatten classes)- where- flatten (Class name derived)- = Set.insert name (Set.unions (map flatten derived))--classExtends :: Map.Map String String-classExtends- = Map.unions (map (flatten "") classes)- where- flatten parent (Class name derived)- = Map.insert name parent (Map.unions (map (flatten name) derived))---{--sortClasses :: [Class] -> [Class]-sortClasses cs- = map sortExtends (sortBy cmp cs)- where- cmp (Class name1 _) (Class name2 _) = compare name1 name2-- sortExtends (Class name extends)- = Class name (sortClasses extends)--}--haskellClassDefs :: ([(String,[String])],[String]) -- exported, definitions-haskellClassDefs- = unzip (concatMap (haskellClass []) classes)---haskellClass :: [[Char]] -> Class -> [(([Char], [[Char]]), [Char])]-haskellClass parents (Class name derived)--- | isBuiltin name = [] -- handled as a basic type--- | otherwise- = ( (tname,[tname,inheritName tname,className tname])- , (- ("-- | Pointer to an object of type '" ++ tname ++ "'" ++- (if null parents then "" else ", derived from '" ++ head parents ++ "'") ++- ".\n" ++- "type " ++ tname ++ " a = " ++ inheritance)- ) ++ "\n" ++- "-- | Inheritance type of the " ++ tname ++ " class.\n" ++- "type " ++ inheritName tname ++ " a = " ++ inheritanceType ++ "\n" ++- "-- | Abstract type of the " ++ tname ++ " class.\n" ++- "data " ++ className tname ++ " a = " ++ className tname ++ "\n"- )- : concatMap (haskellClass (tname:parents)) derived- where- tname = haskellTypeName name- className s = "C" ++ haskellTypeName s- inheritName s = "T" ++ haskellTypeName s--{-- explicitInheritance- = foldl extend (className tname ++ " a") parents- where- extend child parent- = "C"++parent ++ " " ++ pparens child--}- inheritanceType- = (if null parents then id else (\tp -> inheritName (head parents) ++ " " ++ pparens tp))- (className tname ++ " a")-- inheritance- = (if null parents then "Object " else (haskellTypeName (head parents) ++ " "))- ++ pparens (className tname ++ " a")---pparens :: [Char] -> [Char]-pparens txt- = "(" ++ txt ++ ")"---{------------------------------------------------------------------------------------------ Read a class hierarchy from file.- The format consists of all classes on a line,- with subclassing expressed by putting tabs in front of the class.- see: http://www.wxwindows.org/classhierarchy.txt------------------------------------------------------------------------------------------}-{--parseClassHierarchy :: FilePath -> IO [Class]-parseClassHierarchy fname- = do result <- parseFromFile parseClasses (if null fname then "classhierarchy.txt" else fname)- case result of- Left err -> do putStrLn ("parse error in class hierarchy: " ++ show err)- return []- Right cs -> return cs- `catch` \(SomeException err) ->- do putStrLn ("exception while parsing: " ++ fname)- print err- return []--parseClasses :: Parser [Class]-parseClasses- = do cs <- pclasses 0- eof- return cs--pclasses :: Int -> Parser [Class]-pclasses indent- = do css <- many (pclass indent)- return (concat css)- <?> "classes"--pclass :: Int -> Parser [Class]-pclass indent- = do _ <- try (count indent pindent)- name <- pclassName- _ <- whiteSpace- mkClass- <- (do _ <- char '\n'- return (\subs -> filterClass (Class name subs))- <|>- do name2 <- try $- do _ <- char '='- _ <- whiteSpace- name2 <- pclassName- _ <- whiteSpace- _ <- char '\n'- return name2- return (\subs -> filterClass (Class name2 subs))- <|>- do _ <- skipToEndOfLine- return (\_subs -> []))- subs <- pclasses (indent+1)- return (mkClass subs)- <|>- do _ <- char '\n'- return []- <?> "class"--}--{--filterClass :: Class -> [Class]-filterClass (Class name subs)- | not (Set.member name ignoreClasses) = [Class name subs]-filterClass cls- = []--}--{--pindent :: Parser ()-pindent- = (char '\t' >> return ()) <|> - (count 8 space >> return ())- <?> ""--}--{--pclassName :: Parser [Char]-pclassName- = many1 alphaNum- <?> "class name"--}-{--skipToEndOfLine :: Parser Char-skipToEndOfLine- = do _ <- many (noneOf "\n")- char '\n'--}--whiteSpace :: Parser [Char]-whiteSpace- = many (oneOf " \t")--{------------------------------------------------------------------------------------------ parse class hierarchy from class definitions in a C header files:- TClassDef(tp)- TClassDefExtend(tp,parent)------------------------------------------------------------------------------------------}-parseClassDefs :: FilePath -> IO [Class]-parseClassDefs fname- = do putStrLn "reading class definitions:"- contents <- readHeaderFile fname- let defs = filter (not . null . fst) (map parseClassDef contents)- extends = Map.fromList defs- extend name- = complete (Class name [])- where- complete cls@(Class cname _ext)- = case Map.lookup cname extends of- Just "" -> cls- Just parent -> complete (Class parent [cls])- Nothing -> trace ("warning: undefined base class " ++ show cname ++ " in definition of " ++ show name) $- cls- clss = map (extend . fst) defs- return (foldr (\c cs -> mergeClass c cs) [] clss)--parseClassDef :: String -> (String,String)-parseClassDef line- = case parse pdef "" line of- Left _err -> ("","")- Right r -> r--pdef :: Parser (String,String)-pdef- = do _ <- reserved "TClassDefExtend"- _ <- psymbol "("- tp <- identifier- _ <- psymbol ","- ext <- identifier- _ <- psymbol ")"- return (tp,ext)- <|>- do _ <- reserved "TClassDef"- tp <- parens identifier- return (tp,"")---parens :: Parser b -> Parser b-parens p- = do { _ <- psymbol "("; x <- p; _ <- psymbol ")"; return x }--psymbol :: String -> Parser String-psymbol s- = lexeme (string s)--reserved :: String -> Parser String-reserved s- = lexeme (try (string s))--identifier :: Parser String-identifier- = lexeme (many1 alphaNum)--lexeme :: Parser b -> Parser b-lexeme p- = do{ x <- p- ; _ <- whiteSpace- ; return x- }+----------------------------------------------------------------------------------------- +{-| Module : Classes + Copyright : (c) Daan Leijen 2003 + License : BSD-style + + Maintainer : wxhaskell-devel@lists.sourceforge.net + Stability : provisional + Portability : portable + + Defines most of the classes in wxWidgets. +-} +----------------------------------------------------------------------------------------- +module Classes( isClassName, isBuiltin, haskellClassDefs + , objectClassNames, classNames + , classExtends + , getWxcDir, setWxcDir + -- * Class info + , ClassInfo(..) + , classInfo + , classIsManaged + , findManaged + , managedClasses + ) where + +import qualified Data.Set as Set +import qualified Data.Map as Map +import Text.Parsec.Prim hiding ( try ) +import HaskellNames( haskellTypeName, isBuiltin ) +import Types + +-- to parse a class hierarchy +import Text.ParserCombinators.Parsec +import ParseC( readHeaderFile ) + +-- unsafe hack :-( +import System.IO.Unsafe( unsafePerformIO ) +import Data.IORef + + + +-- urk, ugly hack to make "classes" function pure. +{-# NOINLINE wxcdir #-} +wxcdir :: IORef String +wxcdir + = unsafePerformIO $ + do newIORef ("../wxc") + +getWxcDir :: IO String +getWxcDir + = readIORef wxcdir + +setWxcDir :: String -> IO () +setWxcDir dir + = writeIORef wxcdir dir + +{----------------------------------------------------------------------------------------- + +-----------------------------------------------------------------------------------------} +{- +ignoreClasses :: Set.Set String +ignoreClasses + = Set.fromList ["wxFile", "wxDir", "wxString", "wxManagedPtr"] +-} + +classes :: [Class] +classes + = unsafePerformIO $ + do + -- urk, ugly hack. + wxcdir' <- getWxcDir + cs <- parseClassDefs (wxcdir' ++ "/include/wxc.h") + return cs + + +mergeClasses :: [Class] -> [Class] -> [Class] +mergeClasses xs ys + = foldr (\c cs -> mergeClass c cs) xs ys + + +mergeClass :: Class -> [Class] -> [Class] +mergeClass cls [] = [cls] +mergeClass cls1@(Class name1 subs1) (cls2@(Class name2 subs2) : cs) + | name1 == name2 = Class name2 (mergeClasses subs1 subs2) : cs + | otherwise = cls2:mergeClass cls1 cs + + +{----------------------------------------------------------------------------------------- + Managed classes +-----------------------------------------------------------------------------------------} +data ClassInfo = ClassInfo{ classWxName :: String + , withSelf :: String -> String + , withPtr :: String + , withResult :: String + , withRef :: String + , objDelete :: String + , classTypeName :: String -> String + } + +classIsManaged :: String -> Bool +classIsManaged name + = case findManaged name of + Just _ -> True + Nothing -> False + +classInfo :: String -> ClassInfo +classInfo name + = case findManaged name of + Just info -> info + Nothing -> standardInfo name + +findManaged :: String -> Maybe ClassInfo +findManaged name + = find managedClasses + where + find [] = Nothing + find (info:rest) | classWxName info == name = Just info + | otherwise = find rest + + +standardInfo :: String -> ClassInfo +standardInfo name + = ClassInfo name (\methodName -> "withObjectRef " ++ methodName) "withObjectPtr" "withObjectResult" + "" "objectDelete" (\typevar -> haskellTypeName name ++ " " ++ typevar) + +managedClasses :: [ClassInfo] +managedClasses + = -- standard reference objects with a distinguished static object. (i.e. wxNullBitmap) + map standardNull + ["Bitmap" + ,"Cursor" + ,"Icon" + ,"Font" + ,"Pen" + ,"Brush" + ] ++ + + -- standard reference objects + map standardRef + ["Image" + ,"FontData" + ,"ListItem" + ,"PrintData" + ,"PrintDialogData" + ,"PageSetupDialogData"] ++ + + -- standard reference object, but not a subclass of wxObject + [ ClassInfo "wxDateTime" (affix "withObjectRef") "withObjectPtr" "withManagedDateTimeResult" + "withRefDateTime" "dateTimeDelete" (affix "DateTime") + , ClassInfo "wxGridCellCoordsArray" (affix "withObjectRef") "withObjectPtr" + "withManagedGridCellCoordsArrayResult" + "withRefGridCellCoordsArray" "gridCellCoordsArrayDelete" (affix "GridCellCoordsArray") + ] ++ + + + -- managed objects (that are not passed by reference) + map standard + ["Sound"] ++ + + -- translated directly to a Haskell datatype + [ ClassInfo "wxColour" (affix "withColourRef") "withColourPtr" "withManagedColourResult" + "withRefColour" "const (return ())" (const "Color") + , ClassInfo "wxString" (affix "withStringRef") "withStringPtr" "withManagedStringResult" + "withRefString" "const (return ())" (const "String") + , ClassInfo "wxPoint" (affix "withPointRef") "withPointPtr" "withWxPointResult" + "withRefPoint" "const (return ())" (const "Point") + , ClassInfo "wxSize" (affix "withSizeRef") "withSizePtr" "withWxSizeResult" + "withRefSize" "const (return ())" (const "Size") + , ClassInfo "wxRect" (affix "withWxRectRef") "withWxRectPtr" "withWxRectResult" + "withRefRect" "const (return ())" (const "Rect") + , ClassInfo "wxTreeItemId" (affix "withTreeItemIdRef") "withTreeItemIdPtr" "withManagedTreeItemIdResult" + "withRefTreeItemId" "const (return ())" (const "TreeItem") + ] + + + where + standardNull name + = (standardRef name){ withResult = "withManaged" ++ name ++ "Result" } + + standardRef name + = (standard name){ withRef = "withRef" ++ name } + + standard name + = ClassInfo ("wx" ++ name) (affix "withObjectRef") "withObjectPtr" "withManagedObjectResult" + "" "objectDelete" (affix name) + + affix name arg + = name ++ " " ++ arg + +{----------------------------------------------------------------------------------------- + Classes +-----------------------------------------------------------------------------------------} +data Class + = Class String [Class] + deriving Eq + +instance Show Class where + showsPrec _ c + = showString (showClass 0 c) + + +{- +showClasses :: [Class] -> String +showClasses cs + = unlines (map (showClass 0) cs) +-} + +showClass :: Int -> Class -> [Char] +showClass indent (Class name subs) + = (replicate indent '\t' ++ name ++ concatMap ("\n"++) (map (showClass (indent+1)) subs)) + +isClassName :: String -> Bool +isClassName s + = Set.member s classNames + +objectClassNames :: [String] +objectClassNames + = case filter isObject classes of + [classObject] -> flatten classObject + _ -> [] + where + flatten (Class name derived) + = name : concatMap flatten derived + + isObject (Class name _derived) + = (name == "wxObject") + + +classNames :: Set.Set String +classNames + = Set.unions (map flatten classes) + where + flatten (Class name derived) + = Set.insert name (Set.unions (map flatten derived)) + +classExtends :: Map.Map String String +classExtends + = Map.unions (map (flatten "") classes) + where + flatten parent (Class name derived) + = Map.insert name parent (Map.unions (map (flatten name) derived)) + + +{- +sortClasses :: [Class] -> [Class] +sortClasses cs + = map sortExtends (sortBy cmp cs) + where + cmp (Class name1 _) (Class name2 _) = compare name1 name2 + + sortExtends (Class name extends) + = Class name (sortClasses extends) +-} + +haskellClassDefs :: ([(String,[String])],[String]) -- exported, definitions +haskellClassDefs + = unzip (concatMap (haskellClass []) classes) + + +haskellClass :: [[Char]] -> Class -> [(([Char], [[Char]]), [Char])] +haskellClass parents (Class name derived) +-- | isBuiltin name = [] -- handled as a basic type +-- | otherwise + = ( (tname,[tname,inheritName tname,className tname]) + , ( + ("-- | Pointer to an object of type '" ++ tname ++ "'" ++ + (if null parents then "" else ", derived from '" ++ head parents ++ "'") ++ + ".\n" ++ + "type " ++ tname ++ " a = " ++ inheritance) + ) ++ "\n" ++ + "-- | Inheritance type of the " ++ tname ++ " class.\n" ++ + "type " ++ inheritName tname ++ " a = " ++ inheritanceType ++ "\n" ++ + "-- | Abstract type of the " ++ tname ++ " class.\n" ++ + "data " ++ className tname ++ " a = " ++ className tname ++ "\n" + ) + : concatMap (haskellClass (tname:parents)) derived + where + tname = haskellTypeName name + className s = "C" ++ haskellTypeName s + inheritName s = "T" ++ haskellTypeName s + +{- + explicitInheritance + = foldl extend (className tname ++ " a") parents + where + extend child parent + = "C"++parent ++ " " ++ pparens child +-} + inheritanceType + = (if null parents then id else (\tp -> inheritName (head parents) ++ " " ++ pparens tp)) + (className tname ++ " a") + + inheritance + = (if null parents then "Object " else (haskellTypeName (head parents) ++ " ")) + ++ pparens (className tname ++ " a") + + +pparens :: [Char] -> [Char] +pparens txt + = "(" ++ txt ++ ")" + + +{----------------------------------------------------------------------------------------- + Read a class hierarchy from file. + The format consists of all classes on a line, + with subclassing expressed by putting tabs in front of the class. + see: http://www.wxwindows.org/classhierarchy.txt +-----------------------------------------------------------------------------------------} +{- +parseClassHierarchy :: FilePath -> IO [Class] +parseClassHierarchy fname + = do result <- parseFromFile parseClasses (if null fname then "classhierarchy.txt" else fname) + case result of + Left err -> do putStrLn ("parse error in class hierarchy: " ++ show err) + return [] + Right cs -> return cs + `catch` \(SomeException err) -> + do putStrLn ("exception while parsing: " ++ fname) + print err + return [] + +parseClasses :: Parser [Class] +parseClasses + = do cs <- pclasses 0 + eof + return cs + +pclasses :: Int -> Parser [Class] +pclasses indent + = do css <- many (pclass indent) + return (concat css) + <?> "classes" + +pclass :: Int -> Parser [Class] +pclass indent + = do _ <- try (count indent pindent) + name <- pclassName + _ <- whiteSpace + mkClass + <- (do _ <- char '\n' + return (\subs -> filterClass (Class name subs)) + <|> + do name2 <- try $ + do _ <- char '=' + _ <- whiteSpace + name2 <- pclassName + _ <- whiteSpace + _ <- char '\n' + return name2 + return (\subs -> filterClass (Class name2 subs)) + <|> + do _ <- skipToEndOfLine + return (\_subs -> [])) + subs <- pclasses (indent+1) + return (mkClass subs) + <|> + do _ <- char '\n' + return [] + <?> "class" +-} + +{- +filterClass :: Class -> [Class] +filterClass (Class name subs) + | not (Set.member name ignoreClasses) = [Class name subs] +filterClass cls + = [] +-} + +{- +pindent :: Parser () +pindent + = (char '\t' >> return ()) <|> + (count 8 space >> return ()) + <?> "" +-} + +{- +pclassName :: Parser [Char] +pclassName + = many1 alphaNum + <?> "class name" +-} +{- +skipToEndOfLine :: Parser Char +skipToEndOfLine + = do _ <- many (noneOf "\n") + char '\n' +-} + +whiteSpace :: Parser [Char] +whiteSpace + = many (oneOf " \t") + +{----------------------------------------------------------------------------------------- + parse class hierarchy from class definitions in a C header files: + TClassDef(tp) + TClassDefExtend(tp,parent) +-----------------------------------------------------------------------------------------} +parseClassDefs :: FilePath -> IO [Class] +parseClassDefs fname + = do putStrLn "reading class definitions:" + contents <- readHeaderFile fname + let defs = filter (not . null . fst) (map parseClassDef contents) + extends = Map.fromList defs + extend name + = complete (Class name []) + where + complete cls@(Class cname _ext) + = case Map.lookup cname extends of + Just "" -> cls + Just parent -> complete (Class parent [cls]) + Nothing -> trace ("warning: undefined base class " ++ show cname ++ " in definition of " ++ show name) $ + cls + clss = map (extend . fst) defs + return (foldr (\c cs -> mergeClass c cs) [] clss) + +parseClassDef :: String -> (String,String) +parseClassDef line + = case parse pdef "" line of + Left _err -> ("","") + Right r -> r + +pdef :: Parser (String,String) +pdef + = do _ <- reserved "TClassDefExtend" + _ <- psymbol "(" + tp <- identifier + _ <- psymbol "," + ext <- identifier + _ <- psymbol ")" + return (tp,ext) + <|> + do _ <- reserved "TClassDef" + tp <- parens identifier + return (tp,"") + + +parens :: Parser b -> Parser b +parens p + = do { _ <- psymbol "("; x <- p; _ <- psymbol ")"; return x } + +psymbol :: String -> Parser String +psymbol s + = lexeme (string s) + +reserved :: String -> Parser String +reserved s + = lexeme (try (string s)) + +identifier :: Parser String +identifier + = lexeme (many1 alphaNum) + +lexeme :: Parser b -> Parser b +lexeme p + = do{ x <- p + ; _ <- whiteSpace + ; return x + }
src/CompileClassInfo.hs view
@@ -1,161 +1,161 @@-------------------------------------------------------------------------------------------{-| Module : CompileClassInfo- Copyright : (c) Daan Leijen 2003, 2004- License : BSD-style-- Maintainer : wxhaskell-devel@lists.sourceforge.net- Stability : provisional- Portability : portable-- Module that compiles class types to a Haskell module for safe casting--}-------------------------------------------------------------------------------------------module CompileClassInfo( compileClassInfo ) where--import Data.Char( toLower )-import Data.List( sortBy {-, sort-} )---- import Types-import HaskellNames-import Classes-import IOExtra---{------------------------------------------------------------------------------------------ Compile------------------------------------------------------------------------------------------}-compileClassInfo :: Bool -> String -> String -> String -> String -> FilePath -> IO ()-compileClassInfo _verbose moduleRoot moduleClassesName moduleClassTypesName moduleName outputFile- = do let classNames' = sortBy cmpName objectClassNames- (classExports,classDefs) = unzip (map toHaskellClassType classNames') - (downcExports,downcDefs) = unzip (map toHaskellDowncast classNames')-- defCount = length classNames'-- export = concat [ ["module " ++ moduleRoot ++ moduleName- , " ( -- * Class Info"- , " ClassType, classInfo, instanceOf, instanceOfName"- , " -- * Safe casts"- , " , safeCast, ifInstanceOf, whenInstanceOf, whenValidInstanceOf"- , " -- * Class Types"- ]- , map (exportComma++) classExports- , [ " -- * Down casts" ]- , map (exportComma++) downcExports- , [ " ) where"- , ""- , "import System.IO.Unsafe( unsafePerformIO )"- , "import " ++ moduleRoot ++ moduleClassTypesName- , "import " ++ moduleRoot ++ "WxcTypes"- , "import " ++ moduleRoot ++ moduleClassesName- , ""- , "-- | The type of a class."- , "data ClassType a = ClassType (ClassInfo ())"- , ""- , "-- | Return the 'ClassInfo' belonging to a class type. (Do not delete this object, it is statically allocated)"- , "{-# NOINLINE classInfo #-}"- , "classInfo :: ClassType a -> ClassInfo ()"- , "classInfo (ClassType info) = info"- , ""- , "-- | Test if an object is of a certain kind. (Returns also 'True' when the object is null.)"- , "{-# NOINLINE instanceOf #-}"- , "instanceOf :: WxObject b -> ClassType a -> Bool"- , "instanceOf obj (ClassType classInfo) "- , " = if (objectIsNull obj)"- , " then True"- , " else unsafePerformIO (objectIsKindOf obj classInfo)"- , ""- , "-- | Test if an object is of a certain kind, based on a full wxWidgets class name. (Use with care)."- , "{-# NOINLINE instanceOfName #-}"- , "instanceOfName :: WxObject a -> String -> Bool"- , "instanceOfName obj className "- , " = if (objectIsNull obj)"- , " then True"- , " else unsafePerformIO ("- , " do classInfo <- classInfoFindClass className"- , " if (objectIsNull classInfo)"- , " then return False" - , " else objectIsKindOf obj classInfo)"- , ""- , "-- | A safe object cast. Returns 'Nothing' if the object is of the wrong type. Note that a null object can always be cast."- , "safeCast :: WxObject b -> ClassType (WxObject a) -> Maybe (WxObject a)"- , "safeCast obj classType"- , " | instanceOf obj classType = Just (objectCast obj)"- , " | otherwise = Nothing"- , ""- , "-- | Perform an action when the object has the right type /and/ is not null."- , "whenValidInstanceOf :: WxObject a -> ClassType (WxObject b) -> (WxObject b -> IO ()) -> IO ()"- , "whenValidInstanceOf obj classType f"- , " = whenInstanceOf obj classType $ \\object ->"- , " if (object==objectNull) then return () else f object"- , ""- , "-- | Perform an action when the object has the right kind. Note that a null object has always the right kind."- , "whenInstanceOf :: WxObject a -> ClassType (WxObject b) -> (WxObject b -> IO ()) -> IO ()"- , "whenInstanceOf obj classType f"- , " = ifInstanceOf obj classType f (return ())"- , ""- , "-- | Perform an action when the object has the right kind. Perform the default action if the kind is not correct. Note that a null object has always the right kind."- , "ifInstanceOf :: WxObject a -> ClassType (WxObject b) -> (WxObject b -> c) -> c -> c"- , "ifInstanceOf obj classType yes no"- , " = case safeCast obj classType of"- , " Just object -> yes object"- , " Nothing -> no"- , ""- ]- ]- prologue = getPrologue moduleName "class info"- (show defCount ++ " class info definitions.") []-- putStrLn ("generating: " ++ outputFile)- writeFileLazy outputFile (unlines (prologue ++ export ++ classDefs ++ downcDefs))- putStrLn ("generated " ++ show defCount ++ " class info definitions")- putStrLn "ok."--cmpName :: String -> String -> Ordering-cmpName s1 s2- = compare (map toLower (haskellTypeName s1)) (map toLower (haskellTypeName s2))--{--cmpDef :: Def -> Def -> Ordering-cmpDef def1 def2- = compare (defName def1) (defName def2)--}--exportComma :: String-exportComma = exportSpaces ++ ","--exportSpaces :: String-exportSpaces = " "---{------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------}-toHaskellClassType :: String -> (String,String)-toHaskellClassType className- = (classTypeDeclName- ,"{-# NOINLINE " ++ classTypeDeclName ++ " #-}\n" ++- classTypeDeclName ++ " :: ClassType (" ++ classTypeName' ++ " ())\n" ++- classTypeDeclName ++ " = ClassType (unsafePerformIO (classInfoFindClass " ++ classTypeString ++ "))\n\n"- )- where- classTypeDeclName :: String- classTypeDeclName = haskellDeclName ("class" ++ classTypeName')- classTypeName' :: String- classTypeName' = haskellTypeName className- classTypeString :: String- classTypeString = "\"" ++ className ++ "\""---{------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------}-toHaskellDowncast :: String -> (String,String)-toHaskellDowncast className- = (downcastName- ,downcastName ++ " :: " ++ classTypeName' ++ " a -> " ++ classTypeName' ++ " ()\n" ++- downcastName ++ " obj = objectCast obj\n\n"- )- where- classTypeName' = haskellTypeName className- downcastName = haskellDeclName ("downcast" ++ classTypeName')+----------------------------------------------------------------------------------------- +{-| Module : CompileClassInfo + Copyright : (c) Daan Leijen 2003, 2004 + License : BSD-style + + Maintainer : wxhaskell-devel@lists.sourceforge.net + Stability : provisional + Portability : portable + + Module that compiles class types to a Haskell module for safe casting +-} +----------------------------------------------------------------------------------------- +module CompileClassInfo( compileClassInfo ) where + +import Data.Char( toLower ) +import Data.List( sortBy {-, sort-} ) + +-- import Types +import HaskellNames +import Classes +import IOExtra + + +{----------------------------------------------------------------------------------------- + Compile +-----------------------------------------------------------------------------------------} +compileClassInfo :: Bool -> String -> String -> String -> String -> FilePath -> IO () +compileClassInfo _verbose moduleRoot moduleClassesName moduleClassTypesName moduleName outputFile + = do let classNames' = sortBy cmpName objectClassNames + (classExports,classDefs) = unzip (map toHaskellClassType classNames') + (downcExports,downcDefs) = unzip (map toHaskellDowncast classNames') + + defCount = length classNames' + + export = concat [ ["module " ++ moduleRoot ++ moduleName + , " ( -- * Class Info" + , " ClassType, classInfo, instanceOf, instanceOfName" + , " -- * Safe casts" + , " , safeCast, ifInstanceOf, whenInstanceOf, whenValidInstanceOf" + , " -- * Class Types" + ] + , map (exportComma++) classExports + , [ " -- * Down casts" ] + , map (exportComma++) downcExports + , [ " ) where" + , "" + , "import System.IO.Unsafe( unsafePerformIO )" + , "import " ++ moduleRoot ++ moduleClassTypesName + , "import " ++ moduleRoot ++ "WxcTypes" + , "import " ++ moduleRoot ++ moduleClassesName + , "" + , "-- | The type of a class." + , "data ClassType a = ClassType (ClassInfo ())" + , "" + , "-- | Return the 'ClassInfo' belonging to a class type. (Do not delete this object, it is statically allocated)" + , "{-# NOINLINE classInfo #-}" + , "classInfo :: ClassType a -> ClassInfo ()" + , "classInfo (ClassType info) = info" + , "" + , "-- | Test if an object is of a certain kind. (Returns also 'True' when the object is null.)" + , "{-# NOINLINE instanceOf #-}" + , "instanceOf :: WxObject b -> ClassType a -> Bool" + , "instanceOf obj (ClassType classInfo) " + , " = if (objectIsNull obj)" + , " then True" + , " else unsafePerformIO (objectIsKindOf obj classInfo)" + , "" + , "-- | Test if an object is of a certain kind, based on a full wxWidgets class name. (Use with care)." + , "{-# NOINLINE instanceOfName #-}" + , "instanceOfName :: WxObject a -> String -> Bool" + , "instanceOfName obj className " + , " = if (objectIsNull obj)" + , " then True" + , " else unsafePerformIO (" + , " do classInfo <- classInfoFindClass className" + , " if (objectIsNull classInfo)" + , " then return False" + , " else objectIsKindOf obj classInfo)" + , "" + , "-- | A safe object cast. Returns 'Nothing' if the object is of the wrong type. Note that a null object can always be cast." + , "safeCast :: WxObject b -> ClassType (WxObject a) -> Maybe (WxObject a)" + , "safeCast obj classType" + , " | instanceOf obj classType = Just (objectCast obj)" + , " | otherwise = Nothing" + , "" + , "-- | Perform an action when the object has the right type /and/ is not null." + , "whenValidInstanceOf :: WxObject a -> ClassType (WxObject b) -> (WxObject b -> IO ()) -> IO ()" + , "whenValidInstanceOf obj classType f" + , " = whenInstanceOf obj classType $ \\object ->" + , " if (object==objectNull) then return () else f object" + , "" + , "-- | Perform an action when the object has the right kind. Note that a null object has always the right kind." + , "whenInstanceOf :: WxObject a -> ClassType (WxObject b) -> (WxObject b -> IO ()) -> IO ()" + , "whenInstanceOf obj classType f" + , " = ifInstanceOf obj classType f (return ())" + , "" + , "-- | Perform an action when the object has the right kind. Perform the default action if the kind is not correct. Note that a null object has always the right kind." + , "ifInstanceOf :: WxObject a -> ClassType (WxObject b) -> (WxObject b -> c) -> c -> c" + , "ifInstanceOf obj classType yes no" + , " = case safeCast obj classType of" + , " Just object -> yes object" + , " Nothing -> no" + , "" + ] + ] + prologue = getPrologue moduleName "class info" + (show defCount ++ " class info definitions.") [] + + putStrLn ("generating: " ++ outputFile) + writeFileLazy outputFile (unlines (prologue ++ export ++ classDefs ++ downcDefs)) + putStrLn ("generated " ++ show defCount ++ " class info definitions") + putStrLn "ok." + +cmpName :: String -> String -> Ordering +cmpName s1 s2 + = compare (map toLower (haskellTypeName s1)) (map toLower (haskellTypeName s2)) + +{- +cmpDef :: Def -> Def -> Ordering +cmpDef def1 def2 + = compare (defName def1) (defName def2) +-} + +exportComma :: String +exportComma = exportSpaces ++ "," + +exportSpaces :: String +exportSpaces = " " + + +{----------------------------------------------------------------------------------------- + +-----------------------------------------------------------------------------------------} +toHaskellClassType :: String -> (String,String) +toHaskellClassType className + = (classTypeDeclName + ,"{-# NOINLINE " ++ classTypeDeclName ++ " #-}\n" ++ + classTypeDeclName ++ " :: ClassType (" ++ classTypeName' ++ " ())\n" ++ + classTypeDeclName ++ " = ClassType (unsafePerformIO (classInfoFindClass " ++ classTypeString ++ "))\n\n" + ) + where + classTypeDeclName :: String + classTypeDeclName = haskellDeclName ("class" ++ classTypeName') + classTypeName' :: String + classTypeName' = haskellTypeName className + classTypeString :: String + classTypeString = "\"" ++ className ++ "\"" + + +{----------------------------------------------------------------------------------------- + +-----------------------------------------------------------------------------------------} +toHaskellDowncast :: String -> (String,String) +toHaskellDowncast className + = (downcastName + ,downcastName ++ " :: " ++ classTypeName' ++ " a -> " ++ classTypeName' ++ " ()\n" ++ + downcastName ++ " obj = objectCast obj\n\n" + ) + where + classTypeName' = haskellTypeName className + downcastName = haskellDeclName ("downcast" ++ classTypeName')
src/CompileClassTypes.hs view
@@ -1,74 +1,74 @@-------------------------------------------------------------------------------------------{-| Module : CompileClassTypes- Copyright : (c) Daan Leijen 2003, 2004- License : BSD-style-- Maintainer : wxhaskell-devel@lists.sourceforge.net- Stability : provisional- Portability : portable-- Module that compiles classes to class type definitions to Haskell.--}-------------------------------------------------------------------------------------------module CompileClassTypes( compileClassTypes ) where--import qualified Data.Map as Map---- import Data.Time( getCurrentTime)--- import Types-import HaskellNames-import Classes( {-isClassName,-} haskellClassDefs )-import DeriveTypes( ClassName )-import IOExtra--{------------------------------------------------------------------------------------------ Compile------------------------------------------------------------------------------------------}-compileClassTypes :: Bool -> String -> String -> FilePath -> [FilePath] -> IO ()-compileClassTypes _showIgnore moduleRoot moduleName outputFile inputFiles- = do -- time <- getCurrentTime- let (exportsClass,classDecls) = haskellClassDefs- exportsClassClasses = exportDefs exportsClass -- classCount = length exportsClass- - export = concat [ ["module " ++ moduleRoot ++ moduleName- , " ( -- * Classes" ]- , exportsClassClasses- , [ " ) where"- , ""- , "import " ++ moduleRoot ++ "WxcObject"- , "" ]- ]-- prologue = getPrologue moduleName "class"- (show classCount ++ " class definitions.")- inputFiles- output = unlines (prologue ++ export ++ classDecls)-- putStrLn ("generating: " ++ outputFile)- writeFileLazy outputFile output- putStrLn ("generated " ++ show classCount ++ " class definitions.")- putStrLn ("ok.")---{------------------------------------------------------------------------------------------ Create export definitions------------------------------------------------------------------------------------------}-exportDefs :: [(ClassName,[String])] -> [String]-exportDefs classExports - = let classMap = Map.fromListWith (++) classExports - in concatMap exportDef $ zip [(0 :: Int)..] (Map.toAscList classMap)- where- exportDef (n, (className,exports))- = [heading 2 className] ++ (commaSep n) exports-- commaSep n xs- = zipWith (exportComma n) [(0 :: Int)..] xs-- heading i name- = exportSpaces ++ "-- " ++ replicate i '*' ++ " " ++ name-- exportComma n m str = exportSpaces ++ (if n == 0 && m == 0 then " " else ",") ++ str- exportSpaces = " "-+----------------------------------------------------------------------------------------- +{-| Module : CompileClassTypes + Copyright : (c) Daan Leijen 2003, 2004 + License : BSD-style + + Maintainer : wxhaskell-devel@lists.sourceforge.net + Stability : provisional + Portability : portable + + Module that compiles classes to class type definitions to Haskell. +-} +----------------------------------------------------------------------------------------- +module CompileClassTypes( compileClassTypes ) where + +import qualified Data.Map as Map + +-- import Data.Time( getCurrentTime) +-- import Types +import HaskellNames +import Classes( {-isClassName,-} haskellClassDefs ) +import DeriveTypes( ClassName ) +import IOExtra + +{----------------------------------------------------------------------------------------- + Compile +-----------------------------------------------------------------------------------------} +compileClassTypes :: Bool -> String -> String -> FilePath -> [FilePath] -> IO () +compileClassTypes _showIgnore moduleRoot moduleName outputFile inputFiles + = do -- time <- getCurrentTime + let (exportsClass,classDecls) = haskellClassDefs + exportsClassClasses = exportDefs exportsClass + + classCount = length exportsClass + + export = concat [ ["module " ++ moduleRoot ++ moduleName + , " ( -- * Classes" ] + , exportsClassClasses + , [ " ) where" + , "" + , "import " ++ moduleRoot ++ "WxcObject" + , "" ] + ] + + prologue = getPrologue moduleName "class" + (show classCount ++ " class definitions.") + inputFiles + output = unlines (prologue ++ export ++ classDecls) + + putStrLn ("generating: " ++ outputFile) + writeFileLazy outputFile output + putStrLn ("generated " ++ show classCount ++ " class definitions.") + putStrLn ("ok.") + + +{----------------------------------------------------------------------------------------- + Create export definitions +-----------------------------------------------------------------------------------------} +exportDefs :: [(ClassName,[String])] -> [String] +exportDefs classExports + = let classMap = Map.fromListWith (++) classExports + in concatMap exportDef $ zip [(0 :: Int)..] (Map.toAscList classMap) + where + exportDef (n, (className,exports)) + = [heading 2 className] ++ (commaSep n) exports + + commaSep n xs + = zipWith (exportComma n) [(0 :: Int)..] xs + + heading i name + = exportSpaces ++ "-- " ++ replicate i '*' ++ " " ++ name + + exportComma n m str = exportSpaces ++ (if n == 0 && m == 0 then " " else ",") ++ str + exportSpaces = " " +
src/CompileClasses.hs view
@@ -1,687 +1,687 @@-------------------------------------------------------------------------------------------{-| Module : CompileClasses- Copyright : (c) Daan Leijen 2003- License : BSD-style-- Maintainer : wxhaskell-devel@lists.sourceforge.net- Stability : provisional- Portability : portable-- Module that compiles method definitions to Haskell, together- with a proper marshalling wrapper.--}-------------------------------------------------------------------------------------------module CompileClasses( compileClasses, haskellTypeArg, haskellTypePar ) where--import qualified Data.Map as Map--import Data.Time( getCurrentTime )-import Data.Char( toLower )-import Data.List( isPrefixOf, sort, sortBy, elemIndex )--import Types-import HaskellNames-import Classes( haskellClassDefs, objectClassNames, ClassInfo(..), classInfo, classIsManaged )-import ParseC( parseC )-import DeriveTypes( deriveTypes, classifyName, Name(..), Method(..), ClassName )-import IOExtra--{------------------------------------------------------------------------------------------ Compile------------------------------------------------------------------------------------------}-compileClasses :: Bool -> String -> String -> String -> FilePath -> [FilePath] -> IO ()-compileClasses showIgnore moduleRoot moduleClassTypesName moduleName outputFile inputFiles- = do declss <- mapM parseC inputFiles- time <- getCurrentTime- let splitter = 'M'- (decls1,decls2) = let isLower decl = (haskellDeclName (declName decl) < [toLower splitter])- in span isLower (deriveTypes showIgnore (sortBy cmpDecl (concat declss)))-- postfix1 = "A" ++ [toEnum (fromEnum splitter -1)]- postfix2 = [splitter] ++ "Z"-- module1 = moduleRoot ++ moduleName ++ postfix1- module2 = moduleRoot ++ moduleName ++ postfix2-- export = concat [ ["module " ++ moduleRoot ++ moduleName- , " ( -- * Re-export"- , " module " ++ module1- , " , module " ++ module2- , " , module " ++ moduleRoot ++ moduleClassTypesName- , " ) where"- , ""- , "import " ++ module1- , "import " ++ module2- , "import " ++ moduleRoot ++ moduleClassTypesName- , ""- ]- ]-- (m1,c1) <- compileClassesFile showIgnore moduleRoot moduleClassTypesName- (moduleName ++ postfix1) (outputFile ++ postfix1) inputFiles decls1 time- (m2,c2) <- compileClassesFile showIgnore moduleRoot moduleClassTypesName- (moduleName ++ postfix2) (outputFile ++ postfix2) inputFiles decls2 time- let methodCount = m1 + m2- classCount = c1 + c2-- prologue = getPrologue moduleName "class"- (show methodCount ++ " methods for " ++ show classCount ++ " classes.")- inputFiles-- let output = unlines (prologue ++ export)- putStrLn ("generating: " ++ outputFile ++ ".hs")- writeFileLazy (outputFile ++ ".hs") output- putStrLn ("generated " ++ show methodCount ++ " total methods for " ++ show classCount ++ " total classes.")- putStrLn ("ok.")---compileClassesFile :: a- -> String- -> String- -> String- -> String- -> [String]- -> [Decl]- -> b- -> IO (Int, Int)-compileClassesFile _showIgnore moduleRoot moduleClassTypesName moduleName outputFile inputFiles decls _time- = do let foreignDecls = map foreignDecl decls- haskellDecls = map haskellDecl decls- typeDecls = map haskellTypeDecl decls-- marshalDecls = concat (zipWith3 (\t h f -> [t,h,f,""]) typeDecls haskellDecls foreignDecls)-- (exportsClass, _classDecls) = haskellClassDefs-- (exportsStatic,exportsClassClasses,classCount) = exportDefs decls exportsClass []-- methodCount = length decls- ghcoptions = [ "{-# LANGUAGE ForeignFunctionInterface #-}"]-- export = concat [ ["module " ++ moduleRoot ++ moduleName- , " ( -- * Global" ]- , (let es1 : es2 : estail = exportsStatic in es1 : dropFirstComma es2 : estail)- , [ " -- * Classes" ]- , exportsClassClasses- , [ " ) where"- , ""- , "import qualified Data.ByteString as B (ByteString, useAsCStringLen)"- , "import qualified Data.ByteString.Lazy as LB (ByteString, length, unpack)"- , "import System.IO.Unsafe( unsafePerformIO )"- , "import Foreign.C.Types(CInt(..), CWchar(..), CChar(..), CDouble(..))"- , "import " ++ moduleRoot ++ "WxcTypes"- , "import " ++ moduleRoot ++ moduleClassTypesName- , ""- ]- ]-- prologue = getPrologue moduleName "class"- (show methodCount ++ " methods for " ++ show classCount ++ " classes.")- inputFiles- output = unlines (ghcoptions ++ prologue ++ export ++ marshalDecls)-- putStrLn ("generating: " ++ outputFile ++ ".hs")- writeFileLazy (outputFile ++ ".hs") output- putStrLn ("generated " ++ show methodCount ++ " methods for " ++ show classCount ++ " classes.")- return (methodCount,classCount)---cmpDecl :: Decl -> Decl -> Ordering-cmpDecl decl1 decl2- = compare (haskellDeclName (declName decl1)) (haskellDeclName (declName decl2))--exportComma :: String-exportComma = exportSpaces ++ ","--exportSpaces :: String-exportSpaces = " "--dropFirstComma :: String -> String-dropFirstComma str = maybe str replaceNthWithSpace (elemIndex ',' str)- where replaceNthWithSpace n = let (front,back) = splitAt n str in front ++ " " ++ tail back--{------------------------------------------------------------------------------------------ Create export definitions------------------------------------------------------------------------------------------}-exportDefs :: [Decl] -> [(ClassName,[String])] -> [(ClassName,[String])] -> ([String],[String],Int)-exportDefs decls classExports shortExports- = let classMap = Map.fromListWith (++) (classExports ++ [("Events",[]),("Null",[]),("Misc.",[])])- methodMap = Map.map sort (Map.fromListWith (++) (map exportDef decls))- shortMap = Map.map sort (Map.fromListWith (++) shortExports)- exportMap = Map.mapWithKey (addMethods methodMap shortMap) classMap- eventEntry = case Map.lookup "Events" exportMap of- Just entry -> [("Events",entry)]- Nothing -> []- miscEntry = case Map.lookup "Misc." exportMap of- Just entry -> [("Misc.",entry)]- Nothing -> []- nullEntry = case Map.lookup "Null" exportMap of- Just entry -> [("Null",entry)]- Nothing -> []-- staticExps = map todef (nullEntry ++ eventEntry ++ miscEntry)- classExps = map todef (Map.toAscList (Map.delete "Null" (Map.delete "Misc." (Map.delete "Events" exportMap))))-- in (concat staticExps- ,concat classExps- ,length (filter (not . null) classExps)- )- where- addMethods methodMap shortMap className' _classDecls- | null decls'' = []- | otherwise = [heading 2 className'] ++ decls''- where- decls'' =- (case Map.lookup className' shortMap of- Nothing -> []- Just decls' -> [heading 3 "Short methods"] ++ (commaSep decls')) ++- (case Map.lookup className' methodMap of- Nothing -> []- Just decls' -> (commaSep decls'))--- todef (_classname,decls')- = decls'-- exportDef decl- = (case classifyName (declName decl) of- Name name | isPrefixOf "expEVT_" name -> "Events"- | isPrefixOf "Null_" name -> "Null"- | otherwise -> "Misc."- Create name -> haskellTypeName name- Method name _ -> haskellTypeName name- , [haskellDeclName (declName decl)])-- commaSep xs- = map (exportComma++) xs-- heading i name- = exportSpaces ++ "-- " ++ replicate i '*' ++ " " ++ name--{------------------------------------------------------------------------------------------ Short cut names (unused)------------------------------------------------------------------------------------------}-{--validShortNames :: [Decl] -> Set.Set String-validShortNames decls- = Set.fromList- $ map fst- $ filter ((==1).snd)- $ MultiSet.toOccurList- $ MultiSet.fromList- $ filter (any isUpper)- $ filter (not.isBuiltin.headToUpper)- $ filter (not.isClassName.headToUpper)- $ filter (not.isPrefixOf "wx")- $ filter ((>1).length)- $ map shortName decls- where- headToUpper [] = []- headToUpper (c:cs) = toUpper c : cs--}-{--shortName :: Decl -> String-shortName decl- = snd (shortNameEx decl)--}-{--shortNameEx :: Decl -> (String,String)-shortNameEx decl- = case classifyName (declName decl) of- Method cname (Normal name) -> (cname,haskellDeclName name)- Method cname (Set name) -> (cname,haskellDeclName ("Set"++name))- Method cname (Get name) -> (cname,haskellDeclName ("Get"++name))- _other -> ("","")--}-{--shortDecl :: Set.Set String -> Decl -> [((ClassName,[String]), [String])]-shortDecl validShorts decl | Set.member sname validShorts- = [( (cname,[sname])- , [haskellTypeSignature sname decl- ,sname ++ " = " ++ haskellDeclName (declName decl)- ,""]- )- ]- where- (cname,sname) = shortNameEx decl--shortDecl _validShorts _decl- = []--}--{------------------------------------------------------------------------------------------ Compile "xxx_Delete" methods to "objectDelete" to accomodate managed objects.------------------------------------------------------------------------------------------}-isDeleteMethod :: Decl -> Bool-isDeleteMethod decl- = case (declRet decl, declArgs decl, classifyName (declName decl)) of- (Void,[Arg [_] (Object selfName)],Method cname (Normal mname))- -> (mname == "Delete" || mname=="SafeDelete")- && (selfName == cname)- && (cname `elem` objectClassNames || classIsManaged cname)- _ -> False---{------------------------------------------------------------------------------------------ Make the "this" pointer the last argument------------------------------------------------------------------------------------------}--- 2003-7-2: We disable this argument swapping and make it the first argument.-haskellThisArgument :: Decl -> (Maybe Arg,[Arg])-haskellThisArgument decl- = (Nothing, declArgs decl)--haskellThisArgs :: Decl -> [(Bool,Arg)]-haskellThisArgs decl- = case classifyName (declName decl) of- Method name _ | not (null args) && (argType (head args) == Object name)- -> [(True,head args)] ++ [(False,arg) | arg <- tail args]- _other -> [(False,arg) | arg <- args]- where- args = declArgs decl--haskellSwapThis :: Decl -> [Arg]-haskellSwapThis decl- = case haskellThisArgument decl of- (Just this,args) -> args ++ [this]- (Nothing,args) -> args--{------------------------------------------------------------------------------------------ Translate a declaration to a haskell marshalling wrapper------------------------------------------------------------------------------------------}-haskellDecl :: Decl -> String-haskellDecl decl | isDeleteMethod decl- = haskellDeclName (declName decl) ++ nlStart- ++ objDelete (classInfo (case classifyName (declName decl) of- Method cname _ -> cname- _ -> "wxObject"))---haskellDecl decl- = methodName' ++ " " ++ haskellArgs (haskellSwapThis decl) ++ nlStart- ++ haskellToCResult decl (declRet decl) (- haskellToCArgsIO methodName' (haskellThisArgs decl)- ++ foreignName (declName decl) ++ " " ++ haskellToCArgs decl (declArgs decl)- )- where- methodName' = haskellDeclName (declName decl)--nl :: String-nl- = "\n "--nlStart :: String-nlStart- = "\n = "--pparens :: String -> String-pparens txt- = "(" ++ txt ++ ")"---haskellArgs :: [Arg] -> String-haskellArgs args- = concatMap (\arg -> haskellName (argName arg) ++ " ") args---haskellToCResult :: Decl -> Type -> String -> String-haskellToCResult decl tp call- = unsafeIO $- case tp of- Fun _ -> traceWarning "function as result" decl $ call- EventId -> "withIntResult $" ++ nl ++ call- Id -> "withIntResult $" ++ nl ++ call- Int _ -> "withIntResult $" ++ nl ++ call- IntPtr -> "withIntPtrResult $" ++ nl ++ call- Bool -> "withBoolResult $" ++ nl ++ call- Char -> "withCharResult $" ++ nl ++ call- Object obj -> withResult (classInfo obj) ++ " $" ++ nl ++ call- String _ -> "withWStringResult $ \\buffer -> " ++ nl ++ call ++ " buffer" -- always last argument!- ByteString Lazy -> "withLazyByteStringResult $ \\buffer -> " ++ nl ++ call ++ " buffer" -- always last argument!- ByteString _ -> "withByteStringResult $ \\buffer -> " ++ nl ++ call ++ " buffer" -- always last argument!- Point CDouble -> "withPointDoubleResult $ \\px py -> " ++ nl ++ call ++ " px py" -- always last argument!- Point _ -> "withPointResult $ \\px py -> " ++ nl ++ call ++ " px py" -- always last argument!- Vector CDouble -> "withVectorDoubleResult $ \\pdx pdy -> " ++ nl ++ call ++ " pdx pdy" -- always last argument!- Vector _ -> "withVectorResult $ \\pdx pdy -> " ++ nl ++ call ++ " pdx pdy" -- always last argument!- Size CDouble -> "withSizeDoubleResult $ \\pw ph -> " ++ nl ++ call ++ " pw ph" -- always last argument!- Size _ -> "withSizeResult $ \\pw ph -> " ++ nl ++ call ++ " pw ph" -- always last argument!- Rect CDouble -> "withRectDoubleResult $ \\px py pw ph -> " ++ nl ++ call ++ "px py pw ph" -- always last argument!- Rect _ -> "withRectResult $ \\px py pw ph -> " ++ nl ++ call ++ "px py pw ph" -- always last argument!-- RefObject name -> case withRef (classInfo name) of- "" -> errorMsgDecl decl "illegal reference object"- action -> action ++ " $ \\pref -> " ++ nl ++ call ++ " pref" -- always last argument!- ArrayInt _ -> "withArrayIntResult $ \\arr -> " ++ nl ++ call ++ " arr" -- always last- ArrayIntPtr _ -> "withArrayIntPtrResult $ \\arr -> " ++ nl ++ call ++ " arr" -- always last- ArrayString _ -> "withArrayWStringResult $ \\arr -> " ++ nl ++ call ++ " arr" -- always last- ArrayObject _ _ -> "withArrayObjectResult $ \\arr -> " ++ nl ++ call ++ " arr" -- always last- _other -> call- where- unsafeIO body- = case tp of- EventId -> "unsafePerformIO $" ++ nl ++ body- Id -> "unsafePerformIO $" ++ nl ++ body- _other | isPrefixOf "Null_" (declName decl) -> "unsafePerformIO $" ++ nl ++ body- | otherwise -> body---haskellToCArgsIO :: String -> [(Bool, Arg)] -> String-haskellToCArgsIO methodName' args- = concatMap (\(isSelf,arg) -> haskellToCArgIO methodName' isSelf arg) args---haskellToCArgIO :: String -> Bool -> Arg -> String-haskellToCArgIO methodName' isSelf arg- = case argType arg of- String _ -> "withCWString " ++ haskellName (argName arg)- ++ " $ \\" ++ haskellCStringName (argName arg) ++ " -> " ++ nl- ByteString Lazy -> "withArray (LB.unpack " ++ haskellName (argName arg) ++ ") $ \\"- ++ haskellByteStringName (argName arg)- ++ " -> " ++ nl- ByteString _ -> "B.useAsCStringLen " ++ haskellName (argName arg) ++ " $ \\"- ++ "(" ++ haskellByteStringName (argName arg) ++ ", " ++ haskellByteStringLenName (argName arg) ++ ") "- ++ " -> " ++ nl- ArrayString _- -> "withArrayWString " ++ haskellName (argName arg)- ++ " $ \\" ++ haskellArrayLenName (argName arg) ++ " " ++ haskellArrayName (argName arg)- ++ " -> " ++ nl- ArrayObject _tp _- -> "withArrayObject " ++ haskellName (argName arg)- ++ " $ \\" ++ haskellArrayLenName (argName arg) ++ " " ++ haskellArrayName (argName arg)- ++ " -> " ++ nl- ArrayInt _- -> "withArrayInt " ++ haskellName (argName arg)- ++ " $ \\" ++ haskellArrayLenName (argName arg) ++ " " ++ haskellArrayName (argName arg)- ++ " -> " ++ nl- ArrayIntPtr _- -> "withArrayIntPtr " ++ haskellName (argName arg)- ++ " $ \\" ++ haskellArrayLenName (argName arg) ++ " " ++ haskellArrayName (argName arg)- ++ " -> " ++ nl- Object obj -> (if isSelf then withSelf (classInfo obj) ("\"" ++ methodName' ++ "\"")- else withPtr (classInfo obj)) ++ " "- ++ haskellName (argName arg)- ++ " $ \\" ++ haskellCObjectName (argName arg) ++ " -> " ++ nl- _other -> ""---haskellToCArgs :: Decl -> [Arg] -> String-haskellToCArgs decl args- = concatMap (\arg -> haskellToCArg decl arg ++ " ") args---haskellToCArg :: Decl -> Arg -> String-haskellToCArg decl arg- = case argType arg of- RefObject _ -> traceError "reference object as argument" decl $ name- EventId -> traceError "event id as argument" decl $ name- Id -> traceError "id as argument" decl $ name- Int _ -> pparens ("toCInt " ++ name)- IntPtr -> pparens ("toCIntPtr " ++ name)- Char -> pparens ("toCWchar " ++ name)- Bool -> pparens ("toCBool " ++ name)- Fun _ -> pparens ("toCFunPtr " ++ name)-- String _ -> haskellCStringName (argName arg)- ByteString Lazy -> haskellByteStringName name ++ " (fromIntegral $ LB.length " ++ haskellName name ++ ")"- ByteString _ -> haskellByteStringName name ++ " " ++ haskellByteStringLenName name- Object _ -> haskellCObjectName (argName arg)- Point CDouble -> pparens ("toCDoublePointX " ++ name) ++ " " ++ pparens( "toCDoublePointY " ++ name)- Point _ -> pparens ("toCIntPointX " ++ name) ++ " " ++ pparens( "toCIntPointY " ++ name)- Vector CDouble -> pparens ("toCDoubleVectorX " ++ name) ++ " " ++ pparens( "toCDoubleVectorY " ++ name)- Vector _ -> pparens ("toCIntVectorX " ++ name) ++ " " ++ pparens( "toCIntVectorY " ++ name)- Size CDouble -> pparens ("toCDoubleSizeW " ++ name) ++ " " ++ pparens( "toCDoubleSizeH " ++ name)- Size _ -> pparens ("toCIntSizeW " ++ name) ++ " " ++ pparens( "toCIntSizeH " ++ name)- Rect CDouble -> pparens ("toCDoubleRectX " ++ name) ++ " " ++ pparens( "toCDoubleRectY " ++ name)- ++ pparens ("toCDoubleRectW " ++ name) ++ " " ++ pparens( "toCDoubleRectH " ++ name)- Rect _ -> pparens ("toCIntRectX " ++ name) ++ " " ++ pparens( "toCIntRectY " ++ name)- ++ pparens ("toCIntRectW " ++ name) ++ " " ++ pparens( "toCIntRectH " ++ name)- ColorRGB _ -> pparens ("colorRed " ++ name) ++ " "- ++ pparens ("colorGreen " ++ name) ++ " "- ++ pparens ("colorBlue " ++ name)-- ArrayString _ -> haskellArrayLenName name ++ " " ++ haskellArrayName name- ArrayObject _ _ -> haskellArrayLenName name ++ " " ++ haskellArrayName name- ArrayInt _ -> haskellArrayLenName name ++ " " ++ haskellArrayName name- ArrayIntPtr _ -> haskellArrayLenName name ++ " " ++ haskellArrayName name-- _other -> name- where- name = haskellName (argName arg)--haskellCStringName :: String -> String-haskellCStringName name- = "cstr_" ++ haskellName name--haskellByteStringName :: String -> String-haskellByteStringName name- = "bs_" ++ haskellName name--haskellByteStringLenName :: String -> String-haskellByteStringLenName name- = "bslen_" ++ haskellName name--haskellArrayName :: String -> String-haskellArrayName name- = "carr_" ++ haskellName name--haskellArrayLenName :: String -> String-haskellArrayLenName name- = "carrlen_" ++ haskellName name--haskellCObjectName :: String -> String-haskellCObjectName name- = "cobj_" ++ haskellName name--{------------------------------------------------------------------------------------------ Translate a declaration to a haskell type declaration------------------------------------------------------------------------------------------}--- | Generate a full haskell type declarations-haskellTypeDecl :: Decl -> String-haskellTypeDecl decl- = haskellHaddockComment decl ++ "\n" ++- haskellTypeSignature (haskellDeclName (declName decl)) decl---- | Generate a haddock comment-haskellHaddockComment :: Decl -> String-haskellHaddockComment decl- | null (declComment decl) = "-- | usage: (@" ++ callExpr ++ "@)."- | otherwise = "{- | " ++ declComment decl ++ " -}"- where- callExpr = case haskellThisArgument decl of- (Just this,args) -> haskellArgName (argName this) ++ " # " ++ haskellDeclName (declName decl) ++ callArgs args- (Nothing,args) -> haskellDeclName (declName decl) ++ callArgs args- callArgs args- = concatMap (\arg -> " " ++ haskellArgName (argName arg)) args---- | Generate a haskell type signature-haskellTypeSignature :: String -> Decl -> String-haskellTypeSignature name decl- = haskellRetType decl $- name ++ " :: " ++ haskellTypeArgs decl (haskellSwapThis decl)---haskellTypeArgs :: Decl -> [Arg] -> String-haskellTypeArgs decl args- = concatMap (\(i,arg) -> haskellTypeArg decl i arg ++ " -> ") (zip [1..] args)---haskellRetType :: Decl -> [Char] -> String-haskellRetType decl typedecl- = case declRet decl of- EventId -> "{-# NOINLINE " ++ haskellDeclName (declName decl) ++ " #-}\n" ++ typedecl ++ " EventId"- Id -> "{-# NOINLINE " ++ haskellDeclName (declName decl) ++ " #-}\n" ++ typedecl ++ " Int"- tp | isPrefixOf "Null_" (declName decl)- -> typedecl ++ haskellType 0 tp- | otherwise- -> typedecl ++ " IO " ++ haskellTypePar 0 tp------ type def. for clarity-haskellTypeArg :: a -> Int -> Arg -> String-haskellTypeArg _decl _i (Arg ["id"] (Int _)) = "Id"-haskellTypeArg _decl _i (Arg ["_id"] (Int _)) = "Id"-haskellTypeArg _decl _i (Arg ["_stl"] (Int _)) = "Style"-haskellTypeArg _decl i arg- = haskellType i (argType arg)---haskellTypePar :: Int -> Type -> String-haskellTypePar i tp- = parenType (haskellType i) tp---haskellType :: Int -> Type -> String-haskellType i tp- = case tp of- Bool -> "Bool"- Int _ -> "Int"- IntPtr -> "IntPtr"- Int64 -> "Int64"- Word -> "Word"- Word8 -> "Word8"- Word32 -> "Word32"- Word64 -> "Word64"- Void -> "()"- Char -> "Char"- Double -> "Double"- Float -> "Float"- Ptr Void -> "Ptr " ++ typeVar i- Ptr t -> "Ptr " ++ foreignTypePar i t- -- special- Vector CDouble -> "(Vector2 Double)"- Vector _ -> "Vector"- Point CDouble -> "(Point2 Double)"- Point _ -> "Point"- Size CDouble -> "(Size2D Double)"- Size _ -> "Size"- ColorRGB _ -> "Color"- String _ -> "String"- ByteString Lazy -> "LB.ByteString"- ByteString _ -> "B.ByteString"- ArrayString _ -> "[String]"- ArrayInt _ -> "[Int]"- ArrayIntPtr _ -> "[IntPtr]"- ArrayObject name _ -> "[" ++ haskellTypeName name ++ typeVar i ++ "]"- Rect CDouble -> "(Rect2D Double)"- Rect _ -> "Rect"- Fun f -> "FunPtr " ++ pparens f- RefObject name -> classTypeName (classInfo name) (typeVar i) -- haskellTypeName name ++ typeVar i- Object name -> classTypeName (classInfo name) (typeVar i) -- haskellTypeName name ++ typeVar i- _other -> error ("Non exaustive pattern: CompileClasses.haskellType: " ++ show tp)--{------------------------------------------------------------------------------------------ Translate a declaration to a foreign import declaration------------------------------------------------------------------------------------------}-foreignDecl :: Decl -> String-foreignDecl decl | isDeleteMethod decl- = ""--foreignDecl decl- = "foreign import ccall \"" ++ declName decl ++ "\" "- ++ foreignName (declName decl) ++ " :: "- ++ foreignArgs decl (declArgs decl) ++ foreignResultType (declRet decl)---foreignName :: String -> String-foreignName name- | isPrefixOf "wx" name && elem '_' name = name- | otherwise = "wx_" ++ name--foreignArgs :: Decl -> [Arg] -> String-foreignArgs decl args- = concatMap (\(i,arg) -> foreignArg decl i arg ++ " -> ") (zip [1..] args)---foreignArg :: Decl -> Int -> Arg -> String-foreignArg decl i arg- = case argType arg of- RefObject name -> traceError "RefObject in argument" decl $ foreignType i (RefObject name)- Void -> traceError "void type in argument" decl $ foreignType i Void- tp -> foreignType i tp---foreignResultType :: Type -> String-foreignResultType tp- = case tp of- ArrayInt _ -> "Ptr CInt -> IO CInt"- ArrayIntPtr _ -> "Ptr CIntPtr -> IO CInt"- ArrayString _ -> "Ptr (Ptr CWchar) -> IO CInt"- ArrayObject name _ -> "Ptr " ++ foreignTypePar 0 (Object name) ++ " -> IO CInt"- String _ -> "Ptr CWchar -> IO CInt"- ByteString _ -> "Ptr CChar -> IO CInt"- Point CDouble -> "Ptr CDouble -> Ptr CDouble -> IO ()"- Point _ -> "Ptr CInt -> Ptr CInt -> IO ()"- Vector CDouble -> "Ptr Double -> Ptr Double -> IO ()"- Vector _ -> "Ptr CInt -> Ptr CInt -> IO ()"- Size CDouble -> "Ptr CDouble -> Ptr CDouble -> IO ()"- Size _ -> "Ptr CInt -> Ptr CInt -> IO ()"- Rect CDouble -> "Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> IO ()"- Rect _ -> "Ptr CInt -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO ()"- RefObject _name -> foreignType 0 tp ++ " -> IO ()"- EventId -> "IO CInt"- Id -> "IO CInt"- _other -> "IO " ++ foreignTypePar 0 tp---foreignTypePar :: Int -> Type -> String-foreignTypePar i tp- = parenType (foreignType i) tp---foreignType :: Int -> Type -> [Char]-foreignType i tp- = case tp of- Bool -> "CBool"- Int _ -> "CInt"- Int64 -> "Int64"- IntPtr -> "CIntPtr"- Word -> "Word"- Word8 -> "Word8"- Word32 -> "Word32"- Word64 -> "Word64"- Void -> "()"- Char -> "CWchar"- Double -> "Double"- Float -> "Float"- Ptr Void -> "Ptr " ++ typeVar i- Ptr t -> "Ptr " ++ foreignTypePar i t- -- special- String _ -> "CWString"- ByteString Lazy -> "Ptr Word8 -> Int"- ByteString _ -> "Ptr CChar -> Int"- Point CDouble -> "CDouble -> CDouble"- Point _ -> "CInt -> CInt"- Vector CDouble -> "CDouble -> CDouble"- Vector _ -> "CInt -> CInt"- Size CDouble -> "CDouble -> CDouble"- Size _ -> "CInt -> CInt"- ColorRGB _ -> "Word8 -> Word8 -> Word8"- Rect CDouble -> "CDouble -> CDouble -> CDouble -> CDouble"- Rect _ -> "CInt -> CInt -> CInt -> CInt"- Fun f -> "Ptr " ++ pparens f- ArrayObject name _ -> "CInt -> Ptr " ++ foreignTypePar i (Object name)- ArrayString _ -> "CInt -> Ptr (Ptr CWchar)"- ArrayInt _ -> "CInt -> Ptr CInt"- ArrayIntPtr _ -> "CInt -> Ptr CIntPtr"- RefObject name -> "Ptr (T" ++ haskellTypeName name ++ typeVar i ++ ")"- Object name -> "Ptr (T" ++ haskellTypeName name ++ typeVar i ++ ")"- _ -> error $ "CompileClasses.foreignType: unexpected type: " ++ show tp---parenType :: (Type -> String) -> Type -> String-parenType f tp- = parenFun tp (f tp)- where- parenFun tp'- = case tp' of- Ptr _ -> pparens- Object _ -> pparens- RefObject _ -> pparens- _other -> id---typeVar :: Int -> String-typeVar i = " " ++ typeVars !! i--typeVars :: [String]-typeVars = "()" : [[toEnum (fromEnum 'a' + x)] | x <- [0..]]+----------------------------------------------------------------------------------------- +{-| Module : CompileClasses + Copyright : (c) Daan Leijen 2003 + License : BSD-style + + Maintainer : wxhaskell-devel@lists.sourceforge.net + Stability : provisional + Portability : portable + + Module that compiles method definitions to Haskell, together + with a proper marshalling wrapper. +-} +----------------------------------------------------------------------------------------- +module CompileClasses( compileClasses, haskellTypeArg, haskellTypePar ) where + +import qualified Data.Map as Map + +import Data.Time( getCurrentTime ) +import Data.Char( toLower ) +import Data.List( isPrefixOf, sort, sortBy, elemIndex ) + +import Types +import HaskellNames +import Classes( haskellClassDefs, objectClassNames, ClassInfo(..), classInfo, classIsManaged ) +import ParseC( parseC ) +import DeriveTypes( deriveTypes, classifyName, Name(..), Method(..), ClassName ) +import IOExtra + +{----------------------------------------------------------------------------------------- + Compile +-----------------------------------------------------------------------------------------} +compileClasses :: Bool -> String -> String -> String -> FilePath -> [FilePath] -> IO () +compileClasses showIgnore moduleRoot moduleClassTypesName moduleName outputFile inputFiles + = do declss <- mapM parseC inputFiles + time <- getCurrentTime + let splitter = 'M' + (decls1,decls2) = let isLower decl = (haskellDeclName (declName decl) < [toLower splitter]) + in span isLower (deriveTypes showIgnore (sortBy cmpDecl (concat declss))) + + postfix1 = "A" ++ [toEnum (fromEnum splitter -1)] + postfix2 = [splitter] ++ "Z" + + module1 = moduleRoot ++ moduleName ++ postfix1 + module2 = moduleRoot ++ moduleName ++ postfix2 + + export = concat [ ["module " ++ moduleRoot ++ moduleName + , " ( -- * Re-export" + , " module " ++ module1 + , " , module " ++ module2 + , " , module " ++ moduleRoot ++ moduleClassTypesName + , " ) where" + , "" + , "import " ++ module1 + , "import " ++ module2 + , "import " ++ moduleRoot ++ moduleClassTypesName + , "" + ] + ] + + (m1,c1) <- compileClassesFile showIgnore moduleRoot moduleClassTypesName + (moduleName ++ postfix1) (outputFile ++ postfix1) inputFiles decls1 time + (m2,c2) <- compileClassesFile showIgnore moduleRoot moduleClassTypesName + (moduleName ++ postfix2) (outputFile ++ postfix2) inputFiles decls2 time + let methodCount = m1 + m2 + classCount = c1 + c2 + + prologue = getPrologue moduleName "class" + (show methodCount ++ " methods for " ++ show classCount ++ " classes.") + inputFiles + + let output = unlines (prologue ++ export) + putStrLn ("generating: " ++ outputFile ++ ".hs") + writeFileLazy (outputFile ++ ".hs") output + putStrLn ("generated " ++ show methodCount ++ " total methods for " ++ show classCount ++ " total classes.") + putStrLn ("ok.") + + +compileClassesFile :: a + -> String + -> String + -> String + -> String + -> [String] + -> [Decl] + -> b + -> IO (Int, Int) +compileClassesFile _showIgnore moduleRoot moduleClassTypesName moduleName outputFile inputFiles decls _time + = do let foreignDecls = map foreignDecl decls + haskellDecls = map haskellDecl decls + typeDecls = map haskellTypeDecl decls + + marshalDecls = concat (zipWith3 (\t h f -> [t,h,f,""]) typeDecls haskellDecls foreignDecls) + + (exportsClass, _classDecls) = haskellClassDefs + + (exportsStatic,exportsClassClasses,classCount) = exportDefs decls exportsClass [] + + methodCount = length decls + ghcoptions = [ "{-# LANGUAGE ForeignFunctionInterface #-}"] + + export = concat [ ["module " ++ moduleRoot ++ moduleName + , " ( -- * Global" ] + , (let es1 : es2 : estail = exportsStatic in es1 : dropFirstComma es2 : estail) + , [ " -- * Classes" ] + , exportsClassClasses + , [ " ) where" + , "" + , "import qualified Data.ByteString as B (ByteString, useAsCStringLen)" + , "import qualified Data.ByteString.Lazy as LB (ByteString, length, unpack)" + , "import System.IO.Unsafe( unsafePerformIO )" + , "import Foreign.C.Types(CInt(..), CWchar(..), CChar(..), CDouble(..))" + , "import " ++ moduleRoot ++ "WxcTypes" + , "import " ++ moduleRoot ++ moduleClassTypesName + , "" + ] + ] + + prologue = getPrologue moduleName "class" + (show methodCount ++ " methods for " ++ show classCount ++ " classes.") + inputFiles + output = unlines (ghcoptions ++ prologue ++ export ++ marshalDecls) + + putStrLn ("generating: " ++ outputFile ++ ".hs") + writeFileLazy (outputFile ++ ".hs") output + putStrLn ("generated " ++ show methodCount ++ " methods for " ++ show classCount ++ " classes.") + return (methodCount,classCount) + + +cmpDecl :: Decl -> Decl -> Ordering +cmpDecl decl1 decl2 + = compare (haskellDeclName (declName decl1)) (haskellDeclName (declName decl2)) + +exportComma :: String +exportComma = exportSpaces ++ "," + +exportSpaces :: String +exportSpaces = " " + +dropFirstComma :: String -> String +dropFirstComma str = maybe str replaceNthWithSpace (elemIndex ',' str) + where replaceNthWithSpace n = let (front,back) = splitAt n str in front ++ " " ++ tail back + +{----------------------------------------------------------------------------------------- + Create export definitions +-----------------------------------------------------------------------------------------} +exportDefs :: [Decl] -> [(ClassName,[String])] -> [(ClassName,[String])] -> ([String],[String],Int) +exportDefs decls classExports shortExports + = let classMap = Map.fromListWith (++) (classExports ++ [("Events",[]),("Null",[]),("Misc.",[])]) + methodMap = Map.map sort (Map.fromListWith (++) (map exportDef decls)) + shortMap = Map.map sort (Map.fromListWith (++) shortExports) + exportMap = Map.mapWithKey (addMethods methodMap shortMap) classMap + eventEntry = case Map.lookup "Events" exportMap of + Just entry -> [("Events",entry)] + Nothing -> [] + miscEntry = case Map.lookup "Misc." exportMap of + Just entry -> [("Misc.",entry)] + Nothing -> [] + nullEntry = case Map.lookup "Null" exportMap of + Just entry -> [("Null",entry)] + Nothing -> [] + + staticExps = map todef (nullEntry ++ eventEntry ++ miscEntry) + classExps = map todef (Map.toAscList (Map.delete "Null" (Map.delete "Misc." (Map.delete "Events" exportMap)))) + + in (concat staticExps + ,concat classExps + ,length (filter (not . null) classExps) + ) + where + addMethods methodMap shortMap className' _classDecls + | null decls'' = [] + | otherwise = [heading 2 className'] ++ decls'' + where + decls'' = + (case Map.lookup className' shortMap of + Nothing -> [] + Just decls' -> [heading 3 "Short methods"] ++ (commaSep decls')) ++ + (case Map.lookup className' methodMap of + Nothing -> [] + Just decls' -> (commaSep decls')) + + + todef (_classname,decls') + = decls' + + exportDef decl + = (case classifyName (declName decl) of + Name name | isPrefixOf "expEVT_" name -> "Events" + | isPrefixOf "Null_" name -> "Null" + | otherwise -> "Misc." + Create name -> haskellTypeName name + Method name _ -> haskellTypeName name + , [haskellDeclName (declName decl)]) + + commaSep xs + = map (exportComma++) xs + + heading i name + = exportSpaces ++ "-- " ++ replicate i '*' ++ " " ++ name + +{----------------------------------------------------------------------------------------- + Short cut names (unused) +-----------------------------------------------------------------------------------------} +{- +validShortNames :: [Decl] -> Set.Set String +validShortNames decls + = Set.fromList + $ map fst + $ filter ((==1).snd) + $ MultiSet.toOccurList + $ MultiSet.fromList + $ filter (any isUpper) + $ filter (not.isBuiltin.headToUpper) + $ filter (not.isClassName.headToUpper) + $ filter (not.isPrefixOf "wx") + $ filter ((>1).length) + $ map shortName decls + where + headToUpper [] = [] + headToUpper (c:cs) = toUpper c : cs +-} +{- +shortName :: Decl -> String +shortName decl + = snd (shortNameEx decl) +-} +{- +shortNameEx :: Decl -> (String,String) +shortNameEx decl + = case classifyName (declName decl) of + Method cname (Normal name) -> (cname,haskellDeclName name) + Method cname (Set name) -> (cname,haskellDeclName ("Set"++name)) + Method cname (Get name) -> (cname,haskellDeclName ("Get"++name)) + _other -> ("","") +-} +{- +shortDecl :: Set.Set String -> Decl -> [((ClassName,[String]), [String])] +shortDecl validShorts decl | Set.member sname validShorts + = [( (cname,[sname]) + , [haskellTypeSignature sname decl + ,sname ++ " = " ++ haskellDeclName (declName decl) + ,""] + ) + ] + where + (cname,sname) = shortNameEx decl + +shortDecl _validShorts _decl + = [] +-} + +{----------------------------------------------------------------------------------------- + Compile "xxx_Delete" methods to "objectDelete" to accomodate managed objects. +-----------------------------------------------------------------------------------------} +isDeleteMethod :: Decl -> Bool +isDeleteMethod decl + = case (declRet decl, declArgs decl, classifyName (declName decl)) of + (Void,[Arg [_] (Object selfName)],Method cname (Normal mname)) + -> (mname == "Delete" || mname=="SafeDelete") + && (selfName == cname) + && (cname `elem` objectClassNames || classIsManaged cname) + _ -> False + + +{----------------------------------------------------------------------------------------- + Make the "this" pointer the last argument +-----------------------------------------------------------------------------------------} +-- 2003-7-2: We disable this argument swapping and make it the first argument. +haskellThisArgument :: Decl -> (Maybe Arg,[Arg]) +haskellThisArgument decl + = (Nothing, declArgs decl) + +haskellThisArgs :: Decl -> [(Bool,Arg)] +haskellThisArgs decl + = case classifyName (declName decl) of + Method name _ | not (null args) && (argType (head args) == Object name) + -> [(True,head args)] ++ [(False,arg) | arg <- tail args] + _other -> [(False,arg) | arg <- args] + where + args = declArgs decl + +haskellSwapThis :: Decl -> [Arg] +haskellSwapThis decl + = case haskellThisArgument decl of + (Just this,args) -> args ++ [this] + (Nothing,args) -> args + +{----------------------------------------------------------------------------------------- + Translate a declaration to a haskell marshalling wrapper +-----------------------------------------------------------------------------------------} +haskellDecl :: Decl -> String +haskellDecl decl | isDeleteMethod decl + = haskellDeclName (declName decl) ++ nlStart + ++ objDelete (classInfo (case classifyName (declName decl) of + Method cname _ -> cname + _ -> "wxObject")) + + +haskellDecl decl + = methodName' ++ " " ++ haskellArgs (haskellSwapThis decl) ++ nlStart + ++ haskellToCResult decl (declRet decl) ( + haskellToCArgsIO methodName' (haskellThisArgs decl) + ++ foreignName (declName decl) ++ " " ++ haskellToCArgs decl (declArgs decl) + ) + where + methodName' = haskellDeclName (declName decl) + +nl :: String +nl + = "\n " + +nlStart :: String +nlStart + = "\n = " + +pparens :: String -> String +pparens txt + = "(" ++ txt ++ ")" + + +haskellArgs :: [Arg] -> String +haskellArgs args + = concatMap (\arg -> haskellName (argName arg) ++ " ") args + + +haskellToCResult :: Decl -> Type -> String -> String +haskellToCResult decl tp call + = unsafeIO $ + case tp of + Fun _ -> traceWarning "function as result" decl $ call + EventId -> "withIntResult $" ++ nl ++ call + Id -> "withIntResult $" ++ nl ++ call + Int _ -> "withIntResult $" ++ nl ++ call + IntPtr -> "withIntPtrResult $" ++ nl ++ call + Bool -> "withBoolResult $" ++ nl ++ call + Char -> "withCharResult $" ++ nl ++ call + Object obj -> withResult (classInfo obj) ++ " $" ++ nl ++ call + String _ -> "withWStringResult $ \\buffer -> " ++ nl ++ call ++ " buffer" -- always last argument! + ByteString Lazy -> "withLazyByteStringResult $ \\buffer -> " ++ nl ++ call ++ " buffer" -- always last argument! + ByteString _ -> "withByteStringResult $ \\buffer -> " ++ nl ++ call ++ " buffer" -- always last argument! + Point CDouble -> "withPointDoubleResult $ \\px py -> " ++ nl ++ call ++ " px py" -- always last argument! + Point _ -> "withPointResult $ \\px py -> " ++ nl ++ call ++ " px py" -- always last argument! + Vector CDouble -> "withVectorDoubleResult $ \\pdx pdy -> " ++ nl ++ call ++ " pdx pdy" -- always last argument! + Vector _ -> "withVectorResult $ \\pdx pdy -> " ++ nl ++ call ++ " pdx pdy" -- always last argument! + Size CDouble -> "withSizeDoubleResult $ \\pw ph -> " ++ nl ++ call ++ " pw ph" -- always last argument! + Size _ -> "withSizeResult $ \\pw ph -> " ++ nl ++ call ++ " pw ph" -- always last argument! + Rect CDouble -> "withRectDoubleResult $ \\px py pw ph -> " ++ nl ++ call ++ "px py pw ph" -- always last argument! + Rect _ -> "withRectResult $ \\px py pw ph -> " ++ nl ++ call ++ "px py pw ph" -- always last argument! + + RefObject name -> case withRef (classInfo name) of + "" -> errorMsgDecl decl "illegal reference object" + action -> action ++ " $ \\pref -> " ++ nl ++ call ++ " pref" -- always last argument! + ArrayInt _ -> "withArrayIntResult $ \\arr -> " ++ nl ++ call ++ " arr" -- always last + ArrayIntPtr _ -> "withArrayIntPtrResult $ \\arr -> " ++ nl ++ call ++ " arr" -- always last + ArrayString _ -> "withArrayWStringResult $ \\arr -> " ++ nl ++ call ++ " arr" -- always last + ArrayObject _ _ -> "withArrayObjectResult $ \\arr -> " ++ nl ++ call ++ " arr" -- always last + _other -> call + where + unsafeIO body + = case tp of + EventId -> "unsafePerformIO $" ++ nl ++ body + Id -> "unsafePerformIO $" ++ nl ++ body + _other | isPrefixOf "Null_" (declName decl) -> "unsafePerformIO $" ++ nl ++ body + | otherwise -> body + + +haskellToCArgsIO :: String -> [(Bool, Arg)] -> String +haskellToCArgsIO methodName' args + = concatMap (\(isSelf,arg) -> haskellToCArgIO methodName' isSelf arg) args + + +haskellToCArgIO :: String -> Bool -> Arg -> String +haskellToCArgIO methodName' isSelf arg + = case argType arg of + String _ -> "withCWString " ++ haskellName (argName arg) + ++ " $ \\" ++ haskellCStringName (argName arg) ++ " -> " ++ nl + ByteString Lazy -> "withArray (LB.unpack " ++ haskellName (argName arg) ++ ") $ \\" + ++ haskellByteStringName (argName arg) + ++ " -> " ++ nl + ByteString _ -> "B.useAsCStringLen " ++ haskellName (argName arg) ++ " $ \\" + ++ "(" ++ haskellByteStringName (argName arg) ++ ", " ++ haskellByteStringLenName (argName arg) ++ ") " + ++ " -> " ++ nl + ArrayString _ + -> "withArrayWString " ++ haskellName (argName arg) + ++ " $ \\" ++ haskellArrayLenName (argName arg) ++ " " ++ haskellArrayName (argName arg) + ++ " -> " ++ nl + ArrayObject _tp _ + -> "withArrayObject " ++ haskellName (argName arg) + ++ " $ \\" ++ haskellArrayLenName (argName arg) ++ " " ++ haskellArrayName (argName arg) + ++ " -> " ++ nl + ArrayInt _ + -> "withArrayInt " ++ haskellName (argName arg) + ++ " $ \\" ++ haskellArrayLenName (argName arg) ++ " " ++ haskellArrayName (argName arg) + ++ " -> " ++ nl + ArrayIntPtr _ + -> "withArrayIntPtr " ++ haskellName (argName arg) + ++ " $ \\" ++ haskellArrayLenName (argName arg) ++ " " ++ haskellArrayName (argName arg) + ++ " -> " ++ nl + Object obj -> (if isSelf then withSelf (classInfo obj) ("\"" ++ methodName' ++ "\"") + else withPtr (classInfo obj)) ++ " " + ++ haskellName (argName arg) + ++ " $ \\" ++ haskellCObjectName (argName arg) ++ " -> " ++ nl + _other -> "" + + +haskellToCArgs :: Decl -> [Arg] -> String +haskellToCArgs decl args + = concatMap (\arg -> haskellToCArg decl arg ++ " ") args + + +haskellToCArg :: Decl -> Arg -> String +haskellToCArg decl arg + = case argType arg of + RefObject _ -> traceError "reference object as argument" decl $ name + EventId -> traceError "event id as argument" decl $ name + Id -> traceError "id as argument" decl $ name + Int _ -> pparens ("toCInt " ++ name) + IntPtr -> pparens ("toCIntPtr " ++ name) + Char -> pparens ("toCWchar " ++ name) + Bool -> pparens ("toCBool " ++ name) + Fun _ -> pparens ("toCFunPtr " ++ name) + + String _ -> haskellCStringName (argName arg) + ByteString Lazy -> haskellByteStringName name ++ " (fromIntegral $ LB.length " ++ haskellName name ++ ")" + ByteString _ -> haskellByteStringName name ++ " " ++ haskellByteStringLenName name + Object _ -> haskellCObjectName (argName arg) + Point CDouble -> pparens ("toCDoublePointX " ++ name) ++ " " ++ pparens( "toCDoublePointY " ++ name) + Point _ -> pparens ("toCIntPointX " ++ name) ++ " " ++ pparens( "toCIntPointY " ++ name) + Vector CDouble -> pparens ("toCDoubleVectorX " ++ name) ++ " " ++ pparens( "toCDoubleVectorY " ++ name) + Vector _ -> pparens ("toCIntVectorX " ++ name) ++ " " ++ pparens( "toCIntVectorY " ++ name) + Size CDouble -> pparens ("toCDoubleSizeW " ++ name) ++ " " ++ pparens( "toCDoubleSizeH " ++ name) + Size _ -> pparens ("toCIntSizeW " ++ name) ++ " " ++ pparens( "toCIntSizeH " ++ name) + Rect CDouble -> pparens ("toCDoubleRectX " ++ name) ++ " " ++ pparens( "toCDoubleRectY " ++ name) + ++ pparens ("toCDoubleRectW " ++ name) ++ " " ++ pparens( "toCDoubleRectH " ++ name) + Rect _ -> pparens ("toCIntRectX " ++ name) ++ " " ++ pparens( "toCIntRectY " ++ name) + ++ pparens ("toCIntRectW " ++ name) ++ " " ++ pparens( "toCIntRectH " ++ name) + ColorRGB _ -> pparens ("colorRed " ++ name) ++ " " + ++ pparens ("colorGreen " ++ name) ++ " " + ++ pparens ("colorBlue " ++ name) + + ArrayString _ -> haskellArrayLenName name ++ " " ++ haskellArrayName name + ArrayObject _ _ -> haskellArrayLenName name ++ " " ++ haskellArrayName name + ArrayInt _ -> haskellArrayLenName name ++ " " ++ haskellArrayName name + ArrayIntPtr _ -> haskellArrayLenName name ++ " " ++ haskellArrayName name + + _other -> name + where + name = haskellName (argName arg) + +haskellCStringName :: String -> String +haskellCStringName name + = "cstr_" ++ haskellName name + +haskellByteStringName :: String -> String +haskellByteStringName name + = "bs_" ++ haskellName name + +haskellByteStringLenName :: String -> String +haskellByteStringLenName name + = "bslen_" ++ haskellName name + +haskellArrayName :: String -> String +haskellArrayName name + = "carr_" ++ haskellName name + +haskellArrayLenName :: String -> String +haskellArrayLenName name + = "carrlen_" ++ haskellName name + +haskellCObjectName :: String -> String +haskellCObjectName name + = "cobj_" ++ haskellName name + +{----------------------------------------------------------------------------------------- + Translate a declaration to a haskell type declaration +-----------------------------------------------------------------------------------------} +-- | Generate a full haskell type declarations +haskellTypeDecl :: Decl -> String +haskellTypeDecl decl + = haskellHaddockComment decl ++ "\n" ++ + haskellTypeSignature (haskellDeclName (declName decl)) decl + +-- | Generate a haddock comment +haskellHaddockComment :: Decl -> String +haskellHaddockComment decl + | null (declComment decl) = "-- | usage: (@" ++ callExpr ++ "@)." + | otherwise = "{- | " ++ declComment decl ++ " -}" + where + callExpr = case haskellThisArgument decl of + (Just this,args) -> haskellArgName (argName this) ++ " # " ++ haskellDeclName (declName decl) ++ callArgs args + (Nothing,args) -> haskellDeclName (declName decl) ++ callArgs args + callArgs args + = concatMap (\arg -> " " ++ haskellArgName (argName arg)) args + +-- | Generate a haskell type signature +haskellTypeSignature :: String -> Decl -> String +haskellTypeSignature name decl + = haskellRetType decl $ + name ++ " :: " ++ haskellTypeArgs decl (haskellSwapThis decl) + + +haskellTypeArgs :: Decl -> [Arg] -> String +haskellTypeArgs decl args + = concatMap (\(i,arg) -> haskellTypeArg decl i arg ++ " -> ") (zip [1..] args) + + +haskellRetType :: Decl -> [Char] -> String +haskellRetType decl typedecl + = case declRet decl of + EventId -> "{-# NOINLINE " ++ haskellDeclName (declName decl) ++ " #-}\n" ++ typedecl ++ " EventId" + Id -> "{-# NOINLINE " ++ haskellDeclName (declName decl) ++ " #-}\n" ++ typedecl ++ " Int" + tp | isPrefixOf "Null_" (declName decl) + -> typedecl ++ haskellType 0 tp + | otherwise + -> typedecl ++ " IO " ++ haskellTypePar 0 tp + + + +-- type def. for clarity +haskellTypeArg :: a -> Int -> Arg -> String +haskellTypeArg _decl _i (Arg ["id"] (Int _)) = "Id" +haskellTypeArg _decl _i (Arg ["_id"] (Int _)) = "Id" +haskellTypeArg _decl _i (Arg ["_stl"] (Int _)) = "Style" +haskellTypeArg _decl i arg + = haskellType i (argType arg) + + +haskellTypePar :: Int -> Type -> String +haskellTypePar i tp + = parenType (haskellType i) tp + + +haskellType :: Int -> Type -> String +haskellType i tp + = case tp of + Bool -> "Bool" + Int _ -> "Int" + IntPtr -> "IntPtr" + Int64 -> "Int64" + Word -> "Word" + Word8 -> "Word8" + Word32 -> "Word32" + Word64 -> "Word64" + Void -> "()" + Char -> "Char" + Double -> "Double" + Float -> "Float" + Ptr Void -> "Ptr " ++ typeVar i + Ptr t -> "Ptr " ++ foreignTypePar i t + -- special + Vector CDouble -> "(Vector2 Double)" + Vector _ -> "Vector" + Point CDouble -> "(Point2 Double)" + Point _ -> "Point" + Size CDouble -> "(Size2D Double)" + Size _ -> "Size" + ColorRGB _ -> "Color" + String _ -> "String" + ByteString Lazy -> "LB.ByteString" + ByteString _ -> "B.ByteString" + ArrayString _ -> "[String]" + ArrayInt _ -> "[Int]" + ArrayIntPtr _ -> "[IntPtr]" + ArrayObject name _ -> "[" ++ haskellTypeName name ++ typeVar i ++ "]" + Rect CDouble -> "(Rect2D Double)" + Rect _ -> "Rect" + Fun f -> "FunPtr " ++ pparens f + RefObject name -> classTypeName (classInfo name) (typeVar i) -- haskellTypeName name ++ typeVar i + Object name -> classTypeName (classInfo name) (typeVar i) -- haskellTypeName name ++ typeVar i + _other -> error ("Non exaustive pattern: CompileClasses.haskellType: " ++ show tp) + +{----------------------------------------------------------------------------------------- + Translate a declaration to a foreign import declaration +-----------------------------------------------------------------------------------------} +foreignDecl :: Decl -> String +foreignDecl decl | isDeleteMethod decl + = "" + +foreignDecl decl + = "foreign import ccall \"" ++ declName decl ++ "\" " + ++ foreignName (declName decl) ++ " :: " + ++ foreignArgs decl (declArgs decl) ++ foreignResultType (declRet decl) + + +foreignName :: String -> String +foreignName name + | isPrefixOf "wx" name && elem '_' name = name + | otherwise = "wx_" ++ name + +foreignArgs :: Decl -> [Arg] -> String +foreignArgs decl args + = concatMap (\(i,arg) -> foreignArg decl i arg ++ " -> ") (zip [1..] args) + + +foreignArg :: Decl -> Int -> Arg -> String +foreignArg decl i arg + = case argType arg of + RefObject name -> traceError "RefObject in argument" decl $ foreignType i (RefObject name) + Void -> traceError "void type in argument" decl $ foreignType i Void + tp -> foreignType i tp + + +foreignResultType :: Type -> String +foreignResultType tp + = case tp of + ArrayInt _ -> "Ptr CInt -> IO CInt" + ArrayIntPtr _ -> "Ptr CIntPtr -> IO CInt" + ArrayString _ -> "Ptr (Ptr CWchar) -> IO CInt" + ArrayObject name _ -> "Ptr " ++ foreignTypePar 0 (Object name) ++ " -> IO CInt" + String _ -> "Ptr CWchar -> IO CInt" + ByteString _ -> "Ptr CChar -> IO CInt" + Point CDouble -> "Ptr CDouble -> Ptr CDouble -> IO ()" + Point _ -> "Ptr CInt -> Ptr CInt -> IO ()" + Vector CDouble -> "Ptr Double -> Ptr Double -> IO ()" + Vector _ -> "Ptr CInt -> Ptr CInt -> IO ()" + Size CDouble -> "Ptr CDouble -> Ptr CDouble -> IO ()" + Size _ -> "Ptr CInt -> Ptr CInt -> IO ()" + Rect CDouble -> "Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> IO ()" + Rect _ -> "Ptr CInt -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO ()" + RefObject _name -> foreignType 0 tp ++ " -> IO ()" + EventId -> "IO CInt" + Id -> "IO CInt" + _other -> "IO " ++ foreignTypePar 0 tp + + +foreignTypePar :: Int -> Type -> String +foreignTypePar i tp + = parenType (foreignType i) tp + + +foreignType :: Int -> Type -> [Char] +foreignType i tp + = case tp of + Bool -> "CBool" + Int _ -> "CInt" + Int64 -> "Int64" + IntPtr -> "CIntPtr" + Word -> "Word" + Word8 -> "Word8" + Word32 -> "Word32" + Word64 -> "Word64" + Void -> "()" + Char -> "CWchar" + Double -> "Double" + Float -> "Float" + Ptr Void -> "Ptr " ++ typeVar i + Ptr t -> "Ptr " ++ foreignTypePar i t + -- special + String _ -> "CWString" + ByteString Lazy -> "Ptr Word8 -> Int" + ByteString _ -> "Ptr CChar -> Int" + Point CDouble -> "CDouble -> CDouble" + Point _ -> "CInt -> CInt" + Vector CDouble -> "CDouble -> CDouble" + Vector _ -> "CInt -> CInt" + Size CDouble -> "CDouble -> CDouble" + Size _ -> "CInt -> CInt" + ColorRGB _ -> "Word8 -> Word8 -> Word8" + Rect CDouble -> "CDouble -> CDouble -> CDouble -> CDouble" + Rect _ -> "CInt -> CInt -> CInt -> CInt" + Fun f -> "Ptr " ++ pparens f + ArrayObject name _ -> "CInt -> Ptr " ++ foreignTypePar i (Object name) + ArrayString _ -> "CInt -> Ptr (Ptr CWchar)" + ArrayInt _ -> "CInt -> Ptr CInt" + ArrayIntPtr _ -> "CInt -> Ptr CIntPtr" + RefObject name -> "Ptr (T" ++ haskellTypeName name ++ typeVar i ++ ")" + Object name -> "Ptr (T" ++ haskellTypeName name ++ typeVar i ++ ")" + _ -> error $ "CompileClasses.foreignType: unexpected type: " ++ show tp + + +parenType :: (Type -> String) -> Type -> String +parenType f tp + = parenFun tp (f tp) + where + parenFun tp' + = case tp' of + Ptr _ -> pparens + Object _ -> pparens + RefObject _ -> pparens + _other -> id + + +typeVar :: Int -> String +typeVar i = " " ++ typeVars !! i + +typeVars :: [String] +typeVars = "()" : [[toEnum (fromEnum 'a' + x)] | x <- [0..]]
src/CompileHeader.hs view
@@ -1,256 +1,256 @@-------------------------------------------------------------------------------------------{-| Module : CompileHeader- Copyright : (c) Daan Leijen 2003- License : BSD-style-- Maintainer : wxhaskell-devel@lists.sourceforge.net- Stability : provisional- Portability : portable-- Module that compiles typed C definitions from untyped ones.--}-------------------------------------------------------------------------------------------module CompileHeader( compileHeader ) where--import qualified Data.Set as Set-import qualified Data.Map as Map--import Data.List( isPrefixOf, sort, sortBy, intersperse )--import Types-import HaskellNames-import Classes( classNames, classExtends )-import ParseC( parseC )-import DeriveTypes( deriveTypesAll, classifyName, Name(..) )-import IOExtra--{------------------------------------------------------------------------------------------ Compile------------------------------------------------------------------------------------------}-compileHeader :: Bool -> FilePath -> [FilePath] -> IO ()-compileHeader showIgnore outputFile inputFiles- = do declss <- mapM parseC inputFiles- -- time <- getCurrentTime- let decls = deriveTypesAll showIgnore (sortBy cmpDecl (concat declss))-- typeDecls = cTypeDecls decls-- methodCount = length decls-- let output = unlines (["#ifndef WXC_GLUE_H"- ,"#define WXC_GLUE_H"]- ++ typeDecls ++- [""- ,"#endif /* WXC_GLUE_H */"- ,""]- )-- putStrLn ("generating: " ++ outputFile)- writeFileLazy outputFile output- putStrLn ("generated " ++ show methodCount ++ " declarations.")- putStrLn ("ok.\n")---cmpDecl :: Decl -> Decl -> Ordering-cmpDecl decl1 decl2- = compare (haskellDeclName (declName decl1)) (haskellDeclName (declName decl2))--{--exportComma :: String-exportComma = exportSpaces ++ ","--}--{--exportSpaces :: String-exportSpaces = " "--}--{------------------------------------------------------------------------------------------ Translate declarations to a c type declarations------------------------------------------------------------------------------------------}-cTypeDecls :: [Decl] -> [String]-cTypeDecls decls- = let classMap = Map.fromList (map (\name -> (name,[])) (Set.elems classNames ++ ["Events","Null","Misc."]))- methodMap = Map.map (map snd) (Map.map sort (Map.fromListWith (++) (map typeDef decls)))- tdeclMap = Map.mapWithKey (addMethods methodMap) classMap- eventEntry = case Map.lookup "Events" tdeclMap of- Just entry -> [("Events",entry)]- Nothing -> []- miscEntry = case Map.lookup "Misc." tdeclMap of- Just entry -> [("Misc.",entry)]- Nothing -> []- nullEntry = case Map.lookup "Null" tdeclMap of- Just entry -> [("Null",entry)]- Nothing -> []-- in (concatMap toDecls (nullEntry ++ eventEntry ++ miscEntry)- ++- concatMap toDecls (Map.toAscList (Map.delete "Null" (Map.delete "Misc." (Map.delete "Events" tdeclMap))))- )- where- addMethods methodMap className' classDecls- = heading className' ++- (case Map.lookup className' classExtends of- Nothing -> []- Just "" -> ["TClassDef(" ++ className' ++ ")"]- Just ext -> ["TClassDefExtend(" ++ className' ++ "," ++ ext ++ ")"]- )- ++ classDecls ++- (case Map.lookup className' methodMap of- Nothing -> []- Just dcls -> dcls)--- toDecls (_classname, dcls)- = dcls-- typeDef decl- = (case classifyName (declName decl) of- Name name | isPrefixOf "expEVT_" name -> "Events"- | isPrefixOf "Null_" name -> "Null"- | otherwise -> "Misc."- Create name -> name- Method name _ -> name- , [(declName decl, cTypeDecl decl)])--- heading msg- = ["","/* " ++ msg ++ " */"]---{------------------------------------------------------------------------------------------ Translate a declaration to a c type declaration------------------------------------------------------------------------------------------}--- | Generate a full c type declaration-cTypeDecl :: Decl -> String-cTypeDecl decl- = cTypeSignature decl---- | Generate a haskell type signature-cTypeSignature :: Decl -> String-cTypeSignature decl- = fill 10 (cRetType decl (declRet decl)) ++- " _stdcall " ++ declName decl ++- "( " ++ concat (intersperse ", " (cTypeArgs decl (declArgs decl) ++ cOutArg (declRet decl))) ++ " );"---fill :: Int -> String -> String-fill n s- | length s >= n = s- | otherwise = s ++ replicate (n - length s) ' '---cTypeArgs :: Decl -> [Arg] -> [String]-cTypeArgs _ [] = []-cTypeArgs decl (arg:args)- = cTypeArg decl getClassName arg : map (cTypeArg decl "") args- where- getClassName = case classifyName (declName decl) of- Method cname _ -> cname- _otherwise -> ""--cRetType :: Decl -> Type -> String-cRetType decl tp- = case tp of- -- out- String _ -> "TStringLen"- ArrayString _ -> "TArrayLen"- ArrayObject _ _ -> "TArrayLen"- Vector _ -> "void"- Point _ -> "void"- Size _ -> "void"- Rect _ -> "void"- RefObject _ -> "void"- -- typedefs- EventId -> "int"- -- basic- Bool -> "TBool"- Char -> "TChar"- Int CLong -> "long"- Int TimeT -> "time_t"- Int SizeT -> "size_t"- Int _ -> "int"- Void -> "void"- Double -> "double"- Float -> "float"- Ptr Void -> "void*"- Ptr t -> cRetType decl t ++ "*"- Object name -> "TClass(" ++ name ++ ")"- _other -> traceError ("unknown return type (" ++ show tp ++ ")") decl $- "void"--cOutArg :: Type -> [String]-cOutArg tp- = case tp of- Vector ctp -> ["TVectorOut" ++ ctypeSpec CInt ctp ++ "(_vx,_vy)"]- Point ctp -> ["TPointOut" ++ ctypeSpec CInt ctp ++ "(_x,_y)"]- Size ctp -> ["TSizeOut" ++ ctypeSpec CInt ctp ++ "(_w,_h)"]- String ctp -> ["TStringOut" ++ ctypeSpec CChar ctp ++ " _buf"]- Rect ctp -> ["TRectOut" ++ ctypeSpec CInt ctp ++ "(_x,_y,_w,_h)" ]- RefObject name -> ["TClassRef(" ++ name ++ ") _ref"]- ArrayString ctp -> ["TArrayString" ++ ctypeSpec CChar ctp ++ " _strs"]- ArrayObject name ctp -> ["TArrayObject" ++ ctypeSpec CObject ctp ++ "(" ++ name ++ ") _objs"]- _other -> []----- type def. for clarity-cTypeArg :: Decl -> String -> Arg -> String-cTypeArg decl className' arg- = case argType arg of- -- basic- Bool -> "TBool " ++ argName arg- Char -> "TChar " ++ argName arg- Int CLong -> "long " ++ argName arg- Int TimeT -> "time_t " ++ argName arg- Int SizeT -> "size_t " ++ argName arg- Int _ -> "int " ++ argName arg- Void -> "void " ++ argName arg- Double -> "double " ++ argName arg- Float -> "float " ++ argName arg- Ptr Void -> "void* " ++ argName arg- Ptr t -> cRetType decl t ++ "* " ++ argName arg- -- typedefs- EventId -> "int"- -- special- Vector ctp -> "TVector" ++ ctypeSpec CInt ctp ++ argNameTuple- Point ctp -> "TPoint" ++ ctypeSpec CInt ctp ++ argNameTuple- Size ctp -> "TSize" ++ ctypeSpec CInt ctp ++ argNameTuple- String ctp -> "TString" ++ ctypeSpec CChar ctp ++ " " ++ argName arg- Rect ctp -> "TRect" ++ ctypeSpec CInt ctp ++ argNameTuple- Fun _f -> "TClosureFun " ++ argName arg- ArrayString ctp -> "TArrayString" ++ ctypeSpec CChar ctp ++ " " ++ argName arg- ArrayObject name ctp -> "TArrayObject" ++ ctypeSpec CObject ctp ++ "(" ++ name ++ ") " ++ argName arg- RefObject name -> "TClassRef(" ++ name ++ ") " ++ argName arg- Object name | className' == name -> "TSelf(" ++ name ++ ") " ++ argName arg- | otherwise -> "TClass(" ++ name ++ ") " ++ argName arg-- -- temporary types (can this ever happen?)- StringLen -> "TStringLen " ++ argName arg- StringOut ctp -> "TStringOut" ++ ctypeSpec CChar ctp ++ " " ++ argName arg- ArrayLen -> "TArrayLen " ++ argName arg- ArrayStringOut ctp -> "TArrayStringOut" ++ ctypeSpec CChar ctp ++ " " ++ argName arg- ArrayObjectOut name ctp -> "TArrayObjectOut" ++ ctypeSpec CObject ctp ++ "(" ++ name ++ ") " ++ argName arg- PointOut ctp -> "TPointOut" ++ ctypeSpec CInt ctp ++ argNameTuple- SizeOut ctp -> "TSizeOut" ++ ctypeSpec CInt ctp ++ argNameTuple- VectorOut ctp -> "TVectorOut" ++ ctypeSpec CInt ctp ++ argNameTuple- RectOut ctp -> "TRectOut" ++ ctypeSpec CInt ctp ++ argNameTuple-- _other -> error ("cTypeArg: unknown argument type (" ++ show (argType arg) ++ ")") -{-- other -> traceError ("unknown argument type (" ++ show (argType arg) ++ ")") decl $- "ctypeSpec"--}- where- argNameTuple- = "(" ++ concat (intersperse "," (argNames arg)) ++ ")"---ctypeSpec :: CBaseType -> CBaseType -> String-ctypeSpec deftp ctp- | deftp==ctp = ""- | otherwise = case ctp of- CInt -> "Int"- CLong -> "Long"- CChar -> "Char"- CVoid -> "Void"- _other -> ""+----------------------------------------------------------------------------------------- +{-| Module : CompileHeader + Copyright : (c) Daan Leijen 2003 + License : BSD-style + + Maintainer : wxhaskell-devel@lists.sourceforge.net + Stability : provisional + Portability : portable + + Module that compiles typed C definitions from untyped ones. +-} +----------------------------------------------------------------------------------------- +module CompileHeader( compileHeader ) where + +import qualified Data.Set as Set +import qualified Data.Map as Map + +import Data.List( isPrefixOf, sort, sortBy, intersperse ) + +import Types +import HaskellNames +import Classes( classNames, classExtends ) +import ParseC( parseC ) +import DeriveTypes( deriveTypesAll, classifyName, Name(..) ) +import IOExtra + +{----------------------------------------------------------------------------------------- + Compile +-----------------------------------------------------------------------------------------} +compileHeader :: Bool -> FilePath -> [FilePath] -> IO () +compileHeader showIgnore outputFile inputFiles + = do declss <- mapM parseC inputFiles + -- time <- getCurrentTime + let decls = deriveTypesAll showIgnore (sortBy cmpDecl (concat declss)) + + typeDecls = cTypeDecls decls + + methodCount = length decls + + let output = unlines (["#ifndef WXC_GLUE_H" + ,"#define WXC_GLUE_H"] + ++ typeDecls ++ + ["" + ,"#endif /* WXC_GLUE_H */" + ,""] + ) + + putStrLn ("generating: " ++ outputFile) + writeFileLazy outputFile output + putStrLn ("generated " ++ show methodCount ++ " declarations.") + putStrLn ("ok.\n") + + +cmpDecl :: Decl -> Decl -> Ordering +cmpDecl decl1 decl2 + = compare (haskellDeclName (declName decl1)) (haskellDeclName (declName decl2)) + +{- +exportComma :: String +exportComma = exportSpaces ++ "," +-} + +{- +exportSpaces :: String +exportSpaces = " " +-} + +{----------------------------------------------------------------------------------------- + Translate declarations to a c type declarations +-----------------------------------------------------------------------------------------} +cTypeDecls :: [Decl] -> [String] +cTypeDecls decls + = let classMap = Map.fromList (map (\name -> (name,[])) (Set.elems classNames ++ ["Events","Null","Misc."])) + methodMap = Map.map (map snd) (Map.map sort (Map.fromListWith (++) (map typeDef decls))) + tdeclMap = Map.mapWithKey (addMethods methodMap) classMap + eventEntry = case Map.lookup "Events" tdeclMap of + Just entry -> [("Events",entry)] + Nothing -> [] + miscEntry = case Map.lookup "Misc." tdeclMap of + Just entry -> [("Misc.",entry)] + Nothing -> [] + nullEntry = case Map.lookup "Null" tdeclMap of + Just entry -> [("Null",entry)] + Nothing -> [] + + in (concatMap toDecls (nullEntry ++ eventEntry ++ miscEntry) + ++ + concatMap toDecls (Map.toAscList (Map.delete "Null" (Map.delete "Misc." (Map.delete "Events" tdeclMap)))) + ) + where + addMethods methodMap className' classDecls + = heading className' ++ + (case Map.lookup className' classExtends of + Nothing -> [] + Just "" -> ["TClassDef(" ++ className' ++ ")"] + Just ext -> ["TClassDefExtend(" ++ className' ++ "," ++ ext ++ ")"] + ) + ++ classDecls ++ + (case Map.lookup className' methodMap of + Nothing -> [] + Just dcls -> dcls) + + + toDecls (_classname, dcls) + = dcls + + typeDef decl + = (case classifyName (declName decl) of + Name name | isPrefixOf "expEVT_" name -> "Events" + | isPrefixOf "Null_" name -> "Null" + | otherwise -> "Misc." + Create name -> name + Method name _ -> name + , [(declName decl, cTypeDecl decl)]) + + + heading msg + = ["","/* " ++ msg ++ " */"] + + +{----------------------------------------------------------------------------------------- + Translate a declaration to a c type declaration +-----------------------------------------------------------------------------------------} +-- | Generate a full c type declaration +cTypeDecl :: Decl -> String +cTypeDecl decl + = cTypeSignature decl + +-- | Generate a haskell type signature +cTypeSignature :: Decl -> String +cTypeSignature decl + = fill 10 (cRetType decl (declRet decl)) ++ + " _stdcall " ++ declName decl ++ + "( " ++ concat (intersperse ", " (cTypeArgs decl (declArgs decl) ++ cOutArg (declRet decl))) ++ " );" + + +fill :: Int -> String -> String +fill n s + | length s >= n = s + | otherwise = s ++ replicate (n - length s) ' ' + + +cTypeArgs :: Decl -> [Arg] -> [String] +cTypeArgs _ [] = [] +cTypeArgs decl (arg:args) + = cTypeArg decl getClassName arg : map (cTypeArg decl "") args + where + getClassName = case classifyName (declName decl) of + Method cname _ -> cname + _otherwise -> "" + +cRetType :: Decl -> Type -> String +cRetType decl tp + = case tp of + -- out + String _ -> "TStringLen" + ArrayString _ -> "TArrayLen" + ArrayObject _ _ -> "TArrayLen" + Vector _ -> "void" + Point _ -> "void" + Size _ -> "void" + Rect _ -> "void" + RefObject _ -> "void" + -- typedefs + EventId -> "int" + -- basic + Bool -> "TBool" + Char -> "TChar" + Int CLong -> "long" + Int TimeT -> "time_t" + Int SizeT -> "size_t" + Int _ -> "int" + Void -> "void" + Double -> "double" + Float -> "float" + Ptr Void -> "void*" + Ptr t -> cRetType decl t ++ "*" + Object name -> "TClass(" ++ name ++ ")" + _other -> traceError ("unknown return type (" ++ show tp ++ ")") decl $ + "void" + +cOutArg :: Type -> [String] +cOutArg tp + = case tp of + Vector ctp -> ["TVectorOut" ++ ctypeSpec CInt ctp ++ "(_vx,_vy)"] + Point ctp -> ["TPointOut" ++ ctypeSpec CInt ctp ++ "(_x,_y)"] + Size ctp -> ["TSizeOut" ++ ctypeSpec CInt ctp ++ "(_w,_h)"] + String ctp -> ["TStringOut" ++ ctypeSpec CChar ctp ++ " _buf"] + Rect ctp -> ["TRectOut" ++ ctypeSpec CInt ctp ++ "(_x,_y,_w,_h)" ] + RefObject name -> ["TClassRef(" ++ name ++ ") _ref"] + ArrayString ctp -> ["TArrayString" ++ ctypeSpec CChar ctp ++ " _strs"] + ArrayObject name ctp -> ["TArrayObject" ++ ctypeSpec CObject ctp ++ "(" ++ name ++ ") _objs"] + _other -> [] + + +-- type def. for clarity +cTypeArg :: Decl -> String -> Arg -> String +cTypeArg decl className' arg + = case argType arg of + -- basic + Bool -> "TBool " ++ argName arg + Char -> "TChar " ++ argName arg + Int CLong -> "long " ++ argName arg + Int TimeT -> "time_t " ++ argName arg + Int SizeT -> "size_t " ++ argName arg + Int _ -> "int " ++ argName arg + Void -> "void " ++ argName arg + Double -> "double " ++ argName arg + Float -> "float " ++ argName arg + Ptr Void -> "void* " ++ argName arg + Ptr t -> cRetType decl t ++ "* " ++ argName arg + -- typedefs + EventId -> "int" + -- special + Vector ctp -> "TVector" ++ ctypeSpec CInt ctp ++ argNameTuple + Point ctp -> "TPoint" ++ ctypeSpec CInt ctp ++ argNameTuple + Size ctp -> "TSize" ++ ctypeSpec CInt ctp ++ argNameTuple + String ctp -> "TString" ++ ctypeSpec CChar ctp ++ " " ++ argName arg + Rect ctp -> "TRect" ++ ctypeSpec CInt ctp ++ argNameTuple + Fun _f -> "TClosureFun " ++ argName arg + ArrayString ctp -> "TArrayString" ++ ctypeSpec CChar ctp ++ " " ++ argName arg + ArrayObject name ctp -> "TArrayObject" ++ ctypeSpec CObject ctp ++ "(" ++ name ++ ") " ++ argName arg + RefObject name -> "TClassRef(" ++ name ++ ") " ++ argName arg + Object name | className' == name -> "TSelf(" ++ name ++ ") " ++ argName arg + | otherwise -> "TClass(" ++ name ++ ") " ++ argName arg + + -- temporary types (can this ever happen?) + StringLen -> "TStringLen " ++ argName arg + StringOut ctp -> "TStringOut" ++ ctypeSpec CChar ctp ++ " " ++ argName arg + ArrayLen -> "TArrayLen " ++ argName arg + ArrayStringOut ctp -> "TArrayStringOut" ++ ctypeSpec CChar ctp ++ " " ++ argName arg + ArrayObjectOut name ctp -> "TArrayObjectOut" ++ ctypeSpec CObject ctp ++ "(" ++ name ++ ") " ++ argName arg + PointOut ctp -> "TPointOut" ++ ctypeSpec CInt ctp ++ argNameTuple + SizeOut ctp -> "TSizeOut" ++ ctypeSpec CInt ctp ++ argNameTuple + VectorOut ctp -> "TVectorOut" ++ ctypeSpec CInt ctp ++ argNameTuple + RectOut ctp -> "TRectOut" ++ ctypeSpec CInt ctp ++ argNameTuple + + _other -> error ("cTypeArg: unknown argument type (" ++ show (argType arg) ++ ")") +{- + other -> traceError ("unknown argument type (" ++ show (argType arg) ++ ")") decl $ + "ctypeSpec" +-} + where + argNameTuple + = "(" ++ concat (intersperse "," (argNames arg)) ++ ")" + + +ctypeSpec :: CBaseType -> CBaseType -> String +ctypeSpec deftp ctp + | deftp==ctp = "" + | otherwise = case ctp of + CInt -> "Int" + CLong -> "Long" + CChar -> "Char" + CVoid -> "Void" + _other -> ""
src/DeriveTypes.hs view
@@ -1,735 +1,735 @@-------------------------------------------------------------------------------------------{-| Module : DeriveTypes- Copyright : (c) Daan Leijen 2003- License : BSD-style-- Maintainer : wxhaskell-devel@lists.sourceforge.net- Stability : provisional- Portability : portable-- Module that derives more specific types from a C-header signature.- Also removes duplicates and ignored definitions.--}-------------------------------------------------------------------------------------------module DeriveTypes ( deriveTypes, deriveTypesAll- , Name(..), Method(..), ClassName, MethodName, PropertyName- , classifyName- ) where--import qualified Data.Set as Set-import qualified Data.Map as Map--import Data.Char( toUpper, isUpper )-import Data.List( isPrefixOf )--import Types-import Classes( isClassName )--{------------------------------------------------------------------------------------------ The whole type derivation can be tuned with these tables------------------------------------------------------------------------------------------}--- | Map properties names (@GetInvokingWindow@) to object types (@Window@).-objectProperties :: Map.Map String Type-objectProperties- = Map.fromList $ map (\(nm,objname) -> (nm,Object objname))- [("InvokingWindow" , "wxWindow")- ,("EventHandler" , "wxEvtHandler")- ,("NextHandler" , "wxEvtHandler")- ,("PreviousHandler" , "wxEvtHandler")- ,("Parent" , "wxWindow") -- a bit weak :-(- ,("TopWindow" , "wxWindow")- ,("ClientObject" , "wxClientData")- ,("ToolClientData" , "wxClientData")- ,("TextBackground" , "wxColour")- ,("TextForeground" , "wxColour")- ,("ForegroundColour", "wxColour")- ,("BackgroundColour", "wxColour")- ,("CustomColour" , "wxColour")- ,("BorderColour" , "wxColour")- ,("TextColour" , "wxColour")- ,("SystemColour" , "wxColour")- ,("Stipple" , "wxBitmap")- ,("BitmapLabel" , "wxBitmap")- ,("BitmapFocus" , "wxBitmap")- ,("BitmapSelected" , "wxBitmap")- ,("BitmapDisabled" , "wxBitmap")- ,("WeekDayInSameWeek", "wxDateTime")- ,("NextWeekDay" , "wxDateTime")- ,("PrevWeekDay" , "wxDateTime")- ,("WeekDay" , "wxDateTime")- ,("LastWeekDay" , "wxDateTime")- ,("Week" , "wxDateTime")- ,("LastMonthDay" , "wxDateTime")- ,("SystemFont" , "wxFont")- ,("App" , "wxApp")- ,("EventObject" , "wxObject")- ,("Constraints" , "wxLayoutConstraints")- ,("UpdateRegion" , "wxRegion")- ,("SubBitmap" , "wxBitmap")- ,("Background" , "wxBrush")- -- App- ,("TopWindow" , "wxWindow")- ,("LogTarget" , "wxLog")- ]---- | Property names that correspond to a boolean-booleanProperties :: Set.Set String-booleanProperties- = Set.fromList- ["EvtHandlerEnabled"- ,"ToolEnabled"- ,"Skipped"- ,"Enabled"- ,"Checked"- ]---- | Methods that have an object result.-objectMethods :: Map.Map String Type-objectMethods- = Map.fromList $ map (\(nm,objname) -> (nm,Object objname))- [ ("FindFocus", "wxWindow")- , ("FindWindow", "wxWindow")- , ("FindClass", "wxClassInfo")- -- App- , ("FindWindowByName", "wxWindow")- , ("FindWindowByLabel", "wxWindow")- ]----- | Methods that have a boolean result.-booleanMethods :: Set.Set String-booleanMethods- = Set.fromList- ["Dragging"- ,"Entering"- ,"Leaving"- ,"LeftDClick"- ,"LeftDown"- ,"LeftIsDown"- ,"LeftUp"- ,"RightDClick"- ,"RightDown"- ,"RightIsDown"- ,"RightUp"- ,"MiddleDClick"- ,"MiddleDown"- ,"MiddleIsDown"- ,"MiddleUp"- ,"ButtonDown"- ,"ButtonIsDown"- ,"ButtonUp"- ,"ButtonDClick"- ,"Moving"-- ,"MetaDown"- ,"ControlDown"- ,"AltDown"- ,"ShiftDown"-- ,"MoreRequested"- ,"Destroy"- ,"DestroyChildren"- ,"Close"- ,"Disable"- ,"Hide"- ,"Show"- ,"Validate"- ]---- | Argument names that correspond to booleans.-booleans :: Set.Set String-booleans- = Set.fromList- ["_force","force"- ,"_enable","enable","enb"- ,"check"- ,"modal"- ,"eraseBackground"- ,"x_scrolling"- ,"y_scrolling"- ,"useMask"- ,"doIt"- ,"needMore" -- idleEventRequestMore- ,"deleteHandler" -- popEventHandler- ,"autoLayout" -- setAutoLayout- ,"refresh" -- setScrollbar- ]----- | Argument names that correspond to strings.-strings :: Set.Set String-strings- = Set.fromList- [ "_name", "name"- , "strText"- , "str"- , "text"- , "_txt"- , "msg", "_msg", "cap", "_cap"- , "string"- , "path"- , "_lbl" -- HsApp- , "shelp", "lhelp" -- Toolbar- , "section","keyword","viewer" -- HelpController- , "file", "rootpath"- , "_dir", "_fle", "_wcd", "message", "wildCard" -- FileDialog- ]----- | Argument name pairs that correspond to Points.-points :: Set.Set (String,String)-points- = Set.fromList- [ ("x","y")- , ("x1","y1")- , ("x2","y2")- , ("xc","yc")- , ("xoffset","yoffset")- , ("xpos","ypos")- , ("x_pos","y_pos")- , ("x_unit","y_unit")- , ("_x","_y")- , ("xsrc","ysrc")- , ("posx","posy")- , ("_lft","_top") -- FileDialog- ]---- | Argument name pairs that correspond to Sizes.-sizes :: Set.Set (String,String)-sizes- = Set.fromList- [ ("w","h")- , ("_w","_h")- , ("width","height")- , ("_width","_height")- ]---- | Argument name pairs that correspond to Vectors.-vectors :: Set.Set (String,String)-vectors- = Set.fromList- [ ("dx","dy")- , ("_dx","_dy")- ]---- | Argument name quadruples that correspond to Rectangles.-rectangles :: Set.Set (String,String,String,String)-rectangles- = Set.fromList- [ ("x","y","w","h")- , ("_x","_y","_w","_h")- , ("x","y","width","height")- , ("xdest","ydest","width","height")- , ("_lft","_top","_wdt","_hgt")- ]---- | Argument names that correspond to a certain object.-objects :: Map.Map String String-objects- = Map.fromList- [ ("submenu", "wxMenu")- , ("handler", "wxEvtHandler")- , ("dc", "wxDC")- , ("_prc", "wxProcess")- , ("ctrl", "wxControl")- , ("win", "wxWindow")- , ("_wnd", "wxWindow")- , ("_prt", "wxWindow")- , ("parent", "wxWindow")- , ("_par", "wxWindow")- , ("_prt", "wxWindow")- , ("child", "wxWindow")- , ("_lst", "wxList")- , ("sibling", "wxWindow")- , ("otherW", "wxWindow")- , ("otherWin", "wxWindow")- , ("nb", "wxNotebook")- , ("cmap", "wxPalette")- , ("theFont", "wxFont")- , ("stipple", "wxBitmap")- , ("_bmp", "wxBitmap")- , ("bmp", "wxBitmap")- , ("bmp1", "wxBitmap")- , ("bmp2", "wxBitmap")- , ("t1", "wxDateTime")- , ("t2", "wxDateTime")- , ("dt", "wxDateTime")- , ("col", "wxColour")- , ("_itm", "wxMenuItem")- , ("cfg", "wxConfigBase") -- htmlHelpController- , ("config", "wxConfigBase") -- htmlHelpController- ]---- | Argument name pairs that correspond to a certain (haskell) function pointer.-functions :: Map.Map String String-functions- = Map.fromList- [ ("_fun_CEvent", "Ptr fun -> Ptr state -> Event evt -> IO ()")- ]---referenceObjects :: Map.Map String String-referenceObjects- = Map.fromList- [ ("AddTime", "wxDateTime")- , ("SubtractTime", "wxDateTime")- , ("AddDate", "wxDateTime")- , ("SubtractDate", "wxDateTime")- , ("LoadBitmap", "wxBitmap")- , ("LoadIcon", "wxIcon")- ]---- | Definitions that should be ignored.-ignore :: [Decl -> Maybe String]-ignore- = [- -- gizmos: eljgizmos- prefix "expEVT_DYNAMIC_SASH" "gizmos"- ,prefix "wxRemotelyScrolled" "gizmos"- ,prefix "wxTreeCompanionWindow" "gizmos"- ,prefix "wxThinSplitterWindow" "gizmos"- ,prefix "wxSplitterScrolledWindow" "gizmos"- ,prefix "wxMultiCell" "gizmos"- ,prefix "wxLED" "gizmos"- ,prefix "wxEditableListBox" "gizmos"- ,prefix "wxDynamicSash" "gizmos"- -- frame layout: eljfl- ,equals "expEVT_USER_FIRST" "frame layout"- ,prefix "cb" "frame layout"- ,prefix "wxFrameLayout" "frame layout"- ,prefix "wxToolLayout" "frame layout"- ,prefix "wxToolWindow" "frame layout"- ,prefix "wxNewBitmapButton" "frame layout"- ,prefix "wxDynamicToolBar" "frame layout"- ,prefix "wxDynToolInfo" "frame layout"- -- plot window: eljplot- ,prefix "expEVT_PLOT" "plot"- ,prefix "wxPlot" "plot"- ,prefix "ELJPlot" "plot"- -- joystick: eljjoystick- ,prefix "expEVT_JOY" "joystick"- ,prefix "wxJoystick" "joystick"- -- command processor: eljcommand- ,prefix "wxCommandProcessor" "command proc"- ,prefix "ELJCommand" "command proc"- -- message parameters: eljmime / wrapper.h- ,prefix "wxMessageParameters" "message param"- -- non-portable- --,equals "expEVT_COMMAND_TOGGLEBUTTON_CLICKED" "toggle button"- --,prefix "wxToggleButton_" "toggle button"- ,prefix "wxDialUpEvent_" "dialup events"- ,prefix "wxDialUpManager_" "dialup manager"- ,prefix "wxCriticalSection_" "threads"- ,prefix "wxMutex_" "threads"- ,prefix "wxCondition_" "threads"- ,prefix "wxMutexGui_" "threads"- -- misc.- ,equals "wxDateTime_IsGregorianDate" "gregorian date"- ,equals "wxIconBundle_Assign" "icon bundle assign"- ,prefix "ELJConnection" "elj connection"- ,prefix "ELJServer" "elj server"- ,prefix "ELJClient" "elj client"- -- basic types- ,prefix "wxColour" "colour"- ,prefix "wxPoint" "point"- ,prefix "wxTreeItemId" "tree item id"- ,classprefix "wxSize" "size"- ,classprefix "wxString" "string"- ]- where- classprefix s msg decl | (s == declName decl) = Just msg- | isPrefixOf (s++"_") (declName decl) = Just msg- | otherwise = Nothing-- prefix s msg decl | isPrefixOf s (declName decl) = Just msg- | otherwise = Nothing-- equals s msg decl | (s == declName decl) = Just msg- | otherwise = Nothing--{------------------------------------------------------------------------------------------Derive types------------------------------------------------------------------------------------------}-deriveTypes :: Bool -> [Decl] -> [Decl]-deriveTypes showIgnore decls- = map (deriveBetterTypes . deriveOutTypes) (removeDupsAndUndefined shouldIgnore showIgnore decls)--deriveTypesAll :: Bool -> [Decl] -> [Decl]-deriveTypesAll showIgnore decls- = map (deriveBetterTypes . deriveOutTypes) (removeDupsAndUndefined (const Nothing) showIgnore decls)--{------------------------------------------------------------------------------------------ Ignore certain decls------------------------------------------------------------------------------------------}-shouldIgnore :: Decl -> Maybe String-shouldIgnore decl- = walk ignore- where- walk [] = Nothing- walk (f:fs) = case f decl of- Nothing -> walk fs- Just msg -> Just msg--{------------------------------------------------------------------------------------------ Remove duplicates and undefined stuff------------------------------------------------------------------------------------------}-removeDupsAndUndefined :: (Decl -> Maybe String) -> Bool -> [Decl] -> [Decl]-removeDupsAndUndefined shouldIgnore' showIgnore decls- = filterDupsAndUndefined Set.empty decls- where- filterDupsAndUndefined _ [] = []- filterDupsAndUndefined set (decl:decls')- = case shouldIgnore' decl of- Just msg -> (if showIgnore then traceIgnore msg decl else id) $ filterDupsAndUndefined set decls'- _other | Set.member (declName decl) set -> traceIgnore "duplicate" decl $ filterDupsAndUndefined set decls'- | otherwise -> decl : filterDupsAndUndefined (Set.insert (declName decl) set) decls'--{------------------------------------------------------------------------------------------ Derive "Out" types------------------------------------------------------------------------------------------}-deriveOutTypes :: Decl -> Decl-deriveOutTypes decl- = case (declRet decl,reverse (declArgs decl)) of- -- string- (StringLen,Arg _name (StringOut ctp) :args)- -> decl{ declRet = String ctp, declArgs = reverse args }- -- bytestring- (ByteStringLen,Arg _name (ByteStringOut ctp) :args)- -> decl{ declRet = ByteString ctp, declArgs = reverse args }- -- int array- (ArrayLen,Arg _name (ArrayIntOut ctp) :args)- -> decl{ declRet = ArrayInt ctp, declArgs = reverse args }- -- intptr array- (ArrayLen,Arg _name (ArrayIntPtrOut ctp) :args)- -> decl{ declRet = ArrayIntPtr ctp, declArgs = reverse args }- -- string array- (ArrayLen,Arg _name (ArrayStringOut ctp) :args)- -> decl{ declRet = ArrayString ctp, declArgs = reverse args }- -- object array- (ArrayLen,Arg _name (ArrayObjectOut cname ctp) :args)- -> decl{ declRet = ArrayObject cname ctp, declArgs = reverse args }- -- unknown array- (ArrayLen,args)- -> decl{ declRet = Int CInt, declArgs = reverse args }- -- point- (Void,Arg _name (PointOut ctp ):args)- -> decl{ declRet = Point ctp , declArgs = reverse args }- -- size- (Void,Arg _name (SizeOut ctp ):args)- -> decl{ declRet = Size ctp , declArgs = reverse args }- -- vector- (Void,Arg _name (VectorOut ctp ):args)- -> decl{ declRet = Vector ctp , declArgs = reverse args }- -- rect- (Void,Arg _name (RectOut ctp ):args)- -> decl{ declRet = Rect ctp , declArgs = reverse args }- -- rect -- just for treectrl::getBoundingRect and listctrl::GetItemRect- (Int CInt,Arg _name (RectOut ctp ):args)- -> decl{ declRet = Rect ctp , declArgs = reverse args }- -- reference- (Void,Arg _ obj@(RefObject _):args)- -> decl{ declRet = obj, declArgs = reverse args }- -- other- _ -> decl--{------------------------------------------------------------------------------------------ Derive extended types------------------------------------------------------------------------------------------}-deriveBetterTypes :: Decl -> Decl-deriveBetterTypes decl- = deriveReturnProperties- $ deriveThis- $ deriveExtReturn- $ deriveExtTypes- $ deriveStringReturn- $ deriveSimpleTypes- $ deriveId- $ decl----- Extended types: int x, int y => Point-deriveExtTypes :: Decl -> Decl-deriveExtTypes decl- = decl{ declArgs = deriveExtArgs (declArgs decl) }- where- -- rectangle- deriveExtArgs (Arg x (Int ctp): Arg y (Int _): Arg w (Int _): Arg h (Int _): args)- | Set.member (concat x,concat y,concat w,concat h) rectangles- = Arg (concat [x,y,w,h]) (Rect ctp): deriveExtArgs args- -- point- deriveExtArgs (Arg x (Int ctp): Arg y (Int _): args)- | Set.member (concat x,concat y) points- = Arg (x++y) (Point ctp): deriveExtArgs args- -- vector- deriveExtArgs (Arg dx (Int ctp): Arg dy (Int _): args)- | Set.member (concat dx,concat dy) vectors- = Arg (dx++dy) (Vector ctp): deriveExtArgs args- -- size- deriveExtArgs (Arg w (Int ctp): Arg h (Int _): args)- | Set.member (concat w,concat h) sizes- = Arg (w++h) (Size ctp): deriveExtArgs args- -- other- deriveExtArgs (arg:args)- = arg:deriveExtArgs args- deriveExtArgs []- = []---- Derive string return: "int fun(..., void* _buf)"-deriveStringReturn :: Decl -> Decl-deriveStringReturn decl- = case (classifyName (declName decl),declRet decl,reverse (declArgs decl)) of- -- string- (_,Int _,Arg ["_buf"] (Ptr Void):args)- -> decl{ declRet = String CVoid, declArgs = reverse args }- (_,Int _,Arg ["_buf"] (Ptr Char):args)- -> decl{ declRet = String CChar, declArgs = reverse args }- _other- -> decl---- Extended return types. Like string: "int fun(..., void* _buf)"-deriveExtReturn :: Decl -> Decl-deriveExtReturn decl- = case (classifyName (declName decl),declRet decl,reverse (declArgs decl)) of- -- string- (_,Int _,Arg ["_buf"] (Ptr Void):args)- -> decl{ declRet = String CVoid, declArgs = reverse args }- (_,Int _,Arg ["_buf"] (Ptr Char):args)- -> decl{ declRet = String CChar, declArgs = reverse args }- -- point- (_,Void,Arg y (Ptr (Int ctp)):Arg x (Ptr (Int _)):args)- | Set.member (concat x,concat y) points- -> decl{ declRet = Point ctp, declArgs = reverse args }- (_,Void,Arg y (Ptr Void):Arg x (Ptr Void):args)- | Set.member (concat x,concat y) points- -> decl{ declRet = Point CVoid, declArgs = reverse args }- -- rect- (_,Void,Arg h (Ptr (Int ctp)):Arg w (Ptr (Int _)):Arg y (Ptr (Int _)):Arg x (Ptr (Int _)):args)- | Set.member (concat x,concat y,concat w,concat h) rectangles- -> decl{ declRet = Rect ctp, declArgs = reverse args }- (_,Void,Arg h (Ptr Void):Arg w (Ptr Void):Arg y (Ptr Void):Arg x (Ptr Void):args)- | Set.member (concat x,concat y,concat w,concat h) rectangles- -> decl{ declRet = Rect CVoid, declArgs = reverse args }- -- size- (_,Void,Arg y (Ptr (Int ctp)):Arg x (Ptr (Int _)):args)- | Set.member (concat x,concat y) sizes- -> decl{ declRet = Size ctp, declArgs = reverse args }- (_,Void,Arg y (Ptr Void):Arg x (Ptr Void):args)- | Set.member (concat x,concat y) sizes- -> decl{ declRet = Size CVoid, declArgs = reverse args }- -- Vector- (_,Void,Arg y (Ptr (Int ctp)):Arg x (Ptr (Int _)):args)- | Set.member (concat x,concat y) vectors- -> decl{ declRet = Vector ctp, declArgs = reverse args }- (_,Void,Arg y (Ptr Void):Arg x (Ptr Void):args)- | Set.member (concat x,concat y) vectors- -> decl{ declRet = Vector CVoid, declArgs = reverse args }-- -- Null pointer- (Name name,Ptr Void,[])- | isPrefixOf "Null_" name && isClassName cname- -> decl{ declRet = Object cname }- where- cname = "wx" ++ drop 5 name-- -- Is/Has- (Method _cname (Normal mname),Int _ctp,_)- | (isPrefixOf "Is" mname || isPrefixOf "Has" mname || isPrefixOf "Can" mname- || mname=="Ok" || isPrefixOf "Contains" mname)- -> decl{ declRet = Bool }-- (Method cname (Normal mname),Ptr Void,_)- | isPrefixOf "Create" mname && isClassName createName -- frameCreateStatusBar- -> decl{ declRet = Object createName}- | isPrefixOf "CreateFrom" mname -- bitmapCreateFromMetafile- -> decl{ declRet = Object cname }- | mname == "CreateLoad" || mname == "CreateDefault"- || mname == "CreateEmpty" || mname == "CreateSized" -- bitmapCreateLoad- || mname == "FromRaw" || mname == "FromXPM" -- iconFromRaw- -> decl{ declRet = Object cname }- where- createName = drop (length "Create") mname-- -- Boolean methods- (Method _cname (Normal mname),Int _ctp,_)- | Set.member mname booleanMethods- -> decl{ declRet = Bool }-- -- Object methods- (Method _cname (Normal mname),Ptr Void,_)- -> case Map.lookup mname objectMethods of- Just tp -> decl{ declRet = tp }- Nothing -> decl- -- other- _ -> decl----- returned properties: assumes that deriveThis has already been done-deriveReturnProperties :: Decl -> Decl-deriveReturnProperties decl- = case (classifyName (declName decl),declRet decl,reverse (declArgs decl)) of- -- Get via reference- (Method _cname (Get propname),Void,Arg _ (Ptr Void):args)- | isClassName ("wx" ++ propname)- -> -- trace ("ref: " ++ propname ++ ": " ++ declName decl) $- decl{ declRet = RefObject ("wx" ++ propname), declArgs = reverse args }-- (Method cname (Get _propname),Void,[Arg _ (Object objname),argself@(Arg _ (Object selfname))])- | selfname == cname- -> -- trace ("ref: " ++ objname ++ ": " ++ declName decl) $- decl{ declRet = RefObject objname, declArgs = [argself] }-- -- bit adventurous: deals with things like "bitmapGetSubBitmap"- (Method _cname (Get propname),Void,(Arg _ (Object _objname):args))- | Map.member propname objectProperties- -> case Map.lookup propname objectProperties of- Just (Object name) -> -- trace ("ref: " ++ name ++ ": " ++ declName decl) $- decl{ declRet = RefObject name, declArgs = reverse args }- Just _ -> error "deriveReturnProperties: unexpected objectProperty (1)"- Nothing -> traceError ("illegal reference object") decl $ decl-- (Method cname (Get propname),Void,Arg ["_ref"] (Ptr Void):args)- -> case Map.lookup propname objectProperties of- Just (Object name) -> -- trace ("ref: " ++ name ++ ": " ++ declName decl) $- decl{ declRet = RefObject name, declArgs = reverse args }- Just _ -> error "deriveReturnProperties: unexpected objectProperty (2)"- Nothing | cname == "wxListEvent" && propname == "Item"- -> -- trace ("ref: ListItem: " ++ declName decl) $- decl{ declRet = RefObject "wxListItem", declArgs = reverse args }- | cname == "wxTreeEvent" && propname == "Item"- -> -- trace ("ref: TreeItemId: " ++ declName decl) $- decl{ declRet = RefObject "wxTreeItemId", declArgs = reverse args }- | cname == "wxTreeEvent" && propname == "OldItem"- -> -- trace ("ref: TreeItemId: " ++ declName decl) $- decl{ declRet = RefObject "wxTreeItemId", declArgs = reverse args }- | otherwise- -> traceWarning ("unknown reference object") decl $- decl{ declRet = RefObject "Ptr", declArgs = reverse args }-- (Method cname (Normal mname),Void,Arg ["_ref"] (Ptr Void):args)- -> case Map.lookup mname referenceObjects of- Just name -> -- trace ("ref: " ++ name ++ ": " ++ declName decl) $- decl{ declRet = RefObject name, declArgs = reverse args }- Nothing | cname == "wxIconBundle" && mname == "Assign"- -> decl{ declRet = RefObject "wxIconBundle", declArgs = reverse args }- | otherwise- -> traceWarning ("unknown reference object") decl $- decl{ declRet = RefObject "Ptr", declArgs = reverse args }-- -- Get- (Method _cname (Get propname),Ptr Void,_)- | isClassName ("wx" ++ propname)- -> decl{ declRet = Object ("wx" ++ propname) }- | otherwise- -> case Map.lookup propname objectProperties of- Just tp -> decl{ declRet = tp }- Nothing -> decl- (Method _cname (Get propname),Int _,_)- | Set.member propname booleanProperties- -> decl{ declRet = Bool }--- -- Set- (Method _cname (Set propname),_,Arg argname (Ptr Void):args)- | isClassName ("wx" ++ propname)- -> decl{ declArgs = reverse (Arg argname (Object ("wx"++propname)) : args)}- | otherwise- -> case Map.lookup propname objectProperties of- Just tp -> decl{ declArgs = reverse (Arg argname tp : args)}- Nothing -> decl- (Method _cname (Set propname),_,Arg argname (Int _):args)- | Set.member propname booleanProperties- -> decl{ declArgs = reverse (Arg argname Bool : args)}-- -- other- _ -> decl------ Simple types: char* => String-deriveSimpleTypes :: Decl -> Decl-deriveSimpleTypes decl- = decl{ declArgs = deriveArgs (declArgs decl) }- where- deriveArgs args- = map (\arg -> arg{ argType = deriveArg arg }) args-- deriveArg arg- = case argType arg of- Ptr Char -> String CChar- Int _ctp | Set.member (argName arg) booleans -> Bool- | isPrefixOf "is" (argName arg) -> Bool- Ptr Void -> case Map.lookup (argName arg) objects of- Just name -> Object name- _ -> case Map.lookup (argName arg) functions of- Just tp -> Fun tp- _ | Set.member (argName arg) strings -> String CVoid- | isClassName cargName -> Object cargName- | otherwise -> Ptr Void- where- cargName = case argName arg of- (c:cs) -> "wx" ++ (toUpper c : cs)- other -> other- tp -> tp---- Check for "this" pointer--- derive for "wxObject_Create :: ... -> IO (Ptr ())"-deriveThis :: Decl -> Decl-deriveThis decl- = case classifyName (declName decl) of- Create cname | declRet decl == Ptr Void -- bitmapCreate- -> decl{ declRet = Object cname }- Method cname _m | not (null args) && (argType (head args) == Ptr Void) && not (elem cname ["ELJApp"])- -> decl{ declArgs = (head args){ argType = Object cname} : tail args }- _ -> decl- where- args = declArgs decl----- derive event ids: int expEVT_XXX() and expXXX_XXX();-deriveId :: Decl -> Decl-deriveId decl@Decl{ declRet = Int _, declArgs = [] }- | isPrefixOf "expEVT_" (declName decl)- = decl{ declRet = EventId }-deriveId decl@Decl{ declRet = Int _, declArgs = [] }- | isPrefixOf "exp" (declName decl)- = decl{ declRet = Id }-deriveId decl- = decl--{------------------------------------------------------------------------------------------ Names------------------------------------------------------------------------------------------}-data Name = Name String- | Create { className :: ClassName }- | Method { className :: ClassName, method :: Method }- deriving Show--data Method- = Normal { methodName :: MethodName }- | Set { propName :: PropertyName }- | Get { propName :: PropertyName }- deriving Show--type ClassName = String-type MethodName = String-type PropertyName = String--classifyName :: String -> Name-classifyName s- = case s of- ('w' : 'x' : _) -> getClassName s- ('c' : 'b' : _) -> getClassName s- (c : _) | isUpper c -> getClassName s- _ -> Name s- where- getClassName name- = case (span (/='_') name) of- (cname,method') | isClassName cname && not (null method')- -> if (method' == "_Create")- then Create cname- else if (isPrefixOf "_Get" method')- then Method cname (Get (drop 4 method'))- else if (isPrefixOf "_Set" method')- then Method cname (Set (drop 4 method'))- else Method cname (Normal (drop 1 method'))- (_,_)-> Name s+----------------------------------------------------------------------------------------- +{-| Module : DeriveTypes + Copyright : (c) Daan Leijen 2003 + License : BSD-style + + Maintainer : wxhaskell-devel@lists.sourceforge.net + Stability : provisional + Portability : portable + + Module that derives more specific types from a C-header signature. + Also removes duplicates and ignored definitions. +-} +----------------------------------------------------------------------------------------- +module DeriveTypes ( deriveTypes, deriveTypesAll + , Name(..), Method(..), ClassName, MethodName, PropertyName + , classifyName + ) where + +import qualified Data.Set as Set +import qualified Data.Map as Map + +import Data.Char( toUpper, isUpper ) +import Data.List( isPrefixOf ) + +import Types +import Classes( isClassName ) + +{----------------------------------------------------------------------------------------- + The whole type derivation can be tuned with these tables +-----------------------------------------------------------------------------------------} +-- | Map properties names (@GetInvokingWindow@) to object types (@Window@). +objectProperties :: Map.Map String Type +objectProperties + = Map.fromList $ map (\(nm,objname) -> (nm,Object objname)) + [("InvokingWindow" , "wxWindow") + ,("EventHandler" , "wxEvtHandler") + ,("NextHandler" , "wxEvtHandler") + ,("PreviousHandler" , "wxEvtHandler") + ,("Parent" , "wxWindow") -- a bit weak :-( + ,("TopWindow" , "wxWindow") + ,("ClientObject" , "wxClientData") + ,("ToolClientData" , "wxClientData") + ,("TextBackground" , "wxColour") + ,("TextForeground" , "wxColour") + ,("ForegroundColour", "wxColour") + ,("BackgroundColour", "wxColour") + ,("CustomColour" , "wxColour") + ,("BorderColour" , "wxColour") + ,("TextColour" , "wxColour") + ,("SystemColour" , "wxColour") + ,("Stipple" , "wxBitmap") + ,("BitmapLabel" , "wxBitmap") + ,("BitmapFocus" , "wxBitmap") + ,("BitmapSelected" , "wxBitmap") + ,("BitmapDisabled" , "wxBitmap") + ,("WeekDayInSameWeek", "wxDateTime") + ,("NextWeekDay" , "wxDateTime") + ,("PrevWeekDay" , "wxDateTime") + ,("WeekDay" , "wxDateTime") + ,("LastWeekDay" , "wxDateTime") + ,("Week" , "wxDateTime") + ,("LastMonthDay" , "wxDateTime") + ,("SystemFont" , "wxFont") + ,("App" , "wxApp") + ,("EventObject" , "wxObject") + ,("Constraints" , "wxLayoutConstraints") + ,("UpdateRegion" , "wxRegion") + ,("SubBitmap" , "wxBitmap") + ,("Background" , "wxBrush") + -- App + ,("TopWindow" , "wxWindow") + ,("LogTarget" , "wxLog") + ] + +-- | Property names that correspond to a boolean +booleanProperties :: Set.Set String +booleanProperties + = Set.fromList + ["EvtHandlerEnabled" + ,"ToolEnabled" + ,"Skipped" + ,"Enabled" + ,"Checked" + ] + +-- | Methods that have an object result. +objectMethods :: Map.Map String Type +objectMethods + = Map.fromList $ map (\(nm,objname) -> (nm,Object objname)) + [ ("FindFocus", "wxWindow") + , ("FindWindow", "wxWindow") + , ("FindClass", "wxClassInfo") + -- App + , ("FindWindowByName", "wxWindow") + , ("FindWindowByLabel", "wxWindow") + ] + + +-- | Methods that have a boolean result. +booleanMethods :: Set.Set String +booleanMethods + = Set.fromList + ["Dragging" + ,"Entering" + ,"Leaving" + ,"LeftDClick" + ,"LeftDown" + ,"LeftIsDown" + ,"LeftUp" + ,"RightDClick" + ,"RightDown" + ,"RightIsDown" + ,"RightUp" + ,"MiddleDClick" + ,"MiddleDown" + ,"MiddleIsDown" + ,"MiddleUp" + ,"ButtonDown" + ,"ButtonIsDown" + ,"ButtonUp" + ,"ButtonDClick" + ,"Moving" + + ,"MetaDown" + ,"ControlDown" + ,"AltDown" + ,"ShiftDown" + + ,"MoreRequested" + ,"Destroy" + ,"DestroyChildren" + ,"Close" + ,"Disable" + ,"Hide" + ,"Show" + ,"Validate" + ] + +-- | Argument names that correspond to booleans. +booleans :: Set.Set String +booleans + = Set.fromList + ["_force","force" + ,"_enable","enable","enb" + ,"check" + ,"modal" + ,"eraseBackground" + ,"x_scrolling" + ,"y_scrolling" + ,"useMask" + ,"doIt" + ,"needMore" -- idleEventRequestMore + ,"deleteHandler" -- popEventHandler + ,"autoLayout" -- setAutoLayout + ,"refresh" -- setScrollbar + ] + + +-- | Argument names that correspond to strings. +strings :: Set.Set String +strings + = Set.fromList + [ "_name", "name" + , "strText" + , "str" + , "text" + , "_txt" + , "msg", "_msg", "cap", "_cap" + , "string" + , "path" + , "_lbl" -- HsApp + , "shelp", "lhelp" -- Toolbar + , "section","keyword","viewer" -- HelpController + , "file", "rootpath" + , "_dir", "_fle", "_wcd", "message", "wildCard" -- FileDialog + ] + + +-- | Argument name pairs that correspond to Points. +points :: Set.Set (String,String) +points + = Set.fromList + [ ("x","y") + , ("x1","y1") + , ("x2","y2") + , ("xc","yc") + , ("xoffset","yoffset") + , ("xpos","ypos") + , ("x_pos","y_pos") + , ("x_unit","y_unit") + , ("_x","_y") + , ("xsrc","ysrc") + , ("posx","posy") + , ("_lft","_top") -- FileDialog + ] + +-- | Argument name pairs that correspond to Sizes. +sizes :: Set.Set (String,String) +sizes + = Set.fromList + [ ("w","h") + , ("_w","_h") + , ("width","height") + , ("_width","_height") + ] + +-- | Argument name pairs that correspond to Vectors. +vectors :: Set.Set (String,String) +vectors + = Set.fromList + [ ("dx","dy") + , ("_dx","_dy") + ] + +-- | Argument name quadruples that correspond to Rectangles. +rectangles :: Set.Set (String,String,String,String) +rectangles + = Set.fromList + [ ("x","y","w","h") + , ("_x","_y","_w","_h") + , ("x","y","width","height") + , ("xdest","ydest","width","height") + , ("_lft","_top","_wdt","_hgt") + ] + +-- | Argument names that correspond to a certain object. +objects :: Map.Map String String +objects + = Map.fromList + [ ("submenu", "wxMenu") + , ("handler", "wxEvtHandler") + , ("dc", "wxDC") + , ("_prc", "wxProcess") + , ("ctrl", "wxControl") + , ("win", "wxWindow") + , ("_wnd", "wxWindow") + , ("_prt", "wxWindow") + , ("parent", "wxWindow") + , ("_par", "wxWindow") + , ("_prt", "wxWindow") + , ("child", "wxWindow") + , ("_lst", "wxList") + , ("sibling", "wxWindow") + , ("otherW", "wxWindow") + , ("otherWin", "wxWindow") + , ("nb", "wxNotebook") + , ("cmap", "wxPalette") + , ("theFont", "wxFont") + , ("stipple", "wxBitmap") + , ("_bmp", "wxBitmap") + , ("bmp", "wxBitmap") + , ("bmp1", "wxBitmap") + , ("bmp2", "wxBitmap") + , ("t1", "wxDateTime") + , ("t2", "wxDateTime") + , ("dt", "wxDateTime") + , ("col", "wxColour") + , ("_itm", "wxMenuItem") + , ("cfg", "wxConfigBase") -- htmlHelpController + , ("config", "wxConfigBase") -- htmlHelpController + ] + +-- | Argument name pairs that correspond to a certain (haskell) function pointer. +functions :: Map.Map String String +functions + = Map.fromList + [ ("_fun_CEvent", "Ptr fun -> Ptr state -> Event evt -> IO ()") + ] + + +referenceObjects :: Map.Map String String +referenceObjects + = Map.fromList + [ ("AddTime", "wxDateTime") + , ("SubtractTime", "wxDateTime") + , ("AddDate", "wxDateTime") + , ("SubtractDate", "wxDateTime") + , ("LoadBitmap", "wxBitmap") + , ("LoadIcon", "wxIcon") + ] + +-- | Definitions that should be ignored. +ignore :: [Decl -> Maybe String] +ignore + = [ + -- gizmos: eljgizmos + prefix "expEVT_DYNAMIC_SASH" "gizmos" + ,prefix "wxRemotelyScrolled" "gizmos" + ,prefix "wxTreeCompanionWindow" "gizmos" + ,prefix "wxThinSplitterWindow" "gizmos" + ,prefix "wxSplitterScrolledWindow" "gizmos" + ,prefix "wxMultiCell" "gizmos" + ,prefix "wxLED" "gizmos" + ,prefix "wxEditableListBox" "gizmos" + ,prefix "wxDynamicSash" "gizmos" + -- frame layout: eljfl + ,equals "expEVT_USER_FIRST" "frame layout" + ,prefix "cb" "frame layout" + ,prefix "wxFrameLayout" "frame layout" + ,prefix "wxToolLayout" "frame layout" + ,prefix "wxToolWindow" "frame layout" + ,prefix "wxNewBitmapButton" "frame layout" + ,prefix "wxDynamicToolBar" "frame layout" + ,prefix "wxDynToolInfo" "frame layout" + -- plot window: eljplot + ,prefix "expEVT_PLOT" "plot" + ,prefix "wxPlot" "plot" + ,prefix "ELJPlot" "plot" + -- joystick: eljjoystick + ,prefix "expEVT_JOY" "joystick" + ,prefix "wxJoystick" "joystick" + -- command processor: eljcommand + ,prefix "wxCommandProcessor" "command proc" + ,prefix "ELJCommand" "command proc" + -- message parameters: eljmime / wrapper.h + ,prefix "wxMessageParameters" "message param" + -- non-portable + --,equals "expEVT_COMMAND_TOGGLEBUTTON_CLICKED" "toggle button" + --,prefix "wxToggleButton_" "toggle button" + ,prefix "wxDialUpEvent_" "dialup events" + ,prefix "wxDialUpManager_" "dialup manager" + ,prefix "wxCriticalSection_" "threads" + ,prefix "wxMutex_" "threads" + ,prefix "wxCondition_" "threads" + ,prefix "wxMutexGui_" "threads" + -- misc. + ,equals "wxDateTime_IsGregorianDate" "gregorian date" + ,equals "wxIconBundle_Assign" "icon bundle assign" + ,prefix "ELJConnection" "elj connection" + ,prefix "ELJServer" "elj server" + ,prefix "ELJClient" "elj client" + -- basic types + ,prefix "wxColour" "colour" + ,prefix "wxPoint" "point" + ,prefix "wxTreeItemId" "tree item id" + ,classprefix "wxSize" "size" + ,classprefix "wxString" "string" + ] + where + classprefix s msg decl | (s == declName decl) = Just msg + | isPrefixOf (s++"_") (declName decl) = Just msg + | otherwise = Nothing + + prefix s msg decl | isPrefixOf s (declName decl) = Just msg + | otherwise = Nothing + + equals s msg decl | (s == declName decl) = Just msg + | otherwise = Nothing + +{----------------------------------------------------------------------------------------- +Derive types +-----------------------------------------------------------------------------------------} +deriveTypes :: Bool -> [Decl] -> [Decl] +deriveTypes showIgnore decls + = map (deriveBetterTypes . deriveOutTypes) (removeDupsAndUndefined shouldIgnore showIgnore decls) + +deriveTypesAll :: Bool -> [Decl] -> [Decl] +deriveTypesAll showIgnore decls + = map (deriveBetterTypes . deriveOutTypes) (removeDupsAndUndefined (const Nothing) showIgnore decls) + +{----------------------------------------------------------------------------------------- + Ignore certain decls +-----------------------------------------------------------------------------------------} +shouldIgnore :: Decl -> Maybe String +shouldIgnore decl + = walk ignore + where + walk [] = Nothing + walk (f:fs) = case f decl of + Nothing -> walk fs + Just msg -> Just msg + +{----------------------------------------------------------------------------------------- + Remove duplicates and undefined stuff +-----------------------------------------------------------------------------------------} +removeDupsAndUndefined :: (Decl -> Maybe String) -> Bool -> [Decl] -> [Decl] +removeDupsAndUndefined shouldIgnore' showIgnore decls + = filterDupsAndUndefined Set.empty decls + where + filterDupsAndUndefined _ [] = [] + filterDupsAndUndefined set (decl:decls') + = case shouldIgnore' decl of + Just msg -> (if showIgnore then traceIgnore msg decl else id) $ filterDupsAndUndefined set decls' + _other | Set.member (declName decl) set -> traceIgnore "duplicate" decl $ filterDupsAndUndefined set decls' + | otherwise -> decl : filterDupsAndUndefined (Set.insert (declName decl) set) decls' + +{----------------------------------------------------------------------------------------- + Derive "Out" types +-----------------------------------------------------------------------------------------} +deriveOutTypes :: Decl -> Decl +deriveOutTypes decl + = case (declRet decl,reverse (declArgs decl)) of + -- string + (StringLen,Arg _name (StringOut ctp) :args) + -> decl{ declRet = String ctp, declArgs = reverse args } + -- bytestring + (ByteStringLen,Arg _name (ByteStringOut ctp) :args) + -> decl{ declRet = ByteString ctp, declArgs = reverse args } + -- int array + (ArrayLen,Arg _name (ArrayIntOut ctp) :args) + -> decl{ declRet = ArrayInt ctp, declArgs = reverse args } + -- intptr array + (ArrayLen,Arg _name (ArrayIntPtrOut ctp) :args) + -> decl{ declRet = ArrayIntPtr ctp, declArgs = reverse args } + -- string array + (ArrayLen,Arg _name (ArrayStringOut ctp) :args) + -> decl{ declRet = ArrayString ctp, declArgs = reverse args } + -- object array + (ArrayLen,Arg _name (ArrayObjectOut cname ctp) :args) + -> decl{ declRet = ArrayObject cname ctp, declArgs = reverse args } + -- unknown array + (ArrayLen,args) + -> decl{ declRet = Int CInt, declArgs = reverse args } + -- point + (Void,Arg _name (PointOut ctp ):args) + -> decl{ declRet = Point ctp , declArgs = reverse args } + -- size + (Void,Arg _name (SizeOut ctp ):args) + -> decl{ declRet = Size ctp , declArgs = reverse args } + -- vector + (Void,Arg _name (VectorOut ctp ):args) + -> decl{ declRet = Vector ctp , declArgs = reverse args } + -- rect + (Void,Arg _name (RectOut ctp ):args) + -> decl{ declRet = Rect ctp , declArgs = reverse args } + -- rect -- just for treectrl::getBoundingRect and listctrl::GetItemRect + (Int CInt,Arg _name (RectOut ctp ):args) + -> decl{ declRet = Rect ctp , declArgs = reverse args } + -- reference + (Void,Arg _ obj@(RefObject _):args) + -> decl{ declRet = obj, declArgs = reverse args } + -- other + _ -> decl + +{----------------------------------------------------------------------------------------- + Derive extended types +-----------------------------------------------------------------------------------------} +deriveBetterTypes :: Decl -> Decl +deriveBetterTypes decl + = deriveReturnProperties + $ deriveThis + $ deriveExtReturn + $ deriveExtTypes + $ deriveStringReturn + $ deriveSimpleTypes + $ deriveId + $ decl + + +-- Extended types: int x, int y => Point +deriveExtTypes :: Decl -> Decl +deriveExtTypes decl + = decl{ declArgs = deriveExtArgs (declArgs decl) } + where + -- rectangle + deriveExtArgs (Arg x (Int ctp): Arg y (Int _): Arg w (Int _): Arg h (Int _): args) + | Set.member (concat x,concat y,concat w,concat h) rectangles + = Arg (concat [x,y,w,h]) (Rect ctp): deriveExtArgs args + -- point + deriveExtArgs (Arg x (Int ctp): Arg y (Int _): args) + | Set.member (concat x,concat y) points + = Arg (x++y) (Point ctp): deriveExtArgs args + -- vector + deriveExtArgs (Arg dx (Int ctp): Arg dy (Int _): args) + | Set.member (concat dx,concat dy) vectors + = Arg (dx++dy) (Vector ctp): deriveExtArgs args + -- size + deriveExtArgs (Arg w (Int ctp): Arg h (Int _): args) + | Set.member (concat w,concat h) sizes + = Arg (w++h) (Size ctp): deriveExtArgs args + -- other + deriveExtArgs (arg:args) + = arg:deriveExtArgs args + deriveExtArgs [] + = [] + +-- Derive string return: "int fun(..., void* _buf)" +deriveStringReturn :: Decl -> Decl +deriveStringReturn decl + = case (classifyName (declName decl),declRet decl,reverse (declArgs decl)) of + -- string + (_,Int _,Arg ["_buf"] (Ptr Void):args) + -> decl{ declRet = String CVoid, declArgs = reverse args } + (_,Int _,Arg ["_buf"] (Ptr Char):args) + -> decl{ declRet = String CChar, declArgs = reverse args } + _other + -> decl + +-- Extended return types. Like string: "int fun(..., void* _buf)" +deriveExtReturn :: Decl -> Decl +deriveExtReturn decl + = case (classifyName (declName decl),declRet decl,reverse (declArgs decl)) of + -- string + (_,Int _,Arg ["_buf"] (Ptr Void):args) + -> decl{ declRet = String CVoid, declArgs = reverse args } + (_,Int _,Arg ["_buf"] (Ptr Char):args) + -> decl{ declRet = String CChar, declArgs = reverse args } + -- point + (_,Void,Arg y (Ptr (Int ctp)):Arg x (Ptr (Int _)):args) + | Set.member (concat x,concat y) points + -> decl{ declRet = Point ctp, declArgs = reverse args } + (_,Void,Arg y (Ptr Void):Arg x (Ptr Void):args) + | Set.member (concat x,concat y) points + -> decl{ declRet = Point CVoid, declArgs = reverse args } + -- rect + (_,Void,Arg h (Ptr (Int ctp)):Arg w (Ptr (Int _)):Arg y (Ptr (Int _)):Arg x (Ptr (Int _)):args) + | Set.member (concat x,concat y,concat w,concat h) rectangles + -> decl{ declRet = Rect ctp, declArgs = reverse args } + (_,Void,Arg h (Ptr Void):Arg w (Ptr Void):Arg y (Ptr Void):Arg x (Ptr Void):args) + | Set.member (concat x,concat y,concat w,concat h) rectangles + -> decl{ declRet = Rect CVoid, declArgs = reverse args } + -- size + (_,Void,Arg y (Ptr (Int ctp)):Arg x (Ptr (Int _)):args) + | Set.member (concat x,concat y) sizes + -> decl{ declRet = Size ctp, declArgs = reverse args } + (_,Void,Arg y (Ptr Void):Arg x (Ptr Void):args) + | Set.member (concat x,concat y) sizes + -> decl{ declRet = Size CVoid, declArgs = reverse args } + -- Vector + (_,Void,Arg y (Ptr (Int ctp)):Arg x (Ptr (Int _)):args) + | Set.member (concat x,concat y) vectors + -> decl{ declRet = Vector ctp, declArgs = reverse args } + (_,Void,Arg y (Ptr Void):Arg x (Ptr Void):args) + | Set.member (concat x,concat y) vectors + -> decl{ declRet = Vector CVoid, declArgs = reverse args } + + -- Null pointer + (Name name,Ptr Void,[]) + | isPrefixOf "Null_" name && isClassName cname + -> decl{ declRet = Object cname } + where + cname = "wx" ++ drop 5 name + + -- Is/Has + (Method _cname (Normal mname),Int _ctp,_) + | (isPrefixOf "Is" mname || isPrefixOf "Has" mname || isPrefixOf "Can" mname + || mname=="Ok" || isPrefixOf "Contains" mname) + -> decl{ declRet = Bool } + + (Method cname (Normal mname),Ptr Void,_) + | isPrefixOf "Create" mname && isClassName createName -- frameCreateStatusBar + -> decl{ declRet = Object createName} + | isPrefixOf "CreateFrom" mname -- bitmapCreateFromMetafile + -> decl{ declRet = Object cname } + | mname == "CreateLoad" || mname == "CreateDefault" + || mname == "CreateEmpty" || mname == "CreateSized" -- bitmapCreateLoad + || mname == "FromRaw" || mname == "FromXPM" -- iconFromRaw + -> decl{ declRet = Object cname } + where + createName = drop (length "Create") mname + + -- Boolean methods + (Method _cname (Normal mname),Int _ctp,_) + | Set.member mname booleanMethods + -> decl{ declRet = Bool } + + -- Object methods + (Method _cname (Normal mname),Ptr Void,_) + -> case Map.lookup mname objectMethods of + Just tp -> decl{ declRet = tp } + Nothing -> decl + -- other + _ -> decl + + +-- returned properties: assumes that deriveThis has already been done +deriveReturnProperties :: Decl -> Decl +deriveReturnProperties decl + = case (classifyName (declName decl),declRet decl,reverse (declArgs decl)) of + -- Get via reference + (Method _cname (Get propname),Void,Arg _ (Ptr Void):args) + | isClassName ("wx" ++ propname) + -> -- trace ("ref: " ++ propname ++ ": " ++ declName decl) $ + decl{ declRet = RefObject ("wx" ++ propname), declArgs = reverse args } + + (Method cname (Get _propname),Void,[Arg _ (Object objname),argself@(Arg _ (Object selfname))]) + | selfname == cname + -> -- trace ("ref: " ++ objname ++ ": " ++ declName decl) $ + decl{ declRet = RefObject objname, declArgs = [argself] } + + -- bit adventurous: deals with things like "bitmapGetSubBitmap" + (Method _cname (Get propname),Void,(Arg _ (Object _objname):args)) + | Map.member propname objectProperties + -> case Map.lookup propname objectProperties of + Just (Object name) -> -- trace ("ref: " ++ name ++ ": " ++ declName decl) $ + decl{ declRet = RefObject name, declArgs = reverse args } + Just _ -> error "deriveReturnProperties: unexpected objectProperty (1)" + Nothing -> traceError ("illegal reference object") decl $ decl + + (Method cname (Get propname),Void,Arg ["_ref"] (Ptr Void):args) + -> case Map.lookup propname objectProperties of + Just (Object name) -> -- trace ("ref: " ++ name ++ ": " ++ declName decl) $ + decl{ declRet = RefObject name, declArgs = reverse args } + Just _ -> error "deriveReturnProperties: unexpected objectProperty (2)" + Nothing | cname == "wxListEvent" && propname == "Item" + -> -- trace ("ref: ListItem: " ++ declName decl) $ + decl{ declRet = RefObject "wxListItem", declArgs = reverse args } + | cname == "wxTreeEvent" && propname == "Item" + -> -- trace ("ref: TreeItemId: " ++ declName decl) $ + decl{ declRet = RefObject "wxTreeItemId", declArgs = reverse args } + | cname == "wxTreeEvent" && propname == "OldItem" + -> -- trace ("ref: TreeItemId: " ++ declName decl) $ + decl{ declRet = RefObject "wxTreeItemId", declArgs = reverse args } + | otherwise + -> traceWarning ("unknown reference object") decl $ + decl{ declRet = RefObject "Ptr", declArgs = reverse args } + + (Method cname (Normal mname),Void,Arg ["_ref"] (Ptr Void):args) + -> case Map.lookup mname referenceObjects of + Just name -> -- trace ("ref: " ++ name ++ ": " ++ declName decl) $ + decl{ declRet = RefObject name, declArgs = reverse args } + Nothing | cname == "wxIconBundle" && mname == "Assign" + -> decl{ declRet = RefObject "wxIconBundle", declArgs = reverse args } + | otherwise + -> traceWarning ("unknown reference object") decl $ + decl{ declRet = RefObject "Ptr", declArgs = reverse args } + + -- Get + (Method _cname (Get propname),Ptr Void,_) + | isClassName ("wx" ++ propname) + -> decl{ declRet = Object ("wx" ++ propname) } + | otherwise + -> case Map.lookup propname objectProperties of + Just tp -> decl{ declRet = tp } + Nothing -> decl + (Method _cname (Get propname),Int _,_) + | Set.member propname booleanProperties + -> decl{ declRet = Bool } + + + -- Set + (Method _cname (Set propname),_,Arg argname (Ptr Void):args) + | isClassName ("wx" ++ propname) + -> decl{ declArgs = reverse (Arg argname (Object ("wx"++propname)) : args)} + | otherwise + -> case Map.lookup propname objectProperties of + Just tp -> decl{ declArgs = reverse (Arg argname tp : args)} + Nothing -> decl + (Method _cname (Set propname),_,Arg argname (Int _):args) + | Set.member propname booleanProperties + -> decl{ declArgs = reverse (Arg argname Bool : args)} + + -- other + _ -> decl + + + +-- Simple types: char* => String +deriveSimpleTypes :: Decl -> Decl +deriveSimpleTypes decl + = decl{ declArgs = deriveArgs (declArgs decl) } + where + deriveArgs args + = map (\arg -> arg{ argType = deriveArg arg }) args + + deriveArg arg + = case argType arg of + Ptr Char -> String CChar + Int _ctp | Set.member (argName arg) booleans -> Bool + | isPrefixOf "is" (argName arg) -> Bool + Ptr Void -> case Map.lookup (argName arg) objects of + Just name -> Object name + _ -> case Map.lookup (argName arg) functions of + Just tp -> Fun tp + _ | Set.member (argName arg) strings -> String CVoid + | isClassName cargName -> Object cargName + | otherwise -> Ptr Void + where + cargName = case argName arg of + (c:cs) -> "wx" ++ (toUpper c : cs) + other -> other + tp -> tp + +-- Check for "this" pointer +-- derive for "wxObject_Create :: ... -> IO (Ptr ())" +deriveThis :: Decl -> Decl +deriveThis decl + = case classifyName (declName decl) of + Create cname | declRet decl == Ptr Void -- bitmapCreate + -> decl{ declRet = Object cname } + Method cname _m | not (null args) && (argType (head args) == Ptr Void) && not (elem cname ["ELJApp"]) + -> decl{ declArgs = (head args){ argType = Object cname} : tail args } + _ -> decl + where + args = declArgs decl + + +-- derive event ids: int expEVT_XXX() and expXXX_XXX(); +deriveId :: Decl -> Decl +deriveId decl@Decl{ declRet = Int _, declArgs = [] } + | isPrefixOf "expEVT_" (declName decl) + = decl{ declRet = EventId } +deriveId decl@Decl{ declRet = Int _, declArgs = [] } + | isPrefixOf "exp" (declName decl) + = decl{ declRet = Id } +deriveId decl + = decl + +{----------------------------------------------------------------------------------------- + Names +-----------------------------------------------------------------------------------------} +data Name = Name String + | Create { className :: ClassName } + | Method { className :: ClassName, method :: Method } + deriving Show + +data Method + = Normal { methodName :: MethodName } + | Set { propName :: PropertyName } + | Get { propName :: PropertyName } + deriving Show + +type ClassName = String +type MethodName = String +type PropertyName = String + +classifyName :: String -> Name +classifyName s + = case s of + ('w' : 'x' : _) -> getClassName s + ('c' : 'b' : _) -> getClassName s + (c : _) | isUpper c -> getClassName s + _ -> Name s + where + getClassName name + = case (span (/='_') name) of + (cname,method') | isClassName cname && not (null method') + -> if (method' == "_Create") + then Create cname + else if (isPrefixOf "_Get" method') + then Method cname (Get (drop 4 method')) + else if (isPrefixOf "_Set" method') + then Method cname (Set (drop 4 method')) + else Method cname (Normal (drop 1 method')) + (_,_)-> Name s
src/HaskellNames.hs view
@@ -1,191 +1,191 @@-------------------------------------------------------------------------------------------{-| Module : HaskellNames- Copyright : (c) Daan Leijen 2003- License : BSD-style-- Maintainer : wxhaskell-devel@lists.sourceforge.net- Stability : provisional- Portability : portable-- Utility module to create Haskell compatible names.--}-------------------------------------------------------------------------------------------module HaskellNames( haskellDeclName- , haskellName, haskellTypeName, haskellUnBuiltinTypeName- , haskellUnderscoreName, haskellArgName- , isBuiltin- , getPrologue- ) where--import qualified Data.Set as Set-import Data.Char( toLower, toUpper, isLower, isUpper )-import Data.List( isPrefixOf )--{------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------}-builtinObjects :: Set.Set String-builtinObjects- = Set.fromList ["wxColour","wxString"]-- {-- [ "Bitmap"- , "Brush"- , "Colour"- , "Cursor"- , "DateTime"- , "Icon"- , "Font"- , "FontData"- , "ListItem"- , "PageSetupData"- , "Pen"- , "PrintData"- , "PrintDialogData"- , "TreeItemId"- ]- -}--reservedVarNames :: Set.Set String-reservedVarNames- = Set.fromList- ["data"- ,"int"- ,"init"- ,"module"- ,"raise"- ,"type"- ,"objectDelete"- ]--reservedTypeNames :: Set.Set String-reservedTypeNames- = Set.fromList- [ "Object"- , "Managed"- , "ManagedPtr"- , "Array"- , "Date"- , "Dir"- , "DllLoader"- , "Expr"- , "File"- , "Point"- , "Size"- , "String"- , "Rect"- ]---{------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------}-haskellDeclName :: String -> String-haskellDeclName name- | isPrefixOf "wxMDI" name = haskellName ("mdi" ++ drop 5 name)- | isPrefixOf "wxDC_" name = haskellName ("dc" ++ drop 5 name)- | isPrefixOf "wxGL" name = haskellName ("gl" ++ drop 4 name)- | isPrefixOf "wxSVG" name = haskellName ("svg" ++ drop 5 name)- | isPrefixOf "expEVT_" name = ("wxEVT_" ++ drop 7 name) -- keep underscores- | isPrefixOf "exp" name = ("wx" ++ drop 3 name)- | isPrefixOf "wxc" name = haskellName name- | isPrefixOf "wx" name = haskellName (drop 2 name)- | isPrefixOf "ELJ" name = haskellName ("wxc" ++ drop 3 name)- | isPrefixOf "DDE" name = haskellName ("dde" ++ drop 3 name)- | otherwise = haskellName name---haskellArgName :: String -> String-haskellArgName name- = haskellName (dropWhile (=='_') name)--haskellName :: String -> String-haskellName name- | Set.member suggested reservedVarNames = "wx" ++ suggested- | otherwise = suggested- where- suggested- = case name of- (c:cs) -> toLower c : filter (/='_') cs- [] -> "wx"--haskellUnderscoreName :: String -> String-haskellUnderscoreName name- | Set.member suggested reservedVarNames = "wx" ++ suggested- | otherwise = suggested- where- suggested- = case name of- ('W':'X':cs) -> "wx" ++ cs- (c:cs) -> toLower c : cs- [] -> "wx"---haskellTypeName :: String -> String-haskellTypeName name- | isPrefixOf "ELJ" name = haskellTypeName ("WXC" ++ drop 3 name)- | Set.member suggested reservedTypeNames = "Wx" ++ suggested- | otherwise = suggested- where- suggested- = case name of- 'W':'X':'C':cs -> "WXC" ++ cs- 'w':'x':'c':cs -> "WXC" ++ cs- 'w':'x':cs -> firstUpper cs- _ -> firstUpper name-- firstUpper name'- = case name' of- c:cs | isLower c -> toUpper c : cs- | not (isUpper c) -> "Wx" ++ name'- | otherwise -> name'- [] -> "Wx"--haskellUnBuiltinTypeName :: String -> String-haskellUnBuiltinTypeName name- | isBuiltin name = haskellTypeName name ++ "Object"- | otherwise = haskellTypeName name--isBuiltin :: String -> Bool-isBuiltin name- = Set.member name builtinObjects--{------------------------------------------------------------------------------------------ Haddock prologue------------------------------------------------------------------------------------------}-getPrologue :: String -> String -> String -> [String] -> [String]-getPrologue moduleName content contains inputFiles- = [line- ,"{-|\tModule : " ++ moduleName- ,"\tCopyright : Copyright (c) Daan Leijen 2003, 2004"- ,"\tLicense : wxWidgets"- ,""- ,"\tMaintainer : wxhaskell-devel@lists.sourceforge.net"- ,"\tStability : provisional"- ,"\tPortability : portable"- ,""- ,"Haskell " ++ content ++ " definitions for the wxWidgets C library (@wxc.dll@)."- ,""- ,"Do not edit this file manually!"- ,"This file was automatically generated by wxDirect."- ]- ++- (if (null inputFiles)- then []- else (["","From the files:"] ++ concatMap showFile inputFiles))- ++- [""- ,"And contains " ++ contains- ,"-}"- ,line- ]- where- line = replicate 80 '-'-- showFile fname- = [""," * @" ++ concatMap escapeSlash fname ++ "@"]-- escapeSlash c- | c == '/' = "\\/"- | c == '\"' = "\\\""- | otherwise = [c]+----------------------------------------------------------------------------------------- +{-| Module : HaskellNames + Copyright : (c) Daan Leijen 2003 + License : BSD-style + + Maintainer : wxhaskell-devel@lists.sourceforge.net + Stability : provisional + Portability : portable + + Utility module to create Haskell compatible names. +-} +----------------------------------------------------------------------------------------- +module HaskellNames( haskellDeclName + , haskellName, haskellTypeName, haskellUnBuiltinTypeName + , haskellUnderscoreName, haskellArgName + , isBuiltin + , getPrologue + ) where + +import qualified Data.Set as Set +import Data.Char( toLower, toUpper, isLower, isUpper ) +import Data.List( isPrefixOf ) + +{----------------------------------------------------------------------------------------- + +-----------------------------------------------------------------------------------------} +builtinObjects :: Set.Set String +builtinObjects + = Set.fromList ["wxColour","wxString"] + + {- + [ "Bitmap" + , "Brush" + , "Colour" + , "Cursor" + , "DateTime" + , "Icon" + , "Font" + , "FontData" + , "ListItem" + , "PageSetupData" + , "Pen" + , "PrintData" + , "PrintDialogData" + , "TreeItemId" + ] + -} + +reservedVarNames :: Set.Set String +reservedVarNames + = Set.fromList + ["data" + ,"int" + ,"init" + ,"module" + ,"raise" + ,"type" + ,"objectDelete" + ] + +reservedTypeNames :: Set.Set String +reservedTypeNames + = Set.fromList + [ "Object" + , "Managed" + , "ManagedPtr" + , "Array" + , "Date" + , "Dir" + , "DllLoader" + , "Expr" + , "File" + , "Point" + , "Size" + , "String" + , "Rect" + ] + + +{----------------------------------------------------------------------------------------- + +-----------------------------------------------------------------------------------------} +haskellDeclName :: String -> String +haskellDeclName name + | isPrefixOf "wxMDI" name = haskellName ("mdi" ++ drop 5 name) + | isPrefixOf "wxDC_" name = haskellName ("dc" ++ drop 5 name) + | isPrefixOf "wxGL" name = haskellName ("gl" ++ drop 4 name) + | isPrefixOf "wxSVG" name = haskellName ("svg" ++ drop 5 name) + | isPrefixOf "expEVT_" name = ("wxEVT_" ++ drop 7 name) -- keep underscores + | isPrefixOf "exp" name = ("wx" ++ drop 3 name) + | isPrefixOf "wxc" name = haskellName name + | isPrefixOf "wx" name = haskellName (drop 2 name) + | isPrefixOf "ELJ" name = haskellName ("wxc" ++ drop 3 name) + | isPrefixOf "DDE" name = haskellName ("dde" ++ drop 3 name) + | otherwise = haskellName name + + +haskellArgName :: String -> String +haskellArgName name + = haskellName (dropWhile (=='_') name) + +haskellName :: String -> String +haskellName name + | Set.member suggested reservedVarNames = "wx" ++ suggested + | otherwise = suggested + where + suggested + = case name of + (c:cs) -> toLower c : filter (/='_') cs + [] -> "wx" + +haskellUnderscoreName :: String -> String +haskellUnderscoreName name + | Set.member suggested reservedVarNames = "wx" ++ suggested + | otherwise = suggested + where + suggested + = case name of + ('W':'X':cs) -> "wx" ++ cs + (c:cs) -> toLower c : cs + [] -> "wx" + + +haskellTypeName :: String -> String +haskellTypeName name + | isPrefixOf "ELJ" name = haskellTypeName ("WXC" ++ drop 3 name) + | Set.member suggested reservedTypeNames = "Wx" ++ suggested + | otherwise = suggested + where + suggested + = case name of + 'W':'X':'C':cs -> "WXC" ++ cs + 'w':'x':'c':cs -> "WXC" ++ cs + 'w':'x':cs -> firstUpper cs + _ -> firstUpper name + + firstUpper name' + = case name' of + c:cs | isLower c -> toUpper c : cs + | not (isUpper c) -> "Wx" ++ name' + | otherwise -> name' + [] -> "Wx" + +haskellUnBuiltinTypeName :: String -> String +haskellUnBuiltinTypeName name + | isBuiltin name = haskellTypeName name ++ "Object" + | otherwise = haskellTypeName name + +isBuiltin :: String -> Bool +isBuiltin name + = Set.member name builtinObjects + +{----------------------------------------------------------------------------------------- + Haddock prologue +-----------------------------------------------------------------------------------------} +getPrologue :: String -> String -> String -> [String] -> [String] +getPrologue moduleName content contains inputFiles + = [line + ,"{-|\tModule : " ++ moduleName + ,"\tCopyright : Copyright (c) Daan Leijen 2003, 2004" + ,"\tLicense : wxWidgets" + ,"" + ,"\tMaintainer : wxhaskell-devel@lists.sourceforge.net" + ,"\tStability : provisional" + ,"\tPortability : portable" + ,"" + ,"Haskell " ++ content ++ " definitions for the wxWidgets C library (@wxc.dll@)." + ,"" + ,"Do not edit this file manually!" + ,"This file was automatically generated by wxDirect." + ] + ++ + (if (null inputFiles) + then [] + else (["","From the files:"] ++ concatMap showFile inputFiles)) + ++ + ["" + ,"And contains " ++ contains + ,"-}" + ,line + ] + where + line = replicate 80 '-' + + showFile fname + = [""," * @" ++ concatMap escapeSlash fname ++ "@"] + + escapeSlash c + | c == '/' = "\\/" + | c == '\"' = "\\\"" + | otherwise = [c]
src/IOExtra.hs view
@@ -1,24 +1,24 @@-------------------------------------------------------------------------------------------{-| Module : IOExtra- Copyright : (c) Dave Tapley 2011- License : BSD-style-- Maintainer : wxhaskell-devel@lists.sourceforge.net-- Module that writes a string lazily to a file.--}-------------------------------------------------------------------------------------------module IOExtra( writeFileLazy ) where--import Control.Exception-import Control.Monad-import System.IO.Error-import qualified System.IO.Strict as Strictly--{------------------------------------------------------------------------------------------Only write to the file if its contents have changed,-e.g. don't change the file's modified time, unless you change the contents.------------------------------------------------------------------------------------------}-writeFileLazy :: FilePath -> String -> IO ()-writeFileLazy f str = fileChanged >>= flip when (writeFile f str)- where fileChanged = return . either (const True) (/= str) =<< tryJust (guard . isDoesNotExistError) (Strictly.readFile f)+----------------------------------------------------------------------------------------- +{-| Module : IOExtra + Copyright : (c) Dave Tapley 2011 + License : BSD-style + + Maintainer : wxhaskell-devel@lists.sourceforge.net + + Module that writes a string lazily to a file. +-} +----------------------------------------------------------------------------------------- +module IOExtra( writeFileLazy ) where + +import Control.Exception +import Control.Monad +import System.IO.Error +import qualified System.IO.Strict as Strictly + +{----------------------------------------------------------------------------------------- +Only write to the file if its contents have changed, +e.g. don't change the file's modified time, unless you change the contents. +-----------------------------------------------------------------------------------------} +writeFileLazy :: FilePath -> String -> IO () +writeFileLazy f str = fileChanged >>= flip when (writeFile f str) + where fileChanged = return . either (const True) (/= str) =<< tryJust (guard . isDoesNotExistError) (Strictly.readFile f)
src/Main.hs view
@@ -1,233 +1,233 @@-------------------------------------------------------------------------------------------{-| Module : Main- Copyright : (c) Daan Leijen 2003- License : BSD-style-- Maintainer : wxhaskell-devel@lists.sourceforge.net- Stability : provisional- Portability : portable-- The program @wxDirect@ generates the @Graphics.UI.WXCore.WxcClasses@ module automatically- from the @wxc.h@ header file and the header files included in it. It is highly dependent on the- format of these header files, but generates a very reasonable Haskell interface- on top of the basic C interface.-- The generation process can easily be tuned by editing the string lists in this file.--}-------------------------------------------------------------------------------------------module Main where--import System.Environment( getArgs )-import System.Console.GetOpt-import System.FilePath ( pathSeparator )--import CompileClasses ( compileClasses)-import CompileHeader ( compileHeader )-import CompileClassTypes( compileClassTypes )-import CompileClassInfo ( compileClassInfo )-import CompileSTC ( compileSTC )--import Classes( getWxcDir, setWxcDir )--{------------------------------------------------------------------------------------------ Main & options------------------------------------------------------------------------------------------}-main :: IO ()-main- = do mode <- compileOpts- case mode of- ModeHelp- -> showHelp- ModeClasses outputDir' inputFiles' verbose'- -> compileClasses verbose' moduleRootWxCore moduleClassTypesName moduleClassesName- (outputDir' ++ moduleClassesName) inputFiles'- ModeClassTypes outputDir' inputFiles' verbose'- -> compileClassTypes verbose' moduleRootWxCore moduleClassTypesName- (outputDir' ++ moduleClassTypesName ++ ".hs") inputFiles'- ModeClassInfo outputDir' verbose'- -> compileClassInfo verbose' moduleRootWxCore moduleClassesName moduleClassTypesName moduleClassInfoName- (outputDir' ++ moduleClassInfoName ++ ".hs")-- ModeCHeader outputDir' inputFiles' verbose'- -> compileHeader verbose' (outputDir' ++ "wxc_glue.h") inputFiles'- ModeSTC outputDir' inputFiles' verbose'- -> compileSTC verbose' outputDir' inputFiles'- -- putStrLn "done."--moduleClassesShortName, moduleClassTypesName, moduleClassesName,- moduleClassInfoName, moduleDefsName, moduleRootWxCore, - moduleRootWx :: String--moduleClassesShortName= "Classes"-moduleClassTypesName = "WxcClassTypes"-moduleClassesName = "WxcClasses"-moduleClassInfoName = "WxcClassInfo"-moduleDefsName = "WxcDefs"-moduleRootWxCore = "Graphics.UI.WXCore."-moduleRootWx = "Graphics.UI.WX."---moduleRootDir :: String -> FilePath-moduleRootDir moduleRoot- = map dotToSlash moduleRoot- where- dotToSlash c | c == '.' = pathSeparator- | otherwise = c---defaultOutputDirWxh :: FilePath-defaultOutputDirWxh- = "../wxcore/src/" ++ moduleRootDir moduleRootWxCore--getDefaultFiles :: IO [FilePath]-getDefaultFiles = getDefaultHeaderFiles--getDefaultHeaderFiles :: IO [FilePath]-getDefaultHeaderFiles- = do wxcdir <- getWxcDir- return [wxcdir ++ "/include/wxc.h"]--getDefaultSTCHeaderFile :: IO [FilePath]-getDefaultSTCHeaderFile- = do wxcdir <- getWxcDir- return [wxcdir ++ "/wxSTC-D3/stc.h"]--getDefaultOutputDirWxc :: IO FilePath-getDefaultOutputDirWxc- = do wxcdir <- getWxcDir- return (wxcdir ++ "/include/")--{------------------------------------------------------------------------------------------ Options------------------------------------------------------------------------------------------}-data Flag- = Verbose | Output FilePath | Target Target | Help | WxcDir FilePath---data Target- = TClasses | TClassTypes | THeader | TClassInfo | TSTC--data Mode- = ModeHelp- | ModeClasses { outputDir :: FilePath, inputFiles :: [FilePath], verbose :: Bool }- | ModeClassTypes { outputDir :: FilePath, inputFiles :: [FilePath], verbose :: Bool }- | ModeClassInfo { outputDir :: FilePath, verbose :: Bool }- | ModeCHeader { outputDir :: FilePath, inputFiles :: [FilePath], verbose :: Bool }- | ModeSTC { outputDir :: FilePath, inputFiles :: [FilePath], verbose :: Bool }---isHelp :: Flag -> Bool-isHelp Help = True-isHelp _ = False--isVerbose :: Flag -> Bool-isVerbose Verbose = True-isVerbose _ = False--isOutput :: Flag -> Bool-isOutput (Output _) = True-isOutput _ = False--isTarget :: Flag -> Bool-isTarget (Target _) = True-isTarget _ = False--options :: [OptDescr Flag]-options =- [ Option ['c'] ["classes"] (NoArg (Target TClasses)) "generate class method definitions from .h files"- , Option ['t'] ["classtypes"] (NoArg (Target TClassTypes)) "generate class type definitions from .h files"- , Option ['i'] ["classinfo"] (NoArg (Target TClassInfo)) "generate class info definitions"- , Option ['h'] ["header"] (NoArg (Target THeader)) "generate typed C header file -- development use only"- , Option ['s'] ["stc"] (NoArg (Target TSTC)) "generate wxSTC wrapper from .h file"- , Option ['v'] ["verbose"] (NoArg Verbose) "verbose: show ignored definitions"- , Option ['o'] ["output"] (ReqArg Output "DIR") "optional output directory"- , Option ['w'] ["wxc"] (ReqArg WxcDir "DIR") "optional 'wxc' directory (=../wxc)"- , Option ['?'] ["help"] (NoArg Help) "show this information"- ]--compileOpts :: IO Mode-compileOpts- = do args <- getArgs- case (getOpt Permute options args) of- (flags,files,[])- -> do extractWxcDir (reverse flags)- if (any isHelp flags)- then return ModeHelp- else case filter isTarget flags of- [] -> invokeError ["you need to specify a target: methods, definitions or classes.\n"]- [Target TClassInfo]- -> do outputDir' <- getOutputDir flags defaultOutputDirWxh- return (ModeClassInfo outputDir' (any isVerbose flags))-- [Target TClasses] -> do defaultHeaderFiles <- getDefaultHeaderFiles- inputFiles' <- getInputFiles ".h" defaultHeaderFiles files- outputDir' <- getOutputDir flags defaultOutputDirWxh- return (ModeClasses outputDir' inputFiles' (any isVerbose flags))- [Target TClassTypes] ->- do defaultHeaderFiles <- getDefaultHeaderFiles- inputFiles' <- getInputFiles ".h" defaultHeaderFiles files- outputDir' <- getOutputDir flags defaultOutputDirWxh- return (ModeClassTypes outputDir' inputFiles' (any isVerbose flags))- [Target THeader]- -> do defaultHeaderFiles <- getDefaultHeaderFiles- inputFiles' <- getInputFiles ".h" defaultHeaderFiles files- defdir <- getDefaultOutputDirWxc- outputDir' <- getOutputDir flags defdir- return (ModeCHeader outputDir' inputFiles' (any isVerbose flags))- [Target TSTC]- -> do defaultSTCHeaderFile <- getDefaultSTCHeaderFile- inputFiles' <- getInputFiles ".h" defaultSTCHeaderFile files- defdir <- getDefaultOutputDirWxc- outputDir' <- getOutputDir flags defdir- return (ModeSTC outputDir' inputFiles' (any isVerbose flags))- _other -> invokeError ["invalid, or multiple, targets specification.\n"]- (_,_,errs)- -> invokeError errs- where- getOutputDir flags defaultOutputDir- = case filter isOutput flags of- [] -> do putStrLn ("warning: using default output directory:\n " ++ defaultOutputDir ++ "\n")- return defaultOutputDir- [Output dir] -> case reverse dir of- [] -> return ""- ('/':_cs) -> return dir- ('\\':_cs) -> return dir- _other -> return (dir ++ "/")- _other -> invokeError ["invalid, or multiple, output directories"]-- getInputFiles ext defaultFiles files- = case filter (hasExt ext) files of- [] -> do putStrLn (unlines (["warning: using default input files:"] ++ map (" "++) defaultFiles))- return defaultFiles- fs -> return fs-- hasExt ext file- = let (rext,rbase) = span (/='.') (reverse file)- in (not (null rbase) && (ext == ("." ++ reverse rext)))-- -- wxcdir is set via a global variable (yes, I know, it is an ugly hack :-)- extractWxcDir flags- = case flags of- (WxcDir dir :_fs) -> setWxcDir dir- (_other :fs) -> extractWxcDir fs- [] -> return ()----showHelp :: IO ()-showHelp- = do msg <- helpMessage- putStrLn msg--invokeError :: [String] -> IO a-invokeError errs- = do msg <- helpMessage- ioError (userError (concat errs ++ "\n" ++ msg))--helpMessage :: IO String-helpMessage- = do defaultFiles <- getDefaultFiles- return (usageInfo header options ++- "\ndefault input files:\n" ++- unlines (map (" "++) defaultFiles))- where header = "usage: wxDirect -[dcti] [other options] [header-files..]"+----------------------------------------------------------------------------------------- +{-| Module : Main + Copyright : (c) Daan Leijen 2003 + License : BSD-style + + Maintainer : wxhaskell-devel@lists.sourceforge.net + Stability : provisional + Portability : portable + + The program @wxDirect@ generates the @Graphics.UI.WXCore.WxcClasses@ module automatically + from the @wxc.h@ header file and the header files included in it. It is highly dependent on the + format of these header files, but generates a very reasonable Haskell interface + on top of the basic C interface. + + The generation process can easily be tuned by editing the string lists in this file. +-} +----------------------------------------------------------------------------------------- +module Main where + +import System.Environment( getArgs ) +import System.Console.GetOpt +import System.FilePath ( pathSeparator ) + +import CompileClasses ( compileClasses) +import CompileHeader ( compileHeader ) +import CompileClassTypes( compileClassTypes ) +import CompileClassInfo ( compileClassInfo ) +import CompileSTC ( compileSTC ) + +import Classes( getWxcDir, setWxcDir ) + +{----------------------------------------------------------------------------------------- + Main & options +-----------------------------------------------------------------------------------------} +main :: IO () +main + = do mode <- compileOpts + case mode of + ModeHelp + -> showHelp + ModeClasses outputDir' inputFiles' verbose' + -> compileClasses verbose' moduleRootWxCore moduleClassTypesName moduleClassesName + (outputDir' ++ moduleClassesName) inputFiles' + ModeClassTypes outputDir' inputFiles' verbose' + -> compileClassTypes verbose' moduleRootWxCore moduleClassTypesName + (outputDir' ++ moduleClassTypesName ++ ".hs") inputFiles' + ModeClassInfo outputDir' verbose' + -> compileClassInfo verbose' moduleRootWxCore moduleClassesName moduleClassTypesName moduleClassInfoName + (outputDir' ++ moduleClassInfoName ++ ".hs") + + ModeCHeader outputDir' inputFiles' verbose' + -> compileHeader verbose' (outputDir' ++ "wxc_glue.h") inputFiles' + ModeSTC outputDir' inputFiles' verbose' + -> compileSTC verbose' outputDir' inputFiles' + -- putStrLn "done." + +moduleClassesShortName, moduleClassTypesName, moduleClassesName, + moduleClassInfoName, moduleDefsName, moduleRootWxCore, + moduleRootWx :: String + +moduleClassesShortName= "Classes" +moduleClassTypesName = "WxcClassTypes" +moduleClassesName = "WxcClasses" +moduleClassInfoName = "WxcClassInfo" +moduleDefsName = "WxcDefs" +moduleRootWxCore = "Graphics.UI.WXCore." +moduleRootWx = "Graphics.UI.WX." + + +moduleRootDir :: String -> FilePath +moduleRootDir moduleRoot + = map dotToSlash moduleRoot + where + dotToSlash c | c == '.' = pathSeparator + | otherwise = c + + +defaultOutputDirWxh :: FilePath +defaultOutputDirWxh + = "../wxcore/src/" ++ moduleRootDir moduleRootWxCore + +getDefaultFiles :: IO [FilePath] +getDefaultFiles = getDefaultHeaderFiles + +getDefaultHeaderFiles :: IO [FilePath] +getDefaultHeaderFiles + = do wxcdir <- getWxcDir + return [wxcdir ++ "/include/wxc.h"] + +getDefaultSTCHeaderFile :: IO [FilePath] +getDefaultSTCHeaderFile + = do wxcdir <- getWxcDir + return [wxcdir ++ "/wxSTC-D3/stc.h"] + +getDefaultOutputDirWxc :: IO FilePath +getDefaultOutputDirWxc + = do wxcdir <- getWxcDir + return (wxcdir ++ "/include/") + +{----------------------------------------------------------------------------------------- + Options +-----------------------------------------------------------------------------------------} +data Flag + = Verbose | Output FilePath | Target Target | Help | WxcDir FilePath + + +data Target + = TClasses | TClassTypes | THeader | TClassInfo | TSTC + +data Mode + = ModeHelp + | ModeClasses { outputDir :: FilePath, inputFiles :: [FilePath], verbose :: Bool } + | ModeClassTypes { outputDir :: FilePath, inputFiles :: [FilePath], verbose :: Bool } + | ModeClassInfo { outputDir :: FilePath, verbose :: Bool } + | ModeCHeader { outputDir :: FilePath, inputFiles :: [FilePath], verbose :: Bool } + | ModeSTC { outputDir :: FilePath, inputFiles :: [FilePath], verbose :: Bool } + + +isHelp :: Flag -> Bool +isHelp Help = True +isHelp _ = False + +isVerbose :: Flag -> Bool +isVerbose Verbose = True +isVerbose _ = False + +isOutput :: Flag -> Bool +isOutput (Output _) = True +isOutput _ = False + +isTarget :: Flag -> Bool +isTarget (Target _) = True +isTarget _ = False + +options :: [OptDescr Flag] +options = + [ Option ['c'] ["classes"] (NoArg (Target TClasses)) "generate class method definitions from .h files" + , Option ['t'] ["classtypes"] (NoArg (Target TClassTypes)) "generate class type definitions from .h files" + , Option ['i'] ["classinfo"] (NoArg (Target TClassInfo)) "generate class info definitions" + , Option ['h'] ["header"] (NoArg (Target THeader)) "generate typed C header file -- development use only" + , Option ['s'] ["stc"] (NoArg (Target TSTC)) "generate wxSTC wrapper from .h file" + , Option ['v'] ["verbose"] (NoArg Verbose) "verbose: show ignored definitions" + , Option ['o'] ["output"] (ReqArg Output "DIR") "optional output directory" + , Option ['w'] ["wxc"] (ReqArg WxcDir "DIR") "optional 'wxc' directory (=../wxc)" + , Option ['?'] ["help"] (NoArg Help) "show this information" + ] + +compileOpts :: IO Mode +compileOpts + = do args <- getArgs + case (getOpt Permute options args) of + (flags,files,[]) + -> do extractWxcDir (reverse flags) + if (any isHelp flags) + then return ModeHelp + else case filter isTarget flags of + [] -> invokeError ["you need to specify a target: methods, definitions or classes.\n"] + [Target TClassInfo] + -> do outputDir' <- getOutputDir flags defaultOutputDirWxh + return (ModeClassInfo outputDir' (any isVerbose flags)) + + [Target TClasses] -> do defaultHeaderFiles <- getDefaultHeaderFiles + inputFiles' <- getInputFiles ".h" defaultHeaderFiles files + outputDir' <- getOutputDir flags defaultOutputDirWxh + return (ModeClasses outputDir' inputFiles' (any isVerbose flags)) + [Target TClassTypes] -> + do defaultHeaderFiles <- getDefaultHeaderFiles + inputFiles' <- getInputFiles ".h" defaultHeaderFiles files + outputDir' <- getOutputDir flags defaultOutputDirWxh + return (ModeClassTypes outputDir' inputFiles' (any isVerbose flags)) + [Target THeader] + -> do defaultHeaderFiles <- getDefaultHeaderFiles + inputFiles' <- getInputFiles ".h" defaultHeaderFiles files + defdir <- getDefaultOutputDirWxc + outputDir' <- getOutputDir flags defdir + return (ModeCHeader outputDir' inputFiles' (any isVerbose flags)) + [Target TSTC] + -> do defaultSTCHeaderFile <- getDefaultSTCHeaderFile + inputFiles' <- getInputFiles ".h" defaultSTCHeaderFile files + defdir <- getDefaultOutputDirWxc + outputDir' <- getOutputDir flags defdir + return (ModeSTC outputDir' inputFiles' (any isVerbose flags)) + _other -> invokeError ["invalid, or multiple, targets specification.\n"] + (_,_,errs) + -> invokeError errs + where + getOutputDir flags defaultOutputDir + = case filter isOutput flags of + [] -> do putStrLn ("warning: using default output directory:\n " ++ defaultOutputDir ++ "\n") + return defaultOutputDir + [Output dir] -> case reverse dir of + [] -> return "" + ('/':_cs) -> return dir + ('\\':_cs) -> return dir + _other -> return (dir ++ "/") + _other -> invokeError ["invalid, or multiple, output directories"] + + getInputFiles ext defaultFiles files + = case filter (hasExt ext) files of + [] -> do putStrLn (unlines (["warning: using default input files:"] ++ map (" "++) defaultFiles)) + return defaultFiles + fs -> return fs + + hasExt ext file + = let (rext,rbase) = span (/='.') (reverse file) + in (not (null rbase) && (ext == ("." ++ reverse rext))) + + -- wxcdir is set via a global variable (yes, I know, it is an ugly hack :-) + extractWxcDir flags + = case flags of + (WxcDir dir :_fs) -> setWxcDir dir + (_other :fs) -> extractWxcDir fs + [] -> return () + + + +showHelp :: IO () +showHelp + = do msg <- helpMessage + putStrLn msg + +invokeError :: [String] -> IO a +invokeError errs + = do msg <- helpMessage + ioError (userError (concat errs ++ "\n" ++ msg)) + +helpMessage :: IO String +helpMessage + = do defaultFiles <- getDefaultFiles + return (usageInfo header options ++ + "\ndefault input files:\n" ++ + unlines (map (" "++) defaultFiles)) + where header = "usage: wxDirect -[dcti] [other options] [header-files..]"
src/ParseC.hs view
@@ -1,333 +1,336 @@-------------------------------------------------------------------------------------------{-| 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+----------------------------------------------------------------------------------------- +{-| 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 "//") . + 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
src/Types.hs view
@@ -1,139 +1,139 @@-------------------------------------------------------------------------------------------{-| Module : ParseC- Copyright : (c) Daan Leijen 2003- License : BSD-style-- Maintainer : wxhaskell-devel@lists.sourceforge.net- Stability : provisional- Portability : portable-- Basic Types--}-------------------------------------------------------------------------------------------module Types( trace, traceIgnore, traceWarning, traceError- , errorMsg, errorMsgDecl- , Decl(..), Arg(..), Type(..), Strategy(..), CBaseType(..), argName- , Def(..), DefType(..)- ) where--import System.IO.Unsafe ( unsafePerformIO )---{------------------------------------------------------------------------------------------ Tracing------------------------------------------------------------------------------------------}-trace :: String -> t -> t-trace s x- = seq (unsafePerformIO (putStrLn s)) x--traceIgnore :: [Char] -> Decl -> t -> t-traceIgnore msg decl x- = trace ("ignore: " ++ fill 12 msg ++ ": " ++ declName decl) x- where- fill :: Int -> String -> String- fill n s | length s >= n = s- | otherwise = s ++ replicate (n - length s) ' '--traceWarning :: [Char] -> Decl -> t -> t-traceWarning msg decl x- = trace ("****************************************************\n" ++- "warning : " ++ msg ++ ": " ++ declName decl) x--traceError :: [Char] -> Decl -> t -> t-traceError msg decl x- = trace ("****************************************************\n" ++- "error : " ++ msg ++ ": " ++ declName decl) x---errorMsg :: [Char] -> t-errorMsg str- = error ("error: " ++ str)--errorMsgDecl :: Decl -> [Char] -> t-errorMsgDecl decl str- = errorMsg (str ++ " in " ++ declName decl ++ ": " ++ show decl)--{------------------------------------------------------------------------------------------ (Eiffel) Definitions------------------------------------------------------------------------------------------}-data Def = Def{ defName :: String- , defValue :: Int- , defType :: DefType- }- deriving Show--data DefType = DefInt -- normal integer- | DefMask -- bit mask- deriving Show--{------------------------------------------------------------------------------------------ (C) Declarations------------------------------------------------------------------------------------------}-data Decl = Decl{ declName :: String- , declRet :: Type- , declArgs :: [Arg]- , declComment :: String- }- deriving Show--data Arg = Arg{ argNames :: [String]- , argType :: Type- }- deriving Show--argName :: Arg -> String-argName arg- = concat (argNames arg)--data Type = Int CBaseType- | IntPtr- | Int64- | Word- | Word8- | Word32- | Word64- | Void- | Char- | Double- | Float- | Ptr Type- | ByteString Strategy- | ByteStringOut Strategy- | ByteStringLen- -- typedefs- | EventId- | Id- -- temporary types- | StringLen- | StringOut CBaseType- | PointOut CBaseType- | SizeOut CBaseType- | VectorOut CBaseType- | RectOut CBaseType- | ArrayLen- | ArrayStringOut CBaseType- | ArrayIntOut CBaseType- | ArrayIntPtrOut CBaseType- | ArrayObjectOut String CBaseType- -- derived types- | Object String- | String CBaseType- | ArrayInt CBaseType- | ArrayIntPtr CBaseType- | ArrayString CBaseType- | ArrayObject String CBaseType- | Bool- | Point CBaseType- | Size CBaseType- | Vector CBaseType- | Rect CBaseType- | RefObject String -- for "GetFont" etc. returns the font via an indirect reference!- | Fun String -- function pointers- | ColorRGB CBaseType- deriving (Eq,Show)--data Strategy = Lazy | Strict- deriving (Eq,Show)--data CBaseType = CVoid | CInt | CLong | CDouble | CChar | TimeT | SizeT | CObject- deriving (Eq,Show)+----------------------------------------------------------------------------------------- +{-| Module : ParseC + Copyright : (c) Daan Leijen 2003 + License : BSD-style + + Maintainer : wxhaskell-devel@lists.sourceforge.net + Stability : provisional + Portability : portable + + Basic Types +-} +----------------------------------------------------------------------------------------- +module Types( trace, traceIgnore, traceWarning, traceError + , errorMsg, errorMsgDecl + , Decl(..), Arg(..), Type(..), Strategy(..), CBaseType(..), argName + , Def(..), DefType(..) + ) where + +import System.IO.Unsafe ( unsafePerformIO ) + + +{----------------------------------------------------------------------------------------- + Tracing +-----------------------------------------------------------------------------------------} +trace :: String -> t -> t +trace s x + = seq (unsafePerformIO (putStrLn s)) x + +traceIgnore :: [Char] -> Decl -> t -> t +traceIgnore msg decl x + = trace ("ignore: " ++ fill 12 msg ++ ": " ++ declName decl) x + where + fill :: Int -> String -> String + fill n s | length s >= n = s + | otherwise = s ++ replicate (n - length s) ' ' + +traceWarning :: [Char] -> Decl -> t -> t +traceWarning msg decl x + = trace ("****************************************************\n" ++ + "warning : " ++ msg ++ ": " ++ declName decl) x + +traceError :: [Char] -> Decl -> t -> t +traceError msg decl x + = trace ("****************************************************\n" ++ + "error : " ++ msg ++ ": " ++ declName decl) x + + +errorMsg :: [Char] -> t +errorMsg str + = error ("error: " ++ str) + +errorMsgDecl :: Decl -> [Char] -> t +errorMsgDecl decl str + = errorMsg (str ++ " in " ++ declName decl ++ ": " ++ show decl) + +{----------------------------------------------------------------------------------------- + (Eiffel) Definitions +-----------------------------------------------------------------------------------------} +data Def = Def{ defName :: String + , defValue :: Int + , defType :: DefType + } + deriving Show + +data DefType = DefInt -- normal integer + | DefMask -- bit mask + deriving Show + +{----------------------------------------------------------------------------------------- + (C) Declarations +-----------------------------------------------------------------------------------------} +data Decl = Decl{ declName :: String + , declRet :: Type + , declArgs :: [Arg] + , declComment :: String + } + deriving Show + +data Arg = Arg{ argNames :: [String] + , argType :: Type + } + deriving Show + +argName :: Arg -> String +argName arg + = concat (argNames arg) + +data Type = Int CBaseType + | IntPtr + | Int64 + | Word + | Word8 + | Word32 + | Word64 + | Void + | Char + | Double + | Float + | Ptr Type + | ByteString Strategy + | ByteStringOut Strategy + | ByteStringLen + -- typedefs + | EventId + | Id + -- temporary types + | StringLen + | StringOut CBaseType + | PointOut CBaseType + | SizeOut CBaseType + | VectorOut CBaseType + | RectOut CBaseType + | ArrayLen + | ArrayStringOut CBaseType + | ArrayIntOut CBaseType + | ArrayIntPtrOut CBaseType + | ArrayObjectOut String CBaseType + -- derived types + | Object String + | String CBaseType + | ArrayInt CBaseType + | ArrayIntPtr CBaseType + | ArrayString CBaseType + | ArrayObject String CBaseType + | Bool + | Point CBaseType + | Size CBaseType + | Vector CBaseType + | Rect CBaseType + | RefObject String -- for "GetFont" etc. returns the font via an indirect reference! + | Fun String -- function pointers + | ColorRGB CBaseType + deriving (Eq,Show) + +data Strategy = Lazy | Strict + deriving (Eq,Show) + +data CBaseType = CVoid | CInt | CLong | CDouble | CChar | TimeT | SizeT | CObject + deriving (Eq,Show)
wxdirect.cabal view
@@ -1,67 +1,67 @@-name: wxdirect-version: 0.90.1.1-license: BSD3-license-file: LICENSE-author: Daan Leijen-maintainer: wxhaskell-devel@lists.sourceforge.net-category: GUI, User interfaces-synopsis: helper tool for building wxHaskell-description:- wxHaskell is a portable and native GUI library for Haskell. It is built on- top of wxWidgets, a comprehensive C++ library that is portable across all- major GUI platforms, including GTK, Windows, X11, and MacOS X. This version- works with wxWidgets 2.9 only.-homepage: http://haskell.org/haskellwiki/WxHaskell--cabal-version: >= 1.2-build-type: Simple--flag splitBase- description: use new split base- default: True--library- hs-source-dirs:- src-- exposed-modules:- Application.Wxdirect--executable wxdirect- main-is: Main.hs-- other-modules: Classes- , CompileClasses- , CompileClassInfo- , CompileClassTypes- , CompileHeader- , CompileSTC- , DeriveTypes- , HaskellNames- , IOExtra- , ParseC- , Types-- hs-source-dirs:- src-- build-depends:- directory,- parsec >= 2.1.0 && < 4,- strict,- time >= 1.0 && < 1.5,- filepath < 1.4,- process >= 1.1 && < 1.2-- if flag(splitBase)- build-depends:- base >= 4 && < 5,- containers >= 0.2 && < 0.6- else- build-depends:- base >= 3 && < 4,- containers >= 0.1 && < 0.3-- ghc-options: -Wall -O2- if impl(ghc >= 6.8)- ghc-options: -fwarn-tabs+name: wxdirect +version: 0.91.0.0 +license: BSD3 +license-file: LICENSE +author: Daan Leijen +maintainer: wxhaskell-devel@lists.sourceforge.net +category: GUI, User interfaces +synopsis: helper tool for building wxHaskell +description: + wxHaskell is a portable and native GUI library for Haskell. It is built on + top of wxWidgets, a comprehensive C++ library that is portable across all + major GUI platforms, including GTK, Windows, X11, and MacOS X. This version + works with wxWidgets 2.9 and 3.0. +homepage: http://haskell.org/haskellwiki/WxHaskell + +cabal-version: >= 1.2 +build-type: Simple + +flag splitBase + description: use new split base + default: True + +library + hs-source-dirs: + src + + exposed-modules: + Application.Wxdirect + +executable wxdirect + main-is: Main.hs + + other-modules: Classes + , CompileClasses + , CompileClassInfo + , CompileClassTypes + , CompileHeader + , CompileSTC + , DeriveTypes + , HaskellNames + , IOExtra + , ParseC + , Types + + hs-source-dirs: + src + + build-depends: + directory, + parsec >= 2.1.0 && < 4, + strict, + time >= 1.0 && < 1.5, + filepath < 1.4, + process >= 1.1 && < 1.3 + + if flag(splitBase) + build-depends: + base >= 4 && < 5, + containers >= 0.2 && < 0.6 + else + build-depends: + base >= 3 && < 4, + containers >= 0.1 && < 0.3 + + ghc-options: -Wall -O2 + if impl(ghc >= 6.8) + ghc-options: -fwarn-tabs