{-# LANGUAGE CPP                       #-}
{-# LANGUAGE DeriveDataTypeable        #-}
{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE Trustworthy               #-}

-- needed for Data instance
{-# LANGUAGE UndecidableInstances      #-}

#define HAS_POLY_TYPEABLE MIN_VERSION_base(4,7,0)
#define HAS_QUANTIFIED_FUNCTOR_CLASSES MIN_VERSION_base(4,18,0)

#if HAS_POLY_TYPEABLE
{-# LANGUAGE StandaloneDeriving        #-}
#endif

-- | Fixed points of a functor.
--
-- Type @f@ should be a 'Functor' if you want to use
-- simple recursion schemes or 'Traversable' if you want to
-- use monadic recursion schemes. This style allows you to express
-- recursive functions in non-recursive manner.
-- You can imagine that a non-recursive function
-- holds values of the previous iteration.
--
-- An example:
--
-- First we define a base functor. The arguments @b@ are recursion points.
--
-- >>> data ListF a b = Nil | Cons a b deriving (Show, Functor)
--
-- The list is then a fixed point of 'ListF'
--
-- >>> type List a = Fix (ListF a)
--
-- We can write @length@ function. Note that the function we give
-- to 'foldFix' is not recursive. Instead the results
-- of recursive calls are in @b@ positions, and we need to deal
-- only with one layer of the structure.
--
-- >>> :{
-- let length :: List a -> Int
--     length = foldFix $ \x -> case x of
--         Nil      -> 0
--         Cons _ n -> n + 1
-- :}
--
-- If you already have recursive type, like '[Int]',
-- you can first convert it to `Fix (ListF a)` and then `foldFix`.
-- Alternatively you can use @recursion-schemes@ combinators
-- which work directly on recursive types.
--
module Data.Fix (
    -- * Fix
    Fix (..),
    hoistFix,
    hoistFix',
    foldFix,
    unfoldFix,
    wrapFix,
    unwrapFix,
    -- * Mu - least fixed point
    Mu (..),
    hoistMu,
    foldMu,
    unfoldMu,
    wrapMu,
    unwrapMu,
    -- * Nu - greatest fixed point
    Nu (..),
    hoistNu,
    foldNu,
    unfoldNu,
    wrapNu,
    unwrapNu,
    -- * Refolding
    refold,
    -- * Monadic variants
    foldFixM,
    unfoldFixM,
    refoldM,
    -- * Deprecated aliases
    cata, ana, hylo,
    cataM, anaM, hyloM,
) where

-- Explicit imports help dodge unused imports warnings,
-- as we say what we want from Prelude
import Data.Traversable (Traversable (..))
import Prelude (Eq (..), Functor (..), Monad (..), Ord (..), Read (..), Show (..), showParen, showString, ($), (.), (=<<))

#ifdef __GLASGOW_HASKELL__
#if !HAS_POLY_TYPEABLE
import Prelude (const, error, undefined)
#endif
#endif

import Control.Monad        (liftM)
import Data.Function        (on)
import Data.Functor.Classes (Eq1, Ord1, Read1, Show1, readsPrec1, showsPrec1)
import Data.Hashable        (Hashable (..))
import Data.Hashable.Lifted (Hashable1, hashWithSalt1)
import Data.Typeable        (Typeable)
import GHC.Generics         (Generic)
import Text.Read            (Lexeme (Ident), Read (..), lexP, parens, prec, readS_to_Prec, step)

#if MIN_VERSION_deepseq(1,4,3)
import Control.DeepSeq (NFData (..), NFData1, rnf1)
#endif

#if HAS_POLY_TYPEABLE
import Data.Data (Data)
#else
import Data.Data
#endif

#if !HAS_QUANTIFIED_FUNCTOR_CLASSES
import Data.Functor.Classes (compare1, eq1)
#endif

-- $setup
-- >>> :set -XDeriveFunctor
-- >>> import Prelude
-- >>> import Data.Functor.Classes
-- >>> data ListF a b = Nil | Cons a b deriving (Show, Functor)
--
-- >>> :{
-- >>> instance Show a => Show1 (ListF a) where
-- >>>     liftShowsPrec _  _ d Nil        = showString "Nil"
-- >>>     liftShowsPrec sp _ d (Cons a b) = showParen (d > 10) $ showString "Cons " . showsPrec 11 a . showChar ' ' . sp 11 b
-- >>> :}
--
-- >>> :{
-- >>> let elimListF n c Nil        = 0
-- >>>     elimListF n c (Cons a b) = c a b
-- >>> :}

-------------------------------------------------------------------------------
-- Fix
-------------------------------------------------------------------------------

-- | A fix-point type.
newtype Fix f = Fix { forall (f :: * -> *). Fix f -> f (Fix f)
unFix :: f (Fix f) }
  deriving ((forall x. Fix f -> Rep (Fix f) x)
-> (forall x. Rep (Fix f) x -> Fix f) -> Generic (Fix f)
forall x. Rep (Fix f) x -> Fix f
forall x. Fix f -> Rep (Fix f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: * -> *) x. Rep (Fix f) x -> Fix f
forall (f :: * -> *) x. Fix f -> Rep (Fix f) x
$cfrom :: forall (f :: * -> *) x. Fix f -> Rep (Fix f) x
from :: forall x. Fix f -> Rep (Fix f) x
$cto :: forall (f :: * -> *) x. Rep (Fix f) x -> Fix f
to :: forall x. Rep (Fix f) x -> Fix f
Generic)

-- | Change base functor in 'Fix'.
hoistFix :: Functor f => (forall a. f a -> g a) -> Fix f -> Fix g
hoistFix :: forall (f :: * -> *) (g :: * -> *).
Functor f =>
(forall a. f a -> g a) -> Fix f -> Fix g
hoistFix forall a. f a -> g a
nt = Fix f -> Fix g
go where go :: Fix f -> Fix g
go (Fix f (Fix f)
f) = g (Fix g) -> Fix g
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (f (Fix g) -> g (Fix g)
forall a. f a -> g a
nt ((Fix f -> Fix g) -> f (Fix f) -> f (Fix g)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Fix f -> Fix g
go f (Fix f)
f))

-- | Like 'hoistFix' but 'fmap'ping over @g@.
hoistFix' :: Functor g => (forall a. f a -> g a) -> Fix f -> Fix g
hoistFix' :: forall (g :: * -> *) (f :: * -> *).
Functor g =>
(forall a. f a -> g a) -> Fix f -> Fix g
hoistFix' forall a. f a -> g a
nt = Fix f -> Fix g
go where go :: Fix f -> Fix g
go (Fix f (Fix f)
f) = g (Fix g) -> Fix g
forall (f :: * -> *). f (Fix f) -> Fix f
Fix ((Fix f -> Fix g) -> g (Fix f) -> g (Fix g)
forall a b. (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Fix f -> Fix g
go (f (Fix f) -> g (Fix f)
forall a. f a -> g a
nt f (Fix f)
f))

-- | Fold 'Fix'.
--
-- >>> let fp = unfoldFix (\i -> if i < 4 then Cons i (i + 1) else Nil) (0 :: Int)
-- >>> foldFix (elimListF 0 (+)) fp
-- 6
--
foldFix :: Functor f => (f a -> a) -> Fix f -> a
foldFix :: forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix f a -> a
f = Fix f -> a
go where go :: Fix f -> a
go = f a -> a
f (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 a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Fix f -> a
go (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

-- | Unfold 'Fix'.
--
-- >>> unfoldFix (\i -> if i < 4 then Cons i (i + 1) else Nil) (0 :: Int)
-- Fix (Cons 0 (Fix (Cons 1 (Fix (Cons 2 (Fix (Cons 3 (Fix Nil))))))))
--
unfoldFix :: Functor f => (a -> f a) -> a -> Fix f
unfoldFix :: forall (f :: * -> *) a. Functor f => (a -> f a) -> a -> Fix f
unfoldFix a -> f a
f = a -> Fix f
go where go :: a -> Fix f
go = 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 a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Fix f
go (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
f

-- | Wrap 'Fix'.
--
-- >>> let x = unfoldFix (\i -> if i < 3 then Cons i (i + 1) else Nil) (0 :: Int)
-- >>> wrapFix (Cons 10 x)
-- Fix (Cons 10 (Fix (Cons 0 (Fix (Cons 1 (Fix (Cons 2 (Fix Nil))))))))
--
-- @since 0.3.2
--
wrapFix :: f (Fix f) -> Fix f
wrapFix :: forall (f :: * -> *). f (Fix f) -> Fix f
wrapFix = f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix

-- | Unwrap 'Fix'.
--
-- >>> let x = unfoldFix (\i -> if i < 3 then Cons i (i + 1) else Nil) (0 :: Int)
-- >>> unwrapFix x
-- Cons 0 (Fix (Cons 1 (Fix (Cons 2 (Fix Nil)))))
--
-- @since 0.3.2
--
unwrapFix :: Fix f -> f (Fix f)
unwrapFix :: forall (f :: * -> *). Fix f -> f (Fix f)
unwrapFix = Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix

-------------------------------------------------------------------------------
-- Functor instances
-------------------------------------------------------------------------------

instance Eq1 f => Eq (Fix f) where
#if HAS_QUANTIFIED_FUNCTOR_CLASSES
    Fix f (Fix f)
a == :: Fix f -> Fix f -> Bool
== Fix f (Fix f)
b = f (Fix f)
a f (Fix f) -> f (Fix f) -> Bool
forall a. Eq a => a -> a -> Bool
== f (Fix f)
b
#else
    Fix a == Fix b = eq1 a b
#endif

instance Ord1 f => Ord (Fix f) where
#if HAS_QUANTIFIED_FUNCTOR_CLASSES
    compare :: Fix f -> Fix f -> Ordering
compare (Fix f (Fix f)
a) (Fix f (Fix f)
b) = f (Fix f) -> f (Fix f) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare f (Fix f)
a f (Fix f)
b
    min :: Fix f -> Fix f -> Fix f
min (Fix f (Fix f)
a) (Fix f (Fix f)
b) = 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)
a f (Fix f)
b)
    max :: Fix f -> Fix f -> Fix f
max (Fix f (Fix f)
a) (Fix f (Fix f)
b) = 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)
a f (Fix f)
b)
    Fix f (Fix f)
a >= :: Fix f -> Fix f -> Bool
>= Fix f (Fix f)
b = f (Fix f)
a f (Fix f) -> f (Fix f) -> Bool
forall a. Ord a => a -> a -> Bool
>= f (Fix f)
b
    Fix f (Fix f)
a > :: Fix f -> Fix f -> Bool
> Fix f (Fix f)
b = f (Fix f)
a f (Fix f) -> f (Fix f) -> Bool
forall a. Ord a => a -> a -> Bool
> f (Fix f)
b
    Fix f (Fix f)
a < :: Fix f -> Fix f -> Bool
< Fix f (Fix f)
b = f (Fix f)
a f (Fix f) -> f (Fix f) -> Bool
forall a. Ord a => a -> a -> Bool
< f (Fix f)
b
    Fix f (Fix f)
a <= :: Fix f -> Fix f -> Bool
<= Fix f (Fix f)
b = f (Fix f)
a f (Fix f) -> f (Fix f) -> Bool
forall a. Ord a => a -> a -> Bool
<= f (Fix f)
b
#else
    compare (Fix a) (Fix b) = compare1 a b
#endif

instance Show1 f => Show (Fix f) where
    showsPrec :: Int -> Fix f -> ShowS
showsPrec Int
d (Fix f (Fix f)
a) =
        Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
11)
            (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"Fix "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> f (Fix f) -> ShowS
forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1 Int
11 f (Fix f)
a

#ifdef __GLASGOW_HASKELL__
instance Read1 f => Read (Fix f) where
    readPrec :: ReadPrec (Fix f)
readPrec = ReadPrec (Fix f) -> ReadPrec (Fix f)
forall a. ReadPrec a -> ReadPrec a
parens (ReadPrec (Fix f) -> ReadPrec (Fix f))
-> ReadPrec (Fix f) -> ReadPrec (Fix f)
forall a b. (a -> b) -> a -> b
$ Int -> ReadPrec (Fix f) -> ReadPrec (Fix f)
forall a. Int -> ReadPrec a -> ReadPrec a
prec Int
10 (ReadPrec (Fix f) -> ReadPrec (Fix f))
-> ReadPrec (Fix f) -> ReadPrec (Fix f)
forall a b. (a -> b) -> a -> b
$ do
        Ident String
"Fix" <- ReadPrec Lexeme
lexP
        (f (Fix f) -> Fix f) -> ReadPrec (f (Fix f)) -> ReadPrec (Fix f)
forall a b. (a -> b) -> ReadPrec a -> ReadPrec b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (ReadPrec (f (Fix f)) -> ReadPrec (f (Fix f))
forall a. ReadPrec a -> ReadPrec a
step ((Int -> ReadS (f (Fix f))) -> ReadPrec (f (Fix f))
forall a. (Int -> ReadS a) -> ReadPrec a
readS_to_Prec Int -> ReadS (f (Fix f))
forall (f :: * -> *) a. (Read1 f, Read a) => Int -> ReadS (f a)
readsPrec1))
#endif

-------------------------------------------------------------------------------
-- hashable
-------------------------------------------------------------------------------

instance Hashable1 f => Hashable (Fix f) where
#if MIN_VERSION_hashable(1,5,0)
    hash :: Fix f -> Int
hash (Fix f (Fix f)
x) = f (Fix f) -> Int
forall a. Hashable a => a -> Int
hash f (Fix f)
x
    hashWithSalt :: Int -> Fix f -> Int
hashWithSalt Int
salt (Fix f (Fix f)
x) = Int -> f (Fix f) -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt f (Fix f)
x
#else
    hashWithSalt salt = hashWithSalt1 salt . unFix
#endif

-------------------------------------------------------------------------------
-- deepseq
-------------------------------------------------------------------------------

#if MIN_VERSION_deepseq(1,4,3)
instance NFData1 f => NFData (Fix f) where
#if MIN_VERSION_deepseq(1,5,0)
    rnf (Fix a) = rnf a 
#else
    rnf :: Fix f -> ()
rnf = f (Fix f) -> ()
forall (f :: * -> *) a. (NFData1 f, NFData a) => f a -> ()
rnf1 (f (Fix f) -> ()) -> (Fix f -> f (Fix 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
#endif
#endif

-------------------------------------------------------------------------------
-- Typeable and Data
-------------------------------------------------------------------------------

#ifdef __GLASGOW_HASKELL__
#if HAS_POLY_TYPEABLE
deriving instance Typeable Fix
deriving instance (Typeable f, Data (f (Fix f))) => Data (Fix f)
#else
instance Typeable1 f => Typeable (Fix f) where
   typeOf t = mkTyConApp fixTyCon [typeOf1 (undefined `asArgsTypeOf` t)]
     where asArgsTypeOf :: f a -> Fix f -> f a
           asArgsTypeOf = const

fixTyCon :: TyCon
#if MIN_VERSION_base(4,4,0)
fixTyCon = mkTyCon3 "recursion-schemes" "Data.Functor.Foldable" "Fix"
#else
fixTyCon = mkTyCon "Data.Functor.Foldable.Fix"
#endif
{-# NOINLINE fixTyCon #-}

instance (Typeable1 f, Data (f (Fix f))) => Data (Fix f) where
  gfoldl f z (Fix a) = z Fix `f` a
  toConstr _ = fixConstr
  gunfold k z c = case constrIndex c of
    1 -> k (z (Fix))
    _ -> error "gunfold"
  dataTypeOf _ = fixDataType

fixConstr :: Constr
fixConstr = mkConstr fixDataType "Fix" [] Prefix

fixDataType :: DataType
fixDataType = mkDataType "Data.Functor.Foldable.Fix" [fixConstr]
#endif
#endif

-------------------------------------------------------------------------------
-- Mu
-------------------------------------------------------------------------------

-- | Least fixed point. Efficient folding.
newtype Mu f = Mu { forall (f :: * -> *). Mu f -> forall a. (f a -> a) -> a
unMu :: forall a. (f a -> a) -> a }

instance (Functor f, Eq1 f) => Eq (Mu f) where
    == :: Mu f -> Mu f -> Bool
(==) = Fix f -> Fix f -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Fix f -> Fix f -> Bool) -> (Mu f -> Fix f) -> Mu f -> Mu f -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (f (Fix f) -> Fix f) -> Mu f -> Fix f
forall (f :: * -> *) a. (f a -> a) -> Mu f -> a
foldMu f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix

instance (Functor f, Ord1 f) => Ord (Mu f) where
    compare :: Mu f -> Mu f -> Ordering
compare = Fix f -> Fix f -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Fix f -> Fix f -> Ordering)
-> (Mu f -> Fix f) -> Mu f -> Mu f -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (f (Fix f) -> Fix f) -> Mu f -> Fix f
forall (f :: * -> *) a. (f a -> a) -> Mu f -> a
foldMu f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix

instance (Functor f, Show1 f) => Show (Mu f) where
    showsPrec :: Int -> Mu f -> ShowS
showsPrec Int
d Mu f
f = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
        String -> ShowS
showString String
"unfoldMu unFix " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Fix f -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 ((f (Fix f) -> Fix f) -> Mu f -> Fix f
forall (f :: * -> *) a. (f a -> a) -> Mu f -> a
foldMu f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix Mu f
f)

#ifdef __GLASGOW_HASKELL__
instance (Functor f, Read1 f) => Read (Mu f) where
    readPrec :: ReadPrec (Mu f)
readPrec = ReadPrec (Mu f) -> ReadPrec (Mu f)
forall a. ReadPrec a -> ReadPrec a
parens (ReadPrec (Mu f) -> ReadPrec (Mu f))
-> ReadPrec (Mu f) -> ReadPrec (Mu f)
forall a b. (a -> b) -> a -> b
$ Int -> ReadPrec (Mu f) -> ReadPrec (Mu f)
forall a. Int -> ReadPrec a -> ReadPrec a
prec Int
10 (ReadPrec (Mu f) -> ReadPrec (Mu f))
-> ReadPrec (Mu f) -> ReadPrec (Mu f)
forall a b. (a -> b) -> a -> b
$ do
        Ident String
"unfoldMu" <- ReadPrec Lexeme
lexP
        Ident String
"unFix" <- ReadPrec Lexeme
lexP
        (Fix f -> Mu f) -> ReadPrec (Fix f) -> ReadPrec (Mu f)
forall a b. (a -> b) -> ReadPrec a -> ReadPrec b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Fix f -> f (Fix f)) -> Fix f -> Mu f
forall (f :: * -> *) a. Functor f => (a -> f a) -> a -> Mu f
unfoldMu Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix) (ReadPrec (Fix f) -> ReadPrec (Fix f)
forall a. ReadPrec a -> ReadPrec a
step ReadPrec (Fix f)
forall a. Read a => ReadPrec a
readPrec)
#endif

-- | Change base functor in 'Mu'.
hoistMu :: (forall a. f a -> g a) -> Mu f -> Mu g
hoistMu :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Mu f -> Mu g
hoistMu forall a. f a -> g a
n (Mu forall a. (f a -> a) -> a
mk) = (forall a. (g a -> a) -> a) -> Mu g
forall (f :: * -> *). (forall a. (f a -> a) -> a) -> Mu f
Mu ((forall a. (g a -> a) -> a) -> Mu g)
-> (forall a. (g a -> a) -> a) -> Mu g
forall a b. (a -> b) -> a -> b
$ \g a -> a
roll -> (f a -> a) -> a
forall a. (f a -> a) -> a
mk (g a -> a
roll (g a -> a) -> (f a -> g a) -> f a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> g a
forall a. f a -> g a
n)

-- | Fold 'Mu'.
--
-- >>> let mu = unfoldMu (\i -> if i < 4 then Cons i (i + 1) else Nil) (0 :: Int)
-- >>> foldMu (elimListF 0 (+)) mu
-- 6
foldMu :: (f a -> a) -> Mu f -> a
foldMu :: forall (f :: * -> *) a. (f a -> a) -> Mu f -> a
foldMu f a -> a
f (Mu forall a. (f a -> a) -> a
mk) = (f a -> a) -> a
forall a. (f a -> a) -> a
mk f a -> a
f

-- | Unfold 'Mu'.
--
-- >>> unfoldMu (\i -> if i < 4 then Cons i (i + 1) else Nil) (0 :: Int)
-- unfoldMu unFix (Fix (Cons 0 (Fix (Cons 1 (Fix (Cons 2 (Fix (Cons 3 (Fix Nil)))))))))
unfoldMu :: Functor f => (a -> f a) -> a -> Mu f
unfoldMu :: forall (f :: * -> *) a. Functor f => (a -> f a) -> a -> Mu f
unfoldMu a -> f a
f a
x = (forall a. (f a -> a) -> a) -> Mu f
forall (f :: * -> *). (forall a. (f a -> a) -> a) -> Mu f
Mu ((forall a. (f a -> a) -> a) -> Mu f)
-> (forall a. (f a -> a) -> a) -> Mu f
forall a b. (a -> b) -> a -> b
$ \f a -> a
mk -> (f a -> a) -> (a -> f a) -> a -> a
forall (f :: * -> *) b a.
Functor f =>
(f b -> b) -> (a -> f a) -> a -> b
refold f a -> a
mk a -> f a
f a
x

-- | Wrap 'Mu'.
--
-- >>> let x = unfoldMu (\i -> if i < 3 then Cons i (i + 1) else Nil) (0 :: Int)
-- >>> wrapMu (Cons 10 x)
-- unfoldMu unFix (Fix (Cons 10 (Fix (Cons 0 (Fix (Cons 1 (Fix (Cons 2 (Fix Nil)))))))))
--
-- @since 0.3.2
--
wrapMu :: Functor f => f (Mu f) -> Mu f
wrapMu :: forall (f :: * -> *). Functor f => f (Mu f) -> Mu f
wrapMu f (Mu f)
fx = (forall a. (f a -> a) -> a) -> Mu f
forall (f :: * -> *). (forall a. (f a -> a) -> a) -> Mu f
Mu ((forall a. (f a -> a) -> a) -> Mu f)
-> (forall a. (f a -> a) -> a) -> Mu f
forall a b. (a -> b) -> a -> b
$ \f a -> a
f -> f a -> a
f ((Mu f -> a) -> f (Mu f) -> f a
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((f a -> a) -> Mu f -> a
forall (f :: * -> *) a. (f a -> a) -> Mu f -> a
foldMu f a -> a
f) f (Mu f)
fx)

-- | Unwrap 'Mu'.
--
-- >>> let x = unfoldMu (\i -> if i < 3 then Cons i (i + 1) else Nil) (0 :: Int)
-- >>> unwrapMu x
-- Cons 0 (unfoldMu unFix (Fix (Cons 1 (Fix (Cons 2 (Fix Nil))))))
--
-- @since 0.3.2
--
unwrapMu :: Functor f => Mu f -> f (Mu f)
unwrapMu :: forall (f :: * -> *). Functor f => Mu f -> f (Mu f)
unwrapMu = (f (f (Mu f)) -> f (Mu f)) -> Mu f -> f (Mu f)
forall (f :: * -> *) a. (f a -> a) -> Mu f -> a
foldMu ((f (Mu f) -> Mu f) -> f (f (Mu f)) -> f (Mu f)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (Mu f) -> Mu f
forall (f :: * -> *). Functor f => f (Mu f) -> Mu f
wrapMu)

-------------------------------------------------------------------------------
-- Nu
-------------------------------------------------------------------------------

-- | Greatest fixed point. Efficient unfolding.
data Nu f = forall a. Nu (a -> f a) a

instance (Functor f, Eq1 f) => Eq (Nu f) where
    == :: Nu f -> Nu f -> Bool
(==) = Fix f -> Fix f -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Fix f -> Fix f -> Bool) -> (Nu f -> Fix f) -> Nu f -> Nu f -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (f (Fix f) -> Fix f) -> Nu f -> Fix f
forall (f :: * -> *) a. Functor f => (f a -> a) -> Nu f -> a
foldNu f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix

instance (Functor f, Ord1 f) => Ord (Nu f) where
    compare :: Nu f -> Nu f -> Ordering
compare = Fix f -> Fix f -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Fix f -> Fix f -> Ordering)
-> (Nu f -> Fix f) -> Nu f -> Nu f -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (f (Fix f) -> Fix f) -> Nu f -> Fix f
forall (f :: * -> *) a. Functor f => (f a -> a) -> Nu f -> a
foldNu f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix

instance (Functor f, Show1 f) => Show (Nu f) where
    showsPrec :: Int -> Nu f -> ShowS
showsPrec Int
d Nu f
f = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
        String -> ShowS
showString String
"unfoldNu unFix " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Fix f -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 ((f (Fix f) -> Fix f) -> Nu f -> Fix f
forall (f :: * -> *) a. Functor f => (f a -> a) -> Nu f -> a
foldNu f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix Nu f
f)

#ifdef __GLASGOW_HASKELL__
instance (Functor f, Read1 f) => Read (Nu f) where
    readPrec :: ReadPrec (Nu f)
readPrec = ReadPrec (Nu f) -> ReadPrec (Nu f)
forall a. ReadPrec a -> ReadPrec a
parens (ReadPrec (Nu f) -> ReadPrec (Nu f))
-> ReadPrec (Nu f) -> ReadPrec (Nu f)
forall a b. (a -> b) -> a -> b
$ Int -> ReadPrec (Nu f) -> ReadPrec (Nu f)
forall a. Int -> ReadPrec a -> ReadPrec a
prec Int
10 (ReadPrec (Nu f) -> ReadPrec (Nu f))
-> ReadPrec (Nu f) -> ReadPrec (Nu f)
forall a b. (a -> b) -> a -> b
$ do
        Ident String
"unfoldNu" <- ReadPrec Lexeme
lexP
        Ident String
"unFix" <- ReadPrec Lexeme
lexP
        (Fix f -> Nu f) -> ReadPrec (Fix f) -> ReadPrec (Nu f)
forall a b. (a -> b) -> ReadPrec a -> ReadPrec b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Fix f -> f (Fix f)) -> Fix f -> Nu f
forall a (f :: * -> *). (a -> f a) -> a -> Nu f
unfoldNu Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix) (ReadPrec (Fix f) -> ReadPrec (Fix f)
forall a. ReadPrec a -> ReadPrec a
step ReadPrec (Fix f)
forall a. Read a => ReadPrec a
readPrec)
#endif

-- | Change base functor in 'Nu'.
hoistNu :: (forall a. f a -> g a) -> Nu f -> Nu g
hoistNu :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Nu f -> Nu g
hoistNu forall a. f a -> g a
n (Nu a -> f a
next a
seed) = (a -> g a) -> a -> Nu g
forall (f :: * -> *) a. (a -> f a) -> a -> Nu f
Nu (f a -> g a
forall a. f a -> g a
n (f a -> g a) -> (a -> f a) -> a -> g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
next) a
seed

-- | Fold 'Nu'.
--
-- >>> let nu = unfoldNu (\i -> if i < 4 then Cons i (i + 1) else Nil) (0 :: Int)
-- >>> foldNu (elimListF 0 (+)) nu
-- 6
--
foldNu :: Functor f => (f a -> a) -> Nu f -> a
foldNu :: forall (f :: * -> *) a. Functor f => (f a -> a) -> Nu f -> a
foldNu f a -> a
f (Nu a -> f a
next a
seed) = (f a -> a) -> (a -> f a) -> a -> a
forall (f :: * -> *) b a.
Functor f =>
(f b -> b) -> (a -> f a) -> a -> b
refold f a -> a
f a -> f a
next a
seed

-- | Unfold 'Nu'.
--
-- >>> unfoldNu (\i -> if i < 4 then Cons i (i + 1) else Nil) (0 :: Int)
-- unfoldNu unFix (Fix (Cons 0 (Fix (Cons 1 (Fix (Cons 2 (Fix (Cons 3 (Fix Nil)))))))))
unfoldNu :: (a -> f a) -> a -> Nu f
unfoldNu :: forall a (f :: * -> *). (a -> f a) -> a -> Nu f
unfoldNu = (a -> f a) -> a -> Nu f
forall (f :: * -> *) a. (a -> f a) -> a -> Nu f
Nu

-- | Wrap 'Nu'.
--
-- >>> let x = unfoldNu (\i -> if i < 3 then Cons i (i + 1) else Nil) (0 :: Int)
-- >>> wrapNu (Cons 10 x)
-- unfoldNu unFix (Fix (Cons 10 (Fix (Cons 0 (Fix (Cons 1 (Fix (Cons 2 (Fix Nil)))))))))
--
-- @since 0.3.2
--
wrapNu :: Functor f => f (Nu f) -> Nu f
wrapNu :: forall (f :: * -> *). Functor f => f (Nu f) -> Nu f
wrapNu = (f (Nu f) -> f (f (Nu f))) -> f (Nu f) -> Nu f
forall a (f :: * -> *). (a -> f a) -> a -> Nu f
unfoldNu ((Nu f -> f (Nu f)) -> f (Nu f) -> f (f (Nu f))
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Nu f -> f (Nu f)
forall (f :: * -> *). Functor f => Nu f -> f (Nu f)
unwrapNu)

-- | Unwrap 'Nu'.
--
-- >>> let x = unfoldNu (\i -> if i < 3 then Cons i (i + 1) else Nil) (0 :: Int)
-- >>> unwrapNu x
-- Cons 0 (unfoldNu unFix (Fix (Cons 1 (Fix (Cons 2 (Fix Nil))))))
--
-- @since 0.3.2
--
unwrapNu :: Functor f => Nu f -> f (Nu f)
unwrapNu :: forall (f :: * -> *). Functor f => Nu f -> f (Nu f)
unwrapNu (Nu a -> f a
f a
x) = (a -> Nu f) -> f a -> f (Nu f)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> f a) -> a -> Nu f
forall (f :: * -> *) a. (a -> f a) -> a -> Nu f
Nu a -> f a
f) (a -> f a
f a
x)

-------------------------------------------------------------------------------
-- refold
-------------------------------------------------------------------------------

-- | Refold one recursive type into another, one layer at the time.
--
refold :: Functor f => (f b -> b) -> (a -> f a) -> a -> b
refold :: forall (f :: * -> *) b a.
Functor f =>
(f b -> b) -> (a -> f a) -> a -> b
refold f b -> b
f a -> f a
g = a -> b
h where h :: a -> b
h = f b -> b
f (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 a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
h (f a -> f b) -> (a -> f a) -> a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
g

-------------------------------------------------------------------------------
-- Monadic variants
-------------------------------------------------------------------------------

-- | Monadic 'foldFix'.
--
foldFixM:: (Monad m, Traversable t)
    => (t a -> m a) -> Fix t -> m a
foldFixM :: forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Traversable t) =>
(t a -> m a) -> Fix t -> m a
foldFixM t a -> m a
f = Fix t -> m a
go where go :: Fix t -> m a
go = (t a -> m a
f (t a -> m a) -> m (t a) -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (m (t a) -> m a) -> (Fix t -> m (t a)) -> Fix t -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fix t -> m a) -> t (Fix t) -> m (t a)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
mapM Fix t -> m a
go (t (Fix t) -> m (t a)) -> (Fix t -> t (Fix t)) -> Fix t -> m (t a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix t -> t (Fix t)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix

-- | Monadic anamorphism.
unfoldFixM :: (Monad m, Traversable t)
    => (a -> m (t a)) -> (a -> m (Fix t))
unfoldFixM :: forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Traversable t) =>
(a -> m (t a)) -> a -> m (Fix t)
unfoldFixM a -> m (t a)
f = a -> m (Fix t)
go where go :: a -> m (Fix t)
go = (t (Fix t) -> Fix t) -> m (t (Fix t)) -> m (Fix t)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM t (Fix t) -> Fix t
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (m (t (Fix t)) -> m (Fix t))
-> (a -> m (t (Fix t))) -> a -> m (Fix t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> m (Fix t)) -> t a -> m (t (Fix t))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
mapM a -> m (Fix t)
go (t a -> m (t (Fix t))) -> m (t a) -> m (t (Fix t))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (m (t a) -> m (t (Fix t))) -> (a -> m (t a)) -> a -> m (t (Fix t))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m (t a)
f

-- | Monadic hylomorphism.
refoldM :: (Monad m, Traversable t)
    => (t b -> m b) -> (a -> m (t a)) -> (a -> m b)
refoldM :: forall (m :: * -> *) (t :: * -> *) b a.
(Monad m, Traversable t) =>
(t b -> m b) -> (a -> m (t a)) -> a -> m b
refoldM t b -> m b
phi a -> m (t a)
psi = a -> m b
go where go :: a -> m b
go = (t b -> m b
phi (t b -> m b) -> m (t b) -> m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (m (t b) -> m b) -> (a -> m (t b)) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> m b) -> t a -> m (t b)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
mapM a -> m b
go (t a -> m (t b)) -> m (t a) -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (m (t a) -> m (t b)) -> (a -> m (t a)) -> a -> m (t b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m (t a)
psi

-------------------------------------------------------------------------------
-- Deprecated aliases
-------------------------------------------------------------------------------

-- | Catamorphism or generic function fold.
cata :: Functor f => (f a -> a) -> (Fix f -> a)
cata :: forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
cata = (f a -> a) -> Fix f -> a
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix
{-# DEPRECATED cata "Use foldFix" #-}

-- | Anamorphism or generic function unfold.
ana :: Functor f => (a -> f a) -> (a -> Fix f)
ana :: forall (f :: * -> *) a. Functor f => (a -> f a) -> a -> Fix f
ana = (a -> f a) -> a -> Fix f
forall (f :: * -> *) a. Functor f => (a -> f a) -> a -> Fix f
unfoldFix
{-# DEPRECATED ana "Use unfoldFix" #-}

-- | Hylomorphism is anamorphism followed by catamorphism.
hylo :: Functor f => (f b -> b) -> (a -> f a) -> (a -> b)
hylo :: forall (f :: * -> *) b a.
Functor f =>
(f b -> b) -> (a -> f a) -> a -> b
hylo = (f b -> b) -> (a -> f a) -> a -> b
forall (f :: * -> *) b a.
Functor f =>
(f b -> b) -> (a -> f a) -> a -> b
refold
{-# DEPRECATED hylo "Use refold" #-}

-- | Monadic catamorphism.
cataM :: (Monad m, Traversable t)
    => (t a -> m a) -> Fix t -> m a
cataM :: forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Traversable t) =>
(t a -> m a) -> Fix t -> m a
cataM = (t a -> m a) -> Fix t -> m a
forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Traversable t) =>
(t a -> m a) -> Fix t -> m a
foldFixM
{-# DEPRECATED cataM "Use foldFixM" #-}

-- | Monadic anamorphism.
anaM :: (Monad m, Traversable t)
    => (a -> m (t a)) -> (a -> m (Fix t))
anaM :: forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Traversable t) =>
(a -> m (t a)) -> a -> m (Fix t)
anaM = (a -> m (t a)) -> a -> m (Fix t)
forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Traversable t) =>
(a -> m (t a)) -> a -> m (Fix t)
unfoldFixM
{-# DEPRECATED anaM "Use unfoldFixM" #-}

-- | Monadic hylomorphism.
hyloM :: (Monad m, Traversable t)
    => (t b -> m b) -> (a -> m (t a)) -> (a -> m b)
hyloM :: forall (m :: * -> *) (t :: * -> *) b a.
(Monad m, Traversable t) =>
(t b -> m b) -> (a -> m (t a)) -> a -> m b
hyloM = (t b -> m b) -> (a -> m (t a)) -> a -> m b
forall (m :: * -> *) (t :: * -> *) b a.
(Monad m, Traversable t) =>
(t b -> m b) -> (a -> m (t a)) -> a -> m b
refoldM
{-# DEPRECATED hyloM "Use refoldM" #-}