wxdirect 0.11.1.3 → 0.11.1.4
raw patch · 14 files changed
+3792/−1 lines, 14 filesnew-uploaderPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- src/Classes.hs +446/−0
- src/CompileClassInfo.hs +150/−0
- src/CompileClassTypes.hs +78/−0
- src/CompileClasses.hs +703/−0
- src/CompileDefs.hs +81/−0
- src/CompileHeader.hs +244/−0
- src/CompileSTC.hs +162/−0
- src/DeriveTypes.hs +724/−0
- src/HaskellNames.hs +190/−0
- src/MultiSet.hs +421/−0
- src/ParseC.hs +295/−0
- src/ParseEiffel.hs +155/−0
- src/Types.hs +128/−0
- wxdirect.cabal +15/−1
+ src/Classes.hs view
@@ -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+ }
+ src/CompileClassInfo.hs view
@@ -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)
+ src/CompileClassTypes.hs view
@@ -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 = " "+
+ src/CompileClasses.hs view
@@ -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..]]
+ src/CompileDefs.hs view
@@ -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"
+ src/CompileHeader.hs view
@@ -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 -> ""
+ src/CompileSTC.hs view
@@ -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
+ src/DeriveTypes.hs view
@@ -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
+ src/HaskellNames.hs view
@@ -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]
+ src/MultiSet.hs view
@@ -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))
+ src/ParseC.hs view
@@ -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
+ src/ParseEiffel.hs view
@@ -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 }
+ src/Types.hs view
@@ -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)
wxdirect.cabal view
@@ -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