{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -O2 -fenable-rewrite-rules #-}
{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
module Data.Functor.Fixedpoint
(
Fix(..), unFix
, hmap, hmapM
, ymap, ymapM
, build
, cata, cataM
, ycata, ycataM
, ana, anaM
, hylo, hyloM
) where
import Prelude hiding (mapM, sequence)
import Control.Monad hiding (mapM, sequence)
import Data.Traversable
newtype Fix f = Fix (f (Fix f))
unFix :: Fix f -> f (Fix f)
unFix :: Fix f -> f (Fix f)
unFix (Fix f (Fix f)
f) = f (Fix f)
f
{-# INLINE [0] unFix #-}
instance (Show (f (Fix f))) => Show (Fix f) where
showsPrec :: Int -> Fix f -> ShowS
showsPrec Int
p (Fix f (Fix f)
f) = Int -> f (Fix f) -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p f (Fix f)
f
instance (Eq (f (Fix f))) => Eq (Fix f) where
Fix f (Fix f)
x == :: Fix f -> Fix f -> Bool
== Fix f (Fix f)
y = f (Fix f)
x f (Fix f) -> f (Fix f) -> Bool
forall a. Eq a => a -> a -> Bool
== f (Fix f)
y
Fix f (Fix f)
x /= :: Fix f -> Fix f -> Bool
/= Fix f (Fix f)
y = f (Fix f)
x f (Fix f) -> f (Fix f) -> Bool
forall a. Eq a => a -> a -> Bool
/= f (Fix f)
y
#if __GLASGOW_HASKELL__ == 800
{-# NOINLINE (==) #-}
{-# NOINLINE (/=) #-}
#endif
instance (Ord (f (Fix f))) => Ord (Fix f) where
Fix f (Fix f)
x compare :: Fix f -> Fix f -> Ordering
`compare` Fix f (Fix f)
y = f (Fix f)
x f (Fix f) -> f (Fix f) -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` f (Fix f)
y
Fix f (Fix f)
x > :: Fix f -> Fix f -> Bool
> Fix f (Fix f)
y = f (Fix f)
x f (Fix f) -> f (Fix f) -> Bool
forall a. Ord a => a -> a -> Bool
> f (Fix f)
y
Fix f (Fix f)
x >= :: Fix f -> Fix f -> Bool
>= Fix f (Fix f)
y = f (Fix f)
x f (Fix f) -> f (Fix f) -> Bool
forall a. Ord a => a -> a -> Bool
>= f (Fix f)
y
Fix f (Fix f)
x <= :: Fix f -> Fix f -> Bool
<= Fix f (Fix f)
y = f (Fix f)
x f (Fix f) -> f (Fix f) -> Bool
forall a. Ord a => a -> a -> Bool
<= f (Fix f)
y
Fix f (Fix f)
x < :: Fix f -> Fix f -> Bool
< Fix f (Fix f)
y = f (Fix f)
x f (Fix f) -> f (Fix f) -> Bool
forall a. Ord a => a -> a -> Bool
< f (Fix f)
y
Fix f (Fix f)
x max :: Fix f -> Fix f -> Fix f
`max` Fix f (Fix f)
y = f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (f (Fix f) -> f (Fix f) -> f (Fix f)
forall a. Ord a => a -> a -> a
max f (Fix f)
x f (Fix f)
y)
Fix f (Fix f)
x min :: Fix f -> Fix f -> Fix f
`min` Fix f (Fix f)
y = f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (f (Fix f) -> f (Fix f) -> f (Fix f)
forall a. Ord a => a -> a -> a
min f (Fix f)
x f (Fix f)
y)
#if __GLASGOW_HASKELL__ == 800
{-# NOINLINE compare #-}
{-# NOINLINE (>) #-}
{-# NOINLINE (>=) #-}
{-# NOINLINE (<=) #-}
{-# NOINLINE (<) #-}
{-# NOINLINE max #-}
{-# NOINLINE min #-}
#endif
hmap :: (Functor f, Functor g) => (forall a. f a -> g a) -> Fix f -> Fix g
{-# INLINE [0] hmap #-}
hmap :: (forall a. f a -> g a) -> Fix f -> Fix g
hmap forall a. f a -> g a
eps = (Fix f -> g (Fix f)) -> Fix f -> Fix g
forall (f :: * -> *) a. Functor f => (a -> f a) -> a -> Fix f
ana (f (Fix f) -> g (Fix f)
forall a. f a -> g a
eps (f (Fix f) -> g (Fix f))
-> (Fix f -> f (Fix f)) -> Fix f -> g (Fix f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix)
{-# RULES
-- Alas, rule won't fire because 'id' may inline too early.
-- "hmap id"
-- hmap id = id
-- cf., NOTE #1
"hmap-compose"
forall (eps :: forall a. g a -> h a) (eta :: forall a. f a -> g a) x.
hmap eps (hmap eta x) = hmap (eps . eta) x
#-}
hmapM
:: (Functor f, Traversable g, Monad m)
=> (forall a. f a -> m (g a)) -> Fix f -> m (Fix g)
{-# INLINE [0] hmapM #-}
hmapM :: (forall a. f a -> m (g a)) -> Fix f -> m (Fix g)
hmapM forall a. f a -> m (g a)
eps = (Fix f -> m (g (Fix f))) -> Fix f -> m (Fix g)
forall (f :: * -> *) (m :: * -> *) a.
(Traversable f, Monad m) =>
(a -> m (f a)) -> a -> m (Fix f)
anaM (f (Fix f) -> m (g (Fix f))
forall a. f a -> m (g a)
eps (f (Fix f) -> m (g (Fix f)))
-> (Fix f -> f (Fix f)) -> Fix f -> m (g (Fix f))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix)
{-# RULES
-- Alas, rule won't fire because 'return' may inline too early.
-- "hmapM return"
-- hmapM return = return
-- "hmapM-compose"
-- forall eps eta.
-- hmap eps <=< hmap eta = hmapM (eps <=< eta)
#-}
ymap :: (Functor f) => (Fix f -> Fix f) -> Fix f -> Fix f
{-# INLINE [0] ymap #-}
ymap :: (Fix f -> Fix f) -> Fix f -> Fix f
ymap Fix f -> Fix f
f = f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (f (Fix f) -> Fix f) -> (Fix f -> f (Fix f)) -> Fix f -> Fix f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fix f -> Fix f) -> f (Fix f) -> f (Fix f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Fix f -> Fix f
f (f (Fix f) -> f (Fix f))
-> (Fix f -> f (Fix f)) -> Fix f -> f (Fix f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix
{-# RULES
-- Alas, rule won't fire because 'id' may inline too early.
-- "ymap id"
-- ymap id = id
-- cf., NOTE #1
"ymap-compose"
forall f g x.
ymap f (ymap g x) = ymap (f . g) x
#-}
ymapM :: (Traversable f, Monad m)
=> (Fix f -> m (Fix f)) -> Fix f -> m (Fix f)
{-# INLINE [0] ymapM #-}
ymapM :: (Fix f -> m (Fix f)) -> Fix f -> m (Fix f)
ymapM Fix f -> m (Fix f)
f = (f (Fix f) -> Fix f) -> m (f (Fix f)) -> m (Fix f)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (m (f (Fix f)) -> m (Fix f))
-> (Fix f -> m (f (Fix f))) -> Fix f -> m (Fix f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fix f -> m (Fix f)) -> f (Fix f) -> m (f (Fix f))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Fix f -> m (Fix f)
f (f (Fix f) -> m (f (Fix f)))
-> (Fix f -> f (Fix f)) -> Fix f -> m (f (Fix f))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix
{-# RULES
-- Alas, rule won't fire because 'return' may inline too early.
-- "ymapM id"
-- ymapM return = return
-- "ymapM-compose"
-- forall f g.
-- ymapM f <=< ymapM g = ymapM (f <=< g)
#-}
build :: (Functor f) => (forall r. (f r -> r) -> r) -> Fix f
{-# INLINE [0] build #-}
build :: (forall r. (f r -> r) -> r) -> Fix f
build forall r. (f r -> r) -> r
g = (f (Fix f) -> Fix f) -> Fix f
forall r. (f r -> r) -> r
g f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix
{-# RULES
"build/cata" [1]
forall (phi :: f a -> a) (g :: forall r. (f r -> r) -> r).
cata phi (build g) = g phi
#-}
cata :: (Functor f) => (f a -> a) -> (Fix f -> a)
{-# INLINE [0] cata #-}
cata :: (f a -> a) -> Fix f -> a
cata f a -> a
phi = Fix f -> a
self
where
self :: Fix f -> a
self = f a -> a
phi (f a -> a) -> (Fix f -> f a) -> Fix f -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fix f -> a) -> f (Fix f) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Fix f -> a
self (f (Fix f) -> f a) -> (Fix f -> f (Fix f)) -> Fix f -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix
{-# RULES
"cata-refl"
cata Fix = id
-- cf., NOTE #1
"cata-compose"
forall (eps :: forall a. f a -> g a) phi x.
cata phi (cata (\y -> Fix (eps y)) x) = cata (phi . eps) x
#-}
cataM :: (Traversable f, Monad m) => (f a -> m a) -> (Fix f -> m a)
{-# INLINE [0] cataM #-}
cataM :: (f a -> m a) -> Fix f -> m a
cataM f a -> m a
phiM = Fix f -> m a
self
where
self :: Fix f -> m a
self = f a -> m a
phiM (f a -> m a) -> (Fix f -> m (f a)) -> Fix f -> m a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ((Fix f -> m a) -> f (Fix f) -> m (f a)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Fix f -> m a
self (f (Fix f) -> m (f a)) -> (Fix f -> f (Fix f)) -> Fix f -> m (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix)
{-# RULES
-- Alas, rule won't fire because 'return' may inline too early.
-- "cataM-refl"
-- cataM (return . Fix) = return
#-}
ycata :: (Functor f) => (Fix f -> Fix f) -> Fix f -> Fix f
{-# INLINE ycata #-}
ycata :: (Fix f -> Fix f) -> Fix f -> Fix f
ycata Fix f -> Fix f
f = (f (Fix f) -> Fix f) -> Fix f -> Fix f
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
cata (Fix f -> Fix f
f (Fix f -> Fix f) -> (f (Fix f) -> Fix f) -> f (Fix f) -> Fix f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix)
ycataM :: (Traversable f, Monad m)
=> (Fix f -> m (Fix f)) -> Fix f -> m (Fix f)
{-# INLINE ycataM #-}
ycataM :: (Fix f -> m (Fix f)) -> Fix f -> m (Fix f)
ycataM Fix f -> m (Fix f)
f = (f (Fix f) -> m (Fix f)) -> Fix f -> m (Fix f)
forall (f :: * -> *) (m :: * -> *) a.
(Traversable f, Monad m) =>
(f a -> m a) -> Fix f -> m a
cataM (Fix f -> m (Fix f)
f (Fix f -> m (Fix f))
-> (f (Fix f) -> Fix f) -> f (Fix f) -> m (Fix f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix)
ana :: (Functor f) => (a -> f a) -> (a -> Fix f)
{-# INLINE [0] ana #-}
ana :: (a -> f a) -> a -> Fix f
ana a -> f a
psi = a -> Fix f
self
where
self :: a -> Fix f
self = f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (f (Fix f) -> Fix f) -> (a -> f (Fix f)) -> a -> Fix f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Fix f) -> f a -> f (Fix f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Fix f
self (f a -> f (Fix f)) -> (a -> f a) -> a -> f (Fix f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
psi
{-# RULES
"ana-refl"
ana unFix = id
-- BUG: I think I dualized this right...
-- cf., NOTE #1
"ana-compose"
forall (eps :: forall a. f a -> g a) psi x.
ana (\y -> eps (unFix y)) (ana psi x) = ana (eps . psi) x
#-}
anaM :: (Traversable f, Monad m) => (a -> m (f a)) -> (a -> m (Fix f))
{-# INLINE anaM #-}
anaM :: (a -> m (f a)) -> a -> m (Fix f)
anaM a -> m (f a)
psiM = a -> m (Fix f)
self
where
self :: a -> m (Fix f)
self = ((f (Fix f) -> Fix f) -> m (f (Fix f)) -> m (Fix f)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (m (f (Fix f)) -> m (Fix f))
-> (f a -> m (f (Fix f))) -> f a -> m (Fix f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m (Fix f)) -> f a -> m (f (Fix f))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> m (Fix f)
self) (f a -> m (Fix f)) -> (a -> m (f a)) -> a -> m (Fix f)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< a -> m (f a)
psiM
hylo :: (Functor f) => (f b -> b) -> (a -> f a) -> (a -> b)
{-# INLINE hylo #-}
hylo :: (f b -> b) -> (a -> f a) -> a -> b
hylo f b -> b
phi a -> f a
psi = a -> b
self
where
self :: a -> b
self = f b -> b
phi (f b -> b) -> (a -> f b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
self (f a -> f b) -> (a -> f a) -> a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
psi
hyloM :: (Traversable f, Monad m)
=> (f b -> m b) -> (a -> m (f a)) -> (a -> m b)
{-# INLINE hyloM #-}
hyloM :: (f b -> m b) -> (a -> m (f a)) -> a -> m b
hyloM f b -> m b
phiM a -> m (f a)
psiM = a -> m b
self
where
self :: a -> m b
self = f b -> m b
phiM (f b -> m b) -> (a -> m (f b)) -> a -> m b
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (a -> m b) -> f a -> m (f b)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> m b
self (f a -> m (f b)) -> (a -> m (f a)) -> a -> m (f b)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< a -> m (f a)
psiM