diff --git a/src/Classes.hs b/src/Classes.hs --- a/src/Classes.hs +++ b/src/Classes.hs @@ -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 [] diff --git a/src/CompileClassInfo.hs b/src/CompileClassInfo.hs --- a/src/CompileClassInfo.hs +++ b/src/CompileClassInfo.hs @@ -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." diff --git a/src/CompileClassTypes.hs b/src/CompileClassTypes.hs --- a/src/CompileClassTypes.hs +++ b/src/CompileClassTypes.hs @@ -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.") diff --git a/src/CompileClasses.hs b/src/CompileClasses.hs --- a/src/CompileClasses.hs +++ b/src/CompileClasses.hs @@ -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 ++ ")" diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/MultiSet.hs b/src/MultiSet.hs --- a/src/MultiSet.hs +++ b/src/MultiSet.hs @@ -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 diff --git a/src/ParseC.hs b/src/ParseC.hs --- a/src/ParseC.hs +++ b/src/ParseC.hs @@ -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 }] diff --git a/wxdirect.cabal b/wxdirect.cabal --- a/wxdirect.cabal +++ b/wxdirect.cabal @@ -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: