{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Dependency.Type ( Dependency (..)
, Version (..)
, Constraint (..)
, PackageSet (..)
, check
) where
import Control.DeepSeq (NFData)
import Data.Binary
import Data.Functor.Foldable
import Data.Functor.Foldable.TH
import Data.List (intercalate)
import qualified Data.Map as M
import Data.Semigroup
import qualified Data.Set as S
import GHC.Generics (Generic)
import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>))
newtype PackageSet a = PackageSet { _packageSet :: M.Map String (S.Set a) }
deriving (Eq, Ord, Foldable, Generic, Binary)
newtype Version = Version [Integer]
deriving (Eq, Generic, NFData, Binary)
instance Show Version where
show (Version is) = intercalate "." (show <$> is)
instance Ord Version where
(Version []) <= (Version []) = True
(Version []) <= _ = True
_ <= (Version []) = False
(Version (x:xs)) <= (Version (y:ys))
| x == y = Version xs <= Version ys
| otherwise = x <= y
data Constraint a = LessThanEq a
| GreaterThanEq a
| Eq a
| Bounded (Constraint a) (Constraint a)
| None
deriving (Show, Eq, Ord, Functor, Generic, NFData)
instance Semigroup (Constraint a) where
(<>) None x = x
(<>) x None = x
(<>) x y = Bounded x y
instance Monoid (Constraint a) where
mempty = None
mappend = (<>)
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 :: Dependency -> [Dependency] -> Bool
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 (Eq x) y = x == y
satisfies (Bounded x y) z = satisfies x z && satisfies y z
satisfies None _ = True
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