content: {-# LANGUAGE NoImplicitPrelude     #-}
  {-# LANGUAGE DuplicateRecordFields #-}
  {-# LANGUAGE NoFieldSelectors      #-}
  {-# LANGUAGE OverloadedRecordDot   #-}
  {-# LANGUAGE OverloadedStrings     #-}
  
  {-|
  Module      : Stack.Path
  Description : Types and functions related to Stack's @path@ command.
  License     : BSD-3-Clause
  
  Types and functions related to Stack's @path@ command.
  -}
  
  module Stack.Path
    ( EnvConfigPathInfo
    , UseHaddocks
    , path
    , pathsFromRunner
    , pathsFromConfig
    , pathsFromEnvConfig
    ) where
  
  import           Control.Exception ( throw )
  import           Data.List ( intercalate )
  import qualified Data.Text as T
  import qualified Data.Text.IO as T
  import           Path ( (</>), parent )
  import           Path.Extra ( toFilePathNoTrailingSep )
  import           RIO.Process ( HasProcessContext (..), exeSearchPathL )
  import           Stack.Config ( determineStackRootAndOwnership )
  import           Stack.Constants
                     ( docDirSuffix, stackGlobalConfigOptionName
                     , stackRootOptionName
                     )
  import           Stack.Constants.Config ( distRelativeDir )
  import           Stack.GhcPkg as GhcPkg
  import           Stack.Prelude hiding ( pi )
  import           Stack.Runners
                     ( ShouldReexec (..), withConfig, withDefaultEnvConfig )
  import           Stack.Types.BuildConfig
                     ( BuildConfig (..), HasBuildConfig (..), configFileL )
  import           Stack.Types.BuildOptsMonoid ( buildOptsMonoidHaddockL )
  import           Stack.Types.CompilerPaths
                     ( CompilerPaths (..), HasCompiler (..), getCompilerPath )
  import           Stack.Types.Config
                     ( Config (..), HasConfig (..), userGlobalConfigFileL )
  import           Stack.Types.Config.Exception ( ConfigPrettyException (..) )
  import           Stack.Types.EnvConfig
                     ( EnvConfig, HasEnvConfig (..), bindirCompilerTools
                     , hpcReportDir, installationRootDeps, installationRootLocal
                     , packageDatabaseDeps, packageDatabaseExtra
                     , packageDatabaseLocal
                     )
  import qualified Stack.Types.EnvConfig as EnvConfig
  import           Stack.Types.GHCVariant ( HasGHCVariant (..) )
  import           Stack.Types.GlobalOpts
                     ( GlobalOpts (..), globalOptsBuildOptsMonoidL )
  import           Stack.Types.Platform ( HasPlatform (..) )
  import           Stack.Types.Runner ( HasRunner (..), Runner, globalOptsL )
  import qualified System.FilePath as FP
  
  -- | Print out useful path information in a human-readable format (and support
  -- others later).
  path :: [Text] -> RIO Runner ()
  path keys = do
    let -- filter the chosen paths in flags (keys), or show all of them if no
        -- specific paths chosen.
        filterKeys :: (String, Text, a) -> Bool
        filterKeys (_, key, _) = null keys || elem key keys
        goodPathsFromRunner = null keys || elem stackRootOptionName' keys
        goodPathsFromConfig = filter filterKeys pathsFromConfig
        goodPathsFromEnvConfig = filter filterKeys pathsFromEnvConfig
        toKeyPath (_, key, p) = (key, p)
        goodPathsFromConfig' = map toKeyPath goodPathsFromConfig
        singlePath = (if goodPathsFromRunner then 1 else 0) +
          length goodPathsFromConfig + length goodPathsFromEnvConfig == 1
        toEither (_, k, UseHaddocks a) = Left (k, a)
        toEither (_, k, WithoutHaddocks a) = Right (k, a)
        (with, without) = partitionEithers $ map toEither goodPathsFromEnvConfig
    when goodPathsFromRunner $ printKeysWithRunner singlePath
    unless (null goodPathsFromConfig') $
      runHaddockWithConfig $ printKeysWithConfig goodPathsFromConfig' singlePath
    unless (null without) $
      runHaddockWithEnvConfig False $ printKeysWithEnvConfig without singlePath
    unless (null with) $
      runHaddockWithEnvConfig True $ printKeysWithEnvConfig with singlePath
  
  printKeysWithRunner ::
       Bool
    -> RIO Runner ()
  printKeysWithRunner single = do
    clArgs <- view $ globalOptsL . to (.configMonoid)
    liftIO $ do
      (_, stackRoot, _) <- determineStackRootAndOwnership clArgs
      let prefix = if single then "" else stackRootOptionName' <> ": "
      T.putStrLn $ prefix <> T.pack (toFilePathNoTrailingSep stackRoot)
  
  printKeysWithConfig ::
       HasConfig env
    => [(Text, Config -> Text)]
    -> Bool
    -> RIO env ()
  printKeysWithConfig extractors single =
    view configL >>= printKeys extractors single
  
  printKeysWithEnvConfig ::
       HasEnvConfig env
    => [(Text, EnvConfigPathInfo -> Text)]
    -> Bool
    -> RIO env ()
  printKeysWithEnvConfig extractors single =
    fillEnvConfigPathInfo >>= printKeys extractors single
  
  printKeys ::
       [(Text, info -> Text)]
    -> Bool
    -> info
    -> RIO env ()
  printKeys extractors single info = do
    liftIO $ forM_ extractors $ \(key, extractPath) -> do
      let prefix = if single then "" else key <> ": "
      T.putStrLn $ prefix <> extractPath info
  
  runHaddockWithEnvConfig :: Bool -> RIO EnvConfig () -> RIO Runner ()
  runHaddockWithEnvConfig x action = runHaddock x (withDefaultEnvConfig action)
  
  runHaddockWithConfig :: RIO Config () -> RIO Runner ()
  runHaddockWithConfig = runHaddock False
  
  runHaddock :: Bool -> RIO Config () -> RIO Runner ()
  runHaddock x action = local modifyConfig $ withConfig YesReexec action
   where
    modifyConfig = set
      (globalOptsL . globalOptsBuildOptsMonoidL . buildOptsMonoidHaddockL)
      (Just x)
  
  fillEnvConfigPathInfo :: HasEnvConfig env => RIO env EnvConfigPathInfo
  fillEnvConfigPathInfo = do
    -- We must use a BuildConfig from an EnvConfig to ensure that it contains the
    -- full environment info including GHC paths etc.
    buildConfig <- view $ envConfigL . buildConfigL
    -- This is the modified 'bin-path',
    -- including the local GHC or MSYS if not configured to operate on
    -- global GHC.
    -- It was set up in 'withBuildConfigAndLock -> withBuildConfigExt -> setupEnv'.
    -- So it's not the *minimal* override path.
    snapDb <- packageDatabaseDeps
    localDb <- packageDatabaseLocal
    extraDbs <- packageDatabaseExtra
    globalDb <- view $ compilerPathsL . to (.globalDB)
    snapRoot <- installationRootDeps
    localRoot <- installationRootLocal
    toolsDir <- bindirCompilerTools
    hoogleRoot <- EnvConfig.hoogleRoot
    distDir <- distRelativeDir
    hpcDir <- hpcReportDir
    compiler <- getCompilerPath
    pure EnvConfigPathInfo
      { buildConfig
      , snapDb
      , localDb
      , globalDb
      , snapRoot
      , localRoot
      , toolsDir
      , hoogleRoot
      , distDir
      , hpcDir
      , extraDbs
      , compiler
      }
  
  -- | Type representing information needed to generate an appropriate string for
  -- paths of interest to a user which require an 'EnvConfig'.
  data EnvConfigPathInfo = EnvConfigPathInfo
    { buildConfig  :: !BuildConfig
    , snapDb       :: !(Path Abs Dir)
    , localDb      :: !(Path Abs Dir)
    , globalDb     :: !(Path Abs Dir)
    , snapRoot     :: !(Path Abs Dir)
    , localRoot    :: !(Path Abs Dir)
    , toolsDir     :: !(Path Abs Dir)
    , hoogleRoot   :: !(Path Abs Dir)
    , distDir      :: Path Rel Dir
    , hpcDir       :: !(Path Abs Dir)
    , extraDbs     :: ![Path Abs Dir]
    , compiler     :: !(Path Abs File)
    }
  
  instance HasPlatform EnvConfigPathInfo where
    platformL = configL . platformL
    {-# INLINE platformL #-}
    platformVariantL = configL . platformVariantL
    {-# INLINE platformVariantL #-}
  
  instance HasLogFunc EnvConfigPathInfo where
    logFuncL = configL . logFuncL
  
  instance HasRunner EnvConfigPathInfo where
    runnerL = configL . runnerL
  
  instance HasStylesUpdate EnvConfigPathInfo where
    stylesUpdateL = runnerL . stylesUpdateL
  
  instance HasTerm EnvConfigPathInfo where
    useColorL = runnerL . useColorL
    termWidthL = runnerL . termWidthL
  
  instance HasGHCVariant EnvConfigPathInfo where
    ghcVariantL = configL . ghcVariantL
    {-# INLINE ghcVariantL #-}
  
  instance HasConfig EnvConfigPathInfo where
    configL = buildConfigL . lens (.config) (\x y -> x { config = y })
    {-# INLINE configL #-}
  
  instance HasPantryConfig EnvConfigPathInfo where
    pantryConfigL = configL . pantryConfigL
  
  instance HasProcessContext EnvConfigPathInfo where
    processContextL = configL . processContextL
  
  instance HasBuildConfig EnvConfigPathInfo where
    buildConfigL =
      lens (.buildConfig) (\x y -> x { buildConfig = y }) . buildConfigL
  
  -- | Type representing whether or not building Haddocks is required.
  data UseHaddocks a
    = UseHaddocks a
      -- ^ Building Haddocks is required.
    | WithoutHaddocks a
      -- ^ Building Haddocks is not required.
  
  -- | The paths of interest to a user which do require a t'Config' or
  -- 'EnvConfig'. The first tuple string is used for a description that the
  -- optparse flag uses, and the second string as a machine-readable key and also
  -- for @--foo@ flags. The user can choose a specific path to list like
  -- @--stack-root@. But really it's mainly for the documentation aspect.
  pathsFromRunner :: (String, Text)
  pathsFromRunner = ("Global Stack root directory", stackRootOptionName')
  
  -- | The paths of interest to a user which do require an 'EnvConfig'. The first
  -- tuple string is used for a description that the optparse flag uses, and the
  -- second string as a machine-readable key and also for @--foo@ flags. The user
  -- can choose a specific path to list like @--stack-root@. But really it's
  -- mainly for the documentation aspect.
  --
  -- When printing output we generate t'Config' and pass it to the function
  -- to generate an appropriate string. Trailing slashes are removed, see #506.
  pathsFromConfig :: [(String, Text, Config -> Text)]
  pathsFromConfig =
    [ ( "User-specific global configuration file"
      , T.pack stackGlobalConfigOptionName
      , view (userGlobalConfigFileL . to toFilePath . to T.pack)
      )
    , ( "Install location for GHC and other core tools (see 'stack ls tools' command)"
      , "programs"
      , view (configL . to (.localPrograms) . to toFilePathNoTrailingSep . to T.pack)
      )
    , ( "Directory where Stack installs executables (e.g. ~/.local/bin (Unix-like OSs) or %APPDATA%\\local\\bin (Windows))"
      , "local-bin"
      , view $ configL . to (.localBin) . to toFilePathNoTrailingSep . to T.pack
      )
    ]
  
  -- | The paths of interest to a user which require a 'EnvConfig'. The first
  -- tuple string is used for a description that the optparse flag uses, and the
  -- second string as a machine-readable key and also for @--foo@ flags. The user
  -- can choose a specific path to list like @--project-root@. But really it's
  -- mainly for the documentation aspect.
  --
  -- When printing output we generate t'EnvConfigPathInfo' and pass it to the
  -- function to generate an appropriate string. Trailing slashes are removed, see
  -- #506.
  pathsFromEnvConfig :: [(String, Text, UseHaddocks (EnvConfigPathInfo -> Text))]
  pathsFromEnvConfig =
    [ ( "Project root (derived from the project-level configuration file; \
        \stack.yaml, by default)"
      , "project-root"
      , WithoutHaddocks $ view (configFileL . to toProjectConfigFileRootPath)
      )
    , ( "Project-level configuration file (stack.yaml, by default)"
      , "config-location"
      , WithoutHaddocks $ view (configFileL . to toProjectConfigFilePath)
      )
    , ( "PATH environment variable"
      , "bin-path"
      , WithoutHaddocks $
          T.pack . intercalate [FP.searchPathSeparator] . view exeSearchPathL
      )
    , ( "Compiler binary (e.g. ghc)"
      , "compiler-exe"
      , WithoutHaddocks $ T.pack . toFilePath . (.compiler)
      )
    , ( "Directory containing the compiler binary (e.g. ghc)"
      , "compiler-bin"
      , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . parent . (.compiler)
      )
    , ( "Directory containing binaries specific to a particular compiler"
      , "compiler-tools-bin"
      , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . (.toolsDir)
      )
    , ( "Extra include directories"
      , "extra-include-dirs"
      , WithoutHaddocks $
          T.intercalate ", " . map T.pack . (.extraIncludeDirs) . view configL
      )
    , ( "Extra library directories"
      , "extra-library-dirs"
      , WithoutHaddocks $
          T.intercalate ", " . map T.pack . (.extraLibDirs) . view configL
      )
    , ( "Snapshot package database"
      , "snapshot-pkg-db"
      , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . (.snapDb)
      )
    , ( "Local project package database"
      , "local-pkg-db"
      , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . (.localDb)
      )
    , ( "Global package database"
      , "global-pkg-db"
      , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . (.globalDb)
      )
    , ( "GHC_PACKAGE_PATH environment variable"
      , "ghc-package-path"
      , WithoutHaddocks $
          \pi -> mkGhcPackagePath
                   True
                   pi.localDb
                   pi.snapDb
                   pi.extraDbs
                   pi.globalDb
      )
    , ( "Snapshot installation root"
      , "snapshot-install-root"
      , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . (.snapRoot)
      )
    , ( "Local project installation root"
      , "local-install-root"
      , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . (.localRoot)
      )
    , ( "Snapshot documentation root"
      , "snapshot-doc-root"
      , UseHaddocks $
          \pi -> T.pack (toFilePathNoTrailingSep (pi.snapRoot </> docDirSuffix))
      )
    , ( "Local project documentation root"
      , "local-doc-root"
      , UseHaddocks $
          \pi -> T.pack (toFilePathNoTrailingSep (pi.localRoot </> docDirSuffix))
      )
    , ( "Local project documentation root"
      , "local-hoogle-root"
      , UseHaddocks $ T.pack . toFilePathNoTrailingSep . (.hoogleRoot)
      )
    , ( "Dist work directory, relative to package directory"
      , "dist-dir"
      , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . (.distDir)
      )
    , ( "Where HPC reports and tix files are stored"
      , "local-hpc-root"
      , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . (.hpcDir)
      )
    ]
   where
    toProjectConfigFileRootPath :: Either (Path Abs File) (Path Abs File) -> Text
    toProjectConfigFileRootPath (Left _) =
      throw $ PrettyException ConfigFileNotProjectLevelBug
    toProjectConfigFileRootPath (Right projectConfigFile) =
      T.pack $ toFilePathNoTrailingSep $ parent projectConfigFile
    toProjectConfigFilePath :: Either (Path Abs File) (Path Abs File) -> Text
    toProjectConfigFilePath (Left _) =
      throw $ PrettyException ConfigFileNotProjectLevelBug
    toProjectConfigFilePath (Right projectConfigFile) =
      T.pack $ toFilePath projectConfigFile
  
  -- | 'Text' equivalent of 'stackRootOptionName'.
  stackRootOptionName' :: Text
  stackRootOptionName' = T.pack stackRootOptionName
  