module Distribution.Client.CmdHaddockProject
  ( haddockProjectCommand
  , haddockProjectAction
  ) where

import Prelude ()
import Distribution.Client.Compat.Prelude hiding (get)

import qualified Distribution.Client.CmdBuild   as CmdBuild
import qualified Distribution.Client.CmdHaddock as CmdHaddock

import Distribution.Client.DistDirLayout      (DistDirLayout(..)
                                              ,CabalDirLayout(..)
                                              ,StoreDirLayout(..))
import Distribution.Client.InstallPlan        (foldPlanPackage)
import qualified Distribution.Client.InstallPlan as InstallPlan
import qualified Distribution.Client.NixStyleOptions as NixStyleOptions
import Distribution.Client.ProjectOrchestration
                                              (AvailableTarget(..)
                                              ,AvailableTargetStatus(..)
                                              ,CurrentCommand(..)
                                              ,ProjectBaseContext(..)
                                              ,ProjectBuildContext(..)
                                              ,TargetSelector(..)
                                              ,printPlan
                                              ,pruneInstallPlanToTargets
                                              ,resolveTargets
                                              ,runProjectPreBuildPhase
                                              ,selectComponentTargetBasic)
import Distribution.Client.ProjectPlanning    (ElaboratedConfiguredPackage(..)
                                              ,ElaboratedInstallPlan
                                              ,ElaboratedSharedConfig(..)
                                              ,TargetAction(..))
import Distribution.Client.ProjectPlanning.Types
                                              (elabDistDirParams)
import Distribution.Client.Setup              (GlobalFlags(..)
                                              ,ConfigFlags(..))
import Distribution.Client.ScriptUtils        (AcceptNoTargets(..)
                                              ,TargetContext(..)
                                              ,updateContextAndWriteProjectFile
                                              ,withContextAndSelectors)
import Distribution.Client.TargetProblem      (TargetProblem(..))

import Distribution.Types.PackageId (pkgName)
import Distribution.Types.PackageName (unPackageName)
import Distribution.Types.UnitId (unUnitId)
import Distribution.Types.Version (mkVersion)
import Distribution.Types.VersionRange (orLaterVersion)
import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo (..))
import Distribution.Simple.Command
         ( CommandUI(..) )
import Distribution.Simple.Compiler
         ( Compiler (..) )
import Distribution.Simple.Flag
        ( Flag(..)
        , fromFlag
        , fromFlagOrDefault
        )
import Distribution.Simple.InstallDirs
         ( toPathTemplate )
import Distribution.Simple.Haddock (createHaddockIndex)
import Distribution.Simple.Utils
         ( die', createDirectoryIfMissingVerbose
         , copyDirectoryRecursive, warn )
import Distribution.Simple.Program.Builtin
         ( haddockProgram )
import Distribution.Simple.Program.Db
         ( addKnownProgram, reconfigurePrograms, requireProgramVersion )
import Distribution.Simple.Setup
         ( HaddockFlags(..), defaultHaddockFlags
         , HaddockProjectFlags(..)
         , Visibility(..)
         , haddockProjectCommand
         )
import Distribution.Verbosity as Verbosity
         ( normal )

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

haddockProjectAction :: HaddockProjectFlags -> [String] -> GlobalFlags -> IO ()
haddockProjectAction flags _extraArgs globalFlags = do
    -- create destination directory if it does not exist
    let outputDir = normalise $ fromFlag (haddockProjectDir flags)
    createDirectoryIfMissingVerbose verbosity True outputDir

    warn verbosity "haddock-project command is experimental, it might break in the future"

    -- build all packages with appropriate haddock flags
    let haddockFlags = defaultHaddockFlags
          { haddockHtml         = Flag True
          -- one can either use `--haddock-base-url` or
          -- `--haddock-html-location`.
          , haddockBaseUrl      = if localStyle
                                  then Flag ".."
                                  else NoFlag
          , haddockProgramPaths = haddockProjectProgramPaths  flags
          , haddockProgramArgs  = haddockProjectProgramArgs   flags
          , haddockHtmlLocation = if fromFlagOrDefault False (haddockProjectHackage flags)
                                  then Flag "https://hackage.haskell.org/package/$pkg-$version/docs"
                                  else haddockProjectHtmlLocation flags
          , haddockHoogle       = haddockProjectHoogle        flags
          , haddockExecutables  = haddockProjectExecutables   flags
          , haddockTestSuites   = haddockProjectTestSuites    flags
          , haddockBenchmarks   = haddockProjectBenchmarks    flags
          , haddockForeignLibs  = haddockProjectForeignLibs   flags
          , haddockInternal     = haddockProjectInternal      flags
          , haddockCss          = haddockProjectCss           flags
          , haddockLinkedSource = Flag True
          , haddockQuickJump = Flag True
          , haddockHscolourCss  = haddockProjectHscolourCss    flags
          , haddockContents     = if localStyle then Flag (toPathTemplate "../index.html")
                                                else NoFlag
          , haddockIndex        = if localStyle then Flag (toPathTemplate "../doc-index.html")
                                                else NoFlag
          , haddockKeepTempFiles= haddockProjectKeepTempFiles flags
          , haddockVerbosity    = haddockProjectVerbosity     flags
          , haddockLib          = haddockProjectLib           flags
          }
        nixFlags = (commandDefaultFlags CmdHaddock.haddockCommand)
                   { NixStyleOptions.haddockFlags = haddockFlags
                   , NixStyleOptions.configFlags  =
                       (NixStyleOptions.configFlags (commandDefaultFlags CmdBuild.buildCommand))
                       { configVerbosity = haddockProjectVerbosity flags }
                   }

    --
    -- Construct the build plan and infer the list of packages which haddocks
    -- we need.
    --

    withContextAndSelectors RejectNoTargets Nothing (commandDefaultFlags CmdBuild.buildCommand) ["all"] globalFlags HaddockCommand $ \targetCtx ctx targetSelectors -> do
      baseCtx <- case targetCtx of
        ProjectContext             -> return ctx
        GlobalContext              -> return ctx
        ScriptContext path exemeta -> updateContextAndWriteProjectFile ctx path exemeta
      let distLayout  = distDirLayout baseCtx
          cabalLayout = cabalDirLayout baseCtx
      buildCtx <-
        runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
              -- Interpret the targets on the command line as build targets
              -- (as opposed to say repl or haddock targets).
              targets <- either reportTargetProblems return
                       $ resolveTargets
                           selectPackageTargets
                           selectComponentTargetBasic
                           elaboratedPlan
                           Nothing
                           targetSelectors

              let elaboratedPlan' = pruneInstallPlanToTargets
                                      TargetActionBuild
                                      targets
                                      elaboratedPlan
              return (elaboratedPlan', targets)

      printPlan verbosity baseCtx buildCtx

      let elaboratedPlan :: ElaboratedInstallPlan
          elaboratedPlan = elaboratedPlanOriginal buildCtx

          sharedConfig :: ElaboratedSharedConfig
          sharedConfig = elaboratedShared buildCtx

          pkgs :: [Either InstalledPackageInfo ElaboratedConfiguredPackage ]
          pkgs = matchingPackages elaboratedPlan

      progs <- reconfigurePrograms verbosity
                 (haddockProjectProgramPaths flags)
                 (haddockProjectProgramArgs flags)
               -- we need to insert 'haddockProgram' before we reconfigure it,
               -- otherwise 'set
             . addKnownProgram haddockProgram
             . pkgConfigCompilerProgs
             $ sharedConfig
      let sharedConfig' = sharedConfig { pkgConfigCompilerProgs = progs }

      _ <- requireProgramVersion
             verbosity haddockProgram
             (orLaterVersion (mkVersion [2,26,1])) progs

      --
      -- Build project; we need to build dependencies.
      -- Issue #8958.
      --

      when localStyle $
        CmdBuild.buildAction
          (commandDefaultFlags CmdBuild.buildCommand)
          ["all"]
          globalFlags
      --
      -- Build haddocks of each components
      --

      CmdHaddock.haddockAction
        nixFlags
        ["all"]
        globalFlags

      --
      -- Copy haddocks to the destination folder
      --

      packageInfos <- fmap (nub . concat) $ for pkgs $ \pkg ->
        case pkg of
          Left _ | not localStyle ->
            return []
          Left package -> do
            -- TODO: this might not work for public packages with sublibraries.
            -- Issue #9026.
            let packageName = unPackageName (pkgName $ sourcePackageId package)
                destDir = outputDir </> packageName
            fmap catMaybes $ for (haddockInterfaces package) $ \interfacePath -> do
              let docDir = takeDirectory interfacePath
              a <- doesFileExist interfacePath
              case a of
                True -> copyDirectoryRecursive verbosity docDir destDir
                     >> return (Just ( packageName
                                     , interfacePath
                                     , Hidden
                                     ))
                False -> return Nothing

          Right package ->
            case elabLocalToProject package of
              True -> do
                let distDirParams = elabDistDirParams sharedConfig' package
                    unitId = unUnitId (elabUnitId package)
                    buildDir = distBuildDirectory distLayout distDirParams
                    packageName = unPackageName (pkgName $ elabPkgSourceId package)
                let docDir = buildDir
                         </> "doc" </> "html"
                         </> packageName
                    destDir = outputDir </> unitId
                    interfacePath = destDir
                                </> packageName <.> "haddock"
                a <- doesDirectoryExist docDir
                case a of
                  True  -> copyDirectoryRecursive verbosity docDir destDir
                        >> return [( packageName
                                   , interfacePath
                                   , Visible
                                   )]
                  False -> do
                    warn verbosity
                         ("haddocks of "
                          ++ show unitId
                          ++ " not found in the store")
                    return []
              False | not localStyle ->
                return []
              False -> do
                let packageName = unPackageName (pkgName $ elabPkgSourceId package)
                    unitId = unUnitId (elabUnitId package)
                    packageDir = storePackageDirectory (cabalStoreDirLayout cabalLayout)
                                   (compilerId (pkgConfigCompiler sharedConfig'))
                                   (elabUnitId package)
                    docDir = packageDir </> "share" </> "doc" </> "html"
                    destDir = outputDir </> packageName
                    interfacePath = destDir
                                </> packageName <.> "haddock"
                a <- doesDirectoryExist docDir
                case a of
                  True  -> copyDirectoryRecursive verbosity docDir destDir
                        -- non local packages will be hidden in haddock's
                        -- generated contents page
                        >> return [( unitId
                                   , interfacePath
                                   , Hidden
                                   )]
                  False -> do
                    warn verbosity
                         ("haddocks of "
                          ++ show unitId
                          ++ " not found in the store")
                    return []

      --
      -- generate index, content, etc.
      --

      let flags' = flags
            { haddockProjectDir         = Flag outputDir
            , haddockProjectInterfaces  = Flag
                [ ( interfacePath
                  , Just name
                  , Just name
                  , visibility
                  )
                | (name, interfacePath, visibility) <- packageInfos
                ]
            }
      createHaddockIndex verbosity
                         (pkgConfigCompilerProgs sharedConfig')
                         (pkgConfigCompiler sharedConfig')
                         (pkgConfigPlatform sharedConfig')
                         flags'
  where
    verbosity = fromFlagOrDefault normal (haddockProjectVerbosity flags)

    -- Build a self contained directory which contains haddocks of all
    -- transitive dependencies; or depend on `--haddocks-html-location` to
    -- provide location of the documentation of dependencies.
    localStyle =
      let hackage  = fromFlagOrDefault False (haddockProjectHackage flags)
          location = fromFlagOrDefault False (const True <$> haddockProjectHtmlLocation flags)
      in not hackage && not location

    reportTargetProblems :: Show x => [x] -> IO a
    reportTargetProblems =
        die' verbosity . unlines . map show

    -- TODO: this is just a sketch
    selectPackageTargets :: TargetSelector
                         -> [AvailableTarget k]
                         -> Either (TargetProblem ()) [k]
    selectPackageTargets _ ts = Right $
      mapMaybe
        (\t -> case availableTargetStatus t of
            TargetBuildable k _ | availableTargetLocalToProject t
                                -> Just k
            _                   -> Nothing)
        ts

    matchingPackages :: ElaboratedInstallPlan
                     -> [Either InstalledPackageInfo ElaboratedConfiguredPackage]
    matchingPackages =
        fmap (foldPlanPackage Left Right)
      . InstallPlan.toList
