{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Data.HBifunctor.Associative (
Associative(..)
, assoc
, disassoc
, Semigroupoidal(..)
, CS
, matchingSF
, biget
, bicollect
, (!*!)
, (!$!)
) where
import Control.Applicative
import Control.Applicative.ListF
import Control.Applicative.Step
import Control.Monad.Freer.Church
import Control.Monad.Trans.Compose
import Control.Natural
import Control.Natural.IsoF
import Data.Bifunctor.Joker
import Data.Coerce
import Data.Data
import Data.Foldable
import Data.Functor.Apply.Free
import Data.Functor.Bind
import Data.Functor.Day (Day(..))
import Data.Functor.Identity
import Data.Functor.Plus
import Data.Functor.Product
import Data.Functor.Sum
import Data.Functor.These
import Data.HBifunctor
import Data.HFunctor
import Data.HFunctor.Internal
import Data.HFunctor.Interpret
import Data.Kind
import Data.List.NonEmpty (NonEmpty(..))
import GHC.Generics hiding (C)
import qualified Data.Functor.Day as D
import qualified Data.Map.NonEmpty as NEM
class HBifunctor t => Associative t where
associating
:: (Functor f, Functor g, Functor h)
=> t f (t g h) <~> t (t f g) h
{-# MINIMAL associating #-}
assoc
:: (Associative t, Functor f, Functor g, Functor h)
=> t f (t g h)
~> t (t f g) h
assoc = viewF associating
disassoc
:: (Associative t, Functor f, Functor g, Functor h)
=> t (t f g) h
~> t f (t g h)
disassoc = reviewF associating
class (Associative t, Interpret (SF t)) => Semigroupoidal t where
type SF t :: (Type -> Type) -> Type -> Type
appendSF :: t (SF t f) (SF t f) ~> SF t f
matchSF :: Functor f => SF t f ~> f :+: t f (SF t f)
consSF :: t f (SF t f) ~> SF t f
consSF = appendSF . hleft inject
toSF :: t f f ~> SF t f
toSF = consSF . hright inject
biretract :: CS t f => t f f ~> f
biretract = retract . toSF
binterpret
:: CS t h
=> f ~> h
-> g ~> h
-> t f g ~> h
binterpret f g = retract . toSF . hbimap f g
{-# MINIMAL appendSF, matchSF #-}
type CS t = C (SF t)
matchingSF :: (Semigroupoidal t, Functor f) => SF t f <~> f :+: t f (SF t f)
matchingSF = isoF matchSF (inject !*! consSF)
biget
:: (Semigroupoidal t, CS t (Const b))
=> (forall x. f x -> b)
-> (forall x. g x -> b)
-> t f g a
-> b
biget f g = getConst . binterpret (Const . f) (Const . g)
(!$!)
:: (Semigroupoidal t, CS t (Const b))
=> (forall x. f x -> b)
-> (forall x. g x -> b)
-> t f g a
-> b
(!$!) = biget
infixr 5 !$!
(!*!)
:: (Semigroupoidal t, CS t h)
=> (f ~> h)
-> (g ~> h)
-> t f g
~> h
(!*!) = binterpret
infixr 5 !*!
bicollect
:: (Semigroupoidal t, CS t (Const [b]))
=> (forall x. f x -> b)
-> (forall x. g x -> b)
-> t f g a
-> [b]
bicollect f g = biget ((:[]) . f) ((:[]) . g)
instance Associative (:*:) where
associating = isoF to_ from_
where
to_ (x :*: (y :*: z)) = (x :*: y) :*: z
from_ ((x :*: y) :*: z) = x :*: (y :*: z)
instance Associative Product where
associating = isoF to_ from_
where
to_ (Pair x (Pair y z)) = Pair (Pair x y) z
from_ (Pair (Pair x y) z) = Pair x (Pair y z)
instance Associative Day where
associating = isoF D.assoc D.disassoc
instance Associative (:+:) where
associating = isoF to_ from_
where
to_ = \case
L1 x -> L1 (L1 x)
R1 (L1 y) -> L1 (R1 y)
R1 (R1 z) -> R1 z
from_ = \case
L1 (L1 x) -> L1 x
L1 (R1 y) -> R1 (L1 y)
R1 z -> R1 (R1 z)
instance Associative Sum where
associating = isoF to_ from_
where
to_ = \case
InL x -> InL (InL x)
InR (InL y) -> InL (InR y)
InR (InR z) -> InR z
from_ = \case
InL (InL x) -> InL x
InL (InR y) -> InR (InL y)
InR z -> InR (InR z)
instance Associative These1 where
associating = isoF to_ from_
where
to_ = \case
This1 x -> This1 (This1 x )
That1 (This1 y ) -> This1 (That1 y)
That1 (That1 z) -> That1 z
That1 (These1 y z) -> These1 (That1 y) z
These1 x (This1 y ) -> This1 (These1 x y)
These1 x (That1 z) -> These1 (This1 x ) z
These1 x (These1 y z) -> These1 (These1 x y) z
from_ = \case
This1 (This1 x ) -> This1 x
This1 (That1 y) -> That1 (This1 y )
This1 (These1 x y) -> These1 x (This1 y )
That1 z -> That1 (That1 z)
These1 (This1 x ) z -> These1 x (That1 z)
These1 (That1 y) z -> That1 (These1 y z)
These1 (These1 x y) z -> These1 x (These1 y z)
instance Associative Void3 where
associating = isoF coerce coerce
instance Associative Comp where
associating = isoF to_ from_
where
to_ (x :>>= y) = (x :>>= (unComp . y)) :>>= id
from_ ((x :>>= y) :>>= z) = x :>>= ((:>>= z) . y)
instance Semigroupoidal (:*:) where
type SF (:*:) = NonEmptyF
appendSF (NonEmptyF xs :*: NonEmptyF ys) = NonEmptyF (xs <> ys)
matchSF x = case ys of
L1 ~Proxy -> L1 y
R1 zs -> R1 $ y :*: zs
where
y :*: ys = fromListF `hright` nonEmptyProd x
consSF (x :*: NonEmptyF xs) = NonEmptyF $ x :| toList xs
toSF (x :*: y ) = NonEmptyF $ x :| [y]
biretract (x :*: y) = x <!> y
binterpret f g (x :*: y) = f x <!> g y
instance Semigroupoidal Product where
type SF Product = NonEmptyF
appendSF (NonEmptyF xs `Pair` NonEmptyF ys) = NonEmptyF (xs <> ys)
matchSF x = case ys of
L1 ~Proxy -> L1 y
R1 zs -> R1 $ Pair y zs
where
y :*: ys = fromListF `hright` nonEmptyProd x
consSF (x `Pair` NonEmptyF xs) = NonEmptyF $ x :| toList xs
toSF (x `Pair` y ) = NonEmptyF $ x :| [y]
biretract (Pair x y) = x <!> y
binterpret f g (Pair x y) = f x <!> g y
instance Semigroupoidal Day where
type SF Day = Ap1
appendSF (Day x y z) = z <$> x <.> y
matchSF a = case fromAp `hright` ap1Day a of
Day x y z -> case y of
L1 (Identity y') -> L1 $ (`z` y') <$> x
R1 ys -> R1 $ Day x ys z
consSF (Day x y z) = Ap1 x $ flip z <$> toAp y
toSF (Day x y z) = z <$> inject x <.> inject y
biretract (Day x y z) = z <$> x <.> y
binterpret f g (Day x y z) = z <$> f x <.> g y
instance Semigroupoidal (:+:) where
type SF (:+:) = Step
appendSF = \case
L1 (Step i x) -> Step (i + 1) x
R1 (Step i y) -> Step (i + 2) y
matchSF = hright stepDown . stepDown
consSF = stepUp . R1 . stepUp
toSF = \case
L1 x -> Step 1 x
R1 y -> Step 2 y
biretract = \case
L1 x -> x
R1 y -> y
binterpret f g = \case
L1 x -> f x
R1 y -> g y
instance Semigroupoidal Sum where
type SF Sum = Step
appendSF = \case
InL (Step i x) -> Step (i + 1) x
InR (Step i y) -> Step (i + 2) y
matchSF = hright (viewF sumSum . stepDown) . stepDown
consSF = stepUp . R1 . stepUp . reviewF sumSum
toSF = \case
InL x -> Step 1 x
InR y -> Step 2 y
biretract = \case
InR x -> x
InL y -> y
binterpret f g = \case
InL x -> f x
InR y -> g y
instance Semigroupoidal These1 where
type SF These1 = ComposeT Flagged Steps
appendSF s = ComposeT $ case s of
This1 (ComposeT (Flagged _ q)) ->
Flagged True q
That1 (ComposeT (Flagged b q)) ->
Flagged b (stepsUp (That1 q))
These1 (ComposeT (Flagged a q)) (ComposeT (Flagged b r)) ->
Flagged (a || b) (q <> r)
matchSF (ComposeT (Flagged isImpure q)) = case stepsDown q of
This1 x
| isImpure -> R1 $ This1 x
| otherwise -> L1 x
That1 y -> R1 . That1 . ComposeT $ Flagged isImpure y
These1 x y -> R1 . These1 x . ComposeT $ Flagged isImpure y
consSF s = ComposeT $ case s of
This1 x -> Flagged True (inject x)
That1 (ComposeT (Flagged b y)) -> Flagged b (stepsUp (That1 y))
These1 x (ComposeT (Flagged b y)) -> Flagged b (stepsUp (These1 x y))
toSF s = ComposeT $ case s of
This1 x -> Flagged True . Steps $ NEM.singleton 0 x
That1 y -> Flagged False . Steps $ NEM.singleton 1 y
These1 x y -> Flagged False . Steps $ NEM.fromDistinctAscList $ (0, x) :| [(1, y)]
biretract = \case
This1 x -> x
That1 y -> y
These1 x y -> x <!> y
binterpret f g = \case
This1 x -> f x
That1 y -> g y
These1 x y -> f x <!> g y
instance Semigroupoidal Comp where
type SF Comp = Free1
appendSF (x :>>= y) = x >>- y
matchSF = matchFree1
consSF (x :>>= y) = liftFree1 x >>- y
toSF (x :>>= g) = liftFree1 x >>- inject . g
biretract (x :>>= y) = x >>- y
binterpret f g (x :>>= y) = f x >>- (g . y)
instance Associative Joker where
associating = isoF (Joker . Joker . runJoker)
(Joker . runJoker . runJoker)
instance Associative LeftF where
associating = isoF (LeftF . LeftF . runLeftF)
(LeftF . runLeftF . runLeftF)
instance Associative RightF where
associating = isoF (RightF . runRightF . runRightF)
(RightF . RightF . runRightF)
instance Semigroupoidal Joker where
type SF Joker = Flagged
appendSF (Joker (Flagged _ x)) = Flagged True x
matchSF (Flagged False x) = L1 x
matchSF (Flagged True x) = R1 $ Joker x
instance Semigroupoidal LeftF where
type SF LeftF = Flagged
appendSF = hbind (Flagged True) . runLeftF
matchSF (Flagged False x) = L1 x
matchSF (Flagged True x) = R1 $ LeftF x
consSF = Flagged True . runLeftF
toSF = Flagged True . runLeftF
biretract = runLeftF
binterpret f _ = f . runLeftF
instance Semigroupoidal RightF where
type SF RightF = Step
appendSF = stepUp . R1 . runRightF
matchSF = hright RightF . stepDown
consSF = stepUp . R1 . runRightF
toSF = Step 1 . runRightF
biretract = runRightF
binterpret _ g = g . runRightF