cgen-0.0.1: src/HaskellGen.hs
{-# 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