diff --git a/src/Classes.hs b/src/Classes.hs --- a/src/Classes.hs +++ b/src/Classes.hs @@ -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 + } diff --git a/src/CompileClassInfo.hs b/src/CompileClassInfo.hs --- a/src/CompileClassInfo.hs +++ b/src/CompileClassInfo.hs @@ -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') diff --git a/src/CompileClassTypes.hs b/src/CompileClassTypes.hs --- a/src/CompileClassTypes.hs +++ b/src/CompileClassTypes.hs @@ -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 = " " + diff --git a/src/CompileClasses.hs b/src/CompileClasses.hs --- a/src/CompileClasses.hs +++ b/src/CompileClasses.hs @@ -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..]] diff --git a/src/CompileHeader.hs b/src/CompileHeader.hs --- a/src/CompileHeader.hs +++ b/src/CompileHeader.hs @@ -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 -> "" diff --git a/src/DeriveTypes.hs b/src/DeriveTypes.hs --- a/src/DeriveTypes.hs +++ b/src/DeriveTypes.hs @@ -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 diff --git a/src/HaskellNames.hs b/src/HaskellNames.hs --- a/src/HaskellNames.hs +++ b/src/HaskellNames.hs @@ -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] diff --git a/src/IOExtra.hs b/src/IOExtra.hs --- a/src/IOExtra.hs +++ b/src/IOExtra.hs @@ -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) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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..]" diff --git a/src/ParseC.hs b/src/ParseC.hs --- a/src/ParseC.hs +++ b/src/ParseC.hs @@ -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 diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -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) diff --git a/wxdirect.cabal b/wxdirect.cabal --- a/wxdirect.cabal +++ b/wxdirect.cabal @@ -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