{-# LANGUAGE DerivingVia #-}
module Data.Functor.Contravariant.Divisible.Free (
Div(.., Conquer, Divide)
, hoistDiv, liftDiv, runDiv
, divListF, listFDiv
, Div1(.., Div1_)
, hoistDiv1, liftDiv1, toDiv, runDiv1
, div1NonEmptyF, nonEmptyFDiv1
, Dec(..)
, hoistDec, liftDec, runDec
, Dec1(..)
, hoistDec1, liftDec1, toDec, runDec1
) where
import Control.Applicative.ListF
import Control.Natural
import Data.Bifunctor
import Data.Bifunctor.Assoc
import Data.Foldable
import Data.Functor.Contravariant
import Data.Functor.Contravariant.Conclude
import Data.Functor.Contravariant.Coyoneda
import Data.Functor.Contravariant.Decide
import Data.Functor.Contravariant.Divise
import Data.Functor.Contravariant.Divisible
import Data.Functor.Invariant
import Data.HFunctor
import Data.HFunctor.Interpret
import Data.Kind
import Data.List.NonEmpty (NonEmpty(..))
import Data.Void
import qualified Control.Monad.Trans.Compose as CT
import qualified Data.Functor.Contravariant.Day as CD
newtype Div f a = Div { unDiv :: [Coyoneda f a] }
deriving (Contravariant, Divise, Divisible) via (ListF (Coyoneda f))
deriving (HFunctor, Inject) via (CT.ComposeT ListF Coyoneda)
instance Invariant (Div f) where
invmap _ = contramap
pattern Conquer :: Div f a
pattern Conquer = Div []
pattern Divide :: (a -> (b, c)) -> f b -> Div f c -> Div f a
pattern Divide f x xs <- (divDay_ -> Just (CD.Day x xs f))
where
Divide f x (Div xs) = Div $ Coyoneda (fst . f) x : (map . contramap) (snd . f) xs
{-# COMPLETE Conquer, Divide #-}
divDay_ :: Div f a -> Maybe (CD.Day f (Div f) a)
divDay_ (Div []) = Nothing
divDay_ (Div (Coyoneda f x : xs)) = Just $ CD.Day x (Div xs) (\y -> (f y, y))
divListF :: forall f. Contravariant f => Div f ~> ListF f
divListF = ListF . map lowerCoyoneda . unDiv
listFDiv :: ListF f ~> Div f
listFDiv = Div . map liftCoyoneda . runListF
hoistDiv :: forall f g. (f ~> g) -> Div f ~> Div g
hoistDiv = hmap
liftDiv :: f ~> Div f
liftDiv = inject
runDiv :: forall f g. Divisible g => (f ~> g) -> Div f ~> g
runDiv f = foldr go conquer . unDiv
where
go (Coyoneda g x) = divide (\y -> (y,y)) (contramap g (f x))
instance Divisible f => Interpret Div f where
interpret = runDiv
newtype Div1 f a = Div1 { unDiv1 :: NonEmpty (Coyoneda f a) }
deriving (Contravariant, Divise) via (NonEmptyF (Coyoneda f))
deriving (HFunctor, Inject) via (CT.ComposeT NonEmptyF Coyoneda)
instance Invariant (Div1 f) where
invmap _ = contramap
instance Divise f => Interpret Div1 f where
interpret = runDiv1
pattern Div1_ :: (a -> (b, c)) -> f b -> Div f c -> Div1 f a
pattern Div1_ f x xs <- (div1_->CD.Day x xs f)
where
Div1_ f x (Div xs) = Div1 $ Coyoneda (fst . f) x :| (map . contramap) (snd . f) xs
{-# COMPLETE Div1_ #-}
div1_ :: Div1 f ~> CD.Day f (Div f)
div1_ (Div1 (Coyoneda g x :| xs)) = CD.Day x (Div xs) (\y -> (g y, y))
toDiv :: Div1 f ~> Div f
toDiv = Div . toList . unDiv1
hoistDiv1 :: (f ~> g) -> Div1 f ~> Div1 g
hoistDiv1 = hmap
liftDiv1 :: f ~> Div1 f
liftDiv1 = inject
runDiv1 :: Divise g => (f ~> g) -> Div1 f ~> g
runDiv1 f = foldr1 (divise (\y->(y,y))) . fmap go . unDiv1
where
go (Coyoneda g x) = contramap g (f x)
div1NonEmptyF :: Contravariant f => Div1 f ~> NonEmptyF f
div1NonEmptyF = NonEmptyF . fmap lowerCoyoneda . unDiv1
nonEmptyFDiv1 :: NonEmptyF f ~> Div1 f
nonEmptyFDiv1 = Div1 . fmap liftCoyoneda . runNonEmptyF
data Dec :: (Type -> Type) -> Type -> Type where
Lose :: (a -> Void) -> Dec f a
Choose :: (a -> Either b c) -> f b -> Dec f c -> Dec f a
instance Contravariant (Dec f) where
contramap f = \case
Lose g -> Lose (g . f)
Choose g x xs -> Choose (g . f) x xs
instance Invariant (Dec f) where
invmap _ = contramap
instance Decide (Dec f) where
decide f = \case
Lose g -> contramap (either (absurd . g) id . f)
Choose g x xs -> Choose (assoc . first g . f) x
. decide id xs
instance Conclude (Dec f) where
conclude = Lose
instance HFunctor Dec where
hmap = hoistDec
instance Inject Dec where
inject = liftDec
instance Conclude f => Interpret Dec f where
interpret = runDec
hoistDec :: forall f g. (f ~> g) -> Dec f ~> Dec g
hoistDec f = go
where
go :: Dec f ~> Dec g
go = \case
Lose g -> Lose g
Choose g x xs -> Choose g (f x) (go xs)
liftDec :: f ~> Dec f
liftDec x = Choose Left x (Lose id)
runDec :: forall f g. Conclude g => (f ~> g) -> Dec f ~> g
runDec f = go
where
go :: Dec f ~> g
go = \case
Lose g -> conclude g
Choose g x xs -> decide g (f x) (go xs)
data Dec1 :: (Type -> Type) -> Type -> Type where
Dec1 :: (a -> Either b c) -> f b -> Dec f c -> Dec1 f a
toDec :: Dec1 f a -> Dec f a
toDec (Dec1 f x xs) = Choose f x xs
instance Contravariant (Dec1 f) where
contramap f (Dec1 g x xs) = Dec1 (g . f) x xs
instance Invariant (Dec1 f) where
invmap _ = contramap
instance Decide (Dec1 f) where
decide f (Dec1 g x xs) = Dec1 (assoc . first g . f) x
. decide id xs
. toDec
instance HFunctor Dec1 where
hmap = hoistDec1
instance Inject Dec1 where
inject = liftDec1
instance Decide f => Interpret Dec1 f where
interpret = runDec1
hoistDec1 :: forall f g. (f ~> g) -> Dec1 f ~> Dec1 g
hoistDec1 f (Dec1 g x xs) = Dec1 g (f x) (hoistDec f xs)
liftDec1 :: f ~> Dec1 f
liftDec1 x = Dec1 Left x (Lose id)
runDec1 :: Decide g => (f ~> g) -> Dec1 f ~> g
runDec1 f (Dec1 g x xs) = runDec1_ f g x xs
runDec1_
:: forall f g a b c. Decide g
=> (f ~> g)
-> (a -> Either b c)
-> f b
-> Dec f c
-> g a
runDec1_ f = go
where
go :: (x -> Either y z) -> f y -> Dec f z -> g x
go g x = \case
Lose h -> contramap (either id (absurd . h) . g) (f x)
Choose h y ys -> decide g (f x) (go h y ys)