-- | Convenience hooks for writing custom @Setup.hs@ files for
-- bindings.
module Data.GI.CodeGen.CabalHooks
    ( setupHaskellGIBinding
    ) 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)
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 (parseOverridesFile, girFixups,
                                  filterAPIsAndDeps)
import Data.GI.CodeGen.Util (ucFirst)

import Control.Monad (when, void)

import Data.Maybe (fromJust, fromMaybe)
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as T

import System.Directory (doesFileExist)
import System.FilePath ((</>), (<.>))

type ConfHook = (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags
              -> IO LocalBuildInfo

-- | 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
                -> Maybe FilePath -- ^ output dir
                -> ConfHook -- ^ previous `confHook`
                -> ConfHook
confCodeGenHook :: Text
-> Text
-> Bool
-> Maybe FilePath
-> Maybe FilePath
-> ConfHook
-> ConfHook
confCodeGenHook name :: Text
name version :: Text
version verbosity :: Bool
verbosity overrides :: Maybe FilePath
overrides outputDir :: Maybe FilePath
outputDir
                defaultConfHook :: ConfHook
defaultConfHook (gpd :: GenericPackageDescription
gpd, hbi :: HookedBuildInfo
hbi) flags :: ConfigFlags
flags = do
  [FilePath] -> IO ()
setupTypelibSearchPath []

  Overrides
ovs <- case Maybe FilePath
overrides of
    Nothing -> Overrides -> IO Overrides
forall (m :: * -> *) a. Monad m => a -> m a
return Overrides
forall a. Monoid a => a
mempty
    Just fname :: FilePath
fname -> FilePath -> IO (Either Text Overrides)
parseOverridesFile FilePath
fname 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. [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

  (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}

  let m :: ModuleInfo
m = 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)

  let em' :: [ModuleName]
em' = (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)
      ctd' :: Library
ctd' = ((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) {exposedModules :: [ModuleName]
exposedModules = [ModuleName]
em'}
      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
ctd'}
      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'}

  Bool
alreadyDone <- FilePath -> IO Bool
doesFileExist (FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe "" Maybe FilePath
outputDir
                                FilePath -> FilePath -> FilePath
</> "GI" FilePath -> FilePath -> FilePath
</> Text -> FilePath
T.unpack (Text -> Text
ucFirst Text
name) FilePath -> FilePath -> FilePath
<.> "hs")
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
alreadyDone) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    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

  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 =
    UserHooks -> IO ()
defaultMainWithHooks (UserHooks
simpleUserHooks {
                            confHook :: (GenericPackageDescription, HookedBuildInfo)
-> ConfigFlags -> IO LocalBuildInfo
confHook = Text
-> Text
-> Bool
-> Maybe FilePath
-> Maybe FilePath
-> ConfHook
-> ConfHook
confCodeGenHook Text
name Text
version Bool
verbose
                                       Maybe FilePath
overridesFile Maybe FilePath
outputDir
                                       (UserHooks
-> (GenericPackageDescription, HookedBuildInfo)
-> ConfigFlags
-> IO LocalBuildInfo
confHook UserHooks
simpleUserHooks)
                          })