diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -454,49 +454,3 @@ FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Libraries - - If you develop a new library, and you want it to be of the greatest -possible use to the public, we recommend making it free software that -everyone can redistribute and change. You can do so by permitting -redistribution under these terms (or, alternatively, under the terms of the -ordinary General Public License). - - To apply these terms, attach the following notices to the library. It is -safest to attach them to the start of each source file to most effectively -convey the exclusion of warranty; and each file should have at least the -"copyright" line and a pointer to where the full notice is found. - - - Copyright (C) - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -Also add information on how to contact you by electronic and paper mail. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the library, if -necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the - library `Frob' (a library for tweaking knobs) written by James Random Hacker. - - , 1 April 1990 - Ty Coon, President of Vice - -That's all there is to it! diff --git a/haskell-gi.cabal b/haskell-gi.cabal --- a/haskell-gi.cabal +++ b/haskell-gi.cabal @@ -1,5 +1,5 @@ name: haskell-gi -version: 0.9 +version: 0.10 synopsis: Generate Haskell bindings for GObject Introspection capable libraries description: Generate Haskell bindings for GObject Introspection capable libraries. This includes most notably Gtk+, but many other libraries in the GObject ecosystem provide introspection data too. @@ -36,20 +36,24 @@ bytestring, xdg-basedir, xml-conduit >= 1.3.0, - haskell-gi-base == 0.9, + haskell-gi-base == 0.10, text >= 1.0, free build-tools: hsc2hs, c2hs hs-source-dirs: src other-modules: GI.GIR.Alias, + GI.GIR.Arg, GI.GIR.BasicTypes, + GI.GIR.Callable, GI.GIR.Callback, GI.GIR.Constant, GI.GIR.Deprecation, GI.GIR.Enum, GI.GIR.Field, GI.GIR.Flags, + GI.GIR.Function, + GI.GIR.Interface, GI.GIR.Method, GI.GIR.Object, GI.GIR.Parser, @@ -64,18 +68,19 @@ GI.Cabal, GI.Callable, GI.Code, + GI.CodeGen, GI.Config, GI.Constant, GI.Conversions, GI.GObject, GI.GType, GI.Inheritance, + GI.LibGIRepository, GI.OverloadedSignals, GI.Overrides, GI.PkgConfig, GI.ProjectInfo, GI.Properties, - GI.LibGIRepository, GI.Signal, GI.Struct, GI.SymbolNaming, diff --git a/src/GI/Cabal.hs b/src/GI/Cabal.hs --- a/src/GI/Cabal.hs +++ b/src/GI/Cabal.hs @@ -12,10 +12,7 @@ import Data.List (intercalate) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) -import Data.Version (Version(..), showVersion) -#if MIN_VERSION_base(4,8,0) -import Data.Version (makeVersion) -#endif +import Data.Version (Version(..)) import qualified Data.Map as M import qualified Data.Text as T import Data.Text (Text) @@ -44,22 +41,25 @@ haskellGIAPIVersion :: Int haskellGIAPIVersion = (head . versionBranch) version -#if !MIN_VERSION_base(4,8,0) --- Create a version without tags, which we ignore anyway. The --- versionTags constructor field is deprecated in base 4.8.0. -makeVersion :: [Int] -> Version -makeVersion branch = Version branch [] -#endif +-- | Obtain the minor version. That is, if the given version numbers +-- are x.y.z, so branch is [x,y,z], we return y. +minorVersion :: [Int] -> Int +minorVersion (_:y:_) = y +minorVersion v = error $ "Programming error: the haskell-gi version does not have at least two components: " ++ show v ++ "." -haskellGIRevision :: String -haskellGIRevision = - showVersion $ makeVersion (tail (versionBranch version)) +-- | Obtain the haskell-gi minor version. Notice that we only append +-- the minor version here, ignoring revisions. (So if the version is +-- x.y.z, we drop the "z" part.) This gives us a mechanism for +-- releasing bug-fix releases of haskell-gi without increasing the +-- necessary dependency on haskell-gi-base, which only depends on x.y. +haskellGIMinor :: Int +haskellGIMinor = minorVersion (versionBranch version) {- | -If the haskell-gi version is of the form x.y and the pkgconfig version -of the package being wrapped is a.b.c, this gives something of the -form x.a.b.y. +If the haskell-gi version is of the form x.y[.z] and the pkgconfig +version of the package being wrapped is a.b.c, this gives something of +the form x.a.b.y. This strange seeming-rule is so that the packages that we produce follow the PVP, assuming that the package being wrapped follows the @@ -84,7 +84,7 @@ giModuleVersion :: Int -> Int -> Text giModuleVersion major minor = T.pack $ show haskellGIAPIVersion ++ "." ++ show major ++ "." - ++ show minor ++ "." ++ haskellGIRevision + ++ show minor ++ "." ++ show haskellGIMinor -- | Smallest version not backwards compatible with the current -- version (according to PVP). @@ -157,10 +157,11 @@ intercalate ", " [base, base ++ "Attributes", base ++ "Signals"] line $ padTo 20 "pkgconfig-depends:" ++ T.unpack pcName ++ " >= " ++ show major ++ "." ++ show minor - line $ padTo 20 "build-depends: base >= 4.6 && <4.9," + line $ padTo 20 "build-depends: base >= 4.7 && <5," indent $ do - line $ "haskell-gi-base >= " ++ showVersion version - ++ " && < " ++ show (haskellGIAPIVersion + 1) ++ "," + line $ "haskell-gi-base >= " + ++ show haskellGIAPIVersion ++ "." ++ show haskellGIMinor + ++ " && < " ++ show (haskellGIAPIVersion + 1) ++ "," forM_ deps $ \dep -> do let depName = girNSName dep depVersion = girNSVersion dep diff --git a/src/GI/Callable.hs b/src/GI/Callable.hs --- a/src/GI/Callable.hs +++ b/src/GI/Callable.hs @@ -17,7 +17,7 @@ import Data.Bool (bool) import Data.List (intercalate, nub, (\\)) import Data.Maybe (isJust) -import Data.Typeable (TypeRep, tyConName, typeRepTyCon, typeOf) +import Data.Typeable (TypeRep, typeOf) import qualified Data.Map as Map import qualified Data.Text as T import Data.Text (Text) @@ -90,9 +90,13 @@ -- type. TGList _ -> return False TGSList _ -> return False - _ -> if isNullable (argType arg) - then return True - else badIntroError $ "argument \"" ++ T.unpack (argName arg) ++ "\" is not of nullable type, but it is marked as such." + _ -> do + nullable <- isNullable (argType arg) + if nullable + then return True + else badIntroError $ "argument \"" ++ T.unpack (argName arg) + ++ "\" is not of nullable type (" ++ show (argType arg) + ++ "), but it is marked as such." else return False -- Given the list of arguments returns the list of constraints and the @@ -299,10 +303,10 @@ prefix ++ lcFirst n ++ "Wrapper") _ -> error $ "prepareInCallback : Not an interface! " ++ ppShow arg - fC <- tyConName <$> typeRepTyCon <$> foreignType (argType arg) + when (scope == ScopeTypeAsync) $ do + ft <- show <$> foreignType (argType arg) + line $ ptrName ++ " <- callocMem :: IO (Ptr (" ++ ft ++ "))" - when (scope == ScopeTypeAsync) $ - line $ ptrName ++ " <- callocBytes $ sizeOf (undefined :: " ++ fC ++ ")" wrapMaybe arg >>= bool (do let name' = prime name @@ -609,7 +613,7 @@ convertResult :: Map.Map String String -> ExcCodeGen String convertResult nameMap = if ignoreReturn || returnType callable == TBasicType TVoid - then return undefined + then return (error "convertResult: unreachable code reached, bug!") else do if returnMayBeNull callable then do @@ -618,7 +622,12 @@ converted <- unwrappedConvertResult "result'" line $ "return " ++ converted return "maybeResult" - else unwrappedConvertResult "result" + else do + nullable <- isNullable (returnType callable) + when nullable $ + line $ "checkUnexpectedReturnNULL \"" ++ T.unpack symbol + ++ "\" result" + unwrappedConvertResult "result" where unwrappedConvertResult rname = case returnType callable of diff --git a/src/GI/CodeGen.hs b/src/GI/CodeGen.hs new file mode 100644 --- /dev/null +++ b/src/GI/CodeGen.hs @@ -0,0 +1,518 @@ +module GI.CodeGen + ( genConstant + , genFunction + , genPrelude + , 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 Control.Monad.Writer (tell) +import Data.List (intercalate, nub) +import Data.Tuple (swap) +import Data.Maybe (fromJust, fromMaybe) +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Text as T +import Data.Text (Text) + +import Foreign.Storable (sizeOf) +import Foreign.C (CUInt) + +import GI.API +import GI.Callable (genCallable) +import GI.Constant (genConstant) +import GI.Code +import GI.GObject +import GI.Inheritance (instanceTree) +import GI.Signal (genSignal, genCallback) +import GI.Struct (genStructOrUnionFields, extractCallbacksInStruct, + fixAPIStructs, ignoreStruct) +import GI.SymbolNaming (upperName, ucFirst, classConstraint, noName) +import GI.Type + +genFunction :: Name -> Function -> CodeGen () +genFunction n (Function symbol throws callable) = do + line $ "-- function " ++ T.unpack symbol + handleCGExc (\e -> line ("-- XXX Could not generate function " + ++ T.unpack symbol + ++ "\n-- Error was : " ++ describeCGError e)) + (genCallable n symbol callable throws) + +genBoxedObject :: Name -> Text -> CodeGen () +genBoxedObject n typeInit = do + name' <- upperName n + + group $ do + line $ "foreign import ccall \"" ++ T.unpack typeInit ++ "\" c_" ++ + T.unpack typeInit ++ " :: " + indent $ line "IO GType" + group $ do + line $ "instance BoxedObject " ++ name' ++ " where" + indent $ line $ "boxedType _ = c_" ++ T.unpack typeInit + +genBoxedEnum :: Name -> Text -> CodeGen () +genBoxedEnum n typeInit = do + name' <- upperName n + + group $ do + line $ "foreign import ccall \"" ++ T.unpack typeInit ++ "\" c_" ++ + T.unpack typeInit ++ " :: " + indent $ line "IO GType" + group $ do + line $ "instance BoxedEnum " ++ name' ++ " where" + indent $ line $ "boxedEnumType _ = c_" ++ T.unpack typeInit + +genEnumOrFlags :: Name -> Enumeration -> ExcCodeGen () +genEnumOrFlags n@(Name ns name) (Enumeration fields eDomain maybeTypeInit storageBytes isDeprecated) = do + -- Conversion functions expect enums and flags to map to CUInt, + -- which we assume to be of 32 bits. Fail early, instead of giving + -- strange errors at runtime. + when (sizeOf (0 :: CUInt) /= 4) $ + notImplementedError $ "Unsupported CUInt size: " ++ show (sizeOf (0 :: CUInt)) + when (storageBytes /= 4) $ + notImplementedError $ "Storage of size /= 4 not supported : " ++ show storageBytes + + name' <- upperName n + fields' <- forM fields $ \(fieldName, value) -> do + n <- upperName $ Name ns (name ++ "_" ++ T.unpack fieldName) + return (n, value) + + line $ deprecatedPragma name' isDeprecated + + group $ do + line $ "data " ++ name' ++ " = " + indent $ + case fields' of + ((fieldName, _value):fs) -> do + line $ " " ++ fieldName + forM_ fs $ \(n, _) -> line $ "| " ++ n + line $ "| Another" ++ name' ++ " Int" + line "deriving (Show, Eq)" + _ -> return () + group $ do + line $ "instance Enum " ++ name' ++ " where" + indent $ do + forM_ fields' $ \(n, v) -> + line $ "fromEnum " ++ n ++ " = " ++ show v + line $ "fromEnum (Another" ++ name' ++ " k) = k" + let valueNames = M.toList . M.fromListWith (curry snd) $ map swap fields' + blank + indent $ do + forM_ valueNames $ \(v, n) -> + line $ "toEnum " ++ show v ++ " = " ++ n + line $ "toEnum k = Another" ++ name' ++ " k" + maybe (return ()) (genErrorDomain name') eDomain + maybe (return ()) (genBoxedEnum n) maybeTypeInit + +genEnum :: Name -> Enumeration -> CodeGen () +genEnum n@(Name _ name) enum = do + line $ "-- Enum " ++ name + + handleCGExc (\e -> line $ "-- XXX Could not generate: " ++ describeCGError e) + (genEnumOrFlags n enum) + +-- Very similar to enums, but we also declare ourselves as members of +-- the IsGFlag typeclass. +genFlags :: Name -> Flags -> CodeGen () +genFlags n@(Name _ name) (Flags enum) = do + line $ "-- Flags " ++ name + + handleCGExc (\e -> line $ "-- XXX Could not generate: " ++ describeCGError e) + (do + genEnumOrFlags n enum + + name' <- upperName n + group $ line $ "instance IsGFlag " ++ name') + +genErrorDomain :: String -> Text -> CodeGen () +genErrorDomain name' domain = do + group $ do + line $ "instance GErrorClass " ++ name' ++ " where" + indent $ line $ + "gerrorClassDomain _ = \"" ++ T.unpack domain ++ "\"" + -- Generate type specific error handling (saves a bit of typing, and + -- it's clearer to read). + group $ do + let catcher = "catch" ++ name' + line $ catcher ++ " ::" + indent $ do + line "IO a ->" + line $ "(" ++ name' ++ " -> GErrorMessage -> IO a) ->" + line "IO a" + line $ catcher ++ " = catchGErrorJustDomain" + group $ do + let handler = "handle" ++ name' + line $ handler ++ " ::" + indent $ do + line $ "(" ++ name' ++ " -> GErrorMessage -> IO a) ->" + line "IO a ->" + line "IO a" + line $ handler ++ " = handleGErrorJustDomain" + +genStruct :: Name -> Struct -> CodeGen () +genStruct n s = unless (ignoreStruct n s) $ do + name' <- upperName n + line $ "-- struct " ++ name' + + line $ "newtype " ++ name' ++ " = " ++ name' ++ " (ForeignPtr " ++ name' ++ ")" + + noName name' + + when (structIsBoxed s) $ + genBoxedObject n (fromJust $ structTypeInit s) + + -- Generate code for fields. + genStructOrUnionFields n (structFields s) + + -- Methods + forM_ (structMethods s) $ \(mn, f) -> + do isFunction <- symbolFromFunction (methodSymbol f) + unless isFunction $ + handleCGExc + (\e -> line ("-- XXX Could not generate method " + ++ name' ++ "::" ++ name mn ++ "\n" + ++ "-- Error was : " ++ describeCGError e)) + (genMethod n mn f) + +genUnion :: Name -> Union -> CodeGen () +genUnion n u = do + name' <- upperName n + + line $ "-- union " ++ name' ++ " " + + line $ "newtype " ++ name' ++ " = " ++ name' ++ " (ForeignPtr " ++ name' ++ ")" + + noName name' + + when (unionIsBoxed u) $ + genBoxedObject n (fromJust $ unionTypeInit u) + + -- Generate code for fields. + genStructOrUnionFields n (unionFields u) + + -- Methods + forM_ (unionMethods u) $ \(mn, f) -> + do isFunction <- symbolFromFunction (methodSymbol f) + unless isFunction $ + handleCGExc + (\e -> line ("-- XXX Could not generate method " + ++ name' ++ "::" ++ name mn ++ "\n" + ++ "-- Error was : " ++ describeCGError e)) + (genMethod n mn f) + +-- Add the implicit object argument to methods of an object. Since we +-- are prepending an argument we need to adjust the offset of the +-- length arguments of CArrays, and closure and destroyer offsets. +fixMethodArgs :: Name -> Callable -> Callable +fixMethodArgs cn c = c { args = args' , returnType = returnType' } + where + returnType' = fixCArrayLength $ returnType c + args' = objArg : map (fixDestroyers . fixClosures . fixLengthArg) (args c) + + 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 + + objArg = Arg { + argName = "_obj", + argType = TInterface (namespace cn) (name cn), + direction = DirectionIn, + mayBeNull = False, + argScope = ScopeTypeInvalid, + argClosure = -1, + argDestroy = -1, + transfer = TransferNothing } + +-- For constructors we want to return the actual type of the object, +-- rather than a generic superclass (so Gtk.labelNew returns a +-- Gtk.Label, rather than a Gtk.Widget) +fixConstructorReturnType :: Bool -> Name -> Callable -> Callable +fixConstructorReturnType returnsGObject cn c = c { returnType = returnType' } + where + returnType' = if returnsGObject then + TInterface (namespace cn) (name cn) + else + returnType c + +genMethod :: Name -> Name -> Method -> ExcCodeGen () +genMethod cn mn (Method { + methodSymbol = sym, + methodCallable = c, + methodType = t, + methodThrows = throws + }) = do + name' <- upperName cn + returnsGObject <- isGObject (returnType c) + line $ "-- method " ++ name' ++ "::" ++ name mn + line $ "-- method type : " ++ show t + let -- Mangle the name to namespace it to the class. + 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 cn c' + else c' + genCallable mn' sym c'' throws + +-- Type casting with type checking +genGObjectCasts :: Bool -> Name -> Text -> [Name] -> CodeGen () +genGObjectCasts isIU n cn_ parents = do + name' <- upperName n + qualifiedParents <- traverse upperName parents + + group $ do + line $ "foreign import ccall \"" ++ T.unpack cn_ ++ "\"" + indent $ line $ "c_" ++ T.unpack cn_ ++ " :: IO GType" + + group $ do + line $ "type instance ParentTypes " ++ name' ++ " = '[" ++ + intercalate ", " qualifiedParents ++ "]" + + group $ do + line $ "instance GObject " ++ name' ++ " where" + indent $ group $ do + line $ "gobjectIsInitiallyUnowned _ = " ++ show isIU + line $ "gobjectType _ = c_" ++ T.unpack cn_ + + let className = classConstraint name' + group $ do + line $ "class GObject o => " ++ className ++ " o" + line $ "instance (GObject o, IsDescendantOf " ++ name' ++ " o) => " + ++ className ++ " o" + + -- Safe downcasting. + group $ do + let safeCast = "to" ++ name' + line $ safeCast ++ " :: " ++ className ++ " o => o -> IO " ++ name' + line $ safeCast ++ " = unsafeCastTo " ++ name' + +-- Wrap a given Object. We enforce that every Object that we wrap is a +-- GObject. This is the case for everything expect the ParamSpec* set +-- of objects, we deal with these separately. Notice that in the case +-- that a non-GObject Object is passed, it is simply ignored silently +-- by the handler in handleCGExc below. +genObject :: Name -> Object -> CodeGen () +genObject n o = handleCGExc (\_ -> return ()) $ do + name' <- upperName n + + line $ "-- object " ++ name' ++ " " + + let t = (\(Name ns' n') -> TInterface ns' n') n + isGO <- isGObject t + unless isGO $ notImplementedError $ "APIObject \"" ++ name' ++ + "\" does not descend from GObject, it will be ignored." + + line $ "newtype " ++ name' ++ " = " ++ name' ++ " (ForeignPtr " ++ name' ++ ")" + + noName name' + + -- Type safe casting to parent objects, and implemented interfaces. + isIU <- isInitiallyUnowned t + parents <- instanceTree n + genGObjectCasts isIU n (objTypeInit o) (parents ++ objInterfaces o) + + -- Methods + forM_ (objMethods o) $ \(mn, f) -> + handleCGExc + (\e -> line ("-- XXX Could not generate method " + ++ name' ++ "::" ++ name mn ++ "\n" + ++ "-- Error was : " ++ describeCGError e)) + (genMethod n mn f) + + -- And finally signals + forM_ (objSignals o) $ \s -> + handleCGExc + (line . (concat ["-- XXX Could not generate signal ", name', "::" + , (T.unpack . sigName) s + , "\n", "-- Error was : "] ++) . describeCGError) + (genSignal s n) + +genInterface :: Name -> Interface -> CodeGen () +genInterface n iface = do + -- For each interface, we generate a class IFoo and a data structure + -- Foo. We only really need a separate Foo so that we can return + -- them from bound functions. In principle we might be able to do + -- something more elegant with existential types. + + name' <- upperName n + line $ "-- interface " ++ name' ++ " " + line $ deprecatedPragma name' $ ifDeprecated iface + line $ "newtype " ++ name' ++ " = " ++ name' ++ " (ForeignPtr " ++ name' ++ ")" + + noName name' + + isGO <- apiIsGObject n (APIInterface iface) + if isGO + then do + let cn_ = fromMaybe (error "GObject derived interface without a type!") (ifTypeInit iface) + isIU <- apiIsInitiallyUnowned n (APIInterface iface) + gobjectPrereqs <- filterM nameIsGObject (ifPrerequisites iface) + allParents <- forM gobjectPrereqs $ \p -> (p : ) <$> instanceTree p + let uniqueParents = nub (concat allParents) + genGObjectCasts isIU n cn_ uniqueParents + else group $ do + let cls = classConstraint name' + line $ "class ForeignPtrNewtype a => " ++ cls ++ " a" + line $ "instance (ForeignPtrNewtype o, IsDescendantOf " ++ name' ++ " o) => " ++ cls ++ " o" + line $ "type instance ParentTypes " ++ name' ++ " = '[]" + + -- Methods + forM_ (ifMethods iface) $ \(mn, f) -> do + isFunction <- symbolFromFunction (methodSymbol f) + unless isFunction $ + handleCGExc + (\e -> line ("-- XXX Could not generate method " + ++ name' ++ "::" ++ name mn ++ "\n" + ++ "-- Error was : " ++ describeCGError e)) + (genMethod n mn f) + + -- And finally signals + forM_ (ifSignals iface) $ \s -> handleCGExc + (line . (concat ["-- XXX Could not generate signal ", name', "::" + , (T.unpack . sigName) s + , "\n", "-- Error was : "] ++) . describeCGError) + (genSignal s n) + +-- Some type libraries include spurious interface/struct methods, +-- where a method Mod.Foo::func also appears as an ordinary function +-- in the list of APIs. If we find a matching function, we don't +-- generate the method. +-- +-- It may be more expedient to keep a map of symbol -> function. +-- +-- XXX Maybe the GIR helps here? Sometimes such functions are +-- annotated with the "moved-to". +symbolFromFunction :: Text -> CodeGen Bool +symbolFromFunction sym = do + apis <- getAPIs + return $ any (hasSymbol sym . snd) $ M.toList apis + where + hasSymbol sym1 (APIFunction (Function { fnSymbol = sym2 })) = sym1 == sym2 + 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 + +genPrelude :: String -> String -> CodeGen () +genPrelude name modulePrefix = do + let mp = (modulePrefix ++) + + line "-- Generated code." + blank + line "{-# OPTIONS_GHC -fno-warn-unused-imports #-}" + blank + line "{-# LANGUAGE ForeignFunctionInterface, ConstraintKinds," + line " TypeFamilies, MultiParamTypeClasses, KindSignatures," + line " FlexibleInstances, UndecidableInstances, DataKinds," + line " OverloadedStrings, NegativeLiterals, FlexibleContexts #-}" + blank + -- XXX: Generate export list. + line $ "module " ++ mp name ++ " where" + blank + -- The Prelude functions often clash with variable names or + -- functions defined in the bindings, so we only import the + -- necessary minimum into our namespace. + line "import Prelude ()" + line "import Data.GI.Base.ShortPrelude" + line "import Data.Char" + line "import Data.Int" + line "import Data.Word" + line "import qualified Data.ByteString.Char8 as B" + line "import Data.ByteString.Char8 (ByteString)" + line "import qualified Data.Map as Map" + line "import Foreign.C" + line "import Foreign.Ptr" + line "import Foreign.ForeignPtr" + line "import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)" + line "import Foreign.Storable (peek, poke, sizeOf)" + line "import Control.Applicative ((<$>))" + line "import Control.Exception (onException)" + line "import Control.Monad.IO.Class" + line "import qualified Data.Text as T" + blank + line "import Data.GI.Base.Attributes hiding (get, set)" + line "import Data.GI.Base.BasicTypes" + line "import Data.GI.Base.BasicConversions" + line "import Data.GI.Base.Closure" + line "import Data.GI.Base.GError" + line "import Data.GI.Base.GHashTable" + line "import Data.GI.Base.GParamSpec" + line "import Data.GI.Base.GVariant" + line "import Data.GI.Base.GValue" + line "import Data.GI.Base.ManagedPtr" + line "import Data.GI.Base.Overloading" + line "import Data.GI.Base.Properties hiding (new)" + line "import Data.GI.Base.Signals (SignalConnectMode(..), connectSignalFunPtr, SignalHandlerId)" + line "import Data.GI.Base.Utils" + blank + +genModule :: String -> [(Name, API)] -> String -> CodeGen () +genModule name apis modulePrefix = do + let mp = (modulePrefix ++) + name' = ucFirst name + + -- Any module depends on itself, load the information onto the state + -- of the monad. This has to be done early, so symbolFromFunction + -- above has access to it. It would probably be better to prune the + -- duplicated method/functions in advance, and get rid of + -- symbolFromFunction and this loadDependency altogether. + loadDependency name + + -- Some API symbols are embedded into structures, extract these and + -- inject them into the set of APIs loaded and being generated. + let embeddedAPIs = concatMap extractCallbacksInStruct apis + injectAPIs embeddedAPIs + + code <- recurse' $ mapM_ (uncurry genAPI) $ + -- We provide these ourselves + 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) $ + -- Some callback types are defined inside structs + map fixAPIStructs $ (++ embeddedAPIs) apis + + genPrelude name' modulePrefix + deps <- S.toList <$> getDeps + forM_ deps $ \i -> when (i /= name) $ do + line $ "import qualified " ++ mp (ucFirst i) ++ " as " ++ ucFirst i + line $ "import qualified " ++ mp (ucFirst i) ++ "Attributes as " + ++ ucFirst i ++ "A" + blank + + tell code diff --git a/src/GI/Conversions.hs b/src/GI/Conversions.hs --- a/src/GI/Conversions.hs +++ b/src/GI/Conversions.hs @@ -698,8 +698,8 @@ api <- findAPI t prefix <- qualify ns return $ case api of - Just (APICallback _) -> T.pack ("FunPtr " ++ prefix ++ n ++ "C") - `con` [] + Just (APICallback _) -> + funptr $ T.pack (prefix ++ n ++ "C") `con` [] _ -> ptr $ T.pack (prefix ++ n) `con` [] getIsScalar :: Type -> CodeGen Bool @@ -737,12 +737,13 @@ -- Returns whether the given type is nullable in the C sense, -- i.e. whether it can be set to NULL. -isNullable :: Type -> Bool -isNullable (TBasicType TVoid) = True -isNullable (TBasicType TUTF8) = True -isNullable (TBasicType TFileName) = True -isNullable (TBasicType _) = False -isNullable _ = True +isNullable :: Type -> CodeGen Bool +isNullable (TBasicType TVoid) = return True +isNullable (TBasicType TUTF8) = return True +isNullable (TBasicType TFileName) = return True +isNullable t = do + ft <- foreignType t + return (tyConName (typeRepTyCon ft) `elem` ["Ptr", "FunPtr"]) -- If the given type maps to a list in Haskell, return the type of the -- elements, and the function that maps over them. diff --git a/src/GI/GIR/Arg.hs b/src/GI/GIR/Arg.hs new file mode 100644 --- /dev/null +++ b/src/GI/GIR/Arg.hs @@ -0,0 +1,76 @@ +module GI.GIR.Arg + ( Arg(..) + , Direction(..) + , Scope(..) + , parseArg + , parseTransfer + ) where + +import Data.Monoid ((<>)) +import Data.Text (Text) + +import GI.GIR.BasicTypes (Transfer(..)) +import GI.GIR.Parser +import GI.GIR.Type (parseType) +import GI.Type (Type) + +data Direction = DirectionIn + | DirectionOut + | DirectionInout + deriving (Show, Eq, Ord) + +data Scope = ScopeTypeInvalid + | ScopeTypeCall + | ScopeTypeAsync + | ScopeTypeNotified + deriving (Show, Eq, Ord) + +data Arg = Arg { + argName :: Text, + argType :: Type, + direction :: Direction, + mayBeNull :: Bool, + argScope :: Scope, + argClosure :: Int, + argDestroy :: Int, + transfer :: Transfer + } deriving (Show, Eq, Ord) + +parseTransfer :: Parser Transfer +parseTransfer = getAttr "transfer-ownership" >>= \case + "none" -> return TransferNothing + "container" -> return TransferContainer + "full" -> return TransferEverything + t -> parseError $ "Unknown transfer type \"" <> t <> "\"" + +parseScope :: Text -> Parser Scope +parseScope "call" = return ScopeTypeCall +parseScope "async" = return ScopeTypeAsync +parseScope "notified" = return ScopeTypeNotified +parseScope s = parseError $ "Unknown scope type \"" <> s <> "\"" + +parseDirection :: Text -> Parser Direction +parseDirection "in" = return DirectionIn +parseDirection "out" = return DirectionOut +parseDirection "inout" = return DirectionInout +parseDirection d = parseError $ "Unknown direction \"" <> d <> "\"" + +parseArg :: Parser Arg +parseArg = do + name <- getAttr "name" + ownership <- parseTransfer + scope <- optionalAttr "scope" ScopeTypeInvalid parseScope + d <- optionalAttr "direction" DirectionIn parseDirection + closure <- optionalAttr "closure" (-1) parseIntegral + destroy <- optionalAttr "destroy" (-1) parseIntegral + nullable <- optionalAttr "nullable" False parseBool + t <- parseType + return $ Arg { argName = name + , argType = t + , direction = d + , mayBeNull = nullable + , argScope = scope + , argClosure = closure + , argDestroy = destroy + , transfer = ownership + } diff --git a/src/GI/GIR/Callable.hs b/src/GI/GIR/Callable.hs new file mode 100644 --- /dev/null +++ b/src/GI/GIR/Callable.hs @@ -0,0 +1,58 @@ +module GI.GIR.Callable + ( Callable(..) + , parseCallable + ) where + +import GI.Type (Type) +import GI.GIR.Arg (Arg(..), parseArg, parseTransfer) +import GI.GIR.BasicTypes (Transfer(..)) +import GI.GIR.Parser +import GI.GIR.Type (parseType) + +data Callable = Callable { + returnType :: Type, + returnMayBeNull :: Bool, + returnTransfer :: Transfer, + args :: [Arg], + skipReturn :: Bool, + callableDeprecated :: Maybe DeprecationInfo + } deriving (Show, Eq) + +parseArgs :: Parser [Arg] +parseArgs = do + paramSets <- parseChildrenWithLocalName "parameters" parseArgSet + case paramSets of + [] -> return [] + (ps:[]) -> return ps + _ -> parseError $ "Unexpected multiple \"parameters\" tag" + where parseArgSet = parseChildrenWithLocalName "parameter" parseArg + +parseOneReturn :: Parser (Type, Bool, Transfer, Bool) +parseOneReturn = do + returnType <- parseType + mayBeNull <- optionalAttr "allow-none" False parseBool + transfer <- parseTransfer + skip <- optionalAttr "skip" False parseBool + return (returnType, mayBeNull, transfer, skip) + +parseReturn :: Parser (Type, Bool, Transfer, Bool) +parseReturn = do + returnSets <- parseChildrenWithLocalName "return-value" parseOneReturn + case returnSets of + (r:[]) -> return r + [] -> parseError $ "No return information found" + _ -> parseError $ "Multiple return values found" + +parseCallable :: Parser Callable +parseCallable = do + args <- parseArgs + (returnType, mayBeNull, transfer, skip) <- parseReturn + deprecated <- parseDeprecation + return $ Callable { + returnType = returnType + , returnMayBeNull = mayBeNull + , returnTransfer = transfer + , args = args + , skipReturn = skip + , callableDeprecated = deprecated + } diff --git a/src/GI/GIR/Function.hs b/src/GI/GIR/Function.hs new file mode 100644 --- /dev/null +++ b/src/GI/GIR/Function.hs @@ -0,0 +1,33 @@ +module GI.GIR.Function + ( Function(..) + , parseFunction + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +import GI.GIR.Callable (Callable(..), parseCallable) +import GI.GIR.Parser + +data Function = Function { + fnSymbol :: Text, + fnThrows :: Bool, + fnCallable :: Callable + } deriving Show + +parseFunction :: Parser (Name, Function) +parseFunction = do + name <- parseName + shadows <- queryAttr "shadows" + let exposedName = case shadows of + Just n -> name {name = T.unpack n} + Nothing -> name + callable <- parseCallable + symbol <- getAttrWithNamespace CGIRNS "identifier" + throws <- optionalAttr "throws" False parseBool + return $ (exposedName, + Function { + fnSymbol = symbol + , fnCallable = callable + , fnThrows = throws + }) diff --git a/src/GI/GIR/Interface.hs b/src/GI/GIR/Interface.hs new file mode 100644 --- /dev/null +++ b/src/GI/GIR/Interface.hs @@ -0,0 +1,40 @@ +module GI.GIR.Interface + ( Interface(..) + , parseInterface + ) where + +import Data.Text (Text) + +import GI.GIR.Method (Method, MethodType(..), parseMethod) +import GI.GIR.Property (Property, parseProperty) +import GI.GIR.Signal (Signal, parseSignal) +import GI.GIR.Parser + +data Interface = Interface { + ifTypeInit :: Maybe Text, + ifPrerequisites :: [Name], + ifProperties :: [Property], + ifSignals :: [Signal], + ifMethods :: [(Name, Method)], + ifDeprecated :: Maybe DeprecationInfo + } deriving Show + +parseInterface :: Parser (Name, Interface) +parseInterface = do + name <- parseName + props <- parseChildrenWithLocalName "property" parseProperty + signals <- parseChildrenWithNSName GLibGIRNS "signal" parseSignal + typeInit <- queryAttrWithNamespace GLibGIRNS "get-type" + methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod) + functions <- parseChildrenWithLocalName "function" (parseMethod MemberFunction) + constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor) + deprecated <- parseDeprecation + return (name, + Interface { + ifProperties = props + , ifPrerequisites = error ("unfixed interface " ++ show name) + , ifSignals = signals + , ifTypeInit = typeInit + , ifMethods = constructors ++ methods ++ functions + , ifDeprecated = deprecated + }) diff --git a/src/GI/Type.hs b/src/GI/Type.hs --- a/src/GI/Type.hs +++ b/src/GI/Type.hs @@ -4,6 +4,7 @@ , Type(..) , io , ptr + , funptr , con , maybeT ) where @@ -62,6 +63,9 @@ ptr :: TypeRep -> TypeRep ptr t = "Ptr" `con` [t] + +funptr :: TypeRep -> TypeRep +funptr t = "FunPtr" `con` [t] maybeT :: TypeRep -> TypeRep maybeT t = "Maybe" `con` [t] diff --git a/src/haskell-gi.hs b/src/haskell-gi.hs --- a/src/haskell-gi.hs +++ b/src/haskell-gi.hs @@ -13,7 +13,7 @@ import Data.Text (pack, unpack, Text) import System.Directory (createDirectoryIfMissing, doesFileExist) -import System.FilePath (splitPath, joinPath) +import System.FilePath (splitDirectories, joinPath) import System.Console.GetOpt import System.Exit import System.IO (hPutStr, hPutStrLn, stderr) @@ -99,7 +99,7 @@ Nothing -> return ("", ".") Just dir -> do createDirectoryIfMissing True dir - let prefix = intercalate "." (splitPath dir) ++ "." + let prefix = intercalate "." (splitDirectories dir) ++ "." return (prefix, dir) -- | Load the given API and dependencies, filtering them in the process.