semigroupoids 5.3.5 → 5.3.6
raw patch · 20 files changed
+1676/−68 lines, 20 filesdep +voiddep ~basedep ~hashabledep ~transformers
Dependencies added: void
Dependency ranges changed: base, hashable, transformers
Files
- CHANGELOG.markdown +15/−0
- README.markdown +51/−3
- img/classes.dot +52/−0
- img/classes.svg +306/−0
- semigroupoids.cabal +28/−16
- src/Data/Functor/Alt.hs +60/−16
- src/Data/Functor/Apply.hs +12/−1
- src/Data/Functor/Bind/Class.hs +77/−15
- src/Data/Functor/Bind/Trans.hs +16/−0
- src/Data/Functor/Contravariant/Conclude.hs +226/−0
- src/Data/Functor/Contravariant/Decide.hs +252/−0
- src/Data/Functor/Contravariant/Divise.hs +309/−0
- src/Data/Functor/Plus.hs +41/−9
- src/Data/Semigroup/Foldable.hs +2/−2
- src/Data/Semigroup/Foldable/Class.hs +34/−4
- src/Data/Semigroup/Traversable.hs +18/−0
- src/Data/Semigroup/Traversable/Class.hs +1/−2
- src/Data/Semigroupoid/Categorical.hs +50/−0
- src/Semigroupoids/Do.hs +96/−0
- src/Semigroupoids/Internal.hs +30/−0
CHANGELOG.markdown view
@@ -1,3 +1,18 @@+5.3.6 [2021.10.07]+------------------+* Allow building with GHC 9.2.+* Allow building with `transformers-0.6.*`.+* Add `Alt` instance for `Identity`.+* Add `Conclude`, `Decide` and `Divise` type classes and instances.+* Add `(<.*>)`, `(<*.>)`, and `traverseMaybe` functions, which make it easier+ to defined `Traversable1` instances for data types that have fields with a+ combination of `Traversable` and `Traversable1` instances.+* Add `Semigroupoids.Do` module with overloads for use with `QualifiedDo`.+* Add `Apply`, `Alt`, `Plus`, `Bind` and `BindTrans` instances for the CPS+ versions of `WriterT` and `RWST`.+* Add `psum` function to `Data.Functor.Plus`.+* Add `Categorical` data type.+ 5.3.5 [2020.12.31] ------------------ * The build-type has been changed from `Custom` to `Simple`.
README.markdown view
@@ -1,15 +1,63 @@ semigroupoids-==========+============= [](https://hackage.haskell.org/package/semigroupoids) [](https://github.com/ekmett/semigroupoids/actions?query=workflow%3AHaskell-CI) -A semigroupoid is a `Category` without `id`.+A semigroupoid is a `Category` without `id`. This package provides a range of +`id`-free versions of type classes, as well as some supporting functions and+data types. +Field Guide+-----------++The diagram below describes the relationships between the type classes defined+in this package, and those from `base` (with some from `contravariant` as well). Thick-bordered+nodes correspond to type classes defined in this package; thin-bordered ones are+from elsewhere. Solid edges represent subclass relationships that actually+exist; dashed edges are those which _should_ exist in theory.++++We also provide the following table. This is structured in superclass order -+thus, for any type class `T`, all superclasses of `T` will be listed before `T`+in the table.++|**Name**|**Location**|**Superclass of**|**Ideally superclass of**|+|--------|------------|-----------------|-------------------------|+|`Functor`|`base`|`Alt`, `Apply`, `Traversable`||+|`Foldable`|`base`|`Traversable`, `Foldable1`||+|`Bifunctor`|`base`|`Biapply`||+|`Contravariant`|`base`|`Divise`, `Decide`||+|`Semigroupoid`|`semigroupoids`||`Category`|+|`Alt`|`semigroupoids`|`Plus`||+|`Apply`|`semigroupoids`|`Bind`|`Applicative`|+|`Traversable`|`base`|`Traversable1`||+|`Foldable1`|`semigroupoids`|`Traversable1`||+|`Biapply`|`semigroupoids`|||+|`Divise`|`semigroupoids`||`Divisible`|+|`Decide`|`semigroupoids`|`Conclude`|`Decidable`|+|`Category`|`base`|`Arrow`||+|`Plus`|`semigroupoids`||`Alternative`|+|`Applicative`|`base`|`Alternative`, `Monad`||+|`Bind`|`semigroupoids`||`Monad`|+|`Traversable1`|`semigroupoids`|||+|`Divisible`|`contravariant`|||+|`Conclude`|`semigroupoids`||`Decidable`|+|`Arrow`|`base`|||+|`Alternative`|`base`|`MonadPlus`||+|`Monad`|`base`|`MonadPlus`||+|`Decidable`|`contravariant`|||+|`MonadPlus`|`base`|||++We omit some type class relationships from this diagram, as they are not+relevant for the purposes of this package.+ Contact Information ------------------- Contributions and bug reports are welcome! -Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net.+Please feel free to contact me through Github or on the #haskell IRC channel on+LiberaChat. -Edward Kmett
+ img/classes.dot view
@@ -0,0 +1,52 @@+digraph {+ node[shape=box];+ functor [label="Functor"];+ foldable [label="Foldable"];+ traversable [label="Traversable"];+ apply [label="Apply", penwidth=2.0];+ bind [label="Bind", penwidth=2.0];+ applicative [label="Applicative"];+ alt [label="Alt", penwidth=2.0];+ plus [label="Plus", penwidth=2.0];+ alternative [label="Alternative"];+ monad [label="Monad"];+ monad_plus [label="MonadPlus"];+ foldable1 [label="Foldable1", penwidth=2.0];+ traversable1 [label="Traversable1", penwidth=2.0];+ bifunctor [label="Bifunctor"];+ biapply [label="Biapply", penwidth=2.0];+ contravariant [label="Contravariant"];+ divise [label="Divise", penwidth=2.0];+ decide [label="Decide", penwidth=2.0];+ divisible [label="Divisible"];+ decidable [label="Decidable"];+ conclude [label="Conclude", penwidth=2.0];+ semigroupoid [label="Semigroupoid", penwidth=2.0];+ category [label="Category"];+ arrow [label="Arrow"];+ functor -> apply;+ functor -> alt;+ apply -> bind;+ apply -> applicative [style=dashed];+ alt -> plus;+ plus -> alternative [style=dashed];+ applicative -> alternative;+ applicative -> monad;+ bind -> monad [style=dashed];+ monad -> monad_plus;+ alternative -> monad_plus;+ functor -> traversable;+ foldable -> traversable;+ foldable -> foldable1;+ foldable1 -> traversable1;+ traversable -> traversable1;+ bifunctor -> biapply;+ contravariant -> divise;+ contravariant -> decide;+ divise -> divisible [style=dashed];+ decide -> decidable [style=dashed];+ decide -> conclude;+ conclude -> decidable [style=dashed];+ semigroupoid -> category [style=dashed];+ category -> arrow;+}
+ img/classes.svg view
@@ -0,0 +1,306 @@+<?xml version="1.0" encoding="UTF-8" standalone="no"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+ "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<!-- Generated by graphviz version 2.49.1 (0)+ -->+<!-- Pages: 1 -->+<svg width="712pt" height="332pt"+ viewBox="0.00 0.00 712.00 332.00" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">+<g id="graph0" class="graph" transform="scale(1 1) rotate(0) translate(4 328)">+<polygon fill="white" stroke="transparent" points="-4,4 -4,-328 708,-328 708,4 -4,4"/>+<!-- functor -->+<g id="node1" class="node">+<title>functor</title>+<polygon fill="none" stroke="black" points="141.5,-324 82.5,-324 82.5,-288 141.5,-288 141.5,-324"/>+<text text-anchor="middle" x="112" y="-302.3" font-family="Times,serif" font-size="14.00">Functor</text>+</g>+<!-- traversable -->+<g id="node3" class="node">+<title>traversable</title>+<polygon fill="none" stroke="black" points="237,-252 157,-252 157,-216 237,-216 237,-252"/>+<text text-anchor="middle" x="197" y="-230.3" font-family="Times,serif" font-size="14.00">Traversable</text>+</g>+<!-- functor->traversable -->+<g id="edge12" class="edge">+<title>functor->traversable</title>+<path fill="none" stroke="black" d="M133.01,-287.7C143.72,-278.88 156.89,-268.03 168.5,-258.47"/>+<polygon fill="black" stroke="black" points="170.74,-261.16 176.23,-252.1 166.29,-255.76 170.74,-261.16"/>+</g>+<!-- apply -->+<g id="node4" class="node">+<title>apply</title>+<polygon fill="none" stroke="black" stroke-width="2" points="139,-252 85,-252 85,-216 139,-216 139,-252"/>+<text text-anchor="middle" x="112" y="-230.3" font-family="Times,serif" font-size="14.00">Apply</text>+</g>+<!-- functor->apply -->+<g id="edge1" class="edge">+<title>functor->apply</title>+<path fill="none" stroke="black" d="M112,-287.7C112,-279.98 112,-270.71 112,-262.11"/>+<polygon fill="black" stroke="black" points="115.5,-262.1 112,-252.1 108.5,-262.1 115.5,-262.1"/>+</g>+<!-- alt -->+<g id="node7" class="node">+<title>alt</title>+<polygon fill="none" stroke="black" stroke-width="2" points="61,-252 7,-252 7,-216 61,-216 61,-252"/>+<text text-anchor="middle" x="34" y="-230.3" font-family="Times,serif" font-size="14.00">Alt</text>+</g>+<!-- functor->alt -->+<g id="edge2" class="edge">+<title>functor->alt</title>+<path fill="none" stroke="black" d="M92.72,-287.7C83.08,-279.05 71.27,-268.45 60.77,-259.03"/>+<polygon fill="black" stroke="black" points="62.84,-256.18 53.06,-252.1 58.16,-261.39 62.84,-256.18"/>+</g>+<!-- foldable -->+<g id="node2" class="node">+<title>foldable</title>+<polygon fill="none" stroke="black" points="275,-324 211,-324 211,-288 275,-288 275,-324"/>+<text text-anchor="middle" x="243" y="-302.3" font-family="Times,serif" font-size="14.00">Foldable</text>+</g>+<!-- foldable->traversable -->+<g id="edge13" class="edge">+<title>foldable->traversable</title>+<path fill="none" stroke="black" d="M231.63,-287.7C226.28,-279.56 219.8,-269.69 213.89,-260.7"/>+<polygon fill="black" stroke="black" points="216.66,-258.54 208.24,-252.1 210.81,-262.38 216.66,-258.54"/>+</g>+<!-- foldable1 -->+<g id="node12" class="node">+<title>foldable1</title>+<polygon fill="none" stroke="black" stroke-width="2" points="326.5,-252 255.5,-252 255.5,-216 326.5,-216 326.5,-252"/>+<text text-anchor="middle" x="291" y="-230.3" font-family="Times,serif" font-size="14.00">Foldable1</text>+</g>+<!-- foldable->foldable1 -->+<g id="edge14" class="edge">+<title>foldable->foldable1</title>+<path fill="none" stroke="black" d="M254.87,-287.7C260.5,-279.47 267.35,-269.48 273.57,-260.42"/>+<polygon fill="black" stroke="black" points="276.5,-262.33 279.27,-252.1 270.73,-258.37 276.5,-262.33"/>+</g>+<!-- traversable1 -->+<g id="node13" class="node">+<title>traversable1</title>+<polygon fill="none" stroke="black" stroke-width="2" points="332.5,-180 245.5,-180 245.5,-144 332.5,-144 332.5,-180"/>+<text text-anchor="middle" x="289" y="-158.3" font-family="Times,serif" font-size="14.00">Traversable1</text>+</g>+<!-- traversable->traversable1 -->+<g id="edge16" class="edge">+<title>traversable->traversable1</title>+<path fill="none" stroke="black" d="M219.74,-215.7C231.44,-206.8 245.86,-195.82 258.51,-186.2"/>+<polygon fill="black" stroke="black" points="260.68,-188.94 266.52,-180.1 256.44,-183.37 260.68,-188.94"/>+</g>+<!-- bind -->+<g id="node5" class="node">+<title>bind</title>+<polygon fill="none" stroke="black" stroke-width="2" points="224,-180 170,-180 170,-144 224,-144 224,-180"/>+<text text-anchor="middle" x="197" y="-158.3" font-family="Times,serif" font-size="14.00">Bind</text>+</g>+<!-- apply->bind -->+<g id="edge3" class="edge">+<title>apply->bind</title>+<path fill="none" stroke="black" d="M133.01,-215.7C143.72,-206.88 156.89,-196.03 168.5,-186.47"/>+<polygon fill="black" stroke="black" points="170.74,-189.16 176.23,-180.1 166.29,-183.76 170.74,-189.16"/>+</g>+<!-- applicative -->+<g id="node6" class="node">+<title>applicative</title>+<polygon fill="none" stroke="black" points="152,-180 72,-180 72,-144 152,-144 152,-180"/>+<text text-anchor="middle" x="112" y="-158.3" font-family="Times,serif" font-size="14.00">Applicative</text>+</g>+<!-- apply->applicative -->+<g id="edge4" class="edge">+<title>apply->applicative</title>+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M112,-215.7C112,-207.98 112,-198.71 112,-190.11"/>+<polygon fill="black" stroke="black" points="115.5,-190.1 112,-180.1 108.5,-190.1 115.5,-190.1"/>+</g>+<!-- monad -->+<g id="node10" class="node">+<title>monad</title>+<polygon fill="none" stroke="black" points="183,-108 127,-108 127,-72 183,-72 183,-108"/>+<text text-anchor="middle" x="155" y="-86.3" font-family="Times,serif" font-size="14.00">Monad</text>+</g>+<!-- bind->monad -->+<g id="edge9" class="edge">+<title>bind->monad</title>+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M186.62,-143.7C181.74,-135.56 175.81,-125.69 170.42,-116.7"/>+<polygon fill="black" stroke="black" points="173.41,-114.88 165.26,-108.1 167.41,-118.48 173.41,-114.88"/>+</g>+<!-- alternative -->+<g id="node9" class="node">+<title>alternative</title>+<polygon fill="none" stroke="black" points="108.5,-108 31.5,-108 31.5,-72 108.5,-72 108.5,-108"/>+<text text-anchor="middle" x="70" y="-86.3" font-family="Times,serif" font-size="14.00">Alternative</text>+</g>+<!-- applicative->alternative -->+<g id="edge7" class="edge">+<title>applicative->alternative</title>+<path fill="none" stroke="black" d="M101.62,-143.7C96.74,-135.56 90.81,-125.69 85.42,-116.7"/>+<polygon fill="black" stroke="black" points="88.41,-114.88 80.26,-108.1 82.41,-118.48 88.41,-114.88"/>+</g>+<!-- applicative->monad -->+<g id="edge8" class="edge">+<title>applicative->monad</title>+<path fill="none" stroke="black" d="M122.63,-143.7C127.63,-135.56 133.69,-125.69 139.21,-116.7"/>+<polygon fill="black" stroke="black" points="142.24,-118.46 144.49,-108.1 136.28,-114.79 142.24,-118.46"/>+</g>+<!-- plus -->+<g id="node8" class="node">+<title>plus</title>+<polygon fill="none" stroke="black" stroke-width="2" points="54,-180 0,-180 0,-144 54,-144 54,-180"/>+<text text-anchor="middle" x="27" y="-158.3" font-family="Times,serif" font-size="14.00">Plus</text>+</g>+<!-- alt->plus -->+<g id="edge5" class="edge">+<title>alt->plus</title>+<path fill="none" stroke="black" d="M32.27,-215.7C31.5,-207.98 30.57,-198.71 29.71,-190.11"/>+<polygon fill="black" stroke="black" points="33.19,-189.71 28.71,-180.1 26.22,-190.4 33.19,-189.71"/>+</g>+<!-- plus->alternative -->+<g id="edge6" class="edge">+<title>plus->alternative</title>+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M37.63,-143.7C42.63,-135.56 48.69,-125.69 54.21,-116.7"/>+<polygon fill="black" stroke="black" points="57.24,-118.46 59.49,-108.1 51.28,-114.79 57.24,-118.46"/>+</g>+<!-- monad_plus -->+<g id="node11" class="node">+<title>monad_plus</title>+<polygon fill="none" stroke="black" points="151.5,-36 72.5,-36 72.5,0 151.5,0 151.5,-36"/>+<text text-anchor="middle" x="112" y="-14.3" font-family="Times,serif" font-size="14.00">MonadPlus</text>+</g>+<!-- alternative->monad_plus -->+<g id="edge11" class="edge">+<title>alternative->monad_plus</title>+<path fill="none" stroke="black" d="M80.38,-71.7C85.26,-63.56 91.19,-53.69 96.58,-44.7"/>+<polygon fill="black" stroke="black" points="99.59,-46.48 101.74,-36.1 93.59,-42.88 99.59,-46.48"/>+</g>+<!-- monad->monad_plus -->+<g id="edge10" class="edge">+<title>monad->monad_plus</title>+<path fill="none" stroke="black" d="M144.37,-71.7C139.37,-63.56 133.31,-53.69 127.79,-44.7"/>+<polygon fill="black" stroke="black" points="130.72,-42.79 122.51,-36.1 124.76,-46.46 130.72,-42.79"/>+</g>+<!-- foldable1->traversable1 -->+<g id="edge15" class="edge">+<title>foldable1->traversable1</title>+<path fill="none" stroke="black" d="M290.51,-215.7C290.29,-207.98 290.02,-198.71 289.77,-190.11"/>+<polygon fill="black" stroke="black" points="293.27,-190 289.49,-180.1 286.28,-190.2 293.27,-190"/>+</g>+<!-- bifunctor -->+<g id="node14" class="node">+<title>bifunctor</title>+<polygon fill="none" stroke="black" points="408,-324 340,-324 340,-288 408,-288 408,-324"/>+<text text-anchor="middle" x="374" y="-302.3" font-family="Times,serif" font-size="14.00">Bifunctor</text>+</g>+<!-- biapply -->+<g id="node15" class="node">+<title>biapply</title>+<polygon fill="none" stroke="black" stroke-width="2" points="403.5,-252 344.5,-252 344.5,-216 403.5,-216 403.5,-252"/>+<text text-anchor="middle" x="374" y="-230.3" font-family="Times,serif" font-size="14.00">Biapply</text>+</g>+<!-- bifunctor->biapply -->+<g id="edge17" class="edge">+<title>bifunctor->biapply</title>+<path fill="none" stroke="black" d="M374,-287.7C374,-279.98 374,-270.71 374,-262.11"/>+<polygon fill="black" stroke="black" points="377.5,-262.1 374,-252.1 370.5,-262.1 377.5,-262.1"/>+</g>+<!-- contravariant -->+<g id="node16" class="node">+<title>contravariant</title>+<polygon fill="none" stroke="black" points="542.5,-324 451.5,-324 451.5,-288 542.5,-288 542.5,-324"/>+<text text-anchor="middle" x="497" y="-302.3" font-family="Times,serif" font-size="14.00">Contravariant</text>+</g>+<!-- divise -->+<g id="node17" class="node">+<title>divise</title>+<polygon fill="none" stroke="black" stroke-width="2" points="476,-252 422,-252 422,-216 476,-216 476,-252"/>+<text text-anchor="middle" x="449" y="-230.3" font-family="Times,serif" font-size="14.00">Divise</text>+</g>+<!-- contravariant->divise -->+<g id="edge18" class="edge">+<title>contravariant->divise</title>+<path fill="none" stroke="black" d="M485.13,-287.7C479.5,-279.47 472.65,-269.48 466.43,-260.42"/>+<polygon fill="black" stroke="black" points="469.27,-258.37 460.73,-252.1 463.5,-262.33 469.27,-258.37"/>+</g>+<!-- decide -->+<g id="node18" class="node">+<title>decide</title>+<polygon fill="none" stroke="black" stroke-width="2" points="549.5,-252 494.5,-252 494.5,-216 549.5,-216 549.5,-252"/>+<text text-anchor="middle" x="522" y="-230.3" font-family="Times,serif" font-size="14.00">Decide</text>+</g>+<!-- contravariant->decide -->+<g id="edge19" class="edge">+<title>contravariant->decide</title>+<path fill="none" stroke="black" d="M503.18,-287.7C506,-279.81 509.39,-270.3 512.52,-261.55"/>+<polygon fill="black" stroke="black" points="515.82,-262.7 515.89,-252.1 509.23,-260.34 515.82,-262.7"/>+</g>+<!-- divisible -->+<g id="node19" class="node">+<title>divisible</title>+<polygon fill="none" stroke="black" points="482,-180 416,-180 416,-144 482,-144 482,-180"/>+<text text-anchor="middle" x="449" y="-158.3" font-family="Times,serif" font-size="14.00">Divisible</text>+</g>+<!-- divise->divisible -->+<g id="edge20" class="edge">+<title>divise->divisible</title>+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M449,-215.7C449,-207.98 449,-198.71 449,-190.11"/>+<polygon fill="black" stroke="black" points="452.5,-190.1 449,-180.1 445.5,-190.1 452.5,-190.1"/>+</g>+<!-- decidable -->+<g id="node20" class="node">+<title>decidable</title>+<polygon fill="none" stroke="black" points="582.5,-108 511.5,-108 511.5,-72 582.5,-72 582.5,-108"/>+<text text-anchor="middle" x="547" y="-86.3" font-family="Times,serif" font-size="14.00">Decidable</text>+</g>+<!-- decide->decidable -->+<g id="edge21" class="edge">+<title>decide->decidable</title>+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M524.1,-215.87C526.4,-197.9 530.38,-168.87 535,-144 536.58,-135.52 538.56,-126.34 540.45,-118.04"/>+<polygon fill="black" stroke="black" points="543.9,-118.65 542.77,-108.12 537.09,-117.06 543.9,-118.65"/>+</g>+<!-- conclude -->+<g id="node21" class="node">+<title>conclude</title>+<polygon fill="none" stroke="black" stroke-width="2" points="612,-180 544,-180 544,-144 612,-144 612,-180"/>+<text text-anchor="middle" x="578" y="-158.3" font-family="Times,serif" font-size="14.00">Conclude</text>+</g>+<!-- decide->conclude -->+<g id="edge22" class="edge">+<title>decide->conclude</title>+<path fill="none" stroke="black" d="M535.84,-215.7C542.49,-207.39 550.58,-197.28 557.89,-188.14"/>+<polygon fill="black" stroke="black" points="560.8,-190.1 564.32,-180.1 555.34,-185.73 560.8,-190.1"/>+</g>+<!-- conclude->decidable -->+<g id="edge23" class="edge">+<title>conclude->decidable</title>+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M570.34,-143.7C566.81,-135.73 562.54,-126.1 558.63,-117.26"/>+<polygon fill="black" stroke="black" points="561.82,-115.83 554.57,-108.1 555.42,-118.67 561.82,-115.83"/>+</g>+<!-- semigroupoid -->+<g id="node22" class="node">+<title>semigroupoid</title>+<polygon fill="none" stroke="black" stroke-width="2" points="704,-324 610,-324 610,-288 704,-288 704,-324"/>+<text text-anchor="middle" x="657" y="-302.3" font-family="Times,serif" font-size="14.00">Semigroupoid</text>+</g>+<!-- category -->+<g id="node23" class="node">+<title>category</title>+<polygon fill="none" stroke="black" points="690,-252 624,-252 624,-216 690,-216 690,-252"/>+<text text-anchor="middle" x="657" y="-230.3" font-family="Times,serif" font-size="14.00">Category</text>+</g>+<!-- semigroupoid->category -->+<g id="edge24" class="edge">+<title>semigroupoid->category</title>+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M657,-287.7C657,-279.98 657,-270.71 657,-262.11"/>+<polygon fill="black" stroke="black" points="660.5,-262.1 657,-252.1 653.5,-262.1 660.5,-262.1"/>+</g>+<!-- arrow -->+<g id="node24" class="node">+<title>arrow</title>+<polygon fill="none" stroke="black" points="684,-180 630,-180 630,-144 684,-144 684,-180"/>+<text text-anchor="middle" x="657" y="-158.3" font-family="Times,serif" font-size="14.00">Arrow</text>+</g>+<!-- category->arrow -->+<g id="edge25" class="edge">+<title>category->arrow</title>+<path fill="none" stroke="black" d="M657,-215.7C657,-207.98 657,-198.71 657,-190.11"/>+<polygon fill="black" stroke="black" points="660.5,-190.1 657,-180.1 653.5,-190.1 660.5,-190.1"/>+</g>+</g>+</svg>
semigroupoids.cabal view
@@ -1,8 +1,8 @@ name: semigroupoids category: Control, Comonads-version: 5.3.5-license: BSD3-cabal-version: >= 1.10+version: 5.3.6+license: BSD2+cabal-version: 1.18 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett <ekmett@gmail.com>@@ -20,8 +20,9 @@ , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5- , GHC == 8.8.3- , GHC == 8.10.1+ , GHC == 8.8.4+ , GHC == 8.10.4+ , GHC == 9.0.1 build-type: Simple synopsis: Semigroupoids: Category sans id extra-source-files:@@ -29,6 +30,9 @@ .vim.custom README.markdown CHANGELOG.markdown+ img/classes.dot+extra-doc-files:+ img/classes.svg description: Provides a wide array of (semi)groupoids and operations for working with them.@@ -43,16 +47,14 @@ . Similarly many structures are nearly a comonad, but not quite, for instance lists provide a reasonable 'extend' operation in the form of 'tails', but do not always contain a value. .- Ideally the following relationships would hold:+ We describe the relationships between the type classes defined in this package+ and those from `base` (and some from `contravariant`) in the diagram below.+ Thick-bordered nodes correspond to type classes defined in this package;+ thin-bordered ones correspond to type classes from elsewhere. Solid edges+ indicate a subclass relationship that actually exists; dashed edges indicate a+ subclass relationship that /should/ exist, but currently doesn't. .- > Foldable ----> Traversable <--- Functor ------> Alt ---------> Plus Semigroupoid- > | | | | |- > v v v v v- > Foldable1 ---> Traversable1 Apply --------> Applicative -> Alternative Category- > | | | |- > v v v v- > Bind ---------> Monad -------> MonadPlus Arrow- >+ <<img/classes.svg Relationships among type classes from this package and others>> . Apply, Bind, and Extend (not shown) give rise the Static, Kleisli and Cokleisli semigroupoids respectively. .@@ -130,8 +132,8 @@ base-orphans >= 0.8.4 && < 1, bifunctors >= 5.5.9 && < 6, template-haskell >= 0.2.5.0,- transformers >= 0.3 && < 0.6,- transformers-compat >= 0.5 && < 0.7+ transformers >= 0.3 && < 0.7,+ transformers-compat >= 0.5 && < 0.8 if impl(ghc >= 7.0 && < 7.2) build-depends: generic-deriving >= 1.14 && < 1.15@@ -139,6 +141,9 @@ if impl(ghc >= 7.2 && < 7.6) build-depends: ghc-prim + if !impl(ghc >= 7.10)+ build-depends: void >= 0.4 && < 1+ if !impl(ghc >= 8.0) build-depends: semigroups >= 0.18.5 && < 1 @@ -174,6 +179,9 @@ Data.Functor.Bind Data.Functor.Bind.Class Data.Functor.Bind.Trans+ Data.Functor.Contravariant.Conclude+ Data.Functor.Contravariant.Decide+ Data.Functor.Contravariant.Divise Data.Functor.Extend Data.Functor.Plus Data.Groupoid@@ -185,10 +193,14 @@ Data.Semigroup.Traversable Data.Semigroup.Traversable.Class Data.Semigroupoid+ Data.Semigroupoid.Categorical Data.Semigroupoid.Dual Data.Semigroupoid.Ob Data.Semigroupoid.Static Data.Traversable.Instances+ Semigroupoids.Do+ other-modules:+ Semigroupoids.Internal ghc-options: -Wall -fno-warn-warnings-deprecations
src/Data/Functor/Alt.hs view
@@ -35,11 +35,14 @@ import Control.Exception (catch, SomeException) import Control.Monad import Control.Monad.Trans.Identity-import Control.Monad.Trans.Error import Control.Monad.Trans.Except-import Control.Monad.Trans.List import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader+#if MIN_VERSION_transformers(0,5,6)+import qualified Control.Monad.Trans.RWS.CPS as CPS+import qualified Control.Monad.Trans.Writer.CPS as CPS+import Semigroupoids.Internal+#endif import qualified Control.Monad.Trans.RWS.Strict as Strict import qualified Control.Monad.Trans.State.Strict as Strict import qualified Control.Monad.Trans.Writer.Strict as Strict@@ -49,26 +52,38 @@ import Data.Functor.Apply import Data.Functor.Bind import Data.Functor.Compose+import Data.Functor.Identity (Identity (Identity)) import Data.Functor.Product import Data.Functor.Reverse import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Monoid as Monoid-import Data.Semigroup (Option(..), Semigroup(..))+import Data.Semigroup (Semigroup(..)) import qualified Data.Semigroup as Semigroup-import Prelude (($),Either(..),Maybe(..),const,IO,Ord,(++),(.),either,seq,undefined)+import Prelude (($),Either(..),Maybe(..),const,IO,(++),(.),either,seq,undefined,repeat) import Unsafe.Coerce +#if !(MIN_VERSION_transformers(0,6,0))+import Control.Monad.Trans.Error+import Control.Monad.Trans.List+#endif++#if MIN_VERSION_base(4,8,0)+import Prelude (mappend)+#else+import Data.Monoid (mappend)+#endif++#if !(MIN_VERSION_base(4,16,0))+import Data.Semigroup (Option(..))+#endif+ #ifdef MIN_VERSION_containers import qualified Data.IntMap as IntMap import Data.IntMap (IntMap) import Data.Sequence (Seq) import qualified Data.Map as Map import Data.Map (Map)-# if MIN_VERSION_base(4,8,0)-import Prelude (mappend)-# else-import Data.Monoid (mappend)-# endif+import Prelude (Ord) #endif #if defined(MIN_VERSION_tagged) || (MIN_VERSION_base(4,7,0))@@ -98,18 +113,20 @@ -- -- If extended to an 'Alternative' then '<!>' should equal '<|>'. ----- Ideally, an instance of 'Alt' also satisfies the \"left distributon\" law of+-- Ideally, an instance of 'Alt' also satisfies the \"left distribution\" law of -- MonadPlus with respect to '<.>': -- -- > <.> right-distributes over <!>: (a <!> b) <.> c = (a <.> c) <!> (b <.> c) ----- But 'Maybe', 'IO', @'Either' a@, @'ErrorT' e m@, and 'GHC.Conc.STM' satisfy the alternative--- \"left catch\" law instead:+-- 'IO', @'Either' a@, @'ExceptT' e m@ and 'GHC.Conc.STM' instead satisfy the+-- \"left catch\" law: -- -- > pure a <!> b = pure a ----- However, this variation cannot be stated purely in terms of the dependencies of 'Alt'.+-- 'Maybe' and 'Identity' satisfy both \"left distribution\" and \"left catch\". --+-- These variations cannot be stated purely in terms of the dependencies of 'Alt'.+-- -- When and if MonadPlus is successfully refactored, this class should also -- be refactored to remove these instances. --@@ -174,12 +191,22 @@ a <!> _ = a -- | This instance does not actually satisfy the ('<.>') right distributive law--- It instead satisfies the "Left-Catch" law+-- It instead satisfies the \"left catch\" law instance Alt IO where m <!> n = catch m (go n) where go :: x -> SomeException -> x go = const +-- | Choose the first option every time. While \'choose the last option\' every+-- time is also valid, this instance satisfies more laws.+--+-- @since 5.3.6+instance Alt Identity where+ {-# INLINEABLE (<!>) #-}+ m <!> _ = m+ some (Identity x) = Identity . repeat $ x+ many (Identity x) = Identity . repeat $ x+ instance Alt [] where (<!>) = (++) @@ -187,8 +214,10 @@ Nothing <!> b = b a <!> _ = a +#if !(MIN_VERSION_base(4,16,0)) instance Alt Option where (<!>) = (<|>)+#endif instance MonadPlus m => Alt (WrappedMonad m) where (<!>) = (<|>)@@ -231,6 +260,7 @@ Nothing -> b Just _ -> return v +#if !(MIN_VERSION_transformers(0,6,0)) instance (Bind f, Monad f) => Alt (ErrorT e f) where ErrorT m <!> ErrorT n = ErrorT $ do a <- m@@ -238,6 +268,10 @@ Left _ -> n Right r -> return (Right r) +instance Apply f => Alt (ListT f) where+ ListT a <!> ListT b = ListT $ (<!>) <$> a <.> b+#endif+ instance (Bind f, Monad f, Semigroup e) => Alt (ExceptT e f) where ExceptT m <!> ExceptT n = ExceptT $ do a <- m@@ -245,8 +279,6 @@ Left e -> liftM (either (Left . (<>) e) Right) n Right x -> return (Right x) -instance Apply f => Alt (ListT f) where- ListT a <!> ListT b = ListT $ (<!>) <$> a <.> b instance Alt f => Alt (Strict.StateT e f) where Strict.StateT m <!> Strict.StateT n = Strict.StateT $ \s -> m s <!> n s@@ -260,11 +292,23 @@ instance Alt f => Alt (Lazy.WriterT w f) where Lazy.WriterT m <!> Lazy.WriterT n = Lazy.WriterT $ m <!> n +#if MIN_VERSION_transformers(0,5,6)+-- | @since 5.3.6+instance (Alt f) => Alt (CPS.WriterT w f) where+ m <!> n = mkWriterT $ \w -> unWriterT m w <!> unWriterT n w+#endif+ instance Alt f => Alt (Strict.RWST r w s f) where Strict.RWST m <!> Strict.RWST n = Strict.RWST $ \r s -> m r s <!> n r s instance Alt f => Alt (Lazy.RWST r w s f) where Lazy.RWST m <!> Lazy.RWST n = Lazy.RWST $ \r s -> m r s <!> n r s++#if MIN_VERSION_transformers(0,5,6)+-- | @since 5.3.6+instance (Alt f) => Alt (CPS.RWST r w s f) where+ m <!> n = mkRWST $ \r s w -> unRWST m r s w <!> unRWST n r s w+#endif instance Alt f => Alt (Backwards f) where Backwards a <!> Backwards b = Backwards (a <!> b)
src/Data/Functor/Apply.hs view
@@ -28,9 +28,11 @@ -- * Wrappers , WrappedApplicative(..) , MaybeApply(..)+ , (<.*>)+ , (<*.>) ) where -import Control.Comonad+import Data.Functor import Data.Functor.Bind.Class infixl 4 <..>@@ -46,3 +48,12 @@ liftF3 f a b c = f <$> a <.> b <.> c {-# INLINE liftF3 #-} +#if !(MIN_VERSION_base(4,7,0))++infixl 4 $>++-- | Replace the contents of a functor uniformly with a constant value.+($>) :: Functor f => f a -> b -> f b+($>) = flip (<$)++#endif
src/Data/Functor/Bind/Class.hs view
@@ -37,6 +37,9 @@ -- * Wrappers , WrappedApplicative(..) , MaybeApply(..)+ , (<.*>)+ , (<*.>)+ , traverse1Maybe -- * Bindable functors , Bind(..) , apDefault@@ -53,12 +56,15 @@ import Control.Category import Control.Monad (ap) import Control.Monad.Trans.Cont-import Control.Monad.Trans.Error import Control.Monad.Trans.Except import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader-import Control.Monad.Trans.List+#if MIN_VERSION_transformers(0,5,6)+import qualified Control.Monad.Trans.RWS.CPS as CPS+import qualified Control.Monad.Trans.Writer.CPS as CPS+import Semigroupoids.Internal+#endif import qualified Control.Monad.Trans.RWS.Lazy as Lazy import qualified Control.Monad.Trans.State.Lazy as Lazy import qualified Control.Monad.Trans.Writer.Lazy as Lazy@@ -80,13 +86,18 @@ import Data.Functor.Product as Functor import Data.Functor.Reverse import Data.Functor.Extend-import Data.List.NonEmpty+import Data.List.NonEmpty (NonEmpty) import Data.Semigroup as Semigroup import qualified Data.Monoid as Monoid import Data.Orphans () import Language.Haskell.TH (Q) import Prelude hiding (id, (.)) +#if !(MIN_VERSION_transformers(0,6,0))+import Control.Monad.Trans.Error+import Control.Monad.Trans.List+#endif+ #if MIN_VERSION_base(4,6,0) import Data.Ord (Down (..)) #else@@ -127,6 +138,10 @@ import GHC.Generics as Generics #endif +#if __GLASGOW_HASKELL__ < 710+import Data.Traversable+#endif+ #ifdef MIN_VERSION_comonad import Control.Comonad import Control.Comonad.Trans.Env@@ -272,10 +287,12 @@ (<. ) = (<* ) ( .>) = ( *>) +#if !(MIN_VERSION_base(4,16,0)) instance Apply Option where (<.>) = (<*>) (<. ) = (<* ) ( .>) = ( *>)+#endif instance Apply Identity where (<.>) = (<*>)@@ -337,19 +354,21 @@ instance (Functor m, Monad m) => Apply (MaybeT m) where (<.>) = apDefault +#if !(MIN_VERSION_transformers(0,6,0)) -- ErrorT e is _not_ the same as Compose f (Either e) instance (Functor m, Monad m) => Apply (ErrorT e m) where (<.>) = apDefault +instance Apply m => Apply (ListT m) where+ ListT f <.> ListT a = ListT $ (<.>) <$> f <.> a+#endif+ instance (Functor m, Monad m) => Apply (ExceptT e m) where (<.>) = apDefault instance Apply m => Apply (ReaderT e m) where ReaderT f <.> ReaderT a = ReaderT $ \e -> f e <.> a e -instance Apply m => Apply (ListT m) where- ListT f <.> ListT a = ListT $ (<.>) <$> f <.> a- -- unfortunately, WriterT has its wrapped product in the wrong order to just use (<.>) instead of flap -- | A @'Strict.WriterT' w m@ is not 'Applicative' unless its @w@ is a 'Monoid', but it is an instance of 'Apply' instance (Apply m, Semigroup w) => Apply (Strict.WriterT w m) where@@ -361,6 +380,13 @@ Lazy.WriterT f <.> Lazy.WriterT a = Lazy.WriterT $ flap <$> f <.> a where flap ~(x,m) ~(y,n) = (x y, m <> n) +#if MIN_VERSION_transformers(0,5,6)+-- | @since 5.3.6+instance (Bind m) => Apply (CPS.WriterT w m) where+ mf <.> mx = mkWriterT $ \w ->+ unWriterT mf w >>- \(f, w') -> unWriterT (f <$> mx) w'+#endif+ instance Bind m => Apply (Strict.StateT s m) where (<.>) = apDefault @@ -375,6 +401,13 @@ instance (Bind m, Semigroup w) => Apply (Lazy.RWST r w s m) where (<.>) = apDefault +#if MIN_VERSION_transformers(0,5,6)+-- | @since 5.3.6+instance (Bind m) => Apply (CPS.RWST r w s m) where+ mf <.> mx = mkRWST $ \ r s w ->+ unRWST mf r s w >>- \(f, s', w') -> unRWST (f <$> mx) r s' w'+#endif+ instance Apply (ContT r m) where ContT f <.> ContT v = ContT $ \k -> f $ \g -> v (k . g) @@ -415,15 +448,31 @@ -- | Transform an Apply into an Applicative by adding a unit. newtype MaybeApply f a = MaybeApply { runMaybeApply :: Either (f a) a } +-- | Apply a non-empty container of functions to a possibly-empty-with-unit container of values.+(<.*>) :: (Apply f) => f (a -> b) -> MaybeApply f a -> f b+ff <.*> MaybeApply (Left fa) = ff <.> fa+ff <.*> MaybeApply (Right a) = ($ a) <$> ff+infixl 4 <.*>++-- | Apply a possibly-empty-with-unit container of functions to a non-empty container of values.+(<*.>) :: (Apply f) => MaybeApply f (a -> b) -> f a -> f b+MaybeApply (Left ff) <*.> fa = ff <.> fa+MaybeApply (Right f) <*.> fa = f <$> fa+infixl 4 <*.>++-- | Traverse a 'Traversable' using 'Apply', getting the results back in a 'MaybeApply'.+traverse1Maybe :: (Traversable t, Apply f) => (a -> f b) -> t a -> MaybeApply f (t b)+traverse1Maybe f = traverse (MaybeApply . Left . f)+ instance Functor f => Functor (MaybeApply f) where fmap f (MaybeApply (Right a)) = MaybeApply (Right (f a )) fmap f (MaybeApply (Left fa)) = MaybeApply (Left (f <$> fa)) instance Apply f => Apply (MaybeApply f) where- MaybeApply (Right f) <.> MaybeApply (Right a) = MaybeApply (Right (f a ))- MaybeApply (Right f) <.> MaybeApply (Left fa) = MaybeApply (Left (f <$> fa))- MaybeApply (Left ff) <.> MaybeApply (Right a) = MaybeApply (Left (($a) <$> ff))- MaybeApply (Left ff) <.> MaybeApply (Left fa) = MaybeApply (Left (ff <.> fa))+ MaybeApply (Right f) <.> MaybeApply (Right a) = MaybeApply (Right (f a ))+ MaybeApply (Right f) <.> MaybeApply (Left fa) = MaybeApply (Left (f <$> fa))+ MaybeApply (Left ff) <.> MaybeApply (Right a) = MaybeApply (Left (($ a) <$> ff))+ MaybeApply (Left ff) <.> MaybeApply (Left fa) = MaybeApply (Left (ff <.> fa)) MaybeApply a <. MaybeApply (Right _) = MaybeApply a MaybeApply (Right a) <. MaybeApply (Left fb) = MaybeApply (Left (a <$ fb))@@ -576,8 +625,10 @@ instance Bind Maybe where (>>-) = (>>=) +#if !(MIN_VERSION_base(4,16,0)) instance Bind Option where (>>-) = (>>=)+#endif instance Bind Identity where (>>-) = (>>=)@@ -594,6 +645,7 @@ instance (Functor m, Monad m) => Bind (MaybeT m) where (>>-) = (>>=) -- distributive law requires Monad to inject @Nothing@ +#if !(MIN_VERSION_transformers(0,6,0)) instance (Apply m, Monad m) => Bind (ListT m) where (>>-) = (>>=) -- distributive law requires Monad to inject @[]@ @@ -603,6 +655,7 @@ case a of Left l -> return (Left l) Right r -> runErrorT (k r)+#endif instance (Functor m, Monad m) => Bind (ExceptT e m) where m >>- k = ExceptT $ do@@ -628,6 +681,13 @@ Strict.runWriterT (k a) `returning` \ (b, w') -> (b, w <> w') +#if MIN_VERSION_transformers(0,5,6)+-- | @since 5.3.6+instance (Bind m) => Bind (CPS.WriterT w m) where+ m >>- k = mkWriterT $ \ w ->+ unWriterT m w >>- \(a, w') -> unWriterT (k a) w'+#endif+ instance Bind m => Bind (Lazy.StateT s m) where m >>- k = Lazy.StateT $ \s -> Lazy.runStateT m s >>- \ ~(a, s') ->@@ -652,13 +712,15 @@ Strict.runRWST (k a) r s' `returning` \ (b, s'', w') -> (b, s'', w <> w') +#if MIN_VERSION_transformers(0,5,6)+-- | @since 5.3.6+instance (Bind m) => Bind (CPS.RWST r w s m) where+ m >>- k = mkRWST $ \ r s w ->+ unRWST m r s w >>- \(a, s', w') -> unRWST (k a) r s' w'+#endif+ instance Bind (ContT r m) where m >>- k = ContT $ \c -> runContT m $ \a -> runContT (k a) c--{--instance ArrowApply a => Bind (WrappedArrow a b) where- (>>-) = (>>=)--} #if MIN_VERSION_base(4,4,0) instance Bind Complex where
src/Data/Functor/Bind/Trans.hs view
@@ -28,6 +28,10 @@ -- import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader -- import Control.Monad.Trans.List+#if MIN_VERSION_transformers(0,5,6)+import qualified Control.Monad.Trans.RWS.CPS as CPS+import qualified Control.Monad.Trans.Writer.CPS as CPS+#endif import qualified Control.Monad.Trans.RWS.Lazy as Lazy import qualified Control.Monad.Trans.State.Lazy as Lazy import qualified Control.Monad.Trans.Writer.Lazy as Lazy@@ -57,6 +61,12 @@ instance Monoid w => BindTrans (Strict.WriterT w) where liftB = Strict.WriterT . fmap (\a -> (a, mempty)) +#if MIN_VERSION_transformers(0,5,6)+-- | @since 5.3.6+instance Monoid w => BindTrans (CPS.WriterT w) where+ liftB = CPS.writerT . fmap (\a -> (a, mempty))+#endif+ instance BindTrans (Lazy.StateT s) where liftB m = Lazy.StateT $ \s -> fmap (\a -> (a, s)) m @@ -68,6 +78,12 @@ instance Monoid w => BindTrans (Strict.RWST r w s) where liftB m = Strict.RWST $ \ _r s -> fmap (\a -> (a, s, mempty)) m++#if MIN_VERSION_transformers(0,5,6)+-- | @since 5.3.6+instance Monoid w => BindTrans (CPS.RWST r w s) where+ liftB m = CPS.rwsT $ \ _r s -> fmap (\a -> (a, s, mempty)) m+#endif instance BindTrans (ContT r) where liftB m = ContT (m >>-)
+ src/Data/Functor/Contravariant/Conclude.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif+{-# LANGUAGE TypeOperators #-}++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2021 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+----------------------------------------------------------------------------+module Data.Functor.Contravariant.Conclude (+ Conclude(..)+ , concluded+ ) where++import Control.Applicative.Backwards+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict+import Control.Monad.Trans.Reader+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Strict as Strict++import Data.Functor.Apply+import Data.Functor.Compose+import Data.Functor.Contravariant+import Data.Functor.Contravariant.Decide+import Data.Functor.Contravariant.Divise+import Data.Functor.Contravariant.Divisible+import Data.Functor.Product+import Data.Functor.Reverse+import Data.Void++#if !(MIN_VERSION_transformers(0,6,0))+import Control.Monad.Trans.List+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Monoid (Alt(..))+#else+import Control.Applicative+#endif++#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged)+import Data.Proxy+#endif++#ifdef MIN_VERSION_StateVar+import Data.StateVar+#endif++#if __GLASGOW_HASKELL__ >= 702+#define GHC_GENERICS+import GHC.Generics+#endif++-- | The contravariant analogue of 'Plus'. Adds on to 'Decide' the ability+-- to express a combinator that rejects all input, to act as the dead-end.+-- Essentially 'Decidable' without a superclass constraint on 'Divisible'.+--+-- If one thinks of @f a@ as a consumer of @a@s, then 'conclude' defines+-- a consumer that cannot ever receive /any/ input.+--+-- Conclude acts as an identity with 'decide', because any decision that+-- involves 'conclude' must necessarily /always/ pick the other option.+--+-- That is, for, say,+--+-- @+-- 'decide' f x 'concluded'+-- @+--+-- @f@ is the deciding function that picks which of the inputs of @decide@+-- to direct input to; in the situation above, @f@ must /always/ direct all+-- input to @x@, and never 'concluded'.+--+-- Mathematically, a functor being an instance of 'Decide' means that it is+-- \"monoidal\" with respect to the contravariant "either-based" Day+-- convolution described in the documentation of 'Decide'. On top of+-- 'Decide', it adds a way to construct an \"identity\" @conclude@ where+-- @decide f x (conclude q) == x@, and @decide g (conclude r) y == y@.+--+-- @since 5.3.6+class Decide f => Conclude f where+ -- | The consumer that cannot ever receive /any/ input.+ conclude :: (a -> Void) -> f a++-- | A potentially more meaningful form of 'conclude', the consumer that cannot+-- ever receive /any/ input. That is because it expects only input of type+-- 'Void', but such a type has no values.+--+-- @+-- 'concluded' = 'conclude' 'id'+-- @+--+-- @since 5.3.6+concluded :: Conclude f => f Void+concluded = conclude id++-- | @since 5.3.6+instance Decidable f => Conclude (WrappedDivisible f) where+ conclude f = WrapDivisible (lose f)++-- | @since 5.3.6+instance Conclude Comparison where conclude = lose++-- | @since 5.3.6+instance Conclude Equivalence where conclude = lose++-- | @since 5.3.6+instance Conclude Predicate where conclude = lose++-- | @since 5.3.6+instance Conclude (Op r) where+ conclude f = Op $ absurd . f++#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged)+-- | @since 5.3.6+instance Conclude Proxy where conclude = lose+#endif++#ifdef MIN_VERSION_StateVar+-- | @since 5.3.6+instance Conclude SettableStateVar where conclude = lose+#endif++#if MIN_VERSION_base(4,8,0)+-- | @since 5.3.6+instance Conclude f => Conclude (Alt f) where+ conclude = Alt . conclude+#endif++#ifdef GHC_GENERICS+-- | @since 5.3.6+instance Conclude U1 where conclude = lose++-- | @since 5.3.6+instance Conclude f => Conclude (Rec1 f) where+ conclude = Rec1 . conclude++-- | @since 5.3.6+instance Conclude f => Conclude (M1 i c f) where+ conclude = M1 . conclude++-- | @since 5.3.6+instance (Conclude f, Conclude g) => Conclude (f :*: g) where+ conclude f = conclude f :*: conclude f++-- | @since 5.3.6+instance (Apply f, Applicative f, Conclude g) => Conclude (f :.: g) where+ conclude = Comp1 . pure . conclude+#endif++-- | @since 5.3.6+instance Conclude f => Conclude (Backwards f) where+ conclude = Backwards . conclude++-- | @since 5.3.6+instance Conclude f => Conclude (IdentityT f) where+ conclude = IdentityT . conclude++-- | @since 5.3.6+instance Conclude m => Conclude (ReaderT r m) where+ conclude f = ReaderT $ \_ -> conclude f++-- | @since 5.3.6+instance Conclude m => Conclude (Lazy.RWST r w s m) where+ conclude f = Lazy.RWST $ \_ _ -> contramap (\ ~(a, _, _) -> a) (conclude f)++-- | @since 5.3.6+instance Conclude m => Conclude (Strict.RWST r w s m) where+ conclude f = Strict.RWST $ \_ _ -> contramap (\(a, _, _) -> a) (conclude f)++#if !(MIN_VERSION_transformers(0,6,0))+-- | @since 5.3.6+instance (Divisible m, Divise m) => Conclude (ListT m) where+ conclude _ = ListT conquer+#endif++-- | @since 5.3.6+instance (Divisible m, Divise m) => Conclude (MaybeT m) where+ conclude _ = MaybeT conquer++-- | @since 5.3.6+instance Conclude m => Conclude (Lazy.StateT s m) where+ conclude f = Lazy.StateT $ \_ -> contramap lazyFst (conclude f)++-- | @since 5.3.6+instance Conclude m => Conclude (Strict.StateT s m) where+ conclude f = Strict.StateT $ \_ -> contramap fst (conclude f)++-- | @since 5.3.6+instance Conclude m => Conclude (Lazy.WriterT w m) where+ conclude f = Lazy.WriterT $ contramap lazyFst (conclude f)++-- | @since 5.3.6+instance Conclude m => Conclude (Strict.WriterT w m) where+ conclude f = Strict.WriterT $ contramap fst (conclude f)++-- | @since 5.3.6+instance (Apply f, Applicative f, Conclude g) => Conclude (Compose f g) where+ conclude = Compose . pure . conclude++-- | @since 5.3.6+instance (Conclude f, Conclude g) => Conclude (Product f g) where+ conclude f = Pair (conclude f) (conclude f)++-- | @since 5.3.6+instance Conclude f => Conclude (Reverse f) where+ conclude = Reverse . conclude++-- Helpers++lazyFst :: (a, b) -> a+lazyFst ~(a, _) = a
+ src/Data/Functor/Contravariant/Decide.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif+#if MIN_VERSION_base(4,7,0)+{-# LANGUAGE EmptyCase #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2021 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+----------------------------------------------------------------------------+module Data.Functor.Contravariant.Decide (+ Decide(..)+ , decided+ ) where++import Control.Applicative.Backwards+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict+import Control.Monad.Trans.Reader+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Strict as Strict++import Data.Functor.Apply+import Data.Functor.Compose+import Data.Functor.Contravariant+import Data.Functor.Contravariant.Divise+import Data.Functor.Contravariant.Divisible+import Data.Functor.Product+import Data.Functor.Reverse++#if !(MIN_VERSION_transformers(0,6,0))+import Control.Arrow+import Control.Monad.Trans.List+import Data.Either+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Monoid (Alt(..))+#endif++#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged)+import Data.Proxy+#endif++#ifdef MIN_VERSION_StateVar+import Data.StateVar+#endif++#if __GLASGOW_HASKELL__ >= 702+#define GHC_GENERICS+import GHC.Generics+#endif++-- | The contravariant analogue of 'Alt'.+--+-- If one thinks of @f a@ as a consumer of @a@s, then 'decide' allows one+-- to handle the consumption of a value by choosing to handle it via+-- exactly one of two independent consumers. It redirects the input+-- completely into one of two consumers.+--+-- 'decide' takes the \"decision\" method and the two potential consumers,+-- and returns the wrapped/combined consumer.+--+-- Mathematically, a functor being an instance of 'Decide' means that it is+-- \"semigroupoidal\" with respect to the contravariant \"either-based\" Day+-- convolution (@data EitherDay f g a = forall b c. EitherDay (f b) (g c) (a -> Either b c)@).+-- That is, it is possible to define a function @(f `EitherDay` f) a ->+-- f a@ in a way that is associative.+--+-- @since 5.3.6+class Contravariant f => Decide f where+ -- | Takes the \"decision\" method and the two potential consumers, and+ -- returns the wrapped/combined consumer.+ decide :: (a -> Either b c) -> f b -> f c -> f a++-- | For @'decided' x y@, the resulting @f ('Either' b c)@ will direct+-- 'Left's to be consumed by @x@, and 'Right's to be consumed by y.+--+-- @since 5.3.6+decided :: Decide f => f b -> f c -> f (Either b c)+decided = decide id++-- | @since 5.3.6+instance Decidable f => Decide (WrappedDivisible f) where+ decide f (WrapDivisible x) (WrapDivisible y) = WrapDivisible (choose f x y)++-- | @since 5.3.6+instance Decide Comparison where decide = choose++-- | @since 5.3.6+instance Decide Equivalence where decide = choose++-- | @since 5.3.6+instance Decide Predicate where decide = choose++-- | Unlike 'Decidable', requires no constraint on @r@.+--+-- @since 5.3.6+instance Decide (Op r) where+ decide f (Op g) (Op h) = Op $ either g h . f++#if MIN_VERSION_base(4,8,0)+-- | @since 5.3.6+instance Decide f => Decide (Alt f) where+ decide f (Alt l) (Alt r) = Alt $ decide f l r+#endif++#ifdef GHC_GENERICS+-- | @since 5.3.6+instance Decide U1 where decide = choose++-- | Has no 'Decidable' or 'Conclude' instance.+--+-- @since 5.3.6+#if MIN_VERSION_base(4,7,0)+instance Decide V1 where decide _ x = case x of {}+#else+instance Decide V1 where decide _ x = case x of !_ -> error "V1"+#endif++-- | @since 5.3.6+instance Decide f => Decide (Rec1 f) where+ decide f (Rec1 l) (Rec1 r) = Rec1 $ decide f l r++-- | @since 5.3.6+instance Decide f => Decide (M1 i c f) where+ decide f (M1 l) (M1 r) = M1 $ decide f l r++-- | @since 5.3.6+instance (Decide f, Decide g) => Decide (f :*: g) where+ decide f (l1 :*: r1) (l2 :*: r2) = decide f l1 l2 :*: decide f r1 r2++-- | Unlike 'Decidable', requires only 'Apply' on @f@.+--+-- @since 5.3.6+instance (Apply f, Decide g) => Decide (f :.: g) where+ decide f (Comp1 l) (Comp1 r) = Comp1 (liftF2 (decide f) l r)+#endif++-- | @since 5.3.6+instance Decide f => Decide (Backwards f) where+ decide f (Backwards l) (Backwards r) = Backwards $ decide f l r++-- | @since 5.3.6+instance Decide f => Decide (IdentityT f) where+ decide f (IdentityT l) (IdentityT r) = IdentityT $ decide f l r++-- | @since 5.3.6+instance Decide m => Decide (ReaderT r m) where+ decide abc (ReaderT rmb) (ReaderT rmc) = ReaderT $ \r -> decide abc (rmb r) (rmc r)++-- | @since 5.3.6+instance Decide m => Decide (Lazy.RWST r w s m) where+ decide abc (Lazy.RWST rsmb) (Lazy.RWST rsmc) = Lazy.RWST $ \r s ->+ decide (\ ~(a, s', w) -> either (Left . betuple3 s' w)+ (Right . betuple3 s' w)+ (abc a))+ (rsmb r s) (rsmc r s)++-- | @since 5.3.6+instance Decide m => Decide (Strict.RWST r w s m) where+ decide abc (Strict.RWST rsmb) (Strict.RWST rsmc) = Strict.RWST $ \r s ->+ decide (\(a, s', w) -> either (Left . betuple3 s' w)+ (Right . betuple3 s' w)+ (abc a))+ (rsmb r s) (rsmc r s)++#if !(MIN_VERSION_transformers(0,6,0))+-- | @since 5.3.6+instance Divise m => Decide (ListT m) where+ decide f (ListT l) (ListT r) = ListT $ divise ((lefts &&& rights) . map f) l r+#endif++-- | @since 5.3.6+instance Divise m => Decide (MaybeT m) where+ decide f (MaybeT l) (MaybeT r) = MaybeT $+ divise ( maybe (Nothing, Nothing)+ (either (\b -> (Just b, Nothing))+ (\c -> (Nothing, Just c)) . f)+ ) l r++-- | @since 5.3.6+instance Decide m => Decide (Lazy.StateT s m) where+ decide f (Lazy.StateT l) (Lazy.StateT r) = Lazy.StateT $ \s ->+ decide (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a))+ (l s) (r s)++-- | @since 5.3.6+instance Decide m => Decide (Strict.StateT s m) where+ decide f (Strict.StateT l) (Strict.StateT r) = Strict.StateT $ \s ->+ decide (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a))+ (l s) (r s)++-- | @since 5.3.6+instance Decide m => Decide (Lazy.WriterT w m) where+ decide f (Lazy.WriterT l) (Lazy.WriterT r) = Lazy.WriterT $+ decide (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r++-- | @since 5.3.6+instance Decide m => Decide (Strict.WriterT w m) where+ decide f (Strict.WriterT l) (Strict.WriterT r) = Strict.WriterT $+ decide (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r++-- | Unlike 'Decidable', requires only 'Apply' on @f@.+--+-- @since 5.3.6+instance (Apply f, Decide g) => Decide (Compose f g) where+ decide f (Compose l) (Compose r) = Compose (liftF2 (decide f) l r)++-- | @since 5.3.6+instance (Decide f, Decide g) => Decide (Product f g) where+ decide f (Pair l1 r1) (Pair l2 r2) = Pair (decide f l1 l2) (decide f r1 r2)++-- | @since 5.3.6+instance Decide f => Decide (Reverse f) where+ decide f (Reverse l) (Reverse r) = Reverse $ decide f l r++betuple :: s -> a -> (a, s)+betuple s a = (a, s)++betuple3 :: s -> w -> a -> (a, s, w)+betuple3 s w a = (a, s, w)++#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged)+-- | @since 5.3.6+instance Decide Proxy where+ decide _ Proxy Proxy = Proxy+#endif++#ifdef MIN_VERSION_StateVar+-- | @since 5.3.6+instance Decide SettableStateVar where+ decide k (SettableStateVar l) (SettableStateVar r) = SettableStateVar $ \ a -> case k a of+ Left b -> l b+ Right c -> r c+#endif
+ src/Data/Functor/Contravariant/Divise.hs view
@@ -0,0 +1,309 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif+#if MIN_VERSION_base(4,7,0)+{-# LANGUAGE EmptyCase #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2021 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+----------------------------------------------------------------------------+module Data.Functor.Contravariant.Divise (+ Divise(..)+ , divised+ , WrappedDivisible(..)+ ) where++import Control.Applicative+import Control.Applicative.Backwards+import Control.Arrow+import Control.Monad.Trans.Except+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict+import Control.Monad.Trans.Reader+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Strict as Strict++import Data.Functor.Apply+import Data.Functor.Compose+import Data.Functor.Constant+import Data.Functor.Contravariant+import Data.Functor.Contravariant.Divisible+import Data.Functor.Product+import Data.Functor.Reverse++#if !(MIN_VERSION_transformers(0,6,0))+import Control.Monad.Trans.Error+import Control.Monad.Trans.List+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Monoid (Alt(..))+#else+import Data.Monoid (Monoid(..))+#endif++#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,12,0)+import Data.Semigroup (Semigroup(..))+#endif++#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged)+import Data.Proxy+#endif++#ifdef MIN_VERSION_StateVar+import Data.StateVar+#endif++#if __GLASGOW_HASKELL__ >= 702+#define GHC_GENERICS+import GHC.Generics+#endif++-- | The contravariant analogue of 'Apply'; it is+-- 'Divisible' without 'conquer'.+--+-- If one thinks of @f a@ as a consumer of @a@s, then 'divise' allows one+-- to handle the consumption of a value by splitting it between two+-- consumers that consume separate parts of @a@.+--+-- 'divise' takes the \"splitting\" method and the two sub-consumers, and+-- returns the wrapped/combined consumer.+--+-- All instances of 'Divisible' should be instances of 'Divise' with+-- @'divise' = 'divide'@.+--+-- If a function is polymorphic over @'Divise' f@ (as opposed to @'Divisible'+-- f@), we can provide a stronger guarantee: namely, that any input consumed+-- will be passed to at least one sub-consumer. With @'Divisible' f@, said input+-- could potentially disappear into the void, as this is possible with+-- 'conquer'.+--+-- Mathematically, a functor being an instance of 'Divise' means that it is+-- \"semigroupoidal\" with respect to the contravariant (tupling) Day+-- convolution. That is, it is possible to define a function @(f `Day` f)+-- a -> f a@ in a way that is associative.+--+-- @since 5.3.6+class Contravariant f => Divise f where+ -- | Takes a \"splitting\" method and the two sub-consumers, and+ -- returns the wrapped/combined consumer.+ divise :: (a -> (b, c)) -> f b -> f c -> f a++-- | Combine a consumer of @a@ with a consumer of @b@ to get a consumer of+-- @(a, b)@.+--+-- @+-- 'divised' = 'divise' 'id'+-- @+--+-- @since 5.3.6+divised :: Divise f => f a -> f b -> f (a, b)+divised = divise id++-- | Wrap a 'Divisible' to be used as a member of 'Divise'+--+-- @since 5.3.6+newtype WrappedDivisible f a = WrapDivisible { unwrapDivisible :: f a }++-- | @since 5.3.6+instance Contravariant f => Contravariant (WrappedDivisible f) where+ contramap f (WrapDivisible a) = WrapDivisible (contramap f a)++-- | @since 5.3.6+instance Divisible f => Divise (WrappedDivisible f) where+ divise f (WrapDivisible x) (WrapDivisible y) = WrapDivisible (divide f x y)++#if MIN_VERSION_base(4,9,0)+-- | Unlike 'Divisible', requires only 'Semigroup' on @r@.+--+-- @since 5.3.6+instance Semigroup r => Divise (Op r) where+ divise f (Op g) (Op h) = Op $ \a -> case f a of+ (b, c) -> g b <> h c++-- | Unlike 'Divisible', requires only 'Semigroup' on @m@.+--+-- @since 5.3.6+instance Semigroup m => Divise (Const m) where+ divise _ (Const a) (Const b) = Const (a <> b)++-- | Unlike 'Divisible', requires only 'Semigroup' on @m@.+--+-- @since 5.3.6+instance Semigroup m => Divise (Constant m) where+ divise _ (Constant a) (Constant b) = Constant (a <> b)+#else+-- | @since 5.3.6+instance Monoid r => Divise (Op r) where divise = divide++-- | @since 5.3.6+instance Monoid m => Divise (Const m) where divise = divide++-- | @since 5.3.6+instance Monoid m => Divise (Constant m) where divise = divide+#endif++-- | @since 5.3.6+instance Divise Comparison where divise = divide++-- | @since 5.3.6+instance Divise Equivalence where divise = divide++-- | @since 5.3.6+instance Divise Predicate where divise = divide++#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged)+-- | @since 5.3.6+instance Divise Proxy where divise = divide+#endif++#ifdef MIN_VERSION_StateVar+-- | @since 5.3.6+instance Divise SettableStateVar where divise = divide+#endif++#if MIN_VERSION_base(4,8,0)+-- | @since 5.3.6+instance Divise f => Divise (Alt f) where+ divise f (Alt l) (Alt r) = Alt $ divise f l r+#endif++#ifdef GHC_GENERICS+-- | @since 5.3.6+instance Divise U1 where divise = divide++-- | Has no 'Divisible' instance.+--+-- @since 5.3.6+#if MIN_VERSION_base(4,7,0)+instance Divise V1 where divise _ x = case x of {}+#else+instance Divise V1 where divise _ !_ = error "V1"+#endif++-- | @since 5.3.6+instance Divise f => Divise (Rec1 f) where+ divise f (Rec1 l) (Rec1 r) = Rec1 $ divise f l r++-- | @since 5.3.6+instance Divise f => Divise (M1 i c f) where+ divise f (M1 l) (M1 r) = M1 $ divise f l r++-- | @since 5.3.6+instance (Divise f, Divise g) => Divise (f :*: g) where+ divise f (l1 :*: r1) (l2 :*: r2) = divise f l1 l2 :*: divise f r1 r2++-- | Unlike 'Divisible', requires only 'Apply' on @f@.+--+-- @since 5.3.6+instance (Apply f, Divise g) => Divise (f :.: g) where+ divise f (Comp1 l) (Comp1 r) = Comp1 (liftF2 (divise f) l r)+#endif++-- | @since 5.3.6+instance Divise f => Divise (Backwards f) where+ divise f (Backwards l) (Backwards r) = Backwards $ divise f l r++#if !(MIN_VERSION_transformers(0,6,0))+-- | @since 5.3.6+instance Divise m => Divise (ErrorT e m) where+ divise f (ErrorT l) (ErrorT r) = ErrorT $ divise (funzip . fmap f) l r++-- | @since 5.3.6+instance Divise m => Divise (ListT m) where+ divise f (ListT l) (ListT r) = ListT $ divise (funzip . map f) l r+#endif++-- | @since 5.3.6+instance Divise m => Divise (ExceptT e m) where+ divise f (ExceptT l) (ExceptT r) = ExceptT $ divise (funzip . fmap f) l r++-- | @since 5.3.6+instance Divise f => Divise (IdentityT f) where+ divise f (IdentityT l) (IdentityT r) = IdentityT $ divise f l r++-- | @since 5.3.6+instance Divise m => Divise (MaybeT m) where+ divise f (MaybeT l) (MaybeT r) = MaybeT $ divise (funzip . fmap f) l r++-- | @since 5.3.6+instance Divise m => Divise (ReaderT r m) where+ divise abc (ReaderT rmb) (ReaderT rmc) = ReaderT $ \r -> divise abc (rmb r) (rmc r)++-- | @since 5.3.6+instance Divise m => Divise (Lazy.RWST r w s m) where+ divise abc (Lazy.RWST rsmb) (Lazy.RWST rsmc) = Lazy.RWST $ \r s ->+ divise (\ ~(a, s', w) -> case abc a of+ ~(b, c) -> ((b, s', w), (c, s', w)))+ (rsmb r s) (rsmc r s)++-- | @since 5.3.6+instance Divise m => Divise (Strict.RWST r w s m) where+ divise abc (Strict.RWST rsmb) (Strict.RWST rsmc) = Strict.RWST $ \r s ->+ divise (\(a, s', w) -> case abc a of+ (b, c) -> ((b, s', w), (c, s', w)))+ (rsmb r s) (rsmc r s)++-- | @since 5.3.6+instance Divise m => Divise (Lazy.StateT s m) where+ divise f (Lazy.StateT l) (Lazy.StateT r) = Lazy.StateT $ \s ->+ divise (lazyFanout f) (l s) (r s)++-- | @since 5.3.6+instance Divise m => Divise (Strict.StateT s m) where+ divise f (Strict.StateT l) (Strict.StateT r) = Strict.StateT $ \s ->+ divise (strictFanout f) (l s) (r s)++-- | @since 5.3.6+instance Divise m => Divise (Lazy.WriterT w m) where+ divise f (Lazy.WriterT l) (Lazy.WriterT r) = Lazy.WriterT $+ divise (lazyFanout f) l r++-- | @since 5.3.6+instance Divise m => Divise (Strict.WriterT w m) where+ divise f (Strict.WriterT l) (Strict.WriterT r) = Strict.WriterT $+ divise (strictFanout f) l r++-- | Unlike 'Divisible', requires only 'Apply' on @f@.+--+-- @since 5.3.6+instance (Apply f, Divise g) => Divise (Compose f g) where+ divise f (Compose l) (Compose r) = Compose (liftF2 (divise f) l r)++-- | @since 5.3.6+instance (Divise f, Divise g) => Divise (Product f g) where+ divise f (Pair l1 r1) (Pair l2 r2) = Pair (divise f l1 l2) (divise f r1 r2)++-- | @since 5.3.6+instance Divise f => Divise (Reverse f) where+ divise f (Reverse l) (Reverse r) = Reverse $ divise f l r++-- Helpers++lazyFanout :: (a -> (b, c)) -> (a, s) -> ((b, s), (c, s))+lazyFanout f ~(a, s) = case f a of+ ~(b, c) -> ((b, s), (c, s))++strictFanout :: (a -> (b, c)) -> (a, s) -> ((b, s), (c, s))+strictFanout f (a, s) = case f a of+ (b, c) -> ((b, s), (c, s))++funzip :: Functor f => f (a, b) -> (f a, f b)+funzip = fmap fst &&& fmap snd
src/Data/Functor/Plus.hs view
@@ -16,6 +16,7 @@ ---------------------------------------------------------------------------- module Data.Functor.Plus ( Plus(..)+ , psum , module Data.Functor.Alt ) where @@ -23,21 +24,23 @@ import Control.Applicative.Backwards import Control.Applicative.Lift import Control.Arrow--- import Control.Exception import Control.Monad import Control.Monad.Trans.Identity--- import Control.Monad.Trans.Cont-import Control.Monad.Trans.Error import Control.Monad.Trans.Except-import Control.Monad.Trans.List import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader+#if MIN_VERSION_transformers(0,5,6)+import qualified Control.Monad.Trans.RWS.CPS as CPS+import qualified Control.Monad.Trans.Writer.CPS as CPS+import Semigroupoids.Internal+#endif import qualified Control.Monad.Trans.RWS.Strict as Strict import qualified Control.Monad.Trans.State.Strict as Strict import qualified Control.Monad.Trans.Writer.Strict as Strict import qualified Control.Monad.Trans.RWS.Lazy as Lazy import qualified Control.Monad.Trans.State.Lazy as Lazy import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import Data.Foldable hiding (asum) import Data.Functor.Apply import Data.Functor.Alt import Data.Functor.Bind@@ -46,8 +49,13 @@ import Data.Functor.Reverse import qualified Data.Monoid as Monoid import Data.Semigroup hiding (Product)-import Prelude hiding (id, (.))+import Prelude hiding (id, (.), foldr) +#if !(MIN_VERSION_transformers(0,6,0))+import Control.Monad.Trans.Error+import Control.Monad.Trans.List+#endif+ #ifdef MIN_VERSION_containers import qualified Data.IntMap as IntMap import Data.IntMap (IntMap)@@ -78,10 +86,18 @@ -- > m <!> zero = m -- -- If extended to an 'Alternative' then 'zero' should equal 'empty'.- class Alt f => Plus f where zero :: f a +-- | The sum of a collection of actions, generalizing 'concat'.+--+-- >>> psum [Just "Hello", Nothing, Just "World"]+-- Just "Hello"+--+-- @since 5.3.6+psum :: (Foldable t, Plus f) => t (f a) -> f a+psum = foldr (<!>) zero+ instance Plus Proxy where zero = Proxy @@ -106,8 +122,10 @@ instance Plus Maybe where zero = Nothing +#if !(MIN_VERSION_base(4,16,0)) instance Plus Option where zero = empty+#endif instance MonadPlus m => Plus (WrappedMonad m) where zero = empty@@ -143,15 +161,17 @@ instance (Bind f, Monad f) => Plus (MaybeT f) where zero = MaybeT $ return zero +#if !(MIN_VERSION_transformers(0,6,0)) instance (Bind f, Monad f, Error e) => Plus (ErrorT e f) where zero = ErrorT $ return $ Left noMsg -instance (Bind f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f) where- zero = ExceptT $ return $ Left mempty- instance (Apply f, Applicative f) => Plus (ListT f) where zero = ListT $ pure []+#endif +instance (Bind f, Monad f, Semigroup e, Monoid e) => Plus (ExceptT e f) where+ zero = ExceptT $ return $ Left mempty+ instance Plus f => Plus (Strict.StateT e f) where zero = Strict.StateT $ \_ -> zero @@ -164,11 +184,23 @@ instance Plus f => Plus (Lazy.WriterT w f) where zero = Lazy.WriterT zero +#if MIN_VERSION_transformers(0,5,6)+-- | @since 5.3.6+instance (Plus f) => Plus (CPS.WriterT w f) where+ zero = mkWriterT $ const zero+#endif+ instance Plus f => Plus (Strict.RWST r w s f) where zero = Strict.RWST $ \_ _ -> zero instance Plus f => Plus (Lazy.RWST r w s f) where zero = Lazy.RWST $ \_ _ -> zero++#if MIN_VERSION_transformers(0,5,6)+-- | @since 5.3.6+instance (Plus f) => Plus (CPS.RWST r w s f) where+ zero = mkRWST $ \_ _ _ -> zero +#endif instance Plus f => Plus (Backwards f) where zero = Backwards zero
src/Data/Semigroup/Foldable.hs view
@@ -37,7 +37,7 @@ import Prelude hiding (foldr) -- $setup--- >>> import Data.List.NonEmpty+-- >>> import Data.List.NonEmpty (NonEmpty (..)) -- >>> import Data.Monoid (Monoid (..)) newtype JoinWith a = JoinWith {joinee :: (a -> a)}@@ -120,7 +120,7 @@ foldrM1 f = go . toNonEmpty where g = (=<<) . f- + go (e:|es) = case es of [] -> return e
src/Data/Semigroup/Foldable/Class.hs view
@@ -73,7 +73,7 @@ foldMap1 :: Semigroup m => (a -> m) -> t a -> m toNonEmpty :: t a -> NonEmpty a - foldMap1 f = maybe (error "foldMap1") id . getOption . foldMap (Option . Just . f)+ foldMap1 f = maybe (error "foldMap1") id . getOptionCompat . foldMap (optionCompat . Just . f) fold1 = foldMap1 id toNonEmpty = foldMap1 (:|[]) @@ -131,7 +131,9 @@ {-# INLINE bifold1 #-} bifoldMap1 :: Semigroup m => (a -> m) -> (b -> m) -> t a b -> m- bifoldMap1 f g = maybe (error "bifoldMap1") id . getOption . bifoldMap (Option . Just . f) (Option . Just . g)+ bifoldMap1 f g = maybe (error "bifoldMap1") id+ . getOptionCompat+ . bifoldMap (optionCompat . Just . f) (optionCompat . Just . g) {-# INLINE bifoldMap1 #-} instance Bifoldable1 Arg where@@ -244,8 +246,7 @@ foldMap1 f (Functor.InR y) = foldMap1 f y instance Foldable1 NonEmpty where- foldMap1 f (a :| []) = f a- foldMap1 f (a :| b : bs) = f a <> foldMap1 f (b :| bs)+ foldMap1 f (a :| as) = foldr (\b g x -> f x <> g b) f as a toNonEmpty = id instance Foldable1 ((,) a) where@@ -254,3 +255,32 @@ instance Foldable1 g => Foldable1 (Joker g a) where foldMap1 g = foldMap1 g . runJoker {-# INLINE foldMap1 #-}++-- The default implementations of foldMap1 and bifoldMap1 above require the use+-- of a Maybe type with the following Monoid instance:+--+-- instance Semigroup a => Monoid (Maybe a) where ...+--+-- Unfortunately, Maybe has only had such an instance since base-4.11. Prior+-- to that, its Monoid instance had an instance context of Monoid a, which is+-- too strong. To compensate, we use CPP to define an OptionCompat type+-- synonym, which is an alias for Maybe on recent versions of base and an alias+-- for Data.Semigroup.Option on older versions of base. We don't want to use+-- Option on recent versions of base, as it has been removed.+#if MIN_VERSION_base(4,11,0)+type OptionCompat = Maybe++optionCompat :: Maybe a -> OptionCompat a+optionCompat = id++getOptionCompat :: OptionCompat a -> Maybe a+getOptionCompat = id+#else+type OptionCompat = Option++optionCompat :: Maybe a -> OptionCompat a+optionCompat = Option++getOptionCompat :: OptionCompat a -> Maybe a+getOptionCompat = getOption+#endif
src/Data/Semigroup/Traversable.hs view
@@ -16,6 +16,10 @@ ---------------------------------------------------------------------------- module Data.Semigroup.Traversable ( Traversable1(..)+ -- * Defining Traversable1 instances+ -- $traversable1instances+ , traverse1Maybe+ -- * Default superclass instance helpers , foldMap1Default ) where @@ -24,6 +28,20 @@ import Data.Semigroup #endif import Data.Semigroup.Traversable.Class+import Data.Functor.Bind.Class +-- | Default implementation of 'foldMap1' given an implementation of 'Traversable1'. foldMap1Default :: (Traversable1 f, Semigroup m) => (a -> m) -> f a -> m foldMap1Default f = getConst . traverse1 (Const . f)++-- $traversable1instances+-- Defining 'Traversable1' instances for types with both 'Traversable1' and 'Traversable'+-- substructures can be done with 'traverse1Maybe', '(<*.>)', and '(<.*>)'.+--+-- > data Foo a = Foo (Maybe a) (Maybe a) a [a]+-- > deriving (Functor, Traversable, Foldable)+-- > instance Traversable1 Foo where+-- > traverse1 f (Foo ma ma' a as) = Foo <$> traverseMaybe ma <*> traverseMaybe ma' <*.> f a <.*> traverseMaybe as+-- > instance Foldable1 Foo where+-- > foldMap1 = foldMap1Default+
src/Data/Semigroup/Traversable/Class.hs view
@@ -226,8 +226,7 @@ #endif instance Traversable1 NonEmpty where- traverse1 f (a :| []) = (:|[]) <$> f a- traverse1 f (a :| (b: bs)) = (\a' (b':| bs') -> a' :| b': bs') <$> f a <.> traverse1 f (b :| bs)+ traverse1 f (a :| as) = foldr (\b g x -> (\a' (b':| bs') -> a' :| b': bs') <$> f x <.> g b) (fmap (:|[]) . f) as a instance Traversable1 ((,) a) where traverse1 f (a, b) = (,) a <$> f b
+ src/Data/Semigroupoid/Categorical.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2021 Koz Ross+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Koz Ross <koz.ross@retro-freedom.nz>+-- Stability : Experimental+-- Portability : GHC only+--+-- Provides a way to attach an identity to any semigroupoid.+----------------------------------------------------------------------------+module Data.Semigroupoid.Categorical (+ Categorical(..),+ runCategorical+ ) where++import Control.Category (Category (id, (.)))+import Data.Semigroupoid (Semigroupoid (o))+import Prelude ()++-- | Attaches an identity.+--+-- @since 5.3.6+data Categorical s a b where+ Id :: Categorical s a a+ Embed :: s a b -> Categorical s a b++-- | @since 5.3.6+instance (Semigroupoid s) => Semigroupoid (Categorical s) where+ Id `o` y = y+ x `o` Id = x+ Embed x `o` Embed y = Embed (x `o` y)++-- | @since 5.3.6+instance (Semigroupoid s) => Category (Categorical s) where+ id = Id+ (.) = o++-- | @since 5.3.6+runCategorical :: (a ~ b => r) -> (s a b -> r) -> Categorical s a b -> r+runCategorical r _ Id = r+runCategorical _ f (Embed x) = f x
+ src/Semigroupoids/Do.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif++#if __GLASGOW_HASKELL__ == 708+{-# OPTIONS_GHC -fno-warn-amp #-}+#endif++{-|++This module re-exports operators from "Data.Functor.Apply" and +"Data.Functor.Bind", but under the same+names as their 'Applicative' and 'Monad' counterparts. This makes it convenient+to use do-notation on a type that is a 'Bind' but not a monad (or an 'Apply'+but not an 'Applicative' with @ApplicativeDo@), either using the+@QualifiedDo@ extension or the more traditional @RebindableSyntax@.++@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE QualifiedDo #-}++foo :: Apply f => f a -> f b -> f (a, b)+foo as bs = Semi.do+ a <- as+ b <- bs+ pure (a, b)+++bar :: Bind m => (a -> b -> m c) -> m a -> m b -> m c+bar f as bs = Semi.do+ a <- as+ b <- bs+ f a b+@++-}+module Semigroupoids.Do+ ( fmap+ , (<*)+ , (*>)+ , (<*>)+ , (>>)+ , (>>=)+ , join+ , pure+ , return+ , fail+ )+where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative (pure)+import Prelude (String, fmap, return)+#else+import Prelude (String, fmap, pure, return)+#endif+import Data.Functor.Apply (Apply, (<.), (.>), (<.>))+import Data.Functor.Bind (Bind, (>>-), join)+import Data.Functor.Plus (Plus, zero)++-- | @since 5.3.6+(<*) :: Apply f => f a -> f b -> f a+(<*) = (<.)++-- | @since 5.3.6+(*>) :: Apply f => f a -> f b -> f b+(*>) = (.>)++-- | @since 5.3.6+(<*>) :: Apply f => f (a -> b) -> f a -> f b+(<*>) = (<.>)++-- | @since 5.3.6+(>>) :: Bind m => m a -> m b -> m b+(>>) = (.>)++-- | @since 5.3.6+(>>=) :: Bind m => m a -> (a -> m b) -> m b+(>>=) = (>>-)++-- | = Important note+--+-- This /ignores/ whatever 'String' you give it. It is a bad idea to use 'fail'+-- as a form of labelled error; instead, it should only be defaulted to when a+-- pattern match fails.+--+-- @since 5.3.6+fail ::+ (Plus m) =>+ String ->+ m a+fail _ = zero
+ src/Semigroupoids/Internal.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif++module Semigroupoids.Internal where++#if MIN_VERSION_transformers(0,5,6)+import qualified Control.Monad.Trans.RWS.CPS as CPS+import qualified Control.Monad.Trans.Writer.CPS as CPS+import Unsafe.Coerce (unsafeCoerce)+#endif++-- This is designed to avoid both https://hub.darcs.net/ross/transformers/issue/67 +-- and also the unnecessary Monoid constraints that the CPS versions of WriterT+-- and RWST require.++#if MIN_VERSION_transformers(0,5,6)+mkWriterT :: (w -> m (a, w)) -> CPS.WriterT w m a+mkWriterT = unsafeCoerce++unWriterT :: CPS.WriterT w m a -> w -> m (a, w)+unWriterT = unsafeCoerce++mkRWST :: (r -> s -> w -> m (a, s, w)) -> CPS.RWST r w s m a+mkRWST = unsafeCoerce++unRWST :: CPS.RWST r w s m a -> r -> s -> w -> m (a, s, w)+unRWST = unsafeCoerce+#endif