-- | Convenience hooks for writing custom @Setup.hs@ files for
-- bindings.
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

-- | 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
              -> Text -- ^ pkgName
              -> Text -- ^ pkgVersion
              -> Bool -- ^ verbose
              -> [TaggedOverride] -- ^ Explicit overrides
              -> 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 []

  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 Text
tag Text
ovText) -> do
    Text -> IO (Either Text Overrides)
parseOverrides Text
ovText IO (Either Text Overrides)
-> (Either Text Overrides -> IO Overrides) -> IO Overrides
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left Text
err -> [Char] -> IO Overrides
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO Overrides) -> [Char] -> IO Overrides
forall a b. (a -> b) -> a -> b
$ [Char]
"Error when parsing overrides file \""
                  [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
tag [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\":"
                  [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
err
      Right Overrides
ovs -> Overrides -> IO Overrides
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Overrides
ovs

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

  (gir, girDeps) <- loadGIRInfo verbosity name (Just version) [] (girFixups ovs)
  let (apis, deps) = filterAPIsAndDeps ovs gir girDeps
      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 {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}

  return $ genCode cfg allAPIs (toModulePath name) (genModule apis)

-- | Write a module containing information about the configuration for
-- the package.
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 [ [Char] -> Maybe [Char] -> [Char]
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 (Text -> IO ()) -> Text -> IO ()
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." 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
<> 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
" [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"\n , " (Maybe TaggedOverride -> [Text]
quoteOverrides Maybe TaggedOverride
maybeGiven) Text -> Text -> Text
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)) =
          (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Text
T.pack ([Char] -> Text) -> (Text -> [Char]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
forall a. Show a => a -> [Char]
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
                -> Text -- ^ pkgName
                -> Text -- ^ pkgVersion
                -> Bool -- ^ verbose
                -> Maybe FilePath -- ^ overrides file
                -> [TaggedOverride] -- ^ other overrides
                -> Maybe FilePath -- ^ output dir
                -> ConfHook -- ^ previous `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

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

  let 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
  m <- genModuleCode name version pkgName pkgVersion verbosity ovs

  let buildInfo = [Char] -> ModuleName
forall a. IsString a => [Char] -> a
MN.fromString ([Char] -> ModuleName) -> (Text -> [Char]) -> Text -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack (Text -> ModuleName) -> Text -> ModuleName
forall a b. (a -> b) -> a -> b
$ Text
"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
<> Text
".Config"
      em' = ModuleName
buildInfo ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
: (Text -> ModuleName) -> [Text] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> ModuleName
forall a. IsString a => [Char] -> a
MN.fromString ([Char] -> ModuleName) -> (Text -> [Char]) -> Text -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack) (ModuleInfo -> [Text]
listModuleTree ModuleInfo
m)
      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 = Library -> BuildInfo
libBuildInfo Library
lib
#if MIN_VERSION_base(4,11,0)
      bi' = BuildInfo
bi {autogenModules = em'}
#else
      bi' = bi
#endif
      lib' = Library
lib {exposedModules = em', libBuildInfo = bi'}
      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 = lib'}
      gpd' = GenericPackageDescription
gpd {condLibrary = Just cL'}

  void $ writeModuleTree verbosity outputDir m

  genConfigModule outputDir name givenOvs

  lbi <- defaultConfHook (gpd', hbi) flags

  return (lbi {withOptimization = NoOptimisation})

-- | The entry point for @Setup.hs@ files in bindings.
setupBinding :: Text -- ^ name
             -> Text -- ^ version
             -> Text -- ^ pkgName
             -> Text -- ^ pkgVersion
             -> Bool -- ^ verbose
             -> Maybe FilePath -- ^ overrides file
             -> [TaggedOverride] -- ^ Explicit overrides
             -> Maybe FilePath -- ^ output dir
             -> 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 = confCodeGenHook name version
                                       pkgName pkgVersion
                                       verbose
                                       overridesFile overrides outputDir
                                       (confHook 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
                -> Text -- ^ pkgName
                -> Text -- ^ pkgVersion
                -> Maybe FilePath -- ^ Overrides file
                -> [TaggedOverride] -- ^ Other overrides to load
                -> 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
  givenOvs <- ([Char] -> IO TaggedOverride)
-> Maybe [Char] -> IO (Maybe TaggedOverride)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (\[Char]
fname -> Text -> Text -> TaggedOverride
TaggedOverride ([Char] -> Text
T.pack [Char]
fname) (Text -> TaggedOverride) -> IO Text -> IO TaggedOverride
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Text
utf8ReadFile [Char]
fname) Maybe [Char]
overridesFile

  let 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
  m <- genModuleCode name version pkgName pkgVersion False ovs

  return (("GI." <> ucFirst name <> ".Config") : listModuleTree m,
           transitiveModuleDeps m)