diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/cgen.cabal b/cgen.cabal new file mode 100644 --- /dev/null +++ b/cgen.cabal @@ -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 + diff --git a/src/CgenHs.hs b/src/CgenHs.hs new file mode 100644 --- /dev/null +++ b/src/CgenHs.hs @@ -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 + 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 + diff --git a/src/CppGen.hs b/src/CppGen.hs new file mode 100644 --- /dev/null +++ b/src/CppGen.hs @@ -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::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 + diff --git a/src/CppUtils.hs b/src/CppUtils.hs new file mode 100644 --- /dev/null +++ b/src/CppUtils.hs @@ -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 + diff --git a/src/DeriveMod.hs b/src/DeriveMod.hs new file mode 100644 --- /dev/null +++ b/src/DeriveMod.hs @@ -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)])) []]] + diff --git a/src/GrGen.hs b/src/GrGen.hs new file mode 100644 --- /dev/null +++ b/src/GrGen.hs @@ -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 + 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 + diff --git a/src/HaskellGen.hs b/src/HaskellGen.hs new file mode 100644 --- /dev/null +++ b/src/HaskellGen.hs @@ -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 + diff --git a/src/HeaderData.hs b/src/HeaderData.hs new file mode 100644 --- /dev/null +++ b/src/HeaderData.hs @@ -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 + diff --git a/src/HeaderParser.hs b/src/HeaderParser.hs new file mode 100644 --- /dev/null +++ b/src/HeaderParser.hs @@ -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 + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 + 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) + diff --git a/src/Options.hs b/src/Options.hs new file mode 100644 --- /dev/null +++ b/src/Options.hs @@ -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 + diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -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 +