module Data.GI.CodeGen.CabalHooks
( setupBinding
, configureDryRun
, TaggedOverride(..)
) where
import qualified Distribution.ModuleName as MN
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Setup
import Distribution.Simple (UserHooks(..), simpleUserHooks,
defaultMainWithHooks, OptimisationLevel(..))
import Distribution.PackageDescription
import Data.GI.CodeGen.API (loadGIRInfo)
import Data.GI.CodeGen.Code (genCode, writeModuleTree, listModuleTree,
ModuleInfo, transitiveModuleDeps)
import Data.GI.CodeGen.CodeGen (genModule)
import Data.GI.CodeGen.Config (Config(..))
import Data.GI.CodeGen.LibGIRepository (setupTypelibSearchPath)
import Data.GI.CodeGen.ModulePath (toModulePath)
import Data.GI.CodeGen.Overrides (parseOverrides, girFixups,
filterAPIsAndDeps)
import Data.GI.CodeGen.Util (utf8ReadFile, utf8WriteFile, ucFirst)
import System.Directory (createDirectoryIfMissing)
import System.FilePath (joinPath, takeDirectory)
import Control.Monad (void, forM)
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.Map as M
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
type ConfHook = (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags
-> IO LocalBuildInfo
data TaggedOverride =
TaggedOverride { TaggedOverride -> Text
overrideTag :: Text
, TaggedOverride -> Text
overrideText :: Text
}
genModuleCode :: Text
-> Text
-> Text
-> Text
-> Bool
-> [TaggedOverride]
-> IO ModuleInfo
genModuleCode :: Text
-> Text
-> Text
-> Text
-> Bool
-> [TaggedOverride]
-> IO ModuleInfo
genModuleCode Text
name Text
version Text
pkgName Text
pkgVersion Bool
verbosity [TaggedOverride]
overrides = do
[[Char]] -> IO ()
setupTypelibSearchPath []
[Overrides]
parsed <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TaggedOverride]
overrides forall a b. (a -> b) -> a -> b
$ \(TaggedOverride Text
tag Text
ovText) -> do
Text -> IO (Either Text Overrides)
parseOverrides Text
ovText forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left Text
err -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Error when parsing overrides file \""
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
tag forall a. Semigroup a => a -> a -> a
<> [Char]
"\":"
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
err
Right Overrides
ovs -> forall (m :: * -> *) a. Monad m => a -> m a
return Overrides
ovs
let ovs :: Overrides
ovs = forall a. Monoid a => [a] -> a
mconcat [Overrides]
parsed
(GIRInfo
gir, [GIRInfo]
girDeps) <- Bool
-> Text
-> Maybe Text
-> [[Char]]
-> [GIRRule]
-> IO (GIRInfo, [GIRInfo])
loadGIRInfo Bool
verbosity Text
name (forall a. a -> Maybe a
Just Text
version) [] (Overrides -> [GIRRule]
girFixups Overrides
ovs)
let (Map Name API
apis, Map Name API
deps) = Overrides -> GIRInfo -> [GIRInfo] -> (Map Name API, Map Name API)
filterAPIsAndDeps Overrides
ovs GIRInfo
gir [GIRInfo]
girDeps
allAPIs :: Map Name API
allAPIs = forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map Name API
apis Map Name API
deps
cfg :: Config
cfg = Config {modName :: Text
modName = Text
name,
modVersion :: Text
modVersion = Text
version,
ghcPkgName :: Text
ghcPkgName = Text
pkgName,
ghcPkgVersion :: Text
ghcPkgVersion = Text
pkgVersion,
verbose :: Bool
verbose = Bool
verbosity,
overrides :: Overrides
overrides = Overrides
ovs}
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e.
Config -> Map Name API -> ModulePath -> CodeGen e () -> ModuleInfo
genCode Config
cfg Map Name API
allAPIs (Text -> ModulePath
toModulePath Text
name) (forall e. Map Name API -> CodeGen e ()
genModule Map Name API
apis)
genConfigModule :: Maybe FilePath -> Text -> Maybe TaggedOverride -> IO ()
genConfigModule :: Maybe [Char] -> Text -> Maybe TaggedOverride -> IO ()
genConfigModule Maybe [Char]
outputDir Text
modName Maybe TaggedOverride
maybeGiven = do
let fname :: [Char]
fname = [[Char]] -> [Char]
joinPath [ forall a. a -> Maybe a -> a
fromMaybe [Char]
"" Maybe [Char]
outputDir
, [Char]
"GI"
, Text -> [Char]
T.unpack (Text -> Text
ucFirst Text
modName)
, [Char]
"Config.hs" ]
dirname :: [Char]
dirname = [Char] -> [Char]
takeDirectory [Char]
fname
Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
dirname
[Char] -> Text -> IO ()
utf8WriteFile [Char]
fname forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
[ Text
"{-# LANGUAGE OverloadedStrings #-}"
, Text
"-- | Build time configuration used during code generation."
, Text
"module GI." forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
modName forall a. Semigroup a => a -> a -> a
<> Text
".Config ( overrides ) where"
, Text
""
, Text
"import qualified Data.Text as T"
, Text
"import Data.Text (Text)"
, Text
""
, Text
"-- | Overrides used when generating these bindings."
, Text
"overrides :: Text"
, Text
"overrides = T.unlines"
, Text
" [ " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"\n , " (Maybe TaggedOverride -> [Text]
quoteOverrides Maybe TaggedOverride
maybeGiven) forall a. Semigroup a => a -> a -> a
<> Text
"]"
]
where quoteOverrides :: Maybe TaggedOverride -> [Text]
quoteOverrides :: Maybe TaggedOverride -> [Text]
quoteOverrides Maybe TaggedOverride
Nothing = []
quoteOverrides (Just (TaggedOverride Text
_ Text
ovText)) =
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) (Text -> [Text]
T.lines Text
ovText)
confCodeGenHook :: Text
-> Text
-> Text
-> Text
-> Bool
-> Maybe FilePath
-> [TaggedOverride]
-> Maybe FilePath
-> ConfHook
-> ConfHook
confCodeGenHook :: Text
-> Text
-> Text
-> Text
-> Bool
-> Maybe [Char]
-> [TaggedOverride]
-> Maybe [Char]
-> ConfHook
-> ConfHook
confCodeGenHook Text
name Text
version Text
pkgName Text
pkgVersion Bool
verbosity
Maybe [Char]
overridesFile [TaggedOverride]
inheritedOverrides Maybe [Char]
outputDir
ConfHook
defaultConfHook (GenericPackageDescription
gpd, HookedBuildInfo
hbi) ConfigFlags
flags = do
Maybe TaggedOverride
givenOvs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\[Char]
fname -> Text -> Text -> TaggedOverride
TaggedOverride ([Char] -> Text
T.pack [Char]
fname) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Text
utf8ReadFile [Char]
fname) Maybe [Char]
overridesFile
let ovs :: [TaggedOverride]
ovs = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [TaggedOverride]
inheritedOverrides (forall a. a -> [a] -> [a]
:[TaggedOverride]
inheritedOverrides) Maybe TaggedOverride
givenOvs
ModuleInfo
m <- Text
-> Text
-> Text
-> Text
-> Bool
-> [TaggedOverride]
-> IO ModuleInfo
genModuleCode Text
name Text
version Text
pkgName Text
pkgVersion Bool
verbosity [TaggedOverride]
ovs
let buildInfo :: ModuleName
buildInfo = forall a. IsString a => [Char] -> a
MN.fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ Text
"GI." forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
name forall a. Semigroup a => a -> a -> a
<> Text
".Config"
em' :: [ModuleName]
em' = ModuleName
buildInfo forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => [Char] -> a
MN.fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack) (ModuleInfo -> [Text]
listModuleTree ModuleInfo
m)
lib :: Library
lib = ((forall v c a. CondTree v c a -> a
condTreeData forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription
-> Maybe (CondTree ConfVar [Dependency] Library)
condLibrary) GenericPackageDescription
gpd)
bi :: BuildInfo
bi = Library -> BuildInfo
libBuildInfo Library
lib
#if MIN_VERSION_base(4,11,0)
bi' :: BuildInfo
bi' = BuildInfo
bi {autogenModules :: [ModuleName]
autogenModules = [ModuleName]
em'}
#else
bi' = bi
#endif
lib' :: Library
lib' = Library
lib {exposedModules :: [ModuleName]
exposedModules = [ModuleName]
em', libBuildInfo :: BuildInfo
libBuildInfo = BuildInfo
bi'}
cL' :: CondTree ConfVar [Dependency] Library
cL' = ((forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription
-> Maybe (CondTree ConfVar [Dependency] Library)
condLibrary) GenericPackageDescription
gpd) {condTreeData :: Library
condTreeData = Library
lib'}
gpd' :: GenericPackageDescription
gpd' = GenericPackageDescription
gpd {condLibrary :: Maybe (CondTree ConfVar [Dependency] Library)
condLibrary = forall a. a -> Maybe a
Just CondTree ConfVar [Dependency] Library
cL'}
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Bool -> Maybe [Char] -> ModuleInfo -> IO [Text]
writeModuleTree Bool
verbosity Maybe [Char]
outputDir ModuleInfo
m
Maybe [Char] -> Text -> Maybe TaggedOverride -> IO ()
genConfigModule Maybe [Char]
outputDir Text
name Maybe TaggedOverride
givenOvs
LocalBuildInfo
lbi <- ConfHook
defaultConfHook (GenericPackageDescription
gpd', HookedBuildInfo
hbi) ConfigFlags
flags
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalBuildInfo
lbi {withOptimization :: OptimisationLevel
withOptimization = OptimisationLevel
NoOptimisation})
setupBinding :: Text
-> Text
-> Text
-> Text
-> Bool
-> Maybe FilePath
-> [TaggedOverride]
-> Maybe FilePath
-> IO ()
setupBinding :: Text
-> Text
-> Text
-> Text
-> Bool
-> Maybe [Char]
-> [TaggedOverride]
-> Maybe [Char]
-> IO ()
setupBinding Text
name Text
version Text
pkgName Text
pkgVersion Bool
verbose Maybe [Char]
overridesFile [TaggedOverride]
overrides Maybe [Char]
outputDir =
UserHooks -> IO ()
defaultMainWithHooks (UserHooks
simpleUserHooks {
confHook :: ConfHook
confHook = Text
-> Text
-> Text
-> Text
-> Bool
-> Maybe [Char]
-> [TaggedOverride]
-> Maybe [Char]
-> ConfHook
-> ConfHook
confCodeGenHook Text
name Text
version
Text
pkgName Text
pkgVersion
Bool
verbose
Maybe [Char]
overridesFile [TaggedOverride]
overrides Maybe [Char]
outputDir
(UserHooks -> ConfHook
confHook UserHooks
simpleUserHooks)
})
configureDryRun :: Text
-> Text
-> Text
-> Text
-> Maybe FilePath
-> [TaggedOverride]
-> IO ([Text], S.Set Text)
configureDryRun :: Text
-> Text
-> Text
-> Text
-> Maybe [Char]
-> [TaggedOverride]
-> IO ([Text], Set Text)
configureDryRun Text
name Text
version Text
pkgName Text
pkgVersion Maybe [Char]
overridesFile [TaggedOverride]
inheritedOverrides = do
Maybe TaggedOverride
givenOvs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\[Char]
fname -> Text -> Text -> TaggedOverride
TaggedOverride ([Char] -> Text
T.pack [Char]
fname) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Text
utf8ReadFile [Char]
fname) Maybe [Char]
overridesFile
let ovs :: [TaggedOverride]
ovs = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [TaggedOverride]
inheritedOverrides (forall a. a -> [a] -> [a]
:[TaggedOverride]
inheritedOverrides) Maybe TaggedOverride
givenOvs
ModuleInfo
m <- Text
-> Text
-> Text
-> Text
-> Bool
-> [TaggedOverride]
-> IO ModuleInfo
genModuleCode Text
name Text
version Text
pkgName Text
pkgVersion Bool
False [TaggedOverride]
ovs
forall (m :: * -> *) a. Monad m => a -> m a
return ((Text
"GI." forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
name forall a. Semigroup a => a -> a -> a
<> Text
".Config") forall a. a -> [a] -> [a]
: ModuleInfo -> [Text]
listModuleTree ModuleInfo
m,
ModuleInfo -> Set Text
transitiveModuleDeps ModuleInfo
m)