module Data.GI.CodeGen.CodeGen
( genConstant
, genFunction
, genModule
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
import Data.Traversable (traverse)
#endif
import Control.Monad (forM, forM_, when, unless, filterM)
import Data.List (nub)
import Data.Maybe (fromJust, fromMaybe, catMaybes, mapMaybe)
import Data.Monoid ((<>))
import qualified Data.Map as M
import qualified Data.Text as T
import Data.Text (Text)
import Data.GI.CodeGen.API
import Data.GI.CodeGen.Callable (genCCallableWrapper)
import Data.GI.CodeGen.Config (Config(..), CodeGenFlags(..))
import Data.GI.CodeGen.Constant (genConstant)
import Data.GI.CodeGen.Code
import Data.GI.CodeGen.EnumFlags (genEnum, genFlags)
import Data.GI.CodeGen.Fixups (dropMovedItems, guessPropertyNullability,
detectGObject)
import Data.GI.CodeGen.GObject
import Data.GI.CodeGen.Haddock (deprecatedPragma, addModuleDocumentation)
import Data.GI.CodeGen.Inheritance (instanceTree, fullObjectMethodList,
fullInterfaceMethodList)
import Data.GI.CodeGen.Properties (genInterfaceProperties, genObjectProperties,
genNamespacedPropLabels)
import Data.GI.CodeGen.OverloadedSignals (genInterfaceSignals, genObjectSignals)
import Data.GI.CodeGen.OverloadedMethods (genMethodList, genMethodInfo,
genUnsupportedMethodInfo)
import Data.GI.CodeGen.Signal (genSignal, genCallback)
import Data.GI.CodeGen.Struct (genStructOrUnionFields, extractCallbacksInStruct,
fixAPIStructs, ignoreStruct, genZeroStruct, genZeroUnion,
genWrappedPtr)
import Data.GI.CodeGen.SymbolNaming (upperName, classConstraint, noName,
submoduleLocation, lowerName)
import Data.GI.CodeGen.Type
import Data.GI.CodeGen.Util (tshow)
genFunction :: Name -> Function -> CodeGen ()
genFunction n (Function symbol fnMovedTo callable) =
when (Nothing == fnMovedTo) $
group $ do
line $ "-- function " <> symbol
handleCGExc (\e -> line ("-- XXX Could not generate function "
<> symbol
<> "\n-- Error was : " <> describeCGError e))
(do
genCCallableWrapper n symbol callable
exportMethod (lowerName n) (lowerName n)
)
genBoxedObject :: Name -> Text -> CodeGen ()
genBoxedObject n typeInit = do
let name' = upperName n
group $ do
line $ "foreign import ccall \"" <> typeInit <> "\" c_" <>
typeInit <> " :: "
indent $ line "IO GType"
group $ do
line $ "instance BoxedObject " <> name' <> " where"
indent $ line $ "boxedType _ = c_" <> typeInit
hsBoot $ line $ "instance BoxedObject " <> name' <> " where"
genStruct :: Name -> Struct -> CodeGen ()
genStruct n s = unless (ignoreStruct n s) $ do
let name' = upperName n
let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")"
hsBoot decl
decl
addModuleDocumentation (structDocumentation s)
if structIsBoxed s
then genBoxedObject n (fromJust $ structTypeInit s)
else genWrappedPtr n (structAllocationInfo s) (structSize s)
exportDecl (name' <> ("(..)"))
genZeroStruct n s
noName name'
genStructOrUnionFields n (structFields s)
methods <- forM (structMethods s) $ \f -> do
let mn = methodName f
isFunction <- symbolFromFunction (methodSymbol f)
if not isFunction
then handleCGExc
(\e -> line ("-- XXX Could not generate method "
<> name' <> "::" <> name mn <> "\n"
<> "-- Error was : " <> describeCGError e) >>
return Nothing)
(genMethod n f >> return (Just (n, f)))
else return Nothing
cfg <- config
when (cgOverloadedMethods (cgFlags cfg)) $
genMethodList n (catMaybes methods)
genUnion :: Name -> Union -> CodeGen ()
genUnion n u = do
let name' = upperName n
let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")"
hsBoot decl
decl
addModuleDocumentation (unionDocumentation u)
if unionIsBoxed u
then genBoxedObject n (fromJust $ unionTypeInit u)
else genWrappedPtr n (unionAllocationInfo u) (unionSize u)
exportDecl (name' <> "(..)")
genZeroUnion n u
noName name'
genStructOrUnionFields n (unionFields u)
methods <- forM (unionMethods u) $ \f -> do
let mn = methodName f
isFunction <- symbolFromFunction (methodSymbol f)
if not isFunction
then handleCGExc
(\e -> line ("-- XXX Could not generate method "
<> name' <> "::" <> name mn <> "\n"
<> "-- Error was : " <> describeCGError e)
>> return Nothing)
(genMethod n f >> return (Just (n, f)))
else return Nothing
cfg <- config
when (cgOverloadedMethods (cgFlags cfg)) $
genMethodList n (catMaybes methods)
fixMethodArgs :: Callable -> Callable
fixMethodArgs c = c { args = args'' , returnType = returnType' }
where
returnType' = maybe Nothing (Just . fixCArrayLength) (returnType c)
args' = map (fixDestroyers . fixClosures . fixLengthArg) (args c)
args'' = fixInstance (head args') : tail args'
fixLengthArg :: Arg -> Arg
fixLengthArg arg = arg { argType = fixCArrayLength (argType arg)}
fixCArrayLength :: Type -> Type
fixCArrayLength (TCArray zt fixed length t) =
if length > 1
then TCArray zt fixed (length+1) t
else TCArray zt fixed length t
fixCArrayLength t = t
fixDestroyers :: Arg -> Arg
fixDestroyers arg = let destroy = argDestroy arg in
if destroy > 1
then arg {argDestroy = destroy + 1}
else arg
fixClosures :: Arg -> Arg
fixClosures arg = let closure = argClosure arg in
if closure > 1
then arg {argClosure = closure + 1}
else arg
fixInstance :: Arg -> Arg
fixInstance arg = arg { mayBeNull = False
, direction = DirectionIn}
fixConstructorReturnType :: Bool -> Name -> Callable -> Callable
fixConstructorReturnType returnsGObject cn c = c { returnType = returnType' }
where
returnType' = if returnsGObject then
Just (TInterface cn)
else
returnType c
genMethod :: Name -> Method -> ExcCodeGen ()
genMethod cn m@(Method {
methodName = mn,
methodSymbol = sym,
methodCallable = c,
methodType = t
}) = do
let name' = upperName cn
returnsGObject <- maybe (return False) isGObject (returnType c)
line $ "-- method " <> name' <> "::" <> name mn
line $ "-- method type : " <> tshow t
let
mn' = mn { name = name cn <> "_" <> name mn }
let c' = if Constructor == t
then fixConstructorReturnType returnsGObject cn c
else c
c'' = if OrdinaryMethod == t
then fixMethodArgs c'
else c'
genCCallableWrapper mn' sym c''
exportMethod (lowerName mn) (lowerName mn')
cfg <- config
when (cgOverloadedMethods (cgFlags cfg)) $
genMethodInfo cn (m {methodCallable = c''})
genGObjectCasts :: Name -> Text -> [Name] -> CodeGen ()
genGObjectCasts n cn_ parents = do
let name' = upperName n
group $ do
line $ "foreign import ccall \"" <> cn_ <> "\""
indent $ line $ "c_" <> cn_ <> " :: IO GType"
group $ do
bline $ "instance GObject " <> name' <> " where"
indent $ group $ do
line $ "gobjectType _ = c_" <> cn_
className <- classConstraint n
group $ do
exportDecl className
bline $ "class GObject o => " <> className <> " o"
line $ "#if MIN_VERSION_base(4,9,0)"
line $ "instance {-# OVERLAPPABLE #-} (GObject a, O.UnknownAncestorError "
<> name' <> " a) =>"
line $ " " <> className <> " a"
line $ "#endif"
bline $ "instance " <> className <> " " <> name'
forM_ parents $ \parent -> do
pcls <- classConstraint parent
line $ "instance " <> pcls <> " " <> name'
group $ do
let safeCast = "to" <> name'
exportDecl safeCast
line $ safeCast <> " :: (MonadIO m, " <> className <> " o) => o -> m " <> name'
line $ safeCast <> " = liftIO . unsafeCastTo " <> name'
genObject :: Name -> Object -> CodeGen ()
genObject n o = do
let name' = upperName n
let t = TInterface n
isGO <- isGObject t
if not isGO
then line $ "-- APIObject \"" <> name' <>
"\" does not descend from GObject, it will be ignored."
else do
bline $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")"
exportDecl (name' <> "(..)")
addModuleDocumentation (objDocumentation o)
parents <- instanceTree n
genGObjectCasts n (objTypeInit o) (parents <> objInterfaces o)
noName name'
cfg <- config
when (cgOverloadedMethods (cgFlags cfg)) $
fullObjectMethodList n o >>= genMethodList n
forM_ (objSignals o) $ \s ->
handleCGExc
(line . (T.concat ["-- XXX Could not generate signal ", name', "::"
, sigName s
, "\n", "-- Error was : "] <>) . describeCGError)
(genSignal s n)
genObjectProperties n o
when (cgOverloadedProperties (cgFlags cfg)) $
genNamespacedPropLabels n (objProperties o) (objMethods o)
when (cgOverloadedSignals (cgFlags cfg)) $
genObjectSignals n o
forM_ (objMethods o) $ \f -> do
let mn = methodName f
handleCGExc (\e -> line ("-- XXX Could not generate method "
<> name' <> "::" <> name mn <> "\n"
<> "-- Error was : " <> describeCGError e)
>> (when (cgOverloadedMethods (cgFlags cfg)) $
genUnsupportedMethodInfo n f))
(genMethod n f)
genInterface :: Name -> Interface -> CodeGen ()
genInterface n iface = do
let name' = upperName n
line $ "-- interface " <> name' <> " "
deprecatedPragma name' $ ifDeprecated iface
bline $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")"
exportDecl (name' <> "(..)")
addModuleDocumentation (ifDocumentation iface)
noName name'
cfg <- config
forM_ (ifSignals iface) $ \s -> handleCGExc
(line . (T.concat ["-- XXX Could not generate signal ", name', "::"
, sigName s
, "\n", "-- Error was : "] <>) . describeCGError)
(genSignal s n)
when (cgOverloadedSignals (cgFlags cfg)) $
genInterfaceSignals n iface
isGO <- apiIsGObject n (APIInterface iface)
if isGO
then do
let cn_ = fromMaybe (error "GObject derived interface without a type!") (ifTypeInit iface)
gobjectPrereqs <- filterM nameIsGObject (ifPrerequisites iface)
allParents <- forM gobjectPrereqs $ \p -> (p : ) <$> instanceTree p
let uniqueParents = nub (concat allParents)
genGObjectCasts n cn_ uniqueParents
genInterfaceProperties n iface
when (cgOverloadedProperties (cgFlags cfg)) $
genNamespacedPropLabels n (ifProperties iface) (ifMethods iface)
else group $ do
cls <- classConstraint n
exportDecl cls
bline $ "class ManagedPtrNewtype a => " <> cls <> " a"
line $ "instance " <> cls <> " " <> name'
genWrappedPtr n (ifAllocationInfo iface) 0
when (not . null . ifProperties $ iface) $ group $ do
line $ "-- XXX Skipping property generation for non-GObject interface"
when (cgOverloadedMethods (cgFlags cfg)) $
fullInterfaceMethodList n iface >>= genMethodList n
forM_ (ifMethods iface) $ \f -> do
let mn = methodName f
isFunction <- symbolFromFunction (methodSymbol f)
unless isFunction $
handleCGExc
(\e -> line ("-- XXX Could not generate method "
<> name' <> "::" <> name mn <> "\n"
<> "-- Error was : " <> describeCGError e)
>> (when (cgOverloadedMethods (cgFlags cfg)) $
genUnsupportedMethodInfo n f))
(genMethod n f)
symbolFromFunction :: Text -> CodeGen Bool
symbolFromFunction sym = do
apis <- getAPIs
return $ any (hasSymbol sym . snd) $ M.toList apis
where
hasSymbol sym1 (APIFunction (Function { fnSymbol = sym2,
fnMovedTo = movedTo })) =
sym1 == sym2 && movedTo == Nothing
hasSymbol _ _ = False
genAPI :: Name -> API -> CodeGen ()
genAPI n (APIConst c) = genConstant n c
genAPI n (APIFunction f) = genFunction n f
genAPI n (APIEnum e) = genEnum n e
genAPI n (APIFlags f) = genFlags n f
genAPI n (APICallback c) = genCallback n c
genAPI n (APIStruct s) = genStruct n s
genAPI n (APIUnion u) = genUnion n u
genAPI n (APIObject o) = genObject n o
genAPI n (APIInterface i) = genInterface n i
genAPIModule :: Name -> API -> CodeGen ()
genAPIModule n api = submodule (submoduleLocation n api) $ genAPI n api
genModule' :: M.Map Name API -> CodeGen ()
genModule' apis = do
mapM_ (uncurry genAPIModule)
$ filter ((`notElem` [ Name "GLib" "Array"
, Name "GLib" "Error"
, Name "GLib" "HashTable"
, Name "GLib" "List"
, Name "GLib" "SList"
, Name "GLib" "Variant"
, Name "GObject" "Value"
, Name "GObject" "Closure"]) . fst)
$ mapMaybe (traverse dropMovedItems)
$ map fixAPIStructs
$ map guessPropertyNullability
$ map detectGObject
$ M.toList
$ apis
submodule "Callbacks" (return ())
genModule :: M.Map Name API -> CodeGen ()
genModule apis = do
line "import Data.GI.Base"
exportModule "Data.GI.Base"
let embeddedAPIs = (M.fromList
. concatMap extractCallbacksInStruct
. M.toList) apis
allAPIs <- getAPIs
recurseWithAPIs (M.union allAPIs embeddedAPIs)
(genModule' (M.union apis embeddedAPIs))