diff --git a/dependency.cabal b/dependency.cabal --- a/dependency.cabal +++ b/dependency.cabal @@ -1,76 +1,90 @@ -name: dependency -version: 0.1.0.9 -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 -license-file: LICENSE -author: Vanessa McHale -maintainer: vamchale@gmail.com -copyright: Copyright: (c) 2018 Vanessa McHale -category: Development, Build -build-type: Simple -extra-doc-files: README.md -cabal-version: 1.18 +cabal-version: 1.18 +name: dependency +version: 0.1.0.10 +license: BSD3 +license-file: LICENSE +copyright: Copyright: (c) 2018 Vanessa McHale +maintainer: vamchale@gmail.com +author: Vanessa McHale +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. +category: Development, Build +build-type: Simple +extra-doc-files: README.md -Flag development { - Description: Enable `-Werror` - manual: True - default: False -} +source-repository head + type: darcs + location: https://hub.darcs.net/vmchale/ats +flag development + description: + Enable `-Werror` + default: False + manual: True + library - hs-source-dirs: src - exposed-modules: Data.Dependency - other-modules: Data.Dependency.Type - , Data.Dependency.Error - , Data.Dependency.Sort - build-depends: base >= 4.10 && < 5 - , ansi-wl-pprint - , containers - , recursion-schemes - , microlens - , transformers - , deepseq - , binary - , deepseq - , tardis - default-language: Haskell2010 - if flag(development) - ghc-options: -Werror - if impl(ghc >= 8.0) - ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates -Wcompat - ghc-options: -Wall + exposed-modules: + Data.Dependency + hs-source-dirs: src + other-modules: + Data.Dependency.Type + Data.Dependency.Error + Data.Dependency.Sort + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.10 && <5, + ansi-wl-pprint -any, + containers -any, + recursion-schemes -any, + microlens -any, + transformers -any, + binary -any, + deepseq -any, + tardis -any + + if flag(development) + ghc-options: -Werror + + if impl(ghc >=8.0) + ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wcompat test-suite dependency-test - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Spec.hs - build-depends: base - , dependency - , hspec - , containers - if flag(development) - ghc-options: -Werror - if impl(ghc >= 8.0) - ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates -Wcompat - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall - default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + base -any, + dependency -any, + hspec -any, + containers -any + + if flag(development) + ghc-options: -Werror + + if impl(ghc >=8.0) + ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wcompat benchmark dependency-bench - type: exitcode-stdio-1.0 - hs-source-dirs: bench - main-is: Bench.hs - build-depends: base - , dependency - , containers - , criterion - if flag(development) - ghc-options: -Werror - if impl(ghc >= 8.0) - ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates -Wcompat - ghc-options: -Wall - default-language: Haskell2010 - -source-repository head - type: darcs - location: https://hub.darcs.net/vmchale/ats + type: exitcode-stdio-1.0 + main-is: Bench.hs + hs-source-dirs: bench + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base -any, + dependency -any, + containers -any, + criterion -any + + if flag(development) + ghc-options: -Werror + + if impl(ghc >=8.0) + ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wcompat diff --git a/src/Data/Dependency.hs b/src/Data/Dependency.hs --- a/src/Data/Dependency.hs +++ b/src/Data/Dependency.hs @@ -2,8 +2,7 @@ ( -- * Functions resolveDependencies , buildSequence - , satisfies - , compatible + , check -- * Types , Dependency (..) , PackageSet (..) @@ -32,28 +31,47 @@ Just x -> Right x Nothing -> Left (NotPresent k) -checkWith :: Dependency -> [Dependency] -> S.Set Dependency -> DepM Dependency +-- | This function checks a package against currently in-scope packages, +-- downgrading versions as necessary until we reach something amenable or run out +-- of options. +checkWith :: Dependency -- ^ Dependency we want + -> [Dependency] -- ^ Dependencies already in scope. + -> S.Set Dependency -- ^ Set of available versions + -> DepM Dependency checkWith x ds s | check x ds = Right x - | otherwise = lookupSet ds (S.deleteMax s) + | otherwise = lookupSet (Just x) ds (S.deleteMax s) -lookupSet :: [Dependency] -- ^ Dependencies already added - -> S.Set Dependency -- ^ Set of dependencies +lookupSet :: Maybe Dependency -- ^ Optional dependency we are looking for. + -> [Dependency] -- ^ Dependencies already added + -> S.Set Dependency -- ^ Set of available versions of given dependency -> DepM Dependency -lookupSet ds s = case S.lookupMax s of - Just x -> checkWith x ds s - Nothing -> g s +lookupSet x ds s = case S.lookupMax s of + Just x' -> checkWith x' ds s + Nothing -> g x - where g s' - | S.size s' > 0 = Left (Conflict (_libName <$> ds) (_libName . head . toList $ s')) - | otherwise = Left InternalError + where g Nothing = Left InternalError + g (Just x') = Left (Conflicts (_libName <$> ds') (_libName x')) + where ds' = filter (\d -> not (check x' [d])) ds +-- This does check for compatibility with past packages, but doesn't do the +-- fancy tardis shenanigans it's supposed to when package resolution fails. latest :: PackageSet Dependency -> Dependency -> ResolveState (String, Dependency) -latest (PackageSet ps) (Dependency ln _ _) = do +latest (PackageSet ps) d@(Dependency ln _ _) = do st <- getPast s <- lift $ lookupMap ln ps - (,) ln <$> lift (lookupSet (toList st) s) + finish ln (lookupSet (Just d) (toList st) s) +finish :: String -> DepM Dependency -> ResolveState (String, Dependency) +finish ln dep' = + case dep' of + + Right dep -> + modifyForwards (M.insert ln dep) >> + pure (ln, dep) + + Left err -> lift (Left err) + buildSequence :: [Dependency] -> [[Dependency]] buildSequence = reverse . groupBy independent . sortDeps where independent (Dependency ln ls _) (Dependency ln' ls' _) = ln' `notElem` (fst <$> ls) && ln `notElem` (fst <$> ls') @@ -71,7 +89,7 @@ saturateDeps' :: PackageSet Dependency -> Dependency -> DepM (S.Set Dependency) saturateDeps' (PackageSet ps) dep = do deps <- sequence [ lookupMap lib ps | lib <- fst <$> _libDependencies dep ] - list <- (:) dep <$> traverse (lookupSet mempty) deps + list <- (:) dep <$> traverse (lookupSet Nothing mempty) deps pure $ S.fromList list run :: ResolveState a -> DepM a 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,7 +15,7 @@ -- | An error that can occur during package resolution. data ResolveError = InternalError | NotPresent String - | Conflict [String] String + | Conflicts [String] String deriving (Show, Eq, NFData, Generic) -- CircularDependencies String String -- Conflict String String (Constraint Version) (Constraint Version) @@ -23,4 +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 + pretty (Conflicts ss s) = red "Error:" <+> "the package" <+> squotes (text s) <+> "conflicts with already in-scope packages: " <+> mconcat (punctuate ", " (fmap (squotes . text) 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 @@ -13,6 +13,7 @@ s = view _2 keys = view _1 . s triple +-- | Topologically sort dependencies sortDeps :: [Dependency] -> [Dependency] sortDeps ds = fmap find . topSort $ g where (g, find) = asGraph ds 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} @@ -21,8 +20,6 @@ , ResolveStateM (..) , ResolveState -- * Helper functions - , satisfies - , compatible , check ) where @@ -36,9 +33,7 @@ import Data.Functor.Foldable.TH import Data.List (intercalate) import qualified Data.Map as M -#if __GLASGOW_HASKELL__ < 804 import Data.Semigroup -#endif import qualified Data.Set as S import GHC.Generics (Generic) import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) @@ -47,6 +42,8 @@ type ResMap = M.Map String Dependency type ResolveState = ResolveStateM (Either ResolveError) +-- | We use a tardis monad here to give ourselves greater flexibility during +-- dependency solving. newtype ResolveStateM m a = ResolveStateM { unResolve :: TardisT Mod ResMap m a } deriving (Functor) deriving newtype (Applicative, Monad, MonadFix, MonadTardis Mod ResMap) @@ -54,7 +51,8 @@ instance MonadTrans ResolveStateM where lift = ResolveStateM . lift -newtype PackageSet a = PackageSet (M.Map String (S.Set a)) +-- | A package set is simply a map between package names and a set of packages. +newtype PackageSet a = PackageSet { _packageSet :: M.Map String (S.Set a) } deriving (Eq, Ord, Foldable, Generic) deriving newtype Binary @@ -78,7 +76,7 @@ | x == y = Version xs <= Version ys | otherwise = x <= y --- TODO comonad?? +-- | Monoid/functor for representing constraints. data Constraint a = LessThanEq a | GreaterThanEq a | Eq a @@ -86,7 +84,6 @@ | None deriving (Show, Eq, Ord, Functor, Generic, NFData) --- free moinoid but "pokey" because it has extra constructors instance Semigroup (Constraint a) where (<>) None x = x (<>) x None = x @@ -96,19 +93,29 @@ mempty = None mappend = (<>) +-- | A generic dependency, consisting of a package name and version, as well as +-- dependency names and their constraints. data Dependency = Dependency { _libName :: String , _libDependencies :: [(String, Constraint Version)] , _libVersion :: Version } deriving (Show, Eq, Ord, Generic, NFData) +check' :: Dependency -> [Dependency] -> Bool +check' (Dependency _ lds _) ds = + and [ compatible (Eq v') c | (Dependency ln _ v') <- ds, (str, c) <- lds, ln == str ] + +-- | Check a given dependency is compatible with in-scope dependencies. 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) +check d = (&&) <$> check' d <*> check'' d +check'' :: Dependency -> [Dependency] -> Bool +check'' (Dependency ln _ v) ds = and [ g ds' | (Dependency _ ds' _) <- ds ] + where g = all ((`satisfies` v) . snd) . filter ((== ln) . fst) + satisfies :: (Ord a) => Constraint a -> a -> Bool -satisfies (LessThanEq x) y = x <= y -satisfies (GreaterThanEq x) y = x >= y +satisfies (LessThanEq x) y = x >= y +satisfies (GreaterThanEq x) y = x <= y satisfies (Eq x) y = x == y satisfies (Bounded x y) z = satisfies x z && satisfies y z satisfies None _ = True diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -21,6 +21,9 @@ defV :: Version defV = Version [0,1,0] +ghcMod :: Dependency +ghcMod = Dependency "ghc-mod" [("lens", LessThanEq defV)] defV + deps :: [Dependency] deps = [free, lens, comonad] @@ -28,13 +31,15 @@ mapSingles = fmap (second S.singleton) set :: PackageSet Dependency -set = PackageSet $ M.fromList (("lens", S.fromList [lens, newLens]) : mapSingles [("comonad", comonad), ("free", free)]) +set = PackageSet $ M.fromList (("lens", S.fromList [lens, newLens]) : mapSingles [("ghc-mod", ghcMod), ("comonad", comonad), ("free", free)]) main :: IO () main = hspec $ parallel $ do describe "buildSequence" $ it "correctly orders dependencies" $ buildSequence deps `shouldBe` [[free, comonad], [lens]] - describe "resolveDependencies" $ + describe "resolveDependencies" $ do it "correctly resolves dependencies in a package set" $ - resolveDependencies set [lens] `shouldBe` Right [[free, comonad], [newLens]] + resolveDependencies set [newLens] `shouldBe` Right [[free, comonad], [newLens]] + it "correctly resolves dependencies in a package set" $ + pendingWith "not working yet" -- resolveDependencies set [ghcMod] `shouldBe` Right [[free, comonad], [lens], [ghcMod]]