content: {-# LANGUAGE NoImplicitPrelude     #-}
  {-# LANGUAGE DuplicateRecordFields #-}
  {-# LANGUAGE OverloadedRecordDot   #-}
  {-# LANGUAGE OverloadedStrings     #-}
  
  {-|
  Module      : Stack.BuildPlan
  License     : BSD-3-Clause
  
  Resolving a build plan for a set of packages in a given Stackage snapshot.
  -}
  
  module Stack.BuildPlan
    ( BuildPlanException (..)
    , BuildPlanCheck (..)
    , checkSnapBuildPlan
    , DepError (..)
    , DepErrors
    , removeSrcPkgDefaultFlags
    , selectBestSnapshot
    ) where
  
  import qualified Data.Foldable as F
  import           Data.List (intercalate)
  import qualified Data.Map as Map
  import qualified Data.Set as Set
  import qualified Data.Text as T
  import qualified Distribution.Package as C
  import           Distribution.PackageDescription
                     ( GenericPackageDescription, flagDefault, flagName
                     , flagManual, genPackageFlags
                     )
  import qualified Distribution.PackageDescription as C
  import           Distribution.System ( Platform )
  import           Distribution.Text ( display )
  import           Distribution.Types.UnqualComponentName
                     ( unUnqualComponentName )
  import qualified Distribution.Version as C
  import qualified RIO.NonEmpty as NE
  import           Stack.Constants ( wiredInPackages )
  import           Stack.Package
                     ( PackageConfig (..), packageDependencies
                     , resolvePackageDescription
                     )
  import           Stack.Prelude hiding ( Display (..) )
  import           Stack.SourceMap
                     ( SnapshotCandidate, loadProjectSnapshotCandidate )
  import           Stack.Types.Compiler
                     ( ActualCompiler, WhichCompiler (..), compilerVersionText
                     , whichCompiler
                     )
  import           Stack.Types.Config ( HasConfig )
  import           Stack.Types.GHCVariant ( HasGHCVariant )
  import           Stack.Types.Platform ( HasPlatform (..) )
  import           Stack.Types.SourceMap
                     ( CommonPackage (..), DepPackage (..)
                     , GlobalPackageVersion (..), ProjectPackage (..)
                     , SMActual (..)
                     )
  import           Stack.Types.Version ( VersionRange, withinRange )
  
  -- | Type representing exceptions thrown by functions exported by the
  -- "Stack.BuildPlan" module.
  data BuildPlanException
    = UnknownPackages
        (Path Abs File) -- stack.yaml file
        (Map PackageName (Maybe Version, Set PackageName)) -- truly unknown
        (Map PackageName (Set PackageIdentifier)) -- shadowed
    | SnapshotNotFound SnapName
    | NeitherCompilerOrSnapshotSpecified T.Text
    | DuplicatePackagesBug
    deriving Show
  
  instance Exception BuildPlanException where
    displayException (SnapshotNotFound snapName) = unlines
      [ "Error: [S-2045]"
      , "SnapshotNotFound " ++ snapName'
      , "Non existing snapshot: " ++ snapName' ++ "."
      , "For a complete list of available snapshots see https://www.stackage.org/snapshots"
      ]
     where
      snapName' = show snapName
    displayException (UnknownPackages stackYaml unknown shadowed) =
      "Error: [S-7571]\n"
      ++ unlines (unknown' ++ shadowed')
     where
      unknown' :: [String]
      unknown'
        | Map.null unknown = []
        | otherwise = concat
            [ ["The following packages do not exist in the build plan:"]
            , map go (Map.toList unknown)
            , case mapMaybe goRecommend $ Map.toList unknown of
                [] -> []
                rec ->
                    ("Recommended action: modify the value of the extra-deps key of " ++
                    toFilePath stackYaml ++
                    " to include the following:")
                    : (rec
                    ++ ["Note: further dependencies may need to be added"])
            , case mapMaybe getNoKnown $ Map.toList unknown of
                [] -> []
                noKnown ->
                    [ "There are no known versions of the following packages:"
                    , intercalate ", " $ map packageNameString noKnown
                    ]
            ]
       where
        go (dep, (_, users)) | Set.null users = packageNameString dep
        go (dep, (_, users)) = concat
          [ packageNameString dep
          , " (used by "
          , intercalate ", " $ map packageNameString $ Set.toList users
          , ")"
          ]
  
        goRecommend (name, (Just version, _)) =
          Just $ "- " ++ packageIdentifierString (PackageIdentifier name version)
        goRecommend (_, (Nothing, _)) = Nothing
  
        getNoKnown (name, (Nothing, _)) = Just name
        getNoKnown (_, (Just _, _)) = Nothing
  
      shadowed' :: [String]
      shadowed'
        | Map.null shadowed = []
        | otherwise = concat
            [ ["The following packages are shadowed by project packages:"]
            , map go (Map.toList shadowed)
            , ["Recommended action: modify the value of the extra-deps key of " ++
               toFilePath stackYaml ++
               " to include the following:"]
            , extraDeps
            , ["Note: further dependencies may need to be added"]
            ]
       where
        go (dep, users) | Set.null users = packageNameString dep ++ " (internal Stack error: this should never be null)"
        go (dep, users) = concat
          [ packageNameString dep
          , " (used by "
          , intercalate ", "
              $ map (packageNameString . pkgName)
              $ Set.toList users
          , ")"
          ]
  
        extraDeps = map (\ident -> "- " ++ packageIdentifierString ident)
                  $ Set.toList
                  $ Set.unions
                  $ Map.elems shadowed
    displayException (NeitherCompilerOrSnapshotSpecified url) = concat
      [ "Error: [S-8559]\n"
      , "Failed to load custom snapshot at "
      , T.unpack url
      , ", because no 'compiler' or 'snapshot' is specified."
      ]
    displayException DuplicatePackagesBug = bugReport "[S-5743]"
      "Duplicate packages are not expected here."
  
  gpdPackages :: [GenericPackageDescription] -> Map PackageName Version
  gpdPackages = Map.fromList . map (toPair . C.package . C.packageDescription)
   where
    toPair (C.PackageIdentifier name version) = (name, version)
  
  gpdPackageDeps ::
       GenericPackageDescription
    -> ActualCompiler
    -> Platform
    -> Map FlagName Bool
    -> Map PackageName VersionRange
  gpdPackageDeps gpd compilerVersion platform flags =
    Map.filterWithKey (const . not . isLocalLibrary) (packageDependencies pkgDesc)
   where
    isLocalLibrary name' = name' == name || name' `Set.member` subs
  
    name = gpdPackageName gpd
    subs = Set.fromList
         $ map (C.mkPackageName . unUnqualComponentName . fst)
         $ C.condSubLibraries gpd
  
    -- Since tests and benchmarks are both enabled, doesn't matter if we choose
    -- modified or unmodified
    pkgDesc = resolvePackageDescription pkgConfig gpd
    pkgConfig = PackageConfig
      { enableTests = True
      , enableBenchmarks = True
      , flags
      , ghcOptions = []
      , cabalConfigOpts = []
      , compilerVersion
      , platform
      }
  
  -- | For the given list of packages and dictionary of packages and Cabal flags,
  -- remove flags that have defaults and packages with no remaining flags.
  removeSrcPkgDefaultFlags ::
       [C.GenericPackageDescription]
    -> Map PackageName (Map FlagName Bool)
    -> Map PackageName (Map FlagName Bool)
  removeSrcPkgDefaultFlags gpds flags =
    let defaults = Map.unions (map gpdDefaultFlags gpds)
        flags'   = Map.differenceWith removeSame flags defaults
    in  Map.filter (not . Map.null) flags'
   where
    removeSame f1 f2 =
      let diff v v' = if v == v' then Nothing else Just v
      in  Just $ Map.differenceWith diff f1 f2
  
    gpdDefaultFlags gpd =
      let pairs = map (C.flagName &&& C.flagDefault) (C.genPackageFlags gpd)
      in  Map.singleton (gpdPackageName gpd) (Map.fromList pairs)
  
  -- | Find the set of @FlagName@s necessary to get the given
  -- @GenericPackageDescription@ to compile against the given @BuildPlan@. Will
  -- only modify non-manual flags, and will prefer default values for flags.
  -- Returns the plan which produces least number of dep errors
  selectPackageBuildPlan ::
       Platform
    -> ActualCompiler
    -> Map PackageName Version
    -> GenericPackageDescription
    -> (Map PackageName (Map FlagName Bool), DepErrors)
  selectPackageBuildPlan platform compiler pool gpd =
    (selectPlan . limitSearchSpace . NE.map makePlan) flagCombinations
   where
    selectPlan :: NonEmpty (a, DepErrors) -> (a, DepErrors)
    selectPlan = F.foldr1 fewerErrors
     where
      fewerErrors p1 p2
          | nErrors p1 == 0 = p1
          | nErrors p1 <= nErrors p2 = p1
          | otherwise = p2
       where
        nErrors = Map.size . snd
  
    -- Avoid exponential complexity in flag combinations making us sad pandas.
    -- See: https://github.com/commercialhaskell/stack/issues/543
    limitSearchSpace :: NonEmpty a -> NonEmpty a
    limitSearchSpace (x :| xs) = x :| take (maxFlagCombinations - 1) xs
     where
      maxFlagCombinations = 128
  
    makePlan ::
         [(FlagName, Bool)]
      -> (Map PackageName (Map FlagName Bool), DepErrors)
    makePlan flags =
      checkPackageBuildPlan platform compiler pool (Map.fromList flags) gpd
  
    flagCombinations :: NonEmpty [(FlagName, Bool)]
    flagCombinations = mapM getOptions (genPackageFlags gpd)
     where
      getOptions :: C.PackageFlag -> NonEmpty (FlagName, Bool)
      getOptions f
        | flagManual f = (fname, flagDefault f) :| []
        | flagDefault f = (fname, True) :| [(fname, False)]
        | otherwise = (fname, False) :| [(fname, True)]
       where
        fname = flagName f
  
  -- | Check whether with the given set of flags a package's dependency
  -- constraints can be satisfied against a given build plan or pool of packages.
  checkPackageBuildPlan ::
       Platform
    -> ActualCompiler
    -> Map PackageName Version
    -> Map FlagName Bool
    -> GenericPackageDescription
    -> (Map PackageName (Map FlagName Bool), DepErrors)
  checkPackageBuildPlan platform compiler pool flags gpd =
    (Map.singleton pkg flags, errs)
   where
    pkg = gpdPackageName gpd
    errs = checkPackageDeps pkg constraints pool
    constraints = gpdPackageDeps gpd compiler platform flags
  
  -- | Checks if the given package dependencies can be satisfied by the given set
  -- of packages. Will fail if a package is either missing or has a version
  -- outside of the version range.
  checkPackageDeps ::
       PackageName -- ^ package using dependencies, for constructing DepErrors
    -> Map PackageName VersionRange -- ^ dependency constraints
    -> Map PackageName Version -- ^ Available package pool or index
    -> DepErrors
  checkPackageDeps myName deps packages =
    Map.unionsWith combineDepError $ map go $ Map.toList deps
   where
    go :: (PackageName, VersionRange) -> DepErrors
    go (name, range) =
      case Map.lookup name packages of
        Nothing -> Map.singleton name DepError
          { version = Nothing
          , neededBy = Map.singleton myName range
          }
        Just v
          | withinRange v range -> Map.empty
          | otherwise -> Map.singleton name DepError
              { version = Just v
              , neededBy = Map.singleton myName range
              }
  
  -- | A type synoynm for a dictionary of packages and failures to satisfy
  -- packages' dependency constraints.
  type DepErrors = Map PackageName DepError
  
  -- | A type representing failures to satisfy packages' dependency constraints.
  data DepError = DepError
    { version :: !(Maybe Version)
      -- ^ If available, the available version of the package.
    , neededBy :: !(Map PackageName VersionRange)
      -- ^ A dictionary of the packages requiring the package and the permitted
      -- range of versions.
    }
    deriving Show
  
  -- | Combine two t'DepError's for the same 'Version'.
  combineDepError :: DepError -> DepError -> DepError
  combineDepError (DepError a x) (DepError b y) =
    assert (a == b) $ DepError a (Map.unionWith C.intersectVersionRanges x y)
  
  -- | Given a bundle of packages (a list of @GenericPackageDescriptions@'s) to
  -- build and an available package pool (snapshot) check whether the bundle's
  -- dependencies can be satisfied. If flags is passed as Nothing flag settings
  -- will be chosen automatically.
  checkBundleBuildPlan ::
       Platform
    -> ActualCompiler
    -> Map PackageName Version
    -> Maybe (Map PackageName (Map FlagName Bool))
    -> [GenericPackageDescription]
    -> (Map PackageName (Map FlagName Bool), DepErrors)
  checkBundleBuildPlan platform compiler pool flags gpds =
    ( Map.unionsWith dupError (map fst plans)
    , Map.unionsWith combineDepError (map snd plans)
    )
   where
    plans = map (pkgPlan flags) gpds
    pkgPlan Nothing gpd =
      selectPackageBuildPlan platform compiler pool' gpd
    pkgPlan (Just f) gpd =
      checkPackageBuildPlan platform compiler pool' (flags' f gpd) gpd
    flags' f gpd = fromMaybe Map.empty (Map.lookup (gpdPackageName gpd) f)
    pool' = Map.union (gpdPackages gpds) pool
  
    dupError _ _ = impureThrow DuplicatePackagesBug
  
  -- | A type representing the results of evaluating how well a snapshot satisfies
  -- the dependencies of a set of packages and a set of Cabal flags.
  data BuildPlanCheck
    = BuildPlanCheckOk (Map PackageName (Map FlagName Bool))
    | BuildPlanCheckPartial (Map PackageName (Map FlagName Bool)) DepErrors
    | BuildPlanCheckFail
        (Map PackageName (Map FlagName Bool))
        DepErrors
        ActualCompiler
  
  -- | Compare 'BuildPlanCheck', where GT means a better plan.
  compareBuildPlanCheck :: BuildPlanCheck -> BuildPlanCheck -> Ordering
  compareBuildPlanCheck
      (BuildPlanCheckPartial _ e1)
      (BuildPlanCheckPartial _ e2)
    =
      -- Note: order of comparison flipped, since it's better to have fewer errors.
      compare (Map.size e2) (Map.size e1)
  compareBuildPlanCheck (BuildPlanCheckFail _ e1 _) (BuildPlanCheckFail _ e2 _) =
    let numUserPkgs e = Map.size $ Map.unions (Map.elems (fmap (.neededBy) e))
    in  compare (numUserPkgs e2) (numUserPkgs e1)
  compareBuildPlanCheck BuildPlanCheckOk{}      BuildPlanCheckOk{}      = EQ
  compareBuildPlanCheck BuildPlanCheckOk{}      BuildPlanCheckPartial{} = GT
  compareBuildPlanCheck BuildPlanCheckOk{}      BuildPlanCheckFail{}    = GT
  compareBuildPlanCheck BuildPlanCheckPartial{} BuildPlanCheckFail{}    = GT
  compareBuildPlanCheck _                       _                       = LT
  
  instance Show BuildPlanCheck where
    show BuildPlanCheckOk {} = ""
    show (BuildPlanCheckPartial f e)  = T.unpack $ showDepErrors f e
    show (BuildPlanCheckFail f e c) = T.unpack $ showCompilerErrors f e c
  
  -- | Check a set of 'GenericPackageDescription's and a set of flags against a
  -- given snapshot. Returns how well the snapshot satisfies the dependencies of
  -- the packages.
  checkSnapBuildPlan ::
       (HasConfig env, HasGHCVariant env)
    => [ResolvedPath Dir]
    -> Maybe (Map PackageName (Map FlagName Bool))
    -> SnapshotCandidate env
    -> RIO env BuildPlanCheck
  checkSnapBuildPlan pkgDirs flags snapCandidate = do
    platform <- view platformL
    sma <- snapCandidate pkgDirs
    gpds <- liftIO $ forM (Map.elems sma.project) (.projectCommon.gpd)
  
    let compiler = sma.compiler
        globalVersion (GlobalPackageVersion v) = v
        depVersion dep
          | PLImmutable loc <- dep.location = Just $ packageLocationVersion loc
          | otherwise = Nothing
        snapPkgs = Map.union
          (Map.mapMaybe depVersion sma.deps)
          (Map.map globalVersion sma.globals)
        (f, errs) = checkBundleBuildPlan platform compiler snapPkgs flags gpds
        cerrs = compilerErrors compiler errs
  
    if Map.null errs
      then pure $ BuildPlanCheckOk f
      else if Map.null cerrs
        then pure $ BuildPlanCheckPartial f errs
        else pure $ BuildPlanCheckFail f cerrs compiler
   where
    compilerErrors compiler errs
      | whichCompiler compiler == Ghc = ghcErrors compiler errs
      | otherwise = Map.empty
  
    isGhcWiredIn compiler p _ = p `Set.member` wiredInPackages compiler
    ghcErrors compiler = Map.filterWithKey (isGhcWiredIn compiler)
  
  -- | Find a snapshot and set of flags that is compatible with and matches as
  -- best as possible with the given 'GenericPackageDescription's.
  selectBestSnapshot ::
       (HasConfig env, HasGHCVariant env)
    => [ResolvedPath Dir]
    -> NonEmpty SnapName
    -> RIO env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
  selectBestSnapshot pkgDirs snaps = do
    prettyInfo $
         fillSep
           [ flow "Selecting the best among"
           , fromString $ show (NE.length snaps)
           , "snapshots..."
           ]
      <> line
    F.foldr1 go (NE.map (getResult <=< snapshotLocation) snaps)
   where
    go mold mnew = do
      old@(_snap, _loc, bpc) <- mold
      case bpc of
        BuildPlanCheckOk {} -> pure old
        _ -> fmap (betterSnap old) mnew
  
    getResult loc = do
      candidate <- loadProjectSnapshotCandidate loc NoPrintWarnings False
      result <- checkSnapBuildPlan pkgDirs Nothing candidate
      reportResult result loc
      pure (candidate, loc, result)
  
    betterSnap (s1, l1, r1) (s2, l2, r2)
      | compareBuildPlanCheck r1 r2 /= LT = (s1, l1, r1)
      | otherwise = (s2, l2, r2)
  
    reportResult BuildPlanCheckOk {} loc =
      prettyNote $
           fillSep
             [ flow "Matches"
             , pretty $ PrettyRawSnapshotLocation loc
             ]
        <> line
  
    reportResult r@BuildPlanCheckPartial {} loc =
      prettyWarn $
           fillSep
             [ flow "Partially matches"
             , pretty $ PrettyRawSnapshotLocation loc
             ]
        <> blankLine
        <> indent 4 (string (show r))
  
    reportResult r@BuildPlanCheckFail {} loc =
      prettyWarn $
           fillSep
             [ flow "Rejected"
             , pretty $ PrettyRawSnapshotLocation loc
             ]
        <> blankLine
        <> indent 4 (string (show r))
  
  showItems :: [String] -> Text
  showItems items = T.concat (map formatItem items)
   where
    formatItem item = T.concat
      [ "    - "
      , T.pack item
      , "\n"
      ]
  
  showPackageFlags :: PackageName -> Map FlagName Bool -> Text
  showPackageFlags pkg fl =
    if not $ Map.null fl
      then
        T.concat
          [ "    - "
          , T.pack $ packageNameString pkg
          , ": "
          , T.pack $ intercalate ", "
                   $ map formatFlags (Map.toList fl)
          , "\n"
          ]
      else ""
   where
    formatFlags (f, v) = show f ++ " = " ++ show v
  
  showMapPackages :: Map PackageName a -> Text
  showMapPackages mp = showItems $ map packageNameString $ Map.keys mp
  
  showCompilerErrors ::
       Map PackageName (Map FlagName Bool)
    -> DepErrors
    -> ActualCompiler
    -> Text
  showCompilerErrors flags errs compiler =
    T.concat
      [ compilerVersionText compiler
      , " cannot be used for these packages:\n"
      , showMapPackages $ Map.unions (Map.elems (fmap (.neededBy) errs))
      , showDepErrors flags errs -- TODO only in debug mode
      ]
  
  showDepErrors :: Map PackageName (Map FlagName Bool) -> DepErrors -> Text
  showDepErrors flags errs =
    T.concat
      [ T.concat $ map formatError (Map.toList errs)
      , if T.null flagVals then ""
        else "Using package flags:\n" <> flagVals
      ]
   where
    formatError (depName, DepError mversion neededBy) = T.concat
      [ showDepVersion depName mversion
      , T.concat (map showRequirement (Map.toList neededBy))
      ]
  
    showDepVersion depName mversion = T.concat
      [ T.pack $ packageNameString depName
      , case mversion of
          Nothing -> " not found"
          Just version -> T.concat
              [ " version "
              , T.pack $ versionString version
              , " found"
              ]
      , "\n"
      ]
  
    showRequirement (user, range) = T.concat
      [ "    - "
      , T.pack $ packageNameString user
      , " requires "
      , T.pack $ display range
      , "\n"
      ]
  
    flagVals = T.concat (map showFlags userPkgs)
    userPkgs = Map.keys $ Map.unions (Map.elems (fmap (.neededBy) errs))
    showFlags pkg = maybe "" (showPackageFlags pkg) (Map.lookup pkg flags)
  