diff --git a/lib/Data/Internal/XIO.hs b/lib/Data/Internal/XIO.hs index 27dfe29..61801af 100644 --- a/lib/Data/Internal/XIO.hs +++ b/lib/Data/Internal/XIO.hs @@ -221,12 +221,13 @@ type Feature a = Either (Sometimes a) (Always a) -- | Feature that is guaranteed to work -- This is composed of sub-features that are tested in order, and if all fail -- the fallback is a monadic action (eg a plain haskell function) -data Always a = Always T.Text (Always_ a) +data Always a = Always T.Text (Always_ a) deriving (Functor) -- | Feature that is guaranteed to work (inner data) data Always_ a = Option (SubfeatureRoot a) (Always_ a) | Always_ (FallbackRoot a) + deriving (Functor) -- | Root of a fallback action for an always -- This may either be a lone action or a function that depends on the results @@ -235,15 +236,23 @@ data FallbackRoot a = FallbackAlone a | forall p. FallbackTree (p -> a) (FallbackStack p) +instance Functor FallbackRoot where + fmap f (FallbackAlone a) = FallbackAlone (f a) + fmap f (FallbackTree g s) = FallbackTree (f . g) s + -- | Always features that are used as a payload for a fallback action data FallbackStack p = FallbackBottom (Always p) | forall x y. FallbackStack (x -> y -> p) (Always x) (FallbackStack y) +instance Functor FallbackStack where + fmap f (FallbackBottom a) = FallbackBottom $ fmap f a + fmap f (FallbackStack g a s) = FallbackStack (\x -> f . g x) a s + -- | Feature that might not be present -- This is like an Always except it doesn't fall back on a guaranteed monadic -- action -data Sometimes a = Sometimes T.Text XPQuery (Sometimes_ a) +data Sometimes a = Sometimes T.Text XPQuery (Sometimes_ a) deriving (Functor) -- | Feature that might not be present (inner data) type Sometimes_ a = [SubfeatureRoot a] @@ -256,6 +265,7 @@ data Subfeature f = Subfeature { sfData :: f , sfName :: T.Text } + deriving (Functor) type SubfeatureRoot a = Subfeature (Root a) @@ -268,6 +278,12 @@ data Root a | forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c) | forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c) +instance Functor Root where + fmap f (IORoot a t) = IORoot (f . a) t + fmap f (IORoot_ a t) = IORoot_ (f a) t + fmap f (DBusRoot a t cl) = DBusRoot (\p c -> f $ a p c) t cl + fmap f (DBusRoot_ a t cl) = DBusRoot_ (f . a) t cl + -- | The dependency tree with rule to merge results when needed data Tree d d_ p = forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y) @@ -927,12 +943,6 @@ testDBusDepNoCache_ _ (DBusIO i) = testIODepNoCache_ i -- ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a) -- ioSubfeature sf = sf {sfData = ioRoot $ sfData sf} --- ioRoot :: MonadIO m => Root (IO a) -> Root (m a) --- ioRoot (IORoot a t) = IORoot (io . a) t --- ioRoot (IORoot_ a t) = IORoot_ (io a) t --- ioRoot (DBusRoot a t cl) = DBusRoot (\p c -> io $ a p c) t cl --- ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl - -------------------------------------------------------------------------------- -- Feature constructors