cgen (empty) → 0.0.1
raw patch · 14 files changed
+2267/−0 lines, 14 filesdep +basedep +containersdep +directorysetup-changed
Dependencies added: base, containers, directory, filepath, mtl, parsec, regex-posix, safe, template-haskell
Files
- LICENSE +30/−0
- Setup.hs +3/−0
- cgen.cabal +81/−0
- src/CgenHs.hs +72/−0
- src/CppGen.hs +385/−0
- src/CppUtils.hs +151/−0
- src/DeriveMod.hs +109/−0
- src/GrGen.hs +92/−0
- src/HaskellGen.hs +463/−0
- src/HeaderData.hs +156/−0
- src/HeaderParser.hs +492/−0
- src/Main.hs +136/−0
- src/Options.hs +34/−0
- src/Utils.hs +63/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Antti Salonen 2010++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of the copyright holders, nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ cgen.cabal view
@@ -0,0 +1,81 @@+-- cgen.cabal auto-generated by cabal init. For additional options,+-- see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+Name: cgen+Version: 0.0.1+Synopsis: generates Haskell bindings and C wrappers for C++ libraries+Description: cgen parses C++ headers and generates C wrappers and + Haskell bindings to a C++ library.+License: BSD3+License-file: LICENSE+Author: Antti Salonen+Maintainer: ajsalonen at gmail dot com+Copyright: (c) 2010 Antti Salonen+Stability: Experimental+Category: Development+Build-type: Simple+Homepage: http://anttisalonen.github.com/cgen+Bug-reports: http://github.com/anttisalonen/cgen/issues+Extra-source-files: src/HeaderParser.hs, + src/CppGen.hs, + src/DeriveMod.hs, + src/HaskellGen.hs, + src/HeaderData.hs, + src/CppUtils.hs,+ src/Options.hs,+ src/Utils.hs+Cabal-version: >=1.6++Executable cgen+ Main-is: Main.hs+ Hs-Source-Dirs: src+ Build-depends: base > 3 && < 5,+ parsec>=3.1.0,+ containers>=0.3.0.0,+ mtl>=1.1.0.0,+ filepath>=1.1.0.0,+ directory>=1.0.0.0,+ safe>=0.2,+ regex-posix>=0.91,+ template-haskell+ Ghc-options: -Wall -fno-warn-missing-signatures+ -fno-warn-unused-binds+ -fno-warn-unused-do-bind+ -- Build-tools: ++Executable cgen-hs+ Main-is: CgenHs.hs+ Hs-Source-Dirs: src+ Build-depends: base > 3 && < 5,+ parsec>=3.1.0,+ containers>=0.3.0.0,+ mtl>=1.1.0.0,+ filepath>=1.1.0.0,+ directory>=1.0.0.0,+ safe>=0.2,+ regex-posix>=0.91,+ template-haskell+ Ghc-options: -Wall -fno-warn-missing-signatures+ -fno-warn-unused-binds+ -fno-warn-unused-do-bind++Executable grgen+ Main-is: GrGen.hs+ Hs-Source-Dirs: src+ Build-depends: base > 3 && < 5,+ parsec>=3.1.0,+ containers>=0.3.0.0,+ mtl>=1.1.0.0,+ filepath>=1.1.0.0,+ directory>=1.0.0.0,+ safe>=0.2,+ regex-posix>=0.91,+ template-haskell+ Ghc-options: -Wall -fno-warn-missing-signatures+ -fno-warn-unused-binds+ -fno-warn-unused-do-bind++Source-repository head+ type: git+ location: git://github.com/anttisalonen/cgen.git+
+ src/CgenHs.hs view
@@ -0,0 +1,72 @@+module Main+where++import System.Environment+import System.Exit+import System.Console.GetOpt+import System.FilePath+import System.Directory+import Data.Either+import Data.List+import Control.Monad+import Control.Monad.State++import HeaderParser+import HaskellGen+import Options++options :: [OptDescr (Options -> Options)]+options = [+ Option ['o'] ["output"] (ReqArg (setOutputdir) "directory") "output directory for the Haskell files"+ , Option ['u'] ["umbrella"] (ReqArg (setUmbrellamodule) "module name") "name of umbrella module to create"+ , Option [] ["interface"] (ReqArg (setInterfacefile) "file") "define input interface file for Haskell"+ , Option [] ["inherit"] (ReqArg (setInheritfile) "file") "define class inheritance file"+ , Option [] ["exclude"] (ReqArg (\l -> modExcludepatterns (l:)) "expression") "exclude pattern for function names"+ , Option ['h'] ["hierarchy"] (ReqArg (setHierarchy) "hierarchy") "dot-separated hierarchy for the modules, e.g. \"Foo.Bar.\"."+ ]++main :: IO ()+main = do + args <- getArgs+ let (actions, rest, errs) = getOpt Permute options args+ when (not (null errs) || null rest) $ do+ mapM_ putStrLn errs+ pr <- getProgName+ putStrLn $ usageInfo ("Usage: " ++ pr ++ " <options> <C/C++ header files>") options+ exitWith (ExitFailure 1)+ let prevopts = foldl' (flip ($)) defaultOptions actions+ opts <- handleInterfaceFile (interfacefile prevopts) None handleOptionsLine prevopts+ handleHaskell opts rest+ exitWith ExitSuccess++data InterfaceState = None | Exclude | DefaultIn | DefaultOut | InParam | OutParam+ deriving (Eq)++handleOptionsLine :: String -> State InterfaceState (Options -> Options)+handleOptionsLine = + processor None + [(Exclude, \n -> modExcludepatterns (n:))+ ,(DefaultIn, \n -> modDefaultins (n:))+ ,(DefaultOut, \n -> modDefaultouts (n:))+ ,(InParam, \n -> modInparameters (n:))+ ,(OutParam, \n -> modOutparameters (n:))]+ [("@exclude", Exclude)+ ,("@default-in", DefaultIn)+ ,("@default-out", DefaultOut)+ ,("@in-param", InParam)+ ,("@out-param", OutParam)]++handleHaskell :: Options -> [FilePath] -> IO ()+handleHaskell opts filenames = do+ gencontents <- mapM readFile filenames+ let genparses = map parseHeader gencontents+ (genperrs, genpress) = partitionEithers genparses+ case genperrs of+ ((str, err):_) -> do+ putStrLn str+ putStrLn $ "Could not parse generated file (!): " ++ show err+ exitWith (ExitFailure 2)+ [] -> do+ createDirectoryIfMissing True (outputdir opts)+ haskellGen opts $ zip (map takeFileName filenames) genpress+
+ src/CppGen.hs view
@@ -0,0 +1,385 @@+module CppGen(handleHeader)+where++import System.FilePath+import System.IO+import Data.List+import Data.Maybe+import Control.Monad+import Text.Printf+import qualified Data.Set as S++import Text.Regex.Posix+import Safe++import HeaderData+import CppUtils+import Utils++publicMemberFunction :: Object -> Bool+publicMemberFunction (FunDecl _ _ _ _ (Just (Public, _)) _ _) = True+publicMemberFunction _ = False++showP (ParamDecl pn pt _ _) = pt ++ " " ++ pn++paramFormat :: [ParamDecl] -> String+paramFormat (p1:p2:ps) = showP p1 ++ ", " ++ paramFormat (p2:ps)+paramFormat [p1] = showP p1+paramFormat [] = ""++correctParam :: ParamDecl -> ParamDecl+correctParam p = p{vartype = correctType (vartype p)} -- TODO: arrays?++refToPointerParam :: ParamDecl -> ParamDecl+refToPointerParam p = p{vartype = refToPointer (vartype p)}++refToPointer :: String -> String+refToPointer t = + if last t == '&'+ then init t ++ "*"+ else t++handleHeader :: FilePath -> [FilePath] -> [String] -> [String] -> [(String, String)] -> FilePath -> [Object] -> IO ()+handleHeader outdir incfiles exclclasses excls rens headername objs = do+ withFile outfile WriteMode $ \h -> do+ hPrintf h "#ifndef CGEN_%s_H\n" (toCapital (takeBaseName headername))+ hPrintf h "#define CGEN_%s_H\n" (toCapital (takeBaseName headername))+ hPrintf h "\n"+ forM_ incfiles $ \inc -> do+ hPrintf h "#include <%s>\n" inc+ hPrintf h "\n"+ hPrintf h "extern \"C\"\n"+ hPrintf h "{\n"+ hPrintf h "\n"+ forM_ namespaces $ \ns -> do+ hPrintf h "using namespace %s;\n" ns+ hPrintf h "\n"+ forM_ typedefs $ \(td1, td2) -> do+ hPrintf h "typedef %s %s;\n" td1 td2+ hPrintf h "\n\n"+ hPrintf h "#ifdef CGEN_HS\n"+ forM_ (getEnums objs) $ \enum -> do+ hPutStrLn h $ enumDeclaration (enumname enum) (enumvalues enum)+ hPrintf h "#endif\n\n"++ forM_ funs $ \fun -> do+ hPutStrLn h $ funDeclaration (funname fun) (rettype fun) (paramFormat (params fun))+ hPrintf h "\n"+ hPrintf h "}\n"+ hPrintf h "\n"+ hPrintf h "#endif\n"+ hPrintf h "\n"+ hPutStrLn stderr $ "Wrote file " ++ outfile++ withFile cppoutfile WriteMode $ \h -> do+ hPrintf h "#define CGEN_OUTPUT_INTERN\n"+ hPrintf h "#include \"%s\"" headername+ hPrintf h "\n"+ forM_ (zip funs allfuns) $ \(fun, origfun) -> do+ hPrintf h "%s %s(%s)\n" + (stripStatic $ rettype fun)+ (funname fun)+ (paramFormat (params fun))+ hPrintf h "{\n"+ -- NOTE: do NOT call refToPointerParam or refParamsToPointers+ -- for prs, because then the information that the parameter+ -- is actually a reference and the pointer must be dereferenced+ -- is lost.+ let prs = intercalate ", " $ map (correctRef . renameParam rens) $ params $ correctFuncParams origfun+ switch (funname origfun)+ [(getClname origfun, hPrintf h " return new %s(%s);\n" (stripStatic $ stripExtra $ rettype fun) prs),+ ('~':getClname origfun, hPrintf h " delete this_ptr;\n")]+ (hPutStrLn h $ funDefinition (funname origfun) (rettype fun) (getClname origfun) prs)+ hPrintf h "}\n"+ hPrintf h "\n"+ hPutStrLn stderr $ "Wrote file " ++ cppoutfile++ where outfile = (outdir </> headername)+ cppoutfile = (outdir </> takeBaseName headername <.> "cpp")+ allfuns = implicitcdtors ++ filter (\f -> publicMemberFunction f && + not (excludeFun f) && + not (abstractConstructor classes f)) (getFuns objs)+ implicitcdtors = concatMap getImplicitCDtor classes+ namespaces = filter (not . null) $ nub $ map (headDef "") (map fnnamespace funs)+ -- list of names of all parsed classes+ classnames = filter (not . null) $ nub $ map getObjName $ getClasses objs+ classes = concatMap (\nm -> filter (classHasName nm) (getClasses objs)) classnames+ alltypedefs = catMaybes $ map getTypedef (map snd $ concatMap classobjects classes)+ -- typedefs used in function parameter and return types+ usedtypedefs = usedTypedefs usedtypes alltypedefs+ extratypedefs = extraTypedefs usedtypedefs alltypedefs+ -- NOTE: can't just use only public typedefs, because they sometimes depend on + -- protected typedefs, so include them as well (so-called secondary typedefs).+ typedefs = nub $ extratypedefs ++ usedtypedefs+ allenums = map snd $ filter (\(v, o) -> isEnum o && v == Public) $ concatMap classobjects classes+ funs = mangle $ map expandFun allfuns+ excludeFun f = lastDef ' ' (correctType $ rettype f) == '&' || -- TODO: allow returned references+ or (map (\e -> funname f =~ e) excls) ||+ or (map (\e -> fromMaybe "" (liftM snd (fnvisibility f)) =~ e) exclclasses) ||+ take 8 (rettype f) == "template" || -- TODO: allow return types that start with "template"+ rettype f == "operator" || -- conversion operator is parsed as operator as return type+ take 8 (funname f) == "operator" -- TODO: allow normal functions with name starting with operator+ expandFun f = addConstness . -- add const keyword if the function is const+ refParamsToPointers . -- ref params to pointers+ renameTypes rens . -- rename types as specified by user+ addClassspaces allenums classes . -- add qualification when necessary+ correctFuncRetType . -- remove keywords from return type+ correctFuncParams . -- create param name if none, remove keywords+ finalName . -- expand function name by class and namespace+ addThisPointer . -- 1st parameter+ extendFunc $ f -- constructor & destructor handling+ usedtypes = getAllTypes funs++getImplicitCDtor :: Object -> [Object]+getImplicitCDtor c@(ClassDecl cname _ _ cns objs)+ | null $ filter (not . isAbstractFun) $ getFuns . map snd . filter (\(p, _) -> p == Public) $ objs+ = [] -- forward declaration or abstract+ | not (publicClass c)+ = [] + | abstractClass c+ = [] + | otherwise+ = dl ++ cl+ where dl = if any isDestructor (map snd objs) -- explicit destructor+ then []+ else [FunDecl ('~':cname) "void" [] cns (Just (Public, cname)) False False]+ cl = if any isConstructor (map snd objs) -- explicit constructor+ then []+ else [FunDecl cname "" [] cns (Just (Public, cname)) False False]+getImplicitCDtor _ = []++isConstructor :: Object -> Bool+isConstructor (FunDecl fname _ _ _ (Just (_, cname)) _ _) = fname == cname+isConstructor _ = False++isDestructor :: Object -> Bool+isDestructor (FunDecl fname _ _ _ (Just (_, cname)) _ _) = fname == '~':cname+isDestructor _ = False++funDefinition :: String -> String -> String -> String -> String+funDefinition fnname rttype clname fnparams+ | rttype == "void" + = printf " this_ptr->%s(%s);" fnname fnparams+ | isStatic rttype && stripStatic rttype == "void" + = printf " %s::%s(%s);" clname fnname fnparams+ | isStatic rttype + = printf " return %s::%s(%s);" clname fnname fnparams+ | otherwise + = printf " return this_ptr->%s(%s);" fnname fnparams++funDeclaration :: String -> String -> String -> String+funDeclaration fnname rttype fnparams =+ printf "%s %s(%s);" (stripStatic rttype) fnname fnparams++enumDeclaration :: String -> [EnumVal] -> String+enumDeclaration ename evalues = + if not (enumReadable evalues) then "" else printf "enum %s {\n %s\n};\n\n" ename vals+ where vals = intercalate ",\n " (map printEnumval (getEnumValues evalues))++printEnumval :: (String, Int) -> String +printEnumval (n, v) = printf "%s = %d" n v++refParamsToPointers f@(FunDecl _ _ ps _ _ _ _) =+ f{params = map refToPointerParam ps}+refParamsToPointers n = n++renameTypes :: [(String, String)] -> Object -> Object+renameTypes rens f@(FunDecl _ rt ps _ _ _ _) =+ f{rettype = renameType rens rt,+ params = map (renameParam rens) ps}+renameTypes _ n = n++renameParam :: [(String, String)] -> ParamDecl -> ParamDecl+renameParam rens p@(ParamDecl _ pt _ _) =+ p{vartype = renameType rens pt}++renameType :: [(String, String)] -> String -> String+renameType rens t =+ let mnt = lookup tm rens+ tm = stripStatic $ stripExtra t+ mf1 = if isConst t then makeConst else id+ mf2 = makePtr (isPtr t)+ in case mnt of+ Nothing -> if '<' `elem` t && '>' `elem` t+ then handleTemplateTypes rens t+ else t+ Just t' -> if isStatic (stripExtra t)+ then "static " ++ ((mf1 . mf2) t')+ else (mf1 . mf2) t'++handleTemplateTypes :: [(String, String)] -> String -> String+handleTemplateTypes rens t = + let alltypes = typesInType t+ newtypes = map (renameType rens) alltypes+ in foldr (uncurry replace) t (zip alltypes newtypes)++makeConst :: String -> String+makeConst n = "const " ++ n++makePtr :: Int -> String -> String+makePtr num t = t ++ replicate num '*'++abstractConstructor :: [Object] -> Object -> Bool+abstractConstructor classes (FunDecl fn _ _ _ (Just (_, _)) _ _) =+ case fetchClass classes fn of+ Nothing -> False+ Just cl -> any isAbstractFun (map snd $ classobjects cl)+abstractConstructor _ _ = False++-- typesInType "const int" = ["int"]+-- typesInType "map<String, Animation*>::type" = ["String", "Animation"]+typesInType :: String -> [String]+typesInType v =+ case betweenAngBrackets v of+ "" -> [stripExtra v]+ n -> map stripExtra $ splitBy ',' n++-- all typedefs whose definition depends on another typedef.+extraTypedefs :: [(String, String)] -> [(String, String)] -> [(String, String)]+extraTypedefs usedts allts = + case filter (extractSecType usedts) allts of+ [] -> []+ -- NOTE: the order here is significant for the dependencies+ -- between the typedefs.+ newusedts -> extraTypedefs newusedts allts ++ newusedts++-- whether any of the types in the snd of the tuple is contained in+-- any of the fsts of the list.+extractSecType :: [(String, String)] -> (String, String) -> Bool+extractSecType ts (_, t2) = + let sectypes = typesInType t2+ tsstypes = concatMap typesInType (map fst ts)+ in (any (`elem` tsstypes) sectypes)++-- for all types of a function, turn "y" into "x::y" when y is a nested class inside x.+addClassspaces :: [Object] -> [Object] -> Object -> Object+addClassspaces enums classes f@(FunDecl _ rt ps _ _ _ _) =+ let rt' = addClassQual enums classes rt+ ps' = map (addParamClassQual enums classes) ps+ in f{rettype = rt',+ params = ps'}+addClassspaces _ _ n = n++addParamClassQual :: [Object] -> [Object] -> ParamDecl -> ParamDecl+addParamClassQual enums classes p@(ParamDecl _ t _ _) =+ let t' = addClassQual enums classes t+ in p{vartype = t'}++-- add class qualification to rt, if a class named rt is found.+-- the qualification added is the class nesting of the found class.+addClassQual :: [Object] -> [Object] -> String -> String+addClassQual enums classes rt =+ case fetchClass classes (stripStatic $ stripExtra rt) of+ Nothing -> case fetchEnum enums (stripStatic $ stripExtra rt) of+ Nothing -> rt+ Just e -> addNamespaceQual (map snd $ enumclassnesting e) rt+ Just c -> addNamespaceQual (map snd $ classnesting c) rt++-- addNamespaceQual ["aa", "bb"] "foo" = "bb::aa::foo"+-- addNamespaceQual ["aa", "bb"] "static foo" = "static bb::aa::foo"+addNamespaceQual :: [String] -> String -> String+addNamespaceQual ns n+ | isStatic n = "static " ++ addNamespaceQual ns (stripStatic n)+ | otherwise = concatMap (++ "::") ns ++ n++-- turn a "char& param" into "*param".+correctRef :: ParamDecl -> String+correctRef (ParamDecl nm pt _ _) =+ if '&' `elem` take 2 (reverse pt)+ then '*':nm+ else nm++-- separate pointer * from other chars for all params.+-- if param has no name, create one.+-- remove keywords such as virtual, etc.+correctFuncParams :: Object -> Object+correctFuncParams f@(FunDecl _ _ ps _ _ _ _) = + f{params = checkParamNames (map (correctParam) ps)}+correctFuncParams n = n++-- for each unnamed parameter,+-- create a parameter name of (type) ++ running index.+checkParamNames :: [ParamDecl] -> [ParamDecl]+checkParamNames = go (1 :: Int)+ where go _ [] = []+ go n (p:ps) =+ let (p', n') = case varname p of+ "" -> (p{varname = (stripStatic $ stripExtra $ vartype p) ++ (show n)}, n + 1)+ _ -> (p, n)+ in p':(go n' ps)++-- expand function name by namespace and class name.+finalName :: Object -> Object+finalName f@(FunDecl fname _ _ funns _ _ _) =+ let clname = getClname f+ nsname = headDef "" funns+ updname = nsname ++ (if not (null nsname) then "_" else "") ++ + clname ++ (if not (null clname) then "_" else "") ++ fname+ in f{funname = updname}+finalName n = n++constructorName, destructorName :: String+constructorName = "new"+destructorName = "delete"++addThisPointer :: Object -> Object+addThisPointer f@(FunDecl fname rttype ps _ (Just (_, clname)) _ _)+ | fname == constructorName = f+ | isStatic rttype = f+ | otherwise+ = f{params = (t:ps)}+ where t = ParamDecl this_ptrName (clname ++ "*") Nothing Nothing+addThisPointer n = n++this_ptrName = "this_ptr"++-- correct constructors and destructors.+extendFunc :: Object -> Object+extendFunc f@(FunDecl fname _ _ _ (Just (_, clname)) _ _) + | fname == clname = f{funname = constructorName,+ rettype = fname ++ " *"}+ | fname == '~':clname = f{funname = destructorName,+ rettype = "void"}+ | otherwise = f+extendFunc n = n++-- const keyword to return value and this_ptr if needed.+addConstness :: Object -> Object+addConstness f@(FunDecl _ fr ps _ _ constfunc _)+ = f{rettype = cident fr,+ params = map cidentP ps}+ where cident v = if not (isConst v) && + constfunc && + '*' `elem` v + then "const " ++ v + else v+ cidentP p = let n = if not (isConst (varname p)) &&+ constfunc && + varname p == this_ptrName+ then "const " ++ vartype p+ else vartype p+ in p{vartype = n}+addConstness n = n++-- filtering typedefs doesn't help - t1 may refer to private definitions.+usedTypedefs :: S.Set String -> [(String, String)] -> [(String, String)]+usedTypedefs s = filter (\(_, t2) -> t2 `S.member` s)++-- separate pointer * from other chars in function return type.+-- remove keywords such as virtual, etc.+correctFuncRetType :: Object -> Object+correctFuncRetType f@(FunDecl _ fr _ _ _ _ _)+ = f{rettype = correctType fr}+correctFuncRetType n = n++-- o(n^2).+-- simply adds a number at the end of the overloaded function name.+mangle :: [Object] -> [Object]+mangle [] = []+mangle (n:ns) = + let num = length $ filter (== funname n) $ map funname ns+ m = n{funname = funname n ++ show num}+ in if num == 0+ then n : mangle ns+ else m : mangle ns+
+ src/CppUtils.hs view
@@ -0,0 +1,151 @@+module CppUtils+where++import Data.List+import Control.Monad.State++import qualified Data.Set as S++import HeaderData+import Utils++isType :: String -> Bool+isType "virtual" = False+isType "enum" = False+isType "mutable" = False+isType "struct" = False+isType "union" = False+isType "inline" = False+isType _ = True++combChars :: String -> [String] -> [String]+combChars st = map (combChar st)++combChar :: String -> String -> String+combChar st (x:y:xs)+ | x == ' ' && y == ' ' = combChar st xs+ | x == ' ' && y `elem` st = y : combChar st xs+ | otherwise = x : combChar st (y:xs)+combChar _ " " = ""+combChar _ l = l++-- separate pointer * and ref & from other chars.+-- remove keywords such as virtual, static, etc.+correctType :: String -> String+correctType t =+ let ns = words t+ in case ns of+ [] -> ""+ ms -> combChar "*&" $ intercalate " " $ filter isType ms++isStatic :: String -> Bool+isStatic n = take 7 n == "static "++isConst :: String -> Bool+isConst n = take 6 n == "const "++stripStatic :: String -> String+stripStatic n | isStatic n = drop 7 n+ | otherwise = n++stripExtra :: String -> String+stripExtra = stripConst . stripRef . stripPtr++stripChar :: Char -> String -> String+stripChar c = stripWhitespace . takeWhile (/= c)++-- stripPtr " char * " = "char"+stripPtr :: String -> String+stripPtr = stripChar '*'++stripRef :: String -> String+stripRef = stripChar '&'++stripConst :: String -> String+stripConst n | isConst n = stripWhitespace $ drop 5 n + | otherwise = n++getAllTypes :: [Object] -> S.Set String+getAllTypes = S.fromList . map (stripConst . stripPtr) . concatMap getUsedFunTypes++getAllTypesWithPtr :: [Object] -> S.Set String+getAllTypesWithPtr = S.fromList . map (correctType . stripConst) . concatMap getUsedFunTypes++-- "aaa < bbb, ddd> fff" = " bbb, ddd"+betweenAngBrackets :: String -> String+betweenAngBrackets = fst . foldr go ("", Nothing)+ where go _ (accs, Just True) = (accs, Just True) -- done+ go '>' (accs, Nothing) = (accs, Just False) -- start+ go '<' (accs, Just False) = (accs, Just True) -- finish+ go c (accs, Just False) = (c:accs, Just False) -- collect+ go _ (accs, Nothing) = (accs, Nothing) -- continue++isTemplate :: String -> Bool+isTemplate = not . null . betweenAngBrackets++isPtr :: String -> Int+isPtr = length . filter (=='*') . dropWhile (/= '*')++isStdType "float" = True+isStdType "double" = True+isStdType "char" = True+isStdType "int" = True+isStdType "unsigned int" = True+isStdType "signed int" = True+isStdType "long" = True+isStdType "unsigned long" = True+isStdType "signed long" = True+isStdType "bool" = True+isStdType "short" = True+isStdType "unsigned short" = True+isStdType "signed short" = True+isStdType "unsigned" = True+isStdType "long long" = True+isStdType "unsigned long long" = True+isStdType "int8_t" = True+isStdType "uint8_t" = True+isStdType "int16_t" = True+isStdType "uint16_t" = True+isStdType "int32_t" = True+isStdType "uint32_t" = True+isStdType "int64_t" = True+isStdType "uint64_t" = True+isStdType "size_t" = True+isStdType "uint8" = True+isStdType "uint16" = True+isStdType "uint32" = True+isStdType "uint64" = True+isStdType _ = False++getEnumValues :: [EnumVal] -> [(String, Int)]+getEnumValues es = evalState go 0+ where go :: State Int [(String, Int)]+ go = mapM f es+ f :: EnumVal -> State Int (String, Int)+ f (EnumVal en ev) = do+ oldval <- get+ let thisval = case ev of+ Nothing -> oldval+ Just m -> case reads m of+ [(v, _)] -> v+ _ -> oldval+ put $ thisval + 1+ return (en, thisval)++enumReadable :: [EnumVal] -> Bool+enumReadable = all valid . map enumvalue+ where valid Nothing = True+ valid (Just n) = case (reads :: String -> [(Int, String)]) n of+ [(_, [])] -> True+ _ -> False++publicClass :: Object -> Bool+publicClass (ClassDecl _ _ nest _ _) =+ all (== Public) $ map fst nest+publicClass _ = False++abstractClass :: Object -> Bool+abstractClass (ClassDecl _ _ _ _ objs) =+ any isAbstractFun (map snd objs)+abstractClass _ = False+
+ src/DeriveMod.hs view
@@ -0,0 +1,109 @@+module DeriveMod(deriveMod, deriveSMod, deriveMods, modify)+where++import Language.Haskell.TH+import Data.Char+import Control.Monad.State.Class()+import Control.Monad.State(modify) -- for exporting++{-+ example:++data DataType = Constructor {+ field1 :: String+ , field2 :: Int+ }+$(deriveMods ''DataType)++=>++-- from mkModN'+modifyField1 :: (String -> String) -> DataType -> DataType+modifyField1 f c = c{field1 = f (field1 c)}++-- from toState+sModifyField1 :: (MonadState m) => (String -> String) -> m DataType ()+sModifyField1 f = modify (modifyField1 f)++-- from mkSet+setField1 :: String -> DataType -> DataType+setField1 v c = c{field1 = v}++-- from toState+sSetField1 :: (MonadState m) => String -> m DataType ()+sSetField1 v = modify (setField1 v)++and repeat for field2.++-}++deriveMod :: String -> [Dec]+deriveMod = mkModN' . mkName++-- mkModN' abc => modAbc f c = c{abc = f(abc c)}+mkModN' :: Name -> [Dec]+mkModN' n = + let f = mkName "f"+ c = mkName "c"+ m = mkName ("mod" ++ (capitalize (nameBase n)))+ in [FunD m + [Clause [VarP f,VarP c] + (NormalB + (RecUpdE (VarE c) + [(n, AppE (VarE f) (AppE (VarE n) (VarE c)))])) []]]++-- mkModM mkModN' abc creates all modFoo functions for datatype abc.+mkModM :: (Name -> [Dec]) -> Name -> Q [Dec]+mkModM crf d = do+ fs <- dToFs d+ let exps = concatMap crf fs+ return $ exps++-- get the fields of a data type.+dToFs d = do+ TyConI (DataD _ _ _ cons _) <- reify d+ return $ concatMap getF cons++deriveMods :: Name -> Q [Dec]+deriveMods d = do+ fs1 <- mkModM mkModN' d+ let fs2 = deriveSMod fs1+ fs3 <- mkModM mkSet d+ let fs4 = concatMap toState fs3+ return (fs1 ++ fs2 ++ fs3 ++ fs4)++deriveSMod :: [Dec] -> [Dec]+deriveSMod =+ concatMap toState++-- turns a -> b -> b into (MonadState m) => a -> m b ().+toState (FunD fn _) =+ let nn = mkName ('s' : capitalize (nameBase fn))+ f = mkName "f"+ in [FunD nn+ [Clause [VarP f] + (NormalB + (AppE (VarE (mkName "modify"))+ (AppE (VarE fn) (VarE f)))) []]]+toState _ = []++-- get a list of all fields of a constructor.+getF :: Con -> [Name]+getF (RecC _ vars) = let (names, _, _) = unzip3 vars+ in names+getF _ = []++capitalize [] = []+capitalize (h:hs) = toUpper h : hs++mkSet :: Name -> [Dec]+mkSet n = + let v = mkName "v"+ c = mkName "c"+ s = mkName ("set" ++ (capitalize (nameBase n)))+ in [FunD s+ [Clause [VarP v, VarP c]+ (NormalB+ (RecUpdE (VarE c)+ [(n, VarE v)])) []]]+
+ src/GrGen.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE TemplateHaskell #-}+module Main+where++import System.Environment+import System.Exit+import System.Console.GetOpt+import System.Directory+import System.FilePath+import Data.Either+import Data.List+import Control.Monad+import Control.Monad.State+import Text.Printf++import Text.Regex.Posix++import HeaderData+import DeriveMod+import HeaderParser+import Options++data Options = Options+ {+ outputfile :: FilePath+ , interfacefile :: String+ , excludepatterns :: [String] + , includedir :: FilePath+ }+ deriving (Show)+$(deriveMods ''Options)++defaultOptions :: Options+defaultOptions = Options "" "" [] ""++options :: [OptDescr (Options -> Options)]+options = [+ Option ['o'] ["output"] (ReqArg (setOutputfile) "file") "output file for the graph"+ , Option [] ["interface"] (ReqArg (setInterfacefile) "file") "define input interface file"+ , Option [] ["exclude"] (ReqArg (\l -> modExcludepatterns (l:)) "expression") "exclude pattern for class names"+ , Option ['I'] ["include"] (ReqArg (setIncludedir) "Directory") "include path for the header files"+ ]++main :: IO ()+main = do + args <- getArgs+ let (actions, rest, errs) = getOpt Permute options args+ when (not (null errs) || null rest) $ do+ mapM_ putStrLn errs+ pr <- getProgName+ putStrLn $ usageInfo ("Usage: " ++ pr ++ " <options> <C++ header files>") options+ exitWith (ExitFailure 1)+ let prevopts = foldl' (flip ($)) defaultOptions actions+ opts <- handleInterfaceFile (interfacefile prevopts) None handleOptionsLine prevopts+ contents <- mapM readFile (map (if null (includedir opts) then id else (includedir opts </>)) (nub rest))+ let parses = map parseHeader contents+ (perrs, press) = partitionEithers parses+ case perrs of+ ((str, err):_) -> do+ putStrLn str+ putStrLn $ "Could not parse: " ++ show err+ exitWith (ExitFailure 1)+ [] -> do+ handleParses (outputfile opts) + (excludepatterns opts) + (concat press)+ exitWith ExitSuccess++handleOptionsLine :: String -> State InterfaceState (Options -> Options)+handleOptionsLine = + processor None+ [(Exclude, \n -> modExcludepatterns (n:))]+ [("@exclude", Exclude)]++data InterfaceState = None | Exclude+ deriving (Eq)++handleParses :: FilePath -> [String] -> [Object] -> IO ()+handleParses outfile excls objs = do+ createDirectoryIfMissing True (dropFileName outfile)+ writeFile outfile $ createGraphFile excls objs++createGraphFile :: [String] -> [Object] -> String+createGraphFile excls objs = + let incclass n = not $ or (map (\e -> n =~ e) excls)+ mkline (ClassDecl cname inhs _ _ _) = + if incclass cname+ then printf "%s|%s\n" cname (intercalate "," (map inheritname inhs))+ else ""+ mkline _ = ""+ in concatMap mkline $ filter (not . isEmptyClass) $ getClasses objs+
+ src/HaskellGen.hs view
@@ -0,0 +1,463 @@+{-# LANGUAGE TemplateHaskell #-}+module HaskellGen+where++import Data.List+import Data.Maybe+import Text.Printf+import System.IO+import System.FilePath+import Control.Monad+import Control.Applicative+import qualified Data.Set as S+import qualified Data.Map as M++import Text.Regex.Posix+import Safe++import HeaderData+import CppUtils+import Utils+import DeriveMod++data Options = Options+ {+ outputdir :: FilePath+ , interfacefile :: String+ , inheritfile :: FilePath+ , umbrellamodule :: FilePath+ , excludepatterns :: [String] + , defaultins :: [String] + , defaultouts :: [String] + , inparameters :: [String] + , outparameters :: [String] + , hierarchy :: String+ }+ deriving (Show)+$(deriveMods ''Options)++defaultOptions :: Options+defaultOptions = Options "" "" "" "" [] [] [] [] [] ""++-- haskell c type descriptor, e.g. "Ptr CChar"+data HsCType = HsCType {+ hsname :: String -- ^ haskell c type, like "CChar"+ , numptrs :: Int -- ^ number of pointers+ }+ deriving (Show)++-- descriptor on how to convert a haskell type to a c type+data CConv = WithLambda String | CConvFunc String | NoCConv+ deriving (Show)++-- descriptor on how to convert a c type to a haskell type+data HsConv = HsConv String | NoHsConv+ deriving (Show)++data HsFun = HsFun {+ cfilename :: String -- ^ c header file+ , cfunname :: String -- ^ c function name+ , cparams :: [HsCType] -- ^ haskell c type params+ , cretparam :: HsCType -- ^ haskell c type for the return type+ , hsfunname :: String -- ^ haskell function name+ , hsparams :: [(CConv, String)]+ -- ^ (how to convert the c type to a haskell type,+ -- which haskell type to convert to)+ , hsrettypes :: [((CConv, String), HsConv)]+ -- ^ ((how to convert the c return types to a haskell type,+ -- which haskell type to convert to),+ -- ^ how to convert the c return types to a haskell type)+ }+ deriving (Show)++haskellGen :: Options -> [(FilePath, [Object])] -> IO ()+haskellGen opts objs = do+ let outdir = outputdir opts+ excls = excludepatterns opts+ funs = map (apSnd (filter (\f -> not $ or (map (\e -> funname f =~ e) excls)))) $ map (apSnd getFuns) objs+ enums = concatMap getEnums $ map snd objs+ enumnames = map (capitalize . enumname) enums+ alltypes = getAllTypesWithPtr (concatMap snd funs)+ typeValid :: String -> Bool+ typeValid t = not . isJust $ typeValidMsg enumnames opts t+ (cpptypes, rejtypes) = S.partition typeValid alltypes+ modprefix = hierarchy opts+ hPutStrLn stderr $ "Rejected types: "+ forM_ (S.toList rejtypes) print+ hPutStrLn stderr $ "Used types: "+ let hstypes = nub $ filter (not . isStdType . stripPtr) (S.toList cpptypes)+ typefile = outdir </> "Types.hs"+ hstypify = capitalize . stripPtr . removeNamespace++ -- Types module+ withFile typefile WriteMode $ \h -> do+ hPrintf h "module %sTypes\nwhere\n\n" modprefix+ hPutStrLn h importForeign+ hPrintf h "type CBool = CChar -- correct?\n\n"+ forM_ hstypes $ \t -> do+ case (filter (\e -> enumname e == (capitalize . stripPtr . stripNamespace) t)) enums of+ ((EnumDef en vs _):_) -> do+ let hstypename = hstypify en+ decaptn = decapitalize hstypename+ constrs = map (apFst hstypify) $ getEnumValues vs+ hPrintf h "\ndata %s = %s\n\n" hstypename (intercalate " | " (map fst constrs))+ hPrintf h "%sToCInt :: %s -> CInt\n" decaptn hstypename+ forM_ constrs $ \(c, v) -> do+ hPrintf h "%sToCInt %s = %d\n" decaptn c v+ hPrintf h "\n"+ hPrintf h "cintTo%s :: CInt -> %s\n" hstypename hstypename+ forM_ constrs $ \(c, v) -> do+ hPrintf h "cintTo%s %d = %s\n" hstypename v c+ hPrintf h "cintTo%s n = error $ \"cintTo%s: can not convert integer '\" ++ show n ++ \"' to %s\"\n" hstypename hstypename hstypename+ hPrintf h "\n"+ _ -> let t' = hstypify t in hPrintf h "newtype %s = %s (Ptr %s) -- nullary data type\n" t' t' t'+ hPrintf h "\n"++ -- classes and instances+ when (not . null $ inheritfile opts) $ do+ inheritdata <- withFile (inheritfile opts) ReadMode $ \ih -> do+ conts <- hGetContents ih+ forM (lines conts) $ \l -> do+ let (cname, inheritline) = break (== '|') l+ inherits = map (dropWhile (== ',')) $ groupBy (\_ b -> b /= ',') $ tailSafe inheritline+ return (cname, inherits)++ let hstypeset = (S.\\) (S.fromList (map hstypify hstypes)) (S.fromList enumnames) + inheritlist :: [(String, [String])]+ inheritlist = M.toList . foldr (\(k, a) acc -> M.insertWith (++) k [a] acc) M.empty . map swap . expand . catMaybes $ + for inheritdata $ \(cname, superclasses) ->+ if hstypify cname `S.member` hstypeset + then Just (hstypify cname, catMaybes $ for superclasses $ \s ->+ if (s `S.member` hstypeset) then Just (hstypify s) else Nothing)+ else Nothing+ forM_ inheritlist $ \(cname, inheritances) -> do+ when (cname `S.member` hstypeset && not (null inheritances)) $ do+ hPrintf h "class C%s a where\n to%s :: a -> %s\n\n" cname cname cname+ forM_ inheritances $ \i -> do+ hPrintf h "instance C%s %s where\n to%s (%s p) = %s (castPtr p)\n\n" cname i cname i cname++ expfuns <- forM funs $ \(file, filefuns) ->+ withFile (outdir </> ((takeBaseName file) ++ ".hs")) WriteMode $ \h -> do+ allgenfuns <- catMaybes <$> (forM filefuns $ \fun -> do+ case cfunToHsFun enumnames opts file fun of+ Right hsf -> return $ Just hsf+ Left err -> hPrintf stderr "Function %s discarded:\n\t%s\n" (getObjName fun) err >> return Nothing)+ let constructors = filter isConstructor allgenfuns+ withfunnames = map withFunName constructors+ hPrintf h "{-# LANGUAGE ForeignFunctionInterface #-}\n"+ hPrintf h "module %s%s(\n%s\n)\n\nwhere\n\nimport %sTypes\nimport Control.Monad\n\n" + modprefix + (takeBaseName file) + (intercalate ", \n" $ withfunnames ++ map hsfunname allgenfuns)+ modprefix+ hPutStrLn h importForeign+ mapM_ (addWithFun h) $ filter isConstructor allgenfuns+ forM_ allgenfuns $ addFun h+ return $ withfunnames ++ map hsfunname allgenfuns++ when (not . null $ umbrellamodule opts) $ do+ withFile (outdir </> (umbrellamodule opts)) WriteMode $ \h -> do+ hPrintf h "module %s%s(\n %s\n)\n\nwhere\n\n%s\n" + modprefix+ (takeBaseName $ umbrellamodule opts)+ (intercalate ", \n " $ concat expfuns)+ (intercalate "\n" $ map (("import " ++ modprefix) ++) (map (takeBaseName . fst) funs))++withFunName :: HsFun -> String+withFunName = replace "new" "with" . hsfunname++-- creates the HsFun.+cfunToHsFun :: [String] -> Options -> FilePath -> Object -> Either String HsFun+cfunToHsFun enumnames opts filename (FunDecl fname rt ps _ _ _ _) =+ case catMaybes (map (typeValidMsg enumnames opts) (map (correctType . stripConst) (rt:pts))) of+ [] -> Right $+ HsFun filename + fname + (map (cTypeToHsCType enumnames) pts)+ (cTypeToHsCType enumnames rt) + (decapitalize $ dropWhile (== '_') $ dropWhile (/= '_') fname)+ (map (cTypeToHsType enumnames) pts)+ ([(cTypeToHsType enumnames rt, convRevFunc enumnames rt)])+ l -> Left (intercalate "\n" l)+ where pts = map vartype ps+cfunToHsFun _ _ _ _ = Left "Given object is not a function"++-- cTypeToHsCType "const char **" = HsCType CChar 2+cTypeToHsCType :: [String] -> String -> HsCType+cTypeToHsCType _ "void" = HsCType "()" 0+cTypeToHsCType enums t + | (stripNamespace . correctType . stripExtra . stripConst $ t) `elem` enums = HsCType "CInt" 0+ | otherwise =+ case cTypeToHs t of+ Nothing -> HsCType (capitalize . removeNamespace . correctType . stripExtra . stripConst $ t) (isPtr ct - 1)+ Just t' -> HsCType t' (isPtr ct)+ where ct = correctType . stripConst $ t++-- showHsCType (CChar, 2) = (Ptr (Ptr CChar))+showHsCType :: HsCType -> String+showHsCType h = hsPointerize (numptrs h) (hsname h)++-- cTypeToHsType "const int **" = (CConvFunc "fromIntegral", "Int")+cTypeToHsType :: [String] -> String -> (CConv, String)+cTypeToHsType _ "void" = (NoCConv, "()")+cTypeToHsType enums t + | correctType (stripConst t) == "char*"+ = (WithLambda "withCString", "String")+ | otherwise =+ let entype = stripNamespace . correctType . stripExtra . stripConst $ t+ in if entype `elem` enums+ then (CConvFunc (printf "%sToCInt" $ decapitalize entype), entype)+ else+ case join $ fmap cleanCType $ cTypeToHs t of+ Nothing -> (NoCConv, printHsType enums t)+ Just t' -> (convFunc t, t')++paramList :: HsFun -> String+paramList = intercalate " " . paramNames . length . hsparams++-- creates the Haskell function definition.+hsFunDefinition :: HsFun -> String+hsFunDefinition h = printf "%s %s = %s" + (hsfunname h) + (paramList h)+ (hsFunDef (hsfunname h) (hsparams h) (snd $ head $ hsrettypes h))++ where+ hsFunDef :: String -> [(CConv, String)] -> HsConv -> String+ hsFunDef fn inparams retparam = + let ptypes = zip (paramNames maxBound) (map (correctType . stripConst . snd) inparams)+ cstrings = filter (\(_, t) -> t == "String") ptypes+ mkCString (pnm, _) = printf "withCString %s $ \\c%s -> \n " pnm pnm+ resLift = case retparam of+ NoHsConv -> ""+ HsConv n -> "liftM " ++ n ++ " $ "+ funcall = cPrefix ++ fn+ funparams = intercalate " " (map paramcall (zip inparams (map fst ptypes)))+ paramcall :: ((CConv, String), String) -> String+ paramcall ((cv, ct), pt) = pprefix ++ pname ++ psuffix+ where pname = if ct == "String"+ then 'c' : pt+ else pt+ (pprefix, psuffix) = case cv of+ CConvFunc n -> ("(" ++ n ++ " ", ")")+ _ -> ("", "")+ in concatMap mkCString cstrings ++ " " ++ resLift ++ " " ++ funcall ++ " " ++ funparams++-- prints out the haskell function declaration and definition.+-- TODO: take defined out-params into account.+addFun :: Handle -> HsFun -> IO ()+addFun h hsf = do+ -- FFI import+ hPutStrLn h (ffiHsFun hsf)++ -- type signature+ hPutStrLn h (typeSigHsFun hsf)++ -- function definition+ hPutStrLn h (hsFunDefinition hsf)+ hPutStrLn h ""++ where+ ffiHsFun :: HsFun -> String+ ffiHsFun hf = hsFFIFun (cfilename hf) (cfunname hf) (hsfunname hf) (map showHsCType (cparams hf)) (showHsCType (cretparam hf))++ hsFFIFun :: String -> String -> String -> [String] -> String -> String+ hsFFIFun file fn cfn inparams retparam = printf "foreign import ccall \"%s %s\" %s%s :: %sIO %s" + file fn cPrefix cfn+ (printHsParams inparams)+ (retparam)++ typeSigHsFun :: HsFun -> String+ typeSigHsFun hf = + printf "%s :: %sIO %s" + (hsfunname hf)+ (typeSigList hf)+ (hsFunRetType hf)++hsFunRetType :: HsFun -> String+hsFunRetType hf =+ let hsr = map (snd . fst) $ hsrettypes hf+ (pref, suff) = if length hsr == 1 then ("", "") else ("(", ")")+ in pref ++ intercalate ", " hsr ++ suff++-- e.g. "String -> String -> String ->"+typeSigList :: HsFun -> String+typeSigList hf = if null (hsparams hf) then "" else intercalate " -> " (map snd $ hsparams hf) ++ " -> "++-- checks whether the given type can be used.+-- The type can be used, if:+-- The type is a standard c type either as a value or+-- as a pointer with a defined meaning, or+-- the type is a pointer to a handle, or+-- the type is a defined enum, or+-- the type is void.+--+-- The meaning (in/out/in+out) of a standard c type is "defined", if+-- the type is not a pointer, or+-- the type is a pointer, and the meaning is given. (not yet implemented)+typeValidMsg :: [String] -> Options -> String -> Maybe String+typeValidMsg enums opts t = validateAll [(t /= "void*", "Void pointer not supported"),+ (not (isTemplate t), "Template types not supported"),+ ((any (==(stripNamespace t)) enums || + t == "void" || + isStdType t || + isPtr t > 0), "type " ++ t ++ " is a value of a non-standard type"),+ (hasDir, "direction for the type " ++ t ++ " has not been defined in the interface file")]+ where validateAll = foldl' validate Nothing+ where validate (Just n) _ = Just n+ validate Nothing (f, str) = if not f then Just str else Nothing+ hasDir = isPtr t == 0 ||+ (isPtr t == 1 && (not $ isJust $ cTypeToHs t)) ||+ t `elem` defaultins opts++addWithFun :: Handle -> HsFun -> IO ()+addWithFun h fun = do+ let fn = hsfunname fun+ fnw = withFunName fun+ dst = replace "new.*" "delete" fn+ typ = hsFunRetType fun+ pl = paramList fun+ hPrintf h "%s :: %s(%s -> IO a) -> IO a\n" fnw (typeSigList fun) typ+ hPrintf h "%s %s f = do\n" fnw pl+ hPrintf h " obj <- %s %s\n" fn pl+ hPrintf h " res <- f obj\n"+ hPrintf h " %s obj\n" dst+ hPrintf h " return res\n\n"++isConstructor :: HsFun -> Bool+isConstructor = constructor . hsfunname++isDestructor :: HsFun -> Bool+isDestructor = destructor . hsfunname++destructor :: String -> Bool+destructor fn = fn =~ ".*_delete$"++constructor :: String -> Bool+constructor fn = fn =~ ".*_new[0-9]*$"++importForeign :: String+importForeign = "import Foreign\nimport Foreign.C.String\nimport Foreign.C.Types\n"++cPrefix :: String+cPrefix = "c_"++-- in: a c type, like "int"+-- out: the haskell conversion function for converting from haskell data type+convFunc :: String -> CConv+convFunc ptype =+ case fromMaybe "" $ cTypeToHs ptype of+ "CChar" -> CConvFunc "castCCharToChar" + "CSChar" -> CConvFunc "fromIntegral" + "CUChar" -> CConvFunc "fromIntegral" + "CShort" -> CConvFunc "fromIntegral" + "CUShort" -> CConvFunc "fromIntegral" + "CInt" -> CConvFunc "fromIntegral" + "CUInt" -> CConvFunc "fromIntegral" + "CSize" -> CConvFunc "fromIntegral" + "CLong" -> CConvFunc "fromIntegral" + "CULong" -> CConvFunc "fromIntegral" + "CFloat" -> CConvFunc "realToFrac" + "CDouble" -> CConvFunc "realToFrac" + "CBool" -> CConvFunc "fromBool" + _ -> NoCConv++-- in: a c type, like "int"+-- out: the haskell conversion function for converting to haskell data type+convRevFunc :: [String] -> String -> HsConv+convRevFunc enums t+ | fromMaybe "" (cTypeToHs t) == "CBool" = HsConv "toBool"+ | otherwise = + let ccf = convFunc t+ in case ccf of+ CConvFunc n -> HsConv n+ _ -> + let entype = stripNamespace . correctType . stripExtra . stripConst $ t+ in if entype `elem` enums+ then HsConv $ printf "cintTo%s" entype+ else NoHsConv++paramNames :: Int -> [String]+paramNames n = map ('p':) (map show [1..n])++-- printHsType "const char **" = "(Ptr (Ptr CChar))"+printHsType :: [String] -> String -> String+printHsType _ "void" = "()"+printHsType enums t = + case cTypeToHs t of+ Nothing -> hsPointerize (isPtr ct - 1) $ capitalize . fixNamespace enums . correctType . stripConst $ t+ Just t' -> hsPointerize (isPtr ct) t'+ where ct = correctType . stripConst $ t++hsPointerize :: Int -> String -> String+hsPointerize numPtrs t = + concat (replicate numPtrs "(Ptr ") ++ (stripPtr t) ++ concat (replicate numPtrs ")")++cTypeToHs :: String -> Maybe String+cTypeToHs = cTypeToHs' . clearType+ where -- strips const, pointers: const char ** => char+ clearType :: String -> String+ clearType = stripPtr . correctType . stripConst++cTypeToHs' :: String -> Maybe String+cTypeToHs' "float" = Just "CFloat"+cTypeToHs' "double" = Just "CDouble"+cTypeToHs' "char" = Just "CChar"+cTypeToHs' "int" = Just "CInt"+cTypeToHs' "unsigned int" = Just "CUInt"+cTypeToHs' "signed int" = Just "CInt"+cTypeToHs' "long" = Just "CLong"+cTypeToHs' "unsigned long" = Just "CULong"+cTypeToHs' "signed long" = Just "CLong"+cTypeToHs' "bool" = Just "CBool"+cTypeToHs' "short" = Just "CShort"+cTypeToHs' "unsigned short" = Just "CUShort"+cTypeToHs' "signed short" = Just "CShort"+cTypeToHs' "unsigned" = Just "CInt"+cTypeToHs' "long long" = Just "CLong"+cTypeToHs' "unsigned long long" = Just "CULong"+cTypeToHs' "int8_t" = Just "CChar"+cTypeToHs' "uint8_t" = Just "CUChar"+cTypeToHs' "int16_t" = Just "CShort"+cTypeToHs' "uint16_t" = Just "CUShort"+cTypeToHs' "int32_t" = Just "CLong"+cTypeToHs' "uint32_t" = Just "CULong"+cTypeToHs' "int64_t" = Just "CLong"+cTypeToHs' "uint64_t" = Just "CULong"+cTypeToHs' "size_t" = Just "CSize"+cTypeToHs' "uint8" = Just "CUChar"+cTypeToHs' "uint16" = Just "CUShort"+cTypeToHs' "uint32" = Just "CULong"+cTypeToHs' "uint64" = Just "CULong"+cTypeToHs' _ = Nothing++cleanCType :: String -> Maybe String+cleanCType "CFloat" = Just "Float"+cleanCType "CDouble" = Just "Double"+cleanCType "CChar" = Just "Char"+cleanCType "CSChar" = Just "Int"+cleanCType "CUChar" = Just "Int"+cleanCType "CInt" = Just "Int"+cleanCType "CUInt" = Just "Int"+cleanCType "CLong" = Just "Int"+cleanCType "CULong" = Just "Int"+cleanCType "CBool" = Just "Bool"+cleanCType "CShort" = Just "Int"+cleanCType "CUShort" = Just "Int"+cleanCType "CSize" = Just "Int"+cleanCType _ = Nothing++printHsParams :: [String] -> String+printHsParams [] = ""+printHsParams types = + intercalate " -> " types ++ " -> " ++removeNamespace :: String -> String+removeNamespace = map (\c -> if c == ':' then '_' else c)++stripNamespace :: String -> String+stripNamespace = last . takeWhile (not . null) . iterate (dropWhile (==':') . snd . break (== ':'))++fixNamespace :: [String] -> String -> String+fixNamespace enums n = (if (stripNamespace n) `elem` enums then stripNamespace else removeNamespace) n+
+ src/HeaderData.hs view
@@ -0,0 +1,156 @@+module HeaderData+where++import Safe++type Type = String++data ParamDecl = ParamDecl {+ varname :: String+ , vartype :: Type+ , varvalue :: Maybe String+ , vararray :: Maybe String+ }+ deriving (Eq, Read, Show)++data Object = FunDecl {+ funname :: String+ , rettype :: Type+ , params :: [ParamDecl]+ , fnnamespace :: [String]+ , fnvisibility :: Maybe (InheritLevel, String)+ , constclass :: Bool -- void f() const;+ , abstract :: Bool+ }+ | Namespace String [Object]+ | TypeDef (String, String)+ | ClassDecl {+ classname :: String+ , classinherits :: [InheritDecl]+ , classnesting :: [(InheritLevel, String)]+ , classnamespace :: [String]+ , classobjects :: [(InheritLevel, Object)]+ }+ | VarDecl ParamDecl (Maybe (InheritLevel, String))+ | EnumDef {+ enumname :: String+ , enumvalues :: [EnumVal]+ , enumclassnesting :: [(InheritLevel, String)]+ }+ | ExternDecl String [Object]+ | Using Bool String+ deriving (Eq, Read, Show)++data InheritDecl = InheritDecl {+ inheritname :: String+ , inheritlevel :: InheritLevel+ }+ deriving (Eq, Read, Show)++data InheritLevel = Public | Protected | Private+ deriving (Eq, Read, Show, Enum, Bounded)++data EnumVal = EnumVal {+ enumvaluename :: String+ , enumvalue :: Maybe String+ }+ deriving (Eq, Read, Show)++type Header = [Object]++getFuns :: [Object] -> [Object]+getFuns [] = []+getFuns (o:os) = + case o of+ (FunDecl _ _ _ _ _ _ _) -> o : getFuns os+ (Namespace _ os2) -> getFuns os2 ++ getFuns os+ (ClassDecl _ _ n _ os2) -> + case n of+ [] -> getFuns (map snd os2) ++ getFuns os+ ((Public, _):_) -> getFuns (map snd os2) ++ getFuns os+ _ -> getFuns os+ (ExternDecl _ os2) -> getFuns os2 ++ getFuns os+ _ -> getFuns os++getEnums :: [Object] -> [Object]+getEnums [] = []+getEnums (o:os) = + case o of+ (EnumDef _ _ _) -> o : getEnums os+ (Namespace _ os2) -> getEnums os2 ++ getEnums os+ (ClassDecl _ _ n _ os2) -> + case n of+ [] -> getEnums (map snd os2) ++ getEnums os+ ((Public, _):_) -> getEnums (map snd os2) ++ getEnums os+ _ -> getEnums os+ (ExternDecl _ os2) -> getEnums os2 ++ getEnums os+ _ -> getEnums os++addEnumNamespace :: Object -> Object+addEnumNamespace e@(EnumDef n _ nest)+ = e{enumname = concatMap (++"::") (map snd nest) ++ n}+addEnumNamespace o = o++getClasses :: [Object] -> [Object]+getClasses [] = []+getClasses (o:os) = + case o of+ (Namespace _ os2) -> getClasses os2 ++ getClasses os+ (ClassDecl _ _ _ _ os2) -> o : getClasses (map snd os2) ++ getClasses os+ _ -> getClasses os++getObjName :: Object -> String+getObjName (FunDecl n _ _ _ _ _ _) = n+getObjName (Namespace n _ ) = n+getObjName (TypeDef (n, _)) = n+getObjName (ClassDecl n _ _ _ _) = n+getObjName (VarDecl p _) = varname p+getObjName (EnumDef n _ _) = n+getObjName (ExternDecl n _) = n+getObjName (Using _ n) = n++isAbstractFun :: Object -> Bool+isAbstractFun (FunDecl _ _ _ _ _ _ a) = a+isAbstractFun _ = False++getUsedFunTypes :: Object -> [String]+getUsedFunTypes (FunDecl _ rt ps _ _ _ _) =+ rt:(map vartype ps)+getUsedFunTypes _ = []++-- return the enum called n, if found.+fetchEnum :: [Object] -> String -> Maybe Object+fetchEnum enums n = headMay $ filter (enumHasName n) enums++-- return the class called n, if found.+fetchClass :: [Object] -> String -> Maybe Object+fetchClass classes n = headMay $ filter (classHasName n) classes++enumHasName :: String -> Object -> Bool+enumHasName n (EnumDef cn _ _) = n == cn+enumHasName _ _ = False++classHasName :: String -> Object -> Bool+classHasName n (ClassDecl cn _ _ _ _) = n == cn+classHasName _ _ = False++getTypedef :: Object -> Maybe (String, String)+getTypedef (TypeDef t) = Just t+getTypedef _ = Nothing++isEnum :: Object -> Bool+isEnum (EnumDef _ _ _) = True+isEnum _ = False++getEnum :: Object -> Maybe Object+getEnum o@(EnumDef _ _ _) = Just o+getEnum _ = Nothing++getClname :: Object -> String+getClname (FunDecl _ _ _ _ (Just (_, n)) _ _) = n+getClname _ = ""++isEmptyClass :: Object -> Bool+isEmptyClass (ClassDecl _ _ _ _ objs) = null objs+isEmptyClass _ = False+
+ src/HeaderParser.hs view
@@ -0,0 +1,492 @@+module HeaderParser(parseHeader)+where++import Data.List+import Data.Maybe+import Data.Char+import Control.Applicative hiding (many, (<|>), optional)+import qualified Data.Map as M++import Text.ParserCombinators.Parsec++import HeaderData++data HeaderState = HeaderState {+ namespacestack :: [String]+ , classstack :: [(InheritLevel, String)]+ }+ deriving (Eq, Read, Show)++pushNamespace n = + updateState (\h -> h{namespacestack = n:(namespacestack h)})++popNamespace =+ updateState (\h -> h{namespacestack = tail (namespacestack h)})++pushClass n = + updateState (\h -> h{classstack = n:(classstack h)})++popClass =+ updateState (\h -> h{classstack = tail (classstack h)})++setLevel l = do+ n <- classstack <$> getState+ case n of+ ((_, c):ms) -> do+ let cn = ((l,c):ms)+ updateState (\h -> h{classstack = cn})+ _ -> return ()++header :: CharParser HeaderState Header+header = many oneobj++oneobj :: CharParser HeaderState Object+oneobj = do+ spaces+ _ <- many eos+ w <- gettype+ case w of+ "namespace" -> namespace (many1 oneobj)+ "class" -> classDecl + "struct" -> try structDecl <|> varFunDecl "struct"+ "typedef" -> typedef + "enum" -> enum+ "extern" -> extern+ "using" -> using+ _ -> macro w <|> varFunDecl w++extern :: CharParser HeaderState Object+extern = do+ spaces+ en <- quoted+ spaces+ objs <- try manyext <|> (do o <- oneobj; return [o])+ return $ ExternDecl en objs++ where manyext = do+ _ <- char '{'+ os <- many oneobj+ spaces+ _ <- char '}'+ spaces+ return os++using :: CharParser HeaderState Object+using = do+ _ <- many1 whitespace+ (n, iden) <- try (do+ _ <- string "namespace"+ _ <- many1 whitespace+ i <- identifier+ return (True, i))+ <|> (do+ i <- typename+ return (False, i))+ spaces+ _ <- eos+ return $ Using n iden++-- macro is a hack.+macro w = do+ _ <- try (char '(' >> spaces >> optional (paramDecl Nothing) >> spaces >> char ')')+ spaces+ _ <- optional (eos)+ return $ VarDecl (ParamDecl w "macro" Nothing Nothing) Nothing++enum :: CharParser HeaderState Object+enum = do+ _ <- many1 whitespace+ n <- identifier+ spaces+ _ <- char '{'+ vals <- sepBy1 enumVal (char ',')+ spaces+ optional (char ',')+ spaces+ _ <- char '}'+ spaces+ _ <- eos+ spaces+ cls <- classstack <$> getState+ return $ EnumDef n vals cls++enumVal = do+ spaces+ ev <- identifier+ spaces+ val <- optionMaybe (char '=' >> spaces >> many1 valuechar)+ spaces+ return $ EnumVal ev val++typedef :: CharParser HeaderState Object+typedef = do+ allchars <- many1 typedefchar+ spaces+ _ <- eos+ let ns = words allchars+ return $ TypeDef (intercalate " " (init ns), last ns)++gettype :: CharParser u String+gettype = concat <$> many1 (typename <|> templ)++templ = do+ _ <- char '<'+ v <- manyTill anyChar (char '>')+ return ('<' : (v ++ ">"))++getvalue :: CharParser u String+getvalue = quoted <|> many1 valuechar++quoted :: CharParser u String+quoted = do+ _ <- char '"'+ v <- manyTill anyChar (char '"')+ return ('"' : (v ++ "\""))++valuechar = oneOf valuechars++valuechars = typechars ++ ".-"++typename = many1 typechar++typechar = oneOf typechars++typechars = idChar ++ "*:&"++typedefchar = oneOf typedefchars++typedefchars = typechars ++ " \t,<>\r\n"++structDecl = classDecl' Public++classDecl = classDecl' Private++classDecl' lev = do+ _ <- many1 whitespace+ optional (char '_' >> identifier >> spaces)+ n <- identifier+ spaces+ inherits <- option [] inheritDecls+ spaces+ ns <- namespacestack <$> getState+ cs <- classstack <$> getState+ (eos >> return (ClassDecl n inherits cs ns [])) <|> clconts cs ns n inherits lev++clconts cs ns n inherits lev = do+ _ <- char '{'+ spaces+ pushClass (lev, n)+ ret <- clcontents+ popClass+ spaces+ _ <- char '}'+ spaces+ _ <- eos+ spaces+ return $ ClassDecl n inherits cs ns ret++clcontents :: CharParser HeaderState [(InheritLevel, Object)]+clcontents = do+ spaces+ objs <- many $ do+ spaces+ mparse <- optionMaybe (many1 (try setinheritlevel <|> try frienddecl))+ case mparse of+ Just _ -> return Nothing -- ignore friend declarations+ Nothing -> do+ obj <- try specialClassFunction <|> oneobj+ vis <- getVisibility <$> getState+ let vn = case vis of+ Nothing -> Public+ Just (v, _) -> v+ return $ Just (vn, obj)+ return $ catMaybes objs++-- constructor or destructor.+specialClassFunction = do+ spaces+ optional (string "virtual")+ spaces+ cname <- (snd . head . classstack) <$> getState+ fn <- ((string ('~' : cname)) <|> string cname)+ spaces+ funDecl fn ""++inheritDecls = char ':' >> spaces >> sepBy inh (char ',')+ where inh = do+ spaces+ l <- inheritl+ spaces+ n <- gettype+ spaces+ return $ InheritDecl n l++inheritance = do+ _ <- char ':'+ spaces+ inheritl++capitalize [] = []+capitalize (x:xs) = toUpper x : xs++inheritl = do + spaces+ try (string "public" >> return Public) <|> try (string "protected" >> return Protected) <|> (string "private" >> return Private)++frienddecl = do+ _ <- string "friend"+ spaces+ _ <- string "class"+ spaces+ _ <- identifier+ spaces+ _ <- eos+ spaces+ return ()++-- end of statement+eos :: CharParser u ()+eos = char ';' >> spaces >> many eos >> return ()++setinheritlevel = do+ str <- try (string "public") <|> try (string "protected") <|> string "private" + spaces+ _ <- char ':'+ spaces+ setLevel $ case str of+ "public" -> Public+ "protected" -> Protected+ _ -> Private++whitespace = oneOf (" \t\n\r")++namespace :: CharParser HeaderState [Object] -> CharParser HeaderState Object+namespace nscont = do+ _ <- many1 whitespace+ n <- option "" identifier+ spaces+ _ <- char '{'+ spaces+ pushNamespace n+ ret <- nscont+ popNamespace+ spaces+ _ <- char '}'+ spaces+ return $ Namespace n ret++identList = many1 ((concat <$> (many1 (try opr <|> gettype))) >>= \t -> spaces >> return t) <?> "type"++opr = do+ st <- string "operator"+ spaces+ vl <- oprchars+ return $ st ++ vl++oprchars :: CharParser u String+oprchars = try ((string"()") <|> many1 (oneOf "!+-=/*.-><[]|&"))++getassign = do+ v1 <- getvalue+ spaces+ v2 <- try (char '(' >> spaces >> char ')' >> return "()") + <|> option "" (do+ os <- concat <$> many1 oprchars+ spaces+ nm <- getassign+ return $ os ++ nm)+ return $ v1 ++ v2++varFunDecl :: String -> CharParser HeaderState Object+varFunDecl ft = do+ _ <- many1 whitespace+ is <- identList+ spaces+ let alls = (ft:is)+ ptrs = length $ takeWhile (== '*') (last alls)+ nm = drop ptrs $ last alls+ ns = intercalate " " (init alls) ++ replicate ptrs '*'+ vis <- getVisibility <$> getState+ if isOperator nm+ then funDecl nm ns+ else do+ pdecl <- paramDecl (Just alls)+ (optional (char '=' >> spaces >> getassign) >> spaces >>+ (eos <|> (char ',' >> untilEOS >> return ())) >> -- just ignore all other declarations+ spaces >> return (VarDecl pdecl vis))+ <|>+ funDecl nm ns++isOperator :: String -> Bool+isOperator "operator" = True+isOperator t = takeWhile isAlpha (drop 2 (dropWhile (/= ':') t)) == "operator"++getVisibility :: HeaderState -> Maybe (InheritLevel, String)+getVisibility h = + let cs = classstack h+ in case cs of+ (c:_) -> Just c+ _ -> Nothing++funDecl :: String -> String -> CharParser HeaderState Object+funDecl fn ft = do+ n <- if isOperator fn+ then spaces >> option "" oprchars+ else return ""+ spaces+ _ <- char '(' <?> "start of function parameter list: ("+ spaces+ pars <- (try (spaces >> string "void" >> spaces >> return [])) <|> sepBy (paramDecl Nothing) (char ',' >> spaces)+ _ <- char ')' <?> "end of function parameter list: )"+ spaces+ constfun <- option False (try (string "const" >> spaces) >> return True)+ optional (many (identifier >> spaces))+ -- constructing member variables+ optional (char ':' >> many (many1 (digit <|> oneOf ("(.-+)[]" ++ typedefchars)) >> spaces))+ abstr <- (char '{' >> ignoreBraces >> skipMany eos >> return False) <|> + (eos >> return False) <|> + (char '=' >> spaces >> char '0' >> + spaces >> eos >> return True)+ spaces+ ns <- namespacestack <$> getState+ vs <- getVisibility <$> getState+ return $ FunDecl (fn ++ n) ft pars ns vs constfun abstr++ignoreBraces :: CharParser u ()+ignoreBraces = ignoreBraces' (0 :: Int)+ where ignoreBraces' n = do+ skipMany $ noneOf "{}"+ v <- oneOf "{}"+ case v of+ '}' -> case n of+ 0 -> return ()+ _ -> ignoreBraces' (n - 1)+ _ -> ignoreBraces' (n + 1)++paramDecl :: Maybe [String] -> CharParser HeaderState ParamDecl+paramDecl mv = do+ pts <- case mv of+ Nothing -> many1 (refMark <|> ptrStar <|> (gettype >>= \n -> spaces >> return n))+ Just v -> return v+ spaces+ val <- optionMaybe optionalParams + arr <- optionMaybe (concat <$> many1 (between (char '[') (char ']') (many (noneOf "]")) >>= \v -> spaces >> return v))+ if '*' `elem` last pts+ -- pointer as "variable name" => no variable name given+ then return $ ParamDecl "" (intercalate " " pts) val arr+ else return $ ParamDecl (last pts) (intercalate " " (init pts)) val arr++optionalParams = do+ _ <- char '='+ spaces + v <- getassign + spaces + r <- option "" (string "(" >> spaces >> string ")" >> return "()")+ spaces + return (v ++ r)++refMark :: CharParser u String+refMark = do+ c <- char '&'+ spaces+ return [c]++ptrStar :: CharParser u String+ptrStar = do+ ns <- many1 $ char '*'+ spaces+ return ns++idCharInit = ['a'..'z'] ++ ['A'..'Z'] ++ "_"+idChar = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"++identifier :: CharParser u String+identifier = do+ m <- oneOf idCharInit+ n <- many $ oneOf idChar+ return (m:n)++untilEOL :: CharParser u String+untilEOL = manyTill (anyChar) (eof <|> try (char '\n' >> return ()))++untilEOS :: CharParser u String+untilEOS = manyTill (anyChar) (eof <|> try (char ';' >> return ()))++escapedEOL :: CharParser u Char+escapedEOL = char '\\' >> newline++preprocess :: CharParser (M.Map String String) String+preprocess = do+ spaces+ concat <$> many (spaces >> ((char '#' >> preprocessorLine) <|> otherLine))++preprocessorLine = do+ spaces+ n <- (string "define" >> macroDef) <|> otherMacro+ spaces+ return n++otherMacro = untilEOL >> return ""++macroDef :: CharParser (M.Map String String) String+macroDef = do+ spaces+ mname <- identifier+ mval <- option "" (many1 (oneOf " \t") >> untilEOL)+ updateState (M.insert mname mval)+ return ""++otherLine :: CharParser (M.Map String String) String+otherLine = do+ n <- concat <$> many1 expandMacro+ spaces+ return n++expandMacro = do+ ns <- many $ noneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "#"+ mexp <- try expandWord+ ns2 <- many $ noneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "#"+ return $ ns ++ mexp ++ ns2++expandWord = do+ wd <- many1 alphaNum+ ms <- getState+ return $ fromMaybe wd (M.lookup wd ms)++removeComments :: CharParser () String+removeComments = do+ optional getComment+ many getCode+ where getCode = do+ n <- anyChar+ optional getComment+ return n++getComment :: CharParser () String+getComment = concat <$> many1 (try blockComment <|> lineComment)++blockComment :: CharParser u String+blockComment = do+ _ <- try (string "/*")+ manyTill anyChar (try (string "*/"))++eol :: CharParser u ()+eol = + (try (string "\r\n") >> return ()) <|> (oneOf "\r\n" >> return ())++lineComment :: CharParser u String+lineComment = do+ _ <- try (string "//")+ manyTill anyChar (try eol)++parseHeader :: String -> Either (String, ParseError) Header+parseHeader input = + case parse removeComments "removeComments" input of+ Left err -> Left (input, err)+ Right inp -> + case runParser preprocess M.empty "preprocessor" inp of+ Left err2 -> Left (inp, err2)+ Right prp -> case runParser header (HeaderState [] []) "Header" prp of+ Left err -> Left (prp, err)+ Right v -> Right v+
+ src/Main.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE TemplateHaskell #-}+module Main()+where++import System.Environment+import System.Exit+import System.Console.GetOpt+import System.FilePath+import System.Directory+import System.IO+import Data.Either+import Data.List+import Control.Monad+import Control.Monad.State+import Text.Printf+import qualified Data.Set as S++import Text.Regex.Posix++import HeaderParser+import HeaderData+import CppGen+import Utils+import Options+import DeriveMod++data Options = Options+ {+ outputdir :: FilePath+ , inputfiles :: [FilePath]+ , includefiles :: [FilePath]+ , includedir :: FilePath+ , excludepatterns :: [String] + , excludebases :: [String]+ , checksuperclasses :: Bool+ , renamedtypes :: [(String, String)]+ , excludeclasses :: [String]+ , interfacefile :: String+ , hsoutpath :: Maybe FilePath+ , dumpmode :: Bool+ }+ deriving (Show)+$(deriveMods ''Options)++defaultOptions :: Options+defaultOptions = Options "" [] [] "" [] [] False [] [] "" Nothing False++options :: [OptDescr (Options -> Options)]+options = [+ Option ['o'] ["output"] (ReqArg (setOutputdir) "Directory") "output directory for the C files"+ , Option [] ["header"] (ReqArg (\l -> modIncludefiles (l:)) "File") "file to include in the generated headers"+ , Option [] ["exclude"] (ReqArg (\l -> modExcludepatterns (l:)) "Function") "exclude pattern for function names"+ , Option [] ["exclude-base"] (ReqArg (\l -> modExcludebases (l:)) "Class") "exclude pattern for required base classes (with check-super)"+ , Option [] ["exclude-class"] (ReqArg (\l -> modExcludeclasses (l:)) "Class") "exclude pattern for classes"+ , Option [] ["check-super"] (NoArg (setChecksuperclasses True)) "report error if super classes aren't found"+ , Option [] ["rename"] (ReqArg (addRenamedTypes) "oldtype|newtype") "rename a type by another one"+ , Option [] ["interface"] (ReqArg (setInterfacefile) "file") "define input interface file"+ , Option [] ["dump"] (NoArg (setDumpmode True)) "simply dump the parsed data of the header"+ , Option ['I'] ["include"] (ReqArg (setIncludedir) "Directory") "include path for the header files"+ ]++addRenamedTypes :: String -> Options -> Options+addRenamedTypes l = + case splitBy '|' l of+ [t1,t2] -> modRenamedtypes ((t1,t2):)+ _ -> id++main :: IO ()+main = do + args <- getArgs+ let (actions, rest, errs) = getOpt Permute options args+ when (not (null errs) || null rest) $ do+ mapM_ putStrLn errs+ pr <- getProgName+ putStrLn $ usageInfo ("Usage: " ++ pr ++ " <options> <C++ header files>") options+ exitWith (ExitFailure 1)+ let prevopts = foldl' (flip ($)) defaultOptions actions+ opts <- handleInterfaceFile (interfacefile prevopts) None handleOptionsLine prevopts+ contents <- mapM readFile (map (if null (includedir opts) then id else (includedir opts </>)) rest)+ let parses = map parseHeader contents+ (perrs, press) = partitionEithers parses+ case perrs of+ ((str, err):_) -> do+ putStrLn str+ putStrLn $ "Could not parse: " ++ show err+ exitWith (ExitFailure 1)+ [] -> do+ if dumpmode opts+ then print press+ else do + handleParses (outputdir opts) + (includefiles opts) + (excludepatterns opts) + (excludeclasses opts) + (if checksuperclasses opts + then Just (excludebases opts) + else Nothing) + (renamedtypes opts) + $ zip (map takeFileName rest) press+ exitWith ExitSuccess++handleOptionsLine :: String -> State InterfaceState (Options -> Options)+handleOptionsLine = + processor None+ [(Exclude, \n -> modExcludepatterns (n:)),+ (Header, \n -> modIncludefiles (n:)),+ (Rename, \n -> addRenamedTypes n),+ (ExcludeClass, \n -> modExcludeclasses (n:))]+ [("@exclude", Exclude),+ ("@header", Header),+ ("@rename", Rename),+ ("@exclude-class", ExcludeClass)]++data InterfaceState = None | Exclude | ExcludeClass | Header | Rename+ deriving (Eq)++handleParses :: FilePath -> [FilePath] -> [String] -> [String] -> Maybe [String] -> [(String, String)] -> [(FilePath, [Object])] -> IO ()+handleParses outdir incfiles excls exclclasses exclbases rens objs = do+ createDirectoryIfMissing True outdir+ case exclbases of+ Just ex -> checkSuperClasses ex (concatMap snd objs)+ Nothing -> return ()+ mapM_ (uncurry $ handleHeader outdir incfiles exclclasses excls rens) objs++checkSuperClasses :: [String] -> [Object] -> IO ()+checkSuperClasses excls objs = do+ let classes = nub $ getClasses objs+ superclasses = map inheritname $ filter (\i -> inheritlevel i == Public) $ concatMap classinherits classes+ missing = S.difference (S.fromList superclasses) (S.fromList $ map getObjName classes)+ missingrest = S.filter (\s -> not $ or (map (\e -> s =~ e) excls)) missing+ when (not $ S.null missingrest) $ do+ hPutStrLn stderr "Error: the following base classes could not be found: "+ forM_ (S.toList missingrest) $ \s -> do+ hPrintf stderr " %-40s\n" s+ exitWith (ExitFailure 3)+
+ src/Options.hs view
@@ -0,0 +1,34 @@+module Options(handleInterfaceFile,+ processor)+where++import Control.Monad.State++handleInterfaceFile :: FilePath -> b -> (String -> State b (a -> a)) -> a -> IO a+handleInterfaceFile inputFile initState fun oldopts + | null inputFile = return oldopts+ | otherwise = do+ contents <- readFile inputFile+ let ls = lines contents+ return $ flip evalState initState (parseInterfaceFile fun ls oldopts)++parseInterfaceFile :: (String -> State b (a -> a)) -> [String] -> a -> State b a+parseInterfaceFile _ [] opts = return opts+parseInterfaceFile fun (l:ls) opts = do+ ofun <- fun l+ parseInterfaceFile fun ls (ofun opts)++processor :: (Eq b) => b -> [(b, (String -> a -> a))] -> [(String, b)] -> String -> State b (a -> a)+processor none actions labels l = do+ case l of+ ('#':_) -> return id -- comment+ "" -> return id+ ('~':_) -> put none >> return id+ txt -> case lookup l labels of+ Just lb -> put lb >> return id+ Nothing -> do+ lb <- get+ return $ case lookup lb actions of+ Just act -> act txt+ Nothing -> id+
+ src/Utils.hs view
@@ -0,0 +1,63 @@+module Utils+where++import Data.Char++import Text.Regex.Posix+import Safe++toCapital = map toUpper++capitalize [] = []+capitalize (h:hs) = toUpper h : hs++decapitalize [] = []+decapitalize (h:hs) = toLower h : hs++replace :: String -> String -> String -> String+replace old new str = + let (s1, s2, s3) = str =~ old+ in if s2 /= ""+ then s1 ++ new ++ s3+ else str++splitBy :: Char -> String -> [String]+splitBy c str = + let (w1, rest) = break (== c) str+ in if null rest+ then if null w1 then [] else [w1]+ else w1 : splitBy c (tailSafe rest)++stripWhitespace :: String -> String+stripWhitespace = snd . foldr go (True, "") . dropWhile (== ' ')+ where go ' ' (True, acc) = (True, acc)+ go x (_, acc) = (False, x:acc)++switch :: (Eq a) => a -> [(a, b)] -> b -> b+switch _ [] df = df+switch v ((n, f):ns) df+ | v == n = f+ | otherwise = switch v ns df++getSuffixBy :: Char -> String -> String+getSuffixBy c = fst . foldr go ("", True)+ where go x (acc, True) | x == c = (acc, False)+ | otherwise = ((x:acc), True)+ go _ (acc, False) = (acc, False)++apFst :: (a -> c) -> (a, b) -> (c, b)+apFst fun (a, b) = (fun a, b)++apSnd :: (b -> c) -> (a, b) -> (a, c)+apSnd fun (a, b) = (a, fun b)++for :: [a] -> (a -> b) -> [b]+for = flip map++swap :: (a, b) -> (b, a)+swap (a, b) = (b, a)++expand :: [(a, [b])] -> [(a, b)]+expand = concat . foldr go []+ where go (a, bs) acc = zip (repeat a) bs : acc+