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.26.8 +version: 0.26.9 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. @@ -31,7 +31,7 @@ default-language: Haskell2010 pkgconfig-depends: gobject-introspection-1.0 >= 1.32, gobject-2.0 >= 2.32 build-depends: base >= 4.11 && < 5, - haskell-gi-base >= 0.26.4 && <0.27, + haskell-gi-base >= 0.26.5 && <0.27, Cabal >= 1.24, attoparsec >= 0.13, containers, diff --git a/lib/Data/GI/CodeGen/Code.hs b/lib/Data/GI/CodeGen/Code.hs --- a/lib/Data/GI/CodeGen/Code.hs +++ b/lib/Data/GI/CodeGen/Code.hs @@ -78,7 +78,7 @@ import Control.Monad.State.Strict import Control.Monad.Except import qualified Data.Foldable as F -import Data.Maybe (fromMaybe, catMaybes) +import Data.Maybe (fromMaybe, catMaybes, mapMaybe) #if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>), mempty) #endif @@ -922,7 +922,6 @@ -- this prefix will be imported as {-# SOURCE #-}, and otherwise will -- be imported normally. importDeps :: ModulePath -> [ModulePath] -> Text -importDeps _ [] = "" importDeps (ModulePath prefix) deps = T.unlines . map toImport $ deps where toImport :: ModulePath -> Text toImport dep = let impSt = if importSource dep @@ -963,7 +962,11 @@ , "import qualified Data.Map as Map" , "import qualified Foreign.Ptr as FP" , "import qualified GHC.OverloadedLabels as OL" - , "import qualified GHC.Records as R" ] + , "import qualified GHC.Records as R" + , "import qualified Data.Word as DW" + , "import qualified Data.Int as DI" + , "import qualified System.Posix.Types as SPT" + , "import qualified Foreign.C.Types as FCT"] -- | Like `dotModulePath`, but add a "GI." prefix. dotWithPrefix :: ModulePath -> Text @@ -972,8 +975,9 @@ -- | Write to disk the code for a module, under the given base -- directory. Does not write submodules recursively, for that use -- `writeModuleTree`. -writeModuleInfo :: Bool -> Maybe FilePath -> ModuleInfo -> IO () -writeModuleInfo verbose dirPrefix minfo = do +writeModuleInfo :: Bool -> Maybe FilePath -> ModuleInfo -> + M.Map ModulePath ModuleInfo -> IO () +writeModuleInfo verbose dirPrefix minfo treeMap = do let submodulePaths = map (modulePath) (M.elems (submodules minfo)) -- We reexport any submodules. submoduleExports = map dotWithPrefix submodulePaths @@ -990,7 +994,18 @@ then "" else moduleImports pkgRoot = ModulePath (take 1 (modulePathToList $ modulePath minfo)) - deps = importDeps pkgRoot (Set.toList $ qualifiedImports minfo) + allImports = transitiveImports minfo treeMap + minimalImports = qualifiedImports minfo + allDeps = importDeps pkgRoot (Set.toList allImports) + minimalDeps = importDeps pkgRoot (Set.toList minimalImports) + deps = T.unlines [ + "-- Workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/23392", + "#if MIN_VERSION_base(4,18,0)", + allDeps, + "#else", + minimalDeps, + "#endif" + ] haddock = moduleHaddock (M.lookup ToplevelSection (sectionDocs minfo)) when verbose $ putStrLn ((T.unpack . dotWithPrefix . modulePath) minfo @@ -1002,6 +1017,33 @@ let bootFName = modulePathToFilePath dirPrefix (modulePath minfo) ".hs-boot" utf8WriteFile bootFName (genHsBoot minfo) +-- | Collect the transitive set of imports for this module. In +-- principle just importing the set of strictly necessary imports (via +-- qualifiedImports) should be sufficient; the following is a +-- workaround for a GHC bug: +-- https://gitlab.haskell.org/ghc/ghc/-/issues/23392 +transitiveImports :: ModuleInfo -> M.Map ModulePath ModuleInfo + -> Set.Set ModulePath +transitiveImports root treeMap = collectImports root Set.empty + where + collectImports :: ModuleInfo -> Set.Set ModulePath -> Set.Set ModulePath + collectImports minfo deps = let + isCallbacks (ModulePath [_, "Callbacks"]) = True + isCallbacks _ = False + + -- Deps that we haven't analysed yet. + unseenDeps = Set.filter (\e -> Set.notMember e deps) (qualifiedImports minfo) + -- Make sure we don't try to import ourselves + unrooted = Set.filter (\mp -> mp /= modulePath root) unseenDeps + unseenModules = mapMaybe (\d -> M.lookup d treeMap) (Set.toList unrooted) + -- We don't collect implicit deps from the callbacks module, + -- which is always imported normally (not just the hs-boot) + notCallbacks = filter (not . isCallbacks . modulePath) unseenModules + + -- Imports in unseenDeps + depImports = map (\m -> collectImports m (Set.union deps unseenDeps)) notCallbacks + in Set.unions (unrooted : depImports) + -- | Generate the .hs-boot file for the given module. genHsBoot :: ModuleInfo -> Text genHsBoot minfo = @@ -1018,11 +1060,19 @@ -- | Write down the code for a module and its submodules to disk under -- the given base directory. It returns the list of written modules. writeModuleTree :: Bool -> Maybe FilePath -> ModuleInfo -> IO [Text] -writeModuleTree verbose dirPrefix minfo = do - submodulePaths <- concat <$> forM (M.elems (submodules minfo)) - (writeModuleTree verbose dirPrefix) - writeModuleInfo verbose dirPrefix minfo - return $ (dotWithPrefix (modulePath minfo) : submodulePaths) +writeModuleTree verbose dirPrefix root = doWriteModuleTree root + + where + doWriteModuleTree :: ModuleInfo -> IO [Text] + doWriteModuleTree minfo = do + submodulePaths <- concat <$> forM (M.elems (submodules minfo)) doWriteModuleTree + writeModuleInfo verbose dirPrefix minfo treeMap + return $ (dotWithPrefix (modulePath minfo) : submodulePaths) + + treeMap = M.fromList (gatherSubmodules root) + gatherSubmodules :: ModuleInfo -> [(ModulePath, ModuleInfo)] + gatherSubmodules minfo = (modulePath minfo, minfo) : + concatMap gatherSubmodules (M.elems $ submodules minfo) -- | Return the list of modules `writeModuleTree` would write, without -- actually writing anything to disk. diff --git a/lib/Data/GI/CodeGen/Constant.hs b/lib/Data/GI/CodeGen/Constant.hs --- a/lib/Data/GI/CodeGen/Constant.hs +++ b/lib/Data/GI/CodeGen/Constant.hs @@ -106,5 +106,16 @@ showBasicType TGType gtype = return $ "GType " <> gtype showBasicType TIntPtr ptr = return ptr showBasicType TUIntPtr ptr = return ptr +showBasicType TShort s = return s +showBasicType TUShort u = return u +showBasicType TSSize s = return s +showBasicType TSize s = return s +showBasicType Ttime_t t = return t +showBasicType Toff_t o = return o +showBasicType Tdev_t d = return d +showBasicType Tgid_t g = return g +showBasicType Tpid_t p = return p +showBasicType Tsocklen_t l = return l +showBasicType Tuid_t u = return u -- We take care of this one separately above showBasicType TPtr _ = notImplementedError $ "Cannot directly show a pointer" diff --git a/lib/Data/GI/CodeGen/Conversions.hsc b/lib/Data/GI/CodeGen/Conversions.hsc --- a/lib/Data/GI/CodeGen/Conversions.hsc +++ b/lib/Data/GI/CodeGen/Conversions.hsc @@ -777,8 +777,8 @@ 4 -> con0 "Word32" n -> error ("Unsupported `guint' length: " ++ show n) -haskellBasicType TLong = con0 "CLong" -haskellBasicType TULong = con0 "CULong" +haskellBasicType TLong = con0 "FCT.CLong" +haskellBasicType TULong = con0 "FCT.CULong" haskellBasicType TInt8 = con0 "Int8" haskellBasicType TUInt8 = con0 "Word8" haskellBasicType TInt16 = con0 "Int16" @@ -795,6 +795,66 @@ haskellBasicType TFileName = con0 "[Char]" haskellBasicType TIntPtr = con0 "CIntPtr" haskellBasicType TUIntPtr = con0 "CUIntPtr" +haskellBasicType TShort = con0 "FCT.CShort" +haskellBasicType TUShort = con0 "FCT.CUShort" +haskellBasicType TSSize = +#if defined(HTYPE_SSIZE_T) + con0 "SPT.CSsize" +#else + int #{size gsize} +#endif +haskellBasicType TSize = con0 "FCT.CSize" +haskellBasicType Ttime_t = con0 "FCT.CTime" +haskellBasicType Toff_t = +#if defined(HTYPE_OFF_T) + con0 "SPT.COff" +#else + -- If the type is not defined there's not much we can do, other than + -- guessing. The values below are correct on Linux amd64. In + -- practice it will hopefully not be much of an issue with newer + -- versions of GHC, since platforms lacking the definition will + -- (hopefully) also not have the relevant types in the available + -- APIs. The same remark applies to the types below. + int 8 +#endif +haskellBasicType Tdev_t = +#if defined(HTYPE_DEV_T) + con0 "SPT.CDev" +#else + uint 8 +#endif +haskellBasicType Tgid_t = +#if defined(HTYPE_GID_T) + con0 "SPT.CGid" +#else + uint 4 +#endif +haskellBasicType Tpid_t = +#if defined(HTYPE_PID_T) + con0 "SPT.CPid" +#else + int 4 +#endif +haskellBasicType Tsocklen_t = +#if defined(HTYPE_SOCKLEN_T) + con0 "SPT.CSocklen" +#else + uint 4 +#endif +haskellBasicType Tuid_t = +#if defined(HTYPE_UID_T) + con0 "SPT.CUid" +#else + uint 4 +#endif + +-- | Return the unsigned int type with the given amount of bytes. +uint :: Int -> TypeRep +uint n = con0 ("DW.Word" <> tshow (n*8)) + +-- | Return the (signed) int type with the given amount of bytes. +int :: Int -> TypeRep +int n = con0 ("DI.Int" <> tshow (n*8)) -- | This translates GI types to the types used for generated Haskell code. haskellType :: Type -> CodeGen e TypeRep diff --git a/lib/Data/GI/GIR/BasicTypes.hs b/lib/Data/GI/GIR/BasicTypes.hs --- a/lib/Data/GI/GIR/BasicTypes.hs +++ b/lib/Data/GI/GIR/BasicTypes.hs @@ -46,6 +46,17 @@ | TPtr -- ^ gpointer | TIntPtr -- ^ gintptr | TUIntPtr -- ^ guintptr + | TShort -- ^ gshort + | TUShort -- ^ gushort + | TSize -- ^ gsize + | TSSize -- ^ gssize + | Ttime_t -- ^ time_t + | Toff_t -- ^ off_t + | Tdev_t -- ^ dev_t + | Tgid_t -- ^ gid_t + | Tpid_t -- ^ pid_t + | Tsocklen_t -- ^ socklen_t + | Tuid_t -- ^ uid_t deriving (Eq, Show, Ord) -- | This type represents the types found in GObject Introspection diff --git a/lib/Data/GI/GIR/Type.hs b/lib/Data/GI/GIR/Type.hs --- a/lib/Data/GI/GIR/Type.hs +++ b/lib/Data/GI/GIR/Type.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards, PatternGuards #-} -- | Parsing type information from GIR files. module Data.GI.GIR.Type @@ -8,15 +9,14 @@ , parseOptionalType ) where +#include "HsBaseConfig.h" + import Data.Maybe (catMaybes) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import Data.Text (Text) import qualified Data.Text as T -import Foreign.Storable (sizeOf) -import Foreign.C (CShort, CUShort, CSize) -import System.Posix.Types (CSsize) import Data.GI.GIR.BasicTypes (Type(..), BasicType(..)) import Data.GI.GIR.Parser @@ -47,24 +47,17 @@ nameToBasicType "filename" = Just TFileName nameToBasicType "gintptr" = Just TIntPtr nameToBasicType "guintptr" = Just TUIntPtr -nameToBasicType "gshort" = case sizeOf (0 :: CShort) of - 2 -> Just TInt16 - 4 -> Just TInt32 - 8 -> Just TInt64 - n -> error $ "Unexpected short size: " ++ show n -nameToBasicType "gushort" = case sizeOf (0 :: CUShort) of - 2 -> Just TUInt16 - 4 -> Just TUInt32 - 8 -> Just TUInt64 - n -> error $ "Unexpected ushort size: " ++ show n -nameToBasicType "gssize" = case sizeOf (0 :: CSsize) of - 4 -> Just TInt32 - 8 -> Just TInt64 - n -> error $ "Unexpected ssize length: " ++ show n -nameToBasicType "gsize" = case sizeOf (0 :: CSize) of - 4 -> Just TUInt32 - 8 -> Just TUInt64 - n -> error $ "Unexpected size length: " ++ show n +nameToBasicType "gshort" = Just TShort +nameToBasicType "gushort" = Just TUShort +nameToBasicType "gssize" = Just TSSize +nameToBasicType "gsize" = Just TSize +nameToBasicType "time_t" = Just Ttime_t +nameToBasicType "off_t" = Just Toff_t +nameToBasicType "dev_t" = Just Tdev_t +nameToBasicType "gid_t" = Just Tgid_t +nameToBasicType "pid_t" = Just Tpid_t +nameToBasicType "socklen_t" = Just Tsocklen_t +nameToBasicType "uid_t" = Just Tuid_t nameToBasicType _ = Nothing -- | The different array types.