diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TupleSections #-} + module Main where import Control.Arrow @@ -7,22 +9,22 @@ import qualified Data.Set as S free :: Dependency -free = Dependency "free" mempty mempty defV +free = Dependency "free" mempty defV comonad :: Dependency -comonad = Dependency "comonad" mempty mempty defV +comonad = Dependency "comonad" mempty defV lens :: Dependency -lens = Dependency "lens" mempty ["free", "comonad"] defV +lens = Dependency "lens" ((,mempty) <$> ["free", "comonad"]) defV defV :: Version defV = Version [0,1,0] microlens :: Dependency -microlens = Dependency "microlens" mempty mempty defV +microlens = Dependency "microlens" mempty defV bifunctors :: Dependency -bifunctors = Dependency "bifunctors" mempty ["comonad"] defV +bifunctors = Dependency "bifunctors" ((,mempty) <$> ["comonad"]) defV deps :: [Dependency] deps = [free, lens, comonad] diff --git a/dependency.cabal b/dependency.cabal --- a/dependency.cabal +++ b/dependency.cabal @@ -1,5 +1,5 @@ name: dependency -version: 0.1.0.7 +version: 0.1.0.8 synopsis: Dependency resolution for package management description: A library for resolving dependencies; uses a topological sort to construct a build plan and then allows choice between all compatible plans. license: BSD3 @@ -29,9 +29,11 @@ , containers , recursion-schemes , microlens + , transformers , deepseq , binary , deepseq + , tardis default-language: Haskell2010 if flag(development) ghc-options: -Werror diff --git a/src/Data/Dependency.hs b/src/Data/Dependency.hs --- a/src/Data/Dependency.hs +++ b/src/Data/Dependency.hs @@ -3,6 +3,7 @@ resolveDependencies , buildSequence , satisfies + , compatible -- * Types , Dependency (..) , PackageSet (..) @@ -10,35 +11,52 @@ , DepM , ResolveError (..) , Constraint (..) + , ResolveStateM (..) + , ResolveState + , ResMap ) where import Control.Monad +import Control.Monad.Tardis +import Control.Monad.Trans.Class import Data.Dependency.Error import Data.Dependency.Sort import Data.Dependency.Type -import Data.Foldable (toList) -import Data.List (groupBy) -import qualified Data.Map as M -import qualified Data.Set as S +import Data.Foldable (toList) +import Data.List (groupBy) +import qualified Data.Map as M +import qualified Data.Set as S lookupMap :: String -> M.Map String a -> DepM a lookupMap k ps = case M.lookup k ps of Just x -> Right x Nothing -> Left (NotPresent k) -lookupSet :: S.Set a -> DepM a -lookupSet s = case S.lookupMax s of - Just x -> Right x - Nothing -> Left InternalError +checkWith :: Dependency -> [Dependency] -> S.Set Dependency -> DepM Dependency +checkWith x ds s + | check x ds = Right x + | otherwise = lookupSet ds (S.deleteMax s) -latest :: (Ord a) => PackageSet a -> Dependency -> DepM (String, a) -latest (PackageSet ps) (Dependency ln _ _ _) = do - s <- lookupMap ln ps - (,) ln <$> lookupSet s +lookupSet :: [Dependency] -- ^ Dependencies already added + -> S.Set Dependency -- ^ Set of dependencies + -> DepM Dependency +lookupSet ds s = case S.lookupMax s of + Just x -> checkWith x ds s + Nothing -> g s + where g s' + | S.size s' > 0 = Left (Conflict (_libName <$> ds) (_libName . head . toList $ s')) + | otherwise = Left InternalError + +latest :: PackageSet Dependency -> Dependency -> ResolveState (String, Dependency) +latest (PackageSet ps) (Dependency ln _ _) = do + st <- getPast + s <- lift $ lookupMap ln ps + (,) ln <$> lift (lookupSet (toList st) s) + buildSequence :: [Dependency] -> [[Dependency]] buildSequence = reverse . groupBy independent . sortDeps - where independent (Dependency ln _ ls _) (Dependency ln' _ ls' _) = ln' `notElem` ls && ln `notElem` ls' + where independent (Dependency ln ls _) (Dependency ln' ls' _) = ln' `notElem` (fst <$> ls) && ln `notElem` (fst <$> ls') iterateM :: (Monad m) => Int -> (a -> m a) -> a -> m [a] iterateM 0 _ _ = pure [] @@ -52,10 +70,13 @@ saturateDeps' :: PackageSet Dependency -> Dependency -> DepM (S.Set Dependency) saturateDeps' (PackageSet ps) dep = do - deps <- sequence [ lookupMap lib ps | lib <- _libDependencies dep ] - list <- (:) dep <$> traverse lookupSet deps + deps <- sequence [ lookupMap lib ps | lib <- fst <$> _libDependencies dep ] + list <- (:) dep <$> traverse (lookupSet mempty) deps pure $ S.fromList list +run :: ResolveState a -> DepM a +run = flip evalTardisT (id, mempty) . unResolve + -- | Heuristics: -- -- 1. Always use a newer version when possible @@ -73,4 +94,4 @@ resolveDependencies ps = select . getLatest <=< fmap (buildSequence . toList) . saturated where select = fmap (fmap (fmap snd)) saturated dep = S.unions <$> traverse (saturateDeps ps) dep - getLatest = traverse (traverse (latest ps)) + getLatest = run . traverse (traverse (latest ps)) diff --git a/src/Data/Dependency/Error.hs b/src/Data/Dependency/Error.hs --- a/src/Data/Dependency/Error.hs +++ b/src/Data/Dependency/Error.hs @@ -15,6 +15,7 @@ -- | An error that can occur during package resolution. data ResolveError = InternalError | NotPresent String + | Conflict [String] String deriving (Show, Eq, NFData, Generic) -- CircularDependencies String String -- Conflict String String (Constraint Version) (Constraint Version) @@ -22,3 +23,4 @@ instance Pretty ResolveError where pretty InternalError = red "Error:" <+> "the" <+> squotes "dependency" <+> "package enountered an internal error. Please report this as a bug:\n" <> hang 2 "https://hub.darcs.net/vmchale/ats/issues" pretty (NotPresent s) = red "Error:" <+> "the package" <+> squotes (text s) <+> "could not be found.\n" + pretty (Conflict ss s) = red "Error:" <+> "the package" <+> squotes (text s) <+> "conflicts with already in-scope packages: " <+> pretty ss diff --git a/src/Data/Dependency/Sort.hs b/src/Data/Dependency/Sort.hs --- a/src/Data/Dependency/Sort.hs +++ b/src/Data/Dependency/Sort.hs @@ -8,7 +8,7 @@ asGraph :: [Dependency] -> (Graph, Vertex -> Dependency) asGraph ds = (f triple, keys) - where triple = graphFromEdges (zip3 ds (_libName <$> ds) (_libDependencies <$> ds)) + where triple = graphFromEdges (zip3 ds (_libName <$> ds) (fmap fst . _libDependencies <$> ds)) f = view _1 s = view _2 keys = view _1 . s triple diff --git a/src/Data/Dependency/Type.hs b/src/Data/Dependency/Type.hs --- a/src/Data/Dependency/Type.hs +++ b/src/Data/Dependency/Type.hs @@ -5,6 +5,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} @@ -16,12 +17,21 @@ , Version (..) , Constraint (..) , PackageSet (..) + , ResMap + , ResolveStateM (..) + , ResolveState -- * Helper functions , satisfies + , compatible + , check ) where import Control.DeepSeq (NFData) +import Control.Monad.Fix +import Control.Monad.Tardis +import Control.Monad.Trans.Class import Data.Binary +import Data.Dependency.Error import Data.Functor.Foldable import Data.Functor.Foldable.TH import Data.List (intercalate) @@ -33,6 +43,17 @@ import GHC.Generics (Generic) import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) +type Mod = ResMap -> ResMap +type ResMap = M.Map String Dependency +type ResolveState = ResolveStateM (Either ResolveError) + +newtype ResolveStateM m a = ResolveStateM { unResolve :: TardisT Mod ResMap m a } + deriving (Functor) + deriving newtype (Applicative, Monad, MonadFix, MonadTardis Mod ResMap) + +instance MonadTrans ResolveStateM where + lift = ResolveStateM . lift + newtype PackageSet a = PackageSet (M.Map String (S.Set a)) deriving (Eq, Ord, Foldable, Generic) deriving newtype Binary @@ -75,15 +96,15 @@ mempty = None mappend = (<>) -makeBaseFunctor ''Constraint +data Dependency = Dependency { _libName :: String + , _libDependencies :: [(String, Constraint Version)] + , _libVersion :: Version + } + deriving (Show, Eq, Ord, Generic, NFData) -instance Pretty a => Pretty (Constraint a) where - pretty = cata a where - a (LessThanEqF v) = "≤" <+> pretty v - a (GreaterThanEqF v) = "≥" <+> pretty v - a (EqF v) = "≡" <+> pretty v - a (BoundedF c c') = c <+> "∧" <+> c' - a NoneF = mempty +check :: Dependency -> [Dependency] -> Bool +check (Dependency ln _ v) ds = and [ g v ds' | (Dependency _ ds' _) <- ds ] + where g v' = all (`satisfies` v') . fmap snd . filter ((== ln) . fst) satisfies :: (Ord a) => Constraint a -> a -> Bool satisfies (LessThanEq x) y = x <= y @@ -92,10 +113,22 @@ satisfies (Bounded x y) z = satisfies x z && satisfies y z satisfies None _ = True --- FIXME make version first -data Dependency = Dependency { _libName :: String - , _libConstraint :: Constraint Version - , _libDependencies :: [String] - , _libVersion :: Version - } - deriving (Show, Eq, Ord, Generic, NFData) +compatible :: (Ord a) => Constraint a -> Constraint a -> Bool +compatible LessThanEq{} LessThanEq{} = True +compatible (LessThanEq x) (GreaterThanEq y) = y <= x +compatible (Eq x) (Eq y) = x == y +compatible (Bounded x y) z = compatible x z && compatible y z +compatible GreaterThanEq{} GreaterThanEq{} = True +compatible (LessThanEq x) (Eq y) = y <= x +compatible None _ = True +compatible x y = compatible y x + +makeBaseFunctor ''Constraint + +instance Pretty a => Pretty (Constraint a) where + pretty = cata a where + a (LessThanEqF v) = "≤" <+> pretty v + a (GreaterThanEqF v) = "≥" <+> pretty v + a (EqF v) = "≡" <+> pretty v + a (BoundedF c c') = c <+> "∧" <+> c' + a NoneF = mempty diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TupleSections #-} + import Control.Arrow import Data.Dependency import qualified Data.Map as M @@ -5,13 +7,16 @@ import Test.Hspec free :: Dependency -free = Dependency "free" mempty mempty defV +free = Dependency "free" mempty defV comonad :: Dependency -comonad = Dependency "comonad" mempty mempty defV +comonad = Dependency "comonad" mempty defV +newLens :: Dependency +newLens = Dependency "lens" ((,mempty) <$> ["free", "comonad"]) (Version [0,2,0]) + lens :: Dependency -lens = Dependency "lens" mempty ["free", "comonad"] defV +lens = Dependency "lens" ((,mempty) <$> ["free", "comonad"]) defV defV :: Version defV = Version [0,1,0] @@ -23,7 +28,7 @@ mapSingles = fmap (second S.singleton) set :: PackageSet Dependency -set = PackageSet $ M.fromList (mapSingles [("lens", lens), ("comonad", comonad), ("free", free)]) +set = PackageSet $ M.fromList (("lens", S.fromList [lens, newLens]) : mapSingles [("comonad", comonad), ("free", free)]) main :: IO () main = hspec $ parallel $ do @@ -32,4 +37,4 @@ buildSequence deps `shouldBe` [[free, comonad], [lens]] describe "resolveDependencies" $ it "correctly resolves dependencies in a package set" $ - resolveDependencies set [lens] `shouldBe` Right [[free, comonad], [lens]] + resolveDependencies set [lens] `shouldBe` Right [[free, comonad], [newLens]]