wxdirect 0.12.1.4 → 0.13.1
raw patch · 8 files changed
+40/−144 lines, 8 filesdep +directorydep +strict
Dependencies added: directory, strict
Files
- src/Classes.hs +13/−28
- src/CompileClassInfo.hs +3/−3
- src/CompileClassTypes.hs +2/−1
- src/CompileClasses.hs +14/−103
- src/Main.hs +1/−4
- src/MultiSet.hs +2/−2
- src/ParseC.hs +1/−1
- wxdirect.cabal +4/−2
src/Classes.hs view
@@ -23,10 +23,12 @@ ) where import System.Environment ( getEnv )+import Control.Exception ( catch, SomeException(..) ) import Data.Char( isUpper ) import Data.List( sort, sortBy ) import qualified Data.Set as Set import qualified Data.Map as Map+import Prelude hiding ( catch ) import HaskellNames( haskellTypeName, isBuiltin ) import Types @@ -65,24 +67,17 @@ classes :: [Class] classes = unsafePerformIO $- do {-- xs <- parseClassHierarchy "ClassHierarchy.txt"- ys <- parseClassHierarchy "ClassHierarchyExtra.txt"- -}+ do -- 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@@ -214,8 +209,7 @@ objectClassNames :: [String] objectClassNames = case filter isObject classes of- [classObject] -> -- filter (/="wxColour") $ - flatten classObject+ [classObject] -> flatten classObject other -> [] where flatten (Class name derived)@@ -258,22 +252,13 @@ 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" +++ = ( (tname,[tname,inheritName tname,className tname])+ , (+ ("-- | Pointer to an object of type '" ++ tname ++ "'" +++ (if null parents then "" else ", derived from '" ++ head parents ++ "'") +++ ".\n" +++ "type " ++ tname ++ " a = " ++ inheritance)+ ) ++ "\n" ++ "-- | Inheritance type of the " ++ tname ++ " class.\n" ++ "type " ++ inheritName tname ++ " a = " ++ inheritanceType ++ "\n" ++ "-- | Abstract type of the " ++ tname ++ " class.\n" ++@@ -317,7 +302,7 @@ Left err -> do putStrLn ("parse error in class hierarchy: " ++ show err) return [] Right cs -> return cs- `catch` \err ->+ `catch` \(SomeException err) -> do putStrLn ("exception while parsing: " ++ fname) print err return []
src/CompileClassInfo.hs view
@@ -18,6 +18,7 @@ import Types import HaskellNames import Classes+import IOExtra {-----------------------------------------------------------------------------------------@@ -102,11 +103,10 @@ , "" ] ]- prologue <- getPrologue moduleName "class info"- (show defCount ++ " class info definitions.") []+ prologue <- getPrologue moduleName "class info" (show defCount ++ " class info definitions.") [] putStrLn ("generating: " ++ outputFile)- writeFile outputFile (unlines (prologue ++ export ++ classDefs ++ downcDefs))+ writeFileLazy outputFile (unlines (prologue ++ export ++ classDefs ++ downcDefs)) putStrLn ("generated " ++ show defCount ++ " class info definitions") putStrLn "ok."
src/CompileClassTypes.hs view
@@ -19,6 +19,7 @@ import HaskellNames import Classes( isClassName, haskellClassDefs ) import DeriveTypes( ClassName )+import IOExtra {----------------------------------------------------------------------------------------- Compile@@ -51,7 +52,7 @@ let output = unlines (prologue ++ export ++ classDecls) putStrLn ("generating: " ++ outputFile)- writeFile outputFile output+ writeFileLazy outputFile output putStrLn ("generated " ++ show classCount ++ " class definitions.") putStrLn ("ok.")
src/CompileClasses.hs view
@@ -19,13 +19,14 @@ import Data.Time( getCurrentTime) import Data.Char( toUpper, isUpper, toLower ) --toLower, toUpper, isSpace, isLower, isUpper )-import Data.List( isPrefixOf, sort, sortBy, intersperse, zipWith4 )+import Data.List( isPrefixOf, sort, sortBy, intersperse, zipWith4, elemIndex ) import Types import HaskellNames import Classes( isClassName, haskellClassDefs, objectClassNames, ClassInfo(..), classInfo, classIsManaged ) import ParseC( parseC ) import DeriveTypes( deriveTypes, classifyName, Name(..), Method(..), ClassName, MethodName, PropertyName )+import IOExtra {----------------------------------------------------------------------------------------- Compile@@ -45,10 +46,8 @@ module2 = moduleRoot ++ moduleName ++ postfix2 export = concat [ ["module " ++ moduleRoot ++ moduleName- , " ( -- * Version"- , " version" ++ moduleName- , " -- * Re-export" - , " , module " ++ module1+ , " ( -- * Re-export" + , " module " ++ module1 , " , module " ++ module2 , " , module " ++ moduleRoot ++ moduleClassTypesName , " ) where"@@ -57,9 +56,6 @@ , "import " ++ module2 , "import " ++ moduleRoot ++ moduleClassTypesName , ""- , "version" ++ moduleName ++ " :: String"- , "version" ++ moduleName ++ " = \"" ++ show time ++ "\""- , "" ] ] @@ -76,7 +72,7 @@ let output = unlines (prologue ++ export) putStrLn ("generating: " ++ outputFile ++ ".hs")- writeFile (outputFile ++ ".hs") output+ writeFileLazy (outputFile ++ ".hs") output putStrLn ("generated " ++ show methodCount ++ " total methods for " ++ show classCount ++ " total classes.") putStrLn ("ok.") @@ -93,14 +89,11 @@ (exportsStatic,exportsClassClasses,classCount) = exportDefs decls exportsClass [] methodCount = length decls- ghcoptions = [ "{-# INCLUDE \"wxc.h\" #-}"- , "{-# LANGUAGE ForeignFunctionInterface #-}"]+ ghcoptions = [ "{-# LANGUAGE ForeignFunctionInterface #-}"] export = concat [ ["module " ++ moduleRoot ++ moduleName- , " ( -- * Version"- , " version" ++ moduleName- , " -- * Global" ]- , exportsStatic+ , " ( -- * Global" ]+ , (let es1 : es2 : estail = exportsStatic in es1 : dropFirstComma es2 : estail) , [ " -- * Classes" ] , exportsClassClasses , [ " ) where"@@ -111,19 +104,16 @@ , "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)+ let output = unlines (ghcoptions ++ prologue ++ export ++ marshalDecls) putStrLn ("generating: " ++ outputFile ++ ".hs")- writeFile (outputFile ++ ".hs") output+ writeFileLazy (outputFile ++ ".hs") output putStrLn ("generated " ++ show methodCount ++ " methods for " ++ show classCount ++ " classes.") return (methodCount,classCount) @@ -136,6 +126,8 @@ exportComma = exportSpaces ++ "," exportSpaces = " " +dropFirstComma str = maybe str replaceNthWithSpace (elemIndex ',' str)+ where replaceNthWithSpace n = let (front,back) = splitAt n str in front ++ " " ++ tail back {----------------------------------------------------------------------------------------- Create export definitions@@ -166,7 +158,7 @@ where addMethods methodMap shortMap className classDecls | null decls = []- | otherwise = [heading 2 className] ++ decls {- ++ commaSep classDecls -} + | otherwise = [heading 2 className] ++ decls where decls = (case Map.lookup className shortMap of@@ -174,10 +166,7 @@ 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))+ Just decls -> (commaSep decls)) todef (classname,decls)@@ -198,38 +187,6 @@ 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) -----------------------------------------------------------------------------------------}@@ -318,7 +275,6 @@ 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"))@@ -353,14 +309,6 @@ 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!@@ -404,14 +352,6 @@ 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)@@ -424,10 +364,6 @@ -> "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)@@ -450,10 +386,6 @@ 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)@@ -487,11 +419,6 @@ haskellByteStringLenName name = "bslen_" ++ haskellName name -{--haskellCManagedName name- = "cobject_" ++ haskellName name--}- haskellArrayName name = "carr_" ++ haskellName name @@ -584,13 +511,6 @@ 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@@ -637,7 +557,6 @@ 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"@@ -677,14 +596,6 @@ 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 ++ ")"
src/Main.hs view
@@ -91,10 +91,7 @@ getDefaultHeaderFiles :: IO [FilePath] getDefaultHeaderFiles = do wxcdir <- getWxcDir- return [wxcdir ++ "/include/wxc.h"- -- , wxcdir ++ "/ewxw/eiffel/ewxw_glue.h"- -- , wxcdir ++ "/ewxw/eiffel/wxc_glue.h"- ]+ return [wxcdir ++ "/include/wxc.h"] getDefaultSTCHeaderFile :: IO [FilePath] getDefaultSTCHeaderFile
src/MultiSet.hs view
@@ -249,7 +249,7 @@ -- | /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+ = M.foldrWithKey apply z m where apply x n z | n > 0 = apply x (n-1) (f x z) | otherwise = z@@ -257,7 +257,7 @@ -- | /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+ = M.foldrWithKey f z m {-------------------------------------------------------------------- Minimal, Maximal
src/ParseC.hs view
@@ -75,7 +75,7 @@ parseDecl :: FilePath -> (String,String) -> IO [Decl] parseDecl fname (comment,line) = case parse pdecl fname line of- Left err -> do putStrLn ("ignore: parse error : " ++ line)+ Left err -> do putStrLn ("ignore: parse error : " ++ show err ++ ", on : " ++ line) return [] Right mbd -> case mbd of Just d -> return [d{ declComment = comment }]
wxdirect.cabal view
@@ -1,5 +1,5 @@ name: wxdirect-version: 0.12.1.4+version: 0.13.1 license: BSD3 license-file: LICENSE author: Daan Leijen@@ -60,7 +60,9 @@ build-depends: parsec >= 2.1.0 && < 4,- time >= 1.0 && < 1.3+ time >= 1.0 && < 1.3,+ strict >= 0.3 && < 1.0,+ directory >= 1.0 && < 2.0 if flag(splitBase) build-depends: