<commit_before>-----------------------------------------------------------------------------
-- |
-- Module      :  Hackage.Dependency.Types
-- Copyright   :  (c) <NAME> 2008
-- License     :  BSD-like
--
-- Maintainer  :  <EMAIL>
-- Stability   :  provisional
-- Portability :  portable
--
-- Common types for dependency resolution.
-----------------------------------------------------------------------------
module Hackage.Dependency.TopDown (
    topDownResolver
  ) where

import Hackage.Dependency.TopDown.Types
import qualified Hackage.Dependency.TopDown.Constraints as Constraints
import Hackage.Dependency.TopDown.Constraints
         ( Satisfiable(..) )
import qualified Hackage.InstallPlan as InstallPlan
import Hackage.Types
         ( UnresolvedDependency(..), AvailablePackage(..)
         , ConfiguredPackage(..) )
import Hackage.Dependency.Types
         ( DependencyResolver, Progress )
import qualified Hackage.Dependency.Types as Progress
         ( Progress(..), foldProgress )

import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PackageIndex (PackageIndex)
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import Distribution.Package
         ( PackageIdentifier(PackageIdentifier), Dependency(Dependency)
         , Package(..), packageVersion )
import Distribution.PackageDescription
         ( PackageDescription(buildDepends) )
import Distribution.PackageDescription.Configuration
         ( finalizePackageDescription)
import Distribution.Version
         ( VersionRange(..) )
import Distribution.Compiler
         ( CompilerId )
import Distribution.System
         ( OS, Arch )
import Distribution.Simple.Utils
         ( equating, comparing )
import Distribution.Text
         ( display )

import Data.List
         ( maximumBy, deleteBy )
import Data.Maybe
         ( fromJust )
import Data.Monoid
         ( Monoid(mempty) )
import qualified Data.Set as Set
import Data.Set (Set)
import qualified Data.Graph as Graph

import Debug.Trace (trace)

-- ------------------------------------------------------------
-- * Search state types
-- ------------------------------------------------------------

type Constraints  = Constraints.Constraints
                      InstalledPackage AvailablePackage ExclusionReason
type SelectedPackages = PackageIndex SelectedPackage

-- ------------------------------------------------------------
-- * The search tree type
-- ------------------------------------------------------------

data SearchSpace inherited pkg
   = ChoiceNode inherited [[(pkg, SearchSpace inherited pkg)]]
   | Failure Failure

-- ------------------------------------------------------------
-- * Traverse a search tree
-- ------------------------------------------------------------

explore :: SearchSpace a SelectablePackage
        -> Progress Log Failure a

explore (Failure failure)      = Progress.Fail failure
explore (ChoiceNode result []) = Progress.Done result
explore (ChoiceNode _ (choices@(defaultChoice:_))) =
  case [ choice | [choice] <- choices ] of
    ((pkg, node'):_) -> Progress.Step (Select pkg [])    (explore node')
    []               -> seq pkgs' -- avoid retaining defaultChoice
                      $ Progress.Step (Select pkg pkgs') (explore node')
      where
        (pkg, node') = maximumBy (comparing (packageId . fst)) defaultChoice
        pkgs' = deleteBy (equating packageId) pkg (map fst defaultChoice)

-- ------------------------------------------------------------
-- * Generate a search tree
-- ------------------------------------------------------------

type ConfigurePackage = PackageIndex SelectablePackage
                     -> SelectablePackage
                     -> Either [Dependency] SelectedPackage

searchSpace :: ConfigurePackage
            -> Constraints
            -> SelectedPackages
            -> Set PackageName
            -> SearchSpace (SelectedPackages, Constraints) SelectablePackage
searchSpace configure constraints selected next =
  ChoiceNode (selected, constraints)
    [ [ (pkg, select name pkg)
      | pkg <- PackageIndex.lookupPackageName available name ]
    | name <- Set.elems next ]
  where
    available = Constraints.choices constraints

    select name pkg = case configure available pkg of
      Left missing -> Failure $ ConfigureFailed pkg
                        [ (dep, Constraints.conflicting constraints dep)
                        | dep <- missing ]
      Right pkg' -> case constrainDeps pkg' (packageConstraints pkg') constraints of
        Left failure       -> Failure failure
        Right constraints' -> searchSpace configure constraints'' selected' next'
          where
            selected' = PackageIndex.insert pkg' selected
            next'     = Set.delete name $ foldr Set.insert next new
            new       = [ name'
                        | dep <- packageConstraints pkg'
                        , let (Dependency name' _) = untagDependency dep
                        , null (PackageIndex.lookupPackageName selected' name') ]
            Satisfiable constraints'' = addPackageSelectConstraint (packageId pkg) constraints'

packageConstraints :: SelectedPackage -> [TaggedDependency]
packageConstraints = either installedConstraints availableConstraints
                   . preferAvailable
  where
    preferAvailable (InstalledOnly           pkg) = Left pkg
    preferAvailable (AvailableOnly           pkg) = Right pkg
    preferAvailable (InstalledAndAvailable _ pkg) = Right pkg
    installedConstraints (InstalledPackage      _   deps) =
      [ TaggedDependency InstalledConstraint (thisPackageVersion dep)
      | dep <- deps ]
    availableConstraints (SemiConfiguredPackage _ _ deps) =
      [ TaggedDependency NoInstalledConstraint dep | dep <- deps ]

constrainDeps :: SelectedPackage -> [TaggedDependency] -> Constraints
              -> Either Failure Constraints
constrainDeps _   []         cs = Right cs
constrainDeps pkg (dep:deps) cs =
  case addPackageDependencyConstraint (packageId pkg) dep cs of
    Satisfiable cs' -> constrainDeps pkg deps cs'
    Unsatisfiable   -> impossible
    ConflictsWith conflicts ->
      Left (DependencyConflict pkg dep conflicts)

-- ------------------------------------------------------------
-- * The main algorithm
-- ------------------------------------------------------------

search :: ConfigurePackage
       -> Constraints
       -> Set PackageName
       -> Progress Log Failure (SelectedPackages, Constraints)
search configure constraints =
  explore . searchSpace configure constraints mempty

-- ------------------------------------------------------------
-- * The top level resolver
-- ------------------------------------------------------------

-- | The main exported resolver, with string logging and failure types to fit
-- the standard 'DependencyResolver' interface.
--
topDownResolver :: DependencyResolver a
topDownResolver = (((((mapMessages .).).).).) . topDownResolver'
  where
    mapMessages :: Progress Log Failure a -> Either [Dependency] a
    mapMessages = Progress.foldProgress (trace . showLog)
                                        (error . showFailure)
                                        Right

-- | The native resolver with detailed structured logging and failure types.
--
topDownResolver' :: OS -> Arch -> CompilerId
                 -> PackageIndex InstalledPackageInfo
                 -> PackageIndex AvailablePackage
                 -> [UnresolvedDependency]
                 -> Progress Log Failure [InstallPlan.PlanPackage a]
topDownResolver' os arch comp installed available deps =
    fmap (uncurry finaliseSelectedPackages)
  $ search (configurePackage os arch comp) constraints initialPkgNames

  where
    --TODO add actual constraints using addTopLevelDependencyConstraint
    constraints = Constraints.empty installed' available

    installed' = PackageIndex.fromList
                   [ InstalledPackage pkg (transitiveDepends pkg)
                   | pkg <- PackageIndex.allPackages installed ]   
    transitiveDepends :: InstalledPackageInfo -> [PackageIdentifier]
    transitiveDepends = map toPkgid . tail . Graph.reachable graph
                      . fromJust . toVertex . packageId
    (graph, toPkgid, toVertex) = PackageIndex.dependencyGraph installed

    initialDeps     = [ dep  | UnresolvedDependency dep _ <- deps ]
    initialPkgNames = Set.fromList [ name | Dependency name _ <- initialDeps ]

configurePackage :: OS -> Arch -> CompilerId -> ConfigurePackage
configurePackage os arch comp available spkg = case spkg of
  InstalledOnly         ipkg      -> Right (InstalledOnly ipkg)
  AvailableOnly              apkg -> fmap AvailableOnly (configure apkg)
  InstalledAndAvailable ipkg apkg -> fmap (InstalledAndAvailable ipkg)
                                          (configure apkg)
  where
  configure apkg@(AvailablePackage _ p _) =
    case finalizePackageDescription [] (Just available) os arch comp [] p of
      Left missing        -> Left missing
      Right (pkg, flags) -> Right $
        SemiConfiguredPackage apkg flags (buildDepends pkg)

finaliseSelectedPackages :: SelectedPackages
                         -> Constraints
                         -> [InstallPlan.PlanPackage a]
finaliseSelectedPackages selected constraints =
  map finaliseSelected (PackageIndex.allPackages selected)
  where
    remainingChoices = Constraints.choices constraints
    finaliseSelected (InstalledOnly         ipkg     ) = finaliseInstalled ipkg
    finaliseSelected (AvailableOnly              apkg) = finaliseAvailable apkg
    finaliseSelected (InstalledAndAvailable ipkg apkg) =
      case PackageIndex.lookupPackageId remainingChoices (packageId ipkg) of
        Nothing                          -> impossible --picked package not in constraints
        Just (AvailableOnly _)           -> impossible --to constrain to avail only
        Just (InstalledOnly _)           -> finaliseInstalled ipkg
        Just (InstalledAndAvailable _ _) -> finaliseAvailable apkg
        --TODO: improve the plan by picking installed packages where possible

    finaliseInstalled (InstalledPackage pkg _) = InstallPlan.PreExisting pkg
    finaliseAvailable (SemiConfiguredPackage pkg flags deps) =
      InstallPlan.Configured (ConfiguredPackage pkg flags deps')
      where deps' = [ packageId pkg'
                    | dep <- deps
                    , let pkg' = case PackageIndex.lookupDependency selected dep of
                                   [pkg''] -> pkg''
                                   _ -> impossible ]

-- ------------------------------------------------------------
-- * Adding and recording constraints
-- ------------------------------------------------------------

addPackageSelectConstraint :: PackageIdentifier -> Constraints
                    -> Satisfiable Constraints ExclusionReason
addPackageSelectConstraint pkgid constraints =
  Constraints.constrain dep reason constraints
  where
    dep    = TaggedDependency NoInstalledConstraint (thisPackageVersion pkgid)
    reason = SelectedOther pkgid

thisPackageVersion :: PackageIdentifier -> Dependency
thisPackageVersion (PackageIdentifier n v) = Dependency n (ThisVersion v)

addPackageExcludeConstraint :: PackageIdentifier -> Constraints
                     -> Satisfiable Constraints ExclusionReason
addPackageExcludeConstraint pkgid constraints =
  Constraints.constrain dep reason constraints
  where
    dep    = TaggedDependency NoInstalledConstraint
               (notThisPackageVersion pkgid)
    reason = ExcludedByConfigureFail
    notThisPackageVersion (PackageIdentifier n v) =
      Dependency n (notThisVersion v)
    notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v)

addPackageDependencyConstraint :: PackageIdentifier -> TaggedDependency -> Constraints
                               -> Satisfiable Constraints ExclusionReason
addPackageDependencyConstraint pkgid dep constraints =
  Constraints.constrain dep reason constraints
  where
    reason = ExcludedByPackageDependency pkgid dep

addTopLevelDependencyConstraint :: Dependency -> Constraints
                                -> Satisfiable Constraints ExclusionReason<commit_msg>Use thisPackageVersion and notThisPackageVersion from Distribution.Package rather than the local definitions<commit_after>-----------------------------------------------------------------------------
-- |
-- Module      :  Hackage.Dependency.Types
-- Copyright   :  (c) <NAME> 2008
-- License     :  BSD-like
--
-- Maintainer  :  <EMAIL>
-- Stability   :  provisional
-- Portability :  portable
--
-- Common types for dependency resolution.
-----------------------------------------------------------------------------
module Hackage.Dependency.TopDown (
    topDownResolver
  ) where

import Hackage.Dependency.TopDown.Types
import qualified Hackage.Dependency.TopDown.Constraints as Constraints
import Hackage.Dependency.TopDown.Constraints
         ( Satisfiable(..) )
import qualified Hackage.InstallPlan as InstallPlan
import Hackage.Types
         ( UnresolvedDependency(..), AvailablePackage(..)
         , ConfiguredPackage(..) )
import Hackage.Dependency.Types
         ( DependencyResolver, Progress )
import qualified Hackage.Dependency.Types as Progress
         ( Progress(..), foldProgress )

import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PackageIndex (PackageIndex)
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import Distribution.Package
         ( PackageIdentifier, Package(packageId), packageVersion
         , Dependency(Dependency), thisPackageVersion, notThisPackageVersion )
import Distribution.PackageDescription
         ( PackageDescription(buildDepends) )
import Distribution.PackageDescription.Configuration
         ( finalizePackageDescription)
import Distribution.Compiler
         ( CompilerId )
import Distribution.System
         ( OS, Arch )
import Distribution.Simple.Utils
         ( equating, comparing )
import Distribution.Text
         ( display )

import Data.List
         ( maximumBy, deleteBy )
import Data.Maybe
         ( fromJust )
import Data.Monoid
         ( Monoid(mempty) )
import qualified Data.Set as Set
import Data.Set (Set)
import qualified Data.Graph as Graph

import Debug.Trace (trace)

-- ------------------------------------------------------------
-- * Search state types
-- ------------------------------------------------------------

type Constraints  = Constraints.Constraints
                      InstalledPackage AvailablePackage ExclusionReason
type SelectedPackages = PackageIndex SelectedPackage

-- ------------------------------------------------------------
-- * The search tree type
-- ------------------------------------------------------------

data SearchSpace inherited pkg
   = ChoiceNode inherited [[(pkg, SearchSpace inherited pkg)]]
   | Failure Failure

-- ------------------------------------------------------------
-- * Traverse a search tree
-- ------------------------------------------------------------

explore :: SearchSpace a SelectablePackage
        -> Progress Log Failure a

explore (Failure failure)      = Progress.Fail failure
explore (ChoiceNode result []) = Progress.Done result
explore (ChoiceNode _ (choices@(defaultChoice:_))) =
  case [ choice | [choice] <- choices ] of
    ((pkg, node'):_) -> Progress.Step (Select pkg [])    (explore node')
    []               -> seq pkgs' -- avoid retaining defaultChoice
                      $ Progress.Step (Select pkg pkgs') (explore node')
      where
        (pkg, node') = maximumBy (comparing (packageId . fst)) defaultChoice
        pkgs' = deleteBy (equating packageId) pkg (map fst defaultChoice)

-- ------------------------------------------------------------
-- * Generate a search tree
-- ------------------------------------------------------------

type ConfigurePackage = PackageIndex SelectablePackage
                     -> SelectablePackage
                     -> Either [Dependency] SelectedPackage

searchSpace :: ConfigurePackage
            -> Constraints
            -> SelectedPackages
            -> Set PackageName
            -> SearchSpace (SelectedPackages, Constraints) SelectablePackage
searchSpace configure constraints selected next =
  ChoiceNode (selected, constraints)
    [ [ (pkg, select name pkg)
      | pkg <- PackageIndex.lookupPackageName available name ]
    | name <- Set.elems next ]
  where
    available = Constraints.choices constraints

    select name pkg = case configure available pkg of
      Left missing -> Failure $ ConfigureFailed pkg
                        [ (dep, Constraints.conflicting constraints dep)
                        | dep <- missing ]
      Right pkg' -> case constrainDeps pkg' (packageConstraints pkg') constraints of
        Left failure       -> Failure failure
        Right constraints' -> searchSpace configure constraints'' selected' next'
          where
            selected' = PackageIndex.insert pkg' selected
            next'     = Set.delete name $ foldr Set.insert next new
            new       = [ name'
                        | dep <- packageConstraints pkg'
                        , let (Dependency name' _) = untagDependency dep
                        , null (PackageIndex.lookupPackageName selected' name') ]
            Satisfiable constraints'' = addPackageSelectConstraint (packageId pkg) constraints'

packageConstraints :: SelectedPackage -> [TaggedDependency]
packageConstraints = either installedConstraints availableConstraints
                   . preferAvailable
  where
    preferAvailable (InstalledOnly           pkg) = Left pkg
    preferAvailable (AvailableOnly           pkg) = Right pkg
    preferAvailable (InstalledAndAvailable _ pkg) = Right pkg
    installedConstraints (InstalledPackage      _   deps) =
      [ TaggedDependency InstalledConstraint (thisPackageVersion dep)
      | dep <- deps ]
    availableConstraints (SemiConfiguredPackage _ _ deps) =
      [ TaggedDependency NoInstalledConstraint dep | dep <- deps ]

constrainDeps :: SelectedPackage -> [TaggedDependency] -> Constraints
              -> Either Failure Constraints
constrainDeps _   []         cs = Right cs
constrainDeps pkg (dep:deps) cs =
  case addPackageDependencyConstraint (packageId pkg) dep cs of
    Satisfiable cs' -> constrainDeps pkg deps cs'
    Unsatisfiable   -> impossible
    ConflictsWith conflicts ->
      Left (DependencyConflict pkg dep conflicts)

-- ------------------------------------------------------------
-- * The main algorithm
-- ------------------------------------------------------------

search :: ConfigurePackage
       -> Constraints
       -> Set PackageName
       -> Progress Log Failure (SelectedPackages, Constraints)
search configure constraints =
  explore . searchSpace configure constraints mempty

-- ------------------------------------------------------------
-- * The top level resolver
-- ------------------------------------------------------------

-- | The main exported resolver, with string logging and failure types to fit
-- the standard 'DependencyResolver' interface.
--
topDownResolver :: DependencyResolver a
topDownResolver = (((((mapMessages .).).).).) . topDownResolver'
  where
    mapMessages :: Progress Log Failure a -> Either [Dependency] a
    mapMessages = Progress.foldProgress (trace . showLog)
                                        (error . showFailure)
                                        Right

-- | The native resolver with detailed structured logging and failure types.
--
topDownResolver' :: OS -> Arch -> CompilerId
                 -> PackageIndex InstalledPackageInfo
                 -> PackageIndex AvailablePackage
                 -> [UnresolvedDependency]
                 -> Progress Log Failure [InstallPlan.PlanPackage a]
topDownResolver' os arch comp installed available deps =
    fmap (uncurry finaliseSelectedPackages)
  $ search (configurePackage os arch comp) constraints initialPkgNames

  where
    --TODO add actual constraints using addTopLevelDependencyConstraint
    constraints = Constraints.empty installed' available

    installed' = PackageIndex.fromList
                   [ InstalledPackage pkg (transitiveDepends pkg)
                   | pkg <- PackageIndex.allPackages installed ]   
    transitiveDepends :: InstalledPackageInfo -> [PackageIdentifier]
    transitiveDepends = map toPkgid . tail . Graph.reachable graph
                      . fromJust . toVertex . packageId
    (graph, toPkgid, toVertex) = PackageIndex.dependencyGraph installed

    initialDeps     = [ dep  | UnresolvedDependency dep _ <- deps ]
    initialPkgNames = Set.fromList [ name | Dependency name _ <- initialDeps ]

configurePackage :: OS -> Arch -> CompilerId -> ConfigurePackage
configurePackage os arch comp available spkg = case spkg of
  InstalledOnly         ipkg      -> Right (InstalledOnly ipkg)
  AvailableOnly              apkg -> fmap AvailableOnly (configure apkg)
  InstalledAndAvailable ipkg apkg -> fmap (InstalledAndAvailable ipkg)
                                          (configure apkg)
  where
  configure apkg@(AvailablePackage _ p _) =
    case finalizePackageDescription [] (Just available) os arch comp [] p of
      Left missing        -> Left missing
      Right (pkg, flags) -> Right $
        SemiConfiguredPackage apkg flags (buildDepends pkg)

finaliseSelectedPackages :: SelectedPackages
                         -> Constraints
                         -> [InstallPlan.PlanPackage a]
finaliseSelectedPackages selected constraints =
  map finaliseSelected (PackageIndex.allPackages selected)
  where
    remainingChoices = Constraints.choices constraints
    finaliseSelected (InstalledOnly         ipkg     ) = finaliseInstalled ipkg
    finaliseSelected (AvailableOnly              apkg) = finaliseAvailable apkg
    finaliseSelected (InstalledAndAvailable ipkg apkg) =
      case PackageIndex.lookupPackageId remainingChoices (packageId ipkg) of
        Nothing                          -> impossible --picked package not in constraints
        Just (AvailableOnly _)           -> impossible --to constrain to avail only
        Just (InstalledOnly _)           -> finaliseInstalled ipkg
        Just (InstalledAndAvailable _ _) -> finaliseAvailable apkg
        --TODO: improve the plan by picking installed packages where possible

    finaliseInstalled (InstalledPackage pkg _) = InstallPlan.PreExisting pkg
    finaliseAvailable (SemiConfiguredPackage pkg flags deps) =
      InstallPlan.Configured (ConfiguredPackage pkg flags deps')
      where deps' = [ packageId pkg'
                    | dep <- deps
                    , let pkg' = case PackageIndex.lookupDependency selected dep of
                                   [pkg''] -> pkg''
                                   _ -> impossible ]

-- ------------------------------------------------------------
-- * Adding and recording constraints
-- ------------------------------------------------------------

addPackageSelectConstraint :: PackageIdentifier -> Constraints
                    -> Satisfiable Constraints ExclusionReason
addPackageSelectConstraint pkgid constraints =
  Constraints.constrain dep reason constraints
  where
    dep    = TaggedDependency NoInstalledConstraint (thisPackageVersion pkgid)
    reason = SelectedOther pkgid

addPackageExcludeConstraint :: PackageIdentifier -> Constraints
                     -> Satisfiable Constraints ExclusionReason
addPackageExcludeConstraint pkgid constraints =
  Constraints.constrain dep reason constraints
  where
    dep    = TaggedDependency NoInstalledConstraint
               (notThisPackageVersion pkgid)
    reason = ExcludedByConfigureFail

addPackageDependencyConstraint :: PackageIdentifier -> TaggedDependency -> Constraints
                               -> Satisfiable Constraints ExclusionReason
addPackageDependencyConstraint pkgid dep constraints =
  Constraints.constrain dep reason constraints
  where
    reason = ExcludedByPackageDependency pkgid dep

addTopLevelDependencyConstraint :: Dependency -> Constraints
                                -> Satisfiable Constraints ExclusionReason
{'fraction_non_alphanumeric': 0.14674160089259886, 'fraction_numerical': 0.00033059217323029875, 'mean_word_length': 1.9935675408213755, 'pattern_counts': {'":': 0, '<': 29, '<?xml version=': 0, '>': 120, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 16, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '922519', 'n_tokens_mistral': 5452, 'n_tokens_neox': 5173, 'n_words': 1618}