yaya 0.4.2.1 → 0.5.2.1

raw patch · 15 files changed

+1459/−442 lines, 15 filesdep +doctestdep +strictdep +yayadep −bifunctorsdep −constraintsdep −containersdep ~basebuild-type:Customsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: doctest, strict, yaya

Dependencies removed: bifunctors, constraints, containers, distributive, errors

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +58/−3
• README.md +14/−14
• Setup.hs +17/−0
• src/Yaya/Applied.hs +203/−22
• src/Yaya/Experimental/Foldable.hs +16/−5
• src/Yaya/Fold.hs +167/−58
• src/Yaya/Fold/Common.hs +69/−19
• src/Yaya/Fold/Native.hs +55/−18
• src/Yaya/Fold/Native/Internal.hs +36/−0
• src/Yaya/Functor.hs +32/−21
• src/Yaya/Pattern.hs +205/−6
• src/Yaya/Retrofit.hs +259/−179
• src/Yaya/Zoo.hs +96/−30
• tests/doctests.hs +12/−0
• yaya.cabal +220/−67

@@ -1,67 +1,122 @@ # Changelog+ All notable changes to this project will be documented in this file.  The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). -## 0.4.0.1 - 2020-12-08+## 0.4.2.3 – 2024–01–11+ ### Changed++- added CPP to support GHC 9.8++## 0.4.2.2 – 2023–12–21++### Changed++- updated formatting for newer Ormolu+- fixed a Haddock typo++## 0.4.2.1++Unknown changes.++## 0.4.2.0++Unknown changes.++## 0.4.1.0++Unknown changes.++## 0.4.0.1 – 2020–12–08++### Changed+ - updated explanation of differences from `recursion-schemes` - updated comments and parameter names in metamorphisms -## 0.4.0.0 – 2020–12-08+## 0.4.0.0 – 2020–12–08+ ### Added+ - more example algebras+ ### Changed+ - `while` is generalized and now called `definedOrInput` - `split` renamed to `diagonal` -## 0.3.2.0 – 2020–06-01+## 0.3.2.0 – 2020–06–01+ ### Added+ - `zipAlgebraMs`  ## 0.3.1.2 – 2020–05–18+ ### Added+ - `HFunctor` instances  ## 0.3.1.1 – 2020–05–18+ ### Changed+ - Turned on StrictData  ## 0.3.1.0 – 2020–05–18+ ### Added+ - Copied Kmett's auto-extraction of pattern functors  ## 0.3.0.0 – 2020–05–14+ ### Changed+ - introduced minimal poly-kinding of type classes  ## 0.2.1.3 – 2020–05–14+ ### Changed+ - enabled and fixed warnings  ## 0.2.1.2 – 2019–11–08+ ### Changed+ - improved documentation  ## 0.2.1.1 – 2019–11–08+ ### Added+ - documentation explaining limitations of `Mu` - tests for `law_cataCompose` (which bumps the yaya-hedgehog dependency for tests)  ## 0.2.1.0 – 2019–01–08+ ### Added+ - exports of type class methods via `Yaya.Retrofit`  ## 0.2.0.0 – 2019–01–08+ ### Added+ - `DFunctor` instances for `Mu` and `Nu` - lower bounds on internal yaya dependencies  ### Changed+ - moved `DFunctor` and `HFunctor` to a new `Yaya.Functor` module - renamed `cursiveIso` to `steppableIso`  ## 0.1.0.0 – 2019–01–04+ ### Added+ - everything (this is the initial release)

@@ -1,29 +1,29 @@ # Yaya -Yet another … yet another recursion scheme library for Haskell.+Yet another … yet another recursion scheme library for Haskell -## Overview+## overview  Recursion schemes allow you to separate _any_ recursion from your business logic, writing step-wise operations that can be applied in a way that guarantees termination (or, dually, progress). -How is this possible? You can’t have totality _and_ Turing-completeness, can you? Oh, but [you can](https://pdfs.semanticscholar.org/e291/5b546b9039a8cf8f28e0b814f6502630239f.pdf) – there is a particular type, `Partial a` (encoded with a fixed-point) that handles potential non-termination, akin to the way that `Maybe a` handles exceptional cases. It can be folded into `IO` in your main function, so that the runtime can execute a Turing-complete program that was modeled totally.+How's this possible? You can’t have totality _and_ Turing-completeness, can you? Oh, but [you can](https://pdfs.semanticscholar.org/e291/5b546b9039a8cf8f28e0b814f6502630239f.pdf) – there is a particular type, `Partial a` (encoded with a fixed-point) that handles potential non-termination, akin to the way that `Maybe a` handles exceptional cases. It can be folded into `IO` in your main function, so that the runtime can execute a Turing-complete program that was modeled totally.  ## organization  This organization is intended to make this a lightly-opinionated library. You should only need to import one module (per package) into any module of yours. -* `Pattern` – This is what you should use most of the time. It provides common pattern functors that aren’t found elsewhere as well as other operations that are useful when you’re defining your own algebras.-* `Fold` – This (and its submodules) provides algebra transformers, fixed-point operators, and other things you use when applying folds.-* `Retrofit` – Utilities for making your existing data types compatible with recursion schemes.-* `Applied` – A number of commonly-useful utilies defined as folds. Intended both as examples and code that you can actually use in your projects.-* `Zoo` – Names that you may have seen in the recursion scheme literature, but that we generally avoid using here. In general, prefer the right-hand side of these definitions, which shouldn’t require importing this module.+- `Pattern` – This is what you should use most of the time. It provides common pattern functors that aren’t found elsewhere as well as other operations that are useful when you’re defining your own algebras.+- `Fold` – This (and its submodules) provides algebra transformers, fixed-point operators, and other things you use when applying folds.+- `Retrofit` – Utilities for making your existing data types compatible with recursion schemes.+- `Applied` – A number of commonly-useful utilities defined as folds. Intended both as examples and code that you can actually use in your projects.+- `Zoo` – Names that you may have seen in the recursion scheme literature, but that we generally avoid using here. In general, prefer the right-hand side of these definitions, which shouldn’t require importing this module.  ## Some (hopefully) helpful guidelines -Greek characters (and names) for things can often add confusion, however, there are some that we’ve kept here because I think (with the right mnemonic) they are actually clarifying.+Greek characters (and names) for things can often add confusion, however, there are some that we’ve kept here because I think (with the right mnemonic) they're actually clarifying. -- `φ` – an algebra – “phi” (pronounced “fye” or “fee”)-- `ψ` – a coalgebra – “psi” (pronounced “sai” or “see”)+- `φ` – an algebra – “phi” (pronounced /faɪ/)+- `ψ` – a coalgebra – “psi” (pronounced /ˈ(p)saɪ/)  These are the symbols used in “the literature”, but I think they also provide a good visual mnemonic – φ, like an algebra, is folded inward, while ψ, like a coalgebra, opens up. So, I find these symbols more evocative than `f` and `g` or `algebra` and `coalgebra`, or any other pair of names I’ve come across for these concepts. @@ -31,7 +31,7 @@  ### Naming Conventions -There is a set of conventions around the naming of the operations. There are many variants of each operation (and they are all ultimately variants of `cata` and `ana`), so understanding this convention should help make it easier to understand the myriad possibilities rather than learning them by rote. The general pattern is+There's a set of conventions around the naming of the operations. There are many variants of each operation (and they're all ultimately variants of `cata` and `ana`), so understanding this convention should help make it easier to understand the myriad possibilities rather than learning them by rote. The general pattern is  > [`e`][`g`]`operation`[`T`][`M`] @@ -50,7 +50,7 @@  “Elgot” variant – Named after the form of coalgebra used in an “Elgot algebra”. If there is an operation that takes some `f (x a) -> a`, the Elgot variant takes `x (f a) -> a`, which often has similar but distinct properties from the original. -As a mnemonic, you can read the `e` as “exterior” as with a regular generalized fold, the `x` is on the _inside_ of the `f`, while with the Elgot variant, it is on the _outside_ of the `f`.+As a mnemonic, you can read the `e` as “exterior” as with a regular generalized fold, the `x` is on the _inside_ of the `f`, while with the Elgot variant, it's on the _outside_ of the `f`.  #### `T` @@ -58,4 +58,4 @@  #### `M` -Kleisli (“monadic”) variant – This convention is much more widespread than simply recursion schemes. A fold that returns its result in a `Monad`, by applying a Kleisli algebra (i.e., `f a -> m a` rather than `f a -> a`. The dual of this might be something like `anaW` (taking a seed value in a `Comonad`), but those are uninteresting. Having Kleisli variants of unfolds is unsafe, as it can force traversal of an infinite structure. If you’re looking for an operation like that, you are better off with an effectful streaming library.+Kleisli (“monadic”) variant – This convention is much more widespread than simply recursion schemes. A fold that returns its result in a `Monad`, by applying a Kleisli algebra (that is, `f a -> m a` rather than `f a -> a`. The dual of this might be something like `anaW` (taking a seed value in a `Comonad`), but those are uninteresting. Having Kleisli variants of unfolds is unsafe, as it can force traversal of an infinite structure. If you’re looking for an operation like that, you are better off with an effectful streaming library.

@@ -0,0 +1,17 @@+-- __NB__: `custom-setup` doesn’t have any way to specify extensions, so any we+--         want need to be specified here.+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE Unsafe #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Weverything #-}+-- Warns even when `Unsafe` is explicit, not inferred. See+-- https://gitlab.haskell.org/ghc/ghc/-/issues/16689+{-# OPTIONS_GHC -Wno-unsafe #-}++module Main (main) where++import safe "base" System.IO (IO)+import "cabal-doctest" Distribution.Extra.Doctest (defaultMainWithDoctests)++main :: IO ()+main = defaultMainWithDoctests "doctests"

@@ -1,17 +1,118 @@-module Yaya.Applied where+{-# LANGUAGE CPP #-} -import Control.Monad.Trans.Free-import Data.Functor.Identity-import Yaya.Fold-import Yaya.Fold.Common-import Yaya.Pattern+-- __NB__: base-4.17 moves `IsList` to its own module, which avoids the unsafety+--         of importing "GHC.Exts". With prior versions of base, we at least+--         mark the module @Trustworthy@.+#if MIN_VERSION_base(4, 17, 0)+{-# LANGUAGE Safe #-}+#else+{-# LANGUAGE Trustworthy #-}+#endif+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-} -now :: Steppable (->) t (Either a) => a -> t+module Yaya.Applied+  ( Void,+    absurd,+    append,+    at,+    atMay,+    constantly,+    drop',+    drop,+    fibonacci,+    fibonacciPolynomials,+    fromList,+    fromListN,+    fromMaybe,+    height,+    jacobsthal,+    length,+    lucas,+    lucasSequenceU,+    lucasSequenceV,+    maybeReify,+    mersenne,+    naturals,+    now,+    pell,+    reifyUpTo,+    reverse',+    reverse,+    runToEnd,+    succN,+    tail,+    take,+    takeUpTo,+    toList,+    truncate,+    vacuous,+    zeroN,+  )+where++import safe "base" Control.Category (Category (id, (.)))+import safe "base" Data.Foldable (Foldable (foldr))+import safe "base" Data.Function (flip)+import safe "base" Data.Functor (Functor (fmap))+import safe "base" Data.Functor.Identity (Identity (runIdentity))+import safe "base" Data.Int (Int)+import safe "base" Data.Monoid (Monoid (mempty))+import safe "base" Data.Ord (Ord (max))+import safe "base" Data.Semigroup (Semigroup ((<>)))++-- See comment on @{-# LANGUAGE Safe #-}@ above.+#if MIN_VERSION_base(4, 17, 0)+import "base" GHC.IsList (IsList)+import qualified "base" GHC.IsList as IsList+#else+import "base" GHC.Exts (IsList)+import qualified "base" GHC.Exts as IsList+#endif+import safe "base" Numeric.Natural (Natural)+import safe "free" Control.Monad.Trans.Free (FreeF (Free, Pure))+import safe "this" Yaya.Fold+  ( Algebra,+    Corecursive (ana),+    Mu,+    Nu,+    Projectable (project),+    Recursive (cata),+    Steppable (embed),+    cata2,+  )+import safe "this" Yaya.Fold.Common+  ( diagonal,+    fromEither,+    lucasSequence',+    maybeTakeNext,+    never,+    replaceNeither,+    takeAnother,+    takeAvailable,+    takeNext,+    toRight,+    truncate',+    unarySequence,+  )+import safe "this" Yaya.Fold.Native (Fix)+import safe "this" Yaya.Pattern+  ( Either (Left),+    Maybe (Just, Nothing),+    Pair,+    XNor (Both, Neither),+    maybe,+  )+import safe "base" Prelude (Integral, fromIntegral)++now :: (Steppable (->) t (Either a)) => a -> t now = embed . Left  -- | This will collapse all the intermediate steps to get to the value that must --   exist at the end.-runToEnd :: Recursive (->) t (Either a) => t -> a+runToEnd :: (Recursive (->) t (Either a)) => t -> a runToEnd = cata fromEither  -- | Converts exceptional divergence to non-termination.@@ -20,16 +121,16 @@  type Void = Mu Identity -absurd :: Recursive (->) t Identity => t -> a+absurd :: (Recursive (->) t Identity) => t -> a absurd = cata runIdentity  vacuous :: (Functor f, Recursive (->) t Identity) => f t -> f a vacuous = fmap absurd -zeroN :: Steppable (->) t Maybe => t+zeroN :: (Steppable (->) t Maybe) => t zeroN = embed Nothing -succN :: Steppable (->) t Maybe => t -> t+succN :: (Steppable (->) t Maybe) => t -> t succN = embed . Just  height :: (Foldable f, Steppable (->) n Maybe, Ord n) => f n -> n@@ -38,10 +139,52 @@ naturals :: (Steppable (->) n Maybe, Corecursive (->) t ((,) n)) => t naturals = ana (unarySequence succN) zeroN +length :: (Recursive (->) t (XNor a), Steppable (->) n Maybe, Ord n) => t -> n+length = cata height++append :: (Recursive (->) t (XNor a), Steppable (->) u (XNor a)) => t -> u -> u+append front back = cata (embed . replaceNeither (project back)) front++instance Semigroup (Fix (XNor a)) where+  (<>) = append++instance Monoid (Fix (XNor a)) where+  mempty = embed Neither++instance Semigroup (Mu (XNor a)) where+  (<>) = append++instance Monoid (Mu (XNor a)) where+  mempty = embed Neither++drop' :: (Projectable (->) t (XNor a)) => Maybe (t -> t) -> t -> t+drop' (Just fn) (project -> Both _ t) = fn t+drop' _ t = t++drop :: (Recursive (->) n Maybe, Projectable (->) t (XNor a)) => n -> t -> t+drop = cata drop'++tail :: (Projectable (->) t (XNor a)) => t -> t+tail = drop (1 :: Natural)++reverse' ::+  (Steppable (->) t (XNor a)) =>+  XNor a (XNor a t -> XNor a t) ->+  XNor a t ->+  XNor a t+reverse' Neither = id+reverse' (Both a fn) = fn . Both a . embed++reverse :: (Recursive (->) t (XNor a), Steppable (->) u (XNor a)) => t -> u+reverse = embed . flip (cata reverse') Neither+ -- | Extracts _no more than_ @n@ elements from the possibly-infinite sequence --  @s@. takeUpTo ::-  (Recursive (->) n Maybe, Projectable (->) s (XNor a), Steppable (->) l (XNor a)) =>+  ( Recursive (->) n Maybe,+    Projectable (->) s (XNor a),+    Steppable (->) l (XNor a)+  ) =>   n ->   s ->   l@@ -49,19 +192,22 @@  -- | Extracts _exactly_ @n@ elements from the infinite stream @s@. take ::-  (Recursive (->) n Maybe, Projectable (->) s ((,) a), Steppable (->) l (XNor a)) =>+  ( 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---   can't fail).+-- | Extracts the element at a finite index of an infinite sequence (a+--  `Data.List.!!` that can't fail). at :: (Recursive (->) n Maybe, Projectable (->) s ((,) a)) => n -> s -> a at = cata2 takeNext --- | Extracts the element at a finite index of a (co)list (a `!!` that fails---   with `Nothing`).+-- | Extracts the element at a finite index of a (co)list (a `Data.List.!!` that+--   fails with `Nothing`). atMay ::   (Recursive (->) n Maybe, Projectable (->) s (XNor a)) => n -> s -> Maybe a atMay = cata2 maybeTakeNext@@ -75,7 +221,11 @@ maybeReify (Just f) = embed . Free . fmap f . project  reifyUpTo ::-  (Recursive (->) n Maybe, Projectable (->) s f, Steppable (->) l (FreeF f s), Functor f) =>+  ( Recursive (->) n Maybe,+    Projectable (->) s f,+    Steppable (->) l (FreeF f s),+    Functor f+  ) =>   n ->   s ->   l@@ -84,7 +234,7 @@ fibonacciPolynomials :: (Integral i, Corecursive (->) t ((,) i)) => i -> t fibonacciPolynomials x = lucasSequenceU x (-1) -fibonacci :: Corecursive (->) t ((,) Int) => t+fibonacci :: (Corecursive (->) t ((,) Int)) => t fibonacci = fibonacciPolynomials 1  lucasSequenceU :: (Integral i, Corecursive (->) t ((,) i)) => i -> i -> t@@ -93,7 +243,7 @@ lucasSequenceV :: (Integral i, Corecursive (->) t ((,) i)) => i -> i -> t lucasSequenceV p q = lucasSequence' p q `ana` (2, p) -lucas :: Integral i => Corecursive (->) t ((,) i) => t+lucas :: (Integral i) => (Corecursive (->) t ((,) i)) => t lucas = lucasSequenceV 1 (-1)  pell :: (Integral i, Corecursive (->) t ((,) i)) => t@@ -106,15 +256,46 @@ mersenne = lucasSequenceU 3 2  -- | Creates an infinite stream of the provided value.-constantly :: Corecursive (->) t ((,) a) => a -> t+constantly :: (Corecursive (->) t (Pair a)) => a -> t constantly = ana diagonal  -- | 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) =>+  ( Recursive (->) n Maybe,+    Projectable (->) t f,+    Steppable (->) u (FreeF f ()),+    Functor f+  ) =>   n ->   t ->   u truncate = cata2 (embed . truncate')++-- | An implementation of `IsList.toList` for `Corecursive` fixed-points of+--  `XNor`.+fromList :: (Corecursive (->) t (XNor a)) => [a] -> t+fromList = ana project++-- | An implementation of `IsList.fromListN` for `Steppable` fixed-points of+--  `XNor`.+--+--   This should return an empty structure if the `Int` is negative.+--+--   If the target structure isn’t `Steppable` or the target structure is+--  `Corecursive` (i.e., `Yaya.Unsafe.Fold.Applied.unsafeFromList` isn’t used),+--   then the default definition for `fromListN` should suffice.+fromListN :: (Steppable (->) t (XNor a)) => Int -> [a] -> t+fromListN = cata2 (embed . takeAvailable) . fromIntegral @_ @Natural++-- | An implementation of `IsList.toList` for `Projectable` fixed-points of+--  `XNor`.+toList :: (Projectable (->) t (XNor a)) => t -> [a]+toList = ana project++-- | This instance is safe, since both structures are lazy.+instance IsList (Nu (XNor a)) where+  type Item (Nu (XNor a)) = a+  fromList = fromList+  toList = toList

@@ -1,15 +1,26 @@+{-# LANGUAGE Safe #-}+ -- | This shows how `Data.Foldable.Foldable` is basically `Recursive` --   specialized to lists. The true operation of `Data.Foldable.Foldable` is --  `Data.Foldable.toList`. -- --   As these few operations have the usual signatures, the rest of the type --   class can be implemented in the as in @base@.-module Yaya.Experimental.Foldable where+module Yaya.Experimental.Foldable+  ( Listable (naturalList),+    foldMap,+    foldl,+    foldr,+  )+where -import Control.Monad.Trans.Free-import Yaya.Fold-import Yaya.Fold.Common-import Yaya.Pattern+import "base" Control.Category (Category (id, (.)))+import "base" Data.Function (flip)+import "base" Data.Monoid (Monoid)+import "free" Control.Monad.Trans.Free (Free, iter)+import "this" Yaya.Fold (Recursive (cata))+import "this" Yaya.Fold.Common (lowerMonoid)+import "this" Yaya.Pattern (XNor (Both, Neither))  foldMap :: (Recursive (->) t (XNor a), Monoid m) => (a -> m) -> t -> m foldMap = cata . lowerMonoid

@@ -1,26 +1,120 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE Safe #-} -module Yaya.Fold where+module Yaya.Fold+  ( Algebra,+    AlgebraM,+    AlgebraPrism,+    BialgebraIso,+    Coalgebra,+    CoalgebraM,+    CoalgebraPrism,+    Corecursive (ana),+    DistributiveLaw,+    ElgotAlgebra,+    ElgotAlgebraM,+    ElgotCoalgebra,+    GAlgebra,+    GAlgebraM,+    GCoalgebra,+    GCoalgebraM,+    Mu (Mu),+    Nu (Nu),+    Projectable (project),+    Recursive (cata),+    Steppable (embed),+    attributeAlgebra,+    attributeCoalgebra,+    birecursiveIso,+    cata2,+    colambek,+    constAna,+    constCata,+    constEmbed,+    constProject,+    distEnvT,+    distIdentity,+    distTuple,+    elgotAna,+    elgotCata,+    elgotCataM,+    ezygoM,+    gana,+    gcata,+    gcataM,+    ignoringAttribute,+    lambek,+    lowerAlgebra,+    lowerAlgebraM,+    lowerCoalgebra,+    lowerCoalgebraM,+    lowerDay,+    recursiveEq,+    recursivePrism,+    recursiveShowsPrec,+    seqEither,+    seqIdentity,+    steppableIso,+    unFree,+    zipAlgebraMs,+    zipAlgebras,+  )+where -import Control.Applicative-import Control.Arrow-import Control.Comonad-import Control.Comonad.Cofree-import Control.Comonad.Trans.Env-import Control.Lens hiding ((:<))-import Control.Monad-import Control.Monad.Trans.Free-import Data.Bitraversable-import Data.Either.Combinators-import Data.Foldable-import Data.Functor.Classes-import Data.Functor.Day-import Data.List.NonEmpty (NonEmpty (..))-import Data.Void-import Numeric.Natural-import Yaya.Fold.Common-import Yaya.Functor-import Yaya.Pattern+import "base" Control.Applicative (Applicative (pure))+import "base" Control.Category (Category (id, (.)))+import "base" Control.Monad (Monad, join, (<=<), (=<<))+import "base" Data.Bifunctor (Bifunctor (bimap, first, second))+import "base" Data.Bitraversable (bisequence)+import "base" Data.Bool (Bool (True))+import "base" Data.Eq (Eq ((==)))+import "base" Data.Foldable (Foldable (fold, toList))+import "base" Data.Function (const, ($))+import "base" Data.Functor (Functor (fmap), (<$>))+import "base" Data.Functor.Classes (Eq1, Show1 (liftShowsPrec))+import "base" Data.Int (Int)+import "base" Data.List.NonEmpty (NonEmpty ((:|)))+import "base" Data.Traversable (sequenceA)+import "base" Data.Void (Void, absurd)+import "base" Numeric.Natural (Natural)+import "base" Text.Show (Show (showsPrec), ShowS, showParen)+import "comonad" Control.Comonad (Comonad (duplicate, extend, extract))+import "comonad" Control.Comonad.Trans.Env+  ( EnvT (EnvT),+    ask,+    lowerEnvT,+    runEnvT,+  )+import "free" Control.Comonad.Cofree (Cofree ((:<)))+import "free" Control.Monad.Trans.Free (Free, FreeF (Free, Pure), free, runFree)+import "kan-extensions" Data.Functor.Day (Day (Day))+import "lens" Control.Lens+  ( Const (Const, getConst),+    Identity (Identity, runIdentity),+    Iso',+    Prism',+    Traversable (traverse),+    iso,+    matching,+    prism,+    review,+    view,+  )+import "strict" Data.Strict.Classes (Strict (toStrict))+import "this" Yaya.Fold.Common (diagonal, equal, fromEither)+import "this" Yaya.Functor (DFunctor (dmap))+import "this" Yaya.Pattern+  ( AndMaybe (Indeed, Only),+    Either (Left, Right),+    Maybe (Just, Nothing),+    Pair ((:!:)),+    XNor (Both, Neither),+    fst,+    maybe,+    snd,+    uncurry,+  )+import "base" Prelude (Enum (pred, succ))  type Algebra c f a = f a `c` a @@ -55,7 +149,7 @@   project :: Coalgebra c f t  -- | Structures you can walk through step-by-step.-class Projectable c t f => Steppable c t f | t -> f where+class (Projectable c t f) => Steppable c t f | t -> f where   embed :: Algebra c f t  -- | Inductive structures that can be reasoned about in the way we usually do –@@ -90,10 +184,10 @@ --       @-XStrictData@ can help with this a lot. newtype Mu f = Mu (forall a. Algebra (->) f a -> a) -instance Functor f => Projectable (->) (Mu f) f where+instance (Functor f) => Projectable (->) (Mu f) f where   project = lambek -instance Functor f => Steppable (->) (Mu f) f where+instance (Functor f) => Steppable (->) (Mu f) f where   embed m = Mu (\f -> f (fmap (cata f) m))  instance Recursive (->) (Mu f) f where@@ -102,7 +196,7 @@ instance DFunctor Mu where   dmap f (Mu run) = Mu (\φ -> run (φ . f)) -instance Show1 f => Show (Mu f) where+instance (Show1 f) => Show (Mu f) where   showsPrec = recursiveShowsPrec  instance (Functor f, Foldable f, Eq1 f) => Eq (Mu f) where@@ -112,10 +206,10 @@ --   structures. data Nu f where Nu :: Coalgebra (->) f a -> a -> Nu f -instance Functor f => Projectable (->) (Nu f) f where+instance (Functor f) => Projectable (->) (Nu f) f where   project (Nu f a) = Nu f <$> f a -instance Functor f => Steppable (->) (Nu f) f where+instance (Functor f) => Steppable (->) (Nu f) f where   embed = colambek  instance Corecursive (->) (Nu f) f where@@ -170,8 +264,12 @@  -- | 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 ::+  (Functor f) =>+  Algebra (->) f a ->+  Algebra (->) f b ->+  Algebra (->) f (Pair a b)+zipAlgebras f g = bimap (f . fmap fst) (g . fmap snd) . diagonal  -- | Combines two `AlgebraM`s with different carriers into a single tupled --  `AlgebraM`.@@ -179,17 +277,23 @@   (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)+  AlgebraM (->) m f (Pair a b)+zipAlgebraMs f g = bisequence . bimap (f . fmap fst) (g . fmap snd) . diagonal  -- | Algebras over Day convolution are convenient for binary operations, but --   aren’t directly handleable by `cata`.-lowerDay :: Projectable (->) t g => Algebra (->) (Day f g) a -> Algebra (->) f (t -> a)+lowerDay ::+  (Projectable (->) t g) => Algebra (->) (Day f g) a -> Algebra (->) f (t -> a) lowerDay φ fta t = φ (Day fta (project t) ($)) --- | By analogy with `liftA2` (which also relies on `Day`, at least---   conceptually).-cata2 :: (Recursive (->) t f, Projectable (->) u g) => Algebra (->) (Day f g) a -> t -> u -> a+-- | By analogy with `Control.Applicative.liftA2` (which also relies on `Day`,+--   at least conceptually).+cata2 ::+  (Recursive (->) t f, Projectable (->) u g) =>+  Algebra (->) (Day f g) a ->+  t ->+  u ->+  a cata2 = cata . lowerDay  -- | Makes it possible to provide a `GAlgebra` to `cata`.@@ -254,19 +358,20 @@   ElgotAlgebraM (->) m w f a ->   t ->   m a-elgotCataM w φ = φ <=< cata (fmap w . traverse (sequence . extend φ) <=< sequenceA)+elgotCataM w φ =+  φ <=< cata (fmap w . traverse (sequenceA . extend φ) <=< sequenceA)  ezygoM ::   (Monad m, Recursive (->) t f, Traversable f) =>   AlgebraM (->) m f b ->-  ElgotAlgebraM (->) m ((,) b) f a ->+  ElgotAlgebraM (->) m (Pair b) f a ->   t ->   m a ezygoM φ' φ =   fmap snd     . cata-      ( (\x@(b, _) -> (b,) <$> φ x)-          <=< bisequence . (φ' . fmap fst &&& pure . fmap snd)+      ( (\x@(b :!: _) -> (b :!:) <$> φ x)+          <=< bisequence . bimap (φ' . fmap fst) (pure . fmap snd) . diagonal           <=< sequenceA       ) @@ -284,40 +389,43 @@   ElgotCoalgebra (->) m f a ->   a ->   t-elgotAna k ψ = ana (fmap (>>= ψ) . k) . ψ+elgotAna k ψ = ana (fmap (ψ =<<) . k) . ψ -lambek :: (Steppable (->) t f, Recursive (->) t f, Functor f) => Coalgebra (->) f t+lambek ::+  (Steppable (->) t f, Recursive (->) t f, Functor f) => Coalgebra (->) f t lambek = cata (fmap embed) -colambek :: (Projectable (->) t f, Corecursive (->) t f, Functor f) => Algebra (->) f t+colambek ::+  (Projectable (->) t f, Corecursive (->) t f, Functor f) => Algebra (->) f t colambek = ana (fmap project)  -- | There are a number of distributive laws, including---  `Data.Traversable.sequenceA`, `Data.Distributive.distribute`, and---  `Data.Align.sequenceL`. Yaya also provides others for specific recursion---   schemes.+--  `sequenceA`, `Data.Distributive.distribute`, and `Data.Align.sequenceL`.+--   Yaya also provides others for specific recursion schemes. type DistributiveLaw c f g = forall a. f (g a) `c` g (f a) --- | A less-constrained `distribute` for `Identity`.-distIdentity :: Functor f => DistributiveLaw (->) f Identity+-- | A less-constrained `Data.Distributive.distribute` for `Identity`.+distIdentity :: (Functor f) => DistributiveLaw (->) f Identity distIdentity = Identity . fmap runIdentity  -- | A less-constrained `sequenceA` for `Identity`.-seqIdentity :: Functor f => DistributiveLaw (->) Identity f+seqIdentity :: (Functor f) => DistributiveLaw (->) Identity f seqIdentity = fmap Identity . runIdentity -distTuple :: Functor f => Algebra (->) f a -> DistributiveLaw (->) f ((,) a)-distTuple φ = φ . fmap fst &&& fmap snd+distTuple :: (Functor f) => Algebra (->) f a -> DistributiveLaw (->) f (Pair a)+distTuple φ = bimap (φ . fmap fst) (fmap snd) . diagonal  distEnvT ::-  Functor f =>+  (Functor f) =>   Algebra (->) f a ->   DistributiveLaw (->) f w ->   DistributiveLaw (->) f (EnvT a w)-distEnvT φ k = uncurry EnvT . (φ . fmap ask &&& k . fmap lowerEnvT)+distEnvT φ k =+  uncurry EnvT . bimap (φ . fmap ask) (k . fmap lowerEnvT) . diagonal -seqEither :: Functor f => Coalgebra (->) f a -> DistributiveLaw (->) (Either a) f-seqEither ψ = fmap Left . ψ ||| fmap Right+seqEither ::+  (Functor f) => Coalgebra (->) f a -> DistributiveLaw (->) (Either a) f+seqEither ψ = fromEither . bimap (fmap Left . ψ) (fmap Right)  -- | Converts an `Algebra` to one that annotates the tree with the result for --   each node.@@ -325,12 +433,13 @@   (Steppable (->) t (EnvT a f), Functor f) =>   Algebra (->) f a ->   Algebra (->) f t-attributeAlgebra φ ft = embed $ EnvT (φ (fmap (fst . runEnvT . project) ft)) ft+attributeAlgebra φ ft =+  embed $ EnvT (φ (fmap (fst . toStrict . runEnvT . project) ft)) ft  -- | Converts a `Coalgebra` to one that annotates the tree with the seed that --   generated each node. attributeCoalgebra :: Coalgebra (->) f a -> Coalgebra (->) (EnvT a f) a-attributeCoalgebra ψ = uncurry EnvT . (id &&& ψ)+attributeCoalgebra ψ = uncurry EnvT . second ψ . diagonal  -- | This is just a more obvious name for composing `lowerEnvT` with your --   algebra directly.@@ -342,7 +451,7 @@ --   pass to `Yaya.Zoo.apo`) with @η . project@, but the desired `Algebra` is --   more likely to be @cata unFree . η@ than @embed . η@. See yaya-streams for --   some examples of this.-unFree :: Steppable (->) t f => Algebra (->) (FreeF f t) t+unFree :: (Steppable (->) t f) => Algebra (->) (FreeF f t) t unFree = \case   Pure t -> t   Free ft -> embed ft@@ -396,7 +505,7 @@  type CoalgebraPrism f a = Prism' a (f a) -steppableIso :: Steppable (->) t f => BialgebraIso f t+steppableIso :: (Steppable (->) t f) => BialgebraIso f t steppableIso = iso embed project  birecursiveIso ::@@ -412,4 +521,4 @@ recursivePrism alg =   prism     (ana (review alg))-    (\t -> mapLeft (const t) $ cata (matching alg <=< sequenceA) t)+    (\t -> first (const t) $ cata (matching alg <=< sequenceA) t)

@@ -1,29 +1,74 @@+{-# LANGUAGE Safe #-}+ -- | Common algebras that are useful when folding.-module Yaya.Fold.Common where+module Yaya.Fold.Common+  ( binarySequence,+    definedOrInput,+    diagonal,+    equal,+    fromEither,+    height,+    le,+    lowerMonad,+    lowerMonoid,+    lowerSemigroup,+    lucasSequence',+    maybeTakeNext,+    never,+    replaceNeither,+    size,+    takeAnother,+    takeAvailable,+    takeNext,+    ternarySequence,+    toRight,+    truncate',+    unarySequence,+  )+where -import Control.Monad-import Control.Monad.Trans.Free-import Data.Foldable-import Data.Functor.Classes-import Data.Functor.Day-import Data.Functor.Identity-import Numeric.Natural-import Yaya.Pattern+import "base" Control.Applicative (Applicative (pure))+import "base" Control.Category (Category (id, (.)))+import "base" Control.Monad (Monad, join)+import "base" Data.Bool (Bool (False, True), (&&))+import "base" Data.Eq (Eq ((==)))+import "base" Data.Foldable (Foldable (foldr, toList), and)+import "base" Data.Function (($))+import "base" Data.Functor (Functor (fmap), void)+import "base" Data.Functor.Classes (Eq1 (liftEq))+import "base" Data.Functor.Identity (Identity (Identity, runIdentity))+import "base" Data.List (zipWith)+import "base" Data.Monoid (Monoid (mempty))+import "base" Data.Ord (Ord (max))+import "base" Data.Semigroup (Semigroup ((<>)))+import "base" Numeric.Natural (Natural)+import "free" Control.Monad.Trans.Free (FreeF (Free, Pure))+import "kan-extensions" Data.Functor.Day (Day (Day))+import "this" Yaya.Pattern+  ( AndMaybe (Indeed, Only),+    Either (Left, Right),+    Maybe (Just, Nothing),+    Pair ((:!:)),+    XNor (Both, Neither),+    either,+    maybe,+  )+import Prelude (Integer, Num ((*), (+), (-)))  -- | Converts the free monoid (a list) into some other `Monoid`.-lowerMonoid :: Monoid m => (a -> m) -> XNor a m -> m+lowerMonoid :: (Monoid m) => (a -> m) -> XNor a m -> m lowerMonoid f = \case   Neither -> mempty-  Both a b -> mappend (f a) b+  Both a b -> 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 :: (Semigroup m) => (a -> m) -> AndMaybe a m -> m lowerSemigroup f = \case   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 :: (Monad m) => (forall x. f x -> m x) -> FreeF f a (m a) -> m a lowerMonad f = \case   Pure a -> pure a   Free fm -> join (f fm)@@ -37,7 +82,7 @@ -- TODO: Redefine this using `Natural`  -- | When folded, returns the height of the data structure.-height :: Foldable f => f Integer -> Integer+height :: (Foldable f) => f Integer -> Integer height = (+ 1) . foldr max (-1)  -- NB: It seems like this could be some more general notion of this, like@@ -50,7 +95,7 @@ --          @`length` xs + 1 == `cata` `size` xs@, because this is counting the --          nodes of the structure (how many `Neither`s and `Both`s), not how --          many elements (which would be equivalent to only counting `Both`s).-size :: Foldable f => f Natural -> Natural+size :: (Foldable f) => f Natural -> Natural size = foldr (+) 1  -- | Converts a provably infinite structure into a `Yaya.Zoo.Partial` one (that@@ -77,6 +122,11 @@   Day (Just a) (Just b) f -> f a b   Day (Just _) Nothing _ -> False +replaceNeither :: XNor a b -> XNor a b -> XNor a b+replaceNeither replacement = \case+  Neither -> replacement+  next -> next+ takeAnother :: Day Maybe ((,) a) b -> XNor a b takeAnother = \case   Day Nothing _ _ -> Neither@@ -98,15 +148,15 @@   Day (Just x) (Both _ t) f -> f x t   Day _ Neither _ -> Nothing -truncate' :: Functor f => Day Maybe f a -> FreeF f () a+truncate' :: (Functor f) => Day Maybe f a -> FreeF f () a truncate' = \case   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. --   > x &&& y = (x *** y) . diagonal-diagonal :: a -> (a, a)-diagonal x = (x, x)+diagonal :: a -> Pair a a+diagonal x = x :!: x  -- * sequence generators @@ -124,5 +174,5 @@ ternarySequence :: (a -> b -> c -> d) -> (a, b, c) -> (a, (b, c, d)) ternarySequence f (a, b, c) = (a, (b, c, f a b c)) -lucasSequence' :: Integral i => i -> i -> (i, i) -> (i, (i, i))+lucasSequence' :: (Num n) => n -> n -> (n, n) -> (n, (n, n)) lucasSequence' p q = binarySequence (\n2 n1 -> p * n1 - q * n2)

@@ -1,21 +1,51 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-}  -- | Uses of recursion schemes that use Haskell’s built-in recursion in a total --   manner.-module Yaya.Fold.Native where+module Yaya.Fold.Native+  ( module Yaya.Fold.Native.Internal,+    Fix (Fix, unFix),+    distCofreeT,+  )+where -import Control.Arrow-import Control.Comonad-import Control.Comonad.Cofree-import Control.Comonad.Trans.Env-import Control.Monad.Trans.Free-import Data.List.NonEmpty-import Numeric.Natural-import Yaya.Fold-import Yaya.Pattern+import "base" Control.Category (Category ((.)))+import "base" Data.Bifunctor (Bifunctor (bimap))+import "base" Data.Eq (Eq ((==)))+import "base" Data.Foldable (Foldable (toList))+import "base" Data.Function (($))+import "base" Data.Functor (Functor (fmap))+import "base" Data.Functor.Classes (Eq1, Show1)+import "base" Data.List.NonEmpty (NonEmpty ((:|)))+import "base" Numeric.Natural (Natural)+import "base" Text.Show (Show (showsPrec))+import "comonad" Control.Comonad (Comonad (extract))+import "comonad" Control.Comonad.Trans.Env (EnvT (EnvT), runEnvT)+import "free" Control.Comonad.Cofree (Cofree ((:<)), unwrap)+import "free" Control.Monad.Trans.Free (Free, FreeF (Free, Pure), free)+import "strict" Data.Strict.Classes (Strict (toStrict))+import "this" Yaya.Fold+  ( Corecursive (ana),+    DistributiveLaw,+    Projectable (project),+    Recursive (cata),+    Steppable (embed),+    recursiveEq,+    recursiveShowsPrec,+  )+import "this" Yaya.Fold.Common (diagonal)+import "this" Yaya.Fold.Native.Internal (Cofix (unCofix))+import "this" Yaya.Pattern+  ( AndMaybe (Indeed, Only),+    Maybe,+    XNor (Both, Neither),+    uncurry,+  )  -- | A fixed-point constructor that uses Haskell's built-in recursion. This is---   lazy/corecursive.+--   strict/recursive. newtype Fix f = Fix {unFix :: f (Fix f)}  instance Projectable (->) (Fix f) f where@@ -24,9 +54,15 @@ instance Steppable (->) (Fix f) f where   embed = Fix -instance Functor f => Corecursive (->) (Fix f) f where-  ana φ = embed . fmap (ana φ) . φ+instance (Functor f) => Recursive (->) (Fix f) f where+  cata ɸ = ɸ . fmap (cata ɸ) . project +instance (Functor f, Foldable f, Eq1 f) => Eq (Fix f) where+  (==) = recursiveEq++instance (Functor f, Show1 f) => Show (Fix f) where+  showsPrec = recursiveShowsPrec+ instance Recursive (->) Natural Maybe where   cata ɸ = ɸ . fmap (cata ɸ) . project @@ -42,11 +78,11 @@   ana ψ =     ( \case         Only h -> h :| []-        Indeed h t -> h :| toList (ana ψ t)+        Indeed h t -> h :| toList @NonEmpty (ana ψ t)     )       . ψ -instance Functor f => Corecursive (->) (Free f a) (FreeF f a) where+instance (Functor f) => Corecursive (->) (Free f a) (FreeF f a) where   ana ψ =     free       . ( \case@@ -55,11 +91,12 @@         )       . ψ -instance Functor f => Corecursive (->) (Cofree f a) (EnvT a f) where-  ana ψ = uncurry (:<) . fmap (fmap (ana ψ)) . runEnvT . ψ+instance (Functor f) => Corecursive (->) (Cofree f a) (EnvT a f) where+  ana ψ = uncurry (:<) . fmap (fmap (ana ψ)) . toStrict . runEnvT . ψ  distCofreeT ::   (Functor f, Functor h) =>   DistributiveLaw (->) f h ->   DistributiveLaw (->) f (Cofree h)-distCofreeT k = ana $ uncurry EnvT . (fmap extract &&& k . fmap unwrap)+distCofreeT k =+  ana $ uncurry EnvT . bimap (fmap extract) (k . fmap unwrap) . diagonal

@@ -0,0 +1,36 @@+{-# LANGUAGE Safe #-}+-- NB: We disable @StrictData@ here in order for `Cofix` to be lazy. I don’t+--     think there is any way to explicitly add @~@ patterns that has the+--     correct semantics.+{-# LANGUAGE NoStrictData #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++-- | This module only exists to restrict the scope of @NoStrictData@. Everything+--    is re-exported via "Yaya.Fold".+module Yaya.Fold.Native.Internal+  ( Cofix (Cofix, unCofix),+  )+where++import "base" Control.Category (Category ((.)))+import "base" Data.Functor (Functor (fmap))+import "this" Yaya.Fold+  ( Corecursive (ana),+    Projectable (project),+    Steppable (embed),+  )++-- | A fixed-point constructor that uses Haskell's built-in recursion. This is+--   lazy/corecursive.+data Cofix f = Cofix {unCofix :: f (Cofix f)}++{-# HLINT ignore Cofix "Use newtype instead of data" #-}++instance Projectable (->) (Cofix f) f where+  project = unCofix++instance Steppable (->) (Cofix f) f where+  embed = Cofix++instance (Functor f) => Corecursive (->) (Cofix f) f where+  ana φ = embed . fmap (ana φ) . φ

@@ -1,26 +1,37 @@+{-# LANGUAGE Safe #-}+ -- | This should probably be a separate library, but it provides a number of --   functor type classes between various categories.-module Yaya.Functor where+module Yaya.Functor+  ( DFunctor (dmap),+    HFunctor (hmap),+    firstMap,+  )+where -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.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 (..))-import Data.Functor.Product (Product (..))+import "base" Control.Category (Category ((.)))+import "base" Data.Bifunctor (Bifunctor, first)+import "base" Data.Function (($))+import "base" Data.Functor (Functor (fmap))+import "base" Data.Functor.Compose (Compose (Compose))+import "base" Data.Functor.Product (Product (Pair))+import "base" Data.Kind (Type)+import "transformers" Control.Applicative.Backwards (Backwards (Backwards))+import "transformers" Control.Applicative.Lift (Lift (Other, Pure))+import qualified "transformers" Control.Monad.Trans.Except as Ex+import qualified "transformers" Control.Monad.Trans.Identity as I+import qualified "transformers" Control.Monad.Trans.Maybe as M+import qualified "transformers" Control.Monad.Trans.RWS.Lazy as RWS+import qualified "transformers" Control.Monad.Trans.RWS.Strict as RWS'+import qualified "transformers" Control.Monad.Trans.Reader as R+import qualified "transformers" Control.Monad.Trans.State.Lazy as S+import qualified "transformers" Control.Monad.Trans.State.Strict as S'+import qualified "transformers" Control.Monad.Trans.Writer.Lazy as W'+import qualified "transformers" Control.Monad.Trans.Writer.Strict as W  -- | A functor from the category of endofunctors to *Hask*. The @D@ is meant to --   be a mnemonic for “down”, as we’re “lowering” from endofunctors to types.-class DFunctor (d :: (* -> *) -> *) where+class DFunctor (d :: (Type -> Type) -> Type) where   dmap :: (forall x. f x -> g x) -> d f -> d g  -- | This isn’t a Functor instance because of the position of the @a@, but you@@ -34,9 +45,9 @@ -- | An endofunctor in the category of endofunctors. -- --  __NB__: This is similar to `Control.Monad.Morph.MFunctor` /---         `Control.Monad.Morph.hoist` from mmorph, but without the `Monad`---          constraint on `f`.-class HFunctor (h :: (* -> *) -> * -> *) where+--         `Control.Monad.Morph.hoist` from mmorph, but without the+--         `Control.Monad.Monad` constraint on @f@.+class HFunctor (h :: (Type -> Type) -> Type -> Type) where   hmap :: (forall x. f x -> g x) -> h f a -> h g a  instance HFunctor (Ex.ExceptT e) where@@ -69,7 +80,7 @@ instance HFunctor (W'.WriterT w) where   hmap nat m = W'.WriterT (nat (W'.runWriterT m)) -instance Functor f => HFunctor (Compose f) where+instance (Functor f) => HFunctor (Compose f) where   hmap nat (Compose f) = Compose (fmap nat f)  instance HFunctor (Product f) where

@@ -1,13 +1,133 @@-{-# LANGUAGE StrictData #-}+{-# LANGUAGE Safe #-}+{-# OPTIONS_GHC -Wno-orphans #-}  -- | Common pattern functors (and instances for them).-module Yaya.Pattern where+--+--   This re-exports the functors from the strict library because it also adds+--   some orphan instances for them.+module Yaya.Pattern+  ( module Data.Strict.Either,+    module Data.Strict.Maybe,+    module Data.Strict.Tuple,+    AndMaybe (Indeed, Only),+    XNor (Both, Neither),+  )+where -import Data.Bifunctor+import "base" Control.Applicative (Applicative (liftA2, pure))+import "base" Control.Category (Category ((.)))+import "base" Control.Monad (Monad ((>>=)))+import "base" Data.Bifunctor (Bifunctor (bimap))+import "base" Data.Bool (Bool (False, True), (&&))+import "base" Data.Eq (Eq ((==)))+import "base" Data.Foldable (Foldable)+import "base" Data.Function (($))+import "base" Data.Functor (Functor)+import "base" Data.Functor.Classes+  ( Eq1 (liftEq),+    Eq2 (liftEq2),+    Ord1 (liftCompare),+    Ord2 (liftCompare2),+    Show1 (liftShowsPrec),+    Show2 (liftShowsPrec2),+  )+import "base" Data.Ord (Ord (compare, (<=)), Ordering (EQ, GT, LT))+import "base" Data.Semigroup ((<>))+import "base" Data.Traversable (Traversable)+import qualified "base" Data.Tuple as Tuple+import "base" GHC.Generics (Generic, Generic1)+import "base" Text.Show (Show (showList, showsPrec), showParen, showString)+import "comonad" Control.Comonad (Comonad (duplicate, extract))+import "strict" Data.Strict.Either+  ( Either (Left, Right),+    either,+    fromLeft,+    fromRight,+    isLeft,+    isRight,+    lefts,+    partitionEithers,+    rights,+  )+import "strict" Data.Strict.Maybe+  ( Maybe (Just, Nothing),+    catMaybes,+    fromJust,+    fromMaybe,+    isJust,+    isNothing,+    listToMaybe,+    mapMaybe,+    maybe,+    maybeToList,+  )+import "strict" Data.Strict.Tuple+  ( Pair ((:!:)),+    curry,+    fst,+    snd,+    swap,+    uncurry,+    unzip,+    zip,+    (:!:),+  )+import "base" Prelude (Num ((+)))  -- | Isomorphic to 'Maybe (a, b)', it’s also the pattern functor for lists.-data XNor a b = Neither | Both ~a b deriving (Functor, Foldable, Traversable)+data XNor a b = Neither | Both ~a b+  deriving stock+    ( Eq,+      Generic,+      Ord,+      Show,+      Foldable,+      Functor,+      Generic1,+      Traversable+    ) +instance (Eq a) => Eq1 (XNor a) where+  -- TODO: Remove this once base-4.18 is the oldest supported verson, as it’s+  --       the default impl.+  liftEq = liftEq2 (==)++instance Eq2 XNor where+  liftEq2 f g = Tuple.curry $ \case+    (Neither, Neither) -> True+    (Both x y, Both x' y') -> f x x' && g y y'+    (_, _) -> False++instance (Ord a) => Ord1 (XNor a) where+  -- TODO: Remove this once base-4.18 is the oldest supported verson, as it’s+  --       the default impl.+  liftCompare = liftCompare2 compare++instance Ord2 XNor where+  liftCompare2 f g = Tuple.curry $ \case+    (Neither, Neither) -> EQ+    (Neither, Both _ _) -> LT+    (Both _ _, Neither) -> GT+    (Both x y, Both x' y') -> f x x' <> g y y'++instance (Show a) => Show1 (XNor a) where+  -- TODO: Remove this once base-4.18 is the oldest supported verson, as it’s+  --       the default impl.+  liftShowsPrec = liftShowsPrec2 showsPrec showList++instance Show2 XNor where+  liftShowsPrec2 showsPrecX _showListX showsPrecY _showListY prec =+    let appPrec = 10+        nextPrec = appPrec + 1+     in \case+          Neither -> showString "Neither"+          Both x y ->+            showParen (nextPrec <= prec) $+              showString "Both "+                . showsPrecX nextPrec x+                . showString " "+                . showsPrecY nextPrec y+ instance Bifunctor XNor where   bimap f g = \case     Neither -> Neither@@ -15,10 +135,89 @@  -- | Isomorphic to `(a, Maybe b)`, it’s also the pattern functor for non-empty --   lists.-data AndMaybe a b = Only a | Indeed ~a b-  deriving (Functor, Foldable, Traversable)+data AndMaybe a b = Only ~a | Indeed ~a b+  deriving stock (Eq, Generic, Show, Foldable, Functor, Generic1, Traversable) +instance (Eq a) => Eq1 (AndMaybe a) where+  -- TODO: Remove this once base-4.18 is the oldest supported verson, as it’s+  --       the default impl.+  liftEq = liftEq2 (==)++instance Eq2 AndMaybe where+  liftEq2 f g = Tuple.curry $ \case+    (Only x, Only x') -> f x x'+    (Indeed x y, Indeed x' y') -> f x x' && g y y'+    (_, _) -> False++-- | This definition is different from the one that is derivable. For example,+--   the derived instance would always have+--   @`compare` (`Only` x) (`Indeed` x' y) `==` `LT`@, but this instance will+--   return `GT` if @`compare` x x' `==` `GT`@.+instance (Ord a, Ord b) => Ord (AndMaybe a b) where+  compare = liftCompare compare++instance (Ord a) => Ord1 (AndMaybe a) where+  -- TODO: Remove this once base-4.18 is the oldest supported verson, as it’s+  --       the default impl.+  liftCompare = liftCompare2 compare++instance Ord2 AndMaybe where+  liftCompare2 f g = Tuple.curry $ \case+    (Only x, Only x') -> f x x'+    (Only x, Indeed x' _) -> f x x' <> LT+    (Indeed x _, Only x') -> f x x' <> GT+    (Indeed x y, Indeed x' y') -> f x x' <> g y y'++instance (Show a) => Show1 (AndMaybe a) where+  -- TODO: Remove this once base-4.18 is the oldest supported verson, as it’s+  --       the default impl.+  liftShowsPrec = liftShowsPrec2 showsPrec showList++instance Show2 AndMaybe where+  liftShowsPrec2 showsPrecX _showListX showsPrecY _showListY prec =+    let appPrec = 10+        nextPrec = appPrec + 1+     in \case+          Only x ->+            showParen (nextPrec <= prec) $+              showString "Only " . showsPrecX nextPrec x+          Indeed x y ->+            showParen (nextPrec <= prec) $+              showString "Indeed "+                . showsPrecX nextPrec x+                . showString " "+                . showsPrecY nextPrec y+ instance Bifunctor AndMaybe where   bimap f g = \case     Only a -> Only (f a)     Indeed a b -> Indeed (f a) (g b)++-- * orphan instances for types from the strict library++-- TODO: Explain why these instances are actually legit (fast & loose).++instance Applicative (Either a) where+  pure = Right+  liftA2 f = curry $ \case+    Right x :!: Right y -> Right $ f x y+    Right _ :!: Left a -> Left a+    Left a :!: _ -> Left a++instance Monad (Either a) where+  Left a >>= _ = Left a+  Right b >>= f = f b++instance Applicative Maybe where+  pure = Just+  liftA2 f = curry $ \case+    Just x :!: Just y -> Just $ f x y+    _ :!: _ -> Nothing++instance Monad Maybe where+  Nothing >>= _ = Nothing+  Just a >>= f = f a++instance Comonad (Pair a) where+  extract = snd+  duplicate x@(a :!: _) = a :!: x

@@ -1,5 +1,10 @@ {-# LANGUAGE CPP #-}+#if MIN_VERSION_GLASGOW_HASKELL(9, 0, 0, 0)+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE Trustworthy #-}+#endif  -- | This module re-exports a subset of `Yaya.Fold`, intended for when you want --   to define recursion scheme instances for your existing recursive types.@@ -24,42 +29,72 @@ --   disappear. module Yaya.Retrofit   ( module Yaya.Fold,-    PatternFunctorRules (..),+    PatternFunctorRules+      ( PatternFunctorRules,+        patternCon,+        patternField,+        patternType+      ),     defaultRules,     extractPatternFunctor,   ) where -import Control.Exception (Exception (..), throw)-import Control.Monad ((<=<))-import Data.Bifunctor (bimap)-import Data.Either.Validation (Validation (..), validationToEither)-import Data.Functor.Identity (Identity (..))-import Data.List.NonEmpty (NonEmpty)-import Language.Haskell.TH as TH-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 (..),+-- NB: This module does not use the strict library, because its use of `Either`,+--    `Maybe`, etc. is tied to template-haskell and does not involve recursion+--     schemes.+import safe "base" Control.Applicative (Applicative (pure))+import safe "base" Control.Category (Category (id, (.)))+import safe "base" Control.Monad ((<=<))+import safe "base" Control.Monad.Fail (MonadFail (fail))+import safe "base" Data.Bifunctor (Bifunctor (bimap))+import safe "base" Data.Bool (Bool, otherwise, (&&))+import safe "base" Data.Either (Either (Left), either)+import safe "base" Data.Eq (Eq ((==)))+import safe "base" Data.Foldable (Foldable (foldl, length, null))+import safe "base" Data.Function (const, flip, ($))+import safe "base" Data.Functor (Functor (fmap), (<$>))+import safe "base" Data.Functor.Identity (Identity (Identity, runIdentity))+import safe "base" Data.List (all, zip, zip3)+import safe "base" Data.List.NonEmpty (NonEmpty)+import safe "base" Data.Maybe (Maybe (Just, Nothing), maybe)+import safe "base" Data.Semigroup (Semigroup ((<>)))+import safe "base" Data.String (String)+import safe "base" Data.Traversable (Traversable (traverse))+import safe "base" Text.Read.Lex (isSymbolChar)+import safe "base" Text.Show (Show (show))+import safe "either" Data.Either.Validation+  ( Validation (Failure, Success),+    validationToEither,+  )+import safe qualified "template-haskell" Language.Haskell.TH as TH+import safe qualified "template-haskell" Language.Haskell.TH.Syntax as TH.Syn+import safe qualified "th-abstraction" Language.Haskell.TH.Datatype as TH.Abs+import safe "this" Yaya.Fold+  ( Corecursive (ana),+    Projectable (project),+    Recursive (cata),+    Steppable (embed),     recursiveEq,     recursiveShowsPrec,   ) -#if MIN_VERSION_template_haskell(2, 17, 0)-type TyVarBndr' = TyVarBndr ()+#if MIN_VERSION_template_haskell(2, 21, 0)+type TyVarBndrUnit = TH.TyVarBndrUnit+type TyVarBndrVis = TH.TyVarBndrVis+#elif MIN_VERSION_template_haskell(2, 17, 0)+type TyVarBndrUnit = TH.TyVarBndrUnit+type TyVarBndrVis = TH.TyVarBndr () #else-type TyVarBndr' = TyVarBndr+type TyVarBndrUnit = TH.TyVarBndr+type TyVarBndrVis = TH.TyVarBndr #endif -conP' :: Name -> [Pat] -> Pat+conP' :: TH.Name -> [TH.Pat] -> TH.Pat #if MIN_VERSION_template_haskell(2, 18, 0)-conP' n = ConP n []+conP' n = TH.ConP n [] #else-conP' = ConP+conP' = TH.ConP #endif  -- | Extract a pattern functor and relevant instances from a simply recursive type.@@ -71,7 +106,7 @@ --     = Lit a --     | Add (Expr a) (Expr a) --     | Expr a :* [Expr a]---   deriving (Show)+--   deriving stock (Show) -- -- `extractPatternFunctor` `defaultRules` ''Expr -- @@@ -83,7 +118,7 @@ --     = LitF a --     | AddF x x --     | x :*$ [x]---   deriving ('Functor', 'Foldable', 'Traversable')+--   deriving stock ('Functor', 'Foldable', 'Traversable') -- -- instance `Projectable` (->) (Expr a) (ExprF a) where --   `project` (Lit x)   = LitF x@@ -110,15 +145,16 @@ --   <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#deriving-functor-instances GHC's DeriveFunctor>. -- - we always generate both `Recursive` and `Corecursive` instances, but one of these is always unsafe. --   In future, we should check the strictness of the recursive parameter and generate only the appropriate one (unless overridden by a rule).-extractPatternFunctor :: PatternFunctorRules -> Name -> Q [Dec]+extractPatternFunctor :: PatternFunctorRules -> TH.Name -> TH.Q [TH.Dec] extractPatternFunctor rules =-  either throw id . makePrimForDI rules <=< reifyDatatype+  either (fail . displayUnsupportedDatatype) id . makePrimForDI rules+    <=< TH.Abs.reifyDatatype  -- | Rules of renaming data names data PatternFunctorRules = PatternFunctorRules-  { patternType :: Name -> Name,-    patternCon :: Name -> Name,-    patternField :: Name -> Name+  { patternType :: TH.Name -> TH.Name,+    patternCon :: TH.Name -> TH.Name,+    patternField :: TH.Name -> TH.Name   }  -- | Default 'PatternFunctorRules': append @F@ or @$@ to data type, constructors and field names.@@ -130,118 +166,154 @@       patternField = toFName     } -toFName :: Name -> Name-toFName = mkName . f . nameBase+toFName :: TH.Name -> TH.Name+toFName = TH.mkName . f . TH.nameBase   where     f name-      | isInfixName name = name ++ "$"-      | otherwise = name ++ "F"+      | isInfixName name = name <> "$"+      | otherwise = name <> "F"      isInfixName :: String -> Bool     isInfixName = all isSymbolChar  data UnsupportedDatatype-  = UnsupportedInstTypes (NonEmpty Type)-  | UnsupportedVariant DatatypeVariant+  = UnsupportedInstTypes (NonEmpty TH.Type)+  | UnsupportedVariant TH.Abs.DatatypeVariant+  | UnsupportedGADT [TyVarBndrUnit] TH.Cxt+  | NonBinaryInfixConstructor [(TH.Bang, TH.Type)]+  deriving stock (Show) -instance Show UnsupportedDatatype where-  show = \case+displayUnsupportedDatatype :: UnsupportedDatatype -> String+displayUnsupportedDatatype =+  ("extractPatternFunctor: " <>) . \case     UnsupportedInstTypes tys ->-      "extractPatternFunctor: Couldn't process the following types " <> show tys-    UnsupportedVariant _variant ->-      "extractPatternFunctor: Data families are currently not supported."--instance Exception UnsupportedDatatype+      "Couldn't process the following types " <> show tys+    UnsupportedVariant _variant -> "Data families are currently not supported."+    UnsupportedGADT _vars _context -> "GADTs are not currently supported."+    NonBinaryInfixConstructor bts ->+      "internal error: wrong number of BangTypes for InfixConstructor; expected 2, but got "+        <> show (length bts)  makePrimForDI ::-  PatternFunctorRules -> DatatypeInfo -> Either UnsupportedDatatype (Q [Dec])+  PatternFunctorRules ->+  TH.Abs.DatatypeInfo ->+  Either UnsupportedDatatype (TH.Q [TH.Dec]) makePrimForDI   rules-  ( DatatypeInfo-      { datatypeName = tyName,-        datatypeInstTypes = instTys,-        datatypeCons = cons,-        datatypeVariant = variant+  ( TH.Abs.DatatypeInfo+      { TH.Abs.datatypeName = tyName,+        TH.Abs.datatypeInstTypes = instTys,+        TH.Abs.datatypeCons = cons,+        TH.Abs.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+    maybe+      (Left $ UnsupportedVariant variant)+      ( \safeVariant ->+          bimap+            UnsupportedInstTypes+            (flip (makePrimForDI' rules safeVariant tyName) cons)+            . validationToEither+            $ traverse+              (\ty -> maybe (Failure $ pure ty) Success $ toTyVarBndr ty)+              instTys+      )+      $ excludeDataFamInstance variant     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 :: TH.Type -> Maybe TyVarBndrVis+      toTyVarBndr (TH.VarT n) = pure $ TH.plainTV n+      toTyVarBndr (TH.SigT (TH.VarT n) k) = pure $ TH.kindedTV n k       toTyVarBndr _ = Nothing --- 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 :: [TH.DerivClause] deriveds =   pure $-    DerivClause-      Nothing-      [ ConT functorTypeName,-        ConT foldableTypeName,-        ConT traversableTypeName+    TH.DerivClause+      (pure TH.StockStrategy)+      [ TH.ConT functorTypeName,+        TH.ConT foldableTypeName,+        TH.ConT traversableTypeName       ]++-- | A restricted version of `TH.Abs.DatatypeVariant` that excludes data family+--   declarations.+#if MIN_VERSION_th_abstraction(0, 5, 0)+data SafeDatatypeVariant  = Datatype  | Newtype  | TypeDataV #else-deriveds :: [TH.Type]-deriveds =-  [ ConT functorTypeName,-    ConT foldableTypeName,-    ConT traversableTypeName-  ]+data SafeDatatypeVariant  = Datatype  | Newtype #endif +excludeDataFamInstance :: TH.Abs.DatatypeVariant -> Maybe SafeDatatypeVariant+#if MIN_VERSION_th_abstraction(0, 5, 0)+excludeDataFamInstance = \case+  TH.Abs.DataInstance -> Nothing+  TH.Abs.NewtypeInstance -> Nothing+  TH.Abs.Datatype -> Just Datatype+  TH.Abs.Newtype -> Just Newtype+  TH.Abs.TypeData -> Just TypeDataV+#else+excludeDataFamInstance = \case+  TH.Abs.DataInstance -> Nothing+  TH.Abs.NewtypeInstance -> Nothing+  TH.Abs.Datatype -> Just Datatype+  TH.Abs.Newtype -> Just Newtype+#endif++makeDataDefinition ::+  SafeDatatypeVariant -> TH.Name -> [TyVarBndrVis] -> [TH.Con] -> TH.Dec+#if MIN_VERSION_template_haskell(2, 20, 0) && MIN_VERSION_th_abstraction(0, 5, 0)+makeDataDefinition safeVariant tyName vars cons =+  case (safeVariant, cons) of+       (Newtype, [con]) -> TH.NewtypeD [] tyName vars Nothing con deriveds+       (TypeDataV, _) -> TH.TypeDataD tyName vars Nothing cons+       (_, _) -> TH.DataD [] tyName vars Nothing cons deriveds+#else+makeDataDefinition safeVariant tyName vars cons =+  case (safeVariant, cons) of+       (Newtype, [con]) -> TH.NewtypeD [] tyName vars Nothing con deriveds+       (_, _) -> TH.DataD [] tyName vars Nothing cons deriveds+#endif+ makePrimForDI' ::-  PatternFunctorRules -> Bool -> Name -> [TyVarBndr'] -> [ConstructorInfo] -> Q [Dec]-makePrimForDI' rules isNewtype tyName vars cons = do+  PatternFunctorRules ->+  SafeDatatypeVariant ->+  TH.Name ->+  [TyVarBndrVis] ->+  [TH.Abs.ConstructorInfo] ->+  TH.Q [TH.Dec]+makePrimForDI' rules safeVariant tyName vars cons = do   -- variable parameters-  let vars' = map VarT (typeVars vars)+  let vars' = fmap TH.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+  rName <- TH.newName "r"+  let r = TH.VarT rName    -- 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'+  let varsF = vars <> [TH.plainTV rName] -  -- Data definition-  let dataDec = case consF of-        [conF]-          | isNewtype -> NewtypeD [] tyNameF varsF Nothing conF deriveds-        _ -> DataD [] tyNameF varsF Nothing consF deriveds+  -- ekmett/recursion-schemes#33+  cons' <- traverse (conTypeTraversal TH.Abs.resolveTypeSynonyms) cons+  consF <-+    either (fail . displayUnsupportedDatatype) pure $+      traverse+        ( toCon+            . conNameMap (patternCon rules)+            . conFieldNameMap (patternField rules)+            . conTypeMap (substType s r)+        )+        cons' -  recursiveDec <--    [d|+  (makeDataDefinition safeVariant tyNameF varsF consF :)+    <$> [d|       instance Projectable (->) $(pure s) $(pure $ conAppsT tyNameF vars') where-        project = $(LamCaseE <$> mkMorphism id (patternCon rules) cons')+        project = $(TH.LamCaseE <$> mkMorphism id (patternCon rules) cons')        instance Steppable (->) $(pure s) $(pure $ conAppsT tyNameF vars') where-        embed = $(LamCaseE <$> mkMorphism (patternCon rules) id cons')+        embed = $(TH.LamCaseE <$> mkMorphism (patternCon rules) id cons')        instance Recursive (->) $(pure s) $(pure $ conAppsT tyNameF vars') where         cata φ = φ . fmap (cata φ) . project@@ -249,24 +321,24 @@       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]+  (TH.Name -> TH.Name) ->+  (TH.Name -> TH.Name) ->+  [TH.Abs.ConstructorInfo] ->+  TH.Q [TH.Match] mkMorphism nFrom nTo =   traverse     ( \ci -> do-        let n = constructorName ci-        fs <- traverse (const $ newName "x") $ constructorFields ci+        let n = TH.Abs.constructorName ci+        fs <- traverse (const $ TH.newName "x") $ TH.Abs.constructorFields ci         pure $-          Match-            (conP' (nFrom n) (map VarP fs)) -- pattern-            (NormalB $ foldl AppE (ConE $ nTo n) (map VarE fs)) -- body+          TH.Match+            (conP' (nFrom n) (fmap TH.VarP fs)) -- pattern+            ( TH.NormalB . foldl TH.AppE (TH.ConE $ nTo n) $+                fmap TH.VarE fs -- body+            )             [] -- where dec     ) @@ -274,40 +346,45 @@ -- Traversals ------------------------------------------------------------------------------- -conNameTraversal :: Traversal' ConstructorInfo Name-conNameTraversal = lens constructorName (\s v -> s {constructorName = v})+conNameTraversal :: Traversal' TH.Abs.ConstructorInfo TH.Name+conNameTraversal = lens TH.Abs.constructorName (\s v -> s {TH.Abs.constructorName = v}) -conFieldNameTraversal :: Traversal' ConstructorInfo Name+conFieldNameTraversal :: Traversal' TH.Abs.ConstructorInfo TH.Name conFieldNameTraversal =-  lens constructorVariant (\s v -> s {constructorVariant = v})+  lens TH.Abs.constructorVariant (\s v -> s {TH.Abs.constructorVariant = v})     . conVariantTraversal   where-    conVariantTraversal :: Traversal' ConstructorVariant Name-    conVariantTraversal _ NormalConstructor = pure NormalConstructor-    conVariantTraversal _ InfixConstructor = pure InfixConstructor-    conVariantTraversal f (RecordConstructor fs) = RecordConstructor <$> traverse f fs+    conVariantTraversal :: Traversal' TH.Abs.ConstructorVariant TH.Name+    conVariantTraversal _ TH.Abs.NormalConstructor =+      pure TH.Abs.NormalConstructor+    conVariantTraversal _ TH.Abs.InfixConstructor = pure TH.Abs.InfixConstructor+    conVariantTraversal f (TH.Abs.RecordConstructor fs) =+      TH.Abs.RecordConstructor <$> traverse f fs -conTypeTraversal :: Traversal' ConstructorInfo Type+conTypeTraversal :: Traversal' TH.Abs.ConstructorInfo TH.Type conTypeTraversal =-  lens constructorFields (\s v -> s {constructorFields = v})+  lens TH.Abs.constructorFields (\s v -> s {TH.Abs.constructorFields = v})     . traverse -conNameMap :: (Name -> Name) -> ConstructorInfo -> ConstructorInfo+conNameMap ::+  (TH.Name -> TH.Name) -> TH.Abs.ConstructorInfo -> TH.Abs.ConstructorInfo conNameMap = over conNameTraversal -conFieldNameMap :: (Name -> Name) -> ConstructorInfo -> ConstructorInfo+conFieldNameMap ::+  (TH.Name -> TH.Name) -> TH.Abs.ConstructorInfo -> TH.Abs.ConstructorInfo conFieldNameMap = over conFieldNameTraversal -conTypeMap :: (Type -> Type) -> ConstructorInfo -> ConstructorInfo+conTypeMap ::+  (TH.Type -> TH.Type) -> TH.Abs.ConstructorInfo -> TH.Abs.ConstructorInfo conTypeMap = over conTypeTraversal  ------------------------------------------------------------------------------- -- 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+type Traversal' s a = forall f. (Applicative f) => (a -> f a) -> s -> f s  lens :: (s -> a) -> (s -> a -> s) -> Lens' s a lens sa sas afa s = sas s <$> afa (sa s)@@ -322,70 +399,73 @@ -------------------------------------------------------------------------------  -- | Extract type variables-typeVars :: [TyVarBndr'] -> [Name]-typeVars = map tvName+typeVars :: [TyVarBndrVis] -> [TH.Name]+typeVars = fmap TH.Abs.tvName  -- | Apply arguments to a type constructor.-conAppsT :: Name -> [Type] -> Type-conAppsT conName = foldl AppT (ConT conName)+conAppsT :: TH.Name -> [TH.Type] -> TH.Type+conAppsT conName = foldl TH.AppT (TH.ConT conName)  -- | Provides substitution for types substType ::-  Type ->-  Type ->-  Type ->-  Type+  TH.Type ->+  TH.Type ->+  TH.Type ->+  TH.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 (ForallT xs ctx t) = ForallT xs ctx (go t)+    go (TH.VarT n) = TH.VarT n+    go (TH.AppT l r) = TH.AppT (go l) (go r)+    go (TH.ForallT xs ctx t) = TH.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 (TH.SigT t k) = TH.SigT (go t) k+    go (TH.InfixT l n r) = TH.InfixT (go l) n (go r)+    go (TH.UInfixT l n r) = TH.UInfixT (go l) n (go r)+    go (TH.ParensT t) = TH.ParensT (go t)     -- Rest are unchanged     go x = x -toCon :: ConstructorInfo -> Con+toCon :: TH.Abs.ConstructorInfo -> Either UnsupportedDatatype TH.Con toCon-  ( ConstructorInfo-      { constructorName = name,-        constructorVars = vars,-        constructorContext = ctxt,-        constructorFields = ftys,-        constructorStrictness = fstricts,-        constructorVariant = variant+  ( TH.Abs.ConstructorInfo+      { TH.Abs.constructorName = name,+        TH.Abs.constructorVars = vars,+        TH.Abs.constructorContext = ctxt,+        TH.Abs.constructorFields = ftys,+        TH.Abs.constructorStrictness = fstricts,+        TH.Abs.constructorVariant = variant       }-    )-    | not (null vars && null ctxt) =-        error "makeBaseFunctor: GADTs are not currently supported."-    | otherwise =-        let bangs = map toBang fstricts+    ) =+    if null vars && null ctxt+      then+        let bangs = fmap 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)+              TH.Abs.NormalConstructor ->+                pure . TH.NormalC name $ zip bangs ftys+              TH.Abs.RecordConstructor fnames ->+                pure . TH.RecC name $ zip3 fnames bangs ftys+              TH.Abs.InfixConstructor -> case zip bangs ftys of+                [bt1, bt2] -> pure $ TH.InfixC bt1 name bt2+                bts -> Left $ NonBinaryInfixConstructor bts+      else Left $ UnsupportedGADT vars ctxt     where-      toBang (FieldStrictness upkd strct) =-        Bang+      toBang (TH.Abs.FieldStrictness upkd strct) =+        TH.Bang           (toSourceUnpackedness upkd)           (toSourceStrictness strct)         where-          toSourceUnpackedness :: Unpackedness -> SourceUnpackedness-          toSourceUnpackedness UnspecifiedUnpackedness = NoSourceUnpackedness-          toSourceUnpackedness NoUnpack = SourceNoUnpack-          toSourceUnpackedness Unpack = SourceUnpack+          toSourceUnpackedness :: TH.Abs.Unpackedness -> TH.SourceUnpackedness+          toSourceUnpackedness = \case+            TH.Abs.UnspecifiedUnpackedness -> TH.NoSourceUnpackedness+            TH.Abs.NoUnpack -> TH.SourceNoUnpack+            TH.Abs.Unpack -> TH.SourceUnpack -          toSourceStrictness :: Strictness -> SourceStrictness-          toSourceStrictness UnspecifiedStrictness = NoSourceStrictness-          toSourceStrictness Lazy = SourceLazy-          toSourceStrictness TH.Abs.Strict = SourceStrict+          toSourceStrictness :: TH.Abs.Strictness -> TH.SourceStrictness+          toSourceStrictness = \case+            TH.Abs.UnspecifiedStrictness -> TH.NoSourceStrictness+            TH.Abs.Lazy -> TH.SourceLazy+            TH.Abs.Strict -> TH.SourceStrict  ------------------------------------------------------------------------------- -- Manually quoted names@@ -394,11 +474,11 @@ -- TemplateHaskell language extension when compiling this library. -- This allows the library to be used in stage1 cross-compilers. -functorTypeName :: Name-functorTypeName = mkNameG_tc "base" "GHC.Base" "Functor"+functorTypeName :: TH.Name+functorTypeName = TH.Syn.mkNameG_tc "base" "GHC.Base" "Functor" -foldableTypeName :: Name-foldableTypeName = mkNameG_tc "base" "Data.Foldable" "Foldable"+foldableTypeName :: TH.Name+foldableTypeName = TH.Syn.mkNameG_tc "base" "Data.Foldable" "Foldable" -traversableTypeName :: Name-traversableTypeName = mkNameG_tc "base" "Data.Traversable" "Traversable"+traversableTypeName :: TH.Name+traversableTypeName = TH.Syn.mkNameG_tc "base" "Data.Traversable" "Traversable"

@@ -1,21 +1,79 @@+{-# LANGUAGE Safe #-}+ -- | Contains all the commonly-named folds that aren’t core to the library. In --   general, this can be seen as a mapping from names you may have heard or --   read in a paper to how Yaya expects you to achieve the same end. Of course, --   you can always import this module and use the “common” name as well.-module Yaya.Zoo where+module Yaya.Zoo+  ( Colist,+    List,+    Nat,+    NonEmptyList,+    Partial (Partial, fromPartial),+    Stream,+    apo,+    cataM,+    cocontramap,+    comap,+    comutu,+    contramap,+    gmutu,+    histo,+    insidePartial,+    map,+    mutu,+    mutuM,+    para,+    traverse,+    zygo,+    zygoM,+  )+where -import Control.Arrow hiding (first)-import Control.Comonad.Cofree-import Control.Comonad.Env-import Control.Monad-import Data.Bifunctor-import Data.Bitraversable-import Data.Either.Combinators-import Data.Profunctor-import Data.Tuple-import Yaya.Fold-import Yaya.Fold.Native (distCofreeT)-import Yaya.Pattern+import "base" Control.Applicative (Applicative (pure, (<*>)))+import "base" Control.Category (Category (id, (.)))+import "base" Control.Monad (Monad ((>>=)), (<=<))+import "base" Data.Bifunctor (Bifunctor (bimap, first))+import "base" Data.Bitraversable (Bitraversable (bitraverse), bisequence)+import "base" Data.Function (flip, ($))+import "base" Data.Functor (Functor (fmap))+import "base" Data.Traversable (Traversable (sequenceA))+import "comonad" Control.Comonad (Comonad (duplicate, extract))+import "comonad" Control.Comonad.Env (EnvT (EnvT))+import "free" Control.Comonad.Cofree (Cofree)+import "profunctors" Data.Profunctor (Profunctor (lmap))+import "this" Yaya.Fold+  ( Algebra,+    AlgebraM,+    Corecursive (ana),+    DistributiveLaw,+    GAlgebra,+    GAlgebraM,+    GCoalgebra,+    Mu,+    Nu,+    Projectable (project),+    Recursive (cata),+    Steppable (embed),+    distTuple,+    elgotAna,+    gana,+    gcata,+    seqEither,+  )+import "this" Yaya.Fold.Common (diagonal, fromEither)+import "this" Yaya.Fold.Native (distCofreeT)+import "this" Yaya.Pattern+  ( AndMaybe,+    Either (Left, Right),+    Maybe,+    Pair ((:!:)),+    XNor,+    fst,+    snd,+    swap,+    uncurry,+  )  -- | A recursion scheme that allows you to return a complete branch when --   unfolding.@@ -28,19 +86,23 @@  -- | If you have a monadic algebra, you can fold it by distributing the monad --   over the algebra.-cataM :: (Monad m, Recursive (->) t f, Traversable f) => AlgebraM (->) m f a -> t -> m a+cataM ::+  (Monad m, Recursive (->) t f, Traversable f) =>+  AlgebraM (->) m f a ->+  t ->+  m a cataM φ = cata (φ <=< sequenceA) --- | A recursion scheme that allows to algebras to see each others’ results. (A+-- | A recursion scheme that allows two 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 ->+  GAlgebra (->) (Pair a) f b ->+  GAlgebra (->) (Pair b) f a ->   t ->   a-mutu φ' φ = extract . cata (φ' . fmap swap &&& φ)+mutu φ' φ = extract . cata (bimap (φ' . fmap swap) φ . diagonal)  gmutu ::   (Comonad w, Comonad v, Recursive (->) t f, Functor f) =>@@ -55,10 +117,10 @@     lowerEnv x φ'' =       fmap φ''         . x-        . fmap (fmap (uncurry EnvT) . distProd . (extract *** duplicate))+        . fmap (fmap (uncurry EnvT) . distProd . bimap extract duplicate)     distProd p =       let a = fst p-       in fmap (a,) (snd p)+       in fmap (a :!:) (snd p)  -- | This could use a better name. comutu ::@@ -67,7 +129,11 @@   GCoalgebra (->) (Either b) f a ->   a ->   t-comutu ψ' ψ = ana (fmap swapEither . ψ' ||| ψ) . pure+comutu ψ' ψ = ana (fromEither . bimap (fmap swapEither . ψ') ψ) . pure+  where+    swapEither = \case+      Left x -> Right x+      Right y -> Left y  -- gcomutu --   :: (Monad m, Monad n, Corecursive (->) t f, Functor f)@@ -90,11 +156,11 @@  mutuM ::   (Monad m, Recursive (->) t f, Traversable f) =>-  GAlgebraM (->) m ((,) a) f b ->-  GAlgebraM (->) m ((,) b) f a ->+  GAlgebraM (->) m (Pair a) f b ->+  GAlgebraM (->) m (Pair b) f a ->   t ->   m a-mutuM φ' φ = fmap snd . cataM (bisequence . (φ' . fmap swap &&& φ))+mutuM φ' φ = fmap snd . cataM (bisequence . bimap (φ' . fmap swap) φ . diagonal)  histo :: (Recursive (->) t f, Functor f) => GAlgebra (->) (Cofree f) f a -> t -> a histo = gcata (distCofreeT id)@@ -103,7 +169,7 @@ --   fold. (A specialization of `zygo`.) para ::   (Steppable (->) t f, Recursive (->) t f, Functor f) =>-  GAlgebra (->) ((,) t) f a ->+  GAlgebra (->) (Pair t) f a ->   t ->   a para = gcata (distTuple embed)@@ -114,7 +180,7 @@ zygo ::   (Recursive (->) t f, Functor f) =>   Algebra (->) f b ->-  GAlgebra (->) ((,) b) f a ->+  GAlgebra (->) (Pair b) f a ->   t ->   a zygo φ = gcata (distTuple φ)@@ -125,7 +191,7 @@ zygoM ::   (Monad m, Recursive (->) t f, Traversable f) =>   AlgebraM (->) m f b ->-  GAlgebraM (->) m ((,) b) f a ->+  GAlgebraM (->) m (Pair b) f a ->   t ->   m a zygoM φ' = mutuM (φ' . fmap snd)@@ -160,17 +226,17 @@     flip insidePartial ff $       elgotAna         (seqEither project)-        ((fromPartial . flip fmap fa +++ Right) . project)+        (bimap (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)+          elgotAna (seqEither project) (bimap fromPartial Right . project)  -- | Always-infinite streams (as opposed to `Colist`, which _may_ terminate).-type Stream a = Nu ((,) a)+type Stream a = Nu (Pair a)  -- | A more general implementation of `fmap`, because it can also work to, from, --   or within monomorphic structures, obviating the need for classes like

@@ -0,0 +1,12 @@+{-# LANGUAGE Unsafe #-}++module Main (main) where++import safe "base" Data.Function (($))+import safe "base" Data.Semigroup (Semigroup ((<>)))+import safe "base" System.IO (IO)+import "doctest" Test.DocTest (doctest)+import "this" Build_doctests (flags, module_sources, pkgs)++main :: IO ()+main = doctest $ flags <> pkgs <> module_sources

@@ -1,71 +1,224 @@-name:                yaya-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-                     modular, and less error-prone. This library also provides-                     tools for combining your operations in ways that reduce the-                     number of passes over your data and is designed to-                     encourage total (i.e., successfully terminating) functions.-homepage:            https://github.com/sellout/yaya#readme-author:              Greg Pfeil-maintainer:          greg@technomadic.org-copyright:           2017 Greg Pfeil-license:             AGPL-3-license-file:        LICENSE-category:            Recursion-build-type:          Simple-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+cabal-version:  3.0 -library-  hs-source-dirs:      src-  exposed-modules:     Yaya.Pattern-                     , Yaya.Fold-                     , Yaya.Fold.Common-                     , Yaya.Fold.Native-                     , Yaya.Functor-                     , Yaya.Retrofit-                     , Yaya.Applied-                     , Yaya.Zoo-                     , Yaya.Experimental.Foldable-  build-depends:       base >= 4.7 && < 5-                     , bifunctors-                     , comonad-                     , constraints-                     , containers-                     , distributive-                     , either-                     , errors-                     , free-                     , kan-extensions-                     , lens-                     , profunctors-                     , template-haskell-                     , th-abstraction-                     , transformers-  default-extensions:  ConstraintKinds-                     , DeriveTraversable-                     , FlexibleContexts-                     , FlexibleInstances-                     , FunctionalDependencies-                     , LambdaCase-                     , MultiParamTypeClasses-                     , PolyKinds-                     , RankNTypes-                     , ScopedTypeVariables-                     , StrictData-                     , TupleSections-                     , TypeOperators-  default-language:    Haskell2010+name:        yaya+version:     0.5.2.1+synopsis:    Total recursion schemes.+description: Recursion schemes allow you to separate recursion from your+             business logic – making your own operations simpler, more modular,+             and less error-prone. This library also provides tools for+             combining your operations in ways that reduce the number of passes+             over your data and is designed to encourage total (i.e.,+             successfully terminating) functions.+author:      Greg Pfeil <greg@technomadic.org>+maintainer:  Greg Pfeil <greg@technomadic.org>+copyright:   2017 Greg Pfeil+homepage:    https://github.com/sellout/yaya#readme+bug-reports: https://github.com/sellout/yaya/issues+category:    Recursion+build-type:  Custom+license:     AGPL-3.0-or-later+license-files:+  LICENSE+extra-source-files:+  CHANGELOG.md+  README.md+tested-with:+  GHC == {+--  GHCup   Nixpkgs+    8.6.1,+    8.8.1,  8.8.4,+    8.10.1,+    9.0.1,+    9.2.1,+    9.4.1,  9.4.8,+    9.6.1,+            9.8.1+  }  source-repository head-  type:     git+  type: git   location: https://github.com/sellout/yaya++-- This mimics the GHC2021 extension+-- (https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/control.html?highlight=doandifthenelse#extension-GHC2021),+-- but supporting compilers back to GHC 7.10. If the oldest supported compiler+-- is GHC 9.2, then this stanza can be removed and `import: GHC2021` can be+-- replaced by `default-language: GHC2021`.+common GHC2021+  default-language: Haskell2010+  default-extensions:+    BangPatterns+    BinaryLiterals+    ConstraintKinds+    DeriveDataTypeable+    DeriveGeneric+    -- DeriveLift -- uncomment if the oldest supported version is GHC 8.10.1++    DeriveTraversable+    DerivingStrategies+    DoAndIfThenElse+    EmptyCase+    ExistentialQuantification+    FlexibleContexts+    FlexibleInstances+    GADTSyntax+    GeneralizedNewtypeDeriving+    HexFloatLiterals+    -- ImportQualifiedPost -- uncomment if the oldest supported version is GHC 8.10.1++    InstanceSigs+    LambdaCase+    MagicHash+    MonadComprehensions+    MonomorphismRestriction+    MultiParamTypeClasses+    NamedFieldPuns+    NamedWildCards+    NumericUnderscores+    PolyKinds+    PostfixOperators+    RankNTypes+    ScopedTypeVariables+    StandaloneDeriving+    -- StandaloneKindSignatures -- uncomment if the oldest supported version is GHC 8.10.1++    TupleSections+    TypeApplications+    TypeOperators+    UnicodeSyntax+    NoExplicitNamespaces++common defaults+  import: GHC2021+  build-depends:+    base ^>= {4.12.0, 4.13.0, 4.14.0, 4.15.0, 4.16.0, 4.17.0, 4.18.0, 4.19.0},+  ghc-options:+    -Weverything+    -- Type inference good.+    -Wno-missing-local-signatures+    -- Warns even when `Unsafe` is explicit, not inferred. See+    -- https://gitlab.haskell.org/ghc/ghc/-/issues/16689+    -Wno-unsafe+    -- TODO: prune these warnings+    -Wno-all-missed-specialisations+    -fpackage-trust+    -trust base+  if impl(ghc < 8.8.1)+    ghc-options:+      -- This used to warn even when `Safe` was explicit.+      -Wno-safe+  if impl(ghc >= 8.10.1)+    ghc-options:+      -- If we didn’t allow inferred-safe imports, nothing would be `Safe`.+      -Wno-inferred-safe-imports+      -- We support GHC versions without qualified-post.+      -Wno-prepositive-qualified-module+      -- `-trust` triggers this warning when applied to transitive dependencies.+      -Wno-unused-packages+  if impl(ghc >= 9.2.1)+    ghc-options:+      -- We support GHC versions without kind signatures.+      -Wno-missing-kind-signatures+  if impl(ghc >= 9.8.1)+    ghc-options:+      -- We support GHC versions without kind signatures.+      -Wno-missing-poly-kind-signatures+      -- Inference good.+      -Wno-missing-role-annotations+  default-extensions:+    DefaultSignatures+    ExplicitNamespaces+    FunctionalDependencies+    LiberalTypeSynonyms+    -- replace with `LexicalNegation` if the oldest supported version is GHC 9.0.1++    NegativeLiterals+    PackageImports+    ParallelListComp+    -- QualifiedDo - uncomment if the oldest supported version is GHC 9.0.1++    RecursiveDo+    -- RequiredTypeArguments - uncomment if the oldest supported version is GHC 9.10.1++    RoleAnnotations+    StrictData+    TemplateHaskellQuotes+    TransformListComp+    NoGeneralizedNewtypeDeriving+    NoImplicitPrelude+    NoMonomorphismRestriction+    NoPatternGuards+    NoTypeApplications++custom-setup+  setup-depends:+    -- TODO: Remove `Cabal` dep once haskell/cabal#3751 is fixed.+    Cabal ^>= {3.0.0, 3.2.0, 3.4.0, 3.6.0, 3.8.0, 3.10.0},+    base ^>= {4.12.0, 4.13.0, 4.14.0, 4.15.0, 4.16.0, 4.17.0, 4.18.0, 4.19.0},+    cabal-doctest ^>= 1.0.0++library+  import: defaults+  hs-source-dirs: src+  exposed-modules:+    Yaya.Applied+    Yaya.Experimental.Foldable+    Yaya.Fold+    Yaya.Fold.Common+    Yaya.Fold.Native+    Yaya.Functor+    Yaya.Pattern+    Yaya.Retrofit+    Yaya.Zoo+  other-modules:+    Yaya.Fold.Native.Internal+  build-depends:+    comonad,+    either,+    free,+    kan-extensions,+    lens,+    profunctors,+    strict,+    template-haskell,+    th-abstraction,+    transformers,+  ghc-options:+    -trust adjunctions+    -trust array+    -trust base-orphans+    -trust binary+    -trust bytestring+    -trust containers+    -trust distributive+    -trust exceptions+    -trust ghc-prim+    -trust lens+    -trust profunctors+    -trust semigroupoids+    -trust stm+    -trust template-haskell+    -trust text+    -trust transformers-compat+  if impl(ghc < 9.6)+    ghc-options:+      -trust foldable1-classes-compat++test-suite doctests+  import: defaults+  type: exitcode-stdio-1.0+  hs-source-dirs: tests+  main-is: doctests.hs+  build-depends:+    doctest ^>= {0.15.0, 0.16.0, 0.17.0, 0.18.0, 0.19.0, 0.20.0, 0.21.0, 0.22.0},+    yaya,+  -- TODO: The sections below here are necessary because we don’t have control+  --       over the generated `Build_doctests.hs` file. So we have to silence+  --       all of its warnings one way or another.+  ghc-options:+    -Wno-missing-export-lists+    -Wno-missing-import-lists+    -Wno-safe+  if impl(ghc >= 8.8.1)+    ghc-options:+      -- This used to warn even when `Safe` was explicit.+      -Wno-missing-deriving-strategies+  default-extensions:+    -- Since we can’t add `{-# LANGUAGE Safe -#}` to the generated+    -- “Build_doctests.hs”, we set it here, and that means it has to match+    -- doctests.hs, which is `Unsafe`.+    Unsafe