content: {-# LANGUAGE NoImplicitPrelude   #-}
  {-# LANGUAGE OverloadedRecordDot #-}
  {-# LANGUAGE OverloadedStrings   #-}
  
  {-|
  Module      : Stack.Clean
  Description : Types and functions related to Stack's @clean@ and @purge@ commands.
  License     : BSD-3-Clause
  
  Types and functions related to Stack's @clean@ and @purge@ commands.
  -}
  
  module Stack.Clean
    ( CleanOpts (..)
    , CleanDepth (..)
    , CleanCommand (..)
    , cleanCmd
    , clean
    ) where
  
  import           Control.Monad.Extra ( concatMapM )
  import           Data.List ( (\\) )
  import qualified Data.Map.Strict as Map
  import           Path ( (</>), isProperPrefixOf )
  import           Path.IO ( ignoringAbsence, listDirRecur, removeDirRecur )
  import           Stack.Config ( withBuildConfig )
  import           Stack.Constants.Config
                     ( distRelativeDir, rootDistDirFromDir, workDirFromDir )
  import           Stack.Prelude
  import           Stack.Runners
                     ( ShouldReexec (..), withConfig, withDefaultEnvConfig )
  import           Stack.Types.BuildConfig
                     ( BuildConfig (..), HasBuildConfig (..), getWorkDir )
  import           Stack.Types.Config ( Config )
  import           Stack.Types.EnvConfig ( EnvConfig )
  import           Stack.Types.Runner ( Runner )
  import           Stack.Types.SourceMap ( ProjectPackage, SMWanted (..), ppRoot )
  
  -- | Type representing \'pretty\' exceptions thrown by functions exported by the
  -- "Stack.Clean" module.
  data CleanPrettyException
    = NonLocalPackages [PackageName]
    | DeletionFailures [(Path Abs Dir, SomeException)]
    deriving Show
  
  instance Pretty CleanPrettyException where
    pretty (NonLocalPackages pkgs) =
      "[S-9463]"
      <> line
      <> fillSep
           ( flow "The following are not project packages:"
           : mkNarrativeList (Just Current) False
               (map fromPackageName pkgs :: [StyleDoc])
           )
    pretty (DeletionFailures failures) =
      "[S-6321]"
      <> line
      <> flow "Exception while recursively deleting:"
      <> line
      <> mconcat (map prettyFailure failures)
      <> flow "Perhaps you do not have permission to delete these files or they \
              \are in use?"
     where
      prettyFailure (dir, e) =
           pretty dir
        <> line
        <> string (displayException e)
        <> line
  
  instance Exception CleanPrettyException
  
  -- | Type representing command line options for the @stack clean@ command.
  data CleanOpts = CleanOpts
    { depth    :: !CleanDepth
    , omitThis :: !Bool
    }
  
  -- | Type representing depths of cleaning for the @stack clean@ command.
  data CleanDepth
    = CleanShallow [PackageName]
      -- ^ Delete the "dist directories" as defined in
      -- 'Stack.Constants.Config.distRelativeDir' for the given project packages.
      -- If no project packages are given, all project packages should be cleaned.
    | CleanFull
      -- ^ Delete all work directories in the project.
  
  -- | Type representing Stack's cleaning commands.
  data CleanCommand
    = Clean
    | Purge
  
  -- | Function underlying the @stack clean@ command.
  cleanCmd :: CleanOpts -> RIO Runner ()
  cleanCmd = withConfig NoReexec . clean
  
  -- | Deletes build artifacts in the current project.
  clean :: CleanOpts -> RIO Config ()
  clean cleanOpts = do
    toDelete <- if cleanOpts.omitThis
      then
        withDefaultEnvConfig $ dirsToDeleteGivenConfig cleanOpts.depth
      else
        withBuildConfig $ dirsToDeleteSimple cleanOpts.depth
    logDebug $ "Need to delete: " <> fromString (show (map toFilePath toDelete))
    failures <- catMaybes <$> mapM cleanDir toDelete
    case failures of
      [] -> pure ()
      _  -> prettyThrowIO $ DeletionFailures failures
  
  cleanDir :: Path Abs Dir -> RIO Config (Maybe (Path Abs Dir, SomeException))
  cleanDir dir = do
    logDebug $ "Deleting directory: " <> fromString (toFilePath dir)
    liftIO (ignoringAbsence (removeDirRecur dir) >> pure Nothing) `catchAny` \ex ->
      pure $ Just (dir, ex)
  
  dirsToDeleteSimple :: CleanDepth -> RIO BuildConfig [Path Abs Dir]
  dirsToDeleteSimple depth = do
    packages <- view $ buildConfigL . to (.smWanted.project)
    case depth of
      CleanShallow [] -> do
        -- Filter out packages listed as extra-deps
        let pkgNames = Map.elems packages
        mapM (rootDistDirFromDir . ppRoot) pkgNames
      CleanShallow targets -> do
        let localPkgNames = Map.keys packages
            getPkgDir pkgName' = fmap ppRoot (Map.lookup pkgName' packages)
            pkgNames = mapMaybe getPkgDir targets
        case targets \\ localPkgNames of
          [] -> mapM rootDistDirFromDir pkgNames
          xs -> prettyThrowM (NonLocalPackages xs)
      CleanFull -> allWorkDirs $ Map.elems packages
  
  dirsToDeleteGivenConfig :: CleanDepth -> RIO EnvConfig [Path Abs Dir]
  dirsToDeleteGivenConfig depth = do
    packages <- view $ buildConfigL . to (.smWanted.project)
    case depth of
      CleanShallow [] -> do
        -- Filter out packages listed as extra-deps
        let pkgNames = Map.elems packages
        concatMapM (unusedRootDistDirsFromDir . ppRoot) pkgNames
      CleanShallow targets -> do
        let localPkgNames = Map.keys packages
            getPkgDir pkgName' = fmap ppRoot (Map.lookup pkgName' packages)
            pkgNames = mapMaybe getPkgDir targets
        case targets \\ localPkgNames of
          [] -> concatMapM unusedRootDistDirsFromDir pkgNames
          xs -> prettyThrowM (NonLocalPackages xs)
      CleanFull -> allWorkDirs $ Map.elems packages
  
  allWorkDirs :: HasBuildConfig env => [ProjectPackage] -> RIO env [Path Abs Dir]
  allWorkDirs pps = do
    pkgWorkDirs <- mapM (workDirFromDir . ppRoot) pps
    projectWorkDir <- getWorkDir
    pure (projectWorkDir : pkgWorkDirs)
  
  unusedRootDistDirsFromDir :: Path Abs Dir -> RIO EnvConfig [Path Abs Dir]
  unusedRootDistDirsFromDir pkgDir = do
    rootDistDir <- rootDistDirFromDir pkgDir
    omitDir <- fmap (pkgDir </>) distRelativeDir
    allDirsOmittingDirs rootDistDir omitDir
  
  allDirsOmittingDirs ::
       MonadIO m
    => Path Abs Dir
    -> Path Abs Dir
    -> m [Path Abs Dir]
  allDirsOmittingDirs topDir subDir = do
    allDirs <- (topDir :) . fst <$> listDirRecur topDir
    let isNotInSubDir dir = not
          ( isProperPrefixOf dir subDir
          || subDir == dir
          || isProperPrefixOf subDir dir
          )
    pure $ filter isNotInSubDir allDirs
  