{-# LANGUAGE
FlexibleInstances
, GADTs
, LambdaCase
, MultiParamTypeClasses
, PatternSynonyms
, PolyKinds
, QuantifiedConstraints
, RankNTypes
, StandaloneDeriving
#-}
module Control.Category.Free
( Path (..)
, pattern (:<<)
, FoldPath (..)
, Category (..)
, CFunctor (..)
, CFoldable (..)
, CTraversable (..)
, CFree (..)
, toPath
, EndoL (..)
, EndoR (..)
, MCat (..)
, ApCat (..)
) where
import Control.Category
import Prelude hiding (id, (.))
data Path p x y where
Done :: Path p x x
(:>>) :: p x y -> Path p y z -> Path p x z
infixr 7 :>>
pattern (:<<) :: Path p y z -> p x y -> Path p x z
pattern ps :<< p = p :>> ps
infixl 7 :<<
deriving instance (forall x y. Show (p x y)) => Show (Path p x y)
instance x ~ y => Semigroup (Path p x y) where
(<>) = (>>>)
instance x ~ y => Monoid (Path p x y) where
mempty = Done
mappend = (>>>)
instance Category (Path p) where
id = Done
(.) path = \case
Done -> path
p :>> ps -> p :>> (ps >>> path)
instance CFunctor Path where
cmap _ Done = Done
cmap f (p :>> ps) = f p :>> cmap f ps
instance CFoldable Path where
cfoldMap _ Done = id
cfoldMap f (p :>> ps) = f p >>> cfoldMap f ps
ctoMonoid _ Done = mempty
ctoMonoid f (p :>> ps) = f p <> ctoMonoid f ps
ctoList _ Done = []
ctoList f (p :>> ps) = f p : ctoList f ps
ctraverse_ _ Done = pure id
ctraverse_ f (p :>> ps) = (>>>) <$> f p <*> ctraverse_ f ps
instance CTraversable Path where
ctraverse _ Done = pure Done
ctraverse f (p :>> ps) = (:>>) <$> f p <*> ctraverse f ps
instance CFree Path where csingleton p = p :>> Done
newtype FoldPath p x y = FoldPath
{getFoldPath :: forall q. Category q => (forall x y. p x y -> q x y) -> q x y}
instance x ~ y => Semigroup (FoldPath p x y) where
(<>) = (>>>)
instance x ~ y => Monoid (FoldPath p x y) where
mempty = id
mappend = (>>>)
instance Category (FoldPath p) where
id = FoldPath $ \ _ -> id
FoldPath g . FoldPath f = FoldPath $ \ k -> g k . f k
instance CFunctor FoldPath where cmap f = cfoldMap (csingleton . f)
instance CFoldable FoldPath where cfoldMap k (FoldPath f) = f k
instance CTraversable FoldPath where
ctraverse f = getApCat . cfoldMap (ApCat . fmap csingleton . f)
instance CFree FoldPath where csingleton p = FoldPath $ \ k -> k p
class (forall p. Category (c p)) => CFunctor c where
cmap :: (forall x y. p x y -> q x y) -> c p x y -> c q x y
class CFunctor c => CFoldable c where
cfoldMap :: Category q => (forall x y. p x y -> q x y) -> c p x y -> q x y
cfold :: Category q => c q x y -> q x y
cfold = cfoldMap id
cfoldr :: (forall x y z . p x y -> q y z -> q x z) -> q y z -> c p x y -> q x z
cfoldr (?) q c = getEndoR (cfoldMap (\ x -> EndoR (\ y -> x ? y)) c) q
cfoldl :: (forall x y z . q x y -> p y z -> q x z) -> q x y -> c p y z -> q x z
cfoldl (?) q c = getEndoL (cfoldMap (\ x -> EndoL (\ y -> y ? x)) c) q
ctoMonoid :: Monoid m => (forall x y. p x y -> m) -> c p x y -> m
ctoMonoid f = getMCat . cfoldMap (MCat . f)
ctoList :: (forall x y. p x y -> a) -> c p x y -> [a]
ctoList f = ctoMonoid (pure . f)
ctraverse_
:: (Applicative m, Category q)
=> (forall x y. p x y -> m (q x y)) -> c p x y -> m (q x y)
ctraverse_ f = getApCat . cfoldMap (ApCat . f)
class CFoldable c => CTraversable c where
ctraverse
:: Applicative m
=> (forall x y. p x y -> m (q x y)) -> c p x y -> m (c q x y)
class CTraversable c => CFree c where csingleton :: p x y -> c p x y
toPath :: (CFoldable c, CFree path) => c p x y -> path p x y
toPath = cfoldMap csingleton
newtype EndoR p y x = EndoR {getEndoR :: forall z. p x z -> p y z}
instance Category (EndoR p) where
id = EndoR id
EndoR f1 . EndoR f2 = EndoR (f2 . f1)
newtype EndoL p x y = EndoL {getEndoL :: forall w . p w x -> p w y}
instance Category (EndoL p) where
id = EndoL id
EndoL f1 . EndoL f2 = EndoL (f1 . f2)
newtype MCat m x y = MCat {getMCat :: m} deriving (Eq, Ord, Show)
instance Monoid m => Category (MCat m) where
id = MCat mempty
MCat g . MCat f = MCat (f <> g)
newtype ApCat m c x y = ApCat {getApCat :: m (c x y)} deriving (Eq, Ord, Show)
instance (Applicative m, Category c) => Category (ApCat m c) where
id = ApCat (pure id)
ApCat g . ApCat f = ApCat ((.) <$> g <*> f)