60 lines
1.9 KiB
Haskell
60 lines
1.9 KiB
Haskell
module Functor.Algebra where
|
|
|
|
import Functor.Base
|
|
import Relation
|
|
|
|
import Data.Coerce (Coercible, coerce)
|
|
import Data.Fix (Fix (Fix), unFix)
|
|
import Data.Kind (Constraint, Type)
|
|
import GHC.Generics
|
|
|
|
type Algebra :: (k -> k) -> k -> Type
|
|
type Algebra f a = Cod f (f a) a
|
|
|
|
type Coalgebra :: (k -> k) -> k -> Type
|
|
type Coalgebra f a = Cod f a (f a)
|
|
|
|
type Recursive :: k -> Constraint
|
|
class Endofunctor (Base t) => Recursive (t :: k) where
|
|
type Base t :: k -> k
|
|
embed :: Algebra (Base t) t
|
|
project :: Coalgebra (Base t) t
|
|
|
|
newtype Mu f = Mu { unMu :: forall a. Algebra f a -> a }
|
|
data Nu f = forall a. Nu !(Coalgebra f a) !a
|
|
|
|
instance (Endofunctor f, Cod f ~ (->)) => Recursive (Fix f) where
|
|
type Base (Fix f) = f
|
|
embed = Fix
|
|
project = unFix
|
|
|
|
instance (Endofunctor f, Cod f ~ (->)) => Recursive (Mu f) where
|
|
type Base (Mu f) = f
|
|
embed x = Mu \alg -> alg (map (fold alg) x)
|
|
project (Mu fold) = fold (map embed)
|
|
|
|
instance (Endofunctor f, Cod f ~ (->)) => Recursive (Nu f) where
|
|
type Base (Nu f) = f
|
|
embed = Nu (map project)
|
|
project (Nu coalg seed) = map (Nu coalg) (coalg seed)
|
|
|
|
gproject :: forall t. (Recursive t, Generic t, Generic (Base t t), Coercible (Rep t) (Rep (Base t t)))
|
|
=> t -> Base t t
|
|
gproject = to . (coerce :: Rep t () -> Rep (Base t t) ()) . from
|
|
|
|
gembed :: forall t. (Recursive t, Generic t, Generic (Base t t), Coercible (Rep (Base t t)) (Rep t))
|
|
=> Base t t -> t
|
|
gembed = to . (coerce :: Rep (Base t t) () -> Rep t ()) . from
|
|
|
|
fold :: Recursive t => Algebra (Base t) a -> Cod (Base t) t a
|
|
fold alg = h where h = alg . map h . project
|
|
|
|
unfold :: Recursive t => Coalgebra (Base t) a -> Cod (Base t) a t
|
|
unfold coalg = h where h = embed . map h . coalg
|
|
|
|
refold :: Endofunctor f => Cod f (f b) b -> Cod f a (f a) -> Cod f a b
|
|
refold alg coalg = h where h = alg . map h . coalg
|
|
|
|
refix :: (Recursive t, Recursive u, Base t ~ Base u, Endofunctor (Base t), Cod (Base t) ~ (->)) => t -> u
|
|
refix = refold embed project
|