Commit 78c0428f authored by Simon Hengel's avatar Simon Hengel
Browse files

Derive Functor, Traversable and Foldable instances

parent d13a29ed
{-# LANGUAGE DeriveFunctor #-}
module Distribution.Client.Dependency.Modular.Dependency where
import Prelude hiding (pi)
......@@ -19,18 +20,13 @@ import Distribution.Client.Dependency.Modular.Version
-- TODO: This isn't the ideal location to declare the type,
-- but we need them for constrained instances.
data Var qpn = P qpn | F (FN qpn) | S (SN qpn)
deriving (Eq, Ord, Show)
deriving (Eq, Ord, Show, Functor)
showVar :: Var QPN -> String
showVar (P qpn) = showQPN qpn
showVar (F qfn) = showQFN qfn
showVar (S qsn) = showQSN qsn
instance Functor Var where
fmap f (P n) = P (f n)
fmap f (F fn) = F (fmap f fn)
fmap f (S sn) = S (fmap f sn)
type ConflictSet qpn = Set (Var qpn)
showCS :: ConflictSet QPN -> String
......@@ -41,11 +37,7 @@ showCS = intercalate ", " . L.map showVar . S.toList
-- is for convenience. Otherwise, it is a list of version ranges paired with
-- the goals / variables that introduced them.
data CI qpn = Fixed I (Goal qpn) | Constrained [VROrigin qpn]
deriving (Eq, Show)
instance Functor CI where
fmap f (Fixed i g) = Fixed i (fmap f g)
fmap f (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, fmap f y)) vrs)
deriving (Eq, Show, Functor)
instance ResetGoal CI where
resetGoal g (Fixed i _) = Fixed i g
......@@ -98,13 +90,7 @@ data FlaggedDep qpn =
Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)
| Stanza (SN qpn) (TrueFlaggedDeps qpn)
| Simple (Dep qpn)
deriving (Eq, Show)
instance Functor FlaggedDep where
fmap f (Flagged x y tt ff) = Flagged (fmap f x) y
(fmap (fmap f) tt) (fmap (fmap f) ff)
fmap f (Stanza x tt) = Stanza (fmap f x) (fmap (fmap f) tt)
fmap f (Simple d) = Simple (fmap f d)
deriving (Eq, Show, Functor)
type TrueFlaggedDeps qpn = FlaggedDeps qpn
type FalseFlaggedDeps qpn = FlaggedDeps qpn
......@@ -112,7 +98,7 @@ type FalseFlaggedDeps qpn = FlaggedDeps qpn
-- | A dependency (constraint) associates a package name with a
-- constrained instance.
data Dep qpn = Dep qpn (CI qpn)
deriving (Eq, Show)
deriving (Eq, Show, Functor)
showDep :: Dep QPN -> String
showDep (Dep qpn (Fixed i (Goal v _)) ) =
......@@ -123,9 +109,6 @@ showDep (Dep qpn (Constrained [(vr, Goal v _)])) =
showDep (Dep qpn ci ) =
showQPN qpn ++ showCI ci
instance Functor Dep where
fmap f (Dep x y) = Dep (f x) (fmap f y)
instance ResetGoal Dep where
resetGoal g (Dep qpn ci) = Dep qpn (resetGoal g ci)
......@@ -136,10 +119,7 @@ type RevDepMap = Map QPN [QPN]
-- | Goals are solver variables paired with information about
-- why they have been introduced.
data Goal qpn = Goal (Var qpn) (GoalReasonChain qpn)
deriving (Eq, Show)
instance Functor Goal where
fmap f (Goal v grs) = Goal (fmap f v) (fmap (fmap f) grs)
deriving (Eq, Show, Functor)
class ResetGoal f where
resetGoal :: Goal qpn -> f qpn -> f qpn
......@@ -158,13 +138,7 @@ data GoalReason qpn =
| PDependency (PI qpn)
| FDependency (FN qpn) Bool
| SDependency (SN qpn)
deriving (Eq, Show)
instance Functor GoalReason where
fmap _ UserGoal = UserGoal
fmap f (PDependency pi) = PDependency (fmap f pi)
fmap f (FDependency fn b) = FDependency (fmap f fn) b
fmap f (SDependency sn) = SDependency (fmap f sn)
deriving (Eq, Show, Functor)
-- | The first element is the immediate reason. The rest are the reasons
-- for the reasons ...
......
{-# LANGUAGE DeriveFunctor #-}
module Distribution.Client.Dependency.Modular.Flag where
import Data.Map as M
......@@ -10,15 +11,12 @@ import Distribution.Client.Types (OptionalStanza(..))
-- | Flag name. Consists of a package instance and the flag identifier itself.
data FN qpn = FN (PI qpn) Flag
deriving (Eq, Ord, Show)
deriving (Eq, Ord, Show, Functor)
-- | Extract the package name from a flag name.
getPN :: FN qpn -> qpn
getPN (FN (PI qpn _) _) = qpn
instance Functor FN where
fmap f (FN x y) = FN (fmap f x) y
-- | Flag identifier. Just a string.
type Flag = FlagName
......@@ -39,10 +37,7 @@ type QFN = FN QPN
-- | Stanza name. Paired with a package name, much like a flag.
data SN qpn = SN (PI qpn) OptionalStanza
deriving (Eq, Ord, Show)
instance Functor SN where
fmap f (SN x y) = SN (fmap f x) y
deriving (Eq, Ord, Show, Functor)
-- | Qualified stanza name.
type QSN = SN QPN
......
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveFoldable, DeriveTraversable #-}
module Distribution.Client.Dependency.Modular.PSQ where
-- Priority search queues.
......@@ -7,7 +8,6 @@ module Distribution.Client.Dependency.Modular.PSQ where
-- (inefficiently implemented) lookup, because I think that queue-based
-- operations and sorting turn out to be more efficiency-critical in practice.
import Control.Applicative
import Data.Foldable
import Data.Function
import Data.List as S hiding (foldr)
......@@ -15,16 +15,7 @@ import Data.Traversable
import Prelude hiding (foldr)
newtype PSQ k v = PSQ [(k, v)]
deriving (Eq, Show)
instance Functor (PSQ k) where
fmap f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f v)) xs)
instance Foldable (PSQ k) where
foldr op e (PSQ xs) = foldr op e (fmap snd xs)
instance Traversable (PSQ k) where
traverse f (PSQ xs) = PSQ <$> traverse (\ (k, v) -> (\ x -> (k, x)) <$> f v) xs
deriving (Eq, Show, Functor, Foldable, Traversable)
keys :: PSQ k v -> [k]
keys (PSQ xs) = fmap fst xs
......
{-# LANGUAGE DeriveFunctor #-}
module Distribution.Client.Dependency.Modular.Package
(module Distribution.Client.Dependency.Modular.Package,
module Distribution.Package) where
......@@ -51,7 +52,7 @@ showI (I v (Inst (InstalledPackageId i))) = showVer v ++ "/installed" ++ shortId
-- | Package instance. A package name and an instance.
data PI qpn = PI qpn I
deriving (Eq, Ord, Show)
deriving (Eq, Ord, Show, Functor)
-- | String representation of a package instance.
showPI :: PI QPN -> String
......@@ -66,9 +67,6 @@ instI :: I -> Bool
instI (I _ (Inst _)) = True
instI _ = False
instance Functor PI where
fmap f (PI x y) = PI (f x) y
-- | Package path. (Stored in "reverse" order.)
type PP = [PN]
......
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
module Distribution.Client.Dependency.Modular.Tree where
import Control.Applicative
import Control.Monad hiding (mapM)
import Data.Foldable
import Data.Traversable
......@@ -20,7 +20,7 @@ data Tree a =
| GoalChoice (PSQ OpenGoal (Tree a)) -- PSQ should never be empty
| Done RevDepMap
| Fail (ConflictSet QPN) FailReason
deriving (Eq, Show)
deriving (Eq, Show, Functor)
-- Above, a choice is called trivial if it clearly does not matter. The
-- special case of triviality we actually consider is if there are no new
-- dependencies introduced by this node.
......@@ -30,14 +30,6 @@ data Tree a =
-- the system, as opposed to flags that are used to explicitly enable or
-- disable some functionality.
instance Functor Tree where
fmap f (PChoice qpn i xs) = PChoice qpn (f i) (fmap (fmap f) xs)
fmap f (FChoice qfn i b m xs) = FChoice qfn (f i) b m (fmap (fmap f) xs)
fmap f (SChoice qsn i b xs) = SChoice qsn (f i) b (fmap (fmap f) xs)
fmap f (GoalChoice xs) = GoalChoice (fmap (fmap f) xs)
fmap _f (Done rdm ) = Done rdm
fmap _f (Fail cs fr ) = Fail cs fr
data FailReason = InconsistentInitialConstraints
| Conflicting [Dep QPN]
| CannotInstall
......@@ -64,6 +56,7 @@ data TreeF a b =
| GoalChoiceF (PSQ OpenGoal b)
| DoneF RevDepMap
| FailF (ConflictSet QPN) FailReason
deriving (Functor, Foldable, Traversable)
out :: Tree a -> TreeF a (Tree a)
out (PChoice p i ts) = PChoiceF p i ts
......@@ -81,30 +74,6 @@ inn (GoalChoiceF ts) = GoalChoice ts
inn (DoneF x ) = Done x
inn (FailF c x ) = Fail c x
instance Functor (TreeF a) where
fmap f (PChoiceF p i ts) = PChoiceF p i (fmap f ts)
fmap f (FChoiceF p i b m ts) = FChoiceF p i b m (fmap f ts)
fmap f (SChoiceF p i b ts) = SChoiceF p i b (fmap f ts)
fmap f (GoalChoiceF ts) = GoalChoiceF (fmap f ts)
fmap _ (DoneF x ) = DoneF x
fmap _ (FailF c x ) = FailF c x
instance Foldable (TreeF a) where
foldr op e (PChoiceF _ _ ts) = foldr op e ts
foldr op e (FChoiceF _ _ _ _ ts) = foldr op e ts
foldr op e (SChoiceF _ _ _ ts) = foldr op e ts
foldr op e (GoalChoiceF ts) = foldr op e ts
foldr _ e (DoneF _ ) = e
foldr _ e (FailF _ _ ) = e
instance Traversable (TreeF a) where
traverse f (PChoiceF p i ts) = PChoiceF <$> pure p <*> pure i <*> traverse f ts
traverse f (FChoiceF p i b m ts) = FChoiceF <$> pure p <*> pure i <*> pure b <*> pure m <*> traverse f ts
traverse f (SChoiceF p i b ts) = SChoiceF <$> pure p <*> pure i <*> pure b <*> traverse f ts
traverse f (GoalChoiceF ts) = GoalChoiceF <$> traverse f ts
traverse _ (DoneF x ) = DoneF <$> pure x
traverse _ (FailF c x ) = FailF <$> pure c <*> pure x
-- | Determines whether a tree is active, i.e., isn't a failure node.
active :: Tree a -> Bool
active (Fail _ _) = False
......
{-# LANGUAGE DeriveFunctor #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Dependency.Types
......@@ -221,6 +222,7 @@ isAllowNewer AllowNewerAll = True
data Progress step fail done = Step step (Progress step fail done)
| Fail fail
| Done done
deriving Functor
-- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two
-- base cases, one for a final result and one for failure.
......@@ -236,9 +238,6 @@ foldProgress step fail done = fold
fold (Fail f) = fail f
fold (Done r) = done r
instance Functor (Progress step fail) where
fmap f = foldProgress Step Fail (Done . f)
instance Monad (Progress step fail) where
return a = Done a
p >>= f = foldProgress Step Fail f p
......
{-# LANGUAGE DeriveFunctor #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.PackageIndex
......@@ -87,10 +88,7 @@ newtype PackageIndex pkg = PackageIndex
--
(Map PackageName [pkg])
deriving (Show, Read)
instance Functor PackageIndex where
fmap f (PackageIndex m) = PackageIndex (fmap (map f) m)
deriving (Show, Read, Functor)
instance Package pkg => Monoid (PackageIndex pkg) where
mempty = PackageIndex Map.empty
......
{-# LANGUAGE DeriveFunctor #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
-----------------------------------------------------------------------------
-- |
......@@ -673,14 +674,12 @@ getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0')
. getBytes off len
data Partial a = Error String | Ok a
deriving Functor
partial :: Partial a -> Either String a
partial (Error msg) = Left msg
partial (Ok x) = Right x
instance Functor Partial where
fmap = liftM
instance Applicative Partial where
pure = return
(<*>) = ap
......
{-# LANGUAGE DeriveFunctor #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Types
......@@ -172,14 +173,7 @@ data PackageLocation local =
--TODO:
-- * add support for darcs and other SCM style remote repos with a local cache
-- | ScmPackage
deriving Show
instance Functor PackageLocation where
fmap _ (LocalUnpackedPackage dir) = LocalUnpackedPackage dir
fmap _ (LocalTarballPackage file) = LocalTarballPackage file
fmap f (RemoteTarballPackage uri x) = RemoteTarballPackage uri (f x)
fmap f (RepoTarballPackage repo pkg x) = RepoTarballPackage repo pkg (f x)
deriving (Show, Functor)
data LocalRepo = LocalRepo
deriving (Show,Eq)
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment