wxdirect 0.90.0.1 → 0.90.1.0
raw patch · 14 files changed
+774/−976 lines, 14 filesdep +filepathdep +processdep ~basedep ~containersnew-uploader
Dependencies added: filepath, process
Dependency ranges changed: base, containers
Files
- src/Classes.hs +70/−42
- src/CompileClassInfo.hs +24/−14
- src/CompileClassTypes.hs +7/−7
- src/CompileClasses.hs +237/−164
- src/CompileHeader.hs +87/−76
- src/CompileSTC.hs +56/−28
- src/DeriveTypes.hs +108/−97
- src/HaskellNames.hs +14/−7
- src/IOExtra.hs +2/−4
- src/Main.hs +66/−52
- src/MultiSet.hs +0/−421
- src/ParseC.hs +84/−46
- src/Types.hs +13/−2
- wxdirect.cabal +6/−16
src/Classes.hs view
@@ -7,7 +7,7 @@ Stability : provisional Portability : portable - Defines most of the classes in wxWindows.+ Defines most of the classes in wxWidgets. -} ----------------------------------------------------------------------------------------- module Classes( isClassName, isBuiltin, haskellClassDefs@@ -22,13 +22,9 @@ , managedClasses ) 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 Text.Parsec.Prim hiding ( try ) import HaskellNames( haskellTypeName, isBuiltin ) import Types @@ -60,24 +56,28 @@ {----------------------------------------------------------------------------------------- -----------------------------------------------------------------------------------------}+{- ignoreClasses :: Set.Set String ignoreClasses = Set.fromList ["wxFile", "wxDir", "wxString", "wxManagedPtr"]+-} classes :: [Class] classes = unsafePerformIO $ do -- urk, ugly hack.- wxcdir <- getWxcDir- cs <- parseClassDefs (wxcdir ++ "/include/wxc.h")+ wxcdir' <- getWxcDir+ cs <- parseClassDefs (wxcdir' ++ "/include/wxc.h") return cs +mergeClasses :: [Class] -> [Class] -> [Class] mergeClasses xs ys = foldr (\c cs -> mergeClass c cs) xs ys +mergeClass :: Class -> [Class] -> [Class] mergeClass cls [] = [cls] mergeClass cls1@(Class name1 subs1) (cls2@(Class name2 subs2) : cs) | name1 == name2 = Class name2 (mergeClasses subs1 subs2) : cs@@ -99,8 +99,8 @@ classIsManaged :: String -> Bool classIsManaged name = case findManaged name of- Just info -> True- Nothing -> False+ Just _ -> True+ Nothing -> False classInfo :: String -> ClassInfo classInfo name@@ -194,15 +194,21 @@ deriving Eq instance Show Class where- showsPrec d c+ showsPrec _ c = showString (showClass 0 c) ++{-+showClasses :: [Class] -> String showClasses cs = unlines (map (showClass 0) cs)+-} +showClass :: Int -> Class -> [Char] showClass indent (Class name subs) = (replicate indent '\t' ++ name ++ concatMap ("\n"++) (map (showClass (indent+1)) subs)) +isClassName :: String -> Bool isClassName s = Set.member s classNames @@ -210,12 +216,12 @@ objectClassNames = case filter isObject classes of [classObject] -> flatten classObject- other -> []+ _ -> [] where flatten (Class name derived) = name : concatMap flatten derived - isObject (Class name derived)+ isObject (Class name _derived) = (name == "wxObject") @@ -234,6 +240,7 @@ = Map.insert name parent (Map.unions (map (flatten name) derived)) +{- sortClasses :: [Class] -> [Class] sortClasses cs = map sortExtends (sortBy cmp cs)@@ -242,13 +249,14 @@ sortExtends (Class name extends) = Class name (sortClasses extends)-+-} haskellClassDefs :: ([(String,[String])],[String]) -- exported, definitions haskellClassDefs = unzip (concatMap (haskellClass []) classes) +haskellClass :: [[Char]] -> Class -> [(([Char], [[Char]]), [Char])] haskellClass parents (Class name derived) -- | isBuiltin name = [] -- handled as a basic type -- | otherwise@@ -270,12 +278,13 @@ 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")@@ -285,6 +294,7 @@ ++ pparens (className tname ++ " a") +pparens :: [Char] -> [Char] pparens txt = "(" ++ txt ++ ")" @@ -295,6 +305,7 @@ 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)@@ -321,51 +332,62 @@ pclass :: Int -> Parser [Class] pclass indent- = do try (count indent pindent)+ = do _ <- try (count indent pindent) name <- pclassName- whiteSpace+ _ <- whiteSpace mkClass- <- (do char '\n'+ <- (do _ <- char '\n' return (\subs -> filterClass (Class name subs)) <|> do name2 <- try $- do char '='- whiteSpace+ do _ <- char '='+ _ <- whiteSpace name2 <- pclassName- whiteSpace- char '\n'+ _ <- whiteSpace+ _ <- char '\n' return name2 return (\subs -> filterClass (Class name2 subs)) <|>- do skipToEndOfLine- return (\subs -> []))+ do _ <- skipToEndOfLine+ return (\_subs -> [])) subs <- pclasses (indent+1) return (mkClass subs) <|>- do char '\n'+ do _ <- char '\n' return [] <?> "class"-+-} +{- filterClass :: Class -> [Class] filterClass (Class name subs) | not (Set.member name ignoreClasses) = [Class name subs] filterClass cls = []-+-} +{-+pindent :: Parser () pindent- = do{ char '\t'; return ()} <|> do{ count 8 space; return () }+ = (char '\t' >> return ()) <|> + (count 8 space >> return ()) <?> ""+-} +{-+pclassName :: Parser [Char] pclassName = many1 alphaNum <?> "class name"-+-}+{-+skipToEndOfLine :: Parser Char skipToEndOfLine- = do many (noneOf "\n")+ = do _ <- many (noneOf "\n") char '\n'+-} +whiteSpace :: Parser [Char] whiteSpace = many (oneOf " \t") @@ -377,13 +399,13 @@ parseClassDefs :: FilePath -> IO [Class] parseClassDefs fname = do putStrLn "reading class definitions:"- lines <- readHeaderFile fname- let defs = filter (not . null . fst) (map parseClassDef lines)+ contents <- readHeaderFile fname+ let defs = filter (not . null . fst) (map parseClassDef contents) extends = Map.fromList defs extend name = complete (Class name []) where- complete cls@(Class cname ext)+ complete cls@(Class cname _ext) = case Map.lookup cname extends of Just "" -> cls Just parent -> complete (Class parent [cls])@@ -395,37 +417,43 @@ parseClassDef :: String -> (String,String) parseClassDef line = case parse pdef "" line of- Left err -> ("","")+ Left _err -> ("","") Right r -> r pdef :: Parser (String,String) pdef- = do reserved "TClassDefExtend"- psymbol "("- tp <- identifier- psymbol ","+ = do _ <- reserved "TClassDefExtend"+ _ <- psymbol "("+ tp <- identifier+ _ <- psymbol "," ext <- identifier- psymbol ")"+ _ <- psymbol ")" return (tp,ext) <|>- do reserved "TClassDef"+ do _ <- reserved "TClassDef" tp <- parens identifier return (tp,"") ++parens :: Parser b -> Parser b parens p- = do{ psymbol "("; x <- p; psymbol ")"; return x }+ = do { _ <- psymbol "("; x <- p; _ <- psymbol ")"; return x } +psymbol :: String -> Parser String psymbol s = lexeme (string s) +reserved :: String -> Parser String reserved s = lexeme (try (string s)) +identifier :: Parser String identifier = lexeme (many1 alphaNum) +lexeme :: Parser b -> Parser b lexeme p = do{ x <- p- ; whiteSpace+ ; _ <- whiteSpace ; return x }
src/CompileClassInfo.hs view
@@ -13,9 +13,9 @@ module CompileClassInfo( compileClassInfo ) where import Data.Char( toLower )-import Data.List( sortBy, sort )+import Data.List( sortBy {-, sort-} ) -import Types+-- import Types import HaskellNames import Classes import IOExtra@@ -25,12 +25,12 @@ 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)+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+ defCount = length classNames' export = concat [ ["module " ++ moduleRoot ++ moduleName , " ( -- * Class Info"@@ -65,7 +65,7 @@ , " 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)." + , "-- | Test if an object is of a certain kind, based on a full wxWidgets class name. (Use with care)." , "{-# NOINLINE instanceOfName #-}" , "instanceOfName :: WxObject a -> String -> Bool" , "instanceOfName obj className "@@ -111,13 +111,20 @@ putStrLn ("generated " ++ show defCount ++ " class info definitions") putStrLn "ok." +cmpName :: String -> String -> Ordering cmpName s1 s2 = compare (map toLower (haskellTypeName s1)) (map toLower (haskellTypeName s2)) +{-+cmpDef :: Def -> Def -> Ordering cmpDef def1 def2 = compare (defName def1) (defName def2)+-} +exportComma :: String exportComma = exportSpaces ++ ","++exportSpaces :: String exportSpaces = " " @@ -128,12 +135,15 @@ toHaskellClassType className = (classTypeDeclName ,"{-# NOINLINE " ++ classTypeDeclName ++ " #-}\n" ++- classTypeDeclName ++ " :: ClassType (" ++ classTypeName ++ " ())\n" +++ classTypeDeclName ++ " :: ClassType (" ++ classTypeName' ++ " ())\n" ++ classTypeDeclName ++ " = ClassType (unsafePerformIO (classInfoFindClass " ++ classTypeString ++ "))\n\n" ) where- classTypeDeclName = haskellDeclName ("class" ++ classTypeName)- classTypeName = haskellTypeName className+ classTypeDeclName :: String+ classTypeDeclName = haskellDeclName ("class" ++ classTypeName')+ classTypeName' :: String+ classTypeName' = haskellTypeName className+ classTypeString :: String classTypeString = "\"" ++ className ++ "\"" @@ -143,9 +153,9 @@ toHaskellDowncast :: String -> (String,String) toHaskellDowncast className = (downcastName- ,downcastName ++ " :: " ++ classTypeName ++ " a -> " ++ classTypeName ++ " ()\n" +++ ,downcastName ++ " :: " ++ classTypeName' ++ " a -> " ++ classTypeName' ++ " ()\n" ++ downcastName ++ " obj = objectCast obj\n\n" ) where- classTypeName = haskellTypeName className- downcastName = haskellDeclName ("downcast" ++ classTypeName)+ classTypeName' = haskellTypeName className+ downcastName = haskellDeclName ("downcast" ++ classTypeName')
src/CompileClassTypes.hs view
@@ -14,10 +14,10 @@ import qualified Data.Map as Map -import Data.Time( getCurrentTime)-import Types+-- import Data.Time( getCurrentTime)+-- import Types import HaskellNames-import Classes( isClassName, haskellClassDefs )+import Classes( {-isClassName,-} haskellClassDefs ) import DeriveTypes( ClassName ) import IOExtra @@ -25,8 +25,8 @@ Compile -----------------------------------------------------------------------------------------} compileClassTypes :: Bool -> String -> String -> FilePath -> [FilePath] -> IO ()-compileClassTypes showIgnore moduleRoot moduleName outputFile inputFiles- = do time <- getCurrentTime+compileClassTypes _showIgnore moduleRoot moduleName outputFile inputFiles+ = do -- time <- getCurrentTime let (exportsClass,classDecls) = haskellClassDefs exportsClassClasses = exportDefs exportsClass @@ -58,13 +58,13 @@ exportDefs :: [(ClassName,[String])] -> [String] exportDefs classExports = let classMap = Map.fromListWith (++) classExports - in concatMap exportDef $ zip [0..] (Map.toAscList classMap)+ in concatMap exportDef $ zip [(0 :: Int)..] (Map.toAscList classMap) where exportDef (n, (className,exports)) = [heading 2 className] ++ (commaSep n) exports commaSep n xs- = zipWith (exportComma n) [0..] xs+ = zipWith (exportComma n) [(0 :: Int)..] xs heading i name = exportSpaces ++ "-- " ++ replicate i '*' ++ " " ++ name
src/CompileClasses.hs view
@@ -8,24 +8,22 @@ Portability : portable Module that compiles method definitions to Haskell, together- with a proper marshaling wrapper.+ with a proper marshalling 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, elemIndex )+import Data.Time( getCurrentTime )+import Data.Char( toLower )+import Data.List( isPrefixOf, sort, sortBy, elemIndex ) import Types import HaskellNames-import Classes( isClassName, haskellClassDefs, objectClassNames, ClassInfo(..), classInfo, classIsManaged )+import Classes( haskellClassDefs, objectClassNames, ClassInfo(..), classInfo, classIsManaged ) import ParseC( parseC )-import DeriveTypes( deriveTypes, classifyName, Name(..), Method(..), ClassName, MethodName, PropertyName )+import DeriveTypes( deriveTypes, classifyName, Name(..), Method(..), ClassName ) import IOExtra {-----------------------------------------------------------------------------------------@@ -46,7 +44,7 @@ module2 = moduleRoot ++ moduleName ++ postfix2 export = concat [ ["module " ++ moduleRoot ++ moduleName- , " ( -- * Re-export" + , " ( -- * Re-export" , " module " ++ module1 , " , module " ++ module2 , " , module " ++ moduleRoot ++ moduleClassTypesName@@ -69,7 +67,7 @@ prologue = getPrologue moduleName "class" (show methodCount ++ " methods for " ++ show classCount ++ " classes.") inputFiles- + let output = unlines (prologue ++ export) putStrLn ("generating: " ++ outputFile ++ ".hs") writeFileLazy (outputFile ++ ".hs") output@@ -77,14 +75,23 @@ putStrLn ("ok.") -compileClassesFile showIgnore moduleRoot moduleClassTypesName moduleName outputFile inputFiles decls time+compileClassesFile :: a+ -> String+ -> String+ -> String+ -> String+ -> [String]+ -> [Decl]+ -> b+ -> IO (Int, Int)+compileClassesFile _showIgnore moduleRoot moduleClassTypesName moduleName outputFile inputFiles decls _time = do let foreignDecls = map foreignDecl decls haskellDecls = map haskellDecl decls typeDecls = map haskellTypeDecl decls marshalDecls = concat (zipWith3 (\t h f -> [t,h,f,""]) typeDecls haskellDecls foreignDecls) - (exportsClass,classDecls) = haskellClassDefs+ (exportsClass, _classDecls) = haskellClassDefs (exportsStatic,exportsClassClasses,classCount) = exportDefs decls exportsClass [] @@ -101,6 +108,7 @@ , "import qualified Data.ByteString as B (ByteString, useAsCStringLen)" , "import qualified Data.ByteString.Lazy as LB (ByteString, length, unpack)" , "import System.IO.Unsafe( unsafePerformIO )"+ , "import Foreign.C.Types(CInt(..), CWchar(..), CChar(..), CDouble(..))" , "import " ++ moduleRoot ++ "WxcTypes" , "import " ++ moduleRoot ++ moduleClassTypesName , ""@@ -118,14 +126,17 @@ return (methodCount,classCount) -+cmpDecl :: Decl -> Decl -> Ordering cmpDecl decl1 decl2 = compare (haskellDeclName (declName decl1)) (haskellDeclName (declName decl2)) -+exportComma :: String exportComma = exportSpaces ++ ","++exportSpaces :: String exportSpaces = " " +dropFirstComma :: String -> String dropFirstComma str = maybe str replaceNthWithSpace (elemIndex ',' str) where replaceNthWithSpace n = let (front,back) = splitAt n str in front ++ " " ++ tail back @@ -156,21 +167,21 @@ ,length (filter (not . null) classExps) ) where- addMethods methodMap shortMap className classDecls- | null decls = []- | otherwise = [heading 2 className] ++ decls+ addMethods methodMap shortMap className' _classDecls+ | null decls'' = []+ | otherwise = [heading 2 className'] ++ decls'' where- decls =- (case Map.lookup className shortMap of+ decls'' =+ (case Map.lookup className' shortMap of Nothing -> []- Just decls -> [heading 3 "Short methods"] ++ (commaSep decls)) ++- (case Map.lookup className methodMap of+ Just decls' -> [heading 3 "Short methods"] ++ (commaSep decls')) +++ (case Map.lookup className' methodMap of Nothing -> []- Just decls -> (commaSep decls))+ Just decls' -> (commaSep decls')) - todef (classname,decls)- = decls+ todef (_classname,decls')+ = decls' exportDef decl = (case classifyName (declName decl) of@@ -190,6 +201,7 @@ {----------------------------------------------------------------------------------------- Short cut names (unused) -----------------------------------------------------------------------------------------}+{- validShortNames :: [Decl] -> Set.Set String validShortNames decls = Set.fromList@@ -206,19 +218,22 @@ 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 -> ("","")-+ _other -> ("","")+-}+{- shortDecl :: Set.Set String -> Decl -> [((ClassName,[String]), [String])] shortDecl validShorts decl | Set.member sname validShorts = [( (cname,[sname])@@ -230,8 +245,9 @@ where (cname,sname) = shortNameEx decl -shortDecl validShorts decl+shortDecl _validShorts _decl = []+-} {----------------------------------------------------------------------------------------- Compile "xxx_Delete" methods to "objectDelete" to accomodate managed objects.@@ -240,8 +256,8 @@ 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) + -> (mname == "Delete" || mname=="SafeDelete")+ && (selfName == cname) && (cname `elem` objectClassNames || classIsManaged cname) _ -> False @@ -259,7 +275,7 @@ = 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]+ _other -> [(False,arg) | arg <- args] where args = declArgs decl @@ -281,68 +297,80 @@ haskellDecl decl- = methodName ++ " " ++ haskellArgs (haskellSwapThis decl) ++ nlStart+ = methodName' ++ " " ++ haskellArgs (haskellSwapThis decl) ++ nlStart ++ haskellToCResult decl (declRet decl) (- haskellToCArgsIO methodName (haskellThisArgs decl)+ haskellToCArgsIO methodName' (haskellThisArgs decl) ++ foreignName (declName decl) ++ " " ++ haskellToCArgs decl (declArgs decl) ) where- methodName = haskellDeclName (declName decl)+ methodName' = haskellDeclName (declName decl) +nl :: String nl = "\n "++nlStart :: String nlStart = "\n = "++pparens :: String -> String pparens txt = "(" ++ txt ++ ")" ++haskellArgs :: [Arg] -> String haskellArgs args = concatMap (\arg -> haskellName (argName arg) ++ " ") args +haskellToCResult :: Decl -> Type -> String -> String haskellToCResult decl tp call = unsafeIO $ case tp of- Fun 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 -> withResult (classInfo obj) ++ " $" ++ nl ++ call- String _ -> "withWStringResult $ \\buffer -> " ++ nl ++ call ++ " buffer" -- always last argument!+ Fun _ -> traceWarning "function as result" decl $ call+ EventId -> "withIntResult $" ++ nl ++ call+ Id -> "withIntResult $" ++ nl ++ call+ Int _ -> "withIntResult $" ++ nl ++ call+ IntPtr -> "withIntPtrResult $" ++ nl ++ call+ Bool -> "withBoolResult $" ++ nl ++ call+ Char -> "withCharResult $" ++ nl ++ call+ Object obj -> withResult (classInfo obj) ++ " $" ++ nl ++ call+ String _ -> "withWStringResult $ \\buffer -> " ++ nl ++ call ++ " buffer" -- always last argument! ByteString Lazy -> "withLazyByteStringResult $ \\buffer -> " ++ nl ++ call ++ " buffer" -- always last argument!- ByteString _ -> "withByteStringResult $ \\buffer -> " ++ nl ++ call ++ " buffer" -- always last argument!- Point CDouble -> "withPointDoubleResult $ \\px py -> " ++ nl ++ call ++ " px py" -- always last argument!- Point _ -> "withPointResult $ \\px py -> " ++ nl ++ call ++ " px py" -- always last argument!- Vector CDouble -> "withVectorDoubleResult $ \\pdx pdy -> " ++ nl ++ call ++ " pdx pdy" -- always last argument!- Vector _ -> "withVectorResult $ \\pdx pdy -> " ++ nl ++ call ++ " pdx pdy" -- always last argument!- Size CDouble -> "withSizeDoubleResult $ \\pw ph -> " ++ nl ++ call ++ " pw ph" -- always last argument!- Size _ -> "withSizeResult $ \\pw ph -> " ++ nl ++ call ++ " pw ph" -- always last argument!- Rect CDouble -> "withRectDoubleResult $ \\px py pw ph -> " ++ nl ++ call ++ "px py pw ph" -- always last argument!- Rect _ -> "withRectResult $ \\px py pw ph -> " ++ nl ++ call ++ "px py pw ph" -- always last argument!- - -- RefObject name -> "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+ ByteString _ -> "withByteStringResult $ \\buffer -> " ++ nl ++ call ++ " buffer" -- always last argument!+ Point CDouble -> "withPointDoubleResult $ \\px py -> " ++ nl ++ call ++ " px py" -- always last argument!+ Point _ -> "withPointResult $ \\px py -> " ++ nl ++ call ++ " px py" -- always last argument!+ Vector CDouble -> "withVectorDoubleResult $ \\pdx pdy -> " ++ nl ++ call ++ " pdx pdy" -- always last argument!+ Vector _ -> "withVectorResult $ \\pdx pdy -> " ++ nl ++ call ++ " pdx pdy" -- always last argument!+ Size CDouble -> "withSizeDoubleResult $ \\pw ph -> " ++ nl ++ call ++ " pw ph" -- always last argument!+ Size _ -> "withSizeResult $ \\pw ph -> " ++ nl ++ call ++ " pw ph" -- always last argument!+ Rect CDouble -> "withRectDoubleResult $ \\px py pw ph -> " ++ nl ++ call ++ "px py pw ph" -- always last argument!+ Rect _ -> "withRectResult $ \\px py pw ph -> " ++ nl ++ call ++ "px py pw ph" -- always last argument!++ RefObject name -> case withRef (classInfo name) of+ "" -> errorMsgDecl decl "illegal reference object"+ action -> action ++ " $ \\pref -> " ++ nl ++ call ++ " pref" -- always last argument!+ ArrayInt _ -> "withArrayIntResult $ \\arr -> " ++ nl ++ call ++ " arr" -- always last+ ArrayIntPtr _ -> "withArrayIntPtrResult $ \\arr -> " ++ nl ++ call ++ " arr" -- always last+ ArrayString _ -> "withArrayWStringResult $ \\arr -> " ++ nl ++ call ++ " arr" -- always last+ ArrayObject _ _ -> "withArrayObjectResult $ \\arr -> " ++ nl ++ call ++ " arr" -- always last+ _other -> call where unsafeIO body = case tp of EventId -> "unsafePerformIO $" ++ nl ++ body Id -> "unsafePerformIO $" ++ nl ++ body- other | isPrefixOf "Null_" (declName decl) -> "unsafePerformIO $" ++ nl ++ body+ _other | isPrefixOf "Null_" (declName decl) -> "unsafePerformIO $" ++ nl ++ body | otherwise -> body -haskellToCArgsIO methodName args- = concatMap (\(isSelf,arg) -> haskellToCArgIO methodName isSelf arg) args+haskellToCArgsIO :: String -> [(Bool, Arg)] -> String+haskellToCArgsIO methodName' args+ = concatMap (\(isSelf,arg) -> haskellToCArgIO methodName' isSelf arg) args -haskellToCArgIO methodName isSelf arg++haskellToCArgIO :: String -> Bool -> Arg -> String+haskellToCArgIO methodName' isSelf arg = case argType arg of String _ -> "withCWString " ++ haskellName (argName arg) ++ " $ \\" ++ haskellCStringName (argName arg) ++ " -> " ++ nl@@ -356,7 +384,7 @@ -> "withArrayWString " ++ haskellName (argName arg) ++ " $ \\" ++ haskellArrayLenName (argName arg) ++ " " ++ haskellArrayName (argName arg) ++ " -> " ++ nl- ArrayObject tp _+ ArrayObject _tp _ -> "withArrayObject " ++ haskellName (argName arg) ++ " $ \\" ++ haskellArrayLenName (argName arg) ++ " " ++ haskellArrayName (argName arg) ++ " -> " ++ nl@@ -364,67 +392,82 @@ -> "withArrayInt " ++ haskellName (argName arg) ++ " $ \\" ++ haskellArrayLenName (argName arg) ++ " " ++ haskellArrayName (argName arg) ++ " -> " ++ nl- Object obj -> (if isSelf then withSelf (classInfo obj) ("\"" ++ methodName ++ "\"") + ArrayIntPtr _+ -> "withArrayIntPtr " ++ haskellName (argName arg)+ ++ " $ \\" ++ haskellArrayLenName (argName arg) ++ " " ++ haskellArrayName (argName arg)+ ++ " -> " ++ nl+ Object obj -> (if isSelf then withSelf (classInfo obj) ("\"" ++ methodName' ++ "\"") else withPtr (classInfo obj)) ++ " " ++ haskellName (argName arg) ++ " $ \\" ++ haskellCObjectName (argName arg) ++ " -> " ++ nl- other -> ""+ _other -> "" ++haskellToCArgs :: Decl -> [Arg] -> String haskellToCArgs decl args = concatMap (\arg -> haskellToCArg decl arg ++ " ") args ++haskellToCArg :: Decl -> Arg -> String haskellToCArg decl arg = case argType arg of- RefObject 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)+ RefObject _ -> traceError "reference object as argument" decl $ name+ EventId -> traceError "event id as argument" decl $ name+ Id -> traceError "id as argument" decl $ name+ Int _ -> pparens ("toCInt " ++ name)+ IntPtr -> pparens ("toCIntPtr " ++ name)+ Char -> pparens ("toCWchar " ++ name)+ Bool -> pparens ("toCBool " ++ name)+ Fun _ -> pparens ("toCFunPtr " ++ name) - String _ -> haskellCStringName (argName arg)+ String _ -> haskellCStringName (argName arg) ByteString Lazy -> haskellByteStringName name ++ " (fromIntegral $ LB.length " ++ haskellName name ++ ")"- ByteString _ -> haskellByteStringName name ++ " " ++ haskellByteStringLenName name- 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) + ByteString _ -> haskellByteStringName name ++ " " ++ haskellByteStringLenName name+ Object _ -> haskellCObjectName (argName arg)+ Point CDouble -> pparens ("toCDoublePointX " ++ name) ++ " " ++ pparens( "toCDoublePointY " ++ name)+ Point _ -> pparens ("toCIntPointX " ++ name) ++ " " ++ pparens( "toCIntPointY " ++ name)+ Vector CDouble -> pparens ("toCDoubleVectorX " ++ name) ++ " " ++ pparens( "toCDoubleVectorY " ++ name)+ Vector _ -> pparens ("toCIntVectorX " ++ name) ++ " " ++ pparens( "toCIntVectorY " ++ name)+ Size CDouble -> pparens ("toCDoubleSizeW " ++ name) ++ " " ++ pparens( "toCDoubleSizeH " ++ name)+ Size _ -> pparens ("toCIntSizeW " ++ name) ++ " " ++ pparens( "toCIntSizeH " ++ name)+ Rect CDouble -> pparens ("toCDoubleRectX " ++ name) ++ " " ++ pparens( "toCDoubleRectY " ++ name)+ ++ pparens ("toCDoubleRectW " ++ name) ++ " " ++ pparens( "toCDoubleRectH " ++ name)+ Rect _ -> pparens ("toCIntRectX " ++ name) ++ " " ++ pparens( "toCIntRectY " ++ name)+ ++ pparens ("toCIntRectW " ++ name) ++ " " ++ pparens( "toCIntRectH " ++ name)+ ColorRGB _ -> pparens ("colorRed " ++ name) ++ " "+ ++ pparens ("colorGreen " ++ name) ++ " "+ ++ pparens ("colorBlue " ++ name) - ArrayString _ -> haskellArrayLenName name ++ " " ++ haskellArrayName name- ArrayObject tp _ -> haskellArrayLenName name ++ " " ++ haskellArrayName name- ArrayInt _ -> haskellArrayLenName name ++ " " ++ haskellArrayName name+ ArrayString _ -> haskellArrayLenName name ++ " " ++ haskellArrayName name+ ArrayObject _ _ -> haskellArrayLenName name ++ " " ++ haskellArrayName name+ ArrayInt _ -> haskellArrayLenName name ++ " " ++ haskellArrayName name+ ArrayIntPtr _ -> haskellArrayLenName name ++ " " ++ haskellArrayName name - other -> name+ _other -> name where name = haskellName (argName arg) -+haskellCStringName :: String -> String haskellCStringName name = "cstr_" ++ haskellName name +haskellByteStringName :: String -> String haskellByteStringName name = "bs_" ++ haskellName name +haskellByteStringLenName :: String -> String haskellByteStringLenName name = "bslen_" ++ haskellName name +haskellArrayName :: String -> String haskellArrayName name = "carr_" ++ haskellName name +haskellArrayLenName :: String -> String haskellArrayLenName name = "carrlen_" ++ haskellName name +haskellCObjectName :: String -> String haskellCObjectName name = "cobj_" ++ haskellName name @@ -456,10 +499,12 @@ name ++ " :: " ++ haskellTypeArgs decl (haskellSwapThis decl) +haskellTypeArgs :: Decl -> [Arg] -> String haskellTypeArgs decl args = concatMap (\(i,arg) -> haskellTypeArg decl i arg ++ " -> ") (zip [1..] args) +haskellRetType :: Decl -> [Char] -> String haskellRetType decl typedecl = case declRet decl of EventId -> "{-# NOINLINE " ++ haskellDeclName (declName decl) ++ " #-}\n" ++ typedecl ++ " EventId"@@ -472,49 +517,57 @@ -- 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+haskellTypeArg :: a -> Int -> Arg -> String+haskellTypeArg _decl _i (Arg ["id"] (Int _)) = "Id"+haskellTypeArg _decl _i (Arg ["_id"] (Int _)) = "Id"+haskellTypeArg _decl _i (Arg ["_stl"] (Int _)) = "Style"+haskellTypeArg _decl i arg = haskellType i (argType arg) ++haskellTypePar :: Int -> Type -> String haskellTypePar i tp = parenType (haskellType i) tp ++haskellType :: Int -> Type -> String haskellType i tp = case tp of- Bool -> "Bool"- Int _ -> "Int"- 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+ Bool -> "Bool"+ Int _ -> "Int"+ IntPtr -> "IntPtr"+ Int64 -> "Int64"+ Word -> "Word"+ Word8 -> "Word8"+ Word32 -> "Word32"+ Word64 -> "Word64"+ Void -> "()"+ Char -> "Char"+ Double -> "Double"+ Float -> "Float"+ Ptr Void -> "Ptr " ++ typeVar i+ Ptr t -> "Ptr " ++ foreignTypePar i t -- special- Vector CDouble -> "(Vector2 Double)"- Vector _ -> "Vector"- Point CDouble -> "(Point2 Double)"- Point _ -> "Point"- Size CDouble -> "(Size2D Double)"- Size _ -> "Size"- ColorRGB _ -> "Color"- String _ -> "String"- ByteString Lazy -> "LB.ByteString"- ByteString _ -> "B.ByteString"- ArrayString _ -> "[String]"- ArrayInt _ -> "[Int]"+ Vector CDouble -> "(Vector2 Double)"+ Vector _ -> "Vector"+ Point CDouble -> "(Point2 Double)"+ Point _ -> "Point"+ Size CDouble -> "(Size2D Double)"+ Size _ -> "Size"+ ColorRGB _ -> "Color"+ String _ -> "String"+ ByteString Lazy -> "LB.ByteString"+ ByteString _ -> "B.ByteString"+ ArrayString _ -> "[String]"+ ArrayInt _ -> "[Int]"+ ArrayIntPtr _ -> "[IntPtr]" ArrayObject name _ -> "[" ++ haskellTypeName name ++ typeVar i ++ "]"- Rect CDouble -> "(Rect2D Double)"- Rect _ -> "Rect"- Fun f -> "FunPtr " ++ pparens f- RefObject name -> classTypeName (classInfo name) (typeVar i) -- haskellTypeName name ++ typeVar i- Object name -> classTypeName (classInfo name) (typeVar i) -- haskellTypeName name ++ typeVar i- other -> error ("Non exaustive pattern: CompileClasses.haskellType: " ++ show tp)+ Rect CDouble -> "(Rect2D Double)"+ Rect _ -> "Rect"+ Fun f -> "FunPtr " ++ pparens f+ RefObject name -> classTypeName (classInfo name) (typeVar i) -- haskellTypeName name ++ typeVar i+ Object name -> classTypeName (classInfo name) (typeVar i) -- haskellTypeName name ++ typeVar i+ _other -> error ("Non exaustive pattern: CompileClasses.haskellType: " ++ show tp) {----------------------------------------------------------------------------------------- Translate a declaration to a foreign import declaration@@ -528,6 +581,8 @@ ++ foreignName (declName decl) ++ " :: " ++ foreignArgs decl (declArgs decl) ++ foreignResultType (declRet decl) ++foreignName :: String -> String foreignName name | isPrefixOf "wx" name && elem '_' name = name | otherwise = "wx_" ++ name@@ -536,43 +591,54 @@ foreignArgs decl args = concatMap (\(i,arg) -> foreignArg decl i arg ++ " -> ") (zip [1..] args) ++foreignArg :: Decl -> Int -> Arg -> String foreignArg decl i arg = case argType arg of RefObject name -> traceError "RefObject in argument" decl $ foreignType i (RefObject name) Void -> traceError "void type in argument" decl $ foreignType i Void tp -> foreignType i tp ++foreignResultType :: Type -> String foreignResultType tp = case tp of- ArrayInt _ -> "Ptr CInt -> IO CInt"- ArrayString _ -> "Ptr (Ptr CWchar) -> IO CInt"+ ArrayInt _ -> "Ptr CInt -> IO CInt"+ ArrayIntPtr _ -> "Ptr CIntPtr -> IO CInt"+ ArrayString _ -> "Ptr (Ptr CWchar) -> IO CInt" ArrayObject name _ -> "Ptr " ++ foreignTypePar 0 (Object name) ++ " -> IO CInt"- String _ -> "Ptr CWchar -> IO CInt"- ByteString _ -> "Ptr CChar -> IO CInt"- Point CDouble -> "Ptr CDouble -> Ptr CDouble -> IO ()"- Point _ -> "Ptr CInt -> Ptr CInt -> IO ()"- Vector CDouble -> "Ptr Double -> Ptr Double -> IO ()"- Vector _ -> "Ptr CInt -> Ptr CInt -> IO ()"- Size CDouble -> "Ptr CDouble -> Ptr CDouble -> IO ()"- Size _ -> "Ptr CInt -> Ptr CInt -> IO ()"- Rect CDouble -> "Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> IO ()"- Rect _ -> "Ptr CInt -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO ()"- RefObject name -> foreignType 0 tp ++ " -> IO ()"- EventId -> "IO CInt"- Id -> "IO CInt"- other -> "IO " ++ foreignTypePar 0 tp+ String _ -> "Ptr CWchar -> IO CInt"+ ByteString _ -> "Ptr CChar -> IO CInt"+ Point CDouble -> "Ptr CDouble -> Ptr CDouble -> IO ()"+ Point _ -> "Ptr CInt -> Ptr CInt -> IO ()"+ Vector CDouble -> "Ptr Double -> Ptr Double -> IO ()"+ Vector _ -> "Ptr CInt -> Ptr CInt -> IO ()"+ Size CDouble -> "Ptr CDouble -> Ptr CDouble -> IO ()"+ Size _ -> "Ptr CInt -> Ptr CInt -> IO ()"+ Rect CDouble -> "Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> IO ()"+ Rect _ -> "Ptr CInt -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO ()"+ RefObject _name -> foreignType 0 tp ++ " -> IO ()"+ EventId -> "IO CInt"+ Id -> "IO CInt"+ _other -> "IO " ++ foreignTypePar 0 tp ++foreignTypePar :: Int -> Type -> String foreignTypePar i tp = parenType (foreignType i) tp ++foreignType :: Int -> Type -> [Char] foreignType i tp = case tp of Bool -> "CBool" Int _ -> "CInt" Int64 -> "Int64"+ IntPtr -> "CIntPtr" Word -> "Word" Word8 -> "Word8" Word32 -> "Word32"+ Word64 -> "Word64" Void -> "()" Char -> "CWchar" Double -> "Double"@@ -580,35 +646,42 @@ 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+ 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 name -> "Ptr (T" ++ haskellTypeName name ++ typeVar i ++ ")"- Object name -> "Ptr (T" ++ haskellTypeName name ++ typeVar i ++ ")"+ ArrayIntPtr _ -> "CInt -> Ptr CIntPtr"+ RefObject name -> "Ptr (T" ++ haskellTypeName name ++ typeVar i ++ ")"+ Object name -> "Ptr (T" ++ haskellTypeName name ++ typeVar i ++ ")"+ _ -> error $ "CompileClasses.foreignType: unexpected type: " ++ show tp ++parenType :: (Type -> String) -> Type -> String parenType f tp = parenFun tp (f tp) where- parenFun tp- = case tp of+ parenFun tp'+ = case tp' of Ptr _ -> pparens Object _ -> pparens RefObject _ -> pparens- other -> id+ _other -> id +typeVar :: Int -> String typeVar i = " " ++ typeVars !! i++typeVars :: [String] typeVars = "()" : [[toEnum (fromEnum 'a' + x)] | x <- [0..]]
src/CompileHeader.hs view
@@ -14,18 +14,14 @@ 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 Data.List( isPrefixOf, sort, sortBy, intersperse ) import Types import HaskellNames-import Classes( isClassName, classNames, classExtends )+import Classes( classNames, classExtends ) import ParseC( parseC )-import DeriveTypes( deriveTypesAll, classifyName, Name(..), Method(..), ClassName, MethodName, PropertyName )+import DeriveTypes( deriveTypesAll, classifyName, Name(..) ) import IOExtra {-----------------------------------------------------------------------------------------@@ -34,7 +30,7 @@ compileHeader :: Bool -> FilePath -> [FilePath] -> IO () compileHeader showIgnore outputFile inputFiles = do declss <- mapM parseC inputFiles- time <- getCurrentTime+ -- time <- getCurrentTime let decls = deriveTypesAll showIgnore (sortBy cmpDecl (concat declss)) typeDecls = cTypeDecls decls@@ -55,12 +51,19 @@ putStrLn ("ok.\n") +cmpDecl :: Decl -> Decl -> Ordering cmpDecl decl1 decl2 = compare (haskellDeclName (declName decl1)) (haskellDeclName (declName decl2)) -+{-+exportComma :: String exportComma = exportSpaces ++ ","+-}++{-+exportSpaces :: String exportSpaces = " "+-} {----------------------------------------------------------------------------------------- Translate declarations to a c type declarations@@ -85,21 +88,21 @@ 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+ addMethods methodMap className' classDecls+ = heading className' +++ (case Map.lookup className' classExtends of Nothing -> []- Just "" -> ["TClassDef(" ++ className ++ ")"]- Just ext -> ["TClassDefExtend(" ++ className ++ "," ++ ext ++ ")"]+ Just "" -> ["TClassDef(" ++ className' ++ ")"]+ Just ext -> ["TClassDefExtend(" ++ className' ++ "," ++ ext ++ ")"] ) ++ classDecls ++- (case Map.lookup className methodMap of- Nothing -> []- Just decls -> decls)+ (case Map.lookup className' methodMap of+ Nothing -> []+ Just dcls -> dcls) - toDecls (classname,decls)- = decls+ toDecls (_classname, dcls)+ = dcls typeDef decl = (case classifyName (declName decl) of@@ -131,63 +134,68 @@ "( " ++ concat (intersperse ", " (cTypeArgs decl (declArgs decl) ++ cOutArg (declRet decl))) ++ " );" +fill :: Int -> String -> String fill n s | length s >= n = s | otherwise = s ++ replicate (n - length s) ' ' -cTypeArgs decl []- = []++cTypeArgs :: Decl -> [Arg] -> [String]+cTypeArgs _ [] = [] cTypeArgs decl (arg:args)- = cTypeArg decl className arg : map (cTypeArg decl "") args+ = cTypeArg decl getClassName arg : map (cTypeArg decl "") args where- className = case classifyName (declName decl) of- Method cname m -> cname- otherwise -> ""+ getClassName = case classifyName (declName decl) of+ Method cname _ -> cname+ _otherwise -> "" +cRetType :: Decl -> Type -> String cRetType decl tp = case tp of -- out- String _ -> "TStringLen"- ArrayString _ -> "TArrayLen"+ String _ -> "TStringLen"+ ArrayString _ -> "TArrayLen" ArrayObject _ _ -> "TArrayLen"- Vector _ -> "void"- Point _ -> "void"- Size _ -> "void"- Rect _ -> "void"- RefObject name -> "void"+ Vector _ -> "void"+ Point _ -> "void"+ Size _ -> "void"+ Rect _ -> "void"+ RefObject _ -> "void" -- typedefs- EventId -> "int"+ 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"+ Bool -> "TBool"+ Char -> "TChar"+ Int CLong -> "long"+ Int TimeT -> "time_t"+ Int SizeT -> "size_t"+ Int _ -> "int"+ Void -> "void"+ Double -> "double"+ Float -> "float" Ptr Void -> "void*" Ptr t -> cRetType decl t ++ "*" Object name -> "TClass(" ++ name ++ ")"- other -> traceError ("unknown return type (" ++ show tp ++ ")") decl $- "void"+ _other -> traceError ("unknown return type (" ++ show tp ++ ")") decl $+ "void" +cOutArg :: Type -> [String] cOutArg tp = case tp of- Vector ctp -> ["TVectorOut" ++ ctypeSpec CInt ctp ++ "(_vx,_vy)"]- Point ctp -> ["TPointOut" ++ ctypeSpec CInt ctp ++ "(_x,_y)"]- Size ctp -> ["TSizeOut" ++ ctypeSpec CInt ctp ++ "(_w,_h)"]- String ctp -> ["TStringOut" ++ ctypeSpec CChar ctp ++ " _buf"]- Rect ctp -> ["TRectOut" ++ ctypeSpec CInt ctp ++ "(_x,_y,_w,_h)" ]- RefObject name -> ["TClassRef(" ++ name ++ ") _ref"]- ArrayString ctp -> ["TArrayString" ++ ctypeSpec CChar ctp ++ " _strs"]- ArrayObject name ctp -> ["TArrayObject" ++ ctypeSpec CObject ctp ++ "(" ++ name ++ ") _objs"]- other -> []+ 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+cTypeArg :: Decl -> String -> Arg -> String+cTypeArg decl className' arg = case argType arg of -- basic Bool -> "TBool " ++ argName arg@@ -195,37 +203,39 @@ Int CLong -> "long " ++ argName arg Int TimeT -> "time_t " ++ argName arg Int SizeT -> "size_t " ++ argName arg- Int other -> "int " ++ argName arg+ Int _ -> "int " ++ argName arg Void -> "void " ++ argName arg Double -> "double " ++ argName arg Float -> "float " ++ argName arg Ptr Void -> "void* " ++ argName arg- Ptr t -> cRetType decl t ++ "* " ++ argName arg+ Ptr t -> cRetType decl t ++ "* " ++ argName arg -- typedefs- EventId -> "int"+ 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+ 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+ 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+ StringLen -> "TStringLen " ++ argName arg+ StringOut ctp -> "TStringOut" ++ ctypeSpec CChar ctp ++ " " ++ argName arg+ ArrayLen -> "TArrayLen " ++ argName arg+ ArrayStringOut ctp -> "TArrayStringOut" ++ ctypeSpec CChar ctp ++ " " ++ argName arg+ ArrayObjectOut name ctp -> "TArrayObjectOut" ++ ctypeSpec CObject ctp ++ "(" ++ name ++ ") " ++ argName arg+ PointOut ctp -> "TPointOut" ++ ctypeSpec CInt ctp ++ argNameTuple+ SizeOut ctp -> "TSizeOut" ++ ctypeSpec CInt ctp ++ argNameTuple+ VectorOut ctp -> "TVectorOut" ++ ctypeSpec CInt ctp ++ argNameTuple+ RectOut ctp -> "TRectOut" ++ ctypeSpec CInt ctp ++ argNameTuple++ _other -> error ("cTypeArg: unknown argument type (" ++ show (argType arg) ++ ")") {- other -> traceError ("unknown argument type (" ++ show (argType arg) ++ ")") decl $ "ctypeSpec"@@ -235,6 +245,7 @@ = "(" ++ concat (intersperse "," (argNames arg)) ++ ")" +ctypeSpec :: CBaseType -> CBaseType -> String ctypeSpec deftp ctp | deftp==ctp = "" | otherwise = case ctp of@@ -242,4 +253,4 @@ CLong -> "Long" CChar -> "Char" CVoid -> "Void"- other -> ""+ _other -> ""
src/CompileSTC.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------------------- {-| Module : CompileSTC - Copyright : (c) Haste Developper Team 2004, 2005 + Copyright : (c) Haste Developer Team 2004, 2005 License : BSD-style Maintainer : wxhaskell-devel@lists.sourceforge.net @@ -14,7 +14,6 @@ import qualified Text.ParserCombinators.Parsec.Token as P import Text.ParserCombinators.Parsec.Language -import Data.Char import Data.List import Control.Monad @@ -27,8 +26,8 @@ -> IO () compileSTC verbose outputDir inputs = do dfs <- mapM parseH inputs - let (ds,fs) = unzip dfs - d = concat ds --currently unused + 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" @@ -39,14 +38,19 @@ when verbose $ putStrLn $ "Wrote type macros and c wrappers for " ++ show (length f) ++ " functions." + +type Function = (String, String, [(String, String)]) + + +parseH :: FilePath -> IO ([Def], [Function]) 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 ([],[]) + Left err -> print err >> return ([],[]) Right funcs -> return (defs,filter convertable funcs) --- returns a list of defenitions, see Types.Def +-- returns a list of definitions, see Types.Def -- and a new list of lines without #define's partitionDefines :: [String] -> ([Def], [String]) partitionDefines lns = (defs, cpp) @@ -55,20 +59,22 @@ toDef x = let (name,value) = break (==' ') x in Def name (read value) DefInt + +plines :: Parser [Function] plines = whiteSpace >> many1 pfunc -pfunc :: Parser (String, String, [(String, String)]) -pfunc = do ret <- identifier +pfunc :: Parser Function +pfunc = do ret <- identifier stars <- option "" $ symbol "*" - func <- identifier - args <- parens $ commaSep $ arg - symbol ";" + func <- identifier + args <- parens $ commaSep $ arg + _ <- symbol ";" return (ret ++ stars,func,args) - where arg = do option "" $ try $ symbol "const" - t <- identifier + where arg = do _ <- option "" $ try $ symbol "const" + t <- identifier stars <- option "" $ symbol "*" - option "" $ symbol "&" - name <- identifier + _ <- option "" $ symbol "&" + name <- identifier return (t ++ stars, name) {----------------------------------------------------------------------------------------- @@ -79,32 +85,53 @@ 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 +whiteSpace :: Parser () +whiteSpace = P.whiteSpace lexer +-- lexeme = P.lexeme lexer + +symbol :: String -> Parser String +symbol = P.symbol lexer + +parens :: Parser a -> Parser a +parens = P.parens lexer + +-- semi :: Parser String +-- semi = P.semi lexer + +-- comma = P.comma lexer + +commaSep :: Parser a -> Parser [a] +commaSep = P.commaSep lexer + +identifier :: Parser String +identifier = P.identifier lexer + +-- reserved :: String -> Parser () +-- reserved = P.reserved lexer + + {----------------------------------------------------------------------------------------- code gen -----------------------------------------------------------------------------------------} -convertable (t,f,a) = elem t ["int", "bool", "void"] +convertable :: Function -> Bool +convertable (t,_f,_a) = elem t ["int", "bool", "void"] +glue :: String -> [String] -> String glue str strs = concat $ intersperse str strs -- CPP function generator (Creates functions that can be exported as C functions) +cppfunc :: Function -> String cppfunc x = macro x ++ arguments x ++ "\n" ++ body x -macro (ret, func, args) = "EWXWEXPORT(" ++ ret ++ ", wxStyledTextCtrl_" ++ func ++ ")" +macro :: Function -> String +macro (ret, func, _args) = "EWXWEXPORT(" ++ ret ++ ", wxStyledTextCtrl_" ++ func ++ ")" -arguments (ret, func, args) = "(" ++ glue ", " params ++ ")" +arguments :: Function -> String +arguments (_ret, _func, args) = "(" ++ glue ", " params ++ ")" where params = "void* _obj" : rest rest = map transType args @@ -118,6 +145,7 @@ transType ("wxColour", n) = glue ", " ["int " ++ n ++ c | c <- ["_r","_g","_b"]] transType (_, n) = "void* " ++ n +body :: Function -> String body (ret, func, args) = "{\n" ++ "#ifdef wxUSE_STC\n " ++ maybeReturn ++ " ((wxStyledTextCtrl*) _obj)->" ++ func ++ "(" ++ glue ", " params ++ ");\n" @@ -136,7 +164,7 @@ transParam (t, n) = "*(" ++ t ++ "*) " ++ n -- Generator for functions signatures with type macros - +headerfunc :: Function -> String headerfunc (ret, func, args) = returnType ret ++ " wxStyledTextCtrl_" ++ func ++ "(" ++ glue ", " params ++ ");" where
src/DeriveTypes.hs view
@@ -7,7 +7,7 @@ Stability : provisional Portability : portable - Module that derives more specific types from a C-header signature.+ Module that derives more specific types from a C-header signature. Also removes duplicates and ignored definitions. -} -----------------------------------------------------------------------------------------@@ -19,15 +19,14 @@ 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 Data.Char( toUpper, isUpper )+import Data.List( isPrefixOf ) import Types-import HaskellNames-import Classes( isClassName, haskellClassDefs )+import Classes( isClassName ) {------------------------------------------------------------------------------------------ The whole type derivation can be tuned with this tables+ The whole type derivation can be tuned with these tables -----------------------------------------------------------------------------------------} -- | Map properties names (@GetInvokingWindow@) to object types (@Window@). objectProperties :: Map.Map String Type@@ -73,7 +72,7 @@ ,("LogTarget" , "wxLog") ] --- | Property names that correspond with a boolean+-- | Property names that correspond to a boolean booleanProperties :: Set.Set String booleanProperties = Set.fromList@@ -177,7 +176,7 @@ ] --- | Argument name pairs that correspond to Points.+-- | Argument name pairs that correspond to Points. points :: Set.Set (String,String) points = Set.fromList@@ -195,7 +194,7 @@ , ("_lft","_top") -- FileDialog ] --- | Argument name pairs that correspond to Sizes.+-- | Argument name pairs that correspond to Sizes. sizes :: Set.Set (String,String) sizes = Set.fromList@@ -205,7 +204,7 @@ , ("_width","_height") ] --- | Argument name pairs that correspond to Vectors.+-- | Argument name pairs that correspond to Vectors. vectors :: Set.Set (String,String) vectors = Set.fromList@@ -213,7 +212,7 @@ , ("_dx","_dy") ] --- | Argument name quadruples that correspond to Rectangles.+-- | Argument name quadruples that correspond to Rectangles. rectangles :: Set.Set (String,String,String,String) rectangles = Set.fromList@@ -228,56 +227,56 @@ 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+ [ ("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 ()")+ [ ("_fun_CEvent", "Ptr fun -> Ptr state -> Event evt -> IO ()") ] referenceObjects :: Map.Map String String referenceObjects = Map.fromList- [ ("AddTime", "wxDateTime")+ [ ("AddTime", "wxDateTime") , ("SubtractTime", "wxDateTime")- , ("AddDate", "wxDateTime")+ , ("AddDate", "wxDateTime") , ("SubtractDate", "wxDateTime")- , ("LoadBitmap", "wxBitmap")- , ("LoadIcon", "wxIcon")+ , ("LoadBitmap", "wxBitmap")+ , ("LoadIcon", "wxIcon") ] -- | Definitions that should be ignored.@@ -316,8 +315,8 @@ -- message parameters: eljmime / wrapper.h ,prefix "wxMessageParameters" "message param" -- non-portable- ,equals "expEVT_COMMAND_TOGGLEBUTTON_CLICKED" "toggle button"- ,prefix "wxToggleButton_" "toggle button"+ --,equals "expEVT_COMMAND_TOGGLEBUTTON_CLICKED" "toggle button"+ --,prefix "wxToggleButton_" "toggle button" ,prefix "wxDialUpEvent_" "dialup events" ,prefix "wxDialUpManager_" "dialup manager" ,prefix "wxCriticalSection_" "threads"@@ -362,6 +361,7 @@ {----------------------------------------------------------------------------------------- Ignore certain decls -----------------------------------------------------------------------------------------}+shouldIgnore :: Decl -> Maybe String shouldIgnore decl = walk ignore where@@ -374,15 +374,15 @@ Remove duplicates and undefined stuff -----------------------------------------------------------------------------------------} removeDupsAndUndefined :: (Decl -> Maybe String) -> Bool -> [Decl] -> [Decl]-removeDupsAndUndefined shouldIgnore showIgnore decls- = filter Set.empty decls+removeDupsAndUndefined shouldIgnore' showIgnore decls+ = filterDupsAndUndefined 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+ filterDupsAndUndefined _ [] = []+ filterDupsAndUndefined set (decl:decls')+ = case shouldIgnore' decl of+ Just msg -> (if showIgnore then traceIgnore msg decl else id) $ filterDupsAndUndefined set decls'+ _other | Set.member (declName decl) set -> traceIgnore "duplicate" decl $ filterDupsAndUndefined set decls'+ | otherwise -> decl : filterDupsAndUndefined (Set.insert (declName decl) set) decls' {----------------------------------------------------------------------------------------- Derive "Out" types@@ -391,44 +391,46 @@ deriveOutTypes decl = case (declRet decl,reverse (declArgs decl)) of -- string- (StringLen,Arg name (StringOut ctp) :args)+ (StringLen,Arg _name (StringOut ctp) :args) -> decl{ declRet = String ctp, declArgs = reverse args } -- bytestring- (ByteStringLen,Arg name (ByteStringOut ctp) :args)+ (ByteStringLen,Arg _name (ByteStringOut ctp) :args) -> decl{ declRet = ByteString ctp, declArgs = reverse args } -- int array- (ArrayLen,Arg name (ArrayIntOut ctp) :args)+ (ArrayLen,Arg _name (ArrayIntOut ctp) :args) -> decl{ declRet = ArrayInt ctp, declArgs = reverse args }+ -- intptr array+ (ArrayLen,Arg _name (ArrayIntPtrOut ctp) :args)+ -> decl{ declRet = ArrayIntPtr ctp, declArgs = reverse args } -- string array- (ArrayLen,Arg name (ArrayStringOut ctp) :args)+ (ArrayLen,Arg _name (ArrayStringOut ctp) :args) -> decl{ declRet = ArrayString ctp, declArgs = reverse args } -- object array- (ArrayLen,Arg name (ArrayObjectOut cname ctp) :args)+ (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)+ (Void,Arg _name (PointOut ctp ):args) -> decl{ declRet = Point ctp , declArgs = reverse args } -- size- (Void,Arg name (SizeOut ctp ):args)+ (Void,Arg _name (SizeOut ctp ):args) -> decl{ declRet = Size ctp , declArgs = reverse args } -- vector- (Void,Arg name (VectorOut ctp ):args)+ (Void,Arg _name (VectorOut ctp ):args) -> decl{ declRet = Vector ctp , declArgs = reverse args } -- rect- (Void,Arg name (RectOut ctp ):args)+ (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)+ (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+ _ -> decl {----------------------------------------------------------------------------------------- Derive extended types@@ -446,6 +448,7 @@ -- Extended types: int x, int y => Point+deriveExtTypes :: Decl -> Decl deriveExtTypes decl = decl{ declArgs = deriveExtArgs (declArgs decl) } where@@ -472,6 +475,7 @@ = [] -- Derive string return: "int fun(..., void* _buf)"+deriveStringReturn :: Decl -> Decl deriveStringReturn decl = case (classifyName (declName decl),declRet decl,reverse (declArgs decl)) of -- string@@ -479,10 +483,11 @@ -> decl{ declRet = String CVoid, declArgs = reverse args } (_,Int _,Arg ["_buf"] (Ptr Char):args) -> decl{ declRet = String CChar, declArgs = reverse args }- other+ _other -> decl -- Extended return types. Like string: "int fun(..., void* _buf)"+deriveExtReturn :: Decl -> Decl deriveExtReturn decl = case (classifyName (declName decl),declRet decl,reverse (declArgs decl)) of -- string@@ -527,7 +532,7 @@ cname = "wx" ++ drop 5 name -- Is/Has- (Method cname (Normal mname),Int ctp,_)+ (Method _cname (Normal mname),Int _ctp,_) | (isPrefixOf "Is" mname || isPrefixOf "Has" mname || isPrefixOf "Can" mname || mname=="Ok" || isPrefixOf "Contains" mname) -> decl{ declRet = Bool }@@ -545,45 +550,48 @@ createName = drop (length "Create") mname -- Boolean methods- (Method cname (Normal mname),Int ctp,_)+ (Method _cname (Normal mname),Int _ctp,_) | Set.member mname booleanMethods -> decl{ declRet = Bool } -- Object methods- (Method cname (Normal mname),Ptr Void,_)+ (Method _cname (Normal mname),Ptr Void,_) -> case Map.lookup mname objectMethods of Just tp -> decl{ declRet = tp } Nothing -> decl -- other- other -> decl+ _ -> decl -- returned properties: assumes that deriveThis has already been done+deriveReturnProperties :: Decl -> Decl deriveReturnProperties decl = case (classifyName (declName decl),declRet decl,reverse (declArgs decl)) of -- Get via reference- (Method cname (Get propname),Void,Arg _ (Ptr Void):args)+ (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))])+ (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))+ (Method _cname (Get propname),Void,(Arg _ (Object _objname):args)) | Map.member propname objectProperties -> case Map.lookup propname objectProperties of Just (Object name) -> -- trace ("ref: " ++ name ++ ": " ++ declName decl) $ decl{ declRet = RefObject name, declArgs = reverse args }+ Just _ -> error "deriveReturnProperties: unexpected objectProperty (1)" Nothing -> traceError ("illegal reference object") decl $ decl (Method cname (Get propname),Void,Arg ["_ref"] (Ptr Void):args) -> case Map.lookup propname objectProperties of Just (Object name) -> -- trace ("ref: " ++ name ++ ": " ++ declName decl) $ decl{ declRet = RefObject name, declArgs = reverse args }+ Just _ -> error "deriveReturnProperties: unexpected objectProperty (2)" Nothing | cname == "wxListEvent" && propname == "Item" -> -- trace ("ref: ListItem: " ++ declName decl) $ decl{ declRet = RefObject "wxListItem", declArgs = reverse args }@@ -608,36 +616,37 @@ decl{ declRet = RefObject "Ptr", declArgs = reverse args } -- Get- (Method cname (Get propname),Ptr Void,_)+ (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 _,_)+ (Method _cname (Get propname),Int _,_) | Set.member propname booleanProperties -> decl{ declRet = Bool } -- Set- (Method cname (Set propname),_,Arg argname (Ptr Void):args)+ (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)+ (Method _cname (Set propname),_,Arg argname (Int _):args) | Set.member propname booleanProperties -> decl{ declArgs = reverse (Arg argname Bool : args)} -- other- other -> decl+ _ -> decl -- Simple types: char* => String+deriveSimpleTypes :: Decl -> Decl deriveSimpleTypes decl = decl{ declArgs = deriveArgs (declArgs decl) } where@@ -647,7 +656,7 @@ deriveArg arg = case argType arg of Ptr Char -> String CChar- Int ctp | Set.member (argName arg) booleans -> Bool+ 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@@ -664,18 +673,20 @@ -- Check for "this" pointer -- derive for "wxObject_Create :: ... -> IO (Ptr ())"+deriveThis :: Decl -> Decl deriveThis decl = case classifyName (declName decl) of Create cname | declRet decl == Ptr Void -- bitmapCreate -> decl{ declRet = Object cname }- Method cname m | not (null args) && (argType (head args) == Ptr Void) && not (elem cname ["ELJApp"])+ 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+ _ -> decl where args = declArgs decl -- derive event ids: int expEVT_XXX() and expXXX_XXX();+deriveId :: Decl -> Decl deriveId decl@Decl{ declRet = Int _, declArgs = [] } | isPrefixOf "expEVT_" (declName decl) = decl{ declRet = EventId }@@ -706,19 +717,19 @@ 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+ ('w' : 'x' : _) -> getClassName s+ ('c' : 'b' : _) -> getClassName s+ (c : _) | isUpper c -> getClassName s+ _ -> Name s where- className name+ getClassName name = case (span (/='_') name) of- (cname,method) | isClassName cname && not (null method)- -> if (method == "_Create")+ (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))+ 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
@@ -7,7 +7,7 @@ Stability : provisional Portability : portable - Utility module to create haskell compatible names.+ Utility module to create Haskell compatible names. -} ----------------------------------------------------------------------------------------- module HaskellNames( haskellDeclName@@ -19,7 +19,6 @@ import qualified Data.Set as Set import Data.Char( toLower, toUpper, isLower, isUpper )-import Data.Time( getCurrentTime) import Data.List( isPrefixOf ) {-----------------------------------------------------------------------------------------@@ -81,6 +80,7 @@ {----------------------------------------------------------------------------------------- -----------------------------------------------------------------------------------------}+haskellDeclName :: String -> String haskellDeclName name | isPrefixOf "wxMDI" name = haskellName ("mdi" ++ drop 5 name) | isPrefixOf "wxDC_" name = haskellName ("dc" ++ drop 5 name)@@ -95,9 +95,11 @@ | otherwise = haskellName name +haskellArgName :: String -> String haskellArgName name = haskellName (dropWhile (=='_') name) +haskellName :: String -> String haskellName name | Set.member suggested reservedVarNames = "wx" ++ suggested | otherwise = suggested@@ -107,6 +109,7 @@ (c:cs) -> toLower c : filter (/='_') cs [] -> "wx" +haskellUnderscoreName :: String -> String haskellUnderscoreName name | Set.member suggested reservedVarNames = "wx" ++ suggested | otherwise = suggested@@ -118,6 +121,7 @@ [] -> "wx" +haskellTypeName :: String -> String haskellTypeName name | isPrefixOf "ELJ" name = haskellTypeName ("WXC" ++ drop 3 name) | Set.member suggested reservedTypeNames = "Wx" ++ suggested@@ -128,25 +132,28 @@ 'W':'X':'C':cs -> "WXC" ++ cs 'w':'x':'c':cs -> "WXC" ++ cs 'w':'x':cs -> firstUpper cs- other -> firstUpper name+ _ -> firstUpper name - firstUpper name- = case name of+ firstUpper name'+ = case name' of c:cs | isLower c -> toUpper c : cs- | not (isUpper c) -> "Wx" ++ name- | otherwise -> name+ | not (isUpper c) -> "Wx" ++ name'+ | otherwise -> name' [] -> "Wx" +haskellUnBuiltinTypeName :: String -> String haskellUnBuiltinTypeName name | isBuiltin name = haskellTypeName name ++ "Object" | otherwise = haskellTypeName name +isBuiltin :: String -> Bool isBuiltin name = Set.member name builtinObjects {----------------------------------------------------------------------------------------- Haddock prologue -----------------------------------------------------------------------------------------}+getPrologue :: String -> String -> String -> [String] -> [String] getPrologue moduleName content contains inputFiles = [line ,"{-|\tModule : " ++ moduleName
src/IOExtra.hs view
@@ -5,21 +5,19 @@ Maintainer : wxhaskell-devel@lists.sourceforge.net - Defines most of the classes in wxWindows.+ Module that writes a string lazily to a file. -} ----------------------------------------------------------------------------------------- module IOExtra( writeFileLazy ) where import Control.Exception import Control.Monad-import System.Directory-import System.Environment import System.IO.Error import qualified System.IO.Strict as Strictly {----------------------------------------------------------------------------------------- Only write to the file if its contents have changed,-e.g. don't change the file's modifed time unless you change the contents.+e.g. don't change the file's modified time, unless you change the contents. -----------------------------------------------------------------------------------------} writeFileLazy :: FilePath -> String -> IO () writeFileLazy f str = fileChanged >>= flip when (writeFile f str)
src/Main.hs view
@@ -7,20 +7,19 @@ Stability : provisional Portability : portable - The program @wxDirect@ generates the @Graphcic.UI.WXH.WXC@ module automatically- from the @wxc.h@ and @ewxc_glue.h@ header files. It is highly dependent on the- format of these header files but generates a very reasonable haskell interface- on top the basic C interface.+ The program @wxDirect@ generates the @Graphics.UI.WXCore.WxcClasses@ module automatically+ from the @wxc.h@ header file and the header files included in it. It is highly dependent on the+ format of these header files, but generates a very reasonable Haskell interface+ on top of the basic C interface. The generation process can easily be tuned by editing the string lists in this file. -} ----------------------------------------------------------------------------------------- module Main where -import Data.List( isPrefixOf )--import System.Environment( getArgs, getEnv )+import System.Environment( getArgs ) import System.Console.GetOpt+import System.FilePath ( pathSeparator ) import CompileClasses ( compileClasses) import CompileHeader ( compileHeader )@@ -33,27 +32,32 @@ {----------------------------------------------------------------------------------------- Main & options -----------------------------------------------------------------------------------------}+main :: IO () main = do mode <- compileOpts case mode of ModeHelp -> showHelp- ModeClasses outputDir inputFiles verbose- -> compileClasses verbose moduleRootWxCore moduleClassTypesName moduleClassesName- (outputDir ++ moduleClassesName) inputFiles- ModeClassTypes outputDir inputFiles verbose- -> compileClassTypes verbose moduleRootWxCore moduleClassTypesName- (outputDir ++ moduleClassTypesName ++ ".hs") inputFiles- ModeClassInfo outputDir verbose- -> compileClassInfo verbose moduleRootWxCore moduleClassesName moduleClassTypesName moduleClassInfoName- (outputDir ++ moduleClassInfoName ++ ".hs")+ ModeClasses outputDir' inputFiles' verbose'+ -> compileClasses verbose' moduleRootWxCore moduleClassTypesName moduleClassesName+ (outputDir' ++ moduleClassesName) inputFiles'+ ModeClassTypes outputDir' inputFiles' verbose'+ -> compileClassTypes verbose' moduleRootWxCore moduleClassTypesName+ (outputDir' ++ moduleClassTypesName ++ ".hs") inputFiles'+ ModeClassInfo outputDir' verbose'+ -> compileClassInfo verbose' moduleRootWxCore moduleClassesName moduleClassTypesName moduleClassInfoName+ (outputDir' ++ moduleClassInfoName ++ ".hs") - ModeCHeader outputDir inputFiles verbose- -> compileHeader verbose (outputDir ++ "wxc_glue.h") inputFiles- ModeSTC outputDir inputFiles verbose- -> compileSTC verbose outputDir inputFiles+ ModeCHeader outputDir' inputFiles' verbose'+ -> compileHeader verbose' (outputDir' ++ "wxc_glue.h") inputFiles'+ ModeSTC outputDir' inputFiles' verbose'+ -> compileSTC verbose' outputDir' inputFiles' -- putStrLn "done." +moduleClassesShortName, moduleClassTypesName, moduleClassesName,+ moduleClassInfoName, moduleDefsName, moduleRootWxCore, + moduleRootWx :: String+ moduleClassesShortName= "Classes" moduleClassTypesName = "WxcClassTypes" moduleClassesName = "WxcClasses"@@ -62,16 +66,20 @@ moduleRootWxCore = "Graphics.UI.WXCore." moduleRootWx = "Graphics.UI.WX." ++moduleRootDir :: String -> FilePath moduleRootDir moduleRoot = map dotToSlash moduleRoot where- dotToSlash c | c == '.' = '/'+ dotToSlash c | c == '.' = pathSeparator | otherwise = c +defaultOutputDirWxh :: FilePath defaultOutputDirWxh = "../wxcore/src/" ++ moduleRootDir moduleRootWxCore +getDefaultFiles :: IO [FilePath] getDefaultFiles = getDefaultHeaderFiles getDefaultHeaderFiles :: IO [FilePath]@@ -84,6 +92,7 @@ = do wxcdir <- getWxcDir return [wxcdir ++ "/wxSTC-D3/stc.h"] +getDefaultOutputDirWxc :: IO FilePath getDefaultOutputDirWxc = do wxcdir <- getWxcDir return (wxcdir ++ "/include/")@@ -100,32 +109,36 @@ data Mode = ModeHelp- | ModeClasses { outputDir :: FilePath, inputFiles :: [FilePath], verbose :: Bool }- | ModeClassTypes{ outputDir :: FilePath, inputFiles :: [FilePath], verbose :: Bool }- | ModeClassInfo { outputDir :: FilePath, verbose :: Bool }- | ModeCHeader { outputDir :: FilePath, inputFiles :: [FilePath], verbose :: Bool }- | ModeSTC { outputDir :: FilePath, inputFiles :: [FilePath], verbose :: Bool }+ | ModeClasses { outputDir :: FilePath, inputFiles :: [FilePath], verbose :: Bool }+ | ModeClassTypes { outputDir :: FilePath, inputFiles :: [FilePath], verbose :: Bool }+ | ModeClassInfo { outputDir :: FilePath, verbose :: Bool }+ | ModeCHeader { outputDir :: FilePath, inputFiles :: [FilePath], verbose :: Bool }+ | ModeSTC { outputDir :: FilePath, inputFiles :: [FilePath], verbose :: Bool } +isHelp :: Flag -> Bool isHelp Help = True isHelp _ = False +isVerbose :: Flag -> Bool isVerbose Verbose = True isVerbose _ = False +isOutput :: Flag -> Bool isOutput (Output _) = True isOutput _ = False +isTarget :: Flag -> Bool isTarget (Target _) = True isTarget _ = False options :: [OptDescr Flag] options = [ Option ['c'] ["classes"] (NoArg (Target TClasses)) "generate class method definitions from .h files"- , Option ['t'] ["classtypes"] (NoArg (Target TClassTypes)) "generate class type definitions from .h files"+ , Option ['t'] ["classtypes"] (NoArg (Target TClassTypes)) "generate class type definitions from .h files" , Option ['i'] ["classinfo"] (NoArg (Target TClassInfo)) "generate class info definitions" , Option ['h'] ["header"] (NoArg (Target THeader)) "generate typed C header file -- development use only"- , Option ['s'] ["stc"] (NoArg (Target TSTC)) "generate wxSTC wrapper from .h file"+ , Option ['s'] ["stc"] (NoArg (Target TSTC)) "generate wxSTC wrapper from .h file" , Option ['v'] ["verbose"] (NoArg Verbose) "verbose: show ignored definitions" , Option ['o'] ["output"] (ReqArg Output "DIR") "optional output directory" , Option ['w'] ["wxc"] (ReqArg WxcDir "DIR") "optional 'wxc' directory (=../wxc)"@@ -143,30 +156,31 @@ else case filter isTarget flags of [] -> invokeError ["you need to specify a target: methods, definitions or classes.\n"] [Target TClassInfo]- -> do outputDir <- getOutputDir flags defaultOutputDirWxh- return (ModeClassInfo outputDir (any isVerbose flags))+ -> do outputDir' <- getOutputDir flags defaultOutputDirWxh+ return (ModeClassInfo outputDir' (any isVerbose flags))+ [Target TClasses] -> do defaultHeaderFiles <- getDefaultHeaderFiles- inputFiles <- getInputFiles ".h" defaultHeaderFiles files- outputDir <- getOutputDir flags defaultOutputDirWxh- return (ModeClasses outputDir inputFiles (any isVerbose flags))+ inputFiles' <- getInputFiles ".h" defaultHeaderFiles files+ outputDir' <- getOutputDir flags defaultOutputDirWxh+ return (ModeClasses outputDir' inputFiles' (any isVerbose flags)) [Target TClassTypes] -> do defaultHeaderFiles <- getDefaultHeaderFiles- inputFiles <- getInputFiles ".h" defaultHeaderFiles files- outputDir <- getOutputDir flags defaultOutputDirWxh- return (ModeClassTypes outputDir inputFiles (any isVerbose flags))+ inputFiles' <- getInputFiles ".h" defaultHeaderFiles files+ outputDir' <- getOutputDir flags defaultOutputDirWxh+ return (ModeClassTypes outputDir' inputFiles' (any isVerbose flags)) [Target THeader] -> do defaultHeaderFiles <- getDefaultHeaderFiles- inputFiles <- getInputFiles ".h" defaultHeaderFiles files- defdir <- getDefaultOutputDirWxc- outputDir <- getOutputDir flags defdir- return (ModeCHeader outputDir inputFiles (any isVerbose flags))+ inputFiles' <- getInputFiles ".h" defaultHeaderFiles files+ defdir <- getDefaultOutputDirWxc+ outputDir' <- getOutputDir flags defdir+ return (ModeCHeader outputDir' inputFiles' (any isVerbose flags)) [Target TSTC] -> do defaultSTCHeaderFile <- getDefaultSTCHeaderFile- inputFiles <- getInputFiles ".h" defaultSTCHeaderFile files- defdir <- getDefaultOutputDirWxc- outputDir <- getOutputDir flags defdir- return (ModeSTC outputDir inputFiles (any isVerbose flags))- other -> invokeError ["invalid, or multiple, targets specification.\n"]+ inputFiles' <- getInputFiles ".h" defaultSTCHeaderFile files+ defdir <- getDefaultOutputDirWxc+ outputDir' <- getOutputDir flags defdir+ return (ModeSTC outputDir' inputFiles' (any isVerbose flags))+ _other -> invokeError ["invalid, or multiple, targets specification.\n"] (_,_,errs) -> invokeError errs where@@ -175,11 +189,11 @@ [] -> do putStrLn ("warning: using default output directory:\n " ++ defaultOutputDir ++ "\n") return defaultOutputDir [Output dir] -> case reverse dir of- [] -> return ""- ('/':cs) -> return dir- ('\\':cs)-> return dir- other -> return (dir ++ "/")- other -> invokeError ["invalid, or multiple, output directories"]+ [] -> return ""+ ('/':_cs) -> return dir+ ('\\':_cs) -> return dir+ _other -> return (dir ++ "/")+ _other -> invokeError ["invalid, or multiple, output directories"] getInputFiles ext defaultFiles files = case filter (hasExt ext) files of@@ -194,8 +208,8 @@ -- wxcdir is set via a global variable (yes, I know, it is an ugly hack :-) extractWxcDir flags = case flags of- (WxcDir dir :fs) -> setWxcDir dir- (other :fs) -> extractWxcDir fs+ (WxcDir dir :_fs) -> setWxcDir dir+ (_other :fs) -> extractWxcDir fs [] -> return ()
− src/MultiSet.hs
@@ -1,421 +0,0 @@----------------------------------------------------------------------------------{-| 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.foldrWithKey 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.foldrWithKey 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
@@ -14,47 +14,55 @@ import Data.Char( isSpace ) import Data.List( isPrefixOf )+import Data.Functor( (<$>) )+import System.Process( readProcess ) import Text.ParserCombinators.Parsec import qualified Text.ParserCombinators.Parsec.Token as P import Text.ParserCombinators.Parsec.Language import Types + {----------------------------------------------------------------------------------------- Parse C -----------------------------------------------------------------------------------------} parseC :: FilePath -> IO [Decl] parseC fname- = do lines <- readHeaderFile fname- declss <- mapM (parseDecl fname) (pairComments lines)- -- putStrLn ("ok.")+ = do contents <- readHeaderFile fname+ declss <- mapM (parseDecl fname) (pairComments contents) 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+readHeaderFile :: FilePath -> IO [String]+readHeaderFile fname =+ do+ includeDirectories <- getIncludeDirectories+ putStrLn ("Preprocessing and parsing file: " ++ fname ++ + ",\n using include directories: " ++ (unwords includeDirectories)) + flattenComments . filter (not . isPrefixOf "#") . lines <$>+ readProcess + "cpp"+ ( includeDirectories ++ + [ "-C" -- Keep the comments+ , "-DWXC_TYPES_H" -- Make sure wxc_types.h is not included, + -- so the type macros are not replaced + -- (the parser scans for certain macros)+ , fname -- The file to process+ ]+ )+ "" - readIncludeFile line- = return [line]- +getIncludeDirectories :: IO [String]+getIncludeDirectories = + filter (isPrefixOf "-I") . words <$> + readProcess "wx-config" ["--cppflags"] ""+ + -- flaky, but suitable flattenComments :: [String] -> [String]-flattenComments lines- = case lines of- (('/':'*':xs):xss) -> let (incomment,comment:rest) = span (not . endsComment) lines+flattenComments inputLines+ = case inputLines of+ (('/':'*':_):_) -> let (incomment,comment:rest) = span (not . endsComment) inputLines in (concat (incomment ++ [comment]) : flattenComments rest) xs : xss -> xs : flattenComments xss [] -> []@@ -63,8 +71,8 @@ pairComments :: [String] -> [(String,String)]-pairComments lines- = case lines of+pairComments inputLines+ = case inputLines of ('/':'*':'*':xs) : ys : xss | not (classDef ys) -> (reverse (drop 2 (reverse xs)),ys) : pairComments xss xs : xss | not (classDef xs) -> ("",xs) : pairComments xss | otherwise -> pairComments xss@@ -96,12 +104,12 @@ pfundecl :: Parser Decl pfundecl = do optional (reserved "EXPORT")- declRet <- ptype+ declRet' <- ptype optional (reserved "_stdcall" <|> reserved "__cdecl")- declName <- identifier <?> "function name"- declArgs <- pargs- semi- return (Decl declName declRet declArgs "")+ declName' <- identifier <?> "function name"+ declArgs' <- pargs+ _ <- semi+ return (Decl declName' declRet' declArgs' "") <?> "function declaration" pargs :: Parser [Arg]@@ -112,16 +120,16 @@ parg :: Parser Arg parg = pargTypes- <|> do argType <- ptype- argName <- identifier- return (Arg [argName] argType)+ <|> 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)+ return (foldr (\_ tp' -> Ptr tp') tp stars) <?> "type" patomtype :: Parser Type@@ -134,6 +142,12 @@ <|> do reserved "float"; return Float <|> do reserved "size_t"; return (Int SizeT) <|> do reserved "time_t"; return (Int TimeT)+ <|> do reserved "uint8_t"; return Word8+ <|> do reserved "uint32_t"; return Word32+ <|> do reserved "uint64_t"; return Word64+ <|> do reserved "intptr_t"; return IntPtr+ <|> do reserved "int64_t"; return Int64+ <|> do reserved "TIntPtr"; return IntPtr <|> do reserved "TInt64"; return Int64 <|> do reserved "TUInt"; return Word <|> do reserved "TUInt8"; return Word8@@ -154,7 +168,9 @@ <|> do reserved "TArrayStringOut"; return (ArrayStringOut CChar) <|> do reserved "TArrayStringOutVoid"; return (ArrayStringOut CVoid) <|> do reserved "TArrayIntOut"; return (ArrayIntOut CInt)+ <|> do reserved "TArrayIntPtrOut"; return (ArrayIntPtrOut CInt) <|> do reserved "TArrayIntOutVoid"; return (ArrayIntOut CVoid)+ <|> do reserved "TArrayIntPtrOutVoid"; return (ArrayIntPtrOut CVoid) <|> do reserved "TClosureFun"; return (Fun "Ptr fun -> Ptr state -> Ptr (TEvent evt) -> IO ()") <|> do reserved "TClass" name <- parens identifier@@ -188,38 +204,42 @@ return (Arg argnames tp) <|> do reserved "TArrayObject"- parens (do n <- identifier- comma+ parens (do n <- identifier+ _ <- comma tp <- identifier- comma- p <- identifier+ _ <- comma+ p <- identifier return (Arg [n,p] (ArrayObject tp CVoid))) +pargs2 :: Parser [String] pargs2 = do a1 <- identifier- comma+ _ <- comma a2 <- identifier return [a1,a2] +pargs3 :: Parser [String] pargs3 = do a1 <- identifier- comma+ _ <- comma a2 <- identifier- comma+ _ <- comma a3 <- identifier return [a1,a2,a3] +pargs4 :: Parser [String] pargs4 = do a1 <- identifier- comma+ _ <- comma a2 <- identifier- comma+ _ <- comma a3 <- identifier- comma+ _ <- comma a4 <- identifier return [a1,a2,a3,a4] +pargType2 :: Parser Type pargType2 = do reserved "TPoint"; return (Point CInt) <|> do reserved "TSize"; return (Size CInt)@@ -239,12 +259,15 @@ <|> do reserved "TVectorOutVoid"; return (VectorOut CVoid) <|> do reserved "TArrayString"; return (ArrayString CChar) <|> do reserved "TArrayInt"; return (ArrayInt CInt)+ <|> do reserved "TArrayIntPtr"; return (ArrayIntPtr CInt) <|> do reserved "TByteString"; return (ByteString Strict) <|> do reserved "TByteStringLazy"; return (ByteString Lazy) +pargType3 :: Parser Type pargType3 = do reserved "TColorRGB"; return (ColorRGB CChar) +pargType4 :: Parser Type pargType4 = do reserved "TRect"; return (Rect CInt) <|> do reserved "TRectDouble"; return (Rect CDouble)@@ -269,6 +292,7 @@ , caseSensitive = True , reservedNames = ["void","int","long","float","double","char","size_t","time_t","_stdcall","__cdecl" ,"TChar","TBool"+ ,"TIntPtr" ,"TClass","TSelf","TClassRef" ,"TByteData","TByteString","TByteStringOut","TByteStringLen" ,"TString","TStringOut","TStringLen", "TStringVoid"@@ -284,12 +308,26 @@ ] } +whiteSpace :: Parser () whiteSpace = P.whiteSpace lexer-lexeme = P.lexeme lexer++symbol :: String -> Parser String symbol = P.symbol lexer++parens :: Parser a -> Parser a parens = P.parens lexer++semi :: Parser String semi = P.semi lexer++comma :: Parser String comma = P.comma lexer++commaSep :: Parser a -> Parser [a] commaSep = P.commaSep lexer++identifier :: Parser String identifier = P.identifier lexer++reserved :: String -> Parser () reserved = P.reserved lexer
src/Types.hs view
@@ -22,27 +22,34 @@ {----------------------------------------------------------------------------------------- Tracing -----------------------------------------------------------------------------------------}+trace :: String -> t -> t trace s x = seq (unsafePerformIO (putStrLn s)) x +traceIgnore :: [Char] -> Decl -> t -> t traceIgnore msg decl x = trace ("ignore: " ++ fill 12 msg ++ ": " ++ declName decl) x where- fill n s | length s >= 12 = s- | otherwise = s ++ replicate (12 - length s) ' '+ fill :: Int -> String -> String+ fill n s | length s >= n = s+ | otherwise = s ++ replicate (n - length s) ' ' +traceWarning :: [Char] -> Decl -> t -> t traceWarning msg decl x = trace ("****************************************************\n" ++ "warning : " ++ msg ++ ": " ++ declName decl) x +traceError :: [Char] -> Decl -> t -> t traceError msg decl x = trace ("****************************************************\n" ++ "error : " ++ msg ++ ": " ++ declName decl) x +errorMsg :: [Char] -> t errorMsg str = error ("error: " ++ str) +errorMsgDecl :: Decl -> [Char] -> t errorMsgDecl decl str = errorMsg (str ++ " in " ++ declName decl ++ ": " ++ show decl) @@ -79,10 +86,12 @@ = concat (argNames arg) data Type = Int CBaseType+ | IntPtr | Int64 | Word | Word8 | Word32+ | Word64 | Void | Char | Double@@ -104,11 +113,13 @@ | ArrayLen | ArrayStringOut CBaseType | ArrayIntOut CBaseType+ | ArrayIntPtrOut CBaseType | ArrayObjectOut String CBaseType -- derived types | Object String | String CBaseType | ArrayInt CBaseType+ | ArrayIntPtr CBaseType | ArrayString CBaseType | ArrayObject String CBaseType | Bool
wxdirect.cabal view
@@ -1,5 +1,5 @@ name: wxdirect-version: 0.90.0.1+version: 0.90.1.0 license: BSD3 license-file: LICENSE author: Daan Leijen@@ -24,20 +24,9 @@ hs-source-dirs: src - if flag(splitBase)- build-depends:- base >= 4 && < 5- else- build-depends:- base >= 3 && < 4- exposed-modules: Application.Wxdirect - ghc-options: -Wall- if impl(ghc >= 6.8)- ghc-options: -fwarn-tabs- executable wxdirect main-is: Main.hs @@ -50,7 +39,6 @@ , DeriveTypes , HaskellNames , IOExtra- , MultiSet , ParseC , Types @@ -61,17 +49,19 @@ directory, parsec >= 2.1.0 && < 4, strict,- time >= 1.0 && < 1.5+ time >= 1.0 && < 1.5,+ filepath < 1.4,+ process >= 1.1 && < 1.2 if flag(splitBase) build-depends: base >= 4 && < 5,- containers >= 0.2 && < 0.5+ containers >= 0.2 && < 0.6 else build-depends: base >= 3 && < 4, containers >= 0.1 && < 0.3 --- ghc-options: -Wall+ ghc-options: -Wall -O2 if impl(ghc >= 6.8) ghc-options: -fwarn-tabs