Star1.hs

{-# LANGUAGE TupleSections #-}
module Fresnel.Profunctor.Star1
( -- * Star1 profunctor
  Star1(..)
) where

import Data.Functor.Apply
import Data.Functor.Contravariant (Contravariant(..))
import Data.Profunctor
import Fresnel.Bifunctor.Contravariant (Bicontravariant(..))
import Fresnel.Profunctor.Traversing1

-- | Just like 'Data.Profunctor.Star', but with some instances defined in terms of 'Data.Functor.Apply' instead of 'Applicative'. Used by 'Fresnel.Traversal1.Traversal1' & 'Fresnel.Fold1.Fold1'.
newtype Star1 f a b = Star1 { runStar1 :: a -> f b }

instance Functor f => Profunctor (Star1 f) where
  dimap f g (Star1 h) = Star1 (fmap g . h . f)

instance Functor f => Strong (Star1 f) where
  first'  (Star1 h) = Star1 (\ (a, c) -> (,c) <$> h a)
  second' (Star1 h) = Star1 (\ (c, a) -> (c,) <$> h a)

instance Traversable f => Cochoice (Star1 f) where
  unright (Star1 h) = Star1 (go . Right)
    where
    go = either (go . Left) id . sequence . h

instance Apply f => Traversing1 (Star1 f) where
  wander1 f (Star1 h) = Star1 (f h)

instance Contravariant f => Bicontravariant (Star1 f) where
  contrabimap f g (Star1 h) = Star1 (contramap g . h . f)