module Data.Profunctor.Traced where

import Data.Profunctor
import Data.Bifunctor (first)

data Traced m a b = Traced ((a, m) -> b)

instance Profunctor (Traced m) where
  dimap :: (a -> b) -> (c -> d) -> Traced m b c -> Traced m a d
dimap f :: a -> b
f g :: c -> d
g (Traced t :: (b, m) -> c
t) = ((a, m) -> d) -> Traced m a d
forall m a b. ((a, m) -> b) -> Traced m a b
Traced (c -> d
g (c -> d) -> ((a, m) -> c) -> (a, m) -> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b, m) -> c
t ((b, m) -> c) -> ((a, m) -> (b, m)) -> (a, m) -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> (a, m) -> (b, m)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a -> b
f)

instance Strong (Traced m) where
  first' :: Traced m a b -> Traced m (a, c) (b, c)
first' (Traced t :: (a, m) -> b
t) = (((a, c), m) -> (b, c)) -> Traced m (a, c) (b, c)
forall m a b. ((a, m) -> b) -> Traced m a b
Traced (((a, m) -> b) -> ((a, m), c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Strong p =>
p a b -> p (a, c) (b, c)
first' (a, m) -> b
t (((a, m), c) -> (b, c))
-> (((a, c), m) -> ((a, m), c)) -> ((a, c), m) -> (b, c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, c), m) -> ((a, m), c)
forall a b b. ((a, b), b) -> ((a, b), b)
reassoc)
    where
      reassoc :: ((a, b), b) -> ((a, b), b)
reassoc ((a :: a
a, c :: b
c), m :: b
m) = ((a
a, b
m), b
c)

instance Choice (Traced m) where
  left' :: Traced m a b -> Traced m (Either a c) (Either b c)
left' (Traced t :: (a, m) -> b
t) = ((Either a c, m) -> Either b c)
-> Traced m (Either a c) (Either b c)
forall m a b. ((a, m) -> b) -> Traced m a b
Traced (((a, m) -> b) -> Either (a, m) c -> Either b c
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either a c) (Either b c)
left' (a, m) -> b
t (Either (a, m) c -> Either b c)
-> ((Either a c, m) -> Either (a, m) c)
-> (Either a c, m)
-> Either b c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either a c, m) -> Either (a, m) c
forall a b b. (Either a b, b) -> Either (a, b) b
reassoc)
    where
      reassoc :: (Either a b, b) -> Either (a, b) b
reassoc (Left a :: a
a, m :: b
m) = (a, b) -> Either (a, b) b
forall a b. a -> Either a b
Left (a
a, b
m)
      reassoc (Right c :: b
c, _) = b -> Either (a, b) b
forall a b. b -> Either a b
Right b
c

extractTraced :: Monoid m => Traced m a b -> a -> b
extractTraced :: Traced m a b -> a -> b
extractTraced (Traced t :: (a, m) -> b
t) a :: a
a = (a, m) -> b
t (a
a, m
forall a. Monoid a => a
mempty)

-- extend :: Semigroup m => (Traced m x a -> b) -> Traced m x a -> Traced m x b
-- extend f (Traced t) = Traced go
--   where
--     go (x, m) = f $ Traced (\(x, m') -> t (x, m <> m'))