diff --git a/src/Classes.hs b/src/Classes.hs new file mode 100644 --- /dev/null +++ b/src/Classes.hs @@ -0,0 +1,446 @@ +----------------------------------------------------------------------------------------- +{-| 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 wxWindows. +-} +----------------------------------------------------------------------------------------- +module Classes( isClassName, isBuiltin, haskellClassDefs + , objectClassNames, classNames + , classExtends + , getWxcDir, setWxcDir + -- * Class info + , ClassInfo(..) + , classInfo + , classIsManaged + , findManaged + , managedClasses + ) where + +import System.Environment ( getEnv ) +import Data.Char( isUpper ) +import Data.List( sort, sortBy ) +import qualified Data.Set as Set +import qualified Data.Map as Map +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 {- + xs <- parseClassHierarchy "ClassHierarchy.txt" + ys <- parseClassHierarchy "ClassHierarchyExtra.txt" + -} + -- urk, ugly hack. + wxcdir <- getWxcDir + cs <- parseClassDefs (wxcdir ++ "/include/wxc.h") + -- ,wxcdir ++ "/include/ewxw/wxc_glue.h" + -- ,wxcdir ++ "/include/db.h" + + -- writeFile "wxclasses.def" (showClasses cs) + return cs + -- return (mergeClasses xs ys) -- (mergeClasses zs (mergeClasses ys xs)) + + +mergeClasses xs ys + = foldr (\c cs -> mergeClass c cs) xs ys + +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 info -> 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 d c + = showString (showClass 0 c) + +showClasses cs + = unlines (map (showClass 0) cs) + +showClass indent (Class name subs) + = (replicate indent '\t' ++ name ++ concatMap ("\n"++) (map (showClass (indent+1)) subs)) + +isClassName s + = Set.member s classNames + +objectClassNames :: [String] +objectClassNames + = case filter isObject classes of + [classObject] -> -- filter (/="wxColour") $ + flatten classObject + other -> [] + 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 parents (Class name derived) +-- | isBuiltin name = [] -- handled as a basic type +-- | otherwise + = ( (tname,[tname,inheritName tname,className tname]) -- ++ (if isBuiltin name then [tname ++ "Object"] else [])) + , ({- + if isBuiltin name + then ("-- | Pointer to a managed object of type '" ++ tname ++ "'" ++ + (if null parents then "" else ", derived from '" ++ head parents ++ "'") ++ + ".\n" ++ + "type " ++ tname ++ " a = " ++ + "Managed " ++ pparens (inheritName tname ++ " a") ++ "\n" ++ + "-- | Pointer to an (unmanaged) object of type " ++ tname ++ ".\n" ++ + "type " ++ tname ++ "Object" ++ " a = " ++ "Object " ++ pparens (inheritName tname ++ " a")) + else -} + ("-- | 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 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` \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 + = do{ char '\t'; return ()} <|> do{ count 8 space; return () } + "" + +pclassName + = many1 alphaNum + "class name" + +skipToEndOfLine + = do many (noneOf "\n") + char '\n' + +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:" + lines <- readHeaderFile fname + let defs = filter (not . null . fst) (map parseClassDef lines) + 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 p + = do{ psymbol "("; x <- p; psymbol ")"; return x } + +psymbol s + = lexeme (string s) + +reserved s + = lexeme (try (string s)) + +identifier + = lexeme (many1 alphaNum) + +lexeme p + = do{ x <- p + ; whiteSpace + ; return x + } diff --git a/src/CompileClassInfo.hs b/src/CompileClassInfo.hs new file mode 100644 --- /dev/null +++ b/src/CompileClassInfo.hs @@ -0,0 +1,150 @@ +----------------------------------------------------------------------------------------- +{-| 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 + + +{----------------------------------------------------------------------------------------- + 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 wxWindows 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) + writeFile outputFile (unlines (prologue ++ export ++ classDefs ++ downcDefs)) + putStrLn ("generated " ++ show defCount ++ " class info definitions") + putStrLn "ok." + +cmpName s1 s2 + = compare (map toLower (haskellTypeName s1)) (map toLower (haskellTypeName s2)) + +cmpDef def1 def2 + = compare (defName def1) (defName def2) + +exportComma = exportSpaces ++ "," +exportSpaces = " " + + +{----------------------------------------------------------------------------------------- + +-----------------------------------------------------------------------------------------} +toHaskellClassType :: String -> (String,String) +toHaskellClassType className + = (classTypeDeclName + ,"{-# NOINLINE " ++ classTypeDeclName ++ " #-}\n" ++ + classTypeDeclName ++ " :: ClassType (" ++ classTypeName ++ " ())\n" ++ + classTypeDeclName ++ " = ClassType (unsafePerformIO (classInfoFindClass " ++ classTypeString ++ "))\n\n" + ) + where + classTypeDeclName = haskellDeclName ("class" ++ classTypeName) + classTypeName = haskellTypeName className + 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 new file mode 100644 --- /dev/null +++ b/src/CompileClassTypes.hs @@ -0,0 +1,78 @@ +----------------------------------------------------------------------------------------- +{-| 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 ) + +{----------------------------------------------------------------------------------------- + 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 + , " ( -- * Version" + , " classTypesVersion" + , " -- * Classes" ] + , exportsClassClasses + , [ " ) where" + , "" + , "import " ++ moduleRoot ++ "WxcObject" + , "" + , "classTypesVersion :: String" + , "classTypesVersion = \"" ++ show time ++ "\"" + , "" ] + ] + + prologue <- getPrologue moduleName "class" + (show classCount ++ " class definitions.") + inputFiles + let output = unlines (prologue ++ export ++ classDecls) + + putStrLn ("generating: " ++ outputFile) + writeFile 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 (Map.toAscList classMap) + where + exportDef (className,exports) + = [heading 2 className] ++ commaSep exports + + commaSep xs + = map (exportComma++) xs + + heading i name + = exportSpaces ++ "-- " ++ replicate i '*' ++ " " ++ name + + exportComma = exportSpaces ++ "," + exportSpaces = " " + diff --git a/src/CompileClasses.hs b/src/CompileClasses.hs new file mode 100644 --- /dev/null +++ b/src/CompileClasses.hs @@ -0,0 +1,703 @@ +----------------------------------------------------------------------------------------- +{-| 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 marshaling wrapper. +-} +----------------------------------------------------------------------------------------- +module CompileClasses( compileClasses, haskellTypeArg, haskellTypePar ) where + +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified MultiSet + +import Data.Time( getCurrentTime) +import Data.Char( toUpper, isUpper, toLower ) --toLower, toUpper, isSpace, isLower, isUpper ) +import Data.List( isPrefixOf, sort, sortBy, intersperse, zipWith4 ) + +import Types +import HaskellNames +import Classes( isClassName, haskellClassDefs, objectClassNames, ClassInfo(..), classInfo, classIsManaged ) +import ParseC( parseC ) +import DeriveTypes( deriveTypes, classifyName, Name(..), Method(..), ClassName, MethodName, PropertyName ) + +{----------------------------------------------------------------------------------------- + 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 + , " ( -- * Version" + , " version" ++ moduleName + , " -- * Re-export" + , " , module " ++ module1 + , " , module " ++ module2 + , " , module " ++ moduleRoot ++ moduleClassTypesName + , " ) where" + , "" + , "import " ++ module1 + , "import " ++ module2 + , "import " ++ moduleRoot ++ moduleClassTypesName + , "" + , "version" ++ moduleName ++ " :: String" + , "version" ++ moduleName ++ " = \"" ++ show time ++ "\"" + , "" + ] + ] + + (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") + writeFile (outputFile ++ ".hs") output + putStrLn ("generated " ++ show methodCount ++ " total methods for " ++ show classCount ++ " total classes.") + putStrLn ("ok.") + + +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 = [ "{-# INCLUDE \"wxc.h\" #-}" + , "{-# LANGUAGE ForeignFunctionInterface #-}"] + + export = concat [ ["module " ++ moduleRoot ++ moduleName + , " ( -- * Version" + , " version" ++ moduleName + , " -- * Global" ] + , exportsStatic + , [ " -- * 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 " ++ moduleRoot ++ "WxcTypes" + , "import " ++ moduleRoot ++ moduleClassTypesName + , "" + , "version" ++ moduleName ++ " :: String" + , "version" ++ moduleName ++ " = \"" ++ show time ++ "\"" + , "" + ] + ] + + prologue <- getPrologue moduleName "class" + (show methodCount ++ " methods for " ++ show classCount ++ " classes.") + inputFiles + let output = unlines (ghcoptions ++ prologue ++ export {- ++ classDecls -} ++ marshalDecls) + + putStrLn ("generating: " ++ outputFile ++ ".hs") + writeFile (outputFile ++ ".hs") output + putStrLn ("generated " ++ show methodCount ++ " methods for " ++ show classCount ++ " classes.") + return (methodCount,classCount) + + + +cmpDecl decl1 decl2 + = compare (haskellDeclName (declName decl1)) (haskellDeclName (declName decl2)) + + +exportComma = exportSpaces ++ "," +exportSpaces = " " + + +{----------------------------------------------------------------------------------------- + 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 {- ++ commaSep classDecls -} + 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 -> {- (if (null shortExports || elem className ["Events","Misc.","Null"]) + then [] + else [heading 3 "Methods"]) + ++ -} (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 + +{- +properties decls + = unlines + $ map (\(propname,classes) -> propname ++ ": " ++ concat (intersperse ", " classes)) + $ Map.toAscList + $ Map.fromListWith (++) + $ (concatMap property decls) + +property decl + = case (classifyName (declName decl),declArgs decl) of + (Method name (Get propname), [Arg _ (Object objname)]) | objname==name && noclass (declRet decl)-> [(propname ++ "Get", [name])] + (Method name (Set propname), [Arg _ (Object objname),Arg _ tp]) | objname == name && noclass tp -> [(propname ++ "Set", [name])] + other -> [] + where + noclass (Object name) = not (isClassName name || isBuiltin name) + noclass _ = True +-} +{- +properties decls + = unlines + $ map (\(methodname,classes) -> methodname ++ ": " ++ concat (intersperse ", " classes)) + $ filter (\(methodname,classes) -> length classes > 1) + $ Map.toAscList + $ Map.fromListWith (++) + $ (concatMap pmethod decls) + +pmethod decl + = case (classifyName (declName decl)) of + (Method name _) -> [(declName decl, [name])] + other -> [] +-} + +{----------------------------------------------------------------------------------------- + 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 + -- ++ "traceDelete \"" ++ (declName decl) ++ "\" . " + ++ 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 + = "\n " +nlStart + = "\n = " +pparens txt + = "(" ++ txt ++ ")" + +haskellArgs args + = concatMap (\arg -> haskellName (argName arg) ++ " ") args + + +haskellToCResult decl tp call + = unsafeIO $ + case tp of + Fun f -> traceWarning "function as result" decl $ call + EventId -> "withIntResult $" ++ nl ++ call + Id -> "withIntResult $" ++ nl ++ call + Int _ -> "withIntResult $" ++ nl ++ call + Bool -> "withBoolResult $" ++ nl ++ call + Char -> "withCharResult $" ++ nl ++ call + {- + Object obj | isBuiltin obj + -> "withManaged" ++ haskellTypeName obj ++ "Result $" ++ nl ++ call + Object obj | obj == "wxTreeItemId" + -> "with" ++ haskellTypeName obj ++ "Result $" ++ nl ++ call + Object obj + -> "withObjectResult $" ++ 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 -> "withRef" ++ haskellTypeName name ++ " $ \\pref -> " ++ nl ++ call ++ " pref" -- 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 + ArrayString _ -> "withArrayWStringResult $ \\arr -> " ++ nl ++ call ++ " arr" -- always last + ArrayObject name _ -> "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 methodName args + = concatMap (\(isSelf,arg) -> haskellToCArgIO methodName isSelf arg) args + +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 + {- + Object obj | isBuiltin obj + -> "withManaged" ++ haskellTypeName obj ++ " " ++ haskellName (argName arg) + ++ " $ \\" ++ haskellCManagedName (argName arg) ++ " -> " ++ nl + Object obj | obj == "wxTreeItemId" + -> "with" ++ haskellTypeName obj ++ " " ++ haskellName (argName arg) + ++ " $ \\" ++ haskellCManagedName (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 + {- + Object obj -> (if isSelf then "withObjectRef " else "withObjectPtr ") ++ haskellName (argName arg) + ++ " $ \\" ++ haskellCObjectName (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 args + = concatMap (\arg -> haskellToCArg decl arg ++ " ") args + +haskellToCArg decl arg + = case argType arg of + RefObject name -> 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) + Char -> pparens ("toCWchar " ++ name) + Bool -> pparens ("toCBool " ++ name) + Fun f -> pparens ("toCFunPtr " ++ name) + + String _ -> haskellCStringName (argName arg) + ByteString Lazy -> haskellByteStringName name ++ " (fromIntegral $ LB.length " ++ haskellName name ++ ")" + ByteString _ -> haskellByteStringName name ++ " " ++ haskellByteStringLenName name + {- + Object obj | isBuiltin obj -> haskellCManagedName (argName arg) + Object obj | obj == "wxTreeItemId" -> haskellCManagedName (argName arg) + -} + Object obj -> 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 tp _ -> haskellArrayLenName name ++ " " ++ haskellArrayName name + ArrayInt _ -> haskellArrayLenName name ++ " " ++ haskellArrayName name + + other -> name + where + name = haskellName (argName arg) + + +haskellCStringName name + = "cstr_" ++ haskellName name + +haskellByteStringName name + = "bs_" ++ haskellName name + +haskellByteStringLenName name + = "bslen_" ++ haskellName name + +{- +haskellCManagedName name + = "cobject_" ++ haskellName name +-} + +haskellArrayName name + = "carr_" ++ haskellName name + +haskellArrayLenName name + = "carrlen_" ++ haskellName name + +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 args + = concatMap (\(i,arg) -> haskellTypeArg decl i arg ++ " -> ") (zip [1..] args) + + +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 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 i tp + = parenType (haskellType i) tp + +haskellType i tp + = case tp of + Bool -> "Bool" + Int _ -> "Int" + Int64 -> "Int64" + Word -> "Word" + Word8 -> "Word8" + Word32 -> "Word32" + 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]" + ArrayObject name _ -> "[" ++ haskellTypeName name ++ typeVar i ++ "]" + Rect CDouble -> "(Rect2D Double)" + Rect _ -> "Rect" + {- + RefObject "wxColour" -> "Color" + Object "wxColour" -> "Color" + RefObject "wxTreeItemId" -> "TreeItem" + Object "wxTreeItemId" -> "TreeItem" + Object "wxString" -> "String" + -} + 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 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 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 tp + = case tp of + ArrayInt _ -> "Ptr CInt -> 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 "wxColour" -> "ColourPtr () -> IO ()" + RefObject name -> foreignType 0 tp ++ " -> IO ()" + EventId -> "IO CInt" + Id -> "IO CInt" + other -> "IO " ++ foreignTypePar 0 tp + +foreignTypePar i tp + = parenType (foreignType i) tp + +foreignType i tp + = case tp of + Bool -> "CBool" + Int _ -> "CInt" + Int64 -> "Int64" + Word -> "Word" + Word8 -> "Word8" + Word32 -> "Word32" + 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" + {- + RefObject "wxColour" -> "ColourPtr ()" + Object "wxColour" -> "ColourPtr ()" + -} + {- + RefObject name -> "Ptr (T" ++ haskellUnBuiltinTypeName name ++ typeVar i ++ ")" + Object name -> "Ptr (T" ++ haskellUnBuiltinTypeName name ++ typeVar i ++ ")" + -} + RefObject name -> "Ptr (T" ++ haskellTypeName name ++ typeVar i ++ ")" + Object name -> "Ptr (T" ++ haskellTypeName name ++ typeVar i ++ ")" + +parenType f tp + = parenFun tp (f tp) + where + parenFun tp + = case tp of + Ptr _ -> pparens + Object _ -> pparens + RefObject _ -> pparens + other -> id + + +typeVar i = " " ++ typeVars !! i +typeVars = "()" : [[toEnum (fromEnum 'a' + x)] | x <- [0..]] diff --git a/src/CompileDefs.hs b/src/CompileDefs.hs new file mode 100644 --- /dev/null +++ b/src/CompileDefs.hs @@ -0,0 +1,81 @@ +----------------------------------------------------------------------------------------- +{-| Module : CompileDefs + Copyright : (c) Daan Leijen 2003 + License : BSD-style + + Maintainer : wxhaskell-devel@lists.sourceforge.net + Stability : provisional + Portability : portable + + Module that compiles constant definitions to Haskell. +-} +----------------------------------------------------------------------------------------- +module CompileDefs( compileDefs ) where + +import Data.List( sortBy, sort ) + +import Types +import HaskellNames +import ParseEiffel( parseEiffel ) + + +{----------------------------------------------------------------------------------------- + Compile +-----------------------------------------------------------------------------------------} +compileDefs :: Bool -> String -> String -> FilePath -> [FilePath] -> IO () +compileDefs verbose moduleRoot moduleName outputFile inputFiles + = do defss <- mapM parseEiffel inputFiles + let defs = concat defss + (haskellExports,haskellDefs) = unzip (map toHaskellDef defs) + + defCount = length defs + + export = concat [ ["module " ++ moduleRoot ++ moduleName + , " ( -- * Types" + , " BitFlag" + , " -- * Constants" + ] + , map (exportComma++) haskellExports + , [ " ) where" + , "" + , "-- | A flag can be combined with other flags to a bit mask." + , "type BitFlag = Int" + , "" + ] + ] + prologue <- getPrologue moduleName "constant" + (show defCount ++ " constant definitions.") inputFiles + + putStrLn ("generating: " ++ outputFile) + writeFile outputFile (unlines (prologue ++ export ++ haskellDefs)) + putStrLn ("generated " ++ show defCount ++ " constant definitions") + putStrLn "ok." + +cmpDef def1 def2 + = compare (defName def1) (defName def2) + +exportComma = exportSpaces ++ "," +exportSpaces = " " + + +{----------------------------------------------------------------------------------------- + +-----------------------------------------------------------------------------------------} +toHaskellDef :: Def -> (String,String) +toHaskellDef def + = (haskellUnderscoreName (defName def) + ,haskellUnderscoreName (defName def) ++ " :: " ++ haskellDefType def ++ "\n" ++ + haskellUnderscoreName (defName def) ++ " = " ++ haskellDefValue def ++ "\n" + ) + +haskellDefValue def + = showNum (defValue def) + where + showNum x | x >= 0 = show x + | otherwise = "(" ++ show x ++ ")" + + +haskellDefType def + = case defType def of + DefInt -> "Int" + DefMask -> "BitFlag" diff --git a/src/CompileHeader.hs b/src/CompileHeader.hs new file mode 100644 --- /dev/null +++ b/src/CompileHeader.hs @@ -0,0 +1,244 @@ +----------------------------------------------------------------------------------------- +{-| 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 qualified MultiSet + +import Data.Time( getCurrentTime) +import Data.List( isPrefixOf ) +import Data.Char( toUpper, isUpper ) +import Data.List( isPrefixOf, sort, sortBy, intersperse, zipWith4 ) + +import Types +import HaskellNames +import Classes( isClassName, classNames, classExtends ) +import ParseC( parseC ) +import DeriveTypes( deriveTypesAll, classifyName, Name(..), Method(..), ClassName, MethodName, PropertyName ) + +{----------------------------------------------------------------------------------------- + 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) + writeFile outputFile output + putStrLn ("generated " ++ show methodCount ++ " declarations.") + putStrLn ("ok.\n") + + +cmpDecl decl1 decl2 + = compare (haskellDeclName (declName decl1)) (haskellDeclName (declName decl2)) + + +exportComma = exportSpaces ++ "," +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 decls -> decls) + + + toDecls (classname,decls) + = decls + + 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 n s + | length s >= n = s + | otherwise = s ++ replicate (n - length s) ' ' + +cTypeArgs decl [] + = [] +cTypeArgs decl (arg:args) + = cTypeArg decl className arg : map (cTypeArg decl "") args + where + className = case classifyName (declName decl) of + Method cname m -> cname + otherwise -> "" + +cRetType decl tp + = case tp of + -- out + String _ -> "TStringLen" + ArrayString _ -> "TArrayLen" + ArrayObject _ _ -> "TArrayLen" + Vector _ -> "void" + Point _ -> "void" + Size _ -> "void" + Rect _ -> "void" + RefObject name -> "void" + -- typedefs + EventId -> "int" + -- basic + Bool -> "TBool" + Char -> "TChar" + Int CLong -> "long" + Int TimeT -> "time_t" + Int SizeT -> "size_t" + Int other -> "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 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 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 other -> "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 -> traceError ("unknown argument type (" ++ show (argType arg) ++ ")") decl $ + "ctypeSpec" +-} + where + argNameTuple + = "(" ++ concat (intersperse "," (argNames arg)) ++ ")" + + +ctypeSpec deftp ctp + | deftp==ctp = "" + | otherwise = case ctp of + CInt -> "Int" + CLong -> "Long" + CChar -> "Char" + CVoid -> "Void" + other -> "" diff --git a/src/CompileSTC.hs b/src/CompileSTC.hs new file mode 100644 --- /dev/null +++ b/src/CompileSTC.hs @@ -0,0 +1,162 @@ +----------------------------------------------------------------------------------------- +{-| Module : CompileSTC + Copyright : (c) Haste Developper Team 2004, 2005 + License : BSD-style + + Maintainer : wxhaskell-devel@lists.sourceforge.net + Stability : provisional + Portability : portable +-} +----------------------------------------------------------------------------------------- +module CompileSTC ( compileSTC ) where + +import Text.ParserCombinators.Parsec +import qualified Text.ParserCombinators.Parsec.Token as P +import Text.ParserCombinators.Parsec.Language + +import Data.Char +import Data.List +import Control.Monad + +import Types + +compileSTC :: Bool -- ^ Verbose + -> FilePath -- ^ Outputdir + -> [FilePath] -- ^ Input files (stc.h) + -> IO () +compileSTC verbose outputDir inputs = do + dfs <- mapM parseH inputs + let (ds,fs) = unzip dfs + d = concat ds --currently unused + f = concat fs + h_target = outputDir ++ "include/stc_gen.h" + cpp_target = outputDir ++ "src/stc_gen.cpp" + putStrLn $ "generating: " ++ h_target + writeFile h_target $ (glue "\n\n" $ map headerfunc f) ++ "\n" + putStrLn $ "generating: " ++ cpp_target + writeFile cpp_target $ (glue "\n" $ map cppfunc f) ++ "\n" + when verbose $ + putStrLn $ "Wrote type macros and c wrappers for " ++ show (length f) ++ " functions." + +parseH fname = do putStrLn ("parsing: " ++ fname) + input <- liftM lines $ readFile fname + let (defs, cpp) = partitionDefines $ input + case parse plines fname (unlines cpp) of + Left err -> print err >> return ([],[]) + Right funcs -> return (defs,filter convertable funcs) + +-- returns a list of defenitions, see Types.Def +-- and a new list of lines without #define's +partitionDefines :: [String] -> ([Def], [String]) +partitionDefines lns = (defs, cpp) + where (rdefs, cpp) = partition ("#define wxSTC_" `isPrefixOf`) lns + defs = map (toDef . (drop $ length "#define ")) rdefs + toDef x = let (name,value) = break (==' ') x + in Def name (read value) DefInt + +plines = whiteSpace >> many1 pfunc + +pfunc :: Parser (String, String, [(String, String)]) +pfunc = do ret <- identifier + stars <- option "" $ symbol "*" + func <- identifier + args <- parens $ commaSep $ arg + symbol ";" + return (ret ++ stars,func,args) + where arg = do option "" $ try $ symbol "const" + t <- identifier + stars <- option "" $ symbol "*" + option "" $ symbol "&" + name <- identifier + return (t ++ stars, name) + +{----------------------------------------------------------------------------------------- + The lexer +-----------------------------------------------------------------------------------------} + +lexer :: P.TokenParser () +lexer + = P.makeTokenParser $ javaStyle + +whiteSpace = P.whiteSpace lexer +lexeme = P.lexeme lexer +symbol = P.symbol lexer +parens = P.parens lexer +semi = P.semi lexer +comma = P.comma lexer +commaSep = P.commaSep lexer +identifier = P.identifier lexer +reserved = P.reserved lexer + + +{----------------------------------------------------------------------------------------- + code gen +-----------------------------------------------------------------------------------------} + +convertable (t,f,a) = elem t ["int", "bool", "void"] + +glue str strs = concat $ intersperse str strs + +-- CPP function generator (Creates functions that can be exported as C functions) + +cppfunc x = macro x ++ arguments x ++ "\n" ++ body x + +macro (ret, func, args) = "EWXWEXPORT(" ++ ret ++ ", wxStyledTextCtrl_" ++ func ++ ")" + +arguments (ret, func, args) = "(" ++ glue ", " params ++ ")" + where + params = "void* _obj" : rest + rest = map transType args + + transType ("int", n) = "int " ++ n + transType ("bool", n) = "bool " ++ n + transType ("void", n) = "void " ++ n + -- transType ("wxString", n) = "char* " ++ n + transType ("wxString", n) = "wxChar* " ++ n + transType ("wxPoint", n) = glue ", " ["int " ++ n ++ p | p <- ["_x","_y"]] + transType ("wxColour", n) = glue ", " ["int " ++ n ++ c | c <- ["_r","_g","_b"]] + transType (_, n) = "void* " ++ n + +body (ret, func, args) = "{\n" ++ "#ifdef wxUSE_STC\n " + ++ maybeReturn ++ " ((wxStyledTextCtrl*) _obj)->" + ++ func ++ "(" ++ glue ", " params ++ ");\n" + ++ maybeElse ++ "#endif\n}" + where + maybeReturn = if ret == "void" then "" else "return" + maybeElse = if ret == "void" then "" else "#else\n return NULL;\n" + params = map transParam args + transParam ("int", n) = n + transParam ("bool", n) = n + transParam ("void", n) = n + transParam ("wxString", n) = n + transParam ("wxPoint", n) = "wxPoint(" ++ n ++ "_x," ++ n ++ "_y)" + transParam ("wxColour", n) = "wxColour(" ++ n ++ "_r," ++ n ++ "_g," ++ n ++ "_b)" + transParam ("wxSTCDoc*", n) = n + transParam (t, n) = "*(" ++ t ++ "*) " ++ n + +-- Generator for functions signatures with type macros + +headerfunc (ret, func, args) = returnType ret ++ " wxStyledTextCtrl_" ++ func + ++ "(" ++ glue ", " params ++ ");" + where + + returnType "bool" = "TBool" + returnType "int" = "int" + returnType "void" = "void" + returnType _ = error "wtf?" + + params = "TSelf(wxStyledTextCtrl) _obj" : rest + rest = map transType args + + transType ("bool", n) = "TBool " ++ n + transType ("int", n) = "int " ++ n + transType ("int*", n) = "int* " ++ n + transType ("void", n) = "void " ++ n + transType ("char*", n) = "TString " ++ n + -- transType ("wchar_t*", n) = "TString " ++ n + -- transType ("wxChar*", n) = "TString " ++ n + transType ("wxString", n) = "TString " ++ n + transType ("wxPoint", n) = "TPoint(" ++ n ++ "_x," ++ n ++ "_y)" + transType ("wxColour", n) = "TColorRGB(" ++ n ++ "_r," ++ n ++ "_g," ++ n ++ "_b)" + transType (t, n) | "*" `isSuffixOf` t = "TClass(" ++ init t ++ ") " ++ n + | otherwise = "TClass(" ++ t ++ ") " ++ n diff --git a/src/DeriveTypes.hs b/src/DeriveTypes.hs new file mode 100644 --- /dev/null +++ b/src/DeriveTypes.hs @@ -0,0 +1,724 @@ +----------------------------------------------------------------------------------------- +{-| 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( toLower, toUpper, isSpace, isLower, isUpper ) +import Data.List( isPrefixOf, sort, sortBy, intersperse ) + +import Types +import HaskellNames +import Classes( isClassName, haskellClassDefs ) + +{----------------------------------------------------------------------------------------- + The whole type derivation can be tuned with this 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 with 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 + = 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 + = filter Set.empty decls + where + filter set [] = [] + filter set (decl:decls) + = case shouldIgnore decl of + Just msg -> (if showIgnore then traceIgnore msg decl else id) $ filter set decls + other | Set.member (declName decl) set -> traceIgnore "duplicate" decl $ filter set decls + | otherwise -> decl : filter (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 } + -- 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 + 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{ 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 + = 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 + = 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 + other -> decl + + +-- returned properties: assumes that deriveThis has already been done +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 } + 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 } + 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 + other -> decl + + + +-- Simple types: char* => String +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 + = 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 } + other -> decl + where + args = declArgs decl + + +-- derive event ids: int expEVT_XXX() and expXXX_XXX(); +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':name) -> className s + ('c':'b':name) -> className s + (c:cs) | isUpper c -> className s + other -> Name s + where + className 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 new file mode 100644 --- /dev/null +++ b/src/HaskellNames.hs @@ -0,0 +1,190 @@ +----------------------------------------------------------------------------------------- +{-| 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.Time( getCurrentTime) +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 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 name + = haskellName (dropWhile (=='_') name) + +haskellName name + | Set.member suggested reservedVarNames = "wx" ++ suggested + | otherwise = suggested + where + suggested + = case name of + (c:cs) -> toLower c : filter (/='_') cs + [] -> "wx" + +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 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 + other -> firstUpper name + + firstUpper name + = case name of + c:cs | isLower c -> toUpper c : cs + | not (isUpper c) -> "Wx" ++ name + | otherwise -> name + [] -> "Wx" + +haskellUnBuiltinTypeName name + | isBuiltin name = haskellTypeName name ++ "Object" + | otherwise = haskellTypeName name + +isBuiltin name + = Set.member name builtinObjects + +{----------------------------------------------------------------------------------------- + Haddock prologue +-----------------------------------------------------------------------------------------} +getPrologue moduleName content contains inputFiles + = do time <- getCurrentTime + return (prologue time) + where + prologue time + = [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 on: " + , "" + ," * @" ++ show time ++ "@" + ] + ++ + (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/MultiSet.hs b/src/MultiSet.hs new file mode 100644 --- /dev/null +++ b/src/MultiSet.hs @@ -0,0 +1,421 @@ +-------------------------------------------------------------------------------- +{-| Module : MultiSet + Copyright : (c) Daan Leijen 2002 + License : BSD-style + + Maintainer : wxhaskell-devel@lists.sourceforge.net + Stability : provisional + Portability : portable + + An implementation of multi sets on top of the "Map" module. A multi set + differs from a /bag/ in the sense that it is represented as a map from elements + to occurrence counts instead of retaining all elements. This means that equality + on elements should be defined as a /structural/ equality instead of an + equivalence relation. If this is not the case, operations that observe the + elements, like 'filter' and 'fold', should be used with care. +-} +---------------------------------------------------------------------------------} +module MultiSet ( + -- * MultiSet type + MultiSet -- instance Eq,Show + + -- * Operators + , (\\) + + -- *Query + , isEmpty + , size + , distinctSize + , member + , occur + + , subset + , properSubset + + -- * Construction + , empty + , single + , insert + , insertMany + , delete + , deleteAll + + -- * Combine + , union + , difference + , intersection + , unions + + -- * Filter + , filter + , partition + + -- * Fold + , fold + , foldOccur + + -- * Min\/Max + , findMin + , findMax + , deleteMin + , deleteMax + , deleteMinAll + , deleteMaxAll + + -- * Conversion + , elems + + -- ** List + , toList + , fromList + + -- ** Ordered list + , toAscList + , fromAscList + , fromDistinctAscList + + -- ** Occurrence lists + , toOccurList + , toAscOccurList + , fromOccurList + , fromAscOccurList + + -- ** Map + , toMap + , fromMap + , fromOccurMap + + -- * Debugging + , showTree + , showTreeWith + , valid + ) where + +import Prelude hiding (map,filter) +import qualified Prelude (map,filter) + +import qualified Data.Map as M + +{-------------------------------------------------------------------- + Operators +--------------------------------------------------------------------} +infixl 9 \\ + +-- | /O(n+m)/. See 'difference'. +(\\) :: Ord a => MultiSet a -> MultiSet a -> MultiSet a +b1 \\ b2 = difference b1 b2 + +{-------------------------------------------------------------------- + MultiSets are a simple wrapper around Maps, 'Map.Map' +--------------------------------------------------------------------} +-- | A multi set of values @a@. +newtype MultiSet a = MultiSet (M.Map a Int) + +{-------------------------------------------------------------------- + Query +--------------------------------------------------------------------} +-- | /O(1)/. Is the multi set empty? +isEmpty :: MultiSet a -> Bool +isEmpty (MultiSet m) + = M.null m + +-- | /O(1)/. Returns the number of distinct elements in the multi set, ie. (@distinctSize mset == Set.size ('toSet' mset)@). +distinctSize :: MultiSet a -> Int +distinctSize (MultiSet m) + = M.size m + +-- | /O(n)/. The number of elements in the multi set. +size :: MultiSet a -> Int +size b + = foldOccur (\x n m -> n+m) 0 b + +-- | /O(log n)/. Is the element in the multi set? +member :: Ord a => a -> MultiSet a -> Bool +member x m + = (occur x m > 0) + +-- | /O(log n)/. The number of occurrences of an element in the multi set. +occur :: Ord a => a -> MultiSet a -> Int +occur x (MultiSet m) + = case M.lookup x m of + Nothing -> 0 + Just n -> n + +-- | /O(n+m)/. Is this a subset of the multi set? +subset :: Ord a => MultiSet a -> MultiSet a -> Bool +subset (MultiSet m1) (MultiSet m2) + = M.isSubmapOfBy (<=) m1 m2 + +-- | /O(n+m)/. Is this a proper subset? (ie. a subset and not equal) +properSubset :: Ord a => MultiSet a -> MultiSet a -> Bool +properSubset b1 b2 + | distinctSize b1 == distinctSize b2 = (subset b1 b2) && (b1 /= b2) + | distinctSize b1 < distinctSize b2 = (subset b1 b2) + | otherwise = False + +{-------------------------------------------------------------------- + Construction +--------------------------------------------------------------------} +-- | /O(1)/. Create an empty multi set. +empty :: MultiSet a +empty + = MultiSet (M.empty) + +-- | /O(1)/. Create a singleton multi set. +single :: a -> MultiSet a +single x + = MultiSet (M.singleton x 0) + +{-------------------------------------------------------------------- + Insertion, Deletion +--------------------------------------------------------------------} +-- | /O(log n)/. Insert an element in the multi set. +insert :: Ord a => a -> MultiSet a -> MultiSet a +insert x (MultiSet m) + = MultiSet (M.insertWith (+) x 1 m) + +-- | /O(min(n,W))/. The expression (@insertMany x count mset@) +-- inserts @count@ instances of @x@ in the multi set @mset@. +insertMany :: Ord a => a -> Int -> MultiSet a -> MultiSet a +insertMany x count (MultiSet m) + = MultiSet (M.insertWith (+) x count m) + +-- | /O(log n)/. Delete a single element. +delete :: Ord a => a -> MultiSet a -> MultiSet a +delete x (MultiSet m) + = MultiSet (M.updateWithKey f x m) + where + f x n | n > 0 = Just (n-1) + | otherwise = Nothing + +-- | /O(log n)/. Delete all occurrences of an element. +deleteAll :: Ord a => a -> MultiSet a -> MultiSet a +deleteAll x (MultiSet m) + = MultiSet (M.delete x m) + +{-------------------------------------------------------------------- + Combine +--------------------------------------------------------------------} +-- | /O(n+m)/. Union of two multisets. The union adds the elements together. +-- +-- > MultiSet\> union (fromList [1,1,2]) (fromList [1,2,2,3]) +-- > {1,1,1,2,2,2,3} +union :: Ord a => MultiSet a -> MultiSet a -> MultiSet a +union (MultiSet t1) (MultiSet t2) + = MultiSet (M.unionWith (+) t1 t2) + +-- | /O(n+m)/. Intersection of two multisets. +-- +-- > MultiSet\> intersection (fromList [1,1,2]) (fromList [1,2,2,3]) +-- > {1,2} +intersection :: Ord a => MultiSet a -> MultiSet a -> MultiSet a +intersection (MultiSet t1) (MultiSet t2) + = MultiSet (M.intersectionWith min t1 t2) + +-- | /O(n+m)/. Difference between two multisets. +-- +-- > MultiSet\> difference (fromList [1,1,2]) (fromList [1,2,2,3]) +-- > {1} +difference :: Ord a => MultiSet a -> MultiSet a -> MultiSet a +difference (MultiSet t1) (MultiSet t2) + = MultiSet (M.differenceWithKey f t1 t2) + where + f x n m | n-m > 0 = Just (n-m) + | otherwise = Nothing + +-- | The union of a list of multisets. +unions :: Ord a => [MultiSet a] -> MultiSet a +unions multisets + = MultiSet (M.unions [m | MultiSet m <- multisets]) + +{-------------------------------------------------------------------- + Filter and partition +--------------------------------------------------------------------} +-- | /O(n)/. Filter all elements that satisfy some predicate. +filter :: Ord a => (a -> Bool) -> MultiSet a -> MultiSet a +filter p (MultiSet m) + = MultiSet (M.filterWithKey (\x n -> p x) m) + +-- | /O(n)/. Partition the multi set according to some predicate. +partition :: Ord a => (a -> Bool) -> MultiSet a -> (MultiSet a,MultiSet a) +partition p (MultiSet m) + = (MultiSet l,MultiSet r) + where + (l,r) = M.partitionWithKey (\x n -> p x) m + +{-------------------------------------------------------------------- + Fold +--------------------------------------------------------------------} +-- | /O(n)/. Fold over each element in the multi set. +fold :: (a -> b -> b) -> b -> MultiSet a -> b +fold f z (MultiSet m) + = M.foldWithKey apply z m + where + apply x n z | n > 0 = apply x (n-1) (f x z) + | otherwise = z + +-- | /O(n)/. Fold over all occurrences of an element at once. +foldOccur :: (a -> Int -> b -> b) -> b -> MultiSet a -> b +foldOccur f z (MultiSet m) + = M.foldWithKey f z m + +{-------------------------------------------------------------------- + Minimal, Maximal +--------------------------------------------------------------------} +-- | /O(log n)/. The minimal element of a multi set. +findMin :: MultiSet a -> a +findMin (MultiSet m) + = fst (M.findMin m) + +-- | /O(log n)/. The maximal element of a multi set. +findMax :: MultiSet a -> a +findMax (MultiSet m) + = fst (M.findMax m) + +-- | /O(log n)/. Delete the minimal element. +deleteMin :: MultiSet a -> MultiSet a +deleteMin (MultiSet m) + = MultiSet (M.updateMin f m) + where + f n | n > 0 = Just (n-1) + | otherwise = Nothing + +-- | /O(log n)/. Delete the maximal element. +deleteMax :: MultiSet a -> MultiSet a +deleteMax (MultiSet m) + = MultiSet (M.updateMax f m) + where + f n | n > 0 = Just (n-1) + | otherwise = Nothing + +-- | /O(log n)/. Delete all occurrences of the minimal element. +deleteMinAll :: MultiSet a -> MultiSet a +deleteMinAll (MultiSet m) + = MultiSet (M.deleteMin m) + +-- | /O(log n)/. Delete all occurrences of the maximal element. +deleteMaxAll :: MultiSet a -> MultiSet a +deleteMaxAll (MultiSet m) + = MultiSet (M.deleteMax m) + + +{-------------------------------------------------------------------- + List variations +--------------------------------------------------------------------} +-- | /O(n)/. The list of elements. +elems :: MultiSet a -> [a] +elems s + = toList s + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} +-- | /O(n)/. Create a list with all elements. +toList :: MultiSet a -> [a] +toList s + = toAscList s + +-- | /O(n)/. Create an ascending list of all elements. +toAscList :: MultiSet a -> [a] +toAscList (MultiSet m) + = [y | (x,n) <- M.toAscList m, y <- replicate n x] + + +-- | /O(n*log n)/. Create a multi set from a list of elements. +fromList :: Ord a => [a] -> MultiSet a +fromList xs + = MultiSet (M.fromListWith (+) [(x,1) | x <- xs]) + +-- | /O(n)/. Create a multi set from an ascending list in linear time. +fromAscList :: Eq a => [a] -> MultiSet a +fromAscList xs + = MultiSet (M.fromAscListWith (+) [(x,1) | x <- xs]) + +-- | /O(n)/. Create a multi set from an ascending list of distinct elements in linear time. +fromDistinctAscList :: [a] -> MultiSet a +fromDistinctAscList xs + = MultiSet (M.fromDistinctAscList [(x,1) | x <- xs]) + +-- | /O(n)/. Create a list of element\/occurrence pairs. +toOccurList :: MultiSet a -> [(a,Int)] +toOccurList b + = toAscOccurList b + +-- | /O(n)/. Create an ascending list of element\/occurrence pairs. +toAscOccurList :: MultiSet a -> [(a,Int)] +toAscOccurList (MultiSet m) + = M.toAscList m + +-- | /O(n*log n)/. Create a multi set from a list of element\/occurrence pairs. +fromOccurList :: Ord a => [(a,Int)] -> MultiSet a +fromOccurList xs + = MultiSet (M.fromListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs)) + +-- | /O(n)/. Create a multi set from an ascending list of element\/occurrence pairs. +fromAscOccurList :: Ord a => [(a,Int)] -> MultiSet a +fromAscOccurList xs + = MultiSet (M.fromAscListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs)) + +{-------------------------------------------------------------------- + Maps +--------------------------------------------------------------------} +-- | /O(1)/. Convert to a 'Map.Map' from elements to number of occurrences. +toMap :: MultiSet a -> M.Map a Int +toMap (MultiSet m) + = m + +-- | /O(n)/. Convert a 'Map.Map' from elements to occurrences into a multi set. +fromMap :: Ord a => M.Map a Int -> MultiSet a +fromMap m + = MultiSet (M.filter (>0) m) + +-- | /O(1)/. Convert a 'Map.Map' from elements to occurrences into a multi set. +-- Assumes that the 'Map.Map' contains only elements that occur at least once. +fromOccurMap :: M.Map a Int -> MultiSet a +fromOccurMap m + = MultiSet m + +{-------------------------------------------------------------------- + Eq, Ord +--------------------------------------------------------------------} +instance Eq a => Eq (MultiSet a) where + (MultiSet m1) == (MultiSet m2) = (m1==m2) + +{-------------------------------------------------------------------- + Show +--------------------------------------------------------------------} +instance Show a => Show (MultiSet a) where + showsPrec d b = showSet (toAscList b) + +showSet :: Show a => [a] -> ShowS +showSet [] + = showString "{}" +showSet (x:xs) + = showChar '{' . shows x . showTail xs + where + showTail [] = showChar '}' + showTail (x:xs) = showChar ',' . shows x . showTail xs + + +{-------------------------------------------------------------------- + Debugging +--------------------------------------------------------------------} +-- | /O(n)/. Show the tree structure that implements the 'MultiSet'. The tree +-- is shown as a compressed and /hanging/. +showTree :: (Show a) => MultiSet a -> String +showTree mset + = showTreeWith True False mset + +-- | /O(n)/. The expression (@showTreeWith hang wide map@) shows +-- the tree that implements the multi set. The tree is shown /hanging/ when @hang@ is @True@ +-- and otherwise as a /rotated/ tree. When @wide@ is @True@ an extra wide version +-- is shown. +showTreeWith :: Show a => Bool -> Bool -> MultiSet a -> String +showTreeWith hang wide (MultiSet m) + = M.showTreeWith (\x n -> show x ++ " (" ++ show n ++ ")") hang wide m + + +-- | /O(n)/. Is this a valid multi set? +valid :: Ord a => MultiSet a -> Bool +valid (MultiSet m) + = M.valid m && (M.null (M.filter (<=0) m)) diff --git a/src/ParseC.hs b/src/ParseC.hs new file mode 100644 --- /dev/null +++ b/src/ParseC.hs @@ -0,0 +1,295 @@ +----------------------------------------------------------------------------------------- +{-| Module : ParseC + Copyright : (c) Daan Leijen 2003 + License : BSD-style + + Maintainer : wxhaskell-devel@lists.sourceforge.net + Stability : provisional + Portability : portable + + Parse the wxc C header files. +-} +----------------------------------------------------------------------------------------- +module ParseC( parseC, readHeaderFile ) where + +import Data.Char( isSpace ) +import Data.List( isPrefixOf ) +import Text.ParserCombinators.Parsec +import qualified Text.ParserCombinators.Parsec.Token as P +import Text.ParserCombinators.Parsec.Language + +import Types + +{----------------------------------------------------------------------------------------- + Parse C +-----------------------------------------------------------------------------------------} +parseC :: FilePath -> IO [Decl] +parseC fname + = do lines <- readHeaderFile fname + declss <- mapM (parseDecl fname) (pairComments lines) + -- putStrLn ("ok.") + return (concat declss) + +-- flaky but suitable. +readHeaderFile :: FilePath -> IO [String] +readHeaderFile fname + = do putStrLn ("parsing: " ++ fname) + input <- readFile fname + lls <- mapM readIncludeFile (flattenComments (lines input)) + return (concat lls) + where + pathName + = reverse $ dropWhile (\c -> not (elem c "/\\")) $ reverse fname + + readIncludeFile line + | isPrefixOf "#include \"" line + = readHeaderFile (pathName ++ includePath) + where + includePath = takeWhile (/='"') $ tail $ dropWhile (/='"') line + + readIncludeFile line + = return [line] + +-- flaky, but suitable +flattenComments :: [String] -> [String] +flattenComments lines + = case lines of + (('/':'*':xs):xss) -> let (incomment,comment:rest) = span (not . endsComment) lines + in (concat (incomment ++ [comment]) : flattenComments rest) + xs : xss -> xs : flattenComments xss + [] -> [] + where + endsComment line = isPrefixOf "/*" (dropWhile isSpace (reverse line)) + + +pairComments :: [String] -> [(String,String)] +pairComments lines + = case lines of + ('/':'*':'*':xs) : ys : xss | not (classDef ys) -> (reverse (drop 2 (reverse xs)),ys) : pairComments xss + xs : xss | not (classDef xs) -> ("",xs) : pairComments xss + | otherwise -> pairComments xss + [] -> [] + where + classDef xs = isPrefixOf "TClassDef" xs + +parseDecl :: FilePath -> (String,String) -> IO [Decl] +parseDecl fname (comment,line) + = case parse pdecl fname line of + Left err -> do putStrLn ("ignore: parse error : " ++ line) + return [] + Right mbd -> case mbd of + Just d -> return [d{ declComment = comment }] + Nothing -> return [] -- empty line + + +{----------------------------------------------------------------------------------------- + Parse declaration +-----------------------------------------------------------------------------------------} +-- parse a declaration: return Nothing on an empty declaration +pdecl :: Parser (Maybe Decl) +pdecl + = do whiteSpace + x <- (do f <- pfundecl; return (Just f)) <|> return Nothing + eof + return x + +pfundecl :: Parser Decl +pfundecl + = do optional (reserved "EXPORT") + declRet <- ptype + optional (reserved "_stdcall" <|> reserved "__cdecl") + declName <- identifier "function name" + declArgs <- pargs + semi + return (Decl declName declRet declArgs "") + "function declaration" + +pargs :: Parser [Arg] +pargs + = parens (commaSep parg) + "arguments" + +parg :: Parser Arg +parg + = pargTypes + <|> do argType <- ptype + argName <- identifier + return (Arg [argName] argType) + "argument" + +ptype :: Parser Type +ptype + = do tp <- patomtype + stars <- many (symbol "*") + return (foldr (\_ tp -> Ptr tp) tp stars) + "type" + +patomtype :: Parser Type +patomtype + = do reserved "void"; return Void + <|> do reserved "int"; return (Int CInt) + <|> do reserved "char"; return Char + <|> do reserved "long"; return (Int CLong) + <|> do reserved "double"; return Double + <|> do reserved "float"; return Float + <|> do reserved "size_t"; return (Int SizeT) + <|> do reserved "time_t"; return (Int TimeT) + <|> do reserved "TInt64"; return Int64 + <|> do reserved "TUInt"; return Word + <|> do reserved "TUInt8"; return Word8 + <|> do reserved "TUInt32"; return Word32 + <|> do reserved "TBool"; return Bool + <|> do reserved "TBoolInt"; return Bool + <|> do reserved "TChar"; return Char + <|> do reserved "TString"; return (String CChar) + <|> do reserved "TStringVoid"; return (String CVoid) + <|> do reserved "TStringOut"; return (StringOut CChar) + <|> do reserved "TStringOutVoid"; return (StringOut CVoid) + <|> do reserved "TStringLen"; return StringLen + <|> do reserved "TByteData"; return Char + <|> do reserved "TByteStringOut"; return (ByteStringOut Strict) + <|> do reserved "TByteStringLazyOut"; return (ByteStringOut Lazy) + <|> do reserved "TByteStringLen"; return ByteStringLen + <|> do reserved "TArrayLen"; return ArrayLen + <|> do reserved "TArrayStringOut"; return (ArrayStringOut CChar) + <|> do reserved "TArrayStringOutVoid"; return (ArrayStringOut CVoid) + <|> do reserved "TArrayIntOut"; return (ArrayIntOut CInt) + <|> do reserved "TArrayIntOutVoid"; return (ArrayIntOut CVoid) + <|> do reserved "TClosureFun"; return (Fun "Ptr fun -> Ptr state -> Ptr (TEvent evt) -> IO ()") + <|> do reserved "TClass" + name <- parens identifier + return (Object name) + <|> do reserved "TSelf" + name <- parens identifier + return (Object name) + <|> do reserved "TClassRef" + name <- parens identifier + return (RefObject name) + <|> do reserved "TArrayObjectOut" + name <- parens identifier + return (ArrayObjectOut name CObject) + <|> do reserved "TArrayObjectOutVoid" + name <- parens identifier + return (ArrayObjectOut name CVoid) + + +pargTypes :: Parser Arg +pargTypes + = do tp <- pargType2 + argnames <- parens pargs2 + return (Arg argnames tp) + <|> + do tp <- pargType3 + argnames <- parens pargs3 + return (Arg argnames tp) + <|> + do tp <- pargType4 + argnames <- parens pargs4 + return (Arg argnames tp) + <|> + do reserved "TArrayObject" + parens (do n <- identifier + comma + tp <- identifier + comma + p <- identifier + return (Arg [n,p] (ArrayObject tp CVoid))) + +pargs2 + = do a1 <- identifier + comma + a2 <- identifier + return [a1,a2] + +pargs3 + = do a1 <- identifier + comma + a2 <- identifier + comma + a3 <- identifier + return [a1,a2,a3] + +pargs4 + = do a1 <- identifier + comma + a2 <- identifier + comma + a3 <- identifier + comma + a4 <- identifier + return [a1,a2,a3,a4] + + +pargType2 + = do reserved "TPoint"; return (Point CInt) + <|> do reserved "TSize"; return (Size CInt) + <|> do reserved "TVector"; return (Vector CInt) + <|> do reserved "TPointDouble"; return (Point CDouble) + <|> do reserved "TPointLong"; return (Point CLong) + <|> do reserved "TSizeDouble"; return (Size CDouble) + <|> do reserved "TVectorDouble"; return (Vector CDouble) + <|> do reserved "TPointOut"; return (PointOut CInt) + <|> do reserved "TSizeOut"; return (SizeOut CInt) + <|> do reserved "TVectorOut"; return (VectorOut CInt) + <|> do reserved "TPointOutDouble"; return (PointOut CDouble) + <|> do reserved "TPointOutVoid"; return (PointOut CVoid) + <|> do reserved "TSizeOutDouble"; return (SizeOut CDouble) + <|> do reserved "TSizeOutVoid"; return (SizeOut CVoid) + <|> do reserved "TVectorOutDouble"; return (VectorOut CDouble) + <|> do reserved "TVectorOutVoid"; return (VectorOut CVoid) + <|> do reserved "TArrayString"; return (ArrayString CChar) + <|> do reserved "TArrayInt"; return (ArrayInt CInt) + <|> do reserved "TByteString"; return (ByteString Strict) + <|> do reserved "TByteStringLazy"; return (ByteString Lazy) + +pargType3 + = do reserved "TColorRGB"; return (ColorRGB CChar) + +pargType4 + = do reserved "TRect"; return (Rect CInt) + <|> do reserved "TRectDouble"; return (Rect CDouble) + <|> do reserved "TRectOut"; return (RectOut CInt) + <|> do reserved "TRectOutDouble"; return (RectOut CDouble) + <|> do reserved "TRectOutVoid"; return (RectOut CVoid) + + +{----------------------------------------------------------------------------------------- + The lexer +-----------------------------------------------------------------------------------------} +lexer :: P.TokenParser () +lexer + = P.makeTokenParser $ + emptyDef + { commentStart = "/*" + , commentEnd = "*/" + , commentLine = "#" -- ignore pre-processor stuff, but fail to recognise "//" + , nestedComments = False + , identStart = letter <|> char '_' + , identLetter = alphaNum <|> oneOf "_'" + , caseSensitive = True + , reservedNames = ["void","int","long","float","double","char","size_t","time_t","_stdcall","__cdecl" + ,"TChar","TBool" + ,"TClass","TSelf","TClassRef" + ,"TByteData","TByteString","TByteStringOut","TByteStringLen" + ,"TString","TStringOut","TStringLen", "TStringVoid" + ,"TPoint","TSize","TVector","TRect" + ,"TPointOut","TSizeOut","TVectorOut","TRectOut" + ,"TPointOutVoid","TSizeOutVoid","TVectorOutVoid","TRectOutVoid" + ,"TClosureFun" + ,"TPointDouble", "TPointLong", "TSizeDouble", "TVectorDouble", "TRectDouble" + ,"TPointOutDouble", "TSizeOutDouble", "TVectorOutDouble", "TRectOutDouble" + ,"TArrayLen","TArrayStringOut","TArrayStringOutVoid","TArrayObjectOut","TArrayObjectOutVoid" + ,"TColorRGB" + ,"EXPORT" + ] + } + +whiteSpace = P.whiteSpace lexer +lexeme = P.lexeme lexer +symbol = P.symbol lexer +parens = P.parens lexer +semi = P.semi lexer +comma = P.comma lexer +commaSep = P.commaSep lexer +identifier = P.identifier lexer +reserved = P.reserved lexer diff --git a/src/ParseEiffel.hs b/src/ParseEiffel.hs new file mode 100644 --- /dev/null +++ b/src/ParseEiffel.hs @@ -0,0 +1,155 @@ +----------------------------------------------------------------------------------------- +{-| Module : ParseEiffel + Copyright : (c) Daan Leijen 2003 + License : BSD-style + + Maintainer : wxhaskell-devel@lists.sourceforge.net + Stability : provisional + Portability : portable + + Parse the wxc Eiffel definition file. +-} +----------------------------------------------------------------------------------------- +module ParseEiffel( parseEiffel ) where + +import Data.Char( digitToInt ) +import Text.ParserCombinators.Parsec +import qualified Text.ParserCombinators.Parsec.Token as P +import Text.ParserCombinators.Parsec.Language + +import Types + +import System.Environment ( getEnv ) + +{----------------------------------------------------------------------------------------- + Testing +-----------------------------------------------------------------------------------------} +test + = do files <- getDefaultEiffelFiles + defss <- mapM parseEiffel files + let defs = concat defss + haskellDefs = map show defs + writeFile "../../wxh/Graphics/UI/WXH/WxcDefs.hs" (unlines haskellDefs) + +getDefaultEiffelFiles :: IO [FilePath] +getDefaultEiffelFiles + = do wxwin <- getEnv "WXWIN" `catch` \err -> return "" + return [wxwin ++ "/wxc/include/wxc_defs.e" + ,wxwin ++ "/wxc/ewxw/eiffel/spec/r_2_4/wx_defs.e"] + +{----------------------------------------------------------------------------------------- + Parse Eiffel +-----------------------------------------------------------------------------------------} +parseEiffel :: FilePath -> IO [Def] +parseEiffel fname + = do putStrLn ("parsing: " ++ fname) + input <- readFile fname + defss <- mapM (parseDef fname) (lines input) + -- putStrLn ("ok.") + return (concat defss) + +parseDef :: FilePath -> String -> IO [Def] +parseDef fname line + = case parse pdef fname line of + Left err -> do putStrLn ("ignore: parse error : " ++ line) + return [] + Right mbd -> case mbd of + Just d -> return [d] + Nothing -> return [] -- empty line + + +{----------------------------------------------------------------------------------------- + Parse a constant definition +-----------------------------------------------------------------------------------------} +-- parse a definition: return Nothing on an empty definition +pdef :: Parser (Maybe Def) +pdef + = do whiteSpace + x <- option Nothing (pconstDef <|> pignore) + eof + return x + +pconstDef :: Parser (Maybe Def) +pconstDef + = do name <- identifier + symbol ":" + tp <- pdefType + reserved "is" + (do x <- pdefValue + return (Just (Def name x tp)) + <|> + return Nothing) -- external definition + "constant definition" + + +pignore + = do{ reserved "external"; stringLiteral; return Nothing } + <|> do{ reserved "alias"; stringLiteral; return Nothing } + <|> do{ reserved "end"; return Nothing } + <|> do{ reserved "class"; identifier; return Nothing } + <|> do{ reserved "feature"; symbol "{"; reserved "NONE"; symbol "}"; return Nothing } + "" + + +pdefType :: Parser DefType +pdefType + = do reserved "BIT" + bits <- natural + return DefMask + <|> do reserved "INTEGER" + return DefInt + "integer type" + +pdefValue :: Parser Int +pdefValue + = lexeme $ + do sign <- option id (do{ symbol "-"; return negate }) + ds <- many1 digit + base <- option 10 (do{char 'B'; return 2}) + return (sign (convertNum base ds)) + where + convertNum :: Int -> String -> Int + convertNum base digits + = foldl convert 0 digits + where + convert x c = base*x + digitToInt c + + +{----------------------------------------------------------------------------------------- + The lexer +-----------------------------------------------------------------------------------------} +lexer :: P.TokenParser () +lexer + = P.makeTokenParser $ + emptyDef + { commentStart = "/*" + , commentEnd = "*/" + , commentLine = "--" -- ignore pre-processor stuff, but fail to recognise "//" + , nestedComments = True + , identStart = letter <|> char '_' + , identLetter = alphaNum <|> oneOf "_'" + , caseSensitive = True + , reservedNames = ["is","feature","class","end","NONE","BIT","INTEGER","external","alias"] + } + +whiteSpace = P.whiteSpace lexer +lexeme = P.lexeme lexer +symbol = P.symbol lexer +parens = P.parens lexer +semi = P.semi lexer +comma = P.comma lexer +commaSep = P.commaSep lexer +identifier = P.identifier lexer +natural = P.natural lexer +reserved = P.reserved lexer + +stringLiteral + = lexeme $ + do char '"' + many stringChar + char '"' + return () + +stringChar + = noneOf "\"%\n\v" + <|> do{ char '%'; anyChar } diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,128 @@ +----------------------------------------------------------------------------------------- +{-| 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 s x + = seq (unsafePerformIO (putStrLn s)) x + +traceIgnore msg decl x + = trace ("ignore: " ++ fill 12 msg ++ ": " ++ declName decl) x + where + fill n s | length s >= 12 = s + | otherwise = s ++ replicate (12 - length s) ' ' + +traceWarning msg decl x + = trace ("****************************************************\n" ++ + "warning : " ++ msg ++ ": " ++ declName decl) x + +traceError msg decl x + = trace ("****************************************************\n" ++ + "error : " ++ msg ++ ": " ++ declName decl) x + + +errorMsg str + = error ("error: " ++ str) + +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 + | Int64 + | Word + | Word8 + | Word32 + | 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 + | ArrayObjectOut String CBaseType + -- derived types + | Object String + | String CBaseType + | ArrayInt 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,5 +1,5 @@ name: wxdirect -version: 0.11.1.3 +version: 0.11.1.4 license: BSD3 license-file: LICENSE author: Daan Leijen @@ -35,6 +35,20 @@ executable wxdirect main-is: Main.hs + + other-modules: Classes + , CompileClasses + , CompileClassInfo + , CompileClassTypes + , CompileDefs + , CompileHeader + , CompileSTC + , DeriveTypes + , HaskellNames + , MultiSet + , ParseC + , ParseEiffel + , Types hs-source-dirs: src