yaya 0.4.2.0 → 0.4.2.1
raw patch · 10 files changed
+508/−431 lines, 10 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Yaya.Fold: data Mu f
+ Yaya.Fold: newtype Mu f
Files
- src/Yaya/Applied.hs +25/−18
- src/Yaya/Experimental/Foldable.hs +22/−13
- src/Yaya/Fold.hs +118/−101
- src/Yaya/Fold/Common.hs +15/−13
- src/Yaya/Fold/Native.hs +21/−20
- src/Yaya/Functor.hs +24/−24
- src/Yaya/Pattern.hs +1/−2
- src/Yaya/Retrofit.hs +190/−156
- src/Yaya/Zoo.hs +85/−83
- yaya.cabal +7/−1
src/Yaya/Applied.hs view
@@ -2,7 +2,6 @@ import Control.Monad.Trans.Free import Data.Functor.Identity- import Yaya.Fold import Yaya.Fold.Common import Yaya.Pattern@@ -41,15 +40,19 @@ -- | Extracts _no more than_ @n@ elements from the possibly-infinite sequence -- @s@.-takeUpTo- :: (Recursive (->) n Maybe, Projectable (->) s (XNor a), Steppable (->) l (XNor a))- => n -> s -> l+takeUpTo ::+ (Recursive (->) n Maybe, Projectable (->) s (XNor a), Steppable (->) l (XNor a)) =>+ n ->+ s ->+ l takeUpTo = cata2 (embed . takeAvailable) -- | Extracts _exactly_ @n@ elements from the infinite stream @s@.-take- :: (Recursive (->) n Maybe, Projectable (->) s ((,) a), Steppable (->) l (XNor a))- => n -> s -> l+take ::+ (Recursive (->) n Maybe, Projectable (->) s ((,) a), Steppable (->) l (XNor a)) =>+ n ->+ s ->+ l take = cata2 (embed . takeAnother) -- | Extracts the element at a finite index of an infinite sequence (a `!!` that@@ -59,21 +62,23 @@ -- | Extracts the element at a finite index of a (co)list (a `!!` that fails -- with `Nothing`).-atMay- :: (Recursive (->) n Maybe, Projectable (->) s (XNor a)) => n -> s -> Maybe a+atMay ::+ (Recursive (->) n Maybe, Projectable (->) s (XNor a)) => n -> s -> Maybe a atMay = cata2 maybeTakeNext -- | Turns part of a structure inductive, so it can be analyzed, without forcing -- the entire tree.-maybeReify- :: (Projectable (->) s f, Steppable (->) l (FreeF f s), Functor f)- => Algebra (->) Maybe (s -> l)+maybeReify ::+ (Projectable (->) s f, Steppable (->) l (FreeF f s), Functor f) =>+ Algebra (->) Maybe (s -> l) maybeReify Nothing = embed . Pure maybeReify (Just f) = embed . Free . fmap f . project -reifyUpTo- :: (Recursive (->) n Maybe, Projectable (->) s f, Steppable (->) l (FreeF f s), Functor f)- => n -> s -> l+reifyUpTo ::+ (Recursive (->) n Maybe, Projectable (->) s f, Steppable (->) l (FreeF f s), Functor f) =>+ n ->+ s ->+ l reifyUpTo = cata maybeReify fibonacciPolynomials :: (Integral i, Corecursive (->) t ((,) i)) => i -> t@@ -107,7 +112,9 @@ -- | Lops off the branches of the tree below a certain depth, turning a -- potentially-infinite structure into a finite one. Like a generalized -- `Yaya.Applied.take`.-truncate- :: (Recursive (->) n Maybe, Projectable (->) t f, Steppable (->) u (FreeF f ()), Functor f)- => n -> t -> u+truncate ::+ (Recursive (->) n Maybe, Projectable (->) t f, Steppable (->) u (FreeF f ()), Functor f) =>+ n ->+ t ->+ u truncate = cata2 (embed . truncate')
src/Yaya/Experimental/Foldable.hs view
@@ -7,7 +7,6 @@ module Yaya.Experimental.Foldable where import Control.Monad.Trans.Free- import Yaya.Fold import Yaya.Fold.Common import Yaya.Pattern@@ -21,27 +20,37 @@ -- specialized to lists. class Listable f where naturalList :: f a b -> Free (XNor a) b- -- toColist :: (Projectable t (f a), Corecursive (->) u (XNor a)) => t -> u- -- toColist = elgotAna seqFree (naturalList . project)- -- toList :: (Recursive (->) t (f a), Steppable u (XNor a)) => t -> u- -- toList = cata (embed . unFree . naturalList) +-- toColist :: (Projectable t (f a), Corecursive (->) u (XNor a)) => t -> u+-- toColist = elgotAna seqFree (naturalList . project)+-- toList :: (Recursive (->) t (f a), Steppable u (XNor a)) => t -> u+-- toList = cata (embed . unFree . naturalList)+ -- FIXME: Use @cata . liftCoEnv@ instead of `iter`. -- | This is simply `cata` applied to a list – the function is the @Cons@ -- case, while the initial value is the @Nil@ case. foldr :: (Listable f, Recursive (->) t (f a)) => (a -> b -> b) -> b -> t -> b foldr f b =- cata (iter (\case- Neither -> b- Both a r -> f a r)- . naturalList)+ cata+ ( iter+ ( \case+ Neither -> b+ Both a r -> f a r+ )+ . naturalList+ ) -- | Simply `cata` with a carrier of @b -> b@. foldl :: (Listable f, Recursive (->) t (f a)) => (b -> a -> b) -> b -> t -> b foldl f = flip- (cata (iter (\case- Neither -> id- Both a g -> g . flip f a)- . naturalList))+ ( cata+ ( iter+ ( \case+ Neither -> id+ Both a g -> g . flip f a+ )+ . naturalList+ )+ )
src/Yaya/Fold.hs view
@@ -15,28 +15,36 @@ import Data.Foldable import Data.Functor.Classes import Data.Functor.Day-import Data.List.NonEmpty (NonEmpty(..))+import Data.List.NonEmpty (NonEmpty (..)) import Data.Void import Numeric.Natural- import Yaya.Fold.Common import Yaya.Functor import Yaya.Pattern type Algebra c f a = f a `c` a+ type GAlgebra c w f a = f (w a) `c` a+ type ElgotAlgebra c w f a = w (f a) `c` a+ type AlgebraM c m f a = f a `c` m a+ type GAlgebraM c m w f a = f (w a) `c` m a+ type ElgotAlgebraM c m w f a = w (f a) `c` m a type Coalgebra c f a = a `c` f a+ type GCoalgebra c m f a = a `c` f (m a)+ type ElgotCoalgebra c m f a = a `c` m (f a)+ -- | Note that using a `CoalgebraM` “directly” is partial (e.g., with -- `Yaya.Unsafe.Fold.anaM`). However, @ana . Compose@ can accept a `CoalgebraM` -- and produce something like an effectful stream. type CoalgebraM c m f a = a `c` m (f a)+ type GCoalgebraM c m n f a = a `c` m (f (n a)) -- | This type class is lawless on its own, but there exist types that can’t@@ -63,22 +71,24 @@ -- | An implementation of `Eq` for any `Recursive` instance. Note that this is -- actually more general than `Eq`, as it can compare between different -- fixed-point representations of the same functor.-recursiveEq- :: (Recursive (->) t f, Steppable (->) u f, Functor f, Foldable f, Eq1 f)- => t -> u -> Bool+recursiveEq ::+ (Recursive (->) t f, Steppable (->) u f, Functor f, Foldable f, Eq1 f) =>+ t ->+ u ->+ Bool recursiveEq = cata2 equal -- | An implementation of `Show` for any `Recursive` instance. recursiveShowsPrec :: (Recursive (->) t f, Show1 f) => Int -> t -> ShowS recursiveShowsPrec prec =- cata (showParen True . liftShowsPrec (const id) (foldMap id) prec)+ cata (showParen True . liftShowsPrec (const id) fold prec) -- | A fixed-point operator for inductive / finite data structures. -- -- *NB*: This is only guaranteed to be finite when @f a@ is strict in @a@ -- (having strict functors won't prevent `Nu` from being lazy). Using -- @-XStrictData@ can help with this a lot.-data Mu f = Mu (forall a. Algebra (->) f a -> a)+newtype Mu f = Mu (forall a. Algebra (->) f a -> a) instance Functor f => Projectable (->) (Mu f) f where project = lambek@@ -90,7 +100,7 @@ cata φ (Mu f) = f φ instance DFunctor Mu where- dmap f (Mu run) = Mu (\φ -> run (φ . f))+ dmap f (Mu run) = Mu (\φ -> run (φ . f)) instance Show1 f => Show (Mu f) where showsPrec = recursiveShowsPrec@@ -115,19 +125,19 @@ dmap f (Nu φ a) = Nu (f . φ) a instance Projectable (->) [a] (XNor a) where- project [] = Neither+ project [] = Neither project (h : t) = Both h t instance Steppable (->) [a] (XNor a) where- embed Neither = []+ embed Neither = [] embed (Both h t) = h : t instance Projectable (->) (NonEmpty a) (AndMaybe a) where- project (a :| []) = Only a+ project (a :| []) = Only a project (a :| b : bs) = Indeed a (b :| bs) instance Steppable (->) (NonEmpty a) (AndMaybe a) where- embed (Only a) = a :| []+ embed (Only a) = a :| [] embed (Indeed a b) = a :| toList b instance Projectable (->) Natural Maybe where@@ -161,13 +171,15 @@ -- | Combines two `Algebra`s with different carriers into a single tupled -- `Algebra`. zipAlgebras :: Functor f => Algebra (->) f a -> Algebra (->) f b -> Algebra (->) f (a, b)-zipAlgebras f g = (f . fmap fst &&& g . fmap snd)+zipAlgebras f g = f . fmap fst &&& g . fmap snd -- | Combines two `AlgebraM`s with different carriers into a single tupled -- `AlgebraM`.-zipAlgebraMs- :: (Applicative m, Functor f)- => AlgebraM (->) m f a -> AlgebraM (->) m f b -> AlgebraM (->) m f (a, b)+zipAlgebraMs ::+ (Applicative m, Functor f) =>+ AlgebraM (->) m f a ->+ AlgebraM (->) m f b ->+ AlgebraM (->) m f (a, b) zipAlgebraMs f g = uncurry (liftA2 (,)) . (f . fmap fst &&& g . fmap snd) -- | Algebras over Day convolution are convenient for binary operations, but@@ -181,95 +193,97 @@ cata2 = cata . lowerDay -- | Makes it possible to provide a `GAlgebra` to `cata`.-lowerAlgebra- :: (Functor f, Comonad w)- => DistributiveLaw (->) f w- -> GAlgebra (->) w f a- -> Algebra (->) f (w a)+lowerAlgebra ::+ (Functor f, Comonad w) =>+ DistributiveLaw (->) f w ->+ GAlgebra (->) w f a ->+ Algebra (->) f (w a) lowerAlgebra k φ = fmap φ . k . fmap duplicate -- | Makes it possible to provide a `GAlgebraM` to `Yaya.Zoo.cataM`.-lowerAlgebraM- :: (Applicative m, Traversable f, Comonad w, Traversable w)- => DistributiveLaw (->) f w- -> GAlgebraM (->) m w f a- -> AlgebraM (->) m f (w a)+lowerAlgebraM ::+ (Applicative m, Traversable f, Comonad w, Traversable w) =>+ DistributiveLaw (->) f w ->+ GAlgebraM (->) m w f a ->+ AlgebraM (->) m f (w a) lowerAlgebraM k φ = traverse φ . k . fmap duplicate -- | Makes it possible to provide a `GCoalgebra` to `ana`.-lowerCoalgebra- :: (Functor f, Monad m)- => DistributiveLaw (->) m f- -> GCoalgebra (->) m f a- -> Coalgebra (->) f (m a)+lowerCoalgebra ::+ (Functor f, Monad m) =>+ DistributiveLaw (->) m f ->+ GCoalgebra (->) m f a ->+ Coalgebra (->) f (m a) lowerCoalgebra k ψ = fmap join . k . fmap ψ -- | Makes it possible to provide a `GCoalgebraM` to `Yaya.Unsafe.Fold.anaM`.-lowerCoalgebraM- :: (Applicative m, Traversable f, Monad n, Traversable n)- => DistributiveLaw (->) n f- -> GCoalgebraM (->) m n f a- -> CoalgebraM (->) m f (n a)+lowerCoalgebraM ::+ (Applicative m, Traversable f, Monad n, Traversable n) =>+ DistributiveLaw (->) n f ->+ GCoalgebraM (->) m n f a ->+ CoalgebraM (->) m f (n a) lowerCoalgebraM k ψ = fmap (fmap join . k) . traverse ψ -gcata- :: (Recursive (->) t f, Functor f, Comonad w)- => DistributiveLaw (->) f w- -> GAlgebra (->) w f a- -> t- -> a+gcata ::+ (Recursive (->) t f, Functor f, Comonad w) =>+ DistributiveLaw (->) f w ->+ GAlgebra (->) w f a ->+ t ->+ a gcata k φ = extract . cata (lowerAlgebra k φ) -elgotCata- :: (Recursive (->) t f, Functor f, Comonad w)- => DistributiveLaw (->) f w- -> ElgotAlgebra (->) w f a- -> t- -> a+elgotCata ::+ (Recursive (->) t f, Functor f, Comonad w) =>+ DistributiveLaw (->) f w ->+ ElgotAlgebra (->) w f a ->+ t ->+ a elgotCata k φ = φ . cata (k . fmap (extend φ)) -gcataM- :: (Monad m, Recursive (->) t f, Traversable f, Comonad w, Traversable w)- => DistributiveLaw (->) f w- -> GAlgebraM (->) m w f a- -> t- -> m a+gcataM ::+ (Monad m, Recursive (->) t f, Traversable f, Comonad w, Traversable w) =>+ DistributiveLaw (->) f w ->+ GAlgebraM (->) m w f a ->+ t ->+ m a gcataM w φ = fmap extract . cata (lowerAlgebraM w φ <=< sequenceA) -elgotCataM- :: (Monad m, Recursive (->) t f, Traversable f, Comonad w, Traversable w)- => DistributiveLaw (->) f w- -> ElgotAlgebraM (->) m w f a- -> t- -> m a+elgotCataM ::+ (Monad m, Recursive (->) t f, Traversable f, Comonad w, Traversable w) =>+ DistributiveLaw (->) f w ->+ ElgotAlgebraM (->) m w f a ->+ t ->+ m a elgotCataM w φ = φ <=< cata (fmap w . traverse (sequence . extend φ) <=< sequenceA) -ezygoM- :: (Monad m, Recursive (->) t f, Traversable f)- => AlgebraM (->) m f b- -> ElgotAlgebraM (->) m ((,) b) f a- -> t- -> m a+ezygoM ::+ (Monad m, Recursive (->) t f, Traversable f) =>+ AlgebraM (->) m f b ->+ ElgotAlgebraM (->) m ((,) b) f a ->+ t ->+ m a ezygoM φ' φ = fmap snd- . cata ((\x@(b, _) -> (b,) <$> φ x)- <=< bisequence . (φ' . fmap fst &&& pure . fmap snd)- <=< sequenceA)+ . cata+ ( (\x@(b, _) -> (b,) <$> φ x)+ <=< bisequence . (φ' . fmap fst &&& pure . fmap snd)+ <=< sequenceA+ ) -gana- :: (Corecursive (->) t f, Functor f, Monad m)- => DistributiveLaw (->) m f- -> GCoalgebra (->) m f a- -> a- -> t+gana ::+ (Corecursive (->) t f, Functor f, Monad m) =>+ DistributiveLaw (->) m f ->+ GCoalgebra (->) m f a ->+ a ->+ t gana k ψ = ana (lowerCoalgebra k ψ) . pure -elgotAna- :: (Corecursive (->) t f, Functor f, Monad m)- => DistributiveLaw (->) m f- -> ElgotCoalgebra (->) m f a- -> a- -> t+elgotAna ::+ (Corecursive (->) t f, Functor f, Monad m) =>+ DistributiveLaw (->) m f ->+ ElgotCoalgebra (->) m f a ->+ a ->+ t elgotAna k ψ = ana (fmap (>>= ψ) . k) . ψ lambek :: (Steppable (->) t f, Recursive (->) t f, Functor f) => Coalgebra (->) f t@@ -295,11 +309,11 @@ distTuple :: Functor f => Algebra (->) f a -> DistributiveLaw (->) f ((,) a) distTuple φ = φ . fmap fst &&& fmap snd -distEnvT- :: Functor f- => Algebra (->) f a- -> DistributiveLaw (->) f w- -> DistributiveLaw (->) f (EnvT a w)+distEnvT ::+ Functor f =>+ Algebra (->) f a ->+ DistributiveLaw (->) f w ->+ DistributiveLaw (->) f (EnvT a w) distEnvT φ k = uncurry EnvT . (φ . fmap ask &&& k . fmap lowerEnvT) seqEither :: Functor f => Coalgebra (->) f a -> DistributiveLaw (->) (Either a) f@@ -307,9 +321,10 @@ -- | Converts an `Algebra` to one that annotates the tree with the result for -- each node.-attributeAlgebra- :: (Steppable (->) t (EnvT a f), Functor f)- => Algebra (->) f a -> Algebra (->) f t+attributeAlgebra ::+ (Steppable (->) t (EnvT a f), Functor f) =>+ Algebra (->) f a ->+ Algebra (->) f t attributeAlgebra φ ft = embed $ EnvT (φ (fmap (fst . runEnvT . project) ft)) ft -- | Converts a `Coalgebra` to one that annotates the tree with the seed that@@ -329,7 +344,7 @@ -- some examples of this. unFree :: Steppable (->) t f => Algebra (->) (FreeF f t) t unFree = \case- Pure t -> t+ Pure t -> t Free ft -> embed ft -- preservingAttribute :: (forall a. f a -> g a) -> EnvT a f b -> EnvT a g b@@ -376,23 +391,25 @@ -- * Optics type BialgebraIso f a = Iso' (f a) a+ type AlgebraPrism f a = Prism' (f a) a+ type CoalgebraPrism f a = Prism' a (f a) steppableIso :: Steppable (->) t f => BialgebraIso f t steppableIso = iso embed project -birecursiveIso- :: (Recursive (->) t f, Corecursive (->) t f)- => BialgebraIso f a- -> Iso' t a+birecursiveIso ::+ (Recursive (->) t f, Corecursive (->) t f) =>+ BialgebraIso f a ->+ Iso' t a birecursiveIso alg = iso (cata (view alg)) (ana (review alg))- -recursivePrism- :: (Recursive (->) t f, Corecursive (->) t f, Traversable f)- => AlgebraPrism f a- -> Prism' t a++recursivePrism ::+ (Recursive (->) t f, Corecursive (->) t f, Traversable f) =>+ AlgebraPrism f a ->+ Prism' t a recursivePrism alg = prism- (ana (review alg))- (\t -> mapLeft (const t) $ cata (matching alg <=< sequenceA) t)+ (ana (review alg))+ (\t -> mapLeft (const t) $ cata (matching alg <=< sequenceA) t)
src/Yaya/Fold/Common.hs view
@@ -8,34 +8,34 @@ import Data.Functor.Day import Data.Functor.Identity import Numeric.Natural- import Yaya.Pattern -- | Converts the free monoid (a list) into some other `Monoid`. lowerMonoid :: Monoid m => (a -> m) -> XNor a m -> m lowerMonoid f = \case- Neither -> mempty+ Neither -> mempty Both a b -> mappend (f a) b -- | Converts the free semigroup (a non-empty list) into some other `Semigroup`. lowerSemigroup :: Semigroup m => (a -> m) -> AndMaybe a m -> m lowerSemigroup f = \case- Only a -> f a+ Only a -> f a Indeed a b -> f a <> b -- | Converts the free monad into some other `Monad`. lowerMonad :: Monad m => (forall x. f x -> m x) -> FreeF f a (m a) -> m a lowerMonad f = \case- Pure a -> pure a+ Pure a -> pure a Free fm -> join (f fm) -- | Provides equality over arbitrary pattern functors. equal :: (Functor f, Foldable f, Eq1 f) => Day f f Bool -> Bool equal (Day f1 f2 fn) = liftEq (==) (void f1) (void f2)- && and (zipWith fn (toList f1) (toList f2))+ && and (zipWith fn (toList f1) (toList f2)) -- TODO: Redefine this using `Natural`+ -- | When folded, returns the height of the data structure. height :: Foldable f => f Integer -> Integer height = (+ 1) . foldr max (-1)@@ -43,6 +43,7 @@ -- NB: It seems like this could be some more general notion of this, like -- size :: (Foldable f, Semiring a) => f a -> a -- size = foldr (+) one+ -- | When folded, returns the number of nodes in the data structure. -- -- __NB__: This is /not/ the same as the length when applied to a list. I.e.,@@ -72,34 +73,34 @@ le :: Day Maybe Maybe Bool -> Bool le = \case- Day Nothing _ _ -> True+ Day Nothing _ _ -> True Day (Just a) (Just b) f -> f a b- Day (Just _) Nothing _ -> False+ Day (Just _) Nothing _ -> False takeAnother :: Day Maybe ((,) a) b -> XNor a b takeAnother = \case- Day Nothing _ _ -> Neither+ Day Nothing _ _ -> Neither Day (Just x) (h, t) f -> Both h (f x t) takeAvailable :: Day Maybe (XNor a) b -> XNor a b takeAvailable = \case- Day Nothing _ _ -> Neither+ Day Nothing _ _ -> Neither Day (Just x) t f -> fmap (f x) t takeNext :: Day Maybe ((,) a) a -> a takeNext = \case- Day Nothing (h, _) _ -> h+ Day Nothing (h, _) _ -> h Day (Just x) (_, t) f -> f x t maybeTakeNext :: Day Maybe (XNor a) (Maybe a) -> Maybe a maybeTakeNext = \case- Day Nothing (Both h _) _ -> Just h+ Day Nothing (Both h _) _ -> Just h Day (Just x) (Both _ t) f -> f x t- Day _ Neither _ -> Nothing+ Day _ Neither _ -> Nothing truncate' :: Functor f => Day Maybe f a -> FreeF f () a truncate' = \case- Day Nothing _ _ -> Pure ()+ Day Nothing _ _ -> Pure () Day (Just n) fa f -> Free (fmap (f n) fa) -- | Converts a single value into a tuple with the same value on both sides.@@ -108,6 +109,7 @@ diagonal x = (x, x) -- * sequence generators+ -- -- These functions are defined with different type parameters in order to -- constrain the implementation, but to be used as coalgebras, all of the
src/Yaya/Fold/Native.hs view
@@ -1,4 +1,4 @@-{-# options_ghc -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-orphans #-} -- | Uses of recursion schemes that use Haskell’s built-in recursion in a total -- manner.@@ -11,13 +11,12 @@ import Control.Monad.Trans.Free import Data.List.NonEmpty import Numeric.Natural- import Yaya.Fold import Yaya.Pattern -- | A fixed-point constructor that uses Haskell's built-in recursion. This is -- lazy/corecursive.-newtype Fix f = Fix { unFix :: f (Fix f) }+newtype Fix f = Fix {unFix :: f (Fix f)} instance Projectable (->) (Fix f) f where project = unFix@@ -33,32 +32,34 @@ instance Corecursive (->) [a] (XNor a) where ana ψ =- (\case- Neither -> []- Both h t -> h : ana ψ t)- . ψ+ ( \case+ Neither -> []+ Both h t -> h : ana ψ t+ )+ . ψ instance Corecursive (->) (NonEmpty a) (AndMaybe a) where ana ψ =- (\case- Only h -> h :| []- Indeed h t -> h :| toList (ana ψ t))- . ψ+ ( \case+ Only h -> h :| []+ Indeed h t -> h :| toList (ana ψ t)+ )+ . ψ instance Functor f => Corecursive (->) (Free f a) (FreeF f a) where ana ψ = free- . (\case- Pure a -> Pure a- Free fb -> Free . fmap (ana ψ) $ fb)- . ψ+ . ( \case+ Pure a -> Pure a+ Free fb -> Free . fmap (ana ψ) $ fb+ )+ . ψ instance Functor f => Corecursive (->) (Cofree f a) (EnvT a f) where ana ψ = uncurry (:<) . fmap (fmap (ana ψ)) . runEnvT . ψ -distCofreeT- :: (Functor f, Functor h)- => DistributiveLaw (->) f h- -> DistributiveLaw (->) f (Cofree h)+distCofreeT ::+ (Functor f, Functor h) =>+ DistributiveLaw (->) f h ->+ DistributiveLaw (->) f (Cofree h) distCofreeT k = ana $ uncurry EnvT . (fmap extract &&& k . fmap unwrap)-
src/Yaya/Functor.hs view
@@ -4,15 +4,15 @@ import Control.Applicative.Backwards (Backwards (..)) import Control.Applicative.Lift (Lift (..))-import qualified Control.Monad.Trans.Except as Ex-import qualified Control.Monad.Trans.Identity as I-import qualified Control.Monad.Trans.Maybe as M-import qualified Control.Monad.Trans.Reader as R-import qualified Control.Monad.Trans.RWS.Lazy as RWS-import qualified Control.Monad.Trans.RWS.Strict as RWS'-import qualified Control.Monad.Trans.State.Lazy as S-import qualified Control.Monad.Trans.State.Strict as S'-import qualified Control.Monad.Trans.Writer.Lazy as W'+import qualified Control.Monad.Trans.Except as Ex+import qualified Control.Monad.Trans.Identity as I+import qualified Control.Monad.Trans.Maybe as M+import qualified Control.Monad.Trans.RWS.Lazy as RWS+import qualified Control.Monad.Trans.RWS.Strict as RWS'+import qualified Control.Monad.Trans.Reader as R+import qualified Control.Monad.Trans.State.Lazy as S+import qualified Control.Monad.Trans.State.Strict as S'+import qualified Control.Monad.Trans.Writer.Lazy as W' import qualified Control.Monad.Trans.Writer.Strict as W import Data.Bifunctor import Data.Functor.Compose (Compose (..))@@ -40,44 +40,44 @@ hmap :: (forall x. f x -> g x) -> h f a -> h g a instance HFunctor (Ex.ExceptT e) where- hmap nat m = Ex.ExceptT (nat (Ex.runExceptT m))+ hmap nat m = Ex.ExceptT (nat (Ex.runExceptT m)) instance HFunctor I.IdentityT where- hmap nat m = I.IdentityT (nat (I.runIdentityT m))+ hmap nat m = I.IdentityT (nat (I.runIdentityT m)) instance HFunctor M.MaybeT where- hmap nat m = M.MaybeT (nat (M.runMaybeT m))+ hmap nat m = M.MaybeT (nat (M.runMaybeT m)) instance HFunctor (R.ReaderT r) where- hmap nat m = R.ReaderT (\i -> nat (R.runReaderT m i))+ hmap nat m = R.ReaderT $ nat . R.runReaderT m instance HFunctor (RWS.RWST r w s) where- hmap nat m = RWS.RWST (\r s -> nat (RWS.runRWST m r s))+ hmap nat m = RWS.RWST (\r s -> nat (RWS.runRWST m r s)) instance HFunctor (RWS'.RWST r w s) where- hmap nat m = RWS'.RWST (\r s -> nat (RWS'.runRWST m r s))+ hmap nat m = RWS'.RWST (\r s -> nat (RWS'.runRWST m r s)) instance HFunctor (S.StateT s) where- hmap nat m = S.StateT (\s -> nat (S.runStateT m s))+ hmap nat m = S.StateT $ nat . S.runStateT m instance HFunctor (S'.StateT s) where- hmap nat m = S'.StateT (\s -> nat (S'.runStateT m s))+ hmap nat m = S'.StateT $ nat . S'.runStateT m instance HFunctor (W.WriterT w) where- hmap nat m = W.WriterT (nat (W.runWriterT m))+ hmap nat m = W.WriterT (nat (W.runWriterT m)) instance HFunctor (W'.WriterT w) where- hmap nat m = W'.WriterT (nat (W'.runWriterT m))+ hmap nat m = W'.WriterT (nat (W'.runWriterT m)) instance Functor f => HFunctor (Compose f) where- hmap nat (Compose f) = Compose (fmap nat f)+ hmap nat (Compose f) = Compose (fmap nat f) instance HFunctor (Product f) where- hmap nat (Pair f g) = Pair f (nat g)+ hmap nat (Pair f g) = Pair f (nat g) instance HFunctor Backwards where- hmap nat (Backwards f) = Backwards (nat f)+ hmap nat (Backwards f) = Backwards (nat f) instance HFunctor Lift where- hmap _ (Pure a) = Pure a- hmap nat (Other f) = Other (nat f)+ hmap _ (Pure a) = Pure a+ hmap nat (Other f) = Other (nat f)
src/Yaya/Pattern.hs view
@@ -10,7 +10,7 @@ instance Bifunctor XNor where bimap f g = \case- Neither -> Neither+ Neither -> Neither Both a b -> Both (f a) (g b) -- | Isomorphic to `(a, Maybe b)`, it’s also the pattern functor for non-empty@@ -22,4 +22,3 @@ bimap f g = \case Only a -> Only (f a) Indeed a b -> Indeed (f a) (g b)-
src/Yaya/Retrofit.hs view
@@ -1,5 +1,5 @@-{-# language CPP- , TemplateHaskell #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-} -- | This module re-exports a subset of `Yaya.Fold`, intended for when you want -- to define recursion scheme instances for your existing recursive types.@@ -23,11 +23,12 @@ -- away from direct recursion entirely, at which point this import should -- disappear. module Yaya.Retrofit- ( module Yaya.Fold- , PatternFunctorRules (..)- , defaultRules- , extractPatternFunctor- ) where+ ( module Yaya.Fold,+ PatternFunctorRules (..),+ defaultRules,+ extractPatternFunctor,+ )+where import Control.Exception (Exception (..), throw) import Control.Monad ((<=<))@@ -39,15 +40,14 @@ import Language.Haskell.TH.Datatype as TH.Abs import Language.Haskell.TH.Syntax (mkNameG_tc) import Text.Read.Lex (isSymbolChar)- import Yaya.Fold- ( Corecursive (..)- , Projectable (..)- , Recursive (..)- , Steppable (..)- , recursiveEq- , recursiveShowsPrec- )+ ( Corecursive (..),+ Projectable (..),+ Recursive (..),+ Steppable (..),+ recursiveEq,+ recursiveShowsPrec,+ ) #if MIN_VERSION_template_haskell(2, 17, 0) type TyVarBndr' = TyVarBndr ()@@ -55,6 +55,13 @@ type TyVarBndr' = TyVarBndr #endif +conP' :: Name -> [Pat] -> Pat+#if MIN_VERSION_template_haskell(2, 18, 0)+conP' n = ConP n []+#else+conP' = ConP+#endif+ -- | Extract a pattern functor and relevant instances from a simply recursive type. -- -- /e.g./@@ -109,24 +116,26 @@ -- | Rules of renaming data names data PatternFunctorRules = PatternFunctorRules- { patternType :: Name -> Name- , patternCon :: Name -> Name- , patternField :: Name -> Name- }+ { patternType :: Name -> Name,+ patternCon :: Name -> Name,+ patternField :: Name -> Name+ } -- | Default 'PatternFunctorRules': append @F@ or @$@ to data type, constructors and field names. defaultRules :: PatternFunctorRules-defaultRules = PatternFunctorRules- { patternType = toFName- , patternCon = toFName- , patternField = toFName+defaultRules =+ PatternFunctorRules+ { patternType = toFName,+ patternCon = toFName,+ patternField = toFName } toFName :: Name -> Name toFName = mkName . f . nameBase where- f name | isInfixName name = name ++ "$"- | otherwise = name ++ "F"+ f name+ | isInfixName name = name ++ "$"+ | otherwise = name ++ "F" isInfixName :: String -> Bool isInfixName = all isSymbolChar@@ -144,127 +153,144 @@ instance Exception UnsupportedDatatype -makePrimForDI- :: PatternFunctorRules -> DatatypeInfo -> Either UnsupportedDatatype (Q [Dec])+makePrimForDI ::+ PatternFunctorRules -> DatatypeInfo -> Either UnsupportedDatatype (Q [Dec]) makePrimForDI rules- (DatatypeInfo { datatypeName = tyName- , datatypeInstTypes = instTys- , datatypeCons = cons- , datatypeVariant = variant }) =- if isDataFamInstance- then Left $ UnsupportedVariant variant- else- bimap- UnsupportedInstTypes- (flip (makePrimForDI' rules (variant == Newtype) tyName) cons)- . validationToEither- $ traverse (\ty -> maybe (Failure $ pure ty) Success $ toTyVarBndr ty) instTys- where- isDataFamInstance = case variant of- DataInstance -> True- NewtypeInstance -> True- Datatype -> False- Newtype -> False+ ( DatatypeInfo+ { datatypeName = tyName,+ datatypeInstTypes = instTys,+ datatypeCons = cons,+ datatypeVariant = variant+ }+ ) =+ if isDataFamInstance+ then Left $ UnsupportedVariant variant+ else+ bimap+ UnsupportedInstTypes+ (flip (makePrimForDI' rules (variant == Newtype) tyName) cons)+ . validationToEither+ $ traverse (\ty -> maybe (Failure $ pure ty) Success $ toTyVarBndr ty) instTys+ where+ isDataFamInstance = case variant of+ DataInstance -> True+ NewtypeInstance -> True+ Datatype -> False+ Newtype -> False - toTyVarBndr :: Type -> Maybe TyVarBndr'- toTyVarBndr (VarT n) = pure $ plainTV n- toTyVarBndr (SigT (VarT n) k) = pure $ kindedTV n k- toTyVarBndr _ = Nothing+ toTyVarBndr :: Type -> Maybe TyVarBndr'+ toTyVarBndr (VarT n) = pure $ plainTV n+ toTyVarBndr (SigT (VarT n) k) = pure $ kindedTV n k+ toTyVarBndr _ = Nothing -makePrimForDI'- :: PatternFunctorRules -> Bool -> Name -> [TyVarBndr'] -> [ConstructorInfo] -> Q [Dec]+-- TH 2.12.O means GHC 8.2.1, otherwise, we work back to GHC 8.0.1+#if MIN_VERSION_template_haskell(2, 12, 0)+deriveds :: [DerivClause]+deriveds =+ pure $+ DerivClause+ Nothing+ [ ConT functorTypeName,+ ConT foldableTypeName,+ ConT traversableTypeName+ ]+#else+deriveds :: [TH.Type]+deriveds =+ [ ConT functorTypeName,+ ConT foldableTypeName,+ ConT traversableTypeName+ ]+#endif++makePrimForDI' ::+ PatternFunctorRules -> Bool -> Name -> [TyVarBndr'] -> [ConstructorInfo] -> Q [Dec] makePrimForDI' rules isNewtype tyName vars cons = do- -- variable parameters- let vars' = map VarT (typeVars vars)- -- Name of base functor- let tyNameF = patternType rules tyName- -- Recursive type- let s = conAppsT tyName vars'- -- Additional argument- rName <- newName "r"- let r = VarT rName- - -- Vars- let varsF = vars ++ [plainTV rName]+ -- variable parameters+ let vars' = map VarT (typeVars vars)+ -- Name of base functor+ let tyNameF = patternType rules tyName+ -- Recursive type+ let s = conAppsT tyName vars'+ -- Additional argument+ rName <- newName "r"+ let r = VarT rName - -- #33- cons' <- traverse (conTypeTraversal resolveTypeSynonyms) cons- let consF- = toCon+ -- Vars+ let varsF = vars ++ [plainTV rName]++ -- #33+ cons' <- traverse (conTypeTraversal resolveTypeSynonyms) cons+ let consF =+ toCon . conNameMap (patternCon rules) . conFieldNameMap (patternField rules) . conTypeMap (substType s r) <$> cons' - -- Data definition- let dataDec = case consF of- [conF] | isNewtype ->- NewtypeD [] tyNameF varsF Nothing conF deriveds- _ -> DataD [] tyNameF varsF Nothing consF deriveds- where- deriveds =--- TH 2.12.O means GHC 8.2.1, otherwise, we work back to GHC 8.0.1-#if MIN_VERSION_template_haskell(2, 12, 0)- pure $ DerivClause Nothing-#endif- [ ConT functorTypeName- , ConT foldableTypeName- , ConT traversableTypeName ]+ -- Data definition+ let dataDec = case consF of+ [conF]+ | isNewtype -> NewtypeD [] tyNameF varsF Nothing conF deriveds+ _ -> DataD [] tyNameF varsF Nothing consF deriveds - recursiveDec <-- [d|- instance Projectable (->) $(pure s) $(pure $ conAppsT tyNameF vars') where- project = $(LamCaseE <$> mkMorphism id (patternCon rules) cons')+ recursiveDec <-+ [d|+ instance Projectable (->) $(pure s) $(pure $ conAppsT tyNameF vars') where+ project = $(LamCaseE <$> mkMorphism id (patternCon rules) cons') - instance Steppable (->) $(pure s) $(pure $ conAppsT tyNameF vars') where- embed = $(LamCaseE <$> mkMorphism (patternCon rules) id cons')+ instance Steppable (->) $(pure s) $(pure $ conAppsT tyNameF vars') where+ embed = $(LamCaseE <$> mkMorphism (patternCon rules) id cons') - instance Recursive (->) $(pure s) $(pure $ conAppsT tyNameF vars') where- cata φ = φ . fmap (cata φ) . project+ instance Recursive (->) $(pure s) $(pure $ conAppsT tyNameF vars') where+ cata φ = φ . fmap (cata φ) . project - instance Corecursive (->) $(pure s) $(pure $ conAppsT tyNameF vars') where- ana ψ = embed . fmap (ana ψ) . ψ- |]- -- Combine- pure ([dataDec] <> recursiveDec)+ instance Corecursive (->) $(pure s) $(pure $ conAppsT tyNameF vars') where+ ana ψ = embed . fmap (ana ψ) . ψ+ |]+ -- Combine+ pure ([dataDec] <> recursiveDec) -- | makes clauses to rename constructors-mkMorphism- :: (Name -> Name)- -> (Name -> Name)- -> [ConstructorInfo]- -> Q [Match]+mkMorphism ::+ (Name -> Name) ->+ (Name -> Name) ->+ [ConstructorInfo] ->+ Q [Match] mkMorphism nFrom nTo = traverse- (\ci -> do- let n = constructorName ci- fs <- traverse (const $ newName "x") $ constructorFields ci- pure- $ Match- (ConP (nFrom n) (map VarP fs)) -- pattern- (NormalB $ foldl AppE (ConE $ nTo n) (map VarE fs)) -- body- [] -- where dec- )+ ( \ci -> do+ let n = constructorName ci+ fs <- traverse (const $ newName "x") $ constructorFields ci+ pure $+ Match+ (conP' (nFrom n) (map VarP fs)) -- pattern+ (NormalB $ foldl AppE (ConE $ nTo n) (map VarE fs)) -- body+ [] -- where dec+ )+ ------------------------------------------------------------------------------- -- Traversals ------------------------------------------------------------------------------- conNameTraversal :: Traversal' ConstructorInfo Name-conNameTraversal = lens constructorName (\s v -> s { constructorName = v })+conNameTraversal = lens constructorName (\s v -> s {constructorName = v}) conFieldNameTraversal :: Traversal' ConstructorInfo Name-conFieldNameTraversal = lens constructorVariant (\s v -> s { constructorVariant = v })- . conVariantTraversal+conFieldNameTraversal =+ lens constructorVariant (\s v -> s {constructorVariant = v})+ . conVariantTraversal where conVariantTraversal :: Traversal' ConstructorVariant Name- conVariantTraversal _ NormalConstructor = pure NormalConstructor- conVariantTraversal _ InfixConstructor = pure InfixConstructor+ conVariantTraversal _ NormalConstructor = pure NormalConstructor+ conVariantTraversal _ InfixConstructor = pure InfixConstructor conVariantTraversal f (RecordConstructor fs) = RecordConstructor <$> traverse f fs conTypeTraversal :: Traversal' ConstructorInfo Type-conTypeTraversal = lens constructorFields (\s v -> s { constructorFields = v })- . traverse+conTypeTraversal =+ lens constructorFields (\s v -> s {constructorFields = v})+ . traverse conNameMap :: (Name -> Name) -> ConstructorInfo -> ConstructorInfo conNameMap = over conNameTraversal@@ -279,7 +305,8 @@ -- Lenses ------------------------------------------------------------------------------- -type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s+type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s+ type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s lens :: (s -> a) -> (s -> a -> s) -> Lens' s a@@ -303,55 +330,62 @@ conAppsT conName = foldl AppT (ConT conName) -- | Provides substitution for types-substType- :: Type- -> Type- -> Type- -> Type+substType ::+ Type ->+ Type ->+ Type ->+ Type substType a b = go where- go x | x == a = b- go (VarT n) = VarT n- go (AppT l r) = AppT (go l) (go r)+ go x | x == a = b+ go (VarT n) = VarT n+ go (AppT l r) = AppT (go l) (go r) go (ForallT xs ctx t) = ForallT xs ctx (go t) -- This may fail with kind error- go (SigT t k) = SigT (go t) k- go (InfixT l n r) = InfixT (go l) n (go r)- go (UInfixT l n r) = UInfixT (go l) n (go r)- go (ParensT t) = ParensT (go t)+ go (SigT t k) = SigT (go t) k+ go (InfixT l n r) = InfixT (go l) n (go r)+ go (UInfixT l n r) = UInfixT (go l) n (go r)+ go (ParensT t) = ParensT (go t) -- Rest are unchanged go x = x toCon :: ConstructorInfo -> Con-toCon (ConstructorInfo { constructorName = name- , constructorVars = vars- , constructorContext = ctxt- , constructorFields = ftys- , constructorStrictness = fstricts- , constructorVariant = variant })- | not (null vars && null ctxt)- = error "makeBaseFunctor: GADTs are not currently supported."- | otherwise- = let bangs = map toBang fstricts- in case variant of- NormalConstructor -> NormalC name $ zip bangs ftys- RecordConstructor fnames -> RecC name $ zip3 fnames bangs ftys- InfixConstructor -> let [bang1, bang2] = bangs- [fty1, fty2] = ftys- in InfixC (bang1, fty1) name (bang2, fty2)- where- toBang (FieldStrictness upkd strct) = Bang (toSourceUnpackedness upkd)- (toSourceStrictness strct)- where- toSourceUnpackedness :: Unpackedness -> SourceUnpackedness- toSourceUnpackedness UnspecifiedUnpackedness = NoSourceUnpackedness- toSourceUnpackedness NoUnpack = SourceNoUnpack- toSourceUnpackedness Unpack = SourceUnpack+toCon+ ( ConstructorInfo+ { constructorName = name,+ constructorVars = vars,+ constructorContext = ctxt,+ constructorFields = ftys,+ constructorStrictness = fstricts,+ constructorVariant = variant+ }+ )+ | not (null vars && null ctxt) =+ error "makeBaseFunctor: GADTs are not currently supported."+ | otherwise =+ let bangs = map toBang fstricts+ in case variant of+ NormalConstructor -> NormalC name $ zip bangs ftys+ RecordConstructor fnames -> RecC name $ zip3 fnames bangs ftys+ InfixConstructor ->+ let [bang1, bang2] = bangs+ [fty1, fty2] = ftys+ in InfixC (bang1, fty1) name (bang2, fty2)+ where+ toBang (FieldStrictness upkd strct) =+ Bang+ (toSourceUnpackedness upkd)+ (toSourceStrictness strct)+ where+ toSourceUnpackedness :: Unpackedness -> SourceUnpackedness+ toSourceUnpackedness UnspecifiedUnpackedness = NoSourceUnpackedness+ toSourceUnpackedness NoUnpack = SourceNoUnpack+ toSourceUnpackedness Unpack = SourceUnpack - toSourceStrictness :: Strictness -> SourceStrictness- toSourceStrictness UnspecifiedStrictness = NoSourceStrictness- toSourceStrictness Lazy = SourceLazy- toSourceStrictness TH.Abs.Strict = SourceStrict+ toSourceStrictness :: Strictness -> SourceStrictness+ toSourceStrictness UnspecifiedStrictness = NoSourceStrictness+ toSourceStrictness Lazy = SourceLazy+ toSourceStrictness TH.Abs.Strict = SourceStrict ------------------------------------------------------------------------------- -- Manually quoted names
src/Yaya/Zoo.hs view
@@ -13,18 +13,17 @@ import Data.Either.Combinators import Data.Profunctor import Data.Tuple- import Yaya.Fold import Yaya.Fold.Native (distCofreeT) import Yaya.Pattern -- | A recursion scheme that allows you to return a complete branch when -- unfolding.-apo- :: (Projectable (->) t f, Corecursive (->) t f, Functor f)- => GCoalgebra (->) (Either t) f a- -> a- -> t+apo ::+ (Projectable (->) t f, Corecursive (->) t f, Functor f) =>+ GCoalgebra (->) (Either t) f a ->+ a ->+ t apo = gana (seqEither project) -- | If you have a monadic algebra, you can fold it by distributing the monad@@ -35,39 +34,39 @@ -- | A recursion scheme that allows to algebras to see each others’ results. (A -- generalization of `zygo`.) This is an example that falls outside the scope -- of “comonadic folds”, but _would_ be covered by “adjoint folds”.-mutu- :: (Recursive (->) t f, Functor f)- => GAlgebra (->) ((,) a) f b- -> GAlgebra (->) ((,) b) f a- -> t- -> a+mutu ::+ (Recursive (->) t f, Functor f) =>+ GAlgebra (->) ((,) a) f b ->+ GAlgebra (->) ((,) b) f a ->+ t ->+ a mutu φ' φ = extract . cata (φ' . fmap swap &&& φ) -gmutu- :: (Comonad w, Comonad v, Recursive (->) t f, Functor f)- => DistributiveLaw (->) f w- -> DistributiveLaw (->) f v- -> GAlgebra (->) (EnvT a w) f b- -> GAlgebra (->) (EnvT b v) f a- -> t- -> a+gmutu ::+ (Comonad w, Comonad v, Recursive (->) t f, Functor f) =>+ DistributiveLaw (->) f w ->+ DistributiveLaw (->) f v ->+ GAlgebra (->) (EnvT a w) f b ->+ GAlgebra (->) (EnvT b v) f a ->+ t ->+ a gmutu w v φ' φ = extract . mutu (lowerEnv w φ') (lowerEnv v φ) where lowerEnv x φ'' = fmap φ''- . x- . fmap (fmap (uncurry EnvT) . distProd . (extract *** duplicate))+ . x+ . fmap (fmap (uncurry EnvT) . distProd . (extract *** duplicate)) distProd p = let a = fst p- in fmap (\b -> (a , b)) (snd p)+ in fmap (a,) (snd p) -- | This could use a better name.-comutu- :: (Corecursive (->) t f, Functor f)- => GCoalgebra (->) (Either a) f b- -> GCoalgebra (->) (Either b) f a- -> a- -> t+comutu ::+ (Corecursive (->) t f, Functor f) =>+ GCoalgebra (->) (Either a) f b ->+ GCoalgebra (->) (Either b) f a ->+ a ->+ t comutu ψ' ψ = ana (fmap swapEither . ψ' ||| ψ) . pure -- gcomutu@@ -89,12 +88,12 @@ -- let a = fst p -- in fmap (\b -> (a , b)) (snd p) -mutuM- :: (Monad m, Recursive (->) t f, Traversable f)- => GAlgebraM (->) m ((,) a) f b- -> GAlgebraM (->) m ((,) b) f a- -> t- -> m a+mutuM ::+ (Monad m, Recursive (->) t f, Traversable f) =>+ GAlgebraM (->) m ((,) a) f b ->+ GAlgebraM (->) m ((,) b) f a ->+ t ->+ m a mutuM φ' φ = fmap snd . cataM (bisequence . (φ' . fmap swap &&& φ)) histo :: (Recursive (->) t f, Functor f) => GAlgebra (->) (Cofree f) f a -> t -> a@@ -102,34 +101,34 @@ -- | A recursion scheme that gives you access to the original structure as you -- fold. (A specialization of `zygo`.)-para- :: (Steppable (->) t f, Recursive (->) t f, Functor f)- => GAlgebra (->) ((,) t) f a- -> t- -> a+para ::+ (Steppable (->) t f, Recursive (->) t f, Functor f) =>+ GAlgebra (->) ((,) t) f a ->+ t ->+ a para = gcata (distTuple embed) -- | A recursion scheme that uses a “helper algebra” to provide additional -- information when folding. (A generalization of `para`, and specialization -- of `mutu`.)-zygo- :: (Recursive (->) t f, Functor f)- => Algebra (->) f b- -> GAlgebra (->) ((,) b) f a- -> t- -> a+zygo ::+ (Recursive (->) t f, Functor f) =>+ Algebra (->) f b ->+ GAlgebra (->) ((,) b) f a ->+ t ->+ a zygo φ = gcata (distTuple φ) -- | This definition is different from the one given by `gcataM (distTuple φ')` -- because it has a monadic “helper” algebra. But at least it gives us the -- opportunity to show how `zygo` is a specialization of `mutu`.-zygoM- :: (Monad m, Recursive (->) t f, Traversable f)- => AlgebraM (->) m f b- -> GAlgebraM (->) m ((,) b) f a- -> t- -> m a-zygoM φ' φ = mutuM (φ' . fmap snd) φ+zygoM ::+ (Monad m, Recursive (->) t f, Traversable f) =>+ AlgebraM (->) m f b ->+ GAlgebraM (->) m ((,) b) f a ->+ t ->+ m a+zygoM φ' = mutuM (φ' . fmap snd) -- | Potentially-infinite lists, like `[]`. type Colist a = Nu (XNor a)@@ -145,7 +144,7 @@ -- | Represents partial functions that may eventually return a value (`Left`). -- NB: This is a newtype so we can create the usual instances.-newtype Partial a = Partial { fromPartial :: Nu (Either a) }+newtype Partial a = Partial {fromPartial :: Nu (Either a)} -- TODO: There may be some way to do this over an arbitrary @newtype@, or at -- least a way to do it over an arbitrary `Iso`.@@ -158,16 +157,17 @@ instance Applicative Partial where pure = Partial . embed . Left ff <*> fa =- flip insidePartial ff- $ elgotAna (seqEither project)- ((fromPartial . flip fmap fa +++ Right) . project)+ flip insidePartial ff $+ elgotAna+ (seqEither project)+ ((fromPartial . flip fmap fa +++ Right) . project) instance Monad Partial where pa >>= f = join' (fmap f pa) where join' =- insidePartial- $ elgotAna (seqEither project) ((fromPartial +++ Right) . project)+ insidePartial $+ elgotAna (seqEither project) ((fromPartial +++ Right) . project) -- | Always-infinite streams (as opposed to `Colist`, which _may_ terminate). type Stream a = Nu ((,) a)@@ -179,40 +179,42 @@ map f = cata (embed . first f) -- | A version of `Yaya.Zoo.map` that applies to Corecursive structures.-comap- :: (Projectable (->) t (f a), Corecursive (->) u (f b), Bifunctor f)- => (a -> b)- -> t- -> u+comap ::+ (Projectable (->) t (f a), Corecursive (->) u (f b), Bifunctor f) =>+ (a -> b) ->+ t ->+ u comap f = ana (first f . project) -- TODO: Weaken the `Monad` constraint to `Applicative`.+ -- | A more general implementation of `Data.Traversable.traverse`, because it -- can also work to, from, or within monomorphic structures, obviating the -- need for classes like `Data.MonoTraversable.MonoTraversable`.-traverse- :: ( Recursive (->) t (f a)- , Steppable (->) u (f b)- , Bitraversable f- , Traversable (f a)- , Monad m)- => (a -> m b)- -> t- -> m u+traverse ::+ ( Recursive (->) t (f a),+ Steppable (->) u (f b),+ Bitraversable f,+ Traversable (f a),+ Monad m+ ) =>+ (a -> m b) ->+ t ->+ m u traverse f = cata (fmap embed . bitraverse f pure <=< sequenceA) -- | A more general implementation of `Data.Functor.contramap`, because it can -- also work to, from, or within monomorphic structures.-contramap- :: (Recursive (->) t (f b), Steppable (->) u (f a), Profunctor f)- => (a -> b)- -> t- -> u+contramap ::+ (Recursive (->) t (f b), Steppable (->) u (f a), Profunctor f) =>+ (a -> b) ->+ t ->+ u contramap f = cata (embed . lmap f) -cocontramap- :: (Projectable (->) t (f b), Corecursive (->) u (f a), Profunctor f)- => (a -> b)- -> t- -> u+cocontramap ::+ (Projectable (->) t (f b), Corecursive (->) u (f a), Profunctor f) =>+ (a -> b) ->+ t ->+ u cocontramap f = ana (lmap f . project)
yaya.cabal view
@@ -1,5 +1,5 @@ name: yaya-version: 0.4.2.0+version: 0.4.2.1 synopsis: Total recursion schemes. description: Recursion schemes allow you to separate recursion from your business logic – making your own operations simpler, more@@ -18,6 +18,12 @@ extra-source-files: CHANGELOG.md , README.md cabal-version: >=1.10+tested-with: GHC == 8.6.1+ , GHC == 8.8.1+ , GHC == 8.10.1+ , GHC == 8.10.7+ , GHC == 9.0.1+ , GHC == 9.2.1 library hs-source-dirs: src