-- | Convenience hooks for writing custom @Setup.hs@ files for
-- bindings.
module Data.GI.CodeGen.CabalHooks
    ( setupHaskellGIBinding
    , 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

-- | Included overrides file.
data TaggedOverride =
  TaggedOverride { TaggedOverride -> Text
overrideTag   :: Text
                   -- ^ Tag for the override, for error reporting purposes.
                 , TaggedOverride -> Text
overrideText  :: Text
                 }

-- | Generate the code for the given module.
genModuleCode :: Text -- ^ name
              -> Text -- ^ version
              -> Bool -- ^ verbose
              -> [TaggedOverride] -- ^ Explicit overrides
              -> IO ModuleInfo
genModuleCode :: Text -> Text -> Bool -> [TaggedOverride] -> IO ModuleInfo
genModuleCode name :: Text
name version :: Text
version verbosity :: Bool
verbosity overrides :: [TaggedOverride]
overrides = do
  [FilePath] -> IO ()
setupTypelibSearchPath []

  [Overrides]
parsed <- [TaggedOverride]
-> (TaggedOverride -> IO Overrides) -> IO [Overrides]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TaggedOverride]
overrides ((TaggedOverride -> IO Overrides) -> IO [Overrides])
-> (TaggedOverride -> IO Overrides) -> IO [Overrides]
forall a b. (a -> b) -> a -> b
$ \(TaggedOverride tag :: Text
tag ovText :: Text
ovText) -> do
    Text -> IO (Either Text Overrides)
parseOverrides Text
ovText IO (Either Text Overrides)
-> (Either Text Overrides -> IO Overrides) -> IO Overrides
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left err :: Text
err -> FilePath -> IO Overrides
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO Overrides) -> FilePath -> IO Overrides
forall a b. (a -> b) -> a -> b
$ "Error when parsing overrides file \""
                  FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
tag FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> "\":"
                  FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
err
      Right ovs :: Overrides
ovs -> Overrides -> IO Overrides
forall (m :: * -> *) a. Monad m => a -> m a
return Overrides
ovs

  let ovs :: Overrides
ovs = [Overrides] -> Overrides
forall a. Monoid a => [a] -> a
mconcat [Overrides]
parsed

  (gir :: GIRInfo
gir, girDeps :: [GIRInfo]
girDeps) <- Bool
-> Text
-> Maybe Text
-> [FilePath]
-> [GIRRule]
-> IO (GIRInfo, [GIRInfo])
loadGIRInfo Bool
verbosity Text
name (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
version) [] (Overrides -> [GIRRule]
girFixups Overrides
ovs)
  let (apis :: Map Name API
apis, deps :: 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 = Map Name API -> Map Name API -> Map Name API
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 :: Text -> Bool -> Overrides -> Config
Config {modName :: Text
modName = Text
name,
                    verbose :: Bool
verbose = Bool
verbosity,
                    overrides :: Overrides
overrides = Overrides
ovs}

  ModuleInfo -> IO ModuleInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleInfo -> IO ModuleInfo) -> ModuleInfo -> IO ModuleInfo
forall a b. (a -> b) -> a -> b
$ Config -> Map Name API -> ModulePath -> CodeGen () -> ModuleInfo
genCode Config
cfg Map Name API
allAPIs (Text -> ModulePath
toModulePath Text
name) (Map Name API -> CodeGen ()
genModule Map Name API
apis)

-- | Write a module containing information about the configuration for
-- the package.
genConfigModule :: Maybe FilePath -> Text -> Maybe TaggedOverride -> IO ()
genConfigModule :: Maybe FilePath -> Text -> Maybe TaggedOverride -> IO ()
genConfigModule outputDir :: Maybe FilePath
outputDir modName :: Text
modName maybeGiven :: Maybe TaggedOverride
maybeGiven = do
  let fname :: FilePath
fname = [FilePath] -> FilePath
joinPath [ FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe "" Maybe FilePath
outputDir
                       , "GI"
                       , Text -> FilePath
T.unpack (Text -> Text
ucFirst Text
modName)
                       , "Config.hs" ]
      dirname :: FilePath
dirname = FilePath -> FilePath
takeDirectory FilePath
fname

  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
dirname

  FilePath -> Text -> IO ()
utf8WriteFile FilePath
fname (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
    [ "{-# LANGUAGE OverloadedStrings #-}"
    , "-- | Build time configuration used during code generation."
    , "module GI." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
modName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".Config ( overrides ) where"
    , ""
    , "import qualified Data.Text as T"
    , "import Data.Text (Text)"
    , ""
    , "-- | Overrides used when generating these bindings."
    , "overrides :: Text"
    , "overrides = T.unlines"
    , " [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate "\n , " (Maybe TaggedOverride -> [Text]
quoteOverrides Maybe TaggedOverride
maybeGiven) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "]"
    ]

  where quoteOverrides :: Maybe TaggedOverride -> [Text]
        quoteOverrides :: Maybe TaggedOverride -> [Text]
quoteOverrides Nothing = []
        quoteOverrides (Just (TaggedOverride _ ovText :: Text
ovText)) =
          (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Text
T.pack (FilePath -> Text) -> (Text -> FilePath) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
forall a. Show a => a -> FilePath
show) (Text -> [Text]
T.lines Text
ovText)

-- | A convenience helper for `confHook`, such that bindings for the
-- given module are generated in the @configure@ step of @cabal@.
confCodeGenHook :: Text -- ^ name
                -> Text -- ^ version
                -> Bool -- ^ verbose
                -> Maybe FilePath -- ^ overrides file
                -> [TaggedOverride] -- ^ other overrides
                -> Maybe FilePath -- ^ output dir
                -> ConfHook -- ^ previous `confHook`
                -> ConfHook
confCodeGenHook :: Text
-> Text
-> Bool
-> Maybe FilePath
-> [TaggedOverride]
-> Maybe FilePath
-> ConfHook
-> ConfHook
confCodeGenHook name :: Text
name version :: Text
version verbosity :: Bool
verbosity overridesFile :: Maybe FilePath
overridesFile inheritedOverrides :: [TaggedOverride]
inheritedOverrides outputDir :: Maybe FilePath
outputDir
                defaultConfHook :: ConfHook
defaultConfHook (gpd :: GenericPackageDescription
gpd, hbi :: HookedBuildInfo
hbi) flags :: ConfigFlags
flags = do

  Maybe TaggedOverride
givenOvs <- (FilePath -> IO TaggedOverride)
-> Maybe FilePath -> IO (Maybe TaggedOverride)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\fname :: FilePath
fname -> Text -> Text -> TaggedOverride
TaggedOverride (FilePath -> Text
T.pack FilePath
fname) (Text -> TaggedOverride) -> IO Text -> IO TaggedOverride
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Text
utf8ReadFile FilePath
fname) Maybe FilePath
overridesFile

  let ovs :: [TaggedOverride]
ovs = [TaggedOverride]
-> (TaggedOverride -> [TaggedOverride])
-> Maybe TaggedOverride
-> [TaggedOverride]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [TaggedOverride]
inheritedOverrides (TaggedOverride -> [TaggedOverride] -> [TaggedOverride]
forall a. a -> [a] -> [a]
:[TaggedOverride]
inheritedOverrides) Maybe TaggedOverride
givenOvs
  ModuleInfo
m <- Text -> Text -> Bool -> [TaggedOverride] -> IO ModuleInfo
genModuleCode Text
name Text
version Bool
verbosity [TaggedOverride]
ovs

  let buildInfo :: ModuleName
buildInfo = FilePath -> ModuleName
forall a. IsString a => FilePath -> a
MN.fromString (FilePath -> ModuleName)
-> (Text -> FilePath) -> Text -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack (Text -> ModuleName) -> Text -> ModuleName
forall a b. (a -> b) -> a -> b
$ "GI." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".Config"
      em' :: [ModuleName]
em' = ModuleName
buildInfo ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
: (Text -> ModuleName) -> [Text] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> ModuleName
forall a. IsString a => FilePath -> a
MN.fromString (FilePath -> ModuleName)
-> (Text -> FilePath) -> Text -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack) (ModuleInfo -> [Text]
listModuleTree ModuleInfo
m)
      lib :: Library
lib = ((CondTree ConfVar [Dependency] Library -> Library
forall v c a. CondTree v c a -> a
condTreeData (CondTree ConfVar [Dependency] Library -> Library)
-> (GenericPackageDescription
    -> CondTree ConfVar [Dependency] Library)
-> GenericPackageDescription
-> Library
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (CondTree ConfVar [Dependency] Library)
-> CondTree ConfVar [Dependency] Library
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (CondTree ConfVar [Dependency] Library)
 -> CondTree ConfVar [Dependency] Library)
-> (GenericPackageDescription
    -> Maybe (CondTree ConfVar [Dependency] Library))
-> GenericPackageDescription
-> CondTree ConfVar [Dependency] Library
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' = ((Maybe (CondTree ConfVar [Dependency] Library)
-> CondTree ConfVar [Dependency] Library
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (CondTree ConfVar [Dependency] Library)
 -> CondTree ConfVar [Dependency] Library)
-> (GenericPackageDescription
    -> Maybe (CondTree ConfVar [Dependency] Library))
-> GenericPackageDescription
-> CondTree ConfVar [Dependency] Library
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 = CondTree ConfVar [Dependency] Library
-> Maybe (CondTree ConfVar [Dependency] Library)
forall a. a -> Maybe a
Just CondTree ConfVar [Dependency] Library
cL'}

  IO [Text] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [Text] -> IO ()) -> IO [Text] -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe FilePath -> ModuleInfo -> IO [Text]
writeModuleTree Bool
verbosity Maybe FilePath
outputDir ModuleInfo
m

  Maybe FilePath -> Text -> Maybe TaggedOverride -> IO ()
genConfigModule Maybe FilePath
outputDir Text
name Maybe TaggedOverride
givenOvs

  LocalBuildInfo
lbi <- ConfHook
defaultConfHook (GenericPackageDescription
gpd', HookedBuildInfo
hbi) ConfigFlags
flags

  LocalBuildInfo -> IO LocalBuildInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalBuildInfo
lbi {withOptimization :: OptimisationLevel
withOptimization = OptimisationLevel
NoOptimisation})

-- | The entry point for @Setup.hs@ files in bindings.
setupHaskellGIBinding :: Text -- ^ name
                      -> Text -- ^ version
                      -> Bool -- ^ verbose
                      -> Maybe FilePath -- ^ overrides file
                      -> Maybe FilePath -- ^ output dir
                      -> IO ()
setupHaskellGIBinding :: Text -> Text -> Bool -> Maybe FilePath -> Maybe FilePath -> IO ()
setupHaskellGIBinding name :: Text
name version :: Text
version verbose :: Bool
verbose overridesFile :: Maybe FilePath
overridesFile outputDir :: Maybe FilePath
outputDir =
  Text
-> Text
-> Bool
-> Maybe FilePath
-> [TaggedOverride]
-> Maybe FilePath
-> IO ()
setupBinding Text
name Text
version Bool
verbose Maybe FilePath
overridesFile [] Maybe FilePath
outputDir

-- | The entry point for @Setup.hs@ files in bindings.
setupBinding :: Text -- ^ name
             -> Text -- ^ version
             -> Bool -- ^ verbose
             -> Maybe FilePath -- ^ overrides file
             -> [TaggedOverride] -- ^ Explicit overrides
             -> Maybe FilePath -- ^ output dir
             -> IO ()
setupBinding :: Text
-> Text
-> Bool
-> Maybe FilePath
-> [TaggedOverride]
-> Maybe FilePath
-> IO ()
setupBinding name :: Text
name version :: Text
version verbose :: Bool
verbose overridesFile :: Maybe FilePath
overridesFile overrides :: [TaggedOverride]
overrides outputDir :: Maybe FilePath
outputDir =
    UserHooks -> IO ()
defaultMainWithHooks (UserHooks
simpleUserHooks {
                            confHook :: (GenericPackageDescription, HookedBuildInfo)
-> ConfigFlags -> IO LocalBuildInfo
confHook = Text
-> Text
-> Bool
-> Maybe FilePath
-> [TaggedOverride]
-> Maybe FilePath
-> ConfHook
-> ConfHook
confCodeGenHook Text
name Text
version Bool
verbose
                                       Maybe FilePath
overridesFile [TaggedOverride]
overrides Maybe FilePath
outputDir
                                       (UserHooks
-> (GenericPackageDescription, HookedBuildInfo)
-> ConfigFlags
-> IO LocalBuildInfo
confHook UserHooks
simpleUserHooks)
                          })

-- | Return the list of modules that `setupHaskellGIBinding` would
-- create, together with the set of dependencies loaded while
-- generating the code.
configureDryRun :: Text -- ^ name
                -> Text -- ^ version
                -> Maybe FilePath -- ^ Overrides file
                -> [TaggedOverride] -- ^ Other overrides to load
                -> IO ([Text], S.Set Text)
configureDryRun :: Text
-> Text
-> Maybe FilePath
-> [TaggedOverride]
-> IO ([Text], Set Text)
configureDryRun name :: Text
name version :: Text
version overridesFile :: Maybe FilePath
overridesFile inheritedOverrides :: [TaggedOverride]
inheritedOverrides = do
  Maybe TaggedOverride
givenOvs <- (FilePath -> IO TaggedOverride)
-> Maybe FilePath -> IO (Maybe TaggedOverride)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\fname :: FilePath
fname -> Text -> Text -> TaggedOverride
TaggedOverride (FilePath -> Text
T.pack FilePath
fname) (Text -> TaggedOverride) -> IO Text -> IO TaggedOverride
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Text
utf8ReadFile FilePath
fname) Maybe FilePath
overridesFile

  let ovs :: [TaggedOverride]
ovs = [TaggedOverride]
-> (TaggedOverride -> [TaggedOverride])
-> Maybe TaggedOverride
-> [TaggedOverride]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [TaggedOverride]
inheritedOverrides (TaggedOverride -> [TaggedOverride] -> [TaggedOverride]
forall a. a -> [a] -> [a]
:[TaggedOverride]
inheritedOverrides) Maybe TaggedOverride
givenOvs
  ModuleInfo
m <- Text -> Text -> Bool -> [TaggedOverride] -> IO ModuleInfo
genModuleCode Text
name Text
version Bool
False [TaggedOverride]
ovs

  ([Text], Set Text) -> IO ([Text], Set Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (("GI." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".Config") Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ModuleInfo -> [Text]
listModuleTree ModuleInfo
m,
           ModuleInfo -> Set Text
transitiveModuleDeps ModuleInfo
m)