{-# LANGUAGE RecordWildCards #-}

module Hoogle.Cabal.Command.Common
  ( GlobalOptions (..),
    globalOptionsParser,
    hoogleDatabaseArg,
    Context (..),
    readContext,
  )
where

import qualified Data.Map.Strict as Map
import Distribution.Client.CmdBuild (BuildFlags, defaultBuildFlags, selectComponentTarget, selectPackageTargets)
import Distribution.Client.CmdErrorMessages (renderCannotPruneDependencies, reportTargetProblems)
import Distribution.Client.DistDirLayout (distDirectory)
import Distribution.Client.NixStyleOptions
import Distribution.Client.ProjectOrchestration
import Distribution.Client.ScriptUtils
import Distribution.Client.Setup (GlobalFlags, InstallFlags (..), defaultGlobalFlags)
import Distribution.Simple (OptimisationLevel (NoOptimisation))
import Distribution.Simple.Setup (ConfigFlags (..), Flag (..), HaddockFlags (..))
import Distribution.Simple.Utils (die')
import qualified Distribution.Verbosity as Verbosity
import Options.Applicative
import System.FilePath ((</>))

data GlobalOptions = GlobalOptions
  { GlobalOptions -> FilePath
_globalOptions_builddir :: FilePath,
    GlobalOptions -> Bool
_globalOptions_version :: Bool
  }
  deriving (Int -> GlobalOptions -> ShowS
[GlobalOptions] -> ShowS
GlobalOptions -> FilePath
(Int -> GlobalOptions -> ShowS)
-> (GlobalOptions -> FilePath)
-> ([GlobalOptions] -> ShowS)
-> Show GlobalOptions
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GlobalOptions -> ShowS
showsPrec :: Int -> GlobalOptions -> ShowS
$cshow :: GlobalOptions -> FilePath
show :: GlobalOptions -> FilePath
$cshowList :: [GlobalOptions] -> ShowS
showList :: [GlobalOptions] -> ShowS
Show, GlobalOptions -> GlobalOptions -> Bool
(GlobalOptions -> GlobalOptions -> Bool)
-> (GlobalOptions -> GlobalOptions -> Bool) -> Eq GlobalOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GlobalOptions -> GlobalOptions -> Bool
== :: GlobalOptions -> GlobalOptions -> Bool
$c/= :: GlobalOptions -> GlobalOptions -> Bool
/= :: GlobalOptions -> GlobalOptions -> Bool
Eq)

globalOptionsParser :: Parser GlobalOptions
globalOptionsParser :: Parser GlobalOptions
globalOptionsParser =
  FilePath -> Bool -> GlobalOptions
GlobalOptions
    (FilePath -> Bool -> GlobalOptions)
-> Parser FilePath -> Parser (Bool -> GlobalOptions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod OptionFields FilePath -> Parser FilePath
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
      ( FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"builddir"
          Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value FilePath
"dist-newstyle/hoogle"
          Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Cabal project build dir"
      )
    Parser (Bool -> GlobalOptions)
-> Parser Bool -> Parser GlobalOptions
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch
      ( FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"version"
          Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Print version"
      )

hoogleDatabaseArg :: String
hoogleDatabaseArg :: FilePath
hoogleDatabaseArg = FilePath
"--database=all.hoo"

data Context = Context
  { Context -> ProjectBaseContext
_context_baseCtx :: ProjectBaseContext,
    Context -> ProjectBuildContext
_context_buildCtx :: ProjectBuildContext,
    Context -> FilePath
_context_hoogleDir :: FilePath,
    Context -> [FilePath]
_context_targetStrings :: [String],
    Context -> NixStyleFlags BuildFlags
_context_flags :: NixStyleFlags BuildFlags,
    Context -> GlobalFlags
_context_globalFlags :: GlobalFlags
  }

-- | This is copied from the implementation of 'buildAction'
readContext ::
  GlobalOptions ->
  [String] ->
  IO Context
readContext :: GlobalOptions -> [FilePath] -> IO Context
readContext GlobalOptions {Bool
FilePath
_globalOptions_builddir :: GlobalOptions -> FilePath
_globalOptions_version :: GlobalOptions -> Bool
_globalOptions_builddir :: FilePath
_globalOptions_version :: Bool
..} [FilePath]
targetStrings =
  AcceptNoTargets
-> Maybe ComponentKind
-> NixStyleFlags BuildFlags
-> [FilePath]
-> GlobalFlags
-> CurrentCommand
-> (TargetContext
    -> ProjectBaseContext -> [TargetSelector] -> IO Context)
-> IO Context
forall a b.
AcceptNoTargets
-> Maybe ComponentKind
-> NixStyleFlags a
-> [FilePath]
-> GlobalFlags
-> CurrentCommand
-> (TargetContext
    -> ProjectBaseContext -> [TargetSelector] -> IO b)
-> IO b
withContextAndSelectors AcceptNoTargets
RejectNoTargets Maybe ComponentKind
forall a. Maybe a
Nothing NixStyleFlags BuildFlags
flags [FilePath]
targetStrings' GlobalFlags
globalFlags CurrentCommand
HaddockCommand ((TargetContext
  -> ProjectBaseContext -> [TargetSelector] -> IO Context)
 -> IO Context)
-> (TargetContext
    -> ProjectBaseContext -> [TargetSelector] -> IO Context)
-> IO Context
forall a b. (a -> b) -> a -> b
$ \TargetContext
targetCtx ProjectBaseContext
ctx [TargetSelector]
targetSelectors -> do
    let targetAction :: TargetAction
targetAction = TargetAction
TargetActionBuild

    ProjectBaseContext
baseCtx <- case TargetContext
targetCtx of
      TargetContext
ProjectContext -> ProjectBaseContext -> IO ProjectBaseContext
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ProjectBaseContext
ctx
      TargetContext
GlobalContext -> ProjectBaseContext -> IO ProjectBaseContext
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ProjectBaseContext
ctx
      ScriptContext FilePath
path Executable
exemeta -> ProjectBaseContext
-> FilePath -> Executable -> IO ProjectBaseContext
updateContextAndWriteProjectFile ProjectBaseContext
ctx FilePath
path Executable
exemeta

    let verbosity :: Verbosity
verbosity = Verbosity
Verbosity.normal
    ProjectBuildContext
buildCtx <- Verbosity
-> ProjectBaseContext
-> (ElaboratedInstallPlan
    -> IO (ElaboratedInstallPlan, TargetsMap))
-> IO ProjectBuildContext
runProjectPreBuildPhase Verbosity
verbosity ProjectBaseContext
baseCtx ((ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap))
 -> IO ProjectBuildContext)
-> (ElaboratedInstallPlan
    -> IO (ElaboratedInstallPlan, TargetsMap))
-> IO ProjectBuildContext
forall a b. (a -> b) -> a -> b
$ \ElaboratedInstallPlan
elaboratedPlan -> do
      -- Interpret the targets on the command line as build targets
      -- (as opposed to say repl or haddock targets).
      TargetsMap
targets <-
        ([TargetProblem'] -> IO TargetsMap)
-> (TargetsMap -> IO TargetsMap)
-> Either [TargetProblem'] TargetsMap
-> IO TargetsMap
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Verbosity -> FilePath -> [TargetProblem'] -> IO TargetsMap
forall a. Verbosity -> FilePath -> [TargetProblem'] -> IO a
reportTargetProblems Verbosity
verbosity FilePath
"build") TargetsMap -> IO TargetsMap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [TargetProblem'] TargetsMap -> IO TargetsMap)
-> Either [TargetProblem'] TargetsMap -> IO TargetsMap
forall a b. (a -> b) -> a -> b
$
          (forall k.
 TargetSelector -> [AvailableTarget k] -> Either TargetProblem' [k])
-> (forall k.
    SubComponentTarget -> AvailableTarget k -> Either TargetProblem' k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem'] TargetsMap
forall err.
(forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either (TargetProblem err) [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either (TargetProblem err) k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem err] TargetsMap
resolveTargets
            TargetSelector -> [AvailableTarget k] -> Either TargetProblem' [k]
forall k.
TargetSelector -> [AvailableTarget k] -> Either TargetProblem' [k]
selectPackageTargets
            SubComponentTarget -> AvailableTarget k -> Either TargetProblem' k
forall k.
SubComponentTarget -> AvailableTarget k -> Either TargetProblem' k
selectComponentTarget
            ElaboratedInstallPlan
elaboratedPlan
            Maybe SourcePackageDb
forall a. Maybe a
Nothing
            [TargetSelector]
targetSelectors

      let elaboratedPlan' :: ElaboratedInstallPlan
elaboratedPlan' =
            TargetAction
-> TargetsMap -> ElaboratedInstallPlan -> ElaboratedInstallPlan
pruneInstallPlanToTargets
              TargetAction
targetAction
              TargetsMap
targets
              ElaboratedInstallPlan
elaboratedPlan
      ElaboratedInstallPlan
elaboratedPlan'' <-
        if BuildTimeSettings -> Bool
buildSettingOnlyDeps (ProjectBaseContext -> BuildTimeSettings
buildSettings ProjectBaseContext
baseCtx)
          then
            (CannotPruneDependencies -> IO ElaboratedInstallPlan)
-> (ElaboratedInstallPlan -> IO ElaboratedInstallPlan)
-> Either CannotPruneDependencies ElaboratedInstallPlan
-> IO ElaboratedInstallPlan
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Verbosity -> FilePath -> IO ElaboratedInstallPlan
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ElaboratedInstallPlan)
-> (CannotPruneDependencies -> FilePath)
-> CannotPruneDependencies
-> IO ElaboratedInstallPlan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CannotPruneDependencies -> FilePath
renderCannotPruneDependencies) ElaboratedInstallPlan -> IO ElaboratedInstallPlan
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either CannotPruneDependencies ElaboratedInstallPlan
 -> IO ElaboratedInstallPlan)
-> Either CannotPruneDependencies ElaboratedInstallPlan
-> IO ElaboratedInstallPlan
forall a b. (a -> b) -> a -> b
$
              Set UnitId
-> ElaboratedInstallPlan
-> Either CannotPruneDependencies ElaboratedInstallPlan
pruneInstallPlanToDependencies
                (TargetsMap -> Set UnitId
forall k a. Map k a -> Set k
Map.keysSet TargetsMap
targets)
                ElaboratedInstallPlan
elaboratedPlan'
          else ElaboratedInstallPlan -> IO ElaboratedInstallPlan
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ElaboratedInstallPlan
elaboratedPlan'

      (ElaboratedInstallPlan, TargetsMap)
-> IO (ElaboratedInstallPlan, TargetsMap)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ElaboratedInstallPlan
elaboratedPlan'', TargetsMap
targets)
    Context -> IO Context
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> IO Context) -> Context -> IO Context
forall a b. (a -> b) -> a -> b
$
      ProjectBaseContext
-> ProjectBuildContext
-> FilePath
-> [FilePath]
-> NixStyleFlags BuildFlags
-> GlobalFlags
-> Context
Context
        ProjectBaseContext
baseCtx
        ProjectBuildContext
buildCtx
        (DistDirLayout -> FilePath
distDirectory (ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
baseCtx) FilePath -> ShowS
</> FilePath
".hoogle")
        [FilePath]
targetStrings'
        NixStyleFlags BuildFlags
flags
        GlobalFlags
globalFlags
  where
    defaultFlags :: NixStyleFlags BuildFlags
defaultFlags = BuildFlags -> NixStyleFlags BuildFlags
forall a. a -> NixStyleFlags a
defaultNixStyleFlags BuildFlags
defaultBuildFlags
    flags :: NixStyleFlags BuildFlags
flags =
      NixStyleFlags BuildFlags
defaultFlags
        { configFlags =
            (configFlags defaultFlags)
              { configOptimization = Flag NoOptimisation,
                configDistPref = Flag _globalOptions_builddir
              },
          haddockFlags =
            (haddockFlags defaultFlags)
              { haddockHoogle = Flag True,
                haddockHtml = Flag True,
                haddockLinkedSource = Flag True,
                haddockQuickJump = Flag True
              },
          installFlags =
            (installFlags defaultFlags)
              { installDocumentation = Flag True
              }
        }
    targetStrings' :: [String]
    targetStrings' :: [FilePath]
targetStrings' = if [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
targetStrings then [FilePath
"all"] else [FilePath]
targetStrings
    globalFlags :: GlobalFlags
globalFlags = GlobalFlags
defaultGlobalFlags