{-# OPTIONS_GHC -fno-warn-unused-matches #-}
{-# LANGUAGE
RankNTypes
, TypeOperators
, ConstraintKinds
, TemplateHaskell
, UndecidableInstances
, QuantifiedConstraints
#-}
module Data.Functor.HHFree where
import Prelude hiding ((.), id)
import Control.Arrow
import Control.Category
import Data.Bifunctor (Bifunctor)
import Data.Bifunctor.Functor
import Data.Biapplicative (Biapplicative)
import Data.Profunctor
import Data.Profunctor.Monad
import Language.Haskell.TH.Syntax (Q, Name, Dec)
import Data.Functor.Free.Internal
type f :~~> g = forall a b. f a b -> g a b
newtype HHFree c f a b = HHFree { forall (c :: (* -> * -> *) -> Constraint) (f :: * -> * -> *) a b.
HHFree c f a b
-> forall (g :: * -> * -> *). c g => (f :~~> g) -> g a b
runHHFree :: forall g. c g => (f :~~> g) -> g a b }
deriveHHFreeInstance :: Name -> Q [Dec]
deriveHHFreeInstance :: Name -> Q [Dec]
deriveHHFreeInstance = Name -> Name -> Name -> Name -> Q [Dec]
deriveFreeInstance' ''HHFree 'HHFree 'runHHFree
unit :: f :~~> HHFree c f
unit :: forall (f :: * -> * -> *) (c :: (* -> * -> *) -> Constraint).
f :~~> HHFree c f
unit f a b
fa = (forall (g :: * -> * -> *). c g => (f :~~> g) -> g a b)
-> HHFree c f a b
forall (c :: (* -> * -> *) -> Constraint) (f :: * -> * -> *) a b.
(forall (g :: * -> * -> *). c g => (f :~~> g) -> g a b)
-> HHFree c f a b
HHFree ((forall (g :: * -> * -> *). c g => (f :~~> g) -> g a b)
-> HHFree c f a b)
-> (forall (g :: * -> * -> *). c g => (f :~~> g) -> g a b)
-> HHFree c f a b
forall a b. (a -> b) -> a -> b
$ \f :~~> g
k -> f a b -> g a b
f :~~> g
k f a b
fa
rightAdjunct :: c g => (f :~~> g) -> HHFree c f :~~> g
rightAdjunct :: forall (c :: (* -> * -> *) -> Constraint) (g :: * -> * -> *)
(f :: * -> * -> *).
c g =>
(f :~~> g) -> HHFree c f :~~> g
rightAdjunct f :~~> g
f HHFree c f a b
h = HHFree c f a b
-> forall (g :: * -> * -> *). c g => (f :~~> g) -> g a b
forall (c :: (* -> * -> *) -> Constraint) (f :: * -> * -> *) a b.
HHFree c f a b
-> forall (g :: * -> * -> *). c g => (f :~~> g) -> g a b
runHHFree HHFree c f a b
h f :~~> g
f
counit :: c f => HHFree c f :~~> f
counit :: forall (c :: (* -> * -> *) -> Constraint) (f :: * -> * -> *).
c f =>
HHFree c f :~~> f
counit = (f :~~> f) -> HHFree c f :~~> f
forall (c :: (* -> * -> *) -> Constraint) (g :: * -> * -> *)
(f :: * -> * -> *).
c g =>
(f :~~> g) -> HHFree c f :~~> g
rightAdjunct f :~~> f
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
leftAdjunct :: (HHFree c f :~~> g) -> f :~~> g
leftAdjunct :: forall (c :: (* -> * -> *) -> Constraint) (f :: * -> * -> *)
(g :: * -> * -> *).
(HHFree c f :~~> g) -> f :~~> g
leftAdjunct HHFree c f :~~> g
f = HHFree c f a b -> g a b
HHFree c f :~~> g
f (HHFree c f a b -> g a b)
-> (f a b -> HHFree c f a b) -> f a b -> g a b
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. f a b -> HHFree c f a b
forall (f :: * -> * -> *) (c :: (* -> * -> *) -> Constraint).
f :~~> HHFree c f
unit
transform :: (forall r. c r => (g :~~> r) -> f :~~> r) -> HHFree c f :~~> HHFree c g
transform :: forall (c :: (* -> * -> *) -> Constraint) (g :: * -> * -> *)
(f :: * -> * -> *).
(forall (r :: * -> * -> *). c r => (g :~~> r) -> f :~~> r)
-> HHFree c f :~~> HHFree c g
transform forall (r :: * -> * -> *). c r => (g :~~> r) -> f :~~> r
t HHFree c f a b
h = (forall (g :: * -> * -> *). c g => (g :~~> g) -> g a b)
-> HHFree c g a b
forall (c :: (* -> * -> *) -> Constraint) (f :: * -> * -> *) a b.
(forall (g :: * -> * -> *). c g => (f :~~> g) -> g a b)
-> HHFree c f a b
HHFree ((forall (g :: * -> * -> *). c g => (g :~~> g) -> g a b)
-> HHFree c g a b)
-> (forall (g :: * -> * -> *). c g => (g :~~> g) -> g a b)
-> HHFree c g a b
forall a b. (a -> b) -> a -> b
$ \g :~~> g
k -> (f :~~> g) -> HHFree c f :~~> g
forall (c :: (* -> * -> *) -> Constraint) (g :: * -> * -> *)
(f :: * -> * -> *).
c g =>
(f :~~> g) -> HHFree c f :~~> g
rightAdjunct ((g :~~> g) -> f :~~> g
forall (r :: * -> * -> *). c r => (g :~~> r) -> f :~~> r
t g :~~> g
k) HHFree c f a b
h
hfmap :: (f :~~> g) -> HHFree c f :~~> HHFree c g
hfmap :: forall (f :: * -> * -> *) (g :: * -> * -> *)
(c :: (* -> * -> *) -> Constraint).
(f :~~> g) -> HHFree c f :~~> HHFree c g
hfmap f :~~> g
f = (forall (r :: * -> * -> *). c r => (g :~~> r) -> f :~~> r)
-> HHFree c f :~~> HHFree c g
forall (c :: (* -> * -> *) -> Constraint) (g :: * -> * -> *)
(f :: * -> * -> *).
(forall (r :: * -> * -> *). c r => (g :~~> r) -> f :~~> r)
-> HHFree c f :~~> HHFree c g
transform (\g :~~> r
g -> g a b -> r a b
g :~~> r
g (g a b -> r a b) -> (f a b -> g a b) -> f a b -> r a b
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. f a b -> g a b
f :~~> g
f)
bind :: (f :~~> HHFree c g) -> HHFree c f :~~> HHFree c g
bind :: forall (f :: * -> * -> *) (c :: (* -> * -> *) -> Constraint)
(g :: * -> * -> *).
(f :~~> HHFree c g) -> HHFree c f :~~> HHFree c g
bind f :~~> HHFree c g
f = (forall (r :: * -> * -> *). c r => (g :~~> r) -> f :~~> r)
-> HHFree c f :~~> HHFree c g
forall (c :: (* -> * -> *) -> Constraint) (g :: * -> * -> *)
(f :: * -> * -> *).
(forall (r :: * -> * -> *). c r => (g :~~> r) -> f :~~> r)
-> HHFree c f :~~> HHFree c g
transform (\g :~~> r
k -> (g :~~> r) -> HHFree c g :~~> r
forall (c :: (* -> * -> *) -> Constraint) (g :: * -> * -> *)
(f :: * -> * -> *).
c g =>
(f :~~> g) -> HHFree c f :~~> g
rightAdjunct g :~~> r
k (HHFree c g a b -> r a b)
-> (f a b -> HHFree c g a b) -> f a b -> r a b
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. f a b -> HHFree c g a b
f :~~> HHFree c g
f)
instance BifunctorFunctor (HHFree c) where
bifmap :: forall (p :: * -> * -> *) (q :: * -> * -> *).
(p :-> q) -> HHFree c p :-> HHFree c q
bifmap = (p :~~> q) -> HHFree c p :~~> HHFree c q
forall (f :: * -> * -> *) (g :: * -> * -> *)
(c :: (* -> * -> *) -> Constraint).
(f :~~> g) -> HHFree c f :~~> HHFree c g
hfmap
instance BifunctorMonad (HHFree c) where
bireturn :: forall (p :: * -> * -> *). p :-> HHFree c p
bireturn = p a b -> HHFree c p a b
forall (f :: * -> * -> *) (c :: (* -> * -> *) -> Constraint).
f :~~> HHFree c f
unit
bibind :: forall (p :: * -> * -> *) (q :: * -> * -> *).
(p :-> HHFree c q) -> HHFree c p :-> HHFree c q
bibind = (p :~~> HHFree c q) -> HHFree c p :~~> HHFree c q
forall (f :: * -> * -> *) (c :: (* -> * -> *) -> Constraint)
(g :: * -> * -> *).
(f :~~> HHFree c g) -> HHFree c f :~~> HHFree c g
bind
instance ProfunctorFunctor (HHFree c) where
promap :: forall (p :: * -> * -> *) (q :: * -> * -> *).
Profunctor p =>
(p :-> q) -> HHFree c p :-> HHFree c q
promap = (p :~~> q) -> HHFree c p :~~> HHFree c q
forall (f :: * -> * -> *) (g :: * -> * -> *)
(c :: (* -> * -> *) -> Constraint).
(f :~~> g) -> HHFree c f :~~> HHFree c g
hfmap
instance ProfunctorMonad (HHFree c) where
proreturn :: forall (p :: * -> * -> *). Profunctor p => p :-> HHFree c p
proreturn = p a b -> HHFree c p a b
forall (f :: * -> * -> *) (c :: (* -> * -> *) -> Constraint).
f :~~> HHFree c f
unit
projoin :: forall (p :: * -> * -> *).
Profunctor p =>
HHFree c (HHFree c p) :-> HHFree c p
projoin = (HHFree c p :~~> HHFree c p)
-> HHFree c (HHFree c p) :~~> HHFree c p
forall (f :: * -> * -> *) (c :: (* -> * -> *) -> Constraint)
(g :: * -> * -> *).
(f :~~> HHFree c g) -> HHFree c f :~~> HHFree c g
bind HHFree c p :~~> HHFree c p
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Category
deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Arrow
deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''ArrowZero
deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''ArrowPlus
deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''ArrowChoice
deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''ArrowLoop
instance (c ~=> ArrowApply, c (HHFree c f)) => ArrowApply (HHFree c f) where
app :: forall b c. HHFree c f (HHFree c f b c, b) c
app = (forall (g :: * -> * -> *).
c g =>
(f :~~> g) -> g (HHFree c f b c, b) c)
-> HHFree c f (HHFree c f b c, b) c
forall (c :: (* -> * -> *) -> Constraint) (f :: * -> * -> *) a b.
(forall (g :: * -> * -> *). c g => (f :~~> g) -> g a b)
-> HHFree c f a b
HHFree ((forall (g :: * -> * -> *).
c g =>
(f :~~> g) -> g (HHFree c f b c, b) c)
-> HHFree c f (HHFree c f b c, b) c)
-> (forall (g :: * -> * -> *).
c g =>
(f :~~> g) -> g (HHFree c f b c, b) c)
-> HHFree c f (HHFree c f b c, b) c
forall a b. (a -> b) -> a -> b
$ \f :~~> g
k -> g (g b c, b) c
forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app g (g b c, b) c
-> g (HHFree c f b c, b) (g b c, b) -> g (HHFree c f b c, b) c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((HHFree c f b c, b) -> (g b c, b))
-> g (HHFree c f b c, b) (g b c, b)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\(HHFree c f b c
a, b
b) -> ((f :~~> g) -> HHFree c f :~~> g
forall (c :: (* -> * -> *) -> Constraint) (g :: * -> * -> *)
(f :: * -> * -> *).
c g =>
(f :~~> g) -> HHFree c f :~~> g
rightAdjunct f :~~> g
k HHFree c f b c
a, b
b))
deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Bifunctor
deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Biapplicative
deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Profunctor
deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Strong
deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Choice
deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Closed