module Control.Joint.Effects.Writer where import Control.Applicative (Alternative (empty, (<|>))) import Control.Joint.Operators ((<$$>), (<**>)) import Control.Joint.Abilities.Interpreted (Interpreted (Primary, run)) import Control.Joint.Abilities.Transformer (Transformer (build, unite), Schema, (:>) (T)) import Control.Joint.Abilities.Adaptable (Adaptable (adapt)) import Control.Joint.Schemes (UT (UT), type (<.:>) ) newtype Writer e a = Writer (e, a) instance Functor (Writer e) where fmap :: (a -> b) -> Writer e a -> Writer e b fmap a -> b f (Writer (e, a) x) = (e, b) -> Writer e b forall e a. (e, a) -> Writer e a Writer ((e, b) -> Writer e b) -> (e, b) -> Writer e b forall a b. (a -> b) -> a -> b $ a -> b f (a -> b) -> (e, a) -> (e, b) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (e, a) x instance Monoid e => Applicative (Writer e) where pure :: a -> Writer e a pure = (e, a) -> Writer e a forall e a. (e, a) -> Writer e a Writer ((e, a) -> Writer e a) -> (a -> (e, a)) -> a -> Writer e a forall b c a. (b -> c) -> (a -> b) -> a -> c . (,) e forall a. Monoid a => a mempty Writer e (a -> b) f <*> :: Writer e (a -> b) -> Writer e a -> Writer e b <*> Writer e a v = (e, b) -> Writer e b forall e a. (e, a) -> Writer e a Writer ((e, b) -> Writer e b) -> (e, b) -> Writer e b forall a b. (a -> b) -> a -> b $ (e, a -> b) -> (e, a) -> (e, b) forall a t b. Semigroup a => (a, t -> b) -> (a, t) -> (a, b) k (Writer e (a -> b) -> Primary (Writer e) (a -> b) forall (t :: * -> *) a. Interpreted t => t a -> Primary t a run Writer e (a -> b) f) (Writer e a -> Primary (Writer e) a forall (t :: * -> *) a. Interpreted t => t a -> Primary t a run Writer e a v) where k :: (a, t -> b) -> (a, t) -> (a, b) k ~(a e, t -> b a) ~(a e', t b) = (a e a -> a -> a forall a. Semigroup a => a -> a -> a <> a e', t -> b a t b) instance Monoid e => Monad (Writer e) where Writer (e e, a x) >>= :: Writer e a -> (a -> Writer e b) -> Writer e b >>= a -> Writer e b f = let (e e', b b) = Writer e b -> Primary (Writer e) b forall (t :: * -> *) a. Interpreted t => t a -> Primary t a run (Writer e b -> Primary (Writer e) b) -> Writer e b -> Primary (Writer e) b forall a b. (a -> b) -> a -> b $ a -> Writer e b f a x in (e, b) -> Writer e b forall e a. (e, a) -> Writer e a Writer (e e e -> e -> e forall a. Semigroup a => a -> a -> a <> e e', b b) instance Interpreted (Writer e) where type Primary (Writer e) a = (e, a) run :: Writer e a -> Primary (Writer e) a run (Writer (e, a) x) = (e, a) Primary (Writer e) a x type instance Schema (Writer e) = UT ((,) e) instance Monoid e => Transformer (Writer e) where build :: Writer e ~> (Writer e :> u) build = UT ((,) e) u a -> (:>) (Writer e) u a forall (t :: * -> *) (u :: * -> *) a. (Transformer t => Schema t u a) -> (:>) t u a T (UT ((,) e) u a -> (:>) (Writer e) u a) -> (Writer e a -> UT ((,) e) u a) -> Writer e a -> (:>) (Writer e) u a forall b c a. (b -> c) -> (a -> b) -> a -> c . ((u :. (,) e) := a) -> UT ((,) e) u a forall k k (t :: k -> k) (u :: k -> *) (a :: k). ((u :. t) := a) -> UT t u a UT (((u :. (,) e) := a) -> UT ((,) e) u a) -> (Writer e a -> (u :. (,) e) := a) -> Writer e a -> UT ((,) e) u a forall b c a. (b -> c) -> (a -> b) -> a -> c . (e, a) -> (u :. (,) e) := a forall (f :: * -> *) a. Applicative f => a -> f a pure ((e, a) -> (u :. (,) e) := a) -> (Writer e a -> (e, a)) -> Writer e a -> (u :. (,) e) := a forall b c a. (b -> c) -> (a -> b) -> a -> c . Writer e a -> (e, a) forall (t :: * -> *) a. Interpreted t => t a -> Primary t a run unite :: Primary (Schema (Writer e) u) a -> (:>) (Writer e) u a unite = UT ((,) e) u a -> (:>) (Writer e) u a forall (t :: * -> *) (u :: * -> *) a. (Transformer t => Schema t u a) -> (:>) t u a T (UT ((,) e) u a -> (:>) (Writer e) u a) -> (((u :. (,) e) := a) -> UT ((,) e) u a) -> ((u :. (,) e) := a) -> (:>) (Writer e) u a forall b c a. (b -> c) -> (a -> b) -> a -> c . ((u :. (,) e) := a) -> UT ((,) e) u a forall k k (t :: k -> k) (u :: k -> *) (a :: k). ((u :. t) := a) -> UT t u a UT instance Functor u => Functor ((,) e <.:> u) where fmap :: (a -> b) -> (<.:>) ((,) e) u a -> (<.:>) ((,) e) u b fmap a -> b f (UT (u :. (,) e) := a x) = ((u :. (,) e) := b) -> (<.:>) ((,) e) u b forall k k (t :: k -> k) (u :: k -> *) (a :: k). ((u :. t) := a) -> UT t u a UT (((u :. (,) e) := b) -> (<.:>) ((,) e) u b) -> ((u :. (,) e) := b) -> (<.:>) ((,) e) u b forall a b. (a -> b) -> a -> b $ a -> b f (a -> b) -> ((u :. (,) e) := a) -> (u :. (,) e) := b forall (t :: * -> *) (u :: * -> *) a b. (Functor t, Functor u) => (a -> b) -> ((t :. u) := a) -> (t :. u) := b <$$> (u :. (,) e) := a x instance (Monoid e, Applicative u) => Applicative ((,) e <.:> u) where pure :: a -> (<.:>) ((,) e) u a pure = ((u :. (,) e) := a) -> (<.:>) ((,) e) u a forall k k (t :: k -> k) (u :: k -> *) (a :: k). ((u :. t) := a) -> UT t u a UT (((u :. (,) e) := a) -> (<.:>) ((,) e) u a) -> (a -> (u :. (,) e) := a) -> a -> (<.:>) ((,) e) u a forall b c a. (b -> c) -> (a -> b) -> a -> c . (e, a) -> (u :. (,) e) := a forall (f :: * -> *) a. Applicative f => a -> f a pure ((e, a) -> (u :. (,) e) := a) -> (a -> (e, a)) -> a -> (u :. (,) e) := a forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> (e, a) forall (f :: * -> *) a. Applicative f => a -> f a pure UT (u :. (,) e) := (a -> b) f <*> :: (<.:>) ((,) e) u (a -> b) -> (<.:>) ((,) e) u a -> (<.:>) ((,) e) u b <*> UT (u :. (,) e) := a x = ((u :. (,) e) := b) -> (<.:>) ((,) e) u b forall k k (t :: k -> k) (u :: k -> *) (a :: k). ((u :. t) := a) -> UT t u a UT (((u :. (,) e) := b) -> (<.:>) ((,) e) u b) -> ((u :. (,) e) := b) -> (<.:>) ((,) e) u b forall a b. (a -> b) -> a -> b $ (u :. (,) e) := (a -> b) f ((u :. (,) e) := (a -> b)) -> ((u :. (,) e) := a) -> (u :. (,) e) := b forall (t :: * -> *) (u :: * -> *) a b. (Applicative t, Applicative u) => ((t :. u) := (a -> b)) -> ((t :. u) := a) -> (t :. u) := b <**> (u :. (,) e) := a x instance (Monoid e, Alternative u) => Alternative ((,) e <.:> u) where (<.:>) ((,) e) u a x <|> :: (<.:>) ((,) e) u a -> (<.:>) ((,) e) u a -> (<.:>) ((,) e) u a <|> (<.:>) ((,) e) u a y = ((u :. (,) e) := a) -> (<.:>) ((,) e) u a forall k k (t :: k -> k) (u :: k -> *) (a :: k). ((u :. t) := a) -> UT t u a UT (((u :. (,) e) := a) -> (<.:>) ((,) e) u a) -> ((u :. (,) e) := a) -> (<.:>) ((,) e) u a forall a b. (a -> b) -> a -> b $ (<.:>) ((,) e) u a -> Primary ((,) e <.:> u) a forall (t :: * -> *) a. Interpreted t => t a -> Primary t a run (<.:>) ((,) e) u a x ((u :. (,) e) := a) -> ((u :. (,) e) := a) -> (u :. (,) e) := a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> (<.:>) ((,) e) u a -> Primary ((,) e <.:> u) a forall (t :: * -> *) a. Interpreted t => t a -> Primary t a run (<.:>) ((,) e) u a y empty :: (<.:>) ((,) e) u a empty = ((u :. (,) e) := a) -> (<.:>) ((,) e) u a forall k k (t :: k -> k) (u :: k -> *) (a :: k). ((u :. t) := a) -> UT t u a UT (u :. (,) e) := a forall (f :: * -> *) a. Alternative f => f a empty instance (Monoid e, Applicative u, Monad u) => Monad ((,) e <.:> u) where UT (u :. (,) e) := a x >>= :: (<.:>) ((,) e) u a -> (a -> (<.:>) ((,) e) u b) -> (<.:>) ((,) e) u b >>= a -> (<.:>) ((,) e) u b f = ((u :. (,) e) := b) -> (<.:>) ((,) e) u b forall k k (t :: k -> k) (u :: k -> *) (a :: k). ((u :. t) := a) -> UT t u a UT (((u :. (,) e) := b) -> (<.:>) ((,) e) u b) -> ((u :. (,) e) := b) -> (<.:>) ((,) e) u b forall a b. (a -> b) -> a -> b $ (u :. (,) e) := a x ((u :. (,) e) := a) -> ((e, a) -> (u :. (,) e) := b) -> (u :. (,) e) := b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \(e acc, a v) -> (\(e acc', b y) -> (e acc e -> e -> e forall a. Semigroup a => a -> a -> a <> e acc', b y)) ((e, b) -> (e, b)) -> ((u :. (,) e) := b) -> (u :. (,) e) := b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (<.:>) ((,) e) u b -> Primary ((,) e <.:> u) b forall (t :: * -> *) a. Interpreted t => t a -> Primary t a run (a -> (<.:>) ((,) e) u b f a v) type Accumulated e t = Adaptable (Writer e) t add :: Accumulated e t => e -> t () add :: e -> t () add e s = Writer e () -> t () forall (eff :: * -> *) (schema :: * -> *). Adaptable eff schema => eff ~> schema adapt (Writer e () -> t ()) -> Writer e () -> t () forall a b. (a -> b) -> a -> b $ (e, ()) -> Writer e () forall e a. (e, a) -> Writer e a Writer (e s, ())