|
sourcecode:
|
module CPM.Resolution
( ResolutionResult
, showResult, showShortResult, dependenciesAsGraph
, resolutionSuccess
, resolvedPackages
, showDependencies, showShortDependencies
, showConflict
, allTransitiveDependencies
, transitiveDependencies
, resolve
, resolveDependenciesFromLookupSet
, isCompatibleToCompiler
, isDisjunctionCompatible
) where
import Data.Either
import Data.List
import Data.Maybe
import qualified Data.GraphViz as DG
import Test.Prop
import Text.Pretty
import CPM.Config ( Config, defaultConfig, compilerVersion
, compilerBaseVersion )
import CPM.ErrorLogger
import CPM.LookupSet
import CPM.Package
--- Resolves the dependencies of a package using packages from a lookup set,
--- inside an error logger.
resolveDependenciesFromLookupSet :: Config -> Package -> LookupSet
-> ErrorLogger ResolutionResult
resolveDependenciesFromLookupSet cfg pkg lookupSet =
let result = resolve cfg pkg lookupSet
in if resolutionSuccess result
then return result
else fail $ showResult result
--- Resolves the dependencies of a package using packages from a lookup set.
--- The base package of the current compiler is removed from the result set.
resolve :: Config -> Package -> LookupSet -> ResolutionResult
resolve cfg pkg ls = case resolvedPkgs of
Just pkgs -> ResolutionSuccess pkg (deleteBase pkgs)
Nothing -> ResolutionFailure labeledTree
where
labeledTree = labelConflicts cfg $ candidateTree pkg ls
noConflicts = prune ((/= Nothing) . clConflict) labeledTree
resolvedPkgs = maybeHead . map stPackages . filter stComplete . leaves
. mapTree clState $ noConflicts
deleteBase = filter (\p -> name p /= "base" ||
showVersion (version p) /= compilerBaseVersion cfg)
--- Gives a list of all activated packages for a successful resolution.
resolvedPackages :: ResolutionResult -> [Package]
resolvedPackages (ResolutionSuccess pkg deps) = delete pkg deps
resolvedPackages (ResolutionFailure _) = error "resolvedPackages called on failure"
--- Tries to get a list of activated packages for a resolution. Returns Nothing
--- if the resolution was not successful.
maybeResolvedPackages :: ResolutionResult -> Maybe [Package]
maybeResolvedPackages (ResolutionSuccess _ deps) = Just deps
maybeResolvedPackages (ResolutionFailure _) = Nothing
--- Was a resolution successful?
resolutionSuccess :: ResolutionResult -> Bool
resolutionSuccess (ResolutionSuccess _ _) = True
resolutionSuccess (ResolutionFailure _) = False
--- Renders a dependency tree from a successful resolution.
showDependencies :: ResolutionResult -> String
showDependencies (ResolutionSuccess pkg deps) =
showTree . mapTree (text . packageId) $ dependencyTree deps pkg
showDependencies (ResolutionFailure _) = "Resolution failed."
--- Renders a dependency tree from a successful resolution in a short form
--- where already shown packages are not fully shown again.
showShortDependencies :: ResolutionResult -> String
showShortDependencies (ResolutionSuccess pkg deps) =
showTree . mapTree text . shortenPackageTree $ dependencyTree deps pkg
showShortDependencies (ResolutionFailure _) = "Resolution failed."
-- Reduces a package tree so that duplicated nodes are removed.
-- The resulting tree contains the `packageId`s of the packages.
shortenPackageTree :: Tree Package -> Tree String
shortenPackageTree = fst . shortenPT []
where
shortenPT pids (Node p ps) = let pid = packageId p in
if pid `elem` pids then (Node (pid ++ "...") [], pids)
else let (pts, pids') = shortenPTs (pid:pids) ps
in (Node pid pts, pids')
shortenPTs pids [] = ([],pids)
shortenPTs pids (p:ps) = let (pt, pids1) = shortenPT pids p
(pts,pids2) = shortenPTs pids1 ps
in (pt:pts, pids2)
--- Renders a conflict resolution into a textual representation.
showConflict :: ResolutionResult -> String
showConflict (ResolutionSuccess _ _) = "Resolution succeeded."
showConflict (ResolutionFailure t) = case findRelevantConflict t of
Just c -> showConflictState c
Nothing -> case missingPackages $ clState $ findDeepestNode t of
[] -> "Conflict resolution failed for an unknown reason... Hint:(\n" ++
"Please clean your package ('cypm clean') and/or\n" ++
"your package index ('cypm update') and try again..."
(d@(Dependency p _):_) ->
"There seems to be no version of package " ++ p ++
" that can satisfy the constraint " ++ showDependency d
showConflictTree :: ResolutionResult -> String
showConflictTree (ResolutionSuccess _ _) = "Resolution succeeded."
showConflictTree (ResolutionFailure t) =
showTree $ mapTree labeler $ cutBelowConflict t
where
pkgId = text . packageId . actPackage
actChain a@(InitialA _) = pkgId a
actChain a@(ChildA _ _ p) = pkgId a <+> text "->" <+> actChain p
labeler ((a, _), Nothing) = pkgId a
labeler ((a, _), Just (CompilerConflict _)) = red $ text "C" <+> actChain a
labeler ((a, _), Just (PrimaryConflict _)) = red $ text "P" <+> actChain a
labeler ((a, _), Just (SecondaryConflict a' a'')) =
red $ text "S" <+> actChain a <+> parens (pkgId a') <+> parens (pkgId a'')
cutBelowConflict (Node (a, Nothing) cs) = Node (a, Nothing) $ map cutBelowConflict cs
cutBelowConflict (Node (a, Just c) _) = Node (a, Just c) []
showCandidateTree :: Tree State -> String
showCandidateTree = showTree . mapTree (text . packageId . actPackage . stActivation)
showLabelTree :: Config -> Tree State -> String
showLabelTree cfg =
showTree . mapTree labeler . cutBelowConflict . labelConflicts cfg
where
pkgId = text . packageId . actPackage . stActivation
actId = text . packageId . actPackage
labeler (s, Nothing) = pkgId s
labeler (s, Just (CompilerConflict _)) = red $ text "C" <+> pkgId s
labeler (s, Just (PrimaryConflict _)) = red $ text "P" <+> pkgId s
labeler (s, Just (SecondaryConflict a1 a2)) = red $
text "S" <+> pkgId s <+> actId a1 <+> actId a2
cutBelowConflict (Node (a, Nothing) cs) =
Node (a, Nothing) $ map cutBelowConflict cs
cutBelowConflict (Node (a, Just c) _) = Node (a, Just c) []
resultConflict :: ResolutionResult -> Maybe Conflict
resultConflict (ResolutionSuccess _ _) = Nothing
resultConflict (ResolutionFailure t) = case findRelevantConflict t of
Nothing -> Nothing
Just cs -> clConflict cs
--- Renders a resolution result into a textual representation for the user.
--- In case of success, the dependency tree is shown. In case of failure,
--- information on the cause of the conflict is shown.
showResult :: ResolutionResult -> String
showResult r@(ResolutionSuccess _ _) = showDependencies r
showResult r@(ResolutionFailure _) = showConflict r
--- Renders a resolution result into a short textual representation
--- (where already shown packages are not shown again) for the user.
--- In case of success, the shortened dependency tree is shown.
--- In case of failure, information on the cause of the conflict is shown.
showShortResult :: ResolutionResult -> String
showShortResult r@(ResolutionSuccess _ _) = showShortDependencies r
showShortResult r@(ResolutionFailure _) = showConflict r
--- Result of a resolution run. In case of success, it contains the original
--- package as well as a list of resolved packages. If the resolution failed, it
--- contains the conflict tree.
data ResolutionResult = ResolutionSuccess Package [Package]
| ResolutionFailure (Tree ConflictState)
deriving (Eq,Show)
--- Shows a successful resolution as a (Graphviz) dot graph.
dependenciesAsGraph :: ResolutionResult -> Maybe DG.DotGraph
dependenciesAsGraph (ResolutionFailure _) = Nothing
dependenciesAsGraph (ResolutionSuccess pkg deppkgs) =
let allpkgs = pkg : deppkgs
alldepnames = map (\p -> (name p, map (\ (Dependency p' _) -> p')
(dependencies p)))
allpkgs
showPkg pn = maybe pn packageId (find ((== pn) . name) allpkgs)
deps = map (\ (p,dp) -> (showPkg p, map showPkg dp)) alldepnames
in Just $ DG.dgraph ("Dependencies of " ++ name pkg)
(map (\s -> DG.Node s [])
(nub (map fst deps ++ concatMap snd deps)))
(map (\ (s,t) -> DG.Edge s t [])
(nub (concatMap (\ (p,ds) -> map (\d -> (p,d)) ds) deps)))
--- Represents an activation of a package in the candidate tree. Activations
--- form a chain up to the initial activation, i.e. the initial package that
--- resolution was started on. Each activation's parent is the activation of the
--- package that led to the current activation, i.e. the package whose
--- dependency led to the current package version being chosen.
data Activation = InitialA Package
| ChildA Package Dependency Activation
deriving (Eq,Show)
--- Each tree node is labeled with the current activation and all former
--- activations.
type State = (Activation, [Activation])
--- A conflict occurs when one of the active packages in a state clashes with
--- one of dependencies of all of the state's active packages. If the clash
--- occurs between a package A and a dependency of a package B and B is also the
--- package that activated A, i.e. the parent of its activation, we call the
--- conflict a 'same package' conflict. A 'real' conflict is a one where package
--- A was activated by some earlier package. When the compiler compatibility
--- constraints of the package activated in the current state are not met, then
--- we use the compiler conflict.
data Conflict = SecondaryConflict Activation Activation
| PrimaryConflict Activation
| CompilerConflict Activation
deriving (Eq,Show)
--- A state and a potential conflict.
type ConflictState = (State, Maybe Conflict)
--- Gets the package that was activated in a state.
stPackage :: State -> Package
stPackage (a, _) = actPackage a
--- Gets all active packages in a state.
stPackages :: State -> [Package]
stPackages (_, as) = map actPackage as
--- Gets the state's current activation
stActivation :: State -> Activation
stActivation = fst
--- Gets all activations leading up to the state, including the current
--- activation.
stActivations :: State -> [Activation]
stActivations = snd
--- Gets a list of all dependencies of all active packages in a state, alongside
--- the activations that activated the respective packages.
stDependencies :: State -> [(Activation, Dependency)]
stDependencies = concatMap zippedDeps . stActivations
where
zippedDeps a = zip (repeat a) $ dependencies $ actPackage a
--- Gets a list of all dependencies of all active packages in a state.
stAllDependencies :: State -> [Dependency]
stAllDependencies = concatMap dependencies . stPackages
--- Gets an activation's package.
actPackage :: Activation -> Package
actPackage (InitialA p) = p
actPackage (ChildA p _ _) = p
actDependency :: Activation -> Dependency
actDependency (InitialA _) = error "Called on initialA"
actDependency (ChildA _ d _) = d
actParent :: Activation -> Activation
actParent a@(InitialA _) = a
actParent (ChildA _ _ p) = p
--- Gets a potential conflict from a conflict state.
clConflict :: ConflictState -> Maybe Conflict
clConflict = snd
--- Gets the original state from a conflict state.
clState :: ConflictState -> State
clState = fst
--- A tree with a label and child nodes.
data Tree a = Node a [Tree a]
deriving (Eq,Show)
--- Recursively applies a function to each node in a tree.
mapTree :: (a -> b) -> Tree a -> Tree b
mapTree f (Node a cs) = Node (f a) $ map (mapTree f) cs
--- A node's label.
label :: Tree a -> a
label (Node a _) = a
leaves :: Tree a -> [a]
leaves (Node a []) = [a]
leaves (Node _ cs@(_:_)) = concatMap leaves cs
--- Folds a tree to a value.
foldTree :: (a -> [b] -> b) -> Tree a -> b
foldTree f (Node a cs) = f a (map (foldTree f) cs)
--- Filters a tree using a predicate.
filterTree :: (a -> Bool) -> Tree a -> Tree a
filterTree p = foldTree f
where f a cs = Node a (filter (p . label) cs)
--- Removes all nodes from a tree that match the predicate.
prune :: (a -> Bool) -> Tree a -> Tree a
prune p = filterTree (not . p)
--- Shows a textual representation of a tree.
showTree :: Tree Doc -> String
showTree t = "Package dependencies:\n" ++ pPrint (ppTree t)
--- Pretty prints a tree of Docs into a single Doc.
ppTree :: Tree Doc -> Doc
ppTree (Node l cs) = l <$$> vcat children
where
children = map (\t -> indent 2 $ text "|-" <+> ppTree t) cs
--- Extends a tree by appending a node to the first leaf in order, i.e. the
--- leftmost leaf.
extendTree :: Tree a -> Tree a -> Tree a
extendTree (Node a []) n = Node a [n]
extendTree (Node a (c:cs)) n = Node a $ (extendTree c n):cs
--- Converts a tree of strings into the Graphviz dot format.
dotifyTree :: Tree String -> String
dotifyTree t = "digraph tree {\n" ++ full ++ "\n}"
where
(_, _, full) = dotify' (0, [], "") t
dotify' (n, acc, s) (Node l cs) =
let
(n', children, str) = foldl (dotify') (n + 1, [], "") cs
in
(n', n:acc, s ++ intercalate "\n" ([node n l] ++ map (edge n) children) ++ str)
node n l = "n" ++ (show n) ++ " [label=\"" ++ l ++ "\"];\n"
edge a b = "n" ++ (show a) ++ " -> " ++ "n" ++ (show b) ++ ";\n"
--- Builds a tree of candidate states from a package and a lookup set. This is
--- the tree that is searched for complete states or conflicts.
candidateTree :: Package -> LookupSet -> Tree State
candidateTree pkg ls = let s = InitialA pkg in
Node (s, [s]) $ tree' [s] (zip (repeat s) (dependencies pkg))
where
tree' acts ((act, d@(Dependency p _)):ds) =
if p `elem` (map (name . actPackage) acts)
then tree' acts ds
else map (nodesForDep act d ds acts) $ findAllVersions ls p True
tree' _ [] = []
nodesForDep act d ds acts p' =
let
act' = ChildA p' d act
acts' = act':acts
nextDeps = zip (repeat act') (dependencies p') ++ ds
in Node (act', acts') $ tree' acts' nextDeps
--- Calculates the first conflict for each node in the tree and annotates the
--- nodes with these conflicts.
labelConflicts :: Config -> Tree State -> Tree ConflictState
labelConflicts cfg = mapTree f
where
f s = (s, firstConflict cfg s (reverse $ stDependencies s))
--- Checks whether a state is complete, i.e. whether all packages mentioned in
--- all dependencies of all active packages are present in the list of active
--- packages. Note that stComplete does not check whether a dependency is
--- actually met by a package, only whether the package is present. stComplete
--- is meant to be called on a state that has already been checked for
--- conflicts.
stComplete :: State -> Bool
stComplete s = missingPackages s == []
stCompleteness :: State -> Int
stCompleteness s = length $ missingPackages s
--- Finds all dependencies in a state which is unmet because its dependency is
--- missing altogether, i.e. no version of the package is activated.
missingPackages :: State -> [Dependency]
missingPackages s = missing' (stPackages s) (stAllDependencies s)
where
missing' pkgs ds = filter (noPackage pkgs) ds
noPackage pkgs (Dependency p _) = find ((== p) . name) pkgs == Nothing
--- Calculates the first conflict in a state.
firstConflict :: Config -> State -> [(Activation, Dependency)] -> Maybe Conflict
firstConflict _ _ [] = Nothing
firstConflict cfg s@(act, acts) ((depAct, Dependency p disj):ds) =
if not $ isCompatibleToCompiler cfg (actPackage act)
then Just $ CompilerConflict act
else case findPkg of
Nothing -> firstConflict cfg s ds
Just a -> if isDisjunctionCompatible (version $ actPackage a) disj
then firstConflict cfg s ds
else if actParent a == depAct
then Just $ PrimaryConflict a
else Just $ SecondaryConflict a depAct
where
findPkg = find ((== p) . name . actPackage) acts
--- Finds the deepest right-most node in a tree.
findDeepestNode :: Tree a -> a
findDeepestNode = snd . maxNode . leaves . depthTree
where
maxNode ls = foldl maxN (head ls) ls
maxN (na, a) (nb, b) = if nb >= na
then (nb, b)
else (na, a)
depthTree = relabel 0
relabel n (Node a cs) = Node (n, a) (map (relabel (n + 1)) cs)
findRelevantConflict :: Tree ConflictState -> Maybe ConflictState
findRelevantConflict = maybeMostRelevant . map mostRelevant . map snd . minGroups . filter ((/= []) . snd) . findGroups . cutBelowConflict . relabel
where
maybeMostRelevant [] = Nothing
maybeMostRelevant cs@(_:_) = Just $ mostRelevant cs
mostRelevant cs = case find (isSecondary . fromJust . clConflict) cs of
Just s -> s
Nothing -> case find (isCompiler . fromJust . clConflict) cs of
Just c -> c
Nothing -> head cs
minGroups gs = let minG = foldl (\m g -> min m (fst g)) 99999 gs in
filter ((== minG) . fst) gs
isSecondary (SecondaryConflict _ _) = True
isSecondary (PrimaryConflict _) = False
isSecondary (CompilerConflict _) = False
isCompiler (SecondaryConflict _ _) = False
isCompiler (PrimaryConflict _) = False
isCompiler (CompilerConflict _) = True
findGroups (Node (d, (_, Nothing)) []) = [(d, [])]
findGroups (Node (d, (_, Nothing)) cs@(_:_)) = if containsOnlyConflicts cs
then [(d, map (snd . label) cs)]
else concatMap findGroups cs
findGroups (Node (d, (_, Just _)) _) = [(d, [])]
containsOnlyConflicts = all (isJust . clConflict . snd) . map label
cutBelowConflict (Node (d, (a, Nothing)) cs) = Node (d, (a, Nothing)) $ map cutBelowConflict cs
cutBelowConflict (Node (d, (a, Just c)) _) = Node (d, (a, Just c)) []
relabel = mapTree (\a -> (stCompleteness $ clState a, a))
--- Renders the information from a real conflict into a textual representation
--- for the user.
---
--- @param originalAct - the original activation of the package
--- @param confDep - the dependency conflicting the original activation
--- @param confAct - the activation of the conflict dependency
showRealConflictInfo :: Activation -> Activation -> String
showRealConflictInfo originalAct confAct =
let
mkLabel pkg dep = (text $ name pkg) <+> (parens $ text $ showDependency dep)
triedPkg = actPackage originalAct
actLabeler (InitialA p) = text $ name p
actLabeler (ChildA p dep _) = mkLabel p dep
originalTree = mapTree actLabeler $ activationTree originalAct
confTree = mapTree actLabeler $ activationTree confAct
confDepLabel = mkLabel triedPkg (findDependencyOn triedPkg confAct)
confTree' = extendTree confTree (Node confDepLabel [])
findDependencyOn pkg act = case find ((== name pkg) . depPkg) $ dependencies $ actPackage act of
Just a -> a
Nothing -> error "Hey!"
depPkg (Dependency p _) = p
in
pPrint $ (text $ "There was a conflict for package " ++ name triedPkg)
<$$> ppTree originalTree <$$> ppTree confTree'
showSamePackageConflictInfo :: Activation -> String
showSamePackageConflictInfo act =
let
triedPkg = actPackage act
in
"There seems to be no version of package " ++ name triedPkg ++ " that can satisfy the constraint " ++ showDependency (actDependency act)
showCompilerConflictInfo :: Activation -> String
showCompilerConflictInfo act =
"The package " ++ (packageId $ actPackage act) ++ ", dependency constraint " ++ showDependency (actDependency act) ++ ", is not compatible to the current compiler. It was activated because:\n" ++ showTree actTree
where
mkLabel pkg dep = (text $ name pkg) <+> (parens $ text $ showDependency dep)
actLabeler (InitialA p) = text $ name p
actLabeler (ChildA p dep _) = mkLabel p dep
actTree = mapTree actLabeler $ activationTree act
--- Renders a conflict state into a textual representation for the user.
showConflictState :: ConflictState -> String
showConflictState ((InitialA _, _), Nothing) = "No Conflict!"
showConflictState ((InitialA pkg, _), Just _) = "Initial Conflict! " ++ packageId pkg
showConflictState ((ChildA _ _ _, _), Nothing) = "No Conflict!"
showConflictState ((ChildA _ _ _, _), Just (PrimaryConflict originalAct)) =
showSamePackageConflictInfo originalAct
showConflictState ((ChildA _ _ _, _), Just (SecondaryConflict originalAct confAct)) =
showRealConflictInfo originalAct confAct
showConflictState ((ChildA _ _ _, _), Just (CompilerConflict act)) =
showCompilerConflictInfo act
--- Turns an activation into a tree, with the initial activation as its root.
--- Note that this tree will be a singly linked list, i.e. each node will have
--- at most one child.
activationTree :: Activation -> Tree Activation
activationTree = head . foldl (\acc f -> f acc) [] . actTree'
where
actTree' x@(InitialA _) = [\cs -> [Node x cs]]
actTree' x@(ChildA _ _ parent) = (\cs -> [Node x cs]):(actTree' parent)
--- Turns a list of activated packages and an original package into a dependency
--- tree.
dependencyTree :: [Package] -> Package -> Tree Package
dependencyTree chosen pkg = Node pkg $ map (dependencyTree chosen) childPkgs
where
justs = map fromJust . filter (/= Nothing)
childPkgs = justs $ map findPkg (dependencies pkg)
findPkg (Dependency p _) = find ((== p) . name) chosen
maybeHead :: [a] -> Maybe a
maybeHead [] = Nothing
maybeHead (x:_) = Just x
packageSource :: Package -> LookupSet -> Maybe LookupSource
packageSource p ls = lookupSource ls p
allTransitiveDependencies' :: [String] -> LookupSet -> String -> [String]
allTransitiveDependencies' seen ls pkg = nub $ allDeps
where
allVersions = findAllVersions ls pkg True
allDeps = foldl (\s d -> transitiveDependencies' s ls d) seen allVersions
allTransitiveDependencies :: LookupSet -> String -> [String]
allTransitiveDependencies = allTransitiveDependencies' []
transitiveDependencies' :: [String] -> LookupSet -> Package -> [String]
transitiveDependencies' seen ls pkg =
foldl (\s d -> if d `elem` s
then s
else nub (s ++ allTransitiveDependencies' (d:s) ls d))
seen
deps
where
deps = map dependencyName $ dependencies pkg
dependencyName (Dependency n _) = n
transitiveDependencies :: LookupSet -> Package -> [String]
transitiveDependencies = transitiveDependencies' []
test_transitiveDependencies_simpleCase :: Prop
test_transitiveDependencies_simpleCase =
transitiveDependencies db pkg -=- ["B", "C"]
where
pkg = cPackage "A" (0, 0, 1, Nothing)
[cDep "B" ">= 1.0.0", cDep "C" "= 1.2.0"]
b = cPackage "B" (1, 0, 9, Nothing) []
c = cPackage "C" (1, 2, 0, Nothing) []
db = cDB [b, c]
test_transitiveDependencies_loop :: Prop
test_transitiveDependencies_loop = transitiveDependencies db pkg -=- ["B", "C"]
where pkg = cPackage "A" (0, 0, 1, Nothing) [cDep "B" ">= 1.0.0", cDep "C" "= 1.2.0"]
b = cPackage "B" (1, 0, 0, Nothing) [cDep "C" "= 1.2.0"]
c = cPackage "C" (1, 2, 0, Nothing) [cDep "B" ">= 1.0.0"]
db = cDB [b, c]
test_transitiveDependencies_multipleVersions :: Prop
test_transitiveDependencies_multipleVersions = transitiveDependencies db pkg -=- ["B", "D", "C"]
where pkg = cPackage "A" (0, 0, 1, Nothing) [cDep "B" ">= 1.0.0"]
b100 = cPackage "B" (1, 0, 0, Nothing) [cDep "C" "= 1.0.0"]
b110 = cPackage "B" (1, 1, 0, Nothing) [cDep "D" "= 1.0.0"]
c = cPackage "C" (1, 0, 0, Nothing) []
d = cPackage "D" (1, 0, 0, Nothing) []
db = cDB [b100, b110, c, d]
-- Is the package compatible to the compiler used by CPM?
isCompatibleToCompiler :: Config -> Package -> Bool
isCompatibleToCompiler cfg p = case compats of
[] -> -- No compiler constraints => check base compatibility
isCompilerCompatibleBase cfg p
(_:_) -> case constraintForCompiler of
Nothing -> False -- No constraints for current compiler
-- => compiler is incompatible
Just (CompilerCompatibility _ c) ->
isDisjunctionCompatible (maj, min, revi, Nothing) c &&
isCompilerCompatibleBase cfg p
where
(name, maj, min, revi) = compilerVersion cfg
compats = compilerCompatibility p
constraintForCompiler = find (\(CompilerCompatibility c _) -> c == name)
compats
-- Is the package compatible to the base version of the compiler used by CPM?
isCompilerCompatibleBase :: Config -> Package -> Bool
isCompilerCompatibleBase cfg p =
all (\ (Dependency _ c) -> isDisjunctionCompatible baseversion c)
basedependencies
where
baseversion = maybe (0,0,0,Nothing) id
(readVersion (compilerBaseVersion cfg))
basedependencies = filter (\ (Dependency dp _) -> dp == "base")
(dependencies p)
isDisjunctionCompatible :: Version -> Disjunction -> Bool
isDisjunctionCompatible ver cs = any id (map (all id) rs)
where
rs = map (map isCompatible) cs
preReleaseCompatible (_, _, _, p1) (_, _, _, p2)
= (isJust p1 && isJust p2) || (isNothing p1 && isNothing p2)
isCompatible (VExact v) = v == ver
isCompatible (VLt v) = ver `vlt` v && preReleaseCompatible ver v
isCompatible (VLte v) = ver `vlte` v && preReleaseCompatible ver v
isCompatible (VGt v) = ver `vgt` v && preReleaseCompatible ver v
isCompatible (VGte v) = ver `vgte` v && preReleaseCompatible ver v
isCompatible (VMinCompatible v) = ver `vgte` v && ver `vlt` (nextMinor v) &&
preReleaseCompatible ver v
isCompatible (VMajCompatible v) = ver `vgte` v && ver `vlt` (nextMajor v) &&
preReleaseCompatible ver v
test_onlyConjunctionCompatible :: Prop
test_onlyConjunctionCompatible = isDisjunctionCompatible ver dis -=- True
where dis = cDisj "= 1.0.0"
ver = (1, 0, 0, Nothing)
test_allConjunctionsCompatible :: Prop
test_allConjunctionsCompatible = isDisjunctionCompatible ver dis -=- True
where dis = cDisj ">= 1.0.0 || = 1.2.0"
ver = (1, 2, 0, Nothing)
test_oneConjunctionCompatible :: Prop
test_oneConjunctionCompatible = isDisjunctionCompatible ver dis -=- True
where ver = (1, 0, 0, Nothing)
dis = cDisj "> 2.0.0 || = 1.0.0"
test_conjunctionWithMultipleParts :: Prop
test_conjunctionWithMultipleParts = isDisjunctionCompatible ver dis -=- True
where ver = (1, 0, 0, Nothing)
dis = cDisj ">= 1.0.0, < 2.0.0"
test_reportsSimpleFailure :: Prop
test_reportsSimpleFailure = isDisjunctionCompatible ver dis -=- False
where ver = (1, 0, 0, Nothing)
dis = cDisj "> 1.0.0"
test_reportsAllConjunctionsAsFailure :: Prop
test_reportsAllConjunctionsAsFailure = isDisjunctionCompatible ver dis -=- False
where ver = (1, 0, 0, Nothing)
dis = cDisj "< 1.0.0 || > 1.0.0"
test_reportsRelevantPartOfConjunction :: Prop
test_reportsRelevantPartOfConjunction = isDisjunctionCompatible ver dis -=- False
where ver = (1, 0, 0, Nothing)
dis = cDisj "< 1.0.0, > 0.5.0"
test_semverCompatible :: Prop
test_semverCompatible = isDisjunctionCompatible ver dis -=- True
where ver = (0, 5, 9, Nothing)
dis = cDisj "~> 0.5.0"
test_semverIncompatible :: Prop
test_semverIncompatible = isDisjunctionCompatible ver dis -=- False
where ver = (0, 7, 1, Nothing)
dis = cDisj "~> 0.6.0"
test_semverMinimum :: Prop
test_semverMinimum = isDisjunctionCompatible ver dis -=- False
where ver = (0, 7, 0, Nothing)
dis = cDisj "~> 0.7.2"
test_resolvesSimpleDependency :: Prop
test_resolvesSimpleDependency =
maybeResolvedPackages (resolve defaultConfig pkg db) -=- Just [json100, pkg]
where pkg = cPackage "sample" (0, 0, 1, Nothing) [cDep "json" "=1.0.0"]
json100 = cPackage "json" (1, 0, 0, Nothing) []
json101 = cPackage "json" (1, 0, 1, Nothing) []
db = cDB [json100, json101]
test_reportsUnknownPackage :: Prop
test_reportsUnknownPackage =
showResult result -=- "There seems to be no version of package json that can satisfy the constraint json = 1.0.0"
where result = resolve defaultConfig pkg db
pkg = cPackage "sample" (0, 0, 1, Nothing) [cDep "json" "= 1.0.0"]
db = cDB [pkg]
test_reportsMissingPackageVersion :: Prop
test_reportsMissingPackageVersion =
showResult result -=- "There seems to be no version of package json that can satisfy the constraint json = 1.2.0"
where result = resolve defaultConfig pkg db
pkg = cPackage "sample" (0, 0, 1, Nothing) [cDep "json" "=1.2.0"]
json = cPackage "json" (1, 0, 0, Nothing) []
db = cDB [json]
test_reportsSecondaryConflict :: Prop
test_reportsSecondaryConflict = showResult result -=- expectedMessage
where result = resolve defaultConfig pkg db
pkg = cPackage "sample" (0, 0, 1, Nothing)
[cDep "json" "= 1.0.0", cDep "b" ">= 0.0.1"]
b = cPackage "b" (0, 0, 2, Nothing) [cDep "json" "~> 1.0.4"]
json100 = cPackage "json" (1, 0, 0, Nothing) []
json105 = cPackage "json" (1, 0, 5, Nothing) []
db = cDB [pkg, b, json100, json105]
expectedMessage = "There was a conflict for package json\n"
++ "sample\n"
++ " |- json (json = 1.0.0)\n"
++ "sample\n"
++ " |- b (b >= 0.0.1)\n"
++ " |- json (json ~1.0.4)"
test_reportsSecondaryConflictInsteadOfPrimary :: Prop
test_reportsSecondaryConflictInsteadOfPrimary =
showResult result -=- expectedMessage
where result = resolve defaultConfig pkg db
pkg = cPackage "sample" (0, 0, 1, Nothing)
[cDep "json" "= 1.0.0", cDep "b" ">= 0.0.5"]
b001 = cPackage "b" (0, 0, 1, Nothing) []
b002 = cPackage "b" (0, 0, 2, Nothing) []
b003 = cPackage "b" (0, 0, 3, Nothing) []
b006 = cPackage "b" (0, 0, 6, Nothing) [cDep "json" "~> 1.0.4"]
json100 = cPackage "json" (1, 0, 0, Nothing) []
json105 = cPackage "json" (1, 0, 5, Nothing) []
db = cDB [pkg, b001, b002, b003, b006, json100, json105]
expectedMessage = "There was a conflict for package json\n"
++ "sample\n"
++ " |- json (json = 1.0.0)\n"
++ "sample\n"
++ " |- b (b >= 0.0.5)\n"
++ " |- json (json ~1.0.4)"
test_detectsSecondaryOnFirstActivation :: Prop
test_detectsSecondaryOnFirstActivation =
showResult result -=- expectedMessage
where result = resolve defaultConfig pkg db
pkg = cPackage "sample" (0, 0, 1, Nothing)
[cDep "a" "= 0.0.1", cDep "b" "> 0.0.1"]
a001 = cPackage "a" (0, 0, 1, Nothing) [cDep "b" "= 0.0.1"]
b001 = cPackage "b" (0, 0, 1, Nothing) []
b002 = cPackage "b" (0, 0, 2, Nothing) []
db = cDB [pkg, a001, b001, b002]
expectedMessage = "There was a conflict for package b\n"
++ "sample\n"
++ " |- a (a = 0.0.1)\n"
++ " |- b (b = 0.0.1)\n"
++ "sample\n"
++ " |- b (b > 0.0.1)"
test_makesDecisionBetweenAlternatives :: Prop
test_makesDecisionBetweenAlternatives =
maybeResolvedPackages (resolve defaultConfig pkg db) -=- Just [json150, pkg]
where pkg = cPackage "sample" (0, 0, 1, Nothing) [cDep "json" "> 1.0.0, < 2.0.0 || >= 4.0.0"]
json150 = cPackage "json" (1, 5, 0, Nothing) []
json320 = cPackage "json" (3, 2, 0, Nothing) []
db = cDB [json150, json320]
test_alwaysChoosesNewestAlternative :: Prop
test_alwaysChoosesNewestAlternative =
maybeResolvedPackages (resolve defaultConfig pkg db) -=- Just [json420, pkg]
where pkg = cPackage "sample" (0, 0, 1, Nothing) [cDep "json" "> 1.0.0, < 2.0.0 || >= 4.0.0"]
json150 = cPackage "json" (1, 5, 0, Nothing) []
json420 = cPackage "json" (4, 2, 0, Nothing) []
db = cDB [json150, json420]
test_doesNotChoosePrereleaseByDefault :: Prop
test_doesNotChoosePrereleaseByDefault =
maybeResolvedPackages (resolve defaultConfig pkg db) -=- Just [b109, pkg]
where pkg = cPackage "A" (0, 0, 1, Nothing) [cDep "B" ">= 1.0.0"]
b109 = cPackage "B" (1, 0, 9, Nothing) []
b110b1 = cPackage "B" (1, 1, 0, Just "b1") []
db = cDB [b109, b110b1]
test_upgradesPackageToPrereleaseWhenNeccesary :: Prop
test_upgradesPackageToPrereleaseWhenNeccesary =
maybeResolvedPackages (resolve defaultConfig pkg db) -=- Just [b110b1, c, pkg]
where pkg = cPackage "A" (0, 0, 1, Nothing) [cDep "C" "= 1.2.0"]
b109 = cPackage "B" (1, 0, 9, Nothing) []
b110b1 = cPackage "B" (1, 1, 0, Just "b1") []
c = cPackage "C" (1, 2, 0, Nothing) [cDep "B" ">= 1.1.0-b1"]
db = cDB [b109, b110b1, c]
test_prefersLocalPackageCacheEvenIfOlder :: Prop
test_prefersLocalPackageCacheEvenIfOlder =
maybeResolvedPackages (resolve defaultConfig pkg db) -=- Just [b101, pkg]
where pkg = cPackage "A" (0, 0, 1, Nothing) [cDep "B" ">= 1.0.0"]
b101 = cPackage "B" (1, 0, 1, Nothing) []
b105 = cPackage "B" (1, 0, 5, Nothing) []
db = addPackage (addPackage emptySet b101 FromLocalCache) b105 FromRepository
test_reportsCompilerIncompatibility :: Prop
test_reportsCompilerIncompatibility = showResult result -=- "The package json-1.0.0, dependency constraint json = 1.0.0, is not compatible to the current compiler. It was activated because:\nPackage dependencies:\nsample\n |- json (json = 1.0.0)"
where result = resolve defaultConfig pkg db
pkg = cPackage "sample" (0, 0, 1, Nothing) [cDep "json" "= 1.0.0"]
json = cPackageCC "json" (1, 0, 0, Nothing) [cCC "nocompiler" "= 1.0.0"]
db = cDB [json]
cPackage :: String -> Version -> [Dependency] -> Package
cPackage p v ds = emptyPackage {
name = p
, version = v
, author = ["author"]
, synopsis = "JSON library for Curry"
, dependencies = ds
, maintainer = []
, description = Nothing
, license = Nothing
, licenseFile = Nothing
, copyright = Nothing
, homepage = Nothing
, bugReports = Nothing
, repository = Nothing
, compilerCompatibility = []
, source = Nothing
, exportedModules = []
}
cPackageCC :: String -> Version -> [CompilerCompatibility] -> Package
cPackageCC p v cs = emptyPackage {
name = p
, version = v
, author = ["author"]
, synopsis = "JSON library for Curry"
, dependencies = []
, maintainer = []
, description = Nothing
, license = Nothing
, licenseFile = Nothing
, copyright = Nothing
, homepage = Nothing
, bugReports = Nothing
, repository = Nothing
, compilerCompatibility = cs
, source = Nothing
, exportedModules = []
}
cDisj :: String -> Disjunction
cDisj = fromJust . readVersionConstraints
cDep :: String -> String -> Dependency
cDep p c = Dependency p (fromJust $ readVersionConstraints c)
cCC :: String -> String -> CompilerCompatibility
cCC p c = CompilerCompatibility p (fromJust $ readVersionConstraints c)
cDB :: [Package] -> LookupSet
cDB ps = addPackages emptySet ps FromRepository
|