packages feed

proarrow (empty) → 0.1.0.0

raw patch · 198 files changed

+37052/−0 lines, 198 filesdep +basedep +containersdep +data-default

Dependencies added: base, containers, data-default, falsify, fin, proarrow, tasty, tasty-falsify, universe-base, vec

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for proarrow++## 0.1.0.0 -- 2026-09-28++* First release
+ LICENSE view
@@ -0,0 +1,28 @@+BSD 3-Clause License++Copyright (c) 2023, Sjoerd Visscher++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+   contributors may be used to endorse or promote products derived from+   this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,181 @@+[![Haskell-CI](https://github.com/sjoerdvisscher/proarrow/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/sjoerdvisscher/proarrow/actions/workflows/haskell-ci.yml)++# proarrow++A Haskell library for doing category theory with a central role for profunctors.++## Core ideas++### One category per kind++Kind-indexed categories makes life a lot easier, once you know what the kind is of a type,+you know which category it belongs to.++### Use newtype wrappers on kinds++Using kind-indexed categories means you cannot share objects between categories. Newtype+wrappers fix this. For example, if you have a category for kind `k`, it's opposite category+has kind `OP k`.++### Kind `j -> k -> Type` is reserved for profunctors++If profunctors would have kind `OP j -> k -> Type`, then `(->)` wouldn't be a profunctor+as is. This would require too many wrappers all over the place. So instead `j -> k -> Type`+is reserved for profunctors. So for the category of bifunctors we do need a wrapper.++### Use constraints to limit which objects are part of a category++You need this already when creating a category of functors, then each object needs a+`Functor` constraint. It turns out this is powerful enough to limit the objects of any+type of category.++### These constraints can be observed from arrows++If you're not careful these objects constraints can become unweildy, requiring a long list+of object constraints for each function. But if you have an arrow from `a` to `b`, that's+proof enough that `a` and `b` are objects. So there are functions `(//)` and `(\\)` to+observe the constraints.++### Functors that don't land in Type are written as representable profunctors++Functors have kind `j -> k`, but you can't just make a datatype of any kind, it must+always be of the shape `j -> k -> ... -> Type`. So for example you can't make an+identity functor that works for any `k`. But functors are isomorphic to representable+profunctors, with kind `k -> j -> Type`. (Note that the kinds swap!) So you can write+an identity representable profunctor!++### Generalize the category theory to work with profunctors++To make working with representable profunctors instead of functors easier,+the category theory should work with profunctors where possible.++## Example: defining your own category++A category is picked out by its *kind*, so a new category starts with a fresh kind -- here one+with two objects, a `Draft` and a `Live` state, and a single non-identity arrow publishing the+one as the other.++```haskell+{-# LANGUAGE TypeData, TypeFamilies #-}+import Prelude hiding (id, (.))++import Proarrow.Core (CAT, CategoryOf (..), ObId (..), Profunctor (..), Promonad (..), dimapDefault)++type data STATE = Draft | Live++type Move :: CAT STATE+data Move a b where+  KeepDraft :: Move Draft Draft+  Publish :: Move Draft Live+  KeepLive :: Move Live Live++deriving instance Show (Move a b)++-- 'id' has to produce the identity *at whichever object it is asked for*, so being an+-- object is exactly the ability to supply that identity:+instance ObId Draft where objId = KeepDraft+instance ObId Live where objId = KeepLive++instance CategoryOf STATE where+  type (~>) = Move++instance Promonad Move where+  KeepDraft . KeepDraft = KeepDraft+  Publish . KeepDraft = Publish+  KeepLive . Publish = Publish+  KeepLive . KeepLive = KeepLive++instance Profunctor Move where+  dimap = dimapDefault+  r \\ KeepDraft = r+  r \\ Publish = r+  r \\ KeepLive = r+```++Beyond `TypeData` and `TypeFamilies` above, going further needs more extensions — a+`Proarrow.Testing.TestableType` instance for `Move a b`, for instance, also needs+`UndecidableInstances`. Rather than discovering them one failed build at a time, enable the set+the library itself is built with: `GHC2024` plus the `default-extensions` block in+[`proarrow.cabal`](proarrow.cabal).++```haskell+>>> KeepLive . Publish . id+Publish+```++The `Ob` family is where the object constraints from above come in, and the `\\` method is how+those constraints are observed from an arrow — matching on a constructor reveals which objects+it runs between. Note what is *absent*: no `type Ob`, and no `id`. `Ob` defaults to `ObId`, and+`id` defaults to `objId`, so the two instances above are the whole of the object structure. A+category where every type of the kind is an object with no evidence needed says+`type Ob a = Any a` instead — that is what `Hask` does. Where the objects carry *no* non-identity+arrows at all, reach for `Proarrow.Category.Instance.Discrete`'s `DISCRETE` (see+`test/Props/Paths.hs`), and a one-object category needs no dispatch at all, being just a monoid —+`Proarrow.Category.Instance.Monoid`.++And now the generic kind-machinery applies: `OPPOSITE STATE` is the opposite category,+`(STATE, STATE)` the product category, `STATE +-> STATE` are profunctors on states, and so on.+The `Proarrow` module exports the curated core vocabulary; `Proarrow.Core` explains the design+in depth, and the `Proarrow.Category.Instance.*` modules contain many more worked examples of+categories.++To property-test the laws of your own category, depend on the public sublibrary+`proarrow:testing`: a `Testable` instance for your kind plus the law checks from+`Proarrow.Testing.Laws` (`testCategory`, `testMonoidal`, ...) give it a test suite —+proarrow's own tests are built from exactly these pieces.++## Laws as code++A class's laws are written down next to the class, as ordinary proarrow code that works in any+category with the structure: a `Laws` instance from `Proarrow.Tools.Laws`, keyed by the list of+structures the laws mention. For example, from `Proarrow.Category.Monoidal`, where+`SymMonoidalStructures` is `'[Monoidal, SymMonoidal]`:++```haskell+instance Laws SymMonoidalStructures where+  laws =+    [ ...+    , Law "swap naturality" \ @a @b @c @d mor -> do+        f <- mor @a @c "f"+        g <- mor @b @d "g"+        swap @_ @c @d . (f ** g) === (g ** f) . swap @_ @a @b+    , ...+    ]+```++A law binds the object variables it uses and asks the supply `mor` for named arbitrary arrows+between them, then states its equation with `===`. `testLaws` from `Proarrow.Testing.Laws.Run`+checks each law as its own property. It draws random objects and arrows, runs the law in a+category whose arrows also describe themselves, and on failure prints both sides as the code+they were built from:++```+Failed swap naturality:+swap . (f ** g) = ...+(g ** f) . swap = ...+```++`testMonoidal`, `testClosed` and the other checks for proarrow's own classes are built this way,+and a class of your own can be checked the same way: `test/Examples/CustomLaws.hs` walks through+a complete one.++## Laws as code × code as diagrams = laws as diagrams++`Proarrow.Tools.Diagrams.Svg` defines a category `SVG` whose objects are lists of wires and whose+arrows are string diagrams. It is symmetric monoidal, closed, \*-autonomous and compact closed, has+traces, and can copy and merge wires, so code written for any category with that structure also+runs in `SVG`, where it builds a picture of itself. `node "f"` is a box named `f`, and `render`+turns a diagram into an SVG image. The layout follows how the diagram was built: a tensor puts its+two sides next to each other, a composite stacks them with a band of curved wires in between, and+a trace draws its loops round the side. `Options` can draw more of the structure, such as the+identities, the unitors and associators, or the swaps.++Laws are code too, so running one in `SVG` draws it: `lawSvgs @'[Monoidal]` gives every law of+`Monoidal` as a named SVG, an equation between its two sides, each drawn the way the law builds it.+This is swap naturality from above, drawn with explicit swaps:++![swap naturality](https://raw.githubusercontent.com/wiki/sjoerdvisscher/proarrow/images/law-diagrams/symmetric-2.svg)++`proLawSvgs` does the same for profunctor classes such as `Strong`. The+[Law diagrams](https://github.com/sjoerdvisscher/proarrow/wiki/Law-diagrams) wiki page shows the+laws of proarrow's classes drawn this way.
+ fix-github-links.py view
@@ -0,0 +1,75 @@+#!/usr/bin/env python3+# Point every per-entity "Github" link in the generated docs at the same place as the "Source"+# link next to it.+#+# Haddock fills the --comments-entity template with the module of the page being rendered and the+# line of the enclosing declaration, so it goes wrong for instances and re-exports listed under+# another module, and for class members (which get the line of their class). The hyperlinked+# source is right, so this derives the Github URL from it: the defining module picks the file+# (under src/ or testing/), and the entity's position in docs/src/<module>.html gives the line.+#+# Usage (from proarrow/, after haddock has written docs/): fix-github-links.py DOCS GITHUB_BASE+# where GITHUB_BASE is e.g. https://github.com/sjoerdvisscher/proarrow/blob/main/proarrow/++import glob+import os+import re+import sys++docs, base = sys.argv[1], sys.argv[2]+source_dirs = ["src", "testing"]++# The anchor ids in docs/src/<module>.html and the line each one is on.+lines = {}+++def anchor_line(module, anchor):+    if anchor.startswith("line-"):+        return int(anchor[len("line-") :])+    if module not in lines:+        table, current = {}, 0+        with open(os.path.join(docs, "src", module + ".html"), encoding="utf-8") as f:+            for m in re.finditer(r'id="([^"]+)"', f.read()):+                if m.group(1).startswith("line-"):+                    current = int(m.group(1)[len("line-") :])+                else:+                    table.setdefault(m.group(1), current)+        lines[module] = table+    return lines[module].get(anchor)+++def source_file(module):+    path = module.replace(".", "/") + ".hs"+    for d in source_dirs:+        if os.path.exists(os.path.join(d, path)):+            return d + "/" + path+    return None+++pair = re.compile(+    r'(<a href="src/([^"#]+)\.html#([^"]+)" class="link"\s*>Source</a\s*>\s*<a href=")'+    + re.escape(base)+    + r'[^"]*(" class="link")'+)++changed = unresolved = 0+for page in glob.glob(os.path.join(docs, "*.html")):+    with open(page, encoding="utf-8") as f:+        text = f.read()++    def fix(m):+        global changed, unresolved+        module, anchor = m.group(2), m.group(3)+        line, path = anchor_line(module, anchor), source_file(module)+        if line is None or path is None:+            unresolved += 1+            return m.group(0)+        changed += 1+        return f"{m.group(1)}{base}{path}#L{line}{m.group(4)}"++    new = pair.sub(fix, text)+    if new != text:+        with open(page, "w", encoding="utf-8") as f:+            f.write(new)++print(f"fix-github-links: {changed} links set from their Source link, {unresolved} left as they were")
+ lattice.dot view
@@ -0,0 +1,32 @@+digraph optics {+  rankdir=TB; node [shape=box, style=rounded, fontname="Helvetica"]; edge [dir=none];+  // Edges run weakest-to-strongest, mirroring the flavor classes' superclass structure.+  // Dotted nodes are one-sided: their methods never mention the second witness, so its category+  // may differ from the first's. Dashed nodes are indexed by a monad, so Iso has no edge to them.+  node [style="rounded,dotted"]; Fold; AffineFold; Getter; Review;+  node [style="rounded,dashed"];+  AlgebraicLens [label="AlgebraicLens m"];+  ClassifyingLens [label="ClassifyingLens l"];+  node [style=rounded];+  { rank=same; Fold; Setter; }++  Fold -> AffineFold; Fold -> Traversal;+  Setter -> Traversal; Setter -> Cotraversal; Setter -> Tracer; Setter -> Glass;++  AffineFold -> Getter; AffineFold -> AffineTraversal;+  Traversal -> AffineTraversal; Traversal -> MonoidalTraversal;+  Cotraversal -> Kaleidoscope;+  Kaleidoscope -> Grate;++  Glass -> Lens; Glass -> Grate; Glass -> MonoidalLens;+  Getter -> Lens; Getter -> MonoidalLens;+  AffineTraversal -> Lens; AffineTraversal -> Prism; AffineTraversal -> MonoidalLens;+  MonoidalTraversal -> MonoidalLens; MonoidalTraversal -> Prism; MonoidalTraversal -> PowerGrate;+  Review -> Prism;+  Grate -> PowerGrate;++  MonoidalLens -> AlgebraicLens;+  AlgebraicLens -> ClassifyingLens; Kaleidoscope -> ClassifyingLens;++  Lens -> Iso; MonoidalLens -> Iso; Prism -> Iso; PowerGrate -> Iso; Tracer -> Iso;+}
+ lattice.svg view
@@ -0,0 +1,298 @@+<?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 10.0.1 (20240210.2158)+ -->+<!-- Title: optics Pages: 1 -->+<svg width="685pt" height="404pt"+ viewBox="0.00 0.00 684.75 404.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 400)">+<title>optics</title>+<polygon fill="white" stroke="none" points="-4,4 -4,-400 680.75,-400 680.75,4 -4,4"/>+<!-- Fold -->+<g id="node1" class="node">+<title>Fold</title>+<path fill="none" stroke="black" stroke-dasharray="1,5" d="M339.12,-396C339.12,-396 309.12,-396 309.12,-396 303.12,-396 297.12,-390 297.12,-384 297.12,-384 297.12,-372 297.12,-372 297.12,-366 303.12,-360 309.12,-360 309.12,-360 339.12,-360 339.12,-360 345.12,-360 351.12,-366 351.12,-372 351.12,-372 351.12,-384 351.12,-384 351.12,-390 345.12,-396 339.12,-396"/>+<text text-anchor="middle" x="324.12" y="-372.2" font-family="Helvetica,sans-Serif" font-size="14.00">Fold</text>+</g>+<!-- AffineFold -->+<g id="node2" class="node">+<title>AffineFold</title>+<path fill="none" stroke="black" stroke-dasharray="1,5" d="M396.5,-324C396.5,-324 343.75,-324 343.75,-324 337.75,-324 331.75,-318 331.75,-312 331.75,-312 331.75,-300 331.75,-300 331.75,-294 337.75,-288 343.75,-288 343.75,-288 396.5,-288 396.5,-288 402.5,-288 408.5,-294 408.5,-300 408.5,-300 408.5,-312 408.5,-312 408.5,-318 402.5,-324 396.5,-324"/>+<text text-anchor="middle" x="370.12" y="-300.2" font-family="Helvetica,sans-Serif" font-size="14.00">AffineFold</text>+</g>+<!-- Fold&#45;&gt;AffineFold -->+<g id="edge1" class="edge">+<title>Fold&#45;&gt;AffineFold</title>+<path fill="none" stroke="black" d="M335.5,-359.7C342.63,-348.85 351.78,-334.92 358.89,-324.1"/>+</g>+<!-- Traversal -->+<g id="node8" class="node">+<title>Traversal</title>+<path fill="none" stroke="black" d="M301.25,-324C301.25,-324 253,-324 253,-324 247,-324 241,-318 241,-312 241,-312 241,-300 241,-300 241,-294 247,-288 253,-288 253,-288 301.25,-288 301.25,-288 307.25,-288 313.25,-294 313.25,-300 313.25,-300 313.25,-312 313.25,-312 313.25,-318 307.25,-324 301.25,-324"/>+<text text-anchor="middle" x="277.12" y="-300.2" font-family="Helvetica,sans-Serif" font-size="14.00">Traversal</text>+</g>+<!-- Fold&#45;&gt;Traversal -->+<g id="edge2" class="edge">+<title>Fold&#45;&gt;Traversal</title>+<path fill="none" stroke="black" d="M312.51,-359.7C305.22,-348.85 295.87,-334.92 288.61,-324.1"/>+</g>+<!-- Getter -->+<g id="node3" class="node">+<title>Getter</title>+<path fill="none" stroke="black" stroke-dasharray="1,5" d="M391.25,-252C391.25,-252 361,-252 361,-252 355,-252 349,-246 349,-240 349,-240 349,-228 349,-228 349,-222 355,-216 361,-216 361,-216 391.25,-216 391.25,-216 397.25,-216 403.25,-222 403.25,-228 403.25,-228 403.25,-240 403.25,-240 403.25,-246 397.25,-252 391.25,-252"/>+<text text-anchor="middle" x="376.12" y="-228.2" font-family="Helvetica,sans-Serif" font-size="14.00">Getter</text>+</g>+<!-- AffineFold&#45;&gt;Getter -->+<g id="edge7" class="edge">+<title>AffineFold&#45;&gt;Getter</title>+<path fill="none" stroke="black" d="M371.61,-287.7C372.54,-276.85 373.73,-262.92 374.66,-252.1"/>+</g>+<!-- AffineTraversal -->+<g id="node12" class="node">+<title>AffineTraversal</title>+<path fill="none" stroke="black" d="M318.5,-252C318.5,-252 235.75,-252 235.75,-252 229.75,-252 223.75,-246 223.75,-240 223.75,-240 223.75,-228 223.75,-228 223.75,-222 229.75,-216 235.75,-216 235.75,-216 318.5,-216 318.5,-216 324.5,-216 330.5,-222 330.5,-228 330.5,-228 330.5,-240 330.5,-240 330.5,-246 324.5,-252 318.5,-252"/>+<text text-anchor="middle" x="277.12" y="-228.2" font-family="Helvetica,sans-Serif" font-size="14.00">AffineTraversal</text>+</g>+<!-- AffineFold&#45;&gt;AffineTraversal -->+<g id="edge8" class="edge">+<title>AffineFold&#45;&gt;AffineTraversal</title>+<path fill="none" stroke="black" d="M347.14,-287.7C332.83,-276.93 314.49,-263.12 300.17,-252.35"/>+</g>+<!-- Lens -->+<g id="node16" class="node">+<title>Lens</title>+<path fill="none" stroke="black" d="M389.12,-180C389.12,-180 359.12,-180 359.12,-180 353.12,-180 347.12,-174 347.12,-168 347.12,-168 347.12,-156 347.12,-156 347.12,-150 353.12,-144 359.12,-144 359.12,-144 389.12,-144 389.12,-144 395.12,-144 401.12,-150 401.12,-156 401.12,-156 401.12,-168 401.12,-168 401.12,-174 395.12,-180 389.12,-180"/>+<text text-anchor="middle" x="374.12" y="-156.2" font-family="Helvetica,sans-Serif" font-size="14.00">Lens</text>+</g>+<!-- Getter&#45;&gt;Lens -->+<g id="edge16" class="edge">+<title>Getter&#45;&gt;Lens</title>+<path fill="none" stroke="black" d="M375.63,-215.7C375.32,-204.85 374.92,-190.92 374.61,-180.1"/>+</g>+<!-- MonoidalLens -->+<g id="node17" class="node">+<title>MonoidalLens</title>+<path fill="none" stroke="black" d="M316.5,-180C316.5,-180 239.75,-180 239.75,-180 233.75,-180 227.75,-174 227.75,-168 227.75,-168 227.75,-156 227.75,-156 227.75,-150 233.75,-144 239.75,-144 239.75,-144 316.5,-144 316.5,-144 322.5,-144 328.5,-150 328.5,-156 328.5,-156 328.5,-168 328.5,-168 328.5,-174 322.5,-180 316.5,-180"/>+<text text-anchor="middle" x="278.12" y="-156.2" font-family="Helvetica,sans-Serif" font-size="14.00">MonoidalLens</text>+</g>+<!-- Getter&#45;&gt;MonoidalLens -->+<g id="edge17" class="edge">+<title>Getter&#45;&gt;MonoidalLens</title>+<path fill="none" stroke="black" d="M351.65,-215.52C336.57,-204.74 317.31,-190.99 302.29,-180.26"/>+</g>+<!-- Review -->+<g id="node4" class="node">+<title>Review</title>+<path fill="none" stroke="black" stroke-dasharray="1,5" d="M48.25,-252C48.25,-252 12,-252 12,-252 6,-252 0,-246 0,-240 0,-240 0,-228 0,-228 0,-222 6,-216 12,-216 12,-216 48.25,-216 48.25,-216 54.25,-216 60.25,-222 60.25,-228 60.25,-228 60.25,-240 60.25,-240 60.25,-246 54.25,-252 48.25,-252"/>+<text text-anchor="middle" x="30.12" y="-228.2" font-family="Helvetica,sans-Serif" font-size="14.00">Review</text>+</g>+<!-- Prism -->+<g id="node18" class="node">+<title>Prism</title>+<path fill="none" stroke="black" d="M158.12,-180C158.12,-180 128.12,-180 128.12,-180 122.12,-180 116.12,-174 116.12,-168 116.12,-168 116.12,-156 116.12,-156 116.12,-150 122.12,-144 128.12,-144 128.12,-144 158.12,-144 158.12,-144 164.12,-144 170.12,-150 170.12,-156 170.12,-156 170.12,-168 170.12,-168 170.12,-174 164.12,-180 158.12,-180"/>+<text text-anchor="middle" x="143.12" y="-156.2" font-family="Helvetica,sans-Serif" font-size="14.00">Prism</text>+</g>+<!-- Review&#45;&gt;Prism -->+<g id="edge24" class="edge">+<title>Review&#45;&gt;Prism</title>+<path fill="none" stroke="black" d="M58.35,-215.52C75.87,-204.66 98.27,-190.78 115.65,-180.02"/>+</g>+<!-- AlgebraicLens -->+<g id="node5" class="node">+<title>AlgebraicLens</title>+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M621.75,-108C621.75,-108 528.5,-108 528.5,-108 522.5,-108 516.5,-102 516.5,-96 516.5,-96 516.5,-84 516.5,-84 516.5,-78 522.5,-72 528.5,-72 528.5,-72 621.75,-72 621.75,-72 627.75,-72 633.75,-78 633.75,-84 633.75,-84 633.75,-96 633.75,-96 633.75,-102 627.75,-108 621.75,-108"/>+<text text-anchor="middle" x="575.12" y="-84.2" font-family="Helvetica,sans-Serif" font-size="14.00">AlgebraicLens m</text>+</g>+<!-- ClassifyingLens -->+<g id="node6" class="node">+<title>ClassifyingLens</title>+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M664.75,-36C664.75,-36 571.5,-36 571.5,-36 565.5,-36 559.5,-30 559.5,-24 559.5,-24 559.5,-12 559.5,-12 559.5,-6 565.5,0 571.5,0 571.5,0 664.75,0 664.75,0 670.75,0 676.75,-6 676.75,-12 676.75,-12 676.75,-24 676.75,-24 676.75,-30 670.75,-36 664.75,-36"/>+<text text-anchor="middle" x="618.12" y="-12.2" font-family="Helvetica,sans-Serif" font-size="14.00">ClassifyingLens l</text>+</g>+<!-- AlgebraicLens&#45;&gt;ClassifyingLens -->+<g id="edge27" class="edge">+<title>AlgebraicLens&#45;&gt;ClassifyingLens</title>+<path fill="none" stroke="black" d="M585.75,-71.7C592.42,-60.85 600.98,-46.92 607.62,-36.1"/>+</g>+<!-- Setter -->+<g id="node7" class="node">+<title>Setter</title>+<path fill="none" stroke="black" d="M510.12,-396C510.12,-396 480.12,-396 480.12,-396 474.12,-396 468.12,-390 468.12,-384 468.12,-384 468.12,-372 468.12,-372 468.12,-366 474.12,-360 480.12,-360 480.12,-360 510.12,-360 510.12,-360 516.12,-360 522.12,-366 522.12,-372 522.12,-372 522.12,-384 522.12,-384 522.12,-390 516.12,-396 510.12,-396"/>+<text text-anchor="middle" x="495.12" y="-372.2" font-family="Helvetica,sans-Serif" font-size="14.00">Setter</text>+</g>+<!-- Setter&#45;&gt;Traversal -->+<g id="edge3" class="edge">+<title>Setter&#45;&gt;Traversal</title>+<path fill="none" stroke="black" d="M467.87,-369.11C433.83,-359.13 373.88,-341.18 323.12,-324 320.06,-322.96 316.89,-321.86 313.72,-320.73"/>+</g>+<!-- Cotraversal -->+<g id="node9" class="node">+<title>Cotraversal</title>+<path fill="none" stroke="black" d="M561.62,-324C561.62,-324 500.62,-324 500.62,-324 494.62,-324 488.62,-318 488.62,-312 488.62,-312 488.62,-300 488.62,-300 488.62,-294 494.62,-288 500.62,-288 500.62,-288 561.62,-288 561.62,-288 567.62,-288 573.62,-294 573.62,-300 573.62,-300 573.62,-312 573.62,-312 573.62,-318 567.62,-324 561.62,-324"/>+<text text-anchor="middle" x="531.12" y="-300.2" font-family="Helvetica,sans-Serif" font-size="14.00">Cotraversal</text>+</g>+<!-- Setter&#45;&gt;Cotraversal -->+<g id="edge4" class="edge">+<title>Setter&#45;&gt;Cotraversal</title>+<path fill="none" stroke="black" d="M504.02,-359.7C509.6,-348.85 516.77,-334.92 522.33,-324.1"/>+</g>+<!-- Tracer -->+<g id="node10" class="node">+<title>Tracer</title>+<path fill="none" stroke="black" d="M486.62,-108C486.62,-108 455.62,-108 455.62,-108 449.62,-108 443.62,-102 443.62,-96 443.62,-96 443.62,-84 443.62,-84 443.62,-78 449.62,-72 455.62,-72 455.62,-72 486.62,-72 486.62,-72 492.62,-72 498.62,-78 498.62,-84 498.62,-84 498.62,-96 498.62,-96 498.62,-102 492.62,-108 486.62,-108"/>+<text text-anchor="middle" x="471.12" y="-84.2" font-family="Helvetica,sans-Serif" font-size="14.00">Tracer</text>+</g>+<!-- Setter&#45;&gt;Tracer -->+<g id="edge5" class="edge">+<title>Setter&#45;&gt;Tracer</title>+<path fill="none" stroke="black" d="M522.33,-367.1C541.87,-358.61 567.27,-344.47 582.12,-324 610.66,-284.67 617.99,-260.78 599.12,-216 578.87,-167.91 530.07,-129.1 498.92,-108.11"/>+</g>+<!-- Glass -->+<g id="node11" class="node">+<title>Glass</title>+<path fill="none" stroke="black" d="M463.12,-252C463.12,-252 433.12,-252 433.12,-252 427.12,-252 421.12,-246 421.12,-240 421.12,-240 421.12,-228 421.12,-228 421.12,-222 427.12,-216 433.12,-216 433.12,-216 463.12,-216 463.12,-216 469.12,-216 475.12,-222 475.12,-228 475.12,-228 475.12,-240 475.12,-240 475.12,-246 469.12,-252 463.12,-252"/>+<text text-anchor="middle" x="448.12" y="-228.2" font-family="Helvetica,sans-Serif" font-size="14.00">Glass</text>+</g>+<!-- Setter&#45;&gt;Glass -->+<g id="edge6" class="edge">+<title>Setter&#45;&gt;Glass</title>+<path fill="none" stroke="black" d="M489.36,-359.59C480.29,-332.19 462.8,-279.32 453.79,-252.11"/>+</g>+<!-- Traversal&#45;&gt;AffineTraversal -->+<g id="edge9" class="edge">+<title>Traversal&#45;&gt;AffineTraversal</title>+<path fill="none" stroke="black" d="M277.12,-287.7C277.12,-276.85 277.12,-262.92 277.12,-252.1"/>+</g>+<!-- MonoidalTraversal -->+<g id="node13" class="node">+<title>MonoidalTraversal</title>+<path fill="none" stroke="black" d="M194,-252C194,-252 90.25,-252 90.25,-252 84.25,-252 78.25,-246 78.25,-240 78.25,-240 78.25,-228 78.25,-228 78.25,-222 84.25,-216 90.25,-216 90.25,-216 194,-216 194,-216 200,-216 206,-222 206,-228 206,-228 206,-240 206,-240 206,-246 200,-252 194,-252"/>+<text text-anchor="middle" x="142.12" y="-228.2" font-family="Helvetica,sans-Serif" font-size="14.00">MonoidalTraversal</text>+</g>+<!-- Traversal&#45;&gt;MonoidalTraversal -->+<g id="edge10" class="edge">+<title>Traversal&#45;&gt;MonoidalTraversal</title>+<path fill="none" stroke="black" d="M243.41,-287.52C222.63,-276.74 196.11,-262.99 175.41,-252.26"/>+</g>+<!-- Kaleidoscope -->+<g id="node14" class="node">+<title>Kaleidoscope</title>+<path fill="none" stroke="black" d="M578.62,-252C578.62,-252 505.62,-252 505.62,-252 499.62,-252 493.62,-246 493.62,-240 493.62,-240 493.62,-228 493.62,-228 493.62,-222 499.62,-216 505.62,-216 505.62,-216 578.62,-216 578.62,-216 584.62,-216 590.62,-222 590.62,-228 590.62,-228 590.62,-240 590.62,-240 590.62,-246 584.62,-252 578.62,-252"/>+<text text-anchor="middle" x="542.12" y="-228.2" font-family="Helvetica,sans-Serif" font-size="14.00">Kaleidoscope</text>+</g>+<!-- Cotraversal&#45;&gt;Kaleidoscope -->+<g id="edge11" class="edge">+<title>Cotraversal&#45;&gt;Kaleidoscope</title>+<path fill="none" stroke="black" d="M533.84,-287.7C535.55,-276.85 537.74,-262.92 539.44,-252.1"/>+</g>+<!-- Iso -->+<g id="node20" class="node">+<title>Iso</title>+<path fill="none" stroke="black" d="M324.12,-36C324.12,-36 294.12,-36 294.12,-36 288.12,-36 282.12,-30 282.12,-24 282.12,-24 282.12,-12 282.12,-12 282.12,-6 288.12,0 294.12,0 294.12,0 324.12,0 324.12,0 330.12,0 336.12,-6 336.12,-12 336.12,-12 336.12,-24 336.12,-24 336.12,-30 330.12,-36 324.12,-36"/>+<text text-anchor="middle" x="309.12" y="-12.2" font-family="Helvetica,sans-Serif" font-size="14.00">Iso</text>+</g>+<!-- Tracer&#45;&gt;Iso -->+<g id="edge33" class="edge">+<title>Tracer&#45;&gt;Iso</title>+<path fill="none" stroke="black" d="M443.28,-76.1C440.2,-74.7 437.1,-73.31 434.12,-72 400.7,-57.24 361.93,-40.92 336.54,-30.35"/>+</g>+<!-- Grate -->+<g id="node15" class="node">+<title>Grate</title>+<path fill="none" stroke="black" d="M463.12,-180C463.12,-180 433.12,-180 433.12,-180 427.12,-180 421.12,-174 421.12,-168 421.12,-168 421.12,-156 421.12,-156 421.12,-150 427.12,-144 433.12,-144 433.12,-144 463.12,-144 463.12,-144 469.12,-144 475.12,-150 475.12,-156 475.12,-156 475.12,-168 475.12,-168 475.12,-174 469.12,-180 463.12,-180"/>+<text text-anchor="middle" x="448.12" y="-156.2" font-family="Helvetica,sans-Serif" font-size="14.00">Grate</text>+</g>+<!-- Glass&#45;&gt;Grate -->+<g id="edge14" class="edge">+<title>Glass&#45;&gt;Grate</title>+<path fill="none" stroke="black" d="M448.12,-215.7C448.12,-204.85 448.12,-190.92 448.12,-180.1"/>+</g>+<!-- Glass&#45;&gt;Lens -->+<g id="edge13" class="edge">+<title>Glass&#45;&gt;Lens</title>+<path fill="none" stroke="black" d="M429.83,-215.7C418.45,-204.93 403.86,-191.12 392.46,-180.35"/>+</g>+<!-- Glass&#45;&gt;MonoidalLens -->+<g id="edge15" class="edge">+<title>Glass&#45;&gt;MonoidalLens</title>+<path fill="none" stroke="black" d="M420.69,-219.82C417.81,-218.5 414.92,-217.21 412.12,-216 383.2,-203.47 350.29,-190.43 324.32,-180.42"/>+</g>+<!-- AffineTraversal&#45;&gt;Lens -->+<g id="edge18" class="edge">+<title>AffineTraversal&#45;&gt;Lens</title>+<path fill="none" stroke="black" d="M301.1,-215.7C316.03,-204.93 335.15,-191.12 350.09,-180.35"/>+</g>+<!-- AffineTraversal&#45;&gt;MonoidalLens -->+<g id="edge20" class="edge">+<title>AffineTraversal&#45;&gt;MonoidalLens</title>+<path fill="none" stroke="black" d="M277.37,-215.7C277.53,-204.85 277.73,-190.92 277.88,-180.1"/>+</g>+<!-- AffineTraversal&#45;&gt;Prism -->+<g id="edge19" class="edge">+<title>AffineTraversal&#45;&gt;Prism</title>+<path fill="none" stroke="black" d="M243.66,-215.52C221.02,-203.69 191.51,-188.27 170.32,-177.21"/>+</g>+<!-- MonoidalTraversal&#45;&gt;MonoidalLens -->+<g id="edge21" class="edge">+<title>MonoidalTraversal&#45;&gt;MonoidalLens</title>+<path fill="none" stroke="black" d="M176.09,-215.52C197.02,-204.74 223.74,-190.99 244.59,-180.26"/>+</g>+<!-- MonoidalTraversal&#45;&gt;Prism -->+<g id="edge22" class="edge">+<title>MonoidalTraversal&#45;&gt;Prism</title>+<path fill="none" stroke="black" d="M142.37,-215.7C142.53,-204.85 142.73,-190.92 142.88,-180.1"/>+</g>+<!-- PowerGrate -->+<g id="node19" class="node">+<title>PowerGrate</title>+<path fill="none" stroke="black" d="M413.5,-108C413.5,-108 348.75,-108 348.75,-108 342.75,-108 336.75,-102 336.75,-96 336.75,-96 336.75,-84 336.75,-84 336.75,-78 342.75,-72 348.75,-72 348.75,-72 413.5,-72 413.5,-72 419.5,-72 425.5,-78 425.5,-84 425.5,-84 425.5,-96 425.5,-96 425.5,-102 419.5,-108 413.5,-108"/>+<text text-anchor="middle" x="381.12" y="-84.2" font-family="Helvetica,sans-Serif" font-size="14.00">PowerGrate</text>+</g>+<!-- MonoidalTraversal&#45;&gt;PowerGrate -->+<g id="edge23" class="edge">+<title>MonoidalTraversal&#45;&gt;PowerGrate</title>+<path fill="none" stroke="black" d="M152.8,-215.77C166.03,-195.78 190.37,-163.12 219.12,-144 254.85,-120.24 302.08,-106.39 336.32,-98.85"/>+</g>+<!-- Kaleidoscope&#45;&gt;ClassifyingLens -->+<g id="edge28" class="edge">+<title>Kaleidoscope&#45;&gt;ClassifyingLens</title>+<path fill="none" stroke="black" d="M562.88,-215.69C587.5,-193.64 627.22,-152.98 643.12,-108 651.79,-83.49 639.48,-54.36 629.27,-36.27"/>+</g>+<!-- Kaleidoscope&#45;&gt;Grate -->+<g id="edge12" class="edge">+<title>Kaleidoscope&#45;&gt;Grate</title>+<path fill="none" stroke="black" d="M518.89,-215.7C504.43,-204.93 485.89,-191.12 471.42,-180.35"/>+</g>+<!-- Grate&#45;&gt;PowerGrate -->+<g id="edge25" class="edge">+<title>Grate&#45;&gt;PowerGrate</title>+<path fill="none" stroke="black" d="M431.56,-143.7C421.18,-132.85 407.85,-118.92 397.5,-108.1"/>+</g>+<!-- Lens&#45;&gt;Iso -->+<g id="edge29" class="edge">+<title>Lens&#45;&gt;Iso</title>+<path fill="none" stroke="black" d="M354.96,-143.57C345.52,-133.96 334.76,-121.3 328.12,-108 316.56,-84.81 312.02,-54.81 310.24,-36.24"/>+</g>+<!-- MonoidalLens&#45;&gt;AlgebraicLens -->+<g id="edge26" class="edge">+<title>MonoidalLens&#45;&gt;AlgebraicLens</title>+<path fill="none" stroke="black" d="M328.8,-146.39C331.95,-145.56 335.08,-144.76 338.12,-144 412.67,-125.52 432.31,-125.32 507.12,-108 510.09,-107.31 513.12,-106.6 516.18,-105.87"/>+</g>+<!-- MonoidalLens&#45;&gt;Iso -->+<g id="edge30" class="edge">+<title>MonoidalLens&#45;&gt;Iso</title>+<path fill="none" stroke="black" d="M281.09,-143.53C284.23,-125.53 289.51,-96.7 295.12,-72 297.87,-59.94 301.43,-46.46 304.28,-36.11"/>+</g>+<!-- Prism&#45;&gt;Iso -->+<g id="edge31" class="edge">+<title>Prism&#45;&gt;Iso</title>+<path fill="none" stroke="black" d="M163.48,-143.59C195.43,-116.26 256.97,-63.61 288.86,-36.33"/>+</g>+<!-- PowerGrate&#45;&gt;Iso -->+<g id="edge32" class="edge">+<title>PowerGrate&#45;&gt;Iso</title>+<path fill="none" stroke="black" d="M363.33,-71.7C352.25,-60.93 338.05,-47.12 326.97,-36.35"/>+</g>+</g>+</svg>
+ mkdocs.sh view
@@ -0,0 +1,58 @@+: "${CABAL:=cabal}"+: "${HADDOCK:=haddock}"+: "${ARG_COMPILER:=}"+# Where the "Contents" link at the top of each page goes. Empty means the index.html generated+# below (GitHub Pages); hackage-docs.sh sets it to ../, Hackage's own package page.+: "${USE_CONTENTS:=}"++# The optics lattice diagram (Proarrow.Optics) is generated from lattice.dot:+#   dot -Tsvg lattice.dot -o lattice.svg+rm -rf docs+mkdir docs+# copy the optics lattice image next to the module HTML so Haddock's <<lattice.svg>> resolves+cp lattice.svg docs/++# Both libraries render into one doc tree (Hackage has a single documentation set per package).+# This is hand-rolled rather than `cabal haddock-project` because that documents the whole+# project (proarrow-equipment included), nests pages per component (breaking published URLs and+# the flat tree `cabal upload --documentation` expects), and has no per-component haddock options+# (the --comments-module source template differs between src/ and testing/).+# The testing sublibrary goes first: its dependency pass re-renders the main library with the+# wrong source-link template, and the main run afterwards overwrites those pages correctly.+${CABAL} haddock lib:testing ${ARG_COMPILER} \+  --haddock-hyperlink-source \+  --haddock-html-location='https://hackage.haskell.org/package/$pkg-$version/docs' \+  --haddock-options="+    --comments-base=https://github.com/sjoerdvisscher/proarrow/+    --comments-module=https://github.com/sjoerdvisscher/proarrow/blob/main/proarrow/testing/%{MODULE/.//}.hs+    --comments-entity=https://github.com/sjoerdvisscher/proarrow/blob/main/proarrow/testing/%{MODULE/.//}.hs#L%L+    --pretty-html+    ${USE_CONTENTS:+--use-contents=${USE_CONTENTS}}+    --odir=docs+    --dump-interface=docs/testing.haddock"++${CABAL} haddock lib:proarrow ${ARG_COMPILER} \+  --haddock-hyperlink-source \+  --haddock-html-location='https://hackage.haskell.org/package/$pkg-$version/docs' \+  --haddock-options="+    --comments-base=https://github.com/sjoerdvisscher/proarrow/+    --comments-module=https://github.com/sjoerdvisscher/proarrow/blob/main/proarrow/src/%{MODULE/.//}.hs+    --comments-entity=https://github.com/sjoerdvisscher/proarrow/blob/main/proarrow/src/%{MODULE/.//}.hs#L%L+    --pretty-html+    ${USE_CONTENTS:+--use-contents=${USE_CONTENTS}}+    --odir=docs+    --dump-interface=docs/proarrow.haddock"++# regenerate the contents and index pages covering both libraries+${HADDOCK} --gen-contents --gen-index -o docs --title=proarrow ${USE_CONTENTS:+--use-contents=${USE_CONTENTS}} \+  --read-interface=,docs/proarrow.haddock \+  --read-interface=,docs/testing.haddock++# the testing pages link to the main library's modules via hackage; make those links local+grep -rl 'hackage.haskell.org/package/proarrow-' docs | xargs perl -pi -e 's|https://hackage.haskell.org/package/proarrow-[0-9.]+/docs/||g'++grep -rilE '>(User )?Comments<' docs | xargs perl -pi -e 's/>(User )?Comments</>Github</gi'++# haddock's --comments-entity links use the page's module and the enclosing declaration's line;+# make each one agree with the Source link beside it+python3 fix-github-links.py docs https://github.com/sjoerdvisscher/proarrow/blob/main/proarrow/
+ proarrow.cabal view
@@ -0,0 +1,288 @@+cabal-version:      3.0+name:               proarrow+version:            0.1.0.0+synopsis:           Category theory with a central role for profunctors+description:+    A library for doing category theory in Haskell with profunctors, rather+    than functors, as the central abstraction. Every Haskell kind carries at+    most one category structure (chosen via @CategoryOf@), newtype wrappers on+    kinds give variant categories, and functors are encoded as representable+    profunctors. On top of this the library provides monoidal structure,+    (co)limits, adjunctions, Kan extensions, promonads, and a full+    profunctor-optics hierarchy.+    .+    Import "Proarrow" to get started; "Proarrow.Core" explains the design of the+    core abstractions in depth. The public sublibrary @proarrow:testing@ provides+    generic law-checking properties for testing your own categories. +homepage:           https://github.com/sjoerdvisscher/proarrow+bug-reports:        https://github.com/sjoerdvisscher/proarrow/issues+license:            BSD-3-Clause+license-file:       LICENSE+author:             Sjoerd Visscher+maintainer:         sjoerd@w3future.com+category:           Math, Categories+tested-with:        GHC ==9.10.3 || ==9.12.2++extra-doc-files:+    CHANGELOG.md+    lattice.svg+    README.md++extra-source-files:+    fix-github-links.py+    lattice.dot+    mkdocs.sh++common extensions+    default-language: GHC2024+    ghc-options:      -Wall+    default-extensions:+        BlockArguments+        DefaultSignatures+        DeriveAnyClass+        DerivingVia+        FunctionalDependencies+        OverloadedLists+        NoImplicitPrelude+        NoStarIsType+        PatternSynonyms+        RecordWildCards+        QuantifiedConstraints+        StrictData+        TypeAbstractions+        TypeData+        TypeFamilies+        UndecidableInstances+        UndecidableSuperClasses+        ViewPatterns++library+    import: extensions+    exposed-modules:+        Proarrow+        Proarrow.Adjunction+        Proarrow.Category.Enriched+        Proarrow.Category.Enriched.Dagger+        Proarrow.Category.Enriched.Finitary+        Proarrow.Category.Enriched.Finitary.Sheaf+        Proarrow.Category.Enriched.Finitary.Topos+        Proarrow.Category.Enriched.Quantale+        Proarrow.Category.Enriched.Thin+        Proarrow.Category.Enriched.Thin.Composition+        Proarrow.Category.Instance.Bool+        Proarrow.Category.Instance.Collage+        Proarrow.Category.Instance.Constraint+        Proarrow.Category.Instance.Coproduct+        Proarrow.Category.Instance.Cospan+        Proarrow.Category.Instance.Cost+        Proarrow.Category.Instance.Discrete+        Proarrow.Category.Instance.Duploid+        Proarrow.Category.Instance.Fam+        Proarrow.Category.Instance.FinHask+        Proarrow.Category.Instance.FinRel+        Proarrow.Category.Instance.FinSet+        Proarrow.Category.Instance.Free+        Proarrow.Category.Instance.Graph+        Proarrow.Category.Instance.Hask+        Proarrow.Category.Instance.IntConstruction+        Proarrow.Category.Instance.Kleisli+        Proarrow.Category.Instance.Linear+        Proarrow.Category.Instance.Mat+        Proarrow.Category.Instance.Monoid+        Proarrow.Category.Instance.Nat+        Proarrow.Category.Instance.PointedHask+        Proarrow.Category.Instance.Product+        Proarrow.Category.Instance.Prof+        Proarrow.Category.Instance.Rel+        Proarrow.Category.Instance.Rep+        Proarrow.Category.Instance.Simplex+        Proarrow.Category.Instance.Span+        Proarrow.Category.Instance.Sub+        Proarrow.Category.Instance.Unit+        Proarrow.Category.Instance.Zero+        Proarrow.Category.Instance.ZX+        Proarrow.Category.Internal+        Proarrow.Category.Monoidal+        Proarrow.Category.Monoidal.Action+        Proarrow.Category.Monoidal.Applicative+        Proarrow.Category.Monoidal.Cartesian+        Proarrow.Category.Monoidal.Closed+        Proarrow.Category.Monoidal.Coclosed+        Proarrow.Category.Monoidal.CompactClosed+        Proarrow.Category.Monoidal.CopyDiscard+        Proarrow.Category.Monoidal.Distributive+        Proarrow.Category.Monoidal.EndoProf+        Proarrow.Category.Monoidal.Hypergraph+        Proarrow.Category.Monoidal.Rev+        Proarrow.Category.Monoidal.StarAutonomous+        Proarrow.Category.Monoidal.Strength+        Proarrow.Category.Monoidal.Strictified+        Proarrow.Category.Instance.Paths+        Proarrow.Category.Instance.Opposite+        Proarrow.Category.Instance.Ordinal+        Proarrow.Category.Promonoidal+        Proarrow.Category.Sheaf+        Proarrow.Category.Topos+        Proarrow.Colimit+        Proarrow.Colimit.BinaryCoproduct+        Proarrow.Colimit.Coequalizer+        Proarrow.Colimit.Copower+        Proarrow.Colimit.Initial+        Proarrow.Colimit.NaturalNumbers+        Proarrow.Colimit.Pushout+        Proarrow.Core+        Proarrow.Functor+        Proarrow.Limit+        Proarrow.Limit.BinaryProduct+        Proarrow.Limit.Equalizer+        Proarrow.Limit.Power+        Proarrow.Limit.Pullback+        Proarrow.Limit.Terminal+        Proarrow.Monoid+        Proarrow.Object+        Proarrow.Optic+        Proarrow.Optics+        Proarrow.Optic.Action+        Proarrow.Optic.AffineFold+        Proarrow.Optic.AffineTraversal+        Proarrow.Optic.Day+        Proarrow.Optic.Fold+        Proarrow.Optic.Getter+        Proarrow.Optic.Glass+        Proarrow.Optic.Grate+        Proarrow.Optic.Iso+        Proarrow.Optic.Kaleidoscope+        Proarrow.Optic.PowerGrate+        Proarrow.Optic.Lens+        Proarrow.Optic.Prism+        Proarrow.Optic.Prod+        Proarrow.Optic.Setter+        Proarrow.Optic.Sum+        Proarrow.Optic.Tracer+        Proarrow.Optic.MonoidalLens+        Proarrow.Optic.MonoidalTraversal+        Proarrow.Optic.Traversal+        Proarrow.Path+        Proarrow.Profunctor.Cofree+        Proarrow.Profunctor.Corepresentable+        Proarrow.Profunctor.Free+        Proarrow.Profunctor.Instance.Adj+        Proarrow.Profunctor.Instance.Arrow+        Proarrow.Profunctor.Instance.Cocone+        Proarrow.Profunctor.Instance.Composition+        Proarrow.Profunctor.Instance.Cone+        Proarrow.Profunctor.Instance.Constant+        Proarrow.Profunctor.Instance.Coproduct+        Proarrow.Profunctor.Instance.Costar+        Proarrow.Profunctor.Instance.Coyoneda+        Proarrow.Profunctor.Instance.Day+        Proarrow.Profunctor.Instance.Direp+        Proarrow.Profunctor.Instance.Edges+        Proarrow.Profunctor.Instance.Exponential+        Proarrow.Profunctor.Instance.Fix+        Proarrow.Profunctor.Instance.Fold+        Proarrow.Profunctor.Instance.HaskValue+        Proarrow.Profunctor.Instance.Identity+        Proarrow.Profunctor.Instance.Initial+        Proarrow.Profunctor.Instance.List+        Proarrow.Profunctor.Instance.PastroTambara+        Proarrow.Profunctor.Instance.Product+        Proarrow.Profunctor.Instance.Ran+        Proarrow.Profunctor.Instance.Rift+        Proarrow.Profunctor.Instance.Sieve+        Proarrow.Profunctor.Instance.Star+        Proarrow.Profunctor.Instance.Terminal+        Proarrow.Profunctor.Instance.Wrapped+        Proarrow.Profunctor.Instance.Yoneda+        Proarrow.Profunctor.Representable+        Proarrow.Promonad+        Proarrow.Promonad.Cont+        Proarrow.Promonad.Reader+        Proarrow.Promonad.State+        Proarrow.Promonad.Writer+        Proarrow.Squares+        Proarrow.Tools.CCC+        Proarrow.Tools.DPO+        Proarrow.Tools.Laws+        Proarrow.Tools.Diagrams.Dot+        Proarrow.Tools.Diagrams.Svg+        Proarrow.Universal++    build-depends:+        , base >=4.20 && <5+        , containers >=0.6 && <0.9+        , fin >= 0.3.2 && <1+        , vec >= 0.5.1 && <1+        , universe-base >= 1.1.4 && <1.2+    hs-source-dirs:   src++library testing+    import: extensions+    visibility: public+    hs-source-dirs: testing+    exposed-modules:+        Proarrow.Testing+        Proarrow.Testing.Laws+        Proarrow.Testing.Laws.Run+    build-depends: proarrow+    build-depends:+        , base >=4.20 && <5+        , data-default >=0.7 && <0.9+        , falsify >=0.4 && <0.5+        , tasty >=1.4 && <1.6+        , tasty-falsify >=0.1 && <0.2++test-suite test+    import: extensions+    type: exitcode-stdio-1.0+    hs-source-dirs:   test+    main-is:          Main.hs+    other-modules:+        Examples.Cofree+        Examples.CustomLaws+        Examples.Database+        Examples.Free+        Examples.FrontDoor+        Examples.Readme+        Examples.Graph+        Examples.UntypedLambdaCalculus+        Examples.SimplyTypedLambdaCalculus+        Examples.Vitrea+        Props.Bool+        Props.DPO+        Props.Discrete+        Props.Cospan+        Props.Cost+        Props.Dot+        Props.Svg+        Props.FinHask+        Props.FinRel+        Props.FinSet+        Props.Finitary+        Props.Finitary.Graph+        Props.Free+        Props.Hask+        Props.Kleisli+        Props.PointedHask+        Props.Mat+        Props.Optic.Hask+        Props.Optic.Linear+        Props.Ordinal+        Props.Paths+        Props.Sheaf+        Props.Sheaf.Chain+        Props.Sheaf.Collage+        Props.Optic.FinRel+        Props.Simplex+        Props.Span+        Props.ZX+    build-depends: proarrow, proarrow:testing+    build-depends:+        , base >=4.20 && <5+        , containers >=0.6 && <0.9+        , falsify >=0.4 && <0.5+        , fin >= 0.3.2 && <1+        , vec >= 0.5.1 && <1+        , universe-base >= 1.1.4 && <1.2+        , tasty >=1.4 && <1.6+        , tasty-falsify >=0.1 && <0.2
+ src/Proarrow.hs view
@@ -0,0 +1,93 @@+-- | The main entry point of the library. One import gives the curated core vocabulary+-- (categories, profunctors, functors, promonads, objects, monoids, universal properties and+-- optics). Several @Prelude@ names are redefined here, so import it with+--+-- > import Prelude hiding (id, (.), Functor, fmap, Monad, return, Monoid, mempty, mappend, map)+-- > import Proarrow+--+-- There is much more under @Proarrow.*@ than this module exports: concrete categories (the+-- @Proarrow.Category.Instance.*@ modules), monoidal structure, (co)limits, adjunctions, Kan+-- extensions, enriched categories. "Proarrow.Core" documents the design of the core abstractions+-- in depth.+module Proarrow+  ( -- * Categories and profunctors+    CAT+  , type (+->)+  , CategoryOf (..)+  , Promonad (..)+  , Profunctor (..)+  , type (:~>)+  , (//)+  , dimapDefault++    -- * Objects+  , Obj+  , obj+  , src+  , tgt+  , pattern Objs+  , Ob'+  , ObId (..)++    -- * Functors+  , Functor (..)+  , type (.~>)+  , Prelude (..)+  , FunctorForRep (..)+  , Representable (..)+  , Rep (..)+  , Corepresentable (..)+  , Corep (..)++    -- * Promonads as effects+  , Monad+  , return+  , bind+  , Comonad+  , extract+  , extend++    -- * Monoids and comonoids+  , Monoid (..)+  , CommutativeMonoid+  , Comonoid (..)+  , ComonoidOn (..)++    -- * Universal properties and adjunctions+  , InitUniversal (..)+  , TermUniversal (..)+  , Adjunction+  , leftAdjunct+  , rightAdjunct++    -- * Optics++    -- | The full optics vocabulary. See "Proarrow.Optics" for the guided tour: the subtyping+    -- lattice, and how to build, eliminate and compose each optic flavor.+  , module Proarrow.Optics+  ) where++import Proarrow.Adjunction (Adjunction, leftAdjunct, rightAdjunct)+import Proarrow.Core+  ( CAT+  , CategoryOf (..)+  , ObId (..)+  , Obj+  , Profunctor (..)+  , Promonad (..)+  , dimapDefault+  , obj+  , src+  , tgt+  , (//)+  , type (+->)+  , type (:~>)+  )+import Proarrow.Functor (Functor (..), FunctorForRep (..), Prelude (..), type (.~>))+import Proarrow.Monoid (CommutativeMonoid, Comonoid (..), ComonoidOn (..), Monoid (..))+import Proarrow.Object (Ob', pattern Objs)+import Proarrow.Optics+import Proarrow.Profunctor.Corepresentable (Corep (..), Corepresentable (..))+import Proarrow.Profunctor.Representable (Rep (..), Representable (..))+import Proarrow.Promonad (Comonad, Monad, bind, extend, extract, return)+import Proarrow.Universal (InitUniversal (..), TermUniversal (..))
+ src/Proarrow/Adjunction.hs view
@@ -0,0 +1,311 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Adjunctions as heteromorphisms: an 'Adjunction' is a profunctor that is both 'Representable' (by the+-- right adjoint) and 'Corepresentable' (by the left adjoint), giving 'unitRep'\/'counitRep' and+-- 'leftAdjunct'\/'rightAdjunct'. Also the profunctor-level notion 'Proadjunction', and the interaction+-- of adjoints with (co)limits.+module Proarrow.Adjunction where++import Data.Kind (Constraint)+import Prelude (type (~))++import Proarrow.Category.Enriched.Thin (Thin, ThinProfunctor)+import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))+import Proarrow.Category.Instance.Product (Fst, Snd, (:**:) (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Instance.Rep (COREP, COREPK, REP, REPK)+import Proarrow.Category.Instance.Sub (SUBCAT (..), Sub (..))+import Proarrow.Colimit (HasColimits (..))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), UN, lmap, rmap, (//), (:~>), type (+->))+import Proarrow.Functor (Functor (..), FunctorForRep (..))+import Proarrow.Limit (HasLimits (..), mapLimit)+import Proarrow.Object (pattern Objs)+import Proarrow.Optic (PIso, iso, re)+import Proarrow.Profunctor.Corepresentable+  ( Corep+  , Corepresentable (..)+  , corepUniv+  , cotabulated+  )+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Costar (Costar, pattern Costar)+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Instance.Star (Star, pattern Star)+import Proarrow.Profunctor.Representable+  ( CorepStar (..)+  , Rep+  , RepCostar (..)+  , Representable (..)+  , mapRepCostar+  , repUniv+  , tabulated+  )+import Proarrow.Promonad (Procomonad (..), bind, extend, extract, return)+import Proarrow.Tools.Laws (ProLaw (..), ProLaws (..), (=:=))++-- | Adjunctions as heteromorphisms.+class (Representable p, Corepresentable p) => Adjunction p++instance (Representable p, Corepresentable p) => Adjunction p++-- | One direction of the adjunction isomorphism: transpose an arrow out of the left adjoint,+-- @p '%%' a '~>' b@, to an arrow into the right adjoint, @a '~>' p '%' b@.+leftAdjunct :: forall p a b. (Adjunction p, Ob a) => (p %% a ~> b) -> a ~> p % b+leftAdjunct = index . cotabulate @p++-- | The other direction of the adjunction isomorphism, inverse to 'leftAdjunct'.+rightAdjunct :: forall p a b. (Adjunction p, Ob b) => a ~> p % b -> (p %% a ~> b)+rightAdjunct = coindex . tabulate @p++-- | The isomorphism between @leftAdjunct@ and @rightAdjunct@.+adjuncted+  :: forall p a b a' b'. (Adjunction p, Ob a, Ob b') => PIso (b ~> p % a) (b' ~> p % a') (p %% b ~> a) (p %% b' ~> a')+adjuncted = tabulated @p . re cotabulated++-- | The monad induced by an adjunction as a representable promonad.+type AdjMonad p = p :.: CorepStar p++unitRep :: forall p a. (Adjunction p, Ob a) => a ~> AdjMonad p % a+unitRep = return @(AdjMonad p) @a++bindRep :: forall p a b. (Adjunction p, Ob b) => a ~> AdjMonad p % b -> AdjMonad p % a ~> AdjMonad p % b+bindRep = bind @(AdjMonad p) @b++-- | The comonad induced by an adjunction as a corepresentable promonad.+type AdjComonad p = RepCostar p :.: p++counitRep :: forall p a. (Adjunction p, Ob a) => AdjComonad p %% a ~> a+counitRep = extract @(AdjComonad p) @a++extendRep :: forall p a b. (Adjunction p, Ob a) => (AdjComonad p %% a ~> b) -> AdjComonad p %% a ~> AdjComonad p %% b+extendRep = extend @(AdjComonad p) @a @b++-- | The left adjoint of @((->) a)@ is @(,) a@.+instance Corepresentable (Star ((->) a)) where+  type Star ((->) a) %% b = (a, b)+  cotabulate f = Star \a b -> f (b, a)+  coindex (Star f) (a, b) = f b a+  corepMap = map++-- | The right adjoint of @(,) a@ is @((->) a)@.+instance Representable (Costar ((,) a)) where+  type Costar ((,) a) % b = a -> b+  tabulate f = Costar \(a, b) -> f b a+  index (Costar g) a b = g (b, a)+  repMap = map++class (p % a ~ p %% a, p % (p %% a) ~ p % (p % a), p %% (p % a) ~ p % (p % a)) => SelfAdjointPoint p a+instance (p % a ~ p %% a, p % (p %% a) ~ p % (p % a), p %% (p % a) ~ p % (p % a)) => SelfAdjointPoint p a++-- | Self-adjoint functors+class (forall a. (Ob a) => SelfAdjointPoint p a, Adjunction p) => SelfAdjoint p++instance (forall a. (Ob a) => SelfAdjointPoint p a, Adjunction p) => SelfAdjoint p++-- | Involution functors are self-adjoint functors where the unit and counit form an isomorphism.+class (SelfAdjoint p) => Involution p where+  involuted :: forall a a'. (Ob a, Ob a') => PIso a a' (p % (p % a)) (p % (p % a'))+  involuted = iso (unitRep @p) (counitRep @p)++instance (CategoryOf k) => Involution (Id :: CAT k)++class (p %% a ~ RepCostar p % a, p % (p %% a) ~ p % (RepCostar p % a)) => AmbidextrousEqRep p a+instance (p %% a ~ RepCostar p % a, p % (p %% a) ~ p % (RepCostar p % a)) => AmbidextrousEqRep p a++class (p % a ~ CorepStar p %% a, p %% (p % a) ~ p %% (CorepStar p %% a)) => AmbidextrousEqCorep p a+instance (p % a ~ CorepStar p %% a, p %% (p % a) ~ p %% (CorepStar p %% a)) => AmbidextrousEqCorep p a++class+  ( Adjunction p+  , Representable (RepCostar p)+  , Corepresentable (CorepStar p)+  , forall a. (Ob a) => AmbidextrousEqRep p a+  , forall a. (Ob a) => AmbidextrousEqCorep p a+  ) =>+  Ambidextrous p+instance+  ( Adjunction p+  , Representable (RepCostar p)+  , Corepresentable (CorepStar p)+  , forall a. (Ob a) => AmbidextrousEqRep p a+  , forall a. (Ob a) => AmbidextrousEqCorep p a+  )+  => Ambidextrous p++class (Ambidextrous p) => AdjointEquivalence (p :: j +-> k) where+  unitIso :: (Ob a, Ob a') => PIso a a' (AdjMonad p % a) (AdjMonad p % a')+  unitIso @a @a' = iso (unitRep @p @a) (counitRep @(RepCostar p) @a')+  counitIso :: (Ob a, Ob a') => PIso (AdjComonad p %% a) (AdjComonad p %% a') a a'+  counitIso @a @a' = iso (counitRep @p @a) (unitRep @(CorepStar p) @a')++type GaloisConnection (p :: j +-> k) = (ThinProfunctor p, Thin j, Thin k, Adjunction p)++-- | Adjunctions between two profunctors.+type Proadjunction :: forall {j} {k}. j +-> k -> k +-> j -> Constraint+class (Profunctor p, Profunctor q) => Proadjunction (p :: j +-> k) (q :: k +-> j) where+  unit :: (Ob a) => (q :.: p) a a -- (~>) :~> q :.: p+  counit :: p :.: q :~> (~>)++-- | 'Proadjunction' with the right adjoint first, so that the laws about elements of the left+-- adjoint can be indexed by it.+type LeftProadjoint :: forall {j} {k}. k +-> j -> j +-> k -> Constraint+class (Proadjunction p q) => LeftProadjoint q p++instance (Proadjunction p q) => LeftProadjoint q p++-- | The zigzag law for elements of the right adjoint @q@: going through the 'unit' and back through+-- the 'counit' is the identity.+instance ProLaws (Proadjunction p) where+  proLaws =+    [ ProLaw "zigzag" \ @q @a q _ _ -> case unit @p @q @a of+        uq :.: up -> q =:= rmap (counit (up :.: q)) uq+    ]++-- | The zigzag law for elements of the left adjoint @p@.+instance ProLaws (LeftProadjoint q) where+  proLaws =+    [ ProLaw "zigzag" \ @p @_ @b p _ _ -> case unit @p @q @b of+        uq :.: up -> p =:= lmap (counit (p :.: uq)) up+    ]++unit' :: forall p q. (Proadjunction p q) => (~>) :~> q :.: p+unit' (f :: a ~> b) = rmap f (unit @p @q @a) \\ f++flipMate :: forall p q. (Proadjunction p q) => (~>) :~> p -> q :~> (~>)+flipMate n q = counit (n id :.: q) \\ q++unflipMate :: forall p q. (Proadjunction p q) => q :~> (~>) -> (~>) :~> p+unflipMate n f = case unit' @p @q f of q :.: p -> lmap (n q) p++instance (Representable p) => Proadjunction p (RepCostar p) where+  unit = corepUniv :.: repUniv+  counit (f :.: g) = coindex g . index f++instance (Corepresentable p) => Proadjunction (CorepStar p) p where+  unit = corepUniv :.: repUniv+  counit (f :.: g) = coindex g . index f++instance (FunctorForRep f) => Proadjunction (Rep f) (Corep f) where+  unit = corepUniv :.: repUniv+  counit (f :.: g) = coindex g . index f++instance (Functor f) => Proadjunction (Star f) (Costar f) where+  unit = corepUniv :.: repUniv+  counit (f :.: g) = coindex g . index f++instance (Proadjunction l1 r1, Proadjunction l2 r2) => Proadjunction (l1 :.: l2) (r2 :.: r1) where+  unit :: forall a. (Ob a) => ((r2 :.: r1) :.: (l1 :.: l2)) a a+  unit = case unit @l2 @r2 @a of+    r2 :.: l2 ->+      l2 // case unit @l1 @r1 of+        r1 :.: l1 -> (r2 :.: r1) :.: (l1 :.: l2)+  counit ((l1 :.: l2) :.: (r2 :.: r1)) = counit (rmap (counit (l2 :.: r2)) l1 :.: r1)++-- | Adjunctions pair up over the product category.+instance (Proadjunction p1 q1, Proadjunction p2 q2) => Proadjunction (p1 :**: p2) (q1 :**: q2) where+  unit @a = case unit @p1 @q1 @(Fst @ a) of+    u1 :.: v1 -> case unit @p2 @q2 @(Snd @ a) of+      u2 :.: v2 -> (u1 :**: u2) :.: (v1 :**: v2)+  counit ((l1 :**: l2) :.: (r1 :**: r2)) = counit (l1 :.: r1) :**: counit (l2 :.: r2)++instance (CategoryOf k) => Proadjunction (Id :: CAT k) Id where+  unit = Id id :.: Id id+  counit (Id f :.: Id g) = g . f++instance (Proadjunction q p) => Proadjunction (Op p) (Op q) where+  unit = case unit @q @p of q :.: p -> Op p :.: Op q+  counit (Op q :.: Op p) = Op (counit (p :.: q))++instance (Proadjunction p q) => Promonad (q :.: p) where+  id = unit+  (q :.: p) . (q' :.: p') = rmap (counit (p' :.: q)) q' :.: p++instance (Proadjunction p q) => Procomonad (p :.: q) where+  proextract = counit+  produplicate (p :.: q) = p // case unit of q' :.: p' -> (p :.: q') :.: (p' :.: q)++-- (~>) :~> Colimit j c :.: r+--    <=>+-- j :~> c :.: r+--    <=>+-- (~>) :~> c :.: Limit j r++-- | The heteromorphisms witnessing the @'Colimit' j@ ⊣ @'Limit' j@ adjunction: a natural+-- transformation @j ':~>' c ':.:' r@, read as an arrow from the corepresentable @c@ to the+-- representable @r@.+type LimitAdj :: (a +-> b) -> REPK a k +-> COREPK b k+data LimitAdj j c r where+  LimitAdj :: (Corepresentable c, Representable r) => (j :~> c :.: r) -> LimitAdj j (COREP c) (REP r)++instance (Profunctor j) => Profunctor (LimitAdj j) where+  dimap (Sub (Op (Prof l))) (Sub (Prof r)) (LimitAdj n) = LimitAdj (\j -> case n j of c :.: d -> l c :.: r d)+  r \\ LimitAdj f = r \\ f++-- | @Colimit j@ ⊣ @Limit j@+instance (HasLimits j k) => Representable (LimitAdj (j :: a +-> b) :: REPK a k +-> COREPK b k) where+  type LimitAdj j % r = COREP (RepCostar (Limit j (UN SUB r)))+  index @c (LimitAdj n) =+    Sub+      ( Op+          ( Prof \(RepCostar @o l) ->+              cotabulate+                ( l+                    . index+                      ( limitUniv @j @k+                          (\(g :.: j) -> case n j of c :.: r -> lmap (coindex c . index g) r)+                          (repUniv @(CorepStar (UN OP (UN SUB c))) @o)+                      )+                )+          )+      )+  repUniv @(SUB r) = LimitAdj (\j -> RepCostar (index @r (limit (repUniv :.: j))) :.: repUniv \\ j)+  repMap (Sub n) = Sub (Op (mapRepCostar (mapLimit @j n)))++instance (HasColimits j k) => Corepresentable (LimitAdj (j :: a +-> b) :: REPK a k +-> COREPK b k) where+  type LimitAdj j %% c = REP (CorepStar (Colimit j (UN OP (UN SUB c))))+  corepUniv @(SUB (OP r)) = LimitAdj (\j -> corepUniv :.: CorepStar (coindex @r (colimit (j :.: corepUniv))) \\ j)+  coindex @_ @r (LimitAdj n) =+    Sub+      ( Prof \(CorepStar @o l) ->+          tabulate+            ( coindex+                ( colimitUniv @j @k+                    (\(j :.: p) -> case n j of c :.: r -> rmap (coindex p . index r) c)+                    (corepUniv @(RepCostar (UN SUB r)) @o)+                )+                . l+            )+      )++rightAdjointPreservesLimits+  :: forall {k} {k'} {i} {a} (j :: i +-> a) (p :: k +-> k') (d :: i +-> k)+   . (Adjunction p, Representable d, HasLimits j k, HasLimits j k')+  => Limit j (p :.: d) :~> p :.: Limit j d+rightAdjointPreservesLimits lim@Objs =+  corepUniv @p+    :.: limitUniv @j @k @d+      (\((f' :.: lim') :.: j) -> case limit @j @k' @(p :.: d) (lim' :.: j) of g' :.: d -> lmap (coindex g' . index f') d)+      (repUniv @(CorepStar p) :.: lim)++rightAdjointPreservesLimitsInv+  :: forall {k} {k'} {i} {a} (p :: k +-> k') (d :: i +-> k) (j :: i +-> a)+   . (Representable p, Representable d, HasLimits j k, HasLimits j k')+  => p :.: Limit j d :~> Limit j (p :.: d)+rightAdjointPreservesLimitsInv = limitUniv @j @k' @(p :.: d) (\((p :.: lim) :.: j) -> p :.: limit (lim :.: j))++leftAdjointPreservesColimits+  :: forall {k} {k'} {i} {a} (p :: k' +-> k) (d :: k +-> i) (j :: a +-> i)+   . (Adjunction p, Corepresentable d, HasColimits j k, HasColimits j k')+  => Colimit j (d :.: p) :~> Colimit j d :.: p+leftAdjointPreservesColimits colim@Objs =+  colimitUniv @j @k @d+    (\(j :.: (colim' :.: g')) -> case colimit @j @k' @(d :.: p) (j :.: colim') of d :.: f' -> rmap (coindex g' . index f') d)+    (colim :.: corepUniv @(RepCostar p))+    :.: repUniv @p++leftAdjointPreservesColimitsInv+  :: forall {k} {k'} {i} {a} (p :: k' +-> k) (d :: k +-> i) (j :: a +-> i)+   . (Corepresentable p, Corepresentable d, HasColimits j k, HasColimits j k')+  => Colimit j d :.: p :~> Colimit j (d :.: p)+leftAdjointPreservesColimitsInv = colimitUniv @j @k' @(d :.: p) (\(j :.: (colim :.: p)) -> colimit (j :.: colim) :.: p)
+ src/Proarrow/Category/Enriched.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Categories and profunctors enriched in a monoidal category @v@, encoded via their underlying+-- ordinary category\/profunctor: 'EnrichedProfunctor' equips a regular profunctor with hom-objects+-- @'ProObj' v p a b@ in @v@ from which the enriched structure is recovered, and a category is+-- 'Enriched' when its hom-profunctor is. Instances include the self-enrichment of a+-- 'Proarrow.Category.Monoidal.Closed.Closed' category.+module Proarrow.Category.Enriched where++import Data.Kind (Constraint, Type)++import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Proarrow.Category.Enriched.Finitary (Elt (..), Finitary, LocallyFinite)+import Proarrow.Category.Enriched.Thin+  ( CodiscreteProfunctor (..)+  , Decidable+  , DecidableProfunctor (..)+  , Decision (..)+  , Thin+  , ThinProfunctor (..)+  )+import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..))+import Proarrow.Category.Instance.Constraint (CONSTRAINT (..), (:-) (..))+import Proarrow.Category.Instance.FinHask (FINHASK (..))+import Proarrow.Category.Instance.FinHask qualified as F+import Proarrow.Category.Instance.Monoid (MONOID (..), Mon (..))+import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Prof (Prof)+import Proarrow.Category.Instance.Sub (SUBCAT (..), Sub (..))+import Proarrow.Category.Instance.Unit qualified as U+import Proarrow.Category.Monoidal (Monoidal (..), SymMonoidal (..), leftUnitorInvWith, rightUnitorInvWith)+import Proarrow.Category.Monoidal.Closed qualified as E+import Proarrow.Core (Any, CAT, CategoryOf (..), Hom, Kind, Profunctor ((\\)), Promonad (..), type (+->))+import Proarrow.Core qualified as P+import Proarrow.Limit.BinaryProduct (PROD, Prod)+import Proarrow.Monoid (Monoid (..))+import Proarrow.Profunctor.Instance.Exponential ()++-- | Working with enriched categories and profunctors in Haskell is hard.+-- Instead we encode them using the underlying regular category/profunctor,+-- and show that the enriched structure can be recovered.+--+-- Call an arrow @'Unit' '~>' x@ an /element/ of @x@. The laws say that the elements of+-- @'ProObj' v p a b@ are those of the hom-set @p a b@, and that its two actions are the+-- profunctor's:+--+-- [Elements] 'underlying' and 'enriched' are mutually inverse, so 'underlying' is a bijection from+-- @p a b@ onto the elements of @'ProObj' v p a b@.+--+-- [Right action] for @f :: b '~>' c@ in @j@ and @x :: p a b@, where @'underlying' f@ names @f@ as+-- an element of @'HomObj' v b c@:+--+-- > rmap . (underlying f ** underlying x) . leftUnitorInv == underlying (P.rmap f x)+--+-- [Left action] dually, for @g :: c '~>' a@ in @k@:+--+-- > lmap . (underlying g ** underlying x) . leftUnitorInv == underlying (P.lmap g x)+--+-- These fix 'rmap' and 'lmap' completely iff @v@ is well-pointed, as 'Type' and the thin @v@s are.+-- Functoriality follows from the 'Profunctor' instance. At @p ~ 'Hom' k@ the right-action law says+-- that the enriched composition 'comp' is @('.')@.+type EnrichedProfunctor :: forall {j} {k}. Kind -> j +-> k -> Constraint+class (Monoidal v, Profunctor p, Enriched v j, Enriched v k) => EnrichedProfunctor v (p :: j +-> k) where+  type ProObj v (p :: j +-> k) (a :: k) (b :: j) :: v+  withProObj :: (Ob (a :: k), Ob b) => ((Ob (ProObj v p a b)) => r) -> r+  underlying :: p a b -> Unit ~> ProObj v p a b+  enriched :: (Ob a, Ob b) => Unit ~> ProObj v p a b -> p a b+  rmap :: (Ob a, Ob b, Ob c) => HomObj v b c ** ProObj v p a b ~> ProObj v p a c+  lmap :: (Ob a, Ob b, Ob c) => HomObj v c a ** ProObj v p a b ~> ProObj v p c b++class (EnrichedProfunctor v (Hom k)) => Enriched v k+instance (EnrichedProfunctor v (Hom k)) => Enriched v k++type HomObj v (a :: k) (b :: k) = ProObj v (Hom k) a b++comp :: forall {k} v (a :: k) b c. (Enriched v k, Ob a, Ob b, Ob c) => HomObj v b c ** HomObj v a b ~> HomObj v a c+comp = rmap @v @(Hom k) @a @b @c++-- | Closed monoidal categories are enriched in themselves.+type HomSelf a b = a E.~~> b++underlyingSelf :: (E.Closed k) => (a :: k) ~> b -> Unit ~> HomSelf a b+underlyingSelf = E.mkExponential++enrichedSelf :: (E.Closed k, Ob (a :: k), Ob b) => Unit ~> HomSelf a b -> a ~> b+enrichedSelf = E.lower++compSelf :: forall {k} (a :: k) b c. (E.Closed k, Ob a, Ob b, Ob c) => HomSelf b c ** HomSelf a b ~> HomSelf a c+compSelf = E.comp @a @b @c++-- abusing SUBCAT Any as a cheap wrapper to prevent overlapping instances+type Clone k = SUBCAT (Any :: k -> Constraint)++-- | A monoid is a one object enriched category.+instance (Monoid (m :: k)) => EnrichedProfunctor (Clone k) (Mon :: CAT (MONOID (m :: k))) where+  type ProObj (Clone k) (Mon :: CAT (MONOID m)) M M = SUB m+  withProObj r = r+  underlying (Mon f) = Sub f+  enriched (Sub f) = Mon f+  rmap = Sub mappend+  lmap = Sub mappend++instance (Profunctor p) => EnrichedProfunctor Type p where+  type ProObj Type p a b = p a b+  withProObj r = r+  underlying p () = p+  enriched f = f ()+  rmap = E.uncurry P.rmap+  lmap = E.uncurry P.lmap++instance (DaggerProfunctor p) => EnrichedProfunctor (Type, Type) p where+  type ProObj (Type, Type) p a b = '(p a b, p b a)+  withProObj r = r+  underlying p = (\() -> p) :**: (\() -> dagger p)+  enriched (f :**: _) = f ()+  rmap = E.uncurry P.rmap :**: E.uncurry P.lmap+  lmap = E.uncurry P.lmap :**: E.uncurry P.rmap++instance (ThinProfunctor p, Thin j, Thin k) => EnrichedProfunctor CONSTRAINT (p :: j +-> k) where+  type ProObj CONSTRAINT p a b = CNSTRNT (HasArrow p a b)+  withProObj r = r+  underlying p = Entails \r -> withArr p r+  enriched (Entails f) = f arr+  rmap @a @b @c = Entails \r -> withArr @p (P.rmap (arr @(~>) @b @c) (arr @p @a @b)) r+  lmap @a @b @c = Entails \r -> withArr @p (P.lmap (arr @(~>) @c @a) (arr @p @a @b)) r++-- | A decidable thin profunctor is a profunctor enriched in the walking arrow: its hom-object is the+-- type-level 'Holds', an element of it is an arrow, and composition is conjunction.+instance (DecidableProfunctor p, Decidable j, Decidable k) => EnrichedProfunctor BOOL (p :: j +-> k) where+  type ProObj BOOL p a b = Holds p a b+  withProObj @a @b r = case decide @p @a @b of+    Yes _ -> r+    No -> r+  underlying p = toHolds p Tru+  enriched @a @b f = case decide @p @a @b of+    Yes x -> x+    No -> case f of {}+  rmap @a @b @c = case (decide @(Hom j) @b @c, decide @p @a @b) of+    (Yes g, Yes x) -> toHolds (P.rmap g x) Tru+    (No, _) -> fromFls (decide @p @a @c)+    (Yes _, No) -> fromFls (decide @p @a @c)+  lmap @a @b @c = case (decide @(Hom k) @c @a, decide @p @a @b) of+    (Yes g, Yes x) -> toHolds (P.lmap g x) Tru+    (No, _) -> fromFls (decide @p @c @b)+    (Yes _, No) -> fromFls (decide @p @c @b)++-- | @FLS@ is initial, and a decision tells us which object we are aiming at.+fromFls :: Decision p a b h -> Booleans FLS h+fromFls (Yes _) = F2T+fromFls No = Fls++-- | __A finitary profunctor is a profunctor enriched in finite sets.__ The hom-object is the+-- hom-set itself, which 'Elt' makes an object of 'FINHASK' out of nothing but the numbering, and the+-- whiskerings are the two 'dimap's.+instance (Finitary p, LocallyFinite j, LocallyFinite k) => EnrichedProfunctor FINHASK (p :: j +-> k) where+  type ProObj FINHASK p a b = FH (Elt p a b)+  withProObj r = r+  underlying x = F.arr (\() -> Elt x) \\ x+  enriched f = unElt (f F.! ())+  rmap @a = F.arr \(Elt g, Elt x) -> Elt (P.dimap (id @_ @a) g x)+  lmap @_ @b = F.arr \(Elt g, Elt x) -> Elt (P.dimap g (id @_ @b) x)++-- | The category of profunctors is enriched in itself: the hom-object is the internal hom+-- @p ':~>:' q@, an element of it is a natural transformation, and composition is the internal one.+-- Cartesian closed, hence the 'PROD' wrapper (@j '+->' k@\'s own tensor is Day convolution).+--+-- This self-enrichment is written the generic way, from 'HomSelf' and friends. Those apply to any+-- 'Closed' 'SymMonoidal' kind that has no enrichment instance of its own covering its+-- hom-profunctor.+instance (CategoryOf j, CategoryOf k) => EnrichedProfunctor (PROD (j +-> k)) (Prod (Prof :: CAT (j +-> k))) where+  type ProObj (PROD (j +-> k)) (Prod (Prof :: CAT (j +-> k))) p q = HomSelf p q+  withProObj r = r+  underlying = underlyingSelf+  enriched = enrichedSelf+  rmap = compSelf+  lmap = compSelf . swap++instance (CodiscreteProfunctor p) => EnrichedProfunctor () p where+  type ProObj () p a b = '()+  withProObj r = r+  underlying _ = U.Unit+  enriched U.Unit = anyArr+  rmap = U.Unit+  lmap = U.Unit++instance (EnrichedProfunctor v p) => EnrichedProfunctor (Clone v) (Op p) where+  type ProObj (Clone v) (Op p) (OP a) (OP b) = SUB (ProObj v p b a)+  withProObj @(OP a) @(OP b) r = withProObj @v @p @b @a r+  underlying (Op f) = Sub (underlying @v @p f)+  enriched (Sub f) = Op (enriched f)+  rmap @(OP a) @(OP b) @(OP c) = Sub (lmap @v @p @b @a @c)+  lmap @(OP a) @(OP b) @(OP c) = Sub (rmap @v @p @b @a @c)++-- | A generalized arrow of an enriched category. If @k@ is both powered and copowered, this is an adjunction.+type GenArrow :: OPPOSITE v -> k +-> k+data GenArrow n a b where+  GenArrow :: (Ob a, Ob b) => n ~> HomObj v a b -> GenArrow (OP n) a b++instance (Ob (n :: v), Enriched v k, CategoryOf k) => Profunctor (GenArrow (OP n) :: k +-> k) where+  dimap @c @a @b @d l r (GenArrow f) =+    GenArrow+      ( let g = comp @v @c @a @b . rightUnitorInvWith (underlying @v l) . f+        in comp @v @c @b @d . leftUnitorInvWith (underlying @v r) . g \\ g+      )+      \\ f+      \\ l+      \\ r+  r \\ GenArrow f = r \\ f
+ src/Proarrow/Category/Enriched/Dagger.hs view
@@ -0,0 +1,10 @@+-- | Dagger categories: a 'DaggerProfunctor' has an identity-on-objects involution+-- @'dagger' :: p a b -> p b a@, and a category is 'Dagger' when its hom-profunctor is one.+module Proarrow.Category.Enriched.Dagger where++import Proarrow.Core (Hom, Profunctor, type (+->))++class (Dagger k, Profunctor p) => DaggerProfunctor (p :: k +-> k) where+  dagger :: p a b -> p b a++type Dagger k = DaggerProfunctor (Hom k)
+ src/Proarrow/Category/Enriched/Finitary.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Profunctors whose hom-sets are finite and numbered: @p a b@ is in bijection with an initial+-- segment of the naturals. This makes limits and colimits computable: an element is an index, so a+-- subset or quotient of a hom-set is a table of indices, which can be reified into a fresh object.+--+-- The numbering is a /value/, as in "Proarrow.Category.Instance.FinHask". A type-level size could+-- only be a formula in the sizes it is built from, which rules out constructions whose count+-- depends on how arrows compose, such as the exponential and the subobject classifier.+--+-- A 'Proarrow.Category.Enriched.Thin.DecidableProfunctor' is the special case where every size is+-- zero or one; 'decidableSize' and 'decidableFromIndex' build that instance.+--+-- This module is only the vocabulary. The category @'Proarrow.Category.Enriched.Finitary.Topos.FINITARY' j k@+-- and everything computed in it live in "Proarrow.Category.Enriched.Finitary.Topos". The class+-- and 'Elt' are needed by 'Proarrow.Limit.Power.Powered', "Proarrow.Category.Enriched" and+-- others that the topos half itself depends on.+module Proarrow.Category.Enriched.Finitary where++import Data.Kind (Constraint)+import Data.List (elemIndex, find, genericIndex, genericTake)+import Data.Maybe (isJust)+import Data.Type.Nat (snat)+import Data.Type.Nat qualified as N+import Data.Universe.Class qualified as U+import Data.Universe.Helpers qualified as U+import Numeric.Natural (Natural)+import Prelude (Maybe (..), compare, show, (+), (-), (<), (==))+import Prelude qualified as P++import Proarrow.Category.Enriched.Thin+  ( DecidableProfunctor (..)+  , Decision (..)+  , Enumerable (..)+  , Finite (..)+  , Indexed (..)+  , IndexedList (..)+  )+import Proarrow.Category.Instance.Bool (Booleans)+import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))+import Proarrow.Category.Instance.Ordinal (LTE)+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Unit (Unit (..))+import Proarrow.Core (CategoryOf (..), Hom, Profunctor (..), Promonad (..), type (+->))+import Proarrow.Functor (FunctorForRep (..), withMappedOb)+import Proarrow.Profunctor.Corepresentable (Corep (..))+import Proarrow.Profunctor.Instance.Coproduct ((:+:) (..))+import Proarrow.Profunctor.Instance.Initial (InitialProfunctor)+import Proarrow.Profunctor.Instance.Product ((:*:) (..))+import Proarrow.Profunctor.Instance.Terminal (TerminalProfunctor (..))+import Proarrow.Tools.Laws (ProLaw (..), ProLaws (..), (=:=))++-- | A profunctor with finite, numbered hom-sets. 'toIndex' and 'fromIndex' are inverse for indices+-- below 'size'; @fromIndex@ of anything else is an error, as is 'toIndex' of an element that is not+-- one the instance can produce (which only an unlawfully built value can be).+--+-- An instance whose elements are found by searching should define 'elements' and read 'size' off+-- it, rather than let the default call 'fromIndex' once per element and repeat the search each time.+type Finitary :: forall {j} {k}. j +-> k -> Constraint+class (Profunctor p) => Finitary (p :: j +-> k) where+  -- | How many elements the hom-set has.+  size :: (Ob (a :: k), Ob (b :: j)) => Natural++  -- | Where an element sits in 'elements'. Takes its objects like the others do, so that an+  -- instance that has to search can bind the search outside the argument lambda and a caller can+  -- share it with @let toIndexP = 'toIndex' \@p \@a \@b@.+  toIndex :: (Ob (a :: k), Ob (b :: j)) => p a b -> Natural++  -- | The element at a position.+  fromIndex :: (Ob (a :: k), Ob (b :: j)) => Natural -> p a b++  -- | All elements of a hom-set, in index order.+  elements :: (Ob (a :: k), Ob (b :: j)) => [p a b]+  elements @a @b = P.map (fromIndex @p) (indices (size @p @a @b))++-- | 'fromIndex' recovers an element from its index. The other laws, that 'elements' has 'size'+-- entries numbered in order, are not equations between elements.+instance ProLaws Finitary where+  proLaws = [ProLaw "fromIndex . toIndex" \ @p @a @b p _ _ -> p =:= fromIndex @p @a @b (toIndex p)]++-- | @[0 .. n-1]@, which @n@ being a 'Natural' rules out writing directly.+indices :: Natural -> [Natural]+indices n = genericTake n [0 ..]++-- | A finitary profunctor's hom-set sizes, one per pair of objects, the outer index running over+-- @k@ and the inner over @j@. Cheap enough to display an object by: a presheaf on the graph+-- schema, say, shows as @[2,4,2,4]@.+sizes :: forall {j} {k} (p :: j +-> k). (Finitary p, Enumerable j, Enumerable k) => [Natural]+sizes = foreachOb @k \ @a -> foreachOb @j \ @b -> [size @p @a @b]++-- | The position of an object in its kind's object list.+objIndex :: forall {k} (a :: k). (Enumerable k, Ob a) => Natural+objIndex = withIndex @k @a (N.snatToNatural (snat @(Index a)))++-- | Everything an enumeration of a kind's objects can do at each of them, concatenated.+foreachOb :: forall k r. (Enumerable k) => (forall (a :: k). (Ob a) => [r]) -> [r]+foreachOb f = go (finite @k)+  where+    go :: forall (as :: [k]). IndexedList as -> [r]+    go FNil = []+    go (FCons @a as) = withOb @k @a (f @a) P.++ go as++-- * Thin profunctors++-- | A decidable profunctor has one element where it holds and none where it does not. These cannot+-- be @default@ method bodies: 'size' and 'fromIndex' do not mention their objects except in a+-- constraint, so GHC cannot tie a default body's objects to the instance's.+decidableSize :: forall {j} {k} (p :: j +-> k) (a :: k) (b :: j). (DecidableProfunctor p, Ob a, Ob b) => Natural+decidableSize = case decide @p @a @b of+  Yes _ -> 1+  No -> 0++decidableFromIndex+  :: forall {j} {k} (p :: j +-> k) (a :: k) (b :: j). (DecidableProfunctor p, Ob a, Ob b) => Natural -> p a b+decidableFromIndex _ = case decide @p @a @b of+  Yes x -> x+  No -> P.error "fromIndex: the profunctor does not hold here"++-- * Hom-sets as finite sets++-- | An element of a hom-set of @p@, viewed as an element of a /finite set/: every instance the+-- @universe@ package asks for is supplied by the numbering, with 'toIndex' standing in for equality+-- and ordering. So a finitary profunctor is a profunctor enriched in+-- 'Proarrow.Category.Instance.FinHask.FINHASK'.+newtype Elt (p :: j +-> k) (a :: k) (b :: j) = Elt {unElt :: p a b}++instance (Finitary p, Ob a, Ob b) => U.Universe (Elt (p :: j +-> k) a b) where+  universe = P.map Elt (elements @p)++instance (Finitary p, Ob a, Ob b) => U.Finite (Elt (p :: j +-> k) a b) where+  cardinality = U.Tagged (size @p @a @b)++instance (Finitary p) => P.Eq (Elt (p :: j +-> k) a b) where+  Elt x == Elt y = (toIndex x == toIndex y) \\ x++instance (Finitary p) => P.Ord (Elt (p :: j +-> k) a b) where+  compare (Elt x) (Elt y) = P.compare (toIndex x) (toIndex y) \\ x++instance (Finitary p) => P.Show (Elt (p :: j +-> k) a b) where+  show (Elt x) = P.show (toIndex x) \\ x++-- | A category whose hom-sets are finite: the 'Finitary' counterpart of+-- 'Proarrow.Category.Enriched.Thin.Decidable', and one half of 'FiniteCat'.+class (CategoryOf k, Finitary (Hom k)) => LocallyFinite k++instance (CategoryOf k, Finitary (Hom k)) => LocallyFinite k++-- | How an arrow factors through another into the same object: @'factorThrough' g f@ is an @h@+-- with @g = f '.' h@, if there is one. Only the hom-set @x '~>' y@ is searched, so only the+-- hom-sets need to be finite. An element is in the image of @f@ iff it factors through @f@.+factorThrough+  :: forall {k} (x :: k) y a. (LocallyFinite k, Ob x, Ob y, Ob a) => x ~> a -> y ~> a -> Maybe (x ~> y)+factorThrough g f = find (\h -> toIndex @(Hom k) @x @a (f . h) == gi) (elements @(Hom k) @x @y)+  where+    -- hoisted out of the lambda, as 'toIndex' asks: an instance that searches only searches once+    gi = toIndex g++-- | Whether an arrow factors through another, which is 'factorThrough' with the witness dropped.+-- 'Proarrow.Category.Enriched.Finitary.Sheaf.generatedSieve' is the caller: a cover's sieve is the+-- arrows that factor through one of its legs.+factorsThrough :: forall {k} (x :: k) y a. (LocallyFinite k, Ob x, Ob y, Ob a) => x ~> a -> y ~> a -> P.Bool+factorsThrough g f = isJust (factorThrough g f)++-- | A finite category: finitely many objects, and finitely many arrows between them. The first is+-- 'Enumerable', the second does not follow from it, and the enumeration below needs both.+class (Enumerable k, Finitary (Hom k)) => FiniteCat k++instance (Enumerable k, Finitary (Hom k)) => FiniteCat k++-- | A profunctor between categories with finite hom-sets is finitary iff it is enriched in finite+-- sets. These build a 'Finitary' instance from 'U.Finite' hom-sets, the counterparts of+-- 'decidableSize' and 'decidableFromIndex' one level up.+--+-- 'finiteToIndex' and 'finiteFromIndex' search 'U.universeF', which is fine for small hom-sets.+-- For large ones compute the index arithmetically, as+-- 'Proarrow.Category.Instance.FinHask.FinHask' does.+finiteSize :: forall {j} {k} (p :: j +-> k) (a :: k) (b :: j). (U.Finite (p a b)) => Natural+finiteSize = U.unTagged (U.cardinality @(p a b))++finiteToIndex :: forall {j} {k} (p :: j +-> k) (a :: k) (b :: j). (U.Finite (p a b), P.Eq (p a b)) => p a b -> Natural+finiteToIndex x = case elemIndex x U.universeF of+  Just i -> P.fromIntegral i+  Nothing -> P.error "toIndex: not in the universe of the hom-set"++finiteFromIndex :: forall {j} {k} (p :: j +-> k) (a :: k) (b :: j). (U.Finite (p a b)) => Natural -> p a b+finiteFromIndex i = genericIndex (U.universeF @(p a b)) i++-- | The one-object category has one arrow.+instance Finitary Unit where+  size = 1+  toIndex Unit = 0+  fromIndex _ = Unit++-- | @'Proarrow.Category.Instance.Bool.BOOL'@ is thin, so each hom-set holds at most the one arrow.+instance Finitary Booleans where+  size @a @b = decidableSize @Booleans @a @b+  toIndex _ = 0+  fromIndex @a @b = decidableFromIndex @Booleans @a @b++-- | The ordinals are thin too, so the same three lines serve. So a chain can be used as a site: a+-- cover there can have a leg that is itself covered, which no coverage on a two-object category+-- can arrange.+instance Finitary LTE where+  size @a @b = decidableSize @LTE @a @b+  toIndex _ = 0+  fromIndex @a @b = decidableFromIndex @LTE @a @b++-- * Products and coproducts++-- | The terminal profunctor has one element everywhere.+instance (CategoryOf j, CategoryOf k) => Finitary (TerminalProfunctor :: j +-> k) where+  size = 1+  toIndex TerminalProfunctor = 0+  fromIndex _ = TerminalProfunctor++-- | A pair of indices as one index, row-major: the first factor varies slowest. Shared by the two+-- instances that number a pair of independent choices (the product profunctor and the Yoneda+-- embedding), because 'ExpWeight' nests one inside the other, so they have to agree.+pairIndex :: Natural -> Natural -> Natural -> Natural+pairIndex n i j = i P.* n + j++-- | The inverse, given the size of the second factor.+unpairIndex :: Natural -> Natural -> (Natural, Natural)+unpairIndex 0 _ = P.error "fromIndex: a factor of the pair has no elements"+unpairIndex n i = i `P.divMod` n++instance (Finitary p, Finitary q) => Finitary (p :*: q) where+  size @a @b = size @p @a @b P.* size @q @a @b+  toIndex @a @b (x :*: y) = pairIndex (size @q @a @b) (toIndex x) (toIndex y)+  fromIndex @a @b i = let (l, r) = unpairIndex (size @q @a @b) i in fromIndex l :*: fromIndex r++  -- Spelled out, not left to the default: that would ask @p@ for its size once per element, and+  -- when @p@ is itself an enumeration ('Sieve', or a nested internal hom) a size is a whole search.+  elements @a @b = [x :*: y | x <- elements @p @a @b, y <- elements @q @a @b]++-- | The product of two finitary profunctors on the product of their kinds, numbered as ':*:' is.+instance (Finitary p, Finitary q) => Finitary (p :**: q) where+  size @'(a1, a2) @'(b1, b2) = size @p @a1 @b1 P.* size @q @a2 @b2+  toIndex @'(_, a2) @'(_, b2) (x :**: y) = pairIndex (size @q @a2 @b2) (toIndex x) (toIndex y)+  fromIndex @'(_, a2) @'(_, b2) i = let (l, r) = unpairIndex (size @q @a2 @b2) i in fromIndex l :**: fromIndex r+  elements @'(a1, a2) @'(b1, b2) = [x :**: y | x <- elements @p @a1 @b1, y <- elements @q @a2 @b2]++-- | A corepresentable over finite hom-sets is finitary, numbered as the hom-set @f '@' a ~> b@.+-- (It lives here and not with 'Corep': "Proarrow.Profunctor.Corepresentable" is below this module.)+instance (FunctorForRep f, LocallyFinite j) => Finitary (Corep (f :: k +-> j)) where+  size @a @b = withMappedOb @f @a (size @(Hom j) @(f @ a) @b)+  toIndex (Corep g) = toIndex g \\ g+  fromIndex @a @_ i = withMappedOb @f @a (Corep (fromIndex i))+  elements @a @b = withMappedOb @f @a (P.map Corep (elements @(Hom j) @(f @ a) @b))++-- | The opposite of a finitary profunctor is finitary, at the same sizes read the other way round.+-- Taking @p = 'Hom' k@ this makes @'OPPOSITE' k@ a 'FiniteCat' whenever @k@ is one, so everything+-- computed for a finite site is available on the opposite category too. (This instance lives here+-- rather than with 'Op' because "Proarrow.Category.Instance.Opposite" sits below this module in the+-- import graph.)+instance (Finitary p) => Finitary (Op p) where+  size @(OP a) @(OP b) = size @p @b @a+  toIndex @(OP a) @(OP b) (Op x) = toIndex @p @b @a x+  fromIndex @(OP a) @(OP b) i = Op (fromIndex @p @b @a i)+  elements @(OP a) @(OP b) = P.map Op (elements @p @b @a)++-- | The initial profunctor has no elements anywhere.+instance (CategoryOf j, CategoryOf k) => Finitary (InitialProfunctor :: j +-> k) where+  size = 0+  toIndex = \case {}+  fromIndex _ = P.error "fromIndex: the initial profunctor has no elements"++-- | The indices of @p@ first, then those of @q@.+instance (Finitary p, Finitary q) => Finitary (p :+: q) where+  size @a @b = size @p @a @b + size @q @a @b+  toIndex @a @b = \case+    InjL x -> toIndex x+    InjR y -> size @p @a @b + toIndex y+  fromIndex @a @b i = if i < size @p @a @b then InjL (fromIndex i) else InjR (fromIndex (i - size @p @a @b))
+ src/Proarrow/Category/Enriched/Finitary/Sheaf.hs view
@@ -0,0 +1,664 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+-- The instances on 'SHEAVES' are orphans for the reason "Proarrow.Category.Enriched.Finitary.Topos"+-- gives for its own: the kind is 'SUBCAT' of a predicate, and both come from other modules.+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Sheaves on a finite site, decided by enumeration.+--+-- A site is a category where each object @a@ has some /covers/: families of arrows into @a@. A+-- profunctor is a sheaf when an element at @a@ is the same thing as a /matching family/ on a+-- cover: one element at the source of each leg, agreeing wherever two legs overlap. With finitely+-- many objects and elements both sides can be listed, and 'sheafAt' compares the two lists. They+-- must agree as multisets. Equal lengths are not enough: a presheaf can have as many elements as+-- matching families and still not be a sheaf.+--+-- A cover of @a@ generates a 'Sieve', the arrows into @a@ that factor through a leg, and the+-- matching families are the natural transformations out of it ('withSieve').+--+-- The coverage also gives a closure on sieves ('closure', 'lawvereTierney'), truth values+-- ('ClosedSieve') and a sheafification ('Sheafify') with its unit and universal property. All of+-- them are computed, so they too can be enumerated and compared, and together they make 'SHEAVES'+-- an elementary topos.+module Proarrow.Category.Enriched.Finitary.Sheaf where++import Data.List (find, genericIndex, genericLength, sort)+import Data.Map.Strict qualified as M+import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe)+import Numeric.Natural (Natural)+import Prelude (type (~))+import Prelude qualified as P++import Proarrow.Category.Enriched.Finitary+  ( Finitary (..)+  , FiniteCat+  , LocallyFinite+  , factorThrough+  , factorsThrough+  , foreachOb+  )+import Proarrow.Category.Enriched.Finitary.Topos+  ( FINITARY+  , KnownTables+  , Reindex+  , Retabulation (..)+  , Tabulated+  , coequalizeNat+  , equalizeNat+  , factorThroughEqualizer+  , familyIndex+  , fromTabulated+  , graphSieve+  , natDomain+  , natElements+  , natIndex+  , natKey+  , natPositionsBy+  , natTable+  , preimageMaybe+  , sieveTable+  , toTabulated+  , withSubobject+  , withTables+  )+import Proarrow.Category.Enriched.Thin (Enumerable)+import Proarrow.Category.Instance.Opposite (OPPOSITE (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Instance.Sub (SUBCAT (..), Sub (..))+import Proarrow.Category.Sheaf+  ( Coverage+  , Factors (..)+  , HasFiniteCovers (..)+  , PulledBack (..)+  , Sheaf (..)+  , Site (..)+  , SomeCover (..)+  , SomeLeg (..)+  , StableSite (..)+  )+import Proarrow.Category.Topos (ElementaryTopos, HasEpiMonoFactorization, HasSubobjectClassifier (..))+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..))+import Proarrow.Colimit.Coequalizer (HasCoequalizers (..))+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Colimit.Pushout (HasPushouts (..))+import Proarrow.Core+  ( CategoryOf (..)+  , Kind+  , OB+  , Profunctor (..)+  , Promonad (..)+  , UN+  , (//)+  , (\\)+  , type (+->)+  , type (:&&:)+  , type (:~>)+  )+import Proarrow.Limit.BinaryProduct (PROD (..), Prod (..))+import Proarrow.Limit.Equalizer (HasEqualizers (..))+import Proarrow.Limit.Pullback (HasPullbacks)+import Proarrow.Profunctor.Instance.Coproduct ((:+:) (..))+import Proarrow.Profunctor.Instance.Exponential ((:~>:) (..))+import Proarrow.Profunctor.Instance.Initial (InitialProfunctor)+import Proarrow.Profunctor.Instance.Sieve (Sieve (..), maximalSieve, sieveMeet)+import Proarrow.Profunctor.Instance.Terminal (TerminalProfunctor (..))+import Proarrow.Profunctor.Instance.Yoneda (Yo (..))++-- * Sieves and their closure++-- | The sieve a cover generates at @(a, b)@: the arrows into @a@ that factor through a leg,+-- paired with every arrow out of @b@.+generatedSieve+  :: forall t {j} {k} (a :: k) (b :: j) c+   . (Site t k, LocallyFinite k, CategoryOf j, Ob a, Ob b)+  => Cover t k a c+  -> Sieve a b+generatedSieve c = Sieve \g _ -> P.any (\(SomeLeg l) -> let f = legArrow l in factorsThrough g f \\ f \\ g) (legs c)++-- | Whether a sieve is the maximal one, containing every arrow of the category.+isMaximal :: forall {j} {k} (a :: k) (b :: j). (FiniteCat j, FiniteCat k) => Sieve a b -> P.Bool+isMaximal s = P.and (sieveTable s)++-- | Whether every point of the second sieve is a point of the first.+contains :: forall {j} {k} (a :: k) (b :: j). (FiniteCat j, FiniteCat k) => Sieve a b -> Sieve a b -> P.Bool+contains s = \s' -> P.and (P.zipWith (\x y -> P.not y P.|| x) ts (sieveTable s'))+  where+    -- tabulated before the second sieve arrives, so a partial application tabulates @s@ once+    ts = sieveTable s++-- | Whether a sieve is covering: either it is the maximal sieve, or it contains the sieve that some+-- cover of its object generates. A sieve is closed under composition, so that amounts to+-- containing the cover's legs ('coveringCover').+--+-- This takes the coverage at face value. It agrees with the Grothendieck topology the coverage+-- generates only when the covers are stable and compose. When they do not, 'closure' stops being+-- idempotent, which 'Proarrow.Testing.Laws.testLawvereTierney' detects.+isCovering+  :: forall t {j} {k} (a :: k) (b :: j)+   . (HasFiniteCovers t k, FiniteCat j, FiniteCat k)+  => Sieve a b+  -> P.Bool+isCovering s = isMaximal s P.|| isJust (coveringCover @t s)++-- | The first listed cover all of whose legs lie in the sieve, if there is one. Both 'isCovering'+-- and 'extendPlus' use this search. It needs no tabulation, since whether a sieve contains the+-- legs at the identity decides whether it contains everything they generate.+--+-- This relies on the closure that "Proarrow.Profunctor.Instance.Sieve" does not enforce. On a+-- hand-built predicate that is not a sieve it can say yes where comparing the whole generated+-- sieve says no.+coveringCover+  :: forall t {j} {k} (a :: k) (b :: j)+   . (HasFiniteCovers t k, CategoryOf j)+  => Sieve a b+  -> P.Maybe (SomeCover t k a)+coveringCover (Sieve s) = find (\(SomeCover c) -> P.all (\(SomeLeg l) -> s (legArrow l) id) (legs c)) (covers @t @k @a)++-- | The Lawvere–Tierney closure of a sieve: the pairs @(g, h)@ along which it pulls back to a+-- covering one. A sieve is covering iff its closure is the maximal sieve.+--+-- This uses @'dimap' g h@, not @'lmap' g@. A coverage constrains only the contravariant side, but+-- a sieve over @j '+->' k@ has two sides, and 'closure' has to be natural in both.+closure+  :: forall t {j} {k} (a :: k) (b :: j)+   . (HasFiniteCovers t k, FiniteCat j, FiniteCat k)+  => Sieve a b+  -> Sieve a b+closure s@Sieve{} = Sieve \g h -> isCovering @t (dimap g h s) \\ g \\ h++-- | Whether a sieve is /closed/ for the topology, i.e. equal to its own 'closure'. These are the+-- truth values of the sheaf topos, as the sieves are of the presheaf one (see 'ClosedSieve').+isClosed+  :: forall t {j} {k} (a :: k) (b :: j)+   . (HasFiniteCovers t k, FiniteCat j, FiniteCat k)+  => Sieve a b+  -> P.Bool+isClosed s = sieveTable (closure @t s) P.== sieveTable s++-- | The coverage as a Lawvere–Tierney topology on the topos of finitary profunctors: 'closure', as+-- an arrow on the subobject classifier.+lawvereTierney+  :: forall t j k. (HasFiniteCovers t k, FiniteCat j, FiniteCat k) => (Omega :: PROD (FINITARY j k)) ~> Omega+lawvereTierney = Prod (Sub (Prof \s@Sieve{} -> closure @t s))++-- * Deciding the sheaf condition++-- | Whether a finitary profunctor is a sheaf for the coverage: at every pair of objects and every+-- cover, restriction is a bijection from the elements at the covered object to the matching+-- families on the sieve the cover generates.+isSheaf+  :: forall t {j} {k} (p :: j +-> k)+   . (HasFiniteCovers t k, Finitary p, FiniteCat j, FiniteCat k)+  => P.Bool+isSheaf =+  P.and+    ( foreachOb @k \ @a ->+        let cs = covers @t @k @a -- does not depend on @b@, so bound outside the inner walk+        in foreachOb @j \ @b -> [sheafAt @t @p @a @b c | SomeCover c <- cs]+    )++-- | The sheaf condition at one cover: the restrictions of the elements at the covered object are+-- the matching families on the sieve it generates, as multisets.+sheafAt+  :: forall t {j} {k} (p :: j +-> k) (a :: k) (b :: j) c+   . (Site t k, Finitary p, FiniteCat j, FiniteCat k, Ob a, Ob b)+  => Cover t k a c+  -> P.Bool+sheafAt c = withSieve (generatedSieve @t @a @b c) \ @q incl ->+  sort [natTable @q @p (\y -> case incl y of Yo g h -> dimap g h x) | x <- elements @p @a @b]+    P.== sort (natElements @q @p)++-- | A sieve as a subobject of the representable @'Yo' a ('OP' b)@, handed on with its inclusion.+-- A natural transformation out of it picks an element for every arrow in the sieve, compatibly+-- with precomposition, which is what a matching family on the sieve is. 'sheafAt' and 'Plus' both+-- define matching families this way.+--+-- The error branch is unreachable for any coverage, since 'generatedSieve' and 'leastDenseSieve'+-- always give real sieves. Reaching it would take a 'Finitary' instance on the hom-profunctor+-- whose 'elements' omits an arrow, which 'Proarrow.Testing.Laws.testFinitary' rules out.+withSieve+  :: forall {j} {k} (a :: k) (b :: j) r+   . (FiniteCat j, FiniteCat k)+  => Sieve a b+  -> (forall q. (Finitary q) => (q :~> Yo a (OP b)) -> r)+  -> r+withSieve (Sieve s) k =+  withSubobject @(Yo a (OP b))+    (\(Yo g h) -> s g h)+    (\ @q (Sub (Prof incl)) -> k @q incl)+    (P.error "withSieve: not a sieve")++-- * Presenting a sheaf by its tables++-- | Present a finitary profunctor by its tables, as+-- 'Proarrow.Category.Enriched.Finitary.Topos.withTabulated' does, tagged with the coverage so that+-- it has a 'Sheaf' instance. That instance is decided here by 'isSheaf'; the failure continuation+-- is taken when @p@ is no sheaf for @t@.+--+-- This makes a sheaf with no 'Sheaf' instance of its own (a representable, a sheafification) an+-- object of 'SHEAVES'. Deciding on the tables is also cheaper than on @p@: a 'Sheafify' answers+-- each 'toIndex' by re-running the plus construction.+withTabulatedSheaf+  :: forall t {j} {k} (p :: j +-> k) r+   . (HasFiniteCovers t k, Finitary p, FiniteCat j, FiniteCat k)+  => ( forall {lm} {rm} (tab :: j +-> k)+        . (tab ~ Tabulated t lm rm, KnownTables j k lm rm, Sheaf t tab)+       => (p :~> tab)+       -> (tab :~> p)+       -> r+     )+  -> r+  -> r+withTabulatedSheaf ok notSheaf = withTables @p \ @lm @rm ->+  if isSheaf @t @(Tabulated t lm rm :: j +-> k)+    then ok @(Tabulated t lm rm) toTabulated fromTabulated+    else notSheaf++-- | 'withTabulatedSheaf' for a profunctor that already is a 'Sheaf', so there is nothing to decide.+-- The colimits below present their apex, a 'Sheafify', with this, because an unpresented+-- 'Sheafify' re-runs the whole plus construction each time the continuation asks for elements.+withSheafTables+  :: forall t {j} {k} (p :: j +-> k) r+   . (Sheaf t p, Finitary p, FiniteCat j, FiniteCat k)+  => ( forall {lm} {rm} (tab :: j +-> k)+        . (tab ~ Tabulated t lm rm, KnownTables j k lm rm, Sheaf t tab)+       => (p :~> tab)+       -> (tab :~> p)+       -> r+     )+  -> r+withSheafTables ok = withTables @p \ @lm @rm -> ok @(Tabulated t lm rm) toTabulated fromTabulated++-- * Descent++-- | Extend a /partial/ natural transformation into a sheaf to a total one. Where @f@ is undefined+-- at an element @y@, it must be defined on the restrictions of @y@ along the legs of some listed+-- cover, and those values are glued in @q@. Only this one level of descent is tried.+--+-- 'extendPlus' is this at @'Plus' t p@. The colimits below need it because an epimorphism of+-- sheaves is only /locally/ onto: an element may have no preimage while its restrictions along a+-- cover all do.+--+-- 'glue' is lawful here when @f@ commutes with restriction where it is defined. For the callers+-- below that means the arrow being factored is constant on the fibres it factors through.+factorLocally+  :: forall t {j} {k} (p :: j +-> k) q+   . (HasFiniteCovers t k, CategoryOf j, Profunctor p, Sheaf t q)+  => (forall c d. (Ob c, Ob d) => p c d -> P.Maybe (q c d))+  -> p :~> q+factorLocally f y =+  y // case f y of+    P.Just v -> v+    P.Nothing -> case coveringCover @t (domainSieve y) of+      P.Just (SomeCover c) ->+        -- the error is unreachable: 'coveringCover' returned this cover by testing these same legs+        glue @t c \l -> fromMaybe (P.error "factorLocally: a leg outside the domain") (f (lmap (legArrow l) y) \\ legArrow l)+      P.Nothing -> P.error "factorLocally: the partial transformation is not defined on a cover of this element"+  where+    -- where the partial function is defined on restrictions of @y@. This is a sieve, since a+    -- restriction of a restriction is one. Taking the element as an argument pins its objects.+    domainSieve :: forall (a :: k) (b :: j). (Ob a, Ob b) => p a b -> Sieve a b+    domainSieve x = Sieve \g _ -> isJust (f (lmap g x)) \\ g++-- | Factor through a map that is onto only locally: @'factorLocally'@ of the preimage search.+-- Where 'Proarrow.Category.Enriched.Finitary.Topos.factorThroughCoequalizer' asks the map to be+-- onto, this asks only what being epi in the sheaves gives.+--+-- A pushout needs this for its pair of injections, which are jointly locally onto but not+-- separately. That case is this at the coproduct, since two arrows into an object are one arrow+-- out of @a ':+:' b@. One search over that is also one 'toIndex' of the element instead of two.+factorThroughLocalEpi+  :: forall t {j} {k} (c :: j +-> k) x c'+   . (HasFiniteCovers t k, CategoryOf j, Finitary c, Finitary x, Sheaf t c')+  => (x :~> c)+  -> (x :~> c')+  -> c :~> c'+factorThroughLocalEpi proj h = factorLocally @t \y -> P.fmap h (preimageMaybe proj y)++-- * Sheafification++-- | One step of the plus construction for the topology @t@. A 'Plus' value is a matching family on+-- some dense sieve, given as a partial function: it is defined at @(g, h)@ iff that pair is in the+-- sieve ('support'), so the sieve cannot disagree with the family. Two values are the same+-- element when they agree on a dense sieve. Intuitively an element at @a@ is an element of @p@+-- given locally: pieces on a cover of @a@ that agree on overlaps.+--+-- On a finite site whose covers compose ('HasFiniteCovers'\'s Composition law) there is a least+-- dense sieve, 'leastDenseSieve', and each element has one family on it. A value is identified by+-- its restriction there ('plusTable'), which is what 'Finitary' numbers and "Proarrow.Testing"+-- compares, so no quotient is needed. 'leastDenseSieve' fails loudly where the law does not hold.+--+-- __The constructor does not check__ that the support is a dense sieve or that the family is+-- matching. 'plusElements' builds only lawful values; one built by hand is its builder's+-- responsibility.+type Plus :: forall {j} {k}. Coverage -> j +-> k -> j +-> k+data Plus t p a b where+  Plus :: (Ob a, Ob b) => (forall c d. c ~> a -> b ~> d -> P.Maybe (p c d)) -> Plus t p a b++instance (CategoryOf j, CategoryOf k) => Profunctor (Plus t p :: j +-> k) where+  dimap l r (Plus f) = l // r // Plus \g h -> f (l . g) (h . r)+  r \\ Plus{} = r++-- | The sieve a value is defined on.+support :: Plus t p :~> Sieve+support (Plus f) = Sieve \g h -> isJust (f g h)++-- | Whether a sieve is dense for the topology: its 'closure' is the maximal sieve. On a lawful+-- coverage this agrees with 'isCovering' ('Proarrow.Testing.Laws.testDenseIsCovering' checks+-- that). But density is the stable notion, and 'Plus' needs stability, since 'dimap' pulls a+-- support back along arrows.+isDense+  :: forall t {j} {k} (a :: k) (b :: j)+   . (HasFiniteCovers t k, FiniteCat j, FiniteCat k)+  => Sieve a b+  -> P.Bool+isDense s = isMaximal (closure @t s)++-- | The meet of all the dense sieves at a pair of objects. When the covers compose, 'closure'+-- preserves meets, so this is the least dense sieve. Restriction to it picks one matching family+-- out of each element of 'Plus'. On a coverage whose covers pull back but do not compose the meet+-- need not be dense, and then this errors, naming the law that failed, instead of letting 'Plus'+-- compute on it. The smallest example is a poset @w ≤ x ≤ a@, @w ≤ y ≤ a@ with @a@ covered by @x@+-- and by @y@ separately and each of those by @w@.+leastDenseSieve+  :: forall t {j} {k} (a :: k) (b :: j)+   . (HasFiniteCovers t k, FiniteCat j, FiniteCat k, Ob a, Ob b)+  => Sieve a b+leastDenseSieve+  | isDense @t s = s+  | P.otherwise = P.error "leastDenseSieve: the dense sieves have no least one -- the covers do not compose"+  where+    s = P.foldr sieveMeet maximalSieve (P.filter (isDense @t) (elements @(Sieve :: j +-> k) @a @b))++-- | The elements of 'Plus' at a pair of objects: the matching families on the least dense sieve, in+-- the order 'natElements' lists them.+plusElements+  :: forall t {j} {k} (p :: j +-> k) (a :: k) (b :: j)+   . (HasFiniteCovers t k, Finitary p, FiniteCat j, FiniteCat k, Ob a, Ob b)+  => [Plus t p a b]+plusElements = withSieve (leastDenseSieve @t @a @b) \ @q incl ->+  -- the sieve's points as points of the representable, at the positions a row lists them+  let pos = natPositionsBy @q \y -> natKey (incl y)+  in [ Plus \g h -> g // h // P.fmap (fromIndex @p P.. (row P.!!)) (M.lookup (natKey (Yo g h)) pos)+     | row <- natElements @q @p+     ]++-- | A value restricted to a sieve reified as a subobject: the natural transformation out of it+-- that the value's family is.+restrictTo+  :: forall {j} {k} q (a :: k) (b :: j) t (p :: j +-> k)+   . (q :~> Yo a (OP b))+  -> Plus t p a b+  -> q :~> p+restrictTo incl (Plus f) y = case incl y of+  Yo g h ->+    fromMaybe (P.error "restrictTo: the sieve is not inside the support -- see HasFiniteCovers's Composition law") (f g h)++-- | A value's restriction to the least dense sieve, as its 'natTable': the indices of its values+-- at that sieve's points. See 'Plus' for what that determines.+plusTable+  :: forall t {j} {k} (p :: j +-> k) (a :: k) (b :: j)+   . (HasFiniteCovers t k, Finitary p, FiniteCat j, FiniteCat k)+  => Plus t p a b+  -> [Natural]+plusTable x@Plus{} = withSieve (leastDenseSieve @t @a @b) \ @q incl -> natTable @q @p (restrictTo incl x)++-- | Whether two values stand for the same element: their restrictions to the least dense sieve+-- agree. This builds one sieve for the pair, where two 'plusTable's would each build their own.+-- "Proarrow.Testing"\'s equality on 'Plus' uses it, since it compares far more often than it shows.+samePlus+  :: forall t {j} {k} (p :: j +-> k) (a :: k) (b :: j)+   . (HasFiniteCovers t k, Finitary p, FiniteCat j, FiniteCat k)+  => Plus t p a b+  -> Plus t p a b+  -> P.Bool+samePlus x@Plus{} y = withSieve (leastDenseSieve @t @a @b) \ @q incl ->+  -- one walk for the pair, and one 'toIndex' per point: at 'Sheafify' that is itself an enumeration+  P.and+    (natDomain @q @P.Bool \ @c @d z -> let ix = toIndex @p @c @d in ix (restrictTo incl x z) P.== ix (restrictTo incl y z))++-- | Numbered by 'plusElements', as the internal hom is numbered by the natural transformations+-- out of its weight.+instance (HasFiniteCovers t k, Finitary p, FiniteCat j, FiniteCat k) => Finitary (Plus t p :: j +-> k) where+  size @a @b = genericLength (plusElements @t @p @a @b)++  -- above the argument lambda: the sieve too, not just 'natIndex'\'s enumeration+  toIndex @a @b = withSieve (leastDenseSieve @t @a @b) \ @q incl ->+    let ix = natIndex @q @p "toIndex: not natural on the least dense sieve"+    in \x -> ix (restrictTo incl x)+  fromIndex @a @b = genericIndex (plusElements @t @p @a @b)+  elements @a @b = plusElements @t @p @a @b++-- | Sheafification: the plus construction twice. One 'Plus' makes a profunctor /separated/ (two+-- elements with the same restrictions to a dense sieve are equal), and the second makes it a+-- sheaf. The first alone need not: the constant presheaf with two values on the discrete two-point+-- space has one section over the empty set after one plus, but still two over the whole space+-- where a sheaf needs four. On a site whose covers have no overlaps, such as+-- 'Proarrow.Category.Sheaf.Atomic' on the walking arrow, one plus is already a sheaf and the+-- second changes nothing.+type Sheafify :: forall {j} {k}. Coverage -> j +-> k -> j +-> k+type Sheafify t p = Plus t (Plus t p)++-- | The unit of the plus construction: an element as the family of its own restrictions, on the+-- maximal sieve.+unitPlus :: forall t {j} {k} (p :: j +-> k). (Profunctor p) => p :~> Plus t p+unitPlus x = Plus (\g h -> P.Just (dimap g h x)) \\ x++-- | 'unitPlus' twice: the unit of sheafification.+unitSheafify :: forall t {j} {k} (p :: j +-> k). (Profunctor p) => p :~> Sheafify t p+unitSheafify x = unitPlus @t (unitPlus @t x)++-- | The universal property, one plus at a time: a map into a sheaf extends along 'unitPlus'. A+-- dense support is either everything, and then the family is read off at the identity, or it+-- contains the legs of some listed cover (density at the identity says so, and 'coveringCover'+-- finds it), and then the family restricted to those legs glues. Since @q@ is a sheaf, it does not+-- matter which cover is found. @q@ need not be 'Finitary'; only gluing is asked of it.+extendPlus+  :: forall t {j} {k} (p :: j +-> k) q+   . (HasFiniteCovers t k, Sheaf t q)+  => (p :~> q) -> Plus t p :~> q+extendPlus n = factorLocally @t \(Plus f) -> P.fmap n (f id id)++-- | Gluing for the plus construction: a matching family over a cover, assembled into one value.+-- At @(g, h)@ it takes the first leg @l@ with @g = l . u@ ('factorThrough') whose family is+-- defined at @(u, h)@. The support of the result is generated by the legs' supports, so it is dense+-- by 'Proarrow.Category.Sheaf.HasFiniteCovers'\'s Composition law. For a matching family the choice+-- of leg and factorisation does not matter, and 'glue' promises nothing on others.+gluePlus+  :: forall t {j} {k} (q :: j +-> k) (a :: k) c (b :: j)+   . (Site t k, LocallyFinite k, Ob a, Ob b)+  => Cover t k a c+  -> (forall x. Leg t k a c x -> Plus t q x b)+  -> Plus t q a b+gluePlus c m =+  let ls = legs c+  in Plus \g h ->+       -- matching @Plus f@ is what brings the leg's source into scope, as 'plusTable' also relies on+       g // listToMaybe (mapMaybe (\(SomeLeg l) -> case m l of Plus f -> factorThrough g (legArrow l) P.>>= \u -> f u h) ls)++-- | Sheafification lands in the sheaves (@'isSheaf' \@t \@('Sheafify' t p)@ confirms it by+-- enumeration), so a 'Sheafify' can be used wherever a 'Sheaf' is asked for.+--+-- 'gluePlus' is lawful only on a /separated/ @q@, which @'Plus' t p@ always is, hence the double+-- plus in the head. The also true @'Sheaf' t p => 'Sheaf' t ('Plus' t p)@ would overlap this+-- instance with neither more specific.+instance (Site t k, LocallyFinite k, CategoryOf j) => Sheaf t (Sheafify t (p :: j +-> k)) where+  glue = gluePlus @t++-- | 'extendPlus' twice: a map into a sheaf extends along 'unitSheafify'.+extendSheafify+  :: forall t {j} {k} (p :: j +-> k) q+   . (HasFiniteCovers t k, Sheaf t q)+  => (p :~> q) -> Sheafify t p :~> q+extendSheafify n = extendPlus @t (extendPlus @t n)++-- * The truth values of the topos++-- | A sieve equal to its own 'closure'. These are the truth values of the sheaves for @t@, as all+-- sieves are of the presheaves. A subsheaf @s@ of @p@ sends an element @x@ to the sieve of pairs+-- @(g, h)@ with @'dimap' g h x@ in @s@. That sieve is closed: if the restrictions of @x@ along a+-- cover are in @s@, gluing puts @x@ in @s@.+--+-- It is a newtype because the object has to be nameable, and the equalizer of 'lawvereTierney'+-- and the identity on 'Omega' ('equalizeNat') binds its table existentially.+--+-- It is the classifier only when the coverage is a Grothendieck topology ('HasFiniteCovers'\'s+-- Composition law, checked by 'Proarrow.Testing.Laws.testLawvereTierney_'). Otherwise it quietly+-- computes something else, while 'leastDenseSieve' fails loudly.+--+-- __The constructor checks nothing.__ 'elements' produces only closed sieves, and 'closedSieve'+-- closes any sieve.+type ClosedSieve :: forall {j} {k}. Coverage -> j +-> k+newtype ClosedSieve t (a :: k) (b :: j) = ClosedSieve (Sieve a b)++-- | Closure commutes with 'dimap' (the Lawvere–Tierney axiom that 'lawvereTierney' packages as an+-- arrow on 'Omega'), so a restriction of a closed sieve is closed.+instance (CategoryOf j, CategoryOf k) => Profunctor (ClosedSieve t :: j +-> k) where+  dimap l r (ClosedSieve s) = ClosedSieve (dimap l r s)+  x \\ ClosedSieve s = x \\ s++-- | The closed sieves at a pair of objects, in the order 'Sieve' lists them.+closedSieves+  :: forall t {j} {k} (a :: k) (b :: j)+   . (HasFiniteCovers t k, FiniteCat j, FiniteCat k, Ob a, Ob b)+  => [ClosedSieve t a b]+closedSieves = [ClosedSieve s | s <- elements @(Sieve :: j +-> k) @a @b, isClosed @t s]++instance (HasFiniteCovers t k, FiniteCat j, FiniteCat k) => Finitary (ClosedSieve t :: j +-> k) where+  size @a @b = genericLength (closedSieves @t @a @b)++  -- the closed ones are found by filtering every sieve, so that walk is bound outside the lambda+  toIndex @a @b =+    let tables = P.map (\(ClosedSieve s) -> sieveTable s) (closedSieves @t @a @b)+    in \(ClosedSieve s) -> familyIndex "toIndex: not a closed sieve" tables (sieveTable s)+  fromIndex @a @b = genericIndex (closedSieves @t @a @b)+  elements @a @b = closedSieves @t @a @b++-- | Whether an arrow pair is in a closed sieve.+inClosedSieve :: forall {j} {k} t (a :: k) (b :: j) c d. ClosedSieve t a b -> c ~> a -> b ~> d -> P.Bool+inClosedSieve (ClosedSieve (Sieve s)) g h = s g h++-- | The classifier is a sheaf, with gluing built directly: the glued sieve contains @g@ iff every+-- leg of the cover pulled back along @g@ is in the sieve of the family member it factors through.+-- Anything in the glued sieve passes this test, since sieves are closed under precomposition, and+-- anything that passes is in it, since the sieves are /closed/.+instance (StableSite t k, CategoryOf j) => Sheaf t (ClosedSieve t :: j +-> k) where+  glue c m =+    ClosedSieve+      ( Sieve \g h ->+          g // case pullbackCover c g of+            AlreadyFactors (Factors l u) -> inClosedSieve (m l) u h+            PulledBack c' factorsThroughLeg ->+              P.all (\(SomeLeg l') -> case factorsThroughLeg l' of Factors l u -> inClosedSieve (m l) u h) (legs c')+      )++-- | Any sieve as a closed one: 'lawvereTierney' corestricted to its fixed points, which is the+-- reflection of the presheaf classifier onto the sheaf one.+closedSieve+  :: forall t {j} {k} (a :: k) (b :: j)+   . (HasFiniteCovers t k, FiniteCat j, FiniteCat k)+  => Sieve a b+  -> ClosedSieve t a b+closedSieve s = ClosedSieve (closure @t s)++-- * The category of sheaves++-- | The full subcategory of @'FINITARY' j k@ on the sheaves for @t@. Finite limits and the+-- exponential are 'FINITARY'\'s, and are sheaves by the closure instances ('TerminalProfunctor',+-- ':*:', 'Proarrow.Category.Enriched.Finitary.Topos.Reindex', ':~>:'). Colimits are 'FINITARY'\'s+-- followed by 'Sheafify', since a quotient of sheaves need not be a sheaf, and their universal+-- property uses 'factorLocally', since an epi of sheaves is onto only locally.+-- @'Proarrow.Category.Topos.Omega'@ is 'ClosedSieve'.+type SHEAVES :: Coverage -> Kind -> Kind -> Kind+type SHEAVES t j k = SUBCAT ((Finitary :&&: Sheaf t) :: OB (j +-> k))++-- | A sheaf as an object of 'SHEAVES', as 'Proarrow.Category.Enriched.Finitary.Topos.FIN' names+-- an object of 'FINITARY'.+type SHF :: forall {j} {k}. forall (t :: Coverage) -> (j +-> k) -> SHEAVES t j k+type SHF t (p :: j +-> k) = SUB p :: SHEAVES t j k++-- | Equalizers as in 'FINITARY', by 'equalizeNat'; the result is a sheaf for every coverage, which+-- 'Proarrow.Testing.Laws.testEqualizersAreSheaves' checks by enumeration.+instance (Site t k, Enumerable j, Enumerable k) => HasEqualizers (SHEAVES t j k) where+  equalize (Sub (Prof f)) (Sub (Prof g)) k = equalizeNat f g \incl -> k (Sub (Prof incl))+  factorEqualizer (Sub (Prof incl)) (Sub (Prof h)) = Sub (Prof (factorThroughEqualizer incl h))++instance (Site t k, Enumerable j, Enumerable k) => HasPullbacks (SHEAVES t j k)++-- | Colimits are the presheaf colimits, sheafified: take the 'FINITARY' colimit, follow its cocone+-- with 'unitSheafify', and get the universal property from 'extendSheafify'. This works because+-- sheafification is a left adjoint.+--+-- The initial sheaf need not be the initial presheaf. 'Proarrow.Category.Sheaf.Joins' covers the+-- bottom of a lattice by the empty family, so every sheaf has one section there.+instance (HasFiniteCovers t k, FiniteCat j, FiniteCat k) => HasInitialObject (SHEAVES t j k) where+  type InitialObject @(SHEAVES t j k) = SUB (Sheafify t InitialProfunctor)+  initiate @(SUB q) = case initiate @(j +-> k) @q of Prof n -> Sub (Prof (extendSheafify @t n))++instance (HasFiniteCovers t k, FiniteCat j, FiniteCat k) => HasBinaryCoproducts (SHEAVES t j k) where+  type (||) @(SHEAVES t j k) a b = SUB (Sheafify t (UN SUB a :+: UN SUB b))+  withObCoprod r = r+  lft = Sub (Prof \x -> unitSheafify @t (InjL x))+  rgt = Sub (Prof \y -> unitSheafify @t (InjR y))+  Sub (Prof f) ||| Sub (Prof g) = Sub (Prof (extendSheafify @t \case InjL x -> f x; InjR y -> g y))++-- | The quotient a coequalizer takes is 'coequalizeNat'\'s, sheafified. Its projection is epi in+-- the sheaves but need not be onto (the sheafification unit is not), so 'factorCoequalizer' is not+-- 'FINITARY'\'s. It descends, by 'factorThroughLocalEpi'.+instance (HasFiniteCovers t k, FiniteCat j, FiniteCat k) => HasCoequalizers (SHEAVES t j k) where+  coequalize (Sub (Prof @_ @q f)) (Sub (Prof g)) k =+    coequalizeNat f g \ @fs proj ->+      withSheafTables @t @(Sheafify t (Reindex Quotient q fs))+        \toTab _ -> k (Sub (Prof \x -> toTab (unitSheafify @t (proj x))))+  factorCoequalizer (Sub (Prof proj)) (Sub (Prof h)) = Sub (Prof (factorThroughLocalEpi @t proj h))++-- | Not the default coproduct-then-coequalizer, which would sheafify the coproduct and then+-- sheafify the quotient of that. Each 'Sheafify' pays for the one under it, since the plus+-- construction re-runs on every 'toIndex'. Taking both steps in 'FINITARY' and sheafifying once+-- at the end gives the same object, since sheafification is a left adjoint and preserves the+-- pushout, and it avoids stacking one plus construction on another.+instance (HasFiniteCovers t k, FiniteCat j, FiniteCat k) => HasPushouts (SHEAVES t j k) where+  pushout (Sub (Prof @_ @a f)) (Sub (Prof @_ @b g)) k =+    coequalizeNat (\x -> InjL (f x)) (\x -> InjR (g x)) \ @fs proj ->+      withSheafTables @t @(Sheafify t (Reindex Quotient (a :+: b) fs))+        \toTab _ ->+          k+            (Sub (Prof \x -> toTab (unitSheafify @t (proj (InjL x)))))+            (Sub (Prof \y -> toTab (unitSheafify @t (proj (InjR y)))))+  factorPushout (Sub (Prof p1)) (Sub (Prof p2)) (Sub (Prof k1)) (Sub (Prof k2)) =+    Sub (Prof (factorThroughLocalEpi @t (\case InjL x -> p1 x; InjR y -> p2 y) (\case InjL x -> k1 x; InjR y -> k2 y)))++-- | The image of an arrow of sheaves, by the same cokernel-pair construction as in 'FINITARY': the+-- pushout is a colimit and so sheafified, the equalizer that follows it is not.+instance (HasFiniteCovers t k, FiniteCat j, FiniteCat k) => HasEpiMonoFactorization (SHEAVES t j k)++-- | The presheaf internal hom into a sheaf is already a sheaf: a matching family of maps @p -> q@+-- over a cover glues pointwise, because the values glue in @q@. @p@ needs no condition.+--+-- The glued map, at an arrow @g@ into @a@, pulls the cover back along @g@ ('StableSite'). Each+-- pulled-back leg factors through an original leg, whose map is asked, and the answers are glued+-- in @q@. Neither @p@ nor @q@ has to be 'Finitary'. The generic+-- 'Proarrow.Category.Enriched.Finitary.Topos.glueBySearch' would be exponential in the size of @p@.+instance (StableSite t k, Sheaf t q, Profunctor p, CategoryOf j) => Sheaf t (p :~>: q :: j +-> k) where+  glue c m = Exp \g h x ->+    g // h // case pullbackCover c g of+      AlreadyFactors (Factors l u) -> case m l of Exp f -> f u h x+      PulledBack c' factorsThroughLeg -> glue @t c' \l' ->+        case factorsThroughLeg l' of+          Factors l u -> case m l of Exp f -> f u h (lmap (legArrow l') x) \\ legArrow l'++-- | The classifier is the closed sieves, and an arrow is classified by 'FINITARY'\'s graph sieve,+-- closed. For an arrow of sheaves that sieve is already closed, since a sheaf is separated. The+-- 'closedSieve' call guards against a 'Sheaf' instance that was asserted instead of decided, which+-- would otherwise fail later in 'familyIndex' as \"not a closed sieve\".+instance (StableSite t k, HasFiniteCovers t k, FiniteCat j, FiniteCat k) => HasSubobjectClassifier (PROD (SHEAVES t j k)) where+  type Omega @(PROD (SHEAVES t j k)) = PR (SUB (ClosedSieve t))+  true = Prod (Sub (Prof \TerminalProfunctor -> ClosedSieve maximalSieve))+  classifyGraph (Prod (Sub (Prof n))) = Prod (Sub (Prof (closedSieve @t . graphSieve n)))++-- | __The topos of sheaves.__ Finite limits and colimits, cartesian closed, a subobject+-- classifier, and image factorization, all defined above and none of them postulated.+--+-- The exponential needs 'StableSite'. A full subcategory is closed when it contains its internal+-- homs, and an internal hom is a sheaf by gluing pointwise into the codomain, which needs the+-- cover pulled back along the argument.+instance (StableSite t k, HasFiniteCovers t k, FiniteCat j, FiniteCat k) => ElementaryTopos (PROD (SHEAVES t j k))
+ src/Proarrow/Category/Enriched/Finitary/Topos.hs view
@@ -0,0 +1,896 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+-- Orphans throughout, and unavoidably: every instance here is on either 'SUBCAT' 'Finitary' (the+-- kind synonym 'FINITARY' expands to it, and both halves of that come from other modules) or on a+-- profunctor defined elsewhere. Both the class and the category it carves out have to sit below the+-- enrichment machinery; everything computed in that category needs things sitting above it.+{-# OPTIONS_GHC -Wno-orphans #-}++-- | __The topos of finitary profunctors.__ Everything built on the numbering in+-- "Proarrow.Category.Enriched.Finitary": a hom-set is an initial segment of the naturals, so a+-- subobject or a quotient of one is a table of indices, and a computation can produce such a table+-- and reify it into a fresh object. This is 'Reindex', and it gives equalizers, coequalizers,+-- pullbacks, pushouts and epi-mono factorization.+--+-- The internal hom and the subobject classifier are the same construction one level up. Both are+-- ends, enumerated by choosing a value at every point of a domain and keeping the choices that+-- commute with the action. Neither count is a formula in the sizes it is built from, since they+-- depend on how the arrows of @j@ and @k@ compose. That is why the numbering is a value.+--+-- The module ends with @'ElementaryTopos' ('PROD' ('FINITARY' j k))@. With 'PROD' the tensor is the+-- product instead of Day convolution, as it is for @j '+->' k@ itself.+module Proarrow.Category.Enriched.Finitary.Topos where++import Data.IntMap.Strict qualified as IM+import Data.Kind (Constraint, Type)+import Data.List (elemIndex, find, findIndex, genericIndex, genericLength, genericReplicate, partition, sort)+import Data.Map.Strict qualified as M+import Data.Maybe (fromMaybe)+import Data.Proxy (Proxy (..))+import Data.Type.Equality ((:~:) (..))+import Data.Type.Nat (Nat (..), SNatI, reify, snat)+import Data.Type.Nat qualified as N+import Numeric.Natural (Natural)+import Prelude (Maybe (..), ($), (==), (||), type (~))+import Prelude qualified as P++import Proarrow.Category.Enriched.Finitary+import Proarrow.Category.Enriched.Thin+  ( Entry+  , Enumerable (..)+  , Finite (..)+  , Indexed (..)+  , IndexedList (..)+  , KnownList (..)+  )+import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Instance.Sub (SUBCAT (..), Sub (..))+import Proarrow.Category.Sheaf (Coverage, Sheaf (..), Site (..), SomeLeg (..), Trivial)+import Proarrow.Category.Topos+  ( ElementaryTopos+  , HasEpiMonoFactorization (..)+  , HasSubobjectClassifier (..)+  )+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..))+import Proarrow.Colimit.Coequalizer (HasCoequalizers (..))+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Colimit.Pushout (HasPushouts)+import Proarrow.Core+  ( CAT+  , CategoryOf (..)+  , Hom+  , OB+  , Profunctor (..)+  , Promonad (..)+  , UN+  , lmap+  , obj+  , rmap+  , (//)+  , type (+->)+  , type (:~>)+  )+import Proarrow.Limit.BinaryProduct (PROD (..), Prod (..))+import Proarrow.Limit.Equalizer (HasEqualizers (..))+import Proarrow.Limit.Pullback (HasPullbacks)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Coproduct ((:+:) (..))+import Proarrow.Profunctor.Instance.Exponential ((:~>:) (..))+import Proarrow.Profunctor.Instance.Initial (InitialProfunctor)+import Proarrow.Profunctor.Instance.Product ((:*:) (..))+import Proarrow.Profunctor.Instance.Ran (Ran (..))+import Proarrow.Profunctor.Instance.Rift (Rift (..))+import Proarrow.Profunctor.Instance.Sieve (Sieve (..), maximalSieve)+import Proarrow.Profunctor.Instance.Terminal (TerminalProfunctor (..))+import Proarrow.Profunctor.Instance.Yoneda (Yo (..))++-- | The subcategory of finitary profunctors, as "Proarrow.Category.Instance.Rep" does for+-- representable ones.+type FINITARY j k = SUBCAT (Finitary :: (j +-> k) -> Constraint)++type FIN (p :: j +-> k) = SUB p :: FINITARY j k++-- The finite products and coproducts of 'FINITARY' (and of the sheaves) are the generic ones+-- for a full subcategory in "Proarrow.Category.Instance.Sub", pointwise under 'Sub'. The predicate+-- only has to hold of the ambient (co)products, which the instances for+-- ':*:', ':+:', 'TerminalProfunctor' and 'InitialProfunctor' supply.++instance (CategoryOf j, CategoryOf k) => HasInitialObject (FINITARY j k) where+  type InitialObject = FIN InitialProfunctor+  initiate = Sub initiate++instance (CategoryOf j, CategoryOf k) => HasBinaryCoproducts (FINITARY j k) where+  type a || b = SUB (UN SUB a :+: UN SUB b)+  withObCoprod r = r+  lft @(SUB p) @(SUB q) = Sub (lft @(j +-> k) @p @q)+  rgt @(SUB p) @(SUB q) = Sub (rgt @(j +-> k) @p @q)+  Sub l ||| Sub r = Sub (l ||| r)++-- * Tables of fibres++-- | A type-level list of naturals, reflected.+class KnownNats (ns :: [Nat]) where+  natsVal :: [Natural]++instance KnownNats '[] where+  natsVal = []++instance (SNatI n, KnownNats ns) => KnownNats (n ': ns) where+  natsVal = N.snatToNatural (snat @n) : natsVal @ns++-- | A type-level list of lists of naturals, reflected: the fibres of a partial surjection out of+-- one hom-set.+class KnownFibres (fs :: [[Nat]]) where+  fibresVal :: [[Natural]]++instance KnownFibres '[] where+  fibresVal = []++instance (KnownNats f, KnownFibres fs) => KnownFibres (f ': fs) where+  fibresVal = natsVal @f : fibresVal @fs++-- | Reify a list of lists of naturals.+fibres :: forall r. [[Natural]] -> (forall fs. (KnownFibres fs) => r) -> r+fibres [] k = k @'[]+fibres (f : fs) k = nats f \ @f' -> fibres fs \ @fs' -> k @(f' ': fs')+  where+    nats :: forall r'. [Natural] -> (forall ns. (KnownNats ns) => r') -> r'+    nats [] k' = k' @'[]+    nats (n : ns) k' = reify (N.fromNatural n) \(_ :: Proxy n) -> nats ns \ @ns' -> k' @(n ': ns')++-- | A table: a row for each object of @k@, and in each row the fibres at each object of @j@.+type KnownTable bs as t = KnownList (KnownList KnownFibres bs) as t++-- | Build a table by visiting every pair of objects, reifying each cell.+buildTable+  :: forall j k r+   . (Enumerable j, Enumerable k)+  => (forall (a :: k) (b :: j). (Ob a, Ob b) => [[Natural]])+  -> (forall (t :: [[[[Nat]]]]). (KnownTable (Objects j) (Objects k) t) => r)+  -> r+buildTable cell = rows (finite @k)+  where+    rows :: forall (as :: [k]) r'. IndexedList as -> (forall t. (KnownTable (Objects j) as t) => r') -> r'+    rows FNil k' = k' @'[]+    rows (FCons @a as) k' = withOb @k @a (row @a (finite @j) \ @r0 -> rows as \ @t -> k' @(r0 ': t))+    row+      :: forall (a :: k) (bs :: [j]) r'. (Ob a) => IndexedList bs -> (forall r0. (KnownList KnownFibres bs r0) => r') -> r'+    row FNil k' = k' @'[]+    row (FCons @b bs) k' = withOb @j @b (fibres (cell @a @b) \ @fs -> row @a bs \ @r0 -> k' @(fs ': r0))++-- * Reindexing along a table of fibres++-- | What a table of fibres does to the profunctor it relabels. The relabelling is the same either+-- way. What differs is what may be concluded from it, which is why this is in the type at all (see+-- the 'Sheaf' instance below, which is for 'Subobject' alone).+--+-- ['Subobject'] singleton fibres: the elements kept, renumbered. What 'withSubobject' and+--   'equalizeNat' build.+--+-- ['Quotient'] a partition: one index per class of a congruence. What 'coequalize' builds.+type Retabulation :: Type+type data Retabulation = Subobject | Quotient++-- | @p@ relabelled, at each pair of objects, along a partial surjection onto an initial segment of+-- the naturals, given by its fibres: index @i@ of the new hom-set stands for the elements of @p@ in+-- the @i@-th fibre. Well behaved when and only when the fibres are respected by @p@'s 'dimap', as+-- they are for the tables 'equalize' and 'coequalize' build. 'dimap' delegates to @p@ and relies on+-- it.+type Reindex :: forall {j} {k}. Retabulation -> (j +-> k) -> [[[[Nat]]]] -> j +-> k+newtype Reindex r p fs a b = Reindex (p a b)++type Cell fs (a :: k) (b :: j) = Entry (Entry fs (Index a)) (Index b)++instance (Profunctor p) => Profunctor (Reindex r p fs) where+  dimap l r (Reindex x) = Reindex (dimap l r x)+  r \\ Reindex x = r \\ x++-- | The fibres at a pair of objects, found by walking the table to the objects' positions.+cellVal+  :: forall {j} {k} fs (a :: k) (b :: j)+   . (Enumerable j, Enumerable k, KnownTable (Objects j) (Objects k) fs, Ob a, Ob b)+  => [[Natural]]+cellVal =+  withIndex @k @a $+    withIndex @j @b $+      withAtLookup @k (snat @(Index a)) $+        withAtLookup @j (snat @(Index b)) $+          withEntry @(KnownList KnownFibres (Objects j)) @(Objects k) @fs (snat @(Index a)) Refl $+            withEntry @KnownFibres @(Objects j) @(Entry fs (Index a)) (snat @(Index b)) Refl $+              fibresVal @(Cell fs a b)++instance+  (Finitary p, Enumerable j, Enumerable k, KnownTable (Objects j) (Objects k) fs)+  => Finitary (Reindex r (p :: j +-> k) fs)+  where+  size @a @b = genericLength (cellVal @fs @a @b)+  toIndex @a @b (Reindex x) = classIndex "Reindex: element outside every fibre" (cellVal @fs @a @b) (toIndex x) \\ x+  fromIndex @a @b i = Reindex (fromIndex @p (classRep "Reindex: empty fibre" (cellVal @fs @a @b) i))++-- | Restricting a sheaf to a subobject gives a sheaf, provided the subobject is a /subsheaf/: the+-- element glued from a family of kept elements must be kept too. The tables of 'equalize' and the+-- pullbacks are subsheaves. This is a precondition, and a violation fails loudly: 'toIndex' finds+-- the glued element in no fibre.+--+-- There is no instance for 'Quotient'. A quotient of a sheaf is no sheaf in general ('glue' would+-- depend on which representative of each class it was handed), so colimits of sheaves go through+-- sheafification.+instance (Sheaf t p) => Sheaf t (Reindex Subobject p fs) where+  glue c m = Reindex (glue @t c \l -> case m l of Reindex x -> x)++-- | Whether a predicate on @p@\'s elements picks out a /subprofunctor/: the elements it keeps must+-- be closed under the action, since @'Reindex'@ inherits its 'dimap' from @p@ and so can only carve+-- out a set that is.+--+-- @'dimap' l r@ is @'lmap' l . 'rmap' r@, so closure under the two whiskerings separately is closure+-- under the action. That takes two walks over three objects instead of one over four.+closedUnder+  :: forall {j} {k} (p :: j +-> k)+   . (Finitary p, FiniteCat j, FiniteCat k)+  => (forall a b. (Ob a, Ob b) => p a b -> P.Bool)+  -> P.Bool+closedUnder keep =+  P.and+    ( foreachOb @k \ @a -> foreachOb @j \ @b ->+        let kept = [z | z <- elements @p @a @b, keep z]+        in foreachOb @k @P.Bool (\ @c -> [keep (lmap g z) | g <- elements @(Hom k) @c @a, z <- kept])+             P.++ foreachOb @j @P.Bool (\ @d -> [keep (rmap h z) | h <- elements @(Hom j) @b @d, z <- kept])+    )++-- | Carve a subprofunctor out of @p@, the caller choosing which elements to keep, and receiving the+-- new object\'s inclusion. 'equalize' does this with the elements two transformations agree on.+-- Exposed so that a caller can pick out a subobject of its own. This is how a value (a graph read+-- off a file, say) becomes an object of @'FINITARY' j k@, as a subobject of a big enough ambient+-- one. The failure continuation is taken when the kept set is not 'closedUnder' the action, and so+-- is no subobject.+withSubobject+  :: forall {j} {k} (p :: j +-> k) r+   . (Finitary p, FiniteCat j, FiniteCat k)+  => (forall a b. (Ob a, Ob b) => p a b -> P.Bool)+  -> (forall q. (Finitary q) => FIN q ~> FIN p -> r)+  -> r+  -> r+withSubobject keep ok notClosed =+  if closedUnder @p keep+    then buildTable @j @k (\ @a @b -> [[toIndex x] | x <- elements @p @a @b, keep x]) \ @fs ->+      ok @(Reindex Subobject p fs) (Sub (Prof \(Reindex x) -> x))+    else notClosed++-- * Finitary profunctors presented by their tables++-- | Both tables of a 'Tabulated' profunctor over the objects of @j@ and @k@.+type KnownTables :: Type -> Type -> [[[[Nat]]]] -> [[[[Nat]]]] -> Constraint+type KnownTables j k lm rm = (KnownTable (Objects j) (Objects k) lm, KnownTable (Objects j) (Objects k) rm)++-- | A finitary profunctor given by nothing but its tables: at each pair of objects, for each arrow+-- into @a@ and each arrow out of @b@, the function the arrow induces on element indices. A value is+-- its index, and 'dimap' is two lookups.+--+-- Unlike 'Reindex', a view that delegates to @p@, this is the skeleton: 'withTabulated' pays one+-- full enumeration to build it and nothing afterwards. Use it in place of a costly profunctor that+-- is used often, such as 'Proarrow.Category.Enriched.Finitary.Sheaf.Sheafify', whose 'toIndex'+-- re-runs its whole enumeration since a 'Finitary' instance cannot memoise.+--+-- The @lm@ table has, at @(a, b)@, one row per arrow @g :: c '~>' a@ in 'arrowSlot' order, listing+-- @'toIndex' ('lmap' g x)@ for each element @x@ in index order. @rm@ has one row per @h :: b '~>' d@+-- in 'coarrowSlot' order for 'rmap'. A row's length is the size at @(a, b)@.+--+-- @t@ is the coverage the tables have been checked to be a sheaf for, which the tables cannot say.+-- Only the builders apply it: 'withTabulated' uses 'Trivial', which has no covers, and+-- 'Proarrow.Category.Enriched.Finitary.Sheaf.withTabulatedSheaf' decides the condition first.+type Tabulated :: forall {j} {k}. Coverage -> [[[[Nat]]]] -> [[[[Nat]]]] -> j +-> k+data Tabulated t lm rm a b where+  Tabulated :: (Ob a, Ob b) => Natural -> Tabulated t lm rm a b++-- | Where an arrow sits among all the arrows into its target: by source object first, then by the+-- arrow's own index. The row order of a 'Tabulated' @lm@ table.+arrowSlot :: forall {k} (c :: k) a. (FiniteCat k, Ob c, Ob a) => c ~> a -> Natural+arrowSlot g = P.sum (foreachOb @k \ @c' -> [size @(Hom k) @c' @a | objIndex @c' P.< objIndex @c]) P.+ toIndex g++-- | Where an arrow sits among all the arrows out of its source: the row order of an @rm@ table.+coarrowSlot :: forall {j} (b :: j) d. (FiniteCat j, Ob b, Ob d) => b ~> d -> Natural+coarrowSlot h = P.sum (foreachOb @j \ @d' -> [size @(Hom j) @b @d' | objIndex @d' P.< objIndex @d]) P.+ toIndex h++-- | 'lmap' reads the arrow's row in the @lm@ cell at the value's index; 'rmap' then reads the @rm@+-- cell at the new source object.+instance (FiniteCat j, FiniteCat k, KnownTables j k lm rm) => Profunctor (Tabulated t lm rm :: j +-> k) where+  dimap @c @a @b @_ l r (Tabulated i) =+    l // r // Tabulated (look (cellVal @rm @c @b) (coarrowSlot r) (look (cellVal @lm @a @b) (arrowSlot l) i))+    where+      look cell slot = genericIndex (genericIndex cell slot)+  r \\ Tabulated{} = r++-- | The numbering is the value. 'size' is a row's length and the rest is the identity, except for+-- the range check. An index that /is/ the value has nowhere else to fail. Stored unchecked, it+-- would surface much later, as 'genericIndex' running off a row inside 'dimap'.+instance (FiniteCat j, FiniteCat k, KnownTables j k lm rm) => Finitary (Tabulated t lm rm :: j +-> k) where+  size @a @b = case cellVal @lm @a @b of+    row : _ -> genericLength row+    [] -> P.error "Tabulated: empty cell"+  toIndex (Tabulated i) = i+  fromIndex @a @b i+    | i P.< size @(Tabulated t lm rm) @a @b = Tabulated i+    | P.otherwise = P.error "Tabulated: index out of range"++-- | The two tables of @p@, reified, with nothing said about what they present. The enumeration+-- (every element, every arrow, one 'toIndex' per pair) is paid here and never again. The two+-- builders differ only in the tag they hand the tables to, so the enumeration is written once,+-- here. The other builder is 'Proarrow.Category.Enriched.Finitary.Sheaf.withTabulatedSheaf', which+-- lives over there because deciding the sheaf condition needs what is built on this module.+withTables+  :: forall {j} {k} (p :: j +-> k) r+   . (Finitary p, FiniteCat j, FiniteCat k)+  => (forall lm rm. (KnownTables j k lm rm) => r)+  -> r+withTables k =+  buildTable @j @k+    ( \ @a @b -> let xs = elements @p @a @b in foreachOb @k \ @c -> [P.map (toIndex . lmap g) xs | g <- elements @(Hom k) @c @a]+    )+    \ @lm ->+      buildTable @j @k+        ( \ @a @b -> let xs = elements @p @a @b in foreachOb @j \ @d -> [P.map (toIndex . rmap h) xs | h <- elements @(Hom j) @b @d]+        )+        \ @rm -> k @lm @rm++-- | An element of @p@ as the index that stands for it in a presentation of @p@.+toTabulated :: forall {j} {k} t lm rm (p :: j +-> k). (Finitary p) => p :~> Tabulated t lm rm+toTabulated x = Tabulated (toIndex x) \\ x++-- | An index in a presentation of @p@ as the element of @p@ it stands for.+fromTabulated :: forall {j} {k} t lm rm (p :: j +-> k). (Finitary p) => Tabulated t lm rm :~> p+fromTabulated (Tabulated i) = fromIndex i++-- | Present a finitary profunctor by its tables, once, with the isomorphism both ways.+--+-- The continuation receives the presentation as a named @tab ~ 'Tabulated' 'Trivial' lm rm@, since+-- the tables alone do not fix @j@ and @k@. Bind it as @\\ \@tab toTab fromTab -> ...@.+--+-- The presentation is a sheaf only for 'Trivial'. To present a sheaf /as/ one, use+-- 'Proarrow.Category.Enriched.Finitary.Sheaf.withTabulatedSheaf'.+withTabulated+  :: forall {j} {k} (p :: j +-> k) r+   . (Finitary p, FiniteCat j, FiniteCat k)+  => ( forall {lm} {rm} (tab :: j +-> k)+        . (tab ~ Tabulated Trivial lm rm, KnownTables j k lm rm)+       => (p :~> tab)+       -> (tab :~> p)+       -> r+     )+  -> r+withTabulated k = withTables @p \ @lm @rm -> k @(Tabulated Trivial lm rm) toTabulated fromTabulated++-- | Glue by search: find the element whose restrictions along the legs are the family. This gives a+-- 'Sheaf' instance to a sheaf with no 'glue' of its own, such as a 'Tabulated' one or a subsheaf of+-- a profunctor that is no sheaf (like the closed sieves). Lawful iff @p@ is a sheaf, which+-- 'Proarrow.Category.Enriched.Finitary.Sheaf.isSheaf' decides.+--+-- Errors if no element matches, and also if more than one does: over a cover with no legs every+-- element matches, so an unseparated @p@ would otherwise glue silently to the first one.+glueBySearch+  :: forall t {j} {k} (p :: j +-> k) (a :: k) c (b :: j)+   . (Site t k, Finitary p, Ob a, Ob b)+  => Cover t k a c+  -> (forall x. Leg t k a c x -> p x b)+  -> p a b+glueBySearch c m = case P.filter (\x -> P.all ($ x) family) (elements @p @a @b) of+  [x] -> x+  [] -> P.error "glue: no element restricts to the family -- not a sheaf"+  _ -> P.error "glue: more than one element restricts to the family -- not a sheaf"+  where+    -- One test per leg, not one per leg and element. @ix@ is the leg source\'s 'toIndex', bound+    -- before the element arrives, so an instance that searches for an index searches once per leg+    -- instead of once for every element it is asked about.+    family :: [p a b -> P.Bool]+    family = [(let ix = toIndex; i = ix (m l) in \x -> ix (lmap (legArrow l) x) == i) \\ legArrow l | SomeLeg l <- legs c]++-- | A tabulated profunctor glues by search, since it knows nothing of the profunctor it presents.+-- Only for the coverage its tag names. The tag is the only evidence that the search will+-- find its element, so a presentation may be used as a sheaf for the coverage it was checked+-- against and for no other. At 'Trivial', which 'withTabulated' applies and which has no covers,+-- the instance is vacuous and 'glueBySearch' is unreachable.+instance (Site t k, FiniteCat j, FiniteCat k, KnownTables j k lm rm) => Sheaf t (Tabulated t lm rm :: j +-> k) where+  glue = glueBySearch @t++-- * Equalizers and coequalizers++-- | The element of @p@ that @f@ sends to a given element of @q@, if the element is in @f@\'s+-- image. The first one found. For an injective @f@ (an equalizer\'s inclusion) it is the only one.+-- For a projection it is a choice of representative, and the caller is then relying on what it does+-- with it not depending on which.+preimageMaybe+  :: forall {j} {k} (p :: j +-> k) q (a :: k) (b :: j)+   . (Finitary p, Finitary q, Ob a, Ob b)+  => (p a b -> q a b)+  -> q a b+  -> Maybe (p a b)+preimageMaybe f y =+  let toIndexQ = toIndex @q @a @b+      iy = toIndexQ y+  in find (\x -> toIndexQ (f x) == iy) (elements @p @a @b)++-- | 'preimageMaybe' where the element has to be in the image. Both factorizations below need this,+-- in opposite directions.+preimage+  :: forall {j} {k} (p :: j +-> k) q (a :: k) (b :: j)+   . (Finitary p, Finitary q, Ob a, Ob b)+  => P.String -> (p a b -> q a b) -> q a b -> p a b+preimage msg f y = fromMaybe (P.error msg) (preimageMaybe f y)++-- | Partition a list of indices into the equivalence classes generated by a list of pairs. Both+-- levels are sorted, so the classes come out ordered by their least member and the table is canonical.+classes :: [(Natural, Natural)] -> [Natural] -> [[Natural]]+classes pairs is = sort (P.map sort (P.foldr merge (P.map (: []) is) pairs))+  where+    merge (i, j) cs = case partition (\c -> P.elem i c || P.elem j c) cs of+      ([], _) -> P.error "classes: an index outside the set being partitioned"+      (hit, miss) -> P.concat hit : miss++-- | The position of the class an index lies in.+classIndex :: P.String -> [[Natural]] -> Natural -> Natural+classIndex msg cls n = P.fromIntegral (fromMaybe (P.error msg) (findIndex (P.elem n) cls))++-- | The first member of the class at a position, which stands for the class.+classRep :: P.String -> [[Natural]] -> Natural -> Natural+classRep msg cls i = case genericIndex cls i of+  n : _ -> n+  [] -> P.error msg++-- | Equalizers of finitary profunctors between finite categories: at each pair of objects, keep the+-- indices on which the two natural transformations agree, and reify the table.+instance (Enumerable j, Enumerable k) => HasEqualizers (FINITARY j k) where+  equalize (Sub (Prof f)) (Sub (Prof g)) k = equalizeNat f g \incl -> k (Sub (Prof incl))+  factorEqualizer (Sub (Prof incl)) (Sub (Prof h)) = Sub (Prof (factorThroughEqualizer incl h))++-- | The equalizer of two natural transformations: the source retabulated along the points where+-- they agree, handed on with its inclusion. 'FINITARY' and its subcategories of sheaves equalize+-- alike. Only the wrapper around the result differs, so the construction lives here once.+equalizeNat+  :: forall {j} {k} (p :: j +-> k) q r+   . (Finitary p, Finitary q, Enumerable j, Enumerable k)+  => (p :~> q)+  -> (p :~> q)+  -> (forall fs. (KnownTable (Objects j) (Objects k) fs) => (Reindex Subobject p fs :~> p) -> r)+  -> r+equalizeNat f g k =+  buildTable @j @k+    ( \ @a @b ->+        let toIndexP = toIndex @p @a @b; toIndexQ = toIndex @q @a @b+        in [[toIndexP x] | x <- elements @p @a @b, toIndexQ (f x) == toIndexQ (g x)]+    )+    \ @fs -> k @fs \(Reindex x) -> x++-- | Factor through an equalizer's inclusion, by 'preimage': the arrow must land in the image.+factorThroughEqualizer+  :: forall {j} {k} (e :: j +-> k) x e'+   . (Finitary e, Finitary x, Profunctor e')+  => (e :~> x)+  -> (e' :~> x)+  -> e' :~> e+factorThroughEqualizer incl h y = preimage "factorEqualizer: h's image must lie within incl's image" incl (h y) \\ y++-- | Coequalizers: at each pair of objects, partition the indices by the equivalence relation the two+-- natural transformations generate, and reify the table. Naturality makes the partition a+-- congruence, so the quotient is again a profunctor.+instance (Enumerable j, Enumerable k) => HasCoequalizers (FINITARY j k) where+  coequalize (Sub (Prof f)) (Sub (Prof g)) k = coequalizeNat f g \proj -> k (Sub (Prof proj))+  factorCoequalizer (Sub (Prof proj)) (Sub (Prof h)) = Sub (Prof (factorThroughCoequalizer proj h))++-- | The coequalizer of two natural transformations: the target retabulated along the classes the+-- two generate, handed on with its projection. The dual of 'equalizeNat', and shared the same way,+-- though the sheaves take only half of it. A quotient of sheaves is no sheaf and has to be+-- sheafified before it is the coequalizer /there/.+coequalizeNat+  :: forall {j} {k} (p :: j +-> k) q r+   . (Finitary p, Finitary q, Enumerable j, Enumerable k)+  => (p :~> q)+  -> (p :~> q)+  -> (forall fs. (KnownTable (Objects j) (Objects k) fs) => (q :~> Reindex Quotient q fs) -> r)+  -> r+coequalizeNat f g k =+  buildTable @j @k+    ( \ @a @b ->+        let toIndexQ = toIndex @q @a @b+        in classes [(toIndexQ (f x), toIndexQ (g x)) | x <- elements @p @a @b] (P.map toIndexQ (elements @q @a @b))+    )+    \ @fs -> k @fs Reindex++-- | Factor through a coequalizer's projection, by 'preimage': the projection must be onto. The+-- dual of 'factorThroughEqualizer', and stated apart from the instance for the same reason. Unlike+-- the dual it is not shared with the sheaves. A projection there is epi without being onto, and+-- they use 'Proarrow.Category.Enriched.Finitary.Sheaf.factorThroughLocalEpi' instead.+factorThroughCoequalizer+  :: forall {j} {k} (c :: j +-> k) x c'+   . (Finitary c, Finitary x, Profunctor c')+  => (x :~> c)+  -> (x :~> c')+  -> c :~> c'+factorThroughCoequalizer proj h y = h (preimage "factorCoequalizer: proj must be onto" proj y) \\ y++-- * Pullbacks, pushouts and images++-- | Pullbacks are equalizers of products, and pushouts coequalizers of coproducts, all of which+-- finitary profunctors have.+instance (Enumerable j, Enumerable k) => HasPullbacks (FINITARY j k)++instance (Enumerable j, Enumerable k) => HasPushouts (FINITARY j k)++-- | The image of a natural transformation is the equalizer of its cokernel pair.+instance (Enumerable j, Enumerable k) => HasEpiMonoFactorization (FINITARY j k)++-- * Natural transformations, enumerated++-- | Enumerate a set of families by brute force: every way of choosing a value at each point of the+-- domain, kept when it satisfies every condition. A condition is checked as soon as both of its+-- points have been chosen, so a violation prunes the whole subtree of completions instead of+-- rejecting each of them in turn. This keeps the candidate space from being the full product.+-- Families come out in the same order as @'P.sequence' choices@ would give them, with the earliest+-- point varying slowest.+familiesSatisfying :: [[v]] -> [(P.Int, P.Int, v -> v -> P.Bool)] -> [[v]]+familiesSatisfying choices laws = go 0 [] choices+  where+    -- a condition can first be tested at the later of its two points+    byDepth = IM.fromListWith (P.++) [(P.max src tgt, [(src, tgt, rel)]) | (src, tgt, rel) <- laws]+    go _ chosen [] = [P.reverse chosen]+    go i chosen (cs : rest) =+      [ row+      | v <- cs+      , let chosen' = v : chosen+      , let at n = chosen' P.!! (i P.- n) -- @chosen'@ holds points @0..i@ in reverse+      , P.all (\(src, tgt, rel) -> rel (at src) (at tgt)) (IM.findWithDefault [] i byDepth)+      , row <- go (i P.+ 1) chosen' rest+      ]++-- | Which of the enumerated families a tabulated one is.+familyIndex :: (P.Eq v) => P.String -> [[v]] -> [v] -> Natural+familyIndex msg fams row = case elemIndex row fams of+  Just i -> P.fromIntegral i+  Nothing -> P.error msg++-- | One point of the domain of the end @∫ Set(p c d, q c d)@ whose elements are the natural+-- transformations @p -> q@: an object pair and an element of @p@ there. Every end below is one of+-- these. The internal hom only changes the weight @p@, and the subobject classifier also changes+-- what the conditions are read as. So the whole topos is built on this one enumeration.+type NatKey = (Natural, Natural, Natural)++-- | Visit every point of that domain, in one fixed order.+natDomain+  :: forall {j} {k} (p :: j +-> k) r+   . (Finitary p, FiniteCat j, FiniteCat k)+  => (forall a b. (Ob a, Ob b) => p a b -> r)+  -> [r]+natDomain f = foreachOb @k \ @a -> foreachOb @j \ @b -> P.map f (elements @p @a @b)++natKey+  :: forall {j} {k} (a :: k) (b :: j) (p :: j +-> k). (FiniteCat j, FiniteCat k, Finitary p, Ob a, Ob b) => p a b -> NatKey+natKey x = (objIndex @a, objIndex @b, toIndex x)++-- | Where each point of the domain sits in a tabulated family. This is the same for every family+-- over a given weight, so bind it once outside a loop over them.+natPositions+  :: forall {j} {k} (p :: j +-> k). (Finitary p, FiniteCat j, FiniteCat k) => M.Map NatKey P.Int+natPositions = natPositionsBy @p natKey++-- | 'natPositions' with the key chosen by the caller, for a weight whose points are addressed by+-- another object's keys. For example a subobject carved out by 'withSubobject', whose inclusion+-- says which point of the ambient object each of its own points is.+natPositionsBy+  :: forall {j} {k} (p :: j +-> k)+   . (Finitary p, FiniteCat j, FiniteCat k)+  => (forall a b. (Ob a, Ob b) => p a b -> NatKey)+  -> M.Map NatKey P.Int+natPositionsBy key = M.fromList (P.zip (natDomain @p @NatKey key) [0 ..])++-- | Read a tabulated family back as a function on the points, given those positions.+atNatKey :: M.Map NatKey P.Int -> [v] -> NatKey -> v+atNatKey pos row k = row P.!! (pos M.! k)++-- | Every natural transformation @p -> q@, as its list of @q@-indices in 'natDomain' order.+-- Naturality is the only condition: the value at @x@ and the value at @'dimap' g h x@ must agree+-- after transport.+natElements+  :: forall {j} {k} (p :: j +-> k) (q :: j +-> k)+   . (Finitary p, Finitary q, FiniteCat j, FiniteCat k)+  => [[Natural]]+natElements =+  familiesSatisfying+    -- the same choice list at every point over one object pair, so @q@\'s size is asked once per pair+    (foreachOb @k \ @a -> foreachOb @j \ @b -> genericReplicate (size @p @a @b) (indices (size @q @a @b)))+    (natConditions @p @q \tr i j -> j == genericIndex tr i)++-- | The conditions as positions in a tabulated family, with @q@\'s transport handed to the+-- relation. Only the internal hom reads that transport. The sieves below ignore it, and pass+-- 'TerminalProfunctor' for @q@ so that computing it costs nothing.+natConditions+  :: forall {j} {k} (p :: j +-> k) (q :: j +-> k) v+   . (Finitary p, Finitary q, FiniteCat j, FiniteCat k)+  => ([Natural] -> v -> v -> P.Bool)+  -> [(P.Int, P.Int, v -> v -> P.Bool)]+natConditions rel = [(at src, at tgt, rel tr) | (src, tgt, tr) <- natLaws @p @q]+  where+    at = (natPositions @p M.!)++-- | The naturality conditions on a transformation. As in 'closedUnder', @'dimap' g h@ is+-- @'lmap' g . 'rmap' h@, so commuting with the two whiskerings separately is commuting with the+-- action. That takes two walks over three objects instead of one over four, and the transport+-- table depends on the arrow alone, not on each element.+natLaws+  :: forall {j} {k} (p :: j +-> k) (q :: j +-> k)+   . (Finitary p, Finitary q, FiniteCat j, FiniteCat k)+  => [(NatKey, NatKey, [Natural])]+natLaws =+  foreachOb @k \ @a -> foreachOb @j \ @b ->+    let xs = elements @p @a @b; qs = elements @q @a @b+    in foreachOb @k @(NatKey, NatKey, [Natural])+         ( \ @c -> [(natKey x, natKey (lmap g x), tr) | g <- elements @(Hom k) @c @a, let tr = P.map (toIndex . lmap g) qs, x <- xs]+         )+         P.++ foreachOb @j @(NatKey, NatKey, [Natural])+           ( \ @d -> [(natKey x, natKey (rmap h x), tr) | h <- elements @(Hom j) @b @d, let tr = P.map (toIndex . rmap h) qs, x <- xs]+           )++-- | A natural transformation as its table of @q@-indices, in 'natDomain' order. There is nothing+-- else to see of one, so it serves for both comparing and showing.+natTable+  :: forall {j} {k} (p :: j +-> k) (q :: j +-> k)+   . (Finitary p, Finitary q, FiniteCat j, FiniteCat k)+  => (p :~> q)+  -> [Natural]+natTable f = natDomain @p (toIndex P.. f)++-- | Which of the natural transformations @p -> q@ a given one is: 'familyIndex' of its 'natTable' in+-- 'natElements'. The enumeration is bound before the transformation arrives, so a partial+-- application shares it across a hom-set. Every 'toIndex' that numbers transformations uses this.+natIndex+  :: forall {j} {k} (p :: j +-> k) (q :: j +-> k)+   . (Finitary p, Finitary q, FiniteCat j, FiniteCat k)+  => P.String+  -> (p :~> q)+  -> Natural+natIndex msg = \f -> familyIndex msg es (natTable @p @q f)+  where+    es = natElements @p @q++-- | Every natural transformation @p -> q@, as an arrow of @j '+->' k@. With this the category of+-- finitary profunctors, and each of its full subcategories, is testable. Its hom-sets are+-- enumerable, so a generator can pick from them, where in general a natural transformation is not+-- something one can generate.+natTransformations+  :: forall {j} {k} (p :: j +-> k) (q :: j +-> k)+   . (Finitary p, Finitary q, FiniteCat j, FiniteCat k)+  => [p ~> q]+natTransformations = let pos = natPositions @p in P.map (natAt @p @q pos) (natElements @p @q)++-- | A tabulated transformation, as an arrow of @j '+->' k@.+natAt+  :: forall {j} {k} (p :: j +-> k) (q :: j +-> k)+   . (Finitary p, Finitary q, FiniteCat j, FiniteCat k)+  => M.Map NatKey P.Int+  -> [Natural]+  -> p ~> q+natAt pos row = Prof \x -> x // fromIndex @q (atNatKey pos row (natKey x))++-- | @'Finitary' p@ as a class with a single instance, so that a quantified constraint can ask for+-- it without 'Finitary' being the head. 'subFinitary' hands it back as an ordinary given. The+-- instance below says what this is for. 'Proarrow.Optic.Sub' is the same device for flavors, and+-- documents the GHC restriction behind it at more length, including why neither of them carries+-- the constraint it wraps as a superclass.+type SubFinitary :: forall {j} {k}. (j +-> k) -> Constraint+class SubFinitary p where+  subFinitary :: ((Finitary p) => r) -> r++instance (Finitary p) => SubFinitary p where+  subFinitary r = r++-- | @'FINITARY' j k@ is locally finite: its own hom-profunctor is finitary, by 'natTransformations',+-- so the numbering is the skeleton of each hom-set and the 'Finitary' laws apply to it. (It is not+-- a 'FiniteCat': there are unboundedly many finitary profunctors.)+--+-- The same holds for any full subcategory whose predicate implies 'Finitary', such as the sheaves+-- of "Proarrow.Category.Enriched.Finitary.Sheaf". The premise goes through 'SubFinitary' because a+-- bare @forall p. ob p => 'Finitary' p@ cannot be discharged for a conjunction such as+-- @'Finitary' :&&: 'Sheaf' t@: GHC will not solve the head from a superclass that is not smaller.+instance+  (FiniteCat j, FiniteCat k, forall p. (ob p) => SubFinitary p)+  => Finitary (Sub Prof :: CAT (SUBCAT (ob :: OB (j +-> k))))+  where+  size @f @g = subFinitary @(UN SUB f) $ subFinitary @(UN SUB g) $ genericLength (natElements @(UN SUB f) @(UN SUB g))+  toIndex @f @g =+    subFinitary @(UN SUB f) $+      subFinitary @(UN SUB g) $+        -- bound before the argument lambda, so a partial application shares the enumeration+        let ix = natIndex @(UN SUB f) @(UN SUB g) "toIndex: the transformation is not natural"+        in \(Sub (Prof n)) -> ix n+  fromIndex @f @g i =+    subFinitary @(UN SUB f) $+      subFinitary @(UN SUB g) $+        Sub (natAt @(UN SUB f) @(UN SUB g) (natPositions @(UN SUB f)) (genericIndex (natElements @(UN SUB f) @(UN SUB g)) i))+  elements @f @g = subFinitary @(UN SUB f) $ subFinitary @(UN SUB g) $ P.map Sub (natTransformations @(UN SUB f) @(UN SUB g))++-- | What the internal hom at @a@\/@b@ is a set of natural transformations /out of/. An element of+-- it over @c@\/@d@ is an arrow into @a@, an arrow out of @b@ and an element of @p@, the three+-- arguments an 'Exp' takes.+type ExpWeight :: forall {j} {k}. (j +-> k) -> k -> j -> j +-> k+type ExpWeight p a b = Yo a (OP b) :*: p++-- | The internal hom of finitary profunctors is finitary: its elements are the natural+-- transformations out of 'ExpWeight', enumerated. The count is not a formula in the sizes of @p@+-- and @q@, since it depends on how the arrows of @j@ and @k@ compose. So 'size' is a value and+-- not a type family.+instance (Finitary p, Finitary q, FiniteCat j, FiniteCat k) => Finitary (p :~>: q :: j +-> k) where+  size @a @b = genericLength (natElements @(ExpWeight p a b) @q)++  toIndex @a @b = \(Exp f) -> ix \(Yo ca bd :*: x) -> f ca bd x+    where+      ix = natIndex @(ExpWeight p a b) @q "toIndex: the family is not natural"+  fromIndex @a @b i = expAt @p @q (natPositions @(ExpWeight p a b)) (genericIndex (natElements @(ExpWeight p a b) @q) i)+  elements @a @b =+    let pos = natPositions @(ExpWeight p a b) in P.map (expAt @p @q pos) (natElements @(ExpWeight p a b) @q)++-- | A tabulated family as an element of the internal hom.+expAt+  :: forall {j} {k} (p :: j +-> k) (q :: j +-> k) (a :: k) (b :: j)+   . (Finitary p, Finitary q, FiniteCat j, FiniteCat k, Ob a, Ob b)+  => M.Map NatKey P.Int+  -> [Natural]+  -> (p :~>: q) a b+expAt pos row = Exp \ca bd x -> ca // bd // fromIndex @q (atNatKey pos row (natKey (Yo ca bd :*: x)))++-- | What the right Kan lift @'Rift' ('OP' j) p@ at @a@\/@b@ is a set of natural transformations out+-- of. An element of @'Rift' ('OP' j) p a b@ is a function @forall x. j x a -> p x b@, and by Yoneda+-- that is a natural transformation from @j (-) a × (b ~> -)@ to @p@.+type RiftWeight :: forall {i} {j} {k}. (k +-> i) -> k -> j -> j +-> i+data RiftWeight w a b x d where+  RiftWeight :: (Ob x, Ob d) => w x a -> b ~> d -> RiftWeight w a b x d++instance (Profunctor w, CategoryOf j) => Profunctor (RiftWeight w a (b :: j)) where+  dimap f g (RiftWeight u h) = f // g // RiftWeight (lmap f u) (g . h)+  r \\ RiftWeight{} = r++instance (Finitary w, LocallyFinite j, Ob a, Ob b) => Finitary (RiftWeight w a (b :: j)) where+  size @x @d = size @w @x @a P.* size @(Hom j) @b @d+  toIndex @_ @d (RiftWeight u h) = pairIndex (size @(Hom j) @b @d) (toIndex u) (toIndex h)+  fromIndex @_ @d i = let (l, r) = unpairIndex (size @(Hom j) @b @d) i in RiftWeight (fromIndex l) (fromIndex r)+  elements @x @d = [RiftWeight u h | u <- elements @w @x @a, h <- elements @(Hom j) @b @d]++-- | The right Kan lift of finitary profunctors is finitary: its elements are the natural+-- transformations out of 'RiftWeight', enumerated, as for the internal hom.+instance+  (Finitary w, Finitary p, FiniteCat i, FiniteCat j)+  => Finitary (Rift (OP (w :: k +-> i)) p :: j +-> k)+  where+  size @a @b = genericLength (natElements @(RiftWeight w a b) @p)+  toIndex @a @b = \(Rift f) -> ix \(RiftWeight u h) -> rmap h (f u)+    where+      ix = natIndex @(RiftWeight w a b) @p "toIndex: the family is not natural"+  fromIndex @a @b i = riftAt @w @p (natPositions @(RiftWeight w a b)) (genericIndex (natElements @(RiftWeight w a b) @p) i)+  elements @a @b =+    let pos = natPositions @(RiftWeight w a b) in P.map (riftAt @w @p pos) (natElements @(RiftWeight w a b) @p)++-- | The composite of finitary profunctors over a finite middle category is finitary. An element+-- at @a@\/@c@ is a pair @(u, v)@ over some middle object @x@, and pairs are identified along the+-- arrows of the middle category: @(rmap f u, v) = (u, lmap f v)@, the coend+-- @∫^x w a x × s x c@. The classes are computed by 'classes' and numbered in order, each shown by+-- its first pair.+instance (Finitary w, Finitary s, FiniteCat j) => Finitary ((w :: j +-> k) :.: (s :: i +-> j)) where+  size @a @c = genericLength (compClasses @w @s @a @c)+  toIndex @a @c = \(u :.: v) -> u // classIndex "toIndex: a pair in no class" cls (compIndex @w @s @a @c offs u v)+    where+      offs = compOffsets @w @s @a @c+      cls = compClasses @w @s @a @c+  fromIndex @a @c n = genericIndex (compPairs @w @s @a @c) (classRep "fromIndex: an empty class" (compClasses @w @s @a @c) n)+  elements @a @c = let ps = compPairs @w @s @a @c in [genericIndex ps n | n : _ <- compClasses @w @s @a @c]++-- | Every pair @(u, v)@ over every middle object, numbered as 'compIndex' numbers them.+compPairs+  :: forall {i} {j} {k} (w :: j +-> k) (s :: i +-> j) (a :: k) (c :: i)+   . (Finitary w, Finitary s, FiniteCat j, Ob a, Ob c)+  => [(w :.: s) a c]+compPairs = foreachOb @j \ @x -> [u :.: v | u <- elements @w @a @x, v <- elements @s @x @c]++-- | Where each middle object's pairs start in the numbering of 'compPairs'.+compOffsets+  :: forall {i} {j} {k} (w :: j +-> k) (s :: i +-> j) (a :: k) (c :: i)+   . (Finitary w, Finitary s, FiniteCat j, Ob a, Ob c)+  => [Natural]+compOffsets = P.scanl (P.+) 0 (foreachOb @j \ @x -> [size @w @a @x P.* size @s @x @c])++-- | The position of a pair over @x@ in 'compPairs'.+compIndex+  :: forall {i} {j} {k} (w :: j +-> k) (s :: i +-> j) (a :: k) (c :: i) (x :: j)+   . (Finitary w, Finitary s, FiniteCat j, Ob a, Ob c, Ob x)+  => [Natural]+  -> w a x+  -> s x c+  -> Natural+compIndex offs u v = genericIndex offs (objIndex @x) P.+ pairIndex (size @s @x @c) (toIndex u) (toIndex v)++-- | The classes of pairs under the identifications along the middle arrows.+compClasses+  :: forall {i} {j} {k} (w :: j +-> k) (s :: i +-> j) (a :: k) (c :: i)+   . (Finitary w, Finitary s, FiniteCat j, Ob a, Ob c)+  => [[Natural]]+compClasses =+  classes+    ( foreachOb @j \ @x -> foreachOb @j \ @x' ->+        [ (compIndex @w @s @a @c offs (rmap f u) v, compIndex @w @s @a @c offs u (lmap f v))+        | f <- elements @(Hom j) @x @x'+        , u <- elements @w @a @x+        , v <- elements @s @x' @c+        ]+    )+    (indices (P.last offs))+  where+    offs = compOffsets @w @s @a @c++-- | The right Kan extension of finitary profunctors is finitary. It is the right Kan lift in the+-- opposite categories, @'Ran' ('OP' v) p a b ≅ 'Rift' ('OP' ('Op' v)) ('Op' p) ('OP' b) ('OP' a)@,+-- and is numbered as that is.+instance+  (Finitary v, Finitary p, FiniteCat i, FiniteCat k)+  => Finitary (Ran (OP (v :: i +-> j)) p :: j +-> k)+  where+  size @a @b = size @(Rift (OP (Op v)) (Op p)) @(OP b) @(OP a)+  toIndex @a @b (Ran f) = toIndex @(Rift (OP (Op v)) (Op p)) @(OP b) @(OP a) (Rift \(Op u) -> Op (f u))+  fromIndex @a @b i = case fromIndex @(Rift (OP (Op v)) (Op p)) @(OP b) @(OP a) i of Rift k -> Ran \u -> unOp (k (Op u))+  elements @a @b = [Ran \u -> unOp (k (Op u)) | Rift k <- elements @(Rift (OP (Op v)) (Op p)) @(OP b) @(OP a)]++-- | A tabulated family as an element of the right Kan lift.+riftAt+  :: forall {i} {j} {k} (w :: k +-> i) (p :: j +-> i) (a :: k) (b :: j)+   . (Finitary w, Finitary p, FiniteCat i, FiniteCat j, Ob a, Ob b)+  => M.Map NatKey P.Int+  -> [Natural]+  -> Rift (OP w) p a b+riftAt pos row = Rift \u -> u // fromIndex @p (atNatKey pos row (natKey (RiftWeight u (obj @b))))++-- Finitary profunctors are cartesian closed, and the sheaves are too, by the instance for any+-- full subcategory closed under the internal hom in "Proarrow.Profunctor.Instance.Exponential".+-- Here that is @'Finitary' (p ':~>:' q)@ just above, where the hom-set is the natural+-- transformations, enumerated.++-- * The subobject classifier++-- | Every sieve at @a@\/@b@, as the points of @'Yo' a ('OP' b)@ it contains, in 'natDomain' order:+-- all subsets, kept when closed. This is the same end again, at the weight @'Yo' a ('OP' b)@ and+-- valued in booleans, with the naturality conditions read as implications instead of equations.+sieveElements :: forall {j} {k} (a :: k) (b :: j). (FiniteCat j, FiniteCat k, Ob a, Ob b) => [[P.Bool]]+sieveElements =+  familiesSatisfying+    (natDomain @(Yo a (OP b)) (P.const [P.False, P.True]))+    (natConditions @(Yo a (OP b)) @TerminalProfunctor \_ s t -> P.not s P.|| t)++-- | A sieve as the tabulation of its membership, in 'natDomain' order. The inverse of 'sieveAt'.+sieveTable :: forall {j} {k} (a :: k) (b :: j). (FiniteCat j, FiniteCat k) => Sieve a b -> [P.Bool]+sieveTable (Sieve s) = natDomain @(Yo a (OP b)) \(Yo ca bd) -> s ca bd++instance (FiniteCat j, FiniteCat k) => Finitary (Sieve :: j +-> k) where+  size @a @b = genericLength (sieveElements @a @b)+  toIndex @a @b = familyIndex "toIndex: not a sieve" (sieveElements @a @b) . sieveTable+  fromIndex @a @b i = sieveAt (natPositions @(Yo a (OP b))) (genericIndex (sieveElements @a @b) i)+  elements @a @b = let pos = natPositions @(Yo a (OP b)) in P.map (sieveAt pos) (sieveElements @a @b)++-- | A tabulated sieve as a sieve.+sieveAt+  :: forall {j} {k} (a :: k) (b :: j)+   . (FiniteCat j, FiniteCat k, Ob a, Ob b)+  => M.Map NatKey P.Int+  -> [P.Bool]+  -> Sieve a b+sieveAt pos row = Sieve \ca bd -> ca // bd // atNatKey pos row (natKey (Yo ca bd))++-- | All the ways an element of @p@ and one of @q@ can be carried to a matching pair: the sieve an+-- arrow's graph is classified by. Shared with the sheaves, whose classifier is this closed.+graphSieve+  :: forall {j} {k} (p :: j +-> k) (q :: j +-> k)+   . (Profunctor p, Finitary q)+  => (p :~> q) -> (p :*: q) :~> Sieve+graphSieve n (x :*: y) = x // Sieve \g h -> g // h // toIndex @q (n (dimap g h x)) == toIndex (dimap g h y)++-- | The subobject classifier is the profunctor of sieves, and an arrow classifies its graph.+instance (FiniteCat j, FiniteCat k) => HasSubobjectClassifier (PROD (FINITARY j k)) where+  type Omega = PR (SUB Sieve)+  true = Prod (Sub (Prof \TerminalProfunctor -> maximalSieve))+  classifyGraph (Prod (Sub (Prof n))) = Prod (Sub (Prof (graphSieve n)))++-- | Finitary profunctors between finite categories form an elementary topos: finite limits and+-- colimits, cartesian closed, a subobject classifier, and image factorization.+instance (FiniteCat j, FiniteCat k) => ElementaryTopos (PROD (FINITARY j k))
+ src/Proarrow/Category/Enriched/Quantale.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Totally ordered, integral quantales, as far as computing closures of enriched profunctors+-- needs them: 'Proarrow.Category.Instance.Bool.BOOL' (relations, reachability) and+-- 'Proarrow.Category.Instance.Cost.COST' (metric spaces, shortest paths). Besides the structure+-- their classes already provide, the closure needs a handful of facts reflected to the value level,+-- collected in 'Quantale'.+module Proarrow.Category.Enriched.Quantale where++import Data.Kind (Type)+import Data.Proxy (Proxy (..))+import Data.Type.Ord (OrderingI (..))+import GHC.TypeNats (cmpNat)+import Prelude (error, type (~))++import Proarrow.Category.Enriched.Thin (Decidable, Decision (..), decide)+import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..))+import Proarrow.Category.Instance.Cost (COST (..), GTE (..), IsCost (..), SCost (..))+import Proarrow.Category.Monoidal (Monoidal (..), leftUnitorWith, rightUnitorWith)+import Proarrow.Category.Monoidal.Distributive (Distributive (..))+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..))+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Core (CategoryOf (..), Hom, Promonad (..), obj)+import Proarrow.Limit.Terminal (HasTerminalObject (..), Semicartesian)++-- | As much of a quantale as a closure needs: a totally ordered, integral one. It is a+-- 'Semicartesian' 'Distributive' category, so the unit is the top element and the bottom absorbs,+-- the join of two objects is one of them ('minIs'), and the order is decidable. Totality makes a+-- single best walk exist. Infinite joins are not needed, since there are finitely many objects.+--+-- The methods reflect to the value level facts GHC cannot see through the type families: 'minIs'+-- is totality, 'unitIsNotBottom' says the order is nondegenerate, and 'unitIsTop' is antisymmetry+-- at the unit ('Semicartesian' gives the arrow the other way).+class (Semicartesian v, Distributive v, Decidable v) => Quantale v where+  minIs :: forall (x :: v) y. (Ob x, Ob y) => MinIs x y+  unitIsNotBottom :: forall r. (Unit :: v) ~> InitialObject -> r+  unitIsTop :: forall (w :: v) r. (Ob w) => (Unit ~> w) -> ((w ~ Unit) => r) -> r++-- | Which of two objects their join is.+type MinIs :: forall {v}. v -> v -> Type+data MinIs x y where+  MinLeft :: ((x || y) ~ x) => MinIs x y+  MinRight :: ((x || y) ~ y) => MinIs x y++-- | In an integral quantale a tensor lies below each of its factors, since the other factor is at+-- most the unit, so a unit into a tensor is a unit into each factor.+splitUnit :: forall {v} (x :: v) y. (Quantale v, Ob x, Ob y) => Unit ~> (x ** y) -> (Unit ~> x, Unit ~> y)+splitUnit f = (rightUnitorWith @x (terminate @v @y) . f, leftUnitorWith @y (terminate @v @x) . f)++-- | The bottom absorbs the tensor, and nothing lies below the bottom.+bottomTensor :: forall {v} (x :: v) y. (Quantale v, Ob x, Ob y) => (InitialObject ** x) ~> y+bottomTensor = initiate @v @y . absorbR @v @x++-- | The arrow between two objects of a decidable order, when the caller knows it exists but its+-- existence is not derived structurally (the triangle inequality for closures, for instance). As+-- elsewhere in "Proarrow.Category.Instance.Cost", it is checked at runtime.+checkedArrow :: forall v (x :: v) y. (Decidable v, Ob x, Ob y) => x ~> y+checkedArrow = case decide @(Hom v) @x @y of+  Yes f -> f+  No -> error "checkedArrow: the checked arrow does not exist"++-- | The walking arrow: the tensor is conjunction, the join disjunction.+instance Quantale BOOL where+  minIs @x = case obj @x of+    Tru -> MinLeft+    Fls -> MinRight+  unitIsNotBottom = \case {}+  unitIsTop Tru r = r++-- | Costs: the tensor is addition, the join the minimum. Distances are compared with 'cmpNat', whose+-- evidence makes the type-level 'Data.Type.Ord.Min' reduce; that a natural below @0@ is @0@ is+-- arithmetic GHC cannot see, so it is checked at runtime.+instance Quantale COST where+  minIs @x @y = case (sing @x, sing @y) of+    (SINF, _) -> MinRight+    (SC, SINF) -> MinLeft+    (SC @m, SC @m') -> case cmpNat (Proxy @m) (Proxy @m') of+      LTI -> MinLeft+      EQI -> MinLeft+      GTI -> MinRight+  unitIsNotBottom = \case {}+  unitIsTop @w f r = case sing @w of+    SINF -> case f of {}+    SC @m -> case f of+      GTE -> case cmpNat (Proxy @m) (Proxy @0) of+        EQI -> r+        LTI -> error "COST: a natural below 0"
+ src/Proarrow/Category/Enriched/Thin.hs view
@@ -0,0 +1,392 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Thin categories, where any two parallel arrows are equal: a 'ThinProfunctor' has at most one+-- element between any two objects, mere existence being captured by the constraint+-- @'HasArrow' p a b@. Also defines the codiscrete (always exactly one arrow) and discrete (only+-- identity arrows) special cases; 'DecidableProfunctor's, whose arrows are computed at the type+-- level as a 'BOOL' (the category thin profunctors are enriched in); and 'Indexed', 'Finite' and+-- 'Enumerable' kinds and categories, whose inhabitants are numbered, listed, and reflected to the+-- value level.+module Proarrow.Category.Enriched.Thin where++import Data.Kind (Constraint, Type)+import Data.Type.Equality (type (:~:) (..))+import Data.Type.Nat (Nat (..), SNat (..), SNatI, snat)+import Prelude (Maybe (..), type (~))++import Proarrow.Category.Instance.Bool (BOOL (..), BoolLeq, Booleans (..), NonTrivialHolds, NonTrivialProfunctor (..))+import Proarrow.Category.Instance.Zero (Bottom (..), VOID, Zero)+import Proarrow.Core (CAT, CategoryOf (..), Hom, Kind, Profunctor (..), VacuousOb, obj, type (+->))++-- | The defaults take everything from a 'DecidableProfunctor' instance: the arrow exists when+-- @'Holds' p a b@ computes to 'TRU'.+type ThinProfunctor :: forall {j} {k}. j +-> k -> Constraint+class (Profunctor p) => ThinProfunctor (p :: j +-> k) where+  type HasArrow (p :: j +-> k) (a :: k) (b :: j) :: Constraint+  type HasArrow p a b = Holds p a b ~ TRU+  arr :: (Ob a, Ob b, HasArrow p a b) => p a b+  default arr :: (Ob a, Ob b, DecidableProfunctor p, Holds p a b ~ TRU) => p a b+  arr = fromHolds+  withArr :: p a b -> ((HasArrow p a b, Ob a, Ob b) => r) -> r+  default withArr+    :: (DecidableProfunctor p, HasArrow p a b ~ (Holds p a b ~ TRU)) => p a b -> ((HasArrow p a b, Ob a, Ob b) => r) -> r+  withArr = toHolds++instance ThinProfunctor Zero+instance ThinProfunctor Booleans+instance (Ob ff, Ob tt) => ThinProfunctor (NonTrivialProfunctor '(ff, tt))++instance (VacuousOb k, Hom k ~ (:~:)) => ThinProfunctor ((:~:) :: CAT k) where+  type HasArrow ((:~:) :: CAT k) a b = a ~ b+  arr = Refl+  withArr Refl r = r++-- * Decidable thin profunctors++-- | The value-level shadow of a type-level 'BOOL' @h@ answering whether @p a b@ has an arrow: the+-- arrow itself when @h@ is 'TRU', nothing when it is 'FLS'.+type Decision :: forall {j} {k}. (j +-> k) -> k -> j -> BOOL -> Type+data Decision p a b h where+  Yes :: p a b -> Decision p a b TRU+  No :: Decision p a b FLS++mapDecision :: (p a b -> q c d) -> Decision p a b h -> Decision q c d h+mapDecision f (Yes x) = Yes (f x)+mapDecision _ No = No++-- | A thin profunctor whose arrows are decidable at the type level: @'Holds' p a b@ is the+-- 'BOOL'-valued profunctor a thin profunctor really is, computed by a type family, so it reduces to+-- 'TRU' or 'FLS' for concrete objects. It agrees with 'HasArrow' ('fromHolds' and 'toHolds' are the+-- two directions of that agreement, and the 'ThinProfunctor' defaults make it definitional), and+-- 'decide' computes the answer at the value level, arrow included. With it a composite of thin+-- profunctors can search for its middle object ("Proarrow.Category.Enriched.Thin.Composition").+type DecidableProfunctor :: forall {j} {k}. j +-> k -> Constraint+class (ThinProfunctor p) => DecidableProfunctor (p :: j +-> k) where+  type Holds (p :: j +-> k) (a :: k) (b :: j) :: BOOL+  decide :: (Ob a, Ob b) => Decision p a b (Holds p a b)+  toHolds :: p a b -> ((Holds p a b ~ TRU, Ob a, Ob b) => r) -> r++fromHolds :: forall {j} {k} (p :: j +-> k) a b. (DecidableProfunctor p, Ob a, Ob b, Holds p a b ~ TRU) => p a b+fromHolds = case decide @p @a @b of Yes x -> x++-- | A profunctor that decides against an arrow has none, so a caller holding one may return anything.+noArrow :: forall {j} {k} (p :: j +-> k) a b r. (DecidableProfunctor p, Holds p a b ~ FLS) => p a b -> r+noArrow x = case eq of {}+  where+    eq :: Holds p a b :~: TRU+    eq = toHolds x Refl++-- | A thin category whose order is decidable at the type level.+class (DecidableProfunctor (Hom k), CategoryOf k) => Decidable k++instance (DecidableProfunctor (Hom k), CategoryOf k) => Decidable k++instance DecidableProfunctor Zero where+  type Holds Zero a b = FLS+  decide = no+  toHolds = \case {}++instance DecidableProfunctor Booleans where+  type Holds Booleans a b = BoolLeq a b+  decide @a @b = case (obj @a, obj @b) of+    (Fls, Fls) -> Yes Fls+    (Fls, Tru) -> Yes F2T+    (Tru, Tru) -> Yes Tru+    (Tru, Fls) -> No+  toHolds Fls r = r+  toHolds F2T r = r+  toHolds Tru r = r++instance (Ob ff, Ob tt) => DecidableProfunctor (NonTrivialProfunctor '(ff, tt)) where+  type Holds (NonTrivialProfunctor '(ff, tt)) a b = NonTrivialHolds ff tt a b+  decide @a @b = case (obj @a, obj @b) of+    (Fls, Fls) -> case obj @ff of+      Fls -> No+      Tru -> Yes FF+    (Fls, Tru) -> Yes FT+    (Tru, Tru) -> case obj @tt of+      Fls -> No+      Tru -> Yes TT+    (Tru, Fls) -> No+  toHolds FF r = r+  toHolds FT r = r+  toHolds TT r = r++class (ThinProfunctor (Hom k), CategoryOf k) => Thin k+instance (ThinProfunctor (Hom k), CategoryOf k) => Thin k++class (ThinProfunctor p, Ob a, Ob b, HasArrow p a b) => HasArrow' p a b where arr' :: p a b+instance (ThinProfunctor p, Ob a, Ob b, HasArrow p a b) => HasArrow' p a b where arr' = arr++type CodiscreteProfunctor :: forall {j} {k}. j +-> k -> Constraint+class+  (ThinProfunctor p, forall c d. (Ob c, Ob d) => HasArrow' p c d, Codiscrete j, Codiscrete k) =>+  CodiscreteProfunctor (p :: j +-> k)+  where+  anyArr :: (Ob a, Ob b) => p a b+instance+  (ThinProfunctor p, forall c d. (Ob c, Ob d) => HasArrow' p c d, Codiscrete j, Codiscrete k)+  => CodiscreteProfunctor (p :: j +-> k)+  where+  anyArr = arr'++type Codiscrete k = CodiscreteProfunctor (Hom k)++class ((c) => d, (d) => c) => c <=> d+instance ((c) => d, (d) => c) => c <=> d++class ((HasArrow p a b) => Bottom) => HasNoArrow p a b where+  arrowIsBottomProof :: (HasArrow p a b) => r+instance ((HasArrow p a b) => Bottom) => HasNoArrow p a b where+  arrowIsBottomProof = no++type DiscreteProfunctor :: forall {j} {k}. j +-> k -> Constraint+class (ThinProfunctor p, forall a b. (Ob a, Ob b) => HasNoArrow p a b) => DiscreteProfunctor (p :: j +-> k) where+  exfalso :: p a b -> r+instance (ThinProfunctor p, forall a b. (Ob a, Ob b) => HasNoArrow p a b) => DiscreteProfunctor (p :: j +-> k) where+  exfalso @a @b p = withArr p (arrowIsBottomProof @p @a @b)++class ((HasArrow (Hom k) c d) <=> (c ~ d)) => ArrowIsId k c d where+  arrowIsIdProof :: (HasArrow (Hom k) c d) => ((c ~ d) => r) -> r+instance ((HasArrow (Hom k) c d) <=> (c ~ d)) => ArrowIsId k c d where+  arrowIsIdProof r = r++-- | @Discrete k@ is not the same as @DiscreteProfunctor (Hom k)@!+class (Thin k, forall c d. (Ob c, Ob d) => ArrowIsId k c d) => Discrete k where+  withEq :: (a :: k) ~> b -> ((a ~ b) => r) -> r++instance (Thin k, forall c d. (Ob c, Ob d) => ArrowIsId k c d) => Discrete k where+  withEq @a @b f r = withArr f (arrowIsIdProof @k @a @b r)++-- * Indexed, finite and enumerable kinds++-- | A kind whose inhabitants are numbered: 'Index' gives each its position and 'At' reads it back,+-- so that two inhabitants are equal exactly when their indices are ('decideEq'). 'At' is partial, so+-- that finitely many inhabitants can be numbered by an initial segment of the naturals.+class Indexed k where+  type Index (a :: k) :: Nat++  -- | A 'Finite' kind is numbered by its own object list: this default and the one for 'At' are+  -- inverse walks of 'Objects', so an instance that lists its inhabitants need say nothing here.+  type Index (a :: k) = IndexOf a (Objects k)++  type At k (i :: Nat) :: Maybe k+  type At k i = Lookup (Objects k) i++-- | The evidence that @a@ is numbered: its index, reflected, and 'At' reading it back.+class (SNatI (Index a), At k (Index a) ~ 'Just a) => KnownIndex (a :: k)++instance (SNatI (Index a), At k (Index a) ~ 'Just a) => KnownIndex (a :: k)++instance Indexed Nat where+  type Index n = n+  type At Nat i = 'Just i++-- | Equality of naturals, with evidence either way.+type NatEq :: Nat -> Nat -> BOOL+type family NatEq n m where+  NatEq 'Z 'Z = TRU+  NatEq ('S n) ('S m) = NatEq n m+  NatEq n m = FLS++natEq :: SNat n -> SNat m -> Decision (:~:) n m (NatEq n m)+natEq SZ SZ = Yes Refl+natEq (SS @n) (SS @m) = mapDecision (\Refl -> Refl) (natEq (snat @n) (snat @m))+natEq SZ SS = No+natEq SS SZ = No++withNatEqRefl :: forall n r. SNat n -> ((NatEq n n ~ TRU) => r) -> r+withNatEqRefl SZ r = r+withNatEqRefl (SS @n') r = withNatEqRefl (snat @n') r++-- | Two numbered inhabitants are equal exactly when their indices are.+type Equal (a :: k) (b :: k) = NatEq (Index a) (Index b)++decideEq :: forall {k} (a :: k) b. (KnownIndex a, KnownIndex b) => Decision (:~:) a b (Equal a b)+decideEq = case natEq (snat @(Index a)) (snat @(Index b)) of+  Yes Refl -> Yes Refl+  No -> No++type Length :: [k] -> Nat+type family Length xs where+  Length '[] = 'Z+  Length (x ': xs) = 'S (Length xs)++type Lookup :: [k] -> Nat -> Maybe k+type family Lookup xs i where+  Lookup '[] i = 'Nothing+  Lookup (x ': xs) 'Z = 'Just x+  Lookup (x ': xs) ('S i) = Lookup xs i++-- | The inhabitant at an index in a type-level list known to be long enough: 'Lookup' without the+-- 'Maybe', for tables indexed by 'Index'. Out of range it is stuck rather than 'Nothing'.+type Entry :: [k] -> Nat -> k+type family Entry xs i where+  Entry (x ': xs) 'Z = x+  Entry (x ': xs) ('S i) = Entry xs i++-- | Every entry of @xs@ satisfies @c@. The list is shaped like @shape@, a list of objects, so that+-- an index into @shape@ selects an entry of @xs@. The equality argument ties the index to @shape@,+-- so that walking off the end is refutable rather than an error.+type KnownList :: forall {x} {y}. (x -> Constraint) -> [y] -> [x] -> Constraint+class KnownList c shape xs where+  withEntry :: forall s i r. SNat i -> Lookup shape i :~: 'Just s -> ((c (Entry xs i)) => r) -> r++instance KnownList c '[] '[] where+  withEntry _ eq _ = case eq of {}++instance (c x, KnownList c shape xs) => KnownList c (s ': shape) (x ': xs) where+  withEntry SZ Refl r = r+  withEntry (SS @i') eq r = withEntry @c @shape @xs (snat @i') eq r++-- | Where an inhabitant sits in a type-level list, the inverse of 'Lookup'. An inhabitant that does+-- not occur has no index, so the family is stuck rather than total.+type IndexOf :: forall k. k -> [k] -> Nat+type family IndexOf a xs where+  IndexOf a (a ': xs) = 'Z+  IndexOf a (b ': xs) = 'S (IndexOf a xs)++-- | A type-level list of inhabitants, reflected to the value level with their indices.+type IndexedList :: forall k. [k] -> Type+data IndexedList as where+  FNil :: IndexedList '[]+  FCons :: forall a as. (KnownIndex a) => IndexedList as -> IndexedList (a ': as)++-- | Every element of the list is numbered, so the list can be reflected to an 'IndexedList'. So a+-- kind that simply writes its objects out gets 'finite' for free.+class HasFiniteDefault (xs :: [k]) where+  finiteDefault :: IndexedList xs++instance HasFiniteDefault '[] where+  finiteDefault = FNil+instance (KnownIndex a, HasFiniteDefault as) => HasFiniteDefault (a ': as) where+  finiteDefault = FCons finiteDefault++-- | An 'Indexed' kind with finitely many inhabitants, listed in 'Objects' in the order of their+-- indices: 'withAtLookup' says that the list tabulates 'At'.+class (Indexed k) => Finite k where+  type Objects k :: [k]+  finite :: IndexedList (Objects k)+  default finite :: (HasFiniteDefault (Objects k)) => IndexedList (Objects k)+  finite = finiteDefault+  withAtLookup :: forall (i :: Nat) r. SNat i -> ((Lookup (Objects k) i ~ At k i) => r) -> r+  default withAtLookup+    :: forall (i :: Nat) r. (At k i ~ Lookup (Objects k) i) => SNat i -> ((Lookup (Objects k) i ~ At k i) => r) -> r+  withAtLookup _ r = r++-- | A proof that @a@ occurs in the type-level list @as@.+type Member :: forall k. k -> [k] -> Type+data Member a as where+  Here :: Member a (a ': as)+  There :: Member a as -> Member a (b ': as)++-- | Every numbered inhabitant of a finite kind occurs in its list: walk to its index.+memberIndex :: forall {k} (a :: k). (Finite k, KnownIndex a) => Member a (Objects k)+memberIndex = withAtLookup @k (snat @(Index a)) (go (snat @(Index a)) (finite @k))+  where+    go :: forall i xs. (Lookup xs i ~ 'Just a) => SNat i -> IndexedList xs -> Member a xs+    go SZ (FCons _) = Here+    go (SS @i') (FCons xs) = There (go (snat @i') xs)++-- | A category on a 'Finite' kind whose objects are exactly its numbered inhabitants: 'withIndex'+-- and 'withOb' convert between the two notions, and 'atOb' looks an object up by its index.+type Enumerable :: Kind -> Constraint+class (CategoryOf k, Finite k) => Enumerable k where+  withIndex :: forall (a :: k) r. (Ob a) => ((KnownIndex a) => r) -> r+  withOb :: forall (a :: k) r. (KnownIndex a) => ((Ob a) => r) -> r+  withOb @x r = case atOb @k (snat @(Index x)) of AtJust -> r++  -- | The object at an index, if there is one. The default walks the object list, which is all a+  -- kind in general can do. A kind that can answer from the index alone should say so, and a wrapper+  -- kind whose base is itself 'Enumerable' should defer to it. The discrete kinds cannot, since+  -- they ask only that the kind they wrap be 'Finite'.+  atOb :: forall (i :: Nat). SNat i -> AtOb k (At k i)+  atOb i = withAtLookup @k i (lookupOb @k i (finite @k))++  {-# MINIMAL withIndex, (atOb | withOb) #-}++-- | Locate an object in the object list.+member :: forall {k} (a :: k). (Enumerable k, Ob a) => Member a (Objects k)+member = withIndex @k @a (memberIndex @a)++-- | Whether the inhabitant at an index exists, and if so that it is an object. Indexed by the lookup+-- itself, so that a caller holding @'At' k i ~ ''Just' a@ learns @'Ob' a@. A wrapper kind needs+-- this to recover the objects of the kind it wraps.+type AtOb :: forall k -> Maybe k -> Type+data AtOb k x where+  AtNothing :: AtOb k 'Nothing+  AtJust :: (Ob a, KnownIndex a) => AtOb k ('Just a)++-- | A numbered inhabitant is found at its own index, so evidence that nothing is there refutes+-- itself: under @'KnownIndex' a@ the argument's type is @''Just' a ':~:' ''Nothing'@, and a caller+-- holding one may return anything.+noIndex :: forall {k} (a :: k) r. (KnownIndex a) => At k (Index a) :~: 'Nothing -> r+noIndex eq = case eq of {}++-- | A kind that wraps another, one inhabitant for one, keeps its numbering: map the wrapper over the+-- lookup ('FmapWrap') and over the object list ('MapWrap'), and the two agree ('withLookupMapWrap').+type FmapWrap :: forall {j} {k}. (j -> k) -> Maybe j -> Maybe k+type family FmapWrap w x where+  FmapWrap w 'Nothing = 'Nothing+  FmapWrap w ('Just a) = 'Just (w a)++type MapWrap :: forall {j} {k}. (j -> k) -> [j] -> [k]+type family MapWrap w xs where+  MapWrap w '[] = '[]+  MapWrap w (x ': xs) = w x ': MapWrap w xs++mapWrap+  :: forall {j} {k} (w :: j -> k) xs+   . (forall (a :: j). (KnownIndex a) => KnownIndex (w a))+  => IndexedList xs -> IndexedList (MapWrap w xs)+mapWrap FNil = FNil+mapWrap (FCons @a xs) = FCons @(w a) (mapWrap @w xs)++withLookupMapWrap+  :: forall {j} {k} (w :: j -> k) xs i r+   . SNat i -> IndexedList xs -> ((Lookup (MapWrap w xs) i ~ FmapWrap w (Lookup xs i)) => r) -> r+withLookupMapWrap _ FNil r = r+withLookupMapWrap SZ (FCons _) r = r+withLookupMapWrap (SS @i') (FCons xs) r = withLookupMapWrap @w (snat @i') xs r++-- | The two 'Finite' methods of a wrapper kind, which are the same for every wrapper.+wrapFinite+  :: forall {j} {k} (w :: j -> k)+   . (Finite j, forall (a :: j). (KnownIndex a) => KnownIndex (w a))+  => IndexedList (MapWrap w (Objects j))+wrapFinite = mapWrap @w (finite @j)++withWrapAtLookup+  :: forall {j} {k} (w :: j -> k) i r+   . (Finite j)+  => SNat i -> ((Lookup (MapWrap w (Objects j)) i ~ FmapWrap w (At j i)) => r) -> r+withWrapAtLookup i r = withAtLookup @j i (withLookupMapWrap @w i (finite @j) r)++-- | The default 'atOb': walk the object list to the index.+lookupOb :: forall k (j :: Nat) xs. (Enumerable k) => SNat j -> IndexedList (xs :: [k]) -> AtOb k (Lookup xs j)+lookupOb _ FNil = AtNothing+lookupOb SZ (FCons @a _) = withOb @k @a AtJust+lookupOb (SS @j') (FCons xs) = lookupOb @k (snat @j') xs++instance Indexed BOOL++instance Finite BOOL where type Objects BOOL = '[FLS, TRU]++instance Enumerable BOOL where+  withIndex @a r = case obj @a of+    Fls -> r+    Tru -> r+  withOb @a r = case snat @(Index a) of+    SZ -> r+    SS @i -> case snat @i of SZ -> r++-- | The empty kind has no inhabitants to number.+instance Indexed VOID where+  type Index (a :: VOID) = 'Z+  type At VOID i = 'Nothing++instance Finite VOID where type Objects VOID = '[]++instance Enumerable VOID where+  withIndex _ = no+  withOb @a _ = noIndex @a Refl
+ src/Proarrow/Category/Enriched/Thin/Composition.hs view
@@ -0,0 +1,509 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Composition of thin profunctors. In general the arrows of a composite @p ':.:' q@ are an+-- existential over the objects of the middle category, which a 'Constraint' cannot express. This+-- module dispatches on the shape of the legs, so that the single 'ThinProfunctor' instance for+-- ':.:' never overlaps with anything: a representable leg pins the middle object down, and+-- otherwise the middle category is searched ('Search'), which needs it to be 'Enumerable' and both+-- legs to be 'DecidableProfunctor's. Composites are themselves decidable, so searches nest.+module Proarrow.Category.Enriched.Thin.Composition where++import Data.Kind (Constraint, Type)+import Data.Type.Nat (Nat (..), SNat (..), SNatI, snat)+import Prelude (type (~))++import Proarrow.Category.Enriched (Enriched, EnrichedProfunctor (..), HomObj)+import Proarrow.Category.Enriched.Quantale (MinIs (..), Quantale (..), checkedArrow, splitUnit)+import Proarrow.Category.Enriched.Thin+  ( Decidable+  , DecidableProfunctor (..)+  , Decision (..)+  , Enumerable (..)+  , Finite (..)+  , IndexedList (..)+  , Length+  , Member (..)+  , Thin+  , ThinProfunctor (..)+  , mapDecision+  , member+  )+import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..))+import Proarrow.Category.Instance.Cost (COST)+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..))+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..))+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Core (CategoryOf (..), Hom, Kind, Profunctor (..), Promonad (..), obj, type (+->))+import Proarrow.Core qualified as P+import Proarrow.Functor (FunctorForRep (..), withMappedOb)+import Proarrow.Object (pattern Objs)+import Proarrow.Profunctor.Corepresentable (Corep (..), Corepresentable (..), withObCorep)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Representable (CorepStar (..), Rep (..), RepCostar (..), Representable (..), withObRep)++-- | How a composite @p ':.:' q@ of thin profunctors decides its arrows. In general+-- @'HasArrow' (p :.: q) a c@ is an existential over the middle objects @b@ (the join+-- @⋁_b p(a,b) ∧ q(b,c)@), which a 'Constraint' cannot express. When the left leg is corepresented+-- (@f a ≤ b@) or the right leg represented (@b ≤ g c@) the middle object is determined, and the+-- existential becomes @q (f a) c@, respectively @p a (g c)@. The closed family 'ThinCompStrategy'+-- picks the strategy from the shape of the legs, so the one 'ThinProfunctor' instance for ':.:'+-- overlaps nothing. Other composites use 'BySearch', which tries every middle object ('Search').+-- ('Proarrow.Profunctor.Instance.Star.Star' and 'Proarrow.Profunctor.Instance.Costar.Costar' have+-- the same shapes, but functors between thin kinds are 'FunctorForRep's here.)+type data ThinComp = ByLeft | ByRight | BySearch++type ThinCompStrategy :: forall {i} {j} {k}. (j +-> k) -> (i +-> j) -> ThinComp+type family ThinCompStrategy p q where+  ThinCompStrategy (RepCostar p) q = ByLeft+  ThinCompStrategy (Corep f) q = ByLeft+  ThinCompStrategy p (Rep g) = ByRight+  ThinCompStrategy p (CorepStar q) = ByRight+  ThinCompStrategy p q = BySearch++type ComposeThin :: forall {i} {j} {k}. ThinComp -> (j +-> k) -> (i +-> j) -> Constraint+class (ThinProfunctor p, ThinProfunctor q) => ComposeThin s (p :: j +-> k) (q :: i +-> j) where+  type HasArrowComp s p q (a :: k) (c :: i) :: Constraint+  arrComp :: (Ob (a :: k), Ob (c :: i), HasArrowComp s p q a c) => (p :.: q) a c+  withArrComp :: (p :.: q) a c -> ((HasArrowComp s p q a c, Ob a, Ob c) => r) -> r++-- | A corepresented left leg forces the middle object down to @p % a@.+instance (Representable p, Thin j, ThinProfunctor q) => ComposeThin ByLeft (RepCostar p :: j +-> k) (q :: i +-> j) where+  type HasArrowComp ByLeft (RepCostar p) q a c = HasArrow q (p % a) c+  arrComp @a @c = withObRep @p @a (RepCostar id :.: arr @q @(p % a) @c)+  withArrComp (RepCostar f :.: q) r = withArr (P.lmap f q) r++instance (FunctorForRep f, Thin j, ThinProfunctor q) => ComposeThin ByLeft (Corep f :: j +-> k) (q :: i +-> j) where+  type HasArrowComp ByLeft (Corep f) q a c = HasArrow q (f @ a) c+  arrComp @a @c = withMappedOb @f @a (Corep id :.: arr @q @(f @ a) @c)+  withArrComp (Corep f :.: q) r = withArr (P.lmap f q) r++-- | A represented right leg forces the middle object up to @g @ c@.+instance (ThinProfunctor p, FunctorForRep g, Thin j) => ComposeThin ByRight (p :: j +-> k) (Rep g :: i +-> j) where+  type HasArrowComp ByRight p (Rep g) a c = HasArrow p a (g @ c)+  arrComp @a @c = withMappedOb @g @c (arr @p @a @(g @ c) :.: Rep id)+  withArrComp (p :.: Rep g) r = withArr (P.rmap g p) r++instance (ThinProfunctor p, Corepresentable q, Thin j) => ComposeThin ByRight (p :: j +-> k) (CorepStar q :: i +-> j) where+  type HasArrowComp ByRight p (CorepStar q) a c = HasArrow p a (q %% c)+  arrComp @a @c = withObCorep @q @c (arr @p @a @(q %% c) :.: CorepStar id)+  withArrComp (p :.: CorepStar g) r = withArr (P.rmap g p) r++instance (ComposeThin (ThinCompStrategy p q) p q) => ThinProfunctor (p :.: q) where+  type HasArrow (p :.: q) a c = HasArrowComp (ThinCompStrategy p q) p q a c+  arr = arrComp @(ThinCompStrategy p q)+  withArr = withArrComp @(ThinCompStrategy p q)++-- | The join @⋁_b p(a,b) ⊗ w_b@ of an edge out of @a@ with whatever the vector holds for where+-- that edge lands: one row of the matrix of @p@ against a vector, over the given middle objects.+-- The objects and the vector are walked in step, so @ws@ is always the vector cut down to @bs@.+--+-- This is the module's one join. Composing two profunctors multiplies by a column read off the+-- right-hand one ('MatMul'). The closure multiplies by the previous iterate ('Walks'), so that+-- iterate is computed once instead of once per pair.+type MatVec :: forall {j} {k}. forall (v :: Kind) -> [j] -> [v] -> (j +-> k) -> k -> v+type family MatVec v bs ws p a where+  MatVec v '[] ws p a = InitialObject+  MatVec v (b ': bs) (w ': ws) p a = (ProObj v p a b ** w) || MatVec v bs ws p a++-- | One column of the matrix of an enriched profunctor: its hom-objects into @c@, over the given+-- objects.+type MatCol :: forall {i} {j}. forall (v :: Kind) -> [j] -> (i +-> j) -> i -> [v]+type family MatCol v bs q c where+  MatCol v '[] q c = '[]+  MatCol v (b ': bs) q c = ProObj v q b c ': MatCol v bs q c++-- | Matrix multiplication over a list of middle objects, @⋁_b p(a,b) ⊗ q(b,c)@: the hom-object of+-- the composite of two enriched profunctors when the middle category is enumerable. The type-level+-- twin of "Proarrow.Category.Instance.FinRel".+type MatMul :: forall {i} {j} {k}. forall (v :: Kind) -> [j] -> (j +-> k) -> (i +-> j) -> k -> i -> v+type MatMul v bs p q a c = MatVec v bs (MatCol v bs q c) p a++-- | The arrows of a composite by search: is there an object @b@ among @bs@ with both @p a b@ and+-- @q b c@? Over the full object list this is the join @⋁_b p(a,b) ∧ q(b,c)@, which is 'MatMul' in+-- the enriching 'BOOL'.+type Search :: forall {i} {j} {k}. [j] -> (j +-> k) -> (i +-> j) -> k -> i -> BOOL+type Search bs p q a c = MatMul BOOL bs p q a c++-- | Neither leg representable: search the middle category for an object that both legs accept.+instance+  (DecidableProfunctor p, DecidableProfunctor q, Enumerable j)+  => ComposeThin BySearch (p :: j +-> k) (q :: i +-> j)+  where+  type HasArrowComp BySearch (p :: j +-> k) q a c = Search (Objects j) p q a c ~ TRU+  arrComp @a @c = case search @p @q @a @c (finite @j) of Yes x -> x+  withArrComp (p :.: q) r = found p q r++-- | Walk the object list deciding both legs at each object; a hit is the composite, and a miss+-- reduces the search to the tail of the list.+search+  :: forall {i} {j} {k} (p :: j +-> k) (q :: i +-> j) (a :: k) (c :: i) (bs :: [j])+   . (DecidableProfunctor p, DecidableProfunctor q, Enumerable j, Ob a, Ob c)+  => IndexedList bs -> Decision (p :.: q) a c (Search bs p q a c)+search FNil = No+search (FCons @b bs) = withOb @j @b case (decide @p @a @b, decide @q @b @c) of+  (Yes x, Yes y) -> Yes (x :.: y)+  (No, _) -> search @p @q @a @c bs+  (Yes _, No) -> search @p @q @a @c bs++-- | An actual composite proves the search succeeds: locate its middle object in the list, then at+-- that position both legs hold and the disjunction is 'TRU' whatever the rest of the list says.+found+  :: forall {i} {j} {k} (p :: j +-> k) (q :: i +-> j) (a :: k) (b :: j) (c :: i) r+   . (DecidableProfunctor p, DecidableProfunctor q, Enumerable j)+  => p a b -> q b c -> ((Search (Objects j) p q a c ~ TRU, Ob a, Ob c) => r) -> r+found p q r = toHolds p (toHolds q (go (member @b) r))+  where+    go+      :: forall bs+       . (Holds p a b ~ TRU, Holds q b c ~ TRU)+      => Member b bs -> ((Search bs p q a c ~ TRU) => r) -> r+    go Here r' = r'+    go (There m) r' = go m r'++-- | Whether a composite decides its arrows, by the same strategy as 'ComposeThin': a representable+-- leg is substituted away and the other leg decided, a search is decided by running it. So+-- composites are decidable in turn, and searches can nest.+type DecideComp :: forall {i} {j} {k}. ThinComp -> (j +-> k) -> (i +-> j) -> Constraint+class (ComposeThin s p q) => DecideComp s (p :: j +-> k) (q :: i +-> j) where+  type HoldsComp s p q (a :: k) (c :: i) :: BOOL+  decideComp :: (Ob (a :: k), Ob (c :: i)) => Decision (p :.: q) a c (HoldsComp s p q a c)+  toHoldsComp :: (p :.: q) a c -> ((HoldsComp s p q a c ~ TRU, Ob a, Ob c) => r) -> r++instance+  (Representable p, Thin j, DecidableProfunctor q)+  => DecideComp ByLeft (RepCostar p :: j +-> k) (q :: i +-> j)+  where+  type HoldsComp ByLeft (RepCostar p) q a c = Holds q (p % a) c+  decideComp @a @c = withObRep @p @a (mapDecision (RepCostar id :.:) (decide @q @(p % a) @c))+  toHoldsComp (RepCostar f :.: q) r = toHolds (P.lmap f q) r++instance+  (FunctorForRep f, Thin j, DecidableProfunctor q)+  => DecideComp ByLeft (Corep f :: j +-> k) (q :: i +-> j)+  where+  type HoldsComp ByLeft (Corep f) q a c = Holds q (f @ a) c+  decideComp @a @c = withMappedOb @f @a (mapDecision (Corep id :.:) (decide @q @(f @ a) @c))+  toHoldsComp (Corep f :.: q) r = toHolds (P.lmap f q) r++instance+  (DecidableProfunctor p, FunctorForRep g, Thin j)+  => DecideComp ByRight (p :: j +-> k) (Rep g :: i +-> j)+  where+  type HoldsComp ByRight p (Rep g) a c = Holds p a (g @ c)+  decideComp @a @c = withMappedOb @g @c (mapDecision (:.: Rep id) (decide @p @a @(g @ c)))+  toHoldsComp (p :.: Rep g) r = toHolds (P.rmap g p) r++instance+  (DecidableProfunctor p, Corepresentable q, Thin j)+  => DecideComp ByRight (p :: j +-> k) (CorepStar q :: i +-> j)+  where+  type HoldsComp ByRight p (CorepStar q) a c = Holds p a (q %% c)+  decideComp @a @c = withObCorep @q @c (mapDecision (:.: CorepStar id) (decide @p @a @(q %% c)))+  toHoldsComp (p :.: CorepStar g) r = toHolds (P.rmap g p) r++instance+  (DecidableProfunctor p, DecidableProfunctor q, Enumerable j)+  => DecideComp BySearch (p :: j +-> k) (q :: i +-> j)+  where+  type HoldsComp BySearch (p :: j +-> k) q a c = Search (Objects j) p q a c+  decideComp @a @c = search @p @q @a @c (finite @j)+  toHoldsComp = withArrComp @BySearch++instance (DecideComp (ThinCompStrategy p q) p q) => DecidableProfunctor (p :.: q) where+  type Holds (p :.: q) a c = HoldsComp (ThinCompStrategy p q) p q a c+  decide @a @c = decideComp @(ThinCompStrategy p q) @p @q @a @c+  toHolds = toHoldsComp @(ThinCompStrategy p q)++-- * Closure: walks along a graph, in any enriching category++-- | A walk of at most @n@ steps along @p@, finished by an arrow of the base category. Its+-- hom-object in any enriching category is 'Walks': at 'BOOL' the truth of the walk, decided with+-- the path as witness; at 'COST' the shortest distance.+type Walk :: forall {k}. Nat -> (k +-> k) -> k +-> k+data Walk n p a b where+  Done :: forall {k} n (p :: k +-> k) a b. (a ~> b) -> Walk n p a b+  Step :: forall {k} n (p :: k +-> k) a c b. p a c -> Walk n p c b -> Walk ('S n) p a b++instance (Profunctor p) => Profunctor (Walk n p) where+  dimap l r (Done f) = Done (r . f . l)+  dimap l r (Step e w) = Step (P.lmap l e) (P.rmap r w)+  r \\ Done f = r \\ f+  r \\ Step e w = r \\ e \\ w++-- | The hom-object of a walk of at most @n@ steps, in any enriching category @v@: an arrow of the+-- base, or an edge followed by one entry of the previous iterate ('WalkRow'). Naming the whole+-- iterate, instead of a shorter walk per pair, keeps this affordable. At 'BOOL' it is the+-- truth of 'Walk', at 'COST' the shortest distance, computed by GHC at the type level and by 'row'+-- at the value level.+type Walks :: forall {k}. forall (v :: Kind) -> Nat -> (k +-> k) -> k -> k -> v+type family Walks v n p a b where+  Walks v 'Z (p :: k +-> k) a b = HomObj v a b+  Walks v ('S n) (p :: k +-> k) a b = HomObj v a b || MatVec v (Objects k) (WalkRow v n p b) p a++-- | The @n@-th iterate of the fixed point for a fixed target @b@: the hom-objects of the walks of+-- at most @n@ steps into @b@, one per object, in the order of 'Objects'. It starts as the column of+-- base hom-objects and grows by 'NextRow'.+--+-- Each iterate is built from the whole previous one, so it is computed once and shared by every+-- object: steps × objects² work, where a recursion per pair of objects costs objects^steps.+type WalkRow :: forall {k}. forall (v :: Kind) -> Nat -> (k +-> k) -> k -> [v]+type family WalkRow v n p b where+  WalkRow v 'Z (p :: k +-> k) b = MatCol v (Objects k) (Hom k) b+  WalkRow v ('S n) (p :: k +-> k) b = NextRow v (Objects k) (WalkRow v n p b) p b++-- | One more step, taken for every object at once: an arrow of the base, or an edge into the+-- previous iterate ('MatVec').+type NextRow :: forall {k}. forall (v :: Kind) -> [k] -> [v] -> (k +-> k) -> k -> [v]+type family NextRow v as row p b where+  NextRow v '[] row p b = '[]+  NextRow v (a ': as) row (p :: k +-> k) b =+    (HomObj v a b || MatVec v (Objects k) row p a) ': NextRow v as row p b++-- | The Kleene closure of @p@: walks of at most as many steps as there are objects, which is all+-- of them, since a shortest walk never revisits an object. It is the free category on the graph+-- @p@ in whatever @p@ is enriched in: at 'BOOL' the reflexive-transitive closure of a relation, with+-- the path as witness ('decide'); at 'COST' the free Lawvere metric space, with the shortest+-- distances ('withProObj') and the shortest paths ('shortest').+type Closure (p :: k +-> k) = Walk (Length (Objects k)) p++-- * Graded walks++-- | What the closure needs of its ingredients: a quantale to compute in, an enriched graph over an+-- enumerable enriched base, and a known number of steps.+type Closing :: forall {k}. Kind -> Nat -> (k +-> k) -> Constraint+type Closing v n (p :: k +-> k) = (SNatI n, Quantale v, EnrichedProfunctor v p, Enriched v k, Enumerable k)++-- | A walk graded by its cost: each piece comes with a budget, an arrow of @v@ into the piece's+-- hom-object, and the grade of the walk is the tensor of the budgets. A walk at grade @d@ is a+-- generalised element of the closure, @d ~> 'Walks' v n p a b@ ('underlyingAt'), and 'shortest'+-- produces one whose grade is the hom-object itself.+type GradedWalk :: forall {k}. forall (v :: Kind) -> Nat -> (k +-> k) -> v -> k -> k -> Type+data GradedWalk v n p d a b where+  DoneAt :: forall {k} v n (p :: k +-> k) d a b. (Ob a, Ob b) => (d ~> HomObj v a b) -> GradedWalk v n p d a b+  StepAt+    :: forall {k} v n (p :: k +-> k) a c b e d+     . (Ob a, Ob b, Ob c, Ob e, Ob d)+    => (e ~> ProObj v p a c) -> GradedWalk v n p d c b -> GradedWalk v ('S n) p (e ** d) a b++-- | The @n@-th iterate reflected to the value level: every object paired with its own entry, the+-- hom-object of the walks from it. 'row' builds one and everything that needs a+-- shorter walk reads it, so the value level shares its work the same way the type level does.+type Row :: forall {k}. forall (v :: Kind) -> Nat -> (k +-> k) -> k -> [k] -> [v] -> Type+data Row v n p b as ws where+  RNil :: Row v n p b '[] '[]+  RCons+    :: forall {k} a as v ws n (p :: k +-> k) b+     . (Ob a, Ob (Walks v n p a b))+    => Row v n p b as ws -> Row v n p b (a ': as) (Walks v n p a b ': ws)++-- | The @n@-th iterate: the base hom-objects, then one more step for every object at a time.+row :: forall {k} v n (p :: k +-> k) b. (Closing v n p, Ob b) => Row v n p b (Objects k) (WalkRow v n p b)+row = case snat @n of+  SZ ->+    let homRow :: forall as. IndexedList as -> Row v 'Z p b as (MatCol v as (Hom k) b)+        homRow FNil = RNil+        homRow (FCons @a as) = withOb @k @a (withProObj @v @(Hom k) @a @b (RCons (homRow as)))+    in homRow (finite @k)+  SS @n' ->+    let prev = row @v @n' @p @b+        nextRow :: forall as. IndexedList as -> Row v ('S n') p b as (NextRow v as (WalkRow v n' p b) p b)+        nextRow FNil = RNil+        nextRow (FCons @a as) =+          withOb @k @a+            ( withProObj @v @(Hom k) @a @b+                ( withObMatVec @a+                    prev+                    ( withObCoprod @v @(HomObj v a b) @(MatVec v (Objects k) (WalkRow v n' p b) p a)+                        (RCons (nextRow as))+                    )+                )+            )+    in nextRow (finite @k)++-- | Object evidence for the hom-object of a walk: read the object's own entry out of an iterate.+withObRow+  :: forall {k} (a :: k) v n (p :: k +-> k) b cs ws r+   . Member a cs -> Row v n p b cs ws -> ((Ob (Walks v n p a b)) => r) -> r+withObRow Here (RCons _) r = r+withObRow (There m) (RCons rest) r = withObRow m rest r++-- | The same, for a caller that is not already holding the iterate.+withObWalks+  :: forall {k} v n (p :: k +-> k) a b r+   . (Closing v n p, Ob a, Ob b)+  => ((Ob (Walks v n p a b)) => r) -> r+withObWalks = withObRow (member @a) (row @v @n @p @b)++-- | Object evidence for one summand of 'MatVec': an edge and its tensor with the entry after it.+withObStep+  :: forall {k} v n (p :: k +-> k) a c b r+   . (Closing v n p, Ob a, Ob c, Ob (Walks v n p c b))+  => ((Ob (ProObj v p a c), Ob (ProObj v p a c ** Walks v n p c b)) => r) -> r+withObStep r = withProObj @v @p @a @c (withOb2 @v @(ProObj v p a c) @(Walks v n p c b) r)++-- | Object evidence for the join over the given middle objects.+withObMatVec+  :: forall {k} a v n (p :: k +-> k) b cs ws r+   . (Closing v n p, Ob a)+  => Row v n p b cs ws -> ((Ob (MatVec v cs ws p a)) => r) -> r+withObMatVec RNil r = r+withObMatVec (RCons @c @cs' @_ @ws' rest) r =+  withObStep @v @n @p @a @c @b+    ( withObMatVec @a+        rest+        (withObCoprod @v @(ProObj v p a c ** Walks v n p c b) @(MatVec v cs' ws' p a) r)+    )++-- | A graded walk is a generalised element of the closure: inject it into the join at its middle+-- object.+underlyingAt+  :: forall {k} v n (p :: k +-> k) d a b+   . (Closing v n p)+  => GradedWalk v n p d a b -> d ~> Walks v n p a b+underlyingAt (DoneAt g) = case snat @n of+  SZ -> g+  SS @n' ->+    withProObj @v @(Hom k) @a @b+      ( withObMatVec @a+          (row @v @n' @p @b)+          (lft @v @(HomObj v a b) @(MatVec v (Objects k) (WalkRow v n' p b) p a))+      )+      . g+underlyingAt (StepAt @_ @_ @_ @_ @c ee w) = case snat @n of+  SS @n' -> stepAt @v @n' @p @a @c @b ee (underlyingAt w)++-- | An edge with a budget, followed by a generalised element of the shorter walks.+stepAt+  :: forall {k} v n (p :: k +-> k) a c b e d+   . (Closing v n p, Ob a, Ob b, Ob c)+  => (e ~> ProObj v p a c) -> (d ~> Walks v n p c b) -> (e ** d) ~> Walks v ('S n) p a b+stepAt ee uw = case ee ** uw of+  step@Objs ->+    let rw = row @v @n @p @b+    in withProObj @v @(Hom k) @a @b+         ( withObMatVec @a+             rw+             ( withObRow+                 (member @c)+                 rw+                 ( rgt @v @(HomObj v a b) @(MatVec v (Objects k) (WalkRow v n p b) p a)+                     . inject @a rw (member @c)+                     . step+                 )+             )+         )++-- | The injection of one summand into the join over the middle objects.+inject+  :: forall {k} a v n (p :: k +-> k) b c cs ws+   . (Closing v n p, Ob a, Ob c, Ob (Walks v n p c b))+  => Row v n p b cs ws -> Member c cs -> (ProObj v p a c ** Walks v n p c b) ~> MatVec v cs ws p a+inject RNil m = case m of {}+inject (RCons @_ @cs' @_ @ws' rest) Here =+  withObStep @v @n @p @a @c @b+    ( withObMatVec @a+        rest+        (lft @v @(ProObj v p a c ** Walks v n p c b) @(MatVec v cs' ws' p a))+    )+inject (RCons @c' @cs' @_ @ws' rest) (There m) =+  withObStep @v @n @p @a @c' @b+    ( withObMatVec @a+        rest+        ( rgt @v @(ProObj v p a c' ** Walks v n p c' b) @(MatVec v cs' ws' p a)+            . inject @a rest m+        )+    )++-- | A walk of pieces at the unit, as a generalised element at the unit.+underlyingWalk+  :: forall {k} v n (p :: k +-> k) a b+   . (Closing v n p)+  => Walk n p a b -> Unit ~> Walks v n p a b+underlyingWalk (Done f@Objs) = underlyingAt @v @n @p @Unit @a @b (DoneAt @v @n @p @Unit @a @b (underlying @v @(Hom k) @a @b f))+underlyingWalk (Step @_ @_ @_ @c e@Objs w@Objs) = case snat @n of+  SS @n' -> stepAt @v @n' @p @a @c @b (underlying @v @p e) (underlyingWalk @v w) . leftUnitorInv @v @Unit++-- | The best walk between two points, graded by their hom-object itself: a shortest path at+-- 'COST', a path or the absence of one at 'BOOL'. At every join it keeps the summand the join is+-- ('minIs'); a pair no walk connects gets the empty walk at 'InitialObject'.+shortest+  :: forall {k} v n (p :: k +-> k) a b+   . (Closing v n p, Ob a, Ob b)+  => GradedWalk v n p (Walks v n p a b) a b+shortest = case snat @n of+  SZ -> withProObj @v @(Hom k) @a @b (DoneAt @v @n @p (obj @(HomObj v a b)))+  SS @n' ->+    let rw = row @v @n' @p @b+    in withProObj @v @(Hom k) @a @b+         ( withObMatVec @a rw case minIs @v @(HomObj v a b) @(MatVec v (Objects k) (WalkRow v n' p b) p a) of+             MinLeft -> DoneAt @v @n @p (obj @(HomObj v a b))+             MinRight -> best @a rw+         )++-- | The best walk through one of the given middle objects.+best+  :: forall {k} a v n (p :: k +-> k) b cs ws+   . (Closing v n p, Ob a, Ob b)+  => Row v n p b cs ws -> GradedWalk v ('S n) p (MatVec v cs ws p a) a b+best RNil = withProObj @v @(Hom k) @a @b (DoneAt @v @('S n) @p (initiate @v @(HomObj v a b)))+best (RCons @c @cs' @_ @ws' rest) =+  withObStep @v @n @p @a @c @b+    ( withObMatVec @a rest case minIs @v @(ProObj v p a c ** Walks v n p c b) @(MatVec v cs' ws' p a) of+        MinLeft -> StepAt (obj @(ProObj v p a c)) (shortest @v @n @p @c @b)+        MinRight -> best @a rest+    )++-- | A graded walk together with a unit into its grade is a walk of pieces at the unit: the budget+-- splits over the pieces ('splitUnit') and each piece is read off with 'enriched'.+walkAt+  :: forall {k} v n (p :: k +-> k) d a b+   . (Closing v n p)+  => (Unit ~> d) -> GradedWalk v n p d a b -> Walk n p a b+walkAt ud (DoneAt g) = Done (enriched @v @(Hom k) @a @b (g . ud))+walkAt ud (StepAt @_ @_ @_ @_ @c @_ @e @d' ee w) = case snat @n of+  SS -> case splitUnit @e @d' ud of+    (ue, ud') -> Step (enriched @v @p @a @c (ee . ue)) (walkAt @v ud' w)++-- * Reachability and shortest paths++instance (SNatI n, DecidableProfunctor p, Decidable k, Enumerable k) => ThinProfunctor (Walk n (p :: k +-> k))++-- | Reachability: the truth of a walk is its hom-object in 'BOOL', and 'shortest' at grade 'TRU' is+-- the path.+instance (SNatI n, DecidableProfunctor p, Decidable k, Enumerable k) => DecidableProfunctor (Walk n (p :: k +-> k)) where+  type Holds (Walk n (p :: k +-> k)) a b = Walks BOOL n p a b+  decide @a @b = withObWalks @BOOL @n @p @a @b case obj @(Walks BOOL n p a b) of+    Tru -> Yes (walkAt @BOOL Tru (shortest @BOOL @n @p @a @b))+    Fls -> No+  toHolds w@Objs r = case underlyingWalk @BOOL w of Tru -> r++-- | The action of the base on a closure: the triangle inequality. It holds for the best walks but+-- is not derived structurally, so it is a 'checkedArrow'.+checkedWalk+  :: forall {k} v n (p :: k +-> k) (x :: k) y a b c d+   . (Closing v n p, Ob x, Ob y, Ob a, Ob b, Ob c, Ob d)+  => (HomObj v x y ** Walks v n p a b) ~> Walks v n p c d+checkedWalk =+  withProObj @v @(Hom k) @x @y+    ( withObWalks @v @n @p @a @b+        ( withObWalks @v @n @p @c @d+            ( withOb2 @v @(HomObj v x y) @(Walks v n p a b)+                (checkedArrow @v @(HomObj v x y ** Walks v n p a b) @(Walks v n p c d))+            )+        )+    )++-- | Walks along a 'COST'-weighted graph form the free Lawvere metric space on it: 'withProObj' runs+-- the fixed point that computes the shortest distances, 'underlying' and 'enriched' relate a walk of+-- zero-cost pieces to a zero distance, and the actions of the base are the triangle inequality.+instance+  (SNatI n, EnrichedProfunctor COST p, Enriched COST k, Enumerable k)+  => EnrichedProfunctor COST (Walk n (p :: k +-> k))+  where+  type ProObj COST (Walk n p) a b = Walks COST n p a b+  withProObj @a @b = withObWalks @COST @n @p @a @b+  underlying = underlyingWalk @COST+  enriched @a @b f = walkAt @COST f (shortest @COST @n @p @a @b)+  rmap @a @b @c = checkedWalk @COST @n @p @b @c @a @b @a @c+  lmap @a @b @c = checkedWalk @COST @n @p @c @a @a @b @c @b
+ src/Proarrow/Category/Instance/Bool.hs view
@@ -0,0 +1,97 @@+-- | The thin category of booleans: objects 'FLS' and 'TRU' with one non-identity arrow+-- @'FLS' '~>' 'TRU'@, the poset @False <= True@, a.k.a. the walking arrow. It is a core type.+-- Thin categories are enriched in it ("Proarrow.Category.Enriched.Thin"), so this module depends+-- on nothing but "Proarrow.Core". The further structure of @BOOL@ (conjunction as product and+-- tensor, disjunction as coproduct, closed, star-autonomous, (co)equalizers, pullbacks\/pushouts,+-- a parameterized NNO) is instantiated in the modules that define those classes.+module Proarrow.Category.Instance.Bool where++import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault, type (+->))+import Prelude qualified as P++data BOOL = FLS | TRU++type Booleans :: CAT BOOL+data Booleans a b where+  Fls :: Booleans FLS FLS+  F2T :: Booleans FLS TRU+  Tru :: Booleans TRU TRU++deriving instance P.Eq (Booleans a b)+deriving instance P.Show (Booleans a b)++-- | Type-level conditional on a 'BOOL'.+type If :: BOOL -> k -> k -> k+type family If c t e where+  If TRU t e = t+  If FLS t e = e++-- | Negation; the 'Proarrow.Category.Monoidal.StarAutonomous.Dual' of @BOOL@.+type family Not (b :: BOOL) :: BOOL where+  Not FLS = TRU+  Not TRU = FLS++-- | GHC's own type-level 'P.Bool' (as produced by e.g. @<=?@ on 'GHC.TypeNats.Nat'), as a 'BOOL'.+type family FromBool (b :: P.Bool) :: BOOL where+  FromBool 'P.True = TRU+  FromBool 'P.False = FLS++class (IsBool (Not b)) => IsBool (b :: BOOL) where boolId :: b ~> b+instance IsBool FLS where boolId = Fls+instance IsBool TRU where boolId = Tru++-- | The category of 2 objects and one arrow between them, a.k.a. the walking arrow.+instance CategoryOf BOOL where+  type (~>) = Booleans+  type Ob b = IsBool b++instance Promonad Booleans where+  id = boolId+  Fls . Fls = Fls+  F2T . Fls = F2T+  Tru . F2T = F2T+  Tru . Tru = Tru++instance Profunctor Booleans where+  dimap = dimapDefault+  r \\ Fls = r+  r \\ F2T = r+  r \\ Tru = r++-- | @a <= b@ on the walking arrow, as a 'BOOL' again: the hom of the walking arrow is its own+-- internal hom.+type family BoolLeq (a :: BOOL) (b :: BOOL) :: BOOL where+  BoolLeq TRU FLS = FLS+  BoolLeq a b = TRU++-- | The four non-trivial profunctors @BOOL '+->' BOOL@, indexed by a pair of 'BOOL's selecting+-- whether the @FLS->FLS@ and @TRU->TRU@ heteromorphisms are present. @FLS->TRU@ always is.+type NonTrivialProfunctor :: (BOOL, BOOL) -> BOOL +-> BOOL+data NonTrivialProfunctor ft a b where+  FF :: NonTrivialProfunctor '(TRU, tt) FLS FLS+  FT :: NonTrivialProfunctor ft FLS TRU+  TT :: NonTrivialProfunctor '(ff, TRU) TRU TRU++deriving instance P.Eq (NonTrivialProfunctor ft a b)+deriving instance P.Show (NonTrivialProfunctor ft a b)++instance Profunctor (NonTrivialProfunctor ft) where+  dimap Fls Fls FF = FF+  dimap Fls F2T FF = FT+  dimap Fls Tru FT = FT+  dimap F2T Tru TT = FT+  dimap Tru Tru TT = TT+  dimap F2T Fls x = case x of {}+  dimap Tru Fls x = case x of {}+  dimap Tru F2T x = case x of {}+  dimap F2T F2T x = case x of {}+  r \\ FF = r+  r \\ FT = r+  r \\ TT = r++-- | Which heteromorphisms @'NonTrivialProfunctor' '(ff, tt)@ has.+type family NonTrivialHolds (ff :: BOOL) (tt :: BOOL) (a :: BOOL) (b :: BOOL) :: BOOL where+  NonTrivialHolds ff tt FLS FLS = ff+  NonTrivialHolds ff tt FLS TRU = TRU+  NonTrivialHolds ff tt TRU TRU = tt+  NonTrivialHolds ff tt TRU FLS = FLS
+ src/Proarrow/Category/Instance/Collage.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | The __collage__ (or cograph) of a profunctor @p@: a category on the disjoint union of @p@'s+-- two base categories ('L'- and 'R'-tagged objects, via the kind @'COLLAGE' p@), whose+-- cross-arrows @'L' a '~>' 'R' b@ are the elements @p a b@ (the 'L2R' constructor).+-- The injections 'InjL'\/'InjR' present a profunctor as a single category sitting over the+-- walking arrow 'Proarrow.Category.Instance.Bool.BOOL'.+module Proarrow.Category.Instance.Collage where++import Data.Kind (Constraint)+import Data.List (genericIndex)+import Data.Type.Nat (SNat (..), SNatI, snat, type Plus)+import Prelude (Maybe (..), map, type (~))++import Proarrow.Category.Enriched.Finitary (Finitary (..))+import Proarrow.Category.Enriched.Thin+  ( AtOb (..)+  , CodiscreteProfunctor+  , Decidable+  , DecidableProfunctor (..)+  , Decision (..)+  , DiscreteProfunctor (..)+  , Enumerable (..)+  , Finite (..)+  , FmapWrap+  , Indexed (..)+  , IndexedList (..)+  , KnownIndex+  , Length+  , Lookup+  , MapWrap+  , Thin+  , ThinProfunctor (..)+  , anyArr+  , mapDecision+  , withAtLookup+  , withWrapAtLookup+  )+import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..))+import Proarrow.Category.Instance.Coproduct qualified as C+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Colimit.Initial (HasInitialObject (..), initiate')+import Proarrow.Core+  ( CAT+  , CategoryOf (..)+  , Hom+  , Kind+  , Obj+  , Profunctor (..)+  , Promonad (..)+  , dimapDefault+  , lmap+  , obj+  , rmap+  , type (+->)+  )+import Proarrow.Functor (FunctorForRep (..))+import Proarrow.Limit.Terminal (HasTerminalObject (..), terminate')+import Proarrow.Optic (iso)+import Proarrow.Optic.Iso (Iso')+import Proarrow.Profunctor.Instance.Direp (Direp (..))++type COLLAGE :: forall {j} {k}. k +-> j -> Kind+type data COLLAGE (p :: k +-> j) = L j | R k++type Collage :: CAT (COLLAGE p)+data Collage a b where+  InL :: a ~> b -> Collage (L a :: COLLAGE p) (L b :: COLLAGE p)+  InR :: a ~> b -> Collage (R a :: COLLAGE p) (R b :: COLLAGE p)+  L2R :: p a b -> Collage (L a :: COLLAGE p) (R b :: COLLAGE p)++type IsLR :: forall {p}. COLLAGE p -> Constraint+class IsLR (a :: COLLAGE p) where+  lrId :: Obj a+instance (Ob a, Promonad ((~>) :: CAT k)) => IsLR (L a :: (COLLAGE (p :: j +-> k))) where+  lrId = InL id+instance (Ob a, Promonad ((~>) :: CAT j)) => IsLR (R a :: (COLLAGE (p :: j +-> k))) where+  lrId = InR id++instance (Profunctor p) => Profunctor (Collage :: CAT (COLLAGE p)) where+  dimap = dimapDefault+  r \\ InL f = r \\ f+  r \\ InR f = r \\ f+  r \\ L2R p = r \\ p++instance (Profunctor p) => Promonad (Collage :: CAT (COLLAGE p)) where+  id = lrId+  InL g . InL f = InL (g . f)+  InR g . L2R p = L2R (rmap g p)+  L2R p . InL f = L2R (lmap f p)+  InR g . InR f = InR (g . f)++-- | The collage of a profunctor.+instance (Profunctor p) => CategoryOf (COLLAGE p) where+  type (~>) = Collage+  type Ob a = IsLR a++instance (HasInitialObject j, CategoryOf k, CodiscreteProfunctor p) => HasInitialObject (COLLAGE (p :: k +-> j)) where+  type InitialObject = L InitialObject+  initiate @a = case obj @a of+    InL a -> InL (initiate' a)+    InR b -> L2R anyArr \\ b++instance (HasTerminalObject k, CategoryOf j, CodiscreteProfunctor p) => HasTerminalObject (COLLAGE (p :: k +-> j)) where+  type TerminalObject = R TerminalObject+  terminate @a = case obj @a of+    InL a -> L2R anyArr \\ a+    InR b -> InR (terminate' b)++class HasArrowCollage p (a :: COLLAGE p) b where arrCoprod :: a ~> b+instance (Thin j, HasArrow (~>) (a :: j) b, Ob a, Ob b) => HasArrowCollage (p :: k +-> j) (L a) (L b) where+  arrCoprod = InL arr+instance (ThinProfunctor p, HasArrow p a b, Ob a, Ob b) => HasArrowCollage (p :: k +-> j) (L a) (R b) where+  arrCoprod = L2R arr+instance (Thin k, HasArrow (~>) (a :: k) b, Ob a, Ob b) => HasArrowCollage (p :: k +-> j) (R a) (R b) where+  arrCoprod = InR arr++instance (Thin j, Thin k, ThinProfunctor p) => ThinProfunctor (Collage :: CAT (COLLAGE (p :: k +-> j))) where+  type HasArrow (Collage :: CAT (COLLAGE p)) a b = HasArrowCollage p a b+  arr = arrCoprod+  withArr (InL f) r = withArr f r \\ f+  withArr (L2R p) r = withArr p r \\ p+  withArr (InR f) r = withArr f r \\ f++-- | Decided piecewise: within either side by that side's order, across by @p@, and never backwards.+instance+  (Decidable j, Decidable k, DecidableProfunctor p)+  => DecidableProfunctor (Collage :: CAT (COLLAGE (p :: k +-> j)))+  where+  type Holds (Collage :: CAT (COLLAGE (p :: k +-> j))) (L a) (L b) = Holds (Hom j) a b+  type Holds (Collage :: CAT (COLLAGE (p :: k +-> j))) (L a) (R b) = Holds p a b+  type Holds (Collage :: CAT (COLLAGE (p :: k +-> j))) (R a) (L b) = FLS+  type Holds (Collage :: CAT (COLLAGE (p :: k +-> j))) (R a) (R b) = Holds (Hom k) a b+  decide @x @y = case (obj @x, obj @y) of+    (InL @a f, InL @b g) -> mapDecision InL (decide @(Hom j) @a @b) \\ f \\ g+    (InL @a f, InR @b g) -> mapDecision L2R (decide @p @a @b) \\ f \\ g+    (InR _, InL _) -> No+    (InR @a f, InR @b g) -> mapDecision InR (decide @(Hom k) @a @b) \\ f \\ g+  toHolds (InL f) r = toHolds f r+  toHolds (L2R p) r = toHolds p r+  toHolds (InR f) r = toHolds f r++data family InjL :: forall (p :: k +-> j) -> j +-> COLLAGE p+instance (Profunctor p) => FunctorForRep (InjL p) where+  type InjL p @ a = L a+  fmap = InL++data family InjR :: forall (p :: k +-> j) -> k +-> COLLAGE p+instance (Profunctor p) => FunctorForRep (InjR p) where+  type InjR p @ a = R a+  fmap = InR++collageUniv :: forall {j} {k} (p :: k +-> j). (Profunctor p) => Iso' p (Direp (InjL p) (InjR p))+collageUniv = iso (Prof \p -> Direp (L2R p) \\ p) (Prof \case Direp (L2R q) -> q)++data family CollageAsCoprod :: COLLAGE (p :: k +-> j) +-> C.COPRODUCT j k+instance (DiscreteProfunctor p) => FunctorForRep (CollageAsCoprod :: COLLAGE (p :: k +-> j) +-> C.COPRODUCT j k) where+  type CollageAsCoprod @ L a = C.L a+  type CollageAsCoprod @ R a = C.R a+  fmap (InL f) = C.InjL f+  fmap (InR f) = C.InjR f+  fmap (L2R p) = exfalso p++data family ProjTo2 :: forall (p :: k +-> j) -> COLLAGE p +-> BOOL+instance (Profunctor p) => FunctorForRep (ProjTo2 p) where+  type ProjTo2 p @ L a = FLS+  type ProjTo2 p @ R a = TRU+  fmap = \case+    InL _ -> Fls+    InR _ -> Tru+    L2R _ -> F2T++-- * Numbering the collage++-- | The collage numbers the left category's objects first and the right category's after them.+type CollageObjects :: forall {j} {k}. forall (p :: k +-> j) -> [j] -> [COLLAGE p]+type family CollageObjects p xs where+  CollageObjects (p :: k +-> j) '[] = MapWrap R (Objects k)+  CollageObjects p (x ': xs) = L x ': CollageObjects p xs++instance (Finite j, Finite k) => Indexed (COLLAGE (p :: k +-> j)) where+  type Index (L a) = Index a+  type Index (R b :: COLLAGE (p :: k +-> j)) = Plus (Length (Objects j)) (Index b)++-- | An object of the left category is an object of the collage, keeping its index; one of the right+-- category is too, shifted past all the left ones. Both walk the left object list, and both hand the+-- fact to a continuation, since at each step the statement about the tail is the statement about the+-- whole list already reduced.+withCollageL+  :: forall {j} {k} (p :: k +-> j) (x :: j) r+   . (Finite j, Finite k, KnownIndex x)+  => ((KnownIndex (L x :: COLLAGE p)) => r) -> r+withCollageL r = withAtLookup @j (snat @(Index x)) (go (finite @j) (snat @(Index x)) r)+  where+    go+      :: forall xs i+       . (Lookup xs i ~ 'Just x)+      => IndexedList xs -> SNat i -> ((Lookup (CollageObjects p xs) i ~ 'Just (L x)) => r) -> r+    go (FCons _) SZ k = k+    go (FCons xs) (SS @i') k = go xs (snat @i') k++withCollageR+  :: forall {j} {k} (p :: k +-> j) (y :: k) r+   . (Finite j, Finite k, KnownIndex y)+  => ((KnownIndex (R y :: COLLAGE p)) => r) -> r+withCollageR r = go (finite @j) r+  where+    go+      :: forall xs+       . IndexedList xs+      -> ( ( SNatI (Plus (Length xs) (Index y))+           , Lookup (CollageObjects p xs) (Plus (Length xs) (Index y)) ~ FmapWrap R (At k (Index y))+           )+           => r+         )+      -> r+    go FNil k = withWrapAtLookup @(R :: k -> COLLAGE p) (snat @(Index y)) k+    go (FCons xs) k = go xs k++instance (Finite j, Finite k) => Finite (COLLAGE (p :: k +-> j)) where+  type Objects (COLLAGE (p :: k +-> j)) = CollageObjects p (Objects j)+  finite = goL (finite @j)+    where+      goL :: forall xs. IndexedList xs -> IndexedList (CollageObjects p xs)+      goL FNil = goR (finite @k)+      goL (FCons @x xs) = withCollageL @p @x (FCons @(L x) (goL xs))+      goR :: forall ys. IndexedList ys -> IndexedList (MapWrap (R :: k -> COLLAGE p) ys)+      goR FNil = FNil+      goR (FCons @y ys) = withCollageR @p @y (FCons @(R y) (goR ys))++-- | The collage of a finitary profunctor between finite categories is a finite category: a+-- hom-set is a base hom-set, an element set of @p@ for a cross-arrow, or empty going back.+--+-- This is the cheapest source of a finite category that is /not a poset/: elements of @p@+-- between one pair of objects are parallel arrows.+instance+  (Finitary (Hom j), Finitary (Hom k), Finitary p)+  => Finitary (Collage :: CAT (COLLAGE (p :: k +-> j)))+  where+  size @a @b = case (obj @a, obj @b) of+    (InL @x f, InL @y g) -> size @(Hom j) @x @y \\ f \\ g+    (InL @x f, InR @y g) -> size @p @x @y \\ f \\ g+    (InR _, InL _) -> 0+    (InR @x f, InR @y g) -> size @(Hom k) @x @y \\ f \\ g+  toIndex = \case+    InL f -> toIndex f \\ f+    InR f -> toIndex f \\ f+    L2R x -> toIndex x \\ x+  fromIndex @a @b = genericIndex (elements @(Collage :: CAT (COLLAGE p)) @a @b)+  elements @a @b = case (obj @a, obj @b) of+    (InL @x f, InL @y g) -> map InL (elements @(Hom j) @x @y) \\ f \\ g+    (InL @x f, InR @y g) -> map L2R (elements @p @x @y) \\ f \\ g+    (InR _, InL _) -> []+    (InR @x f, InR @y g) -> map InR (elements @(Hom k) @x @y) \\ f \\ g++instance (Enumerable j, Enumerable k, Profunctor p) => Enumerable (COLLAGE (p :: k +-> j)) where+  withIndex @a r = case obj @a of+    InL @x f -> withIndex @j @x (withCollageL @p @x r) \\ f+    InR @y f -> withIndex @k @y (withCollageR @p @y r) \\ f+  atOb = go (finite @j)+    where+      go :: forall xs i. IndexedList xs -> SNat i -> AtOb (COLLAGE p) (Lookup (CollageObjects p xs) i)+      go FNil i = withWrapAtLookup @(R :: k -> COLLAGE p) i case atOb @k i of+        AtJust @_ @y -> withCollageR @p @y AtJust+        AtNothing -> AtNothing+      go (FCons @x _) SZ = withOb @j @x (withCollageL @p @x AtJust)+      go (FCons xs) (SS @i') = go xs (snat @i')
+ src/Proarrow/Category/Instance/Constraint.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | The thin category @CONSTRAINT@ of type class constraints, with entailment @(':-')@ as arrows:+-- @a ':-' b@ holds when @a@ implies @b@. Constraint conjunction is both the categorical product and+-- the tensor of a closed symmetric monoidal structure, with @()@ as unit and terminal object.+module Proarrow.Category.Instance.Constraint (CONSTRAINT (..), (:-) (..), (:=>) (..), reifyExp, eqIsSuperOrd, maybeLiftsSemigroup) where++import Data.Kind (Constraint)+import GHC.Exts (withDict)+import Prelude qualified as P++import Proarrow.Category.Enriched.Thin (ThinProfunctor (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Core (CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, dimapDefault)+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..))+import Proarrow.Limit.BinaryProduct qualified as P+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Monoid (CocommutativeComonoid, Comonoid (..), Monoid (..))++type data CONSTRAINT = CNSTRNT Constraint++data (:-) a b where+  Entails :: {unEntails :: forall r. (a) => ((b) => r) -> r} -> CNSTRNT a :- CNSTRNT b++-- | The category of type class constraints. An arrow from constraint a to constraint b+-- means that a implies b, i.e. if a holds then b holds.+instance CategoryOf CONSTRAINT where+  type (~>) = (:-)+  type Ob a = (Is CNSTRNT a)++instance Promonad (:-) where+  id = Entails \r -> r+  Entails f . Entails g = Entails \r -> g (f r)++instance Profunctor (:-) where+  dimap = dimapDefault+  r \\ Entails{} = r++instance ThinProfunctor (:-) where+  type HasArrow (:-) a b = UN CNSTRNT a :=> UN CNSTRNT b+  arr @(CNSTRNT a) @(CNSTRNT b) = Entails \r -> unEntails (entails @a @b) r+  withArr p@Entails{} r = reifyExp p r++instance HasTerminalObject CONSTRAINT where+  type TerminalObject = CNSTRNT ()+  terminate = Entails \r -> r++instance HasBinaryProducts CONSTRAINT where+  type CNSTRNT l && CNSTRNT r = CNSTRNT (l, r)+  withObProd r = r+  fst = Entails \r -> r+  snd = Entails \r -> r+  Entails f &&& Entails g = Entails \r -> f (g r)++instance MonoidalProfunctor (:-) where+  one = id+  f ** g = f *** g++-- | Products as monoidal structure.+instance Monoidal CONSTRAINT where+  type Unit = TerminalObject+  type a ** b = a && b+  withOb2 r = r+  leftUnitor = P.leftUnitorProd+  leftUnitorInv = P.leftUnitorProdInv+  rightUnitor = P.rightUnitorProd+  rightUnitorInv = P.rightUnitorProdInv+  associator = P.associatorProd+  associatorInv = P.associatorProdInv++instance SymMonoidal CONSTRAINT where+  swap = Entails \r -> r++instance Monoid (CNSTRNT ()) where+  mempty = id+  mappend = Entails \r -> r++instance Comonoid (CNSTRNT a) where+  counit = Entails \r -> r+  comult = Entails \r -> r+instance CocommutativeComonoid (CNSTRNT a)+instance CopyDiscard CONSTRAINT++class b :=> c where+  entails :: CNSTRNT b :- CNSTRNT c+instance ((b) => c) => (b :=> c) where+  entails = Entails \r -> r++reifyExp :: forall b c r. CNSTRNT b :- CNSTRNT c -> ((b :=> c) => r) -> r+reifyExp = withDict @(b :=> c)++instance Closed CONSTRAINT where+  type a ~~> b = CNSTRNT (UN CNSTRNT a :=> UN CNSTRNT b)+  withObExp r = r+  curry @_ @(CNSTRNT b) (Entails @_ @c f) = Entails \r -> reifyExp (Entails @b @c f) r+  apply @(CNSTRNT a) @(CNSTRNT b) = Entails \r -> unEntails (entails @a @b) r++eqIsSuperOrd :: CNSTRNT (P.Ord a) :- CNSTRNT (P.Eq a)+eqIsSuperOrd = Entails \r -> r++maybeLiftsSemigroup :: CNSTRNT (P.Semigroup a) :- CNSTRNT (Monoid (P.Maybe a))+maybeLiftsSemigroup = Entails \r -> r
+ src/Proarrow/Category/Instance/Coproduct.hs view
@@ -0,0 +1,119 @@+-- | The coproduct (disjoint union) of two categories: the kind @'COPRODUCT' j k@ tags objects with+-- 'L' or 'R', and @p ':++:' q@ is the corresponding coproduct of profunctors, with no arrows between+-- the two sides. (Co)equalizers, pullbacks\/pushouts, (co)representability and dagger structure all+-- lift componentwise.+module Proarrow.Category.Instance.Coproduct where++import Data.Kind (Constraint)+import Prelude (type (~))++import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Proarrow.Category.Topos (HasEpiMonoFactorization (..))+import Proarrow.Colimit.Coequalizer (HasCoequalizers (..))+import Proarrow.Colimit.Pushout (HasPushouts (..))+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), type (+->))+import Proarrow.Functor (FunctorForRep (..))+import Proarrow.Limit.Equalizer (HasEqualizers (..))+import Proarrow.Limit.Pullback (HasPullbacks (..))+import Proarrow.Profunctor.Corepresentable (Corepresentable (..))+import Proarrow.Profunctor.Representable (Representable (..))++type data COPRODUCT j k = L j | R k++type (:++:) :: (j1 +-> k1) -> (j2 +-> k2) -> COPRODUCT j1 j2 +-> COPRODUCT k1 k2+data (:++:) p q a b where+  InjL :: p a b -> (p :++: q) (L a) (L b)+  InjR :: q a b -> (p :++: q) (R a) (R b)++type IsLR :: forall {j} {k}. COPRODUCT j k -> Constraint+class IsLR (a :: COPRODUCT j k) where+  lrCase :: (forall b. (a ~ L b, Ob b) => r) -> (forall b. (a ~ R b, Ob b) => r) -> r+instance (Ob a) => IsLR (L a :: COPRODUCT j k) where+  lrCase l _ = l+instance (Ob a) => IsLR (R a :: COPRODUCT j k) where+  lrCase _ r = r++instance (Profunctor p, Profunctor q) => Profunctor (p :++: q) where+  dimap (InjL f) (InjL g) (InjL p) = InjL (dimap f g p)+  dimap (InjR f) (InjR g) (InjR q) = InjR (dimap f g q)+  dimap InjL{} InjR{} p = case p of {}+  dimap InjR{} InjL{} q = case q of {}+  r \\ InjL p = r \\ p+  r \\ InjR q = r \\ q++-- | The coproduct of two promonads.+instance (Promonad p, Promonad q) => Promonad (p :++: q) where+  id @a = lrCase @a (InjL id) (InjR id)+  InjL p . InjL q = InjL (p . q)+  InjR q . InjR r = InjR (q . r)++-- | The coproduct of two categories.+instance (CategoryOf j, CategoryOf k) => CategoryOf (COPRODUCT j k) where+  type (~>) @(COPRODUCT j k) = (~>) @j :++: (~>) @k+  type Ob (a :: COPRODUCT j k) = IsLR a++instance (Representable p, Representable q) => Representable (p :++: q) where+  type (p :++: q) % L a = L (p % a)+  type (p :++: q) % R a = R (q % a)+  index (InjL p) = InjL (index p)+  index (InjR q) = InjR (index q)+  repUniv @a = lrCase @a (InjL (repUniv @p)) (InjR (repUniv @q))++instance (Corepresentable p, Corepresentable q) => Corepresentable (p :++: q) where+  type (p :++: q) %% L a = L (p %% a)+  type (p :++: q) %% R a = R (q %% a)+  coindex (InjL f) = InjL (coindex f)+  coindex (InjR f) = InjR (coindex f)+  corepUniv @a = lrCase @a (InjL (corepUniv @p)) (InjR (corepUniv @q))++instance (DaggerProfunctor p, DaggerProfunctor q) => DaggerProfunctor (p :++: q) where+  dagger = \case+    InjL f -> InjL (dagger f)+    InjR f -> InjR (dagger f)++-- | Morphisms of 'COPRODUCT' never cross sides, so this is a straight case split reusing either+-- @j@'s or @k@'s own equalizer.+instance (HasEqualizers j, HasEqualizers k) => HasEqualizers (COPRODUCT j k) where+  equalize (InjL f) (InjL g) k = equalize f g \e -> k (InjL e)+  equalize (InjR f) (InjR g) k = equalize f g \e -> k (InjR e)+  factorEqualizer (InjL incl) (InjL h) = InjL (factorEqualizer incl h)+  factorEqualizer (InjR incl) (InjR h) = InjR (factorEqualizer incl h)++-- | Dual to the 'HasEqualizers' instance above.+instance (HasCoequalizers j, HasCoequalizers k) => HasCoequalizers (COPRODUCT j k) where+  coequalize (InjL f) (InjL g) k = coequalize f g \c -> k (InjL c)+  coequalize (InjR f) (InjR g) k = coequalize f g \c -> k (InjR c)+  factorCoequalizer (InjL q) (InjL h) = InjL (factorCoequalizer q h)+  factorCoequalizer (InjR q) (InjR h) = InjR (factorCoequalizer q h)++instance (HasPullbacks j, HasPullbacks k) => HasPullbacks (COPRODUCT j k) where+  pullback (InjL f) (InjL g) k = pullback f g \p1 p2 -> k (InjL p1) (InjL p2)+  pullback (InjR f) (InjR g) k = pullback f g \p1 p2 -> k (InjR p1) (InjR p2)+  factorPullback (InjL p1) (InjL p2) (InjL k1) (InjL k2) = InjL (factorPullback p1 p2 k1 k2)+  factorPullback (InjR p1) (InjR p2) (InjR k1) (InjR k2) = InjR (factorPullback p1 p2 k1 k2)++instance (HasPushouts j, HasPushouts k) => HasPushouts (COPRODUCT j k) where+  pushout (InjL f) (InjL g) k = pushout f g \p1 p2 -> k (InjL p1) (InjL p2)+  pushout (InjR f) (InjR g) k = pushout f g \p1 p2 -> k (InjR p1) (InjR p2)+  factorPushout (InjL p1) (InjL p2) (InjL k1) (InjL k2) = InjL (factorPushout p1 p2 k1 k2)+  factorPushout (InjR p1) (InjR p2) (InjR k1) (InjR k2) = InjR (factorPushout p1 p2 k1 k2)++instance (HasPushouts j, HasEqualizers j, HasPushouts k, HasEqualizers k) => HasEpiMonoFactorization (COPRODUCT j k)++data family Lft :: j +-> COPRODUCT j k+instance (CategoryOf j, CategoryOf k) => FunctorForRep (Lft :: j +-> COPRODUCT j k) where+  type Lft @ a = L a+  fmap = InjL++data family Rgt :: k +-> COPRODUCT j k+instance (CategoryOf j, CategoryOf k) => FunctorForRep (Rgt :: k +-> COPRODUCT j k) where+  type Rgt @ a = R a+  fmap = InjR++data family Codiag :: COPRODUCT k k +-> k+instance (CategoryOf k) => FunctorForRep (Codiag :: COPRODUCT k k +-> k) where+  type Codiag @ L a = a+  type Codiag @ R a = a+  fmap = \case+    InjL f -> f+    InjR g -> g
+ src/Proarrow/Category/Instance/Cospan.hs view
@@ -0,0 +1,118 @@+-- | The category of __cospans__ in @k@: objects are those of @k@ (wrapped in 'CS'), and a morphism+-- @a '~>' b@ is a cospan @a -> x <- b@, composed by pushout. With the coproduct of @k@ as tensor+-- every object is a Frobenius monoid, giving a 'Proarrow.Category.Monoidal.Hypergraph.Hypergraph',+-- compact closed, dagger category. This is the archetypal setting for undirected wiring diagrams.+module Proarrow.Category.Instance.Cospan where++import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Proarrow.Category.Instance.Span (SPAN (..), Span (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..))+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Hypergraph (ExpHG, Frobenius, Hypergraph, applyHG, cap, cup, curryHG)+import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomous (..))+import Proarrow.Colimit.BinaryCoproduct+  ( HasBinaryCoproducts (..)+  , HasCoproducts+  , associatorCoprod+  , associatorCoprodInv+  , leftUnitorCoprod+  , leftUnitorCoprodInv+  , rightUnitorCoprod+  , rightUnitorCoprodInv+  , swapCoprod+  )+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Colimit.Pushout (HasPushouts (..))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), WrappedOb, dimapDefault, tgt, type (+->))+import Proarrow.Functor (FunctorForRep (..))+import Proarrow.Limit.Pullback (HasPullbacks (..))+import Proarrow.Monoid (CocommutativeComonoid, CommutativeMonoid, Comonoid (..), Monoid (..))++type data COSPAN k = CS k++type Cospan :: CAT (COSPAN k)+data Cospan a b where+  Cospan :: forall c a b. a ~> c -> b ~> c -> Cospan (CS a) (CS b)++arr :: (CategoryOf k) => (a :: k) ~> b -> Cospan (CS a) (CS b)+arr f = Cospan f (tgt f)++coarr :: (CategoryOf k) => (a :: k) ~> b -> Cospan (CS b) (CS a)+coarr f = Cospan (tgt f) f++instance (HasPushouts k) => Profunctor (Cospan :: CAT (COSPAN k)) where+  dimap = dimapDefault+  r \\ Cospan f g = r \\ f \\ g+instance (HasPushouts k) => Promonad (Cospan :: CAT (COSPAN k)) where+  id = Cospan id id+  Cospan f g . Cospan h i = pushout i f \l r -> Cospan (l . h) (r . g)++-- | The category of cospans in @k@: an arrow @'CS' a '~>' 'CS' b@ is a pair of arrows+-- @a '~>' x@ and @b '~>' x@ into a common object, and composition glues along a pushout.+instance (HasPushouts k) => CategoryOf (COSPAN k) where+  type (~>) = Cospan+  type Ob a = WrappedOb CS a++instance (HasPushouts k, HasCoproducts k) => MonoidalProfunctor (Cospan :: CAT (COSPAN k)) where+  one = id+  Cospan l1 l2 ** Cospan r1 r2 = Cospan (l1 +++ r1) (l2 +++ r2)+instance (HasPushouts k, HasCoproducts k) => Monoidal (COSPAN k) where+  type CS a ** CS b = CS (a || b)+  type Unit = CS InitialObject+  withOb2 @(CS a) @(CS b) r = withObCoprod @k @a @b r+  leftUnitor = arr leftUnitorCoprod+  leftUnitorInv = arr leftUnitorCoprodInv+  rightUnitor = arr rightUnitorCoprod+  rightUnitorInv = arr rightUnitorCoprodInv+  associator @(CS a) @(CS b) @(CS c) = arr (associatorCoprod @a @b @c)+  associatorInv @(CS a) @(CS b) @(CS c) = arr (associatorCoprodInv @a @b @c)+instance (HasPushouts k, HasCoproducts k) => SymMonoidal (COSPAN k) where+  swap @(CS a) @(CS b) = arr (swapCoprod @a @b)++instance (HasPushouts k, HasCoproducts k, Ob a) => Monoid (CS (a :: k)) where+  mempty = arr initiate+  mappend = arr (id ||| id)+instance (HasPushouts k, HasCoproducts k, Ob a) => CommutativeMonoid (CS (a :: k))+instance (HasPushouts k, HasCoproducts k, Ob a) => Comonoid (CS (a :: k)) where+  counit = coarr initiate+  comult = coarr (id ||| id)+instance (HasPushouts k, HasCoproducts k, Ob a) => CocommutativeComonoid (CS (a :: k))+instance (HasPushouts k, HasCoproducts k, Ob a) => Frobenius (CS (a :: k))+instance (HasPushouts k, HasCoproducts k) => Hypergraph (COSPAN k)+instance (HasPushouts k, HasCoproducts k) => CopyDiscard (COSPAN k)++instance (HasPushouts k, HasCoproducts k) => Closed (COSPAN k) where+  type a ~~> b = ExpHG a b+  withObExp @(CS a) @(CS b) r = withObCoprod @k @a @b r+  curry @a @b = curryHG @a @b+  apply @b @c = applyHG @b @c++instance (HasPushouts k, HasCoproducts k) => StarAutonomous (COSPAN k) where+  type Dual a = a+  withObDual r = r+  dual = dagger+  dualInv = dagger+  linDist @(CS a) @(CS b) (Cospan f g) = Cospan (f . lft @k @a @b) (f . rgt @k @a @b ||| g)+  linDistInv @_ @(CS b) @(CS c) (Cospan f g) = Cospan (f ||| g . lft @k @b @c) (g . rgt @k @b @c)+  doubleNeg = id+  doubleNegInv = id+instance (HasPushouts k, HasCoproducts k) => CompactClosed (COSPAN k) where+  distribDual @(CS a) @(CS b) = withObCoprod @k @a @b id+  dualUnit = id+  dualityUnit @a = cup @a+  dualityCounit @a = cap @a++instance (HasPushouts k) => DaggerProfunctor (Cospan :: CAT (COSPAN k)) where+  dagger (Cospan f g) = Cospan g f++data family Pushout :: SPAN k +-> COSPAN k+instance (HasPushouts k, HasPullbacks k) => FunctorForRep (Pushout :: SPAN k +-> COSPAN k) where+  type Pushout @ (SP a) = CS a+  fmap (Span l r) = pushout l r Cospan++data family Pullback :: COSPAN k +-> SPAN k+instance (HasPushouts k, HasPullbacks k) => FunctorForRep (Pullback :: COSPAN k +-> SPAN k) where+  type Pullback @ (CS a) = SP a+  fmap (Cospan l r) = pullback l r Span
+ src/Proarrow/Category/Instance/Cost.hs view
@@ -0,0 +1,303 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}++-- | The Lawvere __cost__ category: extended natural numbers (@'C' n@ or 'INF') as a thin category+-- with an arrow @a '~>' b@ exactly when @a >= b@ ('GTE'). Addition of costs provides a symmetric+-- monoidal structure with @'C' 0@ as unit (and terminal object; 'INF' is initial), so categories+-- enriched in @COST@ are generalized (Lawvere) metric spaces.+module Proarrow.Category.Instance.Cost where++import Data.Proxy (Proxy (..))+import Data.Type.Ord (OrderingI (..), type Max, type Min, type (<=), type (<=?))+import GHC.TypeNats (KnownNat, Nat, cmpNat, natVal, withKnownNat, withSomeSNat, type SNat, type (+))+import Unsafe.Coerce (unsafeCoerce)+import Prelude (Num ((+)), error, ($))++import Proarrow.Category.Enriched.Thin (DecidableProfunctor (..), Decision (..), ThinProfunctor (..))+import Proarrow.Category.Instance.Bool (BOOL (..), FromBool)+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Category.Monoidal.Distributive (Distributive (..))+import Proarrow.Category.Topos (HasEpiMonoFactorization (..))+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..))+import Proarrow.Colimit.Coequalizer (HasCoequalizers (..), factorPushoutDefault, thinCoequalize)+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Colimit.Pushout (HasPushouts (..), thinPushout)+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault, obj, (//))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..))+import Proarrow.Limit.Equalizer (HasEqualizers (..), factorPullbackDefault, thinEqualize)+import Proarrow.Limit.Pullback (HasPullbacks (..), thinPullback)+import Proarrow.Limit.Terminal (HasTerminalObject (..))++type data COST = C Nat | INF++data SCost n where+  SC :: (KnownNat n) => SCost (C n)+  SINF :: SCost INF++type GTE :: CAT COST+data GTE a b where+  Inf :: (Ob a) => GTE INF a+  GTE :: (KnownNat a, KnownNat b, b <= a) => GTE (C a) (C b)++lteTrans :: forall (a :: Nat) b c r. (a <= b, b <= c, KnownNat a, KnownNat c) => ((a <= c) => r) -> r+lteTrans r = case cmpNat (Proxy :: Proxy a) (Proxy :: Proxy c) of+  LTI -> r+  EQI -> r+  GTI -> error "lteTrans: broken transitivity"++plusMonotone+  :: forall (a :: Nat) b c d r. (a <= b, c <= d, KnownNat (a + c), KnownNat (b + d)) => (((a + c) <= (b + d)) => r) -> r+plusMonotone r = case cmpNat (Proxy :: Proxy (a + c)) (Proxy :: Proxy (b + d)) of+  LTI -> r+  EQI -> r+  GTI -> error "plusMonotone: broken monotonicity"++withPlusIsNat :: forall a b r. (KnownNat a, KnownNat b) => ((KnownNat (a + b)) => r) -> r+withPlusIsNat = withKnownNat ab+  where+    ab :: SNat (a + b)+    ab = withSomeSNat (natVal (Proxy :: Proxy a) + natVal (Proxy :: Proxy b)) unsafeCoerce++class IsCost (a :: COST) where+  sing :: SCost a+instance (KnownNat n) => IsCost (C n) where+  sing = SC+instance IsCost INF where+  sing = SINF++instance Profunctor GTE where+  dimap = dimapDefault+  r \\ Inf = r+  r \\ GTE = r+instance Promonad GTE where+  id @a = case sing @a of+    SINF -> Inf+    SC -> GTE+  f . Inf = Inf \\ f+  GTE @b @c . GTE @a = lteTrans @c @b @a GTE++-- | Cost category. Categories enriched in the cost category are lawvere metric spaces.+instance CategoryOf COST where+  type (~>) = GTE+  type Ob a = (IsCost a)++instance ThinProfunctor GTE++-- | Decided by comparing the naturals; @INF@ is below everything.+instance DecidableProfunctor GTE where+  type Holds GTE INF b = TRU+  type Holds GTE (C a) INF = FLS+  type Holds GTE (C a) (C b) = FromBool (b <=? a)+  decide @a @b = case (sing @a, sing @b) of+    (SINF, _) -> Yes Inf+    (SC, SINF) -> No+    (SC @x, SC @y) -> case cmpNat (Proxy :: Proxy y) (Proxy :: Proxy x) of+      LTI -> Yes GTE+      EQI -> Yes GTE+      GTI -> No+  toHolds Inf r = r+  toHolds (GTE @x @y) r = case cmpNat (Proxy :: Proxy y) (Proxy :: Proxy x) of+    LTI -> r+    EQI -> r++instance HasTerminalObject COST where+  type TerminalObject = C 0+  terminate @a = case sing @a of+    SINF -> Inf+    SC @b -> case cmpNat (Proxy :: Proxy 0) (Proxy :: Proxy b) of+      LTI -> GTE+      EQI -> GTE+      GTI -> error "terminate: found a Nat smaller than 0"++instance HasInitialObject COST where+  type InitialObject = INF+  initiate = Inf++instance HasBinaryProducts COST where+  type INF && b = INF+  type a && INF = INF+  type C a && C b = C (Max a b)+  withObProd @a @b r = case (sing @a, sing @b) of+    (SINF, _) -> r+    (_, SINF) -> r+    (SC @a', SC @b') -> case cmpNat (Proxy :: Proxy a') (Proxy :: Proxy b') of+      LTI -> r+      EQI -> r+      GTI -> r+  fst @a @b = case (sing @a, sing @b) of+    (SINF, _) -> Inf+    (_, SINF) -> Inf+    (SC @a', SC @b') -> case cmpNat (Proxy :: Proxy a') (Proxy :: Proxy b') of+      LTI -> GTE+      EQI -> GTE+      GTI -> GTE+  snd @a @b = case (sing @a, sing @b) of+    (SINF, _) -> Inf+    (_, SINF) -> Inf+    (SC @a', SC @b') -> case (cmpNat (Proxy :: Proxy a') (Proxy :: Proxy b'), cmpNat (Proxy :: Proxy b') (Proxy :: Proxy a')) of+      (LTI, _) -> GTE+      (EQI, _) -> GTE+      (GTI, LTI) -> GTE+      (GTI, GTI) -> error "snd: found 2 nats greater than eachother"+  (&&&) @_ @x @y l r = l // r // withObProd @_ @x @y $ case (l, r) of+    (Inf, _) -> Inf+    (GTE @_ @x', GTE @_ @y') -> case cmpNat (Proxy :: Proxy x') (Proxy :: Proxy y') of+      LTI -> GTE+      EQI -> GTE+      GTI -> GTE++instance HasBinaryCoproducts COST where+  type INF || b = b+  type a || INF = a+  type C a || C b = C (Min a b)+  withObCoprod @a @b r = case (sing @a, sing @b) of+    (SINF, _) -> r+    (_, SINF) -> r+    (SC @a', SC @b') -> case cmpNat (Proxy :: Proxy a') (Proxy :: Proxy b') of+      LTI -> r+      EQI -> r+      GTI -> r+  lft @a @b = case (sing @a, sing @b) of+    (SINF, _) -> Inf+    (_, SINF) -> id+    (SC @a', SC @b') -> case (cmpNat (Proxy :: Proxy a') (Proxy :: Proxy b'), cmpNat (Proxy :: Proxy b') (Proxy :: Proxy a')) of+      (LTI, _) -> GTE+      (EQI, _) -> GTE+      (GTI, LTI) -> GTE+      (GTI, GTI) -> error "lft: found 2 nats greater than eachother"+  rgt @a @b = case (sing @a, sing @b) of+    (SINF, _) -> id+    (_, SINF) -> Inf+    (SC @a', SC @b') -> case cmpNat (Proxy :: Proxy a') (Proxy :: Proxy b') of+      LTI -> GTE+      EQI -> GTE+      GTI -> GTE+  (|||) @x @y l r = l // r // withOb2 @_ @x @y $ case (l, r) of+    (Inf, _) -> r+    (_, Inf) -> l+    (GTE @x', GTE @y') -> case cmpNat (Proxy :: Proxy x') (Proxy :: Proxy y') of+      LTI -> GTE+      EQI -> GTE+      GTI -> GTE++instance MonoidalProfunctor GTE where+  one = GTE+  (**) :: forall x1 x2 y1 y2. GTE x1 x2 -> GTE y1 y2 -> GTE (x1 ** y1) (x2 ** y2)+  l ** r = case (l, r) of+    (Inf, _) -> r // withOb2 @_ @x2 @y2 Inf+    (_, Inf) -> l // withOb2 @_ @x2 @y2 Inf+    (GTE @a @b, GTE @c @d) -> withPlusIsNat @a @c $ withPlusIsNat @b @d $ plusMonotone @b @a @d @c GTE++instance Monoidal COST where+  type Unit = C 0+  type INF ** b = INF+  type a ** INF = INF+  type C a ** C b = C (a + b)+  withOb2 @a @b r = case (sing @a, sing @b) of+    (SC @a', SC @b') -> withPlusIsNat @a' @b' r+    (SINF, _) -> r+    (_, SINF) -> r+  leftUnitor @a = case sing @a of+    SINF -> id+    SC -> GTE+  leftUnitorInv @a = case sing @a of+    SINF -> id+    SC -> GTE+  rightUnitor @a = case sing @a of+    SINF -> id+    SC -> GTE+  rightUnitorInv @a = case sing @a of+    SINF -> id+    SC -> GTE+  associator @a @b @c = case (sing @a, sing @b, sing @c) of+    (SC @a', SC @b', SC @c') -> unsafeCoerce $ withPlusIsNat @a' @b' $ withPlusIsNat @(a' + b') @c' $ obj @(C (a' + b' + c'))+    (SINF, _, _) -> Inf+    (_, SINF, _) -> Inf+    (_, _, SINF) -> Inf+  associatorInv @a @b @c = case (sing @a, sing @b, sing @c) of+    (SC @a', SC @b', SC @c') -> unsafeCoerce $ withPlusIsNat @a' @b' $ withPlusIsNat @(a' + b') @c' $ obj @(C (a' + b' + c'))+    (SINF, _, _) -> Inf+    (_, SINF, _) -> Inf+    (_, _, SINF) -> Inf++instance SymMonoidal COST where+  swap @a @b = case (sing @a, sing @b) of+    (SINF, _) -> Inf+    (_, SINF) -> Inf+    (SC @a', SC @b') -> unsafeCoerce (withPlusIsNat @a' @b' (obj @(C (a' + b'))))++instance Distributive COST where+  distL @a @b @c = case (sing @a, sing @b, sing @c) of+    (SINF, _, _) -> Inf+    (_, SINF, _) -> withOb2 @_ @a @c id+    (_, _, SINF) -> withOb2 @_ @a @b id+    (SC @a', SC @b', SC @c') -> withPlusIsNat @a' @b' $+      withPlusIsNat @a' @c' $+        case (cmpNat (Proxy :: Proxy b') (Proxy :: Proxy c'), cmpNat (Proxy :: Proxy (a' + b')) (Proxy :: Proxy (a' + c'))) of+          (LTI, LTI) -> id+          (LTI, GTI) -> error "distL: b is less than c, but a + b is greater than a + c"+          (EQI, _) -> id+          (GTI, LTI) -> error "distL: b is greater than c, but a + b is less than a + c"+          (GTI, GTI) -> id+#if !(MIN_VERSION_GLASGOW_HASKELL(9,12,1,0))+          _ -> error "redundant case"+#endif+  distR @a @b @c = case (sing @a, sing @b, sing @c) of+    (SINF, _, _) -> withOb2 @_ @b @c id+    (_, SINF, _) -> withOb2 @_ @a @c id+    (_, _, SINF) -> Inf+    (SC @a', SC @b', SC @c') -> withPlusIsNat @a' @c' $+      withPlusIsNat @b' @c' $+        case (cmpNat (Proxy :: Proxy a') (Proxy :: Proxy b'), cmpNat (Proxy :: Proxy (a' + c')) (Proxy :: Proxy (b' + c'))) of+          (LTI, LTI) -> id+          (LTI, GTI) -> error "distR: a is less than b, but a + c is greater than b + c"+          (EQI, _) -> id+          (GTI, LTI) -> error "distR: a is greater than b, but a + c is less than b + c"+          (GTI, GTI) -> id+#if !(MIN_VERSION_GLASGOW_HASKELL(9,12,1,0))+          _ -> error "redundant case"+#endif+  absorbL = Inf+  absorbR = Inf++-- | @COST@ is thin and totally ordered, so equalizers are trivial. @factorEqualizer incl h@ just+-- compares @e@ and @e'@ directly (their common bound @x@ does not matter), erroring when and only+-- when @e'@ is finite and strictly less than @e@, or @e@ is 'INF' while @e'@ is finite.+instance HasEqualizers COST where+  equalize = thinEqualize+  factorEqualizer @e @_ @e' incl h =+    ( case (sing @e', sing @e) of+        (SINF, _) -> Inf+        (SC, SINF) -> error "factorEqualizer: h's image must lie within incl's image"+        (SC @b, SC @a) -> case cmpNat (Proxy @a) (Proxy @b) of+          LTI -> GTE+          EQI -> GTE+          GTI -> error "factorEqualizer: h's image must lie within incl's image"+    )+      \\ incl+      \\ h++-- | Dual to the 'HasEqualizers' instance above.+instance HasCoequalizers COST where+  coequalize = thinCoequalize+  factorCoequalizer @c @_ @c' q h =+    ( case (sing @c, sing @c') of+        (SINF, _) -> Inf+        (SC, SINF) -> error "factorCoequalizer: h must be constant on q's fibers"+        (SC @a, SC @b) -> case cmpNat (Proxy @b) (Proxy @a) of+          LTI -> GTE+          EQI -> GTE+          GTI -> error "factorCoequalizer: h must be constant on q's fibers"+    )+      \\ q+      \\ h++instance HasPullbacks COST where+  pullback = thinPullback+  factorPullback = factorPullbackDefault++instance HasPushouts COST where+  pushout = thinPushout+  factorPushout = factorPushoutDefault++instance HasEpiMonoFactorization COST
+ src/Proarrow/Category/Instance/Discrete.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | The __discrete__ category on an 'Thin.Indexed' kind @k@ (@'DISCRETE' k@): the numbered inhabitants+-- of @k@ are the objects and the only arrows are identities ('Refl'). The numbering makes the+-- category decidable, and a 'Thin.Finite' kind gives an enumerable one, so that reachability along+-- a graph on a bare set of points can be computed. Its mirror image, the __codiscrete__ category+-- @CODISCRETE k@, has exactly one arrow between any two objects. All (co)limits that exist are+-- trivially computed.+module Proarrow.Category.Instance.Discrete where++import Data.Type.Equality (type (~~))+import Data.Type.Equality qualified as Eq+import Data.Type.Nat (snat)+import Prelude (type (~))++import Proarrow.Category.Enriched (EnrichedProfunctor (..))+import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Proarrow.Category.Enriched.Quantale (Quantale (..), bottomTensor)+import Proarrow.Category.Enriched.Thin qualified as Thin+import Proarrow.Category.Instance.Bool (BOOL (..), If)+import Proarrow.Category.Instance.Cost (COST)+import Proarrow.Category.Monoidal (Monoidal (..))+import Proarrow.Category.Topos (HasEpiMonoFactorization (..))+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..))+import Proarrow.Colimit.Coequalizer (HasCoequalizers (..), thinCoequalize)+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Colimit.Pushout (HasPushouts (..))+import Proarrow.Core (CAT, CategoryOf (..), Kind, Profunctor (..), Promonad (..), UN, dimapDefault, obj)+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..))+import Proarrow.Limit.Equalizer (HasEqualizers (..), thinEqualize)+import Proarrow.Limit.Pullback (HasPullbacks (..))++type data DISCRETE k = D k++type Discrete :: CAT (DISCRETE k)+data Discrete a b where+  Refl :: (Ob a) => Discrete a a++-- | The discrete category with only identity arrows on the numbered inhabitants of @k@.+instance (Thin.Indexed k) => CategoryOf (DISCRETE k) where+  type (~>) = Discrete+  type Ob (a :: DISCRETE k) = Thin.KnownIndex a++instance (Thin.Indexed k) => Profunctor (Discrete :: CAT (DISCRETE k)) where+  dimap = dimapDefault+  r \\ Refl = r+instance (Thin.Indexed k) => Promonad (Discrete :: CAT (DISCRETE k)) where+  id = Refl+  Refl . Refl = Refl++instance (Thin.Indexed k) => Thin.ThinProfunctor (Discrete :: CAT (DISCRETE k)) where+  type HasArrow Discrete a b = (a ~~ b)+  arr = Refl+  withArr Refl r = r++-- | An arrow of @'DISCRETE' k@ is an equality. This also witnesses that the category is discrete:+-- it only typechecks because 'Thin.withEq' demands it.+withEq :: forall {k} (a :: DISCRETE k) b r. (Thin.Indexed k) => Discrete a b -> ((a ~~ b) => r) -> r+withEq p r = Thin.withEq p r++-- | Two points are equal exactly when their indices are.+instance (Thin.Indexed k) => Thin.DecidableProfunctor (Discrete :: CAT (DISCRETE k)) where+  type Holds (Discrete :: CAT (DISCRETE k)) a b = Thin.Equal a b+  decide @a @b = Thin.mapDecision (\Eq.Refl -> Refl) (Thin.decideEq @a @b)+  toHolds @a Refl r = Thin.withNatEqRefl (snat @(Thin.Index a)) r++-- | The hom-object of the discrete category in a quantale: the unit on the diagonal, the bottom off+-- it. Points are at distance @0@ from themselves and infinitely far from each other: the discrete+-- category is a (discrete) Lawvere metric space, the base for shortest paths on a bare set of points.+type Delta :: forall (v :: Kind) -> BOOL -> v+type Delta v c = If c (Unit :: v) InitialObject++-- | The action of the discrete base on a matrix over the points: on the diagonal the 'Delta' is the+-- unit and the action is the unitor, off it the 'Delta' is the bottom and the action absorbs. The+-- argument says how the matrix is reindexed on the diagonal.+deltaAct+  :: forall {k} {v} (x :: k) y (w :: v) w'+   . (Quantale v, Thin.KnownIndex x, Thin.KnownIndex y, Ob w, Ob w')+  => ((x ~ y) => w Eq.:~: w') -> (Delta v (Thin.Equal x y) ** w) ~> w'+deltaAct eq = case Thin.decideEq @x @y of+  Thin.Yes Eq.Refl -> case eq of Eq.Refl -> leftUnitor @v @w+  Thin.No -> bottomTensor @w @w'++instance (Thin.Indexed k) => EnrichedProfunctor COST (Discrete :: CAT (DISCRETE k)) where+  type ProObj COST (Discrete :: CAT (DISCRETE k)) a b = Delta COST (Thin.Equal a b)+  withProObj @a @b r = case Thin.decideEq @a @b of+    Thin.Yes Eq.Refl -> r+    Thin.No -> r+  underlying @a Refl = Thin.withNatEqRefl (snat @(Thin.Index a)) (obj @(Unit :: COST))+  enriched @a @b f = case Thin.decideEq @a @b of+    Thin.Yes Eq.Refl -> Refl+    Thin.No -> unitIsNotBottom @COST f+  rmap @a @b @c =+    withProObj @COST @(Discrete :: CAT (DISCRETE k)) @a @b+      ( withProObj @COST @(Discrete :: CAT (DISCRETE k)) @a @c+          (deltaAct @b @c @(Delta COST (Thin.Equal a b)) @(Delta COST (Thin.Equal a c)) Eq.Refl)+      )+  lmap @a @b @c =+    withProObj @COST @(Discrete :: CAT (DISCRETE k)) @a @b+      ( withProObj @COST @(Discrete :: CAT (DISCRETE k)) @c @b+          (deltaAct @c @a @(Delta COST (Thin.Equal a b)) @(Delta COST (Thin.Equal c b)) Eq.Refl)+      )++instance (Thin.Indexed k) => Thin.Indexed (DISCRETE k) where+  type Index (a :: DISCRETE k) = Thin.Index (UN D a)+  type At (DISCRETE k) i = Thin.FmapWrap D (Thin.At k i)++instance (Thin.Finite k) => Thin.Finite (DISCRETE k) where+  type Objects (DISCRETE k) = Thin.MapWrap D (Thin.Objects k)+  finite = Thin.wrapFinite @D+  withAtLookup = Thin.withWrapAtLookup @D++instance (Thin.Finite k) => Thin.Enumerable (DISCRETE k) where+  withIndex r = r+  withOb r = r++instance (Thin.Indexed k) => DaggerProfunctor (Discrete :: CAT (DISCRETE k)) where+  dagger Refl = Refl++instance (Thin.Indexed k) => HasEqualizers (DISCRETE k) where+  equalize = thinEqualize+  factorEqualizer Refl Refl = Refl++instance (Thin.Indexed k) => HasCoequalizers (DISCRETE k) where+  coequalize = thinCoequalize+  factorCoequalizer Refl Refl = Refl++instance (Thin.Indexed k) => HasPullbacks (DISCRETE k) where+  pullback Refl Refl k = k Refl Refl+  factorPullback Refl Refl Refl Refl = Refl++instance (Thin.Indexed k) => HasPushouts (DISCRETE k) where+  pushout Refl Refl k = k Refl Refl+  factorPushout Refl Refl Refl Refl = Refl++instance (Thin.Indexed k) => HasEpiMonoFactorization (DISCRETE k)++type data CODISCRETE k = CD k++type Codiscrete :: CAT (CODISCRETE k)+data Codiscrete a b where+  Arr :: (Ob a, Ob b) => Codiscrete a b++-- | The codiscrete category has exactly one arrow between any two objects, the numbered inhabitants+-- of @k@. The numbering makes it enumerable, so its closure can be computed.+instance (Thin.Indexed k) => CategoryOf (CODISCRETE k) where+  type (~>) = Codiscrete+  type Ob (a :: CODISCRETE k) = Thin.KnownIndex a++instance (Thin.Indexed k) => Profunctor (Codiscrete :: CAT (CODISCRETE k)) where+  dimap = dimapDefault+  r \\ Arr = r+instance (Thin.Indexed k) => Promonad (Codiscrete :: CAT (CODISCRETE k)) where+  id = Arr+  Arr . Arr = Arr++instance (Thin.Indexed k) => Thin.ThinProfunctor (Codiscrete :: CAT (CODISCRETE k))++instance (Thin.Indexed k) => Thin.DecidableProfunctor (Codiscrete :: CAT (CODISCRETE k)) where+  type Holds Codiscrete a b = TRU+  decide = Thin.Yes Arr+  toHolds Arr r = r++-- | Witnesses that @'CODISCRETE' k@ really is codiscrete: this only typechecks if 'Codiscrete' is a+-- 'Thin.CodiscreteProfunctor', so the definition is the check.+anyArr :: forall {k} (a :: CODISCRETE k) b. (Thin.Indexed k, Ob a, Ob b) => Codiscrete a b+anyArr = Thin.anyArr++instance (Thin.Indexed k) => Thin.Indexed (CODISCRETE k) where+  type Index (a :: CODISCRETE k) = Thin.Index (UN CD a)+  type At (CODISCRETE k) i = Thin.FmapWrap CD (Thin.At k i)++instance (Thin.Finite k) => Thin.Finite (CODISCRETE k) where+  type Objects (CODISCRETE k) = Thin.MapWrap CD (Thin.Objects k)+  finite = Thin.wrapFinite @CD+  withAtLookup = Thin.withWrapAtLookup @CD++instance (Thin.Finite k) => Thin.Enumerable (CODISCRETE k) where+  withIndex r = r+  withOb r = r++instance (Thin.Indexed k) => DaggerProfunctor (Codiscrete :: CAT (CODISCRETE k)) where+  dagger Arr = Arr++instance (Thin.Indexed k) => HasEqualizers (CODISCRETE k) where+  equalize = thinEqualize+  factorEqualizer Arr Arr = Arr++instance (Thin.Indexed k) => HasCoequalizers (CODISCRETE k) where+  coequalize = thinCoequalize+  factorCoequalizer Arr Arr = Arr++instance (Thin.Indexed k) => HasPullbacks (CODISCRETE k) where+  pullback @o Arr Arr k = k @o Arr Arr+  factorPullback Arr Arr Arr Arr = Arr++instance (Thin.Indexed k) => HasPushouts (CODISCRETE k) where+  pushout @o Arr Arr k = k @o Arr Arr+  factorPushout Arr Arr Arr Arr = Arr++instance (Thin.Indexed k) => HasEpiMonoFactorization (CODISCRETE k)++-- | Any object works as the product of any two objects here, since every hom-set is a singleton.+instance (Thin.Indexed k) => HasBinaryProducts (CODISCRETE k) where+  type a && b = a+  withObProd r = r+  fst = Arr+  snd = Arr+  Arr &&& Arr = Arr++-- | Dual to the 'HasBinaryProducts' instance above.+instance (Thin.Indexed k) => HasBinaryCoproducts (CODISCRETE k) where+  type a || b = a+  withObCoprod r = r+  lft = Arr+  rgt = Arr+  Arr ||| Arr = Arr
+ src/Proarrow/Category/Instance/Duploid.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | The __duploid__ of an adjunction (Munch-Maccagnoni): objects are the positive ('P') and+-- negative ('N') objects of the adjunction's two categories, and a hom @x '~>' y@ is an element+-- @adj ('Pos' x) ('Neg' y)@ of the adjunction profunctor. Composition is biased by the polarity of+-- the middle object ('(•)' through the positive side, '(◦)' through the negative side) and is+-- __not associative in general__. The 'Promonad' instance is a deliberate abuse.+module Proarrow.Category.Instance.Duploid where++import Data.Kind (Constraint)++import Proarrow.Adjunction (AdjMonad, Adjunction)+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), StrongMonoidalCorep, SymMonoidal (..))+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..))+import Proarrow.Core+  ( CAT+  , CategoryOf (..)+  , Kind+  , Profunctor (..)+  , Promonad (..)+  , dimapDefault+  , lmap+  , obj+  , rmap+  , ($)+  , (//)+  , type (+->)+  )+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..))+import Proarrow.Profunctor.Corepresentable (Corepresentable (..), corepUniv, withObCorep)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Representable (CorepStar (..), Representable (..), repUniv, withObRep)++type DUPLOID :: forall {n} {p}. n +-> p -> Kind+type data DUPLOID (adj :: n +-> p) = N n | P p++data SDuploidObj x where+  SN :: (Ob x) => SDuploidObj (N x)+  SP :: (Ob x) => SDuploidObj (P x)++type IsPN :: forall {n} {p} {adj}. DUPLOID (adj :: n +-> p) -> Constraint+class IsPN x where+  pn :: SDuploidObj x+  withPosOb :: ((Ob (Pos x)) => r) -> r+  withNegOb :: ((Ob (Neg x)) => r) -> r+instance (Ob x, Corepresentable adj) => IsPN (P x :: DUPLOID adj) where+  pn = SP+  withPosOb r = r+  withNegOb r = withObCorep @adj @x r+instance (Ob x, Representable adj) => IsPN (N x :: DUPLOID adj) where+  pn = SN+  withPosOb r = withObRep @adj @x r+  withNegOb r = r++type family Pos (x :: DUPLOID (adj :: n +-> p)) :: p where+  Pos (P a) = a+  Pos (N a :: DUPLOID adj) = adj % a++type family Neg (x :: DUPLOID (adj :: n +-> p)) :: n where+  Neg (P a :: DUPLOID adj) = adj %% a+  Neg (N a) = a++type Duploid :: CAT (DUPLOID adj)+data Duploid x y where+  Duploid :: forall {adj} (x :: DUPLOID adj) y. (Ob x, Ob y) => adj (Pos x) (Neg y) -> Duploid x y++instance (Adjunction adj) => Profunctor (Duploid :: CAT (DUPLOID adj)) where+  dimap = dimapDefault+  r \\ Duploid{} = r++-- | ATTENTION: a duploid is not associative, so not really a promonad/category!+instance (Adjunction adj) => Promonad (Duploid :: CAT (DUPLOID adj)) where+  id @x = Duploid case pn @x of+    SP -> corepUniv+    SN -> repUniv+  g@(Duploid @y _) . f = case pn @y of+    SP -> g • f+    SN -> g ◦ f++-- | The duploid of an adjunction, with polarized objects. Deliberately unlawful: composition is+-- polarity-biased and not associative (see the warning on the 'Promonad' instance above).+instance (Adjunction adj) => CategoryOf (DUPLOID adj) where+  type (~>) = Duploid+  type Ob x = IsPN x++(•) :: forall {adj} (x :: DUPLOID adj) y z. (Corepresentable adj) => P y ~> z -> x ~> P y -> x ~> z+Duploid g • Duploid f = Duploid (rmap (coindex g) f)++(◦) :: forall {adj} (x :: DUPLOID adj) y z. (Representable adj) => N y ~> z -> x ~> N y -> x ~> z+Duploid g ◦ Duploid f = Duploid (lmap (index f) g)++fromThunkable :: forall {adj} (x :: DUPLOID adj) y. (Adjunction adj, Ob x, Ob y) => Pos x ~> Pos y -> x ~> y+fromThunkable f = Duploid (case pn @y of SN -> tabulate f; SP -> cotabulate (corepMap @adj f)) \\ f++fromLinear :: forall {adj} (x :: DUPLOID adj) y. (Adjunction adj, Ob x, Ob y) => Neg x ~> Neg y -> x ~> y+fromLinear f = Duploid (case pn @x of SN -> tabulate (repMap @adj f); SP -> cotabulate f) \\ f++type Dn x = P (Pos x)++down :: forall {adj} (x :: DUPLOID adj). (Adjunction adj, Ob x) => x ~> Dn x+down = withPosOb @x $ Duploid corepUniv++undown :: forall {adj} (x :: DUPLOID adj). (Adjunction adj, Ob x) => Dn x ~> x+undown = withPosOb @x $ fromThunkable (obj @(Pos x))++mapDown :: forall {adj} (x :: DUPLOID adj) y. (Adjunction adj) => x ~> y -> Dn x ~> (Dn y :: DUPLOID adj)+mapDown f = down . f . undown \\ f++type Up x = N (Neg x)++unup :: forall {adj} (x :: DUPLOID adj). (Adjunction adj, Ob x) => Up x ~> x+unup = withNegOb @x $ Duploid repUniv++up :: forall {adj} (x :: DUPLOID adj). (Adjunction adj, Ob x) => x ~> Up x+up = withNegOb @x $ fromLinear (obj @(Neg x))++mapUp :: forall {adj} (x :: DUPLOID adj) y. (Adjunction adj) => x ~> y -> Up x ~> (Up y :: DUPLOID adj)+mapUp f = up . f . unup \\ f++instance (Adjunction (adj :: n +-> p), StrongMonoidalCorep adj) => MonoidalProfunctor (Duploid :: CAT (DUPLOID adj)) where+  one = id+  (**) @_ @x2 @_ @y2 f g =+    f // g // case (down . f, down . g) of+      (Duploid fp, Duploid gp) ->+        withPosOb @x2 $+          withPosOb @y2 $+            withOb2 @_ @(Pos x2) @(Pos y2) $+              withObCorep @adj @(Pos x2 ** Pos y2) $+                case lmap (index fp) (repUniv @(AdjMonad adj) @(Pos x2))+                  ** lmap (index gp) (repUniv @(AdjMonad adj) @(Pos y2)) of+                  fg :.: CorepStar h -> Duploid (rmap h fg) \\ fg++instance (Adjunction (adj :: n +-> p), StrongMonoidalCorep adj) => Monoidal (DUPLOID adj) where+  type x ** y = P (Pos x ** Pos y)+  type Unit = P Unit+  withOb2 @a @b r = withPosOb @a $ withPosOb @b $ withOb2 @_ @(Pos a) @(Pos b) r+  leftUnitor @a = withPosOb @a $ withOb2 @_ @Unit @(Pos a) $ fromThunkable (leftUnitor @_ @(Pos a))+  leftUnitorInv @a = withPosOb @a $ withOb2 @_ @Unit @(Pos a) $ fromThunkable (leftUnitorInv @_ @(Pos a))+  rightUnitor @a = withPosOb @a $ withOb2 @_ @(Pos a) @Unit $ fromThunkable (rightUnitor @_ @(Pos a))+  rightUnitorInv @a = withPosOb @a $ withOb2 @_ @(Pos a) @Unit $ fromThunkable (rightUnitorInv @_ @(Pos a))+  associator @a @b @c =+    withPosOb @a $+      withPosOb @b $+        withPosOb @c $+          withOb2 @_ @(Pos a) @(Pos b) $+            withOb2 @_ @(Pos a ** Pos b) @(Pos c) $+              withOb2 @_ @(Pos b) @(Pos c) $+                withOb2 @_ @(Pos a) @(Pos b ** Pos c) $+                  fromThunkable (associator @_ @(Pos a) @(Pos b) @(Pos c))+  associatorInv @a @b @c =+    withPosOb @a $+      withPosOb @b $+        withPosOb @c $+          withOb2 @_ @(Pos a) @(Pos b) $+            withOb2 @_ @(Pos a ** Pos b) @(Pos c) $+              withOb2 @_ @(Pos b) @(Pos c) $+                withOb2 @_ @(Pos a) @(Pos b ** Pos c) $+                  fromThunkable (associatorInv @_ @(Pos a) @(Pos b) @(Pos c))++type StrongSymMonAdj (adj :: n +-> p) = (Adjunction adj, StrongMonoidalCorep adj, SymMonoidal p)++instance (StrongSymMonAdj adj) => SymMonoidal (DUPLOID adj) where+  swap @a @b =+    withPosOb @a $+      withPosOb @b $+        withOb2 @_ @(Pos a) @(Pos b) $+          withOb2 @_ @(Pos b) @(Pos a) $+            fromThunkable (swap @_ @(Pos a) @(Pos b))++instance (HasBinaryCoproducts p, Adjunction adj) => HasBinaryCoproducts (DUPLOID (adj :: n +-> p)) where+  type a || b = P (Pos a || Pos b)+  withObCoprod @a @b r = withPosOb @a $ withPosOb @b $ withObCoprod @p @(Pos a) @(Pos b) r+  lft @a @b = withPosOb @a $ withPosOb @b $ withObCoprod @p @(Pos a) @(Pos b) $ fromThunkable (lft @p @(Pos a) @(Pos b))+  rgt @a @b = withPosOb @a $ withPosOb @b $ withObCoprod @p @(Pos a) @(Pos b) $ fromThunkable (rgt @p @(Pos a) @(Pos b))+  Duploid @x @a f ||| Duploid @y g =+    withPosOb @x $+      withPosOb @y $+        withObCoprod @p @(Pos x) @(Pos y) $+          withNegOb @a $+            Duploid (tabulate (index f ||| index g))++instance (HasBinaryProducts n, Adjunction adj) => HasBinaryProducts (DUPLOID (adj :: n +-> p)) where+  type a && b = N (Neg a && Neg b)+  withObProd @a @b r = withNegOb @a $ withNegOb @b $ withObProd @n @(Neg a) @(Neg b) r+  fst @a @b = withNegOb @a $ withNegOb @b $ withObProd @n @(Neg a) @(Neg b) $ fromLinear (fst @n @(Neg a) @(Neg b))+  snd @a @b = withNegOb @a $ withNegOb @b $ withObProd @n @(Neg a) @(Neg b) $ fromLinear (snd @n @(Neg a) @(Neg b))+  Duploid @a @x f &&& Duploid @_ @y g =+    withNegOb @x $+      withNegOb @y $+        withObProd @n @(Neg x) @(Neg y) $+          withPosOb @a $+            Duploid (cotabulate (coindex f &&& coindex g))
+ src/Proarrow/Category/Instance/Fam.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | The @Fam@ construction, a.k.a. the __free coproduct completion__ of a category: an object of+-- @'FAM' k@ is a family of @k@-objects indexed by some kind @x@ (a representable profunctor+-- @dx :: x '+->' k@, packaged as @'DEP' x dx@), and a morphism is a reindexing functor together+-- with a componentwise map of families.+module Proarrow.Category.Instance.Fam where++import Data.Kind (Type)+import GHC.Base (Any)+import Prelude (type (~))++import Proarrow.Category.Instance.Coproduct (COPRODUCT (..), Codiag, Lft, Rgt, (:++:) (..))+import Proarrow.Category.Instance.Opposite (OPPOSITE)+import Proarrow.Category.Instance.Product (Diag, Fst, Snd, (:**:) (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Instance.Unit (Unit (..))+import Proarrow.Category.Instance.Zero (VOID)+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..))+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Core+  ( CAT+  , CategoryOf (..)+  , Kind+  , Profunctor (..)+  , Promonad (..)+  , UN+  , dimapDefault+  , lmap+  , obj+  , rmap+  , tgt+  , (//)+  , (:~>)+  , type (+->)+  )+import Proarrow.Functor (FunctorForRep (..), Presheaf)+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..))+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Profunctor.Corepresentable (Corep (..), Corepresentable (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Constant (Constant)+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Instance.Terminal (TerminalProfunctor (..))+import Proarrow.Profunctor.Representable (Rep (..), Representable (..), repUniv)++type data FAM (k :: Kind) = forall (x :: Kind). DEP_ (x +-> k)++type family X (a :: FAM k) :: Kind where+  X (DEP_ (dx :: x +-> k)) = x+type DX :: forall (a :: FAM k) -> (X a +-> k)+type DX a = UN DEP_ a++type DEP :: forall x -> (x +-> k) -> FAM k+type DEP x dx = DEP_ dx++type Fam :: CAT (FAM k)+data Fam a b where+  Fam+    :: forall {k} {x} {y} {dx :: x +-> k} {dy :: y +-> k} (f :: x +-> y)+     . (Representable dx, Representable dy, Representable f)+    => dx :~> dy :.: f+    -> Fam (DEP x dx :: FAM k) (DEP y dy :: FAM k)++instance (CategoryOf k) => Profunctor (Fam :: CAT (FAM k)) where+  dimap = dimapDefault+  r \\ Fam{} = r++instance (CategoryOf k) => Promonad (Fam :: CAT (FAM k)) where+  id = Fam @Id \dx -> dx :.: Id (tgt dx)+  Fam @f l . Fam @g r = Fam @(f :.: g) \dx -> case r dx of dy :.: g -> case l dy of dz :.: f -> dz :.: (f :.: g)++-- | The Fam construction a.k.a. the free coproduct completion of @k@+instance (CategoryOf k) => CategoryOf (FAM k) where+  type (~>) = Fam+  type Ob (a :: FAM k) = (a ~ DEP (X a) (DX a), Representable (DX a))++data family Embed :: k +-> FAM k+instance (CategoryOf k) => FunctorForRep (Embed :: k +-> FAM k) where+  type Embed @ a = DEP () (Rep (Constant a))+  fmap f = f // Fam @(Rep (Constant '())) \(Rep a) -> Rep (f . a) :.: Rep Unit++-- | The presheaf on @k@ underlying a family @dx@: @'AsPresheaf' dx a '()@ holds a value+-- @dx a b@ with the index @b@ hidden.+type AsPresheaf :: x +-> k -> Presheaf k+data AsPresheaf dx a u where+  AsPresheaf :: dx a b -> AsPresheaf dx a '()++instance (CategoryOf k, Profunctor dx) => Profunctor (AsPresheaf dx :: Presheaf k) where+  dimap l Unit (AsPresheaf dx) = AsPresheaf (lmap l dx)+  r \\ AsPresheaf dx = r \\ dx+data family IsPresheafSub :: FAM k +-> Presheaf k+instance (CategoryOf k) => FunctorForRep (IsPresheafSub :: FAM k +-> Presheaf k) where+  type IsPresheafSub @ (DEP x dx) = AsPresheaf dx+  fmap (Fam r) = Prof \(AsPresheaf dx) -> AsPresheaf (case r dx of dy :.: f -> rmap (index f) dy)++data family Initiate :: VOID +-> k+instance (CategoryOf k) => FunctorForRep (Initiate :: VOID +-> k) where+  type Initiate @ a = Any+  fmap = \case {}++instance (CategoryOf k) => HasInitialObject (FAM k) where+  type InitialObject = DEP VOID (Rep Initiate)+  initiate = Fam @(Rep Initiate) \(Rep @b _) -> case obj @b of {}++instance (CategoryOf k) => HasBinaryCoproducts (FAM k) where+  type a || b = DEP (COPRODUCT (X a) (X b)) (Rep Codiag :.: (DX a :++: DX b))+  withObCoprod r = r+  lft = Fam @(Rep Lft) \p -> (repUniv :.: InjL p) :.: repUniv \\ p+  rgt = Fam @(Rep Rgt) \q -> (repUniv :.: InjR q) :.: repUniv \\ q+  Fam @f l ||| Fam @g r = Fam @(Rep Codiag :.: (f :++: g)) \case+    Rep d :.: InjL p -> case l p of dx :.: f -> lmap d dx :.: (repUniv :.: InjL f) \\ f+    Rep d :.: InjR q -> case r q of dy :.: g -> lmap d dy :.: (repUniv :.: InjR g) \\ g++instance (HasTerminalObject k) => HasTerminalObject (FAM k) where+  type TerminalObject = DEP () TerminalProfunctor+  terminate = Fam @(Rep (Constant '())) \dx -> TerminalProfunctor :.: Rep Unit \\ dx++instance (HasBinaryProducts k) => HasBinaryProducts (FAM k) where+  type a && b = DEP (X a, X b) (Corep Diag :.: (DX a :**: DX b))+  withObProd r = r+  fst = Fam @(Rep Fst) \(Corep (d :**: _) :.: (l :**: r)) -> lmap d l :.: repUniv \\ l \\ r+  snd = Fam @(Rep Snd) \(Corep (_ :**: d) :.: (l :**: r)) -> lmap d r :.: repUniv \\ l \\ r+  Fam @f l &&& Fam @g r = Fam @((f :**: g) :.: Rep Diag) \dx -> case (l dx, r dx) of+    (dy1 :.: f, dy2 :.: g) -> (corepUniv :.: (dy1 :**: dy2)) :.: ((f :**: g) :.: repUniv) \\ f \\ dy2++type Poly = FAM (OPPOSITE Type)
+ src/Proarrow/Category/Instance/FinHask.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++{- HLINT ignore "Use const" -}++-- | The category of __finite Haskell types__: objects are types with 'Universe'\/'Finite'+-- instances (wrapped in 'FH'), and a morphism is a function stored extensionally as a finite+-- lookup table ('Data.Map.Map'), so morphisms can be enumerated, shown and compared. A finite,+-- fully inspectable stand-in for "Proarrow.Category.Instance.Hask".+module Proarrow.Category.Instance.FinHask where++import Data.Coerce qualified as P+import Data.Containers.ListUtils (nubOrd)+import Data.Data (Proxy (..))+import Data.Kind (Type)+import Data.List (genericLength)+import Data.List qualified as P+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as M+import Data.Universe.Class (Finite (..), Universe (..))+import Data.Universe.Helpers (Tagged (..), retag)+import Data.Void (Void)+import GHC.TypeNats (KnownNat, Nat, natVal, withKnownNat, withSomeSNat)+import Numeric.Natural (Natural)+import Prelude (Bool (..), ($))+import Prelude qualified as P++import Proarrow.Category.Enriched.Finitary (Finitary (..), finiteSize)+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Category.Monoidal.Cartesian (distLProd, distRProd)+import Proarrow.Category.Monoidal.Closed (Closed (..), uncurry)+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Distributive (Distributive (..))+import Proarrow.Category.Topos (ElementaryTopos, HasEpiMonoFactorization (..), HasSubobjectClassifier (..))+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..))+import Proarrow.Colimit.Coequalizer (HasCoequalizers (..))+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Colimit.Pushout (HasPushouts (..))+import Proarrow.Core (CAT, CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, dimapDefault)+import Proarrow.Limit.BinaryProduct+  ( HasBinaryProducts (..)+  , associatorProd+  , associatorProdInv+  , diag+  , leftUnitorProd+  , leftUnitorProdInv+  , rightUnitorProd+  , rightUnitorProdInv+  , swapProd+  )+import Proarrow.Limit.Equalizer (HasEqualizers (..))+import Proarrow.Limit.Pullback (HasPullbacks (..))+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Monoid (CocommutativeComonoid, Comonoid (..), Monoid (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))++newtype Fin (n :: Nat) = Fin {unFin :: P.Int}+  deriving newtype (P.Eq, P.Ord, P.Show, P.Num)++instance (KnownNat n) => Universe (Fin n) where+  universe = P.coerce @[P.Int] [0 .. (P.fromIntegral (natVal (Proxy @n)) P.- 1)]++instance (KnownNat n) => Finite (Fin n) where+  cardinality = Tagged (natVal (Proxy @n))++type data FINHASK = FH Type++type FinHask :: CAT FINHASK+data FinHask a b where+  FinHask :: (Ob (FH a), Ob (FH b)) => {unFinHask :: Map a b} -> FinHask (FH a) (FH b)++instance P.Show (FinHask a b) where+  show (FinHask m) = P.show m+deriving instance P.Eq (FinHask a b)+deriving instance P.Ord (FinHask a b)+instance (Ob a, Ob b) => Universe (FinHask a b) where+  universe = fromList P.<$> P.traverse (\a -> (a,) P.<$> universe) universe+instance (Ob a, Ob b) => Finite (FinHask a b) where+  cardinality =+    P.liftA2+      (P.^)+      (retag @_ @_ @(FinHask a b) (cardinality @(UN FH b)))+      (retag @_ @_ @(FinHask a b) (cardinality @(UN FH a)))++(!) :: (P.Ord (UN FH a)) => FinHask a b -> UN FH a -> UN FH b+FinHask m ! a = case M.lookup a m of+  P.Just x -> x+  P.Nothing -> P.error $ "Index " P.++ P.show a P.++ " out of bounds for " P.++ P.show m++arr :: (Ob (FH a), Ob (FH b)) => (a -> b) -> FinHask (FH a) (FH b)+arr f = fromList [(x, f x) | x <- universeF]++reifyList :: [a] -> (forall l. (Ob (FH l)) => Map l a -> r) -> r+reifyList xs k =+  withSomeSNat (genericLength xs) \ @n snat ->+    withKnownNat snat (k @(Fin n) (M.fromList (P.zip universeF xs)))++fromList :: (Ob (FH a), Ob (FH b)) => [(a, b)] -> FinHask (FH a) (FH b)+fromList = FinHask . M.fromList++toList :: (Ob (FH a), Ob (FH b)) => FinHask (FH a) (FH b) -> [(a, b)]+toList (FinHask m) = M.toList m++instance Profunctor FinHask where+  dimap = dimapDefault+  r \\ FinHask{} = r+instance Promonad FinHask where+  id = arr id+  FinHask l . FinHask r = FinHask (P.fmap (l M.!) r)++-- | The category of finite Haskell types, with morphisms stored extensionally as finite lookup+-- tables.+instance CategoryOf FINHASK where+  type (~>) = FinHask+  type Ob a = (Is FH a, Finite (UN FH a), P.Ord (UN FH a), P.Show (UN FH a))++instance HasInitialObject FINHASK where+  type InitialObject = FH Void+  initiate = FinHask M.empty+instance HasBinaryCoproducts FINHASK where+  type FH a || FH b = FH (P.Either a b)+  withObCoprod r = r+  lft = arr P.Left+  rgt = arr P.Right+  FinHask l ||| FinHask r = FinHask (M.mapKeys P.Left l P.<> M.mapKeys P.Right r)++instance HasTerminalObject FINHASK where+  type TerminalObject = FH ()+  terminate = arr \_ -> ()+instance HasBinaryProducts FINHASK where+  type FH a && FH b = FH (a, b)+  withObProd r = r+  fst = arr P.fst+  snd = arr P.snd+  FinHask l &&& FinHask r =+    FinHask+      ( M.mergeWithKey+          (\_ a b -> P.Just (a, b))+          (\_ -> M.empty)+          (\_ -> M.empty)+          l+          r+      )++instance MonoidalProfunctor FinHask where+  one = id+  (**) = (***)++instance Monoidal FINHASK where+  type a ** b = a && b+  type Unit = TerminalObject+  withOb2 @a @b = withObProd @_ @a @b+  leftUnitor = leftUnitorProd+  leftUnitorInv = leftUnitorProdInv+  rightUnitor = rightUnitorProd+  rightUnitorInv = rightUnitorProdInv+  associator @a @b @c = associatorProd @a @b @c+  associatorInv @a @b @c = associatorProdInv @a @b @c++instance SymMonoidal FINHASK where+  swap @a @b = swapProd @a @b++instance Closed FINHASK where+  type a ~~> b = FH (FinHask a b)+  withObExp r = r+  curry f@FinHask{} = arr \a -> arr \b -> f ! (a, b)+  apply = arr (uncurry (!))++-- | Where a value sits in its own type's 'universe'.+position :: forall x. (Finite x, P.Eq x) => x -> Natural+position x = case P.elemIndex x universeF of+  P.Just i -> P.fromIntegral i+  P.Nothing -> P.error "position: not in the universe of its type"++-- | The hom-sets of 'FINHASK' are finite, so its hom-profunctor is finitary. It is numbered in the+-- order of the 'universe' the 'Finite' instance above enumerates, but arithmetically instead of by+-- searching it. A morphism is a table of values indexed by @'universeF' \@a@. Reading that table+-- as a numeral in base @|b|@, most significant digit first, gives @universe@\'s own order, since+-- @universe@ is @'P.traverse' (\a -> (a,) '<$>' universe) universe@ and for lists @'<*>'@ varies+-- its right operand fastest. So it is the /last/ element of @a@ that varies fastest.+instance Finitary FinHask where+  size @a @b = finiteSize @FinHask @a @b+  toIndex @(FH a) @(FH b) f = P.foldl (\acc x -> acc P.* card @b P.+ position (f ! x)) 0 (universeF @a)+  fromIndex @(FH a) @(FH b) i = fromList (P.zip xs (digits (P.length xs) i))+    where+      xs = universeF @a+      digits :: P.Int -> Natural -> [b]+      digits 0 _ = []+      digits n m = case card @b of+        0 -> P.error "fromIndex: the source is inhabited and the target is empty, so there are no morphisms"+        c -> let (q, r) = m `P.divMod` c in digits (n P.- 1) q P.++ [universeF @b `P.genericIndex` r]++-- | How many inhabitants a type has.+card :: forall x. (Finite x) => Natural+card = unTagged (cardinality @x)++instance Distributive FINHASK where+  distL @a @b @c = distLProd @a @b @c+  distR @a @b @c = distRProd @a @b @c+  absorbL = FinHask M.empty+  absorbR = FinHask M.empty++instance (Ob (FH a)) => Comonoid (FH a) where+  counit = terminate+  comult = diag+instance (Ob (FH a)) => CocommutativeComonoid (FH a)++instance CopyDiscard FINHASK++instance Monoid (FH ()) where+  mempty = terminate+  mappend = terminate++-- | >>> let f :: FinHask (FH (Fin 4)) (FH (Fin 3)) = fromList [(0,0), (1,1), (2,1), (3,0)]+-- >>> let g :: FinHask (FH (Fin 4)) (FH (Fin 3)) = fromList [(0,2), (1,0), (2,1), (3,0)]+-- >>> let h :: FinHask (FH (Fin 3)) (FH (Fin 4)) = fromList [(0,3), (1,2), (2,3)]+-- >>> (equalize f g \incl -> let p = factorEqualizer incl h in P.show (incl, p, incl . p)) :: P.String+-- "(fromList [(0,2),(1,3)],fromList [(0,1),(1,0),(2,1)],fromList [(0,3),(1,2),(2,3)])"+instance HasEqualizers FINHASK where+  equalize f@FinHask{} g k =+    let groups = [x | x <- universeF, f ! x P.== g ! x]+    in reifyList groups \e -> k (FinHask e)+  factorEqualizer (FinHask incl) (FinHask h) =+    let invIncl = M.fromList [(v, ky) | (ky, v) <- M.toList incl]+    in FinHask ((invIncl M.!) P.<$> h)++-- | Example 3.84 of Seven Sketches (A: 0=red, 1=blue, 2=black)+-- >>> data Color = Red | Blue | Black deriving (P.Eq, P.Ord, P.Show, P.Enum, P.Bounded, Universe, Finite)+-- >>> let f :: FinHask (FH (Fin 6)) (FH Color) = fromList [(0,Red), (1,Blue), (2,Red), (3,Red), (4,Black), (5,Blue)]+-- >>> let g :: FinHask (FH (Fin 4)) (FH Color) = fromList [(0,Black), (1,Red), (2,Blue), (3,Red)]+-- >>> (pullback f g \(FinHask l) (FinHask r) -> P.show (P.zip (M.elems l) (M.elems r))) :: P.String+-- "[(0,1),(0,3),(1,2),(2,1),(2,3),(3,1),(3,3),(4,0),(5,2)]"+instance HasPullbacks FINHASK where+  pullback (FinHask f) (FinHask g) k =+    let+      gByValue = M.fromListWith (P.flip (P.++)) [(v, [y]) | (y, v) <- M.toList g]+      groups = [(x, y) | (x, v) <- M.toList f, y <- M.findWithDefault [] v gByValue]+    in+      reifyList groups \e -> k (FinHask (P.fst P.<$> e)) (FinHask (P.snd P.<$> e))++instance HasCoequalizers FINHASK where+  coequalize (FinHask @_ @b f) (FinHask g) k =+    let+      find m i = P.maybe i (find m) $ M.lookup i m+      union m (i, j) = let ri = find m i; rj = find m j in if ri P.== rj then m else M.insert ri rj m+      unionFind = P.foldl union M.empty (P.zip (M.elems f) (M.elems g))+      step m x = M.insertWith (P.++) (find unionFind x) [x] m+      groups = M.elems $ P.foldl step M.empty (universeF @b)+    in+      reifyList groups \ce ->+        let invMap = M.fromList $ P.concatMap (\(l, bs) -> P.map (,l) bs) $ M.toList ce+        in k (FinHask invMap)+  factorCoequalizer (FinHask q) (FinHask h) =+    let reps = M.fromListWith (\_ old -> old) [(v, ky) | (ky, v) <- M.toList q]+    in FinHask ((h M.!) P.<$> reps)++-- | Exercise 6.22 of Seven Sketches+-- >>> let l :: FinHask (FH (Fin 4)) (FH (Fin 3)) = fromList [(0,0), (1,0), (2,1), (3,2)]+-- >>> let r :: FinHask (FH (Fin 4)) (FH (Fin 5)) = fromList [(0,0), (1,2), (2,4), (3,4)]+-- >>> (pushout l r \l' r' -> P.show (l', r')) :: P.String+-- "(fromList [(0,1),(1,3),(2,3)],fromList [(0,1),(1,0),(2,1),(3,2),(4,3)])"+instance HasPushouts FINHASK++-- | >>> import Proarrow.Colimit.Pushout (isEpi)+-- >>> let f :: FinHask (FH (Fin 3)) (FH (Fin 3)) = fromList [(0,2), (1,0), (2,1)]+-- >>> (pushout f f \(FinHask g1) (FinHask g2) -> P.show (g1, g2)) :: P.String+-- "(fromList [(0,0),(1,1),(2,2)],fromList [(0,0),(1,1),(2,2)])"+-- >>> isEpi (f :: FinHask (FH (Fin 3)) (FH (Fin 3)))+-- True+-- >>> import Proarrow.Limit.Pullback (isMono)+-- >>> (pullback f f \(FinHask l) (FinHask r) -> P.show (l, r)) :: P.String+-- "(fromList [(0,0),(1,1),(2,2)],fromList [(0,0),(1,1),(2,2)])"+-- >>> isMono f+-- True+-- >>> import Proarrow.Category.Topos (classifyImage, classifyKernelPair, and, or, implies, false)+-- >>> (case factorize f of p :.: q -> P.show (p, q) \\ p \\ q) :: P.String+-- "(fromList [(0,0),(1,1),(2,2)],fromList [(0,2),(1,0),(2,1)])"+-- >>> (classifyImage f, classifyKernelPair f)+-- (fromList [(0,True),(1,True),(2,True)],fromList [((0,0),True),((0,1),False),((0,2),False),((1,0),False),((1,1),True),((1,2),False),((2,0),False),((2,1),False),((2,2),True)])+-- >>> [and, or, implies] :: [FinHask (FH (Bool, Bool)) (FH Bool)]+-- [fromList [((False,False),False),((False,True),False),((True,False),False),((True,True),True)],fromList [((False,False),False),((False,True),True),((True,False),True),((True,True),True)],fromList [((False,False),True),((False,True),True),((True,False),False),((True,True),True)]]+-- >>> false :: FinHask (FH ()) (FH Bool)+-- fromList [((),False)]+instance HasSubobjectClassifier FINHASK where+  type Omega = FH Bool+  true = arr \_ -> True+  classifyGraph f@FinHask{} = arr \(a, b) -> f ! a P.== b++instance HasEpiMonoFactorization FINHASK where+  factorize (FinHask f) = reifyList (nubOrd (M.elems f)) \lb ->+    let invMap = M.fromList [(lb M.! l, l) | l <- universeF]+    in FinHask (P.fmap (invMap M.!) f) :.: FinHask lb++instance ElementaryTopos FINHASK
+ src/Proarrow/Category/Instance/FinRel.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | The skeleton of the category of __finite sets and relations__: objects are natural numbers+-- (@'FR' n@) and a morphism is a boolean matrix, stored as a vector of 'Bitstring's. A dagger+-- category with biproducts, where the (non-cartesian) monoidal tensor still admits+-- 'Proarrow.Category.Monoidal.CopyDiscard.CopyDiscard' structure.+module Proarrow.Category.Instance.FinRel where++import Data.Fin (Fin (..))+import Data.Type.Nat (Mult, Nat (..), Nat0, Nat1, Plus, SNat (..), SNatI, snat, snatToNatural)+import Data.Vec.Lazy (Vec (..), chunks, concatMap, repeat, universe, zipWith, (++))+import GHC.Bits qualified as B+import GHC.Natural (Natural)+import Prelude (Bounded, Enum (..), Eq, Num (..), Ord, Show, divMod, fromIntegral, ($))+import Prelude qualified as P++import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Proarrow.Category.Instance.FinSet (FINSET (..), FinSet (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Category.Monoidal.Action (MonoidalAction)+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..), coactCC)+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Distributive (Distributive (..))+import Proarrow.Category.Monoidal.Hypergraph (Frobenius, Hypergraph, cap, cup)+import Proarrow.Category.Monoidal.StarAutonomous (ExpSA, StarAutonomous (..), applySA, currySA, expSA)+import Proarrow.Category.Monoidal.Strength (Costrong (..))+import Proarrow.Colimit.BinaryCoproduct (Coprod (..), HasBinaryCoproducts (..), HasBiproducts)+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Core (CAT, CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, dimapDefault, obj, type (+->))+import Proarrow.Functor (FunctorForRep (..))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..))+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Monoid (CocommutativeComonoid, CommutativeMonoid, Comonoid (..), Monoid (..))+import Proarrow.Profunctor.Representable (Rep (..))++newtype Bitstring (n :: Nat) = BS Natural+  deriving (Eq, Ord)+  deriving newtype (Num, B.Bits)++instance (SNatI n) => Bounded (Bitstring n) where+  minBound = BS 0+  maxBound = BS (shiftN @n 1 - 1)+instance Enum (Bitstring n) where+  fromEnum (BS x) = fromIntegral x+  toEnum x = BS (fromIntegral x)+instance (SNatI n) => Show (Bitstring n) where+  show n = case snat @n of+    SZ -> ""+    SS -> case pop n of (n', b) -> (if b then "1" else "0") P.++ P.show n'++shiftN :: forall n. (SNatI n) => Natural -> Natural+shiftN n = n `B.shiftL` fromIntegral (snatToNatural (snat @n))++-- | Split n + m bits into two parts: the lower n bits and the higher m bits.+split :: (SNatI n) => Bitstring (Plus n m) -> (Bitstring n, Bitstring m)+split @n (BS x) = let (m, n) = x `divMod` shiftN @n 1 in (BS n, BS m)++splits :: forall n m. (SNatI n, SNatI m) => Bitstring (Mult n m) -> Vec n (Bitstring m)+splits bs = case snat @n of+  SZ -> VNil+  SS -> case split @m bs of+    (v, vs) -> v ::: splits vs++-- | Combine two bitstrings of lengths n and m into one bitstring with the n lower bits or m higher bits.+combine :: (SNatI n) => Bitstring n -> Bitstring m -> Bitstring (Plus n m)+combine @n (BS x) (BS y) = BS (shiftN @n y B..|. x)++combines :: (SNatI m) => Vec n (Bitstring m) -> Bitstring (Mult n m)+combines VNil = 0+combines (v ::: vs) = combine v (combines vs)++pop :: Bitstring (S n) -> (Bitstring n, P.Bool)+pop (BS n) = (BS (n `B.shiftR` 1), B.testBit n 0)++push :: P.Bool -> Bitstring n -> Bitstring (S n)+push b (BS n) = BS (n * 2 + if b then 1 else 0)++mult :: forall n m. (SNatI n, SNatI m) => Bitstring n -> Bitstring m -> Bitstring (Mult n m)+mult n m = case snat @n of+  SZ -> 0+  SS -> case pop n of (n', b) -> combine (if b then m else 0) (mult n' m)++bit :: (SNatI n) => Fin n -> Bitstring n+bit = B.bit . fromEnum++zero :: (SNatI n, SNatI m) => Vec n (Bitstring m)+zero = repeat 0++pick :: forall n a. Vec n a -> Bitstring n -> [a]+pick VNil _ = []+pick (a ::: as) n = case pop n of (n', b) -> (if b then (a :) else id) (pick as n')++fromBools :: forall n. Vec n P.Bool -> Bitstring n+fromBools VNil = 0+fromBools (b ::: bs) = push b (fromBools bs)++toBools :: forall n. (SNatI n) => Bitstring n -> Vec n P.Bool+toBools n = case snat @n of+  SZ -> VNil+  SS -> case pop n of (n', b) -> b ::: toBools n'++arr :: forall n m. FinSet (FS m) (FS n) -> FinRel (FR m) (FR n)+arr (FinSet v) = FinRel (P.fmap bit v)++coarr :: forall n m. FinSet (FS n) (FS m) -> FinRel (FR m) (FR n)+coarr (FinSet v) = FinRel (P.fmap fromBools (P.traverse (toBools . bit) v))++type data FINREL = FR Nat++type FinRel :: CAT FINREL+data FinRel a b where+  FinRel :: (SNatI n, SNatI m) => {unFinRel :: Vec n (Bitstring m)} -> FinRel (FR n) (FR m)++deriving instance P.Show (FinRel a b)+deriving instance P.Eq (FinRel a b)++instance Profunctor FinRel where+  dimap = dimapDefault+  r \\ FinRel{} = r+instance Promonad FinRel where+  id = FinRel (P.fmap bit universe)+  FinRel l . FinRel r = FinRel (P.fmap (P.foldr (B..|.) 0 . pick l) r)++-- | The skeleton of the category of finite sets and relations: objects are natural numbers and+-- an arrow @'FR' n '~>' 'FR' m@ is an @n@ by @m@ boolean matrix.+instance CategoryOf FINREL where+  type (~>) = FinRel+  type Ob a = (Is FR a, SNatI (UN FR a))++instance DaggerProfunctor FinRel where+  dagger (FinRel v) = FinRel (fromBools P.<$> P.traverse toBools v)++instance HasInitialObject FINREL where+  type InitialObject = FR Nat0+  initiate = FinRel VNil+instance HasBinaryCoproducts FINREL where+  type FR a || FR b = FR (Plus a b)+  withObCoprod @(FR a) @b r = case snat @a of+    SZ -> r+    SS @a' -> withObCoprod @_ @(FR a') @b r+  lft @(FR a) @(FR b) = withObCoprod @_ @(FR a) @(FR b) $ FinRel (P.fmap ((\a -> combine @a @b a 0) . bit) universe)+  rgt @(FR a) @(FR b) = withObCoprod @_ @(FR a) @(FR b) $ FinRel (P.fmap ((\b -> combine @a @b 0 b) . bit) universe)+  FinRel @a l ||| FinRel @b r = withObCoprod @_ @(FR a) @(FR b) $ FinRel (l ++ r)++instance HasTerminalObject FINREL where+  type TerminalObject = FR Nat0+  terminate = FinRel (repeat 0)+instance HasBinaryProducts FINREL where+  type a && b = FR (Plus (UN FR a) (UN FR b))+  withObProd @a @b r = withObCoprod @_ @a @b r+  fst @(FR a) @(FR b) = withObProd @_ @(FR a) @(FR b) $ FinRel (unFinRel (obj @(FR a)) ++ zero @b @a)+  snd @(FR a) @(FR b) = withObProd @_ @(FR a) @(FR b) $ FinRel (zero @a @b ++ unFinRel (obj @(FR b)))+  FinRel @_ @a l &&& FinRel @_ @b r = withObProd @_ @(FR a) @(FR b) $ FinRel (zipWith combine l r)++instance HasBiproducts FINREL++instance MonoidalProfunctor FinRel where+  one = id+  FinRel @nl @ml l ** FinRel @nr @mr r =+    withOb2 @_ @(FR nl) @(FR nr) $+      withOb2 @_ @(FR ml) @(FR mr) $+        FinRel (concatMap (\l' -> P.fmap (mult l') r) l)++instance Monoidal FINREL where+  type FR a ** FR b = FR (Mult a b)+  type Unit = FR Nat1+  withOb2 @(FR a) @b r = case snat @a of+    SZ -> r+    SS @a' -> withOb2 @_ @(FR a') @b $ withObCoprod @_ @b @(FR (Mult a' (UN FR b))) r+  leftUnitor = arr leftUnitor+  leftUnitorInv = arr leftUnitorInv+  rightUnitor = arr rightUnitor+  rightUnitorInv = arr rightUnitorInv+  associator @(FR a) @(FR b) @(FR c) = arr (associator @_ @(FS a) @(FS b) @(FS c))+  associatorInv @(FR a) @(FR b) @(FR c) = arr (associatorInv @_ @(FS a) @(FS b) @(FS c))++instance SymMonoidal FINREL where+  swap @(FR a) @(FR b) = arr (swap @_ @(FS a) @(FS b))++instance Distributive FINREL where+  distL @(FR a) @(FR b) @(FR c) = arr (distL @_ @(FS a) @(FS b) @(FS c))+  distR @(FR a) @(FR b) @(FR c) = arr (distR @_ @(FS a) @(FS b) @(FS c))+  absorbL @(FR a) = arr (absorbL @_ @(FS a))+  absorbR @(FR a) = arr (absorbR @_ @(FS a))++instance Closed FINREL where+  type x ~~> y = ExpSA x y+  withObExp @x @y r = withOb2 @_ @x @y r+  curry @x @y = currySA @x @y+  apply @y @z = applySA @y @z+  (^^^) = expSA++instance StarAutonomous FINREL where+  type Dual n = n+  withObDual r = r+  dual = dagger+  dualInv = dagger+  linDist @(FR a) @(FR b) @(FR c) (FinRel m) = withOb2 @_ @(FR b) @(FR c) $ FinRel (P.fmap combines (chunks @a @b m))+  linDistInv @(FR a) @(FR b) @(FR c) (FinRel m) = withOb2 @_ @(FR a) @(FR b) $ FinRel (concatMap @_ @b @_ @a (splits @b @c) m)+  doubleNeg = id+  doubleNegInv = id++instance CompactClosed FINREL where+  distribDual @m @n = dagger (obj @m) ** dagger (obj @n)+  dualUnit = id+  dualityUnit @a = cup @a+  dualityCounit @a = cap @a++instance (MonoidalAction (t :: (FINREL, FINREL) +-> FINREL)) => Costrong t FinRel where+  coact @x = coactCC @t @x++-- | >>> import Data.Type.Nat+-- >>> mappend @(FR Nat3)+-- FinRel {unFinRel = 100 ::: 000 ::: 000 ::: 000 ::: 010 ::: 000 ::: 000 ::: 000 ::: 001 ::: VNil}+instance (SNatI a) => Monoid (FR a) where+  mempty = FinRel (P.maxBound ::: VNil)+  mappend =+    withOb2 @_ @(FR a) @(FR a) $+      FinRel (concatMap @_ @a @_ @a (\i -> P.fmap (\j -> if i P.== j then bit i else 0) universe) universe)++-- | >>> import Data.Type.Nat+-- >>> comult @(FR Nat3)+-- FinRel {unFinRel = 100000000 ::: 000010000 ::: 000000001 ::: VNil}+instance (SNatI a) => Comonoid (FR a) where+  counit = arr counit+  comult = arr comult++instance (SNatI a) => CocommutativeComonoid (FR a)++instance (SNatI a) => Frobenius (FR a)+instance (SNatI a) => CommutativeMonoid (FR a)+instance Hypergraph FINREL+instance CopyDiscard FINREL++data family Fun :: FINSET +-> FINREL+instance FunctorForRep Fun where+  type Fun @ FS a = FR a+  fmap f = arr f \\ f+instance MonoidalProfunctor (Rep Fun) where+  one = Rep one+  Rep @b l ** Rep @d r = withOb2 @_ @b @d $ Rep (l ** r)+instance MonoidalProfunctor (Coprod (Rep Fun)) where+  one = Coprod (Rep id)+  Coprod (Rep @b l) ** Coprod (Rep @d r) = withObCoprod @_ @b @d $ Coprod (Rep (l +++ r))
+ src/Proarrow/Category/Instance/FinSet.hs view
@@ -0,0 +1,352 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++{- HLINT ignore "Use elemIndex" -}++-- | The skeleton of the category of __finite sets__: objects are natural numbers (@'FS' n@) and a+-- morphism @'FS' n '~>' 'FS' m@ is a function stored as its table, a length-@n@ vector of indices+-- below @m@. Distributive and cartesian closed (exponentials via the 'Exp' type family), with all+-- structure computed concretely.+module Proarrow.Category.Instance.FinSet where++import Data.Containers.ListUtils (nubOrd)+import Data.Data (Proxy (..))+import Data.Fin (Fin (..), fin0, fin1, split, weakenLeft, weakenRight)+import Data.IntMap qualified as IM+import Data.List qualified as List+import Data.Maybe (fromJust, fromMaybe, isNothing)+import Data.Type.Nat (Mult, Nat (..), Nat0, Nat1, Nat2, Plus, SNat (..), SNatI, snat)+import Data.Vec.Lazy+  ( Vec (..)+  , chunks+  , concat+  , concatMap+  , reifyList+  , repeat+  , tabulate+  , toList+  , universe+  , zipWith+  , (!)+  , (++)+  )+import Prelude (($))+import Prelude qualified as P++import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Distributive (Distributive (..))+import Proarrow.Category.Topos (ElementaryTopos, HasEpiMonoFactorization (..), HasSubobjectClassifier (..))+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..))+import Proarrow.Colimit.Coequalizer (HasCoequalizers (..))+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Colimit.Pushout (HasPushouts (..))+import Proarrow.Core (CAT, CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, dimapDefault)+import Proarrow.Limit.BinaryProduct+  ( HasBinaryProducts (..)+  , associatorProd+  , associatorProdInv+  , diag+  , leftUnitorProd+  , leftUnitorProdInv+  , rightUnitorProd+  , rightUnitorProdInv+  , swapProd+  )+import Proarrow.Limit.Equalizer (HasEqualizers (..))+import Proarrow.Limit.Pullback (HasPullbacks (..))+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Monoid (CocommutativeComonoid, Comonoid (..), Monoid (..))+import Proarrow.Optic (iso)+import Proarrow.Optic.Iso (Iso')+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))++type data FINSET = FS Nat++type FinSet :: CAT FINSET+data FinSet a b where+  FinSet :: (SNatI n, SNatI m) => {unFinSet :: Vec n (Fin m)} -> FinSet (FS n) (FS m)++deriving instance P.Show (FinSet a b)+deriving instance P.Eq (FinSet a b)++instance Profunctor FinSet where+  dimap = dimapDefault+  r \\ FinSet{} = r+instance Promonad FinSet where+  id = FinSet universe+  FinSet l . FinSet r = FinSet (P.fmap (l !) r)++-- | The skeleton of the category of finite sets: objects are natural numbers and an arrow+-- @'FS' n '~>' 'FS' m@ is a function given by its table.+instance CategoryOf FINSET where+  type (~>) = FinSet+  type Ob a = (Is FS a, SNatI (UN FS a))++instance HasInitialObject FINSET where+  type InitialObject = FS Nat0+  initiate = FinSet VNil+instance HasBinaryCoproducts FINSET where+  type FS a || FS b = FS (Plus a b)+  withObCoprod @(FS a) @b r = case snat @a of+    SZ -> r+    SS @a' -> withObCoprod @_ @(FS a') @b r+  lft @(FS a) @(FS b) = withObCoprod @_ @(FS a) @(FS b) $ FinSet (P.fmap (weakenLeft (Proxy @b)) universe)+  rgt @(FS a) @(FS b) = withObCoprod @_ @(FS a) @(FS b) $ FinSet (P.fmap (weakenRight (Proxy @a)) universe)+  FinSet @a l ||| FinSet @b r = withObCoprod @_ @(FS a) @(FS b) $ FinSet (l ++ r)++instance HasTerminalObject FINSET where+  type TerminalObject = FS Nat1+  terminate = FinSet (repeat fin0)+instance HasBinaryProducts FINSET where+  type FS a && FS b = FS (Mult a b)+  withObProd @(FS a) @b r = case snat @a of+    SZ -> r+    SS @a' -> withObProd @_ @(FS a') @b $ withObCoprod @_ @b @(FS (Mult a' (UN FS b))) r+  fst @(FS a) @(FS b) = withObProd @_ @(FS a) @(FS b) $ FinSet (concat @a @b $ P.fmap repeat universe)+  snd @(FS a) @(FS b) = withObProd @_ @(FS a) @(FS b) $ FinSet (concat @a @b $ repeat universe)+  FinSet @_ @a l &&& FinSet @_ @b r = withObProd @_ @(FS a) @(FS b) $ FinSet (zipWith mult l r)++instance Distributive FINSET where+  distL @(FS a) @(FS b) @(FS c) =+    withObCoprod @_ @(FS b) @(FS c) $+      withObProd @_ @(FS a) @(FS (Plus b c)) $+        withObProd @_ @(FS a) @(FS b) $+          withObProd @_ @(FS a) @(FS c) $+            withObCoprod @_ @(FS (Mult a b)) @(FS (Mult a c)) $+              FinSet $+                concat @a @(Plus b c) $+                  P.fmap+                    ( \i ->+                        P.fmap (\j -> weakenLeft (Proxy @(Mult a c)) (mult @a @b i j)) (universe @b)+                          ++ P.fmap (\j -> weakenRight (Proxy @(Mult a b)) (mult @a @c i j)) (universe @c)+                    )+                    (universe @a)+  distR @(FS a) @(FS b) @(FS c) =+    withObCoprod @_ @(FS a) @(FS b) $+      withObProd @_ @(FS (Plus a b)) @(FS c) $+        withObProd @_ @(FS a) @(FS c) $+          withObProd @_ @(FS b) @(FS c) $+            withObCoprod @_ @(FS (Mult a c)) @(FS (Mult b c)) $+              FinSet $+                concat @(Plus a b) @c $+                  P.fmap (\i -> P.fmap (\j -> weakenLeft (Proxy @(Mult b c)) (mult @a @c i j)) (universe @c)) (universe @a)+                    ++ P.fmap (\i -> P.fmap (\j -> weakenRight (Proxy @(Mult a c)) (mult @b @c i j)) (universe @c)) (universe @b)+  absorbL @(FS a) = withObProd @_ @(FS a) @(FS Z) $ FinSet (concat @a @Z (repeat VNil))+  absorbR = FinSet VNil++-- | >>> import Data.Type.Nat+-- >>> import Data.Fin+-- >>> mult @Nat5 @Nat4 fin4 fin2 -- 4*4+2+-- 18+-- >>> mult @Nat4 @Nat5 fin2 fin4 -- 5*2+4+-- 14+mult :: forall n m. (SNatI n, SNatI m) => Fin n -> Fin m -> Fin (Mult n m)+mult n m = case snat @n of+  SZ -> case n of {}+  SS @n' -> case n of+    FZ -> weakenLeft (Proxy @(Mult n' m)) m+    FS n' -> weakenRight (Proxy @m) (mult n' m)++unmult :: forall n m. (SNatI n, SNatI m) => Fin (Mult n m) -> (Fin n, Fin m)+unmult f = case snat @n of+  SZ -> case f of {}+  SS @n' -> case split @m @(Mult n' m) f of+    P.Left m -> (FZ, m)+    P.Right f' -> let (n, m) = unmult @n' @m f' in (FS n, m)++instance MonoidalProfunctor FinSet where+  one = id+  (**) = (***)++instance Monoidal FINSET where+  type a ** b = a && b+  type Unit = FS Nat1+  withOb2 @a @b = withObProd @_ @a @b+  leftUnitor = leftUnitorProd+  leftUnitorInv = leftUnitorProdInv+  rightUnitor = rightUnitorProd+  rightUnitorInv = rightUnitorProdInv+  associator @a @b @c = associatorProd @a @b @c+  associatorInv @a @b @c = associatorProdInv @a @b @c++instance SymMonoidal FINSET where+  swap @a @b = swapProd @a @b++type family Exp (a :: Nat) (b :: Nat) :: Nat where+  Exp a Z = S Z+  Exp a (S n) = Mult a (Exp a n)++instance Closed FINSET where+  type FS a ~~> FS b = FS (Exp b a)+  withObExp @(FS a) @b r = case snat @a of+    SZ -> r+    SS @a' -> withObExp @_ @(FS a') @b $ withObProd @_ @b @(FS (Exp (UN FS b) a')) r+  curry @(FS a) @(FS b) (FinSet @_ @c f) = withObExp @_ @(FS b) @(FS c) $ FinSet (P.fmap exp (chunks @a @b f))+  apply @(FS a) @(FS b) =+    withObExp @_ @(FS a) @(FS b) $+      withObProd @_ @(FS (Exp b a)) @(FS a) $+        FinSet (concatMap @_ @a @_ @(Exp b a) unExp universe)++-- | >>> import Data.Type.Nat+-- >>> import Data.Fin+-- >>> exp @_ @Nat2 (fin1 ::: fin0 ::: fin1 ::: fin1 ::: VNil)+-- 11+exp :: forall n m. (SNatI n, SNatI m) => Vec n (Fin m) -> Fin (Exp m n)+exp VNil = FZ+exp (x ::: xs) = case snat @n of+  SS @n' -> withObExp @_ @(FS n') @(FS m) $ mult x (exp @n' @m xs)++-- | >>> import Data.Type.Nat+-- >>> import Data.Fin+-- >>> unExp @Nat3 @Nat2 fin6+-- 1 ::: 1 ::: 0 ::: VNil+unExp :: forall n m. (SNatI n, SNatI m) => Fin (Exp m n) -> Vec n (Fin m)+unExp f = case snat @n of+  SZ -> VNil+  SS @n' -> withObExp @_ @(FS n') @(FS m) $ let (x, xs) = unmult @m @(Exp m n') f in x ::: unExp @n' @m xs++-- | >>> import Data.Type.Nat+-- >>> comult @(FS Nat4)+-- FinSet {unFinSet = 0 ::: 5 ::: 10 ::: 15 ::: VNil}+instance (SNatI a) => Comonoid (FS a) where+  counit = terminate+  comult = diag++instance (SNatI a) => CocommutativeComonoid (FS a)++instance CopyDiscard FINSET++instance Monoid (FS Nat1) where+  mempty = terminate+  mappend = terminate++-- | Finds an isomorphism between 'FS n' and itself that's consistent with the given (source, target)+-- pairs, if one exists.+findIso :: forall n. (SNatI n) => [(Fin n, Fin n)] -> P.Maybe (Iso' (FS n) (FS n))+findIso ps = mkIso P.<$> findBijection ps+  where+    mkIso :: Vec n (Fin n) -> Iso' (FS n) (FS n)+    mkIso fwd = iso (FinSet fwd) (FinSet (tabulate (\j -> findIndex (P.== j) fwd)))++-- | Extends the given (source, target) pairs to a full bijection on @Fin n@, if they're consistent+-- with being a partial injection (checked in both directions as they're added, so two different+-- sources claiming the same target is rejected just as readily as one source getting conflicting+-- targets). Unconstrained sources are matched up with whatever targets are left over, in order.+findBijection :: forall n. (SNatI n) => [(Fin n, Fin n)] -> P.Maybe (Vec n (Fin n))+findBijection ps = do+  (fwd, bwd) <- go (repeat P.Nothing) (repeat P.Nothing) ps+  let freeSrcs = P.filter (\i -> isNothing (fwd ! i)) (toList universe)+      freeTgts = P.filter (\j -> isNothing (bwd ! j)) (toList universe)+      completion = P.zip freeSrcs freeTgts+  P.pure (tabulate (\i -> fromMaybe (fromJust (List.lookup i completion)) (fwd ! i)))+  where+    go+      :: Vec n (P.Maybe (Fin n))+      -> Vec n (P.Maybe (Fin n))+      -> [(Fin n, Fin n)]+      -> P.Maybe (Vec n (P.Maybe (Fin n)), Vec n (P.Maybe (Fin n)))+    go fwd bwd [] = P.Just (fwd, bwd)+    go fwd bwd ((s, t) : rest) = case (fwd ! s, bwd ! t) of+      (P.Just t', _) | t' P./= t -> P.Nothing+      (_, P.Just s') | s' P./= s -> P.Nothing+      _ ->+        go+          (tabulate (\i -> if i P.== s then P.Just t else fwd ! i))+          (tabulate (\j -> if j P.== t then P.Just s else bwd ! j))+          rest++-- | >>> import Data.Fin+-- >>> import Data.Type.Nat+-- >>> import Data.Vec.Lazy+-- >>> let f :: FinSet (FS Nat4) (FS Nat3) = FinSet $ fin0 ::: fin1 ::: fin1 ::: fin0 ::: VNil+-- >>> let g :: FinSet (FS Nat4) (FS Nat3) = FinSet $ fin2 ::: fin0 ::: fin1 ::: fin0 ::: VNil+-- >>> let h :: FinSet (FS Nat3) (FS Nat4) = FinSet $ fin3 ::: fin2 ::: fin3 ::: VNil+-- >>> (equalize f g \incl -> let p = factorEqualizer incl h in P.show (incl, p, incl . p)) :: P.String+-- "(FinSet {unFinSet = 2 ::: 3 ::: VNil},FinSet {unFinSet = 1 ::: 0 ::: 1 ::: VNil},FinSet {unFinSet = 3 ::: 2 ::: 3 ::: VNil})"+instance HasEqualizers FINSET where+  equalize (FinSet f) (FinSet g) k =+    let groups = [x | x <- toList universe, f ! x P.== g ! x]+    in reifyList groups \vec -> k (FinSet vec)+  factorEqualizer (FinSet incl) (FinSet h) = FinSet (tabulate (\c -> findIndex (P.== (h ! c)) incl))++-- Example 3.84 of Seven Sketches (A: 0=red, 1=blue, 2=black)++-- | >>> import Data.Fin+-- >>> import Data.Type.Nat+-- >>> import Data.Vec.Lazy+-- >>> let f :: FinSet (FS Nat6) (FS Nat3) = FinSet $ fin0 ::: fin1 ::: fin0 ::: fin0 ::: fin2 ::: fin1 ::: VNil+-- >>> let g :: FinSet (FS Nat4) (FS Nat3) = FinSet $ fin2 ::: fin0 ::: fin1 ::: fin0 ::: VNil+-- >>> (pullback f g \(FinSet l) (FinSet r) -> P.show (l, r)) :: P.String+-- "(0 ::: 0 ::: 1 ::: 2 ::: 2 ::: 3 ::: 3 ::: 4 ::: 5 ::: VNil,1 ::: 3 ::: 2 ::: 1 ::: 3 ::: 1 ::: 3 ::: 0 ::: 2 ::: VNil)"+instance HasPullbacks FINSET where+  pullback (FinSet f) (FinSet g) k =+    let+      gByValue = IM.fromListWith (P.flip (P.++)) [(P.fromEnum (g ! y), [y]) | y <- toList universe]+      groups = [(x, y) | x <- toList universe, y <- fromMaybe [] (IM.lookup (P.fromEnum (f ! x)) gByValue)]+    in+      reifyList groups \vec -> k (FinSet $ P.fmap fst vec) (FinSet $ P.fmap snd vec)++instance HasCoequalizers FINSET where+  coequalize (FinSet @_ @a f) (FinSet g) k =+    let+      find m i = P.maybe i (find m) $ IM.lookup (P.fromEnum i) m+      union m (i, j) = let ri = find m i; rj = find m j in if ri P.== rj then m else IM.insert (P.fromEnum ri) rj m+      unionFind = P.foldl union IM.empty (zipWith (,) f g)+      step m x = IM.insertWith (P.++) (P.fromEnum $ find unionFind x) [x] m+      groups = IM.elems $ P.foldl step IM.empty (universe @a)+    in+      reifyList groups \vec -> k (FinSet (tabulate (\a -> findIndex (P.elem a) vec)))+  factorCoequalizer (FinSet q) (FinSet h) =+    let reps = IM.fromListWith (\_ old -> old) [(P.fromEnum (q ! b), b) | b <- toList universe]+    in FinSet (tabulate (\i -> h ! (reps IM.! P.fromEnum i)))++-- Exercise 6.22 of Seven Sketches++-- | >>> import Data.Fin+-- >>> import Data.Type.Nat+-- >>> let l :: FinSet (FS Nat4) (FS Nat3) = FinSet $ fin0 ::: fin0 ::: fin1 ::: fin2 ::: VNil+-- >>> let r :: FinSet (FS Nat4) (FS Nat5) = FinSet $ fin0 ::: fin2 ::: fin4 ::: fin4 ::: VNil+-- >>> (pushout l r \(FinSet l') (FinSet r') -> P.show (l', r')) :: P.String+-- "(1 ::: 3 ::: 3 ::: VNil,1 ::: 0 ::: 1 ::: 2 ::: 3 ::: VNil)"+instance HasPushouts FINSET++findIndex :: (a -> P.Bool) -> Vec n a -> Fin n+findIndex _ VNil = P.error "unexpected missing element"+findIndex f (a ::: as)+  | f a = FZ+  | P.otherwise = FS $ findIndex f as++-- | >>> import Proarrow.Colimit.Pushout (isEpi)+-- >>> import Data.Fin+-- >>> import Data.Type.Nat+-- >>> let f :: FinSet (FS Nat3) (FS Nat3) = FinSet $ fin2 ::: fin0 ::: fin1 ::: VNil+-- >>> (pushout f f \(FinSet g1) (FinSet g2) -> P.show (g1, g2)) :: P.String+-- "(0 ::: 1 ::: 2 ::: VNil,0 ::: 1 ::: 2 ::: VNil)"+-- >>> isEpi f+-- True+-- >>> import Proarrow.Limit.Pullback (isMono)+-- >>> (pullback f f \(FinSet l) (FinSet r) -> P.show (l, r)) :: P.String+-- "(0 ::: 1 ::: 2 ::: VNil,0 ::: 1 ::: 2 ::: VNil)"+-- >>> isMono f+-- True+-- >>> import Proarrow.Category.Topos (classifyImage, classifyKernelPair, and, or, implies, false)+-- >>> (classifyImage f, classifyKernelPair f)+-- (FinSet {unFinSet = 1 ::: 1 ::: 1 ::: VNil},FinSet {unFinSet = 1 ::: 0 ::: 0 ::: 0 ::: 1 ::: 0 ::: 0 ::: 0 ::: 1 ::: VNil})+-- >>> [and, or, implies] :: [FinSet (FS Nat4) (FS Nat2)]+-- [FinSet {unFinSet = 0 ::: 0 ::: 0 ::: 1 ::: VNil},FinSet {unFinSet = 0 ::: 1 ::: 1 ::: 1 ::: VNil},FinSet {unFinSet = 1 ::: 1 ::: 0 ::: 1 ::: VNil}]+-- >>> false :: FinSet (FS Nat1) (FS Nat2)+-- FinSet {unFinSet = 0 ::: VNil}+instance HasSubobjectClassifier FINSET where+  type Omega = FS Nat2+  true = FinSet $ fin1 ::: VNil+  classifyGraph (FinSet @n @m f) = withObProd @_ @(FS n) @(FS m) $ FinSet $ tabulate+    \(unmult @n @m -> (n, m)) -> if f ! n P.== m then fin1 else fin0++instance HasEpiMonoFactorization FINSET where+  factorize (FinSet f) = reifyList (nubOrd (toList f)) \vec ->+    let revMap = IM.fromList (toList (zipWith (\k v -> (P.fromEnum k, v)) vec universe))+    in FinSet (tabulate (\a -> revMap IM.! P.fromEnum (f ! a)))+         :.: FinSet vec++instance ElementaryTopos FINSET
+ src/Proarrow/Category/Instance/Free.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE LinearTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The category __freely generated__ by a quiver @p@ of generator arrows, extended with a chosen+-- list @cs@ of structural classes (terminal object, products, closed structure, ...): an arrow of+-- @'FREE' cs p@ is a formal composite of generators ('Emb') and structure morphisms ('St'). 'fold'+-- interprets such an arrow in any category supporting the same structures, making this the basis+-- for deeply embedded categorical DSLs.+--+-- For a quiver with no structures, "Proarrow.Category.Instance.Paths" fits better: its objects are+-- the vertices themselves, which keep the base kind's 'Ob' and can be taken apart.+--+-- __No equations__: only the category laws hold structurally (composition is a normalized spine).+-- For example @'Proarrow.Limit.BinaryProduct.fst' . (f 'Proarrow.Limit.BinaryProduct.&&&' g)@ and+-- @f@ are different 'Free' values. Two arrows are equal when every 'fold' identifies them, so+-- decide equality by interpreting into a concrete category, not by pattern matching.+--+-- An object is a /shape/ ('IsFreeOb'), asking nothing of @k@ beyond being a category. Its+-- denotation along a functor @f@ out of @k@ is @'Lower' f a@, and 'withLowerOb' recovers that+-- denotation's 'Ob' in 'fold'.+--+-- Classes imposing type equalities (like 'Proarrow.Category.Monoidal.Cartesian.Cartesian'\'s+-- @tensor = product@) cannot be listed in @cs@, since each carrier is fixed (@**@ is always the+-- formal tensor). A kind wrapper can recover the instance:+-- @'Proarrow.Limit.BinaryProduct.PROD' ('FREE' '[HasTerminalObject, HasBinaryProducts] p)@ /is/ a+-- free cartesian category.+module Proarrow.Category.Instance.Free where++import Data.Kind (Constraint)+import Prelude (Show (..))+import Prelude qualified as P++import Proarrow.Category.Enriched.Thin (Discrete (..))+import Proarrow.Core+  ( CAT+  , CategoryOf (..)+  , Hom+  , Kind+  , Profunctor (..)+  , Promonad (..)+  , Show2+  , dimapDefault+  , (//)+  , type (+->)+  )+import Proarrow.Functor (FunctorForRep (..))+import Proarrow.Profunctor.Instance.Identity (Id)+import Proarrow.Profunctor.Instance.Initial (InitialProfunctor)+import Proarrow.Profunctor.Representable (Rep, Representable (..), withObRep)++type family All (cs :: [Kind -> Constraint]) (k :: Kind) :: Constraint where+  All '[] k = ()+  All (c ': cs) k = (c k, All cs k)++-- | Membership of a structure in the list, with the entailment @'All' cs k => c k@ as a method+-- rather than a quantified superclass: as a given, the quantified form would shadow the ordinary+-- instances for the free category itself and demand @All cs (FREE cs p)@.+type Elem :: (Kind -> Constraint) -> [Kind -> Constraint] -> Constraint+class c `Elem` cs where+  fromAll :: forall k r. (All cs k) => ((c k) => r) -> r++instance {-# OVERLAPPABLE #-} (c `Elem` cs) => c `Elem` (d ': cs) where+  fromAll @k r = fromAll @c @cs @k r+instance c `Elem` (c ': cs) where+  fromAll r = r++-- | Membership of several structures at once: @'[Monoidal, SymMonoidal] \`Elems\` cs@.+type Elems :: [Kind -> Constraint] -> [Kind -> Constraint] -> Constraint+type family ds `Elems` cs where+  '[] `Elems` cs = ()+  (d ': ds) `Elems` cs = (d `Elem` cs, ds `Elems` cs)++-- | The objects of the free category over the quiver @p@ on @k@: the embedded objects of @k@+-- ('EMB') plus one object former per structure in @cs@ (products, exponentials, ...), which live+-- in their structures' modules.+type data FREE (cs :: [Kind -> Constraint]) (p :: CAT k) = EMB k++-- | Arrows of the free category: a right-associated composition spine ending in 'Nil', with a+-- generator ('Emb') or structure morphism ('St') precomposed onto the rest at each step, so+-- the category laws hold definitionally. The fields are linear (@%1@) so that DSL+-- helpers built on 'Free' can offer HOAS-style binders whose bound variable must be used exactly+-- once.+type Free :: CAT (FREE cs p)+data Free a b where+  Nil :: (Ob a) => Free a a+  Emb :: (Ob a, Ob b) => p a b %1 -> Free (i :: FREE cs p) (EMB a) %1 -> Free i (EMB b)+  St+    :: forall {k} {cs} {p :: CAT k} (c :: Kind -> Constraint) (a :: FREE cs p) b i+     . (HasStructure cs p c, Ob a, Ob b)+    => Struct c a b %1 -> Free i a %1 -> Free i b++emb :: (Ob a, Ob b) => p a b %1 -> Free (EMB a :: FREE cs p) (EMB b)+emb p = Emb p Nil++class (Show2 p) => WithShow (a :: FREE c (p :: CAT j))+instance (Show2 p) => WithShow (a :: FREE c (p :: CAT j))++instance (WithShow a) => Show (Free a b) where+  showsPrec _ Nil = P.showString "id"+  showsPrec d (Emb p g) = showPostComp d p g+  showsPrec d (St s g) = showPostComp d s g++showPostComp :: (Show p, WithShow a) => P.Int -> p -> Free a b -> P.ShowS+showPostComp d p Nil = P.showsPrec d p+showPostComp d p g = P.showParen (d P.> 9) (P.showsPrec 10 p . P.showString " . " . P.showsPrec 10 g)++-- | The shape of an object of the free category, by object former. This is 'Ob' for the free+-- category. It carries the shape's denotation 'Lower' along any functor out of @k@, and how to+-- recover that denotation's 'Ob' from the leaves' ('lowerOb', normally used through+-- 'withLowerOb' and 'withLowerIdOb').+type IsFreeOb :: forall {k} {cs :: [Kind -> Constraint]} {p :: CAT k}. FREE cs p -> Constraint+class IsFreeOb (a :: FREE cs (p :: CAT k)) where+  -- | The denotation of the object along a functor @f@ out of @k@. (The class variable is+  -- re-annotated here so that @k@ is in scope before @f@'s kind mentions it.)+  type Lower (f :: k +-> k') (a :: FREE cs p) :: k'++  lowerOb :: forall k' (f :: k +-> k') r. (Representable f, All cs k') => ((Ob (Lower f a)) => r) -> r++instance (Ob a) => IsFreeOb (EMB a) where+  type Lower f (EMB a) = f % a+  lowerOb @_ @f = withObRep @f @a++-- | @'Ob' ('Lower' f a)@ from the shape of @a@, for interpreting along @f@.+withLowerOb+  :: forall {k} {k'} {cs} {p :: CAT k} (f :: k +-> k') a r+   . (IsFreeOb (a :: FREE cs p), Representable f, All cs k')+  => ((Ob (Lower f a)) => r) -> r+withLowerOb = lowerOb @a @k' @f++-- | 'withLowerOb' along the identity: the 'Ob' of a shape's denotation in @k@ itself, when @k@+-- happens to carry the structures @cs@.+withLowerIdOb+  :: forall {k} {cs} {p :: CAT k} a r+   . (IsFreeOb (a :: FREE cs p), CategoryOf k, All cs k)+  => ((Ob (Lower (Id :: CAT k) a)) => r) -> r+withLowerIdOb = withLowerOb @(Id :: CAT k) @a++class ((Show2 p) => Show2 str) => CanShow (str :: CAT (FREE cs p))+instance ((Show2 p) => Show2 str) => CanShow (str :: CAT (FREE cs p))++class+  (CanShow (Struct c :: CAT (FREE cs p)), c `Elem` cs) =>+  HasStructure cs (p :: CAT k) (c :: Kind -> Constraint)+  where+  data Struct c :: CAT (FREE cs p)+  foldStructure+    :: forall {k'} (f :: k +-> k') (a :: FREE cs p) (b :: FREE cs p)+     . (c k', All cs k', Representable f)+    => (forall (x :: FREE cs p) y. x ~> y -> Lower f x ~> Lower f y)+    -> Struct c a b+    -> Lower f a ~> Lower f b++-- | Interpret a free arrow along a functor @f@ into any category @k'@ supporting the structures+-- @cs@, given an interpretation of the generators between the images of their objects. This is+-- the universal property of the free category. The interpreter is handed @('Ob' x, 'Ob' y)@ explicitly+-- (the evidence bundled on 'Emb'), because a bare quiver @p@ is not a 'Profunctor', so the 'Ob's+-- cannot be recovered from the value.+fold+  :: forall {k} {k'} {p :: CAT k} (cs :: [Kind -> Constraint]) (f :: k +-> k') (a :: FREE cs p) (b :: FREE cs p)+   . (All cs k', Representable f)+  => (forall x y. (Ob x, Ob y) => p x y -> (f % x) ~> (f % y))+  -> a ~> b+  -> Lower f a ~> Lower f b+fold pn = go+  where+    go :: forall (x :: FREE cs p) y. x ~> y -> Lower f x ~> Lower f y+    go Nil = withLowerOb @f @x id+    go (Emb p g) = pn p . go g+    go (St @c s g) = fromAll @c @cs @k' (foldStructure @_ @_ @_ @_ @f go s) . go g++retract+  :: forall {k} {k'} cs (f :: k +-> k') a b+   . (All cs k', Representable f) => (a :: FREE cs (InitialProfunctor :: CAT k)) ~> b -> Lower f a ~> Lower f b+retract = fold @cs @f (\case {})++-- | Taking the quiver to be the /hom of a category/ @k@ makes @'FREE' cs ('Proarrow.Core.Hom' k)@+-- the free @cs@-structured category over @k@: 'liftFree' embeds the arrows of @k@ as generators,+-- and when @k@ itself already has the structures, 'retractFree' interprets back into @k@ along the+-- identity. These back the free-kind instances of+-- 'Proarrow.Profunctor.Free.HasFreeK' (e.g. the free category with a terminal object, or with+-- binary products, over @k@).+liftFree :: forall {k} cs (x :: k) y. (CategoryOf k) => (x ~> y) -> (EMB x :: FREE cs (Hom k)) ~> EMB y+liftFree f = emb f \\ f++retractFree+  :: forall cs {k} (a :: FREE cs (Hom k)) b+   . (CategoryOf k, All cs k)+  => a ~> b+  -> Lower (Id :: CAT k) a ~> Lower (Id :: CAT k) b+retractFree = fold @cs @(Id :: CAT k) (\g -> g)++-- | The object-embedding functor @a |-> 'EMB' a@ of a widening (see 'widen'), as a representable+-- profunctor. The base kind must be 'Discrete', since arrows of @k@ other than identities have no+-- counterpart in the free category.+data family Embed :: k +-> FREE ds (p :: CAT k)++instance (Discrete k) => FunctorForRep (Embed :: k +-> FREE ds (p :: CAT k)) where+  type Embed @ a = EMB a+  fmap (f :: x ~> y) = f // withEq f (Nil :: Free (EMB x :: FREE ds p) (EMB x))++-- | Widen a free arrow into a free category over a larger structure list: 'fold' along 'Embed',+-- so each structural object is rebuilt as itself in the larger category (e.g. the terminal object+-- lowers to the target's terminal object) and generators embed as generators. The+-- @'All' cs ('FREE' ds p)@ constraint is the evidence that every structure in @cs@ is+-- also available in @ds@.+widen+  :: forall ds {k} {cs} {p :: CAT k} (a :: FREE cs p) b+   . (All cs (FREE ds p), Discrete k)+  => a ~> b+  -> Lower (Rep (Embed :: k +-> FREE ds p)) a ~> Lower (Rep (Embed :: k +-> FREE ds p)) b+widen = fold @cs @(Rep (Embed :: k +-> FREE ds p)) (\g -> emb g)++-- | The category freely generated from the heteromorphisms of @p@, together with formal+-- structure arrows for each of the classes in @cs@. An object is a shape ('IsFreeOb').+instance CategoryOf (FREE cs p) where+  type (~>) = Free+  type Ob a = IsFreeOb a++instance Promonad (Free :: CAT (FREE cs p)) where+  id = Nil+  Nil . g = g+  f . Nil = f+  Emb p f . g = Emb p (f . g)+  St s f . g = St s (f . g)++instance Profunctor (Free :: CAT (FREE cs p)) where+  dimap = dimapDefault+  r \\ Nil = r+  r \\ Emb _ f = r \\ f+  r \\ St _ f = r \\ f
+ src/Proarrow/Category/Instance/Graph.hs view
@@ -0,0 +1,76 @@+-- | The __graph__ of a thin profunctor @p@: objects are pairs @'GR' aj ak@ for which @p@ has an+-- element (@HasArrow p aj ak@), and an arrow is a pair of arrows between the components. It forms a+-- commuting square, automatically by thinness. Specializing @p@ gives the arrow category ('ARROW'),+-- the category of elements ('ELEMENTS') and comma categories ('COMMA').+module Proarrow.Category.Instance.Graph where++import Prelude (type (~))++import Proarrow.Category.Enriched.Thin (CodiscreteProfunctor, ThinProfunctor (..))+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault, lmap, type (+->))+import Proarrow.Functor (FunctorForRep (..))+import Proarrow.Optic (iso)+import Proarrow.Optic.Iso (Iso')+import Proarrow.Profunctor.Corepresentable (Corep (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Direp (Direp)+import Proarrow.Profunctor.Instance.Identity (Id)+import Proarrow.Profunctor.Representable (Rep (..))++type data GRAPH (p :: k +-> j) = GR j k++data family ProjJ :: forall (p :: k +-> j) -> GRAPH p +-> j+instance (ThinProfunctor p) => FunctorForRep (ProjJ p) where+  type (ProjJ p) @ GR x y = x+  fmap (Graph l _) = l++data family ProjK :: forall (p :: k +-> j) -> GRAPH p +-> k+instance (ThinProfunctor p) => FunctorForRep (ProjK p) where+  type (ProjK p) @ GR x y = y+  fmap (Graph _ r) = r++data Graph a b where+  Graph+    :: forall {p} aj ak bj bk+     . (HasArrow p aj ak, HasArrow p bj bk) => aj ~> bj -> ak ~> bk -> Graph (GR aj ak :: GRAPH p) (GR bj bk :: GRAPH p)+instance (ThinProfunctor p) => Profunctor (Graph :: CAT (GRAPH p)) where+  dimap = dimapDefault+  r \\ Graph f g = r \\ f \\ g+instance (ThinProfunctor p) => Promonad (Graph :: CAT (GRAPH p)) where+  id = Graph id id+  Graph f1 g1 . Graph f2 g2 = Graph (f1 . f2) (g1 . g2)++-- | The graph of a thin profunctor. Doing this for any profunctor would need dependent types.+instance (ThinProfunctor p) => CategoryOf (GRAPH p) where+  type (~>) = Graph+  type+    Ob @(GRAPH p) ab =+      (ab ~ GR (ProjJ p @ ab) (ProjK p @ ab), Ob (ProjJ p @ ab), Ob (ProjK p @ ab), HasArrow p (ProjJ p @ ab) (ProjK p @ ab))++-- | A morphism gives two equal ways to compute the "diagonal", which is an element of the profunctor.+diagonalElement+  :: forall {j} {k} (p :: k +-> j) (aj :: j) (ak :: k) (bj :: j) (bk :: k) r+   . (ThinProfunctor p) => GR aj ak ~> (GR bj bk :: GRAPH p) -> ((HasArrow p aj bk, Ob aj, Ob bk) => r) -> r+diagonalElement (Graph f g) = withArr @p @aj @bk (lmap f (arr @p @bj @bk) \\ f \\ g)++graphUniv :: forall {j} {k} (p :: k +-> j). (ThinProfunctor p) => Iso' p (Rep (ProjJ p) :.: Corep (ProjK p))+graphUniv =+  iso+    (Prof \ @a @b p -> withArr p (Rep @(GR a b) id :.: Corep id))+    (Prof \(Rep l :.: Corep r) -> dimap l r arr)++data family ProdAsGraph :: (j, k) +-> GRAPH (p :: k +-> j)+instance (CategoryOf j, CategoryOf k, CodiscreteProfunctor p) => FunctorForRep (ProdAsGraph :: (j, k) +-> GRAPH (p :: k +-> j)) where+  type ProdAsGraph @ '(a, b) = GR a b+  fmap (l :**: r) = Graph l r \\ l \\ r++-- | The arrow category is the graph of the hom-functor. Here we require the category to be thin.+type ARROW k = GRAPH (Id :: CAT k)++-- | The category of elements of a functor.+type ELEMENTS f = GRAPH (Rep f)++-- | The comma category f/g is the graph of @C(f(-), g(=))@.+type f `COMMA` g = GRAPH (Direp f g)
+ src/Proarrow/Category/Instance/Hask.hs view
@@ -0,0 +1,10 @@+-- | The category of Haskell types and functions: the 'Proarrow.Core.CategoryOf' structure on the kind 'Type',+-- with @(->)@ as the morphisms and every type an object. The instances themselves live next to+-- the classes they instantiate; this module just names the category.+module Proarrow.Category.Instance.Hask (Type, Hask) where++import Data.Kind (Type)++type Hask = (->)++-- Class instances of (->) are with the class definitions in order to avoid orphan instances
+ src/Proarrow/Category/Instance/IntConstruction.hs view
@@ -0,0 +1,134 @@+-- | The __Int construction__ (Joyal-Street-Verity) on a traced monoidal category @k@: objects are+-- formal differences @'I' plus minus@ of @k@-objects, and morphisms are @k@-morphisms between the+-- appropriately tensored halves, composed by tracing out the middle. The result is compact closed+-- (the free such over @k@) with duals given by swapping the two halves.+module Proarrow.Category.Instance.IntConstruction where++import Prelude (($), type (~))++import Proarrow.Category.Monoidal+  ( Monoidal (..)+  , MonoidalProfunctor (..)+  , SymMonoidal (..)+  , obj2+  , swap+  , swapFst+  , swapInner+  , swapOuter+  , (**)+  )+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..))+import Proarrow.Category.Monoidal.StarAutonomous (ExpSA, StarAutonomous (..), applySA, currySA, expSA)+import Proarrow.Category.Monoidal.Strength (TracedMonoidal, trace)+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault, obj)++data INT k = I k k++type family IntPlus (i :: INT k) :: k where+  IntPlus (I a b) = a+type family IntMinus (i :: INT k) :: k where+  IntMinus (I a b) = b++type IntConstruction :: CAT (INT k)+data IntConstruction a b where+  Int :: (Ob ap, Ob am, Ob bp, Ob bm) => ap ** bm ~> am ** bp -> IntConstruction (I ap am) (I bp bm)++toInt :: forall {k} (a :: k) b m. (TracedMonoidal k, Ob m) => (a ~> b) -> I a m ~> I b m+toInt f = Int (swap @k @b @m . (f ** obj @m)) \\ f++isoToInt :: forall {k} (a :: k) b. (TracedMonoidal k) => (a ~> b) -> (b ~> a) -> I a a ~> I b b+isoToInt f g = Int (swap @k @b @a . (f ** g)) \\ f \\ g++fromInt :: forall {k} (a :: k) b m. (TracedMonoidal k) => (I a m ~> I b m) -> a ~> b+fromInt (Int f) = trace @(~>) @m @a @b (swap @k @m @b . f)++instance (TracedMonoidal k) => Profunctor (IntConstruction :: CAT (INT k)) where+  dimap = dimapDefault+  r \\ Int{} = r+instance (TracedMonoidal k) => Promonad (IntConstruction :: CAT (INT k)) where+  id @a = Int (swap @k @(IntPlus a) @(IntMinus a))+  Int @bp @bm @cp @cm f . Int @ap @am g =+    Int+      ( trace @_ @(bp ** bm) @(ap ** cm) @(am ** cp)+          (swapOuter @bm @cp @bp @am . (f ** (swap @k @am @bp . g)) . swapFst @ap @cm @bp @bm)+      )+      \\ obj2 @ap @cm+      \\ obj2 @am @cp+      \\ obj2 @bp @bm++-- | The Int construction, a.k.a. the geometry of interaction,+-- the free compact closed category on a traced monoidal category.+instance (TracedMonoidal k) => CategoryOf (INT k) where+  type (~>) = IntConstruction+  type Ob a = (a ~ I (IntPlus a) (IntMinus a), Ob (IntPlus a), Ob (IntMinus a))++instance (TracedMonoidal k) => MonoidalProfunctor (IntConstruction :: CAT (INT k)) where+  one = Int (swap @k @Unit @Unit)+  Int @ap @am @bp @bm f ** Int @cp @cm @dp @dm g =+    Int (swapInner @am @bp @cm @dp . (f ** g) . swapInner @ap @cp @bm @dm)+      \\ obj2 @(I ap am) @(I cp cm)+      \\ obj2 @(I bp bm) @(I dp dm)++-- | The monoidal tensor is pointwise, tensoring of the plus and minus parts.+instance (TracedMonoidal k) => Monoidal (INT k) where+  type Unit = I Unit Unit+  type a ** b = I (IntPlus a ** IntPlus b) (IntMinus a ** IntMinus b)+  withOb2 @a @b r = withOb2 @k @(IntPlus a) @(IntPlus b) (withOb2 @k @(IntMinus a) @(IntMinus b) r)+  leftUnitor @(I ap am) =+    Int ((leftUnitorInv @k @am ** obj @ap) . swap @k @ap @am . (leftUnitor @k @ap ** obj @am))+      \\ obj2 @Unit @ap+      \\ obj2 @Unit @am+  leftUnitorInv @(I ap am) =+    Int ((obj @am ** leftUnitorInv @k @ap) . swap @k @ap @am . (obj @ap ** leftUnitor @k @am))+      \\ obj2 @Unit @ap+      \\ obj2 @Unit @am+  rightUnitor @(I ap am) =+    Int ((rightUnitorInv @k @am ** obj @ap) . swap @k @ap @am . (rightUnitor @k @ap ** obj @am))+      \\ obj2 @ap @Unit+      \\ obj2 @am @Unit+  rightUnitorInv @(I ap am) =+    Int ((obj @am ** rightUnitorInv @k @ap) . swap @k @ap @am . (obj @ap ** rightUnitor @k @am))+      \\ obj2 @ap @Unit+      \\ obj2 @am @Unit+  associator @(I ap am) @(I bp bm) @(I cp cm) =+    Int (swap @k @(ap ** (bp ** cp)) @((am ** bm) ** cm) . (associator @k @ap @bp @cp ** associatorInv @k @am @bm @cm))+      \\ obj2 @(I ap am) @(I bp bm) ** obj @(I cp cm)+      \\ obj @(I ap am) ** obj2 @(I bp bm) @(I cp cm)+  associatorInv @(I ap am) @(I bp bm) @(I cp cm) =+    Int (swap @k @((ap ** bp) ** cp) @(am ** (bm ** cm)) . (associatorInv @k @ap @bp @cp ** associator @k @am @bm @cm))+      \\ obj2 @(I ap am) @(I bp bm) ** obj @(I cp cm)+      \\ obj @(I ap am) ** obj2 @(I bp bm) @(I cp cm)++instance (TracedMonoidal k) => SymMonoidal (INT k) where+  swap @(I ap am) @(I bp bm) =+    withOb2 @k @ap @bp $+      withOb2 @k @am @bm $+        withOb2 @k @bp @ap $+          withOb2 @k @bm @am $+            Int ((swap @k @bm @am ** swap @k @ap @bp) . swap @k @(ap ** bp) @(bm ** am))++instance (TracedMonoidal k) => Closed (INT k) where+  type a ~~> b = ExpSA a b+  withObExp @a @b r = withOb2 @k @(IntMinus a) @(IntPlus b) (withOb2 @k @(IntPlus a) @(IntMinus b) r)+  curry @a @b @c = currySA @a @b @c+  apply @b @c = applySA @b @c+  (^^^) = expSA++instance (TracedMonoidal k) => StarAutonomous (INT k) where+  type Dual (I p n) = I n p+  withObDual r = r+  dual (Int @ap @am @bp @bm f) = Int (swap @k @am @bp . f . swap @k @bm @ap)+  dualInv (Int @ap @am @bp @bm f) = Int (swap @k @am @bp . f . swap @k @bm @ap)+  linDist @(I ap am) @(I bp bm) @(I cp cm) (Int f) = Int (associator @k @am @bm @cm . f . associatorInv @k @ap @bp @cp) \\ obj2 @(I bp bm) @(I cp cm)+  linDistInv @(I ap am) @(I bp bm) @(I cp cm) (Int f) = Int (associatorInv @k @am @bm @cm . f . associator @k @ap @bp @cp) \\ obj2 @(I ap am) @(I bp bm)+  doubleNeg = id+  doubleNegInv = id++instance (TracedMonoidal k) => CompactClosed (INT k) where+  distribDual @(I ap am) @(I bp bm) = Int (swap @k @(am ** bm) @(ap ** bp)) \\ obj2 @(I ap am) @(I bp bm)+  dualUnit = id+  dualityUnit @(I p n) =+    withOb2 @k @p @n $ withOb2 @k @n @p $ Int (leftUnitorInv @k @(p ** n) . swap @k @n @p . leftUnitor @k @(n ** p))+  dualityCounit @(I p n) =+    withOb2 @k @p @n $ withOb2 @k @n @p $ Int (rightUnitorInv @k @(p ** n) . swap @k @n @p . rightUnitor @k @(n ** p))
+ src/Proarrow/Category/Instance/Kleisli.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The __Kleisli category__ of a 'Promonad' @p@: objects are those of the base category (wrapped+-- in 'KL') and a morphism @'KL' a '~>' 'KL' b@ is an element @p a b@, composed with @p@'s own+-- composition. Terminal\/initial objects, (co)products, monoidal and+-- 'Proarrow.Category.Monoidal.CopyDiscard.CopyDiscard' structure lift from the base category when+-- @p@ cooperates (e.g. is a 'Proarrow.Category.Monoidal.MonoidalProfunctor').+module Proarrow.Category.Instance.Kleisli+  ( KLEISLI (..)+  , Kleisli (..)+  , arr+  , KleisliFree (..)+  , KleisliForget (..)+  , LIFTEDF+  , pattern LiftF+  ) where++import Proarrow.Adjunction (Proadjunction)+import Proarrow.Adjunction qualified as Adj+import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Proarrow.Category.Enriched.Thin (DecidableProfunctor (..), mapDecision)+import Proarrow.Category.Enriched.Thin qualified as T+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Category.Monoidal.Cartesian (Cartesian)+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard (..))+import Proarrow.Category.Monoidal.Distributive (Distributive (..), DistributiveProfunctor)+import Proarrow.Colimit.BinaryCoproduct (Coprod, HasBinaryCoproducts (..), codiag, (++))+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Core+  ( CAT+  , CategoryOf (..)+  , Profunctor (..)+  , Promonad (..)+  , UN+  , WrappedOb+  , dimapDefault+  , lmap+  , rmap+  , type (+->)+  )+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..), diag)+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Monoid (CocommutativeComonoid, Comonoid (..))+import Proarrow.Object (tgt, pattern Obj, type Obj)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Representable (RepCostar (..), Representable (..), repUniv)+import Proarrow.Promonad (Comonad, Monad)++type data KLEISLI (p :: CAT k) = KL k++-- | The arrows of the promonad @p@, wrapped as a category on the 'KLEISLI'-wrapped kind.+type Kleisli :: CAT (KLEISLI p)+data Kleisli (a :: KLEISLI p) b where+  Kleisli :: {unKleisli :: p a b} -> Kleisli (KL a :: KLEISLI p) (KL b)++instance (Promonad p) => Profunctor (Kleisli :: CAT (KLEISLI p)) where+  dimap = dimapDefault+  r \\ Kleisli p = r \\ p++arr :: (Promonad p) => a ~> b -> Kleisli (KL a :: KLEISLI p) (KL b)+arr f = Kleisli (rmap f id) \\ f++-- | Every promonad makes a category.+instance (Promonad p) => CategoryOf (KLEISLI p) where+  type (~>) = Kleisli+  type Ob a = WrappedOb KL a++instance (Promonad p) => Promonad (Kleisli :: CAT (KLEISLI p)) where+  id = Kleisli id+  Kleisli f . Kleisli g = Kleisli (f . g)++-- | The terminal object lifts to the co-Kleisli category of a 'Comonad': there @p a b@ is+-- @p '%%' a '~>' b@, so @p a (-)@ is representable and preserves limits. A bare 'Promonad' is not+-- enough. At the constant promonad @'Proarrow.Profunctor.Instance.HaskValue.HaskValue' c@ every+-- element of @c@ is an arrow into the terminal object, so uniqueness fails.+instance (HasTerminalObject k, Comonad p) => HasTerminalObject (KLEISLI (p :: k +-> k)) where+  type TerminalObject @(KLEISLI (p :: k +-> k)) = KL (TerminalObject :: k)+  terminate = arr terminate++-- | Dually, the initial object lifts to the Kleisli category of a 'Monad': there @p a b@ is+-- @a '~>' p '%' b@, so the presheaf @p (-) z@ is representable and takes colimits in @k@ to limits.+instance (HasInitialObject k, Monad p) => HasInitialObject (KLEISLI (p :: k +-> k)) where+  type InitialObject @(KLEISLI (p :: k +-> k)) = KL (InitialObject :: k)+  initiate = arr initiate++-- | Products lift for the same reason as the terminal object: for a 'Comonad' @p a (-)@ is+-- representable, and @'lmap' 'diag' (f '**' g)@ is then the canonical mediating map.+instance (Cartesian k, Comonad p, MonoidalProfunctor p) => HasBinaryProducts (KLEISLI (p :: k +-> k)) where+  type a && b = KL (UN KL a && UN KL b)+  withObProd @(KL a) @(KL b) r = withObProd @k @a @b r+  fst @(KL a) @(KL b) = arr (fst @_ @a @b)+  snd @(KL a) @(KL b) = arr (snd @_ @a @b)+  Kleisli f &&& Kleisli g = Kleisli (lmap diag (f ** g)) \\ f++-- | Coproducts lift for the same reason as the initial object: for a 'Monad' @p (-) z@ is a+-- representable presheaf.+instance+  (HasBinaryCoproducts k, Monad p, MonoidalProfunctor (Coprod p))+  => HasBinaryCoproducts (KLEISLI (p :: k +-> k))+  where+  type a || b = KL (UN KL a || UN KL b)+  withObCoprod @(KL a) @(KL b) r = withObCoprod @k @a @b r+  lft @(KL a) @(KL b) = arr (lft @_ @a @b)+  rgt @(KL a) @(KL b) = arr (rgt @_ @a @b)+  Kleisli f ||| Kleisli g = Kleisli (rmap codiag (f ++ g)) \\ f++instance (Promonad p, MonoidalProfunctor p) => MonoidalProfunctor (Kleisli :: CAT (KLEISLI (p :: k +-> k))) where+  one = Kleisli one+  Kleisli f ** Kleisli g = Kleisli (f ** g)++-- | If the promonad is a monoidal profunctor, then its Kleisli category is a monoidal category.+instance (Promonad p, MonoidalProfunctor p) => Monoidal (KLEISLI (p :: k +-> k)) where+  type Unit @(KLEISLI (p :: k +-> k)) = KL (Unit :: k)+  type a ** b = KL (UN KL a ** UN KL b)+  withOb2 @(KL a) @(KL b) r = withOb2 @k @a @b r+  leftUnitor = arr leftUnitor+  leftUnitorInv = arr leftUnitorInv+  rightUnitor = arr rightUnitor+  rightUnitorInv = arr rightUnitorInv+  associator @(KL a) @(KL b) @(KL c) = arr (associator @k @a @b @c)+  associatorInv @(KL a) @(KL b) @(KL c) = arr (associatorInv @k @a @b @c)++instance (Promonad p, MonoidalProfunctor p, SymMonoidal k) => SymMonoidal (KLEISLI (p :: k +-> k)) where+  swap @(KL a) @(KL b) = arr (swap @k @a @b)+instance (Promonad p, MonoidalProfunctor p, CopyDiscard k, Ob (a :: KLEISLI p)) => Comonoid (a :: KLEISLI (p :: k +-> k)) where+  counit = discard+  comult = copy+instance+  (Promonad p, MonoidalProfunctor p, CopyDiscard k, Ob (a :: KLEISLI p))+  => CocommutativeComonoid (a :: KLEISLI (p :: k +-> k))+instance (Promonad p, MonoidalProfunctor p, CopyDiscard k) => CopyDiscard (KLEISLI (p :: k +-> k)) where+  copy = arr copy+  discard = arr discard++instance (Distributive k, Monad p, DistributiveProfunctor p) => Distributive (KLEISLI (p :: k +-> k)) where+  distL @(KL a) @(KL b) @(KL c) = arr (distL @k @a @b @c)+  distR @(KL a) @(KL b) @(KL c) = arr (distR @k @a @b @c)+  absorbL @(KL a) = arr (absorbL @k @a)+  absorbR @(KL a) = arr (absorbR @k @a)++instance (DaggerProfunctor p, Promonad p) => DaggerProfunctor (Kleisli :: CAT (KLEISLI p)) where+  dagger (Kleisli p) = Kleisli (dagger p)++instance (T.ThinProfunctor p, Promonad p) => T.ThinProfunctor (Kleisli :: CAT (KLEISLI p)) where+  type HasArrow (Kleisli :: CAT (KLEISLI p)) (KL a) (KL b) = T.HasArrow p a b+  arr = Kleisli T.arr+  withArr (Kleisli p) r = T.withArr p r++instance (DecidableProfunctor p, Promonad p) => DecidableProfunctor (Kleisli :: CAT (KLEISLI p)) where+  type Holds (Kleisli :: CAT (KLEISLI p)) (KL a) (KL b) = Holds p a b+  decide @(KL a) @(KL b) = mapDecision Kleisli (decide @p @a @b)+  toHolds (Kleisli p) r = toHolds p r++-- | The Kleisli category has the objects of @k@, numbered the same way, so a Kleisli category of a+-- decidable promonad on an enumerable category is itself enumerable, and so can be searched, or+-- closed ("Proarrow.Category.Enriched.Thin.Composition").+instance (T.Indexed k) => T.Indexed (KLEISLI (p :: CAT k)) where+  type Index (a :: KLEISLI p) = T.Index (UN KL a)+  type At (KLEISLI (p :: CAT k)) i = T.FmapWrap KL (T.At k i)++instance (T.Finite k) => T.Finite (KLEISLI (p :: CAT k)) where+  type Objects (KLEISLI (p :: CAT k)) = T.MapWrap KL (T.Objects k)+  finite = T.wrapFinite @KL+  withAtLookup = T.withWrapAtLookup @KL++instance (T.Enumerable k, Promonad p) => T.Enumerable (KLEISLI (p :: CAT k)) where+  withIndex @(KL a) r = T.withIndex @k @a r+  atOb i = case T.atOb @k i of+    T.AtJust -> T.AtJust+    T.AtNothing -> T.AtNothing++-- | The free half of the Kleisli adjunction ('Proadjunction' below), embedding @k@ into the+-- Kleisli category of @p@.+type KleisliFree :: forall (p :: k +-> k) -> k +-> KLEISLI p+data KleisliFree p a b where+  KleisliFree :: p a b -> KleisliFree p (KL a) b++instance (Promonad p) => Profunctor (KleisliFree p) where+  dimap (Kleisli l) r (KleisliFree p) = KleisliFree (rmap r p . l)+  r \\ KleisliFree p = r \\ p++-- | The forgetful half of the Kleisli adjunction, mapping Kleisli objects back to @k@.+type KleisliForget :: forall (p :: k +-> k) -> KLEISLI p +-> k+data KleisliForget p a b where+  KleisliForget :: p a b -> KleisliForget p a (KL b)++instance (Promonad p) => Profunctor (KleisliForget p) where+  dimap l (Kleisli r) (KleisliForget p) = KleisliForget (r . lmap l p)+  r \\ KleisliForget p = r \\ p++instance (Promonad p) => Proadjunction (KleisliFree p) (KleisliForget p) where+  unit = KleisliForget id :.: KleisliFree id+  counit (KleisliFree p :.: KleisliForget q) = Kleisli (q . p)++-- | Categories lifted by a representable profunctor: @f % a ~> f % b@ are kleisli categories on promonads induced by @f@.+type LIFTEDF (f :: j +-> k) = KLEISLI (RepCostar f :.: f)++unlift :: (Representable f) => Kleisli (KL a :: LIFTEDF f) (KL b) -> (f % a ~> f % b, Obj a, Obj b)+unlift (Kleisli (RepCostar f :.: g)) = (index g . f, Obj, tgt g)++pattern LiftF+  :: (Representable (f :: j +-> k)) => (Ob (a :: j), Ob b) => (f % a ~> f % b) -> Kleisli (KL a :: LIFTEDF f) (KL b)+pattern LiftF f <- (unlift -> (f, Obj, Obj))+  where+    LiftF f = Kleisli (RepCostar f :.: repUniv)++{-# COMPLETE LiftF #-}
+ src/Proarrow/Category/Instance/Linear.hs view
@@ -0,0 +1,293 @@+{-# LANGUAGE LinearTypes #-}++{- HLINT ignore "Avoid lambda using `infix`" -}+{- HLINT ignore "Use curry" -}+{- HLINT ignore "Use bimap" -}+{- HLINT ignore "Use tuple-section" -}++-- | The category of Haskell types and __linear functions__: the kind 'LINEAR' wraps 'Data.Kind.Type'+-- in 'L', and a morphism is a @a %1 -> b@ function. Symmetric monoidal closed with+-- @'L' a '**' 'L' b = 'L' (a, b)@. The categorical product is 'With', and only comonoid objects+-- (such as @'L' ('Ur' a)@) can be copied or discarded, so it is deliberately not+-- 'Proarrow.Category.Monoidal.CopyDiscard.CopyDiscard'.+module Proarrow.Category.Instance.Linear where++import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Kind (Type)+import Data.Void (Void)+import System.IO.Unsafe (unsafeDupablePerformIO)+import Unsafe.Coerce (unsafeCoerce)+import Prelude (Bool (..), Either (..), Eq (..), Show (..), error, showParen, showString, (&&), (>))++import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Category.Monoidal.Action (CoprodAction)+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.Distributive (Distributive (..))+import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomous (..))+import Proarrow.Category.Monoidal.Strength (Costrong (..))+import Proarrow.Colimit.BinaryCoproduct (Coprod (..), HasBinaryCoproducts (..))+import Proarrow.Colimit.Copower (Copowered (..))+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Core (CAT, CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, dimapDefault, type (+->))+import Proarrow.Functor (Functor (..), FunctorForRep (..))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..))+import Proarrow.Limit.Power (Powered (..))+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Monoid (Comonoid (..))+import Proarrow.Profunctor.Corepresentable (Corep (..), Corepresentable (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Representable (Rep (..))++type data LINEAR = L Type++type Linear :: CAT LINEAR+data Linear a b where+  Linear :: (a %1 -> b) %1 -> Linear (L a) (L b)++unLinear :: (L a ~> L b) %1 -> (a %1 -> b)+unLinear (Linear f) = f++instance Profunctor Linear where+  dimap = dimapDefault+  r \\ Linear{} = r+instance Promonad Linear where+  id = Linear \x -> x+  Linear f . Linear g = Linear \x -> f (g x)++-- | Category of linear functions.+instance CategoryOf LINEAR where+  type (~>) = Linear+  type Ob (a :: LINEAR) = Is L a++instance MonoidalProfunctor Linear where+  one = id+  Linear f ** Linear g = Linear \(x, y) -> (f x, g y)++-- | Tuples as monoidal tensor. Tuples are not the binary product in LINEAR.+instance Monoidal LINEAR where+  type Unit = L ()+  type L a ** L b = L (a, b)+  withOb2 r = r+  leftUnitor = Linear \((), x) -> x+  leftUnitorInv = Linear \x -> ((), x)+  rightUnitor = Linear \(x, ()) -> x+  rightUnitorInv = Linear \x -> (x, ())+  associator = Linear \((x, y), z) -> (x, (y, z))+  associatorInv = Linear \(x, (y, z)) -> ((x, y), z)++instance SymMonoidal LINEAR where+  swap = Linear \(x, y) -> (y, x)++instance Closed LINEAR where+  type a ~~> b = L (UN L a %1 -> UN L b)+  withObExp r = r+  curry (Linear f) = Linear \a b -> f (a, b)+  apply = Linear \(f, a) -> f a+  Linear f ^^^ Linear g = Linear \h x -> f (h (g x))++data family Forget :: LINEAR +-> Type+instance FunctorForRep Forget where+  type Forget @ a = UN L a+  fmap (Linear f) x = f x++-- | By creating the left adjoint to the forgetful functor,+-- we obtain the free-forgetful adjunction between Hask and LINEAR+instance Corepresentable (Rep Forget :: LINEAR +-> Type) where+  type Rep Forget %% a = L (Ur a)+  coindex (Rep f) = Linear \(Ur a) -> f a+  cotabulate (Linear f) = Rep \a -> f (Ur a)+  corepMap f = Linear \(Ur a) -> Ur (f a)++-- | Forget is a lax monoidal functor+instance MonoidalProfunctor (Rep Forget) where+  one = Rep \() -> ()+  Rep f ** Rep g = Rep \(x, y) -> (f x, g y)++-- | Forget is also a colax monoidal functor+instance MonoidalProfunctor (Corep Forget) where+  one = Corep id+  Corep f ** Corep g = Corep \(x, y) -> (f x, g y)++data Ur a where+  Ur :: a -> Ur a++counitUr :: Ur a %1 -> a+counitUr (Ur a) = a++dupUr :: Ur a %1 -> Ur (Ur a)+dupUr (Ur a) = Ur (Ur a)++instance Functor Ur where+  map f (Ur a) = Ur (f a)++instance Comonoid (L (Ur a)) where+  counit = Linear \(Ur _) -> ()+  comult = Linear \(Ur a) -> (Ur a, Ur a)++-- | @L Bool@ is a comonoid: a @Bool@ is duplicated and discarded by case analysis, which is+-- linear (it consumes the input exactly once). The same holds for any finite, pattern-matchable+-- classical type. Only the @Bool@ instance is spelled out here.+instance Comonoid (L Bool) where+  counit = Linear \case True -> (); False -> ()+  comult = Linear \case True -> (True, True); False -> (False, False)++instance HasBinaryCoproducts LINEAR where+  type L a || L b = L (Either a b)+  withObCoprod r = r+  lft = Linear Left+  rgt = Linear Right+  Linear f ||| Linear g = Linear \case+    Left x -> f x+    Right y -> g y++instance HasInitialObject LINEAR where+  type InitialObject = L Void+  initiate = Linear \case {}++instance Costrong CoprodAction Linear where+  coact (Linear uxuy) = loop . Linear Right+    where+      loop = Linear \ux -> case uxuy ux of Left x -> unLinear loop (Left x); Right b -> b++data Top where+  Top :: a %1 -> Top+instance Show Top where+  showsPrec _ _ = showString "⊤"+instance Eq Top where+  _ == _ = True++data With a b where+  With :: x %1 -> (x %1 -> a) -> (x %1 -> b) -> With a b+instance (Show a, Show b) => Show (With a b) where+  showsPrec d (With x f g) = showParen (d > 9) (showString "mkWith " . showsPrec 10 (f x) . showString " " . showsPrec 10 (g x))+instance (Eq a, Eq b) => Eq (With a b) where+  With x fa fb == With y ga gb = (fa x == ga y) && (fb x == gb y)++urWith :: Ur (With a b) %1 -> (Ur a, Ur b)+urWith (Ur (With x f g)) = (Ur (f x), Ur (g x))++mkWith :: a -> b -> With a b+mkWith a b = With () (\() -> a) (\() -> b)++instance HasTerminalObject LINEAR where+  type TerminalObject = L Top+  terminate = Linear Top++instance HasBinaryProducts LINEAR where+  type L a && L b = L (With a b)+  withObProd r = r+  fst = Linear \(With x xa _) -> xa x+  snd = Linear \(With x _ xb) -> xb x+  Linear f &&& Linear g = Linear \x -> With x f g++instance Powered Type LINEAR where+  type L a ^ n = L (n -> a)+  withObPower r = r+  power f = Linear \x n -> unLinear (f n) x+  unpower (Linear f) n = Linear \x -> f x n++instance Copowered Type LINEAR where+  type n *. L a = L (Ur n, a)+  withObCopower r = r+  copower f = Linear \(Ur n, a) -> unLinear (f n) a+  uncopower (Linear f) n = Linear \x -> f (Ur n, x)++instance MonoidalProfunctor (Coprod Linear) where+  one = Coprod (Linear \x -> x)+  Coprod f ** Coprod g = Coprod (f +++ g)++instance Distributive LINEAR where+  distL = Linear \(a, ebc) -> case ebc of Left b -> Left (a, b); Right c -> Right (a, c)+  distR = Linear \(eab, c) -> case eab of Left a -> Left (a, c); Right b -> Right (b, c)+  absorbL = Linear \(_a, v) -> case v of {}+  absorbR = Linear \(v, _a) -> case v of {}++type Not a = a %1 -> ()++not :: (Not b %1 -> Not a) %1 -> a %1 -> b+not nbna a = dn \nb -> nbna nb a++not' :: (a %1 -> b) %1 -> Not b %1 -> Not a+not' ab nb a = nb (ab a)++newtype Par a b = Par (Not (Not a, Not b))++mkPar :: a %1 -> b %1 -> Par a b+mkPar a b = Par \(na, nb) -> case (na a, nb b) of ((), ()) -> ()++pairFst :: (a, b `Par` c) %1 -> (a, b) `Par` c+pairFst (a, Par f) = Par \(nab, nc) -> f (\b -> nab (a, b), nc)++pairSnd :: (a `Par` b, c) %1 -> a `Par` (b, c)+pairSnd (Par f, c) = Par \(na, nbc) -> f (na, \b -> nbc (b, c))++parAppL :: (a `Par` b) %1 -> Not a %1 -> b+parAppL (Par f) na = dn \nb -> f (na, nb)++parAppR :: (a `Par` b) %1 -> Not b %1 -> a+parAppR (Par f) nb = dn \na -> f (na, nb)++newtype Quest a = Quest (Not (Ur (Not a)))++notQuest :: Not (Quest a) %1 -> Ur (Not a)+notQuest nqa = dn \nuna -> nqa (Quest nuna)++unitQuest :: a %1 -> Quest a+unitQuest a = Quest \(Ur na) -> na a++multQuest :: Quest (Quest a) %1 -> Quest a+multQuest (Quest f) = Quest \(Ur na) -> f (Ur (\(Quest nuna) -> nuna (Ur na)))++questPar :: Par (Quest a) (Quest b) %1 -> Quest (Either a b)+questPar (Par f) = Quest (\(Ur g) -> f (\(Quest nuna) -> nuna (Ur (\a -> g (Left a))), \(Quest nunb) -> nunb (Ur (\b -> g (Right b)))))++-- LINEAR is not CompactClosed. And hence it is also not traced,+-- since any star autonomous category with a trace is compact closed.+instance StarAutonomous LINEAR where+  type Dual (L a) = L (Not a)+  withObDual r = r+  dual (Linear f) = Linear (\nb a -> nb (f a))+  dualInv (Linear f) = Linear (\b -> dn (\na -> f na b))+  linDist (Linear f) = Linear (\a (b, c) -> f (a, b) c)+  linDistInv (Linear f) = Linear (\(a, b) c -> f a (b, c))+  doubleNeg = Linear dn+  doubleNegInv = Linear (\a na -> na a)++-- | Double negation is possible with linear functions, though using `unsafeDupablePerformIO`.+-- Derived from https://gist.github.com/ant-arctica/7563282c57d9d1ce0c4520c543187932+-- TODO: only tested in GHCi, might get ruined by optimizations+dn :: Not (Not a) %1 -> a+dn nna =+  let ref = unsafeDupablePerformIO (newIORef (error "Linear.dn: write failed"))+  in case nna (unsafeLinear (fill ref)) of () -> unsafeDupablePerformIO (readIORef ref)+  where+    fill ref x = unsafeDupablePerformIO (writeIORef ref x)++unsafeLinear :: (a -> b) -> (a %1 -> b)+unsafeLinear = unsafeCoerce++unit :: L () ~> L (Par a (Not a))+unit = Linear \() -> Par \(na, nna) -> nna na++counit :: L (Not a, a) ~> L ()+counit = Linear \(na, a) -> na a++type p !~> q = forall a b. p a b %1 -> q a b++type NegComp :: (j +-> k) -> (i +-> j) -> (i +-> k)+data NegComp p q a c where+  NegComp :: (forall b. Par (p a b) (q b c)) %1 -> NegComp p q a c++newtype Neg p a b = Neg (Not (p b a))++getNeg :: Neg p a b %1 -> Not (p b a)+getNeg (Neg f) = f++conv1 :: NegComp p q !~> Neg (Neg q :.: Neg p)+conv1 (NegComp e) = Neg \(Neg nq :.: Neg np) -> case e of Par e' -> e' (np, nq)++conv2 :: Neg (Neg q :.: Neg p) !~> NegComp p q+conv2 (Neg f) = NegComp (Par (\(np, nq) -> f (Neg nq :.: Neg np)))++asCocat :: (Neg p :.: Neg p !~> Neg p) -> p !~> NegComp p p+asCocat comp p = NegComp (Par \(np1, np2) -> getNeg (comp (Neg np2 :.: Neg np1)) p)
+ src/Proarrow/Category/Instance/Mat.hs view
@@ -0,0 +1,372 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | The category of __matrices__ over a numeric type @a@: objects are natural numbers (dimensions,+-- @'M' n@ of kind @'MatK' a@) and a morphism is an @n@-by-@m@ matrix, composed by matrix+-- multiplication. A dagger (conjugate-transpose) category with biproducts, whose Kronecker-product+-- tensor makes it compact closed. It is the library's linear-algebra playground. The compact+-- structure's 'Proarrow.Category.Monoidal.StarAutonomous.dual' is the plain 'transpose', distinct+-- from 'dagger' once the entries are complex.+module Proarrow.Category.Instance.Mat where++import Data.Complex (Complex, conjugate)+import Data.Kind (Type)+import Data.Type.Nat (Nat (..), SNat (..), SNatI, snat, snatToNat, type Mult, type Plus)+import Data.Vec.Lazy (Vec (..), chunks, concat, concatMap, reifyList, tabulate, toList, zipWith, (++))+import Prelude (($), type (~))+import Prelude qualified as P++import Data.Fin (Fin)+import Proarrow.Adjunction (Involution)+import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Proarrow.Category.Instance.FinSet (FINSET (..), FinSet (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Category.Monoidal.Action (MonoidalAction)+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..), coactCC)+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Distributive (Distributive (..), distLInv, distRInv)+import Proarrow.Category.Monoidal.Hypergraph (Frobenius, Hypergraph, cap, cup)+import Proarrow.Category.Monoidal.StarAutonomous (ExpSA, StarAutonomous (..), applySA, currySA, expSA)+import Proarrow.Category.Monoidal.Strength (Costrong (..))+import Proarrow.Category.Topos (HasEpiMonoFactorization (..))+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..), HasBiproducts)+import Proarrow.Colimit.Coequalizer (HasCoequalizers (..))+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Colimit.Pushout (HasPushouts (..))+import Proarrow.Core (CAT, CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, dimapDefault, obj, type (+->))+import Proarrow.Functor (FunctorForRep (..))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..))+import Proarrow.Limit.Equalizer (HasEqualizers (..))+import Proarrow.Limit.Pullback (HasPullbacks (..))+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Monoid (CocommutativeComonoid, CommutativeMonoid, Comonoid (..), Monoid (..))+import Proarrow.Profunctor.Corepresentable (Corepresentable (..))+import Proarrow.Profunctor.Representable (Rep (..))++type n + m = Plus n m+type (*) n m = Mult n m++type data MatK (a :: Type) = M Nat++data Mat :: CAT (MatK a) where+  Mat+    :: forall {a} m n+     . (IsNat m, IsNat n)+    => {unMat :: Vec n (Vec m a)}+    -> Mat (M m :: MatK a) (M n)++app :: (P.Num a, P.Applicative (Vec m)) => Vec n (Vec m a) -> Vec m a -> Vec n a+app m v = P.fmap (P.sum . P.liftA2 (P.*) v) m++arr :: forall n m a. (P.Num a) => FinSet (FS m) (FS n) -> Mat (M n :: MatK a) (M m :: MatK a)+arr (FinSet v) = withIsNat @n $ withIsNat @m $ Mat (P.fmap oneV v)++arr' :: forall n m a. (P.Num a) => FinSet (FS m) (FS n) -> Mat (M m :: MatK a) (M n :: MatK a)+arr' (FinSet v) = withIsNat @n $ withIsNat @m $ Mat (P.traverse oneV v)++oneV :: (P.Num a, IsNat n) => Fin n -> Vec n a+oneV m = tabulate \n -> if n P.== m then 1 else 0++zero :: (P.Num a, IsNat n) => Vec n a+zero = P.pure 0++withIsNat :: forall n r. (SNatI n) => ((IsNat n) => r) -> r+withIsNat r = case snat @n of+  SZ -> r+  SS @n' -> withIsNat @n' r++class (SNatI n, P.Applicative (Vec n), n + Z ~ n, n * Z ~ Z, n * S Z ~ n) => IsNat (n :: Nat) where+  matId :: (P.Num a) => Vec n (Vec n a)+  withPlusNat :: (IsNat m) => ((IsNat (n + m)) => r) -> r+  withMultNat :: (IsNat m) => ((IsNat (n * m)) => r) -> r+  withPlusSucc :: (IsNat m) => ((n + (S m) ~ S (n + m)) => r) -> r+  withMultSucc :: (IsNat m) => ((n * (S m) ~ n + (n * m)) => r) -> r+  withPlusSym :: (IsNat m) => (((n + m) ~ (m + n)) => r) -> r+  withMultSym :: (IsNat m) => (((n * m) ~ (m * n)) => r) -> r+  withAssocPlus :: (IsNat m, IsNat o) => (((n + m) + o ~ n + (m + o)) => r) -> r+  withAssocMult :: (IsNat m, IsNat o) => (((n * m) * o ~ n * (m * o)) => r) -> r+  withDist :: (IsNat m, IsNat o) => (((n + m) * o ~ (n * o) + (m * o)) => r) -> r+instance IsNat Z where+  matId = VNil+  withPlusNat r = r+  withMultNat r = r+  withPlusSucc r = r+  withMultSucc r = r+  withPlusSym r = r+  withMultSym r = r+  withAssocPlus r = r+  withAssocMult r = r+  withDist r = r+instance (IsNat n) => IsNat (S n) where+  matId = (1 ::: zero) ::: P.fmap (0 :::) matId+  withPlusNat @m r = withPlusNat @n @m r+  withMultNat @m r = withMultNat @n @m (withPlusNat @m @(n * m) r)+  withPlusSucc @m r = withPlusSucc @n @m r+  withMultSucc @m r =+    withMultNat @n @m $+      withAssocPlus @n @m @(n * m) $+        withPlusSym @n @m $+          withAssocPlus @m @n @(n * m) $+            withMultSucc @n @m r+  withPlusSym @m r = withPlusSucc @m @n $ withPlusSym @n @m r+  withMultSym @m r = withMultSucc @m @n $ withMultSym @n @m r+  withAssocPlus @m @o r = withAssocPlus @n @m @o r+  withAssocMult @m @o r = withMultNat @n @m $ withAssocMult @n @m @o (withDist @m @(n * m) @o r)+  withDist @m @o r = withMultNat @n @o $ withMultNat @m @o $ withAssocPlus @o @(n * o) @(m * o) $ withDist @n @m @o r++-- | Plain transpose, with no conjugation.+--+-- Three operations on a matrix are easy to confuse, and at @'MatK' ('Complex' a)@ they differ:+-- this one, the entrywise 'Conjugate' functor, and 'dagger', which is their composite (the+-- conjugate-transpose). Composition and the compact-closed structure are /bilinear/ and must not+-- conjugate, so they are written in terms of 'transpose' rather than 'dagger'. At a real element+-- type 'dagger' /is/ 'transpose', so the distinction is easy to lose.+transpose :: Mat (n :: MatK a) m -> Mat m n+transpose (Mat m) = Mat (P.sequenceA m)++instance {-# OVERLAPPABLE #-} (P.Num a) => DaggerProfunctor (Mat :: CAT (MatK a)) where+  dagger = transpose++instance {-# OVERLAPS #-} (P.RealFloat a) => DaggerProfunctor (Mat :: CAT (MatK (Complex a))) where+  dagger (Mat m) = Mat (P.traverse (P.fmap conjugate) m)++instance (P.Num a) => Profunctor (Mat :: CAT (MatK a)) where+  dimap = dimapDefault+  r \\ Mat{} = r+instance (P.Num a) => Promonad (Mat :: CAT (MatK a)) where+  id = Mat matId+  Mat m . n = case transpose n of Mat nT -> Mat (P.fmap (app nT) m)++-- | The category of matrices with entries in a type @a@, where the objects are natural numbers and the arrows @n ~> m@ are matrices of dimension @n@ by @m@.+instance (P.Num a) => CategoryOf (MatK a) where+  type (~>) = Mat+  type Ob n = (Is M n, IsNat (UN M n))++instance (P.Num a) => HasInitialObject (MatK a) where+  type InitialObject = M Z+  initiate = Mat (P.pure VNil)+instance (P.Num a) => HasTerminalObject (MatK a) where+  type TerminalObject = M Z+  terminate = Mat VNil++instance (P.Num a) => HasBinaryCoproducts (MatK a) where+  type M x || M y = M (x + y)+  withObCoprod @(M x) @(M y) r = withPlusNat @x @y r+  lft @(M m) @(M n) = withPlusNat @m @n (Mat (matId @m ++ (zero P.<$ matId @n @a)))+  rgt @(M m) @(M n) = withPlusNat @m @n (Mat ((zero P.<$ matId @m @a) ++ matId @n))+  Mat @m a ||| Mat @n b = withPlusNat @m @n (Mat (P.liftA2 (++) a b))+instance (P.Num a) => HasBinaryProducts (MatK a) where+  type M x && M y = M (x + y)+  withObProd @(M x) @(M y) r = withPlusNat @x @y r+  fst @(M m) @(M n) = withPlusNat @m @n (Mat (P.fmap (++ (0 P.<$ matId @n @a)) (matId @m)))+  snd @(M m) @(M n) = withPlusNat @m @n (Mat (P.fmap ((0 P.<$ matId @m @a) ++) (matId @n)))+  Mat @_ @m a &&& Mat @_ @n b = withPlusNat @m @n (Mat (a ++ b))+instance (P.Num a) => HasBiproducts (MatK a)++-- | The equalizer of two linear maps @f, g :: M m ~> M n@ is the kernel of @f - g@: the subspace of+-- @M m@ on which they agree. Computed by row-reducing @f - g@ to reduced row echelon form; the free+-- (non-pivot) columns of the result index a basis of the kernel.+--+-- >>> import Data.Vec.Lazy (Vec(..))+-- >>> let f = Mat @(S (S Z)) @(S Z) ((1 ::: 2 ::: VNil) ::: VNil) :: Mat (M (S (S Z))) (M (S Z) :: MatK P.Double)+-- >>> let g = Mat @(S (S Z)) @(S Z) ((3 ::: 0 ::: VNil) ::: VNil) :: Mat (M (S (S Z))) (M (S Z) :: MatK P.Double)+-- >>> let h = Mat @(S Z) @(S (S Z)) ((1 ::: VNil) ::: (1 ::: VNil) ::: VNil) :: Mat (M (S Z)) (M (S (S Z)) :: MatK P.Double)+-- >>> (equalize f g \incl@(Mat inclv) -> case factorEqualizer incl h of p@(Mat pv) -> P.show (inclv, pv, unMat (incl . p))) :: P.String+-- "((1.0 ::: VNil) ::: (1.0 ::: VNil) ::: VNil,(1.0 ::: VNil) ::: VNil,(1.0 ::: VNil) ::: (1.0 ::: VNil) ::: VNil)"+instance (P.Fractional a, P.Eq a) => HasEqualizers (MatK a) where+  equalize (Mat @m @_ l) (Mat r) cont =+    let+      diffRows = toList (zipWith (zipWith (P.-)) l r) :: [Vec m a]+      numCols = P.fromIntegral (snatToNat (snat @m)) :: P.Int+      (pivotCols, finalRows) = rref numCols diffRows+      pivotMap = P.zip pivotCols finalRows+      freeCols = P.filter (`P.notElem` pivotCols) [0 .. numCols P.- 1]+      basisFor :: P.Int -> Vec m a+      basisFor j' = tabulate entryAt+        where+          entryAt fi =+            let i = P.fromEnum fi+            in if i P.== j'+                 then 1+                 else+                   if i `P.elem` freeCols+                     then 0+                     else P.maybe 0 (P.negate . (`at` j')) (P.lookup i pivotMap)+    in+      reifyList (P.map basisFor freeCols) \(vecs :: Vec e (Vec m a)) ->+        withIsNat @e $ cont (Mat (P.sequenceA vecs) :: Mat (M e :: MatK a) (M m))++  -- @incl@ need not literally be the RREF-derived basis 'equalize' produces; any mono @incl@ works,+  -- since we row-reduce the columns of @incl@ and @h@ concatenated (bounding pivot search to just+  -- @incl@'s width). Full column rank turns @incl@'s part into an identity submatrix for free, and+  -- Gaussian elimination carries the same row operations through @h@'s columns alongside it.+  factorEqualizer (Mat @e @_ incl) (Mat @e' j) =+    let+      numColsE = P.fromIntegral (snatToNat (snat @e)) :: P.Int+      combinedRows = P.zipWith (++) (toList incl) (toList j)+      (_, finalRows) = rref numColsE combinedRows+      hRow fi =+        let rest = P.drop numColsE (toList (finalRows P.!! P.fromEnum fi))+        in tabulate (\fj -> rest P.!! P.fromEnum fj) :: Vec e' a+    in+      Mat (tabulate hRow)++-- | The coequalizer of @f, g :: M m ~> M n@ is the cokernel of @f - g@. Since @dagger@ is a+-- contravariant involution on 'Mat', it is the equalizer of @dagger f, dagger g@ transported back.+--+-- >>> let f = Mat @(S Z) @(S (S Z)) ((2 ::: VNil) ::: (0 ::: VNil) ::: VNil) :: Mat (M (S Z)) (M (S (S Z)) :: MatK P.Double)+-- >>> let g = Mat @(S Z) @(S (S Z)) ((0 ::: VNil) ::: (3 ::: VNil) ::: VNil) :: Mat (M (S Z)) (M (S (S Z)) :: MatK P.Double)+-- >>> let w = Mat @(S (S Z)) @(S Z) ((3 ::: 2 ::: VNil) ::: VNil) :: Mat (M (S (S Z))) (M (S Z) :: MatK P.Double)+-- >>> (coequalize f g \q@(Mat qv) -> case factorCoequalizer q w of s@(Mat sv) -> P.show (qv, sv, unMat (s . q))) :: P.String+-- "((1.5 ::: 1.0 ::: VNil) ::: VNil,(2.0 ::: VNil) ::: VNil,(3.0 ::: 2.0 ::: VNil) ::: VNil)"+instance (P.Fractional a, P.Eq a) => HasCoequalizers (MatK a) where+  coequalize f g cont = equalize (dagger f) (dagger g) \incl -> cont (dagger incl)+  factorCoequalizer q h = dagger (factorEqualizer (dagger q) (dagger h))++-- | Pullbacks are computed via 'pullbackDefault', as the equalizer of @f . fst@ and @g . snd@ on the+-- product @a && b@, the standard linear-algebra construction of a fiber product of vector spaces.+--+-- >>> let f = Mat @(S Z) @(S Z) ((2 ::: VNil) ::: VNil) :: Mat (M (S Z)) (M (S Z) :: MatK P.Double)+-- >>> let g = Mat @(S Z) @(S Z) ((3 ::: VNil) ::: VNil) :: Mat (M (S Z)) (M (S Z) :: MatK P.Double)+-- >>> (pullback f g \p q -> case (p, q) of (Mat pv, Mat qv) -> P.show (pv, qv)) :: P.String+-- "((1.5 ::: VNil) ::: VNil,(1.0 ::: VNil) ::: VNil)"+instance (P.Fractional a, P.Eq a) => HasPullbacks (MatK a)++-- | Pushouts are computed via 'pushoutDefault', as the coequalizer of @lft . f@ and @rgt . g@ on the+-- coproduct @a || b@, the standard linear-algebra construction of a cofiber product of vector spaces.+--+-- >>> let f = Mat @(S Z) @(S Z) ((2 ::: VNil) ::: VNil) :: Mat (M (S Z)) (M (S Z) :: MatK P.Double)+-- >>> let g = Mat @(S Z) @(S Z) ((3 ::: VNil) ::: VNil) :: Mat (M (S Z)) (M (S Z) :: MatK P.Double)+-- >>> (pushout f g \p q -> case (p, q) of (Mat pv, Mat qv) -> P.show (pv, qv)) :: P.String+-- "((1.5 ::: VNil) ::: VNil,(1.0 ::: VNil) ::: VNil)"+instance (P.Fractional a, P.Eq a) => HasPushouts (MatK a)++-- | Epi-mono factorization is computed via 'defaultFactorize': @f@ factors as the coequalizer of its+-- cokernel pair (the epi onto its image) followed by the equalizer factorization of @f@ through that+-- epi (the mono inclusion of the image).+--+-- >>> import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+-- >>> let h = Mat @(S (S Z)) @(S (S Z)) ((1 ::: 2 ::: VNil) ::: (2 ::: 4 ::: VNil) ::: VNil) :: Mat (M (S (S Z))) (M (S (S Z)) :: MatK P.Double)+-- >>> (case factorize h of e :.: m -> case (e, m) of (Mat ev, Mat mv) -> P.show (ev, mv, unMat (m . e))) :: P.String+-- "((2.0 ::: 4.0 ::: VNil) ::: VNil,(0.5 ::: VNil) ::: (1.0 ::: VNil) ::: VNil,(1.0 ::: 2.0 ::: VNil) ::: (2.0 ::: 4.0 ::: VNil) ::: VNil)"+instance (P.Fractional a, P.Eq a) => HasEpiMonoFactorization (MatK a)++-- | Reads the entry of a row at a runtime column index.+at :: Vec m a -> P.Int -> a+at v i = toList v P.!! i++-- | Row-reduces the given matrix, given as a list of rows of the given width, to reduced row echelon+-- form, returning the ascending pivot column indices together with the reduced rows.+rref :: (P.Fractional a, P.Eq a) => P.Int -> [Vec m a] -> ([P.Int], [Vec m a])+rref numCols rows0 = go 0 0 rows0+  where+    numRows = P.length rows0+    go rowPtr col rows+      | col P.>= numCols P.|| rowPtr P.>= numRows = ([], rows)+      | P.otherwise =+          let (before, atOrAfter) = P.splitAt rowPtr rows+          in case P.break (\row -> row `at` col P./= 0) atOrAfter of+               (_, []) -> go rowPtr (col P.+ 1) rows+               (skipped, pivotRow : rest) ->+                 let+                   normalized = P.fmap (P./ (pivotRow `at` col)) pivotRow+                   eliminate row =+                     let f = row `at` col+                     in if f P.== 0 then row else zipWith (\x y -> x P.- f P.* y) row normalized+                   rows' = P.map eliminate before P.++ (normalized : P.map eliminate (skipped P.++ rest))+                 in+                   case go (rowPtr P.+ 1) (col P.+ 1) rows' of+                     (pivots, final) -> (col : pivots, final)++instance (P.Num a) => MonoidalProfunctor (Mat :: CAT (MatK a)) where+  one = id+  Mat @fx @fy f ** Mat @gx @gy g =+    withMultNat @gx @fx $+      withMultNat @gy @fy $+        Mat $+          concatMap (\grow -> P.fmap (\frow -> concatMap (\a -> P.fmap (a P.*) frow) grow) f) g++-- | Products of the dimensions of the matrices as the tensor. This is the Kronecker product of matrices.+instance (P.Num a) => Monoidal (MatK a) where+  type Unit = M (S Z)+  type M x ** M y = M (y * x)+  withOb2 @(M x) @(M y) r = withMultNat @y @x r+  associator @(M b) @(M c) @(M d) = withAssocMult @d @c @b (obj @(M b) ** (obj @(M c) ** obj @(M d)))+  associatorInv @(M b) @(M c) @(M d) = withAssocMult @d @c @b (obj @(M b) ** (obj @(M c) ** obj @(M d)))++instance (P.Num a) => SymMonoidal (MatK a) where+  swap @(M x) @(M y) = arr (swap @_ @(FS x) @(FS y))++instance (P.Num a) => Distributive (MatK a) where+  distL @(M a') @(M b) @(M c) = arr (distRInv @(FS b) @(FS c) @(FS a'))+  distR @(M a') @(M b) @(M c) = arr (distLInv @(FS c) @(FS a') @(FS b))+  absorbL = id+  absorbR = id++instance (P.Num a) => Closed (MatK a) where+  type x ~~> y = ExpSA x y+  withObExp @(M x) @(M y) r = withMultNat @y @x r+  curry @x @y = currySA @x @y+  apply @y @z = applySA @y @z+  (^^^) = expSA++instance (P.Num a) => StarAutonomous (MatK a) where+  type Dual n = n+  withObDual r = r++  -- The dual of the compact-closed structure is the transpose, /not/ the conjugate-transpose:+  -- it is the bilinear pairing, so it must not conjugate. See 'transpose'.+  dual = transpose+  dualInv = transpose+  linDist @(M x) @(M y) @(M z) (Mat m) = withMultNat @z @y $ Mat (concat (P.fmap (chunks @y @x) m))+  linDistInv @(M x) @(M y) @(M z) (Mat m) = withMultNat @y @x $ Mat (P.fmap concat (chunks @z @y m))+  doubleNeg = id+  doubleNegInv = id++instance (P.Num a) => CompactClosed (MatK a) where+  distribDual @m @n = withMultNat @(UN M m) @(UN M n) $ transpose (obj @m) ** transpose (obj @n)+  dualUnit = id+  dualityUnit @x = cup @x+  dualityCounit @x = cap @x++instance (P.Num a, MonoidalAction (t :: (MatK a, MatK a) +-> MatK a)) => Costrong t (Mat :: CAT (MatK a)) where+  coact @x = coactCC @t @x++-- | Monoids are associative, unital algebras.+instance (P.Num a, IsNat n) => Monoid (M n :: MatK a) where+  mempty = arr counit+  mappend = arr comult++instance (P.Num a, IsNat n) => Comonoid (M n :: MatK a) where+  counit = arr' counit+  comult = arr' comult+instance (P.Num a, IsNat n) => CocommutativeComonoid (M n :: MatK a)+instance (P.Num a, IsNat n) => Frobenius (M n :: MatK a)+instance (P.Num a, IsNat n) => CommutativeMonoid (M n :: MatK a)+instance (P.Num a) => Hypergraph (MatK a)+instance (P.Num a) => CopyDiscard (MatK a)++data family Conjugate :: MatK (Complex a) +-> MatK (Complex a)+instance (P.RealFloat a) => FunctorForRep (Conjugate :: MatK (Complex a) +-> MatK (Complex a)) where+  type Conjugate @ n = n+  fmap (Mat m) = Mat (P.fmap (P.fmap conjugate) m)++-- | Conjugation is a self-adjoint functor+instance (P.RealFloat a) => Corepresentable (Rep Conjugate :: MatK (Complex a) +-> MatK (Complex a)) where+  type Rep Conjugate %% n = n+  coindex (Rep f) = f+  cotabulate f = Rep f \\ f+  corepMap = fmap @Conjugate++instance (P.RealFloat a) => Involution (Rep Conjugate :: MatK (Complex a) +-> MatK (Complex a))+instance (P.RealFloat a) => MonoidalProfunctor (Rep Conjugate :: MatK (Complex a) +-> MatK (Complex a)) where+  one = Rep one+  Rep l ** Rep r = let lr = l ** r in Rep lr \\ lr++data family App :: MatK a +-> Type+instance (P.Num a) => FunctorForRep (App :: MatK a +-> Type) where+  type App @a @ M n = Vec n a+  fmap (Mat m) = app m+instance (P.Num a) => MonoidalProfunctor (Rep App :: MatK a +-> Type) where+  one = Rep \() -> 1 ::: VNil+  Rep @b f ** Rep @c g = withOb2 @_ @b @c $ Rep (\(x, y) -> concatMap (\a -> (a P.*) P.<$> f x) (g y))
+ src/Proarrow/Category/Instance/Monoid.hs view
@@ -0,0 +1,89 @@+-- | A monoid as a one-object category: the single object 'M', with the monoid's elements+-- @'Unit' ~> m@ as the morphisms. For a commutative monoid the tensor is the monoid operation+-- itself, making it symmetric monoidal, 'Closed', 'StarAutonomous' and 'CompactClosed', with a+-- cocommutative comonoid on @M@ and hence 'CopyDiscard'.+--+-- It is not cartesian or cocartesian: with one object, a terminal object needs a singleton+-- hom-set and binary products force @'combine' f g = f@, so both hold only for the trivial monoid.+module Proarrow.Category.Instance.Monoid where++import Data.Type.Nat (Nat (..))+import Prelude qualified as P++import Proarrow.Category.Enriched.Thin (Enumerable (..), Finite (..), Indexed (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..))+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomous (..))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault)+import Proarrow.Monoid (CocommutativeComonoid, CommutativeMonoid, Comonoid (..), Monoid (..), combine)++type data MONOID (m :: k) = M+data Mon a b where+  Mon :: Unit ~> m -> Mon (M :: MONOID m) M+instance (Monoid m) => Profunctor (Mon :: CAT (MONOID m)) where+  dimap = dimapDefault+  r \\ Mon{} = r+instance (Monoid m) => Promonad (Mon :: CAT (MONOID m)) where+  id = Mon mempty+  Mon f . Mon g = Mon (combine f g)++-- | A monoid as a one object category.+instance (Monoid m) => CategoryOf (MONOID m) where+  type (~>) = Mon+  type Ob a = a P.~ M++instance (CommutativeMonoid m) => MonoidalProfunctor (Mon :: CAT (MONOID m)) where+  one = Mon mempty+  Mon f ** Mon g = Mon (combine f g)+instance (CommutativeMonoid m) => Monoidal (MONOID m) where+  type Unit = M+  type M ** M = M+  withOb2 r = r+  leftUnitor = Mon mempty+  leftUnitorInv = Mon mempty+  rightUnitor = Mon mempty+  rightUnitorInv = Mon mempty+  associator = Mon mempty+  associatorInv = Mon mempty+instance (CommutativeMonoid m) => SymMonoidal (MONOID m) where+  swap = Mon mempty++instance (CommutativeMonoid m) => StarAutonomous (MONOID m) where+  type Dual (M :: MONOID m) = M+  withObDual r = r+  dual f@Mon{} = f+  dualInv f = f+  linDist _ = id+  linDistInv _ = id+  doubleNeg = id+  doubleNegInv = id+instance (CommutativeMonoid m) => CompactClosed (MONOID m) where+  distribDual = Mon mempty+  dualUnit = Mon mempty+  dualityUnit = Mon mempty+  dualityCounit = Mon mempty+instance (CommutativeMonoid m) => Closed (MONOID m) where+  type a ~~> b = M+  withObExp r = r+  curry (Mon m) = Mon m+  apply = Mon mempty++instance (CommutativeMonoid m) => Comonoid (M :: MONOID m) where+  counit = Mon mempty+  comult = Mon mempty+instance (CommutativeMonoid m) => CocommutativeComonoid (M :: MONOID m)+instance (CommutativeMonoid m) => CopyDiscard (MONOID m)++-- | A monoid is a one-object category, so its kind has one inhabitant, at index zero. This is+-- stated directly instead of left to the 'Objects' default, so that it reduces for a not-yet-known+-- inhabitant. That way 'withOb' learns there is only @'M'@.+instance Indexed (MONOID m) where+  type Index (a :: MONOID m) = 'Z++instance Finite (MONOID m) where type Objects (MONOID m) = '[M]++instance (Monoid m) => Enumerable (MONOID m) where+  withIndex r = r+  withOb r = r
+ src/Proarrow/Category/Instance/Nat.hs view
@@ -0,0 +1,260 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Functor categories: 'Nat' is the type of natural transformations between functors @j -> k@,+-- and the kind @j -> 'Data.Kind.Type'@ carries the category of 'Functor's with 'Nat' as its+-- morphisms and pointwise (co)limits. On @'Data.Kind.Type' -> 'Data.Kind.Type'@, functor+-- composition additionally gives a (closed) monoidal structure, the home of monads as monoids.+module Proarrow.Category.Instance.Nat where++import Data.Bifunctor qualified as P+import Data.Functor.Compose (Compose (..))+import Data.Functor.Const (Const (..))+import Data.Functor.Identity (Identity (..))+import Data.Functor.Product (Product (..))+import Data.Functor.Sum (Sum (..))+import Data.Kind (Type)+import Data.Void (Void, absurd)+import Prelude qualified as P++import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..))+import Proarrow.Category.Monoidal.Action (MonoidalAction (..))+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.Coclosed (Coclosed (..))+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..))+import Proarrow.Colimit.Copower (Copowered (..))+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Core (CAT, CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, dimapDefault, (//), type (+->))+import Proarrow.Functor (Functor (..), FunctorForRep (..), type (.~>))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..), PROD (..), Prod (..))+import Proarrow.Limit.Power (Powered (..))+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Monoid (Comonoid (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Representable (Rep)++type Nat :: CAT (j -> k)+data Nat f g where+  Nat+    :: (Functor f, Functor g)+    => {unNat :: f .~> g}+    -> Nat f g++(!) :: Nat f g -> a ~> b -> f a ~> g b+Nat f ! ab = f . map ab \\ ab++-- | The category of functors with target category Hask.+instance CategoryOf (k1 -> Type) where+  type (~>) = Nat+  type Ob f = Functor f++instance Promonad (Nat :: CAT (j -> Type)) where+  id @f = Nat (map @f id)+  Nat f . Nat g = Nat (f . g)++instance Profunctor (Nat :: CAT (k1 -> Type)) where+  dimap = dimapDefault+  r \\ Nat{} = r++instance Functor (:.:) where+  map (Prof n) = Nat (Prof \(p :.: q) -> n p :.: q)++instance (CategoryOf k1) => HasTerminalObject (k1 -> Type) where+  type TerminalObject = Const ()+  terminate = Nat \_ -> Const ()++instance (CategoryOf k1) => HasInitialObject (k1 -> Type) where+  type InitialObject = Const Void+  initiate = Nat \(Const v) -> absurd v++instance (Functor f, Functor g) => Functor (Product f g) where+  map f (Pair x y) = Pair (map f x) (map f y)++instance HasBinaryProducts (k1 -> Type) where+  type f && g = Product f g+  withObProd r = r+  fst = Nat \(Pair f _) -> f+  snd = Nat \(Pair _ g) -> g+  Nat f &&& Nat g = Nat \a -> Pair (f a) (g a)++instance (Functor f, Functor g) => Functor (Sum f g) where+  map f (InL x) = InL (map f x)+  map f (InR y) = InR (map f y)++instance HasBinaryCoproducts (k1 -> Type) where+  type f || g = Sum f g+  withObCoprod r = r+  lft = Nat InL+  rgt = Nat InR+  Nat f ||| Nat g = Nat \case+    InL x -> f x+    InR y -> g y++data (f :~>: g) a where+  Exp :: (Ob a) => (forall b. a ~> b -> f b -> g b) -> (f :~>: g) a++instance (Functor f, Functor g) => Functor (f :~>: g) where+  map ab (Exp k) = ab // Exp \bc fc -> k (bc . ab) fc++instance (CategoryOf k1) => Closed (PROD (k1 -> Type)) where+  type f ~~> g = PR (UN PR f :~>: UN PR g)+  withObExp r = r+  curry (Prod (Nat n)) = Prod (Nat \f -> Exp \ab g -> n (Pair (map ab f) g) \\ ab)+  apply = Prod (Nat \(Pair (Exp k) g) -> k id g)+  Prod (Nat m) ^^^ Prod (Nat n) = Prod (Nat \(Exp k) -> Exp \cd h -> m (k cd (n h)) \\ cd)++instance MonoidalProfunctor (Nat :: CAT (Type -> Type)) where+  one = id+  Nat n ** Nat m = Nat (\(Compose fg) -> Compose (n (map m fg)))++-- | Composition as monoidal tensor.+instance Monoidal (Type -> Type) where+  type Unit = Identity+  type f ** g = Compose f g+  withOb2 r = r+  leftUnitor = Nat (runIdentity . getCompose)+  leftUnitorInv = Nat (Compose . Identity)+  rightUnitor = Nat (map runIdentity . getCompose)+  rightUnitorInv = Nat (Compose . map Identity)+  associator = Nat (Compose . map Compose . getCompose . getCompose)+  associatorInv = Nat (Compose . Compose . map getCompose . getCompose)++type ApplyAction = Rep ApplyAction'+data family ApplyAction' :: (Type -> Type, Type) +-> Type+instance FunctorForRep ApplyAction' where+  type ApplyAction' @ '(f, x) = f x+  fmap (n :**: f) = n ! f+instance MonoidalAction ApplyAction where+  unitor = runIdentity+  unitorInv = Identity+  multiplicator = getCompose+  multiplicatorInv = Compose++type Ran :: (j -> k) -> (j -> Type) -> k -> Type+newtype Ran j h a = Ran {runRan :: forall b. (a ~> j b) -> h b}+instance (CategoryOf k) => Functor (Ran j h :: k -> Type) where+  map f (Ran k) = Ran \j -> k (j . f)+instance Closed (Type -> Type) where+  type j ~~> h = Ran j h+  withObExp r = r+  curry (Nat n) = Nat \fa -> Ran \ajb -> n (Compose (map ajb fa))+  apply = Nat \(Compose fja) -> runRan fja id+  (^^^) (Nat by) (Nat xa) = Nat \h -> Ran \x -> by (runRan h (xa . x))++type Lan :: (j -> k) -> (j -> Type) -> k -> Type+data Lan j f a where+  Lan :: (j b ~> a) -> f b -> Lan j f a+instance (CategoryOf k) => Functor (Lan j f :: k -> Type) where+  map g (Lan k f) = Lan (g . k) f+instance Coclosed (Type -> Type) where+  type f <~~ j = Lan j f+  withObCoExp r = r+  coeval = Nat (Compose . Lan id)+  coevalUniv (Nat n) = Nat \(Lan k f) -> map k (getCompose (n f))++data (f :^: n) a where+  Power :: (Ob a) => {unPower :: n -> f a} -> (f :^: n) a+instance (Functor f) => Functor (f :^: n) where+  map g (Power k) = g // Power \n -> map g (k n)+instance Powered Type (k -> Type) where+  type f ^ n = f :^: n+  withObPower r = r+  power f = Nat \g -> Power \n -> unNat (f n) g+  unpower (Nat f) n = Nat \g -> unPower (f g) n++data (n :*.: f) a where+  Copower :: (Ob a) => {unCopower :: (n, f a)} -> (n :*.: f) a+instance (Functor f) => Functor (n :*.: f) where+  map g (Copower (n, f)) = g // Copower (n, map g f)+instance Copowered Type (k -> Type) where+  type n *. f = n :*.: f+  withObCopower r = r+  copower f = Nat \(Copower (n, g)) -> unNat (f n) g+  uncopower (Nat f) n = Nat \p -> f (Copower (n, p))++data CatAsComonoid k a where+  CatAsComonoid :: forall {k} (c :: k) a. (Ob c) => (forall c'. c ~> c' -> a) -> CatAsComonoid k a+instance Functor (CatAsComonoid k) where+  map f (CatAsComonoid k) = CatAsComonoid (f . k)++instance (CategoryOf k) => Comonoid (CatAsComonoid k) where+  counit = Nat \(CatAsComonoid k) -> Identity (k id)+  comult = Nat \(CatAsComonoid @a k) ->+    Compose+      ( CatAsComonoid @a+          \(f :: a ~> b) ->+            f // CatAsComonoid @b+              \g -> k (g . f)+      )++-- | The coKleisli category of a comonoid @w@ in the functor category: an arrow from @a@ to @b@+-- is a map @w a -> b@.+data ComonoidAsCat (w :: Type -> Type) a b where+  ComonoidAsCat :: (w a -> b) -> ComonoidAsCat w a b++instance (Functor w) => Profunctor (ComonoidAsCat w) where+  dimap f g (ComonoidAsCat h) = ComonoidAsCat (g . h . map f)++instance (Comonoid w) => Promonad (ComonoidAsCat w) where+  id = ComonoidAsCat (runIdentity . unNat counit)+  ComonoidAsCat f . ComonoidAsCat g = ComonoidAsCat (f . map g . getCompose . unNat comult)++-- | The category of functors with target category @k2 -> k3 -> Type@.+-- @CategoryOf (k1 -> k2 -> Type)@ is reserved for profunctors.+instance CategoryOf (k1 -> k2 -> k3 -> Type) where+  type (~>) = Nat+  type Ob f = Functor f++instance Promonad (Nat :: CAT (k1 -> k2 -> k3 -> Type)) where+  id @f = Nat (map @f id)+  Nat f . Nat g = Nat (f . g)++instance Profunctor (Nat :: CAT (k1 -> k2 -> k3 -> Type)) where+  dimap f g h = g . h . f+  r \\ Nat{} = r++-- | The category of functors with target category k2 -> k3 -> k4 -> Type.+instance CategoryOf (k1 -> k2 -> k3 -> k4 -> Type) where+  type (~>) = Nat+  type Ob f = Functor f++instance Promonad (Nat :: CAT (k1 -> k2 -> k3 -> k4 -> Type)) where+  id @f = Nat (map @f id)+  Nat f . Nat g = Nat (f . g)++instance Profunctor (Nat :: CAT (k1 -> k2 -> k3 -> k4 -> Type)) where+  dimap f g h = g . h . f+  r \\ Nat{} = r++newtype j .-> k = NT (j -> k)++data Nat' f g where+  Nat'+    :: (Functor f, Functor g)+    => {unNat' :: f .~> g}+    -> Nat' (NT f) (NT g)++-- | The category of functors and natural transformations.+instance CategoryOf (j .-> k) where+  type (~>) = Nat'+  type Ob f = (Is NT f, Functor (UN NT f))++instance Promonad (Nat' :: CAT (j .-> k)) where+  id @(NT f) = Nat' (map @f id)+  Nat' f . Nat' g = Nat' (f . g)++instance Profunctor (Nat' :: CAT (j .-> k)) where+  dimap = dimapDefault+  r \\ Nat'{} = r++instance Functor P.Either where map f = Nat (P.first f)+instance Functor (,) where map f = Nat (P.first f)++first :: (Functor (f :: i -> j -> k), (~>) P.~ (Nat :: CAT (j -> k)), Ob c) => (a ~> b) -> f a c ~> f b c+first f = unNat (map f)++bimap+  :: (Functor (f :: i -> j -> k), (~>) P.~ (Nat :: CAT (j -> k)), Functor (f a))+  => a ~> c -> b ~> d -> f a b ~> f c d+bimap l r = first l . map r \\ r
+ src/Proarrow/Category/Instance/Opposite.hs view
@@ -0,0 +1,97 @@+-- | The __opposite category__: the kind @'OPPOSITE' k@ wraps @k@ in 'OP', and an arrow+-- @'OP' a '~>' 'OP' b@ is an arrow @b '~>' a@ of @k@. 'Op' (and its inverse 'UnOp') also flips+-- profunctors, swapping their two arguments. This is the prototypical use of a newtype wrapper on+-- a kind to give one collection of types a second category structure.+module Proarrow.Category.Instance.Opposite where++import Proarrow.Category.Enriched.Thin+  ( AtOb (..)+  , DecidableProfunctor (..)+  , Enumerable (..)+  , Finite (..)+  , FmapWrap+  , Indexed (..)+  , MapWrap+  , Thin+  , ThinProfunctor (..)+  , atOb+  , mapDecision+  , withWrapAtLookup+  , wrapFinite+  )+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), UN, WrappedOb, lmap, type (+->))+import Proarrow.Functor (Functor (..))++type data OPPOSITE k = OP k++-- | Flips the two arguments of a profunctor, giving a profunctor between the 'OPPOSITE'+-- categories; at @p = ('~>')@ this is the hom of the opposite category.+type Op :: j +-> k -> OPPOSITE k +-> OPPOSITE j+data Op p a b where+  Op :: {unOp :: p b a} -> Op p (OP a) (OP b)++instance (Profunctor p) => Functor (Op p a) where+  map (Op f) (Op p) = Op (lmap f p)++instance (Profunctor p) => Profunctor (Op p) where+  dimap (Op l) (Op r) = Op . dimap r l . unOp+  r \\ Op f = r \\ f++instance Functor Op where+  map (Prof n) = Prof \(Op p) -> Op (n p)++-- | The opposite category of the category of `k`.+instance (CategoryOf k) => CategoryOf (OPPOSITE k) where+  type (~>) = Op (~>)+  type Ob a = WrappedOb OP a++instance (Promonad c) => Promonad (Op c) where+  id = Op id+  Op f . Op g = Op (g . f)++instance (ThinProfunctor p) => ThinProfunctor (Op p) where+  type HasArrow (Op p) (OP a) (OP b) = HasArrow p b a+  arr = Op arr+  withArr (Op f) r = withArr f r++instance (DecidableProfunctor p) => DecidableProfunctor (Op p) where+  type Holds (Op p) (OP a) (OP b) = Holds p b a+  decide @(OP a) @(OP b) = mapDecision Op (decide @p @b @a)+  toHolds (Op f) r = toHolds f r++-- | Inverse to 'Op': unwraps a profunctor between 'OPPOSITE' categories to one between the+-- underlying kinds.+type UnOp :: OPPOSITE k +-> OPPOSITE j -> j +-> k+data UnOp p a b where+  UnOp :: {unUnOp :: p (OP b) (OP a)} -> UnOp p a b++instance (CategoryOf j, CategoryOf k, Profunctor p) => Profunctor (UnOp p :: j +-> k) where+  dimap l r = UnOp . dimap (Op r) (Op l) . unUnOp+  r \\ UnOp f = r \\ f++instance (Thin j, Thin k, ThinProfunctor p) => ThinProfunctor (UnOp p :: j +-> k) where+  type HasArrow (UnOp p) a b = HasArrow p (OP b) (OP a)+  arr = unOp arr+  withArr f r = withArr (Op f) r++instance (Thin j, Thin k, DecidableProfunctor p) => DecidableProfunctor (UnOp p :: j +-> k) where+  type Holds (UnOp p) a b = Holds p (OP b) (OP a)+  decide @a @b = mapDecision UnOp (decide @p @(OP b) @(OP a))+  toHolds (UnOp f) r = toHolds f r++-- | The opposite category has the same objects, numbered the same way.+instance (Indexed k) => Indexed (OPPOSITE k) where+  type Index (a :: OPPOSITE k) = Index (UN OP a)+  type At (OPPOSITE k) i = FmapWrap OP (At k i)++instance (Finite k) => Finite (OPPOSITE k) where+  type Objects (OPPOSITE k) = MapWrap OP (Objects k)+  finite = wrapFinite @OP+  withAtLookup = withWrapAtLookup @OP++instance (Enumerable k) => Enumerable (OPPOSITE k) where+  withIndex @(OP a) r = withIndex @k @a r+  atOb i = case atOb @k i of+    AtJust -> AtJust+    AtNothing -> AtNothing
+ src/Proarrow/Category/Instance/Ordinal.hs view
@@ -0,0 +1,423 @@+-- | The finite ordinal @n@ as a thin category: the kind @'ORDINAL' n@ has objects @'OZ', 'OS' 'OZ',+-- ...@ (@n@ of them), with an arrow @a '~>' b@ when and only when @a <= b@ ('LTE'). This is the+-- linear order on @n@ elements. Small enough that (co)equalizers can be computed by explicit case+-- analysis.+module Proarrow.Category.Instance.Ordinal where++import Data.Kind (Constraint, Type)+import Data.Type.Nat (Nat (..), SNat (..), SNatI, snat)+import Prelude (Maybe (..), type (~))++import Proarrow.Category.Enriched.Thin+  ( AtOb (..)+  , DecidableProfunctor (..)+  , Decision (..)+  , Enumerable (..)+  , Finite (..)+  , FmapWrap+  , Indexed (..)+  , IndexedList (..)+  , Lookup+  , MapWrap+  , ThinProfunctor (..)+  , mapDecision+  , mapWrap+  , withLookupMapWrap+  )+import Proarrow.Category.Instance.Bool (BOOL (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Distributive (Distributive (..))+import Proarrow.Category.Topos (HasEpiMonoFactorization (..))+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..))+import Proarrow.Colimit.Coequalizer (HasCoequalizers (..), thinCoequalize)+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Colimit.Pushout (HasPushouts (..))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault, obj)+import Proarrow.Limit.BinaryProduct+  ( HasBinaryProducts (..)+  , HasProducts+  , associatorProd+  , associatorProdInv+  , diag+  , leftUnitorProd+  , leftUnitorProdInv+  , rightUnitorProd+  , rightUnitorProdInv+  , swapProd+  )+import Proarrow.Limit.Equalizer (HasEqualizers (..), thinEqualize)+import Proarrow.Limit.Pullback (HasPullbacks (..))+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Monoid (CocommutativeComonoid, Comonoid (..))+import Prelude qualified as P++type data ORDINAL n where+  OZ :: ORDINAL (S n)+  OS :: ORDINAL (S n) -> ORDINAL (S (S n))++type ORDINAL0 = ORDINAL Z+type ORDINAL1 = ORDINAL (S Z)+type ORDINAL2 = ORDINAL (S (S Z))+type ORDINAL3 = ORDINAL (S (S (S Z)))++type LTE :: forall {n :: Nat}. CAT (ORDINAL n)+data LTE a b where+  ZEQ :: LTE OZ OZ+  ZLT :: LTE OZ b -> LTE OZ (OS b)+  SLT :: LTE a b -> LTE (OS a) (OS b)++-- | @'ORDINAL' 'Z'@ is the empty ordinal, so an object of it is a contradiction: @'LTE' a a@ has+-- no constructor that can match at this kind, and the empty case discharges any goal.+absurdL :: forall (a :: ORDINAL Z) b. (Ob a) => a ~> b+absurdL = case obj @a of {}++absurdR :: forall a (b :: ORDINAL Z). (Ob b) => a ~> b+absurdR = case obj @b of {}++type SOrdinal :: forall {n :: Nat}. ORDINAL n -> Type+data SOrdinal a where+  SOZ :: SOrdinal OZ+  SOS :: (IsOrdinal a) => SOrdinal (OS a)++type IsOrdinal :: forall {n :: Nat}. ORDINAL n -> Constraint+class IsOrdinal (a :: ORDINAL n) where+  singOrdinal :: SOrdinal a+instance IsOrdinal OZ where+  singOrdinal = SOZ+instance (IsOrdinal b) => IsOrdinal (OS b) where+  singOrdinal = SOS++-- | Each ordinal is numbered by itself: @'OZ'@ is zero and @'OS'@ the successor.+type OrdIndex :: forall {n :: Nat}. ORDINAL n -> Nat+type family OrdIndex a where+  OrdIndex OZ = Z+  OrdIndex (OS a) = S (OrdIndex a)++type OrdAt :: forall (n :: Nat) -> Nat -> Maybe (ORDINAL n)+type family OrdAt n i where+  OrdAt Z i = 'Nothing+  OrdAt (S n) Z = 'Just OZ+  OrdAt (S Z) (S i) = 'Nothing+  OrdAt (S (S n)) (S i) = FmapWrap OS (OrdAt (S n) i)++-- | The ordinals of @'ORDINAL' n@, in order.+type OrdObjects :: forall (n :: Nat) -> [ORDINAL n]+type family OrdObjects n where+  OrdObjects Z = '[]+  OrdObjects (S Z) = '[OZ]+  OrdObjects (S (S n)) = OZ ': MapWrap OS (OrdObjects (S n))++instance Indexed (ORDINAL n) where+  type Index (a :: ORDINAL n) = OrdIndex a+  type At (ORDINAL n) i = OrdAt n i++instance (SNatI n) => Finite (ORDINAL n) where+  type Objects (ORDINAL n) = OrdObjects n+  finite = withOrdObjects @n SZ P.id+  withAtLookup i r = withOrdObjects @n i (P.const r)++-- | An ordinal count is none, one, or more. It needs three cases, and not the two of 'Nat', because+-- @'OS'@ lands in @'ORDINAL' ('S' ('S' n))@, so @'ORDINAL' ('S' 'Z')@ holds only @'OZ'@.+ordSize+  :: forall n r+   . (SNatI n)+  => ((n ~ Z) => r) -> ((n ~ S Z) => r) -> (forall m. (n ~ S (S m), SNatI m) => r) -> r+ordSize none single more = case snat @n of+  SZ -> none+  SS @m -> case snat @m of+    SZ -> single+    SS -> more++-- | The ordinals of @'ORDINAL' n@ together with the proof that the list tabulates 'OrdAt' at one index.+-- The two are produced by the same recursion, so each level builds the shorter list once and both+-- the proof and the longer list use it.+withOrdObjects+  :: forall n i r+   . (SNatI n)+  => SNat i -> ((Lookup (OrdObjects n) i ~ OrdAt n i) => IndexedList (OrdObjects n) -> r) -> r+withOrdObjects i k =+  ordSize @n+    (k FNil)+    (case i of SZ -> k (FCons FNil); SS -> k (FCons FNil))+    ( \ @m -> case i of+        SZ -> withOrdObjects @(S m) SZ \xs -> k (FCons (mapWrap @OS xs))+        SS @i' -> withOrdObjects @(S m) (snat @i') \xs ->+          withLookupMapWrap @OS (snat @i') xs (k (FCons (mapWrap @OS xs)))+    )++-- | The ordinal at an index, if there is one. 'Enumerable' cannot go through the generic 'atOb',+-- which is defined in terms of the 'withOb' being given here, so the walk is done by recursion+-- on the index instead of on the object list.+ordAtOb :: forall n i. (SNatI n) => SNat i -> AtOb (ORDINAL n) (OrdAt n i)+ordAtOb i =+  ordSize @n+    AtNothing+    (case i of SZ -> AtJust; SS -> AtNothing)+    ( \ @m -> case i of+        SZ -> AtJust+        SS @i' -> case ordAtOb @(S m) (snat @i') of+          AtNothing -> AtNothing+          AtJust -> AtJust+    )++instance (SNatI n) => Enumerable (ORDINAL n) where+  withIndex @a r = case singOrdinal @a of+    SOZ -> r+    SOS @a' -> case snat @n of SS -> withIndex @_ @a' r+  atOb = ordAtOb++instance Profunctor LTE where+  dimap = dimapDefault+  r \\ ZEQ = r+  r \\ ZLT b = r \\ b+  r \\ SLT ab = r \\ ab+instance Promonad LTE where+  id @a = case singOrdinal @a of+    SOZ -> ZEQ+    SOS -> SLT id+  ZEQ . ZEQ = ZEQ+  ZLT b . ZEQ = ZLT b+  SLT ab . ZLT za = ZLT (ab . za)+  SLT ab . SLT bc = SLT (ab . bc)++-- | The (thin) category of finite ordinals. An arrow from a to b means that a is less than or equal to b.+instance CategoryOf (ORDINAL n) where+  type (~>) = LTE+  type Ob a = IsOrdinal a++-- | @a <= b@ on the ordinal, as a 'BOOL'.+type OrdLeq :: forall {n :: Nat}. ORDINAL n -> ORDINAL n -> BOOL+type family OrdLeq a b where+  OrdLeq OZ b = TRU+  OrdLeq (OS a) OZ = FLS+  OrdLeq (OS a) (OS b) = OrdLeq a b++instance ThinProfunctor LTE++instance DecidableProfunctor LTE where+  type Holds LTE a b = OrdLeq a b+  decide @a @b = case (singOrdinal @a, singOrdinal @b) of+    (SOZ, SOZ) -> Yes ZEQ+    (SOZ, SOS @b') -> mapDecision ZLT (decide @LTE @OZ @b')+    (SOS, SOZ) -> No+    (SOS @a', SOS @b') -> mapDecision SLT (decide @LTE @a' @b')+  toHolds ZEQ r = r+  toHolds (ZLT b) r = toHolds b r+  toHolds (SLT ab) r = toHolds ab r++instance HasInitialObject (ORDINAL (S n)) where+  type InitialObject = OZ+  initiate @a = case singOrdinal @a of+    SOZ -> ZEQ+    SOS @a' -> ZLT (initiate @_ @a')++instance HasTerminalObject (ORDINAL (S Z)) where+  type TerminalObject = OZ+  terminate @a = case singOrdinal @a of SOZ -> ZEQ++instance (HasTerminalObject (ORDINAL (S n))) => HasTerminalObject (ORDINAL (S (S n))) where+  type TerminalObject = OS TerminalObject+  terminate @a = case singOrdinal @a of+    SOZ -> ZLT terminate+    SOS @a' -> SLT (terminate @_ @a')++instance HasBinaryCoproducts (ORDINAL Z) where+  type a || b = a+  withObCoprod r = r+  lft = absurdR+  rgt = absurdR+  (|||) = \case {}++instance HasBinaryCoproducts (ORDINAL (S Z)) where+  type OZ || OZ = OZ+  withObCoprod @a @b r = case (singOrdinal @a, singOrdinal @b) of (SOZ, SOZ) -> r+  lft @a @b = case (singOrdinal @a, singOrdinal @b) of (SOZ, SOZ) -> ZEQ+  rgt @a @b = case (singOrdinal @a, singOrdinal @b) of (SOZ, SOZ) -> ZEQ+  ZEQ ||| ZEQ = ZEQ++-- | Maximum+instance (HasBinaryCoproducts (ORDINAL (S n))) => HasBinaryCoproducts (ORDINAL (S (S n))) where+  type OZ || b = b+  type a || OZ = a+  type OS a || OS b = OS (a || b)+  withObCoprod @a @b r = case singOrdinal @a of+    SOZ -> r+    SOS @a' -> case singOrdinal @b of+      SOZ -> r+      SOS @b' -> withObCoprod @(ORDINAL (S n)) @a' @b' r++  lft @a @b = case singOrdinal @b of+    SOZ -> obj @a+    SOS @b' -> case singOrdinal @a of+      SOZ -> ZLT (initiate @_ @b')+      SOS @a' -> SLT (lft @_ @a' @b')++  rgt @a @b = case singOrdinal @a of+    SOZ -> obj @b+    SOS @a' -> case singOrdinal @b of+      SOZ -> ZLT (initiate @_ @a')+      SOS @b' -> SLT (rgt @_ @a' @b')++  ZEQ ||| ZEQ = ZEQ+  ZLT ZEQ ||| a = a+  a ||| ZLT ZEQ = a+  ZLT a@ZLT{} ||| ZLT b@ZLT{} = ZLT (a ||| b)+  ZLT a@ZLT{} ||| SLT bc = SLT (a ||| bc)+  SLT ab ||| ZLT c@ZLT{} = SLT (ab ||| c)+  SLT a ||| SLT b = SLT (a ||| b)++instance HasBinaryProducts (ORDINAL Z) where+  type a && b = a+  withObProd r = r+  fst = absurdR+  snd = absurdR+  (&&&) = \case {}++instance HasBinaryProducts (ORDINAL (S Z)) where+  type OZ && OZ = OZ+  withObProd @a @b r = case (singOrdinal @a, singOrdinal @b) of (SOZ, SOZ) -> r+  fst @a @b = case (singOrdinal @a, singOrdinal @b) of (SOZ, SOZ) -> ZEQ+  snd @a @b = case (singOrdinal @a, singOrdinal @b) of (SOZ, SOZ) -> ZEQ+  ZEQ &&& ZEQ = ZEQ++-- | Minimum+instance (HasBinaryProducts (ORDINAL (S n))) => HasBinaryProducts (ORDINAL (S (S n))) where+  type OZ && b = OZ+  type a && OZ = OZ+  type OS a && OS b = OS (a && b)+  withObProd @a @b r = case singOrdinal @a of+    SOZ -> r+    SOS @a' -> case singOrdinal @b of+      SOZ -> r+      SOS @b' -> withObProd @_ @a' @b' r++  fst @a @b = case singOrdinal @b of+    SOZ -> initiate @_ @a+    SOS @b' -> case singOrdinal @a of+      SOZ -> ZEQ+      SOS @a' -> SLT (fst @_ @a' @b')++  snd @a @b = case singOrdinal @a of+    SOZ -> initiate @_ @b+    SOS @a' -> case singOrdinal @b of+      SOZ -> ZEQ+      SOS @b' -> SLT (snd @_ @a' @b')++  ZEQ &&& ZEQ = ZEQ+  ZLT _ &&& ZEQ = ZEQ+  ZEQ &&& ZLT _ = ZEQ+  ZLT a &&& ZLT b = ZLT (a &&& b)+  SLT a &&& SLT b = SLT (a &&& b)++-- | The meet as tensor and the top as unit: the cartesian monoidal structure. Like the products it+-- is made of, only for a syntactically concrete @n@. 'MonoidalOrdinal' names the context.+type MonoidalOrdinal :: Nat -> Constraint+type MonoidalOrdinal n = (HasProducts (ORDINAL n), Ob (TerminalObject :: ORDINAL n))++-- The second conjunct looks redundant, since 'Ob' 'TerminalObject' is a superclass of+-- 'HasTerminalObject'. It is not: 'Monoidal' needs @'Ob' 'Unit'@ as a superclass of the instance+-- /declaration/, and GHC does not discharge an instance's own superclasses from the superclasses+-- of its context (see "Undecidable instances and loopy superclasses" in the GHC user's guide).+-- Without it the instance fails with @Could not deduce IsOrdinal TerminalObject@.++instance (MonoidalOrdinal n) => MonoidalProfunctor (LTE :: CAT (ORDINAL n)) where+  one = id+  f ** g = f *** g++instance (MonoidalOrdinal n) => Monoidal (ORDINAL n) where+  type Unit = TerminalObject+  type a ** b = a && b+  withOb2 @a @b = withObProd @(ORDINAL n) @a @b+  leftUnitor = leftUnitorProd+  leftUnitorInv = leftUnitorProdInv+  rightUnitor = rightUnitorProd+  rightUnitorInv = rightUnitorProdInv+  associator @a @b @c = associatorProd @a @b @c+  associatorInv @a @b @c = associatorProdInv @a @b @c++instance (MonoidalOrdinal n) => SymMonoidal (ORDINAL n) where+  swap @a @b = swapProd @a @b++-- | Every object is a comonoid by the diagonal and the map to the top. So the chain is+-- 'CopyDiscard', and hence 'Proarrow.Category.Monoidal.Cartesian.Cartesian'.+instance (MonoidalOrdinal n, Ob a) => Comonoid (a :: ORDINAL n) where+  counit = terminate+  comult = diag++instance (MonoidalOrdinal n, Ob a) => CocommutativeComonoid (a :: ORDINAL n)++instance (MonoidalOrdinal n) => CopyDiscard (ORDINAL n)++instance Distributive (ORDINAL (S Z)) where+  distL @a @b @c = case (singOrdinal @a, singOrdinal @b, singOrdinal @c) of (SOZ, SOZ, SOZ) -> ZEQ+  distR @a @b @c = case (singOrdinal @a, singOrdinal @b, singOrdinal @c) of (SOZ, SOZ, SOZ) -> ZEQ+  absorbL @a = case singOrdinal @a of SOZ -> ZEQ+  absorbR @a = case singOrdinal @a of SOZ -> ZEQ++-- | A chain is a distributive lattice: the meet is the minimum and the join the maximum. By+-- recursion on the objects, as the products and coproducts are. A bottom on either side makes+-- both sides the same object, and otherwise both sides are a successor.+instance (Distributive (ORDINAL (S n)), MonoidalOrdinal (S n)) => Distributive (ORDINAL (S (S n))) where+  distL @a @b @c = case singOrdinal @a of+    SOZ -> ZEQ+    SOS @a' -> case singOrdinal @b of+      SOZ -> withObProd @_ @a @c (obj @(a && c))+      SOS @b' -> case singOrdinal @c of+        SOZ -> withObProd @_ @a @b (obj @(a && b))+        SOS @c' -> SLT (distL @_ @a' @b' @c')+  distR @a @b @c = case singOrdinal @c of+    SOZ -> ZEQ+    SOS @c' -> case singOrdinal @a of+      SOZ -> withObProd @_ @b @c (obj @(b && c))+      SOS @a' -> case singOrdinal @b of+        SOZ -> withObProd @_ @a @c (obj @(a && c))+        SOS @b' -> SLT (distR @_ @a' @b' @c')+  absorbL = ZEQ+  absorbR = ZEQ++-- | @LTE@ is thin, so equalizers are trivial. @factorEqualizer incl h@ just needs @h@'s domain to be+-- @<=@ @incl@'s domain. Since both share the codomain @x@, this can only fail when @incl@'s+-- domain is @OZ@ (nothing below it) but @h@'s domain is a successor (necessarily above @OZ@).+instance HasEqualizers (ORDINAL n) where+  equalize = thinEqualize+  factorEqualizer ZEQ ZEQ = ZEQ+  factorEqualizer (ZLT _) (ZLT _) = ZEQ+  factorEqualizer (SLT @e0 incl) (ZLT _) = ZLT (initiate @_ @e0 \\ incl)+  factorEqualizer (SLT incl) (SLT h) = SLT (factorEqualizer incl h)+  factorEqualizer (ZLT _) (SLT _) = P.error "factorEqualizer: h's image must lie within incl's image"++-- | Dual to the 'HasEqualizers' instance above.+instance HasCoequalizers (ORDINAL n) where+  coequalize = thinCoequalize+  factorCoequalizer ZEQ ZEQ = ZEQ+  factorCoequalizer ZEQ (ZLT @c0' h) = ZLT (initiate @_ @c0' \\ h)+  factorCoequalizer (ZLT _) ZEQ = P.error "factorCoequalizer: h must be constant on q's fibers"+  factorCoequalizer (ZLT q) (ZLT h) = SLT (factorCoequalizer q h)+  factorCoequalizer (SLT q) (SLT h) = SLT (factorCoequalizer q h)++-- | Pullbacks in a thin category are just meets. Computed directly, not via+-- 'Proarrow.Limit.Pullback.thinPullback', which would need @HasProducts (ORDINAL n)@. That is+-- unavailable for an abstract @n@, since 'HasBinaryProducts' and 'HasTerminalObject' are only+-- resolvable for a syntactically concrete @n@.+instance HasPullbacks (ORDINAL n) where+  pullback (ZLT _) (ZLT _) k = k ZEQ ZEQ+  pullback (ZLT _) (SLT @b' g) k = k ZEQ (ZLT (initiate @_ @b' \\ g))+  pullback (SLT @a' f) (ZLT _) k = k (ZLT (initiate @_ @a' \\ f)) ZEQ+  pullback (SLT f) (SLT g) k = pullback f g \p1 p2 -> k (SLT p1) (SLT p2)+  pullback ZEQ ZEQ k = k ZEQ ZEQ++  -- @p1@ and @k1@ already share a codomain (@a@), which is all 'factorEqualizer' needs to compare+  -- @q@ against @p@. @p2@/@k2@ carry no extra information once @p1, p2@ are known to be a pullback.+  factorPullback p1 _ k1 _ = factorEqualizer p1 k1++-- | Dual to the 'HasPullbacks' instance above: pushouts in a thin category are joins.+instance HasPushouts (ORDINAL n) where+  pushout ZEQ g k = k g (id \\ g)+  pushout f ZEQ k = k (id \\ f) f+  pushout (ZLT f) (ZLT g) k = pushout f g \q1 q2 -> k (SLT q1) (SLT q2)+  pushout (SLT f) (SLT g) k = pushout f g \q1 q2 -> k (SLT q1) (SLT q2)++  factorPushout p1 _ k1 _ = factorCoequalizer p1 k1++instance HasEpiMonoFactorization (ORDINAL n)
+ src/Proarrow/Category/Instance/Paths.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | The category __freely generated__ by a quiver @p@: an arrow is a finite path of generators+-- ('PCons' onto 'PNil'), and an object is simply a vertex.+--+-- This is "Proarrow.Category.Instance.Free" without structures. With no formal products or+-- exponentials to form, the objects can be the vertices themselves, with 'Ob' inherited from the+-- base kind, so an object of @'PATHS' p@ can be taken apart by whatever that 'Ob' provides. An+-- object of the free structured category cannot, since @Lower@\/@lowerOb@ never yields a value+-- indexed by a shape. An empty structure list does not help: the pattern checker cannot rule out+-- the @HasStructure@ given of @'Proarrow.Category.Instance.Free.St'@, so every consumer would carry+-- an unreachable branch.+--+-- __Equations__ are supported, by 'Rewrite'. Composition only adds an arrow at the outer end of+-- the spine, so each new arrow can be normalised against an already-normal path. With the default+-- 'rewrite' the category is free.+--+-- The base kind must be a category because 'foldPaths' interprets along a functor out of it, and+-- functors are representable profunctors here. Its arrows are never used, so the intended base is+-- a discrete one.+module Proarrow.Category.Instance.Paths where++import Data.Type.Equality ((:~:) (..))+import Prelude (Eq (..), Maybe (..), Show (..), showParen, showString)+import Prelude qualified as P++import Proarrow.Category.Enriched.Thin+  ( AtOb (..)+  , Enumerable (..)+  , Finite (..)+  , FmapWrap+  , Indexed (..)+  , MapWrap+  , withWrapAtLookup+  , wrapFinite+  )+import Proarrow.Core+  ( CAT+  , CategoryOf (..)+  , Profunctor (..)+  , Promonad (..)+  , Show2+  , UN+  , WrappedOb+  , dimapDefault+  , type (+->)+  )+import Proarrow.Profunctor.Representable (Representable (..))++-- | The objects of the free category on @p@: its vertices.+type data PATHS (p :: CAT k) = PTH k++-- | A path of generators, as a right-associated spine, so that the category laws hold+-- definitionally.+type Paths :: CAT (PATHS p)+data Paths a b where+  PNil :: (Ob a) => Paths (PTH a) (PTH a)+  PCons :: (Ob a, Ob b) => p a b -> Paths (i :: PATHS p) (PTH a) -> Paths i (PTH b)++-- | The equations of the generated category, as a rewriting system on paths. 'rewrite' is handed a+-- generator and the already-normalised path it is being composed onto, and returns the normal form+-- of the two together; the default keeps the path as it is, which generates the free category.+--+-- An equation is one clause. For @Secr ⨟ WorksIn = id@, match the junction and drop both arrows:+--+-- > rewrite WorksIn (PCons Secr more) = more+--+-- The whole tail is in scope, so a longer left-hand side can be matched, and recursing on the+-- result renormalises a junction the rewrite has just exposed.+--+-- __Confluence and termination are the caller's to establish.__ Nothing here checks them, and a+-- system that lacks them breaks associativity of composition silently. Two further obligations come+-- with any non-default instance: 'foldPaths' is a functor only for interpretations that respect the+-- equations, and so is any other consumer that matches on generators.+class Rewrite (p :: CAT k) where+  rewrite :: (Ob a, Ob b) => p a b -> Paths (i :: PATHS p) (PTH a) -> Paths i (PTH b)+  rewrite = PCons++-- | Decidable equality of generators, which also has to decide their sources: the object between+-- two arrows of a path is existential, so @'Eq' (p x y)@ alone cannot compare two spines.+-- ('Proarrow.Core.Eq2' does not serve. It is equality of arrows of a fixed category, as+-- 'Proarrow.Limit.Pullback.isMono' wants.)+class EqGen (p :: CAT k) where+  eqGen :: p x b -> p y b -> Maybe (x :~: y)++-- | Structural equality of paths. This is equality of arrows exactly when 'rewrite' is confluent+-- and every path was built through 'emb', 'id' and composition, which keep paths in normal form.+-- The free /structured/ category cannot offer this: there, equality has to be decided by folding+-- both sides into some category that identifies them.+instance (EqGen p) => Eq (Paths (a :: PATHS p) b) where+  PNil == PNil = P.True+  PCons q f == PCons q' g = case eqGen q q' of+    Just Refl -> f == g+    Nothing -> P.False+  _ == _ = P.False++instance (Show2 p) => Show (Paths (a :: PATHS p) b) where+  showsPrec _ PNil = showString "id"+  showsPrec d (PCons q PNil) = showsPrec d q+  showsPrec d (PCons q f) = showParen (d P.> 9) (showsPrec 10 q . showString " . " . showsPrec 10 f)++-- | How many generators a path is made of. With a non-default 'rewrite' this is a way to see that+-- an equation fired, since a path that reduces comes out shorter.+pathLength :: Paths a b -> P.Int+pathLength PNil = 0+pathLength (PCons _ f) = 1 P.+ pathLength f++-- | A single generator, normalised. Named as in "Proarrow.Category.Instance.Free".+emb :: (Ob a, Ob b, Rewrite p) => p a b -> (PTH a :: PATHS p) ~> PTH b+emb q = rewrite q PNil++-- | Interpret a path in any category, given an interpretation of the generators: the universal+-- property of the free category. A functor out of @'PATHS' p@ is a map of vertices plus such an+-- interpretation, with nothing to check, since a quiver has no composition to preserve.+--+-- The first argument supplies @'Ob'@ of an image object. It cannot come from @f@ by+-- 'Proarrow.Profunctor.Representable.withObRep': the usual caller is @f@\'s own 'fmap', which+-- would loop on the empty path. For unconstrained objects pass @\\r -> r@.+foldPaths+  :: forall {k} {k'} {p :: CAT k} (f :: PATHS p +-> k') a b+   . (Representable f)+  => (forall x r. (Ob x) => ((Ob (f % PTH x)) => r) -> r)+  -> (forall x y. (Ob x, Ob y) => p x y -> (f % PTH x) ~> (f % PTH y))+  -> (PTH a :: PATHS p) ~> PTH b+  -> (f % PTH a) ~> (f % PTH b)+foldPaths withObF pn = go+  where+    go :: forall x y. (PTH x :: PATHS p) ~> PTH y -> (f % PTH x) ~> (f % PTH y)+    go PNil = withObF @x id+    go (PCons q g) = pn q . go g++instance (CategoryOf k, Rewrite p) => CategoryOf (PATHS (p :: CAT k)) where+  type (~>) = Paths+  type Ob a = WrappedOb PTH a++-- | Objects are vertices, so a free category has as many of them as its quiver has, however many+-- arrows the paths add (usually unboundedly many). So a free category is 'Finite' without being+-- anywhere near thin or decidable. This buys enumeration of the objects alone. That is enough for+-- @Proarrow.Testing.genSomeFinite@ to derive a schema\'s object palette, and not enough for+-- anything that wants to enumerate arrows.+instance (Indexed k) => Indexed (PATHS (p :: CAT k)) where+  type Index (a :: PATHS p) = Index (UN PTH a)+  type At (PATHS (p :: CAT k)) i = FmapWrap PTH (At k i)++instance (Finite k) => Finite (PATHS (p :: CAT k)) where+  type Objects (PATHS (p :: CAT k)) = MapWrap PTH (Objects k)+  finite = wrapFinite @PTH+  withAtLookup = withWrapAtLookup @PTH++instance (Enumerable k, Rewrite p) => Enumerable (PATHS (p :: CAT k)) where+  withIndex @(PTH a) r = withIndex @k @a r+  atOb i = case atOb @k i of+    AtJust -> AtJust+    AtNothing -> AtNothing++instance (CategoryOf k, Rewrite p) => Promonad (Paths :: CAT (PATHS (p :: CAT k))) where+  id = PNil+  PNil . g = g+  PCons q f . g = rewrite q (f . g)++instance (CategoryOf k, Rewrite p) => Profunctor (Paths :: CAT (PATHS (p :: CAT k))) where+  dimap = dimapDefault+  r \\ PNil = r+  r \\ PCons _ f = r \\ f
+ src/Proarrow/Category/Instance/PointedHask.hs view
@@ -0,0 +1,197 @@+-- | The category of __pointed types__: objects are Haskell types with an added point (wrapped in+-- 'P'), and a morphism is a point-preserving function, represented as @a -> Maybe b@ ('Pt'). The+-- binary product is 'These' (each component present or the point) with @Void@ as terminal object,+-- and the coproduct identifies the two points (a wedge sum).+module Proarrow.Category.Instance.PointedHask where++import Control.Monad ((>=>))+import Data.Kind (Type)+import Data.Map.Lazy qualified as Map+import Data.Map.Merge.Lazy qualified as Map+import Data.Maybe qualified as P+import Data.Void (Void, absurd)+import GHC.Generics (Generic)+import Prelude (Eq, Maybe (..), Ord, Show, const, ($), (>>=), type (~))++import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Category.Monoidal.Applicative (Applicative (..))+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..))+import Proarrow.Colimit.Copower (Copowered (..))+import Proarrow.Colimit.Initial (HasInitialObject (..), HasZeroObject (..))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), UN, dimapDefault)+import Proarrow.Functor (Functor (..))+import Proarrow.Limit.BinaryProduct (FromProd (..), HasBinaryProducts (..), Prod (..))+import Proarrow.Limit.Power (Powered (..))+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Monoid (CocommutativeComonoid, Comonoid (..), Monoid (..))++type data POINTED = P Type++type Pointed :: CAT POINTED+data Pointed a b where+  Pt :: {unPt :: a -> Maybe b} -> Pointed (P a) (P b)++toHask :: P a ~> P b -> (Maybe a -> Maybe b)+toHask (Pt f) = (>>= f)++instance Profunctor Pointed where+  dimap = dimapDefault+  r \\ Pt{} = r+instance Promonad Pointed where+  id = Pt Just+  Pt f . Pt g = Pt (g >=> f)++-- | The category of types with an added point and point-preserving morphisms.+instance CategoryOf POINTED where+  type (~>) = Pointed+  type Ob a = (a ~ P (UN P a))++data These a b = This a | That b | These a b+  deriving (Eq, Show, Generic)+instance HasBinaryProducts POINTED where+  type P a && P b = P (These a b)+  withObProd r = r+  fst = Pt (\case This a -> Just a; That _ -> Nothing; These a _ -> Just a)+  snd = Pt (\case This _ -> Nothing; That b -> Just b; These _ b -> Just b)+  Pt f &&& Pt g =+    Pt+      ( \a -> case (f a, g a) of+          (Just a', Just b') -> Just (These a' b')+          (Just a', Nothing) -> Just (This a')+          (Nothing, Just b') -> Just (That b')+          (Nothing, Nothing) -> Nothing+      )+instance HasTerminalObject POINTED where+  type TerminalObject = P Void+  terminate = Pt (const Nothing)++instance HasBinaryCoproducts POINTED where+  type P a || P b = P (a || b)+  withObCoprod r = r+  lft = Pt (Just . lft)+  rgt = Pt (Just . rgt)+  Pt f ||| Pt g = Pt (f ||| g)+instance HasInitialObject POINTED where+  type InitialObject = P Void+  initiate = Pt absurd++instance MonoidalProfunctor Pointed where+  one = Pt Just+  Pt f ** Pt g = Pt (\(a, b) -> liftA2 id (f a, g b))++-- | The smash product of pointed sets.+-- Monoids relative to the smash product are absorption monoids.+instance Monoidal POINTED where+  type Unit = P ()+  type P a ** P b = P (a, b)+  withOb2 r = r+  leftUnitor = Pt (Just . snd)+  leftUnitorInv = Pt (Just . ((),))+  rightUnitor = Pt (Just . fst)+  rightUnitorInv = Pt (Just . (,()))+  associator = Pt (\((a, b), c) -> Just (a, (b, c)))+  associatorInv = Pt (\(a, (b, c)) -> Just ((a, b), c))++instance SymMonoidal POINTED where+  swap = Pt (Just . swap)++-- No 'Proarrow.Category.Monoidal.Closed.Closed' instance, though pointed sets are closed under the+-- smash product (<https://ncatlab.org/nlab/show/pointed+object#ClosedMonoidalStructure>): the+-- internal hom would need a type @x@ with @Maybe x ≅ (a -> Maybe b)@, the functions other than+-- @const Nothing@, and that is no Haskell type. @a -> Maybe b@ itself is too big by that one+-- function.++instance Powered Type POINTED where+  type P a ^ n = P (n -> Maybe a)+  withObPower r = r+  power f = Pt (\a -> Just \n -> unPt (f n) a)+  unpower (Pt f) n = Pt (f >=> ($ n))++instance Copowered Type POINTED where+  type n *. P a = P (n, a)+  withObCopower r = r+  copower f = Pt \(n, a) -> unPt (f n) a+  uncopower (Pt f) n = Pt \a -> f (n, a)++instance Monoid (P Void) where+  mempty = Pt (const Nothing)+  mappend = Pt (Just . fst)++-- | Lift Hask monoids.+memptyDefault :: (Monoid a) => Unit ~> P a+memptyDefault = Pt (Just . mempty)++mappendDefault :: (Monoid a) => P a ** P a ~> P a+mappendDefault = Pt (Just . mappend)++-- | Conjunction with False = Nothing, True = Just ()+instance Monoid (P ()) where+  mempty = memptyDefault+  mappend = mappendDefault++instance Monoid (P [a]) where+  mempty = memptyDefault+  mappend = mappendDefault++instance Comonoid (P x) where+  counit = Pt (Just . counit)+  comult = Pt (Just . comult)+instance CocommutativeComonoid (P x)+instance CopyDiscard POINTED++-- | Categories with a zero object can be seen as categories enriched in Pointed.+underlyingPt :: (HasZeroObject k) => (a :: k) ~> b -> Unit ~> P (a ~> b)+underlyingPt f = Pt \() -> Just f++enrichedPt :: (Ob (a :: k), Ob b, HasZeroObject k) => Unit ~> P (a ~> b) -> a ~> b+enrichedPt (Pt f) = P.fromMaybe zero (f ())++compPt :: (Ob (a :: k), Ob b, Ob c, HasZeroObject k) => P (b ~> c) ** P (a ~> b) ~> P (a ~> c)+compPt = Pt \(bc, ab) -> Just (bc . ab)++type FromPointed :: (Type -> Type) -> (POINTED -> Type)+data FromPointed f a where+  FromPointed :: {unFromPointed :: f a} -> FromPointed f (P a)++type Filterable f = Functor (FromPointed f)++mapMaybe :: (Filterable f) => (a -> Maybe b) -> f a -> f b+mapMaybe f = unFromPointed . map (Pt f) . FromPointed++instance Functor (FromPointed []) where+  map (Pt f) (FromPointed as) = FromPointed (P.mapMaybe f as)++instance Functor (FromPointed (Map.Map k)) where+  map (Pt f) (FromPointed m) = FromPointed (Map.mapMaybe f m)++-- | Not quite Align from the semialign package.+-- This requires being able to dynamically decide per position if it is included in the result.+-- So more like @merge@ from Data.Map.+type Align f = Applicative (FromProd (FromPointed f))++alignWith :: (Align f) => (These a b -> Maybe c) -> f a -> f b -> f c+alignWith f fa fb = unFromPointed $ unFromProd $ liftA2 (Prod (Pt f)) (FromProd (FromPointed fa), FromProd (FromPointed fb))++nil :: (Align f) => f a+nil = unFromPointed $ unFromProd $ pure (Prod (Pt (const Nothing))) ()++instance Applicative (FromProd (FromPointed [])) where+  pure a () = FromProd (FromPointed []) \\ a+  liftA2 (Prod (Pt f)) (FromProd (FromPointed fa), FromProd (FromPointed fb)) = FromProd (FromPointed (merge fa fb))+    where+      merge as [] = mapMaybe (f . This) as+      merge [] bs = mapMaybe (f . That) bs+      merge (a : as) (b : bs) = case f (These a b) of+        Nothing -> merge as bs+        Just c -> c : merge as bs++instance (Ord k) => Applicative (FromProd (FromPointed (Map.Map k))) where+  pure a () = FromProd (FromPointed Map.empty) \\ a+  liftA2 (Prod (Pt f)) (FromProd (FromPointed fa), FromProd (FromPointed fb)) = FromProd (FromPointed (merge fa fb))+    where+      merge =+        Map.merge+          (Map.mapMaybeMissing \_ a -> f (This a))+          (Map.mapMaybeMissing \_ b -> f (That b))+          (Map.zipWithMaybeMatched \_ a b -> f (These a b))
+ src/Proarrow/Category/Instance/Product.hs view
@@ -0,0 +1,100 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The __product of two categories__: the tuple kind @(j, k)@ is the category whose arrows are+-- pairs of arrows, @p ':**:' q@ being the corresponding product of profunctors. The projections+-- 'Fst'\/'Snd' and diagonal 'Diag' are provided as representable profunctors.+module Proarrow.Category.Instance.Product where++import Prelude (type (~))++import Data.Type.Nat (SNat (..), snat)++import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Proarrow.Category.Enriched.Thin+  ( CodiscreteProfunctor (..)+  , Discrete (..)+  , Enumerable (..)+  , Finite (..)+  , Indexed (..)+  , ThinProfunctor (..)+  )+import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..))+import Proarrow.Core (CategoryOf (..), Hom, Profunctor (..), Promonad (..), obj, type (+->))+import Proarrow.Functor (FunctorForRep (..))++type (:**:) :: j1 +-> k1 -> j2 +-> k2 -> (j1, j2) +-> (k1, k2)+data (c :**: d) a b where+  (:**:) :: {fstK :: c a1 b1, sndK :: d a2 b2} -> (c :**: d) '(a1, a2) '(b1, b2)++-- | The product of two categories.+instance (CategoryOf k1, CategoryOf k2) => CategoryOf (k1, k2) where+  type (~>) = (~>) :**: (~>)+  type Ob a = (a ~ '(Fst @ a, Snd @ a), Ob (Fst @ a), Ob (Snd @ a))++-- | The product promonad of promonads `p` and `q`.+instance (Promonad p, Promonad q) => Promonad (p :**: q) where+  id = id :**: id+  (f1 :**: f2) . (g1 :**: g2) = (f1 . g1) :**: (f2 . g2)++instance (Profunctor p, Profunctor q) => Profunctor (p :**: q) where+  dimap (l1 :**: l2) (r1 :**: r2) (f1 :**: f2) = dimap l1 r1 f1 :**: dimap l2 r2 f2+  r \\ (f :**: g) = r \\ f \\ g++instance (DaggerProfunctor p, DaggerProfunctor q) => DaggerProfunctor (p :**: q) where+  dagger (f :**: g) = dagger f :**: dagger g++instance (ThinProfunctor p, ThinProfunctor q) => ThinProfunctor (p :**: q) where+  type HasArrow (p :**: q) '(a1, a2) '(b1, b2) = (HasArrow p a1 b1, HasArrow q a2 b2)+  arr = arr :**: arr+  withArr (f :**: g) r = withArr f (withArr g r)++data family Fst :: (j, k) +-> j+instance (CategoryOf j, CategoryOf k) => FunctorForRep (Fst :: (j, k) +-> j) where+  type Fst @ '(a, b) = a+  fmap (f :**: _) = f++data family Snd :: (j, k) +-> k+instance (CategoryOf j, CategoryOf k) => FunctorForRep (Snd :: (j, k) +-> k) where+  type Snd @ '(a, b) = b+  fmap (_ :**: f) = f++data family Diag :: k +-> (k, k)+instance (CategoryOf k) => FunctorForRep (Diag :: k +-> (k, k)) where+  type Diag @ a = '(a, a)+  fmap f = f :**: f++checkDiscrete :: (Discrete j, Discrete k) => Hom (j, k) a b -> ((a ~ b) => r) -> r+checkDiscrete f r = withEq f r++-- Does not work+-- checkDiscreteProfunctor :: (DiscreteProfunctor p, DiscreteProfunctor q) => (p :**: q) a b -> r+-- checkDiscreteProfunctor f = exfalso f++checkCodiscreteProfunctor :: (CodiscreteProfunctor p, CodiscreteProfunctor q, Ob a, Ob b) => (p :**: q) a b+checkCodiscreteProfunctor = anyArr++-- | The product of two enumerable kinds is enumerable, but numbering one in general needs type-level+-- division to invert the pairing, which @fin@ does not provide, so this instance for+-- @(BOOL, BOOL)@ is numbered by hand. The order matches the value-level+-- 'Proarrow.Category.Enriched.Finitary.pairIndex' convention: first component slowest.+--+-- ("Proarrow.Category.Sheaf" uses this kind as the opens of a discrete two-point space: a pair of+-- booleans is a subset of @{x, y}@.)+instance Indexed (BOOL, BOOL)++instance Finite (BOOL, BOOL) where+  type Objects (BOOL, BOOL) = '[ '(FLS, FLS), '(FLS, TRU), '(TRU, FLS), '(TRU, TRU)]++instance Enumerable (BOOL, BOOL) where+  withIndex @a r = case obj @a of+    Fls :**: Fls -> r+    Fls :**: Tru -> r+    Tru :**: Fls -> r+    Tru :**: Tru -> r+  withOb @a r = case snat @(Index a) of+    SZ -> r+    SS @i -> case snat @i of+      SZ -> r+      SS @i' -> case snat @i' of+        SZ -> r+        SS @i'' -> case snat @i'' of SZ -> r
+ src/Proarrow/Category/Instance/Prof.hs view
@@ -0,0 +1,29 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The category of __profunctors__ @j '+->' k@ themselves: 'Prof' wraps a natural transformation+-- @p ':~>' q@, making the profunctor kind a category with profunctors as objects. This is one+-- hom-category of the bicategory of profunctors; the full bicategorical structure lives in the+-- @proarrow-equipment@ package.+module Proarrow.Category.Instance.Prof where++import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault, (:~>), type (+->))++type Prof :: CAT (j +-> k)+data Prof p q where+  Prof+    :: (Profunctor p, Profunctor q)+    => {unProf :: p :~> q}+    -> Prof p q++-- | The category of profunctors and natural transformations between them.+instance CategoryOf (j +-> k) where+  type (~>) = Prof+  type Ob p = Profunctor p++instance Promonad Prof where+  id = Prof id+  Prof f . Prof g = Prof (f . g)++instance Profunctor Prof where+  dimap = dimapDefault+  r \\ Prof{} = r
+ src/Proarrow/Category/Instance/Rel.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- Collected from https://www.clowderproject.com/tag/01D0.html++-- | __Relations__ as profunctors: a 'Relation' is a thin profunctor between discrete categories,+-- and this module collects the standard vocabulary of properties ('Functional', 'Total',+-- 'Injective', 'Surjective', 'Reflexive', 'Transitive', 'Symmetric', up to 'Preorder' and+-- 'Equivalence'), together with the 'Converse' relation.+module Proarrow.Category.Instance.Rel where++import Proarrow.Adjunction (Proadjunction (..))+import Proarrow.Category.Enriched.Dagger (DaggerProfunctor)+import Proarrow.Category.Enriched.Thin (DecidableProfunctor (..), Discrete, ThinProfunctor (..), mapDecision, withEq)+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), src, tgt, (:~>), type (+->))+import Proarrow.Profunctor.Corepresentable (Corepresentable (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Representable (Representable (..), repUniv)++class (ThinProfunctor p, Discrete j, Discrete k) => Relation (p :: j +-> k)+instance (ThinProfunctor p, Discrete j, Discrete k) => Relation (p :: j +-> k)++-- | The converse relation: @'Converse' p a b@ relates @a@ to @b@ exactly when @p@ relates @b@+-- to @a@.+type Converse :: (j +-> k) -> (k +-> j)+data Converse p a b where+  Converse :: p b a -> Converse p a b++instance (Relation p) => Profunctor (Converse p) where+  dimap f g (Converse p) = withEq f (withEq g (Converse p))+  r \\ Converse p = r \\ p++instance (Relation p) => ThinProfunctor (Converse p) where+  type HasArrow (Converse p) a b = HasArrow p b a+  arr = Converse arr+  withArr (Converse p) r = withArr p r++instance (Relation p, DecidableProfunctor p) => DecidableProfunctor (Converse p) where+  type Holds (Converse p) a b = Holds p b a+  decide @a @b = mapDecision Converse (decide @p @b @a)+  toHolds (Converse p) r = toHolds p r++instance (Relation p, Representable p) => Corepresentable (Converse p) where+  type (Converse p) %% a = p % a+  coindex (Converse p) = withEq (index p) (src p)+  cotabulate f = withEq f (Converse (tabulate f))+  corepMap f = let fb = repMap @p (tgt f) in withEq f fb \\ fb++asImplication+  :: forall a b p q r+   . (Relation p, Relation q) => p :~> q -> (Ob a, Ob b, HasArrow p a b) => ((HasArrow q a b, Ob a, Ob b) => r) -> r+asImplication n = withArr (n (arr @p @a @b))++class (Relation p) => Functional p where+  isFunctional :: p :.: Converse p :~> (~>)++reprIsFunctional :: (Relation p, Representable p) => p :.: Converse p :~> (~>)+reprIsFunctional (p :.: Converse p') = withEq (index p) (withEq (index p') (src p))++class (Relation p) => Total p where+  isTotal :: (~>) :~> Converse p :.: p++reprIsTotal :: (Relation p, Representable p) => (~>) :~> Converse p :.: p+reprIsTotal f = withEq f (Converse repUniv :.: repUniv) \\ f++class (Relation p) => Injective p where+  isInjective :: Converse p :.: p :~> (~>)++class (Relation p) => Surjective p where+  isSurjective :: (~>) :~> p :.: Converse p++class (Relation p) => Reflexive p where+  isReflexive :: (~>) :~> p++class (Relation p) => Transitive p where+  isTransitive :: p :.: p :~> p++adjToConverse :: forall p q. (Relation p, Relation q, Proadjunction p q) => q :~> Converse p+adjToConverse q = Converse (case unit @p @q of _ :.: p -> withEq (counit (p :.: q)) p) \\ q++adjFromConverse :: forall p q. (Relation p, Relation q, Proadjunction p q) => Converse p :~> q+adjFromConverse (Converse @_ @_ @a p) = (case unit @p @q @a of q :.: _ -> withEq (counit (p :.: q)) q) \\ p++class (Relation p, Promonad p) => Preorder p+instance (Relation p, Promonad p) => Preorder p++class (Relation p, DaggerProfunctor p) => Symmetric p+instance (Relation p, DaggerProfunctor p) => Symmetric p++class (Preorder p, Symmetric p) => Equivalence p+instance (Preorder p, Symmetric p) => Equivalence p
+ src/Proarrow/Category/Instance/Rep.hs view
@@ -0,0 +1,43 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Categories of __representable profunctors__: @'REPK' j k@ is the full subcategory of the+-- profunctor category on the 'Representable' profunctors, and @'COREPK' j k@ its counterpart of+-- (opposed) corepresentable ones. A representable profunctor is a functor in profunctor clothing,+-- so these play the role of functor categories between arbitrary kinds.+module Proarrow.Category.Instance.Rep where++import Data.Kind (Constraint)++import Proarrow.Category.Enriched.Thin (Thin, ThinProfunctor (..))+import Proarrow.Category.Instance.Opposite (OPPOSITE (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Instance.Sub (SUBCAT (..), Sub (..))+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), UN, type (+->))+import Proarrow.Profunctor.Corepresentable (Corepresentable)+import Proarrow.Profunctor.Representable (Representable (..), repObj)++type REPK j k = SUBCAT (Representable :: j +-> k -> Constraint)+type REP (f :: j +-> k) = SUB f :: REPK j k++type OpCorepresentable :: OPPOSITE (j +-> k) -> Constraint+class (Corepresentable (UN OP p)) => OpCorepresentable p+instance (Corepresentable (UN OP p)) => OpCorepresentable p+type COREPK j k = SUBCAT (OpCorepresentable :: OPPOSITE (k +-> j) -> Constraint)+type COREP (f :: k +-> j) = SUB (OP f) :: COREPK j k++class (HasArrow (~>) (p % a) (q % a)) => HasArrowRep p q a+instance (HasArrow (~>) (p % a) (q % a)) => HasArrowRep p q a+class (forall a. (Ob a) => HasArrowRep p q a) => HasAllArrows (p :: j +-> k) (q :: j +-> k)+instance (forall a. (Ob a) => HasArrowRep p q a) => HasAllArrows (p :: j +-> k) (q :: j +-> k)++-- | The natural transformation @p ':~>' q@ obtained from a thin arrow @p % a '~>' q % a@ at every+-- object, i.e. the 'Proarrow.Category.Enriched.Thin.arr' of a thin structure on @'REPK' j k@.+--+-- It is no @'Proarrow.Category.Enriched.Thin.ThinProfunctor' ('Sub' 'Prof')@ instance, because the+-- converse 'Proarrow.Category.Enriched.Thin.withArr' would have to build the quantified+-- @'HasAllArrows' p q@ from per-@a@ evidence, which GHC cannot (cf. GHC issue #16502).+repArr+  :: forall {j} {k} (p :: j +-> k) q+   . (Thin k, Ob (REP p), Ob (REP q), HasAllArrows p q)+  => REP p ~> REP q+repArr = Sub (Prof \ @_ @b p -> tabulate (arr . index p) \\ repObj @p @b \\ repObj @q @b \\ p)
+ src/Proarrow/Category/Instance/Simplex.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The __augmented simplex category__: objects are the finite ordinals (as type-level 'Nat's,+-- including the empty ordinal 'Z') and morphisms are order-preserving maps, built from the+-- constructors 'ZZ', 'Y' (skip a target) and 'X' (repeat a source). Ordinal sum makes it monoidal,+-- and it is the walking monoid: monoids in a monoidal category correspond to monoidal functors out+-- of it.+module Proarrow.Category.Instance.Simplex (module Proarrow.Category.Instance.Simplex, Nat (..)) where++import Data.Fin (Fin (..))+import Data.Kind (Type)+import Data.Type.Nat (Nat (..), SNatI, type Plus)+import Data.Vec.Lazy (Vec (..))+import Prelude (Eq, Show (..), (++), type (~))++import Data.Typeable (Typeable)+import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), Strictly, associatorDefault)+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault, obj, src, type (+->))+import Proarrow.Functor (FunctorForRep (..))+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Monoid (Monoid (..))++type n + m = Plus n m++data SNat :: Nat -> Type where+  SZ :: SNat Z+  SS :: (IsNat n) => SNat (S n)+instance Show (SNat n) where+  show SZ = "Z"+  show (SS @n') = "S" ++ show (singNat @n')++class (a + S b ~ S (a + b), Strictly a) => Rules a b+instance (a + S b ~ S (a + b), Strictly a) => Rules a b++class (forall b. Rules a b, SNatI a, Typeable a) => IsNat (a :: Nat) where singNat :: SNat a+instance IsNat Z where singNat = SZ+instance (IsNat a) => IsNat (S a) where singNat = SS++type Simplex :: CAT Nat+data Simplex a b where+  ZZ :: Simplex Z Z+  Y :: Simplex x y -> Simplex x (S y)+  X :: Simplex x (S y) -> Simplex (S x) (S y)+deriving instance Eq (Simplex a b)+deriving instance Show (Simplex a b)++suc :: Simplex a b -> Simplex (S a) (S b)+suc = X . Y++-- | The (augmented) simplex category is the category of finite ordinals and order preserving maps.+instance CategoryOf Nat where+  type (~>) = Simplex+  type Ob a = IsNat a++instance Promonad Simplex where+  id @a = case singNat @a of+    SZ -> ZZ+    SS -> suc id+  ZZ . f = f+  Y f . g = Y (f . g)+  X f . Y g = f . g+  X f . X g = X (X f . g)++instance Profunctor Simplex where+  dimap = dimapDefault+  r \\ ZZ = r+  r \\ Y f = r \\ f+  r \\ X f = r \\ f++instance HasInitialObject Nat where+  type InitialObject = Z+  initiate @a = case singNat @a of+    SZ -> ZZ+    SS @a' -> Y (initiate @_ @a')++instance HasTerminalObject Nat where+  type TerminalObject = S Z+  terminate @a = case singNat @a of+    SZ -> Y ZZ+    SS @n -> X (terminate @_ @n)++data family Forget :: Nat +-> Type+instance FunctorForRep Forget where+  type Forget @ n = Fin n+  fmap ZZ = id+  fmap (Y f) = FS . fmap @Forget f+  fmap (X f) = \case+    FZ -> FZ+    FS n -> fmap @Forget f n++data family Pick :: Type -> OPPOSITE Nat +-> Type+instance FunctorForRep (Pick a) where+  type (Pick a) @ OP n = Vec n a+  fmap (Op ZZ) VNil = VNil+  fmap (Op (Y f)) (_ ::: xs) = fmap @(Pick a) (Op f) xs+  fmap (Op (X f)) (x ::: xs) = x ::: fmap @(Pick a) (Op f) (x ::: xs)++instance MonoidalProfunctor Simplex where+  one = ZZ+  ZZ ** g = g+  Y f ** g = Y (f ** g)+  X f ** g = X (f ** g)++-- | Addition as monoidal tensor.+instance Monoidal Nat where+  type Unit = Z+  type a ** b = a + b+  withOb2 @a @b r = case singNat @a of+    SZ -> r+    SS @a' -> withOb2 @_ @a' @b r+  associator @a @b @c = associatorDefault @a @b @c+  associatorInv @a @b @c = associatorDefault @a @b @c++-- Not symmetric monoidal++instance Monoid Z where+  mempty = ZZ+  mappend = ZZ++instance Monoid (S Z) where+  mempty = Y ZZ+  mappend = X (X (Y ZZ))++data family Replicate :: k -> Nat +-> k+instance (Monoid m) => FunctorForRep (Replicate m) where+  type Replicate m @ Z = Unit+  type Replicate m @ S b = m ** (Replicate m @ b)+  fmap ZZ = one+  fmap (Y f) = let g = fmap @(Replicate m) f in (mempty @m ** g) . leftUnitorInv \\ g+  fmap (X (Y f)) = obj @m ** fmap @(Replicate m) f+  fmap (X (X @x f)) =+    let g = fmap @(Replicate m) (X f)+        b = fmap @(Replicate m) (src f)+    in g . (mappend @m ** b) . associatorInv @_ @m @m @(Replicate m @ x) \\ b
+ src/Proarrow/Category/Instance/Span.hs view
@@ -0,0 +1,112 @@+-- | The category of __spans__ in @k@: objects are those of @k@ (wrapped in 'SP'), and a morphism+-- @a '~>' b@ is a span @a <- x -> b@, composed by pullback. With the product of @k@ as tensor every+-- object is a Frobenius monoid, giving the hypergraph\/dagger structure dual to+-- "Proarrow.Category.Instance.Cospan".+module Proarrow.Category.Instance.Span where++import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..))+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Hypergraph (ExpHG, Frobenius, Hypergraph, applyHG, cap, cup, curryHG)+import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomous (..))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), WrappedOb, dimapDefault, src)+import Proarrow.Limit.BinaryProduct+  ( HasBinaryProducts (..)+  , HasProducts+  , associatorProd+  , associatorProdInv+  , leftUnitorProd+  , leftUnitorProdInv+  , rightUnitorProd+  , rightUnitorProdInv+  , swapProd+  )+import Proarrow.Limit.Pullback (HasPullbacks (..))+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Monoid (CocommutativeComonoid, CommutativeMonoid, Comonoid (..), Monoid (..))++type data SPAN k = SP k++type Span :: CAT (SPAN k)+data Span a b where+  Span :: forall c a b. c ~> a -> c ~> b -> Span (SP a) (SP b)++arr :: (CategoryOf k) => (a :: k) ~> b -> Span (SP a) (SP b)+arr f = Span (src f) f++coarr :: (CategoryOf k) => (a :: k) ~> b -> Span (SP b) (SP a)+coarr f = Span f (src f)++instance (HasPullbacks k) => Profunctor (Span :: CAT (SPAN k)) where+  dimap = dimapDefault+  r \\ Span f g = r \\ f \\ g+instance (HasPullbacks k) => Promonad (Span :: CAT (SPAN k)) where+  id = Span id id+  Span f g . Span h i = pullback i f \l r -> Span (h . l) (g . r)++-- | The category of spans in @k@: an arrow @'SP' a '~>' 'SP' b@ is a pair of arrows @x '~>' a@+-- and @x '~>' b@ out of a common object, and composition glues along a pullback.+instance (HasPullbacks k) => CategoryOf (SPAN k) where+  type (~>) = Span+  type Ob a = WrappedOb SP a++instance (HasPullbacks k, HasProducts k) => MonoidalProfunctor (Span :: CAT (SPAN k)) where+  one = id+  Span l1 l2 ** Span r1 r2 = Span (l1 *** r1) (l2 *** r2)+instance (HasPullbacks k, HasProducts k) => Monoidal (SPAN k) where+  type SP a ** SP b = SP (a && b)+  type Unit = SP TerminalObject+  withOb2 @(SP a) @(SP b) r = withObProd @k @a @b r+  leftUnitor = arr leftUnitorProd+  leftUnitorInv = arr leftUnitorProdInv+  rightUnitor = arr rightUnitorProd+  rightUnitorInv = arr rightUnitorProdInv+  associator @(SP a) @(SP b) @(SP c) = arr (associatorProd @a @b @c)+  associatorInv @(SP a) @(SP b) @(SP c) = arr (associatorProdInv @a @b @c)+instance (HasPullbacks k, HasProducts k) => SymMonoidal (SPAN k) where+  swap @(SP a) @(SP b) = arr (swapProd @a @b)++instance (HasPullbacks k, HasProducts k, Ob a) => Monoid (SP (a :: k)) where+  mempty = coarr terminate+  mappend = coarr (id &&& id)+instance (HasPullbacks k, HasProducts k, Ob a) => CommutativeMonoid (SP (a :: k))+instance (HasPullbacks k, HasProducts k, Ob a) => Comonoid (SP (a :: k)) where+  counit = arr terminate+  comult = arr (id &&& id)+instance (HasPullbacks k, HasProducts k, Ob a) => CocommutativeComonoid (SP (a :: k))+instance (HasPullbacks k, HasProducts k, Ob a) => Frobenius (SP (a :: k))+instance (HasPullbacks k, HasProducts k) => Hypergraph (SPAN k)+instance (HasPullbacks k, HasProducts k) => CopyDiscard (SPAN k)++instance (HasPullbacks k, HasProducts k) => Closed (SPAN k) where+  type a ~~> b = ExpHG a b+  withObExp @(SP a) @(SP b) r = withObProd @k @a @b r+  curry @a @b = curryHG @a @b+  apply @b @c = applyHG @b @c++instance (HasPullbacks k, HasProducts k) => StarAutonomous (SPAN k) where+  type Dual a = a+  withObDual r = r+  dual (Span f g) = Span g f+  dualInv (Span f g) = Span g f+  linDist @(SP a) @(SP b) (Span f g) = Span (fst @k @a @b . f) (snd @k @a @b . f &&& g)+  linDistInv @_ @(SP b) @(SP c) (Span f g) = Span (f &&& fst @k @b @c . g) (snd @k @b @c . g)+  doubleNeg = id+  doubleNegInv = id+instance (HasPullbacks k, HasProducts k) => CompactClosed (SPAN k) where+  distribDual @(SP a) @(SP b) = withObProd @k @a @b id+  dualUnit = id+  dualityUnit @a = cup @a+  dualityCounit @a = cap @a++instance (HasPullbacks k, HasProducts k) => DaggerProfunctor (Span :: CAT (SPAN k)) where+  dagger = dual++-- Spans over @k@ do /not/ inherit binary products, coproducts or biproducts from @k@'s+-- coproducts alone. That construction is valid only when @k@ is extensive (its coproducts+-- disjoint and stable under pullback), which 'HasPullbacks' plus 'HasBinaryCoproducts' does not+-- imply. Over BOOL, which satisfies both, @snd . (s &&& t)@ collapses to @s@ where the product+-- law demands @t@. The instances are therefore omitted; the monoidal, compact-closed and+-- hypergraph structure above needs no such condition and is unaffected.
+ src/Proarrow/Category/Instance/Sub.hs view
@@ -0,0 +1,121 @@+-- | __Full subcategories__: the kind @'SUBCAT' ob@ restricts a category to the objects satisfying+-- the predicate @ob@, with 'Sub' wrapping the underlying arrows unchanged. This is how object+-- constraints beyond a kind's own 'Ob' are imposed (e.g. the category of representable profunctors+-- in "Proarrow.Category.Instance.Rep").+module Proarrow.Category.Instance.Sub where++import Data.Kind (Constraint)++import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Core (CAT, CategoryOf (..), Kind, OB, Profunctor (..), Promonad (..), UN, WrappedOb, type (+->))+import Proarrow.Functor (FunctorForRep (..))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..))+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Profunctor.Representable (Representable (..))+import Prelude (type (~))++import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..))++type SUBCAT :: forall {k}. OB k -> Kind+type data SUBCAT (ob :: OB k) = SUB k++-- | Wraps an arrow whose endpoints satisfy the predicate @ob@: the arrows of the full+-- subcategory 'SUBCAT'.+type Sub :: CAT k -> CAT (SUBCAT (ob :: OB k))+data Sub p a b where+  Sub :: (ob a, ob b) => {unSub :: p a b} -> Sub p (SUB a :: SUBCAT ob) (SUB b)++instance (Profunctor p) => Profunctor (Sub p) where+  dimap (Sub l) (Sub r) (Sub p) = Sub (dimap l r p)+  r \\ Sub p = r \\ p++instance (Promonad p) => Promonad (Sub p) where+  id = Sub id+  Sub f . Sub g = Sub (f . g)++-- | The subcategory with objects with instances of the given constraint `ob`.+instance (CategoryOf k) => CategoryOf (SUBCAT (ob :: OB k)) where+  type (~>) = Sub (~>)+  type Ob (a :: SUBCAT ob) = (WrappedOb SUB a, ob (UN SUB a))++type On :: (k -> Constraint) -> forall (ob :: OB k) -> SUBCAT ob -> Constraint+class (c (UN SUB a)) => (c `On` ob) a+instance (c (UN SUB a)) => (c `On` ob) a++class (ob (a ** b)) => IsObMult (ob :: OB k) a b+instance (ob (a ** b)) => IsObMult (ob :: OB k) a b++-- | The same for the /product/: that the subcategory contains the products of its objects, as a+-- class with a single instance so that it can be the head of a quantified constraint.+class (ob (a && b)) => IsObProd (ob :: OB k) a b++instance (ob (a && b)) => IsObProd (ob :: OB k) a b++-- | A full subcategory has the ambient finite products as soon as it contains them, as the+-- quantified constraint says. The projections and pairing are the ambient ones under 'Sub'.+--+-- There is no exponential at an arbitrary kind: neither @'withObExp'@ nor @curry@ discharges+-- through @'Proarrow.Limit.BinaryProduct.PROD' k@\'s round trip+-- @'Proarrow.Core.UN' PR (PR a '~~>' PR b)@.+-- For subcategories of profunctors see+-- @'Proarrow.Category.Monoidal.Closed.Closed' ('Proarrow.Limit.BinaryProduct.PROD' ('SUBCAT' ob))@+-- in "Proarrow.Profunctor.Instance.Exponential".+instance (HasTerminalObject k, ob (TerminalObject :: k)) => HasTerminalObject (SUBCAT (ob :: OB k)) where+  type TerminalObject @(SUBCAT (ob :: OB k)) = SUB (TerminalObject :: k)+  terminate = Sub terminate++instance+  (HasBinaryProducts k, forall a b. (ob a, ob b) => IsObProd ob a b)+  => HasBinaryProducts (SUBCAT (ob :: OB k))+  where+  type (&&) @(SUBCAT (ob :: OB k)) a b = SUB (UN SUB a && UN SUB b)+  withObProd @(SUB a) @(SUB b) r = withObProd @k @a @b r+  fst @(SUB a) @(SUB b) = Sub (fst @k @a @b)+  snd @(SUB a) @(SUB b) = Sub (snd @k @a @b)+  Sub l &&& Sub r = Sub (l &&& r)++instance (MonoidalProfunctor p, SubMonoidal ob) => MonoidalProfunctor (Sub p :: CAT (SUBCAT (ob :: OB k))) where+  one = Sub one+  Sub f ** Sub g = Sub (f ** g)++class (Monoidal k, ob Unit, forall a b. (ob a, ob b) => IsObMult ob a b) => SubMonoidal (ob :: OB k)+instance (Monoidal k, ob Unit, forall a b. (ob a, ob b) => IsObMult ob a b) => SubMonoidal (ob :: OB k)++instance (SubMonoidal ob) => Monoidal (SUBCAT (ob :: OB k)) where+  type Unit = SUB Unit+  type a ** b = SUB (UN SUB a ** UN SUB b)+  withOb2 @(SUB a) @(SUB b) r = withOb2 @k @a @b r+  leftUnitor = Sub leftUnitor+  leftUnitorInv = Sub leftUnitorInv+  rightUnitor = Sub rightUnitor+  rightUnitorInv = Sub rightUnitorInv+  associator @(SUB a) @(SUB b) @(SUB c) = Sub (associator @_ @a @b @c)+  associatorInv @(SUB a) @(SUB b) @(SUB c) = Sub (associatorInv @_ @a @b @c)++instance (SymMonoidal k, SubMonoidal ob) => SymMonoidal (SUBCAT (ob :: OB k)) where+  swap @(SUB a) @(SUB b) = Sub (swap @k @a @b)++data family Forget :: forall (ob :: OB k) -> SUBCAT ob +-> k+instance (CategoryOf k) => FunctorForRep (Forget (ob :: OB k)) where+  type Forget ob @ a = UN SUB a+  fmap (Sub f) = f++instance (Representable p, forall a. (ob a) => ob (p % a)) => Representable (Sub p :: CAT (SUBCAT (ob :: OB k))) where+  type Sub p % a = SUB (p % UN SUB a)+  index (Sub p) = Sub (index p)+  tabulate (Sub f) = Sub (tabulate f)+  repMap (Sub f) = Sub (repMap @p f)++type FUN j k = SUBCAT (Representable :: OB (j +-> k))++(!) :: forall {j} {k} f g a b. f ~> (g :: FUN j k) -> a ~> b -> UN SUB f % a ~> UN SUB g % b+Sub (Prof n) ! ab = index @(UN SUB g) @_ @b (n (tabulate (repMap @(UN SUB f) ab))) \\ ab++-- | The arrow category of @k@ as functor category from @2@ to @k@.+type ARROW k = FUN BOOL k++commSquare+  :: forall {k} f g a b c d+   . (a ~ f % FLS, b ~ f % TRU, c ~ g % FLS, d ~ g % TRU) => SUB f ~> (SUB g :: ARROW k) -> (a ~> b, b ~> d, a ~> c, c ~> d)+commSquare n = (repMap @f F2T, n ! Tru, n ! Fls, repMap @g F2T) \\ n
+ src/Proarrow/Category/Instance/Unit.hs view
@@ -0,0 +1,58 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The __terminal category__: the unit kind @()@ with its single object @'()@ and only the+-- identity arrow 'Unit'.+module Proarrow.Category.Instance.Unit where++import Data.Type.Nat (SNat (..), snat)+import Prelude (type (~))++import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Proarrow.Category.Enriched.Thin+  ( DecidableProfunctor (..)+  , Decision (..)+  , Enumerable (..)+  , Finite (..)+  , Indexed (..)+  , ThinProfunctor (..)+  )+import Proarrow.Category.Instance.Bool (BOOL (..))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault)++type Unit :: CAT ()+data Unit a b where+  Unit :: Unit '() '()++-- | The category with one object, the terminal category.+instance CategoryOf () where+  type (~>) = Unit+  type Ob a = a ~ '()++instance Promonad Unit where+  id = Unit+  Unit . Unit = Unit++instance Profunctor Unit where+  dimap = dimapDefault+  r \\ Unit = r++instance DaggerProfunctor Unit where+  dagger Unit = Unit++instance ThinProfunctor Unit where+  type HasArrow Unit a b = (a ~ b)+  arr = Unit+  withArr Unit r = r++instance DecidableProfunctor Unit where+  type Holds Unit a b = TRU+  decide = Yes Unit+  toHolds Unit r = r++instance Indexed ()++instance Finite () where type Objects () = '[ '()]++instance Enumerable () where+  withIndex r = r+  withOb @a r = case snat @(Index a) of SZ -> r
+ src/Proarrow/Category/Instance/ZX.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The __ZX calculus__ for reasoning about quantum computations: objects are numbers of qubits+-- and a morphism @'ZX' i o@ is a complex matrix between the corresponding state spaces, stored+-- sparsely. Provides the generators ('zSpider', 'xSpider' and 'hadamard') as a dagger monoidal+-- category.+module Proarrow.Category.Instance.ZX where++import Data.Bits (Bits (..), shiftL, (.|.))+import Data.Char (chr)+import Data.Complex (Complex (..), conjugate, magnitude, mkPolar)+import Data.Functor ((<&>))+import Data.List (intercalate, sort)+import Data.Map.Strict qualified as Map+import Data.Proxy (Proxy (..))+import Data.Type.Nat qualified as M+import Data.Vec.Lazy (Vec (..), reifyList)+import GHC.TypeNats (KnownNat, Nat, natVal, type (+), type (-))+import Numeric (showFFloat)+import Unsafe.Coerce (unsafeCoerce)+import Prelude hiding (Monoid, id, (**), (.))++import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Proarrow.Category.Instance.Cost (withPlusIsNat)+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Category.Monoidal.Action (MonoidalAction)+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..), coactCC)+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Hypergraph (Frobenius, Hypergraph, cap, cup)+import Proarrow.Category.Monoidal.StarAutonomous (ExpSA, StarAutonomous (..), applySA, currySA, expSA)+import Proarrow.Category.Monoidal.Strength (Costrong (..))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault, obj, type (+->))+import Proarrow.Monoid (CocommutativeComonoid, CommutativeMonoid, Comonoid (..), Monoid (..))++newtype Bitstring (n :: Nat) = BS Int+  deriving (Eq, Ord)+  deriving newtype (Num)++instance (KnownNat n) => Bounded (Bitstring n) where+  minBound = BS 0+  maxBound = BS ((1 `shiftL` nat @n) - 1)+instance Enum (Bitstring n) where+  fromEnum (BS x) = x+  toEnum x = BS x++-- | Split n + m bits into two parts: the lower n bits and the higher m bits.+split :: (KnownNat n) => Bitstring (n + m) -> (Bitstring n, Bitstring m)+split @n (BS x) = let (m, n) = x `divMod` (1 `shiftL` nat @n) in (BS n, BS m)++-- | Combine two bitstrings of lengths n and m into one bitstring with the n lower bits or m higher bits.+combine :: (KnownNat n) => Bitstring n -> Bitstring m -> Bitstring (n + m)+combine @n (BS x) (BS y) = BS ((y `shiftL` nat @n) .|. x)++-- The order is (output, input)!+type SparseMatrix o i = Map.Map (Bitstring o, Bitstring i) (Complex Double)++epsilon :: Double+epsilon = 1e-12++isZero :: Complex Double -> Bool+isZero z = magnitude z <= epsilon++filterSparse :: SparseMatrix o i -> SparseMatrix o i+filterSparse = Map.filter (Prelude.not . isZero)++transpose :: SparseMatrix o i -> SparseMatrix i o+transpose = Map.mapKeys \(o, i) -> (i, o)++mirror :: (KnownNat n) => Bitstring n -> Bitstring (n + n)+mirror @n (BS x) = BS (go (nat @n) x x)+  where+    go 0 _ acc = acc+    go k y acc = go (k - 1) (y `shiftR` 1) ((acc `shiftL` 1) .|. (y .&. 1))++enumAll :: (KnownNat n) => [Bitstring n]+enumAll = [minBound .. maxBound]++nat :: (KnownNat n) => Int+nat @n = fromIntegral $ natVal (Proxy @n)++type ZX :: CAT Nat+data ZX i o where+  ZX :: (KnownNat i, KnownNat o) => SparseMatrix o i -> ZX i o++instance (KnownNat n) => Show (Bitstring n) where+  show (BS x) = go (nat @n) x ""+    where+      go 0 _ acc = acc+      go n bs acc = case bs `divMod` 2 of (r, b) -> go (n - 1) r (chr (48 + b) : acc)++instance Show (ZX a b) where+  show (ZX m) = intercalate ", " (sort (fmt <$> Map.toList m))+    where+      fmt ((o, i), r :+ c) =+        show i+          ++ "->"+          ++ show o+          ++ "="+          ++ (if abs (1 - r) < epsilon then "1" else showFFloat (Just 3) r "")+          ++ (if abs c < epsilon then "" else " :+ " ++ showFFloat (Just 3) c "")++type family MatrixSize (n :: Nat) :: M.Nat where+  MatrixSize 0 = M.Nat1+  MatrixSize n = M.Mult M.Nat2 (MatrixSize (n - 1))++toMatrix :: forall o i. ZX i o -> Vec (MatrixSize o) (Vec (MatrixSize i) (Complex Double))+toMatrix (ZX m) =+  reifyList (enumAll @o) \vo ->+    reifyList (enumAll @i) \vi ->+      unsafeCoerce $ vo <&> \o -> vi <&> \i -> Map.findWithDefault 0 (o, i) m++instance Profunctor ZX where+  dimap = dimapDefault+  r \\ ZX _ = r+instance Promonad ZX where+  id @n = ZX $ Map.fromList [((i, i), 1) | i <- enumAll @n]+  ZX n . ZX m =+    ZX $+      filterSparse $+        Map.fromListWith+          (+)+          [ ((c, a), mv * nv)+          | ((c, b1), mv) <- Map.toList n+          , ((b2, a), nv) <- Map.toList m+          , b1 == b2+          ]++-- | The category of qubits, to implement ZX calculus from quantum computing.+instance CategoryOf Nat where+  type (~>) = ZX+  type Ob a = KnownNat a++instance DaggerProfunctor ZX where+  dagger (ZX m) = ZX $ Map.fromList [((i, o), conjugate v) | ((o, i), v) <- Map.toList m]++instance MonoidalProfunctor ZX where+  one = id+  ZX @ni @no n ** ZX @mi @mo m =+    withOb2 @_ @ni @mi $+      withOb2 @_ @no @mo $+        ZX $+          Map.fromList+            [ ((combine no mo, combine ni mi), nv * mv)+            | ((no, ni), nv) <- Map.toList n+            , ((mo, mi), mv) <- Map.toList m+            ]++-- | Addition of the number of qubits as monoidal tensor. This is the Kronecker product of the matrices.+instance Monoidal Nat where+  type Unit = 0+  type p ** q = p + q+  withOb2 @a @b r = withPlusIsNat @a @b r+  associator @a @b @c = unsafeCoerce (withOb2 @_ @a @b (withOb2 @_ @(a + b) @c (obj @(a + b + c))))+  associatorInv @a @b @c = unsafeCoerce (withOb2 @_ @a @b (withOb2 @_ @(a + b) @c (obj @(a + b + c))))++instance SymMonoidal Nat where+  swap @m @n =+    withOb2 @_ @m @n $+      withOb2 @_ @n @m $+        ZX $+          Map.fromList+            [ ((combine n m, combine m n), 1)+            | n <- enumAll @n+            , m <- enumAll @m+            ]++instance Closed Nat where+  type x ~~> y = ExpSA x y+  withObExp @a @b r = withOb2 @_ @a @b r+  curry @x @y = currySA @x @y+  apply @y @z = applySA @y @z+  (^^^) = expSA++instance StarAutonomous Nat where+  type Dual x = x+  withObDual r = r+  dual (ZX m) = ZX (transpose m)+  dualInv = dual+  linDist @_ @b @c (ZX m) =+    withOb2 @_ @b @c $+      ZX (Map.mapKeys (\(c, ab) -> case split ab of (a, b) -> (combine b c, a)) m)+  linDistInv @a @b (ZX m) =+    withOb2 @_ @a @b $+      ZX (Map.mapKeys (\(bc, a) -> case split bc of (b, c) -> (c, combine a b)) m)+  doubleNeg = id+  doubleNegInv = id++instance CompactClosed Nat where+  distribDual @a @b = withOb2 @_ @a @b id+  dualUnit = id+  dualityUnit @a = cup @a+  dualityCounit @a = cap @a++instance (MonoidalAction (t :: (Nat, Nat) +-> Nat)) => Costrong t ZX where+  coact @x = coactCC @t @x++-- No terminal or initial object: @hom(n, m)@ is the space of @2^m x 2^n@ complex matrices, which+-- is a singleton for no @n@ and @m@ at all. @0@, the monoidal unit, is not terminal either: the+-- zero matrix is an arrow @1 ~> 0@, but so is @zSpider 0 :: ZX 1 0@, and the two differ. The zero+-- matrix is a zero morphism, which wants a class of its own, not a fake zero object.++-- No binary(co)products, since that would need 2^n + 2^m = 2^(x :: nat)++instance (KnownNat n) => Monoid (n :: Nat) where+  mempty = ZX $ Map.fromList [((o, minBound), 1) | o <- enumAll @n]+  mappend = withPlusIsNat @n @n $ ZX $ Map.fromList [((o, combine o o), 1) | o <- enumAll @n]++instance (KnownNat n) => Comonoid (n :: Nat) where+  counit = ZX $ Map.fromList [((minBound, i), 1) | i <- enumAll @n]+  comult = withPlusIsNat @n @n $ ZX $ Map.fromList [((combine i i, i), 1) | i <- enumAll @n]+instance (KnownNat n) => CocommutativeComonoid (n :: Nat)++instance (KnownNat a) => Frobenius (a :: Nat)+instance (KnownNat a) => CommutativeMonoid (a :: Nat)+instance Hypergraph Nat+instance CopyDiscard Nat++zSpider :: (KnownNat i, KnownNat o) => Double -> ZX i o+zSpider alpha = ZX $ Map.fromListWith (+) [(minBound, 1), (maxBound, mkPolar 1 alpha)]++xSpider :: (KnownNat i, KnownNat o) => Double -> ZX i o+xSpider alpha = hadamard . zSpider alpha . hadamard++zCopy :: ZX 1 2+zCopy = zSpider 0++zDisc :: ZX 1 0+zDisc = zSpider 0++xCopy :: ZX 1 2+xCopy = xSpider 0++xDisc :: ZX 1 0+xDisc = xSpider 0++zeroState :: ZX 0 1+zeroState = xSpider 0++oneState :: ZX 0 1+oneState = xSpider pi++plusState :: ZX 0 1+plusState = zSpider 0++minusState :: ZX 0 1+minusState = zSpider pi++not :: ZX 1 1+not = xSpider pi++-- | Controlled NOT gate+cnot :: ZX 2 2+cnot = (id ** xSpider @2 0) . (zCopy ** id)++-- | Greenberger–Horne–Zeilinger state+ghzState :: ZX 0 3+ghzState = zSpider 0++hadamard :: (KnownNat n) => ZX n n+hadamard @n = ZX $ Map.fromList [((i, j), (sign i j * amp) :+ 0) | i <- enumAll @n, j <- enumAll @n]+  where+    amp = 1 / sqrt (fromIntegral (shiftL (1 :: Int) (nat @n)))+    sign (BS a) (BS b) = if even (popCount (a .&. b)) then 1 else -1
+ src/Proarrow/Category/Instance/Zero.hs view
@@ -0,0 +1,38 @@+{-# OPTIONS_GHC -Wno-missing-methods #-}++-- | The __initial category__: the empty kind 'VOID' with no objects (its 'Ob' constraint is+-- 'Bottom', which nothing satisfies) and no arrows.+module Proarrow.Category.Instance.Zero where++import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault, type (+->))+import Proarrow.Functor (FunctorForRep (..))++type data VOID++type Zero :: CAT VOID+data Zero a b++-- Stolen from the constraints package+class Bottom where+  no :: a++-- | The category with no objects, the initial category.+instance CategoryOf VOID where+  type (~>) = Zero+  type Ob a = Bottom++instance Promonad Zero where+  id = no+  (.) = \case {}++instance Profunctor Zero where+  dimap = dimapDefault+  _ \\ x = case x of {}++instance DaggerProfunctor Zero where+  dagger = \case {}++data family Absurd :: VOID +-> k+instance (CategoryOf k) => FunctorForRep (Absurd :: VOID +-> k) where+  fmap = \case {}
+ src/Proarrow/Category/Internal.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Internal categories: @ik \`InternalIn\` k@ is a category internal to @k@, given by an object of+-- objects @'C0' ik@, an object of arrows @'C1' ik@, and source\/target\/identity\/composition+-- structure maps.+--+-- Internal to finite sets these are the finite categories, and each direction needs a different+-- presentation of finite sets. A 'FiniteCat' counts its arrows only at the value level, so it is+-- internal to 'Proarrow.Category.Instance.FinHask.FINHASK'. Going back,+-- 'Proarrow.Category.Enriched.Thin.Enumerable' wants the object list as a type, which only the+-- skeleton 'Proarrow.Category.Instance.FinSet.FINSET' supplies, so 'INTERNAL' is built from an+-- internal category in @FINSET@.+module Proarrow.Category.Internal where++import Prelude (($))+import Prelude qualified as P++import Data.Fin (fin0, fin1, fin2, toNatural)+import Data.Kind (Type)+import Data.List (elemIndex, genericIndex, genericLength)+import Data.Proxy (Proxy (..))+import Data.Type.Nat (Nat2, Nat3, SNatI, reify, snat)+import Data.Type.Nat qualified as N+import Data.Universe.Class qualified as U+import Data.Vec.Lazy (Vec (..))+import Data.Vec.Lazy qualified as Vec+import Numeric.Natural (Natural)+import Proarrow.Category.Enriched.Finitary (Finitary (..), FiniteCat, indices)+import Proarrow.Category.Enriched.Thin+  ( At+  , AtOb (..)+  , Enumerable (..)+  , Finite (..)+  , FmapWrap+  , Index+  , Indexed (..)+  , IndexedList (..)+  , MapWrap+  , Objects+  , finite+  , withWrapAtLookup+  , wrapFinite+  )+import Proarrow.Category.Instance.Bool (BOOL)+import Proarrow.Category.Instance.FinHask (FINHASK (..), arr)+import Proarrow.Category.Instance.FinSet (FINSET (..), FinSet (..))+import Proarrow.Category.Instance.Ordinal (IsOrdinal, ORDINAL)+import Proarrow.Core (CAT, CategoryOf (..), Hom, Is, Kind, Profunctor (..), Promonad (..), UN, dimapDefault, (\\))+import Proarrow.Profunctor.Instance.Cone (Cone (..), Cosink (..))++-- | An internal category in a category @k@.+class ik `InternalIn` k where+  type C0 ik :: k+  type C1 ik :: k+  source :: C1 ik ~> (C0 ik :: k)+  target :: C1 ik ~> (C0 ik :: k)+  identity :: C0 ik ~> (C1 ik :: k)+  compose :: Cosink [C1 ik, C1 ik, C1 ik :: k] -- first arrow projection, second arrow projection, composite++-- | >>> import Data.Fin+-- >>> import Data.Type.Nat+-- >>> import Data.Vec.Lazy+-- >>> import Proarrow.Limit.Pullback+-- >>> import Prelude qualified as P+-- >>> (pullback (source @BOOL @FINSET) (target @BOOL @FINSET) \(FinSet l) (FinSet r) -> P.show (l, r)) :: P.String+-- "(0 ::: 1 ::: 2 ::: 2 ::: VNil,0 ::: 0 ::: 1 ::: 2 ::: VNil)"+instance BOOL `InternalIn` FINSET where+  type C0 BOOL = FS Nat2 -- Fin0 = FLS, Fin1 = TRU+  type C1 BOOL = FS Nat3 -- Fin0 = Fls, Fin1 = F2T, Fin2 = Tru+  source = FinSet $ fin0 ::: fin0 ::: fin1 ::: VNil+  target = FinSet $ fin0 ::: fin1 ::: fin1 ::: VNil+  identity = FinSet $ fin0 ::: fin2 ::: VNil++  -- 4 different ways to compose, read vertically.+  compose =+    Cone $+      Leg (FinSet $ fin0 ::: fin1 ::: fin2 ::: fin2 ::: VNil) $+        Leg (FinSet $ fin0 ::: fin0 ::: fin1 ::: fin2 ::: VNil) $+          Leg+            (FinSet $ fin0 ::: fin1 ::: fin1 ::: fin2 ::: VNil)+            Apex++-- * Finite categories are the ones internal to @FINHASK@++-- | An object of @k@ as an inhabitant of a finite Haskell type: its index in+-- @'Proarrow.Category.Enriched.Thin.Objects' k@.+type ObIx :: Kind -> Type+newtype ObIx k = ObIx Natural+  deriving newtype (P.Eq, P.Ord, P.Show)++-- | An arrow of @k@ as an inhabitant of a finite Haskell type: the indices of its source and target+-- objects, and its own position in that hom-set.+type ArrIx :: Kind -> Type+data ArrIx k = ArrIx {arrSrc :: Natural, arrTgt :: Natural, arrPos :: Natural}+  deriving (P.Eq, P.Ord, P.Show)++-- | A composable pair, and the apex of 'compose': the pullback of 'source' along 'target'. The+-- arrows are given outer first, so that the legs of 'compose' come out in the order that instance+-- wants them: the first leg composed after the second.+type CompIx :: Kind -> Type+data CompIx k = CompIx (ArrIx k) (ArrIx k)+  deriving (P.Eq, P.Ord, P.Show)++-- | How many objects @k@ has, by walking its object list.+obCount :: forall k. (Enumerable k) => Natural+obCount = go (finite @k)+  where+    go :: IndexedList (xs :: [k]) -> Natural+    go FNil = 0+    go (FCons xs) = 1 P.+ go xs++-- | Recover the object sitting at an index, together with the 'Ob' evidence that lets the+-- 'Finitary' methods be called at it. The index must be below 'obCount'; every index the+-- enumerations below produce is.+withObIx :: forall k r. (Enumerable k) => Natural -> (forall (a :: k). (Ob a) => Proxy a -> r) -> r+withObIx i f = reify (N.fromNatural i) \(_ :: Proxy n) -> case atOb @k (snat @n) of+  AtJust @_ @a -> f (Proxy @a)+  AtNothing -> P.error "withObIx: no object at this index"++-- | The size of a hom-set, named by the indices of its endpoints.+homSize :: forall k. (FiniteCat k) => Natural -> Natural -> Natural+homSize i j =+  withObIx @k i \(_ :: Proxy a) ->+    withObIx @k j \(_ :: Proxy b) ->+      size @(Hom k) @a @b++instance (Enumerable k) => U.Universe (ObIx k) where+  universe = ObIx P.<$> indices (obCount @k)+instance (Enumerable k) => U.Finite (ObIx k)++instance (FiniteCat k) => U.Universe (ArrIx k) where+  universe =+    [ ArrIx i j h+    | i <- indices (obCount @k)+    , j <- indices (obCount @k)+    , h <- indices (homSize @k i j)+    ]+instance (FiniteCat k) => U.Finite (ArrIx k)++instance (FiniteCat k) => U.Universe (CompIx k) where+  universe = [CompIx g f | g <- U.universeF, f <- U.universeF, arrSrc g P.== arrTgt f]+instance (FiniteCat k) => U.Finite (CompIx k)++-- | Every finite category is a category internal to 'FINHASK': objects and arrows are carried by+-- their indices, and the structure maps are the lookup tables that read those indices back.+--+-- At 'BOOL' every table agrees with the hand-written @FINSET@ presentation above, with the arrows+-- coming out in the order @Fls@, @F2T@, @Tru@.+--+-- >>> import Data.List (elemIndex)+-- >>> import Proarrow.Category.Instance.FinHask (toList)+-- >>> let ix a = P.maybe (-1) P.id (elemIndex a (U.universeF :: [ArrIx BOOL])) :: P.Int+-- >>> P.map P.snd (toList (source @BOOL @FINHASK))+-- [0,0,1]+-- >>> P.map P.snd (toList (target @BOOL @FINHASK))+-- [0,1,1]+-- >>> P.map (ix P.. P.snd) (toList (identity @BOOL @FINHASK))+-- [0,2]+-- >>> :{+-- (case compose @BOOL @FINHASK of+--    Cone (Leg l1 (Leg l2 (Leg l3 Apex))) ->+--      let g l = P.map (ix P.. P.snd) (toList l) in (g l1, g l2, g l3))+--   :: ([P.Int], [P.Int], [P.Int])+-- :}+-- ([0,1,2,2],[0,0,1,2],[0,1,1,2])+instance (FiniteCat k) => k `InternalIn` FINHASK where+  type C0 k = FH (ObIx k)+  type C1 k = FH (ArrIx k)+  source = arr \(ArrIx i _ _) -> ObIx i+  target = arr \(ArrIx _ j _) -> ObIx j+  identity = arr \(ObIx i) -> withObIx @k i \(_ :: Proxy a) -> ArrIx i i (toIndex @(Hom k) @a @a id)+  compose =+    Cone $+      Leg (arr \(CompIx f _) -> f) $+        Leg (arr \(CompIx _ g) -> g) $+          Leg (arr composite) Apex+    where+      composite (CompIx (ArrIx j l g) (ArrIx i _ f)) =+        withObIx @k i \(_ :: Proxy a) ->+          withObIx @k j \(_ :: Proxy b) ->+            withObIx @k l \(_ :: Proxy c) ->+              ArrIx i l (toIndex @(Hom k) @a @c (fromIndex @(Hom k) @b @c g . fromIndex @(Hom k) @a @b f))++-- * The converse: an internal category in @FINSET@ is a finite category++-- | How many objects and how many arrows an internal category in @FINSET@ has. These are types.+-- That is what @FINSET@ has over 'Proarrow.Category.Instance.FinHask.FINHASK', and the converse+-- needs it, because 'Enumerable' asks for its object list at the type level.+type NumObs ik = UN FS (C0 ik :: FINSET)++type NumArrs ik = UN FS (C1 ik :: FINSET)++-- | The category an internal category in @FINSET@ presents, as a kind: its objects are the elements+-- of @'C0' ik@, numbered by 'ORDINAL'.+type data INTERNAL ik = IN (ORDINAL (NumObs ik))++-- | An arrow of the presented category: an element of @'C1' ik@. That its 'source' and 'target' are+-- the objects claimed is a runtime invariant, as the table invariants of 'FinSet' are.+type Internal :: forall {ik}. CAT (INTERNAL ik)+data Internal a b where+  Internal :: (Ob a, Ob b) => Natural -> Internal (a :: INTERNAL ik) b++-- | A structure map as a list of indices into its codomain.+tableOf :: FinSet a b -> [Natural]+tableOf (FinSet v) = P.map toNatural (Vec.toList v)++-- | The composition table: for each composable pair, the outer arrow, the inner arrow, and their+-- composite, as indices into @'C1' ik@.+compTable :: forall ik. (ik `InternalIn` FINSET) => [(Natural, Natural, Natural)]+compTable = case compose @ik @FINSET of+  Cone (Leg l1 (Leg l2 (Leg l3 Apex))) -> P.zip3 (tableOf l1) (tableOf l2) (tableOf l3)++-- | Which element of @'C0' ik@ an object names.+obNum :: forall {ik} (a :: INTERNAL ik). (Enumerable (INTERNAL ik), Ob a) => Natural+obNum = withIndex @(INTERNAL ik) @a (N.reflectToNum (Proxy @(Index a)))++instance (ik `InternalIn` FINSET) => Indexed (INTERNAL ik) where+  type Index (a :: INTERNAL ik) = Index (UN IN a)+  type At (INTERNAL ik) i = FmapWrap IN (At (ORDINAL (NumObs ik)) i)++instance (ik `InternalIn` FINSET, SNatI (NumObs ik)) => Finite (INTERNAL ik) where+  type Objects (INTERNAL ik) = MapWrap IN (Objects (ORDINAL (NumObs ik)))+  finite = wrapFinite @IN+  withAtLookup = withWrapAtLookup @IN++instance (ik `InternalIn` FINSET, SNatI (NumObs ik)) => Enumerable (INTERNAL ik) where+  withIndex @a r = withIndex @(ORDINAL (NumObs ik)) @(UN IN a) r+  atOb i = case atOb @(ORDINAL (NumObs ik)) i of+    AtJust -> AtJust+    AtNothing -> AtNothing++instance (ik `InternalIn` FINSET, SNatI (NumObs ik)) => Profunctor (Internal :: CAT (INTERNAL ik)) where+  dimap = dimapDefault+  r \\ Internal{} = r++instance (ik `InternalIn` FINSET, SNatI (NumObs ik)) => Promonad (Internal :: CAT (INTERNAL ik)) where+  id @a = Internal (genericIndex (tableOf (identity @ik @FINSET)) (obNum @a))+  Internal g . Internal f = case [c | (o, i, c) <- compTable @ik, o P.== g, i P.== f] of+    c : _ -> Internal c+    [] -> P.error "Internal.(.): the arrows do not compose"++instance (ik `InternalIn` FINSET, SNatI (NumObs ik)) => CategoryOf (INTERNAL ik) where+  type (~>) = Internal+  type Ob a = (Is IN a, IsOrdinal (UN IN a))++instance (ik `InternalIn` FINSET, SNatI (NumObs ik)) => Finitary (Internal :: CAT (INTERNAL ik)) where+  elements @a @b =+    [ Internal e+    | (e, s, t) <- P.zip3 [0 ..] (tableOf (source @ik @FINSET)) (tableOf (target @ik @FINSET))+    , s P.== obNum @a+    , t P.== obNum @b+    ]+  size @a @b = genericLength (elements @(Internal :: CAT (INTERNAL ik)) @a @b)+  toIndex @a @b (Internal e) =+    case elemIndex e [n | Internal n <- elements @(Internal :: CAT (INTERNAL ik)) @a @b] of+      P.Just i -> P.fromIntegral i+      P.Nothing -> P.error "Internal.toIndex: not an arrow of this hom-set"+  fromIndex @a @b i = genericIndex (elements @(Internal :: CAT (INTERNAL ik)) @a @b) i++-- | The converse, as a statement: an internal category in @FINSET@ presents a 'FiniteCat'.+--+-- At 'BOOL' the presented category has the hom-sets of 'BOOL' back: one arrow each way except from+-- @TRU@ to @FLS@, where there is none.+--+-- >>> import Proarrow.Category.Instance.Ordinal (ORDINAL (..))+-- >>> :{+-- [ size @(Hom (INTERNAL BOOL)) @(IN OZ) @(IN OZ)+-- , size @(Hom (INTERNAL BOOL)) @(IN OZ) @(IN (OS OZ))+-- , size @(Hom (INTERNAL BOOL)) @(IN (OS OZ)) @(IN OZ)+-- , size @(Hom (INTERNAL BOOL)) @(IN (OS OZ)) @(IN (OS OZ))+-- ] :: [Natural]+-- :}+-- [1,1,0,1]+--+-- >>> let f = fromIndex @(Hom (INTERNAL BOOL)) @(IN OZ) @(IN (OS OZ)) 0+-- >>> toIndex @(Hom (INTERNAL BOOL)) @(IN OZ) @(IN (OS OZ)) (id @_ @(IN (OS OZ)) . f)+-- 0+internalIsFinite+  :: forall ik r. (ik `InternalIn` FINSET, SNatI (NumObs ik)) => ((FiniteCat (INTERNAL ik)) => r) -> r+internalIsFinite r = r
+ src/Proarrow/Category/Monoidal.hs view
@@ -0,0 +1,535 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Monoidal categories, as kinds with a tensor: 'Monoidal' provides 'Unit', the tensor @('**')@,+-- and the unitor and associator isomorphisms; 'SymMonoidal' adds the symmetry 'swap'. A+-- 'MonoidalProfunctor' is a lax monoidal profunctor with 'one' and a value-level @('**')@, and a+-- category is 'Monoidal' if and only if its hom-profunctor is.+module Proarrow.Category.Monoidal where++import Data.Kind (Constraint)+import Data.Type.Nat (Nat (..), SNat (..), SNatI, snat)+import Prelude (Show, ($), type (~))+import Prelude qualified as P++import Proarrow.Category.Instance.Free+  ( Elem (..)+  , Elems+  , FREE (..)+  , Free (..)+  , HasStructure (..)+  , IsFreeOb (..)+  , Lower+  , WithShow+  , withLowerOb+  )+import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))+import Proarrow.Category.Instance.Product (Fst, Snd, (:**:) (..))+import Proarrow.Category.Instance.Unit qualified as U+import Proarrow.Core+  ( CAT+  , CategoryOf (..)+  , Kind+  , Obj+  , Profunctor (..)+  , Promonad (..)+  , UN+  , obj+  , src+  , tgt+  , type (+->)+  )+import Proarrow.Functor (FunctorForRep (..))+import Proarrow.Optic (PIso, iso)+import Proarrow.Profunctor.Corepresentable (Corepresentable (..), corepUniv)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Identity qualified as Id+import Proarrow.Profunctor.Representable (CorepStar, Rep, RepCostar, Representable (..), repUniv)+import Proarrow.Tools.Laws (Inverses (..), Law (..), Laws (..), ProLaw (..), ProLaws (..), inverses, (=:=), (===))++infixl 8 **+infixl 7 ==++-- This is equal to a lax monoidal functor for representable profunctors+-- and to an oplax monoidal functor for corepresentable profunctors.+type MonoidalProfunctor :: forall {j} {k}. j +-> k -> Constraint+class (Monoidal j, Monoidal k, Profunctor p) => MonoidalProfunctor (p :: j +-> k) where+  one :: p Unit Unit+  (**) :: p x1 x2 -> p y1 y2 -> p (x1 ** y1) (x2 ** y2)++instance MonoidalProfunctor U.Unit where+  one = U.Unit+  U.Unit ** U.Unit = U.Unit++instance (MonoidalProfunctor p, MonoidalProfunctor q) => MonoidalProfunctor (p :**: q) where+  one = one :**: one+  (f1 :**: f2) ** (g1 :**: g2) = (f1 ** g1) :**: (f2 ** g2)++instance (Monoidal k) => MonoidalProfunctor (Id.Id :: k +-> k) where+  one = Id.Id one+  Id.Id f ** Id.Id g = Id.Id (f ** g)++instance (MonoidalProfunctor p, MonoidalProfunctor q) => MonoidalProfunctor (p :.: q) where+  one = one :.: one+  (p :.: q) ** (r :.: s) = (p ** r) :.: (q ** s)++-- | A representable profunctor that is a 'MonoidalProfunctor': its functor @p '%'@ is /lax/+-- monoidal, splitting as 'par0Rep' and 'parRep'.+type LaxMonoidal p = (MonoidalProfunctor p, Representable p)++par0Rep :: (LaxMonoidal p) => Unit ~> p % Unit+par0Rep @p = index @p one++parRep :: (LaxMonoidal p, Ob x, Ob y) => (p % x) ** (p % y) ~> p % (x ** y)+parRep @p @x @y = index @p (repUniv @p @x ** repUniv @p @y)++-- | A corepresentable profunctor that is a 'MonoidalProfunctor': its functor @p '%%'@ is /oplax/+-- monoidal, splitting as 'unpar0Corep' and 'unparCorep'.+type OplaxMonoidal p = (MonoidalProfunctor p, Corepresentable p)++unpar0Corep :: (OplaxMonoidal p) => p %% Unit ~> Unit+unpar0Corep @p = coindex @p one++unparCorep :: (OplaxMonoidal p, Ob x, Ob y) => p %% (x ** y) ~> (p %% x) ** (p %% y)+unparCorep @p @x @y = coindex @p (corepUniv @p @x ** corepUniv @p @y)++-- | A __representable__ profunctor whose functor @p '%'@ is /oplax/ monoidal. Stating the oplax+-- structure of a representable functor means naming that same functor in its other variance, as+-- 'RepCostar' does. So the postfix here says which presentation @p@ is in, not which structure it+-- carries. Weaker than 'StrongMonoidalRep', which additionally asks @p@ itself to be+-- 'LaxMonoidal'.+type OplaxMonoidalRep p = (Representable p, OplaxMonoidal (RepCostar p))++unpar0Rep :: (OplaxMonoidalRep p) => p % Unit ~> Unit+unpar0Rep @p = unpar0Corep @(RepCostar p)++unparRep :: (OplaxMonoidalRep p, Ob x, Ob y) => p % (x ** y) ~> (p % x) ** (p % y)+unparRep @p @x @y = unparCorep @(RepCostar p) @x @y++-- | A __corepresentable__ profunctor whose functor @p '%%'@ is /lax/ monoidal, dually through+-- 'CorepStar'.+type LaxMonoidalCorep p = (Corepresentable p, LaxMonoidal (CorepStar p))++par0Corep :: (LaxMonoidalCorep p) => Unit ~> p %% Unit+par0Corep @p = par0Rep @(CorepStar p)++parCorep :: (LaxMonoidalCorep p, Ob x, Ob y) => (p %% x) ** (p %% y) ~> p %% (x ** y)+parCorep @p @x @y = parRep @(CorepStar p) @x @y++-- | A representable profunctor whose functor is /strong/ monoidal: lax as it stands, and oplax in+-- its other variance.+type StrongMonoidalRep p = (LaxMonoidal p, OplaxMonoidalRep p)++-- | A corepresentable profunctor whose functor is /strong/ monoidal, dually.+type StrongMonoidalCorep p = (OplaxMonoidal p, LaxMonoidalCorep p)++-- | A monoidal category: a tensor @'**'@ with a 'Unit', associative and unital up to the coherent+-- isomorphisms below. The tensor's action on arrows is the 'MonoidalProfunctor' method @**@ at+-- @('~>')@, which the superclass supplies.+--+-- __Laws:__+--+-- The three isomorphisms must be mutually inverse:+--+-- * @'leftUnitor' . 'leftUnitorInv' = 'id'@ and @'leftUnitorInv' . 'leftUnitor' = 'id'@+-- * @'rightUnitor' . 'rightUnitorInv' = 'id'@ and @'rightUnitorInv' . 'rightUnitor' = 'id'@+-- * @'associator' . 'associatorInv' = 'id'@ and @'associatorInv' . 'associator' = 'id'@+--+-- and natural in every argument:+--+-- * @'leftUnitor' . ('id' '**' f) = f . 'leftUnitor'@+-- * @'rightUnitor' . (f '**' 'id') = f . 'rightUnitor'@+-- * @'associator' . ((f '**' g) '**' h) = (f '**' (g '**' h)) . 'associator'@+--+-- subject to the two coherence conditions:+--+-- * Triangle: @('id' '**' 'leftUnitor') . 'associator' = 'rightUnitor' '**' 'id'@+-- * Pentagon: @('id' '**' 'associator') . 'associator' . ('associator' '**' 'id')+--   = 'associator' . 'associator'@+--+-- Checked by 'Proarrow.Testing.Laws.testMonoidal'.+type Monoidal :: Kind -> Constraint+class (CategoryOf k, MonoidalProfunctor ((~>) :: CAT k), Ob (Unit :: k)) => Monoidal k where+  -- | The tensor unit.+  type Unit :: k++  -- | The tensor product of two objects.+  type (a :: k) ** (b :: k) :: k++  -- | Recovers @'Ob' (a '**' b)@ from the objecthood of the factors.+  withOb2 :: (Ob (a :: k), Ob b) => ((Ob (a ** b)) => r) -> r++  -- | Cancels a 'Unit' on the left.+  leftUnitor :: (Ob (a :: k)) => Unit ** a ~> a+  default leftUnitor :: (Ob (a :: k), (Unit ** a) ~ a) => Unit ** a ~> a+  leftUnitor = id++  -- | Introduces a 'Unit' on the left; inverse to 'leftUnitor'.+  leftUnitorInv :: (Ob (a :: k)) => a ~> Unit ** a+  default leftUnitorInv :: (Ob (a :: k), (Unit ** a) ~ a) => a ~> Unit ** a+  leftUnitorInv = id++  -- | Cancels a 'Unit' on the right.+  rightUnitor :: (Ob (a :: k)) => a ** Unit ~> a+  default rightUnitor :: (Ob (a :: k), (a ** Unit) ~ a) => a ** Unit ~> a+  rightUnitor = id++  -- | Introduces a 'Unit' on the right; inverse to 'rightUnitor'.+  rightUnitorInv :: (Ob (a :: k)) => a ~> a ** Unit+  default rightUnitorInv :: (Ob (a :: k), (a ** Unit) ~ a) => a ~> a ** Unit+  rightUnitorInv = id++  -- | Reassociates the tensor to the right.+  associator :: (Ob (a :: k), Ob b, Ob c) => (a ** b) ** c ~> a ** (b ** c)++  -- | Reassociates the tensor to the left; inverse to 'associator'.+  associatorInv :: (Ob (a :: k), Ob b, Ob c) => a ** (b ** c) ~> (a ** b) ** c++leftUnitorIso :: (Monoidal k, Ob (a :: k), Ob (a' :: k)) => PIso (Unit ** a) (Unit ** a') a a'+leftUnitorIso = iso leftUnitor leftUnitorInv++rightUnitorIso :: (Monoidal k, Ob (a :: k), Ob (a' :: k)) => PIso (a ** Unit) (a' ** Unit) a a'+rightUnitorIso = iso rightUnitor rightUnitorInv++associatorIso+  :: (Monoidal k, Ob (a :: k), Ob b, Ob c, Ob (a' :: k), Ob b', Ob c')+  => PIso ((a ** b) ** c) ((a' ** b') ** c') (a ** (b ** c)) (a' ** (b' ** c'))+associatorIso @k @a @b @c @a' @b' @c' = iso (associator @k @a @b @c) (associatorInv @k @a' @b' @c')++class (((a ** b) ** c) ~ (a ** (b ** c))) => StrictlyAssoc a b c+instance (((a ** b) ** c) ~ (a ** (b ** c))) => StrictlyAssoc a b c++-- | The @n@-fold tensor power of @x@: @x '**' x '**' … '**' x@, @n@ times, terminated by 'Unit'.+type family NFold (n :: Nat) (x :: k) :: k where+  NFold Z x = Unit+  NFold (S n) x = x ** NFold n x++-- | The 'Proarrow.Category.Monoidal.Strictified.Strictified' counterpart of 'NFold': @n@ copies+-- of @x@ as a list, rather than nested tensors.+type family NFoldS (n :: Nat) (x :: k) :: [k] where+  NFoldS Z x = '[]+  NFoldS (S n) x = x ': NFoldS n x++-- | @'NFold' n a@ is an object whenever @a@ is.+withObNFold :: forall {k} n (a :: k) r. (SNatI n, Ob a, Monoidal k) => ((Ob (NFold n a)) => r) -> r+withObNFold r = case snat @n of+  SZ -> r+  SS @n' -> withObNFold @n' @a (withOb2 @k @a @(NFold n' a) r)++-- | If your monoidal category is a strict monoidal category, add 'Strictly' to your 'Ob' constraint.+-- This will let GHC know that the unitors and associators are strict, so you won't have to provide proof of that.+--+-- The four unitors then default to 'id'. The defaults need only @'Unit' '**' a ~ a@ and+-- @a '**' 'Unit' ~ a@, so they also fire for a strictly unital category such as+-- 'Proarrow.Category.Instance.Mat.MatK' or 'Proarrow.Category.Instance.ZX.ZX'. Both associators+-- can use 'associatorDefault':+--+-- @+-- associator \@a \@b \@c = associatorDefault \@a \@b \@c+-- associatorInv \@a \@b \@c = associatorDefault \@a \@b \@c+-- @+type Strictly :: forall {k}. k -> Constraint+class (a ** Unit ~ a, Unit ** a ~ a, forall b c. (Ob b, Ob c) => StrictlyAssoc a b c) => Strictly (a :: k) where+  associatorDefault :: forall b c. (Monoidal k, Ob a, Ob b, Ob c) => (a ** b) ** c ~> a ** (b ** c)++instance (a ** Unit ~ a, Unit ** a ~ a, forall b c. (Ob b, Ob c) => StrictlyAssoc a b c) => Strictly (a :: k) where+  associatorDefault @b @c = withOb2 @_ @b @c (withOb2 @_ @a @(b ** c) id)++instance Monoidal () where+  type Unit = '()++  -- a wildcard, not @'()@, so that @a ** b@ reduces for an abstract @a@, as on pairs+  type _ ** _ = '()+  withOb2 @'() @'() r = r+  leftUnitor = U.Unit+  leftUnitorInv = U.Unit+  rightUnitor = U.Unit+  rightUnitorInv = U.Unit+  associator = U.Unit+  associatorInv = U.Unit++instance (Monoidal j, Monoidal k) => Monoidal (j, k) where+  type Unit = '(Unit, Unit)++  -- Through the projections rather than by matching the pair, so that @a ** b@ reduces for an+  -- abstract @a@: the quantified @a ** b ~ a && b@ of 'Proarrow.Category.Monoidal.Cartesian.Cartesian'+  -- needs that.+  type a ** b = '(Fst @ a ** Fst @ b, Snd @ a ** Snd @ b)+  withOb2 @'(a1, a2) @'(b1, b2) r = withOb2 @j @a1 @b1 (withOb2 @k @a2 @b2 r)+  leftUnitor @'(a1, a2) = leftUnitor @j @a1 :**: leftUnitor @k @a2+  leftUnitorInv @'(a1, a2) = leftUnitorInv @j @a1 :**: leftUnitorInv @k @a2+  rightUnitor @'(a1, a2) = rightUnitor @j @a1 :**: rightUnitor @k @a2+  rightUnitorInv @'(a1, a2) = rightUnitorInv @j @a1 :**: rightUnitorInv @k @a2+  associator @'(a1, a2) @'(b1, b2) @'(c1, c2) = associator @j @a1 @b1 @c1 :**: associator @k @a2 @b2 @c2+  associatorInv @'(a1, a2) @'(b1, b2) @'(c1, c2) = associatorInv @j @a1 @b1 @c1 :**: associatorInv @k @a2 @b2 @c2++instance (MonoidalProfunctor p) => MonoidalProfunctor (Op p) where+  one = Op one+  Op l ** Op r = Op (l ** r)++-- | The opposite of a monoidal category is also monoidal, with the same tensor product.+instance (Monoidal k) => Monoidal (OPPOSITE k) where+  type Unit = OP Unit+  type a ** b = OP (UN OP a ** UN OP b)+  withOb2 @(OP a) @(OP b) r = withOb2 @k @a @b r+  leftUnitor = Op leftUnitorInv+  leftUnitorInv = Op leftUnitor+  rightUnitor = Op rightUnitorInv+  rightUnitorInv = Op rightUnitor+  associator @(OP a) @(OP b) @(OP c) = Op (associatorInv @k @a @b @c)+  associatorInv @(OP a) @(OP b) @(OP c) = Op (associator @k @a @b @c)++instance (SymMonoidal k) => SymMonoidal (OPPOSITE k) where+  swap @(OP a) @(OP b) = Op (swap @k @b @a)++(==) :: (CategoryOf k) => (a :: k) ~> b -> b ~> c -> a ~> c+f == g = g . f++obj2 :: forall {k} a b. (Monoidal k, Ob (a :: k), Ob b) => Obj (a ** b)+obj2 = obj @a ** obj @b++leftUnitor' :: (Monoidal k) => (a :: k) ~> b -> Unit ** a ~> b+leftUnitor' f = f . leftUnitor \\ f++leftUnitorInv' :: (Monoidal k) => (a :: k) ~> b -> a ~> Unit ** b+leftUnitorInv' f = leftUnitorInv . f \\ f++rightUnitor' :: (Monoidal k) => (a :: k) ~> b -> a ** Unit ~> b+rightUnitor' f = f . rightUnitor \\ f++rightUnitorInv' :: (Monoidal k) => (a :: k) ~> b -> a ~> b ** Unit+rightUnitorInv' f = rightUnitorInv . f \\ f++associator' :: forall {k} a b c. (Monoidal k) => Obj (a :: k) -> Obj b -> Obj c -> (a ** b) ** c ~> a ** (b ** c)+associator' a b c = associator @k @a @b @c \\ a \\ b \\ c++associatorInv' :: forall {k} a b c. (Monoidal k) => Obj (a :: k) -> Obj b -> Obj c -> a ** (b ** c) ~> (a ** b) ** c+associatorInv' a b c = associatorInv @k @a @b @c \\ a \\ b \\ c++leftUnitorWith :: forall {k} a b. (Monoidal k, Ob (a :: k)) => b ~> Unit -> b ** a ~> a+leftUnitorWith f = leftUnitor . (f ** obj @a)++leftUnitorInvWith :: forall {k} a b. (Monoidal k, Ob (a :: k)) => Unit ~> b -> a ~> b ** a+leftUnitorInvWith f = (f ** obj @a) . leftUnitorInv++rightUnitorWith :: forall {k} a b. (Monoidal k, Ob (a :: k)) => b ~> Unit -> a ** b ~> a+rightUnitorWith f = rightUnitor . (obj @a ** f)++rightUnitorInvWith :: forall {k} a b. (Monoidal k, Ob (a :: k)) => Unit ~> b -> a ~> a ** b+rightUnitorInvWith f = (obj @a ** f) . rightUnitorInv++unitObj :: (Monoidal k) => Obj (Unit :: k)+unitObj = one++first :: forall {k} c a b. (Monoidal k, Ob (c :: k)) => (a ~> b) -> (a ** c) ~> (b ** c)+first f = f ** obj @c++second :: forall {k} c a b. (Monoidal k, Ob (c :: k)) => (a ~> b) -> (c ** a) ~> (c ** b)+second f = obj @c ** f++type State a = Unit ~> a+type Costate a = a ~> Unit+type Scalar k = (Unit :: k) ~> Unit++class (Monoidal k) => SymMonoidal k where+  swap :: (Ob (a :: k), Ob b) => (a ** b) ~> (b ** a)++instance SymMonoidal () where+  swap = U.Unit++instance (SymMonoidal j, SymMonoidal k) => SymMonoidal (j, k) where+  swap @'(a1, a2) @'(b1, b2) = swap @j @a1 @b1 :**: swap @k @a2 @b2++swap' :: forall {k} (a :: k) a' b b'. (SymMonoidal k) => a ~> a' -> b ~> b' -> (a ** b) ~> (b' ** a')+swap' f g = swap @k @a' @b' . (f ** g) \\ f \\ g++swapInner'+  :: (SymMonoidal k)+  => (a :: k) ~> a'+  -> b ~> b'+  -> c ~> c'+  -> d ~> d'+  -> ((a ** b) ** (c ** d)) ~> ((a' ** c') ** (b' ** d'))+swapInner' a b c d =+  associatorInv' (tgt a) (tgt c) (tgt b ** tgt d)+    . (a ** (associator' (tgt c) (tgt b) (tgt d) . (swap' b c ** d) . associatorInv' (src b) (src c) (src d)))+    . associator' (src a) (src b) (src c ** src d)++swapInner+  :: forall {k} a b c d. (SymMonoidal k, Ob (a :: k), Ob b, Ob c, Ob d) => ((a ** b) ** (c ** d)) ~> ((a ** c) ** (b ** d))+swapInner =+  withOb2 @k @b @d $+    withOb2 @k @c @d $+      associatorInv @k @a @c @(b ** d)+        . (obj @a ** (associator @k @c @b @d . (swap @k @b @c ** obj @d) . associatorInv @k @b @c @d))+        . associator @k @a @b @(c ** d)++swapFst+  :: forall {k} (a :: k) b c d. (SymMonoidal k, Ob a, Ob b, Ob c, Ob d) => (a ** b) ** (c ** d) ~> (c ** b) ** (a ** d)+swapFst = (swap @k @b @c ** obj2 @a @d) . swapInner @b @a @c @d . (swap @k @a @b ** obj2 @c @d)++swapSnd+  :: forall {k} a (b :: k) c d. (SymMonoidal k, Ob a, Ob b, Ob c, Ob d) => (a ** b) ** (c ** d) ~> (a ** d) ** (c ** b)+swapSnd = (obj2 @a @d ** swap @k @b @c) . swapInner @a @b @d @c . (obj2 @a @b ** swap @k @c @d)++swapOuter+  :: forall {k} a b c d. (SymMonoidal k, Ob (a :: k), Ob b, Ob c, Ob d) => ((a ** b) ** (c ** d)) ~> ((d ** b) ** (c ** a))+swapOuter = (obj2 @d @b ** swap @k @a @c) . swapFst @a @b @d @c . (obj2 @a @b ** swap @k @c @d)++data UnitRep :: () +-> k+instance (Monoidal k) => FunctorForRep (UnitRep :: () +-> k) where+  type UnitRep @ '() = Unit+  fmap U.Unit = unitObj+data MultRep :: (k, k) +-> k+instance (Monoidal k) => FunctorForRep (MultRep :: (k, k) +-> k) where+  type MultRep @ '(a, b) = a ** b+  fmap (f :**: g) = f ** g+type Tensor = Rep MultRep++data family UnitF :: k+instance (Monoidal `Elem` cs) => IsFreeOb (UnitF :: FREE cs p) where+  type Lower f UnitF = Unit+  lowerOb @k' @_ r = fromAll @Monoidal @cs @k' r+data family (**!) (a :: k) (b :: k) :: k+instance (IsFreeOb (a :: FREE cs p), IsFreeOb b, Monoidal `Elem` cs) => IsFreeOb (a **! b) where+  type Lower f (a **! b) = Lower f a ** Lower f b+  lowerOb @k' @f r = fromAll @Monoidal @cs @k' (withLowerOb @f @a (withLowerOb @f @b (withOb2 @k' @(Lower f a) @(Lower f b) r)))+instance (Monoidal `Elem` cs) => HasStructure cs (p :: CAT k) Monoidal where+  data Struct Monoidal i o where+    Par0 :: Struct Monoidal UnitF UnitF+    Par :: a ~> b -> c ~> d -> Struct Monoidal (a **! c) (b **! d)+    LeftUnitor :: (Ob a) => Struct Monoidal (UnitF **! a) a+    LeftUnitorInv :: (Ob a) => Struct Monoidal a (UnitF **! a)+    RightUnitor :: (Ob a) => Struct Monoidal (a **! UnitF) a+    RightUnitorInv :: (Ob a) => Struct Monoidal a (a **! UnitF)+    Associator :: (Ob a, Ob b, Ob c) => Struct Monoidal ((a **! b) **! c) (a **! (b **! c))+    AssociatorInv :: (Ob a, Ob b, Ob c) => Struct Monoidal (a **! (b **! c)) ((a **! b) **! c)+  foldStructure _ Par0 = one+  foldStructure go (Par f g) = go f ** go g+  foldStructure @f _ (LeftUnitor @a) = withLowerOb @f @a leftUnitor+  foldStructure @f _ (LeftUnitorInv @a) = withLowerOb @f @a leftUnitorInv+  foldStructure @f _ (RightUnitor @a) = withLowerOb @f @a rightUnitor+  foldStructure @f _ (RightUnitorInv @a) = withLowerOb @f @a rightUnitorInv+  foldStructure @f _ (Associator @a @b @c') = withLowerOb @f @a (withLowerOb @f @b (withLowerOb @f @c' (associator @_ @(Lower f a) @(Lower f b) @(Lower f c'))))+  foldStructure @f _ (AssociatorInv @a @b @c') = withLowerOb @f @a (withLowerOb @f @b (withLowerOb @f @c' (associatorInv @_ @(Lower f a) @(Lower f b) @(Lower f c'))))+instance (WithShow a) => Show (Struct Monoidal a b) where+  showsPrec _ Par0 = P.showString "one"+  showsPrec d (Par f g) = P.showParen (d P.> 8) $ P.showsPrec 9 f . P.showString " ** " . P.showsPrec 9 g+  showsPrec _ LeftUnitor = P.showString "leftUnitor"+  showsPrec _ LeftUnitorInv = P.showString "leftUnitorInv"+  showsPrec _ RightUnitor = P.showString "rightUnitor"+  showsPrec _ RightUnitorInv = P.showString "rightUnitorInv"+  showsPrec _ Associator = P.showString "associator"+  showsPrec _ AssociatorInv = P.showString "associatorInv"++instance (Monoidal `Elem` cs) => MonoidalProfunctor (Free :: CAT (FREE cs (p :: CAT k))) where+  one = St Par0 Nil+  f ** g = St (Par f g) Nil \\ f \\ g+instance (Monoidal `Elem` cs) => Monoidal (FREE cs (p :: CAT k)) where+  type Unit = UnitF+  type a ** b = a **! b+  withOb2 r = r+  leftUnitor = St LeftUnitor Nil+  leftUnitorInv = St LeftUnitorInv Nil+  rightUnitor = St RightUnitor Nil+  rightUnitorInv = St RightUnitorInv Nil+  associator = St Associator Nil+  associatorInv = St AssociatorInv Nil++-- | The structures the free category needs for 'SymMonoidal', and those its laws are stated for.+type SymMonoidalStructures :: [Kind -> Constraint]+type SymMonoidalStructures = '[Monoidal, SymMonoidal]++instance (SymMonoidalStructures `Elems` cs) => HasStructure cs (p :: CAT k) SymMonoidal where+  data Struct SymMonoidal i o where+    Swap :: (Ob a, Ob b) => Struct SymMonoidal (a **! b) (b **! a)+  foldStructure @f _ (Swap @a @b) = withLowerOb @f @a (withLowerOb @f @b (swap @_ @(Lower f a) @(Lower f b)))+instance Show (Struct SymMonoidal a b) where+  showsPrec _ Swap = P.showString "swap"++instance (SymMonoidalStructures `Elems` cs) => SymMonoidal (FREE cs (p :: CAT k)) where+  swap = St Swap Nil++-- | The tensor is a bifunctor, and the unitors and the associator are natural isomorphisms+-- satisfying the triangle and pentagon identities.+instance Laws '[Monoidal] where+  laws =+    inverses "leftUnitor" (\ @a -> Inverses (leftUnitor @_ @a) (leftUnitorInv @_ @a))+      P.++ inverses "rightUnitor" (\ @a -> Inverses (rightUnitor @_ @a) (rightUnitorInv @_ @a))+      P.++ inverses+        "associator"+        (\ @a @b @c -> Inverses (associator @_ @a @b @c) (associatorInv @_ @a @b @c))+      P.++ [ Law "tensor identity" \ @a @b _ -> withOb2 @_ @a @b (obj @a ** obj @b === id)+           , Law "tensor interchange" \ @a @b @c @d @e mor -> do+               f <- mor @a @b "f"+               g <- mor @b @c "g"+               h <- mor @d @e "h"+               i <- mor @e @c "i"+               (g . f) ** (i . h) === (g ** i) . (f ** h)+           , Law "leftUnitor naturality" \ @a @b mor -> do+               f <- mor @a @b "f"+               leftUnitor @_ @b . (one ** f) === f . leftUnitor @_ @a+           , Law "leftUnitorInv naturality" \ @a @b mor -> do+               f <- mor @a @b "f"+               leftUnitorInv @_ @b . f === (one ** f) . leftUnitorInv @_ @a+           , Law "rightUnitor naturality" \ @a @b mor -> do+               f <- mor @a @b "f"+               rightUnitor @_ @b . (f ** one) === f . rightUnitor @_ @a+           , Law "rightUnitorInv naturality" \ @a @b mor -> do+               f <- mor @a @b "f"+               rightUnitorInv @_ @b . f === (f ** one) . rightUnitorInv @_ @a+           , Law "associator naturality" \ @a @b @c @d mor -> do+               f <- mor @a @b "f"+               g <- mor @b @c "g"+               h <- mor @c @d "h"+               associator @_ @b @c @d . ((f ** g) ** h) === (f ** (g ** h)) . associator @_ @a @b @c+           , Law "associatorInv naturality" \ @a @b @c @d mor -> do+               f <- mor @a @b "f"+               g <- mor @b @c "g"+               h <- mor @c @d "h"+               associatorInv @_ @b @c @d . (f ** (g ** h)) === ((f ** g) ** h) . associatorInv @_ @a @b @c+           , Law "triangle identity" \ @a @b _ ->+               (obj @a ** leftUnitor @_ @b) . associator @_ @a @Unit @b === rightUnitor @_ @a ** obj @b+           , Law "pentagon identity" \ @a @b @c @d _ ->+               withOb2 @_ @a @b $+                 withOb2 @_ @b @c $+                   withOb2 @_ @c @d $+                     (obj @a ** associator @_ @b @c @d)+                       . associator @_ @a @(b ** c) @d+                       . (associator @_ @a @b @c ** obj @d)+                       === associator @_ @a @b @(c ** d)+                         . associator @_ @(a ** b) @c @d+           ]++-- | 'swap' is a natural self-inverse satisfying the hexagon identity.+instance Laws SymMonoidalStructures where+  laws =+    [ Law "swap self-inverse" \ @a @b _ -> (swap @_ @b @a . swap @_ @a @b === id) \\ swap @_ @a @b+    , Law "swap naturality" \ @a @b @c @d mor -> do+        f <- mor @a @c "f"+        g <- mor @b @d "g"+        swap @_ @c @d . (f ** g) === (g ** f) . swap @_ @a @b+    , Law "hexagon identity" \ @a @b @c _ ->+        withOb2 @_ @b @c $+          associator @_ @b @c @a+            . swap @_ @a @(b ** c)+            . associator @_ @a @b @c+            === (obj @b ** swap @_ @a @c)+              . associator @_ @b @a @c+              . (swap @_ @a @b ** obj @c)+    ]++-- | 'one' is a unit for '**' up to the unitors, '**' is associative up to the associators, and+-- '**' is natural.+instance ProLaws MonoidalProfunctor where+  proLaws =+    [ ProLaw "left unit" \ @_ @a @b p _ _ -> p =:= dimap (leftUnitorInv @_ @a) (leftUnitor @_ @b) (one ** p)+    , ProLaw "right unit" \ @_ @a @b p _ _ -> p =:= dimap (rightUnitorInv @_ @a) (rightUnitor @_ @b) (p ** one)+    , ProLaw3 "associativity" \ @_ @a @b @c @d @e @f p p' p'' _ _ ->+        (p ** p') ** p'' =:= dimap (associator @_ @a @c @e) (associatorInv @_ @b @d @f) (p ** (p' ** p''))+    , ProLaw3 "** naturality" \ @_ @a @b @c @d @e @f p p' _ morK morJ -> do+        g <- morK @e @a "g"+        g' <- morK @e @c "g'"+        h <- morJ @b @f "h"+        h' <- morJ @d @f "h'"+        dimap (g ** g') (h ** h') (p ** p') =:= dimap g h p ** dimap g' h' p'+    ]
+ src/Proarrow/Category/Monoidal/Action.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Actions of a monoidal category on another category: a 'MonoidalAction' is a representable+-- profunctor @t :: (m, k) '+->' k@ acting as @'Act' t a x@, with 'unitor' and 'multiplicator'+-- coherences. Main instances are the tensor acting on its own category, the cartesian product+-- ('ProdAction') and the coproduct ('CoprodAction').+module Proarrow.Category.Monoidal.Action where++import Data.Kind (Constraint)++import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Sub (SUBCAT (..), Sub (..))+import Proarrow.Category.Instance.Unit qualified as U+import Proarrow.Category.Monoidal (Monoidal (..), Tensor)+import Proarrow.Colimit.BinaryCoproduct+  ( COPROD (..)+  , Coprod (..)+  , HasBinaryCoproducts (..)+  , HasCoproducts+  , associatorCoprod+  , associatorCoprodInv+  , leftUnitorCoprod+  , leftUnitorCoprodInv+  )+import Proarrow.Core (CategoryOf (..), OB, Promonad (..), obj, type (+->))+import Proarrow.Functor (FunctorForRep (..))+import Proarrow.Limit.BinaryProduct+  ( HasBinaryProducts (..)+  , HasProducts+  , PROD (..)+  , Prod (..)+  , associatorProd+  , associatorProdInv+  , leftUnitorProd+  , leftUnitorProdInv+  )+import Proarrow.Profunctor.Representable (Rep (..), Representable (..))++type Act :: (m, k) +-> k -> m -> k -> k+type Act t a x = t % '(a, x)++type MonoidalAction :: forall {m} {k}. (m, k) +-> k -> Constraint++-- | An action of a monoidal category @m@ on a category @k@, given by a representable profunctor+-- @t@ whose functor is @'Act' t@. This is 'Monoidal' with the two sides allowed to differ: taking+-- @k = m@ and @t@ the tensor recovers it.+--+-- __Laws:__+--+-- The two isomorphisms must be mutually inverse:+--+-- * @'unitor' . 'unitorInv' = 'id'@ and @'unitorInv' . 'unitor' = 'id'@+-- * @'multiplicator' . 'multiplicatorInv' = 'id'@ and @'multiplicatorInv' . 'multiplicator' = 'id'@+--+-- natural in every argument (via 'actHom'), and coherent with the monoidal structure of @m@:+--+-- * Triangle: @'actHom' 'id' 'unitor' . 'multiplicator' = 'actHom' ('rightUnitor') 'id'@+-- * Pentagon: @'actHom' 'id' 'multiplicator' . 'multiplicator'+--   = 'multiplicator' . 'actHom' ('associator') 'id'@+--+-- "Proarrow.Testing.Laws" has no check for these laws.+class (Representable t, Monoidal m) => MonoidalAction (t :: (m, k) +-> k) where+  -- | Acting by the 'Unit' does nothing.+  unitor :: (Ob x) => Act t Unit x ~> x++  -- | Inverse to 'unitor'.+  unitorInv :: (Ob x) => x ~> Act t Unit x++  -- | Acting by a tensor is acting twice.+  multiplicator :: (Ob a, Ob b, Ob x) => Act t (a ** b) x ~> Act t a (Act t b x)++  -- | Inverse to 'multiplicator'.+  multiplicatorInv :: (Ob a, Ob b, Ob x) => Act t a (Act t b x) ~> Act t (a ** b) x++actHom :: (Representable t) => a ~> b -> x ~> y -> Act t a x ~> Act t b y+actHom @t l r = repMap @t (l :**: r)++composeActs+  :: forall {m} {k} t (x :: m) (y :: m) (c :: k) (a :: k) (b :: k)+   . (MonoidalAction t, Ob x, Ob y, Ob c)+  => a ~> Act t x b+  -> b ~> Act t y c+  -> a ~> Act t (x ** y) c+composeActs f g = multiplicatorInv @t @x @y @c . actHom @t (obj @x) g . f++decomposeActs+  :: forall {m} {k} t (x :: m) (y :: m) (c :: k) (a :: k) (b :: k)+   . (MonoidalAction t, Ob x, Ob y, Ob c)+  => Act t y c ~> b+  -> Act t x b ~> a+  -> Act t (x ** y) c ~> a+decomposeActs f g = g . actHom @t (obj @x) f . multiplicator @t @x @y @c++-- | The dual of 'Act' partially applied at a fixed acted-on object: 'Act' fixes the acted-on+-- object and varies the index, this fixes the index @x@ and varies the acted-on object.+data family ActionAt :: (m, k) +-> k -> m -> k +-> k++instance (MonoidalAction act, Ob (x :: m)) => FunctorForRep (ActionAt act x :: k +-> k) where+  type ActionAt act x @ a = Act act x a+  fmap = actHom @act (obj @x)++data family NoAction :: ((), k) +-> k+instance (CategoryOf k) => FunctorForRep (NoAction :: ((), k) +-> k) where+  type NoAction @ '(a, x) = x+  fmap (U.Unit :**: f) = f+instance (CategoryOf k) => MonoidalAction (Rep NoAction :: ((), k) +-> k) where+  unitor = id+  unitorInv = id+  multiplicator = id+  multiplicatorInv = id++data family OpAction :: (m, k) +-> k -> (OPPOSITE m, OPPOSITE k) +-> OPPOSITE k+instance (Representable (t :: (m, k) +-> k), CategoryOf m) => FunctorForRep (OpAction t) where+  type OpAction t @ '(OP a, OP x) = OP (t % '(a, x))+  fmap (Op l :**: Op r) = Op (actHom @t l r)+instance (MonoidalAction t) => MonoidalAction (Rep (OpAction t)) where+  unitor = Op (unitorInv @t)+  unitorInv = Op (unitor @t)+  multiplicator @(OP a) @(OP b) @(OP x) = Op (multiplicatorInv @t @a @b @x)+  multiplicatorInv @(OP a) @(OP b) @(OP x) = Op (multiplicator @t @a @b @x)++type SubAction ob t = Rep (SubAction' ob t)+data family SubAction' :: forall (ob :: OB m) -> (m, k) +-> k -> (SUBCAT ob, k) +-> k+instance (Monoidal k, Monoidal (SUBCAT (ob :: OB k)), Representable t) => FunctorForRep (SubAction' ob t) where+  type SubAction' ob t @ '(SUB a, x) = t % '(a, x)+  fmap (Sub f :**: g) = repMap @t (f :**: g)+instance (Monoidal k, Monoidal (SUBCAT (ob :: OB k)), MonoidalAction t) => MonoidalAction (SubAction ob t) where+  unitor = unitor @t+  unitorInv = unitorInv @t+  multiplicator @(SUB p) @(SUB q) @x = multiplicator @t @p @q @x+  multiplicatorInv @(SUB p) @(SUB q) @x = multiplicatorInv @t @p @q @x++instance (Monoidal k) => MonoidalAction (Tensor :: (k, k) +-> k) where+  unitor = leftUnitor @k+  unitorInv = leftUnitorInv @k+  multiplicator @a @b @x = associator @k @a @b @x+  multiplicatorInv @a @b @x = associatorInv @k @a @b @x++type ProdAction = Rep ProdAction'+data family ProdAction' :: (PROD k, k) +-> k+instance (HasProducts k) => FunctorForRep (ProdAction' :: (PROD k, k) +-> k) where+  type ProdAction' @ '(PR a, b) = a && b+  fmap (Prod p :**: q) = p *** q+instance (HasProducts k) => MonoidalAction (ProdAction :: (PROD k, k) +-> k) where+  unitor = leftUnitorProd+  unitorInv = leftUnitorProdInv+  multiplicator @(PR a) @(PR b) @x = associatorProd @a @b @x+  multiplicatorInv @(PR a) @(PR b) @x = associatorProdInv @a @b @x++type CoprodAction = Rep CoprodAction'+data family CoprodAction' :: (COPROD k, k) +-> k+instance (HasCoproducts k) => FunctorForRep (CoprodAction' :: (COPROD k, k) +-> k) where+  type CoprodAction' @ '(COPR a, x) = a || x+  fmap (Coprod l :**: r) = l +++ r+instance (HasCoproducts k) => MonoidalAction (CoprodAction :: (COPROD k, k) +-> k) where+  unitor = leftUnitorCoprod+  unitorInv = leftUnitorCoprodInv+  multiplicator @(COPR a) @(COPR b) @x = associatorCoprod @a @b @x+  multiplicatorInv @(COPR a) @(COPR b) @x = associatorCoprodInv @a @b @x
+ src/Proarrow/Category/Monoidal/Applicative.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Lax monoidal functors between monoidal categories: 'Applicative' generalizes the Prelude class+-- with 'pure' and 'liftA2' stated via the tensor, and 'Alternative' adds coproduct structure over a+-- 'Proarrow.Category.Monoidal.Distributive.Distributive' base.+module Proarrow.Category.Monoidal.Applicative where++import Control.Applicative qualified as P+import Data.Function (($))+import Data.Kind (Constraint, Type)+import Data.List.NonEmpty qualified as P+import Prelude qualified as P++import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), first, leftUnitorInvWith)+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.Distributive (Distributive, DistributiveProfunctor)+import Proarrow.Colimit.BinaryCoproduct (COPROD (..), HasBinaryCoproducts (..), nil, unCoprod, (++))+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), type (+->))+import Proarrow.Functor (FromProfunctor (..), Functor (..), Prelude (..))+import Proarrow.Monoid (Comonoid (..))++type Applicative :: forall {j} {k}. (j -> k) -> Constraint+class (Monoidal j, Monoidal k, Functor f) => Applicative (f :: j -> k) where+  pure :: Unit ~> a -> Unit ~> f a+  liftA2 :: (Ob a, Ob b) => (a ** b ~> c) -> f a ** f b ~> f c++ap :: forall {j} {k} f a b. (Applicative (f :: j -> k), Closed j, Closed k, Ob a, Ob b) => f (a ~~> b) ~> f a ~~> f b+ap = withObExp @j @a @b $ curry @k @_ @(f a) @(f b) (liftA2 @f @(a ~~> b) @a (apply @j @a))++fmapDefault :: forall f a b. (Applicative f) => a ~> b -> f a ~> f b+fmapDefault f = liftA2 @_ @Unit @a (f . leftUnitor @_ @a) . leftUnitorInvWith (pure @f id) \\ f++liftA3 :: forall f a b c d. (Applicative f, Ob a, Ob b, Ob c) => (a ** b ** c ~> d) -> f a ** f b ** f c ~> f d+liftA3 f = withOb2 @_ @a @b (liftA2 @_ @(a ** b) @c f . first @(f c) (liftA2 @f @a @b id))++instance (MonoidalProfunctor (p :: j +-> k), Comonoid x) => Applicative (FromProfunctor p x) where+  pure a () = FromProfunctor $ dimap counit a one+  liftA2 abc (FromProfunctor pxa, FromProfunctor pxb) = FromProfunctor $ dimap comult abc (pxa ** pxb)+instance (MonoidalProfunctor (p :: Type +-> Type)) => P.Applicative (FromProfunctor p x) where+  pure a = pure (\() -> a) ()+  liftA2 f = curry (liftA2 (P.uncurry f))++instance (P.Applicative f) => Applicative (Prelude f) where+  pure a () = Prelude (P.pure (a ()))+  liftA2 f (Prelude fa, Prelude fb) = Prelude (P.liftA2 (P.curry f) fa fb)++deriving via Prelude ((,) a) instance (P.Monoid a) => Applicative ((,) a)+deriving via Prelude ((->) a) instance Applicative ((->) a)+deriving via Prelude [] instance Applicative []+deriving via Prelude (P.Either e) instance Applicative (P.Either e)+deriving via Prelude P.IO instance Applicative P.IO+deriving via Prelude P.Maybe instance Applicative P.Maybe+deriving via Prelude P.NonEmpty instance Applicative P.NonEmpty++type Alternative :: forall {j} {k}. (j -> k) -> Constraint+class (Distributive j, Functor f) => Alternative (f :: j -> k) where+  empty :: (Ob a) => Unit ~> f a+  alt :: (Ob a, Ob b) => (a || b ~> c) -> f a ** f b ~> f c++-- Comonoid (COPR x) means we need x ~> InitialObject.+instance (DistributiveProfunctor (p :: j +-> k), Distributive j, Comonoid (COPR x)) => Alternative (FromProfunctor p x) where+  empty () = FromProfunctor (dimap (unCoprod (counit @(COPR x))) initiate (nil @p))+  alt abc (FromProfunctor pxa, FromProfunctor pyb) =+    FromProfunctor $ dimap (unCoprod (comult @(COPR x))) abc (pxa ++ pyb)++instance (P.Alternative f) => Alternative (Prelude f) where+  empty () = Prelude P.empty+  alt abc (Prelude fl, Prelude fr) = Prelude (P.fmap abc $ P.fmap P.Left fl P.<|> P.fmap P.Right fr)++deriving via Prelude [] instance Alternative []+deriving via Prelude P.Maybe instance Alternative P.Maybe+deriving via Prelude P.IO instance Alternative P.IO
+ src/Proarrow/Category/Monoidal/Cartesian.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Cartesian monoidal categories ('Cartesian': tensor = product, with 'CopyDiscard' as+-- superclass by Fox's theorem), cartesian closed ones ('CCC') and bicartesian closed ones+-- ('BiCCC', which implies 'Distributive'): the meeting point of the monoidal and the product+-- worlds, which never import each other. Lives above+-- "Proarrow.Category.Monoidal.CopyDiscard" rather than with the products, because the superclass+-- points that way.+module Proarrow.Category.Monoidal.Cartesian where++import Prelude (($), type (~))+import Prelude qualified as P++import Proarrow.Category.Instance.Free (Elems, FREE, Free (..), HasStructure (..), Lower, withLowerOb)+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal, UnitF, type (**!))+import Proarrow.Category.Monoidal.Closed (Closed (..), uncurry)+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Distributive (Distributive (..), Traversable (..))+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..), type (||))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), lmap, type (+->))+import Proarrow.Limit.BinaryProduct+  ( HasBinaryProducts (..)+  , HasProducts+  , PROD (..)+  , Prod (..)+  , diag+  , swapProd+  , type (*!)+  )+import Proarrow.Limit.Terminal (HasTerminalObject (..), Semicartesian, TermF)+import Proarrow.Monoid (CocommutativeComonoid, Comonoid (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Product ((:*:) (..))+import Proarrow.Profunctor.Representable (RepCostar (..), Representable (..), withObRep)++class (a ** b ~ a && b) => TensorIsProduct a b+instance (a ** b ~ a && b) => TensorIsProduct a b++-- | A cartesian monoidal category: the tensor is the product and the unit the terminal object.+-- By Fox's theorem this is the same as a 'CopyDiscard' category whose 'copy' and 'discard' are+-- natural, so 'CopyDiscard' is a superclass. Every cartesian category supplies its diagonals as+-- comonoids, and anything asking only for copying and discarding (prisms, for instance) accepts+-- a cartesian category directly. The law relating the two is @copy = id &&& id@ and+-- @discard = terminate@.+class+  (HasProducts k, SymMonoidal k, Semicartesian k, CopyDiscard k, forall (a :: k) (b :: k). TensorIsProduct a b) =>+  Cartesian k++instance+  (HasProducts k, SymMonoidal k, Semicartesian k, CopyDiscard k, forall (a :: k) (b :: k). TensorIsProduct a b)+  => Cartesian k++-- | In a category with products every object is a comonoid via the diagonal and the terminal+-- map. With this comonoid structure 'PROD' is 'CopyDiscard' and 'Cartesian'.+instance (HasProducts k, Ob a) => Comonoid (PR (a :: k)) where+  counit = Prod terminate+  comult = Prod diag++instance (HasProducts k, Ob a) => CocommutativeComonoid (PR (a :: k))++-- | A category with products, viewed through 'PROD' as a monoidal category, is cartesian.+instance (HasProducts k) => CopyDiscard (PROD k)++-- | In a cartesian category the tensor /is/ the product ('TensorIsProduct'), but GHC only applies+-- that equation at the top of a type, never under another type family such as @('||')@, and+-- using the quantified form of it directly sends the solver in circles. These two identities take+-- the equation as an ordinary given (discharged at the call site from the quantified superclass+-- of 'Cartesian'), so it can be applied where a product-typed leg meets tensor-typed plumbing.+tensorToProduct :: forall {k} (a :: k) b. (HasBinaryProducts k, TensorIsProduct a b, Ob a, Ob b) => (a ** b) ~> (a && b)+tensorToProduct = withObProd @k @a @b id++productToTensor :: forall {k} (a :: k) b. (HasBinaryProducts k, TensorIsProduct a b, Ob a, Ob b) => (a && b) ~> (a ** b)+productToTensor = withObProd @k @a @b id++-- | Every functor between cartesian categories is oplax monoidal, @f (a && b) ~> f a && f b@ by the+-- projections and @f Unit ~> Unit@ by terminality. On the 'RepCostar' of its representable profunctor+-- this is 'Proarrow.Category.Monoidal.OplaxMonoidal'.+instance (Representable p, Cartesian j, Cartesian k) => MonoidalProfunctor (RepCostar (p :: j +-> k)) where+  one = withObRep @p @Unit (RepCostar terminate)+  RepCostar @a f ** RepCostar @b g = withOb2 @j @a @b (RepCostar (unparRepCartesian @p @a @b f g))++unparRepCartesian+  :: forall {j} {k} p (a :: j) b a' b'+   . ( Representable (p :: j +-> k)+     , Cartesian k+     , Cartesian j+     , TensorIsProduct a b+     , TensorIsProduct a' b'+     , Ob a+     , Ob b+     )+  => (p % a ~> a') -> (p % b ~> b') -> p % (a ** b) ~> (a' ** b')+unparRepCartesian f g = f . repMap @p (fst @j @a @b) &&& g . repMap @p (snd @j @a @b)++class (Cartesian k, Closed k) => CCC k+instance (Cartesian k, Closed k) => CCC k++type Bicartesian k = (Cartesian k, Distributive k)++-- | Bicartesian closed: cartesian closed with coproducts. Every such category is distributive+-- (@a &&@ is a left adjoint, so it preserves coproducts), and the class says so, so that+-- 'Distributive' never has to be asked for separately.+class (CCC k, Distributive k) => BiCCC k++instance (CCC k, Distributive k) => BiCCC k++-- | Distributivity of the /product/ over coproducts, derived from closedness: in any BiCCC the+-- functor @a &&@ is a left adjoint and so preserves coproducts.+distLProd :: forall {k} (a :: k) (b :: k) (c :: k). (BiCCC k, Ob a, Ob b, Ob c) => (a && (b || c)) ~> (a && b || a && c)+distLProd = (swapProd @b @a +++ swapProd @c @a) . distRProd @b @c @a . withObCoprod @k @b @c (swapProd @a @(b || c))++distRProd :: forall {k} (a :: k) (b :: k) (c :: k). (BiCCC k, Ob a, Ob b, Ob c) => ((a || b) && c) ~> (a && c || b && c)+distRProd =+  withObProd @k @a @c $+    withObProd @k @b @c $+      withObCoprod @k @(a && c) @(b && c) $+        uncurry @c (curry @k @a @c (lft @k @(a && c) @(b && c)) ||| curry @k @b @c (rgt @k @(a && c) @(b && c)))++instance (BiCCC k) => Distributive (PROD k) where+  distL @(PR a) @(PR b) @(PR c) = Prod (distLProd @a @b @c)+  distR @(PR a) @(PR b) @(PR c) = Prod (distRProd @a @b @c)+  absorbL @(PR a) = Prod (snd @k @a)+  absorbR @(PR a) = Prod (fst @k @_ @a)++instance (Cartesian k, Traversable p, Traversable q) => Traversable ((p :: k +-> k) :*: q) where+  traverse ((p :*: q) :.: r) = case (traverse (p :.: r), traverse (q :.: r)) of+    ((:.:) @a r' p', (:.:) @b r'' q') -> lmap diag (r' ** r'') :.: (lmap (fst @k @a @b) p' :*: lmap (snd @k @a @b) q') \\ p \\ p' \\ q'++ap+  :: forall {j} {k} y a x p+   . (Closed j, Cartesian k, MonoidalProfunctor (p :: j +-> k), Ob y)+  => p a (x ~~> y)+  -> p a x+  -> p a y+ap pf px = dimap diag (apply @j @x @y) (pf ** px) \\ px++-- | The free-category structure for 'Cartesian'. The free category cannot satisfy the /type+-- equality/ @tensor = product@ ('TensorIsProduct' fails on it, see "Proarrow.Category.Instance.Free"),+-- but it can carry the corresponding isomorphisms as formal arrows, interpreted to the identity in+-- any cartesian target ('productToTensor' and friends). So a free category can serve as syntax+-- for cartesian (closed) categories without collapsing its object grammar.+instance+  ('[Cartesian, HasTerminalObject, HasBinaryProducts, Monoidal] `Elems` cs)+  => HasStructure cs (p :: CAT k) Cartesian+  where+  data Struct Cartesian i o where+    ProdToTensor :: (Ob a, Ob b) => Struct Cartesian (a *! b) (a **! b)+    TensorToProd :: (Ob a, Ob b) => Struct Cartesian (a **! b) (a *! b)+    TermToUnit :: Struct Cartesian TermF UnitF+    UnitToTerm :: Struct Cartesian UnitF TermF+  foldStructure @f _ (ProdToTensor @a @b) =+    withLowerOb @f @a (withLowerOb @f @b (productToTensor @(Lower f a) @(Lower f b)))+  foldStructure @f _ (TensorToProd @a @b) =+    withLowerOb @f @a (withLowerOb @f @b (tensorToProduct @(Lower f a) @(Lower f b)))+  foldStructure _ TermToUnit = id+  foldStructure _ UnitToTerm = id++instance P.Show (Struct Cartesian a b) where+  showsPrec _ ProdToTensor = P.showString "prodToTensor"+  showsPrec _ TensorToProd = P.showString "tensorToProd"+  showsPrec _ TermToUnit = P.showString "termToUnit"+  showsPrec _ UnitToTerm = P.showString "unitToTerm"++-- | The formal @tensor = product@ isomorphisms of a free category with 'Cartesian' in its list.+prodToTensor+  :: forall {k} {cs} {p :: CAT k} (a :: FREE cs p) b+   . ('[Cartesian, HasTerminalObject, HasBinaryProducts, Monoidal] `Elems` cs, Ob a, Ob b)+  => (a *! b) ~> (a **! b)+prodToTensor = St ProdToTensor Nil++tensorToProd+  :: forall {k} {cs} {p :: CAT k} (a :: FREE cs p) b+   . ('[Cartesian, HasTerminalObject, HasBinaryProducts, Monoidal] `Elems` cs, Ob a, Ob b)+  => (a **! b) ~> (a *! b)+tensorToProd = St TensorToProd Nil++termToUnit+  :: forall {k} {cs} {p :: CAT k}+   . ('[Cartesian, HasTerminalObject, HasBinaryProducts, Monoidal] `Elems` cs)+  => (TermF :: FREE cs p) ~> UnitF+termToUnit = St TermToUnit Nil++unitToTerm+  :: forall {k} {cs} {p :: CAT k}+   . ('[Cartesian, HasTerminalObject, HasBinaryProducts, Monoidal] `Elems` cs)+  => (UnitF :: FREE cs p) ~> TermF+unitToTerm = St UnitToTerm Nil
+ src/Proarrow/Category/Monoidal/Closed.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Closed monoidal categories: 'Closed' provides the internal hom @a '~~>' b@, right adjoint to+-- tensoring, with 'curry', 'apply' and functoriality @('^^^')@. Also defines cartesian closed+-- ('CCC') and bicartesian closed ('BiCCC') categories.+module Proarrow.Category.Monoidal.Closed where++import Data.Kind (Constraint, Type)+import Prelude (($))+import Prelude qualified as P++import Proarrow.Category.Instance.Bool (BOOL (..), BoolLeq, Booleans (..))+import Proarrow.Category.Instance.Free+  ( Elem (..)+  , Elems+  , FREE (..)+  , Free (..)+  , HasStructure (..)+  , IsFreeOb (..)+  , Lower+  , WithShow+  , withLowerOb+  )+import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Unit qualified as U+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..), type (**!))+import Proarrow.Category.Monoidal.Strictified (Fold, Strictified (..), concatMany, obj1, singleton, splitMany, (==))+import Proarrow.Core (CAT, CategoryOf (..), Kind, Profunctor (..), Promonad (..), obj, (//), type (+->))+import Proarrow.Functor (FunctorForRep (..))+import Proarrow.Limit.BinaryProduct ()+import Proarrow.Profunctor.Corepresentable (Corepresentable (..))+import Proarrow.Profunctor.Representable (Rep (..))+import Proarrow.Tools.Laws (Bijection (..), Law (..), Laws (..), bijection, (===))++infixr 2 ~~>++-- | A (right) closed monoidal category: every @b '~~>' c@ is an internal hom, right adjoint to+-- tensoring with @b@. 'curry' and 'Proarrow.Category.Monoidal.Closed.uncurry' witness the+-- adjunction @Hom(a '**' b, c) ≅ Hom(a, b '~~>' c)@.+--+-- __Laws:__+--+-- * @'curry'@ and @'Proarrow.Category.Monoidal.Closed.uncurry'@ are mutually inverse:+--   @'Proarrow.Category.Monoidal.Closed.uncurry' ('curry' f) = f@ and+--   @'curry' ('Proarrow.Category.Monoidal.Closed.uncurry' g) = g@+-- * and natural in all three variables: for @f :: a' '~>' a@, @g :: b' '~>' b@, @h :: c '~>' c'@,+--   @'curry' . 'dimap' (f '**' g) h = 'dimap' f (h '^^^' g) . 'curry'@+--+-- Together these say @'curry'@ is a natural isomorphism, which also forces the familiar+-- @'apply' . ('curry' f '**' 'id') = f@. The exponential is thereby functorial: @'(^^^)'@ is+-- contravariant in its second argument and covariant in its first.+--+-- Checked by 'Proarrow.Testing.Laws.testClosed'.+class (Monoidal k) => Closed k where+  -- | The internal hom (exponential) object.+  type (a :: k) ~~> (b :: k) :: k++  -- | Recovers @'Ob' (a '~~>' b)@ from the objecthood of the ends.+  withObExp :: (Ob (a :: k), Ob b) => ((Ob (a ~~> b)) => r) -> r++  -- | Transposes an arrow out of a tensor into one into an exponential.+  curry :: (Ob (a :: k), Ob b) => a ** b ~> c -> a ~> b ~~> c++  -- | Evaluation: the counit of the adjunction.+  apply :: (Ob (a :: k), Ob b) => (a ~~> b) ** a ~> b++  -- | The exponential's action on arrows: covariant in the result, contravariant in the argument.+  (^^^) :: forall (a :: k) b x y. b ~> y -> x ~> a -> a ~~> b ~> x ~~> y+  f ^^^ g =+    f //+      g //+        withObExp @k @a @b $+          let ab = obj @(a ~~> b) in curry @k @(a ~~> b) @x (f . apply @k @a @b . (ab ** g))++uncurry :: forall {k} b c (a :: k). (Closed k) => (Ob b, Ob c) => a ~> b ~~> c -> a ** b ~> c+uncurry f = apply @k @b @c . (f ** obj @b)++curryS :: forall {k} b c (a :: k). (Closed k) => [a, b] ~> '[c] -> '[a] ~> '[b ~~> c]+curryS (Str f) = withObExp @k @b @c $ Str (curry @k @a @b @c f)++curryS'+  :: forall {k} as c (b :: k). (Closed k, Ob as, Ob b) => (as ** '[b]) ~> '[c] -> as ~> '[b ~~> c]+curryS' f = concatMany == curryS @b @c @(Fold as) (splitMany @as ** obj1 == f)++applyS :: forall {k} (a :: k) b. (Closed k, Ob a, Ob b) => '[a ~~> b, a] ~> '[b]+applyS = withObExp @k @a @b $ Str (apply @k @a @b)++uncurryS :: forall {k} b c (a :: k). (Closed k, Ob b, Ob c) => '[a] ~> '[b ~~> c] -> '[a, b] ~> '[c]+uncurryS f = f ** obj1 == applyS++uncurryS' :: forall {k} as b (c :: k). (Closed k, Ob b, Ob c) => as ~> '[b ~~> c] -> (as ** '[b]) ~> '[c]+uncurryS' f@Str{} = concatMany @as ** obj1 == uncurryS @b @c @(Fold as) (splitMany == f)++compS :: forall {k} (a :: k) b c. (Closed k, Ob a, Ob b, Ob c) => '[b ~~> c, a ~~> b] ~> '[a ~~> c]+compS =+  withObExp @k @b @c $+    withObExp @k @a @b $+      curryS' (obj1 ** applyS @a @b == applyS @b @c)++comp :: forall {k} (a :: k) b c. (Closed k, Ob a, Ob b, Ob c) => (b ~~> c) ** (a ~~> b) ~> a ~~> c+comp = unStr (compS @a @b @c)++mkExponentialS :: forall {k} (a :: k) b. (Closed k) => '[a] ~> '[b] -> '[] ~> '[a ~~> b]+mkExponentialS f@Str{} = curryS' f++mkExponential :: forall {k} a b. (Closed k) => (a :: k) ~> b -> Unit ~> (a ~~> b)+mkExponential ab = unStr (mkExponentialS (singleton ab))++lowerS :: forall {k} (a :: k) b. (Closed k, Ob a, Ob b) => ('[] ~> '[a ~~> b]) -> '[a] ~> '[b]+lowerS = uncurryS'++lower :: forall {k} (a :: k) b. (Closed k, Ob a, Ob b) => (Unit ~> (a ~~> b)) -> a ~> b+lower f = unStr (lowerS (Str f)) \\ f++toEl :: forall {k} (a :: k). (Closed k, Ob a) => a ~> Unit ~~> a+toEl = curry @k @a @Unit @a rightUnitor++instance Closed Type where+  type a ~~> b = a -> b+  withObExp r = r+  curry = P.curry+  apply = P.uncurry id+  (^^^) = P.flip dimap++instance Closed () where+  type '() ~~> '() = '()+  withObExp r = r+  curry U.Unit = U.Unit+  apply = U.Unit+  U.Unit ^^^ U.Unit = U.Unit++-- | Implication is the internal hom of the walking arrow: @a ~~> b@ is @'BoolLeq' a b@.+instance Closed BOOL where+  type a ~~> b = BoolLeq a b+  withObExp @a @b r = case (obj @a, obj @b) of+    (Fls, Fls) -> r+    (Fls, Tru) -> r+    (Tru, Fls) -> r+    (Tru, Tru) -> r+  curry @a @b @c f =+    ( case (obj @a, obj @b, obj @c) of+        (Fls, Fls, Fls) -> F2T+        (Fls, Fls, Tru) -> F2T+        (Fls, Tru, Fls) -> Fls+        (Fls, Tru, Tru) -> F2T+        (Tru, Fls, Fls) -> Tru+        (Tru, Fls, Tru) -> Tru+        (Tru, Tru, Fls) -> case f of {}+        (Tru, Tru, Tru) -> Tru+    )+      \\ f+  apply @a @b = case (obj @a, obj @b) of+    (Fls, Fls) -> Fls+    (Fls, Tru) -> F2T+    (Tru, Fls) -> Fls+    (Tru, Tru) -> Tru++instance (Closed j, Closed k) => Closed (j, k) where+  type '(a1, a2) ~~> '(b1, b2) = '(a1 ~~> b1, a2 ~~> b2)+  withObExp @'(a1, a2) @'(b1, b2) r = withObExp @j @a1 @b1 (withObExp @k @a2 @b2 r)+  curry @'(a1, a2) @'(b1, b2) (f1 :**: f2) = curry @j @a1 @b1 f1 :**: curry @k @a2 @b2 f2+  apply @'(a1, a2) @'(b1, b2) = apply @j @a1 @b1 :**: apply @k @a2 @b2+  (f1 :**: f2) ^^^ (g1 :**: g2) = (f1 ^^^ g1) :**: (f2 ^^^ g2)++data family ExpRep :: (OPPOSITE k, k) +-> k+instance (Closed k) => FunctorForRep (ExpRep :: (OPPOSITE k, k) +-> k) where+  type ExpRep @ '(OP a, b) = a ~~> b+  fmap (Op f :**: g) = g ^^^ f++data family Not (r :: k) :: OPPOSITE k +-> k+instance (Closed k, Ob r) => FunctorForRep (Not (r :: k)) where+  type Not r @ OP a = a ~~> r+  fmap (Op f) = obj @r ^^^ f++-- | The "reader"\/exponential-by-@m@ functor, covariant unlike 'Not' (which fixes the codomain).+data family Exp (m :: k) :: k +-> k++instance (Closed k, Ob m) => FunctorForRep (Exp m :: k +-> k) where+  type Exp m @ a = m ~~> a+  fmap f = f ^^^ obj @m++-- | The Op-Op adjunction, giving rise to the continuation monad.+instance (Closed k, SymMonoidal k, Ob r) => Corepresentable (Rep (Not (r :: k))) where+  type Rep (Not r) %% a = OP (a ~~> r)+  cotabulate (Op f) = Rep (swapClosed @r f) \\ f+  coindex (Rep f) = Op (swapClosed @r f)+  corepMap f = Op (obj @r ^^^ f)++swapClosed :: forall {k} (c :: k) a b. (Closed k, SymMonoidal k, Ob b, Ob c) => a ~> b ~~> c -> b ~> a ~~> c+swapClosed f = curry @k @b @a (uncurry @b @c f . swap @k @b @a) \\ f++data family (-->) (a :: k) (b :: k) :: k++-- | The structures the free category needs for 'Closed', and those its laws are stated for.+type ClosedStructures :: [Kind -> Constraint]+type ClosedStructures = '[Monoidal, Closed]++instance (IsFreeOb (a :: FREE cs p), IsFreeOb b, ClosedStructures `Elems` cs) => IsFreeOb (a --> b) where+  type Lower f (a --> b) = Lower f a ~~> Lower f b+  lowerOb @k' @f r = fromAll @Closed @cs @k' (withLowerOb @f @a (withLowerOb @f @b (withObExp @k' @(Lower f a) @(Lower f b) r)))+instance (ClosedStructures `Elems` cs) => HasStructure cs (p :: CAT k) Closed where+  data Struct Closed a b where+    Apply :: (Ob a, Ob b) => Struct Closed ((a --> b) **! a) b+    Curry :: forall a b c. (Ob a, Ob b) => (a **! b) ~> c -> Struct Closed a (b --> c)+  foldStructure @f _ (Apply @a @b) = withLowerOb @f @a (withLowerOb @f @b (apply @_ @(Lower f a) @(Lower f b)))+  foldStructure @f go (Curry @a @b f) = withLowerOb @f @a (withLowerOb @f @b (curry @_ @(Lower f a) @(Lower f b) (go f)))+instance (WithShow a) => P.Show (Struct Closed a b) where+  showsPrec _ Apply = P.showString "apply"+  showsPrec d (Curry f) = P.showParen (d P.> 10) $ P.showString "curry " . P.showsPrec 11 f++instance (ClosedStructures `Elems` cs) => Closed (FREE cs (p :: CAT k)) where+  type a ~~> b = a --> b+  withObExp r = r+  curry f = St (Curry f) Nil \\ f+  apply = St Apply Nil++-- | 'apply' undoes 'curry' and every arrow into an exponential is the 'curry' of one ('curry' is+-- a bijection with inverse @f |-> 'apply' . (f '**' 'id')@), 'curry' is natural in all three+-- objects, and '^^^' is the exponential's action on arrows defined from 'curry' and 'apply'.+-- Together these make @(- ** b)@ left adjoint to @(b ~~> -)@, and '^^^' a profunctor.+instance Laws ClosedStructures where+  laws =+    bijection+      "curry"+      ( \ @a @b @c mor ->+          withOb2 @_ @a @b $+            withObExp @_ @b @c $+              Bijection (mor @(a ** b) @c "p") (mor @a @(b ~~> c) "q") (curry @_ @a @b) (\q -> apply @_ @b @c . (q ** obj @b))+      )+      P.++ [ Law "curry naturality" \ @a @b @c @d @e mor -> withOb2 @_ @a @b $ withOb2 @_ @d @d do+               p <- mor @(a ** b) @c "p"+               f <- mor @d @a "f"+               g <- mor @d @b "g"+               h <- mor @c @e "h"+               (h ^^^ g) . curry @_ @a @b p . f === curry @_ @d @d (h . p . (f ** g))+           , Law "internal hom on arrows" \ @a @b @c @d mor -> do+               f <- mor @b @d "f"+               g <- mor @c @a "g"+               withObExp @_ @a @b (f ^^^ g === curry @_ @(a ~~> b) @c (f . apply @_ @a @b . (obj @(a ~~> b) ** g)))+           ]
+ src/Proarrow/Category/Monoidal/Coclosed.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Coclosed monoidal categories, dual to "Proarrow.Category.Monoidal.Closed": 'Coclosed' provides+-- the coexponential @a '<~~' b@, left adjoint to tensoring, with 'coeval' and its universal property+-- 'coevalUniv'; 'CoCCC' is the cocartesian coclosed case.+module Proarrow.Category.Monoidal.Coclosed where++import Proarrow.Category.Instance.Unit (Unit (..))+import Proarrow.Category.Monoidal (Monoidal (..))+import Proarrow.Colimit.BinaryCoproduct (Cocartesian)+import Proarrow.Core (CategoryOf (..))++-- | A coclosed monoidal category, dual to 'Proarrow.Category.Monoidal.Closed.Closed': the+-- coexponential @a '<~~' b@ is /left/ adjoint to tensoring with @b@, so 'coevalUniv' witnesses+-- @Hom(a '<~~' b, c) ≅ Hom(a, c '**' b)@ with 'coeval' as the unit.+--+-- __Laws:__+--+-- * @'coevalUniv'@ is a bijection, inverted by @\\g -> (g '**' 'id') . 'coeval'@:+--   @('coevalUniv' f '**' 'id') . 'coeval' = f@ and @'coevalUniv' ((g '**' 'id') . 'coeval') = g@+-- * and natural in all three variables, dually to 'Proarrow.Category.Monoidal.Closed.curry'.+--+-- Unlike those of 'Proarrow.Category.Monoidal.Closed.Closed', these laws have no check in+-- "Proarrow.Testing.Laws".+class (Monoidal k) => Coclosed k where+  -- | The coexponential object.+  type (a :: k) <~~ (b :: k) :: k++  -- | Recovers @'Ob' (a '<~~' b)@ from the objecthood of the ends.+  withObCoExp :: (Ob (a :: k), Ob b) => ((Ob (a <~~ b)) => r) -> r++  -- | Co-evaluation: the unit of the adjunction.+  coeval :: (Ob (a :: k), Ob b) => a ~> (a <~~ b) ** b++  -- | Transposes an arrow into a tensor into one out of a coexponential.+  coevalUniv :: (Ob (b :: k), Ob c) => a ~> c ** b -> (a <~~ b) ~> c++instance Coclosed () where+  type (a :: ()) <~~ (b :: ()) = '()+  withObCoExp f = f+  coeval = Unit+  coevalUniv Unit = Unit++class (Cocartesian k, Coclosed k) => CoCCC k+instance (Cocartesian k, Coclosed k) => CoCCC k
+ src/Proarrow/Category/Monoidal/CompactClosed.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE RequiredTypeArguments #-}+{-# OPTIONS_GHC -Wno-unused-foralls #-}++-- | Compact closed categories: star-autonomous categories whose dual distributes over the tensor+-- ('distribDual', 'dualUnit'), so that every object has a duality unit and counit ('dualityUnit',+-- 'dualityCounit') and every morphism @x ** u ~> y ** u@ has a trace ('traceCC').+module Proarrow.Category.Monoidal.CompactClosed where++import Data.Kind (Constraint)+import Prelude (($))+import Prelude qualified as P++import Proarrow.Category.Instance.Free (Elems, FREE (..), Free (..), HasStructure (..), Lower, withLowerOb)+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Unit qualified as U+import Proarrow.Category.Monoidal+  ( Monoidal (..)+  , MonoidalProfunctor (..)+  , SymMonoidal (..)+  , UnitF+  , leftUnitorWith+  , swap+  , unitObj+  , type (**!)+  )+import Proarrow.Category.Monoidal.Action (Act, MonoidalAction (..), actHom)+import Proarrow.Category.Monoidal.Closed (Closed)+import Proarrow.Category.Monoidal.StarAutonomous+  ( DualF+  , StarAutonomous (..)+  , doubleNeg+  , dualObj+  , dualityCounitSA+  , dualityUnitSA+  )+import Proarrow.Category.Monoidal.Strictified (Strictified (..), obj1, swap2, (==))+import Proarrow.Core (CAT, CategoryOf (..), Kind, Profunctor (..), Promonad (..), obj, type (+->))+import Proarrow.Tools.Laws (Inverses (..), Labelled (..), Law (..), Laws (..), inverses, (===))++class (StarAutonomous k, SymMonoidal k) => CompactClosed k where+  distribDual :: forall (a :: k) b. (Ob a, Ob b) => Dual (a ** b) ~> Dual a ** Dual b+  dualUnit :: Dual (Unit :: k) ~> Unit++  -- | The unit of the duality between @a@ and its dual. 'dualityUnitDefault' gives it from the+  -- *-autonomous structure; an instance with cups of its own can use them. (There is no default+  -- method: @a@ occurs only under type families, so GHC could not instantiate one.)+  dualityUnit :: (Ob (a :: k)) => Unit ~> a ** Dual a++  -- | The counit of the duality between @a@ and its dual; see 'dualityCounitDefault'.+  dualityCounit :: (Ob (a :: k)) => Dual a ** a ~> Unit++dualUnitInv :: forall {k}. (CompactClosed k) => (Unit :: k) ~> Dual Unit+dualUnitInv = leftUnitor @k @(Dual Unit) . dualityUnit @k @Unit \\ dualObj @(Unit :: k)++-- | 'dualityUnit' from the *-autonomous structure.+dualityUnitDefault :: forall {k} (a :: k). (CompactClosed k, Ob a) => Unit ~> a ** Dual a+dualityUnitDefault = let dualA = dualObj @a in (doubleNeg @k @a ** dualA) . distribDual @k @(Dual a) @a . dualityUnitSA @a \\ dualA++dualityUnitS :: forall {k} (a :: k). (CompactClosed k, Ob a) => '[] ~> [a, Dual a]+dualityUnitS = withObDual @k @a (Str @'[] @[a, Dual a] (dualityUnit @k @a))++-- | 'dualityCounit' from the *-autonomous structure.+dualityCounitDefault :: forall {k} (a :: k). (CompactClosed k, Ob a) => Dual a ** a ~> Unit+dualityCounitDefault = dualUnit . dualityCounitSA @a++dualityCounitS :: forall {k} (a :: k). (CompactClosed k, Ob a) => [Dual a, a] ~> '[]+dualityCounitS = withObDual @k @a (Str @[Dual a, a] @'[] (dualityCounit @k @a))++combineDual :: forall {k} a b. (CompactClosed k, Ob (a :: k), Ob b) => Dual a ** Dual b ~> Dual (a ** b)+combineDual =+  withObDual @k @a $+    withObDual @k @b $+      withOb2 @k @(Dual a) @(Dual b) $+        linDist @k @_ @a @b $+          leftUnitorWith (dualityCounit @k @a . swap @k @a @(Dual a))+            . associatorInv @k @a @(Dual a) @(Dual b)+            . swap @k @(Dual a ** Dual b) @a++combineDualS :: forall {k} a b. (CompactClosed k, Ob (a :: k), Ob b) => '[Dual a, Dual b] ~> '[Dual (a ** b)]+combineDualS =+  withObDual @k @a (withObDual @k @b (withOb2 @k @a @b (withObDual @k @(a ** b) (Str (combineDual @a @b)))))++-- | The dimension of @a@: the trace of its identity, as a scalar.+dimension :: forall {k} (a :: k). (CompactClosed k, Ob a) => (Unit :: k) ~> Unit+dimension = traceCC @a (unitObj ** obj @a)++traceCCS :: forall {k} u (x :: k) y. (CompactClosed k, Ob x, Ob y, Ob u) => [x, u] ~> [y, u] -> '[x] ~> '[y]+traceCCS f =+  withObDual @k @u $+    obj1 @x ** dualityUnitS @u+      == f ** obj1 @(Dual u)+      == obj1 @y ** (swap2 @u @(Dual u) == dualityCounitS @u)++traceCC :: forall {k} u (x :: k) y. (CompactClosed k, Ob x, Ob y, Ob u) => x ** u ~> y ** u -> x ~> y+traceCC f = unStr (traceCCS @u (Str f))++coactCC+  :: forall {m} {k} (t :: (m, k) +-> k) (u :: m) (x :: k) (y :: k)+   . (CompactClosed m, MonoidalAction t, Ob x, Ob y, Ob u) => Act t u x ~> Act t u y -> x ~> y+coactCC f =+  unitor @t @y+    . actHom @t (dualityCounit @_ @u) (obj @y)+    . multiplicatorInv @t @(Dual u) @u @y+    . actHom @t (obj @(Dual u)) f+    . multiplicator @t @(Dual u) @u @x+    . actHom @t (swap @m @u @(Dual u) . dualityUnit @_ @u) (obj @x)+    . unitorInv @t @x+    \\ dualObj @u++instance CompactClosed () where+  distribDual = U.Unit+  dualUnit = U.Unit+  dualityUnit = U.Unit+  dualityCounit = U.Unit++instance (CompactClosed j, CompactClosed k) => CompactClosed (j, k) where+  distribDual @'(a, a') @'(b, b') = distribDual @j @a @b :**: distribDual @k @a' @b'+  dualUnit = dualUnit :**: dualUnit+  dualityUnit @'(a, a') = dualityUnit @j @a :**: dualityUnit @k @a'+  dualityCounit @'(a, a') = dualityCounit @j @a :**: dualityCounit @k @a'++-- | The structures the free category needs for 'CompactClosed', and those its laws are stated for.+type CompactClosedStructures :: [Kind -> Constraint]+type CompactClosedStructures = '[Monoidal, SymMonoidal, Closed, StarAutonomous, CompactClosed]++instance+  (CompactClosedStructures `Elems` cs)+  => HasStructure cs (p :: CAT k) CompactClosed+  where+  data Struct CompactClosed a b where+    DistribDual :: (Ob a, Ob b) => Struct CompactClosed (DualF (a **! b)) (DualF a **! DualF b)+    DualUnit :: Struct CompactClosed (DualF UnitF) UnitF+  foldStructure @f _ (DistribDual @a @b) =+    withLowerOb @f @a (withLowerOb @f @b (distribDual @_ @(Lower f a) @(Lower f b)))+  foldStructure _ DualUnit = dualUnit+instance P.Show (Struct CompactClosed a b) where+  showsPrec _ DistribDual = P.showString "distribDual"+  showsPrec _ DualUnit = P.showString "dualUnit"++instance+  (CompactClosedStructures `Elems` cs)+  => CompactClosed (FREE cs (p :: CAT k))+  where+  distribDual @a @b = St (DistribDual @a @b) Nil+  dualUnit = St DualUnit Nil+  dualityUnit @a = dualityUnitDefault @a+  dualityCounit @a = dualityCounitDefault @a++-- | 'distribDual' and 'dualUnit' are isomorphisms (so 'Dual' is strong monoidal), and 'dualityUnit'+-- and 'dualityCounit' satisfy the zigzag identities, making @Dual a@ dual to @a@.+instance Laws CompactClosedStructures where+  laws =+    inverses "distribDual" (\ @a @b -> Inverses (distribDual @_ @a @b) (label "combineDual" (combineDual @a @b)))+      P.++ inverses "dualUnit" (Inverses dualUnit (label "dualUnitInv" dualUnitInv))+      P.++ [ Law "dualityUnit definition" \ @a _ -> withObDual @_ @a (dualityUnit @_ @a === dualityUnitDefault @a)+           , Law "dualityCounit definition" \ @a _ -> withObDual @_ @a (dualityCounit @_ @a === dualityCounitDefault @a)+           , Law+               "zigzag (a)"+               \ @a _ ->+                 withObDual @_ @a $+                   ( rightUnitor @_ @a+                       . (obj @a ** dualityCounit @_ @a)+                       . associator @_ @a @(Dual a) @a+                       . (dualityUnit @_ @a ** obj @a)+                       . leftUnitorInv @_ @a+                   )+                     === id+           , Law+               "zigzag (Dual a)"+               \ @a _ ->+                 withObDual @_ @a $+                   ( leftUnitor @_ @(Dual a)+                       . (dualityCounit @_ @a ** obj @(Dual a))+                       . associatorInv @_ @(Dual a) @a @(Dual a)+                       . (obj @(Dual a) ** dualityUnit @_ @a)+                       . rightUnitorInv @_ @(Dual a)+                   )+                     === id+           ]
+ src/Proarrow/Category/Monoidal/CopyDiscard.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans -Wno-unused-foralls #-}++-- | Monoidal categories in which every object carries a cocommutative comonoid (the+-- @'Supplies' 'CocommutativeComonoid' k@ superclass), with @'copy' :: a ~> a ** a@ and+-- @'discard' :: a ~> 'Unit'@ defaulting to its comult\/counit. This gives projections+-- 'fst'\/'snd' without @tensor = product@, e.g. in the biproduct categories+-- "Proarrow.Category.Instance.Mat" and "Proarrow.Category.Instance.FinRel". Unlike in+-- 'Proarrow.Category.Monoidal.Cartesian.Cartesian' (which has this class as a superclass, by Fox's+-- theorem) the comonoids need not be /natural/, so morphisms may duplicate\/delete resources+-- non-uniformly.+module Proarrow.Category.Monoidal.CopyDiscard where++import Data.Kind (Constraint, Type)+import Prelude (Applicative, ($))++import Proarrow.Category.Instance.Bool (BOOL (..))+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Sub (SUBCAT, Sub (..), SubMonoidal)+import Proarrow.Category.Monoidal+  ( Monoidal (..)+  , MonoidalProfunctor (..)+  , SymMonoidal (..)+  , Tensor+  , leftUnitorWith+  , rightUnitorWith+  , swapInner+  )+import Proarrow.Category.Monoidal.Strength (Strong (..))+import Proarrow.Category.Monoidal.Strictified (Strictified (..), listCase)+import Proarrow.Core (CategoryOf (..), Kind, OB, Profunctor (..), Promonad (..), obj, (\\), type (+->))+import Proarrow.Monoid (CocommutativeComonoid, Comonoid (..), Supplies)+import Proarrow.Profunctor.Instance.Constant (Constant)+import Proarrow.Profunctor.Representable (Rep (..))+import Proarrow.Tools.Laws (Equation, Law (..), Laws (..), (===))++class (SymMonoidal k, Supplies CocommutativeComonoid k) => CopyDiscard k where+  copy :: (Ob (a :: k)) => a ~> a ** a+  copy = comult+  discard :: (Ob (a :: k)) => a ~> Unit+  discard = counit++-- | The constant functor ignores the acting object: discard it. Only copying\/discarding is+-- needed, so this works in biproduct categories as well as cartesian ones.+instance (CopyDiscard k, Ob r) => Strong Tensor (Rep (Constant r) :: k +-> k) where+  act @a (Rep @y p) = withOb2 @k @a @y (Rep (p . leftUnitorWith (discard @k @a))) \\ p++-- | The structures the laws of a copy-discard category are stated for.+type CopyDiscardStructures :: [Kind -> Constraint]+type CopyDiscardStructures = '[Monoidal, SymMonoidal, CopyDiscard]++-- | 'copy' and 'discard' are the supplied comonoid, and they respect the tensor: copying or+-- discarding @a '**' b@ is copying or discarding both parts, and on the unit they do nothing.+-- The comonoid laws and cocommutativity are those of the supply, in "Proarrow.Monoid".+instance Laws CopyDiscardStructures where+  laws =+    [ Law "copy is comult" \ @a _ -> copy @_ @a === comult @a+    , Law "discard is counit" \ @a _ -> discard @_ @a === counit @a+    , Law "copy of a tensor" \ @a @b _ ->+        withOb2 @_ @a @b $+          withOb2 @_ @a @a $+            withOb2 @_ @b @b $+              withOb2 @_ @(a ** b) @(a ** b) $+                copy @_ @(a ** b) === swapInner @a @a @b @b . (copy @_ @a ** copy @_ @b)+    , Law "discard of a tensor" \ @a @b _ ->+        withOb2 @_ @a @b (discard @_ @(a ** b) === leftUnitor @_ @Unit . (discard @_ @a ** discard @_ @b))+    , Law "copy of the unit" \ @a _ -> copyOfUnit @a+    , Law "discard of the unit" \ @a _ -> discardOfUnit @a+    ]++-- | 'copy' on the unit is a unitor; @a@ only says which category.+copyOfUnit :: forall {k} (a :: k) m. (CopyDiscard k, Applicative m) => m (Equation k)+copyOfUnit = withOb2 @k @Unit @Unit (copy @k @Unit === leftUnitorInv @k @Unit)++-- | 'discard' on the unit is the identity; @a@ only says which category.+discardOfUnit :: forall {k} (a :: k) m. (CopyDiscard k, Applicative m) => m (Equation k)+discardOfUnit = discard @k @Unit === obj @Unit++copyS :: (CopyDiscard k, Ob (a :: k)) => '[a] ~> '[a, a]+copyS = Str copy++discardS :: (CopyDiscard k, Ob (a :: k)) => '[a] ~> '[]+discardS = Str discard++instance CopyDiscard Type+instance CopyDiscard ()++instance CopyDiscard BOOL++-- | The comonoid supply of a product category, a subcategory and a strictified category are+-- inherited componentwise: each object's comonoid is the ambient 'copy'\/'discard'.+instance (CopyDiscard j, CopyDiscard k, Ob (a :: (j, k))) => Comonoid (a :: (j, k)) where+  counit = discard+  comult = copy++instance (CopyDiscard j, CopyDiscard k, Ob (a :: (j, k))) => CocommutativeComonoid (a :: (j, k))++instance (CopyDiscard j, CopyDiscard k) => CopyDiscard (j, k) where+  copy = copy :**: copy+  discard = discard :**: discard++instance (SubMonoidal ob, CopyDiscard k, Ob (a :: SUBCAT ob)) => Comonoid (a :: SUBCAT (ob :: OB k)) where+  counit = discard+  comult = copy+instance (SubMonoidal ob, CopyDiscard k, Ob (a :: SUBCAT ob)) => CocommutativeComonoid (a :: SUBCAT (ob :: OB k))+instance (SubMonoidal ob, CopyDiscard k) => CopyDiscard (SUBCAT (ob :: OB k)) where+  copy = Sub copy+  discard = Sub discard++instance (CopyDiscard k, Ob (as :: [k])) => Comonoid (as :: [k]) where+  counit = discard+  comult = copy+instance (CopyDiscard k, Ob (as :: [k])) => CocommutativeComonoid (as :: [k])+instance (CopyDiscard k) => CopyDiscard [k] where+  copy @as0 =+    listCase @as0+      id+      (\ @a -> Str @'[a] @'[a, a] copy)+      ( \ @a @as ->+          (obj @'[a] ** (associator @_ @as @'[a] @as . (swap @[k] @'[a] @as ** obj @as)))+            . (Str @'[a] @'[a, a] copy ** copy)+      )+  discard @as =+    listCase @as+      id+      (Str discard)+      (\ @a -> Str @'[a] @'[] discard ** discard)++fst :: forall {k} (a :: k) b. (CopyDiscard k, Ob a, Ob b) => (a ** b) ~> a+fst = rightUnitorWith (discard @k @b)++snd :: forall {k} a (b :: k). (CopyDiscard k, Ob a, Ob b) => (a ** b) ~> b+snd = leftUnitorWith (discard @k @a)++(&&&) :: forall {k} (a :: k) x y. (CopyDiscard k) => a ~> x -> a ~> y -> a ~> x ** y+f &&& g = (f ** g) . copy \\ f
+ src/Proarrow/Category/Monoidal/Distributive.hs view
@@ -0,0 +1,258 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Distributivity of a tensor over coproducts: a 'Distributive' category has 'distL'\/'distR' and+-- absorption by the initial object, and a 'DistributiveProfunctor' is monoidal for both tensor and+-- coproduct. Also home to 'Traversable' and 'Cotraversable' profunctors, which distribute any+-- 'StrongDistributiveProfunctor' and underlie 'Proarrow.Optic.Traversal.Traversal'.+module Proarrow.Category.Monoidal.Distributive where++import Data.Bifunctor (bimap)+import Data.Kind (Constraint, Type)+import Prelude qualified as P++import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..))+import Proarrow.Category.Instance.Free (Elems, FREE, Free (..), HasStructure (..), Lower, withLowerOb)+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Unit qualified as U+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..), first, second, type (**!))+import Proarrow.Category.Monoidal.Action (CoprodAction)+import Proarrow.Category.Monoidal.Closed (Closed (..), uncurry)+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard (..))+import Proarrow.Category.Monoidal.Strength (MonStrong, Strong (..))+import Proarrow.Colimit.BinaryCoproduct+  ( COPROD (..)+  , Coprod (..)+  , HasBinaryCoproducts (..)+  , HasCoproducts+  , codiag+  , (++)+  , type (+)+  )+import Proarrow.Colimit.Initial (HasInitialObject (..), InitF)+import Proarrow.Core (CAT, CategoryOf (..), Kind, Profunctor (..), Promonad (..), lmap, obj, (//), (:~>), type (+->))+import Proarrow.Monoid (Monoid (..))+import Proarrow.Profunctor.Corepresentable (Corepresentable (..), coindex, corepUniv)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Constant (Constant)+import Proarrow.Profunctor.Instance.Coproduct ((:+:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Instance.Product ((:*:) (..))+import Proarrow.Profunctor.Representable (Rep (..), RepCostar (..), Representable (..), repUniv)+import Proarrow.Tools.Laws (Inverses (..), Labelled (..), Laws (..), inverses)+import Prelude (($))++class (MonoidalProfunctor p, MonoidalProfunctor (Coprod p)) => DistributiveProfunctor p+instance (MonoidalProfunctor p, MonoidalProfunctor (Coprod p)) => DistributiveProfunctor p++-- | A distributive monoidal category: the tensor distributes over coproducts, and annihilates the+-- 'InitialObject'. The monoidal and coproduct worlds meet here.+--+-- __Laws:__+--+-- Each of the four arrows is invertible, with the named inverse:+--+-- * @'distL'@ is inverse to 'distLInv', and @'distR'@ to 'distRInv'+-- * @'absorbL'@ and @'absorbR'@ are inverse to 'Proarrow.Colimit.Initial.initiate'+--+-- Checked by 'Proarrow.Testing.Laws.testDistributive'.+class (Monoidal k, HasCoproducts k) => Distributive k where+  -- | Distributes a tensor on the left over a coproduct.+  distL :: (Ob (a :: k), Ob b, Ob c) => (a ** (b || c)) ~> (a ** b || a ** c)++  -- | Distributes a tensor on the right over a coproduct.+  distR :: (Ob (a :: k), Ob b, Ob c) => ((a || b) ** c) ~> (a ** c || b ** c)++  -- | The 'InitialObject' annihilates the tensor on the right.+  absorbL :: (Ob (a :: k)) => (a ** InitialObject) ~> InitialObject++  -- | The 'InitialObject' annihilates the tensor on the left.+  absorbR :: (Ob (a :: k)) => (InitialObject ** a) ~> InitialObject++-- | The structures the free category needs for 'Distributive', and those its laws are stated for.+type DistributiveStructures :: [Kind -> Constraint]+type DistributiveStructures = '[Monoidal, HasInitialObject, HasBinaryCoproducts, Distributive]++-- | The free-category structure for 'Distributive': formal distributors and absorbers,+-- interpreted by 'foldStructure' through the target's own. Together with the coproduct and+-- monoidal structures this makes a free category over a bare quiver distributive without asking+-- anything of the quiver's category.+instance+  (DistributiveStructures `Elems` cs)+  => HasStructure cs (p :: CAT k) Distributive+  where+  data Struct Distributive i o where+    DistL :: (Ob a, Ob b, Ob c) => Struct Distributive (a **! (b + c)) ((a **! b) + (a **! c))+    DistR :: (Ob a, Ob b, Ob c) => Struct Distributive ((a + b) **! c) ((a **! c) + (b **! c))+    AbsorbL :: (Ob a) => Struct Distributive (a **! InitF) InitF+    AbsorbR :: (Ob a) => Struct Distributive (InitF **! a) InitF+  foldStructure @f _ (DistL @a @b @c) =+    withLowerOb @f @a (withLowerOb @f @b (withLowerOb @f @c (distL @_ @(Lower f a) @(Lower f b) @(Lower f c))))+  foldStructure @f _ (DistR @a @b @c) =+    withLowerOb @f @a (withLowerOb @f @b (withLowerOb @f @c (distR @_ @(Lower f a) @(Lower f b) @(Lower f c))))+  foldStructure @f _ (AbsorbL @a) = withLowerOb @f @a (absorbL @_ @(Lower f a))+  foldStructure @f _ (AbsorbR @a) = withLowerOb @f @a (absorbR @_ @(Lower f a))++instance P.Show (Struct Distributive a b) where+  showsPrec _ DistL = P.showString "distL"+  showsPrec _ DistR = P.showString "distR"+  showsPrec _ AbsorbL = P.showString "absorbL"+  showsPrec _ AbsorbR = P.showString "absorbR"++instance (DistributiveStructures `Elems` cs) => Distributive (FREE cs (p :: CAT k)) where+  distL = St DistL Nil+  distR = St DistR Nil+  absorbL = St AbsorbL Nil+  absorbR = St AbsorbR Nil++distLInv+  :: forall {k} a b c. (Distributive k, Ob (a :: k), Ob b, Ob c) => (a ** b || a ** c) ~> (a ** (b || c))+distLInv = second @a (lft @k @b @c) ||| second @a (rgt @k @b @c)++distRInv+  :: forall {k} a b c. (Distributive k, Ob (a :: k), Ob b, Ob c) => (a ** c || b ** c) ~> ((a || b) ** c)+distRInv = first @c (lft @k @a @b) ||| first @c (rgt @k @a @b)++-- | Distributive promonads seem similar to selective applicative functors.+-- https://blog.veritates.love/selective_applicatives_theoretical_basis.html+branch+  :: forall {k} a b c i (p :: k +-> k)+   . (DistributiveProfunctor p, Promonad p, Distributive k, Ob a, Ob b, Ob c)+  => p i (a || b) -> p a c -> p b c -> p i c+branch pab pac pbc = rmap codiag ((pac ++ pbc) . pab)++instance Distributive Type where+  distL (a, e) = bimap (a,) (a,) e+  distR (e, c) = bimap (,c) (,c) e+  absorbL = P.snd+  absorbR = P.fst++instance Distributive () where+  distL = U.Unit+  distR = U.Unit+  absorbL = U.Unit+  absorbR = U.Unit++instance Distributive BOOL where+  distL @a @b @c = case obj @a of+    Fls -> Fls+    Tru -> obj @b +++ obj @c+  distR @a @b @c = case obj @c of+    Fls -> Fls+    Tru -> obj @a +++ obj @b+  absorbL = Fls+  absorbR = Fls++-- | A product of distributive categories distributes componentwise.+instance (Distributive j, Distributive k) => Distributive (j, k) where+  distL @'(a1, a2) @'(b1, b2) @'(c1, c2) = distL @j @a1 @b1 @c1 :**: distL @k @a2 @b2 @c2+  distR @'(a1, a2) @'(b1, b2) @'(c1, c2) = distR @j @a1 @b1 @c1 :**: distR @k @a2 @b2 @c2+  absorbL @'(a1, a2) = absorbL @j @a1 :**: absorbL @k @a2+  absorbR @'(a1, a2) = absorbR @j @a1 :**: absorbR @k @a2++distLClosed+  :: forall {k} (a :: k) (b :: k) (c :: k)+   . (Closed k, SymMonoidal k, HasBinaryCoproducts k, Ob a, Ob b, Ob c) => (a ** (b || c)) ~> (a ** b || a ** c)+distLClosed = (swap @k @b @a +++ swap @k @c @a) . distRClosed @b @c @a . withObCoprod @k @b @c (swap @k @a @(b || c))++distRClosed+  :: forall {k} (a :: k) (b :: k) (c :: k)+   . (Closed k, HasBinaryCoproducts k, Ob a, Ob b, Ob c) => ((a || b) ** c) ~> (a ** c || b ** c)+distRClosed =+  withOb2 @k @a @c $+    withOb2 @k @b @c $+      withObCoprod @k @(a ** c) @(b ** c) $+        uncurry @c (curry @k @a @c (lft @k @(a ** c) @(b ** c)) ||| curry @k @b @c (rgt @k @(a ** c) @(b ** c)))++class+  (DistributiveProfunctor (p :: k +-> k), MonStrong p, Strong CoprodAction p) =>+  StrongDistributiveProfunctor (p :: k +-> k)+instance+  (DistributiveProfunctor (p :: k +-> k), MonStrong p, Strong CoprodAction p)+  => StrongDistributiveProfunctor (p :: k +-> k)++-- | The constant functor absorbs a coproduct action: the injected summand is discarded onto+-- the monoid's unit, so this needs only copying\/discarding on the tensor side and coproducts.+instance (CopyDiscard k, HasCoproducts k, Monoid r) => Strong CoprodAction (Rep (Constant r) :: k +-> k) where+  act @(COPR a) (Rep @y p) = withObCoprod @k @a @y (Rep (mempty @r . discard @k @a ||| p))++type Traversable :: forall {k}. (k +-> k) -> Constraint+class (Profunctor t) => Traversable (t :: k +-> k) where+  traverse :: (StrongDistributiveProfunctor p) => t :.: p :~> p :.: t++-- | With a representable traversable profunctor, you get a traversal a la one-liner.+repTraverse+  :: forall {k} (t :: k +-> k) p a b+   . (Traversable t, Representable t, StrongDistributiveProfunctor p)+  => p a b -> p (t % a) (t % b)+repTraverse p = p // case traverse (repUniv :.: p) of x :.: y -> rmap (index @t y) x++-- | If both profunctors are representable, you get traversals as in base.+baseTraverse+  :: forall {k} (t :: k +-> k) f a b+   . (Traversable t, Representable t, Representable f, StrongDistributiveProfunctor f, Ob b)+  => a ~> f % b -> t % a ~> f % (t % b)+baseTraverse = index . repTraverse @t @f @a @b . tabulate++instance (CategoryOf k) => Traversable (Id :: k +-> k) where+  traverse (Id f :.: p) = lmap f p :.: Id id \\ p++instance Traversable (->) where+  traverse (f :.: p) = lmap f p :.: id++instance (Traversable p, Traversable q) => Traversable (p :.: q) where+  traverse ((p :.: q) :.: r) = case traverse (q :.: r) of+    r' :.: q' -> case traverse (p :.: r') of+      r'' :.: p' -> r'' :.: (p' :.: q')++instance (Traversable p, Traversable q) => Traversable (p :+: q) where+  traverse (InjL p :.: r) = case traverse (p :.: r) of r' :.: p' -> r' :.: InjL p'+  traverse (InjR q :.: r) = case traverse (q :.: r) of r' :.: q' -> r' :.: InjR q'++type Cotraversable :: forall {k}. (k +-> k) -> Constraint+class (Profunctor t) => Cotraversable (t :: k +-> k) where+  cotraverse :: (StrongDistributiveProfunctor (p :: k +-> k)) => p :.: t :~> t :.: p++-- | With a corepresentable cotraversable profunctor, you get a co-traversal a la one-liner.+corepTraverse+  :: forall {k} (t :: k +-> k) p a b+   . (Cotraversable t, Corepresentable t, StrongDistributiveProfunctor p)+  => p a b -> p (t %% a) (t %% b)+corepTraverse p = p // case cotraverse (p :.: corepUniv) of x :.: y -> lmap (coindex @t x) y++instance (CategoryOf k) => Cotraversable (Id :: k +-> k) where+  cotraverse (p :.: Id f) = Id id :.: rmap f p \\ p++instance Cotraversable (->) where+  cotraverse (p :.: f) = id :.: rmap f p++instance (Cotraversable p, Cotraversable q) => Cotraversable (p :.: q) where+  cotraverse (r :.: (p :.: q)) = case cotraverse (r :.: p) of+    p' :.: r' -> case cotraverse (r' :.: q) of+      q' :.: r'' -> (p' :.: q') :.: r''++instance (HasBinaryCoproducts k, Cotraversable p, Cotraversable q) => Cotraversable ((p :: k +-> k) :*: q) where+  cotraverse (r :.: (p :*: q)) = case (cotraverse (r :.: p), cotraverse (r :.: q)) of+    ((:.:) @a p' r', (:.:) @b q' r'') -> (rmap (lft @k @a @b) p' :*: rmap (rgt @k @a @b) q') :.: rmap codiag (r' ++ r'') \\ p \\ p' \\ q'++instance (Cotraversable p, Cotraversable q) => Cotraversable (p :+: q) where+  cotraverse (r :.: InjL p) = case cotraverse (r :.: p) of p' :.: r' -> InjL p' :.: r'+  cotraverse (r :.: InjR q) = case cotraverse (r :.: q) of q' :.: r' -> InjR q' :.: r'++-- | This breaks for possibly infinite traversals like Star [].+instance (Traversable t, Representable t) => Cotraversable (RepCostar t) where+  cotraverse (p :.: RepCostar t) = p // case traverse @t (repUniv :.: p) of p' :.: t' -> corepUniv :.: rmap (t . index t') p'++-- | The tensor distributes over coproducts and is absorbed by the initial object:+-- 'distL', 'distR', 'absorbL' and 'absorbR' are isomorphisms, with the inverses 'distLInv',+-- 'distRInv' and 'initiate'.+instance Laws DistributiveStructures where+  laws =+    inverses "distL" (\ @a @b @c -> Inverses (distL @_ @a @b @c) (label "distLInv" (distLInv @a @b @c)))+      P.++ inverses "distR" (\ @a @b @c -> Inverses (distR @_ @a @b @c) (label "distRInv" (distRInv @a @b @c)))+      P.++ inverses+        "absorbL"+        (\ @a -> withOb2 @_ @a @InitialObject (Inverses (absorbL @_ @a) initiate))+      P.++ inverses+        "absorbR"+        (\ @a -> withOb2 @_ @InitialObject @a (Inverses (absorbR @_ @a) initiate))
+ src/Proarrow/Category/Monoidal/EndoProf.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | The monoidal category of endo-profunctors on @k@, with composition ('(:.:)'\/'Id') as the+-- tensor. The profunctor-specific counterpart of "Proarrow.Category.Monoidal.Endo" (in+-- @proarrow-equipment@), reusing "Proarrow.Path"\'s associators\/unitors.+--+-- A fresh wrapper, since "Proarrow.Profunctor.Instance.Day" already gives @k '+->' k@ a different+-- monoidal structure (Day convolution).+module Proarrow.Category.Monoidal.EndoProf where++import Data.Kind (Constraint)++import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Instance.Sub (SUBCAT (..), Sub (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..))+import Proarrow.Category.Monoidal.Action (MonoidalAction (..))+import Proarrow.Category.Monoidal.Distributive (Traversable)+import Proarrow.Category.Monoidal.Rev (REV (..), Rev (..))+import Proarrow.Core+  ( CAT+  , CategoryOf (..)+  , Is+  , Kind+  , OB+  , Profunctor (..)+  , Promonad (..)+  , UN+  , type (+->)+  , type (:&&:)+  , type (:~>)+  )+import Proarrow.Functor (FunctorForRep (..))+import Proarrow.Path qualified as Path+import Proarrow.Profunctor.Instance.Composition (o, (:.:))+import Proarrow.Profunctor.Instance.Identity (Id)+import Proarrow.Profunctor.Representable (Rep (..), Representable (..), index, repMap, repUniv, withObRep)++-- | An object of @'ENDO' k@ is an endo-profunctor @k +-> k@, i.e. (not necessarily+-- representable) a functor @k -> k@ under the profunctor encoding.+type ENDO :: Kind -> Kind+type data ENDO k = E (k +-> k)++-- | Morphisms of @'ENDO' k@ are natural transformations between the underlying profunctors.+type Endo :: CAT (ENDO k)+data Endo p q where+  Endo :: (Profunctor p, Profunctor q) => (p :~> q) -> Endo (E p) (E q)++instance (CategoryOf k) => Profunctor (Endo :: CAT (ENDO k)) where+  dimap (Endo l) (Endo r) (Endo f) = Endo (r . f . l)+  r \\ Endo _ = r++instance (CategoryOf k) => Promonad (Endo :: CAT (ENDO k)) where+  id = Endo Path.idN+  Endo f . Endo g = Endo (f . g)++-- | The category of endoprofunctors on @k@ and natural transformations between them.+instance (CategoryOf k) => CategoryOf (ENDO k) where+  type (~>) = Endo+  type Ob (a :: ENDO k) = (Is E a, Profunctor (UN E a))++instance (CategoryOf k) => MonoidalProfunctor (Endo :: CAT (ENDO k)) where+  one = Endo Path.idN+  Endo f ** Endo g = Endo (f `o` g)++instance (CategoryOf k) => Monoidal (ENDO k) where+  type Unit = E Id+  type E p ** E q = E (p :.: q)+  withOb2 @(E _) @(E _) r = r+  leftUnitor @(E p) = Endo (Path.leftUnitor @p)+  leftUnitorInv @(E p) = Endo (Path.leftUnitorInv @p)+  rightUnitor @(E p) = Endo (Path.rightUnitor @p)+  rightUnitorInv @(E p) = Endo (Path.rightUnitorInv @p)+  associator @(E p) @(E q) @(E r) = Endo (Path.associator @p @q @r)+  associatorInv @(E p) @(E q) @(E r) = Endo (Path.associatorInv @p @q @r)++-- | Lift a constraint on profunctors @k +-> k@ to the corresponding 'ENDO' objects.+type OnE :: ((k +-> k) -> Constraint) -> ENDO k -> Constraint+class (Is E a, c (UN E a)) => OnE c a++instance (Is E a, c (UN E a)) => OnE c a++-- | The subcategory of representable endo-profunctors, i.e. ordinary functors+-- @k -> k@ under the profunctor encoding. The most permissive restriction of 'ENDO' for+-- which an 'Proarrow.Category.Monoidal.Action.Act'ion makes sense (@'%'@ needs+-- 'Representable'), so every other 'MonoidalAction' on @k@ embeds into this one. See+-- 'TravSub' for a further restriction.+type RepSub k = SUBCAT (OnE Representable :: OB (ENDO k))++-- | The action of 'RepSub' on @k@ by application: @'Proarrow.Category.Monoidal.Action.Act' 'RepAction' ('SUB' ('E' f)) x = f '%' x@.+type RepAction = Rep RepAction'++data family RepAction' :: (RepSub k, k) +-> k+instance (CategoryOf k) => FunctorForRep (RepAction' :: (RepSub k, k) +-> k) where+  type RepAction' @ '(SUB (E p), x) = p % x+  fmap (Sub (Endo @p @q n) :**: (g :: x ~> y)) = index @q (n (repUniv @p @y)) . repMap @p g \\ g++instance (CategoryOf k) => MonoidalAction (RepAction :: (RepSub k, k) +-> k) where+  unitor = id+  unitorInv = id+  multiplicator @(SUB (E p)) @(SUB (E q)) @x = withObRep @q @x (withObRep @p @(q % x) id)+  multiplicatorInv @(SUB (E p)) @(SUB (E q)) @x = withObRep @q @x (withObRep @p @(q % x) id)++-- | The subcategory of representable, traversable endo-profunctors: the+-- functors 'Proarrow.Category.Monoidal.Distributive.repTraverse' can traverse with.+-- 'Monoidal' for free via "Proarrow.Category.Instance.Sub"\'s generic+-- @Monoidal (SUBCAT ob)@, since both 'Representable' and 'Traversable' already have+-- instances closing them under @:.:@\/'Id'.+type TravSub k = SUBCAT (OnE (Representable :&&: Traversable) :: OB (ENDO k))++-- | The action of 'TravSub' on @k@ by application: @'Proarrow.Category.Monoidal.Action.Act' 'TravAction' ('SUB' ('E' f)) x = f '%' x@.+type TravAction = Rep TravAction'++data family TravAction' :: (TravSub k, k) +-> k+instance (CategoryOf k) => FunctorForRep (TravAction' :: (TravSub k, k) +-> k) where+  type TravAction' @ '(SUB (E p), x) = p % x+  fmap (Sub (Endo @p @q n) :**: (g :: x ~> y)) = index @q (n (repUniv @p @y)) . repMap @p g \\ g++instance (CategoryOf k) => MonoidalAction (TravAction :: (TravSub k, k) +-> k) where+  unitor = id+  unitorInv = id+  multiplicator @(SUB (E p)) @(SUB (E q)) @x = withObRep @q @x (withObRep @p @(q % x) id)+  multiplicatorInv @(SUB (E p)) @(SUB (E q)) @x = withObRep @q @x (withObRep @p @(q % x) id)++-- | Endo-profunctors on @x@ act on profunctors @x '+->' h@ by precomposition:+-- @'Proarrow.Category.Monoidal.Action.Act' 'Precomp' ('E' g) q = q ':.:' g@. Since the acted-upon+-- kind is the whole profunctor kind, @g@ need not be 'Representable' (unlike 'RepAction'\/+-- 'TravAction'); only @'Rep' 'Precomp'@ is, automatically. So 'Proarrow.Squares.toOptic' can turn+-- any 'Proarrow.Squares.EqpOptic' into a 'Proarrow.Optic.Optic'.+--+-- The index category is @'REV' ('ENDO' x)@ because precomposing twice applies the actions in the+-- reverse of the order in which @'Proarrow.Category.Monoidal.**'@ on @'ENDO' x@ composes them.+data family Precomp :: forall x h. (REV (ENDO x), x +-> h) +-> (x +-> h)++instance (CategoryOf h, CategoryOf x) => FunctorForRep (Precomp :: (REV (ENDO x), x +-> h) +-> (x +-> h)) where+  type Precomp @ '(R (E g), q) = q :.: g+  fmap (Rev (Endo n) :**: Prof h') = Prof (h' `o` n)++instance (CategoryOf h, CategoryOf x) => MonoidalAction (Rep Precomp :: (REV (ENDO x), x +-> h) +-> (x +-> h)) where+  unitor = Prof Path.rightUnitor+  unitorInv = Prof Path.rightUnitorInv+  multiplicator @(R (E g)) @(R (E g')) @q = Prof (Path.associatorInv @q @g' @g)+  multiplicatorInv @(R (E g)) @(R (E g')) @q = Prof (Path.associator @q @g' @g)
+ src/Proarrow/Category/Monoidal/Hypergraph.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Hypergraph categories: compact closed categories where every object carries a 'Frobenius'+-- structure (a compatible 'Proarrow.Monoid.Monoid' and 'Proarrow.Monoid.Comonoid'), giving n-to-m+-- 'spider's, 'cup's and 'cap's. This is the setting for string diagrams with arbitrary+-- fan-in\/fan-out such as "Proarrow.Category.Instance.ZX".+module Proarrow.Category.Monoidal.Hypergraph where++import Data.Kind (Constraint)+import Data.Type.Nat (SNatI)+import Prelude (($))++import Proarrow.Category.Instance.Free (FREE)+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), NFold, NFoldS, SymMonoidal (..), (==))+import Proarrow.Category.Monoidal.CompactClosed (CompactClosed)+import Proarrow.Category.Monoidal.Strictified (Strictified (..), obj1, singleton, swap2)+import Proarrow.Core (CategoryOf (..), Kind, Profunctor (..), Promonad (..), obj)+import Proarrow.Monoid+  ( CocommutativeComonoid+  , CommutativeMonoid+  , Comonoid (..)+  , Monoid (..)+  , Supplies+  , fanIn+  , fanInS+  , fanOut+  , fanOutS+  )+import Proarrow.Tools.Laws (Law (..), Laws (..), (===))++-- | A __special commutative Frobenius algebra__: a commutative monoid and cocommutative comonoid+-- satisfying speciality (@mappend . comult = id@) and the Frobenius law. A 'Hypergraph' category+-- supplies this structure at every object, and with it the 'spider' from n-fold @a@ to m-fold @a@+-- is the unique connected map (commutativity\/cocommutativity make+-- 'fanIn'\/'fanOut' independent of wiring order). The bare notion of a Frobenius monoid needs+-- neither (co)commutativity, but the library only ever uses the special commutative one.+class (CommutativeMonoid a, CocommutativeComonoid a) => Frobenius a++instance (forall (a :: k). (Ob a) => Frobenius a) => Supplies Frobenius k++spider :: forall n m a. (Frobenius a, SNatI n, SNatI m) => NFold n a ~> NFold m a+spider = fanOut @m @a . fanIn @n @a++spiderS :: forall n m a. (Frobenius a, SNatI n, SNatI m) => NFoldS n a ~> NFoldS m a+spiderS = fanOutS @m @a . fanInS @n @a++cup :: (Frobenius a) => Unit ~> a ** a+cup @a = comult @a . mempty @a++cupS :: (Frobenius a) => '[] ~> [a, a]+cupS @a = Str (cup @a)++cap :: (Frobenius a) => a ** a ~> Unit+cap @a = counit @a . mappend @a++capS :: (Frobenius a) => [a, a] ~> '[]+capS @a = Str (cap @a)++-- | A hypergraph category has a special frobenius algebra for every object, and the+-- frobenius algebra of any tensor product X ⊗ Y is induced in the canonical way from those of X and Y.+class (Supplies Frobenius k, CompactClosed k) => Hypergraph k++-- | A hypergraph category is self-dual compact closed.+dualHG :: forall {k} (a :: k) b. (Hypergraph k) => a ~> b -> b ~> a+dualHG f =+  unStr @'[b] @'[a] $+    cupS ** obj1+      == obj1 ** singleton f ** obj1+      == obj1 ** capS+      \\ f++linDistHG :: forall {k} (a :: k) b c. (Hypergraph k, Ob a, Ob b) => a ** b ~> c -> a ~> b ** c+linDistHG f =+  unStr @'[a] @[b, c] $+    obj1 ** cupS+      == Str @[a, b] @'[c] f ** obj1+      == swap2+      \\ f++linDistInvHG :: forall {k} (a :: k) b c. (Hypergraph k, Ob b, Ob c) => a ~> b ** c -> a ** b ~> c+linDistInvHG f =+  unStr @[a, b] @'[c] $+    swap2+      == obj1 ** Str @'[a] @[b, c] f+      == capS ** obj1+      \\ f++-- | A hypergraph category has a trace.+traceHG :: forall {k} u (x :: k) y. (Hypergraph k, Ob x, Ob y, Ob u) => u ** x ~> u ** y -> x ~> y+traceHG f =+  unStr $+    cupS ** obj1+      == obj1 ** Str @[u, x] @'[u, y] f+      == capS ** obj1++-- | A hypergraph category is monoidal closed.+type ExpHG a b = a ** b++curryHG :: forall {k} (a :: k) b c. (Hypergraph k, Ob a, Ob b) => a ** b ~> c -> a ~> ExpHG b c+curryHG = linDistHG @a @b @c++applyHG :: forall {k} (b :: k) c. (Hypergraph k, Ob b, Ob c) => ExpHG b c ** b ~> c+applyHG = linDistInvHG @_ @b (obj @b ** obj @c)++-- | In the free category the supply generators (see @'Supplies' 'Monoid'@\/@'Supplies' 'Comonoid'@+-- in "Proarrow.Monoid") are compatible by fiat, so monoid + comonoid is already 'Frobenius'. With+-- both supplies in @cs@, @'Supplies' 'Frobenius'@ and 'Hypergraph' are derived, with no structure+-- of their own. Superclasses are taken directly as the context to keep dictionary construction+-- acyclic. Bundling them into an 'Proarrow.Category.Instance.Free.All'-style constraint here builds+-- a dictionary that references itself through the quantified 'Supplies' constraint, looping at+-- runtime.+instance (CommutativeMonoid a, CocommutativeComonoid (a :: FREE cs p)) => Frobenius (a :: FREE cs p)++instance (Supplies Frobenius (FREE cs p), CompactClosed (FREE cs p)) => Hypergraph (FREE cs p)++-- | The structures the laws of a category supplying special commutative Frobenius algebras are+-- stated for: the monoids and comonoids, together.+type FrobeniusStructures :: [Kind -> Constraint]+type FrobeniusStructures = '[Monoidal, SymMonoidal, Supplies Monoid, Supplies Comonoid]++-- | The supplied monoids and comonoids are special and satisfy the Frobenius law. Their monoid and+-- comonoid laws, and their commutativity, are separate instances, in "Proarrow.Monoid".+instance Laws FrobeniusStructures where+  laws =+    [ Law "speciality" \ @a _ -> obj @a === mappend @a . comult @a+    , Law "Frobenius (left)" \ @a _ ->+        withOb2 @_ @a @a $+          comult @a . mappend @a === (mappend @a ** obj @a) . associatorInv @_ @a @a @a . (obj @a ** comult @a)+    , Law "Frobenius (right)" \ @a _ ->+        withOb2 @_ @a @a $+          comult @a . mappend @a === (obj @a ** mappend @a) . associator @_ @a @a @a . (comult @a ** obj @a)+    ]
+ src/Proarrow/Category/Monoidal/Rev.hs view
@@ -0,0 +1,61 @@+-- | The reversed monoidal category: 'REV' wraps a kind so that @'R' a '**' 'R' b = 'R' (b ** a)@,+-- swapping the tensor's arguments while keeping the same objects and morphisms.+module Proarrow.Category.Monoidal.Rev where++import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard (..))+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), WrappedOb, type (+->))+import Proarrow.Monoid (CocommutativeComonoid, Comonoid (..), Monoid (..))++type data REV k = R k++-- | Wraps a profunctor between the 'REV'-wrapped kinds: the same values, but the monoidal+-- structure on 'REV' tensors in reverse order.+type Rev :: j +-> k -> REV j +-> REV k+data Rev p a b where+  Rev :: p a b -> Rev p (R a) (R b)++instance (Profunctor p) => Profunctor (Rev p) where+  dimap (Rev l) (Rev r) (Rev p) = Rev (dimap l r p)+  r \\ Rev p = r \\ p++instance (Promonad p) => Promonad (Rev p) where+  id = Rev id+  Rev f . Rev g = Rev (f . g)++-- | The reverse of the category of @k@, i.e. with the tensor flipped.+instance (CategoryOf k) => CategoryOf (REV k) where+  type (~>) = Rev (~>)+  type Ob a = WrappedOb R a++instance (MonoidalProfunctor p) => MonoidalProfunctor (Rev p) where+  one = Rev one+  Rev f ** Rev g = Rev (g ** f)++-- | The flipped tensor.+instance (Monoidal k) => Monoidal (REV k) where+  type Unit = R Unit+  type R a ** R b = R (b ** a)+  withOb2 @(R a) @(R b) r = withOb2 @k @b @a r+  leftUnitor = Rev rightUnitor+  leftUnitorInv = Rev rightUnitorInv+  rightUnitor = Rev leftUnitor+  rightUnitorInv = Rev leftUnitorInv+  associator @(R a) @(R b) @(R c) = Rev (associatorInv @k @c @b @a)+  associatorInv @(R a) @(R b) @(R c) = Rev (associator @k @c @b @a)++instance (SymMonoidal k) => SymMonoidal (REV k) where+  swap @(R a) @(R b) = Rev (swap @k @b @a)++instance (Monoid a) => Monoid (R a) where+  mempty = Rev mempty+  mappend = Rev mappend++instance (Comonoid a) => Comonoid (R a) where+  counit = Rev counit+  comult = Rev comult+instance (CocommutativeComonoid a) => CocommutativeComonoid (R a)++instance (CopyDiscard k) => CopyDiscard (REV k) where+  copy = Rev copy+  discard = Rev discard
+ src/Proarrow/Category/Monoidal/StarAutonomous.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE RequiredTypeArguments #-}+{-# OPTIONS_GHC -Wno-unused-foralls #-}++-- | Star-autonomous categories: symmetric closed categories with a dualizing functor 'Dual', where+-- morphisms @a ** b ~> Dual c@ correspond to @a ~> Dual (b ** c)@ ('linDist'). This gives+-- double-negation elimination ('doubleNeg') and an internal hom @'ExpSA' a b = 'Dual' (a ** Dual b)@+-- Star-autonomous categories are the categorical semantics of multiplicative linear logic.+module Proarrow.Category.Monoidal.StarAutonomous where++import Data.Kind (Constraint)+import Prelude (($))+import Prelude qualified as P++import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..), Not)+import Proarrow.Category.Instance.Free+  ( Elem (..)+  , Elems+  , FREE (..)+  , Free (..)+  , HasStructure (..)+  , IsFreeOb (..)+  , Lower+  , WithShow+  , withLowerOb+  )+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Unit qualified as U+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..), swap, type (**!))+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.Strictified (Strictified (..), obj1, singleton)+import Proarrow.Core (CAT, CategoryOf (..), Kind, Obj, Profunctor (..), Promonad (..), obj)+import Proarrow.Optic (PIso, iso)+import Proarrow.Tools.Laws+  ( Bijection (..)+  , Inverses (..)+  , Law (..)+  , Laws (..)+  , bijection+  , inverses+  , (===)+  )++-- | A *-autonomous category: a symmetric monoidal closed category with a dualizing object, so+-- that 'Dual' is a contravariant involution and @Hom(a '**' b, 'Dual' c)@ is symmetric in its three+-- arguments.+--+-- __Laws:__+--+-- * 'dual' is a contravariant functor: @'dual' 'id' = 'id'@ and @'dual' (f . g) = 'dual' g . 'dual' f@+-- * 'dual' and 'dualInv' are mutually inverse bijections on hom-sets:+--   @'dualInv' ('dual' f) = f@ and @'dual' ('dualInv' g) = g@+-- * 'linDist' and 'linDistInv' are mutually inverse, giving+--   @Hom(a '**' b, 'Dual' c) ≅ Hom(a, 'Dual' (b '**' c))@, natural in all three variables+-- * 'doubleNeg' and 'doubleNegInv' are mutually inverse, so @'Dual' ('Dual' a) ≅ a@, and+--   'doubleNegInv' is 'doubleNegInvDefault', the one the rest of the structure gives+--+-- Stated as code by the 'Proarrow.Tools.Laws.Laws' instance for 'StarAutonomousStructures', and+-- checked by @Proarrow.Testing.Laws.testStarAutonomous@.+class (SymMonoidal k, Closed k, Ob (Unit :: k)) => StarAutonomous k where+  -- | The dual of an object.+  type Dual (a :: k) :: k++  -- | Recovers @'Ob' ('Dual' a)@ from the objecthood of @a@.+  withObDual :: (Ob (a :: k)) => ((Ob (Dual a)) => r) -> r++  -- | 'Dual'\'s contravariant action on arrows.+  dual :: (a :: k) ~> b -> Dual b ~> Dual a++  -- | Inverse to 'dual' on hom-sets: recovers the undualized arrow.+  dualInv :: (Ob (a :: k), Ob b) => Dual a ~> Dual b -> b ~> a++  -- | Linear distribution: transposes a tensor factor across the dual.+  linDist :: (Ob (a :: k), Ob b, Ob c) => a ** b ~> Dual c -> a ~> Dual (b ** c)++  -- | Inverse to 'linDist'.+  linDistInv :: (Ob (a :: k), Ob b, Ob c) => a ~> Dual (b ** c) -> a ** b ~> Dual c++  -- | Double-negation elimination. Defaults to 'doubleNegDefault'; an instance whose double dual+  -- is the object itself can say so directly.+  doubleNeg :: (Ob (a :: k)) => Dual (Dual a) ~> a+  doubleNeg @a = doubleNegDefault @a++  -- | Double-negation introduction, inverse to 'doubleNeg'. Defaults to 'doubleNegInvDefault'.+  doubleNegInv :: (Ob (a :: k)) => a ~> Dual (Dual a)+  doubleNegInv @a = doubleNegInvDefault @a++dualObj :: forall {k} (a :: k). (StarAutonomous k, Ob a) => Obj (Dual a)+dualObj = dual (obj @a)++-- | 'doubleNeg' from the rest of the structure: 'dualInv' of 'doubleNegInv' at the dual.+doubleNegDefault :: forall {k} (a :: k). (StarAutonomous k, Ob a) => Dual (Dual a) ~> a+doubleNegDefault = dualInv @k @a (doubleNegInv @k @(Dual a)) \\ dualObj @(Dual a) \\ dualObj @a++-- | 'doubleNegInv' from the rest of the structure, through 'linDistInv' and the duality unit.+doubleNegInvDefault :: forall {k} (a :: k). (StarAutonomous k, Ob a) => a ~> Dual (Dual a)+doubleNegInvDefault =+  linDistInv @k @Unit @a @(Dual a) (dual (swap @k @a @(Dual a)) . dualityUnitSA @a) . leftUnitorInv @k @a+    \\ dualObj @a++doubleNegIso+  :: forall {k} (a :: k) (a' :: k). (StarAutonomous k, Ob a, Ob a') => PIso a a' (Dual (Dual a)) (Dual (Dual a'))+doubleNegIso = iso doubleNegInv doubleNeg++linDistS+  :: forall {k} (a :: k) (b :: k) c. (StarAutonomous k, Ob c) => '[a, b] ~> '[Dual c] -> '[a] ~> '[Dual (b ** c)]+linDistS f@Str{} = singleton (linDist @k @a @b @c (unStr f))++linDistInvS+  :: forall {k} (a :: k) (b :: k) c. (StarAutonomous k, Ob b, Ob c) => '[a] ~> '[Dual (b ** c)] -> '[a, b] ~> '[Dual c]+linDistInvS f@Str{} = withObDual @k @c (Str (linDistInv @k @a @b @c (unStr f)) \\ obj1 @(Dual c))++type ExpSA a b = Dual (a ** Dual b)++currySA :: forall {k} (a :: k) b c. (StarAutonomous k, Ob a, Ob b) => a ** b ~> c -> a ~> ExpSA b c+currySA f = linDist @k @a @b @(Dual c) (doubleNegInv @k @c . f) \\ f \\ dual f++applySA :: forall {k} (b :: k) c. (StarAutonomous k, Ob b, Ob c) => ExpSA b c ** b ~> c+applySA =+  doubleNeg @k @c . withOb2 @k @b @(Dual c) (linDistInv @k @(ExpSA b c) @b @(Dual c) id \\ dualObj @(b ** Dual c))+    \\ dualObj @c++expSA :: forall {k} (a :: k) b x y. (StarAutonomous k) => b ~> y -> x ~> a -> ExpSA a b ~> ExpSA x y+expSA f g = dual (g ** dual f)++dualityUnitSA :: forall {k} (a :: k). (StarAutonomous k, Ob a) => Unit ~> Dual (Dual a ** a)+dualityUnitSA = linDist @k @_ @(Dual a) @a leftUnitor \\ dualObj @a++dualityCounitSA :: forall {k} (a :: k). (StarAutonomous k, Ob a) => Dual a ** a ~> Dual Unit+dualityCounitSA = linDistInv @k @(Dual a) @a @Unit (dual (rightUnitor @k @a)) \\ dualObj @a++instance StarAutonomous () where+  type Dual '() = '()+  withObDual r = r+  dual U.Unit = U.Unit+  dualInv U.Unit = U.Unit+  linDist U.Unit = U.Unit+  linDistInv U.Unit = U.Unit+  doubleNeg = U.Unit+  doubleNegInv = U.Unit++instance StarAutonomous BOOL where+  type Dual (a :: BOOL) = Not a+  withObDual r = r+  dual Fls = Tru+  dual F2T = F2T+  dual Tru = Fls+  dualInv @a @b f = case (obj @a, obj @b, f) of+    (Fls, Fls, Tru) -> Fls+    (Tru, Fls, F2T) -> F2T+    (Tru, Tru, Fls) -> Tru+    (Fls, Tru, f') -> case f' of {}+  linDist @a @b f = case (obj @a, obj @b) of+    (Fls, Fls) -> F2T+    (Tru, Fls) -> Tru+    (_, Tru) -> f+  linDistInv @_ @b @c f = case (obj @b, obj @c) of+    (Fls, Fls) -> F2T+    (Fls, Tru) -> Fls+    (Tru, _) -> f+  doubleNeg @a = case obj @a of Fls -> Fls; Tru -> Tru+  doubleNegInv @a = case obj @a of Fls -> Fls; Tru -> Tru++-- BOOL is not CompactClosed++instance (StarAutonomous j, StarAutonomous k) => StarAutonomous (j, k) where+  type Dual '(a, b) = '(Dual a, Dual b)+  withObDual @'(a, b) r = withObDual @j @a (withObDual @k @b r)+  dual (f :**: g) = dual f :**: dual g+  dualInv (f :**: g) = dualInv f :**: dualInv g+  linDist @'(a1, a2) @'(b1, b2) @'(c1, c2) (f :**: g) = linDist @j @a1 @b1 @c1 f :**: linDist @k @a2 @b2 @c2 g+  linDistInv @'(a1, a2) @'(b1, b2) @'(c1, c2) (f :**: g) = linDistInv @j @a1 @b1 @c1 f :**: linDistInv @k @a2 @b2 @c2 g+  doubleNeg @'(a, b) = doubleNeg @j @a :**: doubleNeg @k @b+  doubleNegInv @'(a, b) = doubleNegInv @j @a :**: doubleNegInv @k @b++data family DualF (a :: k) :: k+instance (IsFreeOb (a :: FREE cs p), StarAutonomous `Elem` cs) => IsFreeOb (DualF a) where+  type Lower f (DualF a) = Dual (Lower f a)+  lowerOb @k' @f r = fromAll @StarAutonomous @cs @k' (withLowerOb @f @a (withObDual @k' @(Lower f a) r))++-- | The structures the free category needs for 'StarAutonomous', and those its laws are stated for.+type StarAutonomousStructures :: [Kind -> Constraint]+type StarAutonomousStructures = '[Monoidal, SymMonoidal, Closed, StarAutonomous]++instance+  (StarAutonomousStructures `Elems` cs)+  => HasStructure cs (p :: CAT k) StarAutonomous+  where+  data Struct StarAutonomous a b where+    Dual :: a ~> b -> Struct StarAutonomous (DualF b) (DualF a)+    DualInv :: (Ob a, Ob b) => DualF a ~> DualF b -> Struct StarAutonomous b a+    LinDist :: (Ob a, Ob b, Ob c) => a **! b ~> DualF c -> Struct StarAutonomous a (DualF (b **! c))+    LinDistInv :: (Ob a, Ob b, Ob c) => a ~> DualF (b **! c) -> Struct StarAutonomous (a **! b) (DualF c)+  foldStructure go (Dual f) = dual (go f)+  foldStructure @f go (DualInv @a @b g) =+    withLowerOb @f @a (withLowerOb @f @b (dualInv @_ @(Lower f a) @(Lower f b) (go g)))+  foldStructure @f go (LinDist @a @b @c g) =+    withLowerOb @f @a (withLowerOb @f @b (withLowerOb @f @c (linDist @_ @(Lower f a) @(Lower f b) @(Lower f c) (go g))))+  foldStructure @f go (LinDistInv @a @b @c g) =+    withLowerOb @f @a (withLowerOb @f @b (withLowerOb @f @c (linDistInv @_ @(Lower f a) @(Lower f b) @(Lower f c) (go g))))+instance (WithShow a) => P.Show (Struct StarAutonomous a b) where+  showsPrec d (Dual f) = P.showParen (d P.> 10) P.$ P.showString "dual " . P.showsPrec 11 f+  showsPrec d (DualInv f) = P.showParen (d P.> 10) P.$ P.showString "dualInv " . P.showsPrec 11 f+  showsPrec d (LinDist f) = P.showParen (d P.> 10) P.$ P.showString "linDist " . P.showsPrec 11 f+  showsPrec d (LinDistInv f) = P.showParen (d P.> 10) P.$ P.showString "linDistInv " . P.showsPrec 11 f++instance+  (StarAutonomousStructures `Elems` cs)+  => StarAutonomous (FREE cs (p :: CAT k))+  where+  type Dual a = DualF a+  withObDual r = r+  dual f = St (Dual f) Nil \\ f+  dualInv @a @b f = St (DualInv @a @b f) Nil \\ f+  linDist @a @b @c f = St (LinDist @a @b @c f) Nil \\ f+  linDistInv @a @b @c f = St (LinDistInv @a @b @c f) Nil \\ f++-- | 'dual' is a contravariant functor, bijective on hom-sets with inverse 'dualInv'; 'doubleNeg'+-- is an isomorphism; and 'linDist' is a natural bijection+-- @Hom(a ** b, Dual c) ≅ Hom(a, Dual (b ** c))@ with inverse 'linDistInv'.+instance Laws StarAutonomousStructures where+  laws =+    [ Law "dual identity" \ @a _ -> withObDual @_ @a (dual (obj @a) === id)+    , Law "dual composition" \ @a @b @c mor -> do+        f <- mor @a @b "f"+        g <- mor @b @c "g"+        dual (g . f) === dual f . dual g+    , Law "linDist naturality" \ @a @b @c @d @e mor ->+        withOb2 @_ @a @b $ withOb2 @_ @d @e $ withObDual @_ @c $ withObDual @_ @d do+          p <- mor @(a ** b) @(Dual c) "p"+          f <- mor @d @a "f"+          g <- mor @e @b "g"+          h <- mor @d @c "h"+          linDist @_ @d @e @d (dual h . p . (f ** g)) === dual (g ** h) . linDist @_ @a @b @c p . f+    ]+      P.++ bijection+        "dual"+        ( \ @a @b mor ->+            withObDual @_ @a $+              withObDual @_ @b $+                Bijection (mor @a @b "f") (mor @(Dual b) @(Dual a) "g") dual (dualInv @_ @b @a)+        )+      P.++ bijection+        "linDist"+        ( \ @a @b @c mor ->+            withOb2 @_ @a @b $+              withOb2 @_ @b @c $+                withObDual @_ @c $+                  withObDual @_ @(b ** c) $+                    Bijection (mor @(a ** b) @(Dual c) "p") (mor @a @(Dual (b ** c)) "q") (linDist @_ @a @b @c) (linDistInv @_ @a @b @c)+        )+      P.++ [ Law "doubleNegInv definition" \ @a _ -> withObDual @_ @a $ withObDual @_ @(Dual a) (doubleNegInv @_ @a === doubleNegInvDefault @a)+           ]+      P.++ inverses "doubleNeg" \ @a -> Inverses (doubleNegInv @_ @a) (doubleNeg @_ @a)
+ src/Proarrow/Category/Monoidal/Strength.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Profunctor strength for a monoidal action: @'Strong' t p@ lets @p@ absorb the action of @t@+-- via 'act', with 'MonStrong' the self-action (tensor) case; 'Costrong' is the dual, and a+-- 'TracedMonoidal' category is one whose hom-profunctor is costrong for its own tensor.+module Proarrow.Category.Monoidal.Strength where++import Data.Kind (Constraint)++import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..), Tensor)+import Proarrow.Category.Monoidal.Action (Act, CoprodAction, MonoidalAction, ProdAction, actHom)+import Proarrow.Colimit.BinaryCoproduct (COPROD (..), HasBinaryCoproducts (..), swapCoprod)+import Proarrow.Core (CAT, CategoryOf (..), Hom, Kind, Profunctor (..), Promonad (..), obj, ($), type (+->))+import Proarrow.Profunctor.Corepresentable (Corepresentable (..), corepUniv)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Coproduct ((:+:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Instance.Product ((:*:) (..))+import Proarrow.Profunctor.Representable (Representable (..), repUniv)+import Proarrow.Tools.Laws (Law (..), Laws (..), ProLaw (..), ProLaws (..), (=:=), (===))++-- | Profunctorial strength for a monoidal action.+-- Gives functorial strength for representable profunctors,+-- and functorial costrength for corepresentable profunctors.+type Strong :: forall {m} {k}. (m, k) +-> k -> k +-> k -> Constraint+class (MonoidalAction t, Profunctor p) => Strong t p where+  act :: (Ob a) => p x y -> p (Act t a x) (Act t a y)++instance (Strong t p, Strong t q) => Strong t (p :*: q) where+  act @a (p :*: q) = act @t @_ @a p :*: act @t @_ @a q++instance (Strong t p, Strong t q) => Strong t (p :+: q) where+  act @a (InjL p) = InjL (act @t @_ @a p)+  act @a (InjR q) = InjR (act @t @_ @a q)++instance (MonoidalAction t) => Strong t (Id :: CAT k) where+  act @a (Id g) = Id (actHom @t (obj @a) g)++instance (Strong t p, Strong t q) => Strong t (p :.: q) where+  act @x (p :.: q) = act @t @_ @x p :.: act @t @_ @x q++instance (CategoryOf j, CategoryOf k) => Strong ProdAction (Prof :: CAT (j +-> k)) where+  act (Prof n) = Prof \(p :*: q) -> p :*: n q++-- | The laws of strength for the tensor acting on its own category: acting by the 'Unit' does+-- nothing and acting by a tensor is acting twice, up to the unitor and the associator, and 'act' is+-- natural in the element and dinatural in the acting object.+instance ProLaws (Strong Tensor) where+  proLaws =+    [ ProLaw "act unit" \ @p @a @b p _ _ -> p =:= dimap (leftUnitorInv @_ @a) (leftUnitor @_ @b) (act @Tensor @p @Unit p)+    , ProLaw "act tensor" \ @p @a @b @c @d p _ _ ->+        withOb2 @_ @c @d $+          act @Tensor @p @(c ** d) p+            =:= dimap (associator @_ @c @d @a) (associatorInv @_ @c @d @b) (act @Tensor @p @c (act @Tensor @p @d p))+    , ProLaw "act naturality" \ @p @a @b @c @d @e p morK morJ -> do+        g <- morK @c @a "g"+        h <- morJ @b @d "h"+        act @Tensor @p @e (dimap g h p) =:= dimap (obj @e ** g) (obj @e ** h) (act @Tensor @p @e p)+    , ProLaw "act dinaturality" \ @p @a @b @c @_ @e p morK _ -> do+        g <- morK @e @c "g"+        lmap (g ** obj @a) (act @Tensor @p @c p) =:= rmap (g ** obj @b) (act @Tensor @p @e p)+    ]++type MonStrong (p :: k +-> k) = (Strong Tensor p, SymMonoidal k)++-- | If a strong profunctor is representable, we get the usual strength for the representing functor.+strength+  :: forall {m} t p a b. (Representable p, Strong t p, Ob (a :: m), Ob b) => Act t a (p % b) ~> p % Act t a b+strength = index (act @t @p @a (repUniv @p @b))++-- | If a strong profunctor is corepresentable, we get the usual costrength for the representing functor.+costrength+  :: forall {m} t p a b. (Corepresentable p, Strong t p, Ob (a :: m), Ob b) => p %% Act t a b ~> Act t a (p %% b)+costrength = coindex (act @t @p @a (corepUniv @p @b))++first'+  :: forall {k} {p :: k +-> k} c a b. (MonStrong p, Ob c) => p a b -> p (a ** c) (b ** c)+first' p = dimap (swap @k @a @c) (swap @k @c @b) (second' @c p) \\ p++second'+  :: forall {k} {p :: k +-> k} c a b. (MonStrong p, Ob c) => p a b -> p (c ** a) (c ** b)+second' p = act @Tensor @p @c p++left'+  :: forall {k} (p :: k +-> k) c a b. (Strong CoprodAction p, HasBinaryCoproducts k, Ob c) => p a b -> p (a || c) (b || c)+left' p = dimap (swapCoprod @a @c) (swapCoprod @c @b) (right' @_ @c p) \\ p++right' :: forall {k} (p :: k +-> k) c a b. (Strong CoprodAction p, Ob c) => p a b -> p (c || a) (c || b)+right' p = act @CoprodAction @p @(COPR c) p++-- | This is not monoidal ** but premonoidal, i.e. no sliding.+-- So with `premon f g` the effects of f happen before the effects of g.+-- p needs to be a commutative promonad for this to be monoidal **.+premon+  :: forall {k} {p :: CAT k} a b c d. (MonStrong p, Promonad p) => p a b -> p c d -> p (a ** c) (b ** d)+premon f g = second' @b g . first' @c f \\ f \\ g++strongId :: forall {k} {p :: k +-> k} a. (MonStrong p, MonoidalProfunctor p, Ob a) => p a a+strongId = dimap rightUnitorInv rightUnitor (second' @a one)++-- | A monoidal promonad is automatically strong.+monActDefault :: forall {p} a x y. (MonoidalProfunctor p, Promonad p, Ob a) => p x y -> p (a ** x) (a ** y)+monActDefault p = id @p @a ** p++type Costrong :: forall {m} {k}. (m, k) +-> k -> k +-> k -> Constraint+class (MonoidalAction t, Profunctor p) => Costrong t p where+  coact :: forall a x y. (Ob a, Ob x, Ob y) => p (Act t a x) (Act t a y) -> p x y++instance Costrong Tensor (->) where+  coact f x = let (u, y) = f (u, x) in y++instance (MonoidalAction t, Costrong t (Hom k)) => Costrong t (Id :: CAT k) where+  coact @a (Id g) = Id (coact @t @(Hom k) @a g)++-- | The laws of costrength for the tensor acting on its own category: 'coact' is natural in the+-- element and dinatural in the acting object (sliding), and coacting by the 'Unit' or by a tensor+-- is doing nothing or coacting twice (vanishing). An element with tensored endpoints is made from+-- the drawn element @p@ with arbitrary arrows into and out of it.+instance ProLaws (Costrong Tensor) where+  proLaws =+    [ ProLaw "coact unit" \ @p @a @b p _ _ ->+        withOb2 @_ @Unit @a $+          withOb2 @_ @Unit @b $+            p =:= coact @Tensor @p @Unit (dimap (leftUnitor @_ @a) (leftUnitorInv @_ @b) p)+    , ProLaw "coact tensor" \ @p @a @b @c @d @e @f p morK _ ->+        withOb2 @_ @c @e $+          withOb2 @_ @(c ** e) @d $+            withOb2 @_ @(c ** e) @f $+              withOb2 @_ @e @d $+                withOb2 @_ @e @f $+                  withOb2 @_ @c @(e ** d) $ withOb2 @_ @c @(e ** f) do+                    g <- morK @((c ** e) ** d) @a "g"+                    h <- morK @b @((c ** e) ** f) "h"+                    let q = dimap g h p+                    coact @Tensor @p @(c ** e) q+                      =:= coact @Tensor @p @e @d @f (coact @Tensor @p @c (dimap (associatorInv @_ @c @e @d) (associator @_ @c @e @f) q))+    , ProLaw "coact naturality" \ @p @a @b @c @d @e @f p morK _ ->+        withOb2 @_ @c @d $ withOb2 @_ @c @f $ withOb2 @_ @c @e do+          g <- morK @(c ** d) @a "g"+          h <- morK @b @(c ** f) "h"+          g' <- morK @e @d "g'"+          h' <- morK @f @e "h'"+          let q = dimap g h p+          coact @Tensor @p @c (dimap (obj @c ** g') (obj @c ** h') q) =:= dimap g' h' (coact @Tensor @p @c q)+    , ProLaw "coact sliding" \ @p @a @b @c @d @e @f p morK _ ->+        withOb2 @_ @c @d $ withOb2 @_ @c @f $ withOb2 @_ @e @d $ withOb2 @_ @e @f do+          g <- morK @(c ** d) @a "g"+          h <- morK @b @(e ** f) "h"+          k <- morK @e @c "k"+          let q = dimap g h p+          coact @Tensor @p @e @d @f (lmap (k ** obj @d) q) =:= coact @Tensor @p @c @d @f (rmap (k ** obj @f) q)+    ]++trace+  :: forall {k} (p :: k +-> k) u x y+   . (Costrong Tensor p, Ob x, Ob y, Ob u, SymMonoidal k) => p (x ** u) (y ** u) -> p x y+trace p = coact @Tensor @p @u @x @y (dimap (swap @k @u @x) (swap @k @y @u) p) \\ p++class (Costrong Tensor (Hom k), SymMonoidal k) => TracedMonoidal k+instance (Costrong Tensor (Hom k), SymMonoidal k) => TracedMonoidal k++-- | The structures the laws of a traced monoidal category are stated for.+type TracedStructures :: [Kind -> Constraint]+type TracedStructures = '[Monoidal, SymMonoidal, TracedMonoidal]++-- | The trace laws, for 'trace' over @u@ of @f : x ** u ~> y ** u@: natural in @x@ and @y@,+-- dinatural in @u@ (sliding), trivial over the unit and iterated over a tensor (vanishing),+-- compatible with tensoring on the left (superposing), and the trace of a swap is the identity+-- (yanking).+instance Laws TracedStructures where+  laws =+    [ Law "naturality" \ @x @y @u @d @e mor -> withOb2 @_ @x @u $ withOb2 @_ @y @u $ withOb2 @_ @e @u $ withOb2 @_ @d @u do+        f <- mor @(x ** u) @(y ** u) "f"+        g <- mor @y @d "g"+        h <- mor @e @x "h"+        g . trace @(~>) @u @x @y f . h === trace @(~>) @u @e @d ((g ** obj @u) . f . (h ** obj @u))+    , Law "sliding" \ @x @y @u @v mor -> withOb2 @_ @x @u $ withOb2 @_ @y @u $ withOb2 @_ @x @v $ withOb2 @_ @y @v do+        f <- mor @(x ** v) @(y ** u) "f"+        g <- mor @u @v "g"+        trace @(~>) @u @x @y (f . (obj @x ** g)) === trace @(~>) @v @x @y ((obj @y ** g) . f)+    , Law "vanishing (unit)" \ @x @y mor -> withOb2 @_ @x @Unit $ withOb2 @_ @y @Unit do+        f <- mor @(x ** Unit) @(y ** Unit) "f"+        trace @(~>) @Unit @x @y f === rightUnitor @_ @y . f . rightUnitorInv @_ @x+    , Law "vanishing (tensor)" \ @x @y @u @v mor ->+        withOb2 @_ @u @v $+          withOb2 @_ @x @(u ** v) $+            withOb2 @_ @y @(u ** v) $+              withOb2 @_ @x @u $+                withOb2 @_ @y @u $+                  withOb2 @_ @(x ** u) @v $+                    withOb2 @_ @(y ** u) @v do+                      f <- mor @(x ** (u ** v)) @(y ** (u ** v)) "f"+                      trace @(~>) @(u ** v) @x @y f+                        === trace @(~>) @u @x @y (trace @(~>) @v @(x ** u) @(y ** u) (associatorInv @_ @y @u @v . f . associator @_ @x @u @v))+    , Law "superposing" \ @x @y @u @w mor ->+        withOb2 @_ @x @u $+          withOb2 @_ @y @u $+            withOb2 @_ @w @x $+              withOb2 @_ @w @y $+                withOb2 @_ @w @(x ** u) $+                  withOb2 @_ @w @(y ** u) do+                    f <- mor @(x ** u) @(y ** u) "f"+                    obj @w+                      ** trace @(~>) @u @x @y f+                      === trace @(~>) @u @(w ** x) @(w ** y) (associatorInv @_ @w @y @u . (obj @w ** f) . associator @_ @w @x @u)+    , Law "yanking" \ @u _ -> withOb2 @_ @u @u (obj @u === trace @(~>) @u @u @u (swap @_ @u @u))+    ]
+ src/Proarrow/Category/Monoidal/Strictified.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The strictification of a monoidal category: objects are /lists/ of objects of @k@, tensoring is+-- list concatenation, and a morphism @as ~> bs@ is a @'Fold' as ~> 'Fold' bs@ in @k@ (the+-- 'Strictified' arrow). Unitors and associators become identities, which makes composing long+-- tensor expressions, string diagrams in particular, much more convenient.+module Proarrow.Category.Monoidal.Strictified where++import Data.Kind (Constraint)+import Prelude (($), type (~))++import Proarrow.Category.Monoidal+  ( Monoidal (..)+  , MonoidalProfunctor (..)+  , Strictly+  , SymMonoidal (..)+  , associatorDefault+  )+import Proarrow.Core (CAT, CategoryOf (..), Obj, Profunctor (..), Promonad (..), dimapDefault, obj)++infixl 7 ==++(==) :: (CategoryOf k) => ((a :: k) ~> b) -> (b ~> c) -> a ~> c+f == g = g . f++type family (as :: [k]) ++ (bs :: [k]) :: [k] where+  '[] ++ bs = bs+  (a ': as) ++ bs = a ': (as ++ bs)++data SList as where+  SNil :: SList '[]+  SSing :: (Ob a) => SList '[a]+  SCons :: (Ob a, Ob as, Ob bs, as ~ b ': bs) => SList (a ': as)++type IsList :: forall {k}. [k] -> Constraint+class (CategoryOf k, Obs as, Strictly as) => IsList (as :: [k]) where+  listCase+    :: ((as ~ '[]) => r)+    -> (forall a. (Ob a, as ~ '[a]) => r)+    -> (forall b bs c cs. (Ob b, Ob bs, Ob cs, as ~ (b ': bs), bs ~ (c ': cs)) => r)+    -> r+  sList :: SList as+  withIsList2 :: (IsList bs) => ((IsList (as ++ bs)) => r) -> r+  swap1 :: (Ob b, SymMonoidal k) => as ++ '[b] ~> b ': as+  swap1Inv :: (Ob b, SymMonoidal k) => b ': as ~> as ++ '[b]+  swap' :: (IsList (bs :: [k]), SymMonoidal k) => as ++ bs ~> bs ++ as+instance (CategoryOf k) => IsList ('[] :: [k]) where+  listCase n _ _ = n+  sList = SNil+  withIsList2 r = r+  swap1 = id+  swap1Inv = id+  swap' = id+instance (Ob (a :: k), CategoryOf k) => IsList '[a] where+  listCase _ s _ = s+  sList = SSing+  withIsList2 @bs r = listCase @bs r r r+  swap1 @b = Str (swap @k @a @b)+  swap1Inv @b = Str (swap @k @b @a)+  swap' @bs = swap1Inv @bs @a+instance (Ob (a1 :: k), IsList (a2 ': as), IsList as) => IsList (a1 ': a2 ': as) where+  listCase _ _ c = c+  sList = SCons+  withIsList2 @bs r = withIsList2 @(a2 ': as) @bs $ withIsList2 @as @bs r+  swap1 @b = case swap1 @(a2 ': as) @b of f -> (Str @[a1, b] @[b, a1] (swap @_ @a1 @b) ** obj @(a2 ': as)) . (obj @'[a1] ** f)+  swap1Inv @b = case swap1Inv @(a2 ': as) @b of f -> (obj @'[a1] ** f) . (Str @[b, a1] @[a1, b] (swap @_ @b @a1) ** obj @(a2 ': as))+  swap' @bs = case swap' @(a2 ': as) @bs of+    f -> associator @_ @bs @'[a1] @(a2 ': as) . (swap1Inv @bs @a1 ** obj @(a2 ': as)) . (obj @'[a1] ** f)++type family Fold (as :: [k]) :: k where+  Fold ('[] :: [k]) = Unit :: k+  Fold '[a] = a+  Fold (a ': as) = a ** Fold as++fold :: forall {k} (as :: [k]). (Monoidal k, Ob as) => Obj (Fold as)+fold = listCase @as one obj \ @b @bs -> obj @b ** fold @bs++withObFold :: forall {k} (as :: [k]) r. (Monoidal k, Ob as) => ((Ob (Fold as)) => r) -> r+withObFold r = listCase @as r r \ @b @bs -> withObFold @bs $ withOb2 @k @b @(Fold bs) r++type family Obs (as :: [k]) :: Constraint where+  Obs '[] = ()+  Obs (a ': as) = (Ob a, Obs as)++withObs :: forall {k} (as :: [k]) r. (Monoidal k, Ob as) => ((Obs as) => r) -> r+withObs r = listCase @as r r \ @_ @bs -> withObs @bs r++concatFold+  :: forall {k} (as :: [k]) (bs :: [k])+   . (Ob as, Ob bs, Monoidal k)+  => Fold as ** Fold bs ~> Fold (as ++ bs)+concatFold =+  let fbs = fold @bs+      h :: forall (cs :: [k]) r. (Ob cs) => ((Ob (Fold cs)) => Fold cs ** Fold bs ~> Fold (cs ++ bs) -> r) -> r+      h k =+        listCase @cs+          (k leftUnitor)+          (\ @c -> k $ listCase @bs rightUnitor (obj @c ** fbs) (obj @c ** fbs))+          (\ @c @cs' -> h @cs' \cbs -> withOb2 @k @c @(Fold cs') $ k $ (obj @c ** cbs) . associator @_ @c @(Fold cs') @(Fold bs))+          \\ fbs+  in h @as id++splitFold+  :: forall {k} (as :: [k]) (bs :: [k])+   . (Ob as, Ob bs, Monoidal k)+  => Fold (as ++ bs) ~> (Fold as ** Fold bs)+splitFold =+  let fbs = fold @bs+      h :: forall (cs :: [k]) r. (Ob cs) => ((Ob (Fold cs)) => Fold (cs ++ bs) ~> Fold cs ** Fold bs -> r) -> r+      h k =+        listCase @cs+          (k leftUnitorInv)+          (\ @c -> k $ listCase @bs rightUnitorInv (obj @c ** fbs) (obj @c ** fbs))+          (\ @c @cs' -> h @cs' \cbs -> withOb2 @k @c @(Fold cs') $ k $ associatorInv @_ @c @(Fold cs') @(Fold bs) . (obj @c ** cbs))+          \\ fbs+  in h @as id++type Strictified :: CAT [k]+data Strictified as bs where+  Str :: (Ob as, Ob bs) => {unStr :: Fold as ~> Fold bs} -> Strictified as bs++singleton :: (CategoryOf k) => (a :: k) ~> b -> '[a] ~> '[b]+singleton a = Str a \\ a++obj1 :: forall {k} (a :: k). (Monoidal k, Ob a) => Obj '[a]+obj1 = obj @'[a]++concatMany :: forall {k} (as :: [k]). (Ob as, Monoidal k) => as ~> '[Fold as]+concatMany = withObFold @as (Str id)++splitMany :: forall {k} (as :: [k]). (Ob as, Monoidal k) => '[Fold as] ~> as+splitMany = withObFold @as (Str id)++instance (Monoidal k) => Profunctor (Strictified :: CAT [k]) where+  dimap = dimapDefault+  r \\ Str{} = r++instance (Monoidal k) => Promonad (Strictified :: CAT [k]) where+  id @as = Str (fold @as)+  Str f . Str g = Str (f . g)++-- | The strictified monoidal category, making the unitors and associators identities.+instance (Monoidal k) => CategoryOf [k] where+  type (~>) = Strictified+  type Ob as = IsList as++instance (Monoidal k) => MonoidalProfunctor (Strictified :: CAT [k]) where+  one = id+  Str @as @bs f ** Str @cs @ds g =+    withOb2 @[k] @as @cs $+      withOb2 @[k] @bs @ds $+        Str (concatFold @bs @ds . (f ** g) . splitFold @as @cs)++-- | List concatenation as monoidal tensor.+instance (Monoidal k) => Monoidal [k] where+  type Unit = '[]+  type as ** bs = as ++ bs+  withOb2 @as @bs r = withIsList2 @as @bs r+  associator @as @bs @cs = associatorDefault @as @bs @cs+  associatorInv @as @bs @cs = associatorDefault @as @bs @cs++instance (SymMonoidal k) => SymMonoidal [k] where+  swap @as @bs = swap' @as @bs++swap2 :: forall {k} (a :: k) (b :: k). (SymMonoidal k, Ob a, Ob b) => '[a, b] ~> '[b, a]+swap2 = swap @[k] @'[a] @'[b]
+ src/Proarrow/Category/Promonoidal.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Promonoidal categories, where the tensor is a profunctor rather than a functor: a 'Protensor'+-- @'LIST' k '+->' k@ composes and decomposes lists of objects, 'Promonoid' is a monoid for it, and+-- 'Day' is the convolution tensor a pair of protensors induces on profunctors.+module Proarrow.Category.Promonoidal where++import Data.Kind (Constraint)+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..))+import Proarrow.Category.Monoidal.Strictified qualified as Str+import Proarrow.Core+  ( CategoryOf (..)+  , Obj+  , Profunctor (..)+  , Promonad (..)+  , UN+  , lmap+  , obj+  , tgt+  , (//)+  , (:~>)+  , type (+->)+  )+import Proarrow.Functor (Functor (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.List (LIST (..), List (..), foldList)+import Proarrow.Profunctor.Representable (Representable (..), dimapRep)++type PROTENSOR k = LIST k +-> k+type Protensor :: forall {k}. PROTENSOR k -> Constraint+class (Profunctor p) => Protensor p where+  compose :: (p :.: List p) a bss -> p a (Tensor % bss)+  decompose :: (Ob bss) => p a (Tensor % bss) -> (p :.: List p) a bss++class (Protensor p) => Promonoid p m where+  mempty :: p m (L '[])+  mappend :: p m (L '[m, m])++class (Protensor t, Profunctor p) => PromonoidalProfunctor t p where+  parN :: t :.: List p :~> p :.: t++-- | The 'Protensor' of a monoidal category @k@: an arrow @'[a] '~>' bs@ of the strictified+-- category, representably sending a list of objects to its fold.+type Tensor :: PROTENSOR k+data Tensor a bs where+  Tensor :: (Ob bs) => {unTensor :: '[a] ~> UN L bs} -> Tensor a bs++instance (Monoidal k) => Profunctor (Tensor :: PROTENSOR k) where+  dimap = dimapRep+  r \\ Tensor (Str.Str f) = r \\ f+instance (Monoidal k) => Representable (Tensor :: PROTENSOR k) where+  type Tensor % as = Str.Fold (UN L as)+  index (Tensor (Str.Str f)) = f+  tabulate f = Tensor (Str.Str f) \\ f+  repMap = foldList+instance (Monoidal k) => MonoidalProfunctor (Tensor :: PROTENSOR k) where+  one = Tensor (Str.Str id)+  Tensor f ** Tensor g = let fg = f ** g in fg // Str.unStr fg // Tensor (Str.Str (Str.unStr fg))+instance (Monoidal k) => Protensor (Tensor :: PROTENSOR k) where+  compose (Tensor (Str.Str f) :.: l) = lmap f (foldList l)+  decompose @bss (Tensor (Str.Str f)) = lmap f (go (obj @bss))+    where+      -- 🤮+      go :: (Monoidal k) => Obj (ass :: LIST (LIST k)) -> (Tensor :.: List Tensor) (Tensor % (Tensor % ass)) ass+      go Nil = Tensor (Str.Str id) :.: Nil+      go (Cons as Nil) = let fas = foldList as in as // fas // Tensor (Str.Str fas) :.: Cons (Tensor (Str.Str id)) Nil+      go (Cons @ass' @_ @_ @as as ass@Cons{}) = case go ass of+        Tensor @bs g :.: l ->+          as //+            let fas = foldList as; fass = foldList ass+            in fas //+                 fass //+                   let fasg = Str.Str @(UN L as) @'[Str.Fold (UN L as)] fas ** Str.Str @(UN L (Str.Fold ass')) @(UN L bs) (Str.unStr g)+                   in foldList (as ** fass) // fasg // Tensor (Str.Str (Str.unStr fasg)) :.: Cons (Tensor (Str.Str id)) l++instance (MonoidalProfunctor p) => PromonoidalProfunctor Tensor p where+  parN (Tensor (Str.Str f) :.: l) = let fl = foldList l in lmap f fl :.: Tensor (Str.Str (tgt fl)) \\ fl \\ l++-- | A list of profunctors applied pointwise: @'PList' ps@ relates the lists @as@ and @bs@ by a+-- value of each @p@ in @ps@ at the corresponding positions.+type PList :: LIST (j +-> k) -> LIST j +-> LIST k+data PList ps as bs where+  PNil :: PList (L '[]) (L '[]) (L '[])+  PCons+    :: (Ob as, Ob bs, Ob p, Ob ps) => p a b -> PList (L ps) (L as) (L bs) -> PList (L (p ': ps)) (L (a ': as)) (L (b ': bs))++instance (CategoryOf j, CategoryOf k, Ob ps) => Profunctor (PList ps :: LIST j +-> LIST k) where+  dimap Nil Nil PNil = PNil+  dimap (Cons l ls) (Cons r rs) (PCons f fs) =+    ls //+      rs //+        PCons (dimap l r f) (dimap ls rs fs)+  dimap Nil Cons{} ps = case ps of {}+  dimap Cons{} Nil ps = case ps of {}+  r \\ PNil = r+  r \\ PCons f PNil = r \\ f+  r \\ PCons f fs@PCons{} = r \\ f \\ fs+instance (CategoryOf j, CategoryOf k) => Functor (PList :: LIST (j +-> k) -> LIST j +-> LIST k) where+  map Nil = Prof \PNil -> PNil+  map f@(Cons (Prof n) fs) = f // Prof (\(PCons p ps) -> PCons (n p) (unProf (map fs) ps))++type Day :: PROTENSOR k -> PROTENSOR j -> LIST (j +-> k) -> j +-> k+data Day tk tj ps a b where+  Day :: (Ob a, Ob b) => (tj b bs -> (tk a as, PList ps as bs)) -> Day tk tj ps a b+instance (Profunctor tk, Profunctor tj) => Profunctor (Day tk tj ps) where+  dimap l r (Day f) =+    l // r // Day \tj -> case f (lmap r tj) of+      (tk, ps) -> (lmap l tk, ps)+  r \\ Day{} = r+instance (Profunctor tk, Profunctor tj) => Functor (Day tk tj) where+  map f = Prof (\(Day d) -> Day \k -> case d k of (tk, ps) -> (tk, unProf (map f) ps))
+ src/Proarrow/Category/Sheaf.hs view
@@ -0,0 +1,531 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Sites and sheaves.+--+-- A /cover/ of an object @a@ is a family of arrows into @a@, its /legs/, that together count as+-- all of @a@. The model is the opens of a space: an open is covered by smaller opens whose union+-- it is. A 'Site' is a category with a choice of covers, called a /coverage/.+--+-- Read an element of @p a b@ as data over @a@ (@b@ is a parameter along for the ride). Restricting+-- along a leg @g :: x '~>' a@, with @'lmap' g@, gives data over @x@. A family, one element per leg,+-- is /matching/ when its elements agree wherever two legs overlap: for legs @g@, @g'@ and any+-- @u :: z '~>' x@, @v :: z '~>' y@ with @'legArrow' g . u = 'legArrow' g' . v@,+-- @'lmap' u (m g) = 'lmap' v (m g')@. @p@ is a 'Sheaf' when every matching family is the+-- restriction of exactly one element at @a@. That rules out two failures:+--+-- * /Too many wholes./ Two distinct elements at @a@ restrict to the same family, so agreeing on+--   every leg does not make two things equal, and nothing can be proved by taking @a@ apart.+--+-- * /Too few./ A matching family is the restriction of no element at @a@, so compatible local+--   data cannot be assembled, and nothing can be built by putting @a@ together.+--+-- Neither implies the other, and counting the two sides decides neither:+--+-- @+--                                                elements at a   matching families   verdict+-- the representable at FLS, Atomic on BOOL             0                 1           too few+-- the constant presheaf, Joins on (BOOL, BOOL)         2                 1           too many+-- the collapsing presheaf, Atomic on BOOL              2                 2           not injective+-- @+--+-- Overlap is stated over every commuting square, not over /the/ pullback, so two legs need not+-- have a pullback object. 'Sums' relies on this: it works over a free category that has none.+--+-- The arrows into @a@ that factor through some leg form the /sieve/ the cover generates. Covers are+-- given by their legs because a list of legs is finite and a sieve usually is not. Sieves are the+-- truth values of presheaf categories, see "Proarrow.Profunctor.Instance.Sieve". When covers are+-- stable and compose, the coverage generates a Grothendieck topology; 'Sums' shows it need not.+--+-- Covers given by generating arrows, and gluing as an operation rather than a condition, follow+-- Arnaud Spiwack's /Sheaves in Haskell/ (Tweag, 2026, <https://www.tweag.io/blog/2026-06-18-sheaves-in-haskell/>).+-- Added here: the category, the sieves, the classifier and a decision procedure for the sheaf+-- condition, the last three in "Proarrow.Category.Enriched.Finitary.Sheaf".+module Proarrow.Category.Sheaf where++import Data.Kind (Constraint, Type)+import Data.List (subsequences, tails)+import Data.Maybe (fromMaybe, listToMaybe)+import Prelude (Bool, Maybe (..), and, error, not, null, (||))++import Proarrow.Category.Enriched.Finitary (Finitary (..), FiniteCat, LocallyFinite, factorThrough, foreachOb)+import Proarrow.Category.Enriched.Thin (Thin)+import Proarrow.Category.Instance.Free (Elem, FREE)+import Proarrow.Category.Instance.Opposite (OPPOSITE (..))+import Proarrow.Category.Monoidal.Cartesian (Bicartesian)+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..), type (+))+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Core (CAT, CategoryOf (..), Hom, Kind, Profunctor (..), Promonad (..), obj, rmap, (//), type (+->))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..))+import Proarrow.Limit.Pullback (HasPullbacks (..))+import Proarrow.Object (pattern Objs)+import Proarrow.Profunctor.Corepresentable (Corepresentable (..), withObCorep)+import Proarrow.Profunctor.Instance.Product (fstP, sndP, (:*:) (..))+import Proarrow.Profunctor.Instance.Rift (Rift (..))+import Proarrow.Profunctor.Instance.Terminal (TerminalProfunctor (..))+import Proarrow.Profunctor.Instance.Yoneda (Yo (..))++-- * Sites++-- | The kind of coverage names. A coverage is named by an empty type, the first argument of+-- 'Site', and has no values.+type Coverage :: Kind+type Coverage = Type++-- | A coverage, named @t@, on the category @k@. Several coverages can live on one category, so the+-- name is a parameter rather than a wrapper on the kind.+--+-- A cover is given by its /legs/, the arrows of the covering family. Every object is covered by+-- its identity; that cover is left implicit, and 'Cover' and 'covers' list the others. The laws are+--+-- [Stability] covers pull back: restricting a cover of @a@ to a part @b@ of @a@ gives a cover of+--   @b@. Given a cover @c@ of @a@ and any @f :: b '~>' a@, the object @b@ has a cover (possibly+--   just its identity) each of whose legs @h@ satisfies @f . h = 'legArrow' g . h'@ for some leg+--   @g@ of @c@ and some @h'@. Only the equation is asked for. No pullback object has to exist.+--+-- [Naming] a family over a cover @c@, a function @forall x. 'Leg' t k a c x -> r@ as 'glue' takes+--   and 'PulledBack' carries, is consulted only at the legs of @c@: those in @'legs' c@, or built+--   from the cover's own data. Its values at other legs are unspecified.+--+-- Naming matters when several covers share a type-level name @c@, as 'Atomic'\'s do on a category+-- that is not thin and 'Joins'\'s always do. Then 'Leg' also admits the legs of the other covers+-- with that name, so a hand-written 'glue' takes its legs from the cover it was given.+type Site :: Coverage -> Kind -> Constraint+class (CategoryOf k) => Site t k where+  -- | A cover of @a@. The type @c@ names it, so that 'Leg' can say which cover a leg belongs to;+  -- the value is the evidence that @c@ covers @a@.+  data Cover t k (a :: k) (c :: Type)++  -- | A leg of the cover @c@ of @a@, with source @x@.+  data Leg t k (a :: k) (c :: Type) (x :: k)++  -- Haddock gives no anchor to the constructors of a data family instance written inside a class+  -- instance, so each coverage below names its own in the docs of its cover tags instead.++  -- | The arrow a leg stands for.+  legArrow :: Leg t k a c x -> x ~> a++  -- | The legs of a cover.+  legs :: Cover t k a c -> [SomeLeg t k a c]++-- | A leg of the cover @c@ of @a@, with its source hidden.+type SomeLeg :: Coverage -> forall (k :: Kind) -> k -> Type -> Type+data SomeLeg t k a c where+  SomeLeg :: Leg t k a c x -> SomeLeg t k a c++-- | A site whose covers can be listed, object by object, as the law tests and the decision+-- procedure of "Proarrow.Category.Enriched.Finitary.Sheaf" need. A free category is a 'Site' but+-- not this: its 'Ob' cannot tell whether an object is a sum.+--+-- [Composition] covers compose. If @c@ covers @a@ and every leg of @c@ is itself covered, the+--   composites cover @a@ too. With Stability this makes the coverage generate a Grothendieck+--   topology, so 'Proarrow.Category.Enriched.Finitary.Sheaf.closure' is idempotent and preserves+--   meets, which 'Proarrow.Category.Enriched.Finitary.Sheaf.Plus' needs.+--   'Proarrow.Testing.Laws.testLawvereTierney' is the check.+class (Site t k) => HasFiniteCovers t k where+  -- | The covers of an object, beyond the identity.+  covers :: forall (a :: k). (Ob a) => [SomeCover t k a]++-- | A cover of @a@, with its name hidden.+type SomeCover :: Coverage -> forall (k :: Kind) -> k -> Type+data SomeCover t k a where+  SomeCover :: Cover t k a c -> SomeCover t k a++-- | How an arrow into @a@ factors through a cover of @a@: the leg it goes through, and the arrow+-- to that leg\'s source. The equation @f = 'legArrow' g . h@ is the caller\'s to rely on and the+-- instance\'s to respect.+type Factors :: Coverage -> forall (k :: Kind) -> k -> Type -> k -> Type+data Factors t k a c x where+  Factors :: Leg t k a c y -> x ~> y -> Factors t k a c x++-- | How an arrow into @a@ factors through a cover of @a@, if it does: through the first leg it+-- factors through, found by 'factorThrough'. Only the hom-sets have to be finite.+factorThroughCover :: (Site t k, LocallyFinite k) => Cover t k a c -> x ~> a -> Maybe (Factors t k a c x)+factorThroughCover c h = listToMaybe [Factors l u | SomeLeg l <- legs c, Just u <- [h // legArrow l // factorThrough h (legArrow l)]]++-- | A cover pulled back along an arrow @f :: b '~>' a@: either @f@ itself factors through a leg+-- (the pullback is @b@\'s implicit identity cover), or some cover of @b@ has every leg factoring+-- through one.+type PulledBack :: Coverage -> forall (k :: Kind) -> k -> Type -> k -> Type+data PulledBack t k a c b where+  AlreadyFactors :: Factors t k a c b -> PulledBack t k a c b+  PulledBack :: Cover t k b c' -> (forall x. Leg t k b c' x -> Factors t k a c x) -> PulledBack t k a c b++-- | 'Site'\'s Stability law as an /operation/: a pullback one can compute with, carrying the+-- factorisation of each new leg through an old one. It lets a sheaf be glued structurally. Without+-- it, gluing into a carrier with no 'glue' of its own (an internal hom, the closed sieves) means+-- searching the carrier\'s elements ('Proarrow.Category.Enriched.Finitary.Topos.glueBySearch'),+-- which needs the carrier to be finitary.+--+-- Separate from 'Site' because 'Sums' cannot implement it: a free bicartesian category is not+-- extensive, so its covers do not pull back.+class (Site t k) => StableSite t k where+  pullbackCover :: (Ob b) => Cover t k a c -> b ~> a -> PulledBack t k a c b++-- | A cover pulled back along the identity of the object it covers: itself, each leg factoring+-- through itself. Every instance needs this clause, and this version cannot get it wrong. In a+-- hand-written one, naming another leg with the same source type-checks.+pullbackAlongId :: (Site t k) => Cover t k a c -> PulledBack t k a c a+pullbackAlongId c = PulledBack c \l -> legArrow l // Factors l id++-- * Sheaves++-- | A profunctor that is a sheaf for the coverage @t@ on its contravariant side: every matching+-- family over a cover glues to one element. A family @m@ over the legs of a cover @c@ is+-- /matching/ when it agrees on overlaps: for legs @g@, @g'@ and any @u :: z '~>' x@,+-- @v :: z '~>' y@ with @'legArrow' g . u = 'legArrow' g' . v@, @'lmap' u (m g) = 'lmap' v (m g')@.+-- 'Sums' below is the smallest worked instance. The laws are+--+-- [Restriction] for matching @m@, @'lmap' ('legArrow' g) ('glue' c m) = m g@ at every leg @g@ of+--   @c@: the gluing restricts back to the family;+--+-- [Uniqueness] @'glue' c (\\g -> 'lmap' ('legArrow' g) x) = x@: an element is the gluing of its+--   own restrictions.+--+-- Together they make restriction a bijection from the elements at @a@ to the matching families on+-- @c@. On a non-matching family 'glue' is unspecified. The 'Sums' instance keeps one leg's+-- covariant component and drops the other, which is sound only because matching forces them equal.+--+-- @p@ is a sheaf when each presheaf @p (-) b@ is one, and 'glue' is stated for every @b@ at once.+-- A cosheaf, gluing on the covariant side, is a+-- @'Sheaf' t ('Proarrow.Category.Instance.Opposite.Op' p)@ for a coverage on @'OPPOSITE' k@. The+-- library defines no such coverage.+--+-- Instances are indexed by the shape of the profunctor: the limits below, a site's+-- representables, and the image of sheafification. An instance per coverage would overlap all of+-- them, so 'Trivial' gets the function 'glueTrivial' instead.+type Sheaf :: forall {j} {k}. Coverage -> j +-> k -> Constraint+class (Site t k, Profunctor p) => Sheaf t (p :: j +-> k) where+  glue+    :: forall (a :: k) c (b :: j)+     . (Ob a, Ob b)+    => Cover t k a c+    -> (forall x. Leg t k a c x -> p x b)+    -> p a b++-- | The limits of profunctors are sheaves whenever their factors are: the terminal profunctor for+-- every coverage, and a product of sheaves glued componentwise.+instance (Site t k, CategoryOf j) => Sheaf t (TerminalProfunctor :: j +-> k) where+  glue _ _ = TerminalProfunctor++instance (Sheaf t p, Sheaf t q) => Sheaf t (p :*: q) where+  glue c m = glue @t c (\g -> fstP (m g)) :*: glue @t c (\g -> sndP (m g))++-- * Coverages++-- | The trivial coverage: only identities cover, so every profunctor is a sheaf.+type Trivial :: Coverage+type data Trivial++instance (CategoryOf k) => Site Trivial k where+  data Cover Trivial k a c+  data Leg Trivial k a c x+  legArrow g = case g of {}+  legs c = case c of {}++instance (CategoryOf k) => HasFiniteCovers Trivial k where+  covers = []++instance (CategoryOf k) => StableSite Trivial k where+  pullbackCover c _ = case c of {}++-- | Every profunctor is a sheaf for 'Trivial', by the eliminator of an empty 'Cover'. This is a+-- function rather than an @instance 'Sheaf' 'Trivial' p@ because that head and the two closure+-- instances above overlap (at @'Sheaf' 'Trivial' 'TerminalProfunctor'@, say) with neither more+-- specific than the other, so GHC could not choose between them. Write @glue = glueTrivial@ to get+-- the instance for one profunctor.+glueTrivial :: Cover Trivial k a c -> (forall x. Leg Trivial k a c x -> p x b) -> p a b+glueTrivial c _ = case c of {}++-- | The atomic coverage: every single arrow into an object covers it. So a sieve is covering iff it+-- is nonempty (the /atomic/ topology, with 'HasPullbacks' as its Ore condition). A sheaf is a+-- profunctor whose restriction along every arrow is a bijection. On a chain that is a presheaf+-- that is constant up to iso.+--+-- Stability is the pullback square: pulling a leg back along an arrow into its target gives the+-- cover of that arrow's source by the pullback projection, and the other projection factors it+-- through the old leg. Covers compose, since a composite of single arrows is a single arrow. This+-- is the first coverage here whose legs are themselves covered, so it is the first to exercise+-- 'HasFiniteCovers'\'s Composition law.+--+-- The identity is listed as a cover too. It decides nothing new, and dropping it would take+-- deciding @b ~ a@ under 'foreachOb', which a coverage generic in @k@ cannot do.+type Atomic :: Coverage+type data Atomic++-- | The name of the 'Atomic' cover of an object by a single arrow out of @b@: the 'Cover'+-- constructor is @Solely@ and its one 'Leg' constructor is @Only@. Two distinct arrows @b '~>' a@+-- share the name, so the name is not a singleton, and 'Site'\'s Naming law makes that+-- harmless: 'pullbackCover' answers for the leg of the cover it built, and says nothing true about+-- an @Only@ built from another arrow. On a thin category the arrow is unique and the name a+-- singleton after all.+type data Along (b :: k)++instance (HasPullbacks k, FiniteCat k) => Site Atomic k where+  data Cover Atomic k a c where+    Solely :: (Ob b) => b ~> a -> Cover Atomic k a (Along b)+  data Leg Atomic k a c x where+    Only :: (Ob b) => b ~> a -> Leg Atomic k a (Along b) b+  legArrow (Only f) = f+  legs (Solely f) = [SomeLeg (Only f)]++instance (HasPullbacks k, FiniteCat k) => HasFiniteCovers Atomic k where+  covers @a = foreachOb @k \ @b -> [SomeCover (Solely f) | f <- elements @(Hom k) @b @a]++instance (HasPullbacks k, FiniteCat k) => StableSite Atomic k where+  pullbackCover (Solely f) g = pullback f g \p1 p2 -> p1 // PulledBack (Solely p2) \(Only _) -> Factors (Only f) p1++-- | The open-cover coverage of a finite distributive lattice: an object is covered by any family of+-- objects below it whose join it is. Read the lattice as the opens of a finite space and its+-- sheaves are the sheaves on that space: a section over an open is determined by, and assembled+-- from, its sections over any opens that cover it. On @(BOOL, BOOL)@, the opens of the discrete+-- two-point space (see "Proarrow.Category.Instance.Product"), the whole space is covered by its+-- two points.+--+-- The empty family covers the bottom, the join of nothing, so a sheaf has exactly one section over+-- the bottom, as over the empty set. On a chain nothing else is covered.+--+-- 'covers' lists the antichains strictly below an object that join to it, found by enumerating+-- subsets, so it is for small lattices only. Other families generate the same sieves.+--+-- The instances ask for 'Proarrow.Category.Monoidal.Cartesian.Bicartesian' (meet is the product,+-- join the coproduct) and 'Thin', so that "is there an arrow" reads as @<=@.+-- 'Proarrow.Category.Instance.FinSet.FINSET' is bicartesian and distributive but not thin, and this+-- coverage would mean nothing there. Distributivity gives stability: pulled back along+-- @b '<=' a@, a cover @{x_i}@ of @a@ becomes @{b '&&' x_i}@, whose join is @b@. Covers compose,+-- since a join of joins is a join. The topology is subcanonical (representable presheaves are+-- sheaves), but a two-sided @'Yo' a ('OP' b)@ need not be one: the empty cover asks for one+-- element at the bottom for every object of @j@, and it has none at an object @b@ has no arrow to.+--+-- The finite, stable counterpart of 'Sums': a distributive lattice is the thin case of the+-- extensivity that a free bicartesian category lacks.+type Joins :: Coverage+type data Joins++-- | The name of every 'Joins' cover: the 'Cover' constructor is @ByJoin@, holding its legs, and+-- the 'Leg' constructor is @Under@, one per member of the family. A @ByJoin@ is a cover of @a@+-- only when its legs join to @a@; 'covers' lists exactly the antichains that do. All the covers+-- of an object share the name, so 'Site'\'s Naming law matters here: a family over+-- one of them is not asked about the legs of another.+type data Join++instance (Thin k, FiniteCat k, Bicartesian k) => Site Joins k where+  data Cover Joins k a c where+    ByJoin :: [SomeLeg Joins k a Join] -> Cover Joins k a Join+  data Leg Joins k a c x where+    Under :: (Ob x) => x ~> a -> Leg Joins k a Join x+  legArrow (Under f) = f+  legs (ByJoin ls) = ls++instance (Thin k, FiniteCat k, Bicartesian k) => HasFiniteCovers Joins k where+  covers @a = [SomeCover (ByJoin ls) | ls <- subsequences strictlyBelow, isAntichain ls, isJoin ls]+    where+      strictlyBelow :: [SomeLeg Joins k a Join]+      strictlyBelow = foreachOb @k \ @x -> [SomeLeg (Under f) | not (sourceBelow (obj @a) (obj @x)), f <- elements @(Hom k) @x @a]+      isAntichain ls = and [not (legBelow l m || legBelow m l) | l : ms <- tails ls, m <- ms]+      -- @a@ is below the join of the family, which is below @a@ by construction+      isJoin ls = joinOf ls (sourceBelow (obj @a))++instance (Thin k, FiniteCat k, Bicartesian k) => StableSite Joins k where+  pullbackCover c@(ByJoin ls) f = pullbackJoin c ls f++-- | Whether the source of the first arrow is below that of the second: in a thin category,+-- whether there is an arrow between them at all.+sourceBelow :: forall {k} (x :: k) (y :: k) a b. (FiniteCat k) => x ~> a -> y ~> b -> Bool+sourceBelow f g = f // g // not (null (elements @(Hom k) @x @y))++-- | Whether one leg's source is below the other's.+legBelow :: (FiniteCat k) => SomeLeg Joins k a Join -> SomeLeg Joins k a Join -> Bool+legBelow (SomeLeg (Under f)) (SomeLeg (Under g)) = sourceBelow f g++-- | The join of the legs' sources, as the arrow it has into their common target: the copairing+-- of the legs, starting from the initial object.+joinOf+  :: forall {k} (a :: k) r+   . (HasBinaryCoproducts k, HasInitialObject k, Ob a)+  => [SomeLeg Joins k a Join]+  -> (forall j. j ~> a -> r)+  -> r+joinOf [] kont = kont (initiate @k @a)+joinOf (SomeLeg (Under f) : ls) kont = joinOf ls (copair f)+  where+    copair :: forall x j. x ~> a -> j ~> a -> r+    copair g h = g // h // withObCoprod @k @x @j (kont (g ||| h))++-- | 'Joins'\'s Stability: the meets of the source with the legs. Each is below its leg, so the+-- factorisation is found by 'factorThroughCover'; it is recomputed per leg rather than carried,+-- as a leg is only its arrow. The search fails only for a leg of some other cover of @b@, which+-- 'Site'\'s Naming law rules out.+pullbackJoin+  :: forall {k} (b :: k) a+   . (Thin k, FiniteCat k, Bicartesian k, Ob b)+  => Cover Joins k a Join+  -> [SomeLeg Joins k a Join]+  -> b ~> a+  -> PulledBack Joins k a Join b+pullbackJoin c ls f = PulledBack (ByJoin [meet g | SomeLeg (Under g) <- ls]) \(Under h) ->+  fromMaybe (error "pullbackJoin: not a leg of the pulled-back cover (Site's Naming law)") (factorThroughCover c (f . h))+  where+    meet :: forall x. (Ob x) => x ~> a -> SomeLeg Joins k b Join+    meet _ = withObProd @k @b @x (SomeLeg (Under (fst @k @b @x)))++-- | The sum coverage on a free category with binary coproducts: a sum is covered by its two+-- injections. This is the syntactic site of Spiwack's post (see the module header). In the free+-- bicartesian closed category 'Proarrow.Tools.CCC.Syntax', the booleans @TermF '+' TermF@ are+-- covered by @true@ and @false@.+--+-- Read @p a@ as the ways of producing an @a@. Being a sheaf means @p Bool ≅ p TermF × p TermF@:+-- every pair of branches has a conditional, and only one. With too many, a proof by cases+-- establishes nothing. With too few, @if-then-else@ is not definable. On a representable the+-- conditional is @'|||'@, which is why 'glue' below is @[t, e]@. The conditional on a test+-- @f :: c '~>' Bool@ is 'Proarrow.Tools.CCC.either', which needs the distributive law as well.+--+-- __Stability does not hold.__ It would need every arrow into a sum to split its source into a+-- sum (/extensivity/), and a free bicartesian category is not extensive. The restriction of+-- @id '|||' 'lft' :: (u '+' u) '+' u ~> u '+' u@ to the left summand is @id@, which factors+-- through neither injection. With a richer constraint list,+-- @'Proarrow.Monoid.mempty' :: UnitF ~> u '+' u@ has a source that is not a sum at all.+-- So the coverage generates no Grothendieck topology. Nothing here relies on stability: 'glue'\'s+-- laws are the coproduct's universal property, and @FREE@ cannot list the covers of an arbitrary+-- object, so it is not a 'HasFiniteCovers' and the topology machinery never runs at it.+type Sums :: Coverage+type data Sums++-- | The name of the cover of @x '+' y@ by its injections, whose 'Cover' constructor is+-- @BySummands@ and whose 'Leg' constructors are @AtLeft@ and @AtRight@.+type Summands :: k -> k -> Type+type data Summands x y++instance (HasBinaryCoproducts `Elem` cs) => Site Sums (FREE cs (p :: CAT k)) where+  data Cover Sums (FREE cs p) a c where+    BySummands :: (Ob x, Ob y) => Cover Sums (FREE cs p) (x + y) (Summands x y)+  data Leg Sums (FREE cs p) a c z where+    AtLeft :: (Ob x, Ob y) => Leg Sums (FREE cs p) (x + y) (Summands x y) x+    AtRight :: (Ob x, Ob y) => Leg Sums (FREE cs p) (x + y) (Summands x y) y+  legArrow AtLeft = lft+  legArrow AtRight = rgt+  legs BySummands = [SomeLeg AtLeft, SomeLeg AtRight]++-- | Sums are colimits, so the representables are sheaves for 'Sums': gluing is @'|||'@ on the+-- contravariant component.+--+-- The initial object is needed too. An element of @'Yo' x ('OP' b)@ also has a covariant+-- component @b '~>' d@. A family over the two injections has one per leg, and the glued element+-- only one. Matching forces the two to agree because the injections overlap at the initial object,+-- @'lft' . initiate = 'rgt' . initiate@. Without it every family matches vacuously, and+-- restriction fails for any @j@ with a hom-set bigger than one.+instance+  (HasBinaryCoproducts `Elem` cs, HasInitialObject `Elem` cs, CategoryOf j)+  => Sheaf Sums (Yo (x :: FREE cs (p :: CAT k)) (OP (b :: j)) :: j +-> FREE cs p)+  where+  glue BySummands m = case (m AtLeft, m AtRight) of+    (Yo f h, Yo g _) -> Yo (f ||| g) h++-- | __The coverage by the image of a functor.__ A 'Corepresentable' @w@ is a functor+-- @F = w '%%' -@ from @k@ to @j@, with @w d c ≅ F d ~> c@. Every object @c@ of @j@ is covered by all+-- the arrows into it from the image, @F d ~> c@, so a leg is an element of @w@. For an object in the+-- image the cover contains its identity and asks nothing.+--+-- It is stable, since pulling a leg back along @g@ is composing with @g@, and the covers compose,+-- since the cover of a leg's source is again an image cover, and contains that source's identity.+-- A presheaf on @k@ extends to a sheaf on @j@: its right Kan lift @q '<|' w@ ('Rift'), whose value+-- at @c@ is a family over all the arrows @F d ~> c@. The restriction of a sheaf back to @k@ is+-- @w ':.:' s@, and the two are adjoint by the+-- 'Proarrow.Profunctor.Corepresentable.Corepresentable' instance of @'Star' ('Rift' ('OP' w))@.+--+-- The comparison lemma needs @F@ to be fully faithful: 'corepMap' is a bijection on each hom-set,+-- equivalently @('~>') ≅ w '|>' w@ ('Proarrow.Testing.Laws.testRanFullyFaithful'). Then the unit+-- of the adjunction is an isomorphism exactly on the sheaves, the counit is an isomorphism, and+-- the sheaves are the presheaves on @k@. Without it the coverage is still lawful, but its sheaves+-- are the presheaves on the full subcategory of @j@ on the objects @F d@. When @F@ sends two+-- objects to one, every presheaf is a sheaf, and the unit is a diagonal.+--+-- Two examples: the left inclusion of a collage, whose other objects are covered by the arrows+-- from the left layer, and the edges of a graph, covering each vertex by the two ends of an edge.+type ByImage :: forall {j} {k}. (j +-> k) -> Coverage+type data ByImage w++-- | The name of the one 'ByImage' cover of an object, whose 'Cover' constructor is @Images@ and+-- whose 'Leg' constructor is @FromImage@, one leg per element of @w@.+type data Image++instance (Corepresentable w, Finitary w, FiniteCat k) => Site (ByImage (w :: j +-> k)) j where+  data Cover (ByImage w) j a c where+    Images :: (Ob a) => Cover (ByImage w) j a Image+  data Leg (ByImage w) j a c x where+    FromImage :: (Ob d) => w d a -> Leg (ByImage w) j a Image (w %% d)+  legArrow (FromImage x) = coindex x+  legs @a Images = foreachOb @k \ @d -> [SomeLeg (FromImage x) | x <- elements @w @d @a]++instance (Corepresentable w, Finitary w, FiniteCat k) => HasFiniteCovers (ByImage (w :: j +-> k)) j where+  covers = [SomeCover Images]++instance (Corepresentable w, Finitary w, FiniteCat k) => StableSite (ByImage (w :: j +-> k)) j where+  pullbackCover Images g = PulledBack Images \(FromImage (x :: w d b)) -> withObCorep @w @d (Factors (FromImage (rmap g x)) id)++-- | The extension of a presheaf along @w@ is a sheaf: gluing reads each leg's family at the+-- identity of its source.+instance+  (Corepresentable w, Finitary w, FiniteCat k, Profunctor q)+  => Sheaf (ByImage (w :: j +-> k)) (Rift (OP w) q :: i +-> j)+  where+  glue Images m = Rift \(x :: w d a) -> x // case m (FromImage x) of Rift f -> f (corepUniv @w @d)++-- | __The coverage induced along a functor.__ For a coverage @t@ on @j@ and a functor+-- @F = w '%%' -@ from @k@ to @j@, a cover of @d@ is a @t@-cover @c@ of @F d@, and its legs are+-- all the arrows @h :: e ~> d@ whose image @F h@ factors through a leg of @c@.+--+-- The comparison lemma: when @F@ is fully faithful and every object of @j@ is covered by arrows+-- out of the image ('Proarrow.Testing.Laws.testCoveredByImage'), the sheaves for @t@ are the+-- sheaves for @'Induced' t w@. Restriction is @w ':.:' s@ and extension is the+-- right Kan lift @q '<|' w@, glued by 'glueExtension', the adjunction of 'ByImage'. 'ByImage' is+-- the case where @t@ has only the image covers. Then every induced cover contains an identity,+-- and every presheaf on @k@ is a sheaf.+--+-- The opens of a space and a basis of it are the standard example: sheaves on the space are+-- sheaves on the basis.+type Induced :: forall {j} {k}. Coverage -> (j +-> k) -> Coverage+type data Induced t w++instance (Site t j, Corepresentable w, LocallyFinite j, FiniteCat k) => Site (Induced t (w :: j +-> k)) k where+  data Cover (Induced t w) k d c where+    Induce :: (Ob d) => Cover t j (w %% d) c -> Cover (Induced t w) k d c+  data Leg (Induced t w) k d c e where+    Induces :: (Ob e) => e ~> d -> Factors t j (w %% d) c (w %% e) -> Leg (Induced t w) k d c e+  legArrow (Induces h _) = h+  legs @d (Induce c) =+    foreachOb @k \ @e ->+      [SomeLeg (Induces h fs) | h <- elements @(Hom k) @e @d, Just fs <- [factorThroughCover c (corepMap @w h)]]++instance (HasFiniteCovers t j, Corepresentable w, LocallyFinite j, FiniteCat k) => HasFiniteCovers (Induced t (w :: j +-> k)) k where+  covers @d = withObCorep @w @d [SomeCover (Induce c) | SomeCover c <- covers @t @j @(w %% d)]++-- | Pulling back along @h'@ is pulling the cover of @F d@ back along @F h'@.+instance (StableSite t j, Corepresentable w, LocallyFinite j, FiniteCat k) => StableSite (Induced t (w :: j +-> k)) k where+  pullbackCover @d' (Induce c) h' =+    withObCorep @w @d'+      ( case pullbackCover c (corepMap @w h') of+          AlreadyFactors fs -> AlreadyFactors (Factors (Induces h' fs) id)+          PulledBack c' fs -> PulledBack (Induce c') \(Induces h (Factors l' u)) -> case fs l' of+            Factors l u' -> Factors (Induces (h' . h) (Factors l (u' . u))) id+      )++-- | The extension of a sheaf for the induced coverage is a sheaf for @t@. Its value at @x :: F e ~> a@+-- is found by pulling the cover back along @x@ and gluing in @q@ over the induced cover of @e@.+--+-- A function instead of an instance, because an instance would overlap the 'ByImage' one.+glueExtension+  :: forall t {i} {j} {k} (w :: j +-> k) (q :: i +-> k) (a :: j) c (b :: i)+   . (StableSite t j, Corepresentable w, LocallyFinite j, FiniteCat k, Sheaf (Induced t w) q, Ob a, Ob b)+  => Cover t j a c+  -> (forall x. Leg t j a c x -> Rift (OP w) q x b)+  -> Rift (OP w) q a b+glueExtension c m = Rift \(x@Objs :: w e a) ->+  withObCorep @w @e+    ( case pullbackCover c (coindex x) of+        AlreadyFactors (Factors l u) -> at l (rmap u (corepUniv @w @e))+        PulledBack c' fs -> glue @(Induced t w) (Induce c') \(Induces _ (Factors l' u)) -> case fs l' of+          Factors l u' -> at l (rmap (u' . u) corepUniv)+    )+  where+    at :: Leg t j a c y -> w e' y -> q e' b+    at l y = case m l of Rift f -> f y
+ src/Proarrow/Category/Topos.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Elementary toposes: 'HasSubobjectClassifier' provides the object 'Omega' of truth values+-- classifying monomorphisms, 'HasEpiMonoFactorization' the image factorization, and+-- 'ElementaryTopos' combines these with finite (co)limits and exponentials, yielding the internal+-- logic ('false', 'and', 'or', 'implies').+module Proarrow.Category.Topos where++import Proarrow.Category.Monoidal.Cartesian (CCC)+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..), HasCoproducts)+import Proarrow.Colimit.Coequalizer (HasCoequalizers (..))+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Colimit.Pushout (HasPushouts (..), cokernelPair)+import Proarrow.Core (CategoryOf (..), Hom, Promonad (..), obj)+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..), HasProducts, PROD, Prod (..))+import Proarrow.Limit.Equalizer (HasEqualizers (..))+import Proarrow.Limit.Pullback (HasPullbacks (..))+import Proarrow.Limit.Terminal (HasTerminalObject (..), const)+import Proarrow.Object (pattern Objs)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))++class (HasProducts k, Ob (Omega :: k)) => HasSubobjectClassifier k where+  type Omega :: k+  true :: TerminalObject ~> (Omega :: k)+  default true :: (HasProducts k, HasPushouts k) => TerminalObject ~> (Omega :: k)+  true = classifyImage (obj @TerminalObject)++  -- | Classify the graph (@id *** f :: a ~> a && b@) of a morphism @f@.+  -- This is a minimal primitive that works for any morphism.+  classifyGraph :: a ~> b -> a && b ~> (Omega :: k)++isEq :: forall {k} (a :: k). (HasSubobjectClassifier k, Ob a) => a && a ~> Omega+isEq = classifyGraph (obj @a)++-- | @classify f@ classifies the image of @f@. If @f@ is mono, then this returns its characteristic map.+classifyImage :: forall {k} (a :: k) b. (HasSubobjectClassifier k, HasPushouts k) => a ~> b -> b ~> Omega+classifyImage f = cokernelPair f \ @im g1@Objs g2 -> isEq @im . (g1 &&& g2)++classifyKernelPair :: forall {k} (a :: k) b. (HasSubobjectClassifier k) => a ~> b -> (a && a) ~> Omega+classifyKernelPair f@Objs = isEq @b . (f *** f)++class (CategoryOf k) => HasEpiMonoFactorization k where+  -- | Factor an arrow as an epi followed by a mono. Defaults to 'defaultFactorize', the image+  -- factorization via the cokernel pair, which applies whenever @k@ has pushouts and equalizers.+  factorize :: (a ~> b) -> (Hom k :.: Hom k) a b+  default factorize :: (HasPushouts k, HasEqualizers k) => (a ~> b) -> (Hom k :.: Hom k) a b+  factorize = defaultFactorize++defaultFactorize :: (HasPushouts k, HasEqualizers k) => (a ~> b) -> (Hom k :.: Hom k) a b+defaultFactorize f = pushout f f \q1 q2 -> equalize q1 q2 \incl -> factorEqualizer incl f :.: incl++defaultFactorizeDual :: (HasPullbacks k, HasCoequalizers k) => a ~> b -> (Hom k :.: Hom k) a b+defaultFactorizeDual f = pullback f f \p1 p2 -> coequalize p1 p2 \incl -> incl :.: factorCoequalizer incl f++-- | Image factorization is unchanged by making the tensor the product.+instance (HasEpiMonoFactorization k) => HasEpiMonoFactorization (PROD k) where+  factorize (Prod f) = case factorize f of e :.: m -> Prod e :.: Prod m++type HasFiniteLimits k = (HasProducts k, HasPullbacks k, HasEqualizers k)+type HasFiniteColimits k = (HasCoproducts k, HasPushouts k, HasCoequalizers k)++class+  (HasFiniteLimits k, HasFiniteColimits k, CCC k, HasSubobjectClassifier k, HasEpiMonoFactorization k) =>+  ElementaryTopos k++false :: (ElementaryTopos k) => TerminalObject ~> (Omega :: k)+false = classifyImage initiate++and :: forall k. (ElementaryTopos k) => (Omega :: k) && Omega ~> Omega+and = classifyImage (true &&& true)++or :: forall k. (ElementaryTopos k) => (Omega :: k) && Omega ~> Omega+or = classifyImage (const @Omega true &&& id ||| id &&& const @Omega true)++implies :: forall k. (ElementaryTopos k) => (Omega :: k) && Omega ~> Omega+implies = equalize and (fst @k @Omega @Omega) classifyImage++-- | Negation: the classifying map of 'false', which is a mono as every arrow out of the terminal+-- object is. The same arrow as @u ⇒ false@.+not :: forall k. (ElementaryTopos k) => (Omega :: k) ~> Omega+-- Not through 'implies', which classifies a subobject of @Omega && Omega@ where this classifies+-- one of 'Omega', and 'classifyImage' squares the cokernel pair of whatever it is given.+not = classifyImage (false @k)++-- * Lawvere–Tierney topologies++-- $topologies+-- A Lawvere–Tierney topology is an arrow @j :: 'Omega' '~>' 'Omega'@ that fixes 'true', is+-- idempotent and preserves 'and'. Its sheaves form a subtopos. Every topos has the two extremes,+-- 'id' (every object a sheaf) and @'const' 'true'@ (only the terminal one), and the internal+-- logic gives the ones below. A coverage gives another, by closing sieves:+-- 'Proarrow.Category.Enriched.Finitary.Sheaf.lawvereTierney'.+-- @Proarrow.Testing.Laws.testLawvereTierney@ checks the three laws.++-- | The double-negation topology @¬¬@, whose sheaves form the smallest dense subtopos, and a+-- Boolean one. On a presheaf topos it is the dense topology: a sieve on @a@ covers when every arrow+-- into @a@ can be extended to one in the sieve. When every cospan can be completed to a commuting+-- square (the Ore condition, which pullbacks provide), that is the atomic topology, so there+-- 'Proarrow.Category.Sheaf.Atomic' computes this by closing sieves. In a Boolean topos it is 'id'.+doubleNegation :: forall k. (ElementaryTopos k) => (Omega :: k) ~> Omega+doubleNegation = not @k . not @k++-- | The open topology of a truth value @u@: @u ⇒ -@. Its sheaves are the open subtopos of the+-- subterminal object @u@ classifies, the part of the topos lying over @u@. @'openTopology' 'true'@+-- is 'id' and @'openTopology' 'false'@ is @'const' 'true'@.+openTopology :: forall k. (ElementaryTopos k) => TerminalObject ~> (Omega :: k) -> (Omega :: k) ~> Omega+-- A lambda under the binding, so that 'implies' is built once and shared by every @u@. It is an+-- image to classify, and a family of topologies is typically used at many truth values.+openTopology = \u -> i . (const u &&& id)+  where+    i = implies @k++-- | The closed topology of a truth value @u@: @u ∨ -@, complementary to 'openTopology'. Its+-- sheaves are the part of the topos lying away from @u@. @'closedTopology' 'true'@ is+-- @'const' 'true'@ and @'closedTopology' 'false'@ is 'id'.+closedTopology :: forall k. (ElementaryTopos k) => TerminalObject ~> (Omega :: k) -> (Omega :: k) ~> Omega+-- A lambda under the binding, so that 'or' is built once and shared, as in 'openTopology'.+closedTopology = \u -> o . (const u &&& id)+  where+    o = or @k
+ src/Proarrow/Colimit.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Profunctor-weighted colimits: @'HasColimits' j k@ says @k@ has colimits of @k '+->' i@-diagrams+-- weighted by @j@, given by the 'Colimit' profunctor with 'colimit' and 'colimitUniv'. The+-- 'Proarrow.Profunctor.Instance.Terminal.TerminalProfunctor' weight gives ordinary conical+-- colimits, e.g. initial objects, binary coproducts and copowers.+--+-- As in "Proarrow.Limit", the weight synonyms and shape helpers (@Unweighted@, @O1@\/@O2@,+-- @At1@\/@At2@, @Hom@, @Lan@) are not exported, since their names clash with ones elsewhere.+module Proarrow.Colimit+  ( HasColimits (..)+  , IsCorepColimit+  , mapColimit+  , CoproductColimit+  , CopowerLimit+  , Coend (..)+  , CoendLimit+  , AnyColimit (..)+  ) where++import Data.Function (($))+import Data.Kind (Constraint, Type)++import Proarrow.Category.Instance.Coproduct (COPRODUCT (..), IsLR (..))+import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Instance.Unit (Unit (..))+import Proarrow.Category.Instance.Zero (VOID)+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..), lft, rgt)+import Proarrow.Colimit.Copower (Copowered (..))+import Proarrow.Colimit.Initial (HasInitialObject (..), initiate)+import Proarrow.Core (CAT, CategoryOf (..), Kind, Profunctor (..), Promonad (..), lmap, (//), (:~>), type (+->))+import Proarrow.Functor (Copresheaf, Functor (..), FunctorForRep (..), Presheaf)+import Proarrow.Profunctor.Corepresentable (Corep (..), Corepresentable (..), corepUniv, withObCorep)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Constant (Constant)+import Proarrow.Profunctor.Instance.Costar (Costar, pattern Costar)+import Proarrow.Profunctor.Instance.HaskValue (HaskValue (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Instance.Terminal (TerminalProfunctor (..))+import Proarrow.Profunctor.Representable (Rep (..), Representable (..))++type Unweighted = TerminalProfunctor++class (Corepresentable (Colimit j d)) => IsCorepColimit j d+instance (Corepresentable (Colimit j d)) => IsCorepColimit j d++-- | profunctor-weighted colimits+type HasColimits :: forall {i} {a}. a +-> i -> Kind -> Constraint+class (Profunctor j, forall (d :: k +-> i). (Corepresentable d) => IsCorepColimit j d) => HasColimits (j :: a +-> i) k where+  type Colimit (j :: a +-> i) (d :: k +-> i) :: k +-> a+  colimit :: (Corepresentable (d :: k +-> i)) => j :.: Colimit j d :~> d+  colimitUniv :: (Corepresentable (d :: k +-> i), Profunctor p) => (j :.: p :~> d) -> p :~> Colimit j d++mapColimit+  :: forall {i} j k p q+   . (HasColimits j k, Corepresentable p, Corepresentable q) => (p :: k +-> i) ~> q -> Colimit j p ~> Colimit j q+mapColimit (Prof n) = Prof (colimitUniv @j (n . colimit @j))++instance (HasInitialObject k) => HasColimits (Unweighted :: Presheaf VOID) k where+  type Colimit Unweighted d = Corep (Constant InitialObject)+  colimit (t :.: _) = case t of {}+  colimitUniv _ p = p // Corep initiate++type O1 = L '()+type O2 = R '()+type At1 d = d %% O1+type At2 d = d %% O2++data family CoproductColimit :: k +-> COPRODUCT () () -> Presheaf k+instance (HasBinaryCoproducts k, Corepresentable d) => FunctorForRep (CoproductColimit d :: Presheaf k) where+  type CoproductColimit d @ '() = At1 d || At2 d+  fmap Unit = withObCorep @d @O1 $ withObCorep @d @O2 $ withObCoprod @_ @(At1 d) @(At2 d) id++instance (HasBinaryCoproducts k) => HasColimits (Unweighted :: Presheaf (COPRODUCT () ())) k where+  type Colimit Unweighted d = Corep (CoproductColimit d)+  colimit @d (TerminalProfunctor @o :.: Corep f) =+    withObCorep @d @O1 $+      withObCorep @d @O2 $+        lrCase @o+          (cotabulate (f . lft @_ @(At1 d) @(At2 d)))+          (cotabulate (f . rgt @_ @(At1 d) @(At2 d)))+  colimitUniv n p =+    p //+      let l = n (TerminalProfunctor @O1 :.: p)+          r = n (TerminalProfunctor @O2 :.: p)+      in Corep $ coindex l ||| coindex r++data family CopowerLimit :: Type -> Copresheaf k -> Presheaf k+instance (Corepresentable d, Copowered Type k) => FunctorForRep (CopowerLimit n d :: Presheaf k) where+  type CopowerLimit n d @ '() = n *. (d %% '())+  fmap Unit = withObCorep @d @'() $ withObCopower @Type @k @(d %% '()) @n id+instance (Copowered Type k) => HasColimits (HaskValue n :: Presheaf ()) k where+  type Colimit (HaskValue n) d = Corep (CopowerLimit n d)+  colimit @d (HaskValue n :.: Corep f) = withObCorep @d @'() $ cotabulate $ uncopower f n+  colimitUniv @d m p = withObCorep @d @'() $ Corep (copower \n -> coindex (m (HaskValue n :.: p))) \\ p++data Coend d where+  Coend :: a ~> b -> d %% '(OP b, a) -> Coend d++data family CoendLimit :: Type +-> (OPPOSITE k, k) -> Presheaf Type+instance (Corepresentable d) => FunctorForRep (CoendLimit (d :: Type +-> (OPPOSITE k, k))) where+  type CoendLimit d @ '() = Coend d+  fmap Unit = id++type Hom :: Presheaf (OPPOSITE k, k)+data Hom a b where+  Hom :: a ~> b -> Hom '(OP b, a) '()+instance (CategoryOf k) => Profunctor (Hom :: Presheaf (OPPOSITE k, k)) where+  dimap (Op l :**: r) Unit (Hom f) = Hom (l . f . r) \\ l \\ r+  r \\ Hom f = r \\ f++instance (CategoryOf k) => HasColimits (Hom :: Presheaf (OPPOSITE k, k)) Type where+  type Colimit Hom d = Corep (CoendLimit d)+  colimit (Hom f :.: Corep g) = f // cotabulate (\d -> g (Coend f d))+  colimitUniv n p = p // Corep \(Coend f d) -> coindex (n (Hom f :.: p)) d++instance (CategoryOf j) => HasColimits (Id :: CAT j) k where+  type Colimit Id d = d+  colimit (Id f :.: d) = lmap f d+  colimitUniv n p = n (Id id :.: p) \\ p++instance (Corepresentable j2, HasColimits j1 k, HasColimits j2 k) => HasColimits (j1 :.: j2) k where+  type Colimit (j1 :.: j2) d = Colimit j2 (Colimit j1 d)+  colimit @d ((j1 :.: j2) :.: c) = colimit @j1 @k @d (j1 :.: colimit @j2 @k @(Colimit j1 d) (j2 :.: c))+  colimitUniv @d n = colimitUniv @j2 @k @(Colimit j1 d) (colimitUniv @j1 @k @d (\(j1 :.: (j2 :.: p')) -> n ((j1 :.: j2) :.: p')))++instance (FunctorForRep f) => HasColimits (Rep f) k where+  type Colimit (Rep f) d = Corep f :.: d+  colimit (Rep f :.: (Corep g :.: d)) = lmap (g . f) d+  colimitUniv n p = p // corepUniv :.: n (repUniv :.: p)++newtype AnyColimit j a b = AnyColimit (j a b)+  deriving newtype (Profunctor)+type Lan :: (a +-> i) -> (Type +-> i) -> a -> Type+data Lan j d a where+  Lan :: j b a -> d %% b -> Lan j d a+instance (Profunctor j, Corepresentable d) => Functor (Lan j d) where+  map f (Lan j d) = Lan (rmap f j) d+instance (Profunctor j) => HasColimits (AnyColimit j) Type where+  type Colimit (AnyColimit j) d = Costar (Lan j d)+  colimit (AnyColimit j :.: Costar f) = cotabulate (\db -> f (Lan j db)) \\ j+  colimitUniv n p = p // Costar (\(Lan j db) -> coindex (n (AnyColimit j :.: p)) db)
+ src/Proarrow/Colimit/BinaryCoproduct.hs view
@@ -0,0 +1,408 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE IncoherentInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Binary coproducts: 'HasBinaryCoproducts' provides @a '||' b@ with injections 'lft'\/'rgt' and+-- copairing @('|||')@, and 'HasCoproducts' adds the initial object. Also biproducts ('HasBiproducts')+-- and the 'COPROD' kind wrapper, which makes @('||')@ the tensor of a monoidal structure on the same+-- objects.+module Proarrow.Colimit.BinaryCoproduct where++import Data.Kind (Type)+import Prelude (Show, ($), type (~))+import Prelude qualified as P++import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..))+import Proarrow.Category.Instance.Free+  ( Elem (..)+  , FREE (..)+  , HasStructure (..)+  , IsFreeOb (..)+  , Lower+  , WithShow+  , withLowerOb+  )+import Proarrow.Category.Instance.Free qualified as F+import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))+import Proarrow.Category.Instance.Product (Diag, Fst, Snd, (:**:) (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Instance.Unit qualified as U+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Core (CAT, CategoryOf (..), Hom, Profunctor (..), Promonad (..), UN, WrappedOb, type (+->))+import Proarrow.Functor (Functor (..), FunctorForRep (..))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..), PROD (..), Prod (..), diag)+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Object (Obj, obj, tgt)+import Proarrow.Profunctor.Corepresentable (Corepresentable (..), withObCorep)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Coproduct (coproduct, (:+:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Instance.Product ((:*:) (..))+import Proarrow.Profunctor.Instance.Terminal (TerminalProfunctor (..))+import Proarrow.Profunctor.Representable (CorepStar (..), Rep (..), Representable (..))+import Proarrow.Tools.Laws (Law (..), Laws (..), (===))++infixl 4 ||+infixl 4 |||+infixl 4 +++++-- | Binary coproducts, dual to 'Proarrow.Limit.BinaryProduct.HasBinaryProducts': an object+-- @a '||' b@ with injections 'lft' and 'rgt', universal among all pairs of arrows into a common+-- target. Each such pair factors through it uniquely via '(|||)'.+--+-- __Laws:__+--+-- * @(f '|||' g) . 'lft' = f@+-- * @(f '|||' g) . 'rgt' = g@+-- * Uniqueness: @(h . f) '|||' (h . g) = h . (f '|||' g)@+--+-- Checked by 'Proarrow.Testing.Laws.testBinaryCoproducts'.+class (CategoryOf k) => HasBinaryCoproducts k where+  -- | The coproduct object.+  type (a :: k) || (b :: k) :: k++  -- | Recovers @'Ob' (a '||' b)@ from the objecthood of the summands.+  withObCoprod :: (Ob (a :: k), Ob b) => ((Ob (a || b)) => r) -> r++  -- | The left injection.+  lft :: (Ob (a :: k), Ob b) => a ~> (a || b)++  -- | The right injection.+  rgt :: (Ob (a :: k), Ob b) => b ~> (a || b)++  -- | The mediating arrow: case-splits two arrows into a common target.+  (|||) :: (x :: k) ~> a -> y ~> a -> (x || y) ~> a++  -- | The coproduct of two arrows, acting on each summand independently.+  (+++) :: forall a b x y. (a :: k) ~> x -> b ~> y -> a || b ~> x || y+  l +++ r = lft @k @x @y . l ||| rgt @k @x @y . r \\ l \\ r++lft' :: forall {k} (a :: k) a' b. (HasBinaryCoproducts k) => a ~> a' -> Obj b -> a ~> (a' || b)+lft' a b = lft @k @a' @b . a \\ a \\ b++rgt' :: forall {k} (a :: k) b b'. (HasBinaryCoproducts k) => Obj a -> b ~> b' -> b ~> (a || b')+rgt' a b = rgt @k @a @b' . b \\ a \\ b++left :: forall {k} (c :: k) (a :: k) (b :: k). (HasBinaryCoproducts k, Ob c) => a ~> b -> (a || c) ~> (b || c)+left f = f +++ obj @c++right :: forall {k} (c :: k) (a :: k) (b :: k). (HasBinaryCoproducts k, Ob c) => a ~> b -> (c || a) ~> (c || b)+right f = obj @c +++ f++codiag :: forall {k} (a :: k). (HasBinaryCoproducts k, Ob a) => (a || a) ~> a+codiag = id ||| id++swapCoprod' :: forall {k} (a :: k) a' b b'. (HasBinaryCoproducts k) => a ~> a' -> b ~> b' -> (a || b) ~> (b' || a')+swapCoprod' a b = rgt' (tgt b) a ||| lft' b (tgt a)++swapCoprod :: forall {k} (a :: k) b. (HasBinaryCoproducts k, Ob a, Ob b) => a || b ~> b || a+swapCoprod = swapCoprod' (obj @a) (obj @b)++-- | The coproduct as a functor from the product category, @'(a, b) ↦ a || b@. The coproduct+-- analogue of 'Proarrow.Category.Monoidal.MultRep'.+data PlusRep :: (k, k) +-> k++instance (HasBinaryCoproducts k) => FunctorForRep (PlusRep :: (k, k) +-> k) where+  type PlusRep @ '(a, b) = a || b+  fmap (f :**: g) = f +++ g++data family Coproduct :: k -> k +-> k+instance (HasBinaryCoproducts k, Ob a) => FunctorForRep (Coproduct a :: k +-> k) where+  type Coproduct a @ b = a || b+  fmap f = right @a f++type HasCoproducts k = (HasInitialObject k, HasBinaryCoproducts k)++class ((a ** b) ~ (a || b)) => TensorIsCoproduct a b+instance ((a ** b) ~ (a || b)) => TensorIsCoproduct a b+class+  (HasCoproducts k, Monoidal k, (Unit :: k) ~ InitialObject, forall (a :: k) (b :: k). TensorIsCoproduct a b) =>+  Cocartesian k+instance+  (HasCoproducts k, Monoidal k, (Unit :: k) ~ InitialObject, forall (a :: k) (b :: k). TensorIsCoproduct a b)+  => Cocartesian k++-- | Every functor between cocartesian categories is lax monoidal, @f a || f b ~> f (a || b)@ by the+-- injections and @InitialObject ~> f InitialObject@ by initiality. On the 'CorepStar' of its+-- corepresentable profunctor this is 'Proarrow.Category.Monoidal.LaxMonoidal'.+instance (Corepresentable p, Cocartesian j, Cocartesian k) => MonoidalProfunctor (CorepStar (p :: j +-> k)) where+  one = withObCorep @p @Unit (CorepStar initiate)+  CorepStar @a f ** CorepStar @b g = withOb2 @k @a @b (CorepStar (parCorepCocartesian @p @a @b f g))++parCorepCocartesian+  :: forall {j} {k} p (a :: k) b a' b'+   . ( Corepresentable (p :: j +-> k)+     , Cocartesian j+     , Cocartesian k+     , TensorIsCoproduct a b+     , TensorIsCoproduct a' b'+     , Ob a+     , Ob b+     )+  => (a' ~> p %% a) -> (b' ~> p %% b) -> (a' ** b') ~> p %% (a ** b)+parCorepCocartesian f g = corepMap @p (lft @k @a @b) . f ||| corepMap @p (rgt @k @a @b) . g++instance HasBinaryCoproducts Type where+  type a || b = P.Either a b+  withObCoprod r = r+  lft = P.Left+  rgt = P.Right+  (|||) = P.either++instance HasBinaryCoproducts () where+  -- a wildcard, not @'()@, so that @a || b@ reduces for an abstract @a@, as on pairs+  type _ || _ = '()+  withObCoprod r = r+  lft = U.Unit+  rgt = U.Unit+  U.Unit ||| U.Unit = U.Unit++instance HasBinaryCoproducts BOOL where+  type FLS || b = b+  type TRU || b = TRU+  type a || FLS = a+  type a || TRU = TRU+  withObCoprod @a r = case obj @a of+    Tru -> r+    Fls -> r+  lft @a @b = case obj @a of+    Fls -> initiate @_ @b+    Tru -> Tru+  rgt @a @b = case obj @b of+    Fls -> initiate @_ @a+    Tru -> Tru+  Fls ||| Fls = Fls+  F2T ||| b = b+  Tru ||| _ = Tru++-- | Coproducts in a product category are componentwise. Through the projections, as products are+-- there, so that @a || b@ reduces for an abstract pair.+instance (HasBinaryCoproducts j, HasBinaryCoproducts k) => HasBinaryCoproducts (j, k) where+  type a || b = '(Fst @ a || Fst @ b, Snd @ a || Snd @ b)+  withObCoprod @'(a1, a2) @'(b1, b2) r = withObCoprod @j @a1 @b1 (withObCoprod @k @a2 @b2 r)+  lft @'(a1, a2) @'(b1, b2) = lft @_ @a1 @b1 :**: lft @_ @a2 @b2+  rgt @'(a1, a2) @'(b1, b2) = rgt @_ @a1 @b1 :**: rgt @_ @a2 @b2+  (f1 :**: f2) ||| (g1 :**: g2) = (f1 ||| g1) :**: (f2 ||| g2)++instance (CategoryOf j, CategoryOf k) => HasBinaryCoproducts (j +-> k) where+  type p || q = p :+: q+  withObCoprod r = r+  lft = Prof InjL+  rgt = Prof InjR+  Prof l ||| Prof r = Prof (coproduct l r)++instance (HasBinaryCoproducts j, Corepresentable (p :: j +-> k), Corepresentable q) => Corepresentable (p :*: q) where+  type (p :*: q) %% a = (p %% a) || (q %% a)+  coindex (p :*: q) = coindex p ||| coindex q+  cotabulate @a f =+    withObCorep @p @a+      (withObCorep @q @a (cotabulate (f . lft @_ @(p %% a) @(q %% a)) :*: cotabulate (f . rgt @_ @(p %% a) @(q %% a))))+  corepMap f = corepMap @p f +++ corepMap @q f++instance (HasBinaryCoproducts k) => HasBinaryCoproducts (PROD k) where+  type PR a || PR b = PR (a || b)+  withObCoprod @(PR a) @(PR b) r = withObCoprod @k @a @b r+  lft @(PR a) @(PR b) = Prod (lft @_ @a @b)+  rgt @(PR a) @(PR b) = Prod (rgt @_ @a @b)+  Prod l ||| Prod r = Prod (l ||| r)++type data COPROD k = COPR k++-- | Lifts a profunctor to the 'COPROD'-wrapped kinds, where the monoidal structure is the+-- coproduct.+type Coprod :: j +-> k -> COPROD j +-> COPROD k+data Coprod p a b where+  Coprod :: {unCoprod :: p a b} -> Coprod p (COPR a) (COPR b)++instance (CategoryOf k) => Functor (COPR :: k -> COPROD k) where+  map = Coprod++instance (Profunctor p) => Profunctor (Coprod p) where+  dimap (Coprod l) (Coprod r) (Coprod p) = Coprod (dimap l r p)+  r \\ Coprod f = r \\ f+instance (Promonad p) => Promonad (Coprod p) where+  id = Coprod id+  Coprod f . Coprod g = Coprod (f . g)+instance (Representable p) => Representable (Coprod p) where+  type Coprod p % (COPR a) = COPR (p % a)+  index (Coprod p) = Coprod (index p)+  tabulate (Coprod f) = Coprod (tabulate f)+  repMap (Coprod f) = Coprod (repMap @p f)++instance+  (Profunctor f, Profunctor g, MonoidalProfunctor (Coprod f), MonoidalProfunctor (Coprod g))+  => MonoidalProfunctor (Coprod (f :.: g))+  where+  one = Coprod (nil :.: nil)+  Coprod (f :.: g) ** Coprod (h :.: i) = Coprod ((f ++ h) :.: (g ++ i))++-- | The same category as the category of @k@, but with coproducts as the tensor.+instance (CategoryOf k) => CategoryOf (COPROD k) where+  type (~>) = Coprod (~>)+  type Ob a = WrappedOb COPR a++instance (HasCoproducts k, cat ~ Hom k) => MonoidalProfunctor (Coprod cat :: COPROD k +-> COPROD k) where+  one = Coprod id+  Coprod f ** Coprod g = Coprod (f +++ g)++instance (HasCoproducts k) => MonoidalProfunctor (Coprod (Id :: k +-> k)) where+  one = Coprod (Id id)+  Coprod (Id f) ** Coprod (Id g) = Coprod (Id (f +++ g))++instance (HasCoproducts j, HasCoproducts k) => MonoidalProfunctor (Coprod (TerminalProfunctor :: j +-> k)) where+  one = Coprod TerminalProfunctor+  Coprod (TerminalProfunctor @a1 @b1) ** Coprod (TerminalProfunctor @a2 @b2) =+    withObCoprod @k @a1 @a2 $ withObCoprod @j @b1 @b2 $ Coprod TerminalProfunctor++nil :: (MonoidalProfunctor (Coprod p)) => p InitialObject InitialObject+nil = unCoprod one++(++) :: (MonoidalProfunctor (Coprod p)) => p a b -> p c d -> p (a || c) (b || d)+p ++ q = unCoprod (Coprod p ** Coprod q)++instance (HasInitialObject k) => HasInitialObject (COPROD k) where+  type InitialObject = COPR InitialObject+  initiate = Coprod initiate++instance (HasBinaryCoproducts k) => HasBinaryCoproducts (COPROD k) where+  type a || b = COPR (UN COPR a || UN COPR b)+  withObCoprod @(COPR a) @(COPR b) r = withObCoprod @k @a @b r+  lft @(COPR a) @(COPR b) = Coprod (lft @k @a @b)+  rgt @(COPR a) @(COPR b) = Coprod (rgt @k @a @b)+  Coprod f ||| Coprod g = Coprod (f ||| g)++instance (HasTerminalObject k) => HasTerminalObject (COPROD k) where+  type TerminalObject = COPR TerminalObject+  terminate = Coprod terminate++instance (HasBinaryProducts k) => HasBinaryProducts (COPROD k) where+  type COPR a && COPR b = COPR (a && b)+  withObProd @(COPR a) @(COPR b) r = withObProd @k @a @b r+  fst @(COPR a) @(COPR b) = Coprod (fst @k @a @b)+  snd @(COPR a) @(COPR b) = Coprod (snd @k @a @b)+  Coprod f &&& Coprod g = Coprod (f &&& g)++-- | Coproducts as monoidal tensor.+instance (HasCoproducts k) => Monoidal (COPROD k) where+  type Unit = COPR InitialObject+  type a ** b = COPR (UN COPR a || UN COPR b)+  withOb2 @(COPR a) @(COPR b) r = withObCoprod @k @a @b r+  leftUnitor = Coprod leftUnitorCoprod+  leftUnitorInv = Coprod leftUnitorCoprodInv+  rightUnitor = Coprod rightUnitorCoprod+  rightUnitorInv = Coprod rightUnitorCoprodInv+  associator @(COPR a) @(COPR b) @(COPR c) = Coprod (associatorCoprod @a @b @c)+  associatorInv @(COPR a) @(COPR b) @(COPR c) = Coprod (associatorCoprodInv @a @b @c)++leftUnitorCoprod :: forall {k} (a :: k). (HasCoproducts k, Ob a) => (InitialObject || a) ~> a+leftUnitorCoprod = initiate ||| id++leftUnitorCoprodInv :: forall {k} (a :: k). (HasCoproducts k, Ob a) => a ~> (InitialObject || a)+leftUnitorCoprodInv = rgt @k @InitialObject @a++rightUnitorCoprod :: forall {k} (a :: k). (HasCoproducts k, Ob a) => (a || InitialObject) ~> a+rightUnitorCoprod = id ||| initiate++rightUnitorCoprodInv :: forall {k} (a :: k). (HasCoproducts k, Ob a) => a ~> (a || InitialObject)+rightUnitorCoprodInv = lft @k @a @InitialObject++associatorCoprod :: forall {k} (a :: k) b c. (HasCoproducts k, Ob a, Ob b, Ob c) => (a || b) || c ~> a || (b || c)+associatorCoprod = (obj @a +++ lft @k @b @c) ||| withObCoprod @k @b @c (rgt @k @a @(b || c)) . rgt @k @b @c++associatorCoprodInv :: forall {k} (a :: k) b c. (HasCoproducts k, Ob a, Ob b, Ob c) => a || (b || c) ~> (a || b) || c+associatorCoprodInv = withObCoprod @k @a @b (lft @k @(a || b) @c) . lft @k @a @b ||| (rgt @k @a @b +++ obj @c)++instance (HasCoproducts k) => SymMonoidal (COPROD k) where+  swap @(COPR a) @(COPR b) = Coprod (swapCoprod @a @b)++-- | Inverse to 'Coprod': strips the 'COPR' wrappers from a profunctor between 'COPROD'-wrapped+-- kinds.+type Uncoprod :: (COPROD j +-> COPROD k) -> j +-> k+data Uncoprod p a b where+  Uncoprod :: p (COPR a) (COPR b) -> Uncoprod p a b++instance (Profunctor p, CategoryOf j, CategoryOf k) => Profunctor (Uncoprod p :: j +-> k) where+  dimap l r (Uncoprod p) = Uncoprod (dimap (Coprod l) (Coprod r) p \\ p)+  r \\ Uncoprod f = r \\ f++data family (+) (a :: k) (b :: k) :: k+instance (IsFreeOb (a :: FREE cs p), IsFreeOb b, HasBinaryCoproducts `Elem` cs) => IsFreeOb (a + b) where+  type Lower f (a + b) = Lower f a || Lower f b+  lowerOb @k' @f r =+    fromAll @HasBinaryCoproducts @cs @k'+      (withLowerOb @f @a (withLowerOb @f @b (withObCoprod @k' @(Lower f a) @(Lower f b) r)))+instance (HasBinaryCoproducts `Elem` cs) => HasStructure cs (p :: CAT k) HasBinaryCoproducts where+  data Struct HasBinaryCoproducts i o where+    Lft :: (Ob a, Ob b) => Struct HasBinaryCoproducts a (a + b)+    Rgt :: (Ob a, Ob b) => Struct HasBinaryCoproducts b (a + b)+    Sum :: a ~> o -> b ~> o -> Struct HasBinaryCoproducts (a + b) o+  foldStructure @f _ (Lft @a @b) = withLowerOb @f @a (withLowerOb @f @b (lft @_ @(Lower f a) @(Lower f b)))+  foldStructure @f _ (Rgt @a @b) = withLowerOb @f @a (withLowerOb @f @b (rgt @_ @(Lower f a) @(Lower f b)))+  foldStructure go (Sum g h) = go g ||| go h+instance (WithShow a) => Show (Struct HasBinaryCoproducts a b) where+  showsPrec _ Lft = P.showString "lft"+  showsPrec _ Rgt = P.showString "rgt"+  showsPrec d (Sum f g) =+    P.showParen (d P.> 4) P.$+      P.showsPrec 5 f . P.showString " ||| " . P.showsPrec 5 g+instance (HasBinaryCoproducts `Elem` cs) => HasBinaryCoproducts (FREE cs (p :: CAT k)) where+  type a || b = a + b+  withObCoprod r = r+  lft = F.St Lft F.Nil+  rgt = F.St Rgt F.Nil+  f ||| g = F.St (Sum f g) F.Nil \\ f \\ g++class ((a && b) ~ (a || b)) => CheckBiproduct a b+instance ((a && b) ~ (a || b)) => CheckBiproduct a b++class+  (HasBinaryCoproducts k, HasBinaryProducts k, forall (a :: k) (b :: k). (Ob a, Ob b) => CheckBiproduct a b) =>+  HasBiproducts k+  where+  sum :: (a :: k) ~> b -> a ~> b -> a ~> b+  sum f g = codiag . (f +++ g) . diag \\ f \\ g++instance (HasBinaryCoproducts k) => HasBinaryProducts (OPPOSITE k) where+  type a && b = OP (UN OP a || UN OP b)+  withObProd @(OP a) @(OP b) r = withObCoprod @k @a @b r+  fst @(OP a) @(OP b) = Op (lft @_ @a @b)+  snd @(OP a) @(OP b) = Op (rgt @_ @a @b)+  Op a &&& Op b = Op (a ||| b)++instance (HasBinaryProducts k) => HasBinaryCoproducts (OPPOSITE k) where+  type a || b = OP (UN OP a && UN OP b)+  withObCoprod @(OP a) @(OP b) r = withObProd @k @a @b r+  lft @(OP a) @(OP b) = Op (fst @_ @a @b)+  rgt @(OP a) @(OP b) = Op (snd @_ @a @b)+  Op a ||| Op b = Op (a &&& b)++-- | The left adjoint to the diagonal functor.+instance (HasBinaryCoproducts k) => Corepresentable (Rep Diag :: k +-> (k, k)) where+  type Rep Diag %% '(a, b) = a || b+  coindex (Rep (f :**: g)) = f ||| g+  corepUniv @'(a, b) = withObCoprod @k @a @b (Rep (lft @k @a @b :**: rgt @k @a @b))++-- | The universal property of the binary coproduct: the injections recover the components of+-- @f '|||' g@, and every arrow out of the coproduct is the copairing of its components.+instance Laws '[HasBinaryCoproducts] where+  laws =+    [ Law "lft" \ @a @b @c mor -> do+        f <- mor @a @c "f"+        g <- mor @b @c "g"+        f === (f ||| g) . lft @_ @a @b+    , Law "rgt" \ @a @b @c mor -> do+        f <- mor @a @c "f"+        g <- mor @b @c "g"+        g === (f ||| g) . rgt @_ @a @b+    , Law "copairing naturality" \ @a @b @c @d mor -> do+        f <- mor @a @c "f"+        g <- mor @b @c "g"+        h <- mor @c @d "h"+        (h . f) ||| (h . g) === h . (f ||| g)+    , Law "copairing the injections" \ @a @b _ ->+        withObCoprod @_ @a @b (lft @_ @a @b ||| rgt @_ @a @b === id)+    , Law "copairing uniqueness" \ @a @b @c mor -> withObCoprod @_ @a @b do+        p <- mor @(a || b) @c "p"+        p === (p . lft @_ @a @b) ||| (p . rgt @_ @a @b)+    ]
+ src/Proarrow/Colimit/Coequalizer.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Coequalizers: 'HasCoequalizers' with 'coequalize' in continuation-passing style (the apex type+-- depends on the given arrows, so it is hidden behind an existential) and 'factorCoequalizer' for the+-- universal property.+module Proarrow.Colimit.Coequalizer where++import Proarrow.Category.Enriched.Thin (Thin)+import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..))+import Proarrow.Category.Instance.Opposite (OPPOSITE, Op (..))+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Unit (Unit (..))+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..), HasCoproducts)+import Proarrow.Colimit.Initial (HasZeroObject (..))+import Proarrow.Core (CategoryOf (..), Promonad (..))+import Proarrow.Limit.BinaryProduct (PROD, Prod (..))+import Proarrow.Limit.Equalizer (HasEqualizers (..))+import Proarrow.Object (pattern Objs)+import Prelude qualified as P++-- | Coequalizers are an inherently dependently typed concept:+-- The type of the apex object depends on the values of the given arrows.+-- But at runtime we can still calculate the arrow and the type, which we hide behind an existential.+class (CategoryOf k) => HasCoequalizers k where+  coequalize :: forall (a :: k) b r. a ~> b -> a ~> b -> (forall c. b ~> c -> r) -> r++  -- | @factorCoequalizer q h@ requires @q@ to be epi and @h@ to be constant on @q@'s fibers; @q@ is+  -- typically (though not necessarily) the coequalizer arrow produced by 'coequalize'.+  factorCoequalizer :: forall (c :: k) x c'. x ~> c -> x ~> c' -> c ~> c'++instance HasCoequalizers () where+  coequalize Unit Unit k = k Unit+  factorCoequalizer Unit Unit = Unit++-- | Dual to the 'Proarrow.Limit.Equalizer.HasEqualizers' instance for 'BOOL'.+instance HasCoequalizers BOOL where+  coequalize = thinCoequalize+  factorCoequalizer Fls Fls = Fls+  factorCoequalizer Fls F2T = F2T+  factorCoequalizer F2T F2T = Tru+  factorCoequalizer Tru Tru = Tru+  factorCoequalizer F2T Fls = P.error "factorCoequalizer: h must be constant on q's fibers"++instance (HasCoequalizers k1, HasCoequalizers k2) => HasCoequalizers (k1, k2) where+  coequalize (l1 :**: l2) (r1 :**: r2) k = coequalize l1 r1 \f1 -> coequalize l2 r2 \f2 -> k (f1 :**: f2)+  factorCoequalizer (q1 :**: q2) (h1 :**: h2) = factorCoequalizer q1 h1 :**: factorCoequalizer q2 h2++-- | Coequalizers are unchanged by making the tensor the product.+instance (HasCoequalizers k) => HasCoequalizers (PROD k) where+  coequalize (Prod f) (Prod g) k = coequalize f g \c -> k (Prod c)+  factorCoequalizer (Prod proj) (Prod h) = Prod (factorCoequalizer proj h)++-- | In a thin category, arrows don't carry information, so coequalizers are just coproducts.+thinCoequalize :: forall {k} (a :: k) b r. (Thin k) => a ~> b -> a ~> b -> (forall c. b ~> c -> r) -> r+thinCoequalize Objs _ k = k id++-- | Standalone helper (not a class method) usable as the @default@ implementation of+-- 'Proarrow.Colimit.Pushout.pushout' wherever @(HasCoequalizers k, HasCoproducts k)@ happen to hold.+-- Not every 'Proarrow.Colimit.Pushout.HasPushouts' instance needs it or is required to have it.+pushoutDefault+  :: forall {k} (o :: k) a b r+   . (HasCoequalizers k, HasCoproducts k) => o ~> a -> o ~> b -> (forall p. a ~> p -> b ~> p -> r) -> r+pushoutDefault f@Objs g@Objs k = coequalize (lft @k @a @b . f) (rgt @k @a @b . g) \c@Objs ->+  k (c . lft @k @a @b) (c . rgt @k @a @b)++-- | Given a pushout's own legs @p1, p2@ and a compatible cocone @k1, k2@ out of some @q@ (with+-- @k1 . f == k2 . g@ for whichever cospan @p1, p2@ are a pushout of), produces the unique @p ~> q@+-- through which the cocone factors. Standalone helper (not a class method), usable as the+-- @default@ implementation of 'Proarrow.Colimit.Pushout.factorPushout', dual to+-- 'Proarrow.Limit.Equalizer.factorPullbackDefault'.+factorPushoutDefault+  :: forall {k} (a :: k) b p q+   . (HasCoequalizers k, HasCoproducts k)+  => a ~> p -> b ~> p -> a ~> q -> b ~> q -> p ~> q+factorPushoutDefault p1@Objs p2@Objs k1 k2 = factorCoequalizer (p1 ||| p2) (k1 ||| k2)++cokernel :: (HasCoequalizers k, HasZeroObject k) => (a :: k) ~> b -> (forall c. b ~> c -> r) -> r+cokernel f@Objs = coequalize zero f++instance (HasEqualizers k) => HasCoequalizers (OPPOSITE k) where+  coequalize (Op l) (Op r) k = equalize l r (k . Op)+  factorCoequalizer (Op x1) (Op x2) = Op (factorEqualizer x1 x2)++instance (HasCoequalizers k) => HasEqualizers (OPPOSITE k) where+  equalize (Op l) (Op r) k = coequalize l r (k . Op)+  factorEqualizer (Op x1) (Op x2) = Op (factorCoequalizer x1 x2)
+ src/Proarrow/Colimit/Copower.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Copowers (tensors) of a category enriched in @v@: 'Copowered' provides @n '*.' a@, characterized by+-- the isomorphism between @(n '*.' a) '~>' b@ and @n '~>' 'HomObj' v a b@ ('copower'\/'uncopower').+module Proarrow.Colimit.Copower where++import Data.Kind (Type)+import Prelude (type (~))++import Proarrow.Category.Enriched (Enriched, GenArrow (..), HomObj, comp, underlying)+import Proarrow.Category.Enriched.Finitary (Elt (..))+import Proarrow.Category.Instance.FinHask (FINHASK, arr)+import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Instance.Unit (Unit (..))+import Proarrow.Category.Monoidal (Monoidal (..), SymMonoidal, rightUnitorInvWith, type (**))+import Proarrow.Category.Monoidal.Closed (Closed (..), uncurry)+import Proarrow.Core (CategoryOf (..), Ob, Profunctor (dimap, (\\)), Promonad (..), obj, (//), type (+->))+import Proarrow.Limit.Power (Powered (..))+import Proarrow.Profunctor.Corepresentable (Corepresentable (..))++-- | Categories copowered over @v@.+class (Enriched v k) => Copowered v k where+  type (n :: v) *. (a :: k) :: k+  withObCopower :: (Ob (a :: k), Ob (n :: v)) => ((Ob (n *. a)) => r) -> r+  copower :: (Ob (a :: k), Ob b) => n ~> HomObj v a b -> (n *. a) ~> b+  uncopower :: (Ob (a :: k), Ob n) => (n *. a) ~> b -> n ~> HomObj v a b++mapCobase :: forall {k} {v} (a :: k) b (n :: v). (Copowered v k, Ob n) => a ~> b -> n *. a ~> n *. b+mapCobase f =+  f //+    withObCopower @v @k @b @n+      ( copower @v @k @a @(n *. b) @n+          (let g = uncopower @v @k @b @n id in g // comp @v @a @b @(n *. b) . rightUnitorInvWith (underlying @v f) . g)+      )++mapCopower :: forall {k} {v} (a :: k) (n :: v) m. (Copowered v k, Ob a) => (n ~> m) -> n *. a ~> m *. a+mapCopower f = withObCopower @v @k @a @m (copower @v @k @a @(m *. a) @n (uncopower @v @k @a id . f)) \\ f++selfCopowered :: forall {v} (a :: v) b n. (Closed v, SymMonoidal v, Ob a, Ob b) => n ~> (a ~~> b) -> n ** a ~> b+selfCopowered = uncurry @a++selfUncopowered :: forall {v} (a :: v) b n. (Closed v, SymMonoidal v, Ob a, Ob n) => n ** a ~> b -> n ~> (a ~~> b)+selfUncopowered = curry @_ @n @a @b++instance Copowered Type Type where+  type n *. a = (n, a)+  withObCopower r = r+  copower f (n, a) = f n a+  uncopower f n a = f (n, a)++instance Copowered Type () where+  type n *. a = '()+  withObCopower r = r+  copower _ = Unit+  uncopower Unit _ = Unit++instance (Copowered Type j, Copowered Type k) => Copowered Type (j, k) where+  type n *. '(a, b) = '(n *. a, n *. b)+  withObCopower @'(a, b) @n r = withObCopower @_ @j @a @n (withObCopower @_ @k @b @n r)+  copower f = copower (\n -> fstK (f n)) :**: copower (\n -> sndK (f n))+  uncopower (f :**: g) n = uncopower f n :**: uncopower g n++data (n :*.: p) a b where+  Copower :: n -> p a b -> (n :*.: p) a b+instance (Profunctor p) => Profunctor (n :*.: p) where+  dimap l r (Copower n p) = Copower n (dimap l r p)+  r \\ Copower _ p = r \\ p+instance (CategoryOf j, CategoryOf k) => Copowered Type (j +-> k) where+  type n *. a = n :*.: a+  withObCopower r = r+  copower f = Prof \(Copower n p) -> unProf (f n) p+  uncopower (Prof f) n = Prof \p -> f (Copower n p)++-- | Kept with the class, for the same reason as 'Powered' 'FINHASK' 'FINHASK'.+instance Copowered FINHASK FINHASK where+  type n *. a = n ** a+  withObCopower @a @n r = withOb2 @_ @a @n r+  copower @a @b f = selfCopowered @a @b (arr unElt . f)+  uncopower f = (\g -> arr Elt . g) (selfUncopowered f) \\ f++class (HomObj v (OP a) (OP b) ~ HomObj v b a) => HomObjOp v a b+instance (HomObj v (OP a) (OP b) ~ HomObj v b a) => HomObjOp v a b++instance (Copowered v k, Enriched v (OPPOSITE k), forall (a :: k) b. HomObjOp v a b) => Powered v (OPPOSITE k) where+  type OP a ^ n = OP (n *. a)+  withObPower @(OP a) @n r = withObCopower @v @k @a @n r+  power @(OP a) @(OP b) f = Op (copower @v @k @b @a f)+  unpower @(OP a) (Op f) = uncopower @v @k @a f++instance (Powered v k, Enriched v (OPPOSITE k), forall (a :: k) b. HomObjOp v a b) => Copowered v (OPPOSITE k) where+  type n *. OP a = OP (a ^ n)+  withObCopower @(OP a) @n r = withObPower @v @k @a @n r+  copower @(OP a) @(OP b) f = Op (power @v @k @b @a f)+  uncopower @(OP a) (Op f) = unpower @v @k @a f++instance (Copowered v k, Ob (n :: v)) => Corepresentable (GenArrow (OP (n :: v)) :: k +-> k) where+  type GenArrow (OP n) %% a = n *. a+  coindex (GenArrow @a @b f) = copower @v @k @a @b f+  corepUniv @a = withObCopower @v @k @a @n (GenArrow (uncopower @v @k @a (obj @(n *. a))))
+ src/Proarrow/Colimit/Initial.hs view
@@ -0,0 +1,101 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Initial objects: 'HasInitialObject' with the unique arrow 'initiate', instances for the base kinds,+-- and 'HasZeroObject' for categories where the initial and terminal objects coincide.+module Proarrow.Colimit.Initial where++import Data.Kind (Type)+import Data.Void (Void, absurd)+import Prelude (Show, type (~))+import Prelude qualified as P++import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..))+import Proarrow.Category.Instance.Free+  ( Elem (..)+  , FREE (..)+  , Free (..)+  , HasStructure (..)+  , IsFreeOb (..)+  , Lower+  , withLowerOb+  )+import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Instance.Unit (Unit (..))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), obj, type (+->))+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Profunctor.Corepresentable (Corepresentable (..))+import Proarrow.Profunctor.Instance.Initial (InitialProfunctor)+import Proarrow.Profunctor.Instance.Terminal (TerminalProfunctor (..))+import Proarrow.Tools.Laws (Law (..), Laws (..), (===))++class (CategoryOf k, Ob (InitialObject :: k)) => HasInitialObject k where+  type InitialObject :: k+  initiate :: (Ob (a :: k)) => InitialObject ~> a++initiate' :: forall {k} a' a. (HasInitialObject k) => (a' :: k) ~> a -> InitialObject ~> a+initiate' a = a . initiate @k @a' \\ a++instance HasInitialObject Type where+  type InitialObject = Void+  initiate = absurd++instance HasInitialObject () where+  type InitialObject = '()+  initiate = Unit++instance HasInitialObject BOOL where+  type InitialObject = FLS+  initiate @a = case obj @a of+    Fls -> Fls+    Tru -> F2T++instance (HasInitialObject j, HasInitialObject k) => HasInitialObject (j, k) where+  type InitialObject = '(InitialObject, InitialObject)+  initiate = initiate :**: initiate++instance (CategoryOf j, CategoryOf k) => HasInitialObject (j +-> k) where+  type InitialObject = InitialProfunctor+  initiate = Prof \case {}++instance (HasInitialObject j, CategoryOf k) => Corepresentable (TerminalProfunctor :: j +-> k) where+  type TerminalProfunctor %% x = InitialObject+  coindex TerminalProfunctor = initiate+  cotabulate f = TerminalProfunctor \\ f+  corepMap _ = id++class (HasInitialObject k, HasTerminalObject k, (InitialObject :: k) ~ TerminalObject) => HasZeroObject k where+  zero :: (Ob (a :: k), Ob b) => a ~> b+instance (HasInitialObject k, HasTerminalObject k, (InitialObject :: k) ~ TerminalObject) => HasZeroObject k where+  zero = initiate . terminate++data family InitF :: k+instance (HasInitialObject `Elem` cs) => IsFreeOb (InitF :: FREE cs p) where+  type Lower f InitF = InitialObject+  lowerOb @k' @_ r = fromAll @HasInitialObject @cs @k' r+instance (HasInitialObject `Elem` cs) => HasStructure cs (p :: CAT k) HasInitialObject where+  data Struct HasInitialObject a b where+    Initial :: (Ob b) => Struct HasInitialObject InitF b+  foldStructure @f _ (Initial @b) = withLowerOb @f @b initiate+instance Show (Struct HasInitialObject a b) where+  showsPrec _ Initial = P.showString "initiate"+instance (HasInitialObject `Elem` cs) => HasInitialObject (FREE cs (p :: CAT k)) where+  type InitialObject = InitF+  initiate = St Initial Nil++instance (HasInitialObject k) => HasTerminalObject (OPPOSITE k) where+  type TerminalObject = OP InitialObject+  terminate = Op initiate++instance (HasTerminalObject k) => HasInitialObject (OPPOSITE k) where+  type InitialObject = OP TerminalObject+  initiate = Op terminate++-- | Every arrow out of the initial object is 'initiate'.+instance Laws '[HasInitialObject] where+  laws =+    [ Law "uniqueness" \ @a mor -> do+        g <- mor @InitialObject @a "g"+        g === initiate+    ]
+ src/Proarrow/Colimit/NaturalNumbers.hs view
@@ -0,0 +1,46 @@+-- | Parametrized natural numbers objects: 'HasParamNNO' provides 'NNO' with 'zero', 'succ' and the+-- parametrized recursor 'nnoUniv', from which arithmetic like 'add' is definable.+module Proarrow.Colimit.NaturalNumbers where++import Data.Kind (Type)+import Data.Nat qualified as N++import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..))+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Unit qualified as U+import Proarrow.Category.Monoidal (Monoidal (..), SymMonoidal (..))+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..))+import Proarrow.Limit.BinaryProduct ()++class (SymMonoidal k, Ob (NNO :: k)) => HasParamNNO k where+  type NNO :: k+  zero :: Unit ~> (NNO :: k)+  succ :: NNO ~> (NNO :: k)+  nnoUniv :: forall (a :: k) x. a ~> x -> x ~> x -> a ** NNO ~> x++add :: forall {k}. (HasParamNNO k) => NNO ** NNO ~> (NNO :: k)+add = nnoUniv id succ++instance HasParamNNO () where+  type NNO = '()+  zero = U.Unit+  succ = U.Unit+  nnoUniv z _ = U.Unit \\ z++instance (HasParamNNO j, HasParamNNO k) => HasParamNNO (j, k) where+  type NNO = '(NNO, NNO)+  zero = zero :**: zero+  succ = succ :**: succ+  nnoUniv (z1 :**: z2) (s1 :**: s2) = nnoUniv z1 s1 :**: nnoUniv z2 s2++instance HasParamNNO Type where+  type NNO = N.Nat+  zero () = N.Z+  succ = N.S+  nnoUniv z s (a, n) = N.cata (z a) s n++instance HasParamNNO BOOL where+  type NNO = TRU+  zero = Tru+  succ = Tru+  nnoUniv z _ = z
+ src/Proarrow/Colimit/Pushout.hs view
@@ -0,0 +1,78 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Pushouts: 'HasPushouts' with 'pushout' in continuation-passing style (the apex type depends on the+-- given arrows, so it is hidden behind an existential), and 'factorPushout' for the universal property,+-- defaulting to coproduct-then-coequalizer where those exist.+module Proarrow.Colimit.Pushout where++import Prelude (Bool, const, ($), (==))++import Proarrow.Category.Enriched.Thin (Thin)+import Proarrow.Category.Instance.Bool (BOOL (..))+import Proarrow.Category.Instance.Opposite (OPPOSITE, Op (..))+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Unit (Unit (..))+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..), HasCoproducts)+import Proarrow.Colimit.Coequalizer (HasCoequalizers, factorPushoutDefault, pushoutDefault)+import Proarrow.Core (CategoryOf (..), Eq2, Hom, obj, (//))+import Proarrow.Limit.BinaryProduct (PROD, Prod (..))+import Proarrow.Limit.Pullback (HasPullbacks (..))+import Proarrow.Object (pattern Objs)++-- | Pushouts are an inherently dependently typed concept:+-- The type of the apex object depends on the values of the given arrows.+-- But at runtime we can still calculate the arrows and the type, which we hide behind an existential.+class (CategoryOf k) => HasPushouts k where+  pushout :: forall (o :: k) a b r. o ~> a -> o ~> b -> (forall p. a ~> p -> b ~> p -> r) -> r+  default pushout+    :: forall (o :: k) a b r+     . (HasCoequalizers k, HasCoproducts k)+    => o ~> a -> o ~> b -> (forall p. a ~> p -> b ~> p -> r) -> r+  pushout = pushoutDefault++  -- | @factorPushout p1 p2 k1 k2@ requires @k1, k2@ to be a compatible cocone for whichever cospan+  -- @p1, p2@ happen to be a pushout of. @p1, p2@ need not literally be @pushout@'s own output.+  factorPushout :: forall (a :: k) b p q. a ~> p -> b ~> p -> a ~> q -> b ~> q -> p ~> q+  default factorPushout+    :: forall (a :: k) b p q. (HasCoequalizers k, HasCoproducts k) => a ~> p -> b ~> p -> a ~> q -> b ~> q -> p ~> q+  factorPushout = factorPushoutDefault++instance HasPushouts () where+  pushout Unit Unit k = k Unit Unit+  factorPushout Unit Unit Unit Unit = Unit++instance HasPushouts BOOL where+  pushout = thinPushout++instance (HasPushouts k1, HasPushouts k2) => HasPushouts (k1, k2) where+  pushout (l1 :**: l2) (r1 :**: r2) k = pushout l1 r1 \f1 g1 -> pushout l2 r2 \f2 g2 -> k (f1 :**: f2) (g1 :**: g2)+  factorPushout (p1a :**: p1b) (p2a :**: p2b) (k1a :**: k1b) (k2a :**: k2b) =+    factorPushout p1a p2a k1a k2a :**: factorPushout p1b p2b k1b k2b++-- | Pushouts are unchanged by making the tensor the product.+instance (HasPushouts k) => HasPushouts (PROD k) where+  pushout (Prod f) (Prod g) k = pushout f g \p1 p2 -> k (Prod p1) (Prod p2)+  factorPushout (Prod p1) (Prod p2) (Prod k1) (Prod k2) = Prod (factorPushout p1 p2 k1 k2)++-- | In a thin category, arrows don't carry information, so pushouts are just coproducts.+thinPushout+  :: forall {k} (o :: k) a b r. (Thin k, HasCoproducts k) => o ~> a -> o ~> b -> (forall p. a ~> p -> b ~> p -> r) -> r+thinPushout l r k = l // r // withObCoprod @k @a @b $ k (lft @k @a @b) (rgt @k @a @b)++coequalizerDefault+  :: forall {k} (a :: k) b r. (HasPushouts k, HasCoproducts k) => a ~> b -> a ~> b -> (forall c. b ~> c -> r) -> r+coequalizerDefault f@Objs g k = pushout (obj @b ||| f) (obj @b ||| g) (const k)++cokernelPair :: (HasPushouts k) => (a :: k) ~> b -> (forall p. b ~> p -> b ~> p -> r) -> r+cokernelPair f = pushout f f++isEpi :: (HasPushouts k, Eq2 (Hom k)) => (a :: k) ~> b -> Bool+isEpi f@Objs = cokernelPair f \l@Objs r -> l == r++instance (HasPullbacks k) => HasPushouts (OPPOSITE k) where+  pushout (Op l) (Op r) k = pullback l r \f g -> k (Op f) (Op g)+  factorPushout (Op p1) (Op p2) (Op k1) (Op k2) = Op (factorPullback p1 p2 k1 k2)++instance (HasPushouts k) => HasPullbacks (OPPOSITE k) where+  pullback (Op l) (Op r) k = pushout l r \f g -> k (Op f) (Op g)+  factorPullback (Op p1) (Op p2) (Op k1) (Op k2) = Op (factorPushout p1 p2 k1 k2)
+ src/Proarrow/Core.hs view
@@ -0,0 +1,332 @@+{- HLINT ignore "Redundant lambda" -}++-- | The foundational module, defining the kind-indexed category machinery everything else builds+-- on. A kind @k@ carries at most one category structure, chosen by the 'CategoryOf' class: its+-- morphism type @('~>')@ and its object constraint 'Ob' (not every type of the kind need be an+-- object). A category's identity and composition live in 'Promonad', and 'Profunctor' (with the+-- profunctor kind @j '+->' k@) is this library's central generalization of functors. 'Ob'+-- constraints are typically not threaded through signatures but recovered from morphisms with+-- '(\\)' and '(//)', since an arrow is proof that its endpoints are objects.+--+-- Import "Proarrow" for the curated everyday vocabulary. This module defines the design, and is+-- the place to start when building your own categories.+module Proarrow.Core+  ( -- * Type Infrastructure++    -- ** Basic Type Definitions+    type (+->)+  , CAT+  , OB+  , type (:&&:)+  , Kind++    -- * Category Infrastructure++    -- ** CategoryOf Class+  , CategoryOf (..)+  , Hom+  , Ob'+  , ObId (..)++    -- * Profunctors++    -- ** Profunctor Class+  , Profunctor (..)++    -- ** Natural Transformations+  , type (:~>)++    -- ** Profunctor Utilities+  , (//)++    -- ** Default Implementation+  , dimapDefault++    -- * Promonads++    -- ** Promonad Class+  , Promonad (..)++    -- ** Promonad Utilities+  , arr++    -- * Object Identities+  , Obj+  , obj+  , src+  , tgt++    -- * Universal Constraint+  , Any+  , VacuousOb++    -- * Lifted Type Classes+  , Eq2+  , Show2++    -- * Constraint Continuations+  , ($)++    -- * Type Family Utilities++    -- ** Kind Unwrapping+  , UN+  , Is+  , WrappedOb+  ) where++import Data.Kind (Constraint, Type)+import Data.Type.Equality ((:~:) (Refl))+import Prelude (Eq, Show, type (~))++infixr 0 ~>, :~>, +->+infixl 1 \\+infixr 0 //+infixr 0 $+infixr 9 .++-- * Type Infrastructure++-- ** Basic Type Definitions++-- | The kind @j +-> k@ of profunctors from category @j@ to category @k@.+-- This follows mathematical convention,+-- swapping the order compared to Haskell's contravariant-first ordering.+type j +-> k = k -> j -> Type++-- | The kind of categories on kind @k@.+type CAT k = k +-> k++-- | Object constraints for kind @k@.+type OB k = k -> Constraint++-- | The conjunction of two constraints on a common argument, as one constraint.+type (:&&:) :: OB k -> OB k -> OB k+class (c1 p, c2 p) => (c1 :&&: c2) p++instance (c1 p, c2 p) => (c1 :&&: c2) p++-- | Alias for 'Type' for clarity in kind signatures.+type Kind = Type++-- * Category Infrastructure++-- ** CategoryOf Class++-- | Establishes that @k@ is a category by specifying the morphism type and object constraints.+class (Promonad ((~>) :: CAT k)) => CategoryOf k where+  -- | The type of morphisms in the category.+  type (~>) :: CAT k++  -- | What constraints objects must satisfy. Defaults to 'ObId', which suits a category with+  -- more than one object. A category where every type of the kind is an object, with no+  -- evidence needed, says @type 'Ob' a = 'Any' a@ instead.+  type Ob (a :: k) :: Constraint++  type Ob a = ObId a++-- | A type synonym for @(~>) :: CAT k@, the type of morphisms in the category of kind @k@.+type Hom k = ((~>) :: CAT k)++-- | 'Ob' as a proper class, for the positions where the type family 'Ob' itself cannot appear,+-- such as the head of a quantified constraint.+class (Ob a, CategoryOf k) => Ob' (a :: k)++instance (Ob a, CategoryOf k) => Ob' (a :: k)++-- | Objecthood that carries the object's own identity arrow, and the default for 'Ob'.+--+-- A category with more than one object needs this. 'id' must produce the identity at whichever+-- object it is asked for, so it has to dispatch on the object, and one instance per object does+-- that dispatch. Since 'Ob' defaults to 'ObId' and 'id' defaults to 'objId', such a category+-- defines neither. It just gives an 'ObId' instance per object:+--+-- > type data STATE = Draft | Live+-- >+-- > type Move :: CAT STATE+-- > data Move a b where+-- >   KeepDraft :: Move Draft Draft+-- >   Publish :: Move Draft Live+-- >   KeepLive :: Move Live Live+-- >+-- > instance ObId Draft where objId = KeepDraft+-- > instance ObId Live where objId = KeepLive+-- >+-- > instance CategoryOf STATE where+-- >   type (~>) = Move+type ObId :: forall {k}. k -> Constraint+class (CategoryOf k) => ObId (a :: k) where+  -- | The identity arrow at @a@.+  objId :: a ~> a++-- * Profunctors++-- ** Profunctor Class++-- | The core profunctor abstraction. A profunctor is contravariant in its first+-- argument and covariant in its second argument.+--+-- __Laws:__+--+-- * @'dimap' 'id' 'id' = 'id'@+-- * @'dimap' (f . g) (h . i) = 'dimap' g h . 'dimap' f i@+type Profunctor :: forall {j} {k}. j +-> k -> Constraint+class (CategoryOf j, CategoryOf k) => Profunctor (p :: j +-> k) where+  -- | Map contravariantly over the first argument and covariantly over the second.+  dimap :: c ~> a -> b ~> d -> p a b -> p c d+  dimap l r = lmap l . rmap r++  -- | Left mapping (contravariant mapping over first argument).+  lmap :: c ~> a -> p a b -> p c b+  lmap l p = dimap l id p \\ p++  -- | Right mapping (covariant mapping over second argument).+  rmap :: b ~> d -> p a b -> p a d+  rmap r p = dimap id r p \\ p++  -- | Constraint elimination, extracts object constraints from a profunctor heteromorphism.+  (\\) :: ((Ob a, Ob b) => r) -> p a b -> r+  default (\\) :: (Ob a, Ob b) => ((Ob a, Ob b) => r) -> p a b -> r+  r \\ _ = r++  {-# MINIMAL dimap | (lmap, rmap) #-}++-- ** Natural Transformations++-- | Natural transformation between profunctors.+type p :~> q = forall a b. p a b -> q a b++-- ** Profunctor Utilities++-- | Flipped version of '(\\)'.+(//) :: (Profunctor p) => p a b -> ((Ob a, Ob b) => r) -> r+p // r = r \\ p++-- ** Default Implementation++-- | Default implementation of 'dimap' for promonads using composition.+dimapDefault :: (Promonad p) => p c a -> p b d -> p a b -> p c d+dimapDefault f g h = g . h . f++-- * Promonads++-- ** Promonad Class++-- | A promonad is a category-like profunctor with identity morphisms and composition.+--+-- This is also known as a category structure, or an identity-on-objects functor.+--+-- __Laws:__+--+-- * Left identity: @'id' . f = f@+-- * Right identity: @f . 'id' = f@+-- * Associativity: @(h . g) . f = h . (g . f)@+type Promonad :: forall {k}. CAT k -> Constraint+class (Profunctor p) => Promonad (p :: CAT k) where+  -- | Identity morphisms.+  --+  -- Defaults to 'objId' for a category's own hom-profunctor, so a category that leaves 'Ob' at+  -- its 'ObId' default gets 'id' for free.+  id :: (Ob a) => p a a+  default id :: forall (a :: k). (ObId a, p ~ ((~>) :: CAT k)) => p a a+  id = objId++  -- | Composition (note the parameter order matches function composition).+  (.) :: p b c -> p a b -> p a c++-- ** Promonad Utilities++-- | Lifts morphisms from the base category into the promonad.+arr :: (Promonad p) => a ~> b -> p a b+arr f = rmap f id \\ f++-- * Object Identities++-- | Type of identity morphism for object @a@.+type Obj a = a ~> a++-- | The identity morphism for a given object.+-- Compared to @id@ this makes the kind argument implicit,+-- allowing to write @obj \@a@ instead of @id \@k \@a@.+obj :: forall {k} (a :: k). (CategoryOf k, Ob a) => Obj a+obj = id @_ @a++-- | Extract source identity morphism from a profunctor heteromorphism.+src :: forall {k} a b p. (Profunctor p) => p (a :: k) b -> Obj a+src p = obj @a \\ p++-- | Extract target identity morphism from a profunctor heteromorphism.+tgt :: forall {k} a b p. (Profunctor p) => p (a :: k) b -> Obj b+tgt p = obj @b \\ p++-- * Standard Instances++instance Profunctor (->) where+  dimap = dimapDefault++instance Promonad (->) where+  id = \a -> a+  f . g = \x -> f (g x)++-- | The category of Haskell types (a.k.a @Hask@), where the arrows are functions.+instance CategoryOf Type where+  type (~>) = (->)+  type Ob a = Any a++instance (VacuousOb k, Hom k ~ (:~:)) => Profunctor ((:~:) :: CAT k) where+  dimap Refl Refl Refl = Refl++instance (VacuousOb k, Hom k ~ (:~:)) => Promonad ((:~:) :: CAT k) where+  id = Refl+  Refl . Refl = Refl++-- * Universal Constraint++-- | A constraint that's always satisfied, used as a default when no specific+-- object constraints are needed.+class Any (a :: k)++instance Any a++-- | A category without constraints on its objects.+class (CategoryOf k, forall a. Ob' (a :: k)) => VacuousOb k++instance (CategoryOf k, forall a. Ob' (a :: k)) => VacuousOb k++-- | A profunctor (or something of that kind) whose elements can be compared.+class (forall x y. Eq (p x y)) => Eq2 p++instance (forall x y. Eq (p x y)) => Eq2 p++-- | A profunctor (or something of that kind) whose elements can be shown.+class (forall x y. Show (p x y)) => Show2 p++instance (forall x y. Show (p x y)) => Show2 p++-- * Constraint Continuations++-- Workaround for GHC #26543 (fix pending in !16566): on GHC 9.14 and 10.0 some `with… $ body`+-- applications fail to typecheck with Prelude's $, while the parenthesised form is accepted.++-- | Application of a constraint continuation such as 'Proarrow.Category.Monoidal.withOb2' to its+-- body, as in @withOb2 \@_ \@a \@b $ body@. Unlike Prelude's @$@ it only applies functions of+-- this shape.+($) :: forall (c :: Constraint) r. (((c) => r) -> r) -> ((c) => r) -> r+f $ r = f r++-- * Type Family Utilities++-- ** Kind Unwrapping++-- | A helper type family to unwrap a wrapped kind @w x@.+type UN :: (j -> k) -> k -> j+type family UN w wa where+  UN w (w x) = x++-- | @Is w a@ checks that the kind @a@ is a kind wrapped by @w@.+type Is w a = a ~ w (UN w a)++-- | @WrappedOb w a@ asserts both that @a@ is wrapped by @w@ ('Is' @w a@)+-- and that its unwrapped kind satisfies @Ob@.+type WrappedOb :: (j -> k) -> k -> Constraint+type WrappedOb w a = (Is w a, Ob (UN w a))
+ src/Proarrow/Functor.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Functors between categories of arbitrary kinds: 'Functor' @f@ sends @a '~>' b@ to @f a '~>' f b@.+-- Haskell 'P.Functor's embed via the 'Prelude' wrapper. Only functors into 'Data.Kind.Type' can be+-- written directly as type constructors; functors into other kinds are instead encoded as representable+-- profunctors (see "Proarrow.Profunctor.Representable" and 'FunctorForRep').+module Proarrow.Functor where++import Data.Functor.Compose (Compose (..))+import Data.Functor.Const (Const (..))+import Data.Functor.Identity (Identity)+import Data.Kind (Constraint, Type)+import Data.List.NonEmpty qualified as P+import Prelude qualified as P++import Proarrow.Core (CategoryOf (..), Profunctor, Promonad (..), rmap, (\\), type (+->))+import Proarrow.Object (Ob', obj)++infixr 0 .~>++-- | Natural transformations between functors: an arrow @f a '~>' g a@ for every object @a@.+type f .~> g = forall a. (Ob a) => f a ~> g a++-- | Functors between kind-indexed categories: 'map' sends arrows of the source category to+-- arrows of the target category. Only functors landing in a kind of shape @... -> Type@ can be+-- written as type constructors like this; the rest are encoded as representable profunctors+-- instead ('FunctorForRep', "Proarrow.Profunctor.Representable").+type Functor :: forall {k1} {k2}. (k1 -> k2) -> Constraint+class (CategoryOf k1, CategoryOf k2, forall a. (Ob a) => Ob' (f a)) => Functor (f :: k1 -> k2) where+  map :: a ~> b -> f a ~> f b++-- | Makes a @base@-style 'P.Functor' (kind @Type -> Type@) a 'Functor', to use with @deriving via@+-- (see the instances below). A direct @instance Functor (f :: Type -> Type)@ would overlap with+-- the 'Functor' instances at every other kind @k -> Type@, hence the wrapper.+newtype Prelude (f :: Type -> Type) a = Prelude {unPrelude :: f a}+  deriving (P.Functor, P.Foldable, P.Traversable, P.Eq, P.Show)+  deriving newtype (P.Applicative)++instance (P.Functor f) => Functor (Prelude f) where+  map f = Prelude . P.fmap f . unPrelude++deriving via Prelude ((,) a) instance Functor ((,) a)+deriving via Prelude (P.Either a) instance Functor (P.Either a)+deriving via Prelude P.IO instance Functor P.IO+deriving via Prelude P.Maybe instance Functor P.Maybe+deriving via Prelude P.NonEmpty instance Functor P.NonEmpty+deriving via Prelude ((->) a) instance Functor ((->) a)+deriving via Prelude [] instance Functor []+deriving via Prelude Identity instance Functor Identity++instance (CategoryOf k) => Functor (Const x :: k -> Type) where+  map _ (Const x) = Const x++instance (Functor f, Functor g) => Functor (Compose f g) where+  map f = Compose . map (map f) . getCompose++newtype FromProfunctor p a b = FromProfunctor {unFromProfunctor :: p a b}+  deriving newtype (Profunctor, Promonad)+instance (Profunctor p) => Functor (FromProfunctor p a) where+  map f = FromProfunctor . rmap f . unFromProfunctor+instance (Profunctor p) => P.Functor (FromProfunctor p a) where+  fmap = map++-- | Presheaves are functors but it makes more sense in proarrow to represent them as profunctors from the unit category.+type Presheaf k = () +-> k++-- | Copresheaves are functors but it makes more sense in proarrow to represent them as profunctors into the unit category.+type Copresheaf k = k +-> ()++-- | A perfectly valid functor definition, but hard to use.+-- So we only use it to easily make (co)representable profunctors with @Rep@ and @Corep@.+type FunctorForRep :: forall {j} {k}. (j +-> k) -> Constraint+class (CategoryOf j, CategoryOf k) => FunctorForRep (f :: j +-> k) where+  type f @ (a :: j) :: k+  fmap :: (a ~> b) -> f @ a ~> f @ b++withMappedOb :: forall {j} {k} (f :: j +-> k) (a :: j) r. (FunctorForRep f, Ob a) => ((Ob (f @ a)) => r) -> r+withMappedOb r = r \\ fmap @f (obj @a)++-- | Recover @'Ob' (f a)@ from a 'Functor' @f@ and @'Ob' a@, the @map@-based analog of+-- 'withMappedOb'. The @'Proarrow.Object.Ob'' (f a)@ superclass of 'Functor' is a quantified+-- constraint, and GHC will not extract its own @'Ob' (f a)@ superclass on demand, so it is observed+-- from the mapped identity morphism instead.+withObF :: forall {k1} {k2} (f :: k1 -> k2) a r. (Functor f, Ob a) => ((Ob (f a)) => r) -> r+withObF r = r \\ map @f (obj @a)
+ src/Proarrow/Limit.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Profunctor-weighted limits: @'HasLimits' j k@ says @k@ has limits of @i '+->' k@-diagrams weighted+-- by @j@, given by the 'Limit' profunctor with 'limit' and 'limitUniv'. The+-- 'Proarrow.Profunctor.Instance.Terminal.TerminalProfunctor' weight recovers ordinary conical+-- limits, e.g. terminal objects, binary products and powers as special shapes.+--+-- The helpers that state those instances (@Unweighted@, @O1@\/@O2@, @At1@\/@At2@, @Hom@, @Ran@) are+-- not exported, since they clash with names in "Proarrow.Colimit", "Proarrow.Core" and+-- "Proarrow.Profunctor.Instance.Ran".+module Proarrow.Limit+  ( HasLimits (..)+  , IsRepresentableLimit+  , mapLimit+  , ProductLimit+  , PowerLimit+  , End (..)+  , EndLimit+  , AnyLimit (..)+  ) where++import Data.Function (($))+import Data.Kind (Constraint, Type)++import Proarrow.Category.Instance.Coproduct (COPRODUCT, IsLR (..), L, R)+import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Instance.Unit (Unit (..))+import Proarrow.Category.Instance.Zero (VOID)+import Proarrow.Core (CAT, CategoryOf (..), Kind, Profunctor (..), Promonad (..), rmap, (//), (:~>), type (+->))+import Proarrow.Functor (Copresheaf, Functor (..), FunctorForRep (..), Presheaf)+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..), fst, snd)+import Proarrow.Limit.Power (Powered (..))+import Proarrow.Limit.Terminal (HasTerminalObject (..), terminate)+import Proarrow.Profunctor.Corepresentable (Corep (..), corepUniv)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Constant (Constant)+import Proarrow.Profunctor.Instance.HaskValue (HaskValue (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Instance.Star (Star, pattern Star)+import Proarrow.Profunctor.Instance.Terminal (TerminalProfunctor (..))+import Proarrow.Profunctor.Representable (Rep (..), Representable (..), repUniv, withObRep)++class (Representable (Limit j d)) => IsRepresentableLimit j d+instance (Representable (Limit j d)) => IsRepresentableLimit j d++-- | profunctor-weighted limits+type HasLimits :: forall {a} {i}. i +-> a -> Kind -> Constraint+class (Profunctor j, forall (d :: i +-> k). (Representable d) => IsRepresentableLimit j d) => HasLimits (j :: i +-> a) k where+  type Limit (j :: i +-> a) (d :: i +-> k) :: a +-> k+  limit :: (Representable (d :: i +-> k)) => Limit j d :.: j :~> d+  limitUniv :: (Representable (d :: i +-> k), Profunctor p) => p :.: j :~> d -> p :~> Limit j d++mapLimit+  :: forall {i} j k p q. (HasLimits j k, Representable p, Representable q) => (p :: i +-> k) ~> q -> Limit j p ~> Limit j q+mapLimit (Prof n) = Prof (limitUniv @j (n . limit @j))++type Unweighted = TerminalProfunctor++instance (HasTerminalObject k) => HasLimits (Unweighted :: Copresheaf VOID) k where+  type Limit Unweighted d = Rep (Constant TerminalObject)+  limit (_ :.: t) = case t of {}+  limitUniv _ p = p // Rep terminate++type O1 = L '()+type O2 = R '()+type At1 d = d % O1+type At2 d = d % O2++data family ProductLimit :: COPRODUCT () () +-> k -> Presheaf k+instance (HasBinaryProducts k, Representable d) => FunctorForRep (ProductLimit d :: Presheaf k) where+  type ProductLimit d @ '() = At1 d && At2 d+  fmap Unit = withObRep @d @O1 $ withObRep @d @O2 $ withObProd @_ @(At1 d) @(At2 d) id++instance (HasBinaryProducts k) => HasLimits (Unweighted :: Copresheaf (COPRODUCT () ())) k where+  type Limit Unweighted d = Rep (ProductLimit d)+  limit @d (Rep f :.: TerminalProfunctor @_ @o) =+    withObRep @d @O1 $+      withObRep @d @O2 $+        lrCase @o+          (tabulate (fst @_ @(At1 d) @(At2 d) . f))+          (tabulate (snd @_ @(At1 d) @(At2 d) . f))+  limitUniv n p = p // Rep (index (n (p :.: TerminalProfunctor @'() @O1)) &&& index (n (p :.: TerminalProfunctor @'() @O2)))++data family PowerLimit :: v -> Presheaf k -> Presheaf k+instance (Representable d, Powered v k, Ob n) => FunctorForRep (PowerLimit (n :: v) d :: Presheaf k) where+  type PowerLimit n d @ '() = (d % '()) ^ n+  fmap Unit = withObRep @d @'() $ withObPower @v @k @(d % '()) @n id+instance (Powered Type k) => HasLimits (HaskValue n :: Copresheaf ()) k where+  type Limit (HaskValue n) d = Rep (PowerLimit n d)+  limit @d (Rep f :.: HaskValue n) = withObRep @d @'() $ tabulate (unpower f n)+  limitUniv @d m p = withObRep @d @'() $ Rep (power \n -> index (m (p :.: HaskValue n))) \\ p++newtype End d = End {unEnd :: forall a b. a ~> b -> d % '(OP a, b)}++data family EndLimit :: (OPPOSITE k, k) +-> Type -> Presheaf Type+instance (Representable d) => FunctorForRep (EndLimit (d :: (OPPOSITE k, k) +-> Type)) where+  type EndLimit d @ '() = End d+  fmap Unit = id++-- | The hom-functor of @k@ as a weight: the limit of a diagram @('OPPOSITE' k, k) '+->' ()@+-- weighted by 'Hom' is its end.+type Hom :: Copresheaf (OPPOSITE k, k)+data Hom a b where+  Hom :: a ~> b -> Hom '() '(OP a, b)++instance (CategoryOf k) => Profunctor (Hom :: Copresheaf (OPPOSITE k, k)) where+  dimap Unit (Op l :**: r) (Hom f) = Hom (r . f . l) \\ l \\ r+  r \\ Hom f = r \\ f++instance (CategoryOf k) => HasLimits (Hom :: Copresheaf (OPPOSITE k, k)) Type where+  type Limit Hom d = Rep (EndLimit d)+  limit (Rep f :.: Hom k) = k // tabulate (\a -> unEnd (f a) k)+  limitUniv n p = p // Rep \a -> End \x -> index (n (p :.: Hom x)) a++instance (CategoryOf j) => HasLimits (Id :: CAT j) k where+  type Limit Id d = d+  limit (d :.: Id f) = rmap f d+  limitUniv n p = n (p :.: Id id) \\ p++instance (Representable j1, HasLimits j1 k, HasLimits j2 k) => HasLimits (j1 :.: j2) k where+  type Limit (j1 :.: j2) d = Limit j1 (Limit j2 d)+  limit @d (l :.: (j1 :.: j2)) = limit @j2 @k @d (limit @j1 @k @(Limit j2 d) (l :.: j1) :.: j2)+  limitUniv @d n = limitUniv @j1 @k @(Limit j2 d) (limitUniv @j2 @k @d (\((p' :.: j1) :.: j2) -> n (p' :.: (j1 :.: j2))))++instance (FunctorForRep f) => HasLimits (Corep f) k where+  type Limit (Corep f) d = d :.: Rep f+  limit ((d :.: Rep f) :.: Corep g) = rmap (g . f) d+  limitUniv n p = p // n (p :.: corepUniv) :.: repUniv++newtype AnyLimit j a b = AnyLimit (j a b)+  deriving newtype (Profunctor)+type Ran :: (i +-> a) -> (i +-> Type) -> a -> Type+newtype Ran j d a = Ran {runRan :: forall b. j a b -> d % b}+instance (Profunctor j, Representable d) => Functor (Ran j d) where+  map f (Ran g) = Ran \j -> g (lmap f j)+instance (Profunctor j) => HasLimits (AnyLimit j) Type where+  type Limit (AnyLimit j) d = Star (Ran j d)+  limit (Star f :.: AnyLimit j) = tabulate (\a -> runRan (f a) j) \\ j+  limitUniv n p = p // Star (\a -> Ran \j -> index (n (p :.: AnyLimit j)) a)
+ src/Proarrow/Limit/BinaryProduct.hs view
@@ -0,0 +1,353 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Binary products: 'HasBinaryProducts' provides @a '&&' b@ with projections 'fst'\/'snd' and pairing+-- @('&&&')@, and 'HasProducts' adds the terminal object. Also 'Cartesian' (the monoidal tensor is the+-- product) and the 'PROD' kind wrapper, which makes @('&&')@ the tensor of a monoidal structure on the+-- same objects.+module Proarrow.Limit.BinaryProduct where++import Data.Kind (Type)+import Prelude (Show, type (~))+import Prelude qualified as P++import Proarrow.Category.Enriched.Thin (DecidableProfunctor (..), Decision (..))+import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..))+import Proarrow.Category.Instance.Free+  ( Elem (..)+  , FREE (..)+  , Free (..)+  , HasStructure (..)+  , IsFreeOb (..)+  , Lower+  , WithShow+  , withLowerOb+  )+import Proarrow.Category.Instance.Product (Diag, Fst, Snd, (:**:) (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Instance.Unit qualified as U+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Core (CAT, CategoryOf (..), Hom, Profunctor (..), Promonad (..), UN, WrappedOb, type (+->))+import Proarrow.Functor (Functor (..), FunctorForRep (..))+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Object (Obj, obj)+import Proarrow.Profunctor.Corepresentable (Corep (..))+import Proarrow.Profunctor.Instance.Product (prod, (:*:) (..))+import Proarrow.Profunctor.Representable (Representable (..), withObRep)+import Proarrow.Tools.Laws (Law (..), Laws (..), (===))++infixl 5 &&+infixl 5 &&&+infixl 5 ***++-- | Binary products: an object @a '&&' b@ with projections 'fst' and 'snd', universal among all+-- pairs of arrows out of a common source. Each such pair factors through it uniquely via '(&&&)'.+--+-- __Laws:__+--+-- * @'fst' . (f '&&&' g) = f@+-- * @'snd' . (f '&&&' g) = g@+-- * Uniqueness: @(f . h) '&&&' (g . h) = (f '&&&' g) . h@+--+-- Checked by 'Proarrow.Testing.Laws.testBinaryProducts'.+class (CategoryOf k) => HasBinaryProducts k where+  -- | The product object.+  type (a :: k) && (b :: k) :: k++  -- | Recovers @'Ob' (a '&&' b)@ from the objecthood of the factors.+  withObProd :: (Ob (a :: k), Ob b) => ((Ob (a && b)) => r) -> r++  -- | The left projection.+  fst :: (Ob (a :: k), Ob b) => (a && b) ~> a++  -- | The right projection.+  snd :: (Ob (a :: k), Ob b) => (a && b) ~> b++  -- | The mediating arrow: pairs two arrows out of a common source.+  (&&&) :: (a :: k) ~> x -> a ~> y -> a ~> x && y++  -- | The product of two arrows, acting on each factor independently.+  (***) :: forall a b x y. (a :: k) ~> x -> b ~> y -> a && b ~> x && y+  l *** r = (l . fst @k @a @b) &&& (r . snd @k @a @b) \\ l \\ r++fst' :: forall {k} (a :: k) a' b. (HasBinaryProducts k) => a ~> a' -> Obj b -> a && b ~> a'+fst' a b = a . fst @k @a @b \\ a \\ b++snd' :: forall {k} (a :: k) b b'. (HasBinaryProducts k) => Obj a -> b ~> b' -> a && b ~> b'+snd' a b = b . snd @k @a @b \\ a \\ b++first :: forall {k} (c :: k) (a :: k) (b :: k). (HasBinaryProducts k, Ob c) => a ~> b -> (a && c) ~> (b && c)+first f = f *** obj @c++second :: forall {k} (c :: k) (a :: k) (b :: k). (HasBinaryProducts k, Ob c) => a ~> b -> (c && a) ~> (c && b)+second f = obj @c *** f++diag :: forall {k} (a :: k). (HasBinaryProducts k, Ob a) => a ~> a && a+diag = id &&& id++data family Product :: k -> k +-> k+instance (HasBinaryProducts k, Ob a) => FunctorForRep (Product a :: k +-> k) where+  type Product a @ b = a && b+  fmap f = second @a f+instance (HasBinaryProducts k, Ob a) => Promonad (Corep (Product a) :: k +-> k) where+  id @b = Corep (snd @k @a @b)+  Corep f . Corep @c g = Corep (f . second @a g . associatorProd @a @a @c . first @c (diag @a))++type HasProducts k = (HasTerminalObject k, HasBinaryProducts k)++instance HasBinaryProducts Type where+  type a && b = (a, b)+  withObProd r = r+  fst = P.fst+  snd = P.snd+  f &&& g = \a -> (f a, g a)++instance HasBinaryProducts () where+  -- a wildcard, not @'()@, so that @a && b@ reduces for an abstract @a@, as on pairs+  type _ && _ = '()+  withObProd r = r+  fst = U.Unit+  snd = U.Unit+  U.Unit &&& U.Unit = U.Unit++instance HasBinaryProducts BOOL where+  type TRU && b = b+  type FLS && b = FLS+  type a && TRU = a+  type a && FLS = FLS+  withObProd @a r = case obj @a of+    Tru -> r+    Fls -> r+  fst @a @b = case obj @a of+    Fls -> Fls+    Tru -> terminate @_ @b+  snd @a @b = case obj @b of+    Fls -> Fls+    Tru -> terminate @_ @a+  Fls &&& _ = Fls+  F2T &&& b = b+  Tru &&& Tru = Tru++instance (HasBinaryProducts j, HasBinaryProducts k) => HasBinaryProducts (j, k) where+  -- Through the projections, as the tensor on pairs is, so that the two agree at abstract pairs.+  type a && b = '(Fst @ a && Fst @ b, Snd @ a && Snd @ b)+  withObProd @'(a1, a2) @'(b1, b2) r = withObProd @j @a1 @b1 (withObProd @k @a2 @b2 r)+  fst @'(a1, a2) @'(b1, b2) = fst @_ @a1 @b1 :**: fst @_ @a2 @b2+  snd @'(a1, a2) @'(b1, b2) = snd @_ @a1 @b1 :**: snd @_ @a2 @b2+  (f1 :**: f2) &&& (g1 :**: g2) = (f1 &&& g1) :**: (f2 &&& g2)++instance (CategoryOf j, CategoryOf k) => HasBinaryProducts (j +-> k) where+  type p && q = p :*: q+  withObProd r = r+  fst = Prof fstP+  snd = Prof sndP+  Prof l &&& Prof r = Prof (prod l r)++instance (HasBinaryProducts k, Representable (p :: j +-> k), Representable q) => Representable (p :*: q) where+  type (p :*: q) % a = (p % a) && (q % a)+  index (p :*: q) = index p &&& index q+  tabulate @b f =+    withObRep @p @b (withObRep @q @b (tabulate (fst @_ @(p % b) @(q % b) . f) :*: tabulate (snd @_ @(p % b) @(q % b) . f)))+  repMap f = repMap @p f *** repMap @q f++-- | A product holds when both components do: the type-level '&&' is 'BOOL'\'s categorical product.+instance (DecidableProfunctor p, DecidableProfunctor q) => DecidableProfunctor (p :**: q) where+  type Holds (p :**: q) '(a1, a2) '(b1, b2) = Holds p a1 b1 && Holds q a2 b2+  decide @'(a1, a2) @'(b1, b2) = case (decide @p @a1 @b1, decide @q @a2 @b2) of+    (Yes x, Yes y) -> Yes (x :**: y)+    (No, _) -> No+    (Yes _, No) -> No+  toHolds (f :**: g) r = toHolds f (toHolds g r)++instance (DecidableProfunctor p, DecidableProfunctor q) => DecidableProfunctor (p :*: q) where+  type Holds (p :*: q) a b = Holds p a b && Holds q a b+  decide @a @b = case (decide @p @a @b, decide @q @a @b) of+    (Yes x, Yes y) -> Yes (x :*: y)+    (No, _) -> No+    (Yes _, No) -> No+  toHolds (p :*: q) r = toHolds p (toHolds q r)++leftUnitorProd :: forall {k} (a :: k). (HasProducts k, Ob a) => TerminalObject && a ~> a+leftUnitorProd = snd @k @TerminalObject++leftUnitorProdInv :: forall {k} (a :: k). (HasProducts k, Ob a) => a ~> TerminalObject && a+leftUnitorProdInv = terminate &&& id++rightUnitorProd :: forall {k} (a :: k). (HasProducts k, Ob a) => a && TerminalObject ~> a+rightUnitorProd = fst @k @_ @TerminalObject++rightUnitorProdInv :: forall {k} (a :: k). (HasProducts k, Ob a) => a ~> a && TerminalObject+rightUnitorProdInv = id &&& terminate++associatorProd :: forall {k} (a :: k) b c. (HasBinaryProducts k, Ob a, Ob b, Ob c) => (a && b) && c ~> a && (b && c)+associatorProd = withObProd @k @a @b ((fst @k @a @b . fst @k @(a && b) @c) &&& (snd @k @a @b *** obj @c))++associatorProdInv :: forall {k} (a :: k) b c. (HasBinaryProducts k, Ob a, Ob b, Ob c) => a && (b && c) ~> (a && b) && c+associatorProdInv = withObProd @k @b @c ((obj @a *** fst @k @b @c) &&& (snd @k @b @c . snd @k @a @(b && c)))++swapProd :: forall {k} (a :: k) b. (HasBinaryProducts k, Ob a, Ob b) => a && b ~> b && a+swapProd = snd @k @a @b &&& fst @k @a @b++type data PROD k = PR k++-- | Lifts a profunctor to the 'PROD'-wrapped kinds, where the monoidal structure is the+-- categorical product.+type Prod :: j +-> k -> PROD j +-> PROD k+data Prod p (a :: PROD k) b where+  Prod :: {unProd :: p a b} -> Prod p (PR a) (PR b)++instance (CategoryOf k) => Functor (PR :: k -> PROD k) where+  map f = Prod f++instance (Profunctor p) => Profunctor (Prod p) where+  dimap (Prod l) (Prod r) (Prod p) = Prod (dimap l r p)+  r \\ Prod f = r \\ f+instance (Promonad p) => Promonad (Prod p) where+  id = Prod id+  Prod f . Prod g = Prod (f . g)++-- | The same category as the category of @k@, but with products as the tensor.+instance (CategoryOf k) => CategoryOf (PROD k) where+  type (~>) = Prod (~>)+  type Ob a = WrappedOb PR a++instance (Representable p) => Representable (Prod p) where+  type Prod p % PR a = PR (p % a)+  index (Prod p) = Prod (index p)+  tabulate (Prod f) = Prod (tabulate f)+  repMap (Prod f) = Prod (repMap @p f)++instance (HasTerminalObject k) => HasTerminalObject (PROD k) where+  type TerminalObject = PR TerminalObject+  terminate = Prod terminate+instance (HasBinaryProducts k) => HasBinaryProducts (PROD k) where+  type a && b = PR (UN PR a && UN PR b)+  withObProd @(PR a) @(PR b) r = withObProd @k @a @b r+  fst @(PR a) @(PR b) = Prod (fst @_ @a @b)+  snd @(PR a) @(PR b) = Prod (snd @_ @a @b)+  Prod f &&& Prod g = Prod (f &&& g)+  Prod f *** Prod g = Prod (f *** g)+instance (HasInitialObject k) => HasInitialObject (PROD k) where+  type InitialObject = PR InitialObject+  initiate = Prod initiate++instance (HasProducts k, cat ~ Hom k) => MonoidalProfunctor (Prod cat) where+  one = id+  f ** g = f *** g++-- | Products as monoidal structure.+instance (HasProducts k) => Monoidal (PROD k) where+  type Unit = TerminalObject+  type a ** b = a && b+  withOb2 @(PR a) @(PR b) r = withObProd @k @a @b r+  leftUnitor = leftUnitorProd+  leftUnitorInv = leftUnitorProdInv+  rightUnitor = rightUnitorProd+  rightUnitorInv = rightUnitorProdInv+  associator @(PR a) @(PR b) @(PR c) = Prod (associatorProd @a @b @c)+  associatorInv @(PR a) @(PR b) @(PR c) = Prod (associatorProdInv @a @b @c)++instance (HasProducts k) => SymMonoidal (PROD k) where+  swap @(PR a) @(PR b) = Prod (swapProd @a @b)++type FromProd :: (k -> Type) -> (PROD k -> Type)+data FromProd f a where+  FromProd :: {unFromProd :: f a} -> FromProd f (PR a)++instance (Functor f) => Functor (FromProd f) where+  map (Prod g) (FromProd f) = FromProd (map g f)++instance MonoidalProfunctor (->) where+  one = id+  f ** g = f *** g++-- | Products as monoidal structure.+instance Monoidal Type where+  type Unit = TerminalObject+  type a ** b = a && b+  withOb2 r = r+  leftUnitor = leftUnitorProd+  leftUnitorInv = leftUnitorProdInv+  rightUnitor = rightUnitorProd+  rightUnitorInv = rightUnitorProdInv+  associator = associatorProd+  associatorInv = associatorProdInv++instance SymMonoidal Type where+  swap = swapProd++instance MonoidalProfunctor Booleans where+  one = id+  f ** g = f *** g++-- | Products as monoidal structure.+instance Monoidal BOOL where+  type Unit = TerminalObject+  type a ** b = a && b+  withOb2 @a @b = withObProd @BOOL @a @b+  leftUnitor = leftUnitorProd+  leftUnitorInv = leftUnitorProdInv+  rightUnitor = rightUnitorProd+  rightUnitorInv = rightUnitorProdInv+  associator @a @b @c = associatorProd @a @b @c+  associatorInv @a @b @c = associatorProdInv @a @b @c++instance SymMonoidal BOOL where+  swap @a @b = swapProd @a @b++data family (*!) (a :: k) (b :: k) :: k+instance (IsFreeOb (a :: FREE cs p), IsFreeOb b, HasBinaryProducts `Elem` cs) => IsFreeOb (a *! b) where+  type Lower f (a *! b) = Lower f a && Lower f b+  lowerOb @k' @f r =+    fromAll @HasBinaryProducts @cs @k' (withLowerOb @f @a (withLowerOb @f @b (withObProd @k' @(Lower f a) @(Lower f b) r)))+instance (HasBinaryProducts `Elem` cs) => HasStructure cs (p :: CAT k) HasBinaryProducts where+  data Struct HasBinaryProducts i o where+    Fst :: (Ob a, Ob b) => Struct HasBinaryProducts (a *! b) a+    Snd :: (Ob a, Ob b) => Struct HasBinaryProducts (a *! b) b+    Prd :: i ~> a -> i ~> b -> Struct HasBinaryProducts i (a *! b)+  foldStructure @f _ (Fst @a @b) = withLowerOb @f @a (withLowerOb @f @b (fst @_ @(Lower f a) @(Lower f b)))+  foldStructure @f _ (Snd @a @b) = withLowerOb @f @a (withLowerOb @f @b (snd @_ @(Lower f a) @(Lower f b)))+  foldStructure go (Prd f g) = go f &&& go g+instance (WithShow a) => Show (Struct HasBinaryProducts a b) where+  showsPrec _ Fst = P.showString "fst"+  showsPrec _ Snd = P.showString "snd"+  showsPrec d (Prd f g) =+    P.showParen (d P.> 5) P.$+      P.showsPrec 6 f . P.showString " &&& " . P.showsPrec 6 g+instance (HasBinaryProducts `Elem` cs) => HasBinaryProducts (FREE cs (p :: CAT k)) where+  type a && b = a *! b+  withObProd r = r+  fst = St Fst Nil+  snd = St Snd Nil+  f &&& g = St (Prd f g) Nil \\ f \\ g++-- | The right adjoint to the diagonal functor.+instance (HasBinaryProducts k) => Representable (Corep Diag :: (k, k) +-> k) where+  type Corep Diag % '(a, b) = a && b+  index (Corep (f :**: g)) = f &&& g+  repUniv @'(a, b) = withObProd @k @a @b (Corep (fst @k @a @b :**: snd @k @a @b))++-- | The universal property of the binary product: the projections recover the components of+-- @f '&&&' g@, and every arrow into the product is the pairing of its components.+instance Laws '[HasBinaryProducts] where+  laws =+    [ Law "fst" \ @a @b @c mor -> do+        f <- mor @a @b "f"+        g <- mor @a @c "g"+        f === fst @_ @b @c . (f &&& g)+    , Law "snd" \ @a @b @c mor -> do+        f <- mor @a @b "f"+        g <- mor @a @c "g"+        g === snd @_ @b @c . (f &&& g)+    , Law "pairing naturality" \ @a @b @c @d mor -> do+        f <- mor @a @b "f"+        g <- mor @a @c "g"+        h <- mor @d @a "h"+        (f . h) &&& (g . h) === (f &&& g) . h+    , Law "pairing the projections" \ @_ @b @c _ ->+        withObProd @_ @b @c (fst @_ @b @c &&& snd @_ @b @c === id)+    , Law "pairing uniqueness" \ @a @b @c mor -> withObProd @_ @b @c do+        p <- mor @a @(b && c) "p"+        p === (fst @_ @b @c . p) &&& (snd @_ @b @c . p)+    ]
+ src/Proarrow/Limit/Equalizer.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Equalizers: 'HasEqualizers' with 'equalize' in continuation-passing style (the equalizer object's+-- type depends on the given arrows, so it is hidden behind an existential) and 'factorEqualizer' for+-- the universal property.+module Proarrow.Limit.Equalizer where++import Proarrow.Category.Enriched.Thin (Thin)+import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..))+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Unit (Unit (..))+import Proarrow.Colimit.Initial (HasZeroObject (..))+import Proarrow.Core (CategoryOf (..), Promonad (..))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..), HasProducts, PROD, Prod (..))+import Proarrow.Object (pattern Objs)+import Prelude qualified as P++-- | Equalizers are an inherently dependently typed concept:+-- The type of the base object depends on the values of the given arrows.+-- But at runtime we can still calculate the arrow and the type, which we hide behind an existential.+class (CategoryOf k) => HasEqualizers k where+  equalize :: forall (a :: k) b r. a ~> b -> a ~> b -> (forall e. e ~> a -> r) -> r++  -- | @factorEqualizer incl h@ requires @incl@ to be mono and @h@'s image to lie within @incl@'s+  -- image; @incl@ is typically (though not necessarily) the equalizer arrow produced by 'equalize'.+  factorEqualizer :: forall (e :: k) x e'. e ~> x -> e' ~> x -> e' ~> e++instance HasEqualizers () where+  equalize Unit Unit k = k Unit+  factorEqualizer Unit Unit = Unit++-- | @factorEqualizer incl h@ requires @h@'s image to lie within @incl@'s. Since @BOOL@ is the+-- 2-element total order @FLS <= TRU@, that means @h@'s domain is @<=@ @incl@'s domain. That's always+-- true when @incl@ came from 'equalize' (which only ever produces the identity), but since 'BOOL' is+-- totally ordered we can case on the shapes directly (at most 5 are reachable, since both share a+-- codomain).+instance HasEqualizers BOOL where+  equalize = thinEqualize+  factorEqualizer Fls Fls = Fls+  factorEqualizer F2T F2T = Fls+  factorEqualizer Tru F2T = F2T+  factorEqualizer Tru Tru = Tru+  factorEqualizer F2T Tru = P.error "factorEqualizer: h's image must lie within incl's image"++instance (HasEqualizers k1, HasEqualizers k2) => HasEqualizers (k1, k2) where+  equalize (l1 :**: l2) (r1 :**: r2) k = equalize l1 r1 \f1 -> equalize l2 r2 \f2 -> k (f1 :**: f2)+  factorEqualizer (i1 :**: i2) (h1 :**: h2) = factorEqualizer i1 h1 :**: factorEqualizer i2 h2++-- | Equalizers are unchanged by making the tensor the product.+instance (HasEqualizers k) => HasEqualizers (PROD k) where+  equalize (Prod f) (Prod g) k = equalize f g \e -> k (Prod e)+  factorEqualizer (Prod incl) (Prod h) = Prod (factorEqualizer incl h)++-- | In a thin category, arrows don't carry information, so equalizers are just identities.+thinEqualize :: forall {k} (a :: k) b r. (Thin k) => a ~> b -> a ~> b -> (forall e. e ~> a -> r) -> r+thinEqualize Objs _ k = k id++-- | Standalone helper (not a class method) usable as the @default@ implementation of+-- 'Proarrow.Limit.Pullback.pullback' wherever @(HasEqualizers k, HasProducts k)@ happen to hold.+-- Not every 'Proarrow.Limit.Pullback.HasPullbacks' instance needs it or is required to have it.+pullbackDefault+  :: forall {k} (o :: k) a b r+   . (HasEqualizers k, HasProducts k) => a ~> o -> b ~> o -> (forall p. p ~> a -> p ~> b -> r) -> r+pullbackDefault f@Objs g@Objs k = equalize (f . fst @k @a @b) (g . snd @k @a @b) \e@Objs -> k (fst @k @a @b . e) (snd @k @a @b . e)++-- | Given a pullback's own legs @p1, p2@ and a compatible cone @k1, k2@ on some @q@ (with+-- @f . k1 == g . k2@ for whichever cospan @p1, p2@ are a pullback of), produces the unique+-- @q ~> p@ through which the cone factors. Standalone helper (not a class method), usable as the+-- @default@ implementation of 'Proarrow.Limit.Pullback.factorPullback' wherever+-- @(HasEqualizers k, HasProducts k)@ happen to hold, like 'pullbackDefault' itself.+factorPullbackDefault+  :: forall {k} (a :: k) b p q+   . (HasEqualizers k, HasProducts k)+  => p ~> a -> p ~> b -> q ~> a -> q ~> b -> q ~> p+factorPullbackDefault p1@Objs p2@Objs k1 k2 = factorEqualizer (p1 &&& p2) (k1 &&& k2)++kernel :: (HasEqualizers k, HasZeroObject k) => (a :: k) ~> b -> (forall e. e ~> a -> r) -> r+kernel f@Objs = equalize zero f
+ src/Proarrow/Limit/Power.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Powers (cotensors) of a category enriched in @v@: 'Powered' provides @a '^' n@, characterized by the+-- isomorphism between @a '~>' b '^' n@ and @n '~>' 'HomObj' v a b@ ('power'\/'unpower').+module Proarrow.Limit.Power where++import Data.Kind (Type)+import Prelude (($), type (~))++import Proarrow.Category.Enriched (Enriched, EnrichedProfunctor (..), GenArrow (..), HomObj, comp)+import Proarrow.Category.Enriched.Finitary (Elt (..))+import Proarrow.Category.Instance.FinHask (FINHASK, arr)+import Proarrow.Category.Instance.Opposite (OPPOSITE (..))+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Instance.Unit qualified as U+import Proarrow.Category.Monoidal (SymMonoidal (..), leftUnitorInvWith)+import Proarrow.Category.Monoidal.Cartesian (Cartesian)+import Proarrow.Category.Monoidal.Closed (Closed (..), uncurry)+import Proarrow.Core (CategoryOf (..), Ob, Profunctor (..), Promonad (..), obj, (//), type (+->))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..))+import Proarrow.Limit.Terminal (HasTerminalObject, TerminalObject, terminate)+import Proarrow.Profunctor.Representable (Representable (..))++-- | Categories powered over @v@.+class (Enriched v k) => Powered v k where+  type (a :: k) ^ (n :: v) :: k+  withObPower :: (Ob (a :: k), Ob (n :: v)) => ((Ob (a ^ n)) => r) -> r+  power :: (Ob (a :: k), Ob b) => (n ~> HomObj v a b) -> a ~> (b ^ n)+  unpower :: (Ob (b :: k), Ob n) => a ~> (b ^ n) -> n ~> HomObj v a b++mapBase :: forall {k} {v} (n :: v) (a :: k) b. (Powered v k, Ob n) => a ~> b -> a ^ n ~> b ^ n+mapBase f =+  f //+    withObPower @v @k @a @n+      ( power @v @k @(a ^ n) @b @n+          (let g = unpower @v @k @a @n id in g // comp @v @(a ^ n) @a @b . leftUnitorInvWith (underlying @v f) . g)+      )++mapPower :: forall {k} {v} (a :: k) (n :: v) m. (Powered v k, Ob a) => (n ~> m) -> a ^ m ~> a ^ n+mapPower f = withObPower @v @k @a @m (power @v @k @(a ^ m) @a @n (unpower @v @k @a id . f)) \\ f++selfPowered :: forall {v} (a :: v) b n. (Closed v, SymMonoidal v, Ob a, Ob b) => n ~> (a ~~> b) -> a ~> (n ~~> b)+selfPowered f = curry @_ @a @n @b (uncurry @a f . swap @_ @a @n) \\ f++selfUnpowered :: forall {v} (a :: v) b n. (Closed v, SymMonoidal v, Ob n, Ob b) => a ~> (n ~~> b) -> n ~> (a ~~> b)+selfUnpowered f = curry @_ @n @a @b (uncurry @n f . swap @_ @n @a) \\ f++instance Powered Type Type where+  type a ^ n = n -> a+  withObPower r = r+  power f a n = f n a+  unpower f n a = f a n++instance (Enriched v (), HomObj v '() '() ~ TerminalObject, HasTerminalObject v) => Powered v () where+  type a ^ n = '()+  withObPower r = r+  power _ = U.Unit+  unpower U.Unit = terminate++class (HomObj v '(a1, a2) '(b1, b2) ~ (HomObj v a1 b1 && HomObj v a2 b2)) => HomObjIsProduct v a1 a2 b1 b2+instance (HomObj v '(a1, a2) '(b1, b2) ~ (HomObj v a1 b1 && HomObj v a2 b2)) => HomObjIsProduct v a1 a2 b1 b2+instance+  ( Powered v j+  , Powered v k+  , Enriched v (j, k)+  , forall (a :: (j, k)) (b :: (j, k)) a1 a2 b1 b2+     . (Ob a, a ~ '(a1, a2), Ob b, b ~ '(b1, b2)) => HomObjIsProduct v a1 a2 b1 b2+  , Cartesian v+  )+  => Powered v (j, k)+  where+  type '(a1, a2) ^ n = '(a1 ^ n, a2 ^ n)+  withObPower @'(a, b) @n r = withObPower @v @j @a @n (withObPower @v @k @b @n r)+  power @'(a1, a2) @'(b1, b2) f =+    withProObj @v @(~>) @a1 @b1 $+      withProObj @v @(~>) @a2 @b2 $+        power @v @j @a1 @b1 (fst @_ @(HomObj v a1 b1) @(HomObj v a2 b2) . f)+          :**: power @v @k @a2 @b2 (snd @_ @(HomObj v a1 b1) @(HomObj v a2 b2) . f)+  unpower @'(b1, b2) @n (f :**: g) = unpower @v @j @b1 @n f &&& unpower @v @k @b2 @n g \\ f \\ g++data (p :^: n) a b where+  Power :: (Ob a, Ob b) => {unPower :: n -> p a b} -> (p :^: n) a b+instance (Profunctor p) => Profunctor (p :^: n) where+  dimap l r (Power f) = l // r // Power \n -> dimap l r (f n)+  r \\ Power{} = r+instance (CategoryOf j, CategoryOf k) => Powered Type (j +-> k) where+  type a ^ n = a :^: n+  withObPower r = r+  power f = Prof \p -> p // Power \n -> unProf (f n) p+  unpower (Prof f) n = Prof \p -> unPower (f p) n++-- | Kept with the class: 'FINHASK' is above "Proarrow.Category.Enriched", which this module needs.+instance Powered FINHASK FINHASK where+  type a ^ n = n ~~> a+  withObPower @a @n r = withObExp @_ @a @n r+  power @a @b f = selfPowered @a @b (arr unElt . f)+  unpower f = (\g -> arr Elt . g) (selfUnpowered f) \\ f++instance (Powered v k, Ob (n :: v)) => Representable (GenArrow (OP (n :: v)) :: k +-> k) where+  type GenArrow (OP n) % a = a ^ n+  index (GenArrow @a @b f) = power @v @k @a @b f+  repUniv @a = withObPower @v @k @a @n (GenArrow (unpower @v @k @a (obj @(a ^ n))))
+ src/Proarrow/Limit/Pullback.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Pullbacks: 'HasPullbacks' with 'pullback' in continuation-passing style (the pullback object's+-- type depends on the given arrows, so it is hidden behind an existential) and 'factorPullback' for+-- the universal property, defaulting to product-then-equalizer where those exist.+module Proarrow.Limit.Pullback where++import Prelude (Bool, const, ($), (==))++import Proarrow.Category.Enriched.Thin (Thin)+import Proarrow.Category.Instance.Bool (BOOL (..))+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Unit (Unit (..))+import Proarrow.Core (CategoryOf (..), Eq2, Hom, obj, (//))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..), HasProducts, PROD, Prod (..))+import Proarrow.Limit.Equalizer (HasEqualizers, factorPullbackDefault, pullbackDefault)+import Proarrow.Object (pattern Objs)++-- | Pullbacks are an inherently dependently typed concept:+-- The type of the base object depends on the values of the given arrows.+-- But at runtime we can still calculate the arrows and the type, which we hide behind an existential.+class (CategoryOf k) => HasPullbacks k where+  pullback :: forall (o :: k) a b r. a ~> o -> b ~> o -> (forall p. p ~> a -> p ~> b -> r) -> r+  default pullback+    :: forall (o :: k) a b r+     . (HasEqualizers k, HasProducts k)+    => a ~> o -> b ~> o -> (forall p. p ~> a -> p ~> b -> r) -> r+  pullback = pullbackDefault++  -- | @factorPullback p1 p2 k1 k2@ requires @k1, k2@ to be a compatible cone for whichever cospan+  -- @p1, p2@ happen to be a pullback of. @p1, p2@ need not be @pullback@'s own output.+  factorPullback :: forall (a :: k) b p q. p ~> a -> p ~> b -> q ~> a -> q ~> b -> q ~> p+  default factorPullback+    :: forall (a :: k) b p q. (HasEqualizers k, HasProducts k) => p ~> a -> p ~> b -> q ~> a -> q ~> b -> q ~> p+  factorPullback = factorPullbackDefault++instance HasPullbacks () where+  pullback Unit Unit k = k Unit Unit+  factorPullback Unit Unit Unit Unit = Unit++instance HasPullbacks BOOL where+  pullback = thinPullback++instance (HasPullbacks k1, HasPullbacks k2) => HasPullbacks (k1, k2) where+  pullback (l1 :**: l2) (r1 :**: r2) k = pullback l1 r1 \f1 g1 -> pullback l2 r2 \f2 g2 -> k (f1 :**: f2) (g1 :**: g2)+  factorPullback (p1a :**: p1b) (p2a :**: p2b) (k1a :**: k1b) (k2a :**: k2b) =+    factorPullback p1a p2a k1a k2a :**: factorPullback p1b p2b k1b k2b++-- | Pullbacks are unchanged by making the tensor the product.+instance (HasPullbacks k) => HasPullbacks (PROD k) where+  pullback (Prod f) (Prod g) k = pullback f g \p1 p2 -> k (Prod p1) (Prod p2)+  factorPullback (Prod p1) (Prod p2) (Prod k1) (Prod k2) = Prod (factorPullback p1 p2 k1 k2)++-- | In a thin category, arrows don't carry information, so pullbacks are just products.+thinPullback+  :: forall {k} (o :: k) a b r. (Thin k, HasProducts k) => a ~> o -> b ~> o -> (forall p. p ~> a -> p ~> b -> r) -> r+thinPullback l r k = l // r // withObProd @k @a @b $ k (fst @k @a @b) (snd @k @a @b)++equalizerDefault+  :: forall {k} (a :: k) b r. (HasPullbacks k, HasProducts k) => a ~> b -> a ~> b -> (forall e. e ~> a -> r) -> r+equalizerDefault f@Objs g k = pullback (obj @a &&& f) (obj @a &&& g) (const k)++kernelPair :: (HasPullbacks k) => (a :: k) ~> b -> (forall p. p ~> a -> p ~> a -> r) -> r+kernelPair f = pullback f f++isMono :: (HasPullbacks k, Eq2 (Hom k)) => (a :: k) ~> b -> Bool+isMono f = kernelPair f \l@Objs r -> l == r
+ src/Proarrow/Limit/Terminal.hs view
@@ -0,0 +1,95 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Terminal objects: 'HasTerminalObject' with the unique arrow 'terminate', instances for the base+-- kinds, and global elements @'El' a = 'TerminalObject' '~>' a@.+module Proarrow.Limit.Terminal where++import Data.Kind (Type)+import Prelude (Show, type (~))+import Prelude qualified as P++import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..))+import Proarrow.Category.Instance.Free+  ( Elem (..)+  , FREE (..)+  , Free (..)+  , HasStructure (..)+  , IsFreeOb (..)+  , Lower+  , withLowerOb+  )+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Instance.Unit qualified as U+import Proarrow.Category.Monoidal (Monoidal (..))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), obj, type (+->))+import Proarrow.Profunctor.Instance.Terminal (TerminalProfunctor (..))+import Proarrow.Profunctor.Representable (Representable (..))+import Proarrow.Tools.Laws (Law (..), Laws (..), (===))++class (CategoryOf k, Ob (TerminalObject :: k)) => HasTerminalObject k where+  type TerminalObject :: k+  terminate :: (Ob (a :: k)) => a ~> TerminalObject++terminate' :: forall {k} a a'. (HasTerminalObject k) => (a :: k) ~> a' -> a ~> TerminalObject+terminate' a = terminate @k @a' . a \\ a++-- | The type of elements of `a`.+type El a = TerminalObject ~> a++-- | The constant arrow at an element: 'terminate', then the element.+const :: forall {k} (a :: k) b. (HasTerminalObject k, Ob a) => El b -> a ~> b+const u = u . terminate @k @a++instance HasTerminalObject Type where+  type TerminalObject = ()+  terminate _ = ()++instance HasTerminalObject () where+  type TerminalObject = '()+  terminate = U.Unit++instance HasTerminalObject BOOL where+  type TerminalObject = TRU+  terminate @a = case obj @a of+    Fls -> F2T+    Tru -> Tru++instance (HasTerminalObject j, HasTerminalObject k) => HasTerminalObject (j, k) where+  type TerminalObject = '(TerminalObject, TerminalObject)+  terminate = terminate :**: terminate++instance (CategoryOf j, CategoryOf k) => HasTerminalObject (j +-> k) where+  type TerminalObject = TerminalProfunctor+  terminate = Prof \a -> TerminalProfunctor \\ a++instance (HasTerminalObject k, CategoryOf j) => Representable (TerminalProfunctor :: j +-> k) where+  type TerminalProfunctor % x = TerminalObject+  index TerminalProfunctor = terminate+  tabulate f = TerminalProfunctor \\ f+  repMap _ = id++class ((Unit :: k) ~ TerminalObject, HasTerminalObject k, Monoidal k) => Semicartesian k+instance ((Unit :: k) ~ TerminalObject, HasTerminalObject k, Monoidal k) => Semicartesian k++data family TermF :: k+instance (HasTerminalObject `Elem` cs) => IsFreeOb (TermF :: FREE cs p) where+  type Lower f TermF = TerminalObject+  lowerOb @k' @_ r = fromAll @HasTerminalObject @cs @k' r+instance (HasTerminalObject `Elem` cs) => HasStructure cs (p :: CAT k) HasTerminalObject where+  data Struct HasTerminalObject a b where+    Terminate :: (Ob a) => Struct HasTerminalObject a TermF+  foldStructure @f _ (Terminate @a) = withLowerOb @f @a terminate+instance Show (Struct HasTerminalObject a b) where+  showsPrec _ Terminate = P.showString "terminate"+instance (HasTerminalObject `Elem` cs) => HasTerminalObject (FREE cs (p :: CAT k)) where+  type TerminalObject = TermF+  terminate = St Terminate Nil++-- | Every arrow into the terminal object is 'terminate'.+instance Laws '[HasTerminalObject] where+  laws =+    [ Law "uniqueness" \ @a mor -> do+        g <- mor @a @TerminalObject "g"+        g === terminate+    ]
+ src/Proarrow/Monoid.hs view
@@ -0,0 +1,383 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Monoids and comonoids internal to a monoidal category: a 'Monoid' @m@ has @'mempty' :: 'Unit' '~>' m@+-- and @'mappend' :: m '**' m '~>' m@; dually a 'Comonoid' has 'counit' and 'comult'. Monoids in+-- 'Data.Kind.Type' are the Prelude monoids, and in a cartesian category every object is a comonoid.+module Proarrow.Monoid where++import Data.Kind (Constraint, Type)+import Data.Type.Nat (SNat (..), SNatI, snat)+import Prelude qualified as P++import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..))+import Proarrow.Category.Instance.Free (Elems, FREE, HasStructure (..), Lower, withLowerOb)+import Proarrow.Category.Instance.Free qualified as F+import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))+import Proarrow.Category.Monoidal+  ( Monoidal (..)+  , MonoidalProfunctor (..)+  , NFold+  , NFoldS+  , SymMonoidal (..)+  , Tensor+  , UnitF+  , swapInner+  , (**)+  , type (**!)+  )+import Proarrow.Category.Monoidal.Action (Act, ActionAt, CoprodAction, MonoidalAction (..), actHom)+import Proarrow.Category.Monoidal.Closed (Closed (..), Exp)+import Proarrow.Category.Monoidal.Strength (Strong (..))+import Proarrow.Category.Monoidal.Strictified (Strictified (..), obj1)+import Proarrow.Colimit.BinaryCoproduct+  ( COPROD (..)+  , Coprod (..)+  , HasBinaryCoproducts (..)+  , HasBiproducts (..)+  , HasCoproducts+  , codiag+  )+import Proarrow.Colimit.Initial (HasInitialObject (..), HasZeroObject (..))+import Proarrow.Core (CAT, CategoryOf (..), Kind, Promonad (..), obj, (//), type (+->))+import Proarrow.Object (pattern Objs)+import Proarrow.Profunctor.Corepresentable (Corep (..))+import Proarrow.Profunctor.Instance.Constant (Constant)+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Representable (Rep (..))+import Proarrow.Tools.Laws (Law (..), Laws (..), (===))++-- | A monoid object in a monoidal category: a unit and an (associative, unital) multiplication+-- for the object @m@. At @k = Type@ (with tensor @(,)@) this is the ordinary 'P.Monoid'.+type Monoid :: forall {k}. k -> Constraint+class (Monoidal k, Ob m) => Monoid (m :: k) where+  mempty :: Unit ~> m+  mappend :: m ** m ~> m++combine :: (Monoid m) => Unit ~> m -> Unit ~> m -> Unit ~> m+combine f g = mappend . (f ** g) . leftUnitorInv++memptyS :: (Monoid m) => '[] ~> '[m]+memptyS = Str mempty++mappendS :: (Monoid m) => '[m, m] ~> '[m]+mappendS = Str mappend++-- | A law-only marker class for monoids whose multiplication commutes:+-- @'mappend' . 'swap' = 'mappend'@.+class (Monoid m, SymMonoidal k) => CommutativeMonoid (m :: k)++instance (P.Monoid m) => Monoid (m :: Type) where+  mempty () = P.mempty+  mappend = P.uncurry (P.<>)+instance CommutativeMonoid ()++instance Monoid TRU where+  mempty = Tru+  mappend = Tru+instance CommutativeMonoid TRU++newtype GenElt x m = GenElt (x ~> m)++instance (Monoid m, Comonoid (x :: k)) => P.Semigroup (GenElt x (m :: k)) where+  GenElt f <> GenElt g = GenElt (mappend . (f ** g) . comult)+instance (Monoid m, Comonoid (x :: k)) => P.Monoid (GenElt x (m :: k)) where+  mempty = GenElt (mempty . counit)++instance (HasCoproducts k, Ob a) => Monoid (COPR (a :: k)) where+  mempty = Coprod initiate+  mappend = Coprod codiag++memptyAct :: forall {m} {c} t (a :: m) (n :: c). (MonoidalAction t, Monoid a, Ob n) => n ~> Act t a n+memptyAct = actHom @t (mempty @a) (obj @n) . unitorInv @t++mappendAct+  :: forall {m} {c} t (a :: m) (n :: c). (MonoidalAction t, Monoid a, Ob n) => Act t a (Act t a n) ~> Act t a n+mappendAct = actHom @t (mappend @a) (obj @n) . multiplicatorInv @t @a @a @n++-- | A comonoid object: an object that can be discarded ('counit') and copied ('comult').+type Comonoid :: forall {k}. k -> Constraint+class (Monoidal k, Ob c) => Comonoid (c :: k) where+  counit :: c ~> Unit+  comult :: c ~> c ** c++-- | A law-only marker for comonoids whose comultiplication cocommutes: @'swap' . 'comult' = 'comult'@.+-- Dual to 'CommutativeMonoid'.+class (Comonoid c, SymMonoidal k) => CocommutativeComonoid (c :: k)++counitS :: (Comonoid c) => '[c] ~> '[]+counitS = Str counit++comultS :: (Comonoid c) => '[c] ~> '[c, c]+comultS = Str comult++-- | A comonoid structure on @c@ carried as a value. @Unit@ and @('**')@ are type families and so+-- cannot head a 'Comonoid' instance, yet the unit is a comonoid and, in a symmetric monoidal+-- category, so is a tensor of comonoids. 'unitComonoid' and 'tensorComonoid' say so at the value+-- level, so that 'Proarrow.Optic.MonoidalLens.withMonLens' can hand back the comonoid of a+-- composite residual (cf. 'Proarrow.Optic.Action.withAlgP', which passes algebras the same way).+type ComonoidOn :: forall {k}. k -> Type+data ComonoidOn (c :: k) = ComonoidOn {counitOn :: c ~> Unit, comultOn :: c ~> c ** c}++-- | The comonoid structure of a 'Comonoid' instance, as a value.+comonoidOn :: forall {k} (c :: k). (Comonoid c) => ComonoidOn c+comonoidOn = ComonoidOn counit comult++-- | The unit is a comonoid, via the unitor.+unitComonoid :: forall {k}. (Monoidal k) => ComonoidOn (Unit :: k)+unitComonoid = ComonoidOn id (leftUnitorInv @k @Unit)++-- | In a symmetric monoidal category the tensor of two comonoids is a comonoid: counit both+-- halves, or comultiply both halves and swap the inner pair.+tensorComonoid :: forall {k} (a :: k) b. (SymMonoidal k) => ComonoidOn a -> ComonoidOn b -> ComonoidOn (a ** b)+tensorComonoid (ComonoidOn ca@Objs ma) (ComonoidOn cb@Objs mb) =+  ComonoidOn (leftUnitor @k @Unit . (ca ** cb)) (swapInner @a @a @b @b . (ma ** mb))++instance Comonoid (a :: Type) where+  counit _ = ()+  comult a = (a, a)+instance CocommutativeComonoid (a :: Type)++instance Comonoid '() where+  counit = id+  comult = id+instance CocommutativeComonoid '()++instance (Ob a) => Comonoid (a :: BOOL) where+  counit = case obj @a of+    Fls -> F2T+    Tru -> Tru+  comult = case obj @a of+    Fls -> Fls+    Tru -> Tru+instance (Ob a) => CocommutativeComonoid (a :: BOOL)++counitAct :: forall {m} {c} t (a :: m) (n :: c). (MonoidalAction t, Comonoid a, Ob n) => Act t a n ~> n+counitAct = unitor @t . actHom @t (counit @a) (obj @n)++comultAct+  :: forall {m} {c} t (a :: m) (n :: c). (MonoidalAction t, Comonoid a, Ob n) => Act t a n ~> Act t a (Act t a n)+comultAct = multiplicator @t @a @a @n . actHom @t (comult @a) (obj @n)++-- | @'Supplies' c k@ says that every object of the category @k@ satisfies the constraint @c@,+-- e.g. @'Supplies' 'Comonoid' k@ for a category in which every object can be copied and discarded.+-- The constraint comes first (at a higher-rank kind) so that a partial application like+-- @'Supplies' 'Comonoid'@ has kind @Kind -> Constraint@ and can appear in a free category's+-- structure list ("Proarrow.Category.Instance.Free"). Instances are necessarily per-@c@ (an+-- instance variable cannot have a higher-rank kind); each follows the shape of the 'Comonoid' one.+type Supplies :: (forall j. j -> Constraint) -> Kind -> Constraint+class (forall (a :: k). (Ob a) => c a) => Supplies c k++instance (forall (a :: k). (Ob a) => Comonoid a) => Supplies Comonoid k++instance (forall (a :: k). (Ob a) => CocommutativeComonoid a) => Supplies CocommutativeComonoid k++instance (forall (a :: k). (Ob a) => Monoid a) => Supplies Monoid k++instance (forall (a :: k). (Ob a) => CommutativeMonoid a) => Supplies CommutativeMonoid k++instance (Comonoid c) => Monoid (OP c) where+  mempty = Op counit+  mappend = Op comult+instance (CocommutativeComonoid c) => CommutativeMonoid (OP c)++instance (Monoid c) => Comonoid (OP c) where+  counit = Op mempty+  comult = Op mappend+instance (CommutativeMonoid c) => CocommutativeComonoid (OP c)++instance (HasZeroObject k, HasBiproducts k, Ob (a :: k), Ob b) => P.Semigroup (Id a b) where+  Id f <> Id g = Id (sum f g)+instance (HasZeroObject k, HasBiproducts k, Ob (a :: k), Ob b) => P.Monoid (Id a b) where+  mempty = Id zero+instance (HasZeroObject k, HasBiproducts k, Ob (a :: k), Ob b) => CommutativeMonoid (Id a b)++instance (Monoidal k, Monoid r) => MonoidalProfunctor (Rep (Constant r) :: k +-> k) where+  one = Rep mempty+  Rep @x l ** Rep @y r = withOb2 @k @x @y (Rep (mappend . (l ** r)))+instance (HasCoproducts k, Ob r) => MonoidalProfunctor (Coprod (Rep (Constant r)) :: COPROD k +-> COPROD k) where+  one = Coprod (Rep initiate)+  Coprod @_ @_ @x (Rep l) ** Coprod @_ @_ @y (Rep r) = withObCoprod @k @x @y (Coprod (Rep (l ||| r)))+instance (Monoidal k, Comonoid r) => MonoidalProfunctor (Corep (Constant r) :: k +-> k) where+  one = Corep counit+  Corep @x l ** Corep @y r = withOb2 @k @x @y (Corep ((l ** r) . comult))++-- | Tensoring with a monoid, @m ** -@, is an applicative functor: the monoid's unit is @pure@ and+-- its multiplication is @<*>@. Rendered on the representable profunctor @'Rep' ('ActionAt' 'Tensor' m)@+-- (legs @a ~> m ** b@) this is a 'Proarrow.Category.Monoidal.Distributive.StrongDistributiveProfunctor',+-- the Writer applicative of the literature. (The 'Constant' instances above are the degenerate+-- case @b = Unit@.)+instance (SymMonoidal k, Monoid (m :: k)) => MonoidalProfunctor (Rep (ActionAt Tensor m) :: k +-> k) where+  one = Rep (memptyAct @Tensor @m @Unit)+  Rep @x2 l ** Rep @y2 r =+    l // r // withOb2 @k @x2 @y2 (Rep ((mappend @m ** obj @(x2 ** y2)) . swapInner @m @x2 @m @y2 . (l ** r)))++instance+  (Monoidal k, HasCoproducts k, Ob (m :: k))+  => MonoidalProfunctor (Coprod (Rep (ActionAt Tensor m)) :: COPROD k +-> COPROD k)+  where+  one = withOb2 @k @m @InitialObject (Coprod (Rep initiate))+  Coprod (Rep @x2 l) ** Coprod (Rep @y2 r) =+    withObCoprod @k @x2 @y2 (Coprod (Rep ((obj @m ** lft @k @x2 @y2) . l ||| (obj @m ** rgt @k @x2 @y2) . r)))+instance (SymMonoidal k, Ob (m :: k)) => Strong Tensor (Rep (ActionAt Tensor m) :: k +-> k) where+  act @a (Rep @y p) =+    p //+      withOb2 @k @a @y (Rep (associator @k @m @a @y . (swap @k @a @m ** obj @y) . associatorInv @k @a @m @y . (obj @a ** p)))+instance (Monoidal k, HasCoproducts k, Monoid (m :: k)) => Strong CoprodAction (Rep (ActionAt Tensor m) :: k +-> k) where+  act @(COPR a) (Rep @y p) =+    p // withObCoprod @k @a @y (Rep ((obj @m ** lft @k @a @y) . memptyAct @Tensor @m @a ||| (obj @m ** rgt @k @a @y) . p))++-- | The exponential by a comonoid, @m ~~> -@, is an applicative functor (the reader applicative):+-- @pure@ discards the argument with the counit and @<*>@ duplicates it with the comultiplication.+-- Rendered on @'Rep' ('Exp' m)@ (legs @a ~> (m ~~> b)@) this is a+-- 'Proarrow.Category.Monoidal.Distributive.StrongDistributiveProfunctor', so a+-- 'Proarrow.Optic.Grate.Grate' is a 'Proarrow.Optic.Kaleidoscope.Kaleidoscope'.+instance (Closed k, SymMonoidal k, Comonoid (m :: k)) => MonoidalProfunctor (Rep (Exp m) :: k +-> k) where+  one = Rep (curry @k @Unit @m (leftUnitor @k @Unit . (obj @Unit ** counit @m)))+  Rep @x2 @_ @x1 l ** Rep @y2 @_ @y1 r =+    l //+      r //+        withOb2 @k @x1 @y1+          ( withOb2 @k @x2 @y2+              ( withObExp @k @m @x2+                  ( withObExp @k @m @y2+                      ( Rep+                          ( curry @k @(x1 ** y1) @m+                              ( (apply @k @m @x2 ** apply @k @m @y2)+                                  . swapInner @(m ~~> x2) @(m ~~> y2) @m @m+                                  . ((l ** r) ** comult @m)+                              )+                          )+                      )+                  )+              )+          )++instance (Closed k, HasCoproducts k, Ob (m :: k)) => MonoidalProfunctor (Coprod (Rep (Exp m)) :: COPROD k +-> COPROD k) where+  one = withObExp @k @m @InitialObject (Coprod (Rep initiate))+  Coprod (Rep @x2 l) ** Coprod (Rep @y2 r) =+    withObCoprod @k @x2 @y2 (Coprod (Rep ((lft @k @x2 @y2 ^^^ obj @m) . l ||| (rgt @k @x2 @y2 ^^^ obj @m) . r)))+instance (Closed k, SymMonoidal k, Ob (m :: k)) => Strong Tensor (Rep (Exp m) :: k +-> k) where+  act @a (Rep @y @_ @x p) =+    p //+      withOb2 @k @a @x+        ( withOb2 @k @a @y+            ( withObExp @k @m @y+                (Rep (curry @k @(a ** x) @m ((obj @a ** apply @k @m @y) . associator @k @a @(m ~~> y) @m . ((obj @a ** p) ** obj @m))))+            )+        )+instance (Closed k, HasCoproducts k, Comonoid (m :: k)) => Strong CoprodAction (Rep (Exp m) :: k +-> k) where+  act @(COPR a) (Rep @y p) =+    p //+      withObCoprod @k @a @y+        ( withObExp @k @m @a+            ( withObExp @k @m @y+                ( Rep+                    ((lft @k @a @y ^^^ obj @m) . curry @k @a @m (rightUnitor @k @a . (obj @a ** counit @m)) ||| (rgt @k @a @y ^^^ obj @m) . p)+                )+            )+        )++-- | The free-category structure for @'Supplies' 'Monoid'@: every object gets formal 'mappend'+-- ('Join') and 'mempty' ('Sprout') generators, interpreted by 'foldStructure' through the+-- target's own supply.+instance ('[Supplies Monoid, Monoidal] `Elems` cs) => HasStructure cs (p :: CAT k) (Supplies Monoid) where+  data Struct (Supplies Monoid) i o where+    Join :: (Ob a) => Struct (Supplies Monoid) (a **! a) a+    Sprout :: (Ob a) => Struct (Supplies Monoid) UnitF a+  foldStructure @f _ (Join @a) = withLowerOb @f @a (mappend @(Lower f a))+  foldStructure @f _ (Sprout @a) = withLowerOb @f @a (mempty @(Lower f a))++instance P.Show (Struct (Supplies Monoid) a b) where+  showsPrec _ Join = P.showString "mappend"+  showsPrec _ Sprout = P.showString "mempty"++-- | The free-category structure for @'Supplies' 'Comonoid'@, dually: formal 'comult' ('Fork') and+-- 'counit' ('Prune') generators for every object.+instance ('[Supplies Comonoid, Monoidal] `Elems` cs) => HasStructure cs (p :: CAT k) (Supplies Comonoid) where+  data Struct (Supplies Comonoid) i o where+    Fork :: (Ob a) => Struct (Supplies Comonoid) a (a **! a)+    Prune :: (Ob a) => Struct (Supplies Comonoid) a UnitF+  foldStructure @f _ (Fork @a) = withLowerOb @f @a (comult @(Lower f a))+  foldStructure @f _ (Prune @a) = withLowerOb @f @a (counit @(Lower f a))++instance P.Show (Struct (Supplies Comonoid) a b) where+  showsPrec _ Fork = P.showString "comult"+  showsPrec _ Prune = P.showString "counit"++instance+  ('[Supplies Monoid, Monoidal] `Elems` cs, Ob (a :: FREE cs (p :: CAT k)))+  => Monoid (a :: FREE cs p)+  where+  mempty = F.St Sprout F.Nil+  mappend = F.St Join F.Nil++-- | The free supply is commutative only up to interpretation ('FREE' has no equations); the marker+-- holds because every @'Proarrow.Category.Instance.Free.fold'@ of these arrows into a target lands in that target's commutative+-- monoid.+instance (Monoid (a :: FREE cs p), SymMonoidal (FREE cs p)) => CommutativeMonoid (a :: FREE cs p)++instance+  ('[Supplies Comonoid, Monoidal] `Elems` cs, Ob (a :: FREE cs (p :: CAT k)))+  => Comonoid (a :: FREE cs p)+  where+  counit = F.St Prune F.Nil+  comult = F.St Fork F.Nil++instance (Comonoid (a :: FREE cs p), SymMonoidal (FREE cs p)) => CocommutativeComonoid (a :: FREE cs p)++-- | Collapse an @n@-fold tensor power of a monoid with 'mappend', bottoming out at 'mempty'.+fanIn :: forall n a. (SNatI n, Monoid a) => NFold n a ~> a+fanIn = case snat @n of+  SZ -> mempty+  SS @n' -> mappend @a . (obj @a ** fanIn @n' @a)++-- | Dually, build an @n@-fold tensor power of a comonoid with 'comult', bottoming out at 'counit'.+fanOut :: forall n a. (SNatI n, Comonoid a) => a ~> NFold n a+fanOut = case snat @n of+  SZ -> counit+  SS @n' -> (obj @a ** fanOut @n' @a) . comult @a++-- | The 'Proarrow.Category.Monoidal.Strictified.Strictified' counterpart of 'fanIn'.+fanInS :: forall n a. (SNatI n, Monoid a) => NFoldS n a ~> '[a]+fanInS =+  case snat @n of+    SZ -> Str mempty+    SS @n' -> mappendS @a . (obj1 @a ** fanInS @n' @a)++-- | The 'Proarrow.Category.Monoidal.Strictified.Strictified' counterpart of 'fanOut'.+fanOutS :: forall n a. (SNatI n, Comonoid a) => '[a] ~> NFoldS n a+fanOutS =+  case snat @n of+    SZ -> Str counit+    SS @n' -> (obj1 @a ** fanOutS @n' @a) . comultS @a++-- | In a category that supplies monoids, every object is one: 'mempty' is a unit for 'mappend' (up+-- to the unitors), and 'mappend' is associative (up to the associator).+instance Laws '[Monoidal, Supplies Monoid] where+  laws =+    [ Law "left unit" \ @a _ -> withOb2 @_ @Unit @a (leftUnitor @_ @a === mappend @a . (mempty @a ** obj @a))+    , Law "right unit" \ @a _ -> withOb2 @_ @a @Unit (rightUnitor @_ @a === mappend @a . (obj @a ** mempty @a))+    , Law "associativity" \ @a _ ->+        withOb2 @_ @a @a P.$+          mappend @a . (mappend @a ** obj @a) === mappend @a . (obj @a ** mappend @a) . associator @_ @a @a @a+    ]++-- | In a category that supplies comonoids, every object is one: 'counit' is a unit for 'comult', and+-- 'comult' is coassociative.+instance Laws '[Monoidal, Supplies Comonoid] where+  laws =+    [ Law "left counit" \ @a _ -> withOb2 @_ @Unit @a (leftUnitorInv @_ @a === (counit @a ** obj @a) . comult @a)+    , Law "right counit" \ @a _ -> withOb2 @_ @a @Unit (rightUnitorInv @_ @a === (obj @a ** counit @a) . comult @a)+    , Law "coassociativity" \ @a _ ->+        withOb2 @_ @a @a P.$+          associator @_ @a @a @a . (comult @a ** obj @a) . comult @a === (obj @a ** comult @a) . comult @a+    ]++-- | The supplied monoids are commutative: 'mappend' is unchanged by 'swap'.+instance Laws '[Monoidal, SymMonoidal, Supplies CommutativeMonoid] where+  laws = [Law "commutativity" \ @a _ -> withOb2 @_ @a @a (mappend @a === mappend @a . swap @_ @a @a)]++-- | The supplied comonoids are cocommutative: 'comult' is unchanged by 'swap'.+instance Laws '[Monoidal, SymMonoidal, Supplies CocommutativeComonoid] where+  laws = [Law "cocommutativity" \ @a _ -> withOb2 @_ @a @a (comult @a === swap @_ @a @a . comult @a)]
+ src/Proarrow/Object.hs view
@@ -0,0 +1,40 @@+-- | Working with objects through their identity arrows: 'Obj' @a@ is @a '~>' a@ used as a witness that+-- @a@ is an object, with 'obj', 'src' and 'tgt' to produce them and the 'Obj'\/'Objs' pattern synonyms+-- to recover 'Ob' constraints from arrows and profunctor values.+module Proarrow.Object+  ( Obj+  , pattern Obj+  , pattern Objs+  , obj+  , src+  , tgt+  , Ob'+  , VacuousOb+  , objDicts+  , ObjDict (..)+  ) where++import Data.Kind (Type)++import Proarrow.Core (CategoryOf (..), Ob', Obj, Profunctor, VacuousOb, obj, src, tgt, (\\))++type ObjDict :: forall {k}. k -> Type+data ObjDict a where+  ObjDict :: (Ob a) => ObjDict a++objDicts :: (Profunctor p) => p a a' -> (ObjDict a, ObjDict a')+objDicts a = (ObjDict \\ a, ObjDict \\ a)++pattern Obj :: (CategoryOf k) => (Ob (a :: k)) => Obj a+pattern Obj <- (objDicts -> (ObjDict, ObjDict))+  where+    Obj = obj++{-# COMPLETE Obj #-}++-- | Matching a profunctor value @p a b@ against 'Objs' brings @('Ob' a, 'Ob' b)@ into scope. This+-- is the pattern form of '(\\)', handy in function equations.+pattern Objs :: (Profunctor p) => (Ob a, Ob b) => p a b+pattern Objs <- (objDicts -> (ObjDict, ObjDict))++{-# COMPLETE Objs #-}
+ src/Proarrow/Optic.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | The encoding-agnostic core of the optics machinery: the 'Optic' type (a rank-2 profunctor+-- transformation @forall p. c p => p a b -> p s t@), optic flavors as witness-pair constraints+-- ('FLAVOR') with subtyping via flavor superclasses, carrier strength ('Prostrong'), and the existential+-- encoding 'ExOptic' with 'ex2prof'\/'prof2ex'\/'convert' mediating between the two. Also home to+-- the flavor-generic combinators 'iso', 're' and '(%)'. The concrete optic kinds live in the+-- @Proarrow.Optic.*@ submodules, and the user-facing vocabulary (with the full subtyping lattice+-- drawn out) is re-exported from "Proarrow.Optics".+module Proarrow.Optic where++import Data.Kind (Constraint)+import Prelude (type (~))++import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..), UnOp (..))+import Proarrow.Core+  ( CAT+  , CategoryOf (..)+  , Kind+  , Profunctor (..)+  , Promonad (..)+  , dimapDefault+  , (:~>)+  , type (+->)+  , type (:&&:)+  )+import Proarrow.Object (pattern Objs)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))++type data OPTIC (j :: Kind) (k :: Kind) (c :: j +-> k -> Constraint) = OPT k j+type family OptL (p :: OPTIC j k c) where+  OptL (OPT j k) = j+type family OptR (p :: OPTIC j k c) where+  OptR (OPT j k) = k+type Optic_ :: CAT (OPTIC j k c)+data Optic_ ab st where+  Optic+    :: (Ob a, Ob b, Ob s, Ob t)+    => {unOptic :: forall p. (c p, Profunctor p) => p a b -> p s t} -> Optic_ (OPT a b :: OPTIC j k c) (OPT s t)++instance (CategoryOf j, CategoryOf k) => Profunctor (Optic_ :: CAT (OPTIC j k c)) where+  dimap = dimapDefault+  r \\ Optic{} = r+instance (CategoryOf j, CategoryOf k) => Promonad (Optic_ :: CAT (OPTIC j k c)) where+  id = Optic id+  Optic n . Optic m = Optic (n . m)++-- | Optics form a category: an object @'OPT' s t@ pairs the object @s@ an optic reads from+-- (contravariant) with the object @t@ it writes back (covariant), an arrow+-- @'OPT' a b '~>' 'OPT' s t@ is a @c@-flavored optic with focus @a@\/@b@ inside @s@\/@t@, and+-- composition is optic composition.+instance (CategoryOf j, CategoryOf k) => CategoryOf (OPTIC j k c) where+  type (~>) = Optic_+  type Ob opt = (opt ~ OPT (OptL opt) (OptR opt), Ob (OptL opt), Ob (OptR opt))++type Optic (c :: j +-> k -> Constraint) s t a b = Optic_ (OPT a b) (OPT s t :: OPTIC j k c)+type Optic' c s a = Optic c s s a a++infixl 9 %++-- | Compose two optics, of any (possibly different) flavors or encodings. The composite's constraint+-- is the conjunction ':&&:', so the composite is usable at the meet of the two flavors'+-- capabilities: a lens composed with a prism previews, folds, traverses and sets, but+-- no longer views or reviews. Use 'convert' to name the composite at a single flavor for+-- storage, e.g. @'convert' (l % p) :: 'Proarrow.Optic.AffineTraversal.AffineTraversal' s t a b@.+(%) :: Optic c1 s t a b -> Optic c2 a b c d -> Optic (c1 :&&: c2) s t c d+Optic n % Optic m = Optic (n . m)++-- | An iso in the profunctor-class-flavored encoding (the @P@-prefix convention: plain optic+-- names belong to the 'Prostrong'-flavored encoding, @P@-prefixed ones to the+-- profunctor-class-flavored one). Convert with 'Proarrow.Optic.Iso.fromPIso' and+-- 'Proarrow.Optic.Iso.toPIso'.+type PIso s t a b = Optic Profunctor s t a b++type PIso' s a = PIso s s a a++-- | Create an isomorphism from two arrows, at any optic constraint. This doesn't check that the+-- arrows are inverses!+--+-- The same @iso@ builds a 'Proarrow.Optic.Iso.Iso', a 'PIso', a+-- 'Proarrow.Optic.Traversal.PTraversal', ... depending on the type it is used at; since @c@ is+-- only determined by the use site, bind the result with a type signature.+iso+  :: forall {j} {k} c (s :: k) (t :: j) a b+   . (CategoryOf j, CategoryOf k)+  => (s ~> a) -> (b ~> t) -> Optic c s t a b+iso sa bt = Optic (dimap sa bt) \\ sa \\ bt++type FLAVOR j k = (k +-> k) -> (j +-> j) -> Constraint++-- | A flavor: a class of witness pairs that is closed under composition and contains the identity+-- pair. This is the monoidal structure of the residuals, with @(Id, Id)@ as unit and+-- @(f :.: g, g' :.: f')@ (note the reversal on the right) as tensor.+type Flavor :: forall {j} {k}. FLAVOR j k -> Constraint+class (forall f f' g g'. (w f f', w g g') => w (f :.: g) (g' :.: f'), w Id Id) => Flavor w where+  composeFlavor :: forall f f' g g' r. (w f f', w g g') => ((w (f :.: g) (g' :.: f')) => r) -> r++instance (forall f f' g g'. (w f f', w g g') => w (f :.: g) (g' :.: f'), w Id Id) => Flavor w where+  composeFlavor r = r++-- | @w p q@, as a class with a single instance instead of a bare constraint. The subtyping+-- quantified constraint is spelled @forall p q. v p q => Sub w p q@ because GHC solves the head of+-- a quantified constraint from a superclass of its premise only when that superclass is strictly+-- smaller than the head, which a bare @w p q@ head never is. Behind the 'Sub' instance @w p q@ is+-- an ordinary wanted, solved from the superclasses of @v p q@. 'sub' hands it back as a given.+--+-- 'Sub' has no superclass @w p q@: with one, a quantified given+-- @forall p q. w p q => Sub IsoFl p q@ would reach @'Profunctor' p@ through the flavor+-- superclasses, and GHC would reject the ordinary @Profunctor@ instances as overlapping.+type Sub :: forall {j} {k}. FLAVOR j k -> FLAVOR j k+class Sub w p q where+  sub :: ((w p q) => r) -> r++instance (w p q) => Sub w p q where+  sub r = r++-- | The carrier @p@ is @w@-strong: a Tambara module for the flavor @w@. 'proact' absorbs a+-- @w@-witness pair @(f, g)@ sandwiching @p@ back into @p@, so that an optic built from that+-- witness can distribute the carrier. The name is the profunctor (\"pro\") version of+-- "Proarrow.Category.Monoidal.Strength"'s 'Proarrow.Category.Monoidal.Strength.Strong': its+-- @proact@ specializes to @act@ for certain 'Rep'/'Corep' pairs and to @coact@ for+-- certain 'Corep'/'Rep' ones.+type Prostrong :: forall {j} {k}. FLAVOR j k -> (j +-> k) -> Constraint+class (Profunctor p, CategoryOf j, CategoryOf k) => Prostrong w (p :: j +-> k) where+  proact :: (w f g, Profunctor f, Profunctor g) => f :.: p :.: g :~> p++-- | The existential encoding of an optic.+type ExOptic :: forall {j} {k}. FLAVOR j k -> k -> j -> j +-> k+data ExOptic w a b s t where+  ExOptic+    :: forall {j} {k} {w :: FLAVOR j k} (p :: k +-> k) (q :: j +-> j) (s :: k) (t :: j) a b+     . (w p q, Profunctor p, Profunctor q) => p s a -> q b t -> ExOptic w a b s t++instance (CategoryOf j, CategoryOf k) => Profunctor (ExOptic w a b :: j +-> k) where+  dimap l r (ExOptic p q) = ExOptic (lmap l p) (rmap r q)+  r \\ ExOptic p q = r \\ p \\ q++-- | The free @w@-strong profunctor is @v@-strong for every subflavor @v@ of @w@. With it 'convert'+-- and 'withLegs' accept optics of any encoding (composites included). This one bridge instance+-- replaces a per-carrier one for each flavor.+instance (CategoryOf j, CategoryOf k, forall p q. (v p q) => Sub w p q, Flavor w) => Prostrong v (ExOptic w a b :: j +-> k) where+  proact @f @g (f :.: ExOptic @p @q p q :.: g) = sub @w @f @g (composeFlavor @w @f @g @p @q (ExOptic (f :.: p) (q :.: g)))++-- | Build a 'Prostrong'-flavored optic from a @w@-witness pair (the two legs @p s a@ and @q b t@)+-- by wrapping them around the carrier with one 'proact'. Every optic constructor+-- ('Proarrow.Optic.Lens.lens', 'Proarrow.Optic.Prism.prism', ...) is @legs2prof@ of its generating+-- witness pair; 'ex2prof' is the same on the packaged 'ExOptic'.+legs2prof+  :: forall {j} {k} (w :: FLAVOR j k) p q (s :: k) (t :: j) a b+   . (CategoryOf j, CategoryOf k, w p q, Profunctor p, Profunctor q)+  => p s a -> q b t -> Optic (Prostrong w) s t a b+legs2prof p q = Optic (\pab -> proact @w (p :.: pab :.: q)) \\ p \\ q++ex2prof+  :: forall {j} {k} {w :: FLAVOR j k} (a :: k) (b :: j) (s :: k) (t :: j)+   . (CategoryOf j, CategoryOf k) => ExOptic w a b s t -> Optic (Prostrong w) s t a b+ex2prof (ExOptic p q) = legs2prof @w p q++-- | Run an optic, in any encoding, at its own witness pair (the Pastro-Street move): a+-- 'Prostrong'-flavored optic discharges @c ('ExOptic' w a b)@ through the bridge instance above+-- (i.e. @forall p q. v p q => 'Sub' w p q@), a '(%)'-composite one conjunct at a time, and a+-- profunctor-class-flavored one through the carrier's own instances of its class.+prof2ex+  :: forall {j} {k} w c (s :: k) (t :: j) a b+   . (CategoryOf j, CategoryOf k, Flavor w, (Ob a, Ob b) => c (ExOptic w a b))+  => Optic c s t a b -> ExOptic w a b s t+prof2ex (Optic l) = l @(ExOptic w a b) (ExOptic (Id id) (Id id))++-- | 'prof2ex' in continuation-passing form: the generic eliminator.+withLegs+  :: forall {j} {k} w c (s :: k) (t :: j) a b r+   . (CategoryOf j, CategoryOf k, Flavor w, (Ob a, Ob b) => c (ExOptic w a b))+  => Optic c s t a b -> (forall p q. (w p q, Profunctor p, Profunctor q) => p s a -> q b t -> r) -> r+withLegs o k = case prof2ex @w o of ExOptic p q -> k p q++-- | Convert an optic to a chosen flavor @w@, by running it at @'ExOptic' w a b@ and wrapping the+-- resulting witness pair back around the carrier. A 'Prostrong'-flavored optic converts along the+-- subtyping lattice (an invalid conversion fails with @Could not deduce (w p q)@), a+-- ':&&:'-composite when both conjuncts do, and a profunctor-class-flavored optic when+-- @'ExOptic' w a b@ has an instance of its class (cf. 'Proarrow.Optic.Iso.fromPIso',+-- 'Proarrow.Optic.MonoidalTraversal.fromPTraversal', 'Proarrow.Optic.Tracer.fromPTracer').+--+-- Consumers accept any sufficiently strong optic directly, but constructors and '%' return their+-- exact type, so 'convert' is how to store an optic at a weaker type, e.g.+-- @convert ('Proarrow.Optic.Lens.lens' f g) :: 'Proarrow.Optic.Traversal.Traversal'' s a@.+convert+  :: forall {j} {k} c (w :: FLAVOR j k) (s :: k) (t :: j) a b+   . (CategoryOf j, CategoryOf k, Flavor w, (Ob a, Ob b) => c (ExOptic w a b))+  => Optic c s t a b -> Optic (Prostrong w) s t a b+convert o = withLegs @w o (legs2prof @w)++-- | The reversing carrier implementing 're': it stores a continuation @p b a -> p t s@, so+-- running an optic at @'Re' p _ _@ builds the optic turned around. Its 'Prostrong' instance+-- absorbs the witness pair mirrored, via 'Flip'.+data Re p s t a b where+  Re :: (Ob a, Ob b) => {unRe :: p b a -> p t s} -> Re p s t a b++instance (Profunctor p) => Profunctor (Re p s t) where+  dimap l r (Re f) = Re (f . dimap r l) \\ l \\ r+  r \\ Re{} = r++class+  (forall p a b. (coc p) => c (Re p a b)) =>+  ReversibleOptic (c :: j +-> k -> Constraint) (coc :: k +-> j -> Constraint)+    | c -> coc++instance ReversibleOptic Profunctor Profunctor+instance (ReversibleOptic l l', ReversibleOptic r r') => ReversibleOptic (l :&&: r) (l' :&&: r')+instance ReversibleOptic (Prostrong w) (Prostrong (Flip w))++re :: (Ob a, Ob b, ReversibleOptic c coc) => Optic c s t a b -> Optic coc b a t s+re (Optic l) = Optic (unRe (l (Re id)))++class (w p q) => Flip w q p+instance (w p q) => Flip w q p++instance (CategoryOf j, CategoryOf k, Prostrong (Flip w) p) => Prostrong w (Re p s t :: k +-> j) where+  proact (f@Objs :.: Re n :.: g@Objs) = Re \p -> n (proact @(Flip w) @p (g :.: p :.: f))++class (c (Op q)) => OpConstraint c q+instance (c (Op q)) => OpConstraint c q++class (w (Op g) (Op f)) => OpFlavor w f g+instance (w (Op g) (Op f)) => OpFlavor w f g++instance (Prostrong w p, CategoryOf j, CategoryOf k) => Prostrong (OpFlavor w) (UnOp p :: j +-> k) where+  proact (f :.: UnOp p :.: g) = UnOp (proact @w (Op g :.: p :.: Op f))++instance (Prostrong w p, CategoryOf j, CategoryOf k) => Prostrong w (Op (UnOp p :: j +-> k)) where+  proact (f@Objs :.: Op (UnOp p) :.: g@Objs) = Op (UnOp (proact @w (f :.: p :.: g)))++opOptic+  :: forall {j} {k} c (s :: j) (t :: k) a b+   . (forall p. (c p) => c (Op (UnOp p)), CategoryOf j, CategoryOf k)+  => Optic (OpConstraint c) s t a b -> Optic c (OP t) (OP s) (OP b) (OP a)+opOptic (Optic n) = Optic (unUnOp . n . UnOp)++unOpOptic+  :: forall {k} c (s :: k) t a b+   . Optic c (OP t) (OP s) (OP b) (OP a) -> Optic (OpConstraint c) s t a b+unOpOptic (Optic n) = Optic (unOp . n . Op)
+ src/Proarrow/Optic/Action.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Optics for an arbitrary 'Proarrow.Category.Monoidal.Action.MonoidalAction': the 'ActFl' flavor,+-- whose witness pair is a matched pair of arrows into\/out of the action at some residual; its+-- specialisation to the tensor's self-action gives 'MonoidalOptic'. Also home to the __algebraic+-- lens__ ('AlgLensFl'), the tensor-action pair with an 'Algebra'-for-a-monad residual, and its+-- list-monad case, the __classifying lens__ ('ClassifyFl'), which is moreover a kaleidoscope.+module Proarrow.Optic.Action where++import Data.Kind (Constraint)+import Prelude (($))+import Prelude qualified as P++import Proarrow.Category.Monoidal+  ( Monoidal (..)+  , MonoidalProfunctor (..)+  , OplaxMonoidalRep+  , SymMonoidal+  , Tensor+  , unpar0Rep+  , unparRep+  , type (**)+  )+import Proarrow.Category.Monoidal.Action (Act, ActionAt, MonoidalAction (..), composeActs, decomposeActs)+import Proarrow.Colimit.BinaryCoproduct (HasCoproducts)+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), obj, (\\), type (+->))+import Proarrow.Functor (Functor)+import Proarrow.Monoid (Comonoid, Monoid)+import Proarrow.Monoid qualified as Mon+import Proarrow.Object (pattern Objs)+import Proarrow.Optic (ExOptic, FLAVOR, Optic, Prostrong (..), legs2prof, withLegs)+import Proarrow.Optic.Kaleidoscope (KaleidoFl)+import Proarrow.Optic.MonoidalLens (MonLensFl)+import Proarrow.Profunctor.Corepresentable (Corep (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Instance.Star (Star)+import Proarrow.Profunctor.Representable (Rep (..), RepCostar (..), Representable (..))+import Proarrow.Promonad (Monad, bind, return)++-- | Any 'MonoidalAction' gives rise to a flavor: the witness pair is a matched pair of arrows+-- into\/out of the action for some shared, existentially hidden index @x@. 'Proarrow.Optic.Lens.LensFl'\/'Proarrow.Optic.Prism.PrismFl'+-- are (unspelled-out) special cases of this for 'Proarrow.Category.Monoidal.Action.ProdAction'\/'Proarrow.Category.Monoidal.Action.CoprodAction'.+type ActFl :: forall {m} {k}. (m, k) +-> k -> FLAVOR k k+class (MonoidalAction act, Profunctor p, Profunctor q) => ActFl act (p :: k +-> k) (q :: k +-> k) where+  withActP :: p s a -> q b t -> (forall x. (Ob x) => (s ~> Act act x a) -> (Act act x b ~> t) -> r) -> r++instance (MonoidalAction act, Ob x) => ActFl act (Rep (ActionAt act x)) (Corep (ActionAt act x)) where+  withActP (Rep f) (Corep g) k = k @x f g+instance (MonoidalAction act) => ActFl act (Id :: k +-> k) (Id :: k +-> k) where+  withActP (Id f) (Id g) k = k @Unit (unitorInv @act . f) (g . unitor @act) \\ f \\ g+instance (ActFl act f g, ActFl act f' g') => ActFl act (f :.: f') (g' :.: g) where+  withActP @_ @a @b (f :.: f'@Objs) (g'@Objs :.: g) k =+    withActP @act @f @g f g \ @x f1 g1 ->+      withActP @act @f' @g' f' g' \ @y f2 g2 ->+        withOb2 @_ @x @y $+          k @(x ** y) (composeActs @act @x @y @a f1 f2) (decomposeActs @act @x @y @b g2 g1)++-- | An Eilenberg-Moore algebra for the monad @m@ (a representable 'Promonad' on @k@, acting as+-- the functor @m '%' -@, see "Proarrow.Promonad"): a structure map @m % a ~> a@, coherent with the+-- monad's unit and multiplication. The free algebras @m % s@ are the ones 'algebraicLens' uses.+--+-- @Unit@ and @('**')@ are type families, which may not head an instance, so there are no+-- instances for the unit or for products of algebras. 'withAlgP' passes the structure map as a+-- value instead, and the witnesses combine those with 'unparRep' and 'unpar0Rep'.+type Algebra :: forall {k}. (k +-> k) -> k -> Constraint+class (Monad m, Ob a) => Algebra (m :: k +-> k) (a :: k) where+  algebra :: m % a ~> a++-- | The free algebras of a monad @m@, wrapped as the representable promonad @'Star' m@.+instance (Monad (Star m), Ob (m a), Ob a) => Algebra (Star m) (m a) where+  algebra = bind @(Star m) id++-- | The algebraic-lens flavor (Riley, /Categories of Optics/; Clarke et al.): the tensor-action+-- witness pair @'Rep'@\/@'Corep'@ @('ActionAt' 'Tensor' x)@ of "Proarrow.Optic.MonoidalLens"+-- (legs @s ~> x ** a@ and @x ** b ~> t@), with the residual @x@ an 'Algebra' for @m@. Through the+-- algebra @put@ sees a whole @m@-computation of sources: 'classifyOf' collapses @m % s@ to a single+-- residual. The flavor asks only that @m '%'@ be oplax monoidal, to pair and discard residuals;+-- the monad structure comes with each 'Algebra' witness. Every algebraic lens is a+-- 'Proarrow.Optic.MonoidalLens.MonoidalLens' ('MonLensFl' superclass), so it views, sets, folds+-- and traverses as a lens does.+type AlgLensFl :: forall {k}. (k +-> k) -> FLAVOR k k+class (OplaxMonoidalRep m, MonLensFl p q) => AlgLensFl (m :: k +-> k) (p :: k +-> k) (q :: k +-> k) where+  -- | Recover the two legs and the algebra of the (existential) residual @x@.+  withAlgP+    :: p s a -> q b t -> (forall (x :: k). (Ob x) => (m % x ~> x) -> (s ~> x ** a) -> (x ** b ~> t) -> r) -> r++instance+  (OplaxMonoidalRep m, Algebra m x, Comonoid (x :: k))+  => AlgLensFl m (Rep (ActionAt Tensor x) :: k +-> k) (Corep (ActionAt Tensor x))+  where+  withAlgP (Rep h) (Corep i) k = k @x (algebra @m @x) h i+instance (OplaxMonoidalRep (m :: k +-> k)) => AlgLensFl m (Id :: k +-> k) (Id :: k +-> k) where+  withAlgP (Id l) (Id r) k = k @Unit (unpar0Rep @m) (leftUnitorInv . l) (r . leftUnitor) \\ l \\ r+instance+  forall k (m :: k +-> k) (f :: k +-> k) (f' :: k +-> k) (g :: k +-> k) (g' :: k +-> k)+   . (AlgLensFl m f g, AlgLensFl m f' g')+  => AlgLensFl m (f :.: f') (g' :.: g)+  where+  withAlgP @_ @afoc @bfoc (f :.: f'@Objs) (g'@Objs :.: g) kk =+    withAlgP @m f g \ @(xo :: k) algo ho io ->+      withAlgP @m f' g' \ @(xi :: k) algi hi ii ->+        withOb2 @k @xo @xi+          ( kk @(xo ** xi)+              ((algo ** algi) . unparRep @m @xo @xi)+              (associatorInv @k @xo @xi @afoc . (obj @xo ** hi) . ho)+              (io . (obj @xo ** ii) . associator @k @xo @xi @bfoc)+          )++-- | An algebraic lens: like a 'Proarrow.Optic.Lens.Lens', but @put@ is allowed to combine+-- information monadically (@get :: s ~> a@, @put :: m % s ** b ~> t@) instead of only ever+-- seeing the /last/ @s@.+type AlgebraicLens m (s :: k) (t :: k) a b = Optic (Prostrong (AlgLensFl m)) s t a b++-- | Build an algebraic lens from @get@ and a monadic @put@; the residual is the free algebra+-- @m % s@ itself (which must be a comonoid, as must @s@ to be kept alongside its focus).+algebraicLens+  :: forall {k} m (s :: k) (t :: k) a b+   . (Algebra m (m % s), Comonoid (m % s), Comonoid s, OplaxMonoidalRep m, Ob a, Ob b)+  => (s ~> a) -> (m % s ** b ~> t) -> AlgebraicLens m s t a b+algebraicLens v u =+  legs2prof @(AlgLensFl m)+    (Rep @a @(ActionAt Tensor (m % s)) ((return @m @s ** v) . Mon.comult @s))+    (Corep @b @(ActionAt Tensor (m % s)) u)++-- | Classify a monadic computation of @s@'s through an 'AlgebraicLens' (or any stronger optic,+-- in any encoding), given a replacement focus @b@. This generalizes "set" to combine every @s@ the+-- computation might produce (via its residual's 'Algebra') instead of only ever seeing the last one.+-- The focus @a@ is discarded under the monad, hence must be a comonoid.+classifyOf+  :: forall {k} m c (s :: k) (t :: k) a b+   . (OplaxMonoidalRep m, Comonoid a, (Ob a, Ob b) => c (ExOptic (AlgLensFl m) a b))+  => Optic c s t a b -> (m % s ** b) ~> t+classifyOf optic =+  withLegs @(AlgLensFl m) optic \l r ->+    withAlgP @m l r \ @x alg h i ->+      (i . ((alg . repMap @m (rightUnitor @k @x . (obj @x ** Mon.counit @a) . h)) ** obj @b)) \\ r++infixl 8 .?++-- | 'classifyOf' for a Haskell monad, curried: @optic .? b $ fs@.+(.?)+  :: forall f c s t a b+   . (P.Monad f, Functor f, c (ExOptic (AlgLensFl (Star f)) a b))+  => Optic c s t a b -> b -> f s -> t+(.?) l b fs = classifyOf @(Star f) l (fs, b)++-- | The __classifying lens__ (Clarke et al., Example 3.11): the algebraic lens for the list monad,+-- here for any monad @l@ whose algebras are monoids. Tensoring with a monoid is an applicative+-- functor (the writer applicative), so a classifying lens is also a kaleidoscope+-- ('Proarrow.Optic.Kaleidoscope.KaleidoFl'), and composes with a kaleidoscope to a kaleidoscope+-- (Clarke et al., Remark 3.28), which a plain lens does not. The algebra and the monoid on the+-- residual are assumed to agree, as they do for the free list algebra @l % s@ (@join@ and @++@).+type ClassifyFl :: forall {k}. (k +-> k) -> FLAVOR k k+class (AlgLensFl l p q, KaleidoFl p q) => ClassifyFl (l :: k +-> k) (p :: k +-> k) (q :: k +-> k)++instance+  (OplaxMonoidalRep l, Algebra l x, Monoid x, Comonoid x, SymMonoidal k, HasCoproducts k)+  => ClassifyFl l (Rep (ActionAt Tensor x) :: k +-> k) (Corep (ActionAt Tensor x))+instance (OplaxMonoidalRep (l :: k +-> k)) => ClassifyFl l (Id :: k +-> k) (Id :: k +-> k)+instance (ClassifyFl l f g, ClassifyFl l f' g') => ClassifyFl l (f :.: f') (g' :.: g)++type ClassifyingLens l (s :: k) (t :: k) a b = Optic (Prostrong (ClassifyFl l)) s t a b++-- | Build a classifying lens from @get@ and a @classify :: l % s ** b ~> t@; the residual is the+-- free algebra @l % s@, e.g. the list of sources.+classifyingLens+  :: forall {k} l (s :: k) (t :: k) a b+   . ( Algebra l (l % s)+     , Monoid (l % s)+     , Comonoid (l % s)+     , Comonoid s+     , OplaxMonoidalRep l+     , SymMonoidal k+     , HasCoproducts k+     , Ob a+     , Ob b+     )+  => (s ~> a) -> (l % s ** b ~> t) -> ClassifyingLens l s t a b+classifyingLens v u =+  legs2prof @(ClassifyFl l)+    (Rep @a @(ActionAt Tensor (l % s)) ((return @l @s ** v) . Mon.comult @s))+    (Corep @b @(ActionAt Tensor (l % s)) u)++-- | The carrier of the literature's algebraic-lens eliminator: @'RepCostar' m@, i.e. @m % a ~> b@.+-- Absorbing an algebraic-lens witness pair collapses the residuals of the incoming computation+-- through their algebra and hands the foci on as one @m@-computation.+instance (OplaxMonoidalRep (m :: k +-> k)) => Prostrong (AlgLensFl m) (RepCostar m :: k +-> k) where+  proact (f :.: RepCostar @afoc g :.: g') =+    withAlgP @m f g' \ @x alg h i ->+      RepCostar (i . (alg ** g) . unparRep @m @x @afoc . repMap @m h) \\ g \\ f
+ src/Proarrow/Optic/AffineFold.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | The __affine fold__: a fold that sees at most one focus, @s '~>' (a '||' 'TerminalObject')@+-- ('AffineFoldFl' \/ 'previewP'). Every 'Proarrow.Optic.Getter.Getter' and+-- 'Proarrow.Optic.AffineTraversal.AffineTraversal' is one, and it subtypes to+-- 'Proarrow.Optic.Fold.Fold'. Like all read-only flavors it has no builder of its own+-- ('Proarrow.Optic.convert' a stronger optic). Its canonical eliminator is 'preview' \/ '(^?)',+-- via the generic 'ExOptic' carrier.+module Proarrow.Optic.AffineFold where++import Data.Kind (Type)+import Prelude (Maybe (..), either)+import Prelude qualified as P++import Proarrow.Category.Monoidal.Cartesian (Bicartesian)+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard (..))+import Proarrow.Colimit.BinaryCoproduct (Coproduct, HasBinaryCoproducts (..), HasCoproducts)+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), (\\), type (+->))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts, Product, snd)+import Proarrow.Limit.Terminal (HasTerminalObject (..), const)+import Proarrow.Optic (ExOptic, FLAVOR, Optic, Prostrong (..), withLegs)+import Proarrow.Optic.Fold (FoldFl)+import Proarrow.Profunctor.Corepresentable (Corep (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Instance.Terminal (TerminalProfunctor (..))+import Proarrow.Profunctor.Representable (Rep (..))++-- | An affine fold is a fold that can see at most one @a@ (0-or-1, never 0-or-many). A getter+-- is an affine fold that always succeeds; an affine traversal is one that additionally knows how+-- to reconstruct a @t@ when it fails to match.+type AffineFoldFl :: forall {j} {k}. FLAVOR j k+class (FoldFl p q) => AffineFoldFl (p :: k +-> k) (q :: j +-> j) where+  previewP :: (Bicartesian k) => p s a -> s ~> (a || TerminalObject)++instance (HasBinaryProducts k, Ob (s :: k)) => AffineFoldFl (Rep (Product s)) (Corep (Product s)) where+  previewP @_ @a (Rep p) = lft @k @a @TerminalObject . snd @k @s @a . p+instance (CategoryOf k, CategoryOf j) => AffineFoldFl (Id :: k +-> k) (Id :: j +-> j) where+  previewP @_ @a (Id sa) = lft @k @a @TerminalObject . sa \\ sa+instance (CategoryOf k, CategoryOf j) => AffineFoldFl (Id :: k +-> k) (TerminalProfunctor :: j +-> j) where+  previewP @_ @a (Id sa) = lft @k @a @TerminalObject . sa \\ sa+instance (AffineFoldFl f g, AffineFoldFl f' g') => AffineFoldFl (f :.: f') (g' :.: g) where+  previewP @_ @a (f :.: f') = (previewP @f' @g' f' ||| rgt @_ @a @TerminalObject) . previewP @f @g f \\ f'+instance (HasCoproducts k, Ob t) => AffineFoldFl (Corep (Coproduct t) :: k +-> k) (Rep (Coproduct t)) where+  previewP @_ @a (Corep f) = lft @k @a @TerminalObject . f . rgt @k @t \\ f+instance (CopyDiscard k, HasCoproducts k, Ob t) => AffineFoldFl (Rep (Coproduct t) :: k +-> k) (Corep (Coproduct t)) where+  previewP @_ @a (Rep p) = (const @t (rgt @k @a @TerminalObject) ||| lft @k @a @TerminalObject) . p++type AffineFold (s :: k) (t :: j) a b = Optic (Prostrong AffineFoldFl) s t a b++-- | Preview through any optic that can act as an affine fold, in either encoding: run it at its+-- witness pair ('ExOptic' 'AffineFoldFl', via 'withLegs') and apply 'previewP'.+preview+  :: forall {j} {k} c (s :: k) (t :: j) a b+   . (Bicartesian k, CategoryOf j, (Ob a, Ob b) => c (ExOptic AffineFoldFl a b))+  => Optic c s t a b -> s ~> (a || TerminalObject)+preview o = withLegs @AffineFoldFl o \ @p @q p _ -> previewP @p @q p++infixl 8 ^?++-- | Preview the focus of a concrete, @Type@-level optic (a getter that might not match).+(^?) :: forall s (t :: Type) a b c. (c (ExOptic AffineFoldFl a b)) => s -> Optic c s t a b -> Maybe a+s ^? l = either Just (P.const Nothing) (preview l s)
+ src/Proarrow/Optic/AffineTraversal.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | The __affine traversal__: the 0-or-1 focus optic that can also reconstruct, the meet of+-- 'Proarrow.Optic.Lens.Lens' and 'Proarrow.Optic.Prism.Prism' in the subtyping lattice. Its two+-- legs are 'affineMatch' @:: s ~> (t || a)@ and 'affineSet' @:: (s && b) ~> t@ ('AffineTravFl').+-- Its witnesses only ever arise by composing lens and prism witnesses, so it is built with+-- 'Proarrow.Optic.Prism.affineTraversal' (a 'Proarrow.Optic.Lens.Lens' followed by a+-- 'Proarrow.Optic.Prism.Prism') and eliminated with 'matching', via the generic+-- 'Proarrow.Optic.ExOptic' carrier.+module Proarrow.Optic.AffineTraversal where++import Prelude (($))++import Proarrow.Category.Monoidal (Monoidal (..), first, second)+import Proarrow.Category.Monoidal.Cartesian (Bicartesian, productToTensor, tensorToProduct)+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard (..), fst, snd, (&&&))+import Proarrow.Category.Monoidal.Distributive (Distributive (..))+import Proarrow.Colimit.BinaryCoproduct (Coproduct, HasBinaryCoproducts (..), HasCoproducts, left)+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), (\\), type (+->))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (type (&&)), Product)+import Proarrow.Limit.BinaryProduct qualified as P+import Proarrow.Object (pattern Objs)+import Proarrow.Optic (ExOptic, FLAVOR, Optic, Prostrong (..), withLegs)+import Proarrow.Optic.AffineFold (AffineFoldFl)+import Proarrow.Optic.Traversal (TravFl)+import Proarrow.Profunctor.Corepresentable (Corep (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Representable (Rep (..))++type AffineTravFl :: forall {k}. FLAVOR k k+class (TravFl p q, AffineFoldFl p q) => AffineTravFl (p :: k +-> k) (q :: k +-> k) where+  affineMatch :: (Bicartesian k) => p (s :: k) a -> q b t -> s ~> (t || a)+  affineSet :: (Bicartesian k) => p (s :: k) a -> q b t -> (s && b) ~> t+instance (HasBinaryProducts k, Ob (s :: k)) => AffineTravFl (Rep (Product s)) (Corep (Product s)) where+  -- a lens always matches+  affineMatch @_ @a @_ @t (Rep p) q = rgt @k @t @a . P.snd @k @s @a . p \\ p \\ q+  affineSet @_ @a @b (Rep p) (Corep q) = q . P.first @b (P.fst @k @s @a . p)+instance (CopyDiscard k, HasCoproducts k, Ob t) => AffineTravFl (Rep (Coproduct t) :: k +-> k) (Corep (Coproduct t)) where+  affineMatch @_ @a @b (Rep p) (Corep q) = left @a (q . lft @k @t @b) . p++  -- a prism's set never needs the original value, it just reviews+  affineSet @s @_ @b (Rep p) (Corep q) = q . rgt @k @t @b . P.snd @k @s @b \\ p+instance (CategoryOf k) => AffineTravFl (Id :: k +-> k) (Id :: k +-> k) where+  affineMatch @_ @a @_ @t (Id sa) bt = rgt @k @t @a . sa \\ sa \\ bt+  affineSet @s @_ @b sa (Id bt) = bt . P.snd @k @s @b \\ sa \\ bt+instance (AffineTravFl f g, AffineTravFl f' g') => AffineTravFl (f :.: f') (g' :.: g) where+  -- match the outer; on failure of the inner, reconstruct via the outer's own setter, reusing s+  affineMatch @s @a @_ @t ((:.:) @m f@Objs f'@Objs) ((:.:) @n g'@Objs g@Objs) =+    ( (lft @_ @t @a . snd @s @t)+        ||| ( ((lft @_ @t @a . affineSet @f @g f g . tensorToProduct @s @n) ||| (rgt @_ @t @a . snd @s @a))+                . distL @_ @s @n @a+                . second @s (affineMatch @f' @g' f' g')+            )+    )+      . distL @_ @s @t @m+      . (id &&& affineMatch @f @g f g)++  -- if the outer already fails, the new b is irrelevant; otherwise set inner-then-outer, reusing s+  affineSet @s @_ @b @t ((:.:) @m f@Objs f'@Objs) ((:.:) @n g'@Objs g@Objs) =+    withOb2 @_ @t @b $+      withOb2 @_ @m @b $+        ( (fst @t @b . snd @s @(t ** b))+            ||| (affineSet @f @g f g . tensorToProduct @s @n . second @s (affineSet @f' @g' f' g' . tensorToProduct @m @b))+        )+          . distL @_ @s @(t ** b) @(m ** b)+          . second @s (distR @_ @t @m @b)+          . (fst @s @b &&& first @b (affineMatch @f @g f g))+          . productToTensor @s @b++type AffineTraversal (s :: k) (t :: k) a b = Optic (Prostrong AffineTravFl) s t a b+type AffineTraversal' s a = AffineTraversal s s a a++-- | Match through any optic that can act as an affine traversal, in either encoding: returns the+-- focus (@'rgt'@) when it matches, or a reconstructed @t@ (@'lft'@) when it does not. This is the+-- 'AffineTraversal' eliminator, refining 'Proarrow.Optic.AffineFold.preview' (which forgets @t@).+-- Runs the optic at its witness pair ('ExOptic' 'AffineTravFl', via 'withLegs') and applies+-- 'affineMatch'.+matching+  :: forall {k} c (s :: k) (t :: k) a b+   . (Bicartesian k, (Ob a, Ob b) => c (ExOptic AffineTravFl a b))+  => Optic c s t a b -> s ~> (t || a)+matching o = withLegs @AffineTravFl o \ @p @q p q -> affineMatch @p @q p q
+ src/Proarrow/Optic/Day.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | A third way to combine two flavors, alongside 'Proarrow.Optic.Prod.ProdFl' and+-- 'Proarrow.Optic.Sum.SumFl': via the Day convolution. Unlike those two, it keeps both witnesses+-- in the same ambient categories @j@\/@k@. It needs 'Monoidal' structure there to split objects+-- across the two witnesses, where the others pair\/sum two independent categories.+module Proarrow.Optic.Day where++import Prelude (($))++import Proarrow.Category.Monoidal (Monoidal (..), type (**))+import Proarrow.Core (CAT, CategoryOf (..), (\\), type (+->))+import Proarrow.Object (pattern Objs)+import Proarrow.Optic (FLAVOR, Flavor, Optic, Prostrong (..), legs2prof, withLegs)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Day (Day, day)+import Proarrow.Profunctor.Instance.Identity (Id (..))++type DayFl :: FLAVOR j k -> FLAVOR j k -> FLAVOR j k+class DayFl w1 w2 (p :: k +-> k) (q :: j +-> j)+instance (w1 p1 q1, w2 p2 q2) => DayFl w1 w2 (Day p1 p2) (Day q1 q2)+instance (CategoryOf k, CategoryOf j) => DayFl w1 w2 (Id :: CAT k) (Id :: CAT j)+instance (DayFl w1 w2 f f', DayFl w1 w2 g g') => DayFl w1 w2 (f :.: g) (g' :.: f')++dayOptic+  :: forall {j} {k} (w1 :: FLAVOR j k) (w2 :: FLAVOR j k) s1 t1 a1 b1 s2 t2 a2 b2+   . (Monoidal j, Monoidal k, Flavor w1, Flavor w2)+  => Optic (Prostrong w1) s1 t1 a1 b1+  -> Optic (Prostrong w2) s2 t2 a2 b2+  -> Optic (Prostrong (DayFl w1 w2)) (s1 ** s2) (t1 ** t2) (a1 ** a2) (b1 ** b2)+dayOptic o1 o2 =+  withLegs @w1 o1 \l1@Objs r1@Objs ->+    withLegs @w2 o2 \l2@Objs r2@Objs ->+      withOb2 @k @a1 @a2 $+        withOb2 @j @b1 @b2 $+          legs2prof @(DayFl w1 w2) (day l1 l2) (day r1 r2) \\ l1 \\ r1 \\ l2 \\ r2
+ src/Proarrow/Optic/Fold.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | The __fold__: the weakest read-side optic, reducing the foci to any 'Monoid' object of the+-- category ('FoldFl' \/ 'foldMapP'). It sits at the read-only top of the subtyping lattice+-- (everything that can view, preview or traverse is a fold), so it has no builder of its own+-- (reach it by 'Proarrow.Optic.convert' from a stronger optic). Its canonical eliminator is+-- 'foldMapOf', via the generic 'Proarrow.Optic.ExOptic' carrier, with 'unfold' as the 'Proarrow.Optic.re'-mirror that+-- builds from a 'Comonoid' seed.+module Proarrow.Optic.Fold where++import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..), UnOp)+import Proarrow.Category.Monoidal.Cartesian (Bicartesian)+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard (..))+import Proarrow.Category.Monoidal.Distributive (Cotraversable (..), Traversable (..), corepTraverse, repTraverse)+import Proarrow.Colimit.BinaryCoproduct (Coproduct, HasCoproducts, rgt, (|||))+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), (\\), type (+->))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts, Product, snd)+import Proarrow.Monoid (Comonoid, Monoid (..))+import Proarrow.Optic+  ( ExOptic+  , FLAVOR+  , OpConstraint+  , Optic+  , Prostrong (..)+  , opOptic+  , withLegs+  )+import Proarrow.Profunctor.Corepresentable (Corep (..), Corepresentable (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Constant (Constant)+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Instance.Terminal (TerminalProfunctor (..))+import Proarrow.Profunctor.Representable (CorepStar (..), Rep (..), RepCostar, Representable (..))++-- | A fold is a getter or traversal that forgets everything except the ability to reduce the+-- @a@'s it can see into any monoid object of @k@. It can never reconstruct a @t@.+type FoldFl :: forall {j} {k}. FLAVOR j k+class (Profunctor p, Profunctor q) => FoldFl (p :: k +-> k) (q :: j +-> j) where+  foldMapP :: (Monoid m) => p s a -> (a ~> m) -> (s ~> m)++instance (HasBinaryProducts k, Ob (s :: k)) => FoldFl (Rep (Product s)) (Corep (Product s)) where+  foldMapP (Rep p) am = am . snd @k @s . p+instance (CategoryOf k, CategoryOf j) => FoldFl (Id :: k +-> k) (Id :: j +-> j) where+  foldMapP (Id sa) am = am . sa+instance (CategoryOf k, CategoryOf j) => FoldFl (Id :: k +-> k) (TerminalProfunctor :: j +-> j) where+  foldMapP (Id sa) am = am . sa+instance (FoldFl f g, FoldFl f' g') => FoldFl (f :.: f') (g' :.: g) where+  foldMapP (f :.: f') = foldMapP @f @g f . foldMapP @f' @g' f'+instance (Bicartesian k, Traversable t, Representable t) => FoldFl (t :: k +-> k) (RepCostar t) where+  foldMapP @m @_ @a l am = (case repTraverse @t @(Rep (Constant m)) (Rep @a am) of Rep sm -> sm . index l) \\ am++-- | The corepresentable-cotraversable witness folds by cotraversing at the fold profunctor+-- @'Rep' ('Constant' m)@ and discarding the residual shape.+instance (Bicartesian k, Cotraversable t, Corepresentable t) => FoldFl (CorepStar t) (t :: k +-> k) where+  foldMapP @m @_ @a (CorepStar l) am = (case corepTraverse @t @(Rep (Constant m)) (Rep @a am) of Rep sm -> sm . l) \\ am++instance (HasCoproducts k, Ob t) => FoldFl (Corep (Coproduct t) :: k +-> k) (Rep (Coproduct t)) where+  foldMapP (Corep f) am = am . f . rgt @k @t+instance (CopyDiscard k, HasCoproducts k, Ob t) => FoldFl (Rep (Coproduct t) :: k +-> k) (Corep (Coproduct t)) where+  foldMapP @m (Rep p) am = (mempty @m . discard @k @t ||| am) . p++type Fold (s :: k) (t :: j) a b = Optic (Prostrong FoldFl) s t a b++-- | Fold through any optic that can act as a fold, in either encoding: run it at its witness pair+-- ('ExOptic' 'FoldFl', via 'withLegs') and apply 'foldMapP'.+foldMapOf+  :: forall {j} {k} c m (s :: k) (t :: j) a b+   . (CategoryOf j, CategoryOf k, Ob m, Monoid m, (Ob a, Ob b) => c (ExOptic FoldFl a b))+  => Optic c s t a b -> (a ~> m) -> (s ~> m)+foldMapOf o am = withLegs @FoldFl o \ @p @q p _ -> foldMapP @p @q p am++-- | Unfold @t@ from a 'Comonoid' seed @cm@ through the @b@-foci. It is+-- 'foldMapOf' run in @'OPPOSITE' k@, where 'Monoid' becomes 'Comonoid' and consumption becomes+-- construction.+unfold+  :: forall {k} c (cm :: k) (s :: k) t a b+   . (Comonoid cm, Ob cm, forall p. (c p) => c (Op (UnOp p)), (Ob a, Ob b) => c (ExOptic FoldFl (OP b) (OP a)))+  => Optic (OpConstraint c) s t a b -> (cm ~> b) -> (cm ~> t)+unfold o cb = unOp (foldMapOf @c (opOptic o) (Op cb))
+ src/Proarrow/Optic/Getter.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The __getter__ and its mirror the __review__: the one-leg optics @s '~>' a@ ('GetterFl' \/+-- 'getP') and @b '~>' t@ (its 'Flip'). A getter is an affine fold that always succeeds; a review+-- is what remains of a prism's build leg. Build them from a single morphism with 'to' \/ 'unto',+-- and eliminate with 'view' \/ '(^.)' and 'review' \/ '(#)', via the generic 'ExOptic' carrier.+module Proarrow.Optic.Getter where++import Data.Kind (Type)++import Proarrow.Colimit.BinaryCoproduct (Coproduct, HasCoproducts, rgt)+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), (\\), type (+->))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts, Product, snd)+import Proarrow.Optic+  ( ExOptic+  , FLAVOR+  , Flip+  , Optic+  , Prostrong (..)+  , legs2prof+  , withLegs+  )+import Proarrow.Optic.AffineFold (AffineFoldFl)+import Proarrow.Profunctor.Corepresentable (Corep (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Instance.Terminal (TerminalProfunctor (..))+import Proarrow.Profunctor.Representable (Rep (..))++type GetterFl :: forall {j} {k}. FLAVOR j k+class (AffineFoldFl p q) => GetterFl (p :: k +-> k) (q :: j +-> j) where+  getP :: p s a -> s ~> a+instance (HasBinaryProducts k, Ob (s :: k)) => GetterFl (Rep (Product s)) (Corep (Product s)) where+  getP @_ @a (Rep p) = snd @k @s @a . p+instance (CategoryOf k, CategoryOf j) => GetterFl (Id :: k +-> k) (Id :: j +-> j) where+  getP = unId+instance (CategoryOf k, CategoryOf j) => GetterFl (Id :: k +-> k) (TerminalProfunctor :: j +-> j) where+  getP = unId+instance (GetterFl f g, GetterFl f' g') => GetterFl (f :.: f') (g' :.: g) where+  getP (f :.: f') = getP @f' @g' f' . getP @f @g f+instance (HasCoproducts k, Ob t) => GetterFl (Corep (Coproduct t) :: k +-> k) (Rep (Coproduct t)) where+  getP (Corep f) = f . rgt @k @t++type Getter (s :: k) (t :: j) a b = Optic (Prostrong GetterFl) s t a b++-- | View through any optic that can act as a getter, in either encoding: run it at its witness+-- pair ('ExOptic' 'GetterFl', via 'withLegs') and read the get leg off with 'getP'.+view+  :: forall {j} {k} c (s :: k) (t :: j) a b+   . (CategoryOf j, CategoryOf k, (Ob a, Ob b) => c (ExOptic GetterFl a b))+  => Optic c s t a b -> s ~> a+view o = withLegs @GetterFl o \ @p @q p _ -> getP @p @q p++infixl 8 ^.++-- | View the focus of a concrete, @Type@-level optic.+(^.) :: (c (ExOptic GetterFl a b)) => s -> Optic c (s :: Type) (t :: Type) a b -> a+s ^. l = view l s++to :: forall {k} {j} (s :: k) (t :: j) a b. (CategoryOf k, CategoryOf j, Ob b, Ob t) => (s ~> a) -> Getter s t a b+to sa = legs2prof @GetterFl (Id sa) TerminalProfunctor \\ sa++type Review (s :: k) (t :: j) a b = Optic (Prostrong (Flip GetterFl)) s t a b++-- | Review through any optic that can act as a review, in either encoding: 'getP' on the flipped+-- witness pair.+review+  :: forall {j} {k} c (s :: k) (t :: j) a b+   . (CategoryOf j, CategoryOf k, (Ob a, Ob b) => c (ExOptic (Flip GetterFl) a b))+  => Optic c s t a b -> b ~> t+review o = withLegs @(Flip GetterFl) o \ @p @q _ q -> getP @q @p q++infixr 8 #++-- | Review through a concrete, @Type@-level optic.+(#) :: (c (ExOptic (Flip GetterFl) a b)) => Optic c (s :: Type) (t :: Type) a b -> b -> t+(#) = review++unto :: forall {k} {j} (s :: k) (t :: j) a b. (CategoryOf k, CategoryOf j, Ob s, Ob a) => (b ~> t) -> Review s t a b+unto bt = legs2prof @(Flip GetterFl) TerminalProfunctor (Id bt) \\ bt
+ src/Proarrow/Optic/Glass.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | The __glass__ (Clarke et al., /Profunctor optics: a categorical update/): the optic for the+-- combined action of the product and the exponential,+--+-- > Glass s t a b = exists c d. (s ~> c && (d ~~> a), (c && (d ~~> b)) ~> t)+--+-- which collapses to the single leg @(s && ((s ~~> a) ~~> b)) ~> t@: given the source and a way+-- to turn any selector @s ~~> a@ into a @b@, produce a @t@. A lens is the case @d = Unit@, a grate+-- the case @c = Unit@, so 'GlassFl' is the join of 'Proarrow.Optic.Lens.LensFl' and+-- 'Proarrow.Optic.Grate.GrateFl'. Like 'Proarrow.Optic.AffineTraversal.AffineTravFl' it has no+-- witnesses of its own: its generating pairs are the product pair and the exponential pair, and+-- 'glass' packs its single leg as their composite.+--+-- It sits directly below 'Proarrow.Optic.Setter.SetterFl': a glass sets, but it neither folds+-- (grates do not) nor distributes an applicative (lenses do not).+module Proarrow.Optic.Glass where++import Prelude (($))++import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..), type (**))+import Proarrow.Category.Monoidal.Cartesian (CCC, productToTensor, tensorToProduct)+import Proarrow.Category.Monoidal.Closed (Closed (..), Exp, comp, mkExponential, swapClosed)+import Proarrow.Category.Monoidal.CopyDiscard (fst, snd, (&&&))+import Proarrow.Core (CategoryOf (..), Promonad (..), obj, type (+->))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (type (&&)), Product)+import Proarrow.Limit.BinaryProduct qualified as P+import Proarrow.Object (pattern Objs)+import Proarrow.Optic+  ( ExOptic+  , FLAVOR+  , Optic+  , Prostrong (..)+  , legs2prof+  , withLegs+  )+import Proarrow.Optic.Setter (SetterFl)+import Proarrow.Profunctor.Corepresentable (Corep (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Representable (Rep (..))++-- | The glass flavor. Its one method is the collapsed leg; everything is stated in a cartesian+-- closed category, where the residual can be copied and selectors can be internalised.+type GlassFl :: forall {k}. FLAVOR k k+class (SetterFl p q) => GlassFl (p :: k +-> k) (q :: k +-> k) where+  glassP :: (CCC k) => p s a -> q b t -> (s && Mod s a b) ~> t++-- | A /modifier/: given a selector @s '~~>' a@ for reading the focus out of the source, it+-- produces the new focus @b@. It is the right half of a glass's single leg, and the whole of a+-- 'Proarrow.Optic.Grate.grate'\'s argument.+type Mod :: forall {k}. k -> k -> k -> k+type Mod s a b = (s ~~> a) ~~> b++-- | Feed a fixed selector @s ~> a@ to a 'Mod'.+applySel :: forall {k} (s :: k) a b. (Closed k, Ob s, Ob a, Ob b) => (s ~> a) -> Mod s a b ~> b+applySel sel =+  withObSel @s @a @b $+    apply @k @(s ~~> a) @b . (obj @(Mod s a b) ** mkExponential sel) . rightUnitorInv @k @(Mod s a b)++-- | The two 'Ob' facts every modifier needs: the selector type @s '~~>' a@ and the 'Mod' that+-- consumes it. Each 'GlassFl' instance below opens with this.+withObSel+  :: forall {k} (s :: k) a b r+   . (Closed k, Ob s, Ob a, Ob b) => ((Ob (s ~~> a), Ob (Mod s a b)) => r) -> r+withObSel r = withObExp @k @s @a (withObExp @k @(s ~~> a) @b r)++-- | The product pair, a lens witness: the selector is the lens's own @get@, applied to the source+-- at hand; the residual is kept.+instance (HasBinaryProducts k, Ob (c :: k)) => GlassFl (Rep (Product c)) (Corep (Product c)) where+  glassP @s @a @b (Rep h@Objs) (Corep i) =+    withObSel @s @a @b $+      i+        . tensorToProduct @c @b+        . ( (P.fst @k @c @a . h . fst @s @(Mod s a b))+              &&& (applySel @s @a @b (P.snd @k @c @a . h) . snd @s @(Mod s a b))+          )+        . productToTensor @s @(Mod s a b)++-- | The exponential pair, a grate witness: the source is ignored, and the consumer is fed the+-- selector @\\s -> h s d@ for each point @d@ of the exponent.+instance (Closed k, Ob (d :: k)) => GlassFl (Rep (Exp d)) (Corep (Exp d)) where+  glassP @s @a @b (Rep h@Objs) (Corep i) =+    withObSel @s @a @b $+      i+        . curry @k @(Mod s a b) @d (apply @k @(s ~~> a) @b . (obj @(Mod s a b) ** swapClosed @a @s @d h))+        . snd @s @(Mod s a b)+        . productToTensor @s @(Mod s a b)++instance (CategoryOf k) => GlassFl (Id :: k +-> k) (Id :: k +-> k) where+  glassP @s @a @b (Id l@Objs) (Id r@Objs) =+    withObSel @s @a @b $+      r . applySel @s @a @b l . snd @s @(Mod s a b) . productToTensor @s @(Mod s a b)++-- | Composition threads the selector through: the outer glass is given the consumer+-- @\\sel -> inner (sel s, \\sel' -> k (sel' . sel))@.+instance+  forall k (f :: k +-> k) (f' :: k +-> k) (g :: k +-> k) (g' :: k +-> k)+   . (GlassFl f g, GlassFl f' g')+  => GlassFl (f :.: f') (g' :.: g)+  where+  glassP @s @a @b (f@Objs :.: (f'@Objs :: f' x a)) ((g'@Objs :: g' b y) :.: g@Objs) =+    withObSel @s @a @b $+      withObSel @s @x @y $+        withObSel @x @a @b $+          withOb2 @k @s @(Mod s a b) $+            withOb2 @k @(s ** Mod s a b) @(s ~~> x) $+              withOb2 @k @((s ** Mod s a b) ** (s ~~> x)) @(x ~~> a) $+                let+                  -- the inner glass, fed a product-typed pair+                  inner = glassP @f' @g' f' g' . tensorToProduct @x @(Mod x a b)+                  -- the source of the inner glass: the outer selector applied to @s@+                  xpart =+                    apply @k @s @x+                      . ( snd @(s ** Mod s a b) @(s ~~> x)+                            &&& (fst @s @(Mod s a b) . fst @(s ** Mod s a b) @(s ~~> x))+                        )+                  -- the inner consumer: compose the selectors, hand the result to @k@+                  kk =+                    snd @s @(Mod s a b)+                      . fst @(s ** Mod s a b) @(s ~~> x)+                      . fst @((s ** Mod s a b) ** (s ~~> x)) @(x ~~> a)+                  sel =+                    comp @s @x @a+                      . ( snd @((s ** Mod s a b) ** (s ~~> x)) @(x ~~> a)+                            &&& (snd @(s ** Mod s a b) @(s ~~> x) . fst @((s ** Mod s a b) ** (s ~~> x)) @(x ~~> a))+                        )+                  kipart = curry @k @((s ** Mod s a b) ** (s ~~> x)) @(x ~~> a) (apply @k @(s ~~> a) @b . (kk &&& sel))+                  body = inner . (xpart &&& kipart)+                in+                  glassP @f @g f g+                    . tensorToProduct @s @(Mod s x y)+                    . (fst @s @(Mod s a b) &&& curry @k @(s ** Mod s a b) @(s ~~> x) body)+                    . productToTensor @s @(Mod s a b)++type Glass (s :: k) (t :: k) a b = Optic (Prostrong GlassFl) s t a b+type Glass' s a = Glass s s a a++-- | Build a glass from its single leg. The residuals are the whole source and the "logarithm"+-- @s ~~> a@, so the witness is the lens witness at @s@ composed with the grate witness at @s ~~> a@.+glass+  :: forall {k} (s :: k) (t :: k) a b+   . (CCC k, Ob s, Ob a, Ob b)+  => ((s && Mod s a b) ~> t) -> Glass s t a b+glass f =+  withObSel @s @a @a $+    withObExp @k @(s ~~> a) @b $+      let ev = curry @k @s @(s ~~> a) (apply @k @s @a . swap @k @s @(s ~~> a))+      in legs2prof @GlassFl+           (Rep @(Mod s a a) @(Product s) (id P.&&& ev) :.: Rep @a @(Exp (s ~~> a)) (obj @(Mod s a a)))+           (Corep @b @(Exp (s ~~> a)) (obj @(Mod s a b)) :.: Corep @(Mod s a b) @(Product s) f)++-- | Eliminate any glass-flavored optic (a lens, a grate, or a composite of both, in either+-- encoding) to its single leg.+withGlass+  :: forall {k} c (s :: k) (t :: k) a b r+   . (CCC k, (Ob a, Ob b) => c (ExOptic GlassFl a b))+  => Optic c s t a b -> (((s && Mod s a b) ~> t) -> r) -> r+withGlass o k = withLegs @GlassFl o \ @p @q p q -> k (glassP @p @q p q)
+ src/Proarrow/Optic/Grate.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | The __grate__: the closed-category optic whose residual sits under an exponential,+--+-- > Grate s t a b = exists m. (s ~> (m ~~> a), (m ~~> b) ~> t)+--+-- witnessed by @'Rep'@\/@'Corep'@ @('Exp' m)@ ('GrateFl' \/ 'zipWithP') for a /comonoid/ @m@. The+-- exponential by a comonoid is the reader applicative, so every grate is a+-- 'Proarrow.Optic.Kaleidoscope.Kaleidoscope' (hence a 'Proarrow.Optic.Kaleidoscope.Cotraversal' and a+-- 'Proarrow.Optic.Setter.Setter'), and every 'Proarrow.Optic.PowerGrate.PowerGrate' is a+-- grate. Build with 'grate' (whose residual is the \"logarithm\" @s ~~> a@), eliminate to the+-- zipping function with 'withGrate', via the generic 'ExOptic' carrier.+module Proarrow.Optic.Grate where++import Prelude (($))++import Proarrow.Category.Monoidal (Monoidal (..), SymMonoidal (..), first, second, swap, type (**))+import Proarrow.Category.Monoidal.Closed (Closed (..), Exp)+import Proarrow.Colimit.BinaryCoproduct (HasCoproducts)+import Proarrow.Core (CategoryOf (..), Promonad (..), obj, type (+->))+import Proarrow.Monoid (Comonoid)+import Proarrow.Object (pattern Objs)+import Proarrow.Optic+  ( ExOptic+  , FLAVOR+  , Optic+  , Prostrong (..)+  , legs2prof+  , withLegs+  )+import Proarrow.Optic.Glass (GlassFl, Mod)+import Proarrow.Optic.Kaleidoscope (KaleidoFl)+import Proarrow.Profunctor.Corepresentable (Corep (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Representable (Rep (..))++-- | A grate is a "residual lens" whose residual @m@ sits under an exponential instead of a+-- tensor: @s ~> (m ~~> a)@ and @(m ~~> b) ~> t@. Unlike a 'Proarrow.Optic.Traversal.Traversal',+-- this needs no 'Proarrow.Category.Monoidal.Distributive.StrongDistributiveProfunctor' machinery.+-- 'zipWithP' is built directly out of 'Closed'\/'SymMonoidal' algebra (curry\/apply\/swap),+-- since it manipulates morphisms directly and does not lift an arbitrary effect through a+-- witness functor. 'Proarrow.Optic.Kaleidoscope.KaleidoFl' is a+-- superclass: the residual is a comonoid, so @m ~~> -@ is an applicative functor.+type GrateFl :: forall {k}. FLAVOR k k+class (KaleidoFl p q, GlassFl p q) => GrateFl (p :: k +-> k) (q :: k +-> k) where+  zipWithP+    :: forall s a b t+     . (Closed k, SymMonoidal k) => p s a -> q b t -> (forall (x :: k). (Ob x) => ((x ~~> a) ~> b) -> (x ~~> s) ~> t)++-- | Swap the argument order of a curried two-argument exponential: @x ~~> (m ~~> a) ~> m ~~> (x ~~> a)@.+flipExp+  :: forall {k} (x :: k) m a+   . (Closed k, SymMonoidal k, Ob x, Ob m, Ob a)+  => (x ~~> (m ~~> a)) ~> (m ~~> (x ~~> a))+flipExp =+  withObExp @k @m @a $+    withObExp @k @x @(m ~~> a) $+      withOb2 @k @(x ~~> (m ~~> a)) @m $+        curry @k @(x ~~> (m ~~> a)) @m+          ( curry @k @((x ~~> (m ~~> a)) ** m) @x+              ( apply @k @m @a+                  . first @m (apply @k @x @(m ~~> a))+                  . associatorInv @k @(x ~~> (m ~~> a)) @x @m+                  . second @(x ~~> (m ~~> a)) (swap @k @m @x)+                  . associator @k @(x ~~> (m ~~> a)) @m @x+              )+          )++instance (Closed k, SymMonoidal k, HasCoproducts k, Comonoid m) => GrateFl (Rep (Exp m) :: k +-> k) (Corep (Exp m) :: k +-> k) where+  zipWithP @_ @a (Rep sm) (Corep mbt) @x kk = mbt . (kk ^^^ obj @m) . flipExp @x @m @a . (sm ^^^ obj @x)+instance (CategoryOf k) => GrateFl (Id :: k +-> k) (Id :: k +-> k) where+  zipWithP (Id l) (Id r) @x kk = r . kk . (l ^^^ obj @x)+instance (GrateFl f g, GrateFl f' g') => GrateFl (f :.: f') (g' :.: g) where+  zipWithP (f :.: f') (g' :.: g) @x kk = zipWithP @f @g f g @x (zipWithP @f' @g' f' g' @x kk)++type Grate (s :: k) (t :: k) a b = Optic (Prostrong GrateFl) s t a b+type Grate' s a = Grate s s a a++-- | Eliminate any grate-flavored optic to its zipping function, in either encoding: run it at its+-- witness pair ('ExOptic' 'GrateFl', via 'withLegs') and read the zipper off with 'zipWithP'.+withGrate+  :: forall {k} c (s :: k) (t :: k) a b r+   . (Closed k, SymMonoidal k, (Ob a, Ob b) => c (ExOptic GrateFl a b))+  => Optic c s t a b -> ((forall (x :: k). (Ob x) => ((x ~~> a) ~> b) -> (x ~~> s) ~> t) -> r) -> r+withGrate o k = withLegs @GrateFl o \ @p @q p q -> k (\ @x kk -> zipWithP @p @q p q @x kk)++-- | The canonical\/atomic grate constructor: the residual is the self-referential @s ~~> a@+-- (the "logarithm" of the get side), whose own get-map @m ~> (s ~~> a)@ trivializes to 'id' once+-- @m@ is fixed to be @s ~~> a@. That residual must be a comonoid; in a+-- 'Proarrow.Category.Monoidal.CopyDiscard.CopyDiscard' category every object is.+grate+  :: forall {k} (s :: k) (t :: k) a b+   . (Closed k, SymMonoidal k, HasCoproducts k, Comonoid (s ~~> a), Ob s, Ob a, Ob b)+  => (Mod s a b ~> t) -> Grate s t a b+grate f@Objs =+  withObExp @k @s @a $+    let sa = curry @k @s @(s ~~> a) (apply @k @s @a . swap @k @s @(s ~~> a))+    in legs2prof @GrateFl (Rep @a @(Exp (s ~~> a)) sa) (Corep @b @(Exp (s ~~> a)) f)
+ src/Proarrow/Optic/Iso.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The __iso__: the bottom of the subtyping lattice, usable as every other flavor. 'IsoFl' is+-- the conjunction of the five maximal flavors ('Proarrow.Optic.Lens.LensFl',+-- 'Proarrow.Optic.Prism.PrismFl', 'Proarrow.Optic.PowerGrate.PowerGrateFl',+-- 'Proarrow.Optic.MonoidalLens.MonLensFl' and 'Proarrow.Optic.Tracer.TracerFl'). Build with+-- 'iso', and eliminate to the two legs with 'withIso' via the 'Yo' carrier. That carrier also+-- eliminates 'Proarrow.Optic.re'-versed isos, a conversion the subtyping lattice itself cannot+-- express. 'fromPIso'\/'toPIso' mediate with the profunctor-class-flavored 'PIso'.+module Proarrow.Optic.Iso where++import Proarrow.Category.Instance.Opposite (OPPOSITE (..))+import Proarrow.Core (CategoryOf (..), Promonad (..), type (+->))+import Proarrow.Optic+  ( FLAVOR+  , Flip+  , Optic+  , Optic_ (..)+  , PIso+  , Prostrong (..)+  , Sub (..)+  , convert+  , iso+  )+import Proarrow.Optic.Getter (getP)+import Proarrow.Optic.Lens (LensFl)+import Proarrow.Optic.MonoidalLens (MonLensFl)+import Proarrow.Optic.PowerGrate (PowerGrateFl)+import Proarrow.Optic.Prism (PrismFl)+import Proarrow.Optic.Tracer (TracerFl)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Yoneda (Yo (..))++-- | The iso flavor. Reversed isos still view\/preview\/fold (@'Proarrow.Optic.re' iso@ is a getter,+-- and more), through the @'Proarrow.Optic.Getter.GetterFl' q p@ superclass of 'PrismFl'.+class (LensFl p q, PrismFl p q, PowerGrateFl p q, MonLensFl p q, TracerFl p q) => IsoFl p q++instance (LensFl p q, PrismFl p q, PowerGrateFl p q, MonLensFl p q, TracerFl p q) => IsoFl p q++-- | The 'Prostrong'-flavored iso; for the profunctor-class-flavored encoding see 'Proarrow.Optic.PIso'.+type Iso (s :: k) (t :: k) a b = Optic (Prostrong IsoFl) s t a b++type Iso' s a = Iso s s a a++-- | Any flavor whose optics are isos has strength for the 'Yo' profunctor.+instance (CategoryOf k, forall p q. (w p q) => Sub IsoFl p q) => Prostrong (w :: FLAVOR k k) (Yo a (OP b) :: k +-> k) where+  proact @f @g (f :.: Yo sa bt :.: g) = sub @IsoFl @f @g (Yo (sa . getP @f @g f) (getP @g @f g . bt))++-- | 'Proarrow.Optic.re'-versed isos are still isos: the same carrier eliminates them by reading+-- the witness pair backwards. This is a conversion the subtyping lattice cannot express (the+-- entailment @IsoFl q p => IsoFl p q@ doesn't hold), but the carrier can compute it.+instance {-# OVERLAPPING #-} (CategoryOf k) => Prostrong (Flip IsoFl) (Yo (a :: k) (OP b) :: k +-> k) where+  proact @f @g (f :.: Yo sa bt :.: g) = Yo (sa . getP @f @g f) (getP @g @f g . bt)++-- | Eliminate any iso-flavored optic to its two legs, in either encoding, including the+-- profunctor-class-flavored 'Proarrow.Optic.PIso' and reversed ('Proarrow.Optic.re') isos.+withIso+  :: forall {k} c (s :: k) (t :: k) a b r+   . (CategoryOf k, (Ob a, Ob b) => c (Yo a (OP b)))+  => Optic c s t a b -> ((s ~> a) -> (b ~> t) -> r) -> r+withIso (Optic l) k = case l @(Yo a (OP b)) (Yo id id) of Yo sa bt -> k sa bt++-- | The two iso encodings are equivalent: this direction instantiates the+-- profunctor-class-flavored iso at the free 'IsoFl'-strong profunctor @ExOptic 'IsoFl' a b@,+-- which needs nothing beyond its 'Proarrow.Core.Profunctor' instance.+fromPIso :: forall {k} (s :: k) (t :: k) a b. (CategoryOf k) => PIso s t a b -> Iso s t a b+fromPIso = convert++-- | The other direction of the equivalence, by eliminating to legs and rebuilding.+toPIso :: forall {k} (s :: k) (t :: k) a b. (CategoryOf k) => Iso s t a b -> PIso s t a b+toPIso o = withIso o iso
+ src/Proarrow/Optic/Kaleidoscope.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | The __cotraversal__ and the __kaleidoscope__: two flavors with the same witnesses (the+-- representable 'StrongDistributiveProfunctor's, i.e. applicative functors rendered as profunctors,+-- with their 'RepCostar's) that differ in what they can be eliminated through.+--+-- Both mirror 'Proarrow.Optic.Traversal.MonTravFl'. All three rest on the square+-- @t :.: p ~> p :.: t@ between a functor @t@ and a 'StrongDistributiveProfunctor' @p@ (in @Type@,+-- @sequenceA :: t (f a) -> f (t a)@). A monoidal traversal takes @t@ as the witness and quantifies+-- over @p@; the optics here take @p@ as the witness and quantify over @t@.+--+-- * A 'Cotraversal' passes through every 'Cotraversable' carrier: the square for /arbitrary/ @p@.+--   This holds for finite shapes ('Proarrow.Category.Monoidal.Distributive.Cotraversable'+--   @('RepCostar' t)@ for a traversable representable @t@, 'Id', products, sums).+--+-- * A 'Kaleidoscope' passes through every 'Kaleidoscopic' carrier: the square for /representable/+--   @p@ only. This is the kaleidoscope of Clarke et al. (/Profunctor optics: a categorical update/),+--   @∫^{F applicative} C(S, F A) × C(F B, T)@. In @Type@ it admits unbounded shapes such as+--   @'Costar' t@ for a @Traversable t@ (the @Aggregating@ module of the literature). Those are not+--   'Cotraversable': a generic structural recursion over a list diverges on strict witnesses such+--   as 'Rep'.+--+-- Every 'Cotraversable' carrier is 'Kaleidoscopic' ('cotravAct'), so @'KaleidoFl' <: 'CotravFl'@:+-- the kaleidoscope is the stronger flavor. Both sit below 'Proarrow.Optic.Setter.SetterFl' only,+-- since one can @over@ through an applicative but not fold out of one.+-- 'Proarrow.Optic.PowerGrate.PowerGrateFl' (the reader applicative) and the tensor-action pair for+-- a monoid residual (the writer applicative) are subflavors of 'KaleidoFl', which is how an+-- algebraic lens for the list monad composes with a kaleidoscope+-- ('Proarrow.Optic.Action.ClassifyFl').+module Proarrow.Optic.Kaleidoscope+  ( -- * The cotraversal+    CotravFl (..)+  , Cotraversal+  , Cotraversal'+  , cotraversal+  , cotraverseOf++    -- * The kaleidoscope+  , KaleidoFl (..)+  , Kaleidoscope+  , Kaleidoscope'+  , kaleidoscope+  , kaleidoscopeOf++    -- * Carriers+  , Kaleidoscopic (..)+  , cotravAct+  , CotravAs (..)+  , WrapRep (..)+  ) where++import Data.Kind (Constraint, Type)+import Prelude qualified as P++import Proarrow.Category.Monoidal (MonoidalProfunctor (..), SymMonoidal, Tensor)+import Proarrow.Category.Monoidal.Action (ActionAt)+import Proarrow.Category.Monoidal.Closed (Closed, Exp)+import Proarrow.Category.Monoidal.Distributive (Cotraversable (..), StrongDistributiveProfunctor, Traversable)+import Proarrow.Colimit.BinaryCoproduct (HasCoproducts)+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), (//), (\\), type (+->))+import Proarrow.Functor (Prelude (..))+import Proarrow.Monoid (Comonoid, Monoid)+import Proarrow.Optic (ExOptic, FLAVOR, Optic, Prostrong (..), legs2prof, withLegs)+import Proarrow.Optic.Setter (SetterFl (..))+import Proarrow.Profunctor.Corepresentable (Corep (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Costar (Costar, pattern Costar)+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Representable (Rep (..), RepCostar (..), Representable (..), repUniv)++-- * Carriers++-- | The carriers of the kaleidoscope: profunctors that every representable+-- 'StrongDistributiveProfunctor' @p@ (i.e. every applicative functor @p % -@) acts on by+-- application. Where a traversal's carriers are the applicatives themselves, a kaleidoscope's+-- carriers are the things applicatives can be sequenced through. These are every 'Cotraversable'+-- profunctor ('cotravAct'), and in @Type@ also @'Costar' t@ for any @Traversable t@ (@'Costar' []@+-- directly, and @'Costar' ('Prelude' t)@ for a @t@ that has no 'Proarrow.Functor.Functor' instance+-- of its own).+type Kaleidoscopic :: forall {k}. (k +-> k) -> Constraint+class (Profunctor r) => Kaleidoscopic (r :: k +-> k) where+  kaleidoAct :: forall p a b. (Representable p, StrongDistributiveProfunctor (p :: k +-> k)) => r a b -> r (p % a) (p % b)++-- | 'kaleidoAct' for any 'Cotraversable' carrier: let the witness through.+cotravAct+  :: forall {k} p r (a :: k) b+   . (Cotraversable r, Representable p, StrongDistributiveProfunctor p)+  => r a b -> r (p % a) (p % b)+cotravAct rab = rab // case cotraverse (repUniv @p @a :.: rab) of x :.: y -> rmap (index y) x++-- | A 'Cotraversable' carrier, tagged as the 'Kaleidoscopic' carrier it also is. With it every+-- kaleidoscope witness is a cotraversal witness (the default 'cotravP').+newtype CotravAs r a b = CotravAs {unCotravAs :: r a b}++instance (Profunctor r) => Profunctor (CotravAs r) where+  dimap l r (CotravAs p) = CotravAs (dimap l r p)+  r \\ CotravAs p = r \\ p+instance (Cotraversable r) => Kaleidoscopic (CotravAs r) where+  kaleidoAct @p (CotravAs r) = CotravAs (cotravAct @p r)++-- | The general carrier: the 'RepCostar' of a traversable representable functor.+instance (Traversable t, Representable t) => Kaleidoscopic (RepCostar t) where+  kaleidoAct @p = cotravAct @p++-- | The applicative functor a representable 'StrongDistributiveProfunctor' on 'Type' represents:+-- @pure@ is 'one' and @liftA2@ is '**'.+newtype WrapRep p x = WrapRep {unwrapRep :: p % x}++instance (Representable (p :: Type +-> Type)) => P.Functor (WrapRep p) where+  fmap f (WrapRep x) = WrapRep (repMap @p f x)+instance (Representable p, StrongDistributiveProfunctor (p :: Type +-> Type)) => P.Applicative (WrapRep p) where+  pure x = WrapRep (index (rmap (\() -> x) (one @p)) ())+  liftA2 f (WrapRep x) (WrapRep y) = WrapRep (index (rmap (P.uncurry f) (repUniv @p ** repUniv @p)) (x, y))++-- | @'Costar' ('Prelude' t)@ for a traversable @t@: sequence the applicative through @t@, then+-- aggregate. This carrier is /not/ 'Cotraversable', see the module header.+instance (P.Traversable t) => Kaleidoscopic (Costar (Prelude t)) where+  kaleidoAct @p @a (Costar g) = Costar (\(Prelude tpa) -> repMap @p (g . Prelude) (unwrapRep (P.traverse (WrapRep @p @a) tpa)))++-- | The same for @[]@, which is a 'Proarrow.Functor.Functor' in its own right, so the literature's+-- aggregating carrier can be written as a plain @[a] -> b@.+instance Kaleidoscopic (Costar []) where+  kaleidoAct @p @a (Costar g) = Costar (\tpa -> repMap @p g (unwrapRep (P.traverse (WrapRep @p @a) tpa)))++-- * The cotraversal++-- | The cotraversal flavor: pass any 'Cotraversable' carrier through the witness pair. The+-- mirror of 'Proarrow.Optic.Traversal.MonTravFl', with witness and carrier swapped.+type CotravFl :: forall {k}. FLAVOR k k+class (SetterFl p q) => CotravFl (p :: k +-> k) (q :: k +-> k) where+  cotravP :: (Cotraversable r) => p s a -> q b t -> r a b -> r s t+  default cotravP :: (KaleidoFl p q, Cotraversable r) => p s a -> q b t -> r a b -> r s t+  cotravP l r rab = unCotravAs (kaleidoP l r (CotravAs rab))++-- | The kaleidoscope flavor: act on any 'Kaleidoscopic' carrier through the witness pair.+type KaleidoFl :: forall {k}. FLAVOR k k+class (CotravFl p q) => KaleidoFl (p :: k +-> k) (q :: k +-> k) where+  kaleidoP :: (Kaleidoscopic r) => p s a -> q b t -> r a b -> r s t++-- | The generating witnesses: any representable 'StrongDistributiveProfunctor' (any applicative+-- functor) with its 'RepCostar'. The legs are @s ~> p % a@ and @p % b ~> t@.+instance (Representable p, StrongDistributiveProfunctor p) => CotravFl (p :: k +-> k) (RepCostar p)++instance (Representable p, StrongDistributiveProfunctor p) => KaleidoFl (p :: k +-> k) (RepCostar p) where+  kaleidoP l (RepCostar r) rab = dimap (index l) r (kaleidoAct @_ @p rab)++-- | The tensor-action pair for a monoid residual: @m ** -@ is the writer applicative.+instance+  (SymMonoidal k, HasCoproducts k, Monoid (m :: k))+  => CotravFl (Rep (ActionAt Tensor m) :: k +-> k) (Corep (ActionAt Tensor m))++instance+  (SymMonoidal k, HasCoproducts k, Monoid (m :: k))+  => KaleidoFl (Rep (ActionAt Tensor m) :: k +-> k) (Corep (ActionAt Tensor m))+  where+  kaleidoP (Rep h) (Corep i) rab = dimap h i (kaleidoAct @_ @(Rep (ActionAt Tensor m)) rab)++-- | The exponential pair for a comonoid exponent: @m ~~> -@ is the reader applicative. So every+-- 'Proarrow.Optic.Grate.Grate' is a kaleidoscope.+instance (Closed k, SymMonoidal k, HasCoproducts k, Comonoid (m :: k)) => CotravFl (Rep (Exp m) :: k +-> k) (Corep (Exp m))++instance (Closed k, SymMonoidal k, HasCoproducts k, Comonoid (m :: k)) => KaleidoFl (Rep (Exp m) :: k +-> k) (Corep (Exp m)) where+  kaleidoP (Rep h) (Corep i) rab = dimap h i (kaleidoAct @_ @(Rep (Exp m)) rab)++instance (CategoryOf k) => CotravFl (Id :: k +-> k) (Id :: k +-> k) where+  cotravP (Id l) (Id r) = dimap l r+instance (CategoryOf k) => KaleidoFl (Id :: k +-> k) (Id :: k +-> k) where+  kaleidoP (Id l) (Id r) = dimap l r+instance (CotravFl f g, CotravFl f' g') => CotravFl (f :.: f') (g' :.: g) where+  cotravP (f :.: f') (g' :.: g) = cotravP @f @g f g . cotravP @f' @g' f' g'+instance (KaleidoFl f g, KaleidoFl f' g') => KaleidoFl (f :.: f') (g' :.: g) where+  kaleidoP (f :.: f') (g' :.: g) = kaleidoP @f @g f g . kaleidoP @f' @g' f' g'++type Cotraversal (s :: k) (t :: k) a b = Optic (Prostrong CotravFl) s t a b+type Cotraversal' s a = Cotraversal s s a a++type Kaleidoscope (s :: k) (t :: k) a b = Optic (Prostrong KaleidoFl) s t a b+type Kaleidoscope' s a = Kaleidoscope s s a a++-- | Build a cotraversal from its legs through an applicative functor, given as a representable+-- 'StrongDistributiveProfunctor' @p@.+cotraversal+  :: forall {k} p (s :: k) (t :: k) a b+   . (Representable p, StrongDistributiveProfunctor p, Ob a, Ob b)+  => (s ~> p % a) -> (p % b ~> t) -> Cotraversal s t a b+cotraversal l r = legs2prof @CotravFl (tabulate @p l) (RepCostar @_ @p r)++-- | Build a kaleidoscope from the same legs.+kaleidoscope+  :: forall {k} p (s :: k) (t :: k) a b+   . (Representable p, StrongDistributiveProfunctor p, Ob a, Ob b)+  => (s ~> p % a) -> (p % b ~> t) -> Kaleidoscope s t a b+kaleidoscope l r = legs2prof @KaleidoFl (tabulate @p l) (RepCostar @_ @p r)++-- | Pass a 'Cotraversable' carrier through a cotraversal (or any stronger optic, in any encoding,+-- '(%)'-composites included).+cotraverseOf+  :: forall {k} c (s :: k) (t :: k) a b r+   . (CategoryOf k, Cotraversable r, (Ob a, Ob b) => c (ExOptic CotravFl a b))+  => Optic c s t a b -> r a b -> r s t+cotraverseOf o rab = withLegs @CotravFl o \l r -> cotravP l r rab++-- | Act on a 'Kaleidoscopic' carrier through a kaleidoscope (or any stronger optic, in any+-- encoding, '(%)'-composites included). At @'Costar' []@ this is the literature's+-- aggregation operator @>-@: from @[a] -> b@ to @[s] -> t@.+kaleidoscopeOf+  :: forall {k} c (s :: k) (t :: k) a b r+   . (CategoryOf k, Kaleidoscopic r, (Ob a, Ob b) => c (ExOptic KaleidoFl a b))+  => Optic c s t a b -> r a b -> r s t+kaleidoscopeOf o rab = withLegs @KaleidoFl o \l r -> kaleidoP l r rab++-- | The carriers as instances, so that an optic of these flavors composed with another flavor that+-- also runs at the carrier can be eliminated there directly.+instance (Traversable t, Representable t) => Prostrong CotravFl (RepCostar t) where+  proact (f :.: c :.: g) = cotravP f g c++instance (Traversable t, Representable t) => Prostrong KaleidoFl (RepCostar t) where+  proact (f :.: c :.: g) = kaleidoP f g c+instance (P.Traversable t) => Prostrong KaleidoFl (Costar (Prelude t)) where+  proact (f :.: c :.: g) = kaleidoP f g c+instance Prostrong KaleidoFl (Costar []) where+  proact (f :.: c :.: g) = kaleidoP f g c
+ src/Proarrow/Optic/Lens.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | The __lens__: the optic for the categorical product, with legs+--+-- > Lens s t a b = (s ~> a, (s && b) ~> t)+--+-- witnessed by @'Rep'@\/@'Corep'@ @('Product' s)@ ('LensFl' \/ 'putP'). The product residual is+-- the whole source @s@. A lens both views and sets, sitting below 'Proarrow.Optic.Getter.Getter'+-- and 'Proarrow.Optic.AffineTraversal.AffineTraversal' in the lattice. Build with 'lens' (or from+-- the van-Laarhoven form with 'lensVL'), eliminate to the two legs with 'withLens', via the+-- generic 'ExOptic' carrier.+module Proarrow.Optic.Lens where++import Data.Functor.Const (Const (..))+import Prelude (const)+import Prelude qualified as P++import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), (\\), type (+->))+import Proarrow.Functor (Functor (map), Prelude (..))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..), Product, first)+import Proarrow.Object (pattern Objs)+import Proarrow.Optic+  ( ExOptic+  , FLAVOR+  , Optic+  , Optic_ (..)+  , Prostrong (..)+  , legs2prof+  , withLegs+  )+import Proarrow.Optic.AffineTraversal (AffineTravFl (..))+import Proarrow.Optic.Getter (GetterFl (..))+import Proarrow.Optic.Glass (GlassFl)+import Proarrow.Profunctor.Corepresentable (Corep (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Instance.Star (Star, unStar, pattern Star)+import Proarrow.Profunctor.Representable (Rep (..))++type LensFl :: forall {k}. FLAVOR k k+class (AffineTravFl p q, GetterFl p q, GlassFl p q) => LensFl (p :: k +-> k) (q :: k +-> k) where+  -- | Like 'affineSet', but with a weaker constraint. Lens witnesses only ever need binary+  -- products, so lenses stay usable in categories without coproducts.+  putP :: (HasBinaryProducts k) => p (s :: k) a -> q b t -> (s && b) ~> t+instance (HasBinaryProducts k, Ob (s :: k)) => LensFl (Rep (Product s)) (Corep (Product s)) where+  putP @_ @a @b (Rep p) (Corep q) = q . first @b (fst @k @s @a . p)+instance (CategoryOf k) => LensFl (Id :: k +-> k) (Id :: k +-> k) where+  putP @s @_ @b sa (Id bt) = bt . snd @k @s @b \\ sa \\ bt+instance (LensFl f g, LensFl f' g') => LensFl (f :.: f') (g' :.: g) where+  putP @s @_ @b (f@Objs :.: f') (g'@Objs :.: g) =+    putP @f @g f g . (fst @_ @s @b &&& (putP @f' @g' f' g' . first @b (getP @f @g f)))++type Lens (s :: k) (t :: k) a b = Optic (Prostrong LensFl) s t a b+type Lens' s a = Lens s s a a+lens+  :: forall {k} (s :: k) (t :: k) a b+   . (HasBinaryProducts k, Ob b) => (s ~> a) -> ((s && b) ~> t) -> Lens s t a b+lens sa sbt =+  legs2prof @LensFl (Rep @a @(Product s) (id &&& sa)) (Corep @b @(Product s) sbt) \\ sa++-- | Eliminate any optic that is at least an iso and at most a lens to its two legs, in either+-- encoding: run it at its witness pair ('ExOptic' 'LensFl', via 'withLegs') and read the legs off+-- with 'getP' and 'putP'.+withLens+  :: forall {k} c (s :: k) (t :: k) a b r+   . (HasBinaryProducts k, (Ob a, Ob b) => c (ExOptic LensFl a b))+  => Optic c s t a b -> ((s ~> a) -> ((s && b) ~> t) -> r) -> r+withLens o k = withLegs @LensFl o \ @p @q p q -> k (getP @p @q p) (putP @p @q p q)++instance (P.Functor f) => Prostrong LensFl (Star (Prelude f)) where+  proact @p @q (p@Objs :.: Star f :.: q@Objs) = Star \a -> map (P.curry (putP p q) a) (f (getP @p @q p a))++type LensVL s t a b = forall f. (P.Functor f) => (a -> f b) -> s -> f t+toLensVL :: Lens s t a b -> LensVL s t a b+toLensVL (Optic l) = (unPrelude .) . unStar . l . Star . (Prelude .)++lensVL :: LensVL s t a b -> Lens s t a b+lensVL f = lens (getConst . f Const) (P.uncurry (f (const id)))
+ src/Proarrow/Optic/MonoidalLens.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The __monoidal lens__: the coend optic for the tensor action with a __comonoidal residual__,+--+-- > MonoidalLens s t a b = exists m. Comonoid m => (s ~> m ** a, m ** b ~> t)+--+-- The residual can be discarded (@'counit' :: m ~> 'Unit'@) and copied, which is what a lens's+-- @get@ needs, so a monoidal lens views, sets, folds and traverses:+--+-- > Lens         <: { Getter, AffineTraversal, Glass }                     -- product residual+-- > MonoidalLens <: { Getter, MonoidalTraversal, AffineTraversal, Glass }  -- comonoidal tensor residual+--+-- It is not a 'Proarrow.Optic.Lens.Lens', because 'Proarrow.Optic.Lens.putP' works with binary+-- products alone, unrelated to the tensor. It is an+-- 'Proarrow.Optic.AffineTraversal.AffineTraversal' and a 'Proarrow.Optic.Glass.Glass', because+-- their methods ask for a cartesian category, where the tensor is the product and the residual can+-- be projected out.+module Proarrow.Optic.MonoidalLens where++import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal, Tensor)+import Proarrow.Category.Monoidal.Action (ActionAt)+import Proarrow.Colimit.BinaryCoproduct (lft, rgt)+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), obj, (\\), type (+->))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..), first)+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Monoid (Comonoid, ComonoidOn, comonoidOn, tensorComonoid, unitComonoid)+import Proarrow.Monoid qualified as Mon+import Proarrow.Object (pattern Objs)+import Proarrow.Optic+  ( ExOptic+  , FLAVOR+  , Optic+  , Prostrong (..)+  , legs2prof+  , withLegs+  )+import Proarrow.Optic.AffineFold (AffineFoldFl (..))+import Proarrow.Optic.AffineTraversal (AffineTravFl (..))+import Proarrow.Optic.Getter (GetterFl (..))+import Proarrow.Optic.Glass (GlassFl (..), Mod, applySel, withObSel)+import Proarrow.Optic.Traversal (MonTravFl)+import Proarrow.Profunctor.Corepresentable (Corep (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Representable (Rep (..))+import Prelude (($))++-- | The tensor-action witness pair @'Rep'@\/@'Corep'@ @('ActionAt' 'Tensor' m)@ views (and previews)+-- when the residual @m@ is a 'Comonoid': discard it with the counit. (Its setter and traversal+-- instances live in "Proarrow.Optic.Setter" and "Proarrow.Optic.Traversal".)+instance (Comonoid (m :: k)) => AffineFoldFl (Rep (ActionAt Tensor m) :: k +-> k) (Corep (ActionAt Tensor m)) where+  previewP @_ @a (Rep h) = lft @k @a @TerminalObject . leftUnitor . (Mon.counit @m ** obj @a) . h++instance (Comonoid (m :: k)) => GetterFl (Rep (ActionAt Tensor m) :: k +-> k) (Corep (ActionAt Tensor m)) where+  getP @_ @a (Rep h) = leftUnitor . (Mon.counit @m ** obj @a) . h++-- | In a cartesian category the tensor /is/ the product, so the comonoidal residual can be+-- projected out and put back: 'affineSet' and 'glassP' carry that assumption in their own+-- constraints ('Bicartesian', 'CCC'), which is why these instances exist while a 'LensFl' one+-- cannot ('putP' has only 'HasBinaryProducts').+instance (Comonoid (m :: k)) => AffineTravFl (Rep (ActionAt Tensor m) :: k +-> k) (Corep (ActionAt Tensor m)) where+  -- a lens always matches+  affineMatch @_ @a @_ @t (Rep h) Objs = rgt @k @t @a . leftUnitor . (Mon.counit @m ** obj @a) . h+  affineSet @_ @a @b (Rep h) (Corep i) = i . first @b (fst @k @m @a . h)++instance (Comonoid (m :: k)) => GlassFl (Rep (ActionAt Tensor m) :: k +-> k) (Corep (ActionAt Tensor m)) where+  glassP @s @a @b (Rep h@Objs) (Corep i) =+    withObSel @s @a @b $+      i+        . ( (fst @k @m @a . h . fst @k @s @(Mod s a b))+              &&& (applySel @s @a @b (snd @k @m @a . h) . snd @k @s @(Mod s a b))+          )++-- | The monoidal-lens flavor: a lens whose residual is a comonoid, so it is a+-- 'Proarrow.Optic.Getter.Getter' and a 'Proarrow.Optic.MonoidalTraversal.MonoidalTraversal', and+-- in cartesian categories an 'Proarrow.Optic.AffineTraversal.AffineTraversal' and a+-- 'Proarrow.Optic.Glass.Glass'.+type MonLensFl :: forall {k}. FLAVOR k k+class (GetterFl p q, MonTravFl p q, AffineTravFl p q, GlassFl p q) => MonLensFl (p :: k +-> k) (q :: k +-> k) where+  -- | Recover a monoidal lens's two legs and the comonoid structure of its existential residual+  -- @m@. The comonoid comes as a value ('ComonoidOn') rather than a 'Comonoid' constraint, because+  -- the residual of a composite is a tensor and that of the identity the unit, and type families+  -- cannot head an instance. A tensor of comonoids is a comonoid by symmetry.+  withMonLensP+    :: (SymMonoidal k)+    => p s a -> q b t -> (forall (m :: k). (Ob m) => ComonoidOn m -> (s ~> m ** a) -> (m ** b ~> t) -> r) -> r++instance (Comonoid (m :: k)) => MonLensFl (Rep (ActionAt Tensor m) :: k +-> k) (Corep (ActionAt Tensor m)) where+  withMonLensP (Rep h) (Corep i) k = k @m (comonoidOn @m) h i++instance (CategoryOf k) => MonLensFl (Id :: k +-> k) (Id :: k +-> k) where+  withMonLensP (Id sa) (Id bt) k = k @Unit unitComonoid (leftUnitorInv . sa) (bt . leftUnitor) \\ sa \\ bt++instance+  forall k (f :: k +-> k) (f' :: k +-> k) (g :: k +-> k) (g' :: k +-> k)+   . (MonLensFl f g, MonLensFl f' g')+  => MonLensFl (f :.: f') (g' :.: g)+  where+  withMonLensP (f :.: (f'@Objs :: f' hix afoc)) ((g'@Objs :: g' bfoc giy) :.: g) kk =+    withMonLensP f g \ @(mo :: k) co ho io ->+      withMonLensP f' g' \ @(mi :: k) ci hi ii ->+        withOb2 @k @mo @mi+          ( kk @(mo ** mi)+              (tensorComonoid co ci)+              (associatorInv @k @mo @mi @afoc . (obj @mo ** hi) . ho)+              (io . (obj @mo ** ii) . associator @k @mo @mi @bfoc)+          )++type MonoidalLens (s :: k) (t :: k) a b = Optic (Prostrong MonLensFl) s t a b+type MonoidalLens' s a = MonoidalLens s s a a++-- | Build a monoidal lens from its two legs and a chosen __comonoidal__ residual @m@.+monLens+  :: forall {k} (m :: k) (s :: k) t a b+   . (Comonoid m, Ob a, Ob b) => (s ~> m ** a) -> (m ** b ~> t) -> MonoidalLens s t a b+monLens h i = legs2prof @MonLensFl (Rep @a @(ActionAt Tensor m) h) (Corep @b @(ActionAt Tensor m) i)++-- | Eliminate any optic that is at least an iso and at most a monoidal lens to its two legs,+-- recovering the existential residual @m@ together with its comonoid structure: run it at its+-- witness pair ('ExOptic' 'MonLensFl', via 'withLegs') and read the legs off with 'withMonLensP'.+withMonLens+  :: forall {k} c (s :: k) (t :: k) a b r+   . (SymMonoidal k, (Ob a, Ob b) => c (ExOptic MonLensFl a b))+  => Optic c s t a b -> (forall m. (Ob m) => ComonoidOn m -> (s ~> m ** a) -> (m ** b ~> t) -> r) -> r+withMonLens o k = withLegs @MonLensFl o \ @p @q p q -> withMonLensP @p @q p q \ @m co h i -> k @m co h i
+ src/Proarrow/Optic/MonoidalTraversal.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The __monoidal traversal__ optic and its free-profunctor apparatus. The mutually recursive+-- 'TravFl'\/'MonTravFl' flavor classes and their leaf instances live in+-- "Proarrow.Optic.Traversal". A 'MonoidalTraversal' distributes any+-- 'StrongDistributiveProfunctor' with no product-strength requirement; the profunctor-class+-- encoding 'PTraversal' converts to and from it via 'toPTraversal'\/'fromPTraversal', the latter+-- through the generic carrier @'ExOptic' 'MonTravFl'@, made an SDP here by generators (the Day+-- halves, the tensor-action witness @'Rep'@\/@'Corep'@ @('ActionAt' 'Tensor' _)@ and the coproduct prism).+module Proarrow.Optic.MonoidalTraversal where++import GHC.Generics qualified as G+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal, Tensor)+import Proarrow.Category.Monoidal.Action (ActionAt, CoprodAction, ProdAction)+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard (..))+import Proarrow.Category.Monoidal.Distributive (Distributive, StrongDistributiveProfunctor)+import Proarrow.Category.Monoidal.Strength (Strong (..), strongId)+import Proarrow.Colimit.BinaryCoproduct+  ( COPROD (..)+  , Coprod (..)+  , Coproduct+  , HasBinaryCoproducts (..)+  , HasCoproducts+  , nil+  , (++)+  )+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), UN, type (+->), type (:&&:))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..), HasProducts, PROD (..), Product)+import Proarrow.Object (pattern Objs)+import Proarrow.Optic+  ( ExOptic (..)+  , FLAVOR+  , Flavor+  , Optic+  , Optic_ (..)+  , Prostrong (..)+  , convert+  , withLegs+  )+import Proarrow.Optic.Traversal+  ( Beside+  , BesideSum+  , CoBeside+  , CoBesideSum+  , CoUnitW (..)+  , CoZeroW (..)+  , MonTravFl (..)+  , TravFl (..)+  , Traversal+  , UnitW (..)+  , ZeroW (..)+  )+import Proarrow.Profunctor.Corepresentable (Corep, Corepresentable (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Representable (Rep, Representable (..))+import Prelude (Either (..), const, either, uncurry, ($))++type MonoidalTraversal (s :: k) (t :: k) a b = Optic (Prostrong MonTravFl) s t a b+type MonoidalTraversal' s a = MonoidalTraversal s s a a++-- * The generic carrier is a strong distributive profunctor, by generators++-- Each piece of 'StrongDistributiveProfunctor' structure on @'ExOptic' w a b@ composes one more+-- generating witness pair onto the legs, so each instance holds for any closed flavor @w@ containing+-- that generator: 'UnitW'\/'Beside' for the tensor, 'ZeroW'\/'BesideSum' for the coproduct, the+-- tensor-action pair for tensor strength, and the prism and lens witnesses for the action+-- strengths. So 'PTraversal' and 'PTraversalFull' can be eliminated through 'ExOptic' by the+-- generic eliminators ('Proarrow.Optic.Setter.over', 'Proarrow.Optic.Fold.foldMapOf', ...), and+-- 'fromPTraversal' instantiates at this carrier.++exBeside+  :: forall {k} (w :: FLAVOR k k) (a :: k) b s1 t1 s2 t2+   . ( Monoidal k+     , forall p1 p2 q1 q2+        . (w p1 q1, w p2 q2, Profunctor p1, Profunctor p2, Profunctor q1, Profunctor q2)+       => w (Beside p1 p2) (CoBeside q1 q2)+     )+  => ExOptic w a b s1 t1 -> ExOptic w a b s2 t2 -> ExOptic w a b (s1 ** s2) (t1 ** t2)+exBeside (ExOptic @p1 @q1 l1@Objs r1@Objs) (ExOptic @p2 @q2 l2@Objs r2@Objs) =+  withOb2 @k @s1 @s2 $+    withOb2 @k @t1 @t2 $+      ExOptic @(Beside p1 p2) @(CoBeside q1 q2)+        (repUniv :.: (l1 :**: l2) :.: repUniv)+        (corepUniv :.: (r1 :**: r2) :.: corepUniv)++exBesideSum+  :: forall {k} (w :: FLAVOR k k) (a :: k) b s1 t1 s2 t2+   . ( HasBinaryCoproducts k+     , forall p1 p2 q1 q2+        . (w p1 q1, w p2 q2, Profunctor p1, Profunctor p2, Profunctor q1, Profunctor q2)+       => w (BesideSum p1 p2) (CoBesideSum q1 q2)+     )+  => ExOptic w a b s1 t1 -> ExOptic w a b s2 t2 -> ExOptic w a b (s1 || s2) (t1 || t2)+exBesideSum (ExOptic @p1 @q1 l1@Objs r1@Objs) (ExOptic @p2 @q2 l2@Objs r2@Objs) =+  withObCoprod @k @s1 @s2 $+    withObCoprod @k @t1 @t2 $+      ExOptic @(BesideSum p1 p2) @(CoBesideSum q1 q2)+        (repUniv :.: (l1 :**: l2) :.: repUniv)+        (corepUniv :.: (r1 :**: r2) :.: corepUniv)++instance+  ( Monoidal k+  , Ob (a :: k)+  , Ob b+  , w UnitW CoUnitW+  , forall p1 p2 q1 q2+     . (w p1 q1, w p2 q2, Profunctor p1, Profunctor p2, Profunctor q1, Profunctor q2)+    => w (Beside p1 p2) (CoBeside q1 q2)+  )+  => MonoidalProfunctor (ExOptic w a b :: k +-> k)+  where+  one = ExOptic (UnitW id) (CoUnitW id)+  (**) = exBeside++instance+  ( HasCoproducts k+  , Ob (a :: k)+  , Ob b+  , w ZeroW CoZeroW+  , forall p1 p2 q1 q2+     . (w p1 q1, w p2 q2, Profunctor p1, Profunctor p2, Profunctor q1, Profunctor q2)+    => w (BesideSum p1 p2) (CoBesideSum q1 q2)+  )+  => MonoidalProfunctor (Coprod (ExOptic w a b :: k +-> k))+  where+  one = Coprod (ExOptic (ZeroW id) (CoZeroW id))+  Coprod l ** Coprod r = Coprod (exBesideSum l r)++instance+  ( Monoidal k+  , Ob (a :: k)+  , Ob b+  , Flavor w+  , forall (x :: k). (Ob x) => w (Rep (ActionAt Tensor x)) (Corep (ActionAt Tensor x))+  )+  => Strong Tensor (ExOptic w a b :: k +-> k)+  where+  act @x @y @z (ExOptic @p @q l@Objs r@Objs) =+    withOb2 @k @x @y $+      withOb2 @k @x @z $+        ExOptic @(Rep (ActionAt Tensor x) :.: p) @(q :.: Corep (ActionAt Tensor x)) (repUniv :.: l) (r :.: corepUniv)++instance+  ( HasCoproducts k+  , Ob (a :: k)+  , Ob b+  , Flavor w+  , forall (t :: k). (Ob t) => w (Rep (Coproduct t)) (Corep (Coproduct t))+  )+  => Strong CoprodAction (ExOptic w a b :: k +-> k)+  where+  act @cx @y @z (ExOptic @p @q l@Objs r@Objs) =+    withObCoprod @k @(UN COPR cx) @y $+      withObCoprod @k @(UN COPR cx) @z $+        ExOptic @(Rep (Coproduct (UN COPR cx)) :.: p) @(q :.: Corep (Coproduct (UN COPR cx))) (repUniv :.: l) (r :.: corepUniv)++instance+  (HasProducts k, Ob (a :: k), Ob b, Flavor w, forall (s :: k). (Ob s) => w (Rep (Product s)) (Corep (Product s)))+  => Strong ProdAction (ExOptic w a b :: k +-> k)+  where+  act @px @y @z (ExOptic @p @q l@Objs r@Objs) =+    withObProd @k @(UN PR px) @y $+      withObProd @k @(UN PR px) @z $+        ExOptic @(Rep (Product (UN PR px)) :.: p) @(q :.: Corep (Product (UN PR px))) (repUniv :.: l) (r :.: corepUniv)++-- | The other half of the equivalence between the encodings: instantiate the profunctor-class+-- traversal at @'ExOptic' 'MonTravFl' a b@, an SDP by the instances above. Its tensor strength+-- comes from the tensor-action witness @'Rep' ('ActionAt' 'Tensor' _)@, so this needs only+-- 'Proarrow.Category.Monoidal.CopyDiscard.CopyDiscard', already demanded by the coproduct prism,+-- and no 'Proarrow.Category.Monoidal.Cartesian.Cartesian'. So @Mat@ and @FinRel@ qualify, but+-- @LINEAR@, which cannot discard, does not. A 'Traversal' follows since 'MonTravFl' is a subflavor+-- of 'TravFl'.+fromPTraversal+  :: forall {k} (s :: k) (t :: k) a b+   . (Distributive k, CopyDiscard k, SymMonoidal k)+  => PTraversal s t a b -> MonoidalTraversal s t a b+fromPTraversal = convert++-- | Like 'Proarrow.Optic.Traversal.traverseOf', but for a 'MonoidalTraversal': distributes any+-- 'StrongDistributiveProfunctor' with /no/ product-strength requirement on the carrier. Every non-lens traversal (prism,+-- 'Proarrow.Category.Monoidal.Distributive.Traversable' functor, ...) is a monoidal traversal, so this accepts carriers like @'Proarrow.Promonad.Writer.Writer' w@+-- that are tensor-strong but not product-strong.+--+-- Accepts any encoding (cf. 'Proarrow.Optic.Traversal.traverseOf'): a 'PTraversal' works directly,+-- as does a '(%)'-composite.+monTraverseOf+  :: forall {k} c (s :: k) (t :: k) a b p+   . (Distributive k, StrongDistributiveProfunctor p, (Ob a, Ob b) => c (ExOptic MonTravFl a b))+  => Optic c s t a b -> p a b -> p s t+monTraverseOf o pab = withLegs @MonTravFl o \l r -> monTravP l r pab++-- | A traversal in the profunctor-class-flavored encoding (cf. 'Proarrow.Optic.PIso'), used by+-- the "GHC.Generics" combinators below. Equivalent to 'Traversal' via 'toPTraversal' and+-- 'fromPTraversal'.+type PTraversal s t a b = Optic StrongDistributiveProfunctor s t a b++type PTraversal' s a = PTraversal s s a a++-- | Half of the equivalence between the two traversal encodings: eliminate the existential+-- witnesses with 'travP' at the caller's profunctor.+toPTraversal+  :: forall {k} (s :: k) (t :: k) a b+   . (Distributive k)+  => MonoidalTraversal s t a b -> PTraversal s t a b+toPTraversal o = withLegs @MonTravFl o \l@Objs r@Objs -> Optic (monTravP l r)++-- | A full traversal in the profunctor-class encoding: distributes any profunctor carrying both+-- distributive strength and __product__ strength, the constraint 'travP' demands. This is+-- the 'Traversal' analog of 'PTraversal', which drops the product strength (all it needs for a+-- 'MonoidalTraversal'). Equivalent to 'Traversal' via 'toPTraversalFull' and 'traversal'.+type PTraversalFull s t a b = Optic (StrongDistributiveProfunctor :&&: Strong ProdAction) s t a b++-- | Build a 'Traversal' from its van-Laarhoven \/ profunctor-class form, by instantiating the+-- rank-2 function at the generic carrier @'ExOptic' 'TravFl' a b@ (a 'StrongDistributiveProfunctor'+-- /and/ @'Strong' 'ProdAction'@, unlike @'ExOptic' 'MonTravFl' a b@, since 'TravFl' contains the+-- product-lens witness). The 'Traversal' analog of 'fromPTraversal'.+traversal+  :: forall {k} (s :: k) t a b+   . (Distributive k, CopyDiscard k, SymMonoidal k, HasProducts k, Ob a, Ob b, Ob s, Ob t)+  => (forall r. (StrongDistributiveProfunctor r, Strong ProdAction r) => r a b -> r s t) -> Traversal s t a b+traversal f = convert (Optic f :: PTraversalFull s t a b)++-- | Eliminate a 'Traversal' to its profunctor-class form (the analog of 'toPTraversal'): run 'travP'+-- at the caller's profunctor.+toPTraversalFull+  :: forall {k} (s :: k) (t :: k) a b+   . (Distributive k)+  => Traversal s t a b -> PTraversalFull s t a b+toPTraversalFull o = withLegs @TravFl o \l@Objs r@Objs -> Optic (travP l r)++v1Optic :: PTraversal (G.V1 a) (G.V1 a') a a'+v1Optic = Optic \_ -> dimap (\case {}) (\case {}) nil++u1Optic :: PTraversal (G.U1 a) (G.U1 a') a a'+u1Optic = Optic \_ -> dimap (const ()) (\() -> G.U1) one++par1Optic :: PTraversal (G.Par1 a) (G.Par1 a') a a'+par1Optic = Optic (dimap G.unPar1 G.Par1)++rec1Optic :: PTraversal (f a) (f a') a a' -> PTraversal (G.Rec1 f a) (G.Rec1 f a') a a'+rec1Optic (Optic l) = Optic \p -> dimap G.unRec1 G.Rec1 (l p)++m1Optic :: PTraversal (f a) (f a') a a' -> PTraversal (G.M1 i k f a) (G.M1 i k f a') a a'+m1Optic (Optic l) = Optic \p -> dimap G.unM1 G.M1 (l p)++k1Optic :: forall i k a a'. PTraversal (G.K1 i k a) (G.K1 i k a') a a'+k1Optic = Optic \_ -> dimap G.unK1 G.K1 strongId++plusOptic+  :: PTraversal (p a) (p a') a a'+  -> PTraversal (q a) (q a') a a'+  -> PTraversal ((p G.:+: q) a) ((p G.:+: q) a') a a'+plusOptic (Optic l) (Optic r) = Optic \p -> dimap (\case G.L1 f -> Left f; G.R1 f -> Right f) (either G.L1 G.R1) (l p ++ r p)++multOptic+  :: PTraversal (p a) (p a') a a'+  -> PTraversal (q a) (q a') a a'+  -> PTraversal ((p G.:*: q) a) ((p G.:*: q) a') a a'+multOptic (Optic l) (Optic r) = Optic \p -> dimap (\(f G.:*: g) -> (f, g)) (uncurry (G.:*:)) (l p ** r p)++compOptic+  :: PTraversal (p (q a)) (p (q a')) (q a) (q a')+  -> PTraversal (q a) (q a') a a'+  -> PTraversal ((p G.:.: q) a) ((p G.:.: q) a') a a'+compOptic (Optic l) (Optic r) = Optic \p -> dimap G.unComp1 G.Comp1 (l (r p))
+ src/Proarrow/Optic/PowerGrate.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | A __power grate__ is a 'Proarrow.Optic.Grate.Grate' whose exponent is a fixed tensor /power/ of+-- the focus: the witness @'Pow' n@ presents @s@ as @a ** ... ** a@ (@n@ times), the reader+-- applicative for @n@ readers. A fixed finite shape is a decomposition, so a power grate is also a+-- __fixed-arity 'Proarrow.Optic.Traversal.Traversal'__+-- (@'PowerGrateFl' <: 'GrateFl', 'KaleidoFl', 'MonTravFl'@).+--+-- It adds an eliminator: 'powerGrateP' distributes any 'MonoidalProfunctor', using only 'one' and+-- '**'. A traversal needs a 'Proarrow.Category.Monoidal.Distributive.StrongDistributiveProfunctor',+-- and a kaleidoscope needs a traversable carrier. With a fixed arity /any/ @Costar f@ distributes,+-- by unzipping @f (a ** ... ** a)@ into @f a ** ... ** f a@. So 'powerGrateOf' works at any+-- monoidal profunctor carrier: the hom @('~>')@ gives 'Proarrow.Optic.Setter.over', and an+-- applicative @'Proarrow.Profunctor.Instance.Star.Star' f@ combines the foci through @f@.+module Proarrow.Optic.PowerGrate+  ( PowerGrateFl (..)+  , PowerGrate+  , PowerGrate'+  , powerGrateOf+  , zipWithOf++    -- * @n@-ary aggregation+  , Pow (..)+  , CoPow (..)+  , powerGrate+  ) where++import Data.Type.Nat (Nat, Nat2, SNat (..), SNatI, snat)+import Proarrow.Adjunction (Proadjunction (..))+import Proarrow.Category.Monoidal+  ( Monoidal (..)+  , MonoidalProfunctor (..)+  , NFold+  , SymMonoidal+  , swapInner+  , withObNFold+  , type (**)+  )+import Proarrow.Category.Monoidal qualified as M+import Proarrow.Category.Monoidal.Action (CoprodAction)+import Proarrow.Category.Monoidal.Cartesian (Cartesian)+import Proarrow.Category.Monoidal.Closed (Closed (..), mkExponential)+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard (..), fst, snd, (&&&))+import Proarrow.Category.Monoidal.Distributive (Traversable (..))+import Proarrow.Category.Monoidal.Strength (Strong (..))+import Proarrow.Colimit.BinaryCoproduct (COPROD (..), Coprod (..), HasBinaryCoproducts (..), HasCoproducts)+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), obj, (//), (\\), type (+->))+import Proarrow.Functor (Functor)+import Proarrow.Monoid (fanIn, fanOut)+import Proarrow.Object (pattern Objs)+import Proarrow.Optic+  ( ExOptic+  , FLAVOR+  , Optic+  , Prostrong (..)+  , legs2prof+  , withLegs+  )+import Proarrow.Optic.Fold (FoldFl (..))+import Proarrow.Optic.Glass (GlassFl (..), Mod, withObSel)+import Proarrow.Optic.Grate (GrateFl (..))+import Proarrow.Optic.Kaleidoscope (CotravFl, KaleidoFl (..), Kaleidoscopic (..), kaleidoscopeOf)+import Proarrow.Optic.Setter (SetterFl (..))+import Proarrow.Optic.Traversal (MonTravFl (..), TravFl (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Costar (Costar)+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Representable (RepCostar (..), Representable (..))++-- | The power-grate flavor: distribute any 'MonoidalProfunctor' @r@ through the witness+-- pair. 'Proarrow.Optic.Traversal.TravFl' is a superclass: every power-grate witness is a+-- traversal witness (instantiate @r@ at a 'Proarrow.Category.Monoidal.Distributive.StrongDistributiveProfunctor',+-- a special 'MonoidalProfunctor'), so it folds, sets, and traverses. The extra power is+-- distributing the /non/-SDP monoidal profunctors as well. 'Proarrow.Optic.Kaleidoscope.KaleidoFl'+-- is a superclass too: a tensor power is an applicative functor (the reader applicative).+type PowerGrateFl :: forall {k}. FLAVOR k k+class (MonTravFl p q, GrateFl p q) => PowerGrateFl (p :: k +-> k) (q :: k +-> k) where+  powerGrateP :: (MonoidalProfunctor r) => p s a -> q b t -> r a b -> r s t++instance (CategoryOf k) => PowerGrateFl (Id :: k +-> k) (Id :: k +-> k) where+  powerGrateP (Id l) (Id r) = dimap l r+instance (PowerGrateFl f g, PowerGrateFl f' g') => PowerGrateFl (f :.: f') (g' :.: g) where+  powerGrateP (f :.: f') (g' :.: g) = powerGrateP @f @g f g . powerGrateP @f' @g' f' g'++-- | The carrier of the literature's kaleidoscope eliminator (@>-@): @'Costar' f@, i.e. @f a -> b@ for+-- any functor @f@ on a cartesian category. Power grates distribute any 'MonoidalProfunctor', and+-- @'Costar' f@ is one, so this is 'powerGrateP' at that carrier. It is an instance (and not only+-- reachable through 'powerGrateOf') so that a power grate composed with another flavor that also+-- runs at @Costar f@, an algebraic lens say, can be eliminated there directly.+instance (Cartesian k, Functor (f :: k -> k)) => Prostrong PowerGrateFl (Costar f :: k +-> k) where+  proact (f :.: c :.: g) = powerGrateP f g c++type PowerGrate (s :: k) (t :: k) a b = Optic (Prostrong PowerGrateFl) s t a b+type PowerGrate' s a = PowerGrate s s a a++-- | Distribute any 'MonoidalProfunctor' through a power grate (or any stronger optic). At the+-- hom @('~>')@ this is 'Proarrow.Optic.Setter.over'; at an applicative @'Proarrow.Profunctor.Instance.Star.Star' f@ the foci are+-- combined through @f@.+--+-- Accepts any encoding (cf. 'Proarrow.Optic.Traversal.traverseOf'), including '(%)'-composites.+powerGrateOf+  :: forall {k} c (s :: k) (t :: k) a b r+   . (Monoidal k, MonoidalProfunctor r, (Ob a, Ob b) => c (ExOptic PowerGrateFl a b))+  => Optic c s t a b -> r a b -> r s t+powerGrateOf o rab = withLegs @PowerGrateFl o \l r -> powerGrateP l r rab++-- * @n@-ary aggregation via tensor powers++-- | Distribute a 'MonoidalProfunctor' over the @n@-fold tensor power, by combining @n@ copies of+-- the carrier value with 'one' (at 'Z') and '**' (at 'S'). This is the profunctor-general core+-- of the @n@-ary power grate.+powDist :: forall n r a b. (SNatI n, MonoidalProfunctor r) => r a b -> r (NFold n a) (NFold n b)+powDist rab = case snat @n of+  SZ -> one+  SS @m -> rab ** powDist @m rab++-- | Distribute the internal hom over the tensor power: split @x ~~> aⁿ@ into @(x ~~> a)ⁿ@ using+-- 'CopyDiscard' projections. This makes an @n@-ary power grate a 'Proarrow.Optic.Grate.Grate'.+splitPow+  :: forall n k (x :: k) a. (SNatI n, Closed k, CopyDiscard k, Ob x, Ob a) => (x ~~> NFold n a) ~> NFold n (x ~~> a)+splitPow = case snat @n of+  SZ -> withObExp @k @x @Unit (discard @k @(x ~~> Unit))+  SS @m ->+    withObNFold @m @a+      ((fst @a @(NFold m a) ^^^ obj @x) &&& (splitPow @m @k @x @a . (snd @a @(NFold m a) ^^^ obj @x)))++-- | Zip two tensor powers into the tensor power of the tensor: the @<*>@ of the reader+-- applicative @NFold n@.+powZip+  :: forall n k (a :: k) c. (SNatI n, SymMonoidal k, Ob a, Ob c) => (NFold n a ** NFold n c) ~> NFold n (a ** c)+powZip = case snat @n of+  SZ -> leftUnitor @k @Unit+  SS @m ->+    withObNFold @m @a+      (withObNFold @m @c (((obj @a ** obj @c) ** powZip @m @k @a @c) . swapInner @a @(NFold m a) @c @(NFold m c)))++-- | The tensor power of the unit is (isomorphic to) the unit.+powUnit :: forall n k. (SNatI n, Monoidal k) => Unit ~> NFold n (Unit :: k)+powUnit = case snat @n of+  SZ -> id+  SS @m -> (obj @(Unit :: k) ** powUnit @m @k) . leftUnitorInv @k @Unit++-- | The arity-@n@ aggregation witness: @s@ presents @n@ foci via the tensor power.+--+-- @'Pow' n@ is the representable profunctor of the tensor power @NFold n@, which is the reader+-- applicative for @n@ readers. Its instances make it a+-- 'Proarrow.Category.Monoidal.Distributive.StrongDistributiveProfunctor', hence a kaleidoscope+-- witness.+type Pow :: forall {k}. Nat -> k +-> k+data Pow n s a where+  Pow :: forall (n :: Nat) {k} (s :: k) (a :: k). (Ob a) => (s ~> NFold n a) -> Pow n s a++-- | The dual of 'Pow': @t@ is rebuilt from @n@ foci.+type CoPow :: forall {k}. Nat -> k +-> k+data CoPow n b t where+  CoPow :: forall (n :: Nat) {k} (b :: k) (t :: k). (Ob b) => (NFold n b ~> t) -> CoPow n b t++instance (Monoidal k, SNatI n) => Profunctor (Pow n :: k +-> k) where+  dimap l r (Pow sa) = Pow (powDist @n r . sa . l) \\ l \\ r+  r \\ Pow sa = r \\ sa+instance (Monoidal k, SNatI n) => Profunctor (CoPow n :: k +-> k) where+  dimap l r (CoPow bt) = CoPow (r . bt . powDist @n l) \\ l \\ r+  r \\ CoPow bt = r \\ bt++instance (Monoidal k, SNatI n) => SetterFl (Pow n :: k +-> k) (CoPow n :: k +-> k) where+  overP (Pow sl) (CoPow rt) f = rt . powDist @n f . sl+instance (Monoidal k, SNatI n) => FoldFl (Pow n :: k +-> k) (CoPow n :: k +-> k) where+  foldMapP (Pow sl) am = fanIn @n . powDist @n am . sl+instance (Monoidal k, SNatI n) => TravFl (Pow n :: k +-> k) (CoPow n :: k +-> k)+instance (Monoidal k, SNatI n) => MonTravFl (Pow n :: k +-> k) (CoPow n :: k +-> k) where+  monTravP (Pow sl) (CoPow rt) rab = dimap sl rt (powDist @n rab)++-- | A power grate is a glass: ignore the source, and for each of the @n@ positions feed the+-- consumer the selector "project this focus". The selectors come from @splitPow@ of @sl@, the+-- consumer is copied @n@ times with 'fanOut', @powZip@ pairs them, and @powDist@ applies each.+-- Everything is stated with the 'CopyDiscard' structure that 'CCC' provides, so the tensor+-- and the product never have to be identified by hand.+instance (Monoidal k, HasCoproducts k, SNatI n) => GlassFl (Pow n :: k +-> k) (CoPow n :: k +-> k) where+  glassP @s @a @b (Pow sl@Objs) (CoPow rt@Objs) =+    withObSel @s @a @b+      ( withOb2 @k @s @(Mod s a b)+          ( rt+              . powDist @n (apply @k @(s ~~> a) @b)+              . powZip @n @k @(Mod s a b) @(s ~~> a)+              . ( (fanOut @n @(Mod s a b) . snd @s @(Mod s a b))+                    &&& (splitPow @n @k @s @a . mkExponential sl . discard @k @(s ** Mod s a b))+                )+          )+      )++instance (CopyDiscard k, HasCoproducts k, SNatI n) => GrateFl (Pow n :: k +-> k) (CoPow n :: k +-> k) where+  zipWithP (Pow @_ @_ @a sl) (CoPow rt) @x kk = rt . powDist @n kk . splitPow @n @_ @x @a . (sl ^^^ obj @x)+instance (CopyDiscard k, HasCoproducts k, SNatI n) => PowerGrateFl (Pow n :: k +-> k) (CoPow n :: k +-> k) where+  powerGrateP (Pow sl) (CoPow rt) rab = dimap sl rt (powDist @n rab)++-- | A tensor power is a fixed-shape traversable: distribute the carrier over the @n@ copies.+instance (Monoidal k, SNatI n) => Traversable (Pow n :: k +-> k) where+  traverse @_ @_ @b (Pow f :.: p) = p // withObNFold @n @b (lmap f (powDist @n p) :.: Pow id)++instance (Monoidal k, SNatI n) => Representable (Pow n :: k +-> k) where+  type Pow n % a = NFold n a+  index (Pow f) = f+  tabulate = Pow+  repMap = powDist @n++instance (SymMonoidal k, SNatI n) => MonoidalProfunctor (Pow n :: k +-> k) where+  one = Pow (powUnit @n)+  Pow @_ @_ @a f ** Pow @_ @_ @c g = f // g // withOb2 @k @a @c (Pow (powZip @n @k @a @c . (f ** g)))+instance (SymMonoidal k, HasCoproducts k, SNatI n) => MonoidalProfunctor (Coprod (Pow n :: k +-> k)) where+  one = withObNFold @n @(InitialObject :: k) (Coprod (Pow initiate))+  Coprod (Pow @_ @_ @a f) ** Coprod (Pow @_ @_ @c g) =+    withObCoprod @k @a @c (Coprod (Pow (powDist @n (lft @k @a @c) . f ||| powDist @n (rgt @k @a @c) . g)))+instance (CopyDiscard k, SNatI n) => Strong M.Tensor (Pow n :: k +-> k) where+  act @x (Pow @_ @_ @a f) = f // withOb2 @k @x @a (Pow (powZip @n @k @x @a . (fanOut @n @x ** f)))+instance (CopyDiscard k, HasCoproducts k, SNatI n) => Strong CoprodAction (Pow n :: k +-> k) where+  act @(COPR x) (Pow @_ @_ @a f) =+    f // withObCoprod @k @x @a (Pow (powDist @n (lft @k @x @a) . fanOut @n @x ||| powDist @n (rgt @k @x @a) . f))+instance (CopyDiscard k, HasCoproducts k, SNatI n) => CotravFl (Pow n :: k +-> k) (CoPow n :: k +-> k)+instance (CopyDiscard k, HasCoproducts k, SNatI n) => KaleidoFl (Pow n :: k +-> k) (CoPow n :: k +-> k) where+  kaleidoP (Pow sl) (CoPow rt) rab = dimap sl rt (kaleidoAct @_ @(Pow n) rab)+instance (Monoidal k, SNatI n) => Proadjunction (Pow n :: k +-> k) (CoPow n) where+  unit @x = (CoPow id :.: Pow id) \\ powDist @n (id :: x ~> x)+  counit (Pow sl :.: CoPow rt) = rt . sl++-- | Build an @n@-ary power grate from a tensor-power decomposition of @s@ and recomposition+-- of @t@.+powerGrate+  :: forall {k} (n :: Nat) (s :: k) (t :: k) a b+   . (CopyDiscard k, HasCoproducts k, SNatI n, Ob a, Ob b)+  => (s ~> NFold n a) -> (NFold n b ~> t) -> PowerGrate s t a b+powerGrate sl rt = legs2prof @PowerGrateFl (Pow @n sl) (CoPow @n rt)++-- | Zip two sources through a 'Proarrow.Optic.Kaleidoscope.Kaleidoscope' (or any stronger optic, a+-- 'Proarrow.Optic.Grate.Grate' in particular, in any encoding): combine the foci pairwise. This is+-- 'kaleidoscopeOf' at the carrier @'RepCostar' ('Pow' 2)@, the costar of the binary tensor power:+-- a binary combination @(a ** a) ~> b@ of foci, which the optic's applicative lifts by @liftA2@.+zipWithOf+  :: forall {k} c (s :: k) (t :: k) a b+   . (Monoidal k, Ob a, (Ob a, Ob b) => c (ExOptic KaleidoFl a b))+  => Optic c s t a b -> ((a ** a) ~> b) -> (s ** s) ~> t+zipWithOf o f =+  case kaleidoscopeOf o (RepCostar @_ @(Pow Nat2) (f . (obj @a ** rightUnitor @k @a))) of+    RepCostar @s' g -> g . (obj @s' ** rightUnitorInv @k @s')
+ src/Proarrow/Optic/Prism.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | The __prism__: the optic for the coproduct, with legs+--+-- > Prism s t a b = (b ~> t, s ~> (t || a))+--+-- witnessed by @'Rep'@\/@'Corep'@ @('Coproduct' t)@ ('PrismFl' \/ 'matchingP'). A prism reviews+-- and matches, sitting below 'Proarrow.Optic.Getter.Review',+-- 'Proarrow.Optic.AffineTraversal.AffineTraversal' and+-- 'Proarrow.Optic.MonoidalTraversal.MonoidalTraversal' in the lattice. Build with 'prism',+-- eliminate to the two legs with 'withPrism' via the generic 'ExOptic' carrier.+-- 'toOpLens'\/'fromOpLens' witness the equivalence with the op-lens encoding. This module also+-- hosts 'affineTraversal', the lens-then-prism builder for affine traversals.+module Proarrow.Optic.Prism where++import Proarrow.Category.Instance.Opposite (Op (..))+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard (..))+import Proarrow.Colimit.BinaryCoproduct (Coproduct, HasBinaryCoproducts (..), HasCoproducts, left)+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), (\\), type (+->))+import Proarrow.Object (pattern Objs)+import Proarrow.Optic+  ( ExOptic+  , FLAVOR+  , OpConstraint+  , Optic+  , Prostrong (..)+  , convert+  , legs2prof+  , opOptic+  , unOpOptic+  , withLegs+  , (%)+  )+import Proarrow.Optic.AffineTraversal (AffineTravFl (..), AffineTraversal)+import Proarrow.Optic.Getter (GetterFl (..))+import Proarrow.Optic.Lens (Lens, LensFl, lens, withLens)+import Proarrow.Optic.Traversal (MonTravFl)+import Proarrow.Profunctor.Corepresentable (Corep (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Representable (Rep (..))++-- | The prism flavor. The @'GetterFl' q p@ superclass says a reversed prism views its build leg+-- ('getP' on the swapped pair): @'Proarrow.Optic.re' prism@ is a getter.+type PrismFl :: forall {k}. FLAVOR k k+class (AffineTravFl p q, GetterFl q p, MonTravFl p q) => PrismFl (p :: k +-> k) (q :: k +-> k) where+  -- | Like 'affineMatch', but asking only for binary coproducts. Prism witnesses never need more,+  -- so prisms stay usable in categories without products.+  matchingP :: (HasBinaryCoproducts k) => p (s :: k) a -> q (b :: k) t -> s ~> (t || a)++instance (CopyDiscard k, HasCoproducts k, Ob t) => PrismFl (Rep (Coproduct t) :: k +-> k) (Corep (Coproduct t)) where+  matchingP @_ @a @b (Rep p) (Corep q) = left @a (q . lft @k @t @b) . p+instance (CategoryOf k) => PrismFl (Id :: k +-> k) Id where+  matchingP @_ @a @_ @t (Id sa) bt = rgt @k @t @a . sa \\ sa \\ bt+instance (PrismFl f g, PrismFl f' g') => PrismFl (f :.: f') (g' :.: g) where+  matchingP @_ @a @_ @t (f :.: f'@Objs) (g' :.: g@Objs) =+    (lft @_ @t @a ||| (left @a (getP @g @f g) . matchingP @f' @g' f' g')) . matchingP @f @g f g++type Prism (s :: k) t a b = Optic (Prostrong PrismFl) s t a b+type Prism' s a = Prism s s a a+prism+  :: forall {k} (s :: k) (t :: k) a b+   . (CopyDiscard k, HasCoproducts k, Ob a) => (b ~> t) -> (s ~> (t || a)) -> Prism s t a b+prism bt sta =+  legs2prof @PrismFl (Rep @a @(Coproduct t) sta) (Corep @b @(Coproduct t) (id ||| bt)) \\ bt++-- | Build an 'AffineTraversal' by composing a 'Lens' with a 'Prism': focus a field with the lens,+-- then match a case of that field with the prism. There is no from-legs builder for a bare affine+-- traversal (its witness only ever arises by composition), so this is the way to make one. It is+-- @'convert' (l '%' p)@.+affineTraversal+  :: forall {k} (s :: k) t x y a b. (CategoryOf k) => Lens s t x y -> Prism x y a b -> AffineTraversal s t a b+affineTraversal l p = convert (l % p)++-- | Eliminate any optic that is at least an iso and at most a prism to its two legs, in either+-- encoding: run it at its witness pair ('ExOptic' 'PrismFl', via 'withLegs') and read the legs off+-- with 'matchingP' and 'getP' on the flipped pair (a prism's build leg is a getter read backwards).+withPrism+  :: forall {k} c (s :: k) (t :: k) a b r+   . (HasBinaryCoproducts k, (Ob a, Ob b) => c (ExOptic PrismFl a b))+  => Optic c s t a b -> ((b ~> t) -> (s ~> (t || a)) -> r) -> r+withPrism o k = withLegs @PrismFl o \ @p @q p q -> k (getP @q @p q) (matchingP @p @q p q)++-- | A 'Prism' and its op-lens encoding ('Proarrow.Optic.Lens.Prism', a 'Proarrow.Optic.Lens.Lens'+-- over the opposite category) carry the same data, the two legs @(b '~>' t, s '~>' t '||' a)@,+-- so they are equivalent. 'toOpLens' eliminates a 'PrismFl' prism to its legs (via 'withPrism') and+-- rebuilds the op-lens; 'fromOpLens' eliminates the op-lens (via 'Proarrow.Optic.Lens.withLens' on+-- 'opOptic', i.e. as a lens over 'Proarrow.Category.Instance.Opposite.OPPOSITE') and rebuilds the 'PrismFl' prism.++-- | The __op-lens__ encoding of a prism: a 'Proarrow.Optic.Lens.Lens' over the opposite category.+type OpLens (s :: k) t a b = Optic (OpConstraint (Prostrong LensFl)) s t a b++toOpLens :: forall {k} (s :: k) t a b. (HasCoproducts k, Ob a, Ob b) => Prism s t a b -> OpLens s t a b+toOpLens o = withPrism o (\bt sta -> unOpOptic (lens (Op bt) (Op sta)))++fromOpLens :: forall {k} (s :: k) t a b. (CopyDiscard k, HasCoproducts k, Ob a) => OpLens s t a b -> Prism s t a b+fromOpLens o = withLens (opOptic o) (\rev match -> prism (unOp rev) (unOp match))
+ src/Proarrow/Optic/Prod.hs view
@@ -0,0 +1,73 @@+-- | A third way to combine two flavors, alongside "Proarrow.Optic.Sum" and "Proarrow.Optic.Day":+-- pair them up over the /product/ of two categories via ':**:'.+module Proarrow.Optic.Prod where++import Proarrow.Category.Instance.Product (Fst, Snd, (:**:) (..))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), (\\), type (+->))+import Proarrow.Functor (type (@))+import Proarrow.Optic (FLAVOR, Flavor, Optic, Prostrong (..), legs2prof, withLegs)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))++-- | Two flavors combine into one over the product of their (possibly heterogeneous) categories,+-- by pairing up their witness profunctors componentwise via ':**:' instead of sharing a single+-- object. (@:*:@ doesn't work here. It forces both witnesses onto the same index kind, so it+-- can't combine optics over different categories/objects.)+type ProdFl :: forall {j1} {k1} {j2} {k2}. FLAVOR j1 k1 -> FLAVOR j2 k2 -> FLAVOR (j1, j2) (k1, k2)+class ProdFl w1 w2 (p :: (k1, k2) +-> (k1, k2)) (q :: (j1, j2) +-> (j1, j2)) where+  -- | Recover the two component witnesses from an opaque, possibly-composite 'ProdFl' pair.+  -- Stated via 'Fst'\/'Snd' rather than literal tuple patterns: the existential "middle" object+  -- introduced when recursing through a ':.:' composite isn't syntactically a tuple, even though+  -- (being of a product kind) it always denotes one.+  withProdP+    :: p s a+    -> q b t+    -> ( forall p1 p2 q1 q2+          . (w1 p1 q1, w2 p2 q2, Profunctor p1, Profunctor p2, Profunctor q1, Profunctor q2)+         => p1 (Fst @ s) (Fst @ a) -> p2 (Snd @ s) (Snd @ a) -> q1 (Fst @ b) (Fst @ t) -> q2 (Snd @ b) (Snd @ t) -> r+       )+    -> r++instance+  (w1 p1 q1, w2 p2 q2, Profunctor p1, Profunctor p2, Profunctor q1, Profunctor q2)+  => ProdFl w1 w2 (p1 :**: p2) (q1 :**: q2)+  where+  withProdP (l1 :**: l2) (r1 :**: r2) k = k l1 l2 r1 r2+instance+  (CategoryOf k1, CategoryOf k2, CategoryOf j1, CategoryOf j2, Flavor w1, Flavor w2)+  => ProdFl w1 w2 (Id :: CAT (k1, k2)) (Id :: CAT (j1, j2))+  where+  withProdP (Id (f1 :**: f2)) (Id (g1 :**: g2)) k = k (Id f1) (Id f2) (Id g1) (Id g2)+instance+  (ProdFl w1 w2 f f', ProdFl w1 w2 g g', Flavor w1, Flavor w2)+  => ProdFl w1 w2 (f :.: g) (g' :.: f')+  where+  withProdP (f :.: g) (g' :.: f') k =+    withProdP @w1 @w2 f f' \p1 p2 q1 q2 ->+      withProdP @w1 @w2 g g' \p1' p2' q1' q2' ->+        k (p1 :.: p1') (p2 :.: p2') (q1' :.: q1) (q2' :.: q2)++prodOptic+  :: forall {j1} {k1} {j2} {k2} (w1 :: FLAVOR j1 k1) (w2 :: FLAVOR j2 k2) s1 t1 a1 b1 s2 t2 a2 b2+   . (Flavor w1, Flavor w2, CategoryOf j1, CategoryOf k1, CategoryOf j2, CategoryOf k2)+  => Optic (Prostrong w1) s1 t1 a1 b1+  -> Optic (Prostrong w2) s2 t2 a2 b2+  -> Optic (Prostrong (ProdFl w1 w2)) '(s1, s2) '(t1, t2) '(a1, a2) '(b1, b2)+prodOptic o1 o2 =+  withLegs @w1 o1 \l1 r1 ->+    withLegs @w2 o2 \l2 r2 ->+      legs2prof @(ProdFl w1 w2) (l1 :**: l2) (r1 :**: r2) \\ l1 \\ r1 \\ l2 \\ r2++-- | The inverse of 'prodOptic': split a @'ProdFl' w1 w2@-flavored optic back into its two+-- independent halves.+withProdOptic+  :: forall {j1} {k1} {j2} {k2} (w1 :: FLAVOR j1 k1) (w2 :: FLAVOR j2 k2) s1 t1 a1 b1 s2 t2 a2 b2 r+   . (CategoryOf j1, CategoryOf k1, CategoryOf j2, CategoryOf k2, Flavor w1, Flavor w2)+  => Optic (Prostrong (ProdFl w1 w2)) '(s1, s2) '(t1, t2) '(a1, a2) '(b1, b2)+  -> ((Optic (Prostrong w1) s1 t1 a1 b1, Optic (Prostrong w2) s2 t2 a2 b2) -> r)+  -> r+withProdOptic o k0 =+  withLegs @(ProdFl w1 w2) o \l r ->+    withProdP @w1 @w2 l r \p1 p2 q1 q2 ->+      k0+        (legs2prof @w1 p1 q1, legs2prof @w2 p2 q2)
+ src/Proarrow/Optic/Setter.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The __setter__: the weakest write-side optic, applying a morphism to every focus ('SetterFl'+-- \/ 'overP'). It sits at the write-only top of the subtyping lattice alongside+-- 'Proarrow.Optic.Fold.Fold', so it has no builder of its own ('Proarrow.Optic.convert' a stronger+-- optic). Its canonical eliminator is 'over', via the generic 'ExOptic' carrier, with 'set',+-- '(%~)' and '(.~)' as shorthands.+--+-- This module also hosts the 'SetterFl' instance of the tensor-action witness pair+-- @'Rep'@\/@'Corep'@ @('ActionAt' 'Tensor' a)@, shared by "Proarrow.Optic.MonoidalTraversal" and+-- "Proarrow.Optic.Tracer".+module Proarrow.Optic.Setter where++import Data.Kind (Type)+import Prelude (const)+import Prelude qualified as P++import Proarrow.Category.Instance.Kleisli (KLEISLI (..), Kleisli (..))+import Proarrow.Category.Monoidal (Monoidal, MonoidalProfunctor (..), Tensor)+import Proarrow.Category.Monoidal.Action (ActionAt)+import Proarrow.Category.Monoidal.Closed (Closed (..), Exp)+import Proarrow.Colimit.BinaryCoproduct (Coproduct, HasCoproducts, right)+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), obj, (\\), type (+->))+import Proarrow.Functor (Prelude (..))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts, Product, second)+import Proarrow.Optic (ExOptic, FLAVOR, Optic, Prostrong (..), withLegs)+import Proarrow.Profunctor.Corepresentable (Corep (..), Corepresentable (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Instance.Star (Star, unStar, pattern Star)+import Proarrow.Profunctor.Representable (CorepStar (..), Rep (..), RepCostar (..), Representable (..))++-- | A setter can only apply a pure function to the @a@'s it can see. It can neither view nor+-- fold them. A traversal is both a setter and a fold.+type SetterFl :: forall {k}. FLAVOR k k+class (Profunctor p, Profunctor q) => SetterFl (p :: k +-> k) (q :: k +-> k) where+  overP :: p s a -> q b t -> (a ~> b) -> (s ~> t)++-- | Every /representable/ residual is a setter: map the focus through the residual functor with+-- 'repMap'. This needs only 'Representable' @t@, not+-- 'Proarrow.Category.Monoidal.Distributive.Traversable', which is why+-- 'Proarrow.Optic.Setter.Setter' sits at the top of the lattice: functoriality of the residual is+-- all @over@ ever uses. Richer optics ('Proarrow.Optic.Lens.Lens',+-- 'Proarrow.Optic.Traversal.Traversal', ...) are this witness plus extra algebra on @t@.+instance (Representable t) => SetterFl (t :: k +-> k) (RepCostar t) where+  overP l (RepCostar r) f = r . repMap @t f . index l++instance (HasBinaryProducts k, Ob (s :: k)) => SetterFl (Rep (Product s)) (Corep (Product s)) where+  overP (Rep p) (Corep q) f = q . second @s f . p+instance (HasCoproducts k, Ob t) => SetterFl (Rep (Coproduct t) :: k +-> k) (Corep (Coproduct t)) where+  overP (Rep p) (Corep q) f = q . right @t f . p+instance (CategoryOf k) => SetterFl (Id :: k +-> k) (Id :: k +-> k) where+  overP (Id l) (Id r) f = r . f . l+instance (SetterFl f g, SetterFl f' g') => SetterFl (f :.: f') (g' :.: g) where+  overP (f :.: f') (g' :.: g) = overP @f @g f g . overP @f' @g' f' g'++-- | Dually, every /corepresentable/ residual is a setter: map with 'corepMap'. Needs only+-- 'Corepresentable' @t@, not 'Proarrow.Category.Monoidal.Distributive.Cotraversable'.+instance (Corepresentable t) => SetterFl (CorepStar t) t where+  overP (CorepStar l) co f = coindex co . corepMap @t f . l++-- | The grate witness is a setter witness: map under the exponential. The 'Closed' structure+-- this needs rides in the instance context, not in @overP@'s own (weaker) constraint.+instance (Closed k, Ob (m :: k)) => SetterFl (Rep (Exp m) :: k +-> k) (Corep (Exp m)) where+  overP (Rep sm) (Corep mbt) f = mbt . (f ^^^ obj @m) . sm \\ f++-- | The tensor-action witness pair @'Rep'@\/@'Corep'@ @('ActionAt' 'Tensor' a)@: the focus @x@+-- sits inside @a ** x@ with the residual @a@ carried on the left (legs @s ~> a ** x@ and+-- @a ** x ~> t@). It is a setter witness by mapping under the tensor, and the tensor-strength+-- generator for the free traversal profunctor (see "Proarrow.Optic.MonoidalTraversal"); read the+-- other way round it is the tracer witness (see "Proarrow.Optic.Tracer").+instance (Monoidal k, Ob (a :: k)) => SetterFl (Rep (ActionAt Tensor a) :: k +-> k) (Corep (ActionAt Tensor a)) where+  overP (Rep h) (Corep i) f = i . (obj @a ** f) . h++type Setter (s :: k) (t :: k) a b = Optic (Prostrong SetterFl) s t a b+type Setter' s a = Setter s s a a++-- | Map over any optic that can act as a setter, in either encoding: run it at its witness pair+-- ('ExOptic' 'SetterFl', via 'withLegs') and apply 'overP'.+over+  :: forall {k} c (s :: k) (t :: k) a b+   . (CategoryOf k, (Ob a, Ob b) => c (ExOptic SetterFl a b))+  => Optic c s t a b -> (a ~> b) -> (s ~> t)+over o f = withLegs @SetterFl o \ @p @q p q -> overP @p @q p q f++-- | Apply a function through a concrete, @Type@-level 'Setter'.+infixl 8 %~++(%~) :: (c (ExOptic SetterFl a b)) => Optic c (s :: Type) t a b -> (a -> b) -> (s -> t)+(%~) = over++-- | Replace the focus\/foci of a concrete, @Type@-level 'Setter' with a constant value.+infixl 8 .~++(.~) :: (c (ExOptic SetterFl a b)) => Optic c (s :: Type) t a b -> b -> (s -> t)+l .~ b = l %~ const b++-- | Named version of '(.~)'.+set :: (c (ExOptic SetterFl a b)) => Optic c (s :: Type) t a b -> b -> (s -> t)+set = (.~)++-- | Monadically replace the focus\/foci of a 'Setter' in the Kleisli category of @m@ with a+-- constant value, ignoring the old contents entirely.+mupdate+  :: forall m s t a b+   . (P.Monad m)+  => Setter (KL s :: KLEISLI (Star (Prelude m))) (KL t) (KL a) (KL b) -> b -> s -> m t+mupdate l b s = unPrelude (unStar (unKleisli (over l (Kleisli (Star (\_ -> Prelude (P.return b)))))) s)
+ src/Proarrow/Optic/Sum.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE IncoherentInstances #-}++-- | Dual to 'Proarrow.Optic.Prod.ProdFl': combine over the /coproduct/ of two categories via+-- ':++:'. It has its own module because "Proarrow.Category.Instance.Coproduct" already imports+-- "Proarrow.Optic" transitively.+--+-- It does not combine two different optics into one: an @(p ':++:' q) (L a) (L b)@ only ever holds+-- a @p@. It lets any @w1@- or @w2@-flavored optic be injected into a shared @'SumFl' w1 w2@, the+-- unused side witnessed by @'Id'@ (demanded via 'Flavor').+module Proarrow.Optic.Sum where++import Prelude (type (~))++import Proarrow.Category.Instance.Coproduct (COPRODUCT (..), (:++:) (..))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), type (+->))+import Proarrow.Object (pattern Objs)+import Proarrow.Optic (FLAVOR, Flavor, Optic, Prostrong (..), legs2prof, withLegs)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))++-- | Unlike 'Proarrow.Optic.Prod.ProdFl', a 'SumFl' witness can be decomposed back.+-- 'withSumL'\/'withSumR' only fix the one endpoint anchored from outside (@s@ via @p@'s first+-- slot, @t@ via @q@'s second slot). The other endpoint (@a@, @b@) comes back refined by the+-- continuation instead of being required upfront. So the ':.:' case can recurse: the existential+-- "middle" object introduced there is the next call's anchored endpoint, so its tag is established+-- by the previous step's own guarantee before it's ever needed as input.+type SumFl :: forall {j1} {k1} {j2} {k2}. FLAVOR j1 k1 -> FLAVOR j2 k2 -> FLAVOR (COPRODUCT j1 j2) (COPRODUCT k1 k2)+class SumFl w1 w2 (p :: COPRODUCT k1 k2 +-> COPRODUCT k1 k2) (q :: COPRODUCT j1 j2 +-> COPRODUCT j1 j2) where+  withSumL+    :: p (L s) a+    -> q b (L t)+    -> (forall p1 q1 a' b'. (w1 p1 q1, Profunctor p1, Profunctor q1, a ~ L a', b ~ L b') => p1 s a' -> q1 b' t -> r)+    -> r+  withSumR+    :: p (R s) a+    -> q b (R t)+    -> (forall p2 q2 a' b'. (w2 p2 q2, Profunctor p2, Profunctor q2, a ~ R a', b ~ R b') => p2 s a' -> q2 b' t -> r)+    -> r++instance+  (w1 p1 q1, w2 p2 q2, Profunctor p1, Profunctor p2, Profunctor q1, Profunctor q2)+  => SumFl w1 w2 (p1 :++: p2) (q1 :++: q2)+  where+  withSumL (InjL l1) (InjL r1) k = k l1 r1+  withSumR (InjR l2) (InjR r2) k = k l2 r2+instance+  (CategoryOf k1, CategoryOf k2, CategoryOf j1, CategoryOf j2, Flavor w1, Flavor w2)+  => SumFl w1 w2 (Id :: CAT (COPRODUCT k1 k2)) (Id :: CAT (COPRODUCT j1 j2))+  where+  withSumL (Id (InjL f)) (Id (InjL g)) k = k (Id f) (Id g)+  withSumR (Id (InjR f)) (Id (InjR g)) k = k (Id f) (Id g)+instance+  (SumFl w1 w2 f f', SumFl w1 w2 g g', Flavor w1, Flavor w2)+  => SumFl w1 w2 (f :.: g) (g' :.: f')+  where+  withSumL (f :.: g) (g' :.: f') k =+    withSumL @w1 @w2 f f' \p1 q1 ->+      withSumL @w1 @w2 g g' \p1' q1' ->+        k (p1 :.: p1') (q1' :.: q1)+  withSumR (f :.: g) (g' :.: f') k =+    withSumR @w1 @w2 f f' \p2 q2 ->+      withSumR @w1 @w2 g g' \p2' q2' ->+        k (p2 :.: p2') (q2' :.: q2)++injLOptic+  :: forall {j1} {k1} {j2} {k2} (w2 :: FLAVOR j2 k2) (w1 :: FLAVOR j1 k1) s t a b+   . (Flavor w1, w2 (Id :: CAT k2) (Id :: CAT j2), CategoryOf j1, CategoryOf k1, CategoryOf j2, CategoryOf k2)+  => Optic (Prostrong w1) s t a b -> Optic (Prostrong (SumFl w1 w2)) (L s) (L t) (L a) (L b)+injLOptic o =+  withLegs @w1 o \ @p @q l@Objs r@Objs ->+    legs2prof @(SumFl w1 w2)+      (InjL l :: (p :++: (Id :: CAT k2)) (L s) (L a))+      (InjL r :: (q :++: (Id :: CAT j2)) (L b) (L t))+injROptic+  :: forall {j1} {k1} {j2} {k2} (w1 :: FLAVOR j1 k1) (w2 :: FLAVOR j2 k2) s t a b+   . (Flavor w2, w1 (Id :: CAT k1) (Id :: CAT j1), CategoryOf j1, CategoryOf k1, CategoryOf j2, CategoryOf k2)+  => Optic (Prostrong w2) s t a b -> Optic (Prostrong (SumFl w1 w2)) (R s) (R t) (R a) (R b)+injROptic o =+  withLegs @w2 o \ @p @q l@Objs r@Objs ->+    legs2prof @(SumFl w1 w2)+      (InjR l :: ((Id :: CAT k1) :++: p) (R s) (R a))+      (InjR r :: ((Id :: CAT j1) :++: q) (R b) (R t))++-- | The inverse of 'injLOptic': every 'SumFl' witness of an @(L s) (L t) (L a) (L b)@-shaped+-- optic actually comes from an underlying @w1@-flavored optic on @s t a b@.+withSumOpticL+  :: forall {j1} {k1} {j2} {k2} (w1 :: FLAVOR j1 k1) (w2 :: FLAVOR j2 k2) s t a b r+   . (CategoryOf j1, CategoryOf k1, CategoryOf j2, CategoryOf k2, Flavor w1, Flavor w2, Ob a, Ob b)+  => Optic (Prostrong (SumFl w1 w2)) (L s) (L t) (L a) (L b)+  -> (Optic (Prostrong w1) s t a b -> r)+  -> r+withSumOpticL o k = withLegs @(SumFl w1 w2) o \l r -> withSumL @w1 @w2 l r \p1 q1 -> k (legs2prof @w1 p1 q1)++-- | The inverse of 'injROptic'.+withSumOpticR+  :: forall {j1} {k1} {j2} {k2} (w1 :: FLAVOR j1 k1) (w2 :: FLAVOR j2 k2) s t a b r+   . (CategoryOf j1, CategoryOf k1, CategoryOf j2, CategoryOf k2, Flavor w1, Flavor w2, Ob a, Ob b)+  => Optic (Prostrong (SumFl w1 w2)) (R s) (R t) (R a) (R b)+  -> (Optic (Prostrong w2) s t a b -> r)+  -> r+withSumOpticR o k = withLegs @(SumFl w1 w2) o \l r -> withSumR @w1 @w2 l r \p2 q2 -> k (legs2prof @w2 p2 q2)
+ src/Proarrow/Optic/Tracer.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The __tracer__: the write-only optic whose residual sits on the source and target side,+--+-- > Tracer s t a b = exists m. (m ** s ~> a, b ~> m ** t)+--+-- witnessed by @'Corep'@\/@'Rep'@ @('ActionAt' 'Tensor' m)@ ('TracerFl'), a setter witness pair+-- read the other way round. Running it forwards closes a feedback loop through the residual, so it+-- distributes any 'Costrong' profunctor ('tracerP') and is a 'Proarrow.Optic.Setter.Setter'+-- exactly in a 'TracedMonoidal' category. Run backwards+-- ('Proarrow.Optic.Setter.over' . 'Proarrow.Optic.re') it needs no trace. Build with 'tracer',+-- eliminate with 'tracerOf' or recover the legs with 'withTracer'. 'fromPTracer'\/'toPTracer'+-- mediate with 'PTracer' (@'Optic' ('Costrong' 'Tensor')@).+module Proarrow.Optic.Tracer where++import Prelude (($))++import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), Tensor, type (**))+import Proarrow.Category.Monoidal.Action (ActionAt)+import Proarrow.Category.Monoidal.Strength (Costrong (..), TracedMonoidal)+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), obj, (\\), type (+->))+import Proarrow.Object (pattern Objs)+import Proarrow.Optic+  ( ExOptic (..)+  , FLAVOR+  , Flavor+  , Optic+  , Optic_ (..)+  , Prostrong (..)+  , convert+  , legs2prof+  , withLegs+  )+import Proarrow.Optic.Setter (SetterFl (..))+import Proarrow.Profunctor.Corepresentable (Corep (..), Corepresentable (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Representable (Rep (..), Representable (..))++-- | The tracer flavor: a witness pair with legs @m ** s ~> a@ and @b ~> m ** t@ for an+-- existential residual @m@, an @'ActFl' 'Tensor'@ pair with the witnesses' roles swapped. It is+-- the @'Prostrong'@ counterpart of @'Costrong' 'Tensor'@, as+-- 'Proarrow.Optic.MonoidalLens.MonLensFl' is of+-- @'Proarrow.Category.Monoidal.Strength.Strong' 'Tensor'@.+--+-- A tracer pair and its flip are both setter pairs, so 'Proarrow.Optic.Setter.over' works on a+-- tracer and on its 'Proarrow.Optic.re', and+-- @'convert' t :: 'Optic' ('Prostrong' ('Flip' 'SetterFl')) s t a b@ typechecks. The converse+-- fails: a flipped setter (e.g. a flipped lens witness) need not have a trace.+--+-- 'TracedMonoidal' sits in the instance context of the tensor-action witness, so ordinary setters+-- don't pick up the constraint. 'Monoidal' sits on the method so that the identity witness needs+-- only 'CategoryOf' and 'Proarrow.Optic.Iso.IsoFl' can include this flavor.+type TracerFl :: forall {k}. FLAVOR k k+class (SetterFl p q, SetterFl q p) => TracerFl (p :: k +-> k) (q :: k +-> k) where+  -- | Recover the two legs, with the residual @m@ existential.+  withTracerP+    :: (Monoidal k) => p s a -> q b t -> (forall (m :: k). (Ob m) => ((m ** s) ~> a) -> (b ~> (m ** t)) -> r) -> r++instance (CategoryOf k) => TracerFl (Id :: k +-> k) (Id :: k +-> k) where+  withTracerP (Id l) (Id r) k = k @Unit (l . leftUnitor) (leftUnitorInv . r) \\ l \\ r++instance+  forall k (f :: k +-> k) (f' :: k +-> k) (g :: k +-> k) (g' :: k +-> k)+   . (TracerFl f g, TracerFl f' g')+  => TracerFl (f :.: f') (g' :.: g)+  where+  withTracerP ((f@Objs :: f s x) :.: f') (g' :.: (g@Objs :: g y t)) kk =+    withTracerP f g \ @(mo :: k) ho io ->+      withTracerP f' g' \ @(mi :: k) hi ii ->+        withOb2 @k @mi @mo+          ( kk @(mi ** mo)+              (hi . (obj @mi ** ho) . associator @k @mi @mo @s)+              (associatorInv @k @mi @mo @t . (obj @mi ** io) . ii)+          )++-- | The tracer witness: the tensor-action pair read the other way round, @'Corep' ('ActionAt' 'Tensor' m)@+-- on the left and @'Rep' ('ActionAt' 'Tensor' m)@ on the right. Its 'overP' is the trace+-- of @m ** s ~> a ~> b ~> m ** t@ over @m@, so it needs the category to be 'TracedMonoidal'.+instance (TracedMonoidal k, Ob (m :: k)) => SetterFl (Corep (ActionAt Tensor m) :: k +-> k) (Rep (ActionAt Tensor m)) where+  overP (Corep l) (Rep r) f = coact @Tensor @_ @m (r . f . l)++instance (TracedMonoidal k, Ob (m :: k)) => TracerFl (Corep (ActionAt Tensor m) :: k +-> k) (Rep (ActionAt Tensor m)) where+  withTracerP (Corep l) (Rep r) k = k @m l r++-- | Distribute any 'Costrong' profunctor through a tracer witness pair: 'dimap' the legs on and+-- 'coact' the residual away. At the hom this is 'overP'.+tracerP+  :: forall {k} p q (s :: k) a b t r+   . (TracerFl p q, Costrong Tensor r)+  => p s a -> q b t -> r a b -> r s t+tracerP l r rab = withTracerP l r (\ @m i h -> coact @Tensor @r @m (dimap i h rab)) \\ l \\ r++type Tracer (s :: k) (t :: k) a b = Optic (Prostrong TracerFl) s t a b+type Tracer' s a = Tracer s s a a++-- | Build a tracer from its two legs and a chosen residual @m@: @m ** s ~> a@ decomposes the source+-- (given the residual), @b ~> m ** t@ rebuilds the target and produces the residual to feed back.+tracer+  :: forall {k} (m :: k) (s :: k) t a b+   . (TracedMonoidal k, Ob m, Ob s, Ob t, Ob a, Ob b)+  => ((m ** s) ~> a) -> (b ~> (m ** t)) -> Tracer s t a b+tracer l r = legs2prof @TracerFl (Corep @s @(ActionAt Tensor m) l) (Rep @t @(ActionAt Tensor m) r)++-- | Distribute any 'Costrong' profunctor through a tracer (or any stronger optic). At the hom this+-- is 'Proarrow.Optic.Setter.over', computing the feedback loop through the residual.+--+-- Accepts any encoding (cf. 'Proarrow.Optic.Traversal.traverseOf'): a 'PTracer' works directly, as+-- does a '(Proarrow.Optic.%)'-composite.+tracerOf+  :: forall {k} c (s :: k) (t :: k) a b r+   . (Monoidal k, Costrong Tensor r, c (ExOptic TracerFl a b))+  => Optic c s t a b -> r a b -> r s t+tracerOf o rab = withLegs @TracerFl o \l r -> tracerP l r rab++-- | The generic carrier absorbs the residual of a 'Costrong' action whenever the flavor contains the+-- tracer generator: one more tensor-action layer, composed onto the witnesses.+-- With it, profunctor-class-flavored tracers ('PTracer') eliminate through 'ExOptic' too.+instance+  ( Monoidal k+  , Ob (a :: k)+  , Ob b+  , Flavor w+  , forall (m :: k). (Ob m) => w (Corep (ActionAt Tensor m)) (Rep (ActionAt Tensor m))+  )+  => Costrong Tensor (ExOptic w a b :: k +-> k)+  where+  coact @m @x @y (ExOptic @p @q l r) =+    withOb2 @k @m @x $+      withOb2 @k @m @y $+        ExOptic @(Corep (ActionAt Tensor m) :.: p) @(q :.: Rep (ActionAt Tensor m)) (corepUniv :.: l) (r :.: repUniv)++-- | Eliminate any optic that is at least an iso and at most a tracer to its two legs, recovering+-- the existential residual @m@, in either encoding: run it at its witness pair ('ExOptic' 'TracerFl',+-- via 'withLegs') and read the legs off with 'withTracerP'.+withTracer+  :: forall {k} c (s :: k) (t :: k) a b r+   . (Monoidal k, (Ob a, Ob b) => c (ExOptic TracerFl a b))+  => Optic c s t a b -> (forall (m :: k). (Ob m) => ((m ** s) ~> a) -> (b ~> (m ** t)) -> r) -> r+withTracer o k = withLegs @TracerFl o \ @p @q p q -> withTracerP @p @q p q \ @m h i -> k @m h i++-- | A tracer in the profunctor-class-flavored encoding (cf. 'Proarrow.Optic.PIso'). Equivalent to+-- 'Tracer' via 'toPTracer' and 'fromPTracer'.+type PTracer s t a b = Optic (Costrong Tensor) s t a b++-- | Instantiate a profunctor-class tracer at the generic carrier @'ExOptic' 'TracerFl' a b@, which is+-- 'Costrong' by the instance above (the Pastro-Street move).+fromPTracer :: forall {k} (s :: k) (t :: k) a b. (TracedMonoidal k) => PTracer s t a b -> Tracer s t a b+fromPTracer = convert++-- | Eliminate a 'Tracer' to its profunctor-class form: run 'tracerP' at the caller's profunctor.+toPTracer :: forall {k} (s :: k) (t :: k) a b. (CategoryOf k) => Tracer s t a b -> PTracer s t a b+toPTracer o = withLegs @TracerFl o \l@Objs r@Objs -> Optic (tracerP l r)
+ src/Proarrow/Optic/Traversal.hs view
@@ -0,0 +1,271 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The __traversal__: the many-focus optic, distributing any+-- 'Proarrow.Category.Monoidal.Distributive.StrongDistributiveProfunctor' with product strength+-- through the foci. This module keeps the mutually-recursive 'TravFl'\/'MonTravFl' flavor+-- classes and their leaf witnesses ('Traversable' and 'Cotraversable' functors, the product lens,+-- the coproduct prism, 'Beside'\/'BesideSum' juxtaposition and the unit\/zero witnesses). The+-- free-profunctor apparatus lives in "Proarrow.Optic.MonoidalTraversal". A traversal subtypes to+-- 'Proarrow.Optic.Fold.Fold' and 'Proarrow.Optic.Setter.Setter'. Build with 'traversed' (from a+-- 'Traversable') or 'Proarrow.Optic.MonoidalTraversal.traversal' (from the van-Laarhoven form),+-- eliminate with 'traverseOf'.+module Proarrow.Optic.Traversal where++import Proarrow.Adjunction (Proadjunction (..))+import Proarrow.Category.Instance.Product (Diag, (:**:) (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), MultRep, Tensor)+import Proarrow.Category.Monoidal.Action (ActionAt, CoprodAction, ProdAction)+import Proarrow.Category.Monoidal.Cartesian (Bicartesian)+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard (..))+import Proarrow.Category.Monoidal.Distributive+  ( Cotraversable (..)+  , Distributive+  , StrongDistributiveProfunctor+  , Traversable (..)+  , corepTraverse+  , repTraverse+  )+import Proarrow.Category.Monoidal.Strength (Strong (..))+import Proarrow.Colimit.BinaryCoproduct+  ( COPROD (..)+  , Coproduct+  , HasBinaryCoproducts (..)+  , HasCoproducts+  , PlusRep+  , nil+  , (++)+  )+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), (\\), type (+->))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..), PROD (..), Product)+import Proarrow.Monoid (Comonoid, Monoid (..))+import Proarrow.Monoid qualified as Mon+import Proarrow.Optic+  ( ExOptic+  , FLAVOR+  , Optic+  , Prostrong (..)+  , legs2prof+  , withLegs+  )+import Proarrow.Optic.Fold (FoldFl (..))+import Proarrow.Optic.Setter (SetterFl (..))+import Proarrow.Profunctor.Corepresentable (Corep (..), Corepresentable (..), coindex)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Representable (CorepStar (..), Rep (..), RepCostar (..), Representable (..))++type TravFl :: forall {k}. FLAVOR k k+class (SetterFl p q, FoldFl p q) => TravFl (p :: k +-> k) (q :: k +-> k) where+  -- | Distribute a traversal-strength profunctor. Only the product-lens witness needs+  -- @'Strong' 'ProdAction'@ (to carry the residual through the categorical product). Every other+  -- witness distributes a plain 'StrongDistributiveProfunctor' and inherits 'travP' from 'monTravP'.+  travP :: (StrongDistributiveProfunctor r, Strong ProdAction r) => p s a -> q b t -> r a b -> r s t+  default travP :: (MonTravFl p q, StrongDistributiveProfunctor r) => p s a -> q b t -> r a b -> r s t+  travP = monTravP++-- | A __monoidal traversal__ sits between 'Proarrow.Optic.PowerGrate.PowerGrate' and+-- 'Traversal': it distributes any 'StrongDistributiveProfunctor' without the product-strength a+-- lens-as-traversal needs. Every traversal witness except the product lens is a monoidal traversal.+type MonTravFl :: forall {k}. FLAVOR k k+class (TravFl p q) => MonTravFl (p :: k +-> k) (q :: k +-> k) where+  monTravP :: (StrongDistributiveProfunctor r) => p s a -> q b t -> r a b -> r s t++instance (Bicartesian k, Traversable t, Representable t) => TravFl (t :: k +-> k) (RepCostar t)+instance (Bicartesian k, Traversable t, Representable t) => MonTravFl (t :: k +-> k) (RepCostar t) where+  monTravP l (RepCostar r) = dimap (index l) r . repTraverse @t++-- | A corepresentable 'Cotraversable' functor builds @s@ from a shape of @a@'s, and its 'travP'+-- distributes an SDP the same way a cotraversal's would. So at this witness a cotraversal is a+-- traversal, and it needs no flavor of its own.+-- ("Proarrow.Optic.Kaleidoscope" does define a @Cotraversal@, over 'Cotraversable' witnesses that+-- are not representable. In the lattice it is a sibling of 'Traversal', not a descendant: both are+-- children of @Setter@, and @Cotraversal@\'s own child is @Kaleidoscope@.)+instance (Bicartesian k, Cotraversable t, Corepresentable t) => TravFl (CorepStar t) (t :: k +-> k)++instance (Bicartesian k, Cotraversable t, Corepresentable t) => MonTravFl (CorepStar t) (t :: k +-> k) where+  monTravP (CorepStar l) co = dimap l (coindex co) . corepTraverse @t++instance (HasBinaryProducts k, Ob (s :: k)) => TravFl (Rep (Product s)) (Corep (Product s)) where+  travP (Rep p) (Corep q) r = dimap p q (act @ProdAction @_ @(PR s) r)++-- | The tensor-action witness pair @'Rep'@\/@'Corep'@ @('ActionAt' 'Tensor' m)@ with a __comonoid__+-- residual @m@ (legs @s ~> m ** a@, @m ** b ~> t@) is a (monoidal) traversal witness. It folds by+-- discarding the residual with the counit, and distributes a 'StrongDistributiveProfunctor' by its+-- own strength @'act' \@'Tensor'@, so neither product strength nor @tensor = product@ is needed.+-- Only @m@ must be a 'Comonoid', so this works in @LINEAR@ for the duplicable objects. It is also+-- the monoidal-lens witness ("Proarrow.Optic.MonoidalLens").+instance (Comonoid (m :: k)) => FoldFl (Rep (ActionAt Tensor m) :: k +-> k) (Corep (ActionAt Tensor m)) where+  foldMapP (Rep h) am = leftUnitor . (Mon.counit @m ** am) . h++instance (Comonoid (m :: k)) => TravFl (Rep (ActionAt Tensor m) :: k +-> k) (Corep (ActionAt Tensor m))+instance (Comonoid (m :: k)) => MonTravFl (Rep (ActionAt Tensor m) :: k +-> k) (Corep (ActionAt Tensor m)) where+  monTravP (Rep h) (Corep i) r = dimap h i (act @Tensor @_ @m r)+instance (CopyDiscard k, HasCoproducts k, Ob t) => TravFl (Rep (Coproduct t) :: k +-> k) (Corep (Coproduct t))+instance (CopyDiscard k, HasCoproducts k, Ob t) => MonTravFl (Rep (Coproduct t) :: k +-> k) (Corep (Coproduct t)) where+  monTravP (Rep p) (Corep q) r = dimap p q (act @CoprodAction @_ @(COPR t) r)+instance (CategoryOf k) => TravFl (Id :: k +-> k) (Id :: k +-> k)+instance (CategoryOf k) => MonTravFl (Id :: k +-> k) (Id :: k +-> k) where+  monTravP (Id l) (Id r) = dimap l r+instance (TravFl f g, TravFl f' g') => TravFl (f :.: f') (g' :.: g) where+  travP (f :.: f') (g' :.: g) = travP @f @g f g . travP @f' @g' f' g'+instance (MonTravFl f g, MonTravFl f' g') => MonTravFl (f :.: f') (g' :.: g) where+  monTravP (f :.: f') (g' :.: g) = monTravP @f @g f g . monTravP @f' @g' f' g'++type Traversal (s :: k) (t :: k) a b = Optic (Prostrong TravFl) s t a b+type Traversal' s a = Traversal s s a a++-- | Distribute any 'StrongDistributiveProfunctor' (not only a @Star f@, the van-Laarhoven shape)+-- through any optic that is at least a 'Traversal', by handing it to 'travP'.+--+-- The optic may be in any encoding: the constraint asks its class to hold for the generic carrier+-- @'ExOptic' 'TravFl' a b@. A 'Prostrong'-flavored optic discharges it via+-- @forall p q. w p q => 'Proarrow.Optic.Sub' 'TravFl' p q@, a '(%)'-composite one conjunct at a+-- time, and a profunctor-class one ('Proarrow.Optic.MonoidalTraversal.PTraversalFull') through the+-- carrier's by-generator instances.+traverseOf+  :: forall {k} c (s :: k) (t :: k) a b p+   . (Distributive k, StrongDistributiveProfunctor p, Strong ProdAction p, (Ob a, Ob b) => c (ExOptic TravFl a b))+  => Optic c s t a b -> p a b -> p s t+traverseOf o pab = withLegs @TravFl o \l r -> travP l r pab++-- | Build a traversal from a 'Traversable' (representable) functor @t@: it focuses every element+-- the functor holds. This is the one weak-flavor builder that is primitive: a+-- 'Traversable's traversal is not reachable by 'convert' from any single stronger optic. The+-- witness is @t@ itself paired with @'RepCostar' t@ (see 'TravFl' above). The two legs are the+-- representable universal @'repUniv'@ and the identity 'RepCostar'.+traversed+  :: forall {k} (t :: k +-> k) a b+   . (Bicartesian k, Traversable t, Representable t, Ob a, Ob b) => Traversal (t % a) (t % b) a b+traversed = legs2prof @TravFl (repUniv @t) (corepUniv @(RepCostar t))++-- * The free traversal profunctor++-- | Witness pair for traversing two juxtaposed (tensored) parts in sequence, both focusing @x@:+--+-- > Beside p1 p2 s x = exists s1 s2. (s ~> s1 ** s2, p1 s1 x, p2 s2 x)+--+-- spelled as a composite through @(k, k)@: split the source with the tensor (@'Rep' 'MultRep'@),+-- run the witnesses side by side (':**:'), and identify the foci with the diagonal (@'Rep' 'Diag'@).+-- 'Proarrow.Profunctor.Instance.Day.Day' is the same composite with @'Corep' 'MultRep'@ in place of+-- the diagonal, tensoring the foci instead. Identifying them is necessary: a Day witness pair admits+-- no componentwise 'travP', which would have to split a 'StrongDistributiveProfunctor' value at a+-- tensor. So 'Proarrow.Optic.Day.DayFl' optics focus pairs, while this one visits both foci in turn.+type Beside :: forall {k}. (k +-> k) -> (k +-> k) -> k +-> k+type Beside p1 p2 = Rep MultRep :.: (p1 :**: p2) :.: Rep Diag++-- | The covariant half of the 'Beside' witness pair: duplicate the focus with the diagonal+-- (@'Corep' 'Diag'@), run the two witnesses side by side, recompose the targets with the tensor+-- (@'Corep' 'MultRep'@, @t1 ** t2 ~> t@).+type CoBeside :: forall {k}. (k +-> k) -> (k +-> k) -> k +-> k+type CoBeside q1 q2 = Corep Diag :.: (q1 :**: q2) :.: Corep MultRep++instance (SetterFl p1 q1, SetterFl p2 q2, Monoidal k) => SetterFl (Beside p1 p2 :: k +-> k) (CoBeside q1 q2) where+  overP (Rep d :.: (l1 :**: l2) :.: Rep (f1 :**: f2)) (Corep (g1 :**: g2) :.: (r1 :**: r2) :.: Corep c) f =+    c . (overP @p1 @q1 (rmap f1 l1) (lmap g1 r1) f ** overP @p2 @q2 (rmap f2 l2) (lmap g2 r2) f) . d+instance (FoldFl p1 q1, FoldFl p2 q2, Monoidal k) => FoldFl (Beside p1 p2 :: k +-> k) (CoBeside q1 q2 :: k +-> k) where+  foldMapP (Rep d :.: (l1 :**: l2) :.: Rep (f1 :**: f2)) am =+    mappend . (foldMapP @p1 @q1 (rmap f1 l1) am ** foldMapP @p2 @q2 (rmap f2 l2) am) . d+instance (TravFl p1 q1, TravFl p2 q2, Monoidal k) => TravFl (Beside p1 p2 :: k +-> k) (CoBeside q1 q2) where+  travP (Rep d :.: (l1 :**: l2) :.: Rep (f1 :**: f2)) (Corep (g1 :**: g2) :.: (r1 :**: r2) :.: Corep c) r =+    dimap d c (travP @p1 @q1 (rmap f1 l1) (lmap g1 r1) r ** travP @p2 @q2 (rmap f2 l2) (lmap g2 r2) r)+instance (MonTravFl p1 q1, MonTravFl p2 q2, Monoidal k) => MonTravFl (Beside p1 p2 :: k +-> k) (CoBeside q1 q2) where+  monTravP (Rep d :.: (l1 :**: l2) :.: Rep (f1 :**: f2)) (Corep (g1 :**: g2) :.: (r1 :**: r2) :.: Corep c) r =+    dimap d c (monTravP @p1 @q1 (rmap f1 l1) (lmap g1 r1) r ** monTravP @p2 @q2 (rmap f2 l2) (lmap g2 r2) r)++-- | Witness pair for traversing one of two alternative (coproduct) parts: 'Beside' with the tensor+-- replaced by the coproduct (@'Rep' 'PlusRep'@, @s ~> s1 || s2@, and @'Corep' 'PlusRep'@,+-- @t1 || t2 ~> t@). Here identifying the foci and tensoring them agree, since @x1 || x2 ~> x@ is a+-- pair @(x1 ~> x, x2 ~> x)@. So this is Day convolution over the coproduct.+type BesideSum :: forall {k}. (k +-> k) -> (k +-> k) -> k +-> k+type BesideSum p1 p2 = Rep PlusRep :.: (p1 :**: p2) :.: Rep Diag++-- | The covariant half of the 'BesideSum' witness pair.+type CoBesideSum :: forall {k}. (k +-> k) -> (k +-> k) -> k +-> k+type CoBesideSum q1 q2 = Corep Diag :.: (q1 :**: q2) :.: Corep PlusRep++instance (SetterFl p1 q1, SetterFl p2 q2, HasBinaryCoproducts k) => SetterFl (BesideSum p1 p2 :: k +-> k) (CoBesideSum q1 q2) where+  overP (Rep d :.: (l1 :**: l2) :.: Rep (f1 :**: f2)) (Corep (g1 :**: g2) :.: (r1 :**: r2) :.: Corep c) f =+    c . (overP @p1 @q1 (rmap f1 l1) (lmap g1 r1) f +++ overP @p2 @q2 (rmap f2 l2) (lmap g2 r2) f) . d+instance+  (FoldFl p1 q1, FoldFl p2 q2, HasBinaryCoproducts k)+  => FoldFl (BesideSum p1 p2 :: k +-> k) (CoBesideSum q1 q2 :: k +-> k)+  where+  foldMapP (Rep d :.: (l1 :**: l2) :.: Rep (f1 :**: f2)) am =+    (foldMapP @p1 @q1 (rmap f1 l1) am ||| foldMapP @p2 @q2 (rmap f2 l2) am) . d+instance (TravFl p1 q1, TravFl p2 q2, HasBinaryCoproducts k) => TravFl (BesideSum p1 p2 :: k +-> k) (CoBesideSum q1 q2) where+  travP (Rep d :.: (l1 :**: l2) :.: Rep (f1 :**: f2)) (Corep (g1 :**: g2) :.: (r1 :**: r2) :.: Corep c) r =+    dimap d c (travP @p1 @q1 (rmap f1 l1) (lmap g1 r1) r ++ travP @p2 @q2 (rmap f2 l2) (lmap g2 r2) r)+instance+  (MonTravFl p1 q1, MonTravFl p2 q2, HasBinaryCoproducts k)+  => MonTravFl (BesideSum p1 p2 :: k +-> k) (CoBesideSum q1 q2)+  where+  monTravP (Rep d :.: (l1 :**: l2) :.: Rep (f1 :**: f2)) (Corep (g1 :**: g2) :.: (r1 :**: r2) :.: Corep c) r =+    dimap d c (monTravP @p1 @q1 (rmap f1 l1) (lmap g1 r1) r ++ monTravP @p2 @q2 (rmap f2 l2) (lmap g2 r2) r)++-- | Witness pair with no foci at all: decompose to 'Unit' and rebuild.+--+-- 'UnitW' and 'CoUnitW' are the halves of 'Proarrow.Profunctor.Instance.Day.DayUnit', one per side,+-- with a phantom focus; with 'Beside'\/'CoBeside' they are the Day-monoidal structure on profunctors+-- split at the focus. The split is forced: a whole 'DayUnit' on the decomposition side would demand+-- @Unit ~> a@ for an arbitrary focus @a@.+--+-- Unlike 'Beside' this is not a composite: the nullary analogue would pass through the unit+-- category @()@, which can coincide with @k@ and so overlap the generic composition instances.+type UnitW :: forall {k}. k +-> k+data UnitW s x where+  UnitW :: (Ob x) => (s ~> Unit) -> UnitW s x++-- | The covariant half of the 'UnitW' witness pair: rebuilds the target from 'Unit'.+type CoUnitW :: forall {k}. k +-> k+data CoUnitW x t where+  CoUnitW :: (Ob x) => (Unit ~> t) -> CoUnitW x t++instance (Monoidal k) => Profunctor (UnitW :: k +-> k) where+  dimap l r (UnitW h) = UnitW (h . l) \\ r+  r \\ UnitW h = r \\ h+instance (Monoidal k) => Profunctor (CoUnitW :: k +-> k) where+  dimap l r (CoUnitW i) = CoUnitW (r . i) \\ l+  r \\ CoUnitW i = r \\ i++instance (Monoidal k) => SetterFl (UnitW :: k +-> k) CoUnitW where+  overP (UnitW h) (CoUnitW i) _ = i . h+instance (Monoidal k) => FoldFl (UnitW :: k +-> k) (CoUnitW :: k +-> k) where+  foldMapP (UnitW h) _ = mempty . h+instance (Monoidal k) => TravFl (UnitW :: k +-> k) CoUnitW+instance (Monoidal k) => MonTravFl (UnitW :: k +-> k) CoUnitW where+  monTravP (UnitW h) (CoUnitW i) _ = dimap h i one+instance (Monoidal k) => Proadjunction (UnitW :: k +-> k) CoUnitW where+  unit = CoUnitW id :.: UnitW id+  counit (UnitW h :.: CoUnitW i) = i . h++-- | Witness pair for the impossible case: decompose to the initial object. These are the halves of+-- the (unspelled) unit of Day convolution over the coproduct monoidal structure, cf.+-- 'UnitW'\/'CoUnitW'.+type ZeroW :: forall {k}. k +-> k+data ZeroW s x where+  ZeroW :: (Ob x) => (s ~> InitialObject) -> ZeroW s x++-- | The covariant half of the 'ZeroW' witness pair: rebuilds the target from 'InitialObject'.+type CoZeroW :: forall {k}. k +-> k+data CoZeroW x t where+  CoZeroW :: (Ob x) => (InitialObject ~> t) -> CoZeroW x t++instance (HasInitialObject k) => Profunctor (ZeroW :: k +-> k) where+  dimap l r (ZeroW h) = ZeroW (h . l) \\ r+  r \\ ZeroW h = r \\ h+instance (HasInitialObject k) => Profunctor (CoZeroW :: k +-> k) where+  dimap l r (CoZeroW i) = CoZeroW (r . i) \\ l+  r \\ CoZeroW i = r \\ i++instance (HasInitialObject k) => SetterFl (ZeroW :: k +-> k) CoZeroW where+  overP (ZeroW h) (CoZeroW i) _ = i . h+instance (HasInitialObject k) => FoldFl (ZeroW :: k +-> k) (CoZeroW :: k +-> k) where+  foldMapP (ZeroW h) _ = initiate . h+instance (HasInitialObject k) => TravFl (ZeroW :: k +-> k) CoZeroW+instance (HasInitialObject k) => MonTravFl (ZeroW :: k +-> k) CoZeroW where+  monTravP (ZeroW h) (CoZeroW i) _ = dimap h i nil+instance (HasInitialObject k) => Proadjunction (ZeroW :: k +-> k) CoZeroW where+  unit = CoZeroW id :.: ZeroW id+  counit (ZeroW h :.: CoZeroW i) = i . h
+ src/Proarrow/Optics.hs view
@@ -0,0 +1,189 @@+-- | The user-facing optics vocabulary, in one import.+--+-- * /Build/ optics with 'iso', 'lens', 'monLens', 'prism', 'affineTraversal', 'grate', 'glass',+--   'powerGrate', 'cotraversal', 'kaleidoscope', 'algebraicLens', 'classifyingLens', 'tracer',+--   'traversed', 'traversal' (from a rank-2 function on profunctors, not the van-Laarhoven form),+--   'to' and 'unto'. The results support subtyping: an optic can be used wherever a weaker flavor+--   is needed (a 'Lens' is a 'Getter', a 'Setter', a 'Fold', ...). 'MonoidalTraversal' is built+--   with 'fromPTraversal'. 'Setter', 'Fold' and 'AffineFold' have no builder; reach them by+--   'convert' from a stronger optic.+-- * /Eliminate/ optics with one eliminator per flavor: 'view' (a 'Getter'), 'review' (a 'Review'),+--   'preview' (an 'AffineFold'), 'matching' (an 'AffineTraversal'), 'over' (a 'Setter'),+--   'foldMapOf' (a 'Fold'), 'traverseOf' (a 'Traversal'), 'monTraverseOf' (a 'MonoidalTraversal'),+--   'powerGrateOf' (a 'PowerGrate'), 'cotraverseOf' (a 'Cotraversal'), 'kaleidoscopeOf' and+--   'zipWithOf' (a 'Kaleidoscope'), 'classifyOf' (an 'AlgebraicLens') and 'tracerOf' (a 'Tracer')+--   /run/ the optic, while 'withIso', 'withLens', 'withMonLens', 'withPrism', 'withGrate' and+--   'withGlass' /recover its two legs/. The operators '(^.)', '(#)', 'set', '(%~)' and '(.~)'+--   abbreviate common ones; '(^?)' and '(.?)' abbreviate 'preview' and 'classifyOf' and return a+--   plain 'Prelude.Maybe' \/ pair instead of the ambient coproduct. Writing down 'preview'\'s own+--   result type needs "Proarrow.Colimit.BinaryCoproduct" and "Proarrow.Limit.Terminal".+-- * The library's structural isos (e.g. 'Proarrow.Category.Monoidal.associator') use a second,+--   profunctor-class encoding ('Proarrow.Optic.PIso'), which every consumer above also accepts.+--   To convert between encodings, interoperate with van Laarhoven, or write flavor-generic code,+--   import "Proarrow.Optic" and its submodules.+--+-- The subtyping lattice (flavor superclass edges, weakest at the top). Dotted nodes are one-sided+-- flavors, whose methods never mention the second witness; dashed nodes are indexed by a monad and+-- so have no edge to 'Iso':+--+-- <<lattice.svg The optics subtyping lattice>>+module Proarrow.Optics+  ( -- * Optic kinds+    Optic+  , Optic'+  , Iso+  , Iso'+  , Lens+  , Lens'+  , MonoidalLens+  , MonoidalLens'+  , Prism+  , Prism'+  , AffineTraversal+  , AffineTraversal'+  , Traversal+  , Traversal'+  , MonoidalTraversal+  , MonoidalTraversal'+  , PTraversal+  , PTraversal'+  , PTraversalFull+  , Setter+  , Setter'+  , Getter+  , Review+  , AffineFold+  , Fold+  , Grate+  , Grate'+  , Glass+  , Glass'+  , PowerGrate+  , PowerGrate'+  , Cotraversal+  , Cotraversal'+  , Kaleidoscope+  , Kaleidoscope'+  , AlgebraicLens+  , ClassifyingLens+  , Tracer+  , Tracer'++    -- * Building optics+  , iso+  , lens+  , monLens+  , prism+  , affineTraversal+  , grate+  , glass+  , powerGrate+  , cotraversal+  , kaleidoscope+  , algebraicLens+  , classifyingLens+  , tracer+  , traversed+  , traversal+  , to+  , unto+  , re++    -- * Eliminating optics++    -- | Exactly one eliminator per flavor: 'view', 'review', 'preview', 'matching', 'over',+    -- 'foldMapOf', 'traverseOf', 'monTraverseOf', 'powerGrateOf', 'cotraverseOf', 'kaleidoscopeOf',+    -- 'zipWithOf', 'classifyOf' and 'tracerOf' /run/ the optic; 'withIso', 'withLens',+    -- 'withMonLens', 'withPrism', 'withGrate' and 'withGlass' /recover its two legs/.+  , view+  , review+  , preview+  , matching+  , over+  , foldMapOf+  , traverseOf+  , monTraverseOf+  , powerGrateOf+  , cotraverseOf+  , kaleidoscopeOf+  , zipWithOf+  , classifyOf+  , tracerOf+  , withIso+  , withLens+  , withMonLens+  , withPrism+  , withGrate+  , withGlass++    -- * Operators and shorthands+  , (^.)+  , (#)+  , (^?)+  , (.?)+  , set+  , (%~)+  , (.~)+  , unfold++    -- * Composing and converting optics+  , (%)+  , convert+  , Algebra (..)+  , toPTraversal+  , toPTraversalFull+  , fromPTraversal+  ) where++import Proarrow.Optic (Optic, Optic', convert, iso, re, (%))+import Proarrow.Optic.Action+  ( Algebra (..)+  , AlgebraicLens+  , ClassifyingLens+  , algebraicLens+  , classifyOf+  , classifyingLens+  , (.?)+  )+import Proarrow.Optic.AffineFold (AffineFold, preview, (^?))+import Proarrow.Optic.AffineTraversal (AffineTraversal, AffineTraversal', matching)+import Proarrow.Optic.Fold (Fold, foldMapOf, unfold)+import Proarrow.Optic.Getter (Getter, Review, review, to, unto, view, (#), (^.))+import Proarrow.Optic.Glass (Glass, Glass', glass, withGlass)+import Proarrow.Optic.Grate (Grate, Grate', grate, withGrate)+import Proarrow.Optic.Iso (Iso, Iso', withIso)+import Proarrow.Optic.Kaleidoscope+  ( Cotraversal+  , Cotraversal'+  , Kaleidoscope+  , Kaleidoscope'+  , cotraversal+  , cotraverseOf+  , kaleidoscope+  , kaleidoscopeOf+  )+import Proarrow.Optic.Lens (Lens, Lens', lens, withLens)+import Proarrow.Optic.MonoidalLens (MonoidalLens, MonoidalLens', monLens, withMonLens)+import Proarrow.Optic.MonoidalTraversal+  ( MonoidalTraversal+  , MonoidalTraversal'+  , PTraversal+  , PTraversal'+  , PTraversalFull+  , fromPTraversal+  , monTraverseOf+  , toPTraversal+  , toPTraversalFull+  , traversal+  )+import Proarrow.Optic.PowerGrate+  ( PowerGrate+  , PowerGrate'+  , powerGrate+  , powerGrateOf+  , zipWithOf+  )+import Proarrow.Optic.Prism (Prism, Prism', affineTraversal, prism, withPrism)+import Proarrow.Optic.Setter (Setter, Setter', over, set, (%~), (.~))+import Proarrow.Optic.Tracer (Tracer, Tracer', tracer, tracerOf)+import Proarrow.Optic.Traversal (Traversal, Traversal', traverseOf, traversed)
+ src/Proarrow/Path.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | A profunctor-specific counterpart of "Proarrow.Bicategory.Strictified", hardcoded to+-- @:.:@\/'Id'. A 'Path' is a type-level list of profunctors; 'Fold' composes one down to a single+-- profunctor. Identity 2-cells need no tracking, since 2-cells are plain functions (@:~>@).+-- 'concatFold'\/'splitFold' do the associator\/unitor reshuffling once, by induction, so that+-- "Proarrow.Squares" never has to.+module Proarrow.Path where++import Data.Kind (Constraint, Type)+import Prelude (type (~))++import Proarrow.Core (CategoryOf (..), Kind, Profunctor (..), Promonad (..), lmap, rmap, src, tgt, (:~>), type (+->))+import Proarrow.Profunctor.Instance.Composition (o, (:.:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Representable (Representable)++infixr 5 :::+infixl 5 +++++-- | Identity natural transformation, used as a 2-cell between profunctors that happen to+-- be syntactically equal.+idN :: p :~> p+idN x = x++-- @:.:@\/'Id' aren't strictly associative\/unital, unlike the 'Proarrow.Bicategory.O'\/+-- 'Proarrow.Bicategory.I' of a strictified bicategory.+leftUnitor :: (Profunctor p) => Id :.: p :~> p+leftUnitor (Id l :.: p) = lmap l p++leftUnitorInv :: (Profunctor p) => p :~> Id :.: p+leftUnitorInv p = Id (src p) :.: p++rightUnitor :: (Profunctor p) => p :.: Id :~> p+rightUnitor (p :.: Id r) = rmap r p++rightUnitorInv :: (Profunctor p) => p :~> p :.: Id+rightUnitorInv p = p :.: Id (tgt p)++associator :: (p :.: q) :.: r :~> p :.: (q :.: r)+associator ((p :.: q) :.: r) = p :.: (q :.: r)++associatorInv :: p :.: (q :.: r) :~> (p :.: q) :.: r+associatorInv (p :.: (q :.: r)) = (p :.: q) :.: r++-- | A type-level list of profunctors, from category @j@ to category @k@.+type Path :: Kind -> Kind -> Kind+type data Path j k where+  Nil :: Path k k+  (:::) :: (i +-> j) -> Path j k -> Path i k++type family (+++) (ps :: Path a b) (qs :: Path b c) :: Path a c+type instance Nil +++ qs = qs+type instance (p ::: ps) +++ qs = p ::: (ps +++ qs)++-- | @(as +++ bs) +++ cs@ and @as +++ (bs +++ cs)@ are the same 'Path'. Proved once, up+-- front, by (mutual) induction with 'IsOb'\'s superclasses (see there for how the+-- induction goes through), so that every other associativity fact needed anywhere in+-- "Proarrow.Squares" is a free @~@ coercion instead of a function call.+class ((as +++ bs) +++ cs ~ as +++ (bs +++ cs)) => Assoc as bs cs++instance (as +++ (bs +++ cs) ~ (as +++ bs) +++ cs) => Assoc as bs cs++-- | Fold a 'Path' down to the single profunctor its elements compose to.+type family Fold (ps :: Path j k) :: j +-> k++type instance Fold (Nil :: Path j j) = Id+type instance Fold (p ::: Nil) = p+type instance Fold (p ::: (q ::: ps)) = Fold (q ::: ps) :.: p++-- | Which per-element property a 'SPath' witnesses. @Tight@ plays the role of the tight+-- (vertical, 'Representable') legs of the @Prof@ equipment; a later @Cotight@ would do+-- the same for 'Proarrow.Profunctor.Corepresentable.Corepresentable' legs.+data Tag = Prof | Tight++-- | The per-element constraint a 'Tag' stands for. @c@ is applied homogeneously at every+-- element of a path, each of a (potentially) different @i +-> j@ kind. That is an+-- impredicative use GHC's kind system can't express with @c@ itself as the parameter, so+-- 'Tag' is the (monomorphic, first-order) proxy for it. Mirrors+-- "Proarrow.Bicategory.Sub"'s @IsOb@\/@SUBCAT@ tag mechanism.+type family Sat (t :: Tag) (p :: i +-> j) :: Constraint++type instance Sat Prof p = Profunctor p+type instance Sat Tight p = Representable p++-- | Runtime witness that every element of a 'Path' satisfies @'Sat' t@. One witness type serves+-- every tag, so '(Proarrow.Squares.|||)'\/'(Proarrow.Squares.===)' need only one append lemma+-- ('withObAppend').+type SPath :: Tag -> Path a b -> Type+data SPath t ps where+  SNil :: (CategoryOf k) => SPath t (Nil :: Path k k)+  SCons :: (Sat t p) => SPath t ps -> SPath t (p ::: ps)++-- | @ps@ is a path all of whose elements satisfy @'Sat' t@. Only two cases (@Nil@\/@Cons@)+-- are needed: the head @p@ stays concrete at each step of 'withObAppend'\'s recursion, so+-- GHC's own instance resolution reattaches it to the recursively-derived+-- @'IsOb' t (ps +++ qs)@ for free. It never needs to reduce @ps +++ qs@ itself, only+-- match the @(':::')@ shape.+class+  (ps +++ Nil ~ ps, forall b c (qs :: Path k b) (rs :: Path b c). Assoc ps qs rs) =>+  IsOb (t :: Tag) (ps :: Path j k)+  where+  singPath :: SPath t ps++instance (CategoryOf k) => IsOb t (Nil :: Path k k) where+  singPath = SNil+instance (Sat t p, IsOb t ps) => IsOb t (p ::: ps) where+  singPath = SCons singPath++-- | Concatenate two witnesses. Plain recursion with no constraint solving, unlike+-- 'withObAppend', which also proves @'IsOb' t (ps +++ qs)@.+appendPath :: SPath t ps -> SPath t qs -> SPath t (ps +++ qs)+appendPath SNil qs = qs+appendPath (SCons ps) qs = SCons (appendPath ps qs)++-- | Bring a specific instantiation of @'IsOb' t ps@\'s quantified @'Assoc' ps qs rs@+-- superclass into scope. Needed explicitly: GHC won't search the superclasses of an+-- arbitrary given constraint to solve an unrelated @~@ goal, so uses of associativity+-- (e.g. in '(Proarrow.Squares.|||)'\/'(Proarrow.Squares.===)') have to ask for it by name+-- at the specific @ps@\/@qs@\/@rs@ in play, even though the fact itself is free once+-- asked for.+withAssoc :: forall ps qs rs t r. (IsOb t ps) => ((Assoc ps qs rs) => r) -> r+withAssoc r = r++-- | A well-formed (horizontal) path: every element is a plain 'Profunctor'.+type IsPath = IsOb Prof++-- | A tight (vertical) path: every element is 'Representable'.+type IsTight = IsOb Tight++-- | A tight path is, in particular, a well-formed path ('Representable' implies+-- 'Profunctor'). Needed explicitly because different 'Tag's don't otherwise know+-- anything about each other.+weakenTight :: SPath Tight ps -> SPath Prof ps+weakenTight SNil = SNil+weakenTight (SCons ps) = SCons (weakenTight ps)++-- | @ps@,@qs@ both satisfy @'Sat' t@ pointwise ⟹ so does @ps +++ qs@.+withObAppend :: forall t ps qs r. (IsOb t qs) => SPath t ps -> ((IsOb t (ps +++ qs)) => r) -> r+withObAppend SNil r = r+withObAppend (SCons ps) r = withObAppend @t @_ @qs ps r++-- | Extract 'Profunctor' evidence for @'Fold' ps@ from a runtime witness.+withFoldOb :: SPath Prof ps -> ((Profunctor (Fold ps)) => r) -> r+withFoldOb SNil r = r+withFoldOb (SCons SNil) r = r+withFoldOb (SCons cs@(SCons _)) r = withFoldOb cs r++-- | Extract 'Representable' evidence for @'Fold' ps@ from a runtime witness. The body is+-- identical to 'withFoldOb'\'s. Both extract @'Sat' t ('Fold' ps)@, which needs the same+-- single-vs-multi-element case split 'Fold' itself has. There is no polymorphic @t@ that would+-- let one definition serve both, since every call site knows its tag concretely.+withFoldRep :: SPath Tight ps -> ((Representable (Fold ps)) => r) -> r+withFoldRep SNil r = r+withFoldRep (SCons SNil) r = r+withFoldRep (SCons cs@(SCons _)) r = withFoldRep cs r++-- | Combine the composites of two adjacent paths into the composite of their+-- concatenation.+concatFold :: SPath Prof as -> SPath Prof bs -> Fold bs :.: Fold as :~> Fold (as +++ bs)+concatFold SNil bs = withFoldOb bs rightUnitor+concatFold (SCons SNil) bs = case bs of+  SNil -> leftUnitor+  SCons _ -> idN+concatFold (SCons cs@(SCons _)) bs = (concatFold cs bs `o` idN) . associatorInv++-- | The inverse of 'concatFold'.+splitFold :: SPath Prof as -> SPath Prof bs -> Fold (as +++ bs) :~> Fold bs :.: Fold as+splitFold SNil bs = withFoldOb bs rightUnitorInv+splitFold (SCons SNil) bs = case bs of+  SNil -> leftUnitorInv+  SCons _ -> idN+splitFold (SCons cs@(SCons _)) bs = associator . (splitFold cs bs `o` idN)++-- | Apply a 2-cell inside a concatenation, on the right.+whiskerL+  :: SPath Prof xs -> SPath Prof ys -> SPath Prof zs -> Fold ys :~> Fold zs -> Fold (xs +++ ys) :~> Fold (xs +++ zs)+whiskerL xs ys zs f = concatFold xs zs . (f `o` idN) . splitFold xs ys++-- | Apply a 2-cell inside a concatenation, on the left.+whiskerR+  :: SPath Prof xs -> SPath Prof ys -> SPath Prof zs -> Fold xs :~> Fold ys -> Fold (xs +++ zs) :~> Fold (ys +++ zs)+whiskerR xs ys zs f = concatFold ys zs . (idN `o` f) . splitFold xs zs
+ src/Proarrow/Profunctor/Cofree.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Cofree constructions, dual to "Proarrow.Profunctor.Free": 'HasCofree' captures the object constraints+-- @ob@ whose forgetful functor has a right adjoint, with @Cofree ob@ the cofree object, 'lower' the counit+-- and 'unfoldMap' the universal property.+module Proarrow.Profunctor.Cofree where++import Data.Kind (Constraint)++import Proarrow.Category.Instance.Sub (Forget, SUBCAT (..), Sub (..))+import Proarrow.Core (CategoryOf (..), OB, Profunctor (..), Promonad (..))+import Proarrow.Profunctor.Corepresentable (Corep (..))+import Proarrow.Profunctor.Representable (Representable (..), repUniv)++type HasCofree :: forall {k}. OB k -> Constraint+class (CategoryOf k, forall a. (Ob a) => ob (Cofree ob a)) => HasCofree (ob :: k -> Constraint) where+  type Cofree ob (a :: k) :: k+  lower :: (Ob a) => Cofree ob a ~> a+  unfoldMap :: (ob a) => a ~> b -> a ~> Cofree ob b++section :: forall ob a. (HasCofree ob, ob a, Ob a) => a ~> Cofree ob a+section = unfoldMap @ob id++cofreeMap :: (HasCofree ob) => (a ~> b) -> Cofree ob a ~> Cofree ob b+cofreeMap @ob f = unfoldMap @ob (f . lower @ob) \\ f++cofreeComp :: (HasCofree ob, Ob a) => Cofree ob b ~> c -> Cofree ob a ~> b -> Cofree ob a ~> c+cofreeComp @ob l r = l . unfoldMap @ob r++-- | By creating the right adjoint to the forgetful functor,+-- we obtain the forgetful-cofree adjunction.+instance (HasCofree ob) => Representable (Corep (Forget (ob :: OB k))) where+  type Corep (Forget ob) % a = SUB (Cofree ob a)+  index (Corep f) = Sub (unfoldMap @ob f) \\ f+  repUniv @a = let f = lower @ob @a in Corep f \\ f
+ src/Proarrow/Profunctor/Corepresentable.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Corepresentable profunctors, dual to "Proarrow.Profunctor.Representable": profunctors of the shape+-- /hom preceded by a functor/, identifying @p a b@ with @p %% a ~> b@ (functorial action '%%'). 'Corep'+-- packages any 'Proarrow.Functor.FunctorForRep' as its corepresentable profunctor.+module Proarrow.Profunctor.Corepresentable where++import Data.Kind (Constraint)++import Proarrow.Category.Enriched.Thin (DecidableProfunctor (..), Thin, ThinProfunctor (..), mapDecision)+import Proarrow.Category.Instance.Bool (Booleans (..))+import Proarrow.Category.Instance.Unit ()+import Proarrow.Core (CategoryOf (..), Hom, Profunctor (..), Promonad (..), lmap, rmap, type (+->))+import Proarrow.Functor (Copresheaf, FunctorForRep (..), withMappedOb)+import Proarrow.Object (Obj, obj)+import Proarrow.Optic (PIso, iso)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))++infixl 8 %%++-- | A profunctor is corepresentable if @p a ?@ as a copresheaf is representable in a functorial way over @a@.+type Corepresentable :: forall {j} {k}. (j +-> k) -> Constraint+class (Profunctor p) => Corepresentable (p :: j +-> k) where+  type p %% (a :: k) :: j+  coindex :: p a b -> p %% a ~> b+  cotabulate :: (Ob a) => (p %% a ~> b) -> p a b+  cotabulate f = rmap f corepUniv+  corepMap :: (a ~> b) -> p %% a ~> p %% b+  corepMap @_ @b f = coindex @p (lmap f (corepUniv @p @b)) \\ f+  corepUniv :: (Ob a) => p a (p %% a)+  corepUniv @a = cotabulate (corepObj @p @a)+  {-# MINIMAL coindex, ((cotabulate, corepMap) | corepUniv) #-}++instance Corepresentable (->) where+  type (->) %% a = a+  coindex f = f+  cotabulate f = f+  corepMap f = f+  corepUniv = id++instance Corepresentable Booleans where+  type Booleans %% x = x+  coindex = id+  cotabulate = id+  corepMap = id++instance (CategoryOf k) => Corepresentable (Id :: k +-> k) where+  type Id %% a = a+  coindex = unId+  cotabulate = Id+  corepMap = id++instance (Corepresentable p, Corepresentable q) => Corepresentable (p :.: q) where+  type (p :.: q) %% a = q %% (p %% a)+  coindex (p :.: q) = coindex q . corepMap @q (coindex p)+  cotabulate :: forall a b. (Ob a) => (((p :.: q) %% a) ~> b) -> (:.:) p q a b+  cotabulate f = withObCorep @p @a (cotabulate id :.: cotabulate f)+  corepMap f = corepMap @q (corepMap @p f)++corepObj :: forall p a. (Corepresentable p, Ob a) => Obj (p %% a)+corepObj = corepMap @p (obj @a)++withObCorep :: forall p a r. (Corepresentable p, Ob a) => ((Ob (p %% a)) => r) -> r+withObCorep r = r \\ corepMap @p (obj @a)++dimapCorep :: forall p a b c d. (Corepresentable p) => (c ~> a) -> (b ~> d) -> p a b -> p c d+dimapCorep l r = cotabulate @p . dimap (corepMap @p l) r . coindex \\ l++cotabulated :: forall p a a' b b'. (Corepresentable p, Ob a) => PIso (p %% a ~> b) (p %% a' ~> b') (p a b) (p a' b')+cotabulated = iso cotabulate coindex++-- | A representable copresheaf is a representable functor in the Haskell sense.+type RepresentableCopresheaf (f :: Copresheaf k) = Corepresentable f++type Key (f :: Copresheaf k) = f %% '()+tabulatedCopresheaf :: (RepresentableCopresheaf f, Ob a) => PIso (Key f ~> a) (Key f ~> a') (f '() a) (f '() a')+tabulatedCopresheaf = cotabulated++-- | Dual to 'Proarrow.Profunctor.Representable.Rep': the corepresentable profunctor of @f@, a+-- value @'Corep' f a b@ being an arrow @f \@ a '~>' b@.+type Corep :: (j +-> k) -> (k +-> j)+data Corep f a b where+  Corep :: forall a f b. (Ob a) => {unCorep :: f @ a ~> b} -> Corep f a b++instance (FunctorForRep f) => Profunctor (Corep f) where+  dimap = dimapCorep+  r \\ Corep f = r \\ f+instance (FunctorForRep f) => Corepresentable (Corep f) where+  type Corep f %% a = f @ a+  coindex (Corep f) = f+  cotabulate = Corep+  corepMap = fmap @f++-- | @'Corep' f a b@ holds in a thin category exactly when @f a ≤ b@.+instance (FunctorForRep f, Thin j) => ThinProfunctor (Corep f :: j +-> k) where+  type HasArrow (Corep f :: j +-> k) a b = HasArrow (Hom j) (f @ a) b+  arr @a = withMappedOb @f @a (Corep arr)+  withArr (Corep f) r = withArr f r++instance (FunctorForRep f, DecidableProfunctor (Hom j)) => DecidableProfunctor (Corep f :: j +-> k) where+  type Holds (Corep f :: j +-> k) a b = Holds (Hom j) (f @ a) b+  decide @a @b = withMappedOb @f @a (mapDecision Corep (decide @(Hom j) @(f @ a) @b))+  toHolds (Corep f) r = toHolds f r++corep :: forall f a b a' b'. (FunctorForRep f, Ob a) => PIso (f @ a ~> b) (f @ a' ~> b') (Corep f a b) (Corep f a' b')+corep = cotabulated
+ src/Proarrow/Profunctor/Free.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Free constructions: 'HasFree' captures the object constraints @ob@ whose forgetful functor has a left+-- adjoint, with @Free ob@ the free object, 'lift' the unit and 'foldMap' the universal property of the+-- adjunction (packaged as a 'Corepresentable' heteromorphism profunctor).+module Proarrow.Profunctor.Free where++import Data.Foldable1 (Foldable1 (foldMap1))+import Data.Kind (Constraint, Type)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe (Maybe (..))+import Prelude (($))+import Prelude qualified as P++import Proarrow.Category.Instance.Free (FREE (..), IsFreeOb (..), liftFree, retractFree)+import Proarrow.Category.Instance.IntConstruction (INT (..), IntConstruction (..), toInt)+import Proarrow.Category.Instance.Nat (Nat (..), first)+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Instance.Sub (Forget, On, SUBCAT (..), Sub (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), swap)+import Proarrow.Category.Monoidal.Applicative (Applicative (..))+import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..))+import Proarrow.Category.Monoidal.StarAutonomous (Dual, dualObj)+import Proarrow.Category.Monoidal.Strength (TracedMonoidal)+import Proarrow.Category.Monoidal.Strictified (Fold, Strictified (..), (==))+import Proarrow.Core+  ( CAT+  , CategoryOf (..)+  , Hom+  , Kind+  , OB+  , Profunctor (..)+  , Promonad (..)+  , UN+  , arr+  , lmap+  , obj+  , rmap+  , tgt+  , (//)+  , (:~>)+  )+import Proarrow.Functor (Functor (..))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts)+import Proarrow.Limit.Terminal (HasTerminalObject)+import Proarrow.Monoid (Monoid)+import Proarrow.Monoid qualified as M+import Proarrow.Profunctor.Corepresentable (Corepresentable (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Identity (Id)+import Proarrow.Profunctor.Instance.List (LIST (..), List (..))+import Proarrow.Profunctor.Instance.Star (Star, pattern Star)+import Proarrow.Profunctor.Representable (Rep (..))++type HasFree :: forall {k}. OB k -> Constraint+class (CategoryOf k, forall a. (Ob a) => ob (Free ob a)) => HasFree (ob :: OB k) where+  type Free ob (a :: k) :: k+  lift :: (Ob a) => a ~> Free ob a+  foldMap :: (ob b) => (a ~> b) -> Free ob a ~> b++retract :: forall ob a. (HasFree ob, ob a, Ob a) => Free ob a ~> a+retract = foldMap @ob id++freeMap :: (HasFree ob) => (a ~> b) -> Free ob a ~> Free ob b+freeMap @ob f = foldMap @ob (lift @ob . f) \\ f++freeComp :: (HasFree ob, Ob c) => b ~> Free ob c -> a ~> Free ob b -> a ~> Free ob c+freeComp @ob l r = foldMap @ob l . r++-- | By creating the left adjoint to the forgetful functor,+-- we obtain the free-forgetful adjunction.+instance (HasFree ob) => Corepresentable (Rep (Forget (ob :: OB k))) where+  type Rep (Forget ob) %% a = SUB (Free ob a)+  coindex (Rep f) = Sub (foldMap @ob f) \\ f+  corepUniv @a = let f = lift @ob @a in Rep f \\ f++instance HasFree P.Monoid where+  type Free P.Monoid a = [a]+  lift = P.pure+  foldMap = P.foldMap++instance HasFree P.Semigroup where+  type Free P.Semigroup a = NonEmpty a+  lift = P.pure+  foldMap = foldMap1++instance HasFree (P.Monoid `On` P.Semigroup) where+  type Free (P.Monoid `On` P.Semigroup) (SUB a) = SUB (Maybe a)+  lift = Sub Just+  foldMap (Sub f) = Sub (P.foldMap f)++-- | The free 'Applicative' on a functor @f@ (the 'HasFree' instance for 'Applicative'): formal 'pure',+-- effect and 'liftA2' nodes, retracted into any applicative by 'retractAp'.+type Ap :: (k -> Type) -> k -> Type+data Ap f a where+  Pure :: Unit ~> a -> Ap f a+  Eff :: f a -> Ap f a+  LiftA2 :: (Ob a, Ob b) => (a ** b ~> c) -> Ap f a -> Ap f b -> Ap f c++instance (CategoryOf k, Functor f) => Functor (Ap (f :: k -> Type)) where+  map f (Pure a) = Pure (f . a)+  map f (Eff x) = Eff (map f x)+  map f (LiftA2 k x y) = LiftA2 (f . k) x y++instance Functor Ap where+  map (Nat n) = Nat $ \case+    Pure a -> Pure a+    Eff fa -> Eff (n fa)+    LiftA2 k x y -> LiftA2 k (first (Nat n) x) (first (Nat n) y)++instance (Monoidal k) => Promonad (Star Ap :: CAT (k -> Type)) where+  id = Star (lift @Applicative)+  Star l . Star r = Star (freeComp @Applicative l r)++instance (Monoidal k, Functor f) => Applicative (Ap (f :: k -> Type)) where+  pure a () = Pure a+  liftA2 f (fa, fb) = LiftA2 f fa fb++-- | Given as 'P.Semigroup'\/'P.Monoid' rather than as 'Monoid' directly: @'Ap' f m@ is of kind+-- @Type@, where 'Monoid' already comes from the blanket @'P.Monoid' m => 'Monoid' (m :: Type)@+-- instance, so defining it here too would make every use overlap and solve to neither.+instance (Monoidal k, Monoid m) => P.Semigroup (Ap (f :: k -> Type) m) where+  l <> r = LiftA2 M.mappend l r++instance (Monoidal k, Monoid m) => P.Monoid (Ap (f :: k -> Type) m) where+  mempty = Pure M.mempty++retractAp :: (Applicative f) => Ap f a -> f a+retractAp (Pure a) = pure a ()+retractAp (Eff fa) = fa+retractAp (LiftA2 k x y) = liftA2 k (retractAp x, retractAp y)++instance (Monoidal k) => HasFree (Applicative :: OB (k -> Type)) where+  type Free Applicative f = Ap f+  lift = Nat Eff+  foldMap f@Nat{} = Nat retractAp . map f++-- | The free 'Promonad' on a profunctor @p@: a chain of @p@s ending in a hom arrow, folded into any+-- promonad by 'foldFreePromonad'.+data FreePromonad p a b where+  Unit :: (a ~> b) -> FreePromonad p a b+  Comp :: p a b -> FreePromonad p b c -> FreePromonad p a c++freePromonadAlg :: p :.: FreePromonad p :~> FreePromonad p+freePromonadAlg (p :.: pp) = Comp p pp++foldFreePromonad :: (Promonad q) => p :~> q -> FreePromonad p :~> q+foldFreePromonad _ (Unit f) = arr f+foldFreePromonad n (Comp p pp) = foldFreePromonad n pp . n p++instance (Profunctor p) => Profunctor (FreePromonad p) where+  dimap l r (Unit f) = Unit (r . f . l)+  dimap l r (Comp p q) = Comp (lmap l p) (rmap r q)+  r \\ (Unit f) = r \\ f+  r \\ Comp p q = r \\ p \\ q++instance (Profunctor p) => Promonad (FreePromonad p) where+  id = Unit id+  p . Unit f = lmap f p+  p . Comp r q = Comp r (p . q)+instance Functor FreePromonad where+  map = freeMap @Promonad+instance Promonad (Star FreePromonad) where+  id = Star (lift @Promonad)+  Star l . Star r = Star (freeComp @Promonad l r)+instance HasFree Promonad where+  type Free Promonad p = FreePromonad p+  lift = Prof \p -> p `Comp` Unit (tgt p)+  foldMap (Prof n) = Prof (foldFreePromonad n)++-- | The free @c@-structured kind over a @b@-structured kind @k@. A standalone family (rather than+-- an associated type of 'HasFreeK') because the kinds of 'Lift' and 'Retract' mention it.+type family FreeK (b :: Kind -> Constraint) (c :: Kind -> Constraint) (k :: Kind) :: Kind++-- | 'Proarrow.Object.Ob''-style helper: the quantified superclass of 'HasFreeK' needs to state+-- @c ('FreeK' b c k)@, and a type family application cannot head a quantified constraint directly.+class (c (FreeK b c k)) => FreeK' (b :: Kind -> Constraint) (c :: Kind -> Constraint) (k :: Kind)++instance (c (FreeK b c k)) => FreeK' b c k++-- | The embedding of an object of @k@ into the free @c@-structured kind.+type family Lift (b :: Kind -> Constraint) (c :: Kind -> Constraint) (a :: k) :: FreeK b c k++-- | Interpret an object of the free @c@-structured kind back into @k@.+type family Retract (b :: Kind -> Constraint) (c :: Kind -> Constraint) (k :: Kind) (a :: FreeK b c k) :: k++-- | @'FreeK' b c@ builds the free @c@-structured kind over any @b@-structured kind: 'liftK'+-- embeds the arrows of @k@, and when @k@ itself is already @c@-structured 'retractK' interprets+-- back into @k@.+class+  (forall k. (b k) => FreeK' b c k) =>+  HasFreeK (b :: Kind -> Constraint) (c :: Kind -> Constraint)+  where+  liftK :: (b k) => (x :: k) ~> y -> Lift b c x ~> Lift b c y+  retractK+    :: forall k (x :: FreeK b c k) (y :: FreeK b c k)+     . (c k)+    => x ~> y -> Retract b c k x ~> Retract b c k y++type instance FreeK CategoryOf Monoidal k = LIST k++type instance Lift CategoryOf Monoidal a = L '[a]+type instance Retract CategoryOf Monoidal k (a :: LIST k) = Fold (UN L a)++instance HasFreeK CategoryOf Monoidal where+  liftK f = Cons f Nil+  retractK Nil = one+  retractK (Cons f Nil) = f+  retractK (Cons f fs@Cons{}) = f ** retractK @CategoryOf @Monoidal fs++-- | The free category with a terminal object over @k@, built with+-- "Proarrow.Category.Instance.Free".+type instance FreeK CategoryOf HasTerminalObject k = FREE '[HasTerminalObject] (Hom k)++type instance Lift CategoryOf HasTerminalObject (a :: k) = EMB a+type instance Retract CategoryOf HasTerminalObject k (a :: FREE '[HasTerminalObject] (Hom k)) = Lower (Id :: CAT k) a++instance HasFreeK CategoryOf HasTerminalObject where+  liftK = liftFree+  retractK = retractFree @'[HasTerminalObject]++-- | The free category with binary products over @k@, built with+-- "Proarrow.Category.Instance.Free".+type instance FreeK CategoryOf HasBinaryProducts k = FREE '[HasBinaryProducts] (Hom k)++type instance Lift CategoryOf HasBinaryProducts (a :: k) = EMB a+type instance Retract CategoryOf HasBinaryProducts k (a :: FREE '[HasBinaryProducts] (Hom k)) = Lower (Id :: CAT k) a++instance HasFreeK CategoryOf HasBinaryProducts where+  liftK = liftFree+  retractK = retractFree @'[HasBinaryProducts]++type instance FreeK TracedMonoidal CompactClosed k = INT k++type instance Lift TracedMonoidal CompactClosed (a :: k) = I a Unit+type instance Retract TracedMonoidal CompactClosed k (I a b :: INT k) = a ** Dual b++instance HasFreeK TracedMonoidal CompactClosed where+  liftK = toInt+  retractK (Int @ap @am @bp @bm f) =+    dualObj @am //+      dualObj @bm //+        unStr $+          Str @[ap, Dual am] @[Dual am, ap] (swap @_ @ap @(Dual am)) ** Str @'[] @[bm, Dual bm] (dualityUnit @_ @bm)+            == obj @'[Dual am] ** Str @[ap, bm] @[am, bp] f ** obj @'[Dual bm]+            == Str @[Dual am, am] @'[] (dualityCounit @_ @am) ** obj @'[bp] ** obj @'[Dual bm]
+ src/Proarrow/Profunctor/Instance/Adj.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The 'Adj' newtype marks a profunctor as the heteromorphism profunctor of an adjunction: because left+-- adjoints preserve colimits and right adjoints preserve limits, @Adj p@ is a distributive monoidal+-- profunctor. Also proves that every adjunction between Hask endofunctors is equivalent to the+-- curry\/uncurry adjunction ('haskAdjIsCurryAdj').+module Proarrow.Profunctor.Instance.Adj where++import Data.Kind (Type)+import Prelude (const)++import Proarrow.Adjunction (Adjunction)+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..))+import Proarrow.Category.Monoidal.Cartesian (Cartesian)+import Proarrow.Colimit.BinaryCoproduct (Coprod (..), HasBinaryCoproducts (..), HasCoproducts)+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Core (Profunctor (..), Promonad (..), lmap, rmap, type (+->))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..))+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Object (pattern Objs)+import Proarrow.Optic (PIso, iso)+import Proarrow.Optic.Getter (review, view)+import Proarrow.Profunctor.Corepresentable (Corepresentable (..), corepObj)+import Proarrow.Profunctor.Representable (Representable (..), repObj)++-- | Preservation of limits and colimits makes the adjunction heteromorphism a distributive profunctor.+newtype Adj p a b = Adj (p a b)+  deriving newtype (Profunctor, Representable, Corepresentable)++instance (Cartesian j, Cartesian k, Corepresentable p) => MonoidalProfunctor (Adj p :: j +-> k) where+  one = cotabulate terminate \\ corepObj @p @TerminalObject+  Adj @_ @x l@Objs ** Adj @_ @y r@Objs =+    withOb2 @_ @x @y+      ( cotabulate+          ( coindex @p @(x ** y) (lmap (fst @_ @x @y) l)+              &&& coindex @p @(x ** y) (lmap (snd @_ @x @y) r)+          )+      )++instance (HasCoproducts j, HasCoproducts k, Representable p) => MonoidalProfunctor (Coprod (Adj p :: j +-> k)) where+  one = tabulate initiate \\ repObj @p @InitialObject+  Coprod (Adj @_ @_ @x l@Objs) ** Coprod (Adj @_ @_ @y r@Objs) =+    withObCoprod @_ @x @y+      ( Coprod+          ( Adj+              ( tabulate+                  ( index @p @_ @(x || y) (rmap (lft @_ @x @y) l)+                      ||| index @p @_ @(x || y) (rmap (rgt @_ @x @y) r)+                  )+              )+          )+      )++-- | Every adjunction between Hask endofunctors is equivalent to the curry-uncurry adjunction.+haskAdjIsCurryAdj+  :: forall p a b a' b'+   . (Adjunction (p :: Type +-> Type)) => PIso (p %% () -> a -> b) (p %% () -> a' -> b') (p a b) (p a' b')+haskAdjIsCurryAdj =+  iso (\kab -> tabulate \a -> index @p (cotabulate (`kab` a)) ()) (\p k a -> coindex p (corepMap @p (\() -> a) k))++instance (Adjunction p) => Promonad (Adj p :: Type +-> Type) where+  id = Adj (view (haskAdjIsCurryAdj @p) (const id))+  Adj l . Adj r = Adj (view (haskAdjIsCurryAdj @p) (\k -> review haskAdjIsCurryAdj l k . review haskAdjIsCurryAdj r k))
+ src/Proarrow/Profunctor/Instance/Arrow.hs view
@@ -0,0 +1,111 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Classic "Control.Arrow" arrows as promonads: 'Arr' wraps any 'Control.Arrow.Arrow' as a 'Promonad',+-- with the strength and monoidal instances corresponding to the arrow's capabilities+-- ('Control.Arrow.ArrowChoice', 'Control.Arrow.ArrowLoop', 'Control.Arrow.ArrowApply', ...).+module Proarrow.Profunctor.Instance.Arrow where++import Control.Arrow+  ( Arrow (..)+  , ArrowApply (..)+  , ArrowChoice (..)+  , ArrowLoop (..)+  , Kleisli (..)+  , (>>>)+  )+import Control.Category qualified as P+import Control.Monad (MonadPlus)+import Control.Monad.Fix (MonadFix)+import Data.Kind (Type)+import Prelude (Either (..), Functor (..), Monad (..))++import Proarrow.Category.Monoidal (MonoidalProfunctor (..), Tensor)+import Proarrow.Category.Monoidal.Action (CoprodAction)+import Proarrow.Category.Monoidal.Distributive (DistributiveProfunctor)+import Proarrow.Category.Monoidal.Strength (Costrong (..), Strong (..))+import Proarrow.Colimit.BinaryCoproduct (Coprod (..), (++))+import Proarrow.Core (CAT, Profunctor (..), Promonad (..), rmap, type (+->))+import Proarrow.Functor (FromProfunctor (..))+import Proarrow.Limit.BinaryProduct ()+import Proarrow.Profunctor.Representable (Representable (..))++swap :: (b, a) -> (a, b)+swap ~(x, y) = (y, x)++-- | A "Control.Arrow" 'Arrow' wrapped as a 'Promonad' on 'Type'.+type Arr :: CAT Type -> CAT Type+newtype Arr arr a b = Arr {unArr :: arr a b}++instance (Arrow arr) => Profunctor (Arr arr) where+  dimap l r (Arr a) = Arr (arr l >>> a >>> arr r)++instance (Arrow arr) => Promonad (Arr arr) where+  id = Arr (arr id)+  Arr f . Arr g = Arr (g >>> f)++instance (Arrow arr) => Strong Tensor (Arr arr) where+  act (Arr a) = Arr (second a)++instance (ArrowLoop arr) => Costrong Tensor (Arr arr) where+  coact (Arr f) = Arr (loop (arr swap >>> f >>> arr swap))++instance (Arrow arr) => MonoidalProfunctor (Arr arr) where+  one = Arr (arr id)+  Arr l ** Arr r = Arr (l *** r)++instance (ArrowChoice arr) => MonoidalProfunctor (Coprod (Arr arr)) where+  one = Coprod (Arr (arr id))+  Coprod (Arr l) ** Coprod (Arr r) = Coprod (Arr (l +++ r))++instance (ArrowApply arr) => Representable (Arr arr) where+  type Arr arr % a = arr () a+  index (Arr a) b = arr (\() -> b) >>> a+  tabulate f = Arr (arr (\a -> (f a, ())) >>> app)+  repMap f a = a >>> arr f++instance (Functor m) => Profunctor (Kleisli m) where+  dimap l r (Kleisli a) = Kleisli (fmap r . a . l)++instance (Monad m) => Promonad (Kleisli m) where+  id = arr id+  f . g = g >>> f++instance (Monad m) => Strong Tensor (Kleisli m) where+  act = second++instance (MonadPlus m) => Strong CoprodAction (Kleisli m) where+  act (Kleisli a) = Kleisli ((return . Left) ||| (a >>> fmap Right))++instance (MonadFix m) => Costrong Tensor (Kleisli m) where+  coact f = loop (arr swap >>> f >>> arr swap)++instance (Monad m) => MonoidalProfunctor (Kleisli m) where+  one = arr id+  l ** r = l *** r++instance (MonadPlus m) => MonoidalProfunctor (Coprod (Kleisli m)) where+  one = Coprod (Kleisli return)+  Coprod (Kleisli l) ** Coprod (Kleisli r) = Coprod (Kleisli ((l >>> fmap Left) ||| (r >>> fmap Right)))++instance (Functor m) => Representable (Kleisli m) where+  type Kleisli m % a = m a+  index = runKleisli+  tabulate = Kleisli+  repMap = fmap++instance (Promonad p) => P.Category (FromProfunctor p :: Type +-> Type) where+  id = id+  (.) = (.)++instance (MonoidalProfunctor p, Promonad p) => Arrow (FromProfunctor p :: Type +-> Type) where+  arr f = rmap f id+  FromProfunctor f *** FromProfunctor g = FromProfunctor (f ** g)++instance (DistributiveProfunctor p, Promonad p) => ArrowChoice (FromProfunctor p :: Type +-> Type) where+  FromProfunctor f +++ FromProfunctor g = FromProfunctor (f ++ g)++instance (Representable p, MonoidalProfunctor p, Promonad p) => ArrowApply (FromProfunctor p :: Type +-> Type) where+  app = FromProfunctor (tabulate \(FromProfunctor p, b) -> index p b)++instance (Costrong Tensor p, MonoidalProfunctor p, Promonad p) => ArrowLoop (FromProfunctor p :: Type +-> Type) where+  loop (FromProfunctor p) = FromProfunctor (coact @Tensor (dimap swap swap p))
+ src/Proarrow/Profunctor/Instance/Cocone.hs view
@@ -0,0 +1,29 @@+-- | A 'Cocone' is a list of arrows sharing a single target (the coapex), as a profunctor from lists of+-- objects to objects; a 'Sink' is a cocone with the coapex hidden existentially.+module Proarrow.Profunctor.Instance.Cocone where++import Proarrow.Category.Monoidal (MonoidalProfunctor (..))+import Proarrow.Colimit.BinaryCoproduct (COPROD (..), Coprod (..), HasBinaryCoproducts (..), HasCoproducts)+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), UN, rmap, type (+->))+import Proarrow.Profunctor.Instance.List (LIST (..), List (..))++-- | A cocone is a bunch of arrows with a shared target.+data Cocone (bs :: LIST k) (a :: COPROD k) where+  Coapex :: (Ob a) => Cocone (L '[]) (COPR a)+  Coleg :: b ~> a -> Cocone (L bs) (COPR a) -> Cocone (L (b : bs)) (COPR a)++instance (CategoryOf k) => Profunctor (Cocone :: COPROD k +-> LIST k) where+  dimap Nil r Coapex = Coapex \\ r+  dimap (Cons l ls) r@(Coprod r') (Coleg f fs) = Coleg (r' . f . l) (dimap ls r fs)+  r \\ Coapex = r+  r \\ Coleg l Coapex = r \\ l+  r \\ Coleg l c@(Coleg _ c1) = r \\ l \\ c \\ c1++instance (HasCoproducts k) => MonoidalProfunctor (Cocone :: COPROD k +-> LIST k) where+  one = Coapex+  Coapex @l ** rs = rmap (Coprod (rgt @_ @l)) rs \\ rs+  Coleg l ls ** (rs :: Cocone rs r) = Coleg (lft @_ @_ @(UN COPR r) . l) (ls ** rs) \\ l \\ rs++-- | A sink is a cocone, but with the apex type hidden by an existential.+data Sink (as :: [k]) where+  Cocone :: Cocone (L as) (COPR a) -> Sink as
+ src/Proarrow/Profunctor/Instance/Composition.hs view
@@ -0,0 +1,41 @@+-- | Profunctor composition ':.:', the coend @exists b. (p a b, q b c)@ with the coend hidden in the+-- existential of the constructor. This is the horizontal composition of profunctors; 'Promonad's are the+-- monoids with respect to it.+module Proarrow.Profunctor.Instance.Composition where++import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Core (Profunctor (..), Promonad (..), lmap, rmap, (:~>), type (+->))+import Proarrow.Functor (Functor (..), FunctorForRep (..))++type (:.:) :: (j +-> k) -> (i +-> j) -> (i +-> k)+data (p :.: q) a c where+  (:.:) :: forall b a c p q. ~(p a b) -> ~(q b c) -> (p :.: q) a c++instance (Profunctor p, Profunctor q) => Profunctor (p :.: q) where+  dimap l r (p :.: q) = lmap l p :.: rmap r q+  r \\ p :.: q = r \\ p \\ q++instance (Profunctor p) => Functor ((:.:) p) where+  map (Prof n) = Prof \(p :.: q) -> p :.: n q++instance (FunctorForRep p, FunctorForRep q) => FunctorForRep (p :.: q) where+  type (p :.: q) @ b = p @ (q @ b)+  fmap = fmap @p . fmap @q++-- The 'Proarrow.Category.Enriched.Thin.ThinProfunctor' instance for composition lives in+-- "Proarrow.Category.Enriched.Thin.Composition": in general it needs an existential over the+-- middle objects, which constraints can't express directly, so it either substitutes a+-- representable leg or, when both legs are decidable and the middle category enumerable,+-- searches the middle objects at the type level.++-- | Horizontal composition+o+  :: forall {i} {j} {k} (p :: j +-> k) (q :: j +-> k) (r :: i +-> j) (s :: i +-> j)+   . p :~> q+  -> r :~> s+  -> p :.: r :~> q :.: s+pq `o` rs = \(p :.: r) -> pq p :.: rs r++-- | @p :.: q@ is a `Promonad` if @p@ and @q@ are and if there's a distributive law between @p@ and @q@.+compComp :: (Promonad p, Promonad q) => q :.: p :~> p :.: q -> (p :.: q) b c -> (p :.: q) a b -> (p :.: q) a c+compComp dist (p1 :.: q1) (p2 :.: q2) = case dist (q2 :.: p1) of p3 :.: q3 -> (p3 . p2) :.: (q1 . q3)
+ src/Proarrow/Profunctor/Instance/Cone.hs view
@@ -0,0 +1,29 @@+-- | A 'Cone' is a list of arrows sharing a single source (the apex), as a profunctor from objects to lists+-- of objects; a 'Cosink' (a.k.a. a source) is a cone with the apex hidden existentially.+module Proarrow.Profunctor.Instance.Cone where++import Proarrow.Category.Monoidal (MonoidalProfunctor (..))+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), UN, lmap, type (+->))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..), HasProducts, PROD (..), Prod (..))+import Proarrow.Profunctor.Instance.List (LIST (..), List (..))++-- | A cone is a bunch of arrows with a shared source.+data Cone (a :: PROD k) (bs :: LIST k) where+  Apex :: (Ob a) => Cone (PR a) (L '[])+  Leg :: a ~> b -> Cone (PR a) (L bs) -> Cone (PR a) (L (b : bs))++instance (CategoryOf k) => Profunctor (Cone :: LIST k +-> PROD k) where+  dimap l Nil Apex = Apex \\ l+  dimap (Prod l) (Cons r rs) (Leg f fs) = Leg (r . f . l) (dimap (Prod l) rs fs)+  r \\ Apex = r+  r \\ Leg l Apex = r \\ l+  r \\ Leg l c@(Leg _ c1) = r \\ l \\ c \\ c1++instance (HasProducts k) => MonoidalProfunctor (Cone :: LIST k +-> PROD k) where+  one = Apex+  Apex @a ** rs = lmap (Prod (snd @_ @a)) rs \\ rs+  Leg l ls ** (rs :: Cone r rs) = Leg (l . fst @_ @_ @(UN PR r)) (ls ** rs) \\ l \\ rs++-- | A cosink (a.k.a a source) is a cone, but with the apex type hidden by an existential.+data Cosink (as :: [k]) where+  Cone :: Cone (PR a) (L as) -> Cosink as
+ src/Proarrow/Profunctor/Instance/Constant.hs view
@@ -0,0 +1,11 @@+-- | The constant functor as a 'Proarrow.Functor.FunctorForRep', sending every object to @c@. Its+-- representable profunctor @Rep (Constant c)@ is the viewing carrier used by 'Proarrow.Optic.Getter.view'.+module Proarrow.Profunctor.Instance.Constant where++import Proarrow.Core (CategoryOf (..), Promonad (..), type (+->))+import Proarrow.Functor (FunctorForRep (..))++data family Constant :: k -> j +-> k+instance (CategoryOf j, CategoryOf k, Ob c) => FunctorForRep (Constant c :: j +-> k) where+  type Constant c @ a = c+  fmap _ = id
+ src/Proarrow/Profunctor/Instance/Coproduct.hs view
@@ -0,0 +1,31 @@+-- | The pointwise coproduct of two profunctors: a @(p ':+:' q) a b@ is either a @p a b@ or a @q a b@.+module Proarrow.Profunctor.Instance.Coproduct where++import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Core (Profunctor (..), type (+->))+import Proarrow.Functor (Functor (..))++type (:+:) :: (j +-> k) -> (j +-> k) -> (j +-> k)+data (p :+: q) a b where+  InjL :: p a b -> (p :+: q) a b+  InjR :: q a b -> (p :+: q) a b++instance (Profunctor p, Profunctor q) => Profunctor (p :+: q) where+  dimap l r (InjL p) = InjL (dimap l r p)+  dimap l r (InjR q) = InjR (dimap l r q)+  r \\ InjL p = r \\ p+  r \\ InjR q = r \\ q++coproduct :: (p x y -> r) -> (q x y -> r) -> (p :+: q) x y -> r+coproduct l _ (InjL p) = l p+coproduct _ r (InjR q) = r q++instance (DaggerProfunctor p, DaggerProfunctor q) => DaggerProfunctor (p :+: q) where+  dagger (InjL p) = InjL (dagger p)+  dagger (InjR q) = InjR (dagger q)++instance (Profunctor p) => Functor ((:+:) p) where+  map (Prof n) = Prof \case+    InjL p -> InjL p+    InjR q -> InjR (n q)
+ src/Proarrow/Profunctor/Instance/Costar.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | 'Costar' embeds a functor @f@ as a profunctor with the functor on the source side:+-- @Costar f a b = f a ~> b@. It is the corepresentable profunctor of @f@, dual to+-- 'Proarrow.Profunctor.Instance.Star.Star'.+module Proarrow.Profunctor.Instance.Costar where++import Control.Monad qualified as P+import Data.Functor.Compose (Compose (..))+import Prelude qualified as P++import Proarrow.Category.Enriched.Thin (DecidableProfunctor (..), Thin, ThinProfunctor (..), mapDecision)+import Proarrow.Category.Instance.Nat (Nat' (..), type (.->) (..))+import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), withOb2)+import Proarrow.Category.Monoidal.Cartesian (Cartesian)+import Proarrow.Category.Monoidal.Distributive (Cotraversable (..), Traversable (..))+import Proarrow.Core (CategoryOf (..), Hom, Profunctor (..), Promonad (..), rmap, (//), (:~>), type (+->))+import Proarrow.Functor (Functor (..), Prelude (..), withObF)+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..))+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Profunctor.Corepresentable (Corepresentable (..), dimapCorep)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Product ((:*:) (..))+import Proarrow.Profunctor.Instance.Star (Star, pattern Star)+import Proarrow.Promonad (Procomonad (..))++type Costar' :: OPPOSITE (j .-> k) -> k +-> j+data Costar' f a b where+  Costar' :: (Ob a) => f a ~> b -> Costar' (OP (NT f)) a b++type Costar f = Costar' (OP (NT f))+pattern Costar :: () => (Ob a) => (f a ~> b) -> Costar f a b+pattern Costar f = Costar' f+{-# COMPLETE Costar #-}+unCostar :: Costar f a b -> f a ~> b+unCostar (Costar f) = f++instance (Functor f) => Profunctor (Costar f) where+  dimap = dimapCorep+  r \\ Costar f = r \\ f++instance Functor Costar' where+  map (Op (Nat' n)) = Prof \(Costar f) -> Costar (f . n)++instance (Functor f) => Corepresentable (Costar f) where+  type Costar f %% a = f a+  coindex = unCostar+  cotabulate = Costar+  corepMap = map++instance (Profunctor p) => Promonad (Costar ((:*:) p)) where+  id = Costar (Prof \(_ :*: q) -> q)+  Costar (Prof l) . Costar (Prof r) = Costar (Prof \(p :*: a) -> l (p :*: r (p :*: a)))++instance (P.Monad m) => Procomonad (Costar (Prelude m)) where+  proextract (Costar f) = f . Prelude . P.pure+  produplicate (Costar f) = Costar unPrelude :.: Costar (f . Prelude . P.join . unPrelude)++composeCostar :: (Functor g) => Costar f :.: Costar g :~> Costar (Compose g f)+composeCostar (Costar f :.: Costar g) = Costar (g . map f . getCompose)++-- | Every functor between cartesian categories is a colax monoidal functor.+instance (Cartesian j, Cartesian k, Functor (f :: j -> k)) => MonoidalProfunctor (Costar f) where+  one = withObF @f @(Unit :: j) (Costar terminate)+  Costar @a f ** Costar @b g = withOb2 @j @a @b (Costar (f . map (fst @j @a @b) &&& g . map (snd @j @a @b)))++instance (Functor t, Traversable (Star t)) => Cotraversable (Costar t) where+  cotraverse (p :.: Costar f) = p // Costar id :.: case traverse (Star id :.: p) of p' :.: Star g -> rmap (f . g) p'++instance (Functor f, Thin j) => ThinProfunctor (Costar f :: j +-> k) where+  type HasArrow (Costar f :: j +-> k) a b = HasArrow (Hom j) (f a) b+  arr = Costar arr+  withArr (Costar f) r = withArr f r++instance (Functor f, DecidableProfunctor (Hom j)) => DecidableProfunctor (Costar f :: j +-> k) where+  type Holds (Costar f :: j +-> k) a b = Holds (Hom j) (f a) b+  decide @a @b = withObF @f @a (mapDecision Costar (decide @(Hom j) @(f a) @b))+  toHolds (Costar f) r = toHolds f r
+ src/Proarrow/Profunctor/Instance/Coyoneda.hs view
@@ -0,0 +1,46 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The coyoneda construction: @'Coyoneda' p@ pairs a value of @p c d@ with reindexing arrows, making it+-- the free profunctor on an arbitrary type of kind @j +-> k@ (the 'HasFree' instance for 'Profunctor'). By+-- the coyoneda lemma it is equivalent to @p@ when @p@ is already a profunctor ('coyoneda'\/'unCoyoneda').+module Proarrow.Profunctor.Instance.Coyoneda where++import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), (:~>), type (+->))+import Proarrow.Functor (Functor (..))+import Proarrow.Profunctor.Free (HasFree (..))+import Proarrow.Profunctor.Instance.Costar (Costar, pattern Costar)+import Proarrow.Profunctor.Instance.Star (Star, pattern Star)++-- | The free profunctor on @p@ (the 'HasFree' instance for 'Profunctor'): a @p c d@ together with+-- reindexing arrows on both sides. Equivalent to @p@ when @p@ is already a profunctor+-- ('coyoneda'\/'unCoyoneda').+type Coyoneda :: (j +-> k) -> j +-> k+data Coyoneda p a b where+  Coyoneda :: (a ~> c) -> (d ~> b) -> p c d -> Coyoneda p a b++instance (CategoryOf j, CategoryOf k) => Profunctor (Coyoneda (p :: j +-> k)) where+  dimap l r (Coyoneda f g p) = Coyoneda (f . l) (r . g) p+  r \\ Coyoneda f g _ = r \\ f \\ g++instance (Functor Coyoneda) where+  map (Prof n) = Prof \(Coyoneda g h p) -> Coyoneda g h (n p)++instance Promonad (Star Coyoneda) where+  id = Star (Prof \p -> coyoneda p \\ p)+  Star (Prof l) . Star (Prof r) = Star (Prof (l . unCoyoneda . r))++instance Promonad (Costar Coyoneda) where+  id = Costar (Prof unCoyoneda)+  Costar (Prof l) . Costar (Prof r) = Costar (Prof (\p -> (l . (coyoneda \\ p) . r) p))++instance HasFree Profunctor where+  type Free Profunctor p = Coyoneda p+  lift = Prof \p -> coyoneda p \\ p+  foldMap (Prof f) = Prof (f . unCoyoneda)++coyoneda :: (CategoryOf j, CategoryOf k, Ob a, Ob b) => p a b -> Coyoneda (p :: j +-> k) a b+coyoneda = Coyoneda id id++unCoyoneda :: (Profunctor p) => Coyoneda p :~> p+unCoyoneda (Coyoneda f g p) = dimap f g p
+ src/Proarrow/Profunctor/Instance/Day.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Day convolution of profunctors: @'Day' p q@ convolves @p@ and @q@ along the tensors of the source and+-- target categories, with unit 'DayUnit' and internal hom 'DayExp'. Monoidal profunctors are closed under+-- it, and it preserves 'Procomonad's.+module Proarrow.Profunctor.Instance.Day where++import Proarrow.Category.Instance.Nat (Nat (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Monoidal+  ( Monoidal (..)+  , MonoidalProfunctor (..)+  , SymMonoidal (..)+  , swap+  , swapInner'+  , unitObj+  )+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard (..))+import Proarrow.Category.Monoidal.Distributive (Distributive (..))+import Proarrow.Category.Monoidal.Strength (MonStrong, first', second')+import Proarrow.Core+  ( CAT+  , CategoryOf (..)+  , Profunctor (..)+  , Promonad (..)+  , lmap+  , obj+  , rmap+  , src+  , tgt+  , (//)+  , type (+->)+  )+import Proarrow.Functor (Functor (..))+import Proarrow.Monoid (CocommutativeComonoid, CommutativeMonoid, Comonoid (..), Monoid (..), Supplies)+import Proarrow.Object (pattern Objs)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Coproduct ((:+:) (..))+import Proarrow.Promonad (Procomonad (..))++-- | The unit of 'Day' convolution: a pair of arrows through the monoidal units.+data DayUnit a b where+  DayUnit :: a ~> Unit -> Unit ~> b -> DayUnit a b++instance (CategoryOf j, CategoryOf k) => Profunctor (DayUnit :: j +-> k) where+  dimap l r (DayUnit f g) = DayUnit (f . l) (r . g)+  r \\ DayUnit f g = r \\ f \\ g++type Day :: (j +-> k) -> (j +-> k) -> j +-> k++-- | The Day convolution on profunctors.+data Day p q a b where+  Day :: forall c d e f p q a b. a ~> c ** e -> p c d -> q e f -> d ** f ~> b -> Day p q a b++day :: (Monoidal j, Monoidal k, Profunctor (p :: j +-> k), Profunctor q) => p c d -> q e f -> Day p q (c ** e) (d ** f)+day p q = Day (src p ** src q) p q (tgt p ** tgt q)++instance (Profunctor p, Profunctor q) => Profunctor (Day p q) where+  dimap l r (Day f p q g) = Day (lmap l f) p q (rmap r g)+  r \\ Day f _ _ g = r \\ f \\ g++instance (Procomonad p, Procomonad q, Monoidal k) => Procomonad (Day p q :: k +-> k) where+  proextract (Day f p q g) = g . (proextract p ** proextract q) . f+  produplicate (Day f p q g) = case (produplicate p, produplicate q) of+    (p' :.: p'', q' :.: q'') -> let bb = tgt p' ** tgt q' in Day f p' q' bb :.: Day bb p'' q'' g++instance (Profunctor p) => Functor (Day p) where+  map (Prof n) = Prof \(Day f p q g) -> Day f p (n q) g++instance Functor Day where+  map (Prof n) = Nat (Prof \(Day f p q g) -> Day f (n p) q g)++instance (SymMonoidal j, SymMonoidal k, MonoidalProfunctor p, MonoidalProfunctor q) => MonoidalProfunctor (Day p q :: j +-> k) where+  one = Day leftUnitorInv one one leftUnitor \\ unitObj @j \\ unitObj @k+  Day f1 p1 q1 g1 ** Day f2 p2 q2 g2 =+    let f = swapInner' (src p1) (src q1) (src p2) (src q2) . (f1 ** f2)+        g = (g1 ** g2) . swapInner' (tgt p1) (tgt p2) (tgt q1) (tgt q2)+    in Day f (p1 ** p2) (q1 ** q2) g++instance (Monoidal j, Monoidal k) => MonoidalProfunctor (Prof :: CAT (j +-> k)) where+  one = id+  Prof m ** Prof n = Prof \(Day f p q g) -> Day f (m p) (n q) g++instance (Monoidal j, Monoidal k) => Monoidal (j +-> k) where+  type Unit = DayUnit+  type p ** q = Day p q+  withOb2 r = r+  leftUnitor = Prof \(Day f (DayUnit h i) q g) -> dimap (leftUnitor . (h ** src q) . f) (g . (i ** tgt q) . leftUnitorInv) q \\ q+  leftUnitorInv = Prof \q -> Day leftUnitorInv (DayUnit one one) q leftUnitor \\ q+  rightUnitor = Prof \(Day f p (DayUnit h i) g) -> dimap (rightUnitor . (src p ** h) . f) (g . (tgt p ** i) . rightUnitorInv) p \\ p+  rightUnitorInv = Prof \p -> Day rightUnitorInv p (DayUnit one one) rightUnitor \\ p+  associator = Prof \(Day @_ @_ @e1 @f1 f1 (Day @c2 @d2 @e2 @f2 f2 p2@Objs q2@Objs g2) q1@Objs g1) ->+    Day+      (associator @_ @c2 @e2 @e1 . (f2 ** src q1) . f1)+      p2+      (day q2 q1)+      (g1 . (g2 ** tgt q1) . associatorInv @_ @d2 @f2 @f1)+  associatorInv = Prof \(Day @c1 @d1 f1 p1@Objs (Day @c2 @d2 @e2 @f2 f2 p2@Objs q2@Objs g2) g1) ->+    Day+      (associatorInv @_ @c1 @c2 @e2 . (src p1 ** f2) . f1)+      (day p1 p2)+      q2+      (g1 . (tgt p1 ** g2) . associator @_ @d1 @d2 @f2)++instance (SymMonoidal j, SymMonoidal k) => SymMonoidal (j +-> k) where+  swap = Prof \(Day @c @d @e @f f p q g) -> Day (swap @_ @c @e . f) q p (g . swap @_ @f @d) \\ p \\ q++instance (Profunctor p, MonoidalProfunctor p) => Monoid p where+  mempty = Prof \(DayUnit f g) -> dimap f g one+  mappend = Prof \(Day f p q g) -> dimap f g (p ** q)++instance (SymMonoidal j, CopyDiscard k, Supplies CommutativeMonoid j, Profunctor p) => Comonoid (p :: j +-> k) where+  counit = Prof \p -> p // DayUnit discard mempty+  comult = Prof \p -> p // Day copy p p mappend+instance (SymMonoidal j, CopyDiscard k, Supplies CommutativeMonoid j, Profunctor p) => CocommutativeComonoid (p :: j +-> k)++instance (SymMonoidal j, CopyDiscard k, Supplies CommutativeMonoid j) => CopyDiscard (j +-> k)++instance (Monoidal j, Monoidal k) => Distributive (j +-> k) where+  distL = Prof \(Day l a bc r) -> case bc of+    InjL b -> InjL (Day l a b r)+    InjR c -> InjR (Day l a c r)+  distR = Prof \(Day l ab c r) -> case ab of+    InjL a -> InjL (Day l a c r)+    InjR b -> InjR (Day l b c r)+  absorbL = Prof \case {}+  absorbR = Prof \case {}++duoidal+  :: (Monoidal j, Profunctor (p :: j +-> k), Profunctor p', Profunctor q, Profunctor q')+  => (p :.: p') `Day` (q :.: q') ~> (p `Day` q) :.: (p' `Day` q')+duoidal = Prof \(Day f (p :.: p') (q :.: q') g) -> let b = tgt p ** tgt q in Day f p q b :.: Day b p' q' g++-- | The internal hom of 'Day' convolution, making the category of profunctors 'Closed'.+data DayExp p q a b where+  DayExp+    :: forall p q a b. (Ob a, Ob b) => (forall c d e f. e ~> a ** c -> b ** d ~> f -> p c d -> q e f) -> DayExp p q a b++instance (Monoidal j, Monoidal k, Profunctor (p :: j +-> k), Profunctor q) => Profunctor (DayExp p q) where+  dimap l r (DayExp n) = l // r // DayExp \f g p -> n ((l ** src p) . f) (g . (r ** tgt p)) p+  r \\ DayExp n = r \\ n++instance (Monoidal j, Monoidal k, Profunctor (p :: j +-> k)) => Functor (DayExp p) where+  map (Prof n) = Prof \(DayExp m) -> DayExp \f g p -> n (m f g p)++instance (Monoidal j, Monoidal k) => Closed (j +-> k) where+  type p ~~> q = DayExp p q+  withObExp r = r+  curry (Prof n) = Prof \p -> p // DayExp \f g q -> n (Day f p q g)+  apply = Prof \(Day f (DayExp h) q g) -> h f g q+  (^^^) (Prof n) (Prof m) = Prof \(DayExp k) -> DayExp \f g p -> n (k f g (m p))++multDayExp+  :: (SymMonoidal j, SymMonoidal k, Profunctor (p :: j +-> k), Profunctor q, Profunctor p', Profunctor q')+  => (p ~~> q) `Day` (p' ~~> q') ~> (p `Day` p') ~~> (q `Day` q')+multDayExp = Prof \(Day @c @d @e @f g (DayExp pq) (DayExp pq') h) ->+  g //+    h //+      DayExp+        ( \l r (Day i p p' j) ->+            p //+              p' //+                let c = obj @c; d = obj @d; e = obj @e; f = obj @f; c' = src p; d' = tgt p; e' = src p'; f' = tgt p'+                in Day+                     (swapInner' c e c' e' . (g ** i) . l)+                     (pq (c ** c') (d ** d') p)+                     (pq' (e ** e') (f ** f') p')+                     (r . (h ** j) . swapInner' d d' f f')+        )++-- Day p q :: j +-> k can be Strong in multiple ways:+-- 1. Either p or q is strong, and we have: Act a (b ** c) ~ (Act a b) ** c.+-- 2. Or p and q are both strong, and we have: Act a (b ** c) ~ (Act a b) ** (Act a c)++day2comp :: (MonStrong (p :: k +-> k), MonStrong q, Monoidal k) => Day p q ~> p :.: q+day2comp = Prof \(Day @_ @d @e f p q g) -> lmap f (first' @e p) :.: rmap g (second' @d q) \\ p \\ q
+ src/Proarrow/Profunctor/Instance/Direp.hs view
@@ -0,0 +1,31 @@+-- | @'Direp' f g@ is the profunctor of arrows @f \@ a ~> g \@ b@ between the images of two functors+-- (given as 'Proarrow.Functor.FunctorForRep's).+module Proarrow.Profunctor.Instance.Direp where++import Prelude (($))++import Proarrow.Category.Enriched.Thin (DecidableProfunctor (..), Thin, ThinProfunctor (..), mapDecision)+import Proarrow.Core (CategoryOf (..), Hom, Profunctor (..), Promonad (..), type (+->))+import Proarrow.Functor (FunctorForRep (..), withMappedOb)++-- | An arrow @f \@ a '~>' g \@ b@ between the images of the functors @f@ and @g@, as a profunctor.+type Direp :: (j +-> k) -> (i +-> k) -> i +-> j+data Direp f g a b where+  Direp :: (Ob a, Ob b) => (f @ a) ~> (g @ b) -> Direp f g a b++instance (FunctorForRep f, FunctorForRep g) => Profunctor (Direp f g) where+  dimap l r (Direp f) = Direp (fmap @g r . f . fmap @f l) \\ r \\ l+  r \\ Direp{} = r++instance (Thin k, FunctorForRep f, FunctorForRep g) => ThinProfunctor (Direp (f :: j +-> k) (g :: i +-> k)) where+  type HasArrow (Direp (f :: j +-> k) g) a b = HasArrow (Hom k) (f @ a) (g @ b)+  arr @a @b = withMappedOb @f @a $ withMappedOb @g @b $ Direp (arr @(Hom k) @(f @ a) @(g @ b))+  withArr (Direp f) r = withArr f r++instance+  (DecidableProfunctor (Hom k), FunctorForRep f, FunctorForRep g)+  => DecidableProfunctor (Direp (f :: j +-> k) (g :: i +-> k))+  where+  type Holds (Direp (f :: j +-> k) g) a b = Holds (Hom k) (f @ a) (g @ b)+  decide @a @b = withMappedOb @f @a (withMappedOb @g @b (mapDecision Direp (decide @(Hom k) @(f @ a) @(g @ b))))+  toHolds (Direp f) r = toHolds f r
+ src/Proarrow/Profunctor/Instance/Edges.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Relations and weighted graphs on a bare set of points, given as a table: a list of edges with+-- their weights in the enriching category @v@. 'Edges' is an enriched profunctor on the discrete+-- category of an 'Indexed' kind (over a discrete base there is nothing to be compatible with), so+-- it composes, and its Kleene closure 'Proarrow.Category.Enriched.Thin.Composition.Closure' is+-- reachability for 'BOOL' weights and shortest paths for 'COST' weights.+module Proarrow.Profunctor.Instance.Edges where++import Data.Kind (Constraint)+import Data.Type.Equality qualified as Eq+import Prelude (type (~))++import Proarrow.Category.Enriched (EnrichedProfunctor (..))+import Proarrow.Category.Enriched.Quantale (Quantale (..))+import Proarrow.Category.Enriched.Thin+  ( DecidableProfunctor (..)+  , Decision (..)+  , Equal+  , Indexed+  , KnownIndex+  , ThinProfunctor+  , decideEq+  )+import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..), If)+import Proarrow.Category.Instance.Cost (COST)+import Proarrow.Category.Instance.Discrete (DISCRETE (..), Discrete (..), deltaAct)+import Proarrow.Category.Monoidal (Monoidal (..))+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Core (CategoryOf (..), Kind, Profunctor (..), obj, type (+->))+import Proarrow.Limit.BinaryProduct (type (&&))++-- | A weighted graph on the bare set of points of an 'Indexed' kind, given as a list of edges with+-- their weights in @v@: an enriched profunctor on the discrete category, since over a discrete base+-- there is nothing to be compatible with. Unlisted pairs are at 'InitialObject', a pair listed twice+-- takes its first weight, and an element is a pair at 'Unit' weight.+type Edges :: forall {k} {v}. [(k, k, v)] -> DISCRETE k +-> DISCRETE k+data Edges es a b where+  Edge :: (Ob a, Ob b, WeightOf es a b ~ Unit) => Edges es a b++type WeightOf :: forall {k} {v}. [(k, k, v)] -> DISCRETE k -> DISCRETE k -> v+type family WeightOf es a b where+  WeightOf '[] a b = InitialObject+  WeightOf ('(x, y, w) ': es) a b = If (Equal a (D x) && Equal b (D y)) w (WeightOf es a b)++instance (Indexed k) => Profunctor (Edges (es :: [(k, k, v)])) where+  dimap Refl Refl e = e+  r \\ Edge = r++-- | The edge list, reflected to the value level.+type EdgeList :: forall {k} {v}. [(k, k, v)] -> Kind+data EdgeList es where+  ENil :: EdgeList '[]+  ECons :: forall x y w es. (KnownIndex x, KnownIndex y, Ob w) => EdgeList es -> EdgeList ('(x, y, w) ': es)++type KnownEdges :: forall {k} {v}. [(k, k, v)] -> Constraint+class KnownEdges es where+  edges :: EdgeList es+instance KnownEdges '[] where+  edges = ENil+instance (KnownIndex x, KnownIndex y, Ob w, KnownEdges es) => KnownEdges ('(x, y, w) ': es) where+  edges = ECons edges++-- | A graph with 'BOOL' weights is a relation on the points: decided by walking the edge list.+instance (Indexed k, KnownEdges es) => ThinProfunctor (Edges (es :: [(k, k, BOOL)]))++instance (Indexed k, KnownEdges es) => DecidableProfunctor (Edges (es :: [(k, k, BOOL)])) where+  type Holds (Edges es) a b = WeightOf es a b+  decide @a @b = go (edges @es)+    where+      go+        :: forall (es' :: [(k, k, BOOL)])+         . (WeightOf es' a b ~ WeightOf es a b)+        => EdgeList es' -> Decision (Edges es) a b (WeightOf es' a b)+      go ENil = No+      go (ECons @x @y @w es') = case (decideEq @a @(D x), decideEq @b @(D y)) of+        (Yes Eq.Refl, Yes Eq.Refl) -> case obj @w of+          Tru -> Yes Edge+          Fls -> No+        (No, _) -> go es'+        (Yes _, No) -> go es'+  toHolds Edge r = r++-- | The weight of a pair, reflected to the value level by walking the edge list.+withObWeight+  :: forall {k} {v} (es :: [(k, k, v)]) a b r+   . (Quantale v, Indexed k, KnownEdges es, KnownIndex a, KnownIndex b)+  => ((Ob (WeightOf es a b)) => r) -> r+withObWeight r = go (edges @es) r+  where+    go :: forall (es' :: [(k, k, v)]). EdgeList es' -> ((Ob (WeightOf es' a b)) => r) -> r+    go ENil r' = r'+    go (ECons @x @y es') r' = case (decideEq @a @(D x), decideEq @b @(D y)) of+      (Yes Eq.Refl, Yes Eq.Refl) -> r'+      (No, _) -> go es' r'+      (Yes _, No) -> go es' r'++-- | A unit into a weight is an edge at the unit, since an object above the unit is the unit.+enrichedEdge+  :: forall {k} {v} (es :: [(k, k, v)]) a b+   . (Quantale v, Indexed k, KnownEdges es, KnownIndex a, KnownIndex b)+  => Unit ~> WeightOf es a b -> Edges es a b+enrichedEdge f = go (edges @es) f+  where+    go+      :: forall (es' :: [(k, k, v)])+       . (WeightOf es' a b ~ WeightOf es a b)+      => EdgeList es' -> Unit ~> WeightOf es' a b -> Edges es a b+    go ENil g = unitIsNotBottom @v g+    go (ECons @x @y @w es') g = case (decideEq @a @(D x), decideEq @b @(D y)) of+      (Yes Eq.Refl, Yes Eq.Refl) -> unitIsTop @v @w g Edge+      (No, _) -> go es' g+      (Yes _, No) -> go es' g++-- | A graph with 'COST' weights: a weighted graph, whose closure is shortest paths.+instance (Indexed k, KnownEdges es) => EnrichedProfunctor COST (Edges (es :: [(k, k, COST)])) where+  type ProObj COST (Edges es) a b = WeightOf es a b+  withProObj @a @b = withObWeight @es @a @b+  underlying Edge = obj @(Unit :: COST)+  enriched @a @b = enrichedEdge @es @a @b+  rmap @a @b @c =+    withObWeight @es @a @b (withObWeight @es @a @c (deltaAct @b @c @(WeightOf es a b) @(WeightOf es a c) Eq.Refl))+  lmap @a @b @c =+    withObWeight @es @a @b (withObWeight @es @c @b (deltaAct @c @a @(WeightOf es a b) @(WeightOf es c b) Eq.Refl))
+ src/Proarrow/Profunctor/Instance/Exponential.hs view
@@ -0,0 +1,89 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The internal hom of the category of profunctors under the /product/: a @(p ':~>:' q) a b@ is a+-- natural family of maps @p c d -> q c d@ available at @a@\/@b@, making @'PROD' (j +-> k)@ 'Closed'.+-- @j +-> k@ itself is 'Closed' too, but for Day convolution and with a different hom (see+-- "Proarrow.Profunctor.Instance.Day"). The 'PROD' wrapper keeps the two apart.+module Proarrow.Profunctor.Instance.Exponential where++import Proarrow.Category.Enriched.Thin+  ( DecidableProfunctor (..)+  , Decision (..)+  , Discrete+  , ThinProfunctor (..)+  , noArrow+  , withEq+  )+import Proarrow.Category.Instance.Bool (BoolLeq)+import Proarrow.Category.Instance.Constraint (reifyExp, (:=>) (..), type (:-) (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Instance.Sub (IsObProd, SUBCAT (..), Sub (..))+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Core (CategoryOf (..), OB, Profunctor (..), Promonad (..), UN, (//), type (+->))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts, PROD (..), Prod (..))+import Proarrow.Limit.Terminal (HasTerminalObject)+import Proarrow.Profunctor.Instance.Product ((:*:) (..))++data (p :~>: q) a b where+  Exp :: (Ob a, Ob b) => (forall c d. c ~> a -> b ~> d -> p c d -> q c d) -> (p :~>: q) a b++instance (Profunctor p, Profunctor q) => Profunctor (p :~>: q) where+  dimap l r (Exp f) = l // r // Exp \ca bd p -> f (l . ca) (bd . r) p+  r \\ Exp{} = r++instance (CategoryOf j, CategoryOf k) => Closed (PROD (j +-> k)) where+  type p ~~> q = PR (UN PR p :~>: UN PR q)+  withObExp r = r+  curry (Prod (Prof n)) = Prod (Prof \p -> p // Exp \ca bd q -> n (dimap ca bd p :*: q))+  apply = Prod (Prof \(Exp f :*: q) -> f id id q \\ q)+  Prod (Prof m) ^^^ Prod (Prof n) = Prod (Prof \(Exp f) -> Exp \ca bd p -> m (f ca bd (n p)))++-- | That a full subcategory of the profunctors contains the internal homs of its objects, as a+-- class with a single instance, so that it can be the head of the quantified constraint below.+-- 'Proarrow.Category.Instance.Sub.IsObProd' has the same shape for the product.+class (ob (p :~>: q)) => IsObExp (ob :: OB (j +-> k)) p q++instance (ob (p :~>: q)) => IsObExp ob p q++-- | And then the subcategory is closed, with the ambient exponential and nothing of its own,+-- just as its products are the ambient ones. @'Proarrow.Category.Enriched.Finitary.Topos.FINITARY'+-- j k@ is one instance, 'Proarrow.Category.Enriched.Finitary.Sheaf.SHEAVES' another. For the+-- first, a hom-set of natural transformations is finitary. For the second, an internal hom into a+-- sheaf is a sheaf.+instance+  ( CategoryOf j+  , CategoryOf k+  , HasTerminalObject (SUBCAT ob)+  , HasBinaryProducts (SUBCAT ob)+  , -- the product one again, as a constraint: 'apply' needs @ob@ of a product whose left factor is+    -- an internal hom, which no @'Ob' _@ in scope mentions+    forall p q. (ob p, ob q) => IsObProd ob p q+  , forall p q. (ob p, ob q) => IsObExp ob p q+  )+  => Closed (PROD (SUBCAT (ob :: OB (j +-> k))))+  where+  type p ~~> q = PR (SUB (UN SUB (UN PR p) :~>: UN SUB (UN PR q)))+  withObExp r = r+  curry (Prod (Sub (Prof n))) = Prod (Sub (Prof \p -> p // Exp \ca bd q -> n (dimap ca bd p :*: q)))+  apply = Prod (Sub (Prof \(Exp f :*: q) -> f id id q \\ q))+  Prod (Sub (Prof m)) ^^^ Prod (Sub (Prof n)) = Prod (Sub (Prof \(Exp f) -> Exp \ca bd p -> m (f ca bd (n p))))++instance (ThinProfunctor p, ThinProfunctor q, Discrete j, Discrete k) => ThinProfunctor (p :~>: q :: j +-> k) where+  type HasArrow (p :~>: q) a b = (HasArrow p a b :=> HasArrow q a b)+  arr @a @b = Exp \ca bd p -> withEq ca (withEq bd (withArr p (unEntails (entails @(HasArrow p a b) @(HasArrow q a b)) arr)))+  withArr @a @b (Exp f) r = reifyExp (Entails @(HasArrow p a b) @(HasArrow q a b) (\r' -> withArr (f id id arr) r')) r++-- | Implication, decided: the exponential holds unless @p@ holds and @q@ does not. Against @p@ an+-- arrow of @p@ is refuted by 'noArrow'.+instance+  (DecidableProfunctor p, DecidableProfunctor q, Discrete j, Discrete k)+  => DecidableProfunctor (p :~>: q :: j +-> k)+  where+  type Holds (p :~>: q) a b = BoolLeq (Holds p a b) (Holds q a b)+  decide @a @b = case (decide @p @a @b, decide @q @a @b) of+    (_, Yes y) -> Yes (Exp \ca bd _ -> withEq ca (withEq bd y))+    (No, No) -> Yes (Exp \ca bd x -> withEq ca (withEq bd (noArrow x)))+    (Yes _, No) -> No+  toHolds @a @b (Exp f) r = case decide @p @a @b of+    Yes x -> toHolds (f id id x) r+    No -> r
+ src/Proarrow/Profunctor/Instance/Fix.hs view
@@ -0,0 +1,79 @@+-- | The fixed point of a profunctor: @'Fix' p@ is @p ':.:' 'Fix' p@ rolled up, with 'hylo' as the+-- accompanying hylomorphism combinator.+module Proarrow.Profunctor.Instance.Fix where++import Data.Functor.Const (Const (..))++import Proarrow.Category.Instance.Nat (Nat (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Monoidal (MonoidalProfunctor (..))+import Proarrow.Category.Monoidal.Distributive (Cotraversable (..), Traversable (..))+import Proarrow.Category.Monoidal.Strength (Strong (..))+import Proarrow.Core (Profunctor (..), Promonad (..), (:~>), type (+->))+import Proarrow.Functor (Functor (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Star (Star, pattern Star)++-- | The fixed point of a profunctor: @'Fix' p@ is @p ':.:' 'Fix' p@ rolled up ('In'\/'out'). Fold it+-- with 'cata', unfold it with 'ana', or both at once with 'hylo'.+type Fix :: k +-> k -> k +-> k+data Fix p a b where+  In :: {out :: ~((p :.: Fix p) a b)} -> Fix p a b++instance (Profunctor p) => Profunctor (Fix p) where+  dimap l r = In . dimap l r . out \\ l \\ r+  r \\ In p = r \\ p++instance (Promonad p) => Promonad (Fix p) where+  id = In (id :.: id)+  qs . In (p :.: ps) = In (p :.: (qs . ps))++instance Functor Fix where+  map n@Prof{} = Prof (In . unProf (unNat (map n) . map (map n)) . out)++instance (MonoidalProfunctor p) => MonoidalProfunctor (Fix p) where+  one = In one+  In p ** In q = In (p ** q)++instance (Traversable p) => Traversable (Fix p) where+  traverse (In pfp :.: r) = case traverse (pfp :.: r) of r' :.: pfp' -> r' :.: In pfp'++instance (Cotraversable p) => Cotraversable (Fix p) where+  cotraverse (r :.: In pfp) = case cotraverse (r :.: pfp) of pfp' :.: r' -> In pfp' :.: r'++instance (Strong t p) => Strong t (Fix p) where+  act @x (In p) = In (act @t @_ @x p)++hylo :: (Profunctor p, Profunctor a, Profunctor b) => (p :.: b :~> b) -> (a :~> p :.: a) -> a :~> b+hylo alg coalg = unProf go where go = Prof alg . map go . Prof coalg++cata :: (Profunctor p, Profunctor r) => (p :.: r :~> r) -> Fix p :~> r+cata alg = hylo alg out++ana :: (Profunctor p, Profunctor r) => (r :~> p :.: r) -> r :~> Fix p+ana coalg = hylo In coalg++data ListF x l = Nil | Cons x l+instance Functor (ListF x) where+  map _ Nil = Nil+  map f (Cons x l) = Cons x (f l)++embed :: ListF x [x] -> [x]+embed Nil = []+embed (Cons x xs) = x : xs++project :: [x] -> ListF x [x]+project [] = Nil+project (x : xs) = Cons x xs++embed' :: Star (ListF x) :.: Star (Const [x]) :~> Star (Const [x])+embed' (Star f :.: Star g) = Star (Const . embed . map (getConst . g) . f)++project' :: Star (Const [x]) :~> Star (ListF x) :.: Star (Const [x])+project' (Star f) = Star (project . getConst . f) :.: Star Const++toList :: Fix (Star (ListF x)) :~> Star (Const [x])+toList = cata embed'++fromList :: Star (Const [x]) :~> Fix (Star (ListF x))+fromList = ana project'
+ src/Proarrow/Profunctor/Instance/Fold.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | The left-fold profunctor (after @Data.Fold.M@ from the @folds@ package): a @'Fold' a b@ is a monoid+-- @m@ together with arrows @a ~> m@ and @m ~> b@.+module Proarrow.Profunctor.Instance.Fold where++import Data.Kind (Type)+import Prelude qualified as P++import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal, leftUnitorInvWith, swapInner)+import Proarrow.Category.Monoidal.Action (CoprodAction, ProdAction)+import Proarrow.Category.Monoidal.Applicative (Applicative (..))+import Proarrow.Category.Monoidal.Cartesian (BiCCC, Cartesian, distLProd, distRProd)+import Proarrow.Category.Monoidal.Strength (Costrong (..), Strong (..))+import Proarrow.Colimit.BinaryCoproduct (COPROD (..), HasBinaryCoproducts (..), right)+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), obj, type (+->))+import Proarrow.Functor (map)+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..), PROD (..))+import Proarrow.Monoid (Monoid (..))+import Proarrow.Profunctor.Corepresentable (Corepresentable (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Promonad (Procomonad (..))++-- | A left fold from @a@ to @b@: an internal monoid @m@ with a step arrow @a '~>' m@ and an+-- extractor @m '~>' b@.+data Fold a b where+  Fold :: (Ob m) => (m ~> b) -> (a ~> m) -> (m ** m ~> m) -> (Unit ~> m) -> Fold a b++instance (CategoryOf k) => Profunctor (Fold :: k +-> k) where+  dimap f g (Fold k h m z) = Fold (g . k) (h . f) m z+  r \\ Fold f g _ _ = r \\ f \\ g++instance (CategoryOf k) => Procomonad (Fold :: k +-> k) where+  proextract (Fold f g _ _) = f . g+  produplicate (Fold f g m z) = Fold id g m z :.: Fold f id m z++instance (SymMonoidal k) => MonoidalProfunctor (Fold :: k +-> k) where+  one = Fold id id leftUnitor id+  Fold @m f g m z ** Fold @n f' g' m' z' =+    withOb2 @k @m @n P.$+      Fold (f ** f') (g ** g') ((m ** m') . swapInner @m @n @m @n) ((z ** z') . leftUnitorInv)++instance (BiCCC k) => Strong CoprodAction (Fold :: k +-> k) where+  act @(COPR a) (Fold @m k h m z) = withObCoprod @k @a @m P.$ Fold (obj @a +++ k) (right @a h) (step m) (rgt @_ @a @m . z)+    where+      step :: (Ob m, Ob a, Ob (a || m)) => (m && m) ~> m -> (a || m) && (a || m) ~> (a || m)+      step mult = (lft @k @a @m . fst @k @a @(a || m) ||| (snd @k @m @a +++ mult) . distLProd @m @a @m) . distRProd @a @m @(a || m)++instance (Cartesian k) => Costrong ProdAction (Fold :: k +-> k) where+  coact @(PR a) @_ @y (Fold f g m z) = Fold (snd @k @a @y . f) (g . leftUnitorInvWith (fst @k @a @y . f . z)) m z++trav :: (Applicative f) => Fold a b -> Fold (f a) (f b)+trav (Fold @m k h m z) = Fold (map k) (map h) (liftA2 @_ @m @m m) (pure z)++instance Corepresentable (Fold :: Type +-> Type) where+  type Fold %% a = [a]+  cotabulate f = Fold f (: []) mappend mempty+  coindex (Fold f g m z) xs = f (go xs)+    where+      go [] = z ()+      go (x : xs') = m (g x, go xs')+  corepMap = map
+ src/Proarrow/Profunctor/Instance/HaskValue.hs view
@@ -0,0 +1,35 @@+-- | @'HaskValue' c@ is the profunctor that ignores its indices and simply holds a Haskell value of type+-- @c@; it is a 'Promonad' and a monoidal profunctor whenever @c@ is a 'Prelude.Monoid'.+module Proarrow.Profunctor.Instance.HaskValue where++import Data.Kind (Type)+import Prelude (Monoid (..), ($))++import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..))+import Proarrow.Category.Monoidal.Distributive (Cotraversable (..), Traversable (..))+import Proarrow.Category.Monoidal.Strength (strongId)+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), type (+->))+import Proarrow.Profunctor.Instance.Composition ((:.:) ((:.:)))++-- | The profunctor that ignores its indices and holds a plain Haskell value of type @c@.+type HaskValue :: Type -> j +-> k+data HaskValue c a b where+  HaskValue :: (Ob a, Ob b) => c -> HaskValue c a b++instance (CategoryOf j, CategoryOf k) => Profunctor (HaskValue c :: j +-> k) where+  dimap l r (HaskValue c) = HaskValue c \\ l \\ r+  r \\ HaskValue{} = r++instance (Monoid c, CategoryOf k) => Promonad (HaskValue c :: k +-> k) where+  id = HaskValue mempty+  HaskValue c1 . HaskValue c2 = HaskValue (mappend c1 c2)++instance (Monoid c, Monoidal j, Monoidal k) => MonoidalProfunctor (HaskValue c :: j +-> k) where+  one = HaskValue mempty+  HaskValue @a1 @b1 c1 ** HaskValue @a2 @b2 c2 = withOb2 @k @a1 @a2 $ withOb2 @j @b1 @b2 $ HaskValue (mappend c1 c2)++instance (Monoidal k) => Traversable (HaskValue c :: k +-> k) where+  traverse (HaskValue c :.: r) = strongId :.: HaskValue c \\ r++instance (Monoidal k) => Cotraversable (HaskValue c :: k +-> k) where+  cotraverse (r :.: HaskValue c) = HaskValue c :.: strongId \\ r
+ src/Proarrow/Profunctor/Instance/Identity.hs view
@@ -0,0 +1,39 @@+-- | The identity profunctor 'Id', wrapping the hom arrows of a category. It is the unit of profunctor+-- composition ("Proarrow.Profunctor.Instance.Composition") and the identity 'Promonad'.+module Proarrow.Profunctor.Instance.Identity where++import Proarrow.Category.Enriched.Dagger (Dagger, DaggerProfunctor (..))+import Proarrow.Category.Enriched.Thin (DecidableProfunctor (..), Thin, ThinProfunctor (..), mapDecision)+import Proarrow.Core (CAT, CategoryOf (..), Hom, Profunctor (..), Promonad (..))+import Proarrow.Functor (FunctorForRep (..))++-- | The identity profunctor: the hom arrows of the category wrapped as a data type. It is the unit+-- of profunctor composition and the identity 'Promonad'.+type Id :: CAT k+newtype Id a b = Id {unId :: a ~> b}++instance (CategoryOf k) => Profunctor (Id :: CAT k) where+  lmap l (Id f) = Id (f . l)+  rmap r (Id f) = Id (r . f)+  r \\ Id f = r \\ f++instance (CategoryOf k) => Promonad (Id :: CAT k) where+  id = Id id+  Id f . Id g = Id (f . g)++instance (CategoryOf k) => FunctorForRep (Id :: CAT k) where+  type Id @ a = a+  fmap f = f++instance (Dagger k) => DaggerProfunctor (Id :: CAT k) where+  dagger (Id p) = Id (dagger p)++instance (Thin k) => ThinProfunctor (Id :: CAT k) where+  type HasArrow (Id :: CAT k) a b = HasArrow (Hom k) a b+  arr = Id arr+  withArr (Id f) r = withArr f r++instance (DecidableProfunctor (Hom k)) => DecidableProfunctor (Id :: CAT k) where+  type Holds (Id :: CAT k) a b = Holds (Hom k) a b+  decide @a @b = mapDecision Id (decide @(Hom k) @a @b)+  toHolds (Id f) r = toHolds f r
+ src/Proarrow/Profunctor/Instance/Initial.hs view
@@ -0,0 +1,34 @@+-- | The empty profunctor, with no values at all: the initial object of the category of profunctors+-- @j +-> k@.+module Proarrow.Profunctor.Instance.Initial where++import Prelude (Eq, Show)++import Proarrow.Category.Enriched.Dagger (Dagger, DaggerProfunctor (..))+import Proarrow.Category.Enriched.Thin (DecidableProfunctor (..), Decision (..), Thin, ThinProfunctor (..))+import Proarrow.Category.Instance.Bool (BOOL (..))+import Proarrow.Category.Instance.Zero (Bottom (..))+import Proarrow.Core (CategoryOf, Profunctor (..), type (+->))++-- | The profunctor with no values at all: the initial object of the category of profunctors+-- @j +-> k@.+type InitialProfunctor :: j +-> k+data InitialProfunctor a b+  deriving (Show, Eq)++instance (CategoryOf j, CategoryOf k) => Profunctor (InitialProfunctor :: j +-> k) where+  dimap _ _ = \case {}+  (\\) _ = \case {}++instance (Dagger k) => DaggerProfunctor (InitialProfunctor :: k +-> k) where+  dagger = \case {}++instance (Thin j, Thin k) => (ThinProfunctor (InitialProfunctor :: j +-> k)) where+  type HasArrow (InitialProfunctor :: j +-> k) a b = Bottom+  arr = no+  withArr = \case {}++instance (Thin j, Thin k) => DecidableProfunctor (InitialProfunctor :: j +-> k) where+  type Holds (InitialProfunctor :: j +-> k) a b = FLS+  decide = No+  toHolds = \case {}
+ src/Proarrow/Profunctor/Instance/List.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The category @'LIST' k@ of lists of objects of @k@, whose arrows are componentwise lists of arrows.+-- @'List' p@ lifts a profunctor @p@ componentwise to lists. Lists of objects are the arity-indexing used by+-- promonoidal categories ("Proarrow.Category.Promonoidal") and by cones and cocones.+module Proarrow.Profunctor.Instance.List where++import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), Strictly (..))++-- import Proarrow.Category.Monoidal.Action (MonoidalAction (..), Strong (..))+import Proarrow.Category.Monoidal.Strictified qualified as Str+import Proarrow.Core (CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, type (+->))+import Proarrow.Functor (Functor (..))++-- import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Representable (Representable (..))++type data LIST k = L [k]++-- | Lifts @p@ componentwise to lists: an arrow between equal-length lists of objects is a list of+-- @p@-arrows.+type List :: (j +-> k) -> LIST j +-> LIST k+data List p as bs where+  Nil :: List p (L '[]) (L '[])+  Cons :: (Str.IsList as, Str.IsList bs) => p a b -> List p (L as) (L bs) -> List p (L (a ': as)) (L (b ': bs))++mkCons :: (Profunctor p) => p a b -> List p (L as) (L bs) -> List p (L (a ': as)) (L (b ': bs))+mkCons f fs = Cons f fs \\ fs++foldList :: (MonoidalProfunctor p) => List p as bs -> p (Str.Fold (UN L as)) (Str.Fold (UN L bs))+foldList Nil = one+foldList (Cons p Nil) = p+foldList (Cons p ps@Cons{}) = p ** foldList ps++instance Functor List where+  map (Prof n) = Prof \case+    Nil -> Nil+    Cons p ps -> Cons (n p) (unProf (map (Prof n)) ps)++-- | The category of lists of arrows.+instance (CategoryOf k) => CategoryOf (LIST k) where+  type (~>) = List (~>)+  type Ob as = (Is L as, Str.IsList (UN L as))++instance (Promonad p) => Promonad (List p) where+  id @(L bs) = case Str.sList @bs of+    Str.SNil -> Nil+    Str.SSing -> Cons id Nil+    Str.SCons -> Cons id id+  Nil . Nil = Nil+  Cons f fs . Cons g gs = Cons (f . g) (fs . gs)++instance (Profunctor p) => Profunctor (List p) where+  dimap Nil Nil Nil = Nil+  dimap (Cons l ls) (Cons r rs) (Cons f fs) =+    Cons (dimap l r f) (dimap ls rs fs)+  dimap Nil Cons{} fs = case fs of {}+  dimap Cons{} Nil fs = case fs of {}+  r \\ Nil = r+  r \\ Cons f Nil = r \\ f+  r \\ Cons f fs@Cons{} = r \\ f \\ fs++-- | The free monoidal profunctor on a profunctor.+instance (Profunctor p) => MonoidalProfunctor (List p) where+  one = Nil+  Nil ** Nil = Nil+  Nil ** gs@Cons{} = gs+  Cons f fs ** Nil = mkCons f (fs ** Nil)+  Cons f fs ** Cons g gs = mkCons f (fs ** Cons g gs)++-- | The free monoidal category on a category.+instance (CategoryOf k) => Monoidal (LIST k) where+  type Unit = L '[]+  type p ** q = L (UN L p Str.++ UN L q)+  withOb2 @(L as) @(L bs) r = Str.withIsList2 @as @bs r+  associator @as @bs @cs = associatorDefault @as @bs @cs+  associatorInv @as @bs @cs = associatorDefault @as @bs @cs++instance (Representable p) => Representable (List p) where+  type List p % L '[] = L '[]+  type List p % L (a ': as) = L ((p % a) ': UN L (List p % L as))+  index Nil = Nil+  index (Cons p Nil) = Cons (index @p p) Nil+  index (Cons p ps@Cons{}) = mkCons (index @p p) (index @(List p) ps)+  tabulate @(L b) Nil = case Str.sList @b of Str.SNil -> Nil+  tabulate @(L b) (Cons f Nil) = case Str.sList @b of Str.SSing -> Cons (tabulate @p f) Nil+  tabulate @(L b) (Cons f fs@Cons{}) = case Str.sList @b of Str.SCons -> Cons (tabulate @p f) (tabulate @(List p) fs)+  repMap Nil = Nil+  repMap (Cons f Nil) = Cons (repMap @p f) Nil+  repMap (Cons f fs@Cons{}) = mkCons (repMap @p f) (repMap @(List p) fs)++instance (DaggerProfunctor p) => DaggerProfunctor (List p) where+  dagger Nil = Nil+  dagger (Cons f fs) = Cons (dagger f) (dagger fs)
+ src/Proarrow/Profunctor/Instance/PastroTambara.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | 'Pastro' and 'Tambara' are the free and cofree 'Prostrong' profunctors for an optic flavor @w@ (the+-- 'HasFree' and 'HasCofree' instances for @'Prostrong' w@): @Pastro w r@ sandwiches @r@ between an+-- existential witness pair, while @Tambara w r@ provides strength against every witness pair at once.+module Proarrow.Profunctor.Instance.PastroTambara where++import Prelude (($))++import Proarrow.Category.Instance.Opposite (OPPOSITE (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Core (CategoryOf (..), OB, Profunctor (..), Promonad (..), src, tgt, (//), (:~>), type (+->))+import Proarrow.Functor (Functor (..))+import Proarrow.Optic (ExOptic (..), FLAVOR, Flavor, Prostrong (..))+import Proarrow.Profunctor.Cofree (HasCofree (..), cofreeComp)+import Proarrow.Profunctor.Corepresentable (Corepresentable (..))+import Proarrow.Profunctor.Free (HasFree (..), freeComp)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Costar (Costar, pattern Costar)+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Instance.Ran (Ran (..), runRan, type (|>))+import Proarrow.Profunctor.Instance.Rift (Rift (..), runRift, type (<|))+import Proarrow.Profunctor.Instance.Star (Star, pattern Star)+import Proarrow.Profunctor.Instance.Yoneda (Yo (..))++-- | The free 'Prostrong' profunctor for the flavor @w@: the profunctor @r@ sandwiched between an+-- existential @w@-witness pair.+type Pastro :: FLAVOR j k -> j +-> k -> j +-> k+data Pastro w r a b where+  Pastro+    :: forall {k} {j} (p :: k +-> k) (q :: j +-> j) w r a b+     . (w p q, Profunctor p, Profunctor q) => (p :.: r :.: q) a b -> Pastro w r a b++pastro :: forall {j} {k} (w :: FLAVOR j k) (p :: j +-> k). (Profunctor p, Flavor w) => p :~> Pastro w p+pastro p = Pastro (Id id :.: p :.: Id id) \\ p++unpastro :: forall {j} {k} (w :: FLAVOR j k) (p :: j +-> k). (Prostrong w p) => Pastro w p :~> p+unpastro (Pastro fpg) = proact @w fpg++instance (CategoryOf j, CategoryOf k, Profunctor p) => Profunctor (Pastro t p :: j +-> k) where+  dimap l r (Pastro fpg) = Pastro (dimap l r fpg)+  r \\ Pastro fpg = r \\ fpg+instance (Flavor w, Profunctor p) => Prostrong w (Pastro w p :: j +-> k) where+  proact (p :.: Pastro (p' :.: r :.: q') :.: q) = Pastro ((p :.: p') :.: r :.: (q' :.: q))++instance (Flavor w) => HasFree (Prostrong w :: OB (j +-> k)) where+  type Free (Prostrong w) p = Pastro w p+  lift = Prof pastro+  foldMap n = Prof unpastro . map n++instance Functor (Pastro t) where+  map (Prof n) = Prof \(Pastro (f :.: p :.: g)) -> Pastro (f :.: n p :.: g)+instance (Flavor w) => Promonad (Star (Pastro w) :: (j +-> k) +-> (j +-> k)) where+  id = Star (Prof pastro)+  Star n . Star m = Star (freeComp @(Prostrong w) n m)++fromExOptic+  :: forall {j} {k} w (a :: k) (b :: j)+   . (CategoryOf j, CategoryOf k) => ExOptic w a b :~> (Pastro w (Yo a (OP b)) :: j +-> k)+fromExOptic (ExOptic f g) = Pastro (f :.: Yo (tgt f) (src g) :.: g)++-- | The cofree 'Prostrong' profunctor for the flavor @w@: strength against every @w@-witness pair+-- at once.+type Tambara :: FLAVOR j k -> j +-> k -> j +-> k+data Tambara w r a b where+  Tambara+    :: forall {j} {k} (w :: FLAVOR j k) (r :: j +-> k) a b+     . (Ob a, Ob b)+    => (forall (p :: k +-> k) (q :: j +-> j). (w p q, Profunctor p, Profunctor q) => (q |> r <| p) a b)+    -> Tambara w r a b++mkTambara+  :: (Ob a, Ob b)+  => (forall (p :: k +-> k) (q :: j +-> j) x y. (w p q, Profunctor p, Profunctor q) => p x a -> q b y -> r x y)+  -> Tambara w r a b+mkTambara f = Tambara (Rift \p -> p // Ran \q -> f p q)++runTambara :: (w p q, Profunctor p, Profunctor q) => ((Ob a) => p x a) -> ((Ob b) => q b y) -> Tambara w r a b -> r x y+runTambara p q (Tambara qrp) = runRan q $ runRift p qrp++tambara :: forall {j} {k} w (p :: j +-> k). (Prostrong w p) => p :~> Tambara w p+tambara r = mkTambara (\p q -> proact @w (p :.: r :.: q)) \\ r++untambara+  :: forall {j} {k} w (p :: j +-> k). (Profunctor p, Flavor w) => Tambara w p :~> p+untambara = runTambara @w @Id @Id (Id id) (Id id)++instance (Profunctor p) => Profunctor (Tambara w p :: j +-> k) where+  dimap l r (Tambara n) = Tambara (dimap l r n) \\ l \\ r+  r \\ Tambara{} = r++instance (Flavor w, Profunctor p) => Prostrong w (Tambara w p :: j +-> k) where+  proact (p :.: n :.: q) = mkTambara (\p' q' -> runTambara (p' :.: p) (q :.: q') n) \\ p \\ q++instance (Flavor w) => HasCofree (Prostrong w :: OB (j +-> k)) where+  type Cofree (Prostrong w) p = Tambara w p+  lower = Prof untambara+  unfoldMap n = map n . Prof tambara++instance Functor (Tambara w :: (j +-> k) -> (j +-> k)) where+  map (Prof n) = Prof \t -> t // mkTambara \p q -> n (runTambara p q t)+instance (Flavor w) => Promonad (Costar (Tambara w) :: (j +-> k) +-> (j +-> k)) where+  id = Costar (Prof untambara)+  Costar n . Costar m = Costar (cofreeComp @(Prostrong w) n m)++-- | @Pastro t@ ⊣ @Tambara t@+instance Corepresentable (Star (Tambara w) :: (j +-> k) +-> (j +-> k)) where+  type Star (Tambara w) %% p = Pastro w p+  coindex (Star (Prof n)) = Prof \(Pastro @p @q (p :.: r :.: q)) -> case n r of m -> runTambara @w @p @q p q m+  corepUniv = Star (Prof \r -> r // mkTambara \p q -> Pastro (p :.: r :.: q))
+ src/Proarrow/Profunctor/Instance/Product.hs view
@@ -0,0 +1,35 @@+-- | The pointwise product of two profunctors: a @(p ':*:' q) a b@ is a pair of a @p a b@ and a @q a b@.+module Proarrow.Profunctor.Instance.Product where++import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Proarrow.Category.Enriched.Thin (ThinProfunctor (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Monoidal (MonoidalProfunctor (..))+import Proarrow.Core (Profunctor (..), (:~>), type (+->))+import Proarrow.Functor (Functor (..))++type (:*:) :: (j +-> k) -> (j +-> k) -> (j +-> k)+data (p :*: q) a b where+  (:*:) :: {fstP :: p a b, sndP :: q a b} -> (p :*: q) a b++prod :: (r :~> p) -> (r :~> q) -> r :~> p :*: q+prod l r p = l p :*: r p++instance (Profunctor p, Profunctor q) => Profunctor (p :*: q) where+  dimap l r (p :*: q) = dimap l r p :*: dimap l r q+  r \\ (p :*: _) = r \\ p++instance (MonoidalProfunctor p, MonoidalProfunctor q) => MonoidalProfunctor (p :*: q) where+  one = one :*: one+  (p1 :*: p2) ** (q1 :*: q2) = (p1 ** q1) :*: (p2 ** q2)++instance (DaggerProfunctor p, DaggerProfunctor q) => DaggerProfunctor (p :*: q) where+  dagger (p :*: q) = dagger p :*: dagger q++instance (ThinProfunctor p, ThinProfunctor q) => ThinProfunctor (p :*: q) where+  type HasArrow (p :*: q) a b = (HasArrow p a b, HasArrow q a b)+  arr = arr :*: arr+  withArr (p :*: q) r = withArr p (withArr q r)++instance (Profunctor p) => Functor ((:*:) p) where+  map (Prof n) = Prof \(p :*: q) -> p :*: n q
+ src/Proarrow/Profunctor/Instance/Ran.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The right Kan extension of a profunctor @p@ along @j@, written @j '|>' p@: the universal @g@ with+-- @g ':.:' j ~> p@. 'Ran' and 'Proarrow.Profunctor.Instance.Rift.Rift' are swapped compared to the+-- @profunctors@ package.+module Proarrow.Profunctor.Instance.Ran where++import Prelude (type (~))++import Proarrow.Category.Instance.Nat (Nat (..))+import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), lmap, rmap, (//), type (+->))+import Proarrow.Functor (Functor (..), FunctorForRep)+import Proarrow.Limit (HasLimits (..))+import Proarrow.Profunctor.Corepresentable (Corep (..), Corepresentable (..), corepUniv, withObCorep)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Star (Star, pattern Star)+import Proarrow.Profunctor.Representable (CorepStar, Rep (..), Representable (..), repUniv, withObRep)+import Proarrow.Promonad (Procomonad (..), RelativeMonad (..))++type j |> p = Ran (OP j) p++-- | The data type behind @j '|>' p@. Its universal property is 'ranUniv' and 'runRanProf'.+type Ran :: OPPOSITE (i +-> j) -> i +-> k -> j +-> k+data Ran j p a b where+  Ran :: (Ob a, Ob b) => {unRan :: forall x. j b x -> p a x} -> Ran (OP j) p a b++runRan :: (Profunctor j) => j b x -> Ran (OP j) p a b -> p a x+runRan j (Ran k) = k j \\ j++runRanProf :: (Profunctor j, Profunctor p) => (j |> p) :.: j ~> p+runRanProf = Prof \(r :.: j) -> runRan j r++ranUniv :: (Profunctor j, Profunctor g) => (g :.: j) ~> p -> g ~> j |> p+ranUniv (Prof n) = Prof \g -> g // Ran \j -> n (g :.: j)++flipRan :: (FunctorForRep j, Profunctor p) => Corep j |> p ~> p :.: Rep j+flipRan = Prof \(Ran k) -> k corepUniv :.: repUniv++flipRanInv :: (FunctorForRep j, Profunctor p) => p :.: Rep j ~> Corep j |> p+flipRanInv = Prof \(p :.: f) -> p // f // Ran \g -> rmap (coindex g . index f) p++instance (Profunctor p, Profunctor j) => Profunctor (Ran (OP j) p) where+  dimap l r (Ran k) = l // r // Ran (lmap l . k . lmap r)+  r \\ Ran{} = r++instance (Profunctor j) => Functor (Ran (OP j)) where+  map (Prof n) = Prof \(Ran k) -> Ran (n . k)++instance Functor Ran where+  map (Op (Prof n)) = Nat (Prof \(Ran k) -> Ran (k . n))++instance (p ~ j, Profunctor p) => Promonad (Ran (OP j) p) where+  id = Ran id+  Ran l . Ran r = Ran (r . l)++instance (HasLimits j k, Representable d) => Representable (Ran (OP j) (d :: i +-> k)) where+  type Ran (OP j) d % a = Limit j d % a+  index = index @(Limit j d) . limitUniv @j @k @d (\(Ran k' :.: j) -> k' j)+  repUniv @a = withObRep @(Limit j d) @a (Ran \j -> limit (repUniv :.: j))++type PWRan j p a = (j |> p) % a++-- a ~> PWRan j p b = forall x. (b ~> j x) -> a ~> p x+-- a ~> PWRan j p b = forall x. a ~> (p x ^ (b ~> j x))+-- PWRan j p b = forall x. p x ^ (b ~> j x)+class (Representable p, Representable j, Representable (j |> p)) => PointwiseRightKanExtension j p+instance (Representable p, Representable j, Representable (j |> p)) => PointwiseRightKanExtension j p++type PWLift j p a = (j |> p) %% a++-- PWLift j p a ~> b = forall x. (j b ~> x) -> p a ~> x+-- PWLift j p a ~> b = p a ~> j b+class (Corepresentable j, Corepresentable p, Corepresentable (j |> p)) => PointwiseLeftKanLift j p+instance (Corepresentable j, Corepresentable p, Corepresentable (j |> p)) => PointwiseLeftKanLift j p++instance (Corepresentable g, Corepresentable f, Profunctor j, f ~ g |> j) => RelativeMonad j (CorepStar g :.: CorepStar f) where+  relReturn @a = let f = corepUniv @f @a in runRan (corepUniv @g) f \\ f+  relBind @b @a j = withObCorep @f @b (corepMap @g @(f %% a) @(f %% b) (coindex @f @a (Ran (\g -> rmap (coindex g) j)))) \\ j++-- | The right Kan extension is the right adjoint of the precomposition functor.+instance (Profunctor j) => Corepresentable (Star (Ran (OP j))) where+  type Star (Ran (OP j)) %% p = p :.: j+  coindex (Star (Prof n)) = Prof \(p :.: j) -> runRan j (n p)+  cotabulate (Prof n) = Star (Prof \p -> p // Ran \q -> n (p :.: q))+  corepMap f = unNat (map f)++ranCompose :: (Profunctor i, Profunctor j, Profunctor p) => i |> (j |> p) ~> (i :.: j) |> p+ranCompose = Prof \k -> k // Ran \(i :.: j) -> runRan j (runRan i k)++ranComposeInv :: (Profunctor i, Profunctor j, Profunctor p) => (i :.: j) |> p ~> i |> (j |> p)+ranComposeInv = Prof \k -> k // Ran \i -> i // Ran \j -> runRan (i :.: j) k++ranHom :: (Profunctor p) => p ~> (~>) |> p+ranHom = Prof \p -> p // Ran (`rmap` p)++ranHomInv :: (Profunctor p) => (~>) |> p ~> p+ranHomInv = Prof \(Ran k) -> k id++compAsRan :: (Promonad p, Ob a) => (p |> (p |> p)) a a+compAsRan = Ran \p -> p // Ran (. p)++instance (Procomonad j) => Promonad (Star (Ran (OP j))) where+  id = Star (unNat (map (Op (Prof proextract))) . ranHom)+  Star l . Star r = Star (unNat (map (Op (Prof produplicate))) . ranCompose . map l . r)
+ src/Proarrow/Profunctor/Instance/Rift.hs view
@@ -0,0 +1,106 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The right Kan lift of a profunctor @p@ along @j@, written @p '<|' j@: the universal @g@ with+-- @j ':.:' g ~> p@. 'Proarrow.Profunctor.Instance.Ran.Ran' and 'Rift' are swapped compared to the+-- @profunctors@ package.+module Proarrow.Profunctor.Instance.Rift where++import Prelude (type (~))++import Proarrow.Category.Instance.Nat (Nat (..))+import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Colimit (HasColimits (..))+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), lmap, rmap, (//), type (+->))+import Proarrow.Functor (Functor (..), FunctorForRep)+import Proarrow.Profunctor.Corepresentable (Corep (..), Corepresentable (..), corepUniv, withObCorep)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Star (Star, pattern Star)+import Proarrow.Profunctor.Representable (Rep (..), RepCostar, Representable (..), repUniv, withObRep)+import Proarrow.Promonad (Procomonad (..), RelativeComonad (..))++type p <| j = Rift (OP j) p++-- | The data type behind @p '<|' j@. Its universal property is 'riftUniv' and 'runRiftProf'.+type Rift :: OPPOSITE (k +-> i) -> j +-> i -> j +-> k+data Rift j p a b where+  Rift :: (Ob a, Ob b) => {unRift :: forall x. j x a -> p x b} -> Rift (OP j) p a b++runRift :: (Profunctor j) => j x a -> Rift (OP j) p a b -> p x b+runRift j (Rift k) = k j \\ j++runRiftProf :: (Profunctor j, Profunctor p) => j :.: (p <| j) ~> p+runRiftProf = Prof \(j :.: r) -> runRift j r++riftUniv :: (Profunctor j, Profunctor g) => (j :.: g) ~> p -> g ~> p <| j+riftUniv (Prof n) = Prof \g -> g // Rift \j -> n (j :.: g)++flipRift :: (FunctorForRep j, Profunctor p) => p <| Rep j ~> Corep j :.: p+flipRift = Prof \(Rift k) -> corepUniv :.: k repUniv++flipRiftInv :: (FunctorForRep j, Profunctor p) => Corep j :.: p ~> p <| Rep j+flipRiftInv = Prof \(g :.: p) -> g // p // Rift \f -> lmap (coindex g . index f) p++instance (Profunctor p, Profunctor j) => Profunctor (Rift (OP j) p) where+  dimap l r (Rift k) = r // l // Rift (rmap r . k . rmap l)+  r \\ Rift{} = r++instance (Profunctor j) => Functor (Rift (OP j)) where+  map (Prof n) = Prof \(Rift k) -> Rift (n . k)++instance Functor Rift where+  map (Op (Prof n)) = Nat (Prof \(Rift k) -> Rift (k . n))++-- | The right Kan lift is the right adjoint of the postcomposition functor.+instance (Profunctor j) => Corepresentable (Star (Rift (OP j))) where+  type Star (Rift (OP j)) %% p = j :.: p+  coindex (Star (Prof f)) = Prof \(j :.: p) -> runRift j (f p)+  cotabulate (Prof f) = Star (Prof \p -> p // Rift \q -> f (q :.: p))+  corepMap = map++instance (p ~ j, Profunctor p) => Promonad (Rift (OP j) p) where+  id = Rift id+  Rift l . Rift r = Rift (l . r)++instance (HasColimits j k, Corepresentable d) => Corepresentable (Rift (OP j) (d :: k +-> i)) where+  type Rift (OP j) d %% a = Colimit j d %% a+  coindex = coindex @(Colimit j d) . colimitUniv @j @k @d (\(j :.: Rift k') -> k' j)+  corepUniv @a = withObCorep @(Colimit j d) @a (Rift \j -> colimit (j :.: corepUniv))++type PWLan j p a = (p <| j) %% a++-- PWLan j p a ~> b = forall x. j x ~> a -> p x ~> b+-- PWLan j p a ~> b = forall x. ((j x ~> a) .* p x) ~> b+-- PWLan j p a = exists x. ((j x ~> a) .* p x)+class (Corepresentable j, Corepresentable p, Corepresentable (p <| j)) => PointwiseLeftKanExtension j p+instance (Corepresentable j, Corepresentable p, Corepresentable (p <| j)) => PointwiseLeftKanExtension j p++type PWRift j p a = (p <| j) % a++-- a ~> PWRift j p b = forall x. x ~> j a -> x ~> p b+-- a ~> PWRift j p b = j a ~> p b+class (Representable p, Representable j, Representable (p <| j)) => PointwiseRightKanLift j p+instance (Representable p, Representable j, Representable (p <| j)) => PointwiseRightKanLift j p++instance (Representable g, Representable f, Profunctor j, f ~ j <| g) => RelativeComonad j (RepCostar f :.: RepCostar g) where+  relExtract @a = let f = repUniv @f @a in runRift (repUniv @g) f \\ f+  relExtend @a @b j = withObRep @f @a (repMap @g @(f % a) @(f % b) (index @f @_ @b (Rift (\g -> lmap (index g) j)))) \\ j++riftCompose :: (Profunctor i, Profunctor j, Profunctor p) => (p <| j) <| i ~> p <| (j :.: i)+riftCompose = Prof \k -> k // Rift \(j :.: i) -> runRift j (runRift i k)++riftComposeInv :: (Profunctor i, Profunctor j, Profunctor p) => p <| (j :.: i) ~> (p <| j) <| i+riftComposeInv = Prof \k -> k // Rift \i -> i // Rift \j -> runRift (j :.: i) k++riftHom :: (Profunctor p) => p ~> p <| (~>)+riftHom = Prof \p -> p // Rift (`lmap` p)++riftHomInv :: (Profunctor p) => p <| (~>) ~> p+riftHomInv = Prof \(Rift k) -> k id++compAsRift :: (Promonad p, Ob a) => ((p <| p) <| p) a a+compAsRift = Rift \p -> p // Rift (p .)++instance (Procomonad j) => Promonad (Star (Rift (OP j))) where+  id = Star (unNat (map (Op (Prof proextract))) . riftHom)+  Star l . Star r = Star (unNat (map (Op (Prof produplicate))) . riftCompose . map l . r)
+ src/Proarrow/Profunctor/Instance/Sieve.hs view
@@ -0,0 +1,43 @@+-- | __Sieves__: a @'Sieve' a b@ is a set of pairs @(g :: c '~>' a, h :: b '~>' d)@, given as a+-- predicate, that is closed under composing on the outside: if @(g, h)@ is in, so is+-- @(g '.' l, r '.' h)@ for any @l@ and @r@. With @b@ ignored this is the textbook sieve on @a@, a+-- set of arrows into @a@ closed under precomposition.+--+-- __The constructor does not check this closure.__ @toIndex@ of+-- 'Proarrow.Category.Enriched.Finitary.Finitary' (failing with @\"not a sieve\"@) and+-- 'Proarrow.Category.Enriched.Finitary.Topos.withSubobject' check it. Others presuppose it, e.g.+-- 'Proarrow.Category.Enriched.Finitary.Sheaf.coveringCover' judges a sieve by a cover's legs, so+-- on a non-sieve the two kinds of function disagree. A hand-built 'Sieve' must be closed.+--+-- Sieves are the subobjects of the representable at @a@\/@b@, so they are the truth values of a+-- category of profunctors: "Proarrow.Category.Enriched.Finitary.Topos" makes them the+-- 'Proarrow.Category.Topos.HasSubobjectClassifier' of the finitary ones.+module Proarrow.Profunctor.Instance.Sieve where++import Prelude (Bool (..), (&&))++import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), (//), type (+->))++type Sieve :: forall {j} {k}. j +-> k+data Sieve a b where+  Sieve :: (Ob a, Ob b) => (forall c d. c ~> a -> b ~> d -> Bool) -> Sieve a b++instance (CategoryOf j, CategoryOf k) => Profunctor (Sieve :: j +-> k) where+  dimap l r (Sieve s) = l // r // Sieve \g h -> s (l . g) (h . r)+  r \\ Sieve{} = r++-- | The sieve that contains every arrow. 'Sieve' is the /object/ of truth values of a category of+-- profunctors, and this is its value @yes@, so it is the 'Proarrow.Category.Topos.true' of their+-- subobject classifier. A sieve is called /dense/ for a coverage when its closure is this one (see+-- 'Proarrow.Category.Enriched.Finitary.Sheaf.closure').+maximalSieve :: forall {j} {k} (a :: k) (b :: j). (CategoryOf j, CategoryOf k, Ob a, Ob b) => Sieve a b+maximalSieve = Sieve \_ _ -> True++-- | The sieve of arrows in both: the @and@ of the truth values the two stand for. This is+-- 'Proarrow.Category.Topos.and' at the classifier of+-- "Proarrow.Category.Enriched.Finitary.Topos", computed directly instead of as an arrow. Being+-- closed under composition is pointwise, so the meet of two sieves is again one.+-- 'Proarrow.Category.Enriched.Finitary.Sheaf.Plus' is computed on the meet of all the /dense/+-- sieves at a pair of objects.+sieveMeet :: Sieve a b -> Sieve a b -> Sieve a b+sieveMeet (Sieve s) (Sieve s') = Sieve \g h -> s g h && s' g h
+ src/Proarrow/Profunctor/Instance/Star.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | 'Star' embeds a functor @f@ as a profunctor with the functor on the target side:+-- @Star f a b = a ~> f b@. It is the representable profunctor of @f@; for a Haskell monad @m@,+-- @Star (Prelude m)@ is its Kleisli promonad.+module Proarrow.Profunctor.Instance.Star where++import Control.Monad qualified as P+import Data.Functor.Compose (Compose (..))+import Data.Kind (Type)+import Prelude qualified as P++import Proarrow.Category.Enriched.Thin (DecidableProfunctor (..), Thin, ThinProfunctor (..), mapDecision)+import Proarrow.Category.Instance.Nat (ApplyAction, Nat' (..), type (.->) (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), Tensor)+import Proarrow.Category.Monoidal.Action (CoprodAction, ProdAction, SubAction)+import Proarrow.Category.Monoidal.Applicative (Alternative (..), Applicative (..))+import Proarrow.Category.Monoidal.Distributive (Distributive, Traversable (..), baseTraverse)+import Proarrow.Category.Monoidal.Strength (Strong (..))+import Proarrow.Colimit.BinaryCoproduct (COPROD (..), Coprod (..), HasBinaryCoproducts (..), HasCoproducts, (++))+import Proarrow.Colimit.Initial (initiate)+import Proarrow.Core (CategoryOf (..), Hom, Profunctor (..), Promonad (..), lmap, obj, (:~>), type (+->))+import Proarrow.Functor (Functor (..), Prelude (..), withObF)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Coproduct ((:+:) (..))+import Proarrow.Profunctor.Representable (Representable (..), dimapRep)++type Star' :: j .-> k -> j +-> k+data Star' f a b where+  Star' :: (Ob b) => {unStar :: a ~> f b} -> Star' (NT f) a b++type Star f = Star' (NT f)+pattern Star :: () => (Ob b) => (a ~> f b) -> Star f a b+pattern Star f = Star' f+{-# COMPLETE Star #-}++instance (Functor f) => Profunctor (Star f) where+  dimap = dimapRep+  r \\ Star f = r \\ f++instance (CategoryOf j, CategoryOf k) => Functor (Star' :: (j .-> k) -> j +-> k) where+  map (Nat' n) = Prof \(Star f) -> Star (n . f)++instance (Functor f) => Representable (Star f) where+  type Star f % a = f a+  index = unStar+  tabulate = Star+  repMap = map++instance (Profunctor p) => Promonad (Star ((:+:) p)) where+  id = Star (Prof InjR)+  Star (Prof l) . Star (Prof r) = Star (Prof (\a -> case r a of InjL p -> InjL p; InjR b -> l b))++instance (P.Monad m) => Promonad (Star (Prelude m)) where+  id = Star (Prelude . P.pure)+  Star g . Star f = Star \a -> Prelude (unPrelude (f a) P.>>= (unPrelude . g))++composeStar :: (Functor f) => Star f :.: Star g :~> Star (Compose f g)+composeStar (Star f :.: Star g) = Star (Compose . map g . f)++instance (Applicative f, Monoidal j, Monoidal k) => MonoidalProfunctor (Star (f :: j -> k)) where+  one = Star (pure id)+  Star @a f ** Star @b g = withOb2 @_ @a @b (Star (liftA2 @f @a @b id . (f ** g)))++instance (Functor f, HasCoproducts j, HasCoproducts k) => MonoidalProfunctor (Coprod (Star (f :: j -> k))) where+  one = Coprod (Star initiate)+  Coprod (Star @a f) ** Coprod (Star @b g) = withObCoprod @_ @a @b (Coprod (Star (map (lft @_ @a @b) . f ||| map (rgt @_ @a @b) . g)))++-- Hmm, another wrapper required...++-- | Wraps the domain of @p@ in 'COPROD', letting 'Star' of an 'Alternative' functor be monoidal+-- over coproducts.+type CoprodDom :: j +-> k -> COPROD j +-> k+data CoprodDom p a b where+  Co :: {unCo :: p a b} -> CoprodDom p a (COPR b)++instance (Profunctor p) => Profunctor (CoprodDom p) where+  dimap l (Coprod r) (Co p) = Co (dimap l r p)+  r \\ Co p = r \\ p++instance (Alternative f, Monoidal k, Distributive j) => MonoidalProfunctor (CoprodDom (Star (f :: j -> k))) where+  one = Co (Star empty)+  Co (Star @a f) ** Co (Star @b g) = let ab = obj @a +++ obj @b in Co (Star (alt @f @a @b ab . (f ** g))) \\ ab++instance (P.Functor f) => Strong ProdAction (Star (Prelude f)) where+  act (Star k) = Star (\(a, x) -> P.fmap (a,) (k x))++instance (Functor f) => Strong Tensor (Star (f :: Type -> Type)) where+  act (Star k) = Star (\(a, x) -> map (a,) (k x))+instance (Applicative f) => Strong CoprodAction (Star (f :: Type -> Type)) where+  act (Star k) = Star (f ||| map P.Right . k)+    where+      f a = pure (\() -> P.Left a) ()++instance (P.Applicative f) => Strong (SubAction P.Traversable ApplyAction) (Star (Prelude f)) where+  act (Star f) = Star (P.traverse f)++instance Traversable (Star P.Maybe) where+  traverse (Star a2mb :.: p) = lmap a2mb go :.: Star id+    where+      go =+        dimap+          (P.maybe (P.Left ()) P.Right)+          (P.const P.Nothing ||| P.Just)+          (one ++ p)++instance Traversable (Star []) where+  traverse (Star a2bs :.: p) = lmap a2bs go :.: Star id+    where+      go =+        dimap+          (\case [] -> P.Left (); (x : xs) -> P.Right (x, xs))+          (P.const [] ||| P.uncurry (:))+          (one ++ (p ** go))++-- | The list monad without the 'Prelude' wrapper, so that a Kleisli arrow of @[]@ reads as the+-- plain @a -> [b]@.+instance Promonad (Star []) where+  id = Star P.return+  Star l . Star r = Star (l P.<=< r)++starTraverse+  :: forall t f a b+   . ( Applicative (f :: Type -> Type)+     , Functor t+     , Traversable (Star t)+     , Ob b+     )+  => (a ~> f b) -> t a ~> f (t b)+starTraverse = baseTraverse @(Star t) @(Star f)++instance (Functor f, Thin k) => ThinProfunctor (Star f :: j +-> k) where+  type HasArrow (Star f :: j +-> k) a b = HasArrow (Hom k) a (f b)+  arr = Star arr+  withArr (Star f) r = withArr f r++instance (Functor f, DecidableProfunctor (Hom k)) => DecidableProfunctor (Star f :: j +-> k) where+  type Holds (Star f :: j +-> k) a b = Holds (Hom k) a (f b)+  decide @a @b = withObF @f @b (mapDecision Star (decide @(Hom k) @a @(f b)))+  toHolds (Star f) r = toHolds f r
+ src/Proarrow/Profunctor/Instance/Terminal.hs view
@@ -0,0 +1,44 @@+-- | The terminal profunctor, with exactly one value between any two objects: the terminal object of the+-- category of profunctors @j +-> k@.+module Proarrow.Profunctor.Instance.Terminal (TerminalProfunctor (.., TerminalProfunctor)) where++import Proarrow.Category.Enriched.Dagger (Dagger, DaggerProfunctor (..))+import Proarrow.Category.Enriched.Thin (DecidableProfunctor (..), Decision (..), ThinProfunctor (..))+import Proarrow.Category.Instance.Bool (BOOL (..))+import Proarrow.Category.Monoidal (Monoidal, MonoidalProfunctor (..))+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), type (+->))+import Proarrow.Object (pattern Obj, type Obj)++-- | The profunctor with exactly one value between any two objects: the terminal object of the+-- category of profunctors @j +-> k@.+type TerminalProfunctor :: j +-> k+data TerminalProfunctor a b where+  TerminalProfunctor' :: Obj a -> Obj b -> TerminalProfunctor (a :: j) (b :: k)++instance (CategoryOf j, CategoryOf k) => Profunctor (TerminalProfunctor :: j +-> k) where+  dimap l r TerminalProfunctor = TerminalProfunctor \\ l \\ r+  r \\ TerminalProfunctor = r++instance (CategoryOf k) => Promonad (TerminalProfunctor :: k +-> k) where+  id = TerminalProfunctor+  TerminalProfunctor . TerminalProfunctor = TerminalProfunctor++instance (Monoidal j, Monoidal k) => MonoidalProfunctor (TerminalProfunctor :: j +-> k) where+  one = TerminalProfunctor' one one+  TerminalProfunctor' a1 b1 ** TerminalProfunctor' a2 b2 = TerminalProfunctor' (a1 ** a2) (b1 ** b2)++instance (Dagger k) => DaggerProfunctor (TerminalProfunctor :: k +-> k) where+  dagger TerminalProfunctor = TerminalProfunctor++pattern TerminalProfunctor+  :: forall {j} {k} a b. (CategoryOf j, CategoryOf k) => (Ob (a :: j), Ob (b :: k)) => TerminalProfunctor a b+pattern TerminalProfunctor = TerminalProfunctor' Obj Obj++{-# COMPLETE TerminalProfunctor #-}++instance (CategoryOf j, CategoryOf k) => ThinProfunctor (TerminalProfunctor :: j +-> k)++instance (CategoryOf j, CategoryOf k) => DecidableProfunctor (TerminalProfunctor :: j +-> k) where+  type Holds TerminalProfunctor a b = TRU+  decide = Yes TerminalProfunctor+  toHolds TerminalProfunctor r = r
+ src/Proarrow/Profunctor/Instance/Wrapped.hs view
@@ -0,0 +1,29 @@+-- | The 'Wrapped' newtype makes the values @p c m@ of a monoidal profunctor into 'Monoid's, for a comonoid+-- @c@ and a monoid @m@.+module Proarrow.Profunctor.Instance.Wrapped where++import Prelude qualified as P++import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Proarrow.Category.Monoidal (MonoidalProfunctor (..))+import Proarrow.Core (Profunctor (..), Promonad (..))+import Proarrow.Monoid (Comonoid (..), Monoid)+import Proarrow.Monoid qualified as M+import Proarrow.Optic (PIso, iso)+import Proarrow.Profunctor.Corepresentable (Corepresentable (..))+import Proarrow.Profunctor.Representable (Representable (..))++newtype Wrapped p a b = Wrapped {unWrapped :: p a b}+  deriving newtype (Profunctor, Promonad, MonoidalProfunctor, DaggerProfunctor, Representable, Corepresentable)++-- | Given as 'P.Semigroup'\/'P.Monoid' rather than as 'Proarrow.Monoid.Monoid' directly: at kind+-- @Type@ the latter comes from the blanket @'P.Monoid' m => 'Proarrow.Monoid.Monoid' (m :: Type)@+-- instance, so defining it here too would make every use overlap and solve to neither.+instance (Comonoid c, Monoid m, MonoidalProfunctor p) => P.Semigroup (Wrapped p c m) where+  l <> r = dimap comult M.mappend (l ** r)++instance (Comonoid c, Monoid m, MonoidalProfunctor p) => P.Monoid (Wrapped p c m) where+  mempty = dimap counit M.mempty one++wrapped :: PIso (p a b) (p a' b') (Wrapped p a b) (Wrapped p a' b')+wrapped = iso Wrapped unWrapped
+ src/Proarrow/Profunctor/Instance/Yoneda.hs view
@@ -0,0 +1,82 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The Yoneda construction: @'Yoneda' p@ is the cofree profunctor on an arbitrary type of kind+-- @j +-> k@ (the 'HasCofree' instance for 'Profunctor'), and 'Yo' is the Yoneda embedding. By the+-- Yoneda lemma @Yoneda p@ is equivalent to @p@ when @p@ is already a profunctor+-- ('yoneda'\/'mkYoneda').+module Proarrow.Profunctor.Instance.Yoneda where++import Data.Function (($))+import Prelude ((*))++import Proarrow.Category.Enriched.Finitary (Finitary (..), FiniteCat, pairIndex, unpairIndex)+import Proarrow.Category.Instance.Nat (Nat (..))+import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))+import Proarrow.Category.Instance.Prof (Prof (Prof))+import Proarrow.Core (CategoryOf (..), Hom, Profunctor (..), Promonad (..), (//), (:~>), type (+->))+import Proarrow.Functor (Functor (..))+import Proarrow.Profunctor.Cofree (HasCofree (..))+import Proarrow.Profunctor.Instance.Costar (Costar, pattern Costar)+import Proarrow.Profunctor.Instance.Star (Star, pattern Star)++-- | The cofree profunctor on @p@ (the 'HasCofree' instance for 'Profunctor'): natural+-- transformations out of the Yoneda embedding 'Yo'. Equivalent to @p@ when @p@ is already a+-- profunctor ('yoneda'\/'mkYoneda').+type Yoneda :: (j +-> k) -> j +-> k+data Yoneda p a b where+  Yoneda :: (Ob a, Ob b) => {unYoneda :: Yo a (OP b) :~> p} -> Yoneda p a b++instance (CategoryOf j, CategoryOf k) => Profunctor (Yoneda (p :: j +-> k)) where+  dimap l r (Yoneda k) = l // r // Yoneda \(Yo ca bd) -> k $ Yo (l . ca) (bd . r)+  r \\ Yoneda{} = r++instance Functor Yoneda where+  map (Prof n) = Prof \(Yoneda k) -> Yoneda (n . k)++instance Promonad (Star Yoneda) where+  id = Star (Prof mkYoneda)+  Star (Prof l) . Star (Prof r) = Star (Prof (l . yoneda . r))++instance Promonad (Costar Yoneda) where+  id = Costar (Prof yoneda)+  Costar (Prof l) . Costar (Prof r) = Costar (Prof (l . mkYoneda . r))++instance HasCofree Profunctor where+  type Cofree Profunctor p = Yoneda p+  lower = Prof yoneda+  unfoldMap (Prof n) = Prof (mkYoneda . n)++yoneda :: (CategoryOf j, CategoryOf k) => Yoneda (p :: j +-> k) :~> p+yoneda (Yoneda k) = k $ Yo id id++mkYoneda :: (Profunctor p) => p :~> Yoneda p+mkYoneda p = p // Yoneda \(Yo ca bd) -> dimap ca bd p++-- | Yoneda embedding+type Yo :: k -> OPPOSITE j -> j +-> k+data Yo a b c d where+  Yo :: c ~> a -> b ~> d -> Yo a (OP b) c d++instance (CategoryOf j, CategoryOf k) => Profunctor (Yo (a :: k) (OP b :: OPPOSITE j) :: j +-> k) where+  dimap l r (Yo f g) = Yo (f . l) (r . g)+  r \\ Yo f g = r \\ f \\ g++-- | The embedding is finitary when the arrows are: its elements over @c@\/@d@ are an arrow @c ~> a@+-- paired with an arrow @b ~> d@, numbered with the first varying slowest. This is the weight of the+-- ends in "Proarrow.Category.Enriched.Finitary.Topos", so it shares that module\'s+-- 'pairIndex' instead of spelling the radix out again.+instance (FiniteCat j, FiniteCat k, Ob a, Ob b) => Finitary (Yo (a :: k) (OP (b :: j)) :: j +-> k) where+  size @c @d = size @(Hom k) @c @a * size @(Hom j) @b @d+  toIndex @c @d (Yo ca bd) = pairIndex (size @(Hom j) @b @d) (toIndex @(Hom k) @c @a ca) (toIndex @(Hom j) @b @d bd)+  fromIndex @c @d i =+    let (l, r) = unpairIndex (size @(Hom j) @b @d) i+    in Yo (fromIndex @(Hom k) @c @a l) (fromIndex @(Hom j) @b @d r)++  -- spelled out for the same reason as the product's: the default would ask for a size per element+  elements @c @d = [Yo ca bd | ca <- elements @(Hom k) @c @a, bd <- elements @(Hom j) @b @d]++instance (CategoryOf j, CategoryOf k) => Functor (Yo (a :: k) :: OPPOSITE j -> j +-> k) where+  map (Op f) = Prof \(Yo ca bd) -> Yo ca (bd . f)++instance (CategoryOf j, CategoryOf k) => Functor (Yo :: k -> OPPOSITE j -> j +-> k) where+  map f = Nat (Prof \(Yo ca bd) -> Yo (f . ca) bd)
+ src/Proarrow/Profunctor/Representable.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Representable profunctors: profunctors of the shape /functor followed by hom/, identifying @p a b@+-- with @a ~> p % b@. Since a functor between different kinds cannot be written directly as a Haskell data+-- type, representable profunctors (with their functorial action '%') are how this library encodes such+-- functors; 'Rep' packages any 'Proarrow.Functor.FunctorForRep' as its representable profunctor.+module Proarrow.Profunctor.Representable where++import Data.Kind (Constraint)++import Proarrow.Category.Enriched.Thin (DecidableProfunctor (..), Thin, ThinProfunctor (..), mapDecision)+import Proarrow.Category.Instance.Bool (Booleans (..))+import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Instance.Unit ()+import Proarrow.Core (CategoryOf (..), Hom, Profunctor (..), Promonad (..), lmap, rmap, (:~>), type (+->))+import Proarrow.Functor (FunctorForRep (..), Presheaf, withMappedOb)+import Proarrow.Object (Obj, obj, src, tgt)+import Proarrow.Optic (PIso, iso)+import Proarrow.Profunctor.Corepresentable (Corep (..), Corepresentable (..), corepUniv, dimapCorep, withObCorep)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))++infixl 8 %++-- | A profunctor is representable if @p ? a@ as a presheaf is representable in a functorial way over @a@.+type Representable :: forall {j} {k}. j +-> k -> Constraint+class (Profunctor p) => Representable (p :: j +-> k) where+  type p % (a :: j) :: k+  index :: p a b -> a ~> p % b+  tabulate :: (Ob b) => (a ~> p % b) -> p a b+  tabulate f = lmap f repUniv+  repMap :: (a ~> b) -> p % a ~> p % b+  repMap @a f = index @p (rmap f (repUniv @p @a)) \\ f+  repUniv :: (Ob a) => p (p % a) a+  repUniv @a = tabulate (repObj @p @a)+  {-# MINIMAL index, ((tabulate, repMap) | repUniv) #-}++instance Representable (->) where+  type (->) % a = a+  index f = f+  tabulate f = f+  repMap f = f+  repUniv = id++instance Representable Booleans where+  type Booleans % x = x+  index = id+  tabulate = id+  repMap = id++instance (Representable p, Representable q) => Representable (p :**: q) where+  type (p :**: q) % '(a, b) = '(p % a, q % b)+  index (p :**: q) = index p :**: index q+  tabulate (f :**: g) = tabulate f :**: tabulate g+  repMap (f :**: g) = repMap @p f :**: repMap @q g+  repUniv = repUniv :**: repUniv++instance (CategoryOf k) => Representable (Id :: k +-> k) where+  type Id % a = a+  index = unId+  tabulate = Id+  repMap = id++instance (Representable p, Representable q) => Representable (p :.: q) where+  type (p :.: q) % a = p % (q % a)+  index (p :.: q) = repMap @p (index q) . index p+  tabulate :: forall a b. (Ob b) => (a ~> ((p :.: q) % b)) -> (:.:) p q a b+  tabulate f = withObRep @q @b (tabulate f :.: tabulate id)+  repMap f = repMap @p (repMap @q f)++repObj :: forall p a. (Representable p, Ob a) => Obj (p % a)+repObj = repMap @p (obj @a)++withObRep :: forall p a r. (Representable p, Ob a) => ((Ob (p % a)) => r) -> r+withObRep r = r \\ repObj @p @a++dimapRep :: forall p a b c d. (Representable p) => (c ~> a) -> (b ~> d) -> p a b -> p c d+dimapRep l r = tabulate @p . dimap l (repMap @p r) . index \\ r++tabulated :: forall p a a' b b'. (Representable p, Ob b) => PIso (a ~> p % b) (a' ~> p % b') (p a b) (p a' b')+tabulated = iso tabulate index++-- | A representable presheaf is a contravariant representable functor in the Haskell sense.+type RepresentablePresheaf (f :: Presheaf k) = Representable f++type Key (f :: Presheaf k) = f % '()+tabulatedPresheaf :: (RepresentablePresheaf f, Ob a) => PIso (a ~> Key f) (a' ~> Key f) (f a '()) (f a' '())+tabulatedPresheaf = tabulated++instance (Representable p) => Corepresentable (Op p) where+  type Op p %% OP a = OP (p % a)+  coindex (Op f) = Op (index f)+  cotabulate (Op f) = Op (tabulate f)+  corepMap (Op f) = Op (repMap @p f)+  corepUniv = Op repUniv++instance (Corepresentable p) => Representable (Op p) where+  type Op p % OP a = OP (p %% a)+  index (Op f) = Op (coindex f)+  tabulate (Op f) = Op (cotabulate f)+  repMap (Op f) = Op (corepMap @p f)+  repUniv = Op corepUniv++-- | The corepresenting functor of @p@ repackaged with the opposite variance: a value is an arrow+-- @a '~>' p '%%' b@, making @'CorepStar' p@ 'Representable'.+type CorepStar :: (k +-> j) -> (j +-> k)+data CorepStar p a b where+  CorepStar :: (Ob b) => {unCorepStar :: a ~> p %% b} -> CorepStar p a b++instance (Corepresentable p) => Profunctor (CorepStar p) where+  dimap = dimapRep+  r \\ CorepStar f = r \\ f+instance (Corepresentable p) => Representable (CorepStar p) where+  type CorepStar p % a = p %% a+  index (CorepStar f) = f+  tabulate = CorepStar+  repMap = corepMap @p++mapCorepStar :: (Corepresentable p, Corepresentable q) => p ~> q -> CorepStar q ~> CorepStar p+mapCorepStar (Prof n) = Prof \(CorepStar @a f) -> CorepStar (coindex (n (corepUniv @_ @a)) . f)++-- | The representing functor of @p@ repackaged with the opposite variance: a value is an arrow+-- @p '%' a '~>' b@, making @'RepCostar' p@ 'Corepresentable'.+type RepCostar :: (k +-> j) -> (j +-> k)+data RepCostar p a b where+  RepCostar :: (Ob a) => {unRepCostar :: p % a ~> b} -> RepCostar p a b++instance (Representable p) => Profunctor (RepCostar p) where+  dimap = dimapCorep+  r \\ RepCostar f = r \\ f+instance (Representable p) => Corepresentable (RepCostar p) where+  type RepCostar p %% a = p % a+  coindex (RepCostar f) = f+  cotabulate = RepCostar+  corepMap = repMap @p+instance (Representable p, Thin j) => ThinProfunctor (RepCostar p :: j +-> k) where+  type HasArrow (RepCostar p :: j +-> k) a b = HasArrow (Hom j) (p % a) b+  arr @a = withObRep @p @a (RepCostar arr)+  withArr (RepCostar f) r = withArr f r++instance (Representable p, DecidableProfunctor (Hom j)) => DecidableProfunctor (RepCostar p :: j +-> k) where+  type Holds (RepCostar p :: j +-> k) a b = Holds (Hom j) (p % a) b+  decide @a @b = withObRep @p @a (mapDecision RepCostar (decide @(Hom j) @(p % a) @b))+  toHolds (RepCostar f) r = toHolds f r++-- | @'CorepStar' p a b@ holds in a thin category exactly when @a ≤ p %% b@.+instance (Corepresentable p, Thin k) => ThinProfunctor (CorepStar p :: j +-> k) where+  type HasArrow (CorepStar p :: j +-> k) a b = HasArrow (Hom k) a (p %% b)+  arr @_ @b = withObCorep @p @b (CorepStar arr)+  withArr (CorepStar f) r = withArr f r++instance (Corepresentable p, DecidableProfunctor (Hom k)) => DecidableProfunctor (CorepStar p :: j +-> k) where+  type Holds (CorepStar p :: j +-> k) a b = Holds (Hom k) a (p %% b)+  decide @a @b = withObCorep @p @b (mapDecision CorepStar (decide @(Hom k) @a @(p %% b)))+  toHolds (CorepStar f) r = toHolds f r++mapRepCostar :: (Representable p, Representable q) => p ~> q -> RepCostar q ~> RepCostar p+mapRepCostar (Prof n) = Prof \(RepCostar @a f) -> RepCostar (f . index (n (repUniv @_ @a)))++flipRep :: forall p. (Representable p) => (~>) :~> p -> RepCostar p :~> (~>)+flipRep n p = coindex p . index (n (src p))++unflipRep :: forall p. (Representable p) => RepCostar p :~> (~>) -> (~>) :~> p+unflipRep n f = tabulate (n (RepCostar (repMap @p f))) \\ f++flipCorep :: forall p. (Corepresentable p) => (~>) :~> p -> CorepStar p :~> (~>)+flipCorep n p = coindex (n (tgt p)) . index p++unflipCorep :: forall p. (Corepresentable p) => CorepStar p :~> (~>) -> (~>) :~> p+unflipCorep n f = cotabulate (n (CorepStar (corepMap @p f))) \\ f++-- | The representable profunctor of a functor-for-representation @f@ ('FunctorForRep'): a value+-- @'Rep' f a b@ is an arrow @a '~>' f \@ b@. This is the profunctor encoding of+-- functors used throughout the library.+type Rep :: (j +-> k) -> j +-> k+data Rep f a b where+  Rep :: forall b f a. (Ob b) => {unRep :: a ~> f @ b} -> Rep f a b++instance (FunctorForRep f) => Profunctor (Rep f) where+  dimap = dimapRep+  r \\ Rep f = r \\ f+instance (FunctorForRep f) => Representable (Rep f) where+  type Rep f % a = f @ a+  index (Rep f) = f+  tabulate = Rep+  repMap = fmap @f+instance (FunctorForRep f, Thin k) => ThinProfunctor (Rep f :: j +-> k) where+  type HasArrow (Rep f :: j +-> k) a b = HasArrow (Hom k) a (f @ b)+  arr @_ @b = withMappedOb @f @b (Rep arr)+  withArr (Rep f) r = withArr f r++instance (FunctorForRep f, DecidableProfunctor (Hom k)) => DecidableProfunctor (Rep f :: j +-> k) where+  type Holds (Rep f :: j +-> k) a b = Holds (Hom k) a (f @ b)+  decide @a @b = withMappedOb @f @b (mapDecision Rep (decide @(Hom k) @a @(f @ b)))+  toHolds (Rep f) r = toHolds f r++rep :: forall f a b a' b'. (FunctorForRep f, Ob b) => PIso (a ~> f @ b) (a' ~> f @ b') (Rep f a b) (Rep f a' b')+rep = tabulated++instance (FunctorForRep f, Promonad (Corep f)) => Promonad (RepCostar (Rep f)) where+  id @b = RepCostar (unCorep (id @(Corep f) @b))+  RepCostar @a l . RepCostar @b r = RepCostar (unCorep (Corep @a @f l . Corep @b @f r))
+ src/Proarrow/Promonad.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- the identity laws compose with id on purpose+{- HLINT ignore "Redundant id" -}++-- | Promonads as effects: a 'Promonad' ("Proarrow.Core") that is 'Representable' is an ordinary 'Monad'+-- on objects ('return', 'bind'); a 'Promonad' that is 'Corepresentable' is a 'Comonad' ('extract',+-- 'extend'). Also 'Procomonad's and relative (co)monads ('RelativeMonad', 'RelativeComonad'). Concrete+-- promonads live in @Proarrow.Promonad.*@.+module Proarrow.Promonad+  ( Promonad (..)+  , Procomonad (..)+  , Monad+  , return+  , bind+  , Comonad+  , extract+  , extend+  , AsRelative (..)+  , RelativeMonad (..)+  , RelAlgebra+  , RelativeComonad (..)+  , RelCoalgebra+  ) where++import Data.Kind (Constraint)++import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), src, (:~>), type (+->), type (~>))+import Proarrow.Profunctor.Corepresentable (Corepresentable (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Representable (Representable (..))+import Proarrow.Tools.Laws (ProLaw (..), ProLaws (..), (=:=), (===))++type Procomonad :: k +-> k -> Constraint+class (Profunctor p) => Procomonad p where+  proextract :: p :~> (~>)+  produplicate :: p :~> p :.: p++-- | 'id' is a unit for composition, which is associative, and both are natural. Elements that+-- start where another one ends are made from the drawn ones with 'lmap' and an arbitrary arrow.+instance ProLaws Promonad where+  proLaws =+    [ ProLaw "left identity" \p _ _ -> p =:= id . p+    , ProLaw "right identity" \p _ _ -> p =:= p . id+    , ProLaw3 "associativity" \ @_ @_ @b @c @d @e p p' p'' mor _ -> do+        g <- mor @b @c "g"+        h <- mor @d @e "h"+        let q = lmap g p'+            r = lmap h p''+        r . (q . p) =:= (r . q) . p+    , ProLaw "id dinaturality" \ @_ @a @_ @c _ mor _ -> do+        g <- mor @c @a "g"+        rmap g id =:= lmap g id+    , ProLaw3 "composition naturality" \ @_ @a @b @c @d @e @f p p' _ mor _ -> do+        k <- mor @b @c "k"+        g <- mor @e @a "g"+        h <- mor @d @f "h"+        let q = lmap k p'+        dimap g h (q . p) =:= rmap h q . lmap g p+    , ProLaw3 "composition dinaturality" \ @_ @_ @b @c p p' _ mor _ -> do+        g <- mor @b @c "g"+        p' . rmap g p =:= lmap g p' . p+    ]++-- | 'proextract' is natural, and extracting either half of 'produplicate' gives back the element.+-- Coassociativity is not an equation between elements: its two sides are composites whose middle+-- objects cannot be compared.+instance ProLaws Procomonad where+  proLaws =+    [ ProLaw "proextract naturality" \ @_ @a @b @c @d p morK morJ -> do+        g <- morK @c @a "g"+        h <- morJ @b @d "h"+        proextract (dimap g h p) === h . proextract p . g+    , ProLaw "left counit" \p _ _ -> case produplicate p of q :.: r -> p =:= lmap (proextract q) r+    , ProLaw "right counit" \p _ _ -> case produplicate p of q :.: r -> p =:= rmap (proextract r) q+    ]++instance (CategoryOf k) => Procomonad (Id :: CAT k) where+  proextract (Id f) = f+  produplicate (Id f) = Id (src f) :.: Id f++-- | A representable promonad is a monad on objects: it acts as the functor @m '%' -@, with+-- 'return' and 'bind'.+type Monad m = (Promonad m, Representable m)++-- | The unit of the monad @m@.+return :: forall m a. (Monad m, Ob a) => a ~> m % a+return = index @m id++-- | Kleisli extension: run a Kleisli arrow under @m@.+bind :: forall m b a. (Monad m, Ob b) => a ~> m % b -> m % a ~> m % b+bind f = index (tabulate @m @b f . (repUniv \\ f))++-- | Dually, a corepresentable promonad is a comonad on objects, acting as @w '%%' -@, with+-- 'extract' and 'extend'.+type Comonad w = (Promonad w, Corepresentable w)++-- | The counit of the comonad @w@.+extract :: forall w a. (Comonad w, Ob a) => w %% a ~> a+extract = coindex @w id++-- | CoKleisli extension: run a coKleisli arrow under @w@.+extend :: forall w a b. (Comonad w, Ob a) => w %% a ~> b -> w %% a ~> w %% b+extend f = coindex ((corepUniv \\ f) . cotabulate @w @a f)++type RelativeMonad :: i +-> k -> k +-> i -> Constraint+class (Representable m, Profunctor j) => RelativeMonad j m where+  relReturn :: (Ob a) => j a (m % a)+  relBind :: (Ob b) => j a (m % b) -> m % a ~> m % b++type RelAlgebra j m a b = j a b -> m % a ~> b++-- | A 'Monad' or 'Comonad' seen as a relative (co)monad along 'Id'.+--+-- The wrapper is needed: a direct @'RelativeMonad' 'Id' m@ instance would unify at @j = 'Id'@ with+-- carrier-specific ones such as the codensity monad's, with neither more specific, so no overlap+-- pragma could order them.+type AsRelative :: (k +-> i) -> k +-> i+newtype AsRelative m a b = AsRelative {unAsRelative :: m a b}+  deriving newtype (Profunctor, Promonad, Representable, Corepresentable)++instance (Monad m) => RelativeMonad Id (AsRelative m) where+  relReturn = Id (return @m)+  relBind @b (Id f) = bind @m @b f++type RelativeComonad :: i +-> k -> k +-> i -> Constraint+class (Corepresentable w, Profunctor j) => RelativeComonad j w where+  relExtract :: (Ob a) => j (w %% a) a+  relExtend :: (Ob a) => j (w %% a) b -> w %% a ~> w %% b++type RelCoalgebra j w a b = j a b -> a ~> w %% b++instance (Comonad w) => RelativeComonad Id (AsRelative w) where+  relExtract = Id (extract @w)+  relExtend @a (Id f) = extend @w @a f
+ src/Proarrow/Promonad/Cont.hs view
@@ -0,0 +1,69 @@+-- | The continuation promonad: @'Cont' r a b@ is a continuation transformer @(b '~>' r) -> (a '~>' r)@.+-- It is strong for the tensor but only premonoidal, as the order of effects matters.+module Proarrow.Promonad.Cont where++import Data.Kind (Type)+import Prelude (($))++import Proarrow.Category.Instance.Kleisli (KLEISLI (..), Kleisli (..))+import Proarrow.Category.Monoidal (MonoidalProfunctor (..), Tensor)+import Proarrow.Category.Monoidal.Closed (Closed (..), curry, uncurry)+import Proarrow.Category.Monoidal.StarAutonomous (ExpSA, StarAutonomous (..), applySA, currySA, expSA)+import Proarrow.Category.Monoidal.Strength (Strong (..))+import Proarrow.Colimit.BinaryCoproduct (Coprod (..), HasBinaryCoproducts (..), HasCoproducts)+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..))+import Proarrow.Profunctor.Representable (Representable (..))++-- | An arrow from @a@ to @b@ is a mapping of continuations @(b '~>' r) -> (a '~>' r)@.+data Cont r a b where+  Cont :: (Ob a, Ob b) => {runCont :: (b ~> r) -> (a ~> r)} -> Cont r a b++instance (CategoryOf k) => Profunctor (Cont (r :: k)) where+  dimap l r (Cont f) = Cont ((. l) . f . (. r)) \\ l \\ r+  r \\ Cont{} = r+instance (CategoryOf k) => Promonad (Cont (r :: k)) where+  id = Cont id+  Cont f . Cont g = Cont (g . f)++-- | At @Type@ the continuation promonad is the continuation /monad/: @(b -> r) -> (a -> r)@ is+-- @a -> (b -> r) -> r@ by flipping the arguments, so @'Cont' r '%' b@ is the double-negation+-- @(b -> r) -> r@. This gives @'KLEISLI' ('Cont' r)@ its initial object and coproducts, which+-- hold for the Kleisli category of a monad but not of an arbitrary promonad.+instance Representable (Cont (r :: Type)) where+  type Cont r % b = (b -> r) -> r+  index (Cont f) a k = f k a+  tabulate g = Cont \k a -> g a k+  repMap f c k = c (k . f)++instance Strong Tensor (Cont (r :: Type)) where+  act (Cont yrxy) = Cont \byr -> uncurry (yrxy . curry byr)++-- Not costrong++-- | Only premonoidal not monoidal.+instance MonoidalProfunctor (Cont (r :: Type)) where+  one = Cont id+  Cont f ** Cont g = Cont \k (x1, y1) -> f (\x2 -> g (\y2 -> k (x2, y2)) y1) x1++instance (HasCoproducts k) => MonoidalProfunctor (Coprod (Cont (r :: k))) where+  one = Coprod (Cont id)+  Coprod (Cont @af @bf f) ** Coprod (Cont @ag @bg g) =+    withObCoprod @k @af @ag $+      withObCoprod @k @bf @bg $+        Coprod (Cont (\k -> f (k . lft @_ @bf @bg) ||| g (k . rgt @_ @bf @bg)))++instance StarAutonomous (KLEISLI (Cont (r :: Type))) where+  type Dual @(KLEISLI (Cont r)) (KL a) = KL (a ~~> r)+  withObDual r = r+  dual (Kleisli (Cont f)) = Kleisli (Cont \k br -> k (f br))+  dualInv (Kleisli (Cont f)) = Kleisli (Cont \k b -> f (\g -> g b) k)+  linDist (Kleisli (Cont f)) = Kleisli (Cont \k a -> k (\(b, c) -> f (\g -> g c) (a, b)))+  linDistInv (Kleisli (Cont f)) = Kleisli (Cont \k (a, b) -> k (\c -> f (\g -> g (b, c)) a))+instance Closed (KLEISLI (Cont (r :: Type))) where+  type a ~~> b = ExpSA a b+  withObExp r = r+  curry = currySA+  apply = applySA+  (^^^) = expSA++-- Not CompactClosed, needs ((a -> r, b -> r) -> r) -> ((a, b) -> r) -> r
+ src/Proarrow/Promonad/Reader.hs view
@@ -0,0 +1,168 @@+-- | The reader promonad over a monoidal category: @'Reader' ('OP' r) a b@ is a map @r '**' a '~>' b@.+-- It is 'Corepresentable' by @r '**' -@ (the coreader comonad) and, in a symmetric closed category,+-- 'Representable' by @r '~~>' -@ (the reader monad); a 'Comonoid' @r@ makes it a 'Promonad'. 'ReaderT'+-- is the corresponding transformer.+module Proarrow.Promonad.Reader where++import Prelude (($))++import Proarrow.Adjunction qualified as Adj+import Proarrow.Category.Instance.Nat (Nat (..))+import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Monoidal+  ( Monoidal (..)+  , MonoidalProfunctor (..)+  , SymMonoidal (..)+  , Tensor+  , first+  , leftUnitorInvWith+  , leftUnitorWith+  , second+  , swap'+  , swapInner+  , unitObj+  )+import Proarrow.Category.Monoidal.Cartesian (Cartesian)+import Proarrow.Category.Monoidal.Closed (Closed (..), uncurry)+import Proarrow.Category.Monoidal.Distributive (Cotraversable (..))+import Proarrow.Category.Monoidal.Strength (Strong (..))+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), lmap, obj, rmap, src, (//), (:~>), type (+->))+import Proarrow.Functor (Functor (..))+import Proarrow.Monoid (Comonoid (..), Monoid (..))+import Proarrow.Profunctor.Corepresentable (Corepresentable (..))+import Proarrow.Profunctor.Instance.Composition (compComp, (:.:) (..))+import Proarrow.Profunctor.Instance.Day (Day (..))+import Proarrow.Profunctor.Instance.Star (Star, pattern Star)+import Proarrow.Profunctor.Representable (Representable (..))+import Proarrow.Promonad (Procomonad (..))+import Proarrow.Promonad.Writer (Writer (..), WriterT (..))++-- | The reader promonad for an environment @r@: an arrow from @a@ to @b@ is a map+-- @r '**' a '~>' b@ consuming the environment. The index is 'OP'-wrapped, as it acts+-- contravariantly.+data Reader r a b where+  Reader :: forall a b r. (Ob a) => r ** a ~> b -> Reader (OP r) a b++instance (Ob (r :: k), Monoidal k) => Profunctor (Reader (OP r) :: k +-> k) where+  dimap l r (Reader f) = Reader (r . f . second @r l) \\ r \\ l+  r \\ Reader f = r \\ f++-- | The coreader comonad given the Promonad instance.+-- Together with the 'Representable' instance this gives the curry/uncurry adjunction.+instance (Ob (r :: k), Monoidal k) => Corepresentable (Reader (OP r) :: k +-> k) where+  type Reader (OP r) %% a = r ** a+  coindex (Reader f) = f+  cotabulate = Reader+  corepMap = second @r++-- | The reader monad given the Promonad instance.+instance (Ob (r :: k), SymMonoidal k, Closed k) => Representable (Reader (OP r) :: k +-> k) where+  type Reader (OP r) % a = r ~~> a+  index (Reader @a @b f) = curry @_ @a @r @b (f . swap @_ @a @r)+  tabulate @b @a f = Reader (uncurry @r @b f . swap @_ @r @a) \\ f+  repMap f = f ^^^ obj @r++instance (Monoidal k) => Functor (Reader :: OPPOSITE k -> k +-> k) where+  map (Op f) = f // Prof \(Reader @a g) -> Reader (g . first @a f)++instance (Comonoid (r :: k), Monoidal k) => Promonad (Reader (OP r) :: k +-> k) where+  id = Reader (leftUnitorWith (counit @r))+  Reader g . Reader @a f = Reader (g . second @r f . associator @k @r @r @a . first @a (comult @r))++instance (Monoid (r :: k), Monoidal k) => Procomonad (Reader (OP r) :: k +-> k) where+  proextract (Reader f) = f . leftUnitorInvWith (mempty @r)+  produplicate (Reader @a f) = Reader id :.: Reader (f . first @a (mappend @r) . associatorInv @k @r @r @a) \\ f++instance (Ob (r :: k), SymMonoidal k) => Strong Tensor (Reader (OP r) :: k +-> k) where+  act @a @x (Reader g) =+    withOb2 @k @a @x $+      Reader ((obj @a ** g) . associator @k @a @r @x . first @x (swap @_ @r @a) . associatorInv @k @r @a @x)++-- | Note: This is only premonoidal, not monoidal, unless the comonoid is cocommutative.+instance (Comonoid (r :: k), SymMonoidal k) => MonoidalProfunctor (Reader (OP r) :: k +-> k) where+  one = id \\ unitObj @k+  Reader @x1 @x2 f ** Reader @y1 @y2 g =+    f //+      g //+        withOb2 @_ @x1 @y1 $+          withOb2 @_ @x2 @y2 $+            Reader+              ( second @x2 g+                  . associator @k @x2 @r @y1+                  . ((swap' (obj @r) f . associator @k @r @r @x1 . first @x1 (comult @r)) ** obj @y1)+                  . associatorInv @k @r @x1 @y1+              )++-- | A version of cotraverse specialized to `Reader`, with fewer requirements on @p@.+cotraverseReader+  :: forall {k} p (r :: k). (Strong Tensor p, Ob r) => p :.: Reader (OP r) :~> Reader (OP r) :.: p+cotraverseReader (p :.: Reader f) = let rp = act @Tensor @p @r p in Reader (src rp) :.: rmap f rp \\ rp \\ p++instance (Comonoid (r :: k), Monoidal k) => Cotraversable (Reader (OP r) :: k +-> k) where+  cotraverse = cotraverseReader++-- Reader is not Traversable++instance (Ob (r :: k), Monoidal k) => Adj.Proadjunction (Writer r :: k +-> k) (Reader (OP r)) where+  unit @a = withOb2 @k @r @a $ Reader id :.: Writer id+  counit (Writer f :.: Reader g) = g . f++dayCounit :: forall {k} (r :: k). (Ob r, Cartesian k) => Writer r `Day` Reader (OP r) ~> (~>)+dayCounit = Prof \(Day @_ @d @e f (Writer p) (Reader q) g) -> g . second @d q . associator @k @d @r @e . first @e (swap @k @r @d . p) . f++readerComp+  :: forall {k} (r :: k) (s :: k). (SymMonoidal k, Ob r, Ob s) => Reader (OP r) :.: Reader (OP s) ~> Reader (OP (r ** s))+readerComp = withOb2 @k @r @s $+  Prof \(Reader @a f :.: Reader g) -> Reader (g . second @s f . associator @k @s @r @a . first @a (swap @k @r @s))++readerDay+  :: forall {k} (r :: k) (s :: k). (SymMonoidal k, Ob r, Ob s) => Reader (OP r) `Day` Reader (OP s) ~> Reader (OP (r ** s))+readerDay = withOb2 @k @r @s $+  Prof \(Day @c @_ @e @_ f (Reader p) (Reader q) g) -> Reader (g . (p ** q) . swapInner @r @s @c @e . second @(r ** s) f) \\ f++type ReaderT :: OPPOSITE k -> k +-> k -> k +-> k+newtype ReaderT r p a b where+  ReaderT :: (Reader r :.: p) a b -> ReaderT r p a b++runReaderT :: (Profunctor p) => ReaderT (OP r) p a b -> p (r ** a) b+runReaderT (ReaderT (Reader f :.: p)) = lmap f p++ask :: (Promonad p, Monoidal k, Ob (r :: k)) => ReaderT (OP r) p Unit r+ask = ReaderT (Reader rightUnitor :.: id)++answer+  :: forall {k} p r a b. (Promonad p, Monoidal k, Comonoid (r :: k)) => ReaderT (OP r) p a b -> ReaderT (OP r) p (r ** a) b+answer (ReaderT (Reader f :.: p)) = withOb2 @k @r @a $ ReaderT (Reader (f . leftUnitorWith @(r ** a) (counit @r)) :.: p)++local :: forall {k} a b p r. (Monoidal k, Ob (r :: k)) => r ~> r -> ReaderT (OP r) p a b -> ReaderT (OP r) p a b+local f (ReaderT (Reader r :.: p)) = ReaderT (Reader (r . first @a f) :.: p)++deriving newtype instance (Profunctor p, Monoidal k, Ob (r :: k)) => Profunctor (ReaderT (OP r) p)+deriving newtype instance (Representable p, Ob (r :: k), SymMonoidal k, Closed k) => Representable (ReaderT (OP r) p)+deriving newtype instance (Corepresentable p, Ob (r :: k), Monoidal k) => Corepresentable (ReaderT (OP r) p)+deriving newtype instance+  (MonoidalProfunctor p, Comonoid (r :: k), SymMonoidal k) => MonoidalProfunctor (ReaderT (OP r) p)+deriving newtype instance (Cotraversable p, Comonoid (r :: k), Monoidal k) => Cotraversable (ReaderT (OP r) p)++instance (Strong Tensor p, Ob (r :: k), SymMonoidal k) => Strong Tensor (ReaderT (OP r) p) where+  act @a (ReaderT p) = ReaderT (act @Tensor @_ @a p)++instance (Monoidal k, Ob r) => Functor (ReaderT r :: k +-> k -> k +-> k) where+  map n@Prof{} = Prof \(ReaderT p) -> ReaderT (unProf (map n) p)++instance (Monoidal k) => Functor (ReaderT :: OPPOSITE k -> k +-> k -> k +-> k) where+  map f = f // Nat $ Prof \(ReaderT p) -> ReaderT (unProf (unNat (map (map f))) p)++instance (Comonoid (r :: k), Monoidal k, Strong Tensor p, Promonad p) => Promonad (ReaderT (OP r) p) where+  id = ReaderT (id :.: id)+  ReaderT l . ReaderT r = ReaderT (compComp cotraverseReader l r)++-- | ReaderT is a monad on profunctors, i.e. we have @p ~> ReaderT p@ and @ReaderT (ReaderT p) ~> ReaderT p@.+instance (Comonoid r, Monoidal k) => Promonad (Star (ReaderT (OP r) :: k +-> k -> k +-> k)) where+  id = Star $ Prof \p -> ReaderT (id :.: p) \\ p+  Star l . Star r = Star $ Prof (\(ReaderT (f :.: ReaderT (g :.: p))) -> ReaderT ((g . f) :.: p)) . map l . r++instance (Adj.Proadjunction p q, Ob (r :: k), Monoidal k) => Adj.Proadjunction (WriterT r p) (ReaderT (OP r) q) where+  unit @a = case Adj.unit @_ @_ @a of l :.: r -> ReaderT l :.: WriterT r+  counit (WriterT l :.: ReaderT r) = Adj.counit (l :.: r)
+ src/Proarrow/Promonad/State.hs view
@@ -0,0 +1,84 @@+-- | The state promonad and its transformer: @'StateT' s p@ sandwiches @p@ between 'Reader' and 'Writer',+-- so @'State' s a b@ amounts to a map @s '**' a '~>' s '**' b@. It is only premonoidal, not monoidal:+-- the order in which two stateful effects run matters.+module Proarrow.Promonad.State where++import Prelude (($))++import Proarrow.Adjunction qualified as Adj+import Proarrow.Category.Instance.Opposite (OPPOSITE (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Monoidal+  ( Monoidal (..)+  , MonoidalProfunctor (..)+  , SymMonoidal (..)+  , Tensor+  , leftUnitorWith+  , swap'+  )+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..))+import Proarrow.Category.Monoidal.Strength (Strong (..))+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), arr, obj, type (+->))+import Proarrow.Functor (Functor (..))+import Proarrow.Limit.BinaryProduct ((&&&))+import Proarrow.Monoid (Comonoid (..))+import Proarrow.Object (ObjDict (..), objDicts)+import Proarrow.Profunctor.Corepresentable (Corepresentable)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Representable (Representable (..))+import Proarrow.Promonad.Reader (Reader (..))+import Proarrow.Promonad.Writer (Writer (..))++type State s = StateT s Id+pattern State :: forall {k} a b s. (Monoidal k, Ob (s :: k)) => (Ob a, Ob b) => (s ** a) ~> (s ** b) -> State s a b+pattern State f <- (runStateT &&& objDicts -> (Id f, (ObjDict, ObjDict)))+  where+    State f = StateT (Reader id :.: Id f :.: Writer id) \\ f+{-# COMPLETE State #-}++-- | This is only premonoidal, not monoidal.+instance (SymMonoidal k, Ob s) => MonoidalProfunctor (State (s :: k)) where+  one = State (obj @s ** one) \\ (one :: (Unit :: k) ~> Unit)+  State @a1 @b1 f ** State @a2 @b2 g =+    let s = obj @s; a1 = obj @a1; b1 = obj @b1; a2 = obj @a2; b2 = obj @b2+    in State+         ( (s ** swap' b2 b1)+             . associator @_ @s @b2 @b1+             . (g ** b1)+             . associatorInv @_ @s @a2 @b1+             . (s ** swap' b1 a2)+             . associator @_ @s @b1 @a2+             . (f ** a2)+             . associatorInv @_ @s @a1 @a2+         )+         \\ (a1 ** a2)+         \\ (b1 ** b2)++type StateT :: k -> k +-> k -> k +-> k+newtype StateT s p a b where+  StateT :: (Reader (OP s) :.: p :.: Writer s) a b -> StateT s p a b++runStateT :: (Profunctor p) => StateT s p a b -> p (s ** a) (s ** b)+runStateT (StateT (Reader f :.: p :.: Writer g)) = dimap f g p++get :: forall {k} p s. (Promonad p, Monoidal k, Comonoid (s :: k)) => StateT s p Unit s+get = StateT (Reader (rightUnitor @k @s) :.: id :.: Writer (comult @s))++put :: forall {k} p s. (Promonad p, Monoidal k, Comonoid (s :: k)) => StateT s p s Unit+put = StateT (Reader (leftUnitorWith (counit @s)) :.: id :.: Writer (rightUnitorInv @k @s))++deriving newtype instance (Profunctor p, Monoidal k, Ob (s :: k)) => Profunctor (StateT s p)+deriving newtype instance (Representable p, Ob (s :: k), SymMonoidal k, Closed k) => Representable (StateT s p)+deriving newtype instance (Corepresentable p, Ob (s :: k), Monoidal k, CompactClosed k) => Corepresentable (StateT s p)++instance (Strong Tensor p, Ob (s :: k), SymMonoidal k) => Strong Tensor (StateT s p) where+  act @a (StateT p) = StateT (act @Tensor @_ @a p)++instance (Ob (s :: k), Monoidal k, Strong Tensor p, Promonad p) => Promonad (StateT s p) where+  id @a = withOb2 @k @s @a $ StateT (Reader id :.: act @Tensor @p @s (id @p @a) :.: Writer id)+  StateT (r1 :.: p1 :.: w1) . StateT (r2 :.: p2 :.: w2) = StateT (r2 :.: (p1 . arr (Adj.counit (w2 :.: r1)) . p2) :.: w1)++instance (Monoidal k, Ob s) => Functor (StateT s :: k +-> k -> k +-> k) where+  map (Prof n) = Prof \(StateT (r :.: p :.: w)) -> StateT (r :.: n p :.: w)
+ src/Proarrow/Promonad/Writer.hs view
@@ -0,0 +1,166 @@+-- | The writer promonad: @'Writer' w a b@ is a map @a '~>' w '**' b@, 'Representable' by @w '**' -@.+-- A 'Monoid' @w@ makes it a 'Promonad' (the writer monad), and in a compact closed category it is also+-- 'Corepresentable' (the cowriter comonad). 'WriterT' is the corresponding transformer, with 'tell'.+module Proarrow.Promonad.Writer where++import Prelude (($))++import Proarrow.Category.Instance.Nat (Nat (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Monoidal+  ( Monoidal (..)+  , MonoidalProfunctor (..)+  , SymMonoidal (..)+  , Tensor+  , first+  , leftUnitorInvWith+  , leftUnitorWith+  , second+  , swap'+  , swapInner+  , unitObj+  )+import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..), combineDual)+import Proarrow.Category.Monoidal.Distributive (Traversable (..))+import Proarrow.Category.Monoidal.StarAutonomous (ExpSA, StarAutonomous (..), expSA)+import Proarrow.Category.Monoidal.Strength (Strong (..))+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), lmap, obj, rmap, tgt, (//), (:~>), type (+->))+import Proarrow.Functor (Functor (..))+import Proarrow.Monoid (Comonoid (..), Monoid (..))+import Proarrow.Profunctor.Corepresentable (Corepresentable (..))+import Proarrow.Profunctor.Instance.Composition (compComp, (:.:) (..))+import Proarrow.Profunctor.Instance.Day (Day (..))+import Proarrow.Profunctor.Instance.Star (Star, pattern Star)+import Proarrow.Profunctor.Representable (Representable (..), dimapRep)+import Proarrow.Promonad (Procomonad (..))++-- | The writer promonad over @w@: an arrow from @a@ to @b@ is a map @a '~>' w '**' b@, emitting+-- output alongside the result.+data Writer w a b where+  Writer :: (Ob b) => a ~> w ** b -> Writer w a b++instance (Ob (w :: k), Monoidal k) => Profunctor (Writer w :: k +-> k) where+  dimap = dimapRep+  r \\ Writer f = r \\ f++-- | The writer monad given the Promonad instance.+instance (Ob (w :: k), Monoidal k) => Representable (Writer w :: k +-> k) where+  type Writer w % a = w ** a+  index (Writer f) = f+  tabulate = Writer+  repMap = second @w++-- | The cowriter comonad given the Promonad instance.+instance (Ob (w :: k), CompactClosed k) => Corepresentable (Writer w :: k +-> k) where+  type Writer w %% a = ExpSA w a+  coindex (Writer @b @a f) =+    withObDual @k @w+      ( withObDual @k @a $+          leftUnitorWith (dualityCounit @k @w)+            . associatorInv @k @(Dual w) @w @b+            . (obj @(Dual w) ** (f . doubleNeg @k @a))+            . distribDual @k @w @(Dual a)+      )+      \\ f+  cotabulate @a f =+    withObDual @k @w+      ( withObDual @k @a $+          withObDual @k @(Dual a) $+            Writer+              ( (obj @w ** (f . combineDual @w @(Dual a)))+                  . associator @k @w @(Dual w) @(Dual (Dual a))+                  . leftUnitorInvWith (dualityUnit @k @w)+                  . doubleNegInv @k @a+              )+      )+      \\ f+  corepMap f = expSA f (obj @w)++instance (Monoidal k) => Functor (Writer :: k -> k +-> k) where+  map f = f // Prof \(Writer @b g) -> Writer ((f ** obj @b) . g)++instance (Monoid (w :: k), Monoidal k) => Promonad (Writer w :: k +-> k) where+  id = Writer (leftUnitorInvWith (mempty @w))+  Writer @c g . Writer f = Writer (first @c (mappend @w) . associatorInv @k @w @w @c . second @w g . f)++instance (Comonoid (w :: k), Monoidal k) => Procomonad (Writer w :: k +-> k) where+  proextract (Writer f) = leftUnitorWith (counit @w) . f+  produplicate (Writer @b f) = Writer (associator @k @w @w @b . first @b (comult @w) . f) :.: Writer id \\ f++instance (Ob (w :: k), SymMonoidal k) => Strong Tensor (Writer w :: k +-> k) where+  act @b @_ @y (Writer g) =+    withOb2 @k @b @y $+      Writer (associator @k @w @b @y . first @y (swap @_ @b @w) . associatorInv @k @b @w @y . (obj @b ** g))++-- | This is only premonoidal, not monoidal, unless the monoid is commutative.+instance (Monoid (w :: k), SymMonoidal k) => MonoidalProfunctor (Writer w :: k +-> k) where+  one = id \\ unitObj @k+  Writer @x2 @x1 f ** Writer @y2 @y1 g =+    f //+      g //+        withOb2 @_ @x1 @y1 $+          withOb2 @_ @x2 @y2 $+            Writer+              ( associator @k @w @x2 @y2+                  . first @y2 (first @x2 (mappend @w) . associatorInv @k @w @w @x2 . swap' f (obj @w))+                  . associatorInv @k @x1 @w @y2+                  . second @x1 g+              )++-- | A version of traverse specialized to `Writer`, with fewer requirements on @p@.+traverseWriter :: forall {k} p (w :: k). (Strong Tensor p, Ob w) => Writer w :.: p :~> p :.: Writer w+traverseWriter (Writer f :.: p) = let wp = act @Tensor @p @w p in lmap f wp :.: Writer (tgt wp) \\ wp \\ p++instance (Monoid (w :: k), Monoidal k) => Traversable (Writer w :: k +-> k) where+  traverse = traverseWriter++-- Writer is not Cotraversable++writerComp :: forall {k} (r :: k) (s :: k). (SymMonoidal k, Ob r, Ob s) => Writer r :.: Writer s ~> Writer (r ** s)+writerComp = withOb2 @k @r @s $+  Prof \(Writer f :.: Writer @b g) -> Writer (associatorInv @k @r @s @b . second @r g . f)++writerDay :: forall {k} (r :: k) (s :: k). (SymMonoidal k, Ob r, Ob s) => Writer r `Day` Writer s ~> Writer (r ** s)+writerDay = withOb2 @k @r @s $+  Prof \(Day @_ @d @_ @f f (Writer p) (Writer q) g) -> Writer (second @(r ** s) g . swapInner @r @d @s @f . (p ** q) . f) \\ g++type WriterT :: k -> k +-> k -> k +-> k+newtype WriterT w p a b where+  WriterT :: (p :.: Writer w) a b -> WriterT w p a b++runWriterT :: (Profunctor p) => WriterT w p a b -> p a (w ** b)+runWriterT (WriterT (p :.: Writer f)) = rmap f p++tell :: (Promonad p, Monoidal k, Ob (w :: k)) => WriterT w p w Unit+tell = WriterT (id :.: Writer rightUnitorInv)++listen :: forall {k} p w a b. (Promonad p, Monoidal k, Comonoid (w :: k)) => WriterT w p a b -> WriterT w p a (w ** b)+listen (WriterT (p :.: Writer f)) = withOb2 @k @w @b $ WriterT (p :.: Writer (associator @k @w @w @b . first @b (comult @w) . f))++censor :: forall {k} p w a b. (Monoidal k, Ob (w :: k)) => w ~> w -> WriterT w p a b -> WriterT w p a b+censor f (WriterT (p :.: Writer w)) = WriterT (p :.: Writer (first @b f . w))++deriving newtype instance (Profunctor p, Monoidal k, Ob (w :: k)) => Profunctor (WriterT w p)+deriving newtype instance (Representable p, Ob (w :: k), Monoidal k) => Representable (WriterT w p)+deriving newtype instance (Corepresentable p, Ob (w :: k), CompactClosed k) => Corepresentable (WriterT w p)+deriving newtype instance (MonoidalProfunctor p, Monoid (w :: k), SymMonoidal k) => MonoidalProfunctor (WriterT w p)+deriving newtype instance (Traversable p, Monoid (w :: k)) => Traversable (WriterT w p)++instance (Strong Tensor p, Ob (w :: k), SymMonoidal k) => Strong Tensor (WriterT w p) where+  act @a (WriterT p) = WriterT (act @Tensor @_ @a p)++instance (Monoidal k, Ob w) => Functor (WriterT w :: k +-> k -> k +-> k) where+  map n@Prof{} = Prof \(WriterT p) -> WriterT (unProf (unNat (map n)) p)++instance (Monoidal k) => Functor (WriterT :: k -> k +-> k -> k +-> k) where+  map f = f // Nat $ Prof \(WriterT p) -> WriterT (unProf (map (map f)) p)++instance (Monoid (w :: k), Strong Tensor p, Promonad p) => Promonad (WriterT w p) where+  id = WriterT (id :.: id)+  WriterT l . WriterT r = WriterT (compComp traverseWriter l r)++-- | WriterT is a monad on profunctors, with @p ~> WriterT p@ and+-- @WriterT (WriterT p) ~> WriterT p@.+instance (Monoid w, Monoidal k) => Promonad (Star (WriterT w :: k +-> k -> k +-> k)) where+  id = Star $ Prof \p -> WriterT (p :.: id) \\ p+  Star l . Star r = Star $ Prof (\(WriterT (WriterT (p :.: f) :.: g)) -> WriterT (p :.: (g . f))) . map l . r
+ src/Proarrow/Squares.hs view
@@ -0,0 +1,406 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Squares, specialized to profunctors: the counterpart of "Proarrow.Equipment.Squares" in+-- @proarrow-equipment@. Horizontal legs are 'Proarrow.Path.Path's of profunctors, vertical legs+-- 'Representable' profunctors (the tight morphisms of the @Prof@ equipment).+--+-- A square's payload is @'Fold' (p '+++' f) :~> 'Fold' (g '+++' q)@, the fold of each side's+-- concatenated path, instead of @'Fold' f ':.:' 'Fold' p :~> 'Fold' q ':.:' 'Fold' g@.+-- "Proarrow.Path" does the associator\/unitor bookkeeping once, and since @'Nil' '+++' ps@ and+-- @ps '+++' 'Nil'@ both reduce to @ps@, combinators with trivial legs need no unitors.+module Proarrow.Squares where++import Data.Kind (Type)+import Prelude (($))++import Proarrow.Adjunction (Proadjunction)+import Proarrow.Adjunction qualified as Adj+import Proarrow.Category.Instance.Prof qualified as P+import Proarrow.Category.Monoidal (Monoidal (..), type (**))+import Proarrow.Category.Monoidal.Action (Act, ActionAt, MonoidalAction (..), actHom)+import Proarrow.Category.Monoidal.EndoProf (ENDO (..), Precomp)+import Proarrow.Category.Monoidal.Rev (REV (..))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), obj, rmap, (//), (:~>), (\\), type (+->))+import Proarrow.Functor (FunctorForRep (..))+import Proarrow.Optic (ExOptic (..))+import Proarrow.Optic.Action (ActFl (..))+import Proarrow.Path+  ( Fold+  , IsPath+  , IsTight+  , Path (..)+  , SPath (..)+  , Tag (..)+  , appendPath+  , idN+  , singPath+  , weakenTight+  , whiskerL+  , whiskerR+  , withAssoc+  , withFoldOb+  , withFoldRep+  , withObAppend+  , type (+++)+  )+import Proarrow.Profunctor.Corepresentable (Corep (..), Corepresentable (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Representable (CorepStar (..), Rep (..), Representable (..))++infixl 6 |||+infixl 5 ===++-- | The kind of a square @p q f g@.+--+-- > h--f--i+-- > |  v  |+-- > p--@--q+-- > |  v  |+-- > j--g--k+type Sq :: Path j h -> Path k i -> Path h i -> Path j k -> Type+data Sq p q f g where+  Sq+    :: (IsPath p, IsPath q, IsTight f, IsTight g)+    => Fold (p +++ f) :~> Fold (g +++ q)+    -> Sq p q f g++-- | The empty square for an object.+--+-- > K-----K+-- > |     |+-- > |     |+-- > |     |+-- > K-----K+object :: (CategoryOf k) => Sq (Nil :: Path k k) Nil Nil Nil+object = Sq idN++-- | Make a square from a horizontal proarrow.+--+-- > K-----K+-- > |     |+-- > p--@--q+-- > |     |+-- > J-----J+hArr :: (Profunctor p, Profunctor q) => p :~> q -> Sq (p ::: Nil) (q ::: Nil) Nil Nil+hArr = Sq++-- | A horizontal identity square.+--+-- > J-----J+-- > |     |+-- > p-----p+-- > |     |+-- > K-----K+hId :: (Profunctor p) => Sq (p ::: Nil) (p ::: Nil) Nil Nil+hId = hArr idN++-- | Make a square from a vertical arrow.+--+-- > J--f--K+-- > |  v  |+-- > |  @  |+-- > |  v  |+-- > J--g--K+vArr :: (Representable f, Representable g) => f :~> g -> Sq Nil Nil (f ::: Nil) (g ::: Nil)+vArr = Sq++-- | A vertical identity square.+--+-- > J--f--K+-- > |  v  |+-- > |  |  |+-- > |  v  |+-- > J--f--K+vId :: (Representable f) => Sq Nil Nil (f ::: Nil) (f ::: Nil)+vId = vArr idN++-- | Horizontal composition.+--+-- > L--d--H     H--f--I     L-d+f-I+-- > |  v  |     |  v  |     |  v  |+-- > p--@--q ||| q--@--r  =  p--@--r+-- > |  v  |     |  v  |     |  v  |+-- > M--e--J     J--g--K     M-e+g-K+(|||) :: forall ps qs rs ds es fs gs. Sq ps qs ds es -> Sq qs rs fs gs -> Sq ps rs (ds +++ fs) (es +++ gs)+Sq l ||| Sq r =+  withObAppend @Tight @ds @fs tds $+    withObAppend @Tight @es @gs tes $+      withAssoc @ps @ds @fs @Prof $+        withAssoc @es @qs @fs @Tight $+          withAssoc @es @gs @rs @Tight $+            Sq $+              whiskerL ses (appendPath sqs sfs) (appendPath sgs srs) r+                . whiskerR (appendPath sps sds) (appendPath ses sqs) sfs l+  where+    tds :: SPath Tight ds+    tds = singPath+    tes :: SPath Tight es+    tes = singPath+    sps :: SPath Prof ps+    sps = singPath+    sqs :: SPath Prof qs+    sqs = singPath+    srs :: SPath Prof rs+    srs = singPath+    sds :: SPath Prof ds+    sds = weakenTight tds+    ses :: SPath Prof es+    ses = weakenTight tes+    sfs :: SPath Prof fs+    sfs = weakenTight singPath+    sgs :: SPath Prof gs+    sgs = weakenTight singPath++-- | Vertical composition.+--+-- >  H--e--I+-- >  |  v  |+-- >  r--@--s+-- >  |  v  |+-- >  J--f--K+-- >    ===+-- >  J--f--K+-- >  |  v  |+-- >  p--@--q+-- >  |  v  |+-- >  L--g--M+-- >+-- >    v v+-- >+-- >  H--e--I+-- >  |  v  |+-- > p+r-@-q+s+-- >  |  v  |+-- >  J--g--K+(===) :: forall rs ss es fs ps qs gs. Sq rs ss es fs -> Sq ps qs fs gs -> Sq (ps +++ rs) (qs +++ ss) es gs+Sq top === Sq bot =+  withObAppend @Prof @ps @rs sps $+    withObAppend @Prof @qs @ss sqs $+      withAssoc @gs @qs @ss @Tight $+        withAssoc @ps @rs @es @Prof $+          withAssoc @ps @fs @ss @Prof $+            Sq $+              whiskerR (appendPath sps sfs) (appendPath sgs sqs) sss bot+                . whiskerL sps (appendPath srs ses) (appendPath sfs sss) top+  where+    sps :: SPath Prof ps+    sps = singPath+    sqs :: SPath Prof qs+    sqs = singPath+    srs :: SPath Prof rs+    srs = singPath+    sss :: SPath Prof ss+    sss = singPath+    ses :: SPath Prof es+    ses = weakenTight singPath+    sfs :: SPath Prof fs+    sfs = weakenTight singPath+    sgs :: SPath Prof gs+    sgs = weakenTight singPath++-- | Bend a vertical arrow in the companion direction.+--+-- > J--f--K+-- > |  v  |+-- > |  \->f+-- > |     |+-- > J-----J+toRight :: (Representable f) => Sq Nil (f ::: Nil) (f ::: Nil) Nil+toRight = Sq idN++-- | Bend a vertical arrow in the conjoint direction.+--+-- > J--f--K+-- > |  v  |+-- > f<-/  |+-- > |     |+-- > K-----K+toLeft :: forall f f'. (Proadjunction f f', Representable f) => Sq (f' ::: Nil) Nil (f ::: Nil) Nil+toLeft = Sq (counitNat @f @f')++-- | Bend a companion proarrow back to a vertical arrow.+--+-- > K-----K+-- > |     |+-- > f>-\  |+-- > |  v  |+-- > J--f--K+fromLeft :: (Representable f) => Sq (f ::: Nil) Nil Nil (f ::: Nil)+fromLeft = Sq idN++-- | Bend a conjoint proarrow back to a vertical arrow.+--+-- > J-----J+-- > |     |+-- > |  /-<f+-- > |  v  |+-- > J--f--K+fromRight :: forall f f'. (Proadjunction f f', Representable f) => Sq Nil (f' ::: Nil) Nil (f ::: Nil)+fromRight = Sq (unitNat @f @f')++unitNat :: forall p q. (Proadjunction p q) => Id :~> q :.: p+unitNat (Id f) = rmap f (Adj.unit @p @q) \\ f++counitNat :: forall p q. (Proadjunction p q) => p :.: q :~> Id+counitNat pq = Id (Adj.counit pq)++-- > K--I--K+-- > |  v  |+-- > |  @  |+-- > |     |+-- > K-----K+vUnitor :: forall k. (CategoryOf k) => Sq Nil Nil ((Id :: CAT k) ::: Nil) Nil+vUnitor = vSplitAll @Nil++-- > K-----K+-- > |     |+-- > |  @  |+-- > |  v  |+-- > K--I--K+vUnitorInv :: forall k. (CategoryOf k) => Sq Nil Nil Nil ((Id :: CAT k) ::: Nil)+vUnitorInv = vCombineAll @Nil++-- > I-f-g-K+-- > | v v |+-- > | \@/ |+-- > |  v  |+-- > I-gof-K+vCombine :: forall p q. (Representable p, Representable q) => Sq Nil Nil (p ::: q ::: Nil) (q :.: p ::: Nil)+vCombine = vCombineAll @(p ::: q ::: Nil)++-- > I-gof-K+-- > |  v  |+-- > | /@\ |+-- > | v v |+-- > I-f-g-K+vSplit :: forall p q. (Representable p, Representable q) => Sq Nil Nil (q :.: p ::: Nil) (p ::: q ::: Nil)+vSplit = vSplitAll @(p ::: q ::: Nil)++-- | Combine a whole bunch of vertical arrows into one composed arrow.+--+-- > J-p..-K+-- > | vvv |+-- > | \@/ |+-- > |  v  |+-- > J--f--K+vCombineAll :: forall ps. (IsTight ps) => Sq Nil Nil ps (Fold ps ::: Nil)+vCombineAll = withFoldRep tp (Sq idN)+  where+    tp :: SPath Tight ps+    tp = singPath++-- | Split one composed arrow into a whole bunch of vertical arrows.+--+-- > J--f--K+-- > |  v  |+-- > | /@\ |+-- > | vvv |+-- > J-p..-K+vSplitAll :: forall ps. (IsTight ps) => Sq Nil Nil (Fold ps ::: Nil) ps+vSplitAll = withFoldRep tp (Sq idN)+  where+    tp :: SPath Tight ps+    tp = singPath++-- | Combine a whole bunch of horizontal proarrows into one composed proarrow.+--+-- > K-----K+-- > p--\  |+-- > :--@--F+-- > :--/  |+-- > J-----J+hCombineAll :: forall ps. (IsPath ps) => Sq ps (Fold ps ::: Nil) Nil Nil+hCombineAll = withFoldOb sp (Sq idN)+  where+    sp :: SPath Prof ps+    sp = singPath++-- | Split one composed proarrow into a whole bunch of horizontal proarrows.+--+-- > K-----K+-- > |  /--p+-- > F--@--:+-- > |  \--:+-- > J-----J+hSplitAll :: forall ps. (IsPath ps) => Sq (Fold ps ::: Nil) ps Nil Nil+hSplitAll = withFoldOb sp (Sq idN)+  where+    sp :: SPath Prof ps+    sp = singPath++-- | The unit of an adjunction.+--+-- > J-------J+-- > |   /---q+-- > |   @   |+-- > |   \---p+-- > J-------J+unit :: forall p q. (Proadjunction p q) => Sq Nil (p ::: q ::: Nil) Nil Nil+unit = hCombineAll @Nil ||| hArr (unitNat @p @q) ||| hSplitAll @(p ::: q ::: Nil)++-- | The counit of an adjunction.+--+-- > K-------K+-- > p---\   |+-- > |   @   |+-- > q---/   |+-- > K-------K+counit :: forall p q. (Proadjunction p q) => Sq (q ::: p ::: Nil) Nil Nil Nil+counit = hCombineAll @(q ::: p ::: Nil) ||| hArr (counitNat @p @q) ||| hSplitAll @Nil++-- | Optics in the @Prof@ equipment.+--+-- > J-------J+-- > s>--@-->a+-- > |   @   |+-- > t<--@--<b+-- > K-------K+type EqpOptic a b s t = (IsOptic a b s t) => Sq (t ::: s ::: Nil) (b ::: a ::: Nil) Nil Nil++type IsOptic a b s t = (Representable s, Corepresentable t, Representable a, Corepresentable b)++mkOptic+  :: (IsOptic a b s t)+  => (forall x r. (Ob x) => (forall y. (Ob y) => (s % x ~> a % y) -> (b %% y ~> t %% x) -> r) -> r)+  -> EqpOptic a b s t+mkOptic k = Sq \((:.:) @x s t) -> s // k @x \ @y get put -> tabulate @_ @y (get . index s) :.: cotabulate (coindex t . put)++-- | Sequential composition of optics, with 2 holes.+seq+  :: forall a b s t a' b' u v+   . (Proadjunction u t, IsOptic a b s t, IsOptic a' b' u v)+  => EqpOptic a b s t -> EqpOptic a' b' u v -> Sq (v ::: s ::: Nil) (b' ::: a' ::: b ::: a ::: Nil) Nil Nil+seq st uv = (hId @s === unit @u @t === hId @v) ||| (st === uv)++data family Action :: (m, k) +-> k -> k -> m +-> k+instance (MonoidalAction act, Ob a) => FunctorForRep (Action act a :: m +-> k) where+  type Action act a @ x = Act act x a+  fmap f = actHom @act f (obj @a)++type ActionOptic act a b s t =+  EqpOptic (Rep (Action act a)) (Corep (Action act b)) (Rep (Action act s)) (Corep (Action act t))++fromOptic :: (MonoidalAction act, Ob a, Ob b, Ob s, Ob t) => ExOptic (ActFl act) a b s t -> ActionOptic act a b s t+fromOptic @act @a @b @s @t (ExOptic (l :: p s a) (r :: q b t)) = mkOptic \ @x k ->+  withActP @act @p @q l r \ @z f g ->+    withOb2 @_ @x @z $+      k @(x ** z)+        (multiplicatorInv @act @x @z @a . actHom @act (obj @x) f)+        (actHom @act (obj @x) g . multiplicator @act @x @z @b)++toOptic+  :: forall h x (s :: x +-> h) (t :: h +-> x) (a :: x +-> h) (b :: h +-> x)+   . (CategoryOf h, CategoryOf x, Representable s, Corepresentable t, Representable a, Corepresentable b)+  => EqpOptic a b s t+  -> ExOptic (ActFl (Rep Precomp)) a (CorepStar b) s (CorepStar t)+toOptic (Sq pl) =+  ExOptic+    (Rep @a @(ActionAt (Rep Precomp) (R (E (b :.: CorepStar t)))) (P.Prof get))+    (Corep @(CorepStar b) @(ActionAt (Rep Precomp) (R (E (b :.: CorepStar t)))) (P.Prof put))+  where+    get :: s :~> a :.: (b :.: CorepStar t)+    get s = s // case Adj.unit @(CorepStar t) @t of t :.: t' -> case pl (s :.: t) of a :.: b -> a :.: (b :.: t')++    put :: CorepStar b :.: (b :.: CorepStar t) :~> CorepStar t+    put (b' :.: (b :.: t')) = lmap (Adj.counit @(CorepStar b) @b (b' :.: b)) t'
+ src/Proarrow/Tools/CCC.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++{- HLINT ignore "Redundant $" -}++-- | A small HOAS (higher-order abstract syntax) front end for building morphisms in any+-- 'BiCCC', compiling through the free category of "Proarrow.Category.Instance.Free" with the+-- bicartesian closed structures rather than a bespoke one. A 'Free' term tracks its free+-- variables via a context list, the way a well-scoped lambda calculus does; 'lam' binds an+-- ordinary Haskell-level variable that 'Cast' automatically "weakens" across nested lambdas so+-- inner lambdas can still refer to outer ones. 'toCCC' interprets a closed term (no free+-- variables) into an actual morphism of the target category.+module Proarrow.Tools.CCC+  ( toCCC+  , lam+  , ($)+  , lift+  , pattern (:&)+  , either+  , lft+  , rgt+  , Free+  , Syntax+  , Ctx+  , Mul+  , Cast (..)+  , KnownCtx (..)+  , BiCCCStructs+  , type F+  , injectRight+  , swapProduct+  , applyPair+  , curryPair+  , flipCurried3+  , swapSum+  , caseEither+  ) where++import Data.Kind (Constraint)+import Prelude (type (~))++import Proarrow.Category.Instance.Free (FREE (..), Lower, emb, fold)+import Proarrow.Category.Monoidal (Monoidal)+import Proarrow.Category.Monoidal.Cartesian (BiCCC, Cartesian, prodToTensor, tensorToProd, unitToTerm)+import Proarrow.Category.Monoidal.Closed (Closed (..), lower)+import Proarrow.Category.Monoidal.Distributive (Distributive (..))+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts ((+++), (|||)), type (||))+import Proarrow.Colimit.BinaryCoproduct qualified as BC+import Proarrow.Colimit.Initial (HasInitialObject)+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..), type (*!))+import Proarrow.Limit.Terminal (HasTerminalObject, TermF)+import Proarrow.Object (Obj)+import Proarrow.Profunctor.Instance.Identity (Id (..))++infixr 0 $++-- | The structures of a bicartesian closed category as a list for 'FREE': the five BiCCC+-- classes, the 'Cartesian' marker supplying the formal @tensor = product@ coercions (the free+-- category cannot state that type equality itself), and 'Distributive', for case analysis in the+-- presence of a context.+type BiCCCStructs =+  '[ HasTerminalObject+   , HasInitialObject+   , HasBinaryProducts+   , HasBinaryCoproducts+   , Monoidal+   , Closed+   , Cartesian+   , Distributive+   ]++-- | The syntax category over @k@: the free BiCCC on @k@'s own hom-sets, i.e. 'Id'. @(~>)@ itself+-- is an unsaturated type family application, so it isn't allowed as a type index where it is+-- pattern-matched on below, in 'Mul'.+type Syntax k = FREE BiCCCStructs (Id :: CAT k)++type Ctx k = [Syntax k]++-- | A short alias for embedding a base-category object, so type applications built from it read+-- like the target signature: '&&', '||' and '~~>' on the free category are its object formers,+-- so @(F a ~~> F b) && F a@ is the object it looks like.+type F a = EMB a++-- | The context product: @'Mul' i@ is the single object standing in for "all the bound+-- variables in @i@", a right fold with the most-recently-bound variable last. This mirrors+-- "Proarrow.Category.Monoidal.Strictified"'s @Fold@, which puts its head leftmost. @Fold@ itself+-- can't be reused, since 'curry'\/'fst'\/'snd' expect the thing being abstracted over on the right+-- of the product.+type family Mul (i :: Ctx k) :: Syntax k where+  Mul '[] = TermF+  Mul (a ': as) = Mul as *! a++-- | A term with free variables @i@ (innermost\/most-recently-bound first) and result type+-- @a@: a morphism from the context product to @a@ in the free BiCCC. A newtype+-- (rather than a bare type synonym) so that @i@ is recoverable from a 'Free' term's type: 'Mul'+-- is many-to-one at the type-family level as far as GHC's injectivity checker is concerned (even+-- though it's mathematically injective here), which would otherwise leave @i@ ambiguous wherever+-- it has to be inferred rather than given explicitly (e.g. picking which context a HOAS variable+-- reference in 'lam' denotes).+newtype Free (i :: Ctx k) (a :: Syntax k) = MkFree {unFree :: Mul i ~> a}++type KnownCtx :: forall {k}. Ctx k -> Constraint+class KnownCtx (i :: Ctx k) where+  ctxOb :: Obj (Mul i)++instance KnownCtx ('[] :: Ctx k) where+  ctxOb = id++instance (KnownCtx i, Ob (b :: Syntax k)) => KnownCtx (b ': i) where+  ctxOb = id \\ ctxOb @i++-- | The most-recently-bound variable.+headT :: forall {k} a i. (KnownCtx (i :: Ctx k), Ob (a :: Syntax k)) => Free (a ': i) a+headT = MkFree (snd @(Syntax k) @(Mul i) @a) \\ ctxOb @i++-- | Weaken a term by one more bound variable it doesn't use.+tailT :: forall {k} a i b. (KnownCtx (i :: Ctx k), Ob (a :: Syntax k)) => Free i b -> Free (a ': i) b+tailT (MkFree f) = MkFree (f . fst @(Syntax k) @(Mul i) @a) \\ ctxOb @i++-- | @'Cast' i j@ holds when context @i@ is context @j@ with zero or more extra variables+-- pushed on top, letting a term built for @j@ be used anywhere \"deeper\" than @j@.+type Cast :: forall {k}. Ctx k -> Ctx k -> Constraint+class Cast (i :: Ctx k) (j :: Ctx k) where+  cast :: (Ob (a :: Syntax k)) => Free j a -> Free i a++instance Cast i i where+  cast f = f++instance+  {-# OVERLAPPABLE #-}+  (Cast i j, KnownCtx (i :: Ctx k), Ob (b :: Syntax k), (b ': i) ~ i')+  => Cast i' j+  where+  cast f = tailT (cast f)++-- | Bind a variable, HOAS-style: the function argument stands for the newly bound variable,+-- usable (via 'Cast') in the body of this 'lam' and any 'lam' nested inside it. The body is a+-- morphism out of the context product, but 'curry' wants the tensor, so the 'Cartesian'+-- coercion mediates.+lam+  :: forall {k} a b i+   . (KnownCtx (i :: Ctx k), Ob (a :: Syntax k), Ob b)+  => ((forall (x :: Ctx k). (Cast x (a ': i)) => Free x a) -> Free (a ': i) b)+  -> Free i (a ~~> b)+lam f = MkFree (curry @(Syntax k) @(Mul i) @a @b (unFree (f xa) . tensorToProd @(Mul i) @a)) \\ ctxOb @i+  where+    xa :: forall (x :: Ctx k). (Cast x (a ': i)) => Free x a+    xa = cast (headT @a @i)++-- | Function application.+($) :: forall {k} a b i. (Ob (a :: Syntax k), Ob b) => Free i (a ~~> b) -> Free i a -> Free i b+MkFree f $ MkFree g = MkFree (apply @(Syntax k) @a @b . prodToTensor @(a ~~> b) @a . (f &&& g))++-- | Embed a morphism of the target category as a term between embedded objects.+lift :: forall {k} a b i. (Ob (a :: k), Ob b) => a ~> b -> Free i (F a) -> Free i (F b)+lift f (MkFree g) = MkFree (emb (Id f) . g)++fstSnd :: forall {k} a b i. (Ob (a :: Syntax k), Ob b) => Free i (a && b) -> (Free i a, Free i b)+fstSnd (MkFree f) = (MkFree (fst @(Syntax k) @a @b . f), MkFree (snd @(Syntax k) @a @b . f))++pattern (:&) :: (Ob (a :: Syntax k), Ob b) => Free i a -> Free i b -> Free i (a && b)+pattern x :& y <- (fstSnd -> (x, y))+  where+    x :& y = MkFree (unFree x &&& unFree y)++{-# COMPLETE (:&) #-}++-- | Inject as the left\/right branch of a sum.+lft :: forall {k} a b i. (Ob (a :: Syntax k), Ob b) => Free i a -> Free i (a || b)+lft (MkFree f) = MkFree (BC.lft @(Syntax k) @a @b . f)++rgt :: forall {k} a b i. (Ob (a :: Syntax k), Ob b) => Free i b -> Free i (a || b)+rgt (MkFree f) = MkFree (BC.rgt @(Syntax k) @a @b . f)++-- | Uncurry a function term into the body of a 'lam' binding its argument.+uncurryF+  :: forall {k} a b i+   . (KnownCtx (i :: Ctx k), Ob (a :: Syntax k), Ob b)+  => Free i (a ~~> b) -> Free (a ': i) b+uncurryF f = MkFree (apply @(Syntax k) @a @b . prodToTensor @(a ~~> b) @a . (unFree (tailT f) &&& unFree (headT @a @i)))++-- | Case analysis on a sum, in the presence of a shared context: distributes the context over+-- the sum, so each branch still has access to it. The free category's distributivity is stated+-- for the tensor, so the product is coerced to the tensor and back around 'distL'.+caseT+  :: forall {k} a b c i+   . (KnownCtx (i :: Ctx k), Ob (a :: Syntax k), Ob b)+  => Free i (a || b) -> Free (a ': i) c -> Free (b ': i) c -> Free i c+caseT m f g =+  MkFree+    ( (unFree f ||| unFree g)+        . (tensorToProd @(Mul i) @a +++ tensorToProd @(Mul i) @b)+        . distL @(Syntax k) @(Mul i) @a @b+        . prodToTensor @(Mul i) @(a || b)+        . (id &&& unFree m)+    )+    \\ ctxOb @i++either+  :: forall {k} a b c i+   . (KnownCtx (i :: Ctx k), Ob (a :: Syntax k), Ob b, Ob c)+  => Free i (a ~~> c) -> Free i (b ~~> c) -> Free i (a || b) -> Free i c+either f g m = caseT m (uncurryF f) (uncurryF g)++-- | Interpret a closed term (no free variables) into an actual morphism of the target+-- category: move the empty context from the terminal object to the monoidal unit, 'lower' the+-- function-valued term (a closed one needs no arguments to uncurry), and 'fold' into @k@ with+-- generators interpreted by unwrapping 'Id' (the free category was built over @k@'s own+-- hom-sets directly).+toCCC+  :: forall {k} a b+   . (BiCCC k, Ob (a :: Syntax k), Ob b)+  => Free '[] (a ~~> b) -> Lower (Id :: CAT k) a ~> Lower (Id :: CAT k) b+toCCC (MkFree f) = fold @BiCCCStructs @(Id :: CAT k) unId (lower @a @b (f . unitToTerm))++-- $+-- The examples below exercise 'lam'\/'Cast' (including nested lambdas) and 'toCCC' at+-- @k = 'Type'@, where the compiled morphism can be run and its result printed.++-- | Inject as the right element of a sum.+--+-- >>> import Prelude (Bool (..))+-- >>> injectRight @Bool @Bool True+-- Right True+injectRight :: forall {k} (a :: k) b. (BiCCC k, Ob (a :: k), Ob b) => a ~> (b || a)+injectRight = toCCC @(F a) @(F b || F a) (lam (\x -> rgt x))++-- | Swap a product.+--+-- >>> import Prelude (Bool (..))+-- >>> swapProduct @Bool @Bool (True, False)+-- (False,True)+swapProduct :: forall {k} (a :: k) b. (BiCCC k, Ob a, Ob b) => (a && b) ~> (b && a)+swapProduct = toCCC @(F a && F b) @(F b && F a) (lam (\p -> let (x :& y) = p in y :& x))++-- | Apply a function to an argument, both bundled in a product.+--+-- >>> import Prelude (Bool (..), not)+-- >>> applyPair @Bool @Bool (not, True)+-- False+applyPair :: forall {k} (a :: k) b. (BiCCC k, Ob a, Ob b) => ((a ~~> b) && a) ~> b+applyPair = toCCC @((F a ~~> F b) && F a) @(F b) (lam (\p -> let (f :& a) = p in f $ a))++-- | Curry a pairing function.+--+-- >>> import Prelude (Bool (..))+-- >>> curryPair @Bool @Bool True False+-- (True,False)+curryPair :: forall {k} (a :: k) b. (BiCCC k, Ob a, Ob b) => a ~> (b ~~> (a && b))+curryPair = toCCC @(F a) @(F b ~~> (F a && F b)) (lam (\x -> lam (\y -> x :& y)))++-- | Flip the argument order of a 3-argument curried function, applying the last argument+-- twice. This exercises three levels of nested 'lam' and 'Cast' weakening across all of them.+--+-- >>> import Prelude (Bool (..))+-- >>> flipCurried3 @Bool @Bool @Bool (\_ a _ -> a) True False+-- True+flipCurried3+  :: forall {k} a b c. (BiCCC k, Ob (a :: k), Ob b, Ob c) => (b ~~> a ~~> b ~~> c) ~> (a ~~> b ~~> c)+flipCurried3 =+  toCCC @(F b ~~> (F a ~~> (F b ~~> F c))) @(F a ~~> (F b ~~> F c))+    (lam (\x -> lam (\y -> lam (\z -> ((x $ z) $ y) $ z))))++-- | Swap a sum, via 'either'.+--+-- >>> import Prelude (Bool (..), Either (..))+-- >>> swapSum @Bool @Bool (Left True)+-- Right True+-- >>> swapSum @Bool @Bool (Right False)+-- Left False+swapSum :: forall {k} a b. (BiCCC k, Ob (a :: k), Ob b) => (a || b) ~> (b || a)+swapSum = toCCC @(F a || F b) @(F b || F a) (lam (\x -> either (lam (\y -> rgt y)) (lam (\y -> lft y)) x))++-- | Eliminate a sum by applying whichever of the two functions matches the branch actually+-- present.+--+-- >>> import Prelude (Bool (..), Either (..), not)+-- >>> caseEither @Bool @Bool @Bool (Left True, (not, id))+-- False+-- >>> caseEither @Bool @Bool @Bool (Right True, (not, id))+-- True+caseEither+  :: forall {k} (a :: k) b c. (BiCCC k, Ob a, Ob b, Ob c) => ((a || b) && ((a ~~> c) && (b ~~> c))) ~> c+caseEither =+  toCCC @((F a || F b) && ((F a ~~> F c) && (F b ~~> F c))) @(F c)+    (lam (\p -> let (ab :& q) = p in let (ac :& bc) = q in either ac bc ab))
+ src/Proarrow/Tools/DPO.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Double-pushout (DPO) rewriting.+--+-- A rewrite 'Rule' is a span @l \<~ a ~> r@: @a@ is the interface that's preserved by the+-- rewrite, @l@ is matched against the host object, and @r@ replaces it. Applying a rule at+-- a match @m :: l ~> g@ proceeds in two pushout steps, both performed by 'dpoStep':+--+-- 1. Compute the /pushout complement/ of the rule's left leg and the match, giving the+--    "rest of the world" object @d@ together with legs @a ~> d@ and @d ~> g@. This step+--    can fail if the match doesn't satisfy the gluing condition.+-- 2. Push @a ~> d@ out along the rule's right leg @a ~> r@ to get the result @h@, together+--    with legs @d ~> h@ and @r ~> h@.+--+-- The two legs out of @d@ (@d ~> g@ and @d ~> h@) exhibit the rewrite step as a cospan+-- @g \<- d -> h@ relating the object before and after the rewrite.+module Proarrow.Tools.DPO+  ( HasPushoutComplements (..)+  , Rule (..)+  , dpoStep+  ) where++import Data.Map.Strict qualified as M+import Data.Set qualified as Set+import Data.Universe.Class (Finite (..))+import Prelude qualified as P++import Numeric.Natural (Natural)++import Proarrow.Category.Enriched.Finitary (Finitary (..), FiniteCat, elements, foreachOb, objIndex)+import Proarrow.Category.Enriched.Finitary.Topos (FINITARY, withSubobject)+import Proarrow.Category.Instance.FinHask (FINHASK, FinHask (..), reifyList)+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Instance.Sub (Sub (..))+import Proarrow.Colimit.Pushout (HasPushouts (..))+import Proarrow.Core (CategoryOf (..))+import Proarrow.Limit.Equalizer (factorEqualizer)++-- | A rewrite rule: a span @l \<~ a ~> r@. Both legs are conventionally mono: @a@ is the+-- shared interface, @l \\ a@ is what the rule deletes, @r \\ a@ is what it creates.+data Rule a l r where+  Rule :: a ~> l -> a ~> r -> Rule a l r++-- | Apply a 'Rule' at a match @l ~> g@. On success, the continuation receives the rewrite+-- step's cospan legs @d ~> g@, @d ~> h@ and the embedding @r ~> h@ of the newly created+-- pattern in the result @h@. Calls the failure continuation if the gluing condition fails.+dpoStep+  :: forall {k} (a :: k) l r g ans+   . (HasPushoutComplements k)+  => Rule a l r+  -> l ~> g+  -> (forall d h. d ~> g -> d ~> h -> r ~> h -> ans)+  -> ans+  -> ans+dpoStep (Rule left right) m ok notGlueable =+  pushoutComplement left m (\a2d d2g -> pushout a2d right \d2h r2h -> ok d2g d2h r2h) notGlueable++-- | Whether a collection has no repeats. The match may identify two elements only if the rule+-- keeps both, so a repeated image among the deleted ones is an identification conflict.+allDistinct :: (P.Int, Set.Set a) -> P.Bool+allDistinct (n, s) = Set.size s P.== n++-- | Categories where pushout complements can be computed, or shown not to exist.+--+-- Given the left leg @ll :: a ~> l@ of a rule (assumed mono, i.e. @a@ embeds into @l@) and+-- a match @m :: l ~> g@, 'pushoutComplement' either succeeds with an object @d@ and legs+-- @a ~> d@, @d ~> g@ forming a pushout square with @ll@ and @m@, or calls the second+-- continuation when no such object exists (the gluing condition fails).+class (HasPushouts k) => HasPushoutComplements k where+  pushoutComplement :: a ~> l -> l ~> g -> (forall (d :: k). a ~> d -> d ~> g -> ans) -> ans -> ans++instance HasPushoutComplements FINHASK where+  pushoutComplement (FinHask ll) (FinHask m) ok notGlueable =+    let+      aToG = P.fmap (m M.!) ll+      keptLValues = Set.fromList (M.elems ll)+      deleteList = [m M.! l | l <- M.keys m, l `Set.notMember` keptLValues]+      deleteValues = Set.fromList deleteList+      keepValues = Set.fromList (M.elems aToG)+      dValues = [g | g <- universeF, g `Set.notMember` deleteValues]+    in+      -- the match must identify no two elements that the rule does not both keep: neither a kept one+      -- with a deleted one, nor two distinct deleted ones+      if P.not (Set.disjoint keepValues deleteValues) P.|| P.not (allDistinct (P.length deleteList, deleteValues))+        then notGlueable+        else reifyList dValues \d ->+          let gToD = M.fromList [(d M.! i, i) | i <- universeF]+          in ok (FinHask (P.fmap (gToD M.!) aToG)) (FinHask d)++-- | Pushout complements of finitary profunctors over any finite schema, so one instance gives+-- double-pushout rewriting of graphs, typed graphs, or the rows of a database.+--+-- The gluing condition has two halves:+--+-- * no /identification conflict/: the match identifies two elements only if the rule keeps both+--   (so never a kept element with a deleted one, nor two distinct deleted ones), and+-- * the /dangling condition/: the surviving elements are closed under the schema\'s arrows, i.e.+--   form a subprofunctor that 'Reindex' can carve out. For the schema @E \-\> V@ it says a+--   surviving edge keeps both its endpoints.+instance (FiniteCat j, FiniteCat k) => HasPushoutComplements (FINITARY j k) where+  pushoutComplement (Sub (Prof @av @lv ll)) (Sub (Prof @_ @gv m)) ok notGlueable+    | noSharedImage P.&& noDoubleDelete =+        -- the complement is the subobject of the host that survives, and the interface lands in it+        -- by its own universal property+        withSubobject @gv kept (\incl -> ok (factorEqualizer incl (Sub (Prof (m P.. ll)))) incl) notGlueable+    | P.otherwise = notGlueable+    where+      -- what the match sends the rule's deleted part to, as a set per pair of objects: the checks+      -- below ask about it once per element of every hom-set, and it is not cheap+      deleted :: forall (x :: k) (y :: j). (Ob x, Ob y) => [Natural]+      deleted =+        let keptImages = Set.fromList (P.map (toIndex P.. ll) (elements @av @x @y))+        in [toIndex (m w) | w <- elements @lv @x @y, toIndex w `Set.notMember` keptImages]+      deletedAt :: M.Map (Natural, Natural) (P.Int, Set.Set Natural)+      deletedAt =+        M.fromList+          ( foreachOb @k \ @x -> foreachOb @j \ @y ->+              [((objIndex @x, objIndex @y), (P.length (deleted @x @y), Set.fromList (deleted @x @y)))]+          )+      at :: forall (x :: k) (y :: j). (Ob x, Ob y) => (P.Int, Set.Set Natural)+      at = deletedAt M.! (objIndex @x, objIndex @y)+      kept :: forall (x :: k) (y :: j). (Ob x, Ob y) => gv x y -> P.Bool+      kept z = toIndex z `Set.notMember` P.snd (at @x @y)+      -- nothing the rule keeps may share an image with something it deletes ...+      noSharedImage =+        P.and (foreachOb @k \ @x -> foreachOb @j \ @y -> [kept @x @y (m (ll v)) | v <- elements @av @x @y])+      -- ... and no two deleted elements may share one either+      noDoubleDelete =+        P.and (foreachOb @k \ @x -> foreachOb @j \ @y -> [allDistinct (at @x @y)])
+ src/Proarrow/Tools/Diagrams/Dot.hs view
@@ -0,0 +1,458 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | String diagrams rendered to Graphviz: 'Dot' is a monoidal category of diagram fragments+-- ('node', 'line', the adjunction unit and counit 'unitAdj'\/'counitAdj', ...) indexed by their typed input and+-- output wires, and 'run' emits the composed diagram as dot source.+module Proarrow.Tools.Diagrams.Dot where++import Data.Bifunctor (first)+import Data.Char (digitToInt, isDigit)+import Data.Coerce (coerce)+import Data.List qualified as List+import Data.Proxy (Proxy (..))+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import Prelude hiding (Monoid (..), curry, id, (.))++import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), Strictly (..), SymMonoidal (..), Tensor)+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..))+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Hypergraph+  ( ExpHG+  , Frobenius+  , Hypergraph+  , applyHG+  , cap+  , cup+  , curryHG+  , dualHG+  , linDistHG+  , linDistInvHG+  )+import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomous (..))+import Proarrow.Category.Monoidal.Strength (Costrong (..))+import Proarrow.Category.Monoidal.Strictified (IsList (..), SList (..), type (++))+import Proarrow.Core (CAT, CategoryOf (..), Is, Kind, Profunctor (..), Promonad (..), UN, dimapDefault)+import Proarrow.Monoid (CocommutativeComonoid, CommutativeMonoid, Comonoid (..), Monoid (..))++type Port = String -- Basically a shown int, but may contain an additional direction (:n, :e, :s, :w)++newtype Vec as x = Vec {unVec :: [x]}+  deriving newtype (Show, Eq, Foldable, Functor)+instance Traversable (Vec as) where+  traverse f (Vec xs) = fmap Vec (traverse f xs)+newtype Fin as = Fin {unFin :: Int}+  deriving newtype (Show, Eq, Num)+(!) :: Vec as x -> Fin as -> x+Vec xs ! Fin i = xs !! i++(+++) :: Vec as x -> Vec bs x -> Vec (as ++ bs) x+Vec xs +++ Vec ys = Vec (xs ++ ys)++split :: (IsList as) => Vec (as ++ bs) x -> (Vec as x, Vec bs x)+split @as (Vec xs) = case splitAt (len @as) xs of (as, bs) -> (Vec as, Vec bs)++len :: (IsList as) => Int+len @as = case sList @as of+  SNil -> 0+  SSing -> 1+  SCons @_ @bs -> 1 + len @bs++ixs :: (IsList as) => Vec as (Fin as)+ixs @as = case sList @as of+  SNil -> Vec []+  SSing -> Vec [0]+  SCons @_ @bs -> coerce (0 : fmap (+ 1) (unVec (ixs @bs)))++ixed :: (IsList as) => Vec as x -> Vec as (Fin as, x)+ixed (Vec []) = Vec []+ixed (Vec (x : xs)) = Vec $ (0, x) : fmap (\(i, y) -> (i + 1, y)) (unVec (ixed (Vec xs)))++zipV3 :: Vec as x -> Vec as y -> Vec as z -> Vec as (x, y, z)+zipV3 (Vec xs) (Vec ys) (Vec zs) = Vec (zip3 xs ys zs)++relax :: forall bs as. Fin as -> Fin (as ++ bs)+relax (Fin i) = Fin i++shift :: forall as bs. (IsList as) => Fin bs -> Fin (as ++ bs)+shift (Fin i) = Fin (len @as + i)++eitherF :: forall as bs r. (IsList as) => (Fin as -> r) -> (Fin bs -> r) -> Fin (as ++ bs) -> r+eitherF f g (Fin i)+  | i < len @as = f (Fin i)+  | otherwise = g (Fin (i - len @as))++names :: (IsList (as :: [Symbol])) => Vec as String+names @as = case sList @as of+  SNil -> Vec []+  SSing @s -> Vec [symbolVal (Proxy @s)]+  SCons @s @ss -> Vec (symbolVal (Proxy @s) : unVec (names @ss))++type SymRefl :: CAT Symbol+data SymRefl a b where+  SymRefl :: (KnownSymbol s) => SymRefl s s+instance Eq (SymRefl a b) where+  SymRefl == SymRefl = True+instance Show (SymRefl a b) where+  show SymRefl = "SymRefl"+instance Profunctor SymRefl where+  dimap = dimapDefault+  r \\ SymRefl = r+instance Promonad SymRefl where+  id = SymRefl+  SymRefl . SymRefl = SymRefl++-- | The discrete category on type-level 'Symbol's, labelling the wires of a string diagram.+instance CategoryOf Symbol where+  type (~>) = SymRefl+  type Ob s = KnownSymbol s++type DOT :: Kind+type data DOT = D [Symbol]++data DotData as bs = DotData+  { inputs :: Vec as (Either (Fin bs) Port)+  , outputs :: Vec bs (Either (Fin as) Port)+  , edges :: [(Port, String, Port)]+  , nodes :: [(NodeKind, String)]+  -- ^ what each node means, and its Graphviz options+  }+  deriving (Show, Eq)++-- | What a node means, as opposed to how it is drawn.+data NodeKind+  = -- | all its wires carry the same value: a (co)monoid point, a cup or a cap+    Spider+  | -- | 'swapNode'+    Crossing+  | -- | a generator, 'node'+    Box+  deriving (Show, Eq, Ord)++type Dot :: CAT DOT+data Dot a b where+  Dot :: (IsList as, IsList bs) => (Int -> (Int, DotData as bs)) -> Dot (D as) (D bs)++instance Show (Dot a b) where+  show (Dot f) = show (getData (Dot f))++instance Profunctor Dot where+  dimap = dimapDefault+  r \\ Dot{} = r+instance Promonad Dot where+  id @(D as) =+    Dot+      (,DotData+          { inputs = fmap Left (ixs @as)+          , outputs = fmap Left (ixs @as)+          , edges = []+          , nodes = []+          })+  Dot @bs l . Dot r = Dot \i ->+    let (k, DotData li lo le ln) = l j; (j, DotData ri ro re rn) = r i+    in ( k+       , DotData+           { inputs = fmap (either (li !) Right) ri+           , outputs = fmap (either (ro !) Right) lo+           , edges = re ++ foldMap (\case (Right n1, n, Right n2) -> [(n1, n, n2)]; _ -> []) (zipV3 ro (names @bs) li) ++ le+           , nodes = rn ++ ln+           }+       )++-- | The category string diagrams are built in: an object @'D' ws@ is the list of wire labels+-- along a boundary, and an arrow accumulates the Graphviz data connecting its input wires to its+-- output wires.+instance CategoryOf DOT where+  type (~>) = Dot+  type Ob a = (Is D a, IsList (UN D a))++instance MonoidalProfunctor Dot where+  one = Dot (,DotData (Vec []) (Vec []) [] [])+  Dot @lis @los l ** Dot @ris @ros r = withIsList2 @lis @ris $ withIsList2 @los @ros $ Dot \i ->+    let (j, DotData li lo le ln) = l i; (k, DotData ri ro re rn) = r j+    in ( k+       , DotData+           { inputs = fmap (first (relax @ros)) li +++ fmap (first (shift @los)) ri+           , outputs = fmap (first (relax @ris)) lo +++ fmap (first (shift @lis)) ro+           , edges = le ++ re+           , nodes = ln ++ rn+           }+       )+instance Monoidal DOT where+  type Unit = D '[]+  type ls ** rs = D (UN D ls ++ UN D rs)+  withOb2 @(D ls) @(D rs) r = withIsList2 @ls @rs r+  associator @as @bs @cs = associatorDefault @as @bs @cs+  associatorInv @as @bs @cs = associatorDefault @as @bs @cs+instance SymMonoidal DOT where+  swap @(D as) @(D bs) =+    withIsList2 @as @bs $+      withIsList2 @bs @as $+        Dot \n ->+          let as = ixs @as; bs = ixs @bs+          in ( n+             , DotData+                 { inputs = fmap Left (fmap (shift @bs) as +++ fmap (relax @as) bs)+                 , outputs = fmap Left (fmap (shift @as) bs +++ fmap (relax @bs) as)+                 , edges = []+                 , nodes = []+                 }+             )++-- | One point node for each wire of @as@. @inAt@ and @outAt@ say which wire's node each input and+-- output is attached to, and at which port. Drawing the (co)monoid on several wires as a single+-- point would not say which output continues which input.+pointsPerWire+  :: forall (as :: [Symbol]) xs ys+   . (IsList as, IsList xs, IsList ys)+  => (Fin xs -> (Int, String))+  -> (Fin ys -> (Int, String))+  -> String+  -> Dot (D xs) (D ys)+pointsPerWire inAt outAt opts = Dot \n ->+  let at :: forall zs ws. (Fin zs -> (Int, String)) -> Fin zs -> Either (Fin ws) Port+      at f i = let (w, port) = f i in Right (show (n + w) ++ port)+  in ( n + len @as+     , DotData+         { inputs = fmap (at inAt) (ixs @xs)+         , outputs = fmap (at outAt) (ixs @ys)+         , edges = []+         , nodes = replicate (len @as) (Spider, opts)+         }+     )++-- | Attaches at the given port of wire @i@'s point.+wireAt :: String -> Fin as -> (Int, String)+wireAt port (Fin i) = (i, port)++-- | Attaches wire @i@ of either copy in @as ++ as@ to wire @i@'s point, the first copy at the+-- first port and the second at the second.+eitherCopy :: forall (as :: [Symbol]). (IsList as) => String -> String -> Fin (as ++ as) -> (Int, String)+eitherCopy l r = eitherF @as @as (wireAt l) (wireAt r)++instance (Ob as) => Monoid (D as) where+  mempty = pointsPerWire @as (wireAt "") (wireAt ":s") "shape=point; width=0.07; fillcolor=white"+  mappend =+    withIsList2 @as @as $+      pointsPerWire @as (eitherCopy @as ":nw" ":ne") (wireAt ":s") "shape=point; width=0.07; fillcolor=white"+instance (Ob as) => Comonoid (D as) where+  counit = pointsPerWire @as (wireAt ":n") (wireAt "") "shape=point; width=0.07"+  comult =+    withIsList2 @as @as $+      pointsPerWire @as (wireAt ":n") (eitherCopy @as ":sw" ":se") "shape=point; width=0.07"+instance (Ob as) => CocommutativeComonoid (D as)+instance (Ob as) => CommutativeMonoid (D as)++-- | The points are spiders: on each wire, merging and copying are the special commutative+-- Frobenius structure.+instance (Ob as) => Frobenius (D as)++instance CopyDiscard DOT++-- | The points make every object a special commutative Frobenius object, so a diagram's wires can+-- be bent: each object is its own dual, with cups and caps drawn as a copy or merge point next to+-- a unit or counit point.+instance Hypergraph DOT++instance Closed DOT where+  type a ~~> b = ExpHG a b+  withObExp @a @b r = withOb2 @DOT @a @b r+  curry @a @b = curryHG @a @b+  apply @b @c = applyHG @b @c++instance StarAutonomous DOT where+  type Dual a = a+  withObDual r = r+  dual = dualHG+  dualInv = dualHG+  linDist @a @b @c = linDistHG @a @b @c+  linDistInv @a @b @c = linDistInvHG @a @b @c+  doubleNeg = id+  doubleNegInv = id++instance CompactClosed DOT where+  distribDual @a @b = withOb2 @DOT @a @b id+  dualUnit = id+  dualityUnit @a = cup @a+  dualityCounit @a = cap @a+instance Costrong Tensor Dot where+  coact @(D as) @(D xs) @(D ys) (Dot f) = Dot \n ->+    case f n of+      (n', DotData is os es ns) ->+        let+          inps = fmap fromI is+          outs = fmap fromO os+          (ais, xs) = split @as @xs inps+          (aos, ys) = split @as @ys outs+          fromI = either (eitherF @as @ys (ais !) Left) Right+          fromO = either (eitherF @as @xs (aos !) Left) Right+        in+          ( n'+          , DotData+              { inputs = xs+              , outputs = ys+              , edges =+                  es+                    ++ foldMap (\case (Right n1, nm, Right n2) -> [feedback n1 nm n2]; _ -> []) (zipV3 aos (names @as) ais)+              , nodes = ns+              }+          )++-- | A fed-back wire. One that returns to the node it leaves is attached at corners of its ports, so+-- that Graphviz draws the loop beside the node and not across it; one between two nodes attaches+-- as any other wire does.+feedback :: Port -> String -> Port -> (Port, String, Port)+feedback from nm to+  | nodeOf from == nodeOf to = (bend ":sw" from, nm, bend ":nw" to)+  | otherwise = (from, nm, to)++-- | A port with the side it is drawn at replaced by the given corner.+bend :: String -> Port -> Port+bend corner p = case break (== ':') (reverse p) of+  (side, ':' : rest) | reverse side `elem` (["n", "ne", "e", "se", "s", "sw", "w", "nw", "c"] :: [String]) -> reverse rest ++ corner+  _ -> p ++ corner++swap2 :: (Ob a, Ob b) => Dot (D [a, b]) (D [b, a])+swap2 @a @b = swap @_ @(D '[a]) @(D '[b])++-- | A crossing drawn through an invisible node, which pins the crossing point. A plain 'swap'+-- also renders as a crossing, since 'run' fixes the order of the boundary wires and 'node' the+-- order of its ports, but Graphviz is then free to place it.+swapNode :: (Ob a, Ob b) => Dot (D [a, b]) (D [b, a])+swapNode @a @b =+  node' @[a, b] @[b, a]+    Crossing+    (Vec [":nw", ":ne"])+    (Vec [":sw", ":se"])+    "shape=point; style=invis; height=0; width=0"++node' :: (IsList as, IsList bs) => NodeKind -> Vec as String -> Vec bs String -> String -> Dot (D as) (D bs)+node' @as @bs k as bs s = Dot \n ->+  ( n + 1+  , DotData+      { inputs = fmap (\i -> Right (show n ++ (as ! i))) (ixs @as)+      , outputs = fmap (\i -> Right (show n ++ (bs ! i))) (ixs @bs)+      , edges = []+      , nodes = [(k, s)]+      }+  )++-- | A node with the given name, with a port for each input along the top and each output along+-- the bottom, in order, so that Graphviz draws the wires into it in order.+node :: forall as bs. (IsList as, IsList bs) => String -> Dot (D as) (D bs)+node s =+  node'+    Box+    (fmap (\(Fin i) -> ":i" ++ show i ++ ":n") (ixs @as))+    (fmap (\(Fin j) -> ":o" ++ show j ++ ":s") (ixs @bs))+    (portedLabel (len @as) (len @bs) s)++-- | An HTML-like label drawing the node as a rounded box: the name in the middle, with a row of+-- empty cells along the top edge for the inputs and along the bottom edge for the outputs, named+-- by the ports 'node' attaches the wires to. The wires end at the box's edge.+portedLabel :: Int -> Int -> String -> String+portedLabel ins outs s =+  "shape=plain; label=<<table border=\"1\" style=\"rounded\" cellborder=\"0\" cellspacing=\"0\" cellpadding=\"0\">"+    ++ "<tr><td>"+    ++ ports "i" ins+    ++ "</td></tr><tr><td cellpadding=\"2\">"+    ++ htmlEscape s+    ++ "</td></tr><tr><td>"+    ++ ports "o" outs+    ++ "</td></tr></table>>"+  where+    ports :: String -> Int -> String+    ports port n =+      "<table border=\"0\" cellborder=\"0\" cellspacing=\"0\" cellpadding=\"0\"><tr>"+        ++ "<td width=\"6\" height=\"6\"></td>"+        ++ List.intercalate+          "<td width=\"4\"></td>"+          ["<td port=\"" ++ port ++ show i ++ "\" width=\"10\"></td>" | i <- [0 .. n - 1 :: Int]]+        ++ "<td width=\"6\"></td></tr></table>"++-- | The nodes in the order they are reached from the inputs, going along the wires, followed by+-- any that no input reaches.+nodeOrder :: [Either x Port] -> [(Port, String, Port)] -> Int -> [Int]+nodeOrder ins es count = reached ++ [n | n <- [0 .. count - 1], n `notElem` reached]+  where+    reached = go [] [nodeOf p | Right p <- ins]+    go seen [] = reverse seen+    go seen (n : queue)+      | n `elem` seen = go seen queue+      | otherwise = go (n : seen) (queue ++ [nodeOf q | (p, _, q) <- es, nodeOf p == n])++-- | The node a port belongs to.+nodeOf :: Port -> Int+nodeOf = List.foldl' (\n c -> n * 10 + digitToInt c) 0 . takeWhile isDigit++-- | A port without its node and without the side it is drawn at (@3:o0:s@ is @:o0@); a port that+-- is only a side keeps it (@3:nw@ is @:nw@).+portOf :: Port -> String+portOf p = case break (== ':') (drop 1 (dropWhile isDigit p)) of+  (name, ':' : _) -> ':' : name+  _ -> dropWhile isDigit p++htmlEscape :: String -> String+htmlEscape = foldMap (\case '<' -> "&lt;"; '>' -> "&gt;"; '&' -> "&amp;"; c -> [c])++line :: (Ob a) => Dot (D '[a]) (D '[a])+line = id++getData :: Dot (D as) (D bs) -> DotData as bs+getData (Dot f) = snd (f 0)++run :: Dot (D as) (D bs) -> String+run @as @bs d@Dot{} =+  header+    ++ statements d+    -- the inputs at the top and the outputs at the bottom+    ++ onRank "source" "i" (len @as)+    ++ onRank "sink" "o" (len @bs)+    ++ "\n}\n"++-- | A boundary node on the given rank, when its boundary has any wires.+onRank :: String -> String -> Int -> String+onRank rank n wires = if wires == 0 then "" else "\n  { rank=" ++ rank ++ "; " ++ n ++ "; }"++-- | The start of a Graphviz graph, with the fonts and wire style of every diagram.+header :: String+header =+  "digraph G { ranksep=0.3; node [fontname=\"Times-Italic\"; shape=circle; margin=0]; edge [fontname=\"Times-Italic\"; dir=none];"++-- | The statements drawing a diagram. Each boundary is one node, @i@ or @o@, with a port per+-- wire, so that Graphviz keeps the wires in order, and is left out when it has no wires.+statements :: Dot (D as) (D bs) -> String+statements @as @bs (Dot f) =+  let (_, DotData is os es ns) = f 0+      ins = unVec (names @as)+      outs = unVec (names @bs)+  in boundary "i" ins+       ++ boundary "o" outs+       -- node configuration, in the order the nodes are reached from the inputs: Graphviz breaks+       -- the cycles of a trace by searching in the order nodes are listed, so this makes the wires+       -- run forward from the first input+       ++ foldMap (\i -> "\n  " ++ show i ++ " [" ++ snd (ns !! i) ++ "];") (nodeOrder (unVec is) es (length ns))+       -- edges from inputs+       ++ foldMap+         (\(i, n) -> "\n  i:p" ++ show i ++ ":s -> " ++ either (\j -> "o:p" ++ show j ++ ":n") id n ++ ";")+         (ixed is)+       -- edges from outputs+       ++ foldMap (\(i, n) -> either (const "") (\n' -> "\n  " ++ n' ++ " -> o:p" ++ show i ++ ":n;") n) (ixed os)+       -- internal edges+       ++ foldMap (\(i, s, j) -> "\n  " ++ i ++ " -> " ++ j ++ " [label=\"" ++ s ++ "\"];") es+  where+    boundary name ws+      | null ws = ""+      | otherwise =+          "\n  "+            ++ name+            ++ " [shape=plain; label=<<table border=\"0\" cellborder=\"0\" cellspacing=\"8\" cellpadding=\"0\"><tr>"+            ++ foldMap (\(i, n) -> "<td port=\"p" ++ show i ++ "\" width=\"24\">" ++ htmlEscape n ++ "</td>") (zip [0 :: Int ..] ws)+            ++ "</tr></table>>];"++unitAdj :: (Ob l, Ob r) => Dot (D '[]) (D '[l, r])+unitAdj = node' Box (Vec []) (Vec [":sw", ":se"]) "label=η"++counitAdj :: (Ob l, Ob r) => Dot (D '[r, l]) (D '[])+counitAdj = node' Box (Vec [":nw", ":ne"]) (Vec []) "label=ϵ"
+ src/Proarrow/Tools/Diagrams/Svg.hs view
@@ -0,0 +1,1364 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE NoOverloadedLists #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | String diagrams drawn as SVG. 'Svg' is the category of diagrams of+-- "Proarrow.Tools.Diagrams.Dot", with the same meaning, but a diagram is laid out from how it is+-- built instead of by Graphviz: a tensor puts its two sides next to each other, a composite stacks+-- them with a band of curved wires in between, and a trace draws its loops around the side. Every+-- coordinate is computed here, so every choice can be tweaked.+--+-- Unlike 'DOT', 'SVG' is not strict about its unit: the unit is a wire of its own, 'I', so the+-- unitors are arrows that can be drawn, a dotted wire ending on or leaving another wire. With+-- 'explicitCoherence' off, unit wires take up no room and are not drawn at all.+--+-- Nor is 'SVG' self-dual on the nose: the dual of a wire @'Wire' s@ is the wire @'Co' s@, shown+-- with a superscript ⁻¹ and drawn as a hollow line. The arrows between a wire and its dual only+-- relabel.+--+-- Both are only drawn: an arrow means the 'Dot' diagram on the wires with the unit wires left out+-- and the duals forgotten ('Erase').+module Proarrow.Tools.Diagrams.Svg where++import Data.Functor.Identity (Identity (..))+import Data.Kind (Constraint)+import Data.List qualified as List+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NE+import Data.Maybe (fromMaybe)+import Data.Proxy (Proxy (..))+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import Numeric (showFFloat)+import Prelude hiding (Monoid (..), curry, id, (**), (.))++import Proarrow.Category.Instance.Free (All)+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..), Tensor)+import Proarrow.Category.Monoidal qualified as M+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..))+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Hypergraph (Frobenius, Hypergraph, cap, cup)+import Proarrow.Category.Monoidal.StarAutonomous (ExpSA, StarAutonomous (..), applySA, currySA, expSA)+import Proarrow.Category.Monoidal.Strength (Costrong (..))+import Proarrow.Category.Monoidal.Strictified+  ( IsList (..)+  , SList (..)+  , Strictified (..)+  , obj1+  , singleton+  , swap2+  , type (++)+  )+import Proarrow.Core (CAT, CategoryOf (..), Is, Kind, Profunctor (..), Promonad (..), UN, dimapDefault, obj, type (+->))+import Proarrow.Monoid (CocommutativeComonoid, CommutativeMonoid, Comonoid (..), Monoid (..))+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Tools.Diagrams.Dot (DOT, Dot)+import Proarrow.Tools.Diagrams.Dot qualified as Dot+import Proarrow.Tools.Laws+  ( Labelled (..)+  , Law (..)+  , Laws (..)+  , ProEquation (..)+  , ProLaw (..)+  , ProLaws (..)+  , lawName+  , proLawName+  , withSides+  )++-- * Wires++-- | A wire: a labelled wire, the dual of one, or the unit wire.+type W :: Kind+type data W = Wire Symbol | Co Symbol | I++-- | The dual of a wire. The unit wire is its own dual.+type DualW :: W -> W+type family DualW w where+  DualW (Wire s) = Co s+  DualW (Co s) = Wire s+  DualW I = I++-- | The duals of the wires.+type DualList :: [W] -> [W]+type family DualList ws where+  DualList '[] = '[]+  DualList (w ': ws) = DualW w ': DualList ws++-- | The labels of the wires that carry something: the unit wires left out, and a dual wire+-- labelled as the wire it is the dual of.+type Erase :: [W] -> [Symbol]+type family Erase ws where+  Erase '[] = '[]+  Erase (Wire s ': ws) = s ': Erase ws+  Erase (Co s ': ws) = s ': Erase ws+  Erase (I ': ws) = Erase ws++-- | A wire whose label is known. The methods are facts about 'DualW' and 'Erase' that hold for+-- each kind of wire, from which 'withIsListDual', 'withIsListErase', 'withEraseAppend',+-- 'withDualDual' and 'withEraseDual' prove them for lists by induction.+type KnownWire :: W -> Constraint+class KnownWire w where+  -- | The label of the wire as it is shown, and its kind.+  wireInfo :: (String, WireKind)++  withKnownDualW :: ((KnownWire (DualW w)) => r) -> r+  withIsListEraseCons :: forall (ws :: [W]) r. (IsList (Erase ws)) => ((IsList (Erase (w ': ws))) => r) -> r+  withEraseAppendCons+    :: forall (as :: [W]) (bs :: [W]) r+     . (Erase (as ++ bs) ~ (Erase as ++ Erase bs))+    => ((Erase (w ': (as ++ bs)) ~ (Erase (w ': as) ++ Erase bs)) => r)+    -> r+  withDualDualW :: ((DualW (DualW w) ~ w) => r) -> r+  withEraseDualCons+    :: forall (ws :: [W]) r. (Erase (DualList ws) ~ Erase ws) => ((Erase (DualList (w ': ws)) ~ Erase (w ': ws)) => r) -> r++instance (KnownSymbol s) => KnownWire (Wire s) where+  wireInfo = (symbolVal (Proxy @s), Plain)+  withKnownDualW r = r+  withIsListEraseCons @ws r = withIsList2 @'[s] @(Erase ws) r+  withEraseAppendCons r = r+  withDualDualW r = r+  withEraseDualCons r = r++instance (KnownSymbol s) => KnownWire (Co s) where+  wireInfo = (symbolVal (Proxy @s) ++ "⁻¹", DualWire)+  withKnownDualW r = r+  withIsListEraseCons @ws r = withIsList2 @'[s] @(Erase ws) r+  withEraseAppendCons r = r+  withDualDualW r = r+  withEraseDualCons r = r++instance KnownWire I where+  wireInfo = ("𝐈", UnitWire)+  withKnownDualW r = r+  withIsListEraseCons r = r+  withEraseAppendCons r = r+  withDualDualW r = r+  withEraseDualCons r = r++type WireId :: CAT W+data WireId a b where+  WireId :: (KnownWire w) => WireId w w+instance Profunctor WireId where+  dimap = dimapDefault+  r \\ WireId = r+instance Promonad WireId where+  id = WireId+  WireId . WireId = WireId++-- | The discrete category on wires, so that lists of wires are objects of 'Strictified'.+instance CategoryOf W where+  type (~>) = WireId+  type Ob w = KnownWire w++-- | The duals of a list of wires are a list of wires.+withIsListDual :: forall (ws :: [W]) r. (IsList ws) => ((IsList (DualList ws)) => r) -> r+withIsListDual r =+  listCase @ws+    r+    (\ @w -> withKnownDualW @w r)+    (\ @b @bs @c @cs -> withKnownDualW @b (withKnownDualW @c (withIsListDual @cs (withIsListDual @bs r))))++-- | The erased wires of a list of wires are a list of labels.+withIsListErase :: forall (ws :: [W]) r. (IsList ws) => ((IsList (Erase ws)) => r) -> r+withIsListErase r =+  listCase @ws+    r+    (\ @w -> withIsListEraseCons @w @'[] r)+    (\ @w @ws' -> withIsListErase @ws' (withIsListEraseCons @w @ws' r))++-- | Erasing commutes with appending.+withEraseAppend+  :: forall (as :: [W]) (bs :: [W]) r. (IsList as) => ((Erase (as ++ bs) ~ (Erase as ++ Erase bs)) => r) -> r+withEraseAppend r =+  listCase @as+    r+    (\ @w -> withEraseAppendCons @w @'[] @bs r)+    (\ @w @as' -> withEraseAppend @as' @bs (withEraseAppendCons @w @as' @bs r))++-- | Dualising twice gives the wires back.+withDualDual :: forall (ws :: [W]) r. (IsList ws) => ((DualList (DualList ws) ~ ws) => r) -> r+withDualDual r =+  listCase @ws+    r+    (\ @w -> withDualDualW @w r)+    (\ @w @ws' -> withDualDual @ws' (withDualDualW @w r))++-- | Dualising commutes with appending.+withDualAppend+  :: forall (as :: [W]) (bs :: [W]) r. (IsList as) => ((DualList (as ++ bs) ~ (DualList as ++ DualList bs)) => r) -> r+withDualAppend r = listCase @as r r (\ @_ @as' -> withDualAppend @as' @bs r)++-- | The duals of wires erase to the same labels as the wires.+withEraseDual :: forall (ws :: [W]) r. (IsList ws) => ((Erase (DualList ws) ~ Erase ws) => r) -> r+withEraseDual r =+  listCase @ws+    r+    (\ @w -> withEraseDualCons @w @'[] r)+    (\ @w @ws' -> withEraseDual @ws' (withEraseDualCons @w @ws' r))++-- | The labels of the wires of @ws@ as they are shown, and their kinds.+wires :: forall (ws :: [W]). (IsList ws) => [(String, WireKind)]+wires = case sList @ws of+  SNil -> []+  SSing @w -> [wireInfo @w]+  SCons @w @ws' -> wireInfo @w : wires @ws'++wireKinds :: forall (ws :: [W]). (IsList ws) => [WireKind]+wireKinds = map snd (wires @ws)++-- * The category++type SVG :: Kind+type data SVG = S [W]++-- | A diagram: its meaning, as a 'Dot' diagram on the erased wires, and how it was built, which+-- is drawn when it is rendered.+type Svg :: CAT SVG+data Svg a b where+  Svg :: (IsList as, IsList bs) => Dot (Dot.D (Erase as)) (Dot.D (Erase bs)) -> Diagram -> Svg (S as) (S bs)++-- | A diagram from its meaning, which may use that the erased wires are lists, and how it is+-- drawn.+svg+  :: forall (as :: [W]) (bs :: [W])+   . (IsList as, IsList bs)+  => ((IsList (Erase as), IsList (Erase bs)) => Dot (Dot.D (Erase as)) (Dot.D (Erase bs)))+  -> Diagram+  -> Svg (S as) (S bs)+svg d = withIsListErase @as (withIsListErase @bs (Svg d))++-- | A diagram that means the identity on the erased wires, drawn as given.+drawnAs :: forall (as :: [W]) (bs :: [W]). (IsList as, IsList bs, Erase as ~ Erase bs) => Diagram -> Svg (S as) (S bs)+drawnAs = svg @as @bs (obj @(Dot.D (Erase as)))++-- | An arrow between wires that erase to the same labels, a wire and its dual for example: in+-- meaning the identity. It is drawn as nothing, the wires carrying on in the style of their new+-- kinds.+relabel :: forall (a :: SVG) (b :: SVG). (Ob a, Ob b, Erase (UN S a) ~ Erase (UN S b)) => a ~> b+relabel = drawnAs (Straight (wireKinds @(UN S a)) (wireKinds @(UN S b)))++-- | Choices about what to draw.+data Options = Options+  { explicitIdentities :: Bool+  -- ^ draw each identity, 'line' included, as a wire in a dashed frame; otherwise an identity is+  -- not drawn at all+  , explicitCoherence :: Bool+  -- ^ draw the unit wires dotted, the unitors as a unit wire running into another wire or out of+  -- it, and the associators with brackets for the groupings they go between; otherwise none of+  -- these are drawn, and unit wires take up no room+  , explicitSwaps :: Bool+  -- ^ draw each 'swap' as a crossing of its own; otherwise its crossing is drawn in the band+  -- where the wires next change position+  , fixedSpiders :: Bool+  -- ^ keep the two legs of a copy or merge point in the order they are listed; otherwise they+  -- may trade places to avoid a crossing, which the points being commutative allows+  }+  deriving (Show)++-- | Nothing drawn that the meaning does not need, legs in order.+defaultOptions :: Options+defaultOptions = Options{explicitIdentities = False, explicitCoherence = False, explicitSwaps = False, fixedSpiders = True}++-- | The meaning of a diagram, forgetting how it is drawn.+meaningOf :: Svg (S as) (S bs) -> Dot (Dot.D (Erase as)) (Dot.D (Erase bs))+meaningOf (Svg d _) = d++instance Show (Svg a b) where+  show (Svg d _) = show d++instance Profunctor Svg where+  lmap l f = f . l+  rmap r f = r . f+  r \\ Svg{} = r+instance Promonad Svg where+  id @(S as) = drawnAs @as @as (Ident (wireKinds @as))+  Svg f l . Svg g m = Svg (f . g) (Seq m l)++-- | The category string diagrams are drawn in: an object @'S' ws@ is the list of wires along a+-- boundary.+instance CategoryOf SVG where+  type (~>) = Svg+  type Ob a = (Is S a, IsList (UN S a))++instance MonoidalProfunctor Svg where+  one = drawnAs (Ident [UnitWire])+  Svg @lis @los f l ** Svg @ris @ros g m =+    withIsList2 @lis @ris $+      withIsList2 @los @ros $+        withEraseAppend @lis @ris $+          withEraseAppend @los @ros $+            Svg (f ** g) (Beside l m)++-- | The unit is the unit wire, and the unitors absorb or create it.+instance Monoidal SVG where+  type Unit = S '[I]+  type ls ** rs = S (UN S ls ++ UN S rs)+  withOb2 @(S ls) @(S rs) r = withIsList2 @ls @rs r+  leftUnitor @(S as) = withIsList2 @'[I] @as $ drawnAs (Unitor OnLeft Absorb (wireKinds @as))+  leftUnitorInv @(S as) = withIsList2 @'[I] @as $ drawnAs (Unitor OnLeft Create (wireKinds @as))+  rightUnitor @(S as) = withRightUnit @as $ drawnAs (Unitor OnRight Absorb (wireKinds @as))+  rightUnitorInv @(S as) = withRightUnit @as $ drawnAs (Unitor OnRight Create (wireKinds @as))+  associator @(S as) @(S bs) @(S cs) = rebracketed @as @bs @cs LeftFirst+  associatorInv @(S as) @(S bs) @(S cs) = rebracketed @as @bs @cs RightFirst++-- | Wires with a unit wire on the right are a list, and erase to the same labels.+withRightUnit :: forall (as :: [W]) r. (IsList as) => ((IsList (as ++ '[I]), Erase (as ++ '[I]) ~ Erase as) => r) -> r+withRightUnit r = withIsList2 @as @'[I] $ withEraseAppend @as @'[I] $ withIsListErase @as r++-- | An associator, from the given grouping to the other one.+rebracketed+  :: forall (as :: [W]) (bs :: [W]) (cs :: [W])+   . (IsList as, IsList bs, IsList cs)+  => Grouping+  -> Svg (S (as ++ (bs ++ cs))) (S (as ++ (bs ++ cs)))+rebracketed g =+  withIsList2 @bs @cs $+    withIsList2 @as @(bs ++ cs) $+      drawnAs (Rebracket g (wireKinds @as) (wireKinds @bs) (wireKinds @cs))++instance SymMonoidal SVG where+  swap @(S as) @(S bs) =+    withIsList2 @as @bs $+      withIsList2 @bs @as $+        withEraseAppend @as @bs $+          withEraseAppend @bs @as $+            withIsListErase @as $+              withIsListErase @bs $+                svg (swap @DOT @(Dot.D (Erase as)) @(Dot.D (Erase bs))) $+                  Permute False (wireKinds @(as ++ bs)) ([Dot.len @as .. Dot.len @as + Dot.len @bs - 1] ++ [0 .. Dot.len @as - 1])++-- | The unit point takes the unit wire in, and the discard point gives it out.+instance (Ob as) => Monoid (S as) where+  mempty = svg (mempty @(Dot.D (Erase as))) (Seq UnitEnd (Points UnitPoint (wireKinds @as)))+  mappend = withIsList2 @as @as $ withEraseAppend @as @as $ svg (mappend @(Dot.D (Erase as))) (Points MergePoint (wireKinds @as))++instance (Ob as) => Comonoid (S as) where+  counit = svg (counit @(Dot.D (Erase as))) (Seq (Points DiscardPoint (wireKinds @as)) UnitStart)+  comult = withIsList2 @as @as $ withEraseAppend @as @as $ svg (comult @(Dot.D (Erase as))) (Points CopyPoint (wireKinds @as))+instance (Ob as) => CocommutativeComonoid (S as)+instance (Ob as) => CommutativeMonoid (S as)+instance (Ob as) => Frobenius (S as)+instance CopyDiscard SVG+instance Hypergraph SVG++-- | The exponential is the *-autonomous one, @'Dual' (a '**' 'Dual' b)@, so curried wires show as+-- duals.+instance Closed SVG where+  type a ~~> b = ExpSA a b+  withObExp @a @b r = withObDual @SVG @b $ withOb2 @SVG @a @(Dual b) $ withObDual @SVG @(a ** Dual b) r+  curry @a @b @c = currySA @a @b @c+  apply @b @c = applySA @b @c+  (^^^) = expSA++-- | The dual of a wire is its 'Co' wire. Duals come from 'dualCup' and 'dualCap', which mean a cup+-- or cap and are drawn as a bend, so a dual wire is drawn hollow wherever it runs.+instance StarAutonomous SVG where+  type Dual a = S (DualList (UN S a))+  withObDual @a r = withIsListDual @(UN S a) r+  dual @a @b f =+    ( withObDual @SVG @a $+        withObDual @SVG @b $+          unStr @'[Dual b] @'[Dual a] $+            obj1 ** dualCupS @a+              M.== obj1 ** singleton f ** obj1+              M.== dualCapS @b ** obj1+    )+      \\ f+  dualInv @a @b g =+    withObDual @SVG @a $+      withObDual @SVG @b $+        unStr @'[b] @'[a] $+          dualCupS @a ** obj1+            M.== obj1 ** singleton g ** obj1+            M.== obj1 ** dualCapS @b+  linDist @a @b @c f =+    withObDual @SVG @b $+      withObDual @SVG @c $+        withOb2 @SVG @b @c $+          withObDual @SVG @(b ** c) $+            withOb2 @SVG @(Dual b) @(Dual c) $+              withDualAppend @(UN S b) @(UN S c) $+                relabel @(Dual b ** Dual c) @(Dual (b ** c))+                  . unStr @'[a] @[Dual b, Dual c]+                    ( obj1 ** dualCupS @b+                        M.== Str @[a, b] @'[Dual c] f ** obj1+                        M.== swap2+                    )+  linDistInv @a @b @c g =+    withObDual @SVG @b $+      withObDual @SVG @c $+        withOb2 @SVG @b @c $+          withObDual @SVG @(b ** c) $+            withOb2 @SVG @(Dual b) @(Dual c) $+              withDualAppend @(UN S b) @(UN S c) $+                unStr @[a, b] @'[Dual c] $+                  Str @'[a] @[Dual b, Dual c] (relabel @(Dual (b ** c)) @(Dual b ** Dual c) . g) ** obj1+                    M.== obj1 ** swap2+                    M.== dualCapS @b ** obj1+  doubleNeg @a = withObDual @SVG @a $ withObDual @SVG @(Dual a) $ withDualDual @(UN S a) $ relabel @(Dual (Dual a)) @a+  doubleNegInv @a = withObDual @SVG @a $ withObDual @SVG @(Dual a) $ withDualDual @(UN S a) $ relabel @a @(Dual (Dual a))++-- | A wire bent upwards, @a@ on the left and its dual on the right. It means 'cup', and is drawn+-- as one bend that turns into the dual at its apex.+dualCup :: forall (a :: SVG). (Ob a) => Unit ~> a ** Dual a+dualCup = withObDual @SVG @a $+  withEraseDual @(UN S a) $+    withOb2 @SVG @a @a $+      withOb2 @SVG @a @(Dual a) $+        case (obj @a ** relabel @a @(Dual a)) . cup @a of+          Svg d _ -> Svg d (Seq UnitEnd (Bend Cup (wireKinds @(UN S a)) (wireKinds @(UN S (Dual a)))))++-- | A wire bent downwards, the dual of @a@ on the left and @a@ on the right. It means 'cap', and is+-- drawn as one bend that turns into the dual at its apex.+dualCap :: forall (a :: SVG). (Ob a) => Dual a ** a ~> Unit+dualCap = withObDual @SVG @a $+  withEraseDual @(UN S a) $+    withOb2 @SVG @a @a $+      withOb2 @SVG @(Dual a) @a $+        case cap @a . (relabel @(Dual a) @a ** obj @a) of+          Svg d _ -> Svg d (Seq (Bend Cap (wireKinds @(UN S a)) (wireKinds @(UN S (Dual a)))) UnitStart)++-- | 'dualCup' as a strictified arrow. The *-autonomous structure is built from it, not from the+-- compact closed 'dualityUnit', so that the laws relating the two compare different definitions.+dualCupS :: forall (a :: SVG). (Ob a) => '[] ~> [a, Dual a]+dualCupS = withObDual @SVG @a $ Str (dualCup @a)++-- | 'dualCap' as a strictified arrow.+dualCapS :: forall (a :: SVG). (Ob a) => [Dual a, a] ~> '[]+dualCapS = withObDual @SVG @a $ Str (dualCap @a)++instance CompactClosed SVG where+  distribDual @a @b =+    withOb2 @SVG @a @b $+      withObDual @SVG @a $+        withObDual @SVG @b $+          withObDual @SVG @(a ** b) $+            withOb2 @SVG @(Dual a) @(Dual b) $+              withDualAppend @(UN S a) @(UN S b) $+                relabel @(Dual (a ** b)) @(Dual a ** Dual b)+  dualUnit = relabel+  dualityUnit @a = dualCup @a+  dualityCounit @a = dualCap @a++-- | The traced wires loop round the side of the diagram they are nearest to.+instance Costrong Tensor Svg where+  coact @(S as) @(S xs) @(S ys) (Svg f l) =+    withEraseAppend @as @xs $+      withEraseAppend @as @ys $+        withIsListErase @as $+          svg (coact @Tensor @Dot @(Dot.D (Erase as)) @(Dot.D (Erase xs)) @(Dot.D (Erase ys)) f) (Trace (wireKinds @as) l)++-- | Derived operations are drawn as what they are made of.+instance Labelled SVG where+  label _ f = f++-- * Building diagrams++-- | A box with the given name, its inputs along the top and its outputs along the bottom, each+-- output labelled with its wire.+node :: forall (as :: [W]) (bs :: [W]). (IsList as, IsList bs) => String -> Svg (S as) (S bs)+node s = svg (Dot.node @(Erase as) @(Erase bs) s) (Node ArrowBox s (wireKinds @as) (wires @bs))++-- | A shaded box with the given name, for an element of a profunctor: in meaning a 'node'.+element :: forall (as :: [W]) (bs :: [W]). (IsList as, IsList bs) => String -> Svg (S as) (S bs)+element s = svg (Dot.node @(Erase as) @(Erase bs) s) (Node ElementBox s (wireKinds @as) (wires @bs))++-- | A wire, the identity on it.+line :: (KnownSymbol a) => Svg (S '[Wire a]) (S '[Wire a])+line = id++-- | A crossing of fixed height. A plain 'swap' is drawn as a crossing too, but in the band where+-- the wires next change position.+swapNode+  :: forall (a :: Symbol) (b :: Symbol). (KnownSymbol a, KnownSymbol b) => Svg (S [Wire a, Wire b]) (S [Wire b, Wire a])+swapNode = Svg (Dot.swapNode @a @b) (Permute True (wireKinds @[Wire a, Wire b]) [1, 0])++-- | The unit of an adjunction, drawn as a box named η.+unitAdj :: forall (l :: Symbol) (r :: Symbol). (KnownSymbol l, KnownSymbol r) => Svg (S '[]) (S '[Wire l, Wire r])+unitAdj = Svg (Dot.unitAdj @l @r) (Node ArrowBox "η" [] (wires @[Wire l, Wire r]))++-- | The counit of an adjunction, drawn as a box named ϵ.+counitAdj :: forall (l :: Symbol) (r :: Symbol). (KnownSymbol l, KnownSymbol r) => Svg (S '[Wire r, Wire l]) (S '[])+counitAdj = Svg (Dot.counitAdj @l @r) (Node ArrowBox "ϵ" (wireKinds @[Wire r, Wire l]) [])++-- | What kind of wire a wire is, which decides how it is drawn.+data WireKind = Plain | UnitWire | DualWire+  deriving (Eq, Show)++-- * Diagrams++-- | How a diagram was built. The options come in only when it is drawn: 'hideUnits' takes out what+-- 'explicitCoherence' would show, and 'layout' decides the rest.+data Diagram+  = -- | the identity on wires of the given kinds+    Ident [WireKind]+  | -- | wires of the given kinds, output @j@ continuing input @p !! j@; when the flag is set, its+    -- crossings are drawn on their own+    Permute Bool [WireKind] [Int]+  | -- | wires carrying straight on, as many out as in, possibly of other kinds+    Straight [WireKind] [WireKind]+  | -- | a box of the given kind with a name, the kinds of its inputs, and the labels and kinds of+    -- its outputs+    Node BoxKind String [WireKind] [(String, WireKind)]+  | -- | a point of the given kind on each wire+    Points PointKind [WireKind]+  | -- | bends joining each wire of the first kinds to its dual, of the second kinds+    Bend BendKind [WireKind] [WireKind]+  | -- | an associator from the given grouping, on three lists of wires+    Rebracket Grouping [WireKind] [WireKind] [WireKind]+  | -- | a unitor on wires of the given kinds+    Unitor Side Direction [WireKind]+  | -- | a unit wire ending+    UnitEnd+  | -- | a unit wire starting+    UnitStart+  | -- | the first diagram above the second+    Seq Diagram Diagram+  | -- | two diagrams side by side+    Beside Diagram Diagram+  | -- | the first inputs and outputs, of the given kinds, fed back+    Trace [WireKind] Diagram+  deriving (Show)++-- | What a box stands for: an arrow, drawn as an outline, or an element of a profunctor that a+-- profunctor law is about, drawn shaded.+data BoxKind = ArrowBox | ElementBox+  deriving (Eq, Show)++-- | The points a (co)monoid is drawn with.+data PointKind = UnitPoint | DiscardPoint | CopyPoint | MergePoint+  deriving (Show)++-- | Whether a bend opens downwards, a cup, or upwards, a cap.+data BendKind = Cup | Cap+  deriving (Show)++-- | Which pair an associator groups first: @(a ⊗ b) ⊗ c@ or @a ⊗ (b ⊗ c)@.+data Grouping = LeftFirst | RightFirst+  deriving (Show)++-- | Which side of the other wires a unit wire joins them.+data Side = OnLeft | OnRight+  deriving (Show)++-- | Whether a unitor ends a unit wire on another wire, or starts one from it.+data Direction = Absorb | Create+  deriving (Show)++-- | The diagram with its unit wires left out, and its unitors and associators turned into wires+-- carrying straight on.+hideUnits :: Diagram -> Diagram+hideUnits = \case+  Ident ks -> Ident (noUnits ks)+  Permute c ks p ->+    let kept = [i | (i, k) <- zip [0 :: Int ..] ks, k /= UnitWire]+        renumber i = fromMaybe 0 (List.elemIndex i kept)+    in Permute c (map (ks !!) kept) [renumber i | i <- p, ks !! i /= UnitWire]+  Straight ks ls -> Straight (noUnits ks) (noUnits ls)+  Node bk s ks os -> Node bk s (noUnits ks) [w | w@(_, k) <- os, k /= UnitWire]+  Points pk ks -> Points pk (noUnits ks)+  Bend b ka kd -> Bend b (noUnits ka) (noUnits kd)+  Rebracket _ ka kb kc -> straight (noUnits (ka ++ kb ++ kc))+  Unitor _ _ ks -> straight (noUnits ks)+  UnitEnd -> straight []+  UnitStart -> straight []+  Seq a b -> Seq (hideUnits a) (hideUnits b)+  Beside a b -> Beside (hideUnits a) (hideUnits b)+  Trace ks d -> Trace (noUnits ks) (hideUnits d)+  where+    straight ks = Straight ks ks++noUnits :: [WireKind] -> [WireKind]+noUnits = filter (/= UnitWire)++-- | The diagram laid out with the given options.+layout :: Options -> Diagram -> Layout+layout o = go . if explicitCoherence o then id else hideUnits+  where+    go = \case+      Ident ks -> identity (explicitIdentities o) ks+      Permute c ks p -> permutation (c || explicitSwaps o) ks p+      Straight ks ls -> Wiring [0 .. length ls - 1] ks ls+      Node bk s ks os -> Stage (nodeGeo bk ks os s)+      Points pk ks -> points (not (fixedSpiders o)) pk ks+      Bend b ka kd -> bend b ka kd+      Rebracket g ka kb kc -> Stage (rebracket g ka kb kc)+      Unitor s d ks -> Stage (unitor s d ks)+      UnitEnd -> Stage unitEnd+      UnitStart -> Stage (mirror unitEnd)+      Seq a b -> compose (go b) (go a)+      Beside a b -> tensor (go a) (go b)+      Trace ks d -> Stage (loops (length ks) (toGeo slot (go d)))++-- | The boundary wires that are drawn with the given options.+visible :: Options -> [(String, WireKind)] -> [(String, WireKind)]+visible o ws = [w | w@(_, k) <- ws, explicitCoherence o || k /= UnitWire]++-- * Layout++-- | A point in the plane, @y@ growing downwards.+type Pt = (Double, Double)++-- | The course of a piece of wire.+data Path+  = -- | straight from one point to another+    Line Pt Pt+  | -- | from one point down to another, leaving and arriving vertically+    Curve Pt Pt+  | -- | along the given corners, rounded+    Loop (NonEmpty Pt)+  | -- | a quarter of an ellipse, leaving the first point vertically and reaching the second+    -- horizontally: half of a bend+    Quarter Pt Pt+  deriving (Show)++-- | What a diagram is drawn with.+data Shape+  = -- | a piece of wire of the given kind: plain, dotted for a unit wire, hollow for a dual one+    Piece WireKind Path+  | -- | a box of the given kind between two corners, with a name+    Box BoxKind Pt Pt String+  | -- | the dashed frame of an identity, between two corners+    Frame Pt Pt+  | -- | a bracket grouping wires, from one point to another, its ends pointing down or up+    Bracket Pt Pt Bool+  | -- | a point on a wire, filled for a comonoid and hollow for a monoid+    Point Pt Bool+  | -- | the label of the wire leaving a box+    Label Pt String+  | -- | the label of a boundary wire, centred+    Boundary Pt String+  | -- | the equals sign of an equation+    Equals Pt+  deriving (Show)++-- | A shape moved right by @dx@ and down by @dy@.+move :: Double -> Double -> Shape -> Shape+move dx dy = \case+  Piece k (Line a b) -> Piece k (Line (at a) (at b))+  Piece k (Curve a b) -> Piece k (Curve (at a) (at b))+  Piece k (Loop ps) -> Piece k (Loop (fmap at ps))+  Piece k (Quarter a b) -> Piece k (Quarter (at a) (at b))+  Box bk a b s -> Box bk (at a) (at b) s+  Frame a b -> Frame (at a) (at b)+  Bracket a b down -> Bracket (at a) (at b) down+  Point a f -> Point (at a) f+  Label a s -> Label (at a) s+  Boundary a s -> Boundary (at a) s+  Equals a -> Equals (at a)+  where+    at (x, y) = (x + dx, y + dy)++-- | Where a wire enters a drawing along its top or leaves it along its bottom: how far along, the+-- kind of wire, and, for a leg of a copy or merge point that may trade places with the point's+-- other leg, which point it is a leg of.+data Port = Port {portX :: Double, portKind :: WireKind, portLegs :: Maybe Int}+  deriving (Show)++port :: Double -> WireKind -> Port+port x k = Port x k Nothing++-- | A port moved right by @dx@.+shiftPort :: Double -> Port -> Port+shiftPort dx p = p{portX = portX p + dx}++-- | A drawn diagram: its size, its input and output ports, and its shapes.+data Geo = Geo+  { geoWidth :: Double+  , geoHeight :: Double+  , geoIns :: [Port]+  , geoOuts :: [Port]+  , geoShapes :: [Shape]+  }+  deriving (Show)++-- | How a diagram is drawn. A diagram that only permutes its wires has no height of its own: its+-- crossings are drawn in the band where the wires next change position, so that a 'swap' next to+-- a box does not make the box taller.+data Layout+  = -- | output @j@ continues input @p !! j@, with the kinds of the inputs and of the outputs+    Wiring [Int] [WireKind] [WireKind]+  | Stage Geo+  deriving (Show)++-- | The distance between neighbouring wires.+slot :: Double+slot = 32++-- | The length of wire above and below a box.+stub :: Double+stub = 10++-- | The height of a box.+boxHeight :: Double+boxHeight = 24++-- | The distance between the rails of neighbouring trace loops.+loopGap :: Double+loopGap = 14++-- | How far the innermost trace loop runs below and above the diagram it loops round, clear of+-- the wire labels.+loopClearance :: Double+loopClearance = 6++-- | The width of a name, roughly, in the box font.+textWidth :: String -> Double+textWidth s = 7.5 * fromIntegral (length s)++-- | The positions of @n@ wires, one slot apart.+slots :: Int -> [Double]+slots n = [slot * (fromIntegral k + 0.5) | k <- [0 .. n - 1]]++width :: Int -> Double+width n = slot * fromIntegral n++-- | Ports at the given positions, for wires of the given kinds.+ports :: [Double] -> [WireKind] -> [Port]+ports = zipWith port++-- | A permutation of wires of the given kinds, drawn over the given height.+wiringGeo :: Double -> [Int] -> [WireKind] -> [WireKind] -> Geo+wiringGeo h p ks os =+  let xs = slots (length p)+  in Geo+       { geoWidth = width (length p)+       , geoHeight = h+       , geoIns = ports xs ks+       , geoOuts = ports xs os+       , geoShapes = [Piece (ks !! i) (Curve (xs !! i, 0) (x, h)) | (x, i) <- zip xs p]+       }++-- | Straight wires of the given kinds at the given positions, from the top down to @h@.+verticals :: Double -> [Double] -> [WireKind] -> [Shape]+verticals h xs ks = [Piece u (Line (x, 0) (x, h)) | (x, u) <- zip xs ks]++-- | A layout as geometry, a permutation drawn over the given height.+toGeo :: Double -> Layout -> Geo+toGeo h (Wiring p ks os) = wiringGeo h p ks os+toGeo _ (Stage g) = g++layoutHeight :: Layout -> Double+layoutHeight Wiring{} = 0+layoutHeight (Stage g) = geoHeight g++-- | Geometry made taller, centred, with its wires extended to the new top and bottom.+stretch :: Double -> Geo -> Geo+stretch h g+  | h <= geoHeight g = g+  | otherwise =+      g+        { geoHeight = h+        , geoShapes =+            map (move 0 pad) (geoShapes g)+              ++ [Piece k (Line (x, 0) (x, pad)) | Port x k _ <- geoIns g]+              ++ [Piece k (Line (x, pad + geoHeight g) (x, h)) | Port x k _ <- geoOuts g]+        }+  where+    pad = (h - geoHeight g) / 2++-- | Two layouts side by side, as tall as the taller one.+tensor :: Layout -> Layout -> Layout+tensor (Wiring p ks os) (Wiring q ls ps) = Wiring (p ++ map (+ length p) q) (ks ++ ls) (os ++ ps)+tensor l r =+  let h = max (layoutHeight l) (layoutHeight r)+      gl = stretch h (toGeo h l)+      gr = stretch h (toGeo h r)+      w = geoWidth gl+      -- the points on the right are numbered after those on the left+      n = 1 + maximum (-1 : [i | Port _ _ (Just i) <- geoIns gl ++ geoOuts gl])+      right q = (shiftPort w q){portLegs = (+ n) <$> portLegs q}+  in Stage+       Geo+         { geoWidth = w + geoWidth gr+         , geoHeight = h+         , geoIns = geoIns gl ++ map right (geoIns gr)+         , geoOuts = geoOuts gl ++ map right (geoOuts gr)+         , geoShapes = geoShapes gl ++ map (move w 0) (geoShapes gr)+         }++-- | The layout of @after . before@. A permutation is absorbed into the layout next to it, so its+-- crossings end up in the next band.+compose :: Layout -> Layout -> Layout+compose (Wiring p _ os) (Wiring q ls _) = Wiring (map (q !!) p) ls os+compose (Stage g) (Wiring p ks _) = Stage g{geoIns = [(geoIns g !! j){portKind = k} | (j, k) <- zip (inverse p) ks]}+compose (Wiring p _ os) (Stage f) = Stage f{geoOuts = [(geoOuts f !! i){portKind = k} | (i, k) <- zip p os]}+compose (Stage g) (Stage f) = Stage (stack f g)++inverse :: [Int] -> [Int]+inverse p = map snd (List.sort (zip p [0 ..]))++-- | @before@ above @after@, with a band of wires between them. The two are placed so that the wires+-- between them move sideways as little as possible.+stack :: Geo -> Geo -> Geo+stack f0 g0 =+  let f = f0{geoOuts = untangle (map portX (geoIns g0)) (geoOuts f0)}+      g = g0{geoIns = untangle (map portX (geoOuts f)) (geoIns g0)}+      dxs = zipWith (\a b -> portX a - portX b) (geoOuts f) (geoIns g)+      off = if null dxs then (geoWidth f - geoWidth g) / 2 else List.sort dxs !! (length dxs `div` 2)+      sf = negate (min 0 off)+      sg = off + sf+      ends = [(portX a + sf, portX b + sg, portKind a) | (a, b) <- zip (geoOuts f) (geoIns g)]+      hb = bandHeight (maximum (0 : [abs (a - b) | (a, b, _) <- ends]))+      hf = geoHeight f+  in Geo+       { geoWidth = max (geoWidth f + sf) (geoWidth g + sg)+       , geoHeight = hf + hb + geoHeight g+       , geoIns = map (shiftPort sf) (geoIns f)+       , geoOuts = map (shiftPort sg) (geoOuts g)+       , geoShapes =+           map (move sf 0) (geoShapes f)+             ++ [Piece u (Curve (a, hf) (b, hf + hb)) | (a, b, u) <- ends]+             ++ map (move sg (hf + hb)) (geoShapes g)+       }++-- | Ports with the legs of each point that may trade places reordered, so that they run to their+-- targets without crossing each other.+untangle :: [Double] -> [Port] -> [Port]+untangle targets ps = [p{portX = fromMaybe (portX p) (lookup i moved)} | (i, p) <- zip [0 ..] ps]+  where+    legs = [(i, l) | (i, Port _ _ (Just l)) <- zip [0 :: Int ..] ps]+    groups = map (map fst . NE.toList) (NE.groupAllWith snd legs)+    moved = concat [zip (List.sortOn (targets !!) grp) (List.sort (map (portX . (ps !!)) grp)) | grp <- groups]++-- | The height of a band whose wires move sideways by at most @d@.+bandHeight :: Double -> Double+bandHeight d+  | d < 0.5 = 0+  | otherwise = max 16 (min 64 (0.6 * d))++-- | A box of the given kind with inputs of the given kinds, and outputs with the given labels and+-- kinds. Unit wires get no label.+nodeGeo :: BoxKind -> [WireKind] -> [(String, WireKind)] -> String -> Geo+nodeGeo bk inKinds outWires s =+  Geo+    { geoWidth = w+    , geoHeight = h+    , geoIns = ports ins inKinds+    , geoOuts = ports outs (map snd outWires)+    , geoShapes =+        [Piece u (Line (x, 0) (x, stub)) | (x, u) <- zip ins inKinds]+          ++ [Piece u (Line (x, stub + boxHeight) (x, h)) | (x, (_, u)) <- zip outs outWires]+          ++ [Box bk ((w - bw) / 2, stub) ((w + bw) / 2, stub + boxHeight) s]+          ++ [Label (x + 3, stub + boxHeight + 9) o | (x, (o, ok)) <- zip outs outWires, ok /= UnitWire]+    }+  where+    n = length inKinds+    m = length outWires+    k = max 1 (max n m)+    bw = max (textWidth s + 14) (fromIntegral (k - 1) * slot + 18)+    w = max (bw + 8) (fromIntegral k * slot)+    h = stub + boxHeight + stub+    at c = [w / 2 + (fromIntegral i - fromIntegral (c - 1) / 2) * slot | i <- [0 .. c - 1]]+    ins = at n+    outs = at m++-- | The points of a (co)monoid, one on each wire of the given kinds; nothing drawn when there are+-- no wires. The legs of copy and merge points may trade places when @free@.+points :: Bool -> PointKind -> [WireKind] -> Layout+points _ _ [] = Wiring [] [] []+points free pk ks = Stage $ case pk of+  UnitPoint -> unit+  DiscardPoint -> mirror unit+  MergePoint -> merge+  CopyPoint -> mirror merge+  where+    n = length ks+    xs = slots n+    -- each copy or merge point forks to two slots; the first legs are listed before the second+    -- ones, so with several wires the next band sorts them+    firsts = [slot * (2 * fromIntegral i + 0.5) | i <- [0 .. n - 1]]+    seconds = map (+ slot) firsts+    ps = zipWith (\l r -> (l + r) / 2) firsts seconds+    leg i = if free then Just i else Nothing+    legs = [Port x u (leg i) | (i, x, u) <- zip3 [0 ..] firsts ks] ++ [Port x u (leg i) | (i, x, u) <- zip3 [0 ..] seconds ks]+    -- the wires stop at the edge of a hollow point, so that the background shows through it+    unit =+      Geo (width n) 12 [] (ports xs ks) (concat [[Piece u (Line (x, 7) (x, 12)), Point (x, 4) False] | (x, u) <- zip xs ks])+    merge =+      Geo+        (width (2 * n))+        20+        legs+        (ports ps ks)+        ( concat+            [ [Piece u (Curve (l, 0) (x, 11)), Piece u (Curve (r, 0) (x, 11)), Piece u (Line (x, 17) (x, 20)), Point (x, 14) False]+            | (x, l, r, u) <- List.zip4 ps firsts seconds ks+            ]+        )++-- | The height of a swap drawn on its own.+swapHeight :: Double+swapHeight = 24++-- | A permutation of wires of the given kinds, drawn on its own when @explicit@.+permutation :: Bool -> [WireKind] -> [Int] -> Layout+permutation explicit ks p =+  let os = map (ks !!) p+  in if explicit then Stage (wiringGeo swapHeight p ks os) else Wiring p ks os++-- | The identity on wires of the given kinds, drawn in a dashed frame when @explicit@.+identity :: Bool -> [WireKind] -> Layout+identity explicit ks+  | explicit =+      let n = length ks+          w = if n == 0 then slot / 2 else width n+          h = 18+          xs = slots n+      in Stage+           ( Geo+               w+               h+               (ports xs ks)+               (ports xs ks)+               (verticals h xs ks ++ [Frame (2, 3) (w - 2, h - 3)])+           )+  | otherwise = Wiring [0 .. length ks - 1] ks ks++-- | Bends joining each wire of the given kinds to its dual: for a 'Cup' the wires and then their+-- duals leave along the bottom, for a 'Cap' the duals and then the wires enter along the top.+-- Each bend changes style at its apex.+bend :: BendKind -> [WireKind] -> [WireKind] -> Layout+bend _ [] _ = Wiring [] [] []+bend kind ka kd =+  let m = length ka+      h = 18+      xs = slots (2 * m)+      (lefts, rights) = splitAt m xs+      -- bends with the given kinds on their left and on their right halves, opening downwards+      cups ls rs =+        Geo (width (2 * m)) h [] (ports xs (ls ++ rs)) $+          concat+            [ [Piece k (Quarter (l, h) ((l + r) / 2, 3)), Piece k' (Quarter (r, h) ((l + r) / 2, 3))]+            | (l, r, k, k') <- List.zip4 lefts rights ls rs+            ]+  in Stage $ case kind of+       Cup -> cups ka kd+       Cap -> mirror (cups kd ka)++-- | An associator from the grouping given to the other one, on wires of the given kinds: the+-- wires with a bracket over the pair grouped at the top and one under the pair grouped at the+-- bottom.+rebracket :: Grouping -> [WireKind] -> [WireKind] -> [WireKind] -> Geo+rebracket grouping ka kb kc =+  let ks = ka ++ kb ++ kc+      n = length ks+      h = 30+      xs = slots n+      group from to+        | to <= from = []+        | otherwise = [(xs !! from - slot / 3, xs !! (to - 1) + slot / 3)]+      ab = group 0 (length ka + length kb)+      bc = group (length ka) n+      leftFirst =+        Geo+          (width n)+          h+          (ports xs ks)+          (ports xs ks)+          ( verticals h xs ks+              ++ [Bracket (x0, 6) (x1, 6) True | (x0, x1) <- ab]+              ++ [Bracket (x0, h - 6) (x1, h - 6) False | (x0, x1) <- bc]+          )+  in case grouping of LeftFirst -> leftFirst; RightFirst -> mirror leftFirst++-- | A unitor on wires of the given kinds: a dotted unit wire that runs into the outermost wire on+-- its side or out of it.+unitor :: Side -> Direction -> [WireKind] -> Geo+unitor side dir ks =+  let n = length ks+      h = 16+      xs = case side of OnLeft -> map (+ slot) (slots n); OnRight -> slots n+      xu = case side of OnLeft -> slot / 2; OnRight -> slot * (fromIntegral n + 0.5)+      other = case side of OnLeft -> take 1 xs; OnRight -> drop (n - 1) xs+      place :: forall t. t -> [t] -> [t]+      place u us = case side of OnLeft -> u : us; OnRight -> us ++ [u]+      joining = case other of+        [x] -> Curve (xu, 0) (x, h)+        _ -> Line (xu, 0) (xu, h / 2)+      absorb =+        Geo+          (width (n + 1))+          h+          (ports (place xu xs) (place UnitWire ks))+          (ports xs ks)+          (Piece UnitWire joining : verticals h xs ks)+  in case dir of Absorb -> absorb; Create -> mirror absorb++-- | The end of a unit wire.+unitEnd :: Geo+unitEnd = Geo slot 8 [port (slot / 2) UnitWire] [] [Piece UnitWire (Line (slot / 2, 0) (slot / 2, 8))]++-- | Geometry upside down: its inputs become its outputs and the other way round, so that a merge+-- point becomes a copy point, a cup a cap, and so on. A point is filled when it was hollow and+-- hollow when it was filled, as the points of a comonoid are the mirror images of a monoid's. A+-- piece of wire still runs from top to bottom, except a bend's, which runs towards its apex.+mirror :: Geo -> Geo+mirror g = g{geoIns = geoOuts g, geoOuts = geoIns g, geoShapes = map flipShape (geoShapes g)}+  where+    h = geoHeight g+    f (x, y) = (x, h - y)+    corners (x0, y0) (x1, y1) = ((x0, h - y1), (x1, h - y0))+    flipShape = \case+      Piece k (Line a b) -> Piece k (Line (f b) (f a))+      Piece k (Curve a b) -> Piece k (Curve (f b) (f a))+      Piece k (Loop ps) -> Piece k (Loop (NE.reverse (fmap f ps)))+      Piece k (Quarter a b) -> Piece k (Quarter (f a) (f b))+      Box bk a b s -> uncurry (Box bk) (corners a b) s+      Frame a b -> uncurry Frame (corners a b)+      Bracket a b down -> Bracket (f a) (f b) (not down)+      Point a filled -> Point (f a) (not filled)+      Label a s -> Label (f a) s+      Boundary a s -> Boundary (f a) s+      Equals a -> Equals (f a)++-- | The first @k@ wires fed back from the outputs to the inputs, each looping round the side where+-- it crosses fewer other wires. The loops on one side are nested: the one whose ends are nearest+-- that side runs innermost.+loops :: Int -> Geo -> Geo+loops k g =+  Geo+    { geoWidth = left + w + right+    , geoHeight = depth + h + depth+    , geoIns = map (shiftPort left) (drop k (geoIns g))+    , geoOuts = map (shiftPort left) (drop k (geoOuts g))+    , geoShapes =+        map (move left depth) (geoShapes g)+          ++ [Piece u (Line (x + left, 0) (x + left, depth)) | Port x u _ <- drop k (geoIns g)]+          ++ [Piece u (Line (x + left, depth + h) (x + left, depth + h + depth)) | Port x u _ <- drop k (geoOuts g)]+          ++ zipWith (loop 0 (\d -> left - d)) [1 ..] (List.sortOn (\(a, b, _) -> min a b) lefts)+          ++ zipWith (loop (loopGap / 2) (\d -> left + w + d)) [1 ..] (List.sortOn (\(a, b, _) -> negate (max a b)) rights)+    }+  where+    w = geoWidth g+    h = geoHeight g+    (lefts, rights) = List.partition goesLeft [(portX a, portX b, portKind a) | (a, b) <- take k (zip (geoIns g) (geoOuts g))]+    -- a loop goes round the side where it crosses fewer of the wires that carry on, and round the+    -- side its ends are nearest to when that is a tie+    carryOn = map portX (drop k (geoIns g) ++ drop k (geoOuts g))+    goesLeft (a, b, _) =+      let crossLeft = length (filter (< min a b) carryOn)+          crossRight = length (filter (> max a b) carryOn)+      in crossLeft < crossRight || (crossLeft == crossRight && a + b <= w)+    left = loopGap * fromIntegral (length lefts)+    right = loopGap * fromIntegral (length rights)+    depth = loopClearance + loopGap * fromIntegral (max (length lefts) (length rights))+    -- the loops on the right run half a gap higher than those on the left, so that a left and a+    -- right loop cross instead of running along each other+    loop :: Double -> (Double -> Double) -> Int -> (Double, Double, WireKind) -> Shape+    loop lift rail level (xi, xo, u) =+      let d = loopGap * fromIntegral level+          v = loopClearance + d - lift+          x = rail d+      in Piece u $+           Loop+             ( (xo + left, depth + h)+                 :| [ (xo + left, depth + h + v)+                    , (x, depth + h + v)+                    , (x, depth - v)+                    , (xi + left, depth - v)+                    , (xi + left, depth)+                    ]+             )++-- * Rendering++-- | The height of the row of boundary labels.+labelRow :: Double+labelRow = 16++-- | Geometry with its boundary: the input labels above and the output labels below, each joined+-- to its wire by a band @top@ and @bottom@ tall. Legs that may trade places are put in the+-- boundary's order.+framed :: Double -> Double -> [(String, WireKind)] -> [(String, WireKind)] -> Geo -> Geo+framed top bottom ins outs g =+  Geo+    { geoWidth = geoWidth g+    , geoHeight = labelRow + top + geoHeight g + bottom + labelRow+    , geoIns = []+    , geoOuts = []+    , geoShapes =+        [Boundary (x, labelRow - 4) s | (x, (s, _)) <- zip inXs ins]+          ++ [Piece u (Curve (x, labelRow) (y, labelRow + top)) | (x, y, (_, u)) <- zip3 inXs inYs ins]+          ++ map (move 0 (labelRow + top)) (geoShapes g)+          ++ [Piece u (Curve (y, bottomAt) (x, bottomAt + bottom)) | (x, y, (_, u)) <- zip3 outXs outYs outs]+          ++ [Boundary (x, bottomAt + bottom + labelRow - 3) s | (x, (s, _)) <- zip outXs outs]+    }+  where+    inYs = inOrder (geoIns g)+    outYs = inOrder (geoOuts g)+    inXs = List.sort inYs+    outXs = List.sort outYs+    bottomAt = labelRow + top + geoHeight g++-- | The positions of ports, the legs of each point that may trade places put in the order of the+-- wires.+inOrder :: [Port] -> [Double]+inOrder ps = map portX (untangle (map fromIntegral [0 .. length ps - 1]) ps)++-- | The height of the bands joining the boundary to the wires.+boundaryBands :: Geo -> (Double, Double)+boundaryBands g =+  let band xs = max 8 (bandHeight (maximum (0 : zipWith (\a b -> abs (a - b)) (List.sort xs) xs)))+  in (band (inOrder (geoIns g)), band (inOrder (geoOuts g)))++-- | The diagram as an SVG document, with the 'defaultOptions'.+render :: forall (as :: [W]) (bs :: [W]). Svg (S as) (S bs) -> String+render = renderWith defaultOptions++-- | The diagram as an SVG document.+renderWith :: forall (as :: [W]) (bs :: [W]). Options -> Svg (S as) (S bs) -> String+renderWith o (Svg _ d) = sideBySide @as @bs o [d]++-- | Two parallel diagrams side by side, with an equals sign between them, with the+-- 'defaultOptions'.+renderEquation :: forall (as :: [W]) (bs :: [W]). Svg (S as) (S bs) -> Svg (S as) (S bs) -> String+renderEquation = renderEquationWith defaultOptions++-- | Two parallel diagrams side by side, with an equals sign between them. Neither is simplified:+-- the picture shows two different diagrams that mean the same.+renderEquationWith+  :: forall (as :: [W]) (bs :: [W]). Options -> Svg (S as) (S bs) -> Svg (S as) (S bs) -> String+renderEquationWith o (Svg _ l) (Svg _ r) = sideBySide @as @bs o [l, r]++-- | Diagrams from the wires @as@ to the wires @bs@ as one SVG document: side by side, each with+-- the boundary labels, stretched to the height of the tallest, and with an equals sign between+-- each and the next.+sideBySide :: forall (as :: [W]) (bs :: [W]). (IsList as, IsList bs) => Options -> [Diagram] -> String+sideBySide o ds =+  let ls = map (layout o) ds+      h = maximum (0 : map layoutHeight ls)+      gs = [stretch h (toGeo (max h slot) l) | l <- ls]+      bands = map boundaryBands gs+      side = framed (maximum (0 : map fst bands)) (maximum (0 : map snd bands)) (visible o (wires @as)) (visible o (wires @bs))+      fs = map side gs+      -- each side starts where the one before it ends, with room for the equals sign between+      offsets = scanl (\x f -> x + geoWidth f + 48) 0 fs+      equalsAt = case fs of f : _ -> geoHeight f / 2; [] -> 0+      placed i x f = [Equals (x - 24, equalsAt) | i > (0 :: Int)] ++ map (move x 0) (geoShapes f)+  in document+       Geo+         { geoWidth = last offsets - 48+         , geoHeight = maximum (0 : map geoHeight fs)+         , geoIns = []+         , geoOuts = []+         , geoShapes = concat (zipWith3 placed [0 ..] offsets fs)+         }++-- | The arrows a law asks for, drawn as 'node's with the names the law gives them.+lawNode :: forall (x :: SVG) (y :: SVG). (Ob x, Ob y) => String -> Identity (x ~> y)+lawNode s = Identity (node @(UN S x) @(UN S y) s)++-- | The laws of @cs@ drawn with the 'defaultOptions', see 'lawSvgsWith'.+lawSvgs :: forall (cs :: [Kind -> Constraint]). (Laws cs, All cs SVG) => [(String, String)]+lawSvgs = lawSvgsWith @cs defaultOptions++-- | The laws of @cs@, each drawn as an equation by 'renderEquationWith', with its name. The object+-- variables are single wires @'Wire' "a"@ to @'Wire' "e"@, and the arrows a law asks for are 'node's with the names+-- it gives them.+lawSvgsWith :: forall (cs :: [Kind -> Constraint]). (Laws cs, All cs SVG) => Options -> [(String, String)]+lawSvgsWith o = [(lawName law, draw law) | law <- laws @cs]+  where+    draw :: Law cs -> String+    draw (Law _ body) = withSides+      (runIdentity (body @(S '[Wire "a"]) @(S '[Wire "b"]) @(S '[Wire "c"]) @(S '[Wire "d"]) @(S '[Wire "e"]) lawNode))+      \l@Svg{} r ->+        renderEquationWith o l r++-- | The laws of the profunctor class @c@ drawn with the 'defaultOptions', see 'proLawSvgsWith'.+proLawSvgs :: forall (c :: (SVG +-> SVG) -> Constraint). (ProLaws c, c (Id :: CAT SVG)) => [(String, String)]+proLawSvgs = proLawSvgsWith @c defaultOptions++-- | The laws of the profunctor class @c@, each drawn as an equation by 'renderEquationWith', with+-- its name. The profunctor is the identity profunctor on 'SVG', so an element is a diagram: the+-- elements a law is given are 'element's named p, p' and p'', and the arrows it asks for are+-- 'node's with the names it gives them. The object variables are single wires @'Wire' "a"@ to+-- @'Wire' "f"@.+proLawSvgsWith+  :: forall (c :: (SVG +-> SVG) -> Constraint). (ProLaws c, c (Id :: CAT SVG)) => Options -> [(String, String)]+proLawSvgsWith o = [(proLawName law, draw law) | law <- proLaws @c]+  where+    draw :: ProLaw c -> String+    draw (ProLaw _ body) =+      equation+        ( runIdentity+            ( body @Id @(S '[Wire "a"]) @(S '[Wire "b"]) @(S '[Wire "c"]) @(S '[Wire "d"]) @(S '[Wire "e"]) @(S '[Wire "f"])+                (el "p")+                lawNode+                lawNode+            )+        )+    draw (ProLaw3 _ body) =+      equation+        ( runIdentity+            ( body @Id @(S '[Wire "a"]) @(S '[Wire "b"]) @(S '[Wire "c"]) @(S '[Wire "d"]) @(S '[Wire "e"]) @(S '[Wire "f"])+                (el "p")+                (el "p'")+                (el "p''")+                lawNode+                lawNode+            )+        )+    equation :: ProEquation (Id :: CAT SVG) -> String+    equation = \case+      Id l@Svg{} :=: Id r -> renderEquationWith o l r+      InK e -> arrows e+      InJ e -> arrows e+    arrows e = withSides e \l@Svg{} r -> renderEquationWith o l r+    el :: forall (x :: SVG) (y :: SVG). (Ob x, Ob y) => String -> Id x y+    el s = Id (element @(UN S x) @(UN S y) s)++-- | An SVG document showing the geometry. Wires, outlines and text use the current colour. Boxes+-- are not filled, and the wires stop at the edge of a hollow point, so the background shows+-- through both. Only the core of a dual wire is painted, in @--sd-paper@ (white when it is not+-- set), which a page can set to its background.+document :: Geo -> String+document g =+  "<svg xmlns=\"http://www.w3.org/2000/svg\" class=\"sd\" viewBox=\""+    ++ unwords (map num [-margin, -margin, geoWidth g + 2 * margin, geoHeight g + 2 * margin])+    ++ "\" width=\""+    ++ num (geoWidth g + 2 * margin)+    ++ "\" height=\""+    ++ num (geoHeight g + 2 * margin)+    ++ "\"><style>"+    ++ ".sd path{fill:none;stroke:currentColor;stroke-width:1.3;stroke-linecap:round}"+    ++ ".sd .u path{stroke-dasharray:1.3 2.6}"+    ++ ".sd .d path{stroke-linecap:butt;stroke-width:4}"+    ++ ".sd .di path{stroke:var(--sd-paper,#fff);stroke-width:1.6}"+    ++ ".sd rect,.sd .h{fill:none;stroke:currentColor;stroke-width:1.3}"+    ++ ".sd .f{fill:currentColor}"+    ++ ".sd .el{fill:currentColor;fill-opacity:0.15}"+    ++ ".sd .id{stroke-width:0.8;stroke-dasharray:3 2}"+    ++ ".sd .br{stroke-width:0.9}"+    ++ ".sd text{fill:currentColor;font-family:'STIX Two Text','Times New Roman',serif;font-style:italic}"+    ++ ".sd .n{font-size:15px;text-anchor:middle;dominant-baseline:central}"+    ++ ".sd .l{font-size:11px}"+    ++ ".sd .b{font-size:13px;text-anchor:middle}"+    ++ ".sd .e{font-size:22px;font-style:normal;text-anchor:middle;dominant-baseline:central}"+    ++ "</style>"+    -- the outlines of all dual wires go below all their cores, so that where two dual wires meet or+    -- cross the cores run on unbroken+    ++ group "d" duals+    ++ group "di" duals+    ++ concatMap path (chains Plain)+    ++ group "u" (chains UnitWire)+    ++ concat [shape x | x <- geoShapes g, not (isPiece x), not (isText x)]+    ++ concat [shape x | x <- geoShapes g, isText x]+    ++ "</svg>"+  where+    margin = 8+    -- the pieces of wire of one kind, joined into as few paths as possible, so that no seams show+    duals = chains DualWire+    chains k = joined [segment p | Piece k' p <- geoShapes g, k' == k]+    group _ [] = ""+    group cls ds = "<g class=\"" ++ cls ++ "\">" ++ concatMap path ds ++ "</g>"+    isPiece = \case Piece{} -> True; _ -> False+    isText = \case Label{} -> True; Boundary{} -> True; Equals{} -> True; _ -> False++-- | Where a piece of wire starts and ends, and the SVG path from its start.+segment :: Path -> (Pt, Pt, String)+segment = \case+  Line a b -> (a, b, "L" ++ pt b)+  Curve a@(ax, ay) b@(bx, by)+    | abs (ax - bx) < 0.5 -> (a, b, "L" ++ pt b)+    | otherwise -> let my = (ay + by) / 2 in (a, b, "C" ++ pt (ax, my) ++ " " ++ pt (bx, my) ++ " " ++ pt b)+  Loop ps -> (NE.head ps, NE.last ps, rounded ps)+  Quarter a@(ax, ay) b@(bx, by) ->+    (a, b, "C" ++ pt (ax, ay + (by - ay) * kappa) ++ " " ++ pt (bx - (bx - ax) * kappa, by) ++ " " ++ pt b)++-- | Pieces of wire joined where one ends where the next starts, each chain as one path. A chain+-- starts at a piece that no other piece leads into.+joined :: [(Pt, Pt, String)] -> [String]+joined [] = []+joined ps@(p : _) =+  let start = fromMaybe p (List.find (\(a, _, _) -> key a `notElem` [key b | (_, b, _) <- ps]) ps)+      chain = follow start (List.delete start ps)+      rest = foldr List.delete ps (start : chain)+      (a0, _, _) = start+  in ("M" ++ pt a0 ++ concat [d | (_, _, d) <- start : chain]) : joined rest+  where+    key (x, y) = (round (x * 100), round (y * 100)) :: (Int, Int)+    follow (_, b, _) qs = case List.find (\(a', _, _) -> key a' == key b) qs of+      Just next -> next : follow next (List.delete next qs)+      Nothing -> []++path :: String -> String+path d = "<path d=\"" ++ d ++ "\"/>"++-- | One shape as SVG.+shape :: Shape -> String+shape = \case+  Box bk a@(x0, y0) b@(x1, y1) s ->+    rect (if bk == ElementBox then " class=\"el\"" else "") 7 a b ++ text "n" ((x0 + x1) / 2, (y0 + y1) / 2) s+  Frame a b -> rect " class=\"id\"" 4 a b+  Bracket (x0, y0) (x1, y1) down ->+    let tick = if down then 4 else -4+    in "<path class=\"br\" d=\"M"+         ++ pt (x0, y0 + tick)+         ++ "L"+         ++ pt (x0, y0)+         ++ "L"+         ++ pt (x1, y1)+         ++ "L"+         ++ pt (x1, y1 + tick)+         ++ "\"/>"+  Point (x, y) filled -> "<circle cx=\"" ++ num x ++ "\" cy=\"" ++ num y ++ "\" r=\"3\" class=\"" ++ (if filled then "f" else "h") ++ "\"/>"+  Label p s -> text "l" p s+  Boundary p s -> text "b" p s+  Equals p -> text "e" p "="+  -- wires are drawn by 'document', joined into as few paths as possible+  Piece{} -> ""+  where+    rect cls r (x0, y0) (x1, y1) =+      "<rect"+        ++ cls+        ++ " x=\""+        ++ num x0+        ++ "\" y=\""+        ++ num y0+        ++ "\" width=\""+        ++ num (x1 - x0)+        ++ "\" height=\""+        ++ num (y1 - y0)+        ++ "\" rx=\""+        ++ num r+        ++ "\"/>"+    text cls (x, y) s = "<text class=\"" ++ cls ++ "\" x=\"" ++ num x ++ "\" y=\"" ++ num y ++ "\">" ++ Dot.htmlEscape s ++ "</text>"++-- | How far along its tangent a cubic curve's control point lies, as a fraction of the radius,+-- for the curve to be a quarter circle.+kappa :: Double+kappa = 0.5523++-- | The radius of a bend, and of the corners of a trace loop, so that a small loop is a cup and a+-- cap joined by straight wire.+bendRadius :: Double+bendRadius = slot / 2++-- | A path from the first of the given corners along the rest, each corner rounded with a quarter+-- circle of radius 'bendRadius', or less where the wire on either side of it is too short. A+-- stretch of wire between two corners is shared between them; one at either end belongs to its+-- corner alone.+rounded :: NonEmpty Pt -> String+rounded ne = concatMap corner (zip3 [0 :: Int ..] ps (drop 1 ps `zip` drop 2 ps)) ++ "L" ++ pt (NE.last ne)+  where+    ps = NE.toList ne+    lastCorner = length ps - 3+    corner (i, prev, (c, next)) =+      let room end q = if end then dist c q else dist c q / 2+          rr = minimum [bendRadius, room (i == 0) prev, room (i == lastCorner) next]+          a = towards c prev rr+          b = towards c next rr+      in "L" ++ pt a ++ "C" ++ pt (between a c) ++ " " ++ pt (between b c) ++ " " ++ pt b+    dist (x0, y0) (x1, y1) = sqrt ((x1 - x0) ^ (2 :: Int) + (y1 - y0) ^ (2 :: Int))+    towards c@(cx, cy) q@(x, y) d = let t = d / dist c q in (cx + (x - cx) * t, cy + (y - cy) * t)+    -- the control point of a quarter circle, from its end towards the corner+    between (x, y) (cx, cy) = (x + (cx - x) * kappa, y + (cy - y) * kappa)++pt :: Pt -> String+pt (x, y) = num x ++ " " ++ num y++num :: Double -> String+num x = showFFloat (Just 1) x ""
+ src/Proarrow/Tools/Laws.hs view
@@ -0,0 +1,310 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- the identity laws compose with id on purpose+{- HLINT ignore "Redundant id" -}++-- | Laws stated as code, polymorphic in the category. A law of the structures @cs@ takes five+-- object variables and a supply of named arbitrary arrows, and returns an equation between two+-- arrows. The @proarrow:testing@ library checks laws by running them with random objects and+-- arrows, in a category whose arrows also carry their own description, so that a failing law+-- prints as the code it was built from.+--+-- A derived operation (a function defined from the class methods, like+-- 'Proarrow.Category.Monoidal.StarAutonomous.doubleNeg') would print as its definition. 'label'+-- names it instead.+--+-- A class's laws are an instance of 'Laws' for the list of structures they mention, the same list+-- the class's free-category structure requires, e.g.+-- @'Laws' 'Proarrow.Category.Monoidal.SymMonoidalStructures'@. The instances live next to their+-- classes.+module Proarrow.Tools.Laws where++import Data.Kind (Constraint, Type)+import Prelude (Applicative, Monad, String, pure, (++))++import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Proarrow.Category.Instance.Free (All)+import Proarrow.Core (CategoryOf (..), Hom, Kind, Profunctor (..), Promonad (..), type (+->))+import Proarrow.Profunctor.Corepresentable (Corepresentable (..), withObCorep)+import Proarrow.Profunctor.Representable (Representable (..), withObRep)++-- * Laws++-- | The laws of the structures @cs@. A class with a new kind of object also needs support in the+-- testing library before its laws can be checked, see "Proarrow.Testing.Laws.Run".+--+-- For example, the laws of a functor on objects @Sq@ with action @sq@ on arrows:+--+-- @+-- instance Laws '[HasSquare] where+--   laws =+--     [ Law "sq identity" \\ \@a _ -> withObSq \@_ \@a (sq (obj \@a) '===' id)+--     , Law "sq composition" \\ \@a \@b \@c mor -> do+--         f <- mor \@a \@b "f"+--         g <- mor \@b \@c "g"+--         sq (g . f) '===' sq g . sq f+--     ]+-- @+type Laws :: [Kind -> Constraint] -> Constraint+class Laws cs where+  -- | The laws, each tested as its own property.+  laws :: [Law cs]++-- | A named law.+type Law :: [Kind -> Constraint] -> Type+data Law cs = Law String (LawBody cs)++-- | The name of a law, used as its test's name.+lawName :: Law cs -> String+lawName (Law name _) = name++-- | The body of a 'Law': given five object variables and a supply of named arbitrary arrows,+-- produce an 'Equation'. A body binds as many of the variables as it uses, e.g. @\\ \@a \@b mor -> ...@,+-- and gives each arrow it asks for the name to print it as.+type LawBody :: [Kind -> Constraint] -> Type+type LawBody cs =+  forall {k} (a :: k) (b :: k) (c :: k) (d :: k) (e :: k) m+   . (Labelled k, All cs k, Monad m, Ob a, Ob b, Ob c, Ob d, Ob e)+  => (forall (x :: k) y. (Ob x, Ob y) => String -> m (x ~> y))+  -> m (Equation k)++-- * Equations++infix 1 :=:++-- | Two parallel elements of a profunctor claimed to be equal, or an equation between arrows of its+-- codomain ('InK') or domain ('InJ').+type ProEquation :: forall {j} {k}. (j +-> k) -> Type+data ProEquation p where+  (:=:) :: forall {j} {k} (p :: j +-> k) a b. p a b -> p a b -> ProEquation p+  InK :: forall {j} {k} (p :: j +-> k). Equation k -> ProEquation p+  InJ :: forall {j} {k} (p :: j +-> k). Equation j -> ProEquation p++-- | Two parallel arrows claimed to be equal: an equation between elements of the hom profunctor.+type Equation :: Kind -> Type+type Equation k = ProEquation (Hom k)++-- | The two sides of an equation between arrows. At the hom profunctor 'InK' and 'InJ' only wrap+-- another equation between arrows of the same category, and are looked through.+withSides :: forall {k} r. Equation k -> (forall (a :: k) b. a ~> b -> a ~> b -> r) -> r+withSides (l :=: r) f = f l r+withSides (InK e) f = withSides e f+withSides (InJ e) f = withSides e f++-- | The equations that an equation between arrows of @i@ can be the result of: those of a+-- profunctor law whose codomain ('InK') or domain ('InJ') is @i@. An 'Equation' is one of these,+-- at the hom profunctor. When the codomain and the domain are the same category either+-- constructor says the same, and 'InK' is used.+type ArrowEquation :: Kind -> Type -> Constraint+class ArrowEquation i r where+  -- | An equation between arrows of @i@, as an @r@.+  fromArrowEquation :: Equation i -> r++instance ArrowEquation k (ProEquation (p :: j +-> k)) where+  fromArrowEquation = InK+instance {-# INCOHERENT #-} ArrowEquation j (ProEquation (p :: j +-> k)) where+  fromArrowEquation = InJ++infix 1 ===++-- | An equation between arrows as the result of a law body, in whichever category of the law the+-- arrows are in: @l '===' r = 'pure' ('fromArrowEquation' (l ':=:' r))@.+(===) :: forall {i} m r (a :: i) b. (Applicative m, ArrowEquation i r) => a ~> b -> a ~> b -> m r+l === r = pure (fromArrowEquation (l :=: r :: Equation i))++infix 1 =:=++-- | An equation between elements as the result of a profunctor law body:+-- @l '=:=' r = 'pure' (l ':=:' r)@.+(=:=) :: forall {j} {k} m (p :: j +-> k) a b. (Applicative m) => p a b -> p a b -> m (ProEquation p)+l =:= r = pure (l :=: r)++-- * Inverses++-- | A pair of arrows claimed to be inverse to each other, see 'inverses'.+type Inverses :: Kind -> Type+data Inverses k where+  Inverses :: forall {k} (a :: k) b. a ~> b -> b ~> a -> Inverses k++-- | The body of a law that asks for no arrows: given five object variables, an @r k@.+type PureLawBody :: [Kind -> Constraint] -> (Kind -> Type) -> Type+type PureLawBody cs r =+  forall {k} (a :: k) (b :: k) (c :: k) (d :: k) (e :: k). (Labelled k, All cs k, Ob a, Ob b, Ob c, Ob d, Ob e) => r k++-- | @g . f = id@ and @f . g = id@ for @'Inverses' f g@.+leftInverse, rightInverse :: (CategoryOf k) => Inverses k -> Equation k+leftInverse (Inverses f g) = (g . f :=: id) \\ f+rightInverse (Inverses f g) = (f . g :=: id) \\ f++-- | The two laws saying that a pair of arrows @f@, @g@ are inverse to each other: @g@ is a left+-- and a right inverse of @f@.+inverses :: forall cs. String -> PureLawBody cs Inverses -> [Law cs]+inverses name body = [side " left inverse" leftInverse, side " right inverse" rightInverse]+  where+    side :: String -> (forall k. (CategoryOf k) => Inverses k -> Equation k) -> Law cs+    side suffix eqn = Law (name ++ suffix) \ @a @b @c @d @e _ -> pure (eqn (body @a @b @c @d @e))++-- * Bijections++-- | Two maps between hom-sets claimed to be inverse to each other, see 'bijection', with how to+-- ask for an arrow of either hom-set.+type Bijection :: (Type -> Type) -> Kind -> Type+data Bijection m k where+  Bijection+    :: forall {k} m (a :: k) (b :: k) (c :: k) (d :: k)+     . m (a ~> b) -> m (c ~> d) -> (a ~> b -> c ~> d) -> (c ~> d -> a ~> b) -> Bijection m k++-- | The body of a 'bijection': given five object variables and a supply of named arbitrary arrows,+-- the two maps, with how to ask for an arrow of each hom-set.+type BijectionBody :: [Kind -> Constraint] -> Type+type BijectionBody cs =+  forall {k} (a :: k) (b :: k) (c :: k) (d :: k) (e :: k) m+   . (Labelled k, All cs k, Monad m, Ob a, Ob b, Ob c, Ob d, Ob e)+  => (forall (x :: k) y. (Ob x, Ob y) => String -> m (x ~> y))+  -> Bijection m k++-- | The two laws saying that maps @to@ and @from@ between hom-sets are inverse to each other:+-- @from (to f) = f@ and @to (from g) = g@. Each asks only for the arrow it needs, so an empty+-- hom-set on the other side discards nothing.+bijection :: forall cs. String -> BijectionBody cs -> [Law cs]+bijection name body =+  [ Law (name ++ " left inverse") \ @a @b @c @d @e mor -> case body @a @b @c @d @e mor of+      Bijection askF _ to from -> do+        f <- askF+        f === from (to f)+  , Law (name ++ " right inverse") \ @a @b @c @d @e mor -> case body @a @b @c @d @e mor of+      Bijection _ askG to from -> do+        g <- askG+        g === to (from g)+  ]++-- * The laws of a category++-- | 'id' is a unit for composition, which is associative.+instance Laws '[CategoryOf] where+  laws =+    [ Law "left identity" \ @a @b mor -> do+        f <- mor @a @b "f"+        f === id . f+    , Law "right identity" \ @a @b mor -> do+        f <- mor @a @b "f"+        f === f . id+    , Law "associativity" \ @a @b @c @d mor -> do+        f <- mor @a @b "f"+        g <- mor @b @c "g"+        h <- mor @c @d "h"+        h . (g . f) === (h . g) . f+    ]++-- * Profunctor laws++-- | The laws of the profunctor class @c@, for any profunctor @p@ with @c p@. The instances for+-- classes that "Proarrow.Category.Instance.Free" depends on live here.+type ProLaws :: forall {j} {k}. ((j +-> k) -> Constraint) -> Constraint+class ProLaws c where+  -- | The laws, each tested as its own property.+  proLaws :: [ProLaw c]++-- | A named profunctor law, about one element of the profunctor ('ProLaw') or three ('ProLaw3').+type ProLaw :: forall {j} {k}. ((j +-> k) -> Constraint) -> Type+data ProLaw c = ProLaw String (ProLawBody c) | ProLaw3 String (ProLawBody3 c)++-- | The name of a profunctor law, used as its test's name.+proLawName :: ProLaw c -> String+proLawName (ProLaw name _) = name+proLawName (ProLaw3 name _) = name++-- | The body of a 'ProLaw': given a profunctor @p :: j '+->' k@, six object variables alternating+-- between @k@ and @j@, an element @p :: p a b@ between the first two, and a supply of named+-- arbitrary arrows for each of @k@ and @j@, produce a 'ProEquation'. The element picks its+-- endpoints, so that a test can draw it where @p@ has elements, and a test draws the other+-- variables so that there are arrows @e '~>' c '~>' a@ and @b '~>' d '~>' f@. A body binds as many+-- of the variables as it uses, e.g. @\\ \@_ \@a \@b p morK _ -> ...@.+type ProLawBody :: forall {j} {k}. ((j +-> k) -> Constraint) -> Type+type ProLawBody (cl :: (j +-> k) -> Constraint) =+  forall (p :: j +-> k) (a :: k) (b :: j) (c :: k) (d :: j) (e :: k) (f :: j) m+   . (cl p, Labelled j, Labelled k, Monad m, Ob a, Ob b, Ob c, Ob d, Ob e, Ob f)+  => p a b+  -> (forall (x :: k) y. (Ob x, Ob y) => String -> m (x ~> y))+  -> (forall (x :: j) y. (Ob x, Ob y) => String -> m (x ~> y))+  -> m (ProEquation p)++-- | The body of a 'ProLaw3': a 'ProLawBody' with three elements @p :: p a b@, @p' :: p c d@ and+-- @p'' :: p e f@, which pick all six object variables. A law that needs arbitrary objects uses the+-- endpoints of an element it does not otherwise use.+type ProLawBody3 :: forall {j} {k}. ((j +-> k) -> Constraint) -> Type+type ProLawBody3 (cl :: (j +-> k) -> Constraint) =+  forall (p :: j +-> k) (a :: k) (b :: j) (c :: k) (d :: j) (e :: k) (f :: j) m+   . (cl p, Labelled j, Labelled k, Monad m, Ob a, Ob b, Ob c, Ob d, Ob e, Ob f)+  => p a b+  -> p c d+  -> p e f+  -> (forall (x :: k) y. (Ob x, Ob y) => String -> m (x ~> y))+  -> (forall (x :: j) y. (Ob x, Ob y) => String -> m (x ~> y))+  -> m (ProEquation p)++-- | 'dimap' preserves identities and composition, and 'lmap' and 'rmap' are its two halves.+instance ProLaws Profunctor where+  proLaws =+    [ ProLaw "dimap identity" \p _ _ -> p =:= dimap id id p+    , ProLaw "dimap composition" \ @_ @a @b @c @d @e @f p morK morJ -> do+        g <- morK @c @a "g"+        h <- morJ @b @d "h"+        g' <- morK @e @c "g'"+        h' <- morJ @d @f "h'"+        dimap (g . g') (h' . h) p =:= dimap g' h' (dimap g h p)+    , ProLaw "lmap" \ @_ @a @_ @c p morK _ -> do+        g <- morK @c @a "g"+        lmap g p =:= dimap g id p+    , ProLaw "rmap" \ @_ @_ @b @_ @d p _ morJ -> do+        h <- morJ @b @d "h"+        rmap h p =:= dimap id h p+    ]++-- | 'index' and 'tabulate' are inverse and natural, and 'repUniv' is @'tabulate' 'id'@.+instance ProLaws Representable where+  proLaws =+    [ ProLaw "tabulate . index" \p _ _ -> p =:= tabulate (index p)+    , ProLaw "index . tabulate" \ @p @a @b _ morK _ -> withObRep @p @b do+        g <- morK @a @(p % b) "g"+        g === index (tabulate @p @b g)+    , ProLaw "index naturality" \ @p @a @b @c @d p morK morJ -> do+        g <- morK @c @a "g"+        h <- morJ @b @d "h"+        index (dimap g h p) === repMap @p h . index p . g+    , ProLaw "repUniv" \ @p @_ @b _ _ _ -> withObRep @p @b (repUniv @p @b =:= tabulate id)+    ]++-- | 'coindex' and 'cotabulate' are inverse and natural, and 'corepUniv' is @'cotabulate' 'id'@.+instance ProLaws Corepresentable where+  proLaws =+    [ ProLaw "cotabulate . coindex" \p _ _ -> p =:= cotabulate (coindex p)+    , ProLaw "coindex . cotabulate" \ @p @a @b _ _ morJ -> withObCorep @p @a do+        h <- morJ @(p %% a) @b "h"+        h === coindex (cotabulate @p @a h)+    , ProLaw "coindex naturality" \ @p @a @b @c @d p morK morJ -> do+        g <- morK @c @a "g"+        h <- morJ @b @d "h"+        coindex (dimap g h p) === h . coindex p . corepMap @p g+    , ProLaw "corepUniv" \ @p @a _ _ _ -> withObCorep @p @a (corepUniv @p @a =:= cotabulate id)+    ]++-- | 'dagger' is an involution that reverses 'dimap'. At the hom profunctor these are the laws of a+-- dagger category.+instance ProLaws DaggerProfunctor where+  proLaws =+    [ ProLaw "dagger involution" \p _ _ -> p =:= dagger (dagger p)+    , ProLaw "dagger dimap" \ @_ @a @b @c @d p morK morJ -> do+        g <- morK @c @a "g"+        h <- morJ @b @d "h"+        dagger (dimap g h p) =:= dimap (dagger h) (dagger g) (dagger p)+    ]++-- * Naming arrows++-- | Categories whose arrows can be given a name, for printing laws. Naming leaves the arrow as it+-- is.+type Labelled :: Kind -> Constraint+class (CategoryOf k) => Labelled k where+  -- | @'label' s f@ is @f@, printed as @s@.+  label :: String -> (a :: k) ~> b -> a ~> b
+ src/Proarrow/Universal.hs view
@@ -0,0 +1,68 @@+-- | Universal properties of a functor at a single object: 'InitUniversal' @a r@ gives the universal+-- arrow from @a@ to the functor @r@, 'TermUniversal' dually. The 'AsRightAdjoint'\/'AsLeftAdjoint'+-- newtypes upgrade a functor with a universal property at /every/ object to a full+-- 'Proarrow.Adjunction.Adjunction'.+module Proarrow.Universal where++import Data.Kind (Constraint)++import Proarrow.Adjunction (Adjunction)+import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))+import Proarrow.Core (CategoryOf (..), Profunctor (..), type (+->))+import Proarrow.Profunctor.Corepresentable (Corepresentable (..), corepUniv)+import Proarrow.Profunctor.Representable (Representable (..), repUniv)++-- | The initial universal property of a functor @r@ (as a representable profunctor) and an object @a@.+type InitUniversal :: forall {j} {k}. k -> (j +-> k) -> Constraint+class (Representable r, Ob a) => InitUniversal (a :: k) (r :: j +-> k) where+  -- | The target of the universal arrow out of @a@.+  type InitUnivTgt r a :: j++  initUnivArr :: r a (InitUnivTgt r a)+  initUnivProp :: r a b -> InitUnivTgt r a ~> b++-- | The terminal universal property of a functor @l@ (as a corepresentable profunctor) and an object @b@.+type TermUniversal :: forall {j} {k}. j -> (j +-> k) -> Constraint+class (Corepresentable l, Ob b) => TermUniversal (b :: j) (l :: j +-> k) where+  -- | The source of the universal arrow into @b@.+  type TermUnivSrc l b :: k++  termUnivArr :: l (TermUnivSrc l b) b+  termUnivProp :: l a b -> a ~> TermUnivSrc l b++instance (TermUniversal b l) => InitUniversal (OP b) (Op l) where+  type InitUnivTgt (Op l) (OP b) = OP (TermUnivSrc l b)+  initUnivArr = Op termUnivArr+  initUnivProp (Op l) = Op (termUnivProp l)++instance (InitUniversal a r) => TermUniversal (OP a) (Op r) where+  type TermUnivSrc (Op r) (OP a) = OP (InitUnivTgt r a)+  termUnivArr = Op initUnivArr+  termUnivProp (Op l) = Op (initUnivProp l)++newtype AsRightAdjoint r a b = AsRightAdjoint {unAsRightAdjoint :: r a b}+  deriving newtype (Profunctor, Representable)+deriving newtype instance (InitUniversal a r) => InitUniversal a (AsRightAdjoint r)+instance (forall (a :: k). (Ob a) => InitUniversal a r, Representable r) => Corepresentable (AsRightAdjoint (r :: j +-> k)) where+  type AsRightAdjoint r %% a = InitUnivTgt r a+  coindex r = initUnivProp r \\ r+  corepUniv = initUnivArr++newtype AsLeftAdjoint l a b = AsLeftAdjoint {unAsLeftAdjoint :: l a b}+  deriving newtype (Profunctor, Corepresentable)+deriving newtype instance (TermUniversal b l) => TermUniversal b (AsLeftAdjoint l)+instance (forall b. (Ob b) => TermUniversal b l, Corepresentable l) => Representable (AsLeftAdjoint l) where+  type AsLeftAdjoint l % b = TermUnivSrc l b+  index l = termUnivProp l \\ l+  repUniv = termUnivArr++newtype FromAdjunction p a b = FromAdjunction {unFromAdjunction :: p a b}+  deriving newtype (Profunctor, Representable, Corepresentable)+instance (Adjunction p, Ob a) => InitUniversal a (FromAdjunction p) where+  type InitUnivTgt (FromAdjunction p) a = p %% a+  initUnivArr = corepUniv+  initUnivProp = coindex+instance (Adjunction p, Ob b) => TermUniversal b (FromAdjunction p) where+  type TermUnivSrc (FromAdjunction p) b = p % b+  termUnivArr = repUniv+  termUnivProp = index
+ test/Examples/Cofree.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | A worked instance of 'HasCofree', checked by the typechecker only. The cofree @Test@ object+-- on a Hask type is that type paired with the @Int@ the class produces, and that makes the+-- coKleisli category of the env comonad a 'Promonad'. There is nothing to assert at runtime, so+-- this module exports no 'Test.Tasty.TestTree'. Compiling it is the test, as in "Examples.Free".+module Examples.Cofree where++import Prelude (Int, fst, snd)++import Proarrow.Core (Promonad (..))+import Proarrow.Profunctor.Cofree (HasCofree (..), cofreeComp)+import Proarrow.Profunctor.Instance.Costar (Costar, pattern Costar)++class Test a where+  test :: a -> Int++instance HasCofree Test where+  type Cofree Test a = (Int, a)+  lower = snd+  unfoldMap f a = (test a, f a)++instance Test (Int, a) where+  test = fst++instance Promonad (Costar ((,) Int)) where+  id = Costar (lower @Test)+  Costar l . Costar r = Costar (cofreeComp @Test l r)
+ test/Examples/CustomLaws.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Law-checking a class of your own with 'testLaws', using only the exports of+-- "Proarrow.Testing.Laws.Run". It also keeps those exports honest: if one this needs goes+-- missing, this module stops compiling.+--+-- The class is a functor on objects, @'Sq' a = (a, a)@ in 'Type'. Checking its laws takes:+--+-- * the laws themselves, a 'Laws' instance for the structure list;+-- * a former for the new kind of object, here 'SqF', with a 'Tested' instance saying what it+--   stands for and how its 'Ob' and 'TestOb' are rebuilt;+-- * a 'Witness' for the structure, saying how 'TestOb' is closed under the former;+-- * the class instance for 'TESTED', whose arrows describe themselves for failure messages.+module Examples.CustomLaws where++import Data.Kind (Constraint, Type)+import Test.Tasty (TestTree)+import Prelude hiding (id, (.))++import Proarrow.Core (CategoryOf (..), Kind, Promonad (..), obj)+import Proarrow.Testing (TestOb)+import Proarrow.Testing.Laws.Run+  ( HasWitness (..)+  , TESTED+  , Tested (..)+  , Witness+  , Witnesses (..)+  , app+  , testLaws+  , pattern TestedArr+  )+import Proarrow.Tools.Laws (Law (..), Laws (..), (===))++import Props.Hask ()++-- | A functor on objects, given by a type family.+type HasSquare :: Kind -> Constraint+class (CategoryOf k) => HasSquare k where+  type Sq (a :: k) :: k+  withObSq :: (Ob (a :: k)) => ((Ob (Sq a)) => r) -> r+  sq :: (a :: k) ~> b -> Sq a ~> Sq b++instance HasSquare Type where+  type Sq a = (a, a)+  withObSq r = r+  sq f (x, y) = (f x, f y)++-- | 'sq' preserves identities and composition.+instance Laws '[HasSquare] where+  laws =+    [ Law "sq identity" \ @a _ -> withObSq @_ @a (sq (obj @a) === id)+    , Law "sq composition" \ @a @b @c mor -> do+        f <- mor @a @b "f"+        g <- mor @b @c "g"+        sq (g . f) === sq g . sq f+    ]++-- | The object former: @'SqF' a@ stands for @'Sq' a@.+data family SqF (a :: k) :: k++newtype instance Witness HasSquare k = SquareW (forall (a :: k) r. (TestOb a) => ((TestOb (Sq a)) => r) -> r)++instance (HasWitness HasSquare cs, HasSquare k, Tested (a :: TESTED cs k)) => Tested (SqF a) where+  type Untest (SqF a) = Sq (Untest a)+  untestOb r = untestOb @a (withObSq @k @(Untest a) r)+  untestTestOb ws r = untestTestOb @a ws (case witness @HasSquare ws of SquareW f -> f @(Untest a) r)++instance (HasWitness HasSquare cs, HasSquare k) => HasSquare (TESTED cs k) where+  type Sq a = SqF a+  withObSq r = r+  sq (TestedArr d f) = TestedArr (app "sq" d) (sq f)++test :: TestTree+test = testLaws @'[HasSquare] "Custom laws" (SquareW (\r -> r) :& WNil :: Witnesses '[HasSquare] Type)
+ test/Examples/Database.hs view
@@ -0,0 +1,431 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Functorial data migration, worked through the airline example of Fong and Spivak,+-- /Seven Sketches in Compositionality/ (arXiv:1803.05316), section 3.4.3.+--+-- A database __schema__ is a category, an __instance__ of it is a copresheaf, and a functor between+-- schemas induces three migrations: restriction @'Delta'@ and its left and right adjoints+-- @'Sigma'@ and @'Pi'@. None needs new machinery. A functor is a 'FunctorForRep', with conjoint+-- 'Rep' and companion 'Corep'; restriction and the left pushforward are profunctor composition,+-- and the right pushforward is the right Kan extension.+--+-- The schemas are the book's: @A@ tells economy seats from first class ones, @B@ does not. Each is+-- a free category on a graph ('PATHS'), and the functor between them is a graph map that+-- 'foldPaths' turns into a functor. Neither has path equations: every arrow lands in an attribute+-- object, which has no arrows out.+--+-- A second pair, @GraphSch@ and @Dds@, is section 3.4.1, which the book works through with tables+-- on both sides. @Dds@ is one point with a loop, so it has one morphism per number of steps.+--+-- The book's own schema, which has equations, is in "Props.Paths", since it exercises the free+-- category's laws rather than migration.+module Examples.Database (test) where++import Control.Monad (unless)+import Data.Type.Equality ((:~:) (..))+import Test.Falsify (testFailed)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (id, (.))++import Proarrow.Category.Enriched.Thin (Finite (..), Indexed (..), Member (..), memberIndex)+import Proarrow.Category.Instance.Discrete (DISCRETE (..))+import Proarrow.Category.Instance.Paths (PATHS (..), Paths (..), Rewrite, emb, foldPaths, pathLength)+import Proarrow.Category.Instance.Unit (Unit (..))+import Proarrow.Core (Any, CAT, CategoryOf (..), Profunctor (..), Promonad (..), UN, type (+->))+import Proarrow.Functor (Copresheaf, FunctorForRep (..))+import Proarrow.Object (pattern Objs)+import Proarrow.Profunctor.Corepresentable (Corep (..), Corepresentable (corepUniv))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Ran (Ran (..), runRan, type (|>))+import Proarrow.Profunctor.Representable (Rep (..), Representable (repUniv))++-- * The detailed schema @A@++-- | The points of schema @A@: two classes of seat, and the two attribute types. Bare data, with+-- 'DISCRETE' supplying the identity arrows.+type data APoint = EconomyP | FirstClassP | DollarsAP | StringAP++instance Indexed APoint+instance Finite APoint where type Objects APoint = '[EconomyP, FirstClassP, DollarsAP, StringAP]++type A' = DISCRETE APoint++type Economy' = D EconomyP :: A'+type FirstClass' = D FirstClassP :: A'+type DollarsA' = D DollarsAP :: A'+type StringA' = D StringAP :: A'++-- | A singleton for the points. The right pushforward is an end, so 'matchSeats' has to produce a+-- seat at an arbitrary point of this kind, and 'Ob' carries which point it has been handed. So+-- this kind cannot be @(\':~:\')@-arrowed like @B'@, whose 'Ob' is vacuous. 'memberIndex'+-- already refines a point to the one it is, but positionally, so the four positions get names.+type SA (a :: A') = Member a (Objects A')++pattern SEconomy :: () => (a ~ Economy') => SA a+pattern SEconomy = Here++pattern SFirstClass :: () => (a ~ FirstClass') => SA a+pattern SFirstClass = There Here++pattern SDollarsA :: () => (a ~ DollarsA') => SA a+pattern SDollarsA = There (There Here)++pattern SStringA :: () => (a ~ StringA') => SA a+pattern SStringA = There (There (There Here))++{-# COMPLETE SEconomy, SFirstClass, SDollarsA, SStringA #-}++-- | The generating arrows: each class of seat has a price and a position.+type GA :: CAT A'+data GA a b where+  PriceE :: GA Economy' DollarsA'+  PosE :: GA Economy' StringA'+  PriceF :: GA FirstClass' DollarsA'+  PosF :: GA FirstClass' StringA'++-- | No equations: the schema is free on that graph.+instance Rewrite GA++type A = PATHS GA++type Economy = PTH Economy' :: A+type FirstClass = PTH FirstClass' :: A+type DollarsA = PTH DollarsA' :: A+type StringA = PTH StringA' :: A++-- * The merged schema @B@++-- | One class of seat, and the same two attribute types. Nothing maps out of @B'@, so a vacuous+-- 'Ob' is fine here and @(':~:')@ does the job in one line.+type data B' = AirlineSeat' | DollarsB' | StringB'++instance CategoryOf B' where+  type (~>) = (:~:)+  type Ob a = Any a++type GB :: CAT B'+data GB a b where+  PriceB :: GB AirlineSeat' DollarsB'+  PosB :: GB AirlineSeat' StringB'++instance Rewrite GB++type B = PATHS GB++type AirlineSeat = PTH AirlineSeat' :: B++-- * The functor between them++-- | Forget which class a seat is in, on points.+type MergePt :: A' -> B'+type family MergePt a where+  MergePt Economy' = AirlineSeat'+  MergePt FirstClass' = AirlineSeat'+  MergePt DollarsA' = DollarsB'+  MergePt StringA' = StringB'++-- | The functor on the schemas. Only the graph map is given; the universal property of the free+-- category supplies the rest, and there is nothing to check. The object witness is @\\r -> r@+-- because every image is a point of @B@, whose objects are unconstrained.+data family Merge :: A +-> B++instance FunctorForRep Merge where+  type Merge @ x = PTH (MergePt (UN PTH x))+  fmap f@Objs =+    foldPaths @(Rep Merge)+      (\r -> r)+      ( \case+          PriceE -> emb PriceB+          PosE -> emb PosB+          PriceF -> emb PriceB+          PosF -> emb PosB+      )+      f++-- * An instance of the detailed schema++-- | The tables. Two economy seats, two first class ones, and the attribute values they use.+--+-- > Economy | Price | Position       First Class | Price | Position+-- > E1      | 300   | 12A            F1          | 1200  | 2A+-- > E2      | 350   | 14C            F2          | 300   | 12A+type Seats :: Copresheaf A+data Seats u a where+  E1, E2 :: Seats '() Economy+  F1, F2 :: Seats '() FirstClass+  P :: Int -> Seats '() DollarsA+  Pos :: String -> Seats '() StringA++deriving instance Eq (Seats u a)+deriving instance Show (Seats u a)++-- | The table itself, one entry per generating arrow. Acting by @PriceE@ reads the price column of+-- the economy table.+step :: GA a b -> Seats '() (PTH a) -> Seats '() (PTH b)+step PriceE E1 = P 300+step PriceE E2 = P 350+step PosE E1 = Pos "12A"+step PosE E2 = Pos "14C"+step PriceF F1 = P 1200+step PriceF F2 = P 300+step PosF F1 = Pos "2A"+step PosF F2 = Pos "12A"++-- | Functoriality of the instance is that table, walked along a path. The recursion is generic; all+-- the data is in 'step'.+instance Profunctor Seats where+  dimap Unit PNil x = x+  dimap Unit (PCons g rest) x = step g (dimap Unit rest x)+  r \\ s = case s of+    E1 -> r+    E2 -> r+    F1 -> r+    F2 -> r+    P _ -> r+    Pos _ -> r++-- * The three migrations++-- | Restriction: read a @B@-instance as an @A@-instance, by composing with the conjoint.+type Delta :: a +-> b -> Copresheaf b -> Copresheaf a+type Delta f g = g :.: Rep f++-- | The left pushforward: composition with the companion. The coend is the existential of ':.:'.+--+-- That existential skips the coend's quotient, which identifies a row with its image under every+-- arrow. Here nothing is lost, since merging the seat classes relates nothing new. For the functor+-- to the one-point schema (section 3.4.4) it would matter: the book gets the connected components+-- of the emails, this gives the disjoint union of all rows.+type Sigma :: a +-> b -> Copresheaf a -> Copresheaf b+type Sigma f i = i :.: Corep f++-- | The right pushforward: the right Kan extension along the conjoint. The end is the @forall@ of+-- 'Ran'.+type Pi :: a +-> b -> Copresheaf a -> Copresheaf b+type Pi f i = Rep f |> i++-- | Restriction is lookup at the image object. The coend has nothing to range over once the+-- conjoint is there, so it collapses by coYoneda, and 'toDelta' takes it back.+fromDelta :: (Profunctor j) => Delta f j u x -> j u (f @ x)+fromDelta (j :.: Rep g) = rmap g j++toDelta :: forall {a} {b} (x :: a) (f :: a +-> b) j u. (FunctorForRep f, Ob x) => j u (f @ x) -> Delta f j u x+toDelta j = j :.: repUniv++-- | Every row of an instance turns up in its left pushforward, sitting at the image of the object+-- it came from. This is the unit of @'Sigma' f ⊣ 'Delta' f@ read through 'fromDelta', and it is why+-- the pushforward is a union: two objects with the same image land in the same table.+toSigma :: forall {a} {b} (x :: a) (f :: a +-> b) i u. (FunctorForRep f, Ob x) => i u x -> Sigma f i u (f @ x)+toSigma i = i :.: corepUniv++-- | Reading one component out of a right pushforward, at the image of the object asked for. This is+-- the counit of @'Delta' f ⊣ 'Pi' f@, so it runs from the pushforward back to the instance, where+-- 'toSigma' runs the other way. A unit points into its pushforward and a counit out of one, and+-- which of the two a pushforward gets is fixed by the side of restriction it is adjoint on.+fromPi :: forall {a} {b} (x :: a) (f :: a +-> b) i u. (FunctorForRep f, Ob x) => Pi f i u (f @ x) -> i u x+fromPi = runRan repUniv++-- | The same read along an arrow of the target schema rather than at the image object itself. A+-- right pushforward answers one question per arrow into an image, and 'fromPi' is the case where+-- that arrow is the identity.+atPi :: forall {a} {b} (x :: a) (f :: a +-> b) i u c. (FunctorForRep f, Ob x) => (c ~> f @ x) -> Pi f i u c -> i u x+atPi g = runRan (Rep g)++-- * The left pushforward is the union++-- | Every seat of either class becomes an airline seat. Nothing here says which table a seat came+-- from: 'toSigma' sends it to the image of its own object, and both seat objects have the same+-- image, so all four land in one table.+mergedSeats :: [Sigma Merge Seats '() AirlineSeat]+mergedSeats = [toSigma E1, toSigma E2, toSigma F1, toSigma F2]++-- | Read a merged seat back, by asking the singleton which table it came from. Only the two seat+-- objects can appear: an attribute object would need an arrow from @DollarsB@ or @StringB@ to+-- @AirlineSeat@, and the schema has none, so those cases are unreachable and need no equation.+seatName :: Sigma Merge Seats '() AirlineSeat -> String+seatName (s :.: Corep @a PNil) = case memberIndex @(UN PTH a) of+  SEconomy -> "economy " ++ show s+  SFirstClass -> "first class " ++ show s++-- * Restriction duplicates++-- | One merged seat, read back as an economy row and as a first class row. The two definitions are+-- the same expression at two different types, which is the duplication the book describes: both+-- seat objects have image @AirlineSeat@, so 'toDelta' accepts the same seat for either.+economyRow :: Delta Merge (Sigma Merge Seats) '() Economy+economyRow = toDelta (toSigma E1)++firstClassRow :: Delta Merge (Sigma Merge Seats) '() FirstClass+firstClassRow = toDelta (toSigma E1)++-- | And one reader serves both, for the same reason.+readRow :: (Merge @ x ~ AirlineSeat) => Delta Merge (Sigma Merge Seats) '() x -> String+readRow = seatName . fromDelta++-- * The right pushforward is the join++-- | A pair of seats, one of each class, as an element of the right pushforward at @AirlineSeat@.+--+-- Only the pair is data. The two attribute components are forced: they are read off the economy+-- seat by the instance's own functoriality. The end condition says that reading them off the first+-- class seat gives the same answer. That agreement is tested for here, so this returns 'Nothing'+-- for a pair that does not agree instead of building an ill-formed element.+matchSeats :: Seats '() Economy -> Seats '() FirstClass -> Maybe (Pi Merge Seats '() AirlineSeat)+matchSeats e f+  | dimap Unit (emb PriceE) e == dimap Unit (emb PriceF) f+  , dimap Unit (emb PosE) e == dimap Unit (emb PosF) f =+      Just+        ( Ran \(Rep @x _) -> case memberIndex @(UN PTH x) of+            SEconomy -> e+            SFirstClass -> f+            SDollarsA -> dimap Unit (emb PriceE) e+            SStringA -> dimap Unit (emb PosE) e+        )+  | otherwise = Nothing++-- | The join: every pair of seats that agrees on both attributes.+theJoin :: [Pi Merge Seats '() AirlineSeat]+theJoin = [p | e <- [E1, E2], f <- [F1, F2], Just p <- [matchSeats e f]]++-- * Restriction from a schema with infinitely many arrows++-- | Section 3.4.1. The graph schema: an arrow has a source and a target vertex.+type data GR' = Arrow' | Vertex'++instance CategoryOf GR' where+  type (~>) = (:~:)+  type Ob a = Any a++type GGr :: CAT GR'+data GGr a b where+  Source :: GGr Arrow' Vertex'+  Target :: GGr Arrow' Vertex'++instance Rewrite GGr++type GraphSch = PATHS GGr++type Arrow = PTH Arrow' :: GraphSch+type Vertex = PTH Vertex' :: GraphSch++-- | The discrete dynamical system schema: one point, one arrow from it to itself. Its morphisms are+-- the powers of that arrow, so unlike every other schema here it has infinitely many of them. A+-- free category gives them for nothing; a hand-written morphism type would have to index by a+-- number and re-derive composition.+type data DDS' = State'++instance CategoryOf DDS' where+  type (~>) = (:~:)+  type Ob a = Any a++type GDds :: CAT DDS'+data GDds a b where+  Next :: GDds State' State'++instance Rewrite GDds++type Dds = PATHS GDds++type State = PTH State' :: Dds++twoSteps :: State ~> State+twoSteps = emb Next . emb Next++-- | Both points of the graph schema go to the single state, the source arrow to the identity and+-- the target arrow to one step of the machine.+type FPt :: GR' -> DDS'+type family FPt a where+  FPt Arrow' = State'+  FPt Vertex' = State'++data family Unroll :: GraphSch +-> Dds++instance FunctorForRep Unroll where+  type Unroll @ x = PTH (FPt (UN PTH x))+  fmap f@Objs =+    foldPaths @(Rep Unroll)+      (\r -> r)+      ( \case+          Source -> id+          Target -> emb Next+      )+      f++-- | The machine of equation 3.65: seven states, each with a next.+--+-- > State | next     State | next+-- > 1     | 4        5     | 5+-- > 2     | 4        6     | 7+-- > 3     | 5        7     | 6+-- > 4     | 5+type Machine :: Copresheaf Dds+data Machine u a where+  St1, St2, St3, St4, St5, St6, St7 :: Machine '() State++deriving instance Eq (Machine u a)+deriving instance Show (Machine u a)++machineStep :: GDds a b -> Machine '() (PTH a) -> Machine '() (PTH b)+machineStep Next St1 = St4+machineStep Next St2 = St4+machineStep Next St3 = St5+machineStep Next St4 = St5+machineStep Next St5 = St5+machineStep Next St6 = St7+machineStep Next St7 = St6++instance Profunctor Machine where+  dimap Unit PNil x = x+  dimap Unit (PCons g rest) x = machineStep g (dimap Unit rest x)+  r \\ s = case s of+    St1 -> r+    St2 -> r+    St3 -> r+    St4 -> r+    St5 -> r+    St6 -> r+    St7 -> r++states :: [Machine '() State]+states = [St1, St2, St3, St4, St5, St6, St7]++-- | Restricting the machine along that functor turns it into a graph. Both tables hold the states,+-- because both points have the same image, and the source and target columns are read off by the+-- restricted instance's own functoriality rather than by hand.+type Graph = Delta Unroll Machine++asArrow :: Machine '() State -> Graph '() Arrow+asArrow = toDelta++sourceOf, targetOf :: Graph '() Arrow -> Graph '() Vertex+sourceOf = dimap Unit (emb Source)+targetOf = dimap Unit (emb Target)++test :: TestTree+test =+  testGroup+    "Database"+    [ testProperty "the left pushforward unions the two seat tables" $+        unless+          (map seatName mergedSeats == ["economy E1", "economy E2", "first class F1", "first class F2"])+          (testFailed "the merged table should hold all four seats, tagged by where they came from")+    , testProperty "restriction copies a merged seat into both tables" $ do+        unless (readRow economyRow == "economy E1") (testFailed "E1 should appear as an economy row")+        unless (readRow firstClassRow == "economy E1") (testFailed "E1 should appear as a first class row too")+    , testProperty "the right pushforward joins the two tables" $ case theJoin of+        [p] -> do+          unless (fromPi @Economy p == E1) (testFailed "the economy half should be E1")+          unless (fromPi @FirstClass p == F2) (testFailed "the first class half should be F2")+          unless (atPi @DollarsA (emb PriceB) p == P 300) (testFailed "the shared price should be 300")+          unless (atPi @StringA (emb PosB) p == Pos "12A") (testFailed "the shared position should be 12A")+        ps -> testFailed ("exactly one pair of seats agrees, found " ++ show (length ps))+    , testProperty "restriction turns the machine into the book's graph" $ do+        unless+          (map (fromDelta . sourceOf . asArrow) states == states)+          (testFailed "the source column should be the identity")+        unless+          (map (fromDelta . targetOf . asArrow) states == [St4, St4, St5, St5, St5, St7, St6])+          (testFailed "the target column should be one step of the machine")+        unless (pathLength twoSteps == 2) (testFailed "the loop schema should have a two-step arrow")+    ]
+ test/Examples/Free.hs view
@@ -0,0 +1,110 @@+{- HLINT ignore "Redundant $" -}+{-# LANGUAGE LinearTypes #-}++-- | A small free category on a two-object quiver, folded through an interpretation, plus a lambda+-- term built in the free cartesian closed category. Most of this is checked just by compiling it,+-- since the types are what matter, but the fold does produce a value, which is asserted at the end.+module Examples.Free where++import Data.Kind (Constraint, Type)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude qualified as P++import Proarrow.Category.Enriched.Thin (Finite (..), Indexed (..))+import Proarrow.Category.Instance.Discrete (DISCRETE (..), Discrete (..))+import Proarrow.Category.Instance.Free (FREE (..), Free (..), fold)+import Proarrow.Category.Monoidal (Monoidal (..), SymMonoidal (..), UnitF, (**), type (**!))+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), type (+->))+import Proarrow.Functor (FunctorForRep (..))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts, (&&&), type (*!))+import Proarrow.Profunctor.Representable (Rep, Representable (..))+import Proarrow.Testing (expect)+import Unsafe.Coerce (unsafeCoerce)++type data TestTy = IntTy' | StringTy'++instance Indexed TestTy+instance Finite TestTy where type Objects TestTy = '[IntTy', StringTy']++type IntTy = D IntTy'+type StringTy = D StringTy'+data Test a b where+  Show :: Test IntTy StringTy+  Read :: Test StringTy IntTy+  Succ :: Test IntTy IntTy+  Dup :: Test StringTy StringTy++shw :: (i :: FREE cs Test) ~> EMB IntTy %1 -> i ~> EMB StringTy+shw = Emb Show++read :: (i :: FREE cs Test) ~> EMB StringTy %1 -> i ~> EMB IntTy+read = Emb Read++succ :: (i :: FREE cs Test) ~> EMB IntTy %1 -> i ~> EMB IntTy+succ = Emb Succ++dup :: (i :: FREE cs Test) ~> EMB StringTy %1 -> i ~> EMB StringTy+dup = Emb Dup++pipeline :: (i :: FREE cs Test) ~> EMB StringTy %1 -> i ~> EMB StringTy+pipeline x = dup (shw (succ (read x)))++pipelineWithInput+  :: (HasBinaryProducts (FREE cs Test)) => (i :: FREE cs Test) ~> EMB StringTy -> i ~> (EMB StringTy *! EMB StringTy)+pipelineWithInput x = x &&& pipeline x++data family Interp :: DISCRETE TestTy +-> Type+instance FunctorForRep Interp where+  type Interp @ IntTy = P.Int+  type Interp @ StringTy = P.String+  fmap Refl = id++-- | Read the string as an int, increment, show it, and duplicate, alongside the untouched input.+testFold :: P.String -> (P.String, P.String)+testFold = fold @'[HasBinaryProducts] @(Rep Interp) interp (pipelineWithInput Nil)+  where+    interp :: Test x y -> Rep Interp % x ~> Rep Interp % y+    interp Show = P.show+    interp Read = P.read+    interp Succ = P.succ+    interp Dup = \s -> s P.++ s++type SwapIn :: FC -> FC -> FC -> Constraint+class SwapIn (ia :: FC) i a | ia i -> a where+  swapIn :: (Ob a, Ob i) => a ** i ~> (ia :: FC)++instance SwapIn (a **! i) i a where+  swapIn = id+instance SwapIn (i **! a) i a where+  swapIn = swap+instance SwapIn i i UnitF where+  swapIn = leftUnitor++type Cls = '[Closed, Monoidal, SymMonoidal]+type FC = FREE Cls Test++lam+  :: forall ia i a b+   . (SwapIn ia i a, Ob i, Ob a)+  => ((i :: FC) ~> i %1 -> (ia :: FC) ~> b) %1 -> a ~> (i ~~> b)+lam = unsafeLinear \f -> curry (f id . swapIn)++($) :: forall {k} (a :: k) a' (b :: k) i. (Closed k, Ob b) => a ~> (i ~~> b) %1 -> a' ~> i %1 -> a ** a' ~> b+($) = unsafeLinear \f -> unsafeLinear \x -> apply @k @i @b . (f ** x) \\ x++testLam :: forall (a :: FC) b. (Ob a, Ob b) => UnitF ~> ((a ~~> b) ~~> (a ~~> b))+testLam = lam \f -> lam \x -> f $ x++unsafeLinear :: (a -> b) -> (a %1 -> b)+unsafeLinear = unsafeCoerce++test :: TestTree+test =+  testGroup+    "Free"+    [ testProperty+        "the pipeline folds through the interpretation"+        (expect "input paired with succ-then-duplicate" ("123", "124124") (testFold "123"))+    ]
+ test/Examples/FrontDoor.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Compiles the import incantation documented in "Proarrow"'s module header, using at least one+-- name from every section of its export list. Nothing else in the repo imports the front door, so+-- without this the documented line is never checked by a compiler.+module Examples.FrontDoor where++import Proarrow+import Prelude hiding (Functor, Monad, Monoid, fmap, id, map, mappend, mempty, return, (.))++-- categories and profunctors+frontId :: (CategoryOf k, Ob (a :: k)) => a ~> a+frontId = id++frontComp :: (CategoryOf k, Ob (a :: k), Ob b, Ob c) => b ~> c -> a ~> b -> a ~> c+frontComp = (.)++frontDimap :: (Profunctor p) => c ~> a -> b ~> d -> p a b -> p c d+frontDimap = dimap++-- objects+frontObj :: (CategoryOf k, Ob (a :: k)) => Obj a+frontObj = obj++-- functors+frontFmap :: forall f a b. (FunctorForRep f) => a ~> b -> f @ a ~> f @ b+frontFmap = fmap @f++-- promonads as effects+frontReturn :: forall m a. (Monad m, Ob a) => a ~> m % a+frontReturn = return @m++frontExtract :: forall w a. (Comonad w, Ob a) => w %% a ~> a+frontExtract = extract @w++-- The monoid section is usable from here alone. At a concrete category @Unit@ and @**@ reduce+-- (to @()@ and @(,)@ in Hask), so neither name has to be written and the monoidal vocabulary does+-- not have to be imported, even though 'Proarrow' exports none of it.+frontMempty :: () -> [Int]+frontMempty = mempty++frontMappend :: ([Int], [Int]) -> [Int]+frontMappend = mappend++-- universal properties and adjunctions+frontLeftAdjunct :: forall p a b. (Adjunction p, Ob a) => (p %% a ~> b) -> a ~> p % b+frontLeftAdjunct = leftAdjunct @p++-- optics+frontLens :: Lens' (Int, Char) Int+frontLens = lens fst (\((_, c), i) -> (i, c))++frontView :: (Int, Char) -> Int+frontView = view frontLens
+ test/Examples/Graph.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | __The schema of directed graphs__: the two-object category @E ⇉ V@, worked out in full. A+-- copresheaf on it is a graph, a profunctor @'GRAPH' '+->' k@ is a diagram of graphs shaped like+-- @k@, and both are finitary whenever the sets are. Small as it is, it is a complete example of+-- standing up a finite category: the arrows, the object enumeration, the numbering of the hom-sets+-- that makes it a 'Proarrow.Category.Enriched.Finitary.FiniteCat', and the instances that make it+-- testable. "Props.Finitary.Graph" and "Props.DPO" are what it is put to work for.+module Examples.Graph where++import Data.List (genericIndex, genericLength)+import Data.Type.Nat (SNat (..), snat)+import Test.Tasty (TestTree, testGroup)+import Prelude hiding (id, (.))++import Proarrow.Category.Enriched.Finitary (Finitary (..))+import Proarrow.Category.Enriched.Thin (Enumerable (..), Finite (..), Indexed (..))+import Proarrow.Category.Sheaf+  ( Coverage+  , Factors (..)+  , HasFiniteCovers (..)+  , PulledBack (..)+  , Site (..)+  , SomeCover (..)+  , SomeLeg (..)+  , StableSite (..)+  , pullbackAlongId+  )+import Proarrow.Core (CAT, CategoryOf (..), ObId (..), Profunctor (..), Promonad (..), dimapDefault, obj)+import Proarrow.Testing+  ( GenTotal (..)+  , Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow+  , genSomeFinite+  , optGen+  )+import Proarrow.Testing.Laws (testCategory, testFinitary)++-- | Two objects: the edges and the vertices.+type data GRAPH = E | V++-- | Four morphisms: the two identities, and an edge's source and target.+type GraphHom :: CAT GRAPH+data GraphHom a b where+  IdE :: GraphHom E E+  IdV :: GraphHom V V+  Src :: GraphHom E V+  Tgt :: GraphHom E V++deriving instance Eq (GraphHom a b)+deriving instance Show (GraphHom a b)++instance ObId E where objId = IdE+instance ObId V where objId = IdV++instance CategoryOf GRAPH where+  type (~>) = GraphHom++instance Profunctor GraphHom where+  dimap = dimapDefault+  r \\ f = case f of IdE -> r; IdV -> r; Src -> r; Tgt -> r++instance Promonad GraphHom where+  g . IdE = g+  IdV . f = f++instance Indexed GRAPH+instance Finite GRAPH where type Objects GRAPH = '[E, V]+instance Enumerable GRAPH where+  withIndex @a r = case obj @a of+    IdE -> r+    IdV -> r+  withOb @a r = case snat @(Index a) of+    SZ -> r+    SS @i -> case snat @i of SZ -> r++-- | The arrows of the schema, which is all the numbering needs: two identities and the two+-- incidence maps. Since there are finitely many, the gluing conditions can be enumerated.+graphHoms :: forall a b. (Ob a, Ob b) => [GraphHom a b]+graphHoms = case (obj @a, obj @b) of+  (IdE, IdE) -> [IdE]+  (IdV, IdV) -> [IdV]+  (IdE, IdV) -> [Src, Tgt]+  (IdV, IdE) -> []++instance Finitary GraphHom where+  size @a @b = genericLength (graphHoms @a @b)+  toIndex IdE = 0+  toIndex IdV = 0+  toIndex Src = 0+  toIndex Tgt = 1+  fromIndex @a @b i = graphHoms @a @b `genericIndex` i+  elements = graphHoms++-- * A coverage on the schema++-- | A coverage on the graph schema @E ⇉ V@: the vertex 'V' is covered by the two ends of an edge,+-- the arrows 'Src' and 'Tgt' out of 'E'. Most sites in this repo are posets, with at most one+-- arrow between two objects. Here the legs are parallel, so a sieve at 'V' (a set of arrows+-- into 'V' closed under precomposition) can hold 'Src' without 'Tgt', and a factorisation through+-- a leg can be well typed and still wrong. That gives 'Proarrow.Testing.Laws.testStableSite'+-- something to check.+--+-- It is a Grothendieck topology: the only arrows into 'V' are its identity and the two legs, so a+-- cover pulls back either to itself or to the identity cover of 'E'. It is also+-- 'Proarrow.Category.Sheaf.ByImage' of the inclusion of 'E', written out because the schema reads+-- better as itself.+--+-- A sheaf for it is a presheaf with @p 'V' ≅ p 'E' × p 'E'@. The legs do not overlap (nothing but+-- 'E' maps into 'E'), so matching is vacuous and gluing is a product. For overlapping legs see+-- @Props.Sheaf@\'s @Overlapping@, on a poset.+type ByEnds :: Coverage+type data ByEnds++-- | The name of 'ByEnds'\'s one cover, whose 'Cover' constructor is @VByEnds@ and whose 'Leg'+-- constructors are @AtSrc@ and @AtTgt@.+type data Endpoints++instance Site ByEnds GRAPH where+  data Cover ByEnds GRAPH a c where+    VByEnds :: Cover ByEnds GRAPH V Endpoints+  data Leg ByEnds GRAPH a c x where+    AtSrc :: Leg ByEnds GRAPH V Endpoints E+    AtTgt :: Leg ByEnds GRAPH V Endpoints E+  legArrow AtSrc = Src+  legArrow AtTgt = Tgt+  legs VByEnds = [SomeLeg AtSrc, SomeLeg AtTgt]++instance HasFiniteCovers ByEnds GRAPH where+  covers @a = case obj @a of+    IdE -> []+    IdV -> [SomeCover VByEnds]++-- | Each leg is its own pullback along itself, and the cover pulls back to itself along the+-- identity. @'Factors' AtTgt IdE@ type-checks where @'Factors' AtSrc IdE@ is meant, since the legs+-- share a source, so unlike on a poset these equations are the instance's to get right.+instance StableSite ByEnds GRAPH where+  pullbackCover VByEnds IdV = pullbackAlongId VByEnds+  pullbackCover VByEnds Src = AlreadyFactors (Factors AtSrc IdE)+  pullbackCover VByEnds Tgt = AlreadyFactors (Factors AtTgt IdE)++-- * The schema as a testable category++instance TestingEqShow (GraphHom a b)++instance (Ob a, Ob b) => TestableType (GraphHom a b) where+  gen = case (obj @a, obj @b) of+    (IdE, IdE) -> optGen [IdE]+    (IdV, IdV) -> optGen [IdV]+    (IdE, IdV) -> optGen [Src, Tgt]+    (IdV, IdE) -> GenEmpty \case {}++instance TestableProfunctor GraphHom++instance Testable GRAPH where+  showOb @a = case obj @a of IdE -> "E"; IdV -> "V"+  genSome = genSomeFinite++test :: TestTree+test =+  testGroup+    "Graph"+    [ testCategory @GRAPH+    , -- the numbering of the hom-sets, which everything finitary over this schema is built on+      testFinitary @GraphHom "GraphHom"+    ]
+ test/Examples/Readme.hs view
@@ -0,0 +1,40 @@+-- | The "define your own category" example from @proarrow\/README.md@, compiled so it cannot+-- rot. Keep the two in sync: the README block is the same text with the pragma line on top.+--+-- It is also the only thing exercising the @'Ob' = 'ObId'@ and @'id' = 'objId'@ defaults, so it+-- belongs here and not only in prose.+module Examples.Readme where++import Prelude hiding (id, (.))++import Proarrow.Core (CAT, CategoryOf (..), ObId (..), Profunctor (..), Promonad (..), dimapDefault)++type data STATE = Draft | Live++type Move :: CAT STATE+data Move a b where+  KeepDraft :: Move Draft Draft+  Publish :: Move Draft Live+  KeepLive :: Move Live Live++deriving instance Show (Move a b)++-- 'id' has to produce the identity at whichever object it is asked for, so being an+-- object is the ability to supply that identity:+instance ObId Draft where objId = KeepDraft+instance ObId Live where objId = KeepLive++instance CategoryOf STATE where+  type (~>) = Move++instance Promonad Move where+  KeepDraft . KeepDraft = KeepDraft+  Publish . KeepDraft = Publish+  KeepLive . Publish = Publish+  KeepLive . KeepLive = KeepLive++instance Profunctor Move where+  dimap = dimapDefault+  r \\ KeepDraft = r+  r \\ Publish = r+  r \\ KeepLive = r
+ test/Examples/SimplyTypedLambdaCalculus.hs view
@@ -0,0 +1,528 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Examples.SimplyTypedLambdaCalculus where++import Control.Applicative (Alternative (..))+import Data.Kind (Constraint, Type)+import Data.Type.Equality ((:~:) (..))+import Prelude hiding (curry, fst, id, snd, (.))++import Test.Falsify.Generator (Function)+import Test.Tasty (TestTree, testGroup)++import Proarrow.Core+  ( CAT+  , CategoryOf (..)+  , ObId (..)+  , Profunctor (..)+  , Promonad (..)+  , dimapDefault+  , obj+  , (//)+  , type (+->)+  )+import Proarrow.Limit.Terminal (HasTerminalObject (..))++import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..))+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Limit.BinaryProduct+  ( HasBinaryProducts (..)+  , associatorProd+  , associatorProdInv+  , leftUnitorProd+  , leftUnitorProdInv+  , rightUnitorProd+  , rightUnitorProdInv+  )+import Proarrow.Testing+  ( GenTotal (..)+  , MkSomeList (..)+  , Some (..)+  , SomeProfunctorElt (..)+  , Testable (..)+  , TestableProfunctor (..)+  , TestableType (..)+  , TestingEqShow (..)+  , eqHask+  , genNamed+  , genObSuchThat+  , genSomeDef+  , isGenNonEmpty+  , oneElem+  , oneOfTotal+  )+import Proarrow.Testing.Laws+  ( testBinaryProducts+  , testCategory+  , testClosed+  , testMonoidal+  , testProfunctor+  , testTerminalObject+  )+import Props.Hask ()++type data TY = K | TY :=> TY++instance ObId K where objId = SK+instance (ObId a, ObId b) => ObId (a :=> b) where objId = SF++type Ty :: CAT TY+data Ty g h where+  SK :: Ty K K+  SF :: (Ob a, Ob b) => Ty (a :=> b) (a :=> b)+instance Profunctor Ty where+  dimap = dimapDefault+  r \\ SK = r+  r \\ SF = r+instance Promonad Ty where+  SK . SK = SK+  SF . SF = SF+instance CategoryOf TY where+  type (~>) = Ty++type data CON = E | CON :> TY++type Sub :: CAT CON+data Sub g h where+  Comp :: Sub h j -> Sub g h -> Sub g j+  Empty :: Sub E E+  Cons :: Sub g h -> Tm g a -> Sub g (h :> a)+  Wk :: (Ob a, Ob g) => Sub (g :> a) g++type Tm :: TY +-> CON+data Tm g a where+  Vz :: (Ob a, Ob g) => Tm (g :> a) a+  Vs :: (Ob b) => Tm g a -> Tm (g :> b) a+  Lam :: (Ob g, Ob a) => Tm (g :> a) b -> Tm g (a :=> b)+  App :: forall a b g. (Ob b) => Tm g (a :=> b) -> Tm g a -> Tm g b++instance Profunctor Sub where+  dimap = dimapDefault+  r \\ Comp f g = r \\ f \\ g+  r \\ Empty = r+  r \\ Cons f t = r \\ f \\ t+  r \\ Wk = r+instance Promonad Sub where+  id @a = case sing @a of+    SE -> Empty+    SC @g' -> Cons (obj @g' . Wk) Vz+  Comp f g . h = f . (g . h)+  Empty . f = f+  Wk @a . r = pComp r+    where+      pComp :: (Ob g) => Sub h (g :> a) -> Sub h g+      pComp (Cons f _) = f+      pComp (Comp g h) = case pComp g of+        c | c == Comp Wk g -> Comp Wk (Comp g h)+        x -> x . h+      pComp s = Comp Wk s+  Cons f t . r = cons (f . r) (lmap r t)+instance CategoryOf CON where+  type (~>) = Sub+  type Ob a = (ConOb a)+instance HasTerminalObject CON where+  type TerminalObject = E+  terminate @a = case sing @a of+    SE -> Empty+    SC @a' -> terminate @CON @a' . Wk++instance HasBinaryProducts CON where+  type n && E = n+  type n && (g :> a) = (n && g) :> a++  withObProd @a @b r =+    case sing @b of+      SE -> r+      SC @b' -> withObProd @CON @a @b' r+  fst @a @b = case sing @b of+    SE -> obj @a+    SC @b' -> let f = fst @CON @a @b' in f . Wk \\ f+  snd @a @b = case sing @b of+    SE -> terminate+    SC @b' -> let f = snd @CON @a @b' in lift f+  (&&&) @_ @_ @y l r =+    r // case sing @y of+      SE -> l+      SC -> cons (l &&& Comp Wk r) (lmap r Vz)++instance MonoidalProfunctor Sub where+  one = id+  (**) = (***)++instance Monoidal CON where+  type a ** b = a && b+  type Unit = TerminalObject+  withOb2 @a @b = withObProd @_ @a @b+  leftUnitor = leftUnitorProd+  leftUnitorInv = leftUnitorProdInv+  rightUnitor = rightUnitorProd+  rightUnitorInv = rightUnitorProdInv+  associator @a @b @c = associatorProd @a @b @c+  associatorInv @a @b @c = associatorProdInv @a @b @c++type family Exp (g :: CON) (a :: TY) :: CON where+  Exp E _ = E+  Exp (g :> b) a = Exp g a :> (a :=> b)++withObExpSub :: forall g a r. (Ob g, Ob a) => ((Ob (Exp g a)) => r) -> r+withObExpSub r = case sing @g of+  SE -> r+  SC @g' -> withObExpSub @g' @a r++currySub :: forall a d g. (Ob g, Ob a) => Sub (g :> a) d -> Sub g (Exp d a)+currySub s =+  s // case sing @d of+    SE -> terminate+    SC -> case uncons s of (s1, t) -> cons (currySub s1) (Lam t)++uncurrySub :: forall a d g. (Ob d, Ob a) => Sub g (Exp d a) -> Sub (g :> a) d+uncurrySub s =+  s // case sing @d of+    SE -> terminate+    SC @g' -> withObExpSub @g' @a $ case uncons s of (s', t) -> cons (uncurrySub s') (App (Vs t) Vz)++instance Closed CON where+  type E ~~> d = d+  type (g :> a) ~~> d = g ~~> Exp d a+  withObExp @g @d r = case sing @g of+    SE -> r+    SC @g' @a -> withObExpSub @d @a $ withObExp @CON @g' @(Exp d a) r+  curry @d @g f =+    f // case sing @g of+      SE -> f+      SC @g' -> withObProd @CON @d @g' (curry @CON @d @g' (currySub f))+  apply @d @g = case sing @d of+    SE -> id+    SC @d' @a -> withObExpSub @g @a $ uncurrySub (apply @CON @d' @(Exp g a))++class (E && a ~ a, (c && b) && a ~ c && (b && a)) => Rules a b c+instance (E && a ~ a, (c && b) && a ~ c && (b && a)) => Rules a b c++type SingCon :: CON -> Type+data SingCon g where+  SE :: SingCon E+  SC :: (Ob g, Ob a) => SingCon (g :> a)+class (forall b c. Rules g b c) => ConOb g where sing :: SingCon g+instance ConOb E where sing = SE+instance (Ob g, Ob a) => ConOb (g :> a) where sing = SC++instance Profunctor Tm where+  lmap (Comp l r) t = lmap r (lmap l t)+  lmap (Cons _ t) Vz = t+  lmap (Cons f _) (Vs t) = lmap f t+  lmap l (Lam t) = Lam (lmap (cons (l . Wk) Vz) t) \\ l+  lmap l (App s t) = App (lmap l s) (lmap l t)+  lmap Wk t = Vs t++  rmap SK = id+  rmap SF = id++  r \\ Vz = r+  r \\ Vs f = r \\ f+  r \\ Lam t = r \\ t+  r \\ App t _ = r \\ t++uncons :: forall g d a. (Ob d, Ob a) => Sub g (d :> a) -> (Sub g d, Tm g a)+uncons (Cons s t) = (s, t)+uncons (Comp l r) = case uncons l of+  (s, t) -> (s . r, lmap r t)+uncons Wk = (Wk . Wk, Vs Vz)++lift :: (Ob a) => Sub d g -> Sub (d :> a) (g :> a)+lift s = Cons (s . Wk) Vz \\ s++weakenR :: (Ob a) => Sub d g -> Sub (d && a) (g && a)+weakenR @a f =+  f // case sing @a of+    SE -> f+    SC @a' @x -> lift @x (weakenR @a' f)++-- simplifies @Cons (Wk . σ) (lmap σ Vz)@ to @σ@+cons :: Sub d g -> Tm d a -> Sub d (g :> a)+cons (Comp Wk s) t = case (countWk s, countVs t) of+  (Just l, Just r) | l == r -> case uncons s of (s', _) -> Cons s' t+  _ -> s // Cons (Comp Wk s) t+cons s t = Cons s t++countWk :: Sub a b -> Maybe Int+countWk Wk = Just 1+countWk (Comp Wk w) = (+ 1) <$> countWk w+countWk _ = Nothing++countVs :: Tm g a -> Maybe Int+countVs Vz = Just 0+countVs (Vs t) = (+ 1) <$> countVs t+countVs _ = Nothing++app :: (Ob b) => Tm g (a :=> b) -> Tm g a -> Tm g b+app (Lam t) u = lmap (cons id u) t \\ u+app t u = App t u++lam :: (Ob g, Ob a) => (SingCon g -> Tm (g :> a) b) -> Tm g (a :=> b)+lam f = Lam (f sing)++type family EvalTy (a :: TY) :: Type where+  EvalTy K = Bool+  EvalTy (a :=> b) = EvalTy a -> EvalTy b++type family EvalCon (g :: CON) :: Type where+  EvalCon E = ()+  EvalCon (g :> a) = (EvalCon g, EvalTy a)++eval :: (Ob a) => Tm g a -> EvalCon g -> EvalTy a+eval Vz (_, x) = x+eval (Vs f) (g, _) = eval f g+eval (Lam f) g = \x -> eval f (g, x) \\ f+eval (App t u) g = eval t g (eval u g) \\ u++type Nat a = (a :=> a) :=> (a :=> a)++-- \f z -> z+nat0 :: (Ob a) => Tm E (Nat a)+nat0 = Lam (Lam Vz)++-- \f z -> f z+nat1 :: (Ob a) => Tm E (Nat a)+nat1 = Lam (Lam (App (Vs Vz) Vz))++-- \n f z -> f (n f z)+succ :: (Ob a) => Tm E (Nat a :=> Nat a)+succ = Lam (Lam (Lam (App (Vs Vz) (App (App (Vs (Vs Vz)) (Vs Vz)) Vz))))++-- * Testing++--+-- The generators follow the Props.Free recipe: total, type-directed generation via+-- 'GenTotal' ('empty' for uninhabited branches, so nothing is ever discarded), structural+-- recursion wherever a branch shrinks the goal, and a small fixed palette of intermediate+-- objects for the one branch that doesn't ('App'/composition), bounded by fuel. Equality is+-- semantic (terms and substitutions are compared through 'eval'/'evalSub'), so the smart+-- normalizing constructors don't have to be confluent for the laws to pass.++-- ** Structural equality and display, needing only 'Ob'++eqTy :: forall (x :: TY) (y :: TY). (Ob x, Ob y) => Maybe (x :~: y)+eqTy = case (obj @x, obj @y) of+  (SK, SK) -> Just Refl+  (SF @a @b, SF @a' @b') -> case (eqTy @a @a', eqTy @b @b') of+    (Just Refl, Just Refl) -> Just Refl+    _ -> Nothing+  _ -> Nothing++showTy :: forall (a :: TY). (Ob a) => String+showTy = case obj @a of+  SK -> "K"+  SF @a' @b' -> "(" ++ showTy @a' ++ " => " ++ showTy @b' ++ ")"++eqCon :: forall (g :: CON) (h :: CON). (Ob g, Ob h) => Maybe (g :~: h)+eqCon = case (sing @g, sing @h) of+  (SE, SE) -> Just Refl+  (SC @g' @a, SC @h' @b) -> case (eqTy @a @b, eqCon @g' @h') of+    (Just Refl, Just Refl) -> Just Refl+    _ -> Nothing+  _ -> Nothing++showCon :: forall (g :: CON). (Ob g) => String+showCon = case sing @g of+  SE -> "E"+  SC @g' @a -> "(" ++ showCon @g' ++ " :> " ++ showTy @a ++ ")"++-- ** Semantic interpretation of substitutions (terms already have 'eval')++evalSub :: Sub g h -> EvalCon g -> EvalCon h+evalSub Empty () = ()+evalSub Wk (g, _) = g+evalSub (Cons s t) g = (evalSub s g, eval t g \\ t)+evalSub (Comp f g) x = evalSub f (evalSub g x)++-- ** Generateability of interpreted values++--+-- 'eqHask' compares interpreted terms by sampling arguments, which needs falsify 'Function'+-- instances at every arrow's /left/ argument. These families thread that requirement through+-- 'TestOb', as @KnownFree@ does in Props.Free. The palettes below only ever put 'K'+-- on the left of an arrow (and only 'K' entries in contexts), so the vacuous+-- @Function (a -> b)@ instance is never exercised.++type family TyTestOb (a :: TY) :: Constraint where+  TyTestOb K = ()+  TyTestOb (a :=> b) = (Function (EvalTy a), TyTestOb a, TyTestOb b)++type family ConTestOb (g :: CON) :: Constraint where+  ConTestOb E = ()+  ConTestOb (g :> a) = (ConTestOb g, TyTestOb a, Function (EvalTy a))++withEvalTy :: forall (a :: TY) r. (Ob a, TyTestOb a) => ((TestableType (EvalTy a), TestingEqShow (EvalTy a)) => r) -> r+withEvalTy r = case obj @a of+  SK -> r+  SF @x @y -> withEvalTy @x (withEvalTy @y r)++withEvalCon+  :: forall (g :: CON) r. (Ob g, ConTestOb g) => ((TestableType (EvalCon g), TestingEqShow (EvalCon g)) => r) -> r+withEvalCon r = case sing @g of+  SE -> r+  SC @g' @a -> withEvalCon @g' (withEvalTy @a r)++-- ** 'TestOb' is closed under the categorical structure++withTestObProdCON :: forall (a :: CON) b r. (TestOb a, TestOb b) => ((TestOb (a && b)) => r) -> r+withTestObProdCON r = case sing @b of+  SE -> r+  SC @b' -> withTestObProdCON @a @b' r++-- | @'TestOb' ('Exp' d a)@ for an entry type @a@ of a testable context.+withTestObExpArg+  :: forall (d :: CON) a r. (TestOb d, Ob a, TyTestOb a, Function (EvalTy a)) => ((TestOb (Exp d a)) => r) -> r+withTestObExpArg r = case sing @d of+  SE -> r+  SC @d' -> withTestObExpArg @d' @a r++withTestObExpCON :: forall (g :: CON) d r. (TestOb g, TestOb d) => ((TestOb (g ~~> d)) => r) -> r+withTestObExpCON r = case sing @g of+  SE -> r+  SC @g' @a -> withTestObExpArg @d @a (withTestObExpCON @g' @(Exp d a) r)++-- ** Object palettes++type TyPalette = '[K, K :=> K, K :=> (K :=> K)]++tyPalette :: [Some TY]+tyPalette = mkSomeList @TY @TyPalette++type ConPalette = '[E, E :> K, (E :> K) :> K]++conPalette :: [Some CON]+conPalette = mkSomeList @CON @ConPalette++-- ** Total type-directed generators++-- | Generate a term of type @a@ in context @g@. The variable branch recurses structurally on+-- the context and the lambda branch on the type, so both terminate on their own; only 'App'+-- needs an intermediate type (drawn from 'tyPalette') and is bounded by fuel. Uninhabited+-- goals (e.g. @Tm E K@) come out 'empty' instead of looping or discarding.+genTm :: forall (g :: CON) (a :: TY). (Ob g, Ob a) => Int -> GenTotal (Tm g a)+genTm fuel = oneOfTotal [varB, lamB, appB]+  where+    varB = case sing @g of+      SE -> empty+      SC @g' @b ->+        oneOfTotal+          [ case eqTy @b @a of Just Refl -> pure Vz; Nothing -> empty+          , Vs <$> genTm @g' @a fuel+          ]+    lamB = case obj @a of+      SK -> empty+      SF @a1 @a2 -> Lam <$> genTm @(g :> a1) @a2 fuel+    appB+      | fuel <= 0 = empty+      | otherwise =+          oneOfTotal+            [ App <$> genTm @g @(c :=> a) (fuel - 1) <*> genTm @g @c (fuel - 1)+            | Some @c <- tyPalette+            ]++-- | Generate a substitution, type-directed on both contexts: identity and weakening when the+-- shapes allow it, 'terminate' into the empty context, 'cons' peeling the target context (which+-- terminates structurally), and fuel-bounded composition through 'conPalette'.+genSub :: forall (g :: CON) (h :: CON). (Ob g, Ob h) => Int -> GenTotal (Sub g h)+genSub fuel = oneOfTotal [idB, termB, wkB, consB, compB]+  where+    idB = case eqCon @g @h of Just Refl -> pure id; Nothing -> empty+    termB = case sing @h of SE -> pure terminate; SC -> empty+    wkB = case sing @g of+      SE -> empty+      SC @g' -> (. Wk) <$> genSub @g' @h fuel+    consB = case sing @h of+      SE -> empty+      SC @h' @a -> cons <$> genSub @g @h' fuel <*> genTm @g @a fuel+    compB+      | fuel <= 0 = empty+      | otherwise =+          oneOfTotal+            [ (.) <$> genSub @m @h (fuel - 1) <*> genSub @g @m (fuel - 1)+            | Some @m <- conPalette+            ]++-- ** Testable instances++instance Testable TY where+  type TestOb a = (ObId a, TyTestOb a)+  showOb @a = showTy @a+  genSome = genSomeDef @TyPalette++deriving instance Show (Ty a b)+deriving instance Eq (Ty a b)+instance (Ob a, Ob b) => TestingEqShow (Ty a b)+instance (Ob a, Ob b) => TestableType (Ty a b) where+  gen = case eqTy @a @b of+    Just Refl -> oneElem (obj @a)+    Nothing -> GenEmpty (error "gen @Ty")+instance TestableProfunctor Ty++instance Testable CON where+  type TestOb g = (ConOb g, ConTestOb g)+  showOb @g = showCon @g+  genSome = genSomeDef @ConPalette++deriving instance Show (Sub a b)++-- | Structural equality, used by the normalizing smart constructors ('cons', 'pComp'). The+-- test suite compares substitutions semantically instead, see 'TestingEqShow'.+instance Eq (Sub a b) where+  Empty == Empty = True+  Wk == Wk = True+  Cons a b == Cons c d = a == c && b == d+  Comp @l a b == Comp @r c d =+    a // c // case eqCon @l @r of+      Just Refl -> a == c && b == d+      Nothing -> False+  _ == _ = False++instance (Ob a, ConTestOb a, Ob b, ConTestOb b) => TestingEqShow (Sub a b) where+  eqP l r = withEvalCon @a (withEvalCon @b (eqHask (evalSub l) (evalSub r)))+  showP = show+instance (Ob a, ConTestOb a, Ob b, ConTestOb b) => TestableType (Sub a b) where+  gen = genSub @a @b 3+instance TestableProfunctor Sub where+  genProfunctorElt nm = do+    Some @g <- genObSuchThat @CON \(Some @g') -> any (\(Some @h') -> isGenNonEmpty @(Sub g' h')) conPalette+    Some @h <- genObSuchThat @CON \(Some @h') -> isGenNonEmpty @(Sub g h')+    s <- genNamed @(Sub g h) nm+    pure (SomeP s)++deriving instance Show (Tm g a)++-- | Structural equality, only used by @Eq Sub@ above.+instance Eq (Tm g a) where+  Vz == Vz = True+  Lam l == Lam r = l == r+  App @al fl xl == App @ar fr xr =+    xl // xr // case eqTy @al @ar of+      Just Refl -> xl == xr && fl == fr+      Nothing -> False+  Vs tl == Vs tr = tl == tr+  _ == _ = False++instance (Ob g, ConTestOb g, Ob a, TyTestOb a) => TestingEqShow (Tm g a) where+  eqP l r = withEvalCon @g (withEvalTy @a (eqHask (eval l) (eval r)))+  showP = show+instance (Ob g, ConTestOb g, Ob a, TyTestOb a) => TestableType (Tm g a) where+  gen = genTm @g @a 3+instance TestableProfunctor Tm where+  genProfunctorElt nm = do+    Some @g <- genObSuchThat @CON \(Some @g') -> any (\(Some @a') -> isGenNonEmpty @(Tm g' a')) tyPalette+    Some @a <- genObSuchThat @TY \(Some @a') -> isGenNonEmpty @(Tm g a')+    t <- genNamed @(Tm g a) nm+    pure (SomeP t)++test :: TestTree+test =+  testGroup+    "Simply typed lambda calculus"+    [ testCategory @CON+    , testTerminalObject @CON+    , testBinaryProducts @CON (\ @a @b r -> withTestObProdCON @a @b r)+    , testMonoidal @CON (\ @a @b r -> withTestObProdCON @a @b r)+    , testClosed @CON (\ @a @b r -> withTestObProdCON @a @b r) (\ @a @b r -> withTestObExpCON @a @b r)+    , testGroup "Tm profunctor" [testProfunctor @Tm]+    ]
+ test/Examples/UntypedLambdaCalculus.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE IncoherentInstances #-}++module Examples.UntypedLambdaCalculus where++import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Type.Equality ((:~:) (..))+import Prelude hiding (fst, id, snd, (.))++import Test.Falsify.Generator (Gen, frequency, oneof)+import Test.Tasty (TestTree, testGroup)++import Proarrow.Category.Instance.Unit (Unit (..))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault, obj, (//))+import Proarrow.Functor (Presheaf)+import Proarrow.Limit.Terminal (HasTerminalObject (..))++import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..))+import Proarrow.Testing+  ( GenTotal (..)+  , Some (..)+  , Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow+  , mapSome+  , pattern GenNonEmpty+  )+import Proarrow.Testing.Laws (testBinaryProducts_, testCategory, testProfunctor, testTerminalObject)++type data CON = Z | S CON++type Sub :: CAT CON+data Sub a b where+  Id :: Sub Z Z+  Comp :: Sub b c -> Sub a b -> Sub a c+  Cons :: Sub a b -> Tm a -> Sub a (S b)+  Wk :: (Ob a) => Sub (S a) a++type Tm a = Tm' a '()+type Tm' :: Presheaf CON+data Tm' a u where+  Vz :: (Ob a) => Tm' (S a) '()+  Vs :: Tm a -> Tm' (S a) '()+  Lam :: Tm (S a) -> Tm' a '()+  App :: Tm a -> Tm a -> Tm' a '()++instance Profunctor Sub where+  dimap = dimapDefault+  r \\ Id = r+  r \\ Comp f g = r \\ f \\ g+  r \\ Cons f _ = r \\ f+  r \\ Wk = r+instance Promonad Sub where+  id @a = case sing @a of+    SZ -> Id+    SS @a' -> lift (obj @a')+  Id . h = h+  f . Id = f+  Comp f g . h = f . (g . h)+  Wk . r = pComp r+    where+      pComp :: (Ob b) => Sub a (S b) -> Sub a b+      pComp (Cons f _) = f+      pComp (Comp g h) = case pComp g of+        Comp Wk x | x == g -> Comp Wk (Comp g h)+        x -> x . h+      pComp s = Comp Wk s+  Cons f t . r = cons (f . r) (lmap r t)+instance CategoryOf CON where+  type (~>) = Sub+  type Ob a = (ConOb a)+instance HasTerminalObject CON where+  type TerminalObject = Z+  terminate @a = case sing @a of+    SZ -> Id+    SS @a' -> terminate @CON @a' . Wk+instance HasBinaryProducts CON where+  type Z && n = n+  type S a && n = S (a && n)+  withObProd @a @b r =+    case sing @a of+      SZ -> r+      SS @a' -> withObProd @CON @a' @b r+  fst @a @b = case sing @a of+    SZ -> terminate+    SS @a' -> let f = fst @CON @a' @b in lift f+  snd @a @b = case sing @a of+    SZ -> id+    SS @a' -> let f = snd @CON @a' @b in f . Wk \\ f+  (&&&) @_ @x l r =+    l // case sing @x of+      SZ -> r+      SS -> cons (Wk . l &&& r) (lmap l Vz)++type SingCon :: CON -> Type+data SingCon a where+  SZ :: SingCon Z+  SS :: (Ob a) => SingCon (S a)++class (a && Z ~ a, (a && b) && c ~ a && (b && c)) => Rules a b c+instance (a && Z ~ a, (a && b) && c ~ a && (b && c)) => Rules a b c++class (forall b c. Rules a b c) => ConOb a where sing :: SingCon a+instance ConOb Z where sing = SZ+instance (Ob a) => ConOb (S a) where sing = SS++instance Profunctor Tm' where+  lmap Id t = t+  lmap (Comp l r) t = lmap r (lmap l t)+  lmap (Cons _ t) Vz = t+  lmap (Cons f _) (Vs t) = lmap f t+  lmap l (Lam t) = Lam (lmap (cons (l . Wk) Vz) t) \\ l+  lmap l (App s t) = App (lmap l s) (lmap l t)+  lmap Wk t = Vs t \\ t++  rmap Unit = id++  r \\ Vz = r+  r \\ Vs t = r \\ t+  r \\ Lam @a t = (case sing @(S a) of SS -> r) \\ t+  r \\ App t _ = r \\ t++lift :: Sub d g -> Sub (S d) (S g)+lift s = Cons (s . Wk) Vz \\ s++($$) :: Tm a -> Tm a -> Tm a+($$) (Lam t) u = lmap (cons id u) t \\ u+($$) t u = App t u++-- simplifies @Cons (Wk . σ) (lmap σ Vz)@ to @σ@+cons :: Sub a b -> Tm a -> Sub a (S b)+cons (Comp Wk s) t = case (countWk s, countVs t) of+  (Just l, Just r) | l == r -> s+  _ -> Cons (Comp Wk s) t+cons s t = Cons s t++countWk :: Sub a b -> Maybe Int+countWk Wk = Just 1+countWk (Comp Wk w) = (+ 1) <$> countWk w+countWk _ = Nothing++countVs :: Tm a -> Maybe Int+countVs Vz = Just 0+countVs (Vs t) = (+ 1) <$> countVs t+countVs _ = Nothing++class b >= a where+  var :: (Ob a) => SingCon a -> Tm (S b)+instance a >= a where+  var _ = Vz+instance (b >= a, Ob b) => S b >= a where+  var _ = lmap Wk (var @b @a sing)++lam :: (Ob a) => (SingCon a -> Tm (S a)) -> Tm a+lam f = Lam (f sing)++y :: Tm Z+y = lam \f -> let fxx = lam \x -> var f $$ (var x $$ var x) in fxx $$ fxx++test :: TestTree+test =+  testGroup+    "Untyped lambda calculus"+    [ testCategory @CON+    , testTerminalObject @CON+    , testBinaryProducts_ @CON+    , testGroup "Tm presheaf" [testProfunctor @Tm']+    ]++-- | Two contexts are the same when they have the same length. Not a method of 'Testable': the+-- laws never compare objects, and the two places below that do compare an object recovered from+-- a value (the middle context of a composite substitution, and the one a weakening drops).+eqCon :: forall (a :: CON) (b :: CON). (Ob a, Ob b) => Maybe (a :~: b)+eqCon = case (sing @a, sing @b) of+  (SZ, SZ) -> Just Refl+  (SS @a', SS @b') -> case eqCon @a' @b' of+    Just Refl -> Just Refl+    Nothing -> Nothing+  _ -> Nothing++instance Testable CON where+  genSome = frequency [(2, pure (Some @Z)), (1, mapSome S <$> genSome)]+  showOb @a = case sing @a of+    SZ -> "Z"+    SS @b -> "(S " ++ showOb @CON @b ++ ")"++deriving instance Show (Sub a b)+instance Eq (Sub a b) where+  Id == Id = True+  Wk == Wk = True+  Cons a b == Cons c d = a == c && b == d+  Comp @l a b == Comp @r c d =+    a // c // case eqCon @l @r of+      Just Refl -> a == c && b == d+      Nothing -> False+  _ == _ = False++instance (Ob a, Ob b) => TestingEqShow (Sub a b)+instance (Ob a, Ob b) => TestableType (Sub a b) where+  gen = case genDepthSub 8 of+    Just s -> GenNonEmpty s+    Nothing -> GenEmpty $ error $ "Can't generate subst of type Sub " ++ showOb @CON @a ++ " " ++ showOb @CON @b++instance TestableProfunctor Sub++deriving instance Show (Tm a)+instance Eq (Tm a) where+  Vz == Vz = True+  Vs l == Vs r = l == r+  Lam l == Lam r = l == r+  App fl xl == App fr xr = fr == fl && xl == xr+  _ == _ = False+instance (Ob a, Ob b) => TestingEqShow (Tm' a b)+instance (Ob a, Ob b) => TestableType (Tm' a b) where+  gen = case genDepthTm 8 of+    Just t -> GenNonEmpty t+    Nothing -> GenEmpty $ error $ "Can't generate term of type Tm " ++ showOb @CON @a+instance TestableProfunctor Tm'++deriving instance (Show (SingCon a))++genDepthSub :: forall a b. (Ob a, Ob b) => Int -> Maybe (Gen (Sub a b))+genDepthSub 0 = Nothing+genDepthSub d =+  oneof' $+    [ [pure Id | SZ <- [sing @a], SZ <- [sing @b]]+    , [pure Wk | SS @a' <- [sing @a], Just Refl <- [eqCon @a' @b]]+    , [liftA2 cons s t | SS <- [sing @b], Just s <- [genDepthSub (d - 1)], Just t <- [genDepthTm (d - 1)]]+    ]+      ++ [ [liftA2 (.) l r | Just l <- [genDepthSub @m @b (d - 1)], Just r <- [genDepthSub (d - 1)]]+         | Some @m <- [Some @Z, Some @(S Z), Some @(S (S Z)), Some @(S (S (S Z)))]+         ]++genDepthTm :: forall a. (Ob a) => Int -> Maybe (Gen (Tm a))+genDepthTm 0 = Nothing+genDepthTm d =+  oneof' $+    [ [pure Vz | SS <- [sing @a]]+    , [Lam <$> t | Just t <- [genDepthTm (d - 1)]]+    , [liftA2 ($$) l r | Just l <- [genDepthTm (d - 1)], Just r <- [genDepthTm (d - 1)]]+    ]+      ++ [ [liftA2 lmap s t | Just t <- [genDepthTm @b (d - 1)], Just s <- [genDepthSub (d - 1)]]+         | Some @b <- [Some @Z, Some @(S Z), Some @(S (S Z)), Some @(S (S (S Z)))]+         ]++oneof' :: [[Gen a]] -> Maybe (Gen a)+oneof' ls = case concat ls of+  [] -> Nothing+  (g : gs) -> Just (oneof (g :| gs))
+ test/Examples/Vitrea.hs view
@@ -0,0 +1,320 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | The examples that ship with the @vitrea@ library (Mario Román and Bartosz Milewski,+-- /Profunctor optics: a categorical update/), ported to proarrow's optics: lenses and a prism over+-- records, a type-changing lens, an algebraic lens and a kaleidoscope over (a slice of) the iris+-- data set, monadic lenses as ordinary lenses in a Kleisli category, and a traversal composed with+-- a prism and a lens.+module Examples.Vitrea (test) where++import Data.Char (toUpper)+import Data.Function (on)+import Data.List (minimumBy)+import Data.Maybe (fromMaybe)+import Data.Type.Nat (Nat4)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (Applicative (..), Functor (..), id, map, (.))++import Proarrow.Category.Instance.Kleisli (KLEISLI (..), Kleisli (..), arr)+import Proarrow.Category.Monoidal.Applicative (Applicative (..))+import Proarrow.Core (Promonad (..))+import Proarrow.Functor (Functor (..))+import Proarrow.Optic (convert)+import Proarrow.Optic.Action (ClassifyingLens, classifyingLens, (.?))+import Proarrow.Optic.Kaleidoscope (Kaleidoscope', cotraverseOf, kaleidoscopeOf)+import Proarrow.Optic.PowerGrate (PowerGrate', powerGrate, powerGrateOf)+import Proarrow.Optics+  ( Lens+  , Lens'+  , MonoidalLens+  , Prism'+  , Traversal+  , foldMapOf+  , lens+  , monLens+  , over+  , prism+  , review+  , set+  , traversed+  , view+  , (%)+  , (^?)+  )+import Proarrow.Profunctor.Instance.Costar (unCostar, pattern Costar)+import Proarrow.Profunctor.Instance.Star (Star, unStar, pattern Star)+import Proarrow.Profunctor.Representable (RepCostar (..))+import Props.Optic.Hask (assertEq)++-- * Example 1: lenses and prisms++data Address = Address+  { street' :: String+  , city' :: String+  , country' :: String+  }+  deriving (Show, Eq)++data Person = Person+  { name' :: String+  , home' :: Address+  }+  deriving (Show, Eq)++sherlock :: Person+sherlock =+  Person+    { name' = "Sherlock Holmes"+    , home' = Address{street' = "221b Baker Street", city' = "London", country' = "UK"}+    }++home :: Lens' Person Address+home = lens home' (\(p, a) -> p{home' = a})++street :: Lens' Address String+street = lens street' (\(a, s) -> a{street' = s})++city :: Lens' Address String+city = lens city' (\(a, c) -> a{city' = c})++-- | Parse an address from @"street, city, country"@, or fail with the original string.+asAddress :: Prism' String Address+asAddress = prism buildAddress matchAddress+  where+    buildAddress (Address s c r) = s ++ ", " ++ c ++ ", " ++ r+    matchAddress a = case splitOn ", " a of+      [s, c, r] -> Right (Address s c r)+      _ -> Left a++splitOn :: String -> String -> [String]+splitOn sep = go+  where+    n = length sep+    go s = case breakOn s of+      (h, Nothing) -> [h]+      (h, Just rest) -> h : go rest+    breakOn [] = ([], Nothing)+    breakOn s@(c : cs)+      | take n s == sep = ([], Just (drop n s))+      | otherwise = let (h, r) = breakOn cs in (c : h, r)++place :: String+place = "221b Baker St, London, UK"++-- * Example 1.2: a type-changing lens (the clock is an 'Int' so the tests stay pure)++data Timestamped a = Timestamped+  { created' :: Int+  , modified' :: Int+  , contents' :: a+  }+  deriving (Show, Eq)++contents :: Lens (Timestamped a) (Timestamped b) a b+contents = lens contents' (\(x, b) -> x{contents' = b})++-- * Example 2: an algebraic lens and a kaleidoscope over the iris data set++data Species = Setosa | Versicolor | Virginica deriving (Show, Eq)++data Measurements = Measurements+  { sepalLe :: Float+  , sepalWi :: Float+  , petalLe :: Float+  , petalWi :: Float+  }+  deriving (Show, Eq)++data Flower = Flower+  { measurements :: Measurements+  , species :: Species+  }+  deriving (Show, Eq)++-- | Classify a new set of measurements by the species of its nearest neighbour in a list of flowers:+-- an algebraic lens for the list monad, whose @put@ sees the whole list rather than one flower.+measure :: ClassifyingLens (Star []) Flower Flower Measurements Measurements+measure = classifyingLens measurements (uncurry learn)+  where+    distance :: Measurements -> Measurements -> Float+    distance (Measurements a b c d) (Measurements x y z w) = sqrt (sum (map (** 2) ([a - x, b - y, c - z, d - w] :: [Float])))+    learn l m = Flower m (species (minimumBy (compare `on` (distance m . measurements)) l))++-- | The four measurements as a power grate, so that any way of aggregating a list of+-- 'Float's aggregates a list of 'Measurements' field by field.+aggregate :: PowerGrate' Measurements Float+aggregate =+  powerGrate @Nat4+    (\(Measurements a b c d) -> (a, (b, (c, (d, ())))))+    (\(a, (b, (c, (d, ())))) -> Measurements a b c d)++-- | Distribute a list aggregator through the kaleidoscope, at the carrier @Costar []@.+aggregateWith :: ([Float] -> Float) -> [Measurements] -> Measurements+aggregateWith = unCostar . powerGrateOf aggregate . Costar++-- | Classify the /aggregate/ of a list of flowers: the classifying lens composed with the kaleidoscope+-- is a kaleidoscope again (a product by a monoid is applicative), run at the aggregating+-- carrier @Costar []@ (vitrea's @iris & measure . aggregate >- mean@).+classifyAggregate :: ([Float] -> Float) -> [Flower] -> Flower+classifyAggregate = unCostar . kaleidoscopeOf measureAggregate . Costar++-- | The same composite, stored at its named flavor: Román's kaleidoscope.+measureAggregate :: Kaleidoscope' Flower Float+measureAggregate = convert (measure % aggregate)++-- | The kaleidoscope is also a cotraversal: pass a finite 'Cotraversable' carrier through it,+-- here @Maybe a -> b@, i.e. @RepCostar (Star Maybe)@.+classifyOptional :: (Maybe Float -> Float) -> Maybe Flower -> Flower+classifyOptional f = unRepCostar (cotraverseOf measureAggregate (RepCostar @_ @(Star Maybe) f))++mean :: [Float] -> Float+mean l = sum l / fromIntegral (length l)++setosa1 :: Flower+setosa1 = Flower (Measurements 5.1 3.5 1.4 0.2) Setosa++iris :: [Flower]+iris =+  [ setosa1+  , Flower (Measurements 4.9 3.0 1.4 0.2) Setosa+  , Flower (Measurements 4.7 3.2 1.3 0.2) Setosa+  , Flower (Measurements 5.4 3.9 1.7 0.4) Setosa+  , Flower (Measurements 4.4 2.9 1.4 0.2) Setosa+  , Flower (Measurements 7.0 3.2 4.7 1.4) Versicolor+  , Flower (Measurements 6.4 3.2 4.5 1.5) Versicolor+  , Flower (Measurements 5.5 2.3 4.0 1.3) Versicolor+  , Flower (Measurements 4.9 2.4 3.3 1.0) Versicolor+  , Flower (Measurements 5.0 2.0 3.5 1.0) Versicolor+  , Flower (Measurements 6.3 3.3 6.0 2.5) Virginica+  , Flower (Measurements 5.8 2.7 5.1 1.9) Virginica+  , Flower (Measurements 7.1 3.0 5.9 2.1) Virginica+  , Flower (Measurements 4.9 2.5 4.5 1.7) Virginica+  , Flower (Measurements 7.7 3.8 6.7 2.2) Virginica+  ]++-- * Example 3: monadic lenses are lenses in a Kleisli category++-- | A counter monad standing in for the clock: 'tick' returns the current time and advances it.+newtype Clock a = Clock {runClock :: Int -> (a, Int)}++instance Functor Clock where+  map f (Clock g) = Clock (\t -> let (a, t') = g t in (f a, t'))+instance Applicative Clock where+  pure a () = Clock (a (),)+  liftA2 h (Clock f, Clock g) = Clock (\t -> let (a, t') = f t; (b, t'') = g t' in (h (a, b), t''))+instance Promonad (Star Clock) where+  id = Star \a -> Clock (a,)+  Star f . Star g = Star \a -> Clock (\t -> let (b, t') = runClock (g a) t in let (c, t'') = runClock (f b) t' in (c, t''))++tick :: Clock Int+tick = Clock (\t -> (t, t + 1))++-- | Run a Kleisli arrow of @m@ on a plain value.+runK :: forall m a b. Kleisli (KL a :: KLEISLI (Star m)) (KL b) -> a -> m b+runK k = unStar (unKleisli k)++-- | A monadic lens over 'Clock': viewing is pure, updating also stamps the time.+--+-- This is a 'MonoidalLens', not a 'Lens'. The Kleisli category of a monad has coproducts but not+-- products (@'fst' . (f '&&&' g)@ would run both effects where the law allows only @f@\'s), so+-- the monadic lenses of the paper live over the Kleisli /tensor/, with a comonoidal residual.+-- Here the residual is the whole record.+stamp :: forall a b. MonoidalLens (KL (Timestamped a) :: KLEISLI (Star Clock)) (KL (Timestamped b)) (KL a) (KL b)+stamp =+  monLens @(KL (Timestamped a))+    (arr (\x -> (x, contents' x)))+    (Kleisli (Star (\(x, b) -> map (\t -> x{contents' = b, modified' = t}) tick)))++-- | A writer-like monad, for a lens that logs its updates.+newtype Log a = Log {runLog :: ([String], a)}++instance Functor Log where+  map f (Log (w, a)) = Log (w, f a)+instance Applicative Log where+  pure a () = Log ([], a ())+  liftA2 f (Log (w, a), Log (w', b)) = Log (w ++ w', f (a, b))+instance Promonad (Star Log) where+  id = Star (Log . ([],))+  Star f . Star g = Star \a -> let Log (w, b) = g a in let Log (w', c) = f b in Log (w ++ w', c)++newtype Box a = Box {openBox :: a} deriving (Show, Eq)++box :: forall a b. (Show b) => MonoidalLens (KL (Box a) :: KLEISLI (Star Log)) (KL (Box b)) (KL a) (KL b)+box =+  monLens @(KL (Box a))+    (arr (\x -> (x, openBox x)))+    (Kleisli (Star (\(_, b) -> Log (["[box]: contents changed to " ++ show b ++ "."], Box b))))++-- * Example 4: traversals++each :: Traversal [a] [b] a b+each = traversed @(Star [])++uppercase :: String -> String+uppercase = map toUpper++places :: [String]+places =+  [ "43 Adlington Rd, Wilmslow, United Kingdom"+  , "26 Westcott Rd, Princeton, USA"+  , "St James's Square, London, United Kingdom"+  ]++test :: TestTree+test =+  testGroup+    "Vitrea examples"+    [ testProperty "view a composed lens" $ assertEq (view (home % street) sherlock) "221b Baker Street"+    , testProperty "set a composed lens" $+        assertEq (set (home % street) "221b Baker St" sherlock) sherlock{home' = (home' sherlock){street' = "221b Baker St"}}+    , testProperty "over a composed lens" $ assertEq (view (home % city) (over (home % city) uppercase sherlock)) "LONDON"+    , testProperty "preview a prism" $ assertEq (place ^? asAddress) (Just (Address "221b Baker St" "London" "UK"))+    , testProperty "preview a prism that fails" $ assertEq ("nowhere" ^? asAddress) Nothing+    , testProperty "review a prism" $ assertEq (review asAddress (Address "221b Baker St" "London" "UK")) place+    , testProperty "over a prism composed with a lens" $+        assertEq (over (asAddress % city) uppercase place) "221b Baker St, LONDON, UK"+    , testProperty "type-changing lens" $+        assertEq (over contents length (Timestamped 0 1 "What is the answer?")) (Timestamped 0 1 19)+    , testProperty "algebraic lens classifies by nearest neighbour (setosa)" $+        assertEq (species ((measure .? Measurements 4.8 3.1 1.5 0.1) iris)) Setosa+    , testProperty "algebraic lens classifies by nearest neighbour (virginica)" $+        assertEq (species ((measure .? Measurements 7.2 3.1 6.1 2.3) iris)) Virginica+    , testProperty "algebraic lens keeps the measurements it classified" $+        assertEq (measurements ((measure .? Measurements 6.1 2.9 4.2 1.3) iris)) (Measurements 6.1 2.9 4.2 1.3)+    , testProperty "kaleidoscope aggregates field by field" $+        let ms = map measurements iris+        in assertEq+             (aggregateWith mean ms)+             (Measurements (mean (map sepalLe ms)) (mean (map sepalWi ms)) (mean (map petalLe ms)) (mean (map petalWi ms)))+    , testProperty "kaleidoscope with maximum" $+        let ms = map measurements iris+        in assertEq (aggregateWith maximum ms) (Measurements 7.7 3.9 6.7 2.5)+    , testProperty "classifying lens composed with kaleidoscope classifies the mean" $+        assertEq (classifyAggregate mean iris) ((measure .? aggregateWith mean (map measurements iris)) iris)+    , testProperty "the composite is a cotraversal: classify an optional flower" $+        assertEq (species (classifyOptional (fromMaybe 0) (Just setosa1))) Setosa+    , testProperty "algebraic lens is a lens: view" $ assertEq (view measure setosa1) (Measurements 5.1 3.5 1.4 0.2)+    , testProperty "algebraic lens is a lens: over" $+        assertEq (species (over measure id setosa1)) Setosa+    , testProperty "monadic lens: view is pure" $+        assertEq (runClock (runK (view stamp) (Timestamped 0 0 "What is the answer?")) 7) ("What is the answer?", 7)+    , testProperty "monadic lens: update stamps the time" $+        assertEq+          (runClock (runK (over stamp (arr (const "42"))) (Timestamped 0 0 "What is the answer?")) 7)+          (Timestamped 0 7 "42", 8)+    , testProperty "monadic lens: update logs" $+        assertEq (runLog (runK (over box (arr (+ 1))) (Box (41 :: Int)))) (["[box]: contents changed to 42."], Box 42)+    , testProperty "traversal over a list" $ assertEq (over each length ["a", "bb", "ccc"]) [1, 2, 3 :: Int]+    , testProperty "traversal composed with prism and lens" $+        assertEq+          (over (each % asAddress % city) uppercase places)+          [ "43 Adlington Rd, WILMSLOW, United Kingdom"+          , "26 Westcott Rd, PRINCETON, USA"+          , "St James's Square, LONDON, United Kingdom"+          ]+    , testProperty "fold through traversal, prism and lens" $+        assertEq+          (foldMapOf (each % asAddress % street) (: []) places)+          ["43 Adlington Rd", "26 Westcott Rd", "St James's Square"]+    ]
+ test/Main.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Main where++import Test.Tasty (defaultMain, testGroup)+import Prelude++import Examples.CustomLaws qualified as CustomLaws+import Examples.Database qualified as Database+import Examples.Free qualified as FreeExample+import Examples.Graph qualified as Graph+import Examples.SimplyTypedLambdaCalculus qualified as STLC+import Examples.UntypedLambdaCalculus qualified as ULC+import Examples.Vitrea qualified as Vitrea+import Props.Bool qualified as Bool+import Props.Cospan qualified as Cospan+import Props.Cost qualified as Cost+import Props.DPO qualified as DPO+import Props.Discrete qualified as Discrete+import Props.Dot qualified as Dot+import Props.FinHask qualified as FinHask+import Props.FinRel qualified as FinRel+import Props.FinSet qualified as FinSet+import Props.Finitary qualified as Finitary+import Props.Finitary.Graph qualified as FinitaryGraph+import Props.Free qualified as Free+import Props.Hask qualified as Hask+import Props.Kleisli qualified as Kleisli+import Props.Mat qualified as Mat+import Props.Optic.FinRel qualified as OpticFinRel+import Props.Optic.Hask qualified as Optic+import Props.Optic.Linear qualified as OpticLinear+import Props.Ordinal qualified as Ordinal+import Props.Paths qualified as Paths+import Props.PointedHask qualified as PointedHask+import Props.Sheaf qualified as Sheaf+import Props.Sheaf.Chain qualified as SheafChain+import Props.Sheaf.Collage qualified as SheafCollage+import Props.Simplex qualified as Simplex+import Props.Span qualified as Span+import Props.Svg qualified as Svg+import Props.ZX qualified as ZX++main :: IO ()+main =+  defaultMain $+    testGroup+      "tests"+      [ testGroup+          "Proarrow"+          [ Bool.test+          , Discrete.test+          , Cospan.test+          , Cost.test+          , DPO.test+          , Dot.test+          , FinHask.test+          , FinRel.test+          , FinSet.test+          , Finitary.test+          , FinitaryGraph.test+          , Free.test+          , Hask.test+          , Kleisli.test+          , Mat.test+          , Optic.test+          , OpticLinear.test+          , OpticFinRel.test+          , Ordinal.test+          , Paths.test+          , PointedHask.test+          , Sheaf.test+          , SheafChain.test+          , SheafCollage.test+          , Simplex.test+          , Span.test+          , Svg.test+          , ZX.test+          ]+      , testGroup+          "Examples"+          [ CustomLaws.test+          , Database.test+          , FreeExample.test+          , Graph.test+          , STLC.test+          , ULC.test+          , Vitrea.test+          ]+      ]
+ test/Props/Bool.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Props.Bool where++import Data.Type.Equality ((:~:) (Refl))+import Test.Falsify (discard)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (id, (**), (.))++import Proarrow.Category.Enriched qualified as E+import Proarrow.Category.Enriched.Thin (HasArrow, Holds, Objects, ThinProfunctor (..))+import Proarrow.Category.Enriched.Thin.Composition (Closure)+import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..), NonTrivialProfunctor (..))+import Proarrow.Category.Instance.Collage (COLLAGE (..), Collage)+import Proarrow.Category.Instance.Opposite (Op)+import Proarrow.Category.Monoidal (MonoidalProfunctor (..))+import Proarrow.Core (CAT, Ob, Promonad (..), obj, rmap, type (+->), type (~>))+import Proarrow.Profunctor.Corepresentable (Corep)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Constant (Constant)+import Proarrow.Profunctor.Instance.Direp (Direp)+import Proarrow.Profunctor.Instance.Exponential ((:~>:))+import Proarrow.Profunctor.Instance.Product ((:*:))+import Proarrow.Profunctor.Representable (CorepStar, Rep)++import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Testing+  ( GenTotal (..)+  , Some (..)+  , SomeProfunctorElt (..)+  , Testable (..)+  , TestableProfunctor (..)+  , TestableType (..)+  , TestingEqShow (..)+  , genNamed+  , genObSuchThat+  , genSomeFinite+  , isGenNonEmpty+  , oneElem+  , someElemNamed+  , testEq+  )+import Proarrow.Testing.Laws++test :: TestTree+test =+  testGroup+    "Booleans"+    [ testCategory @BOOL+    , testTerminalObject @BOOL+    , testInitialObject @BOOL+    , testBinaryProducts_ @BOOL+    , testCartesian_ @BOOL+    , testMonoidal_ @BOOL+    , testSymMonoidal_ @BOOL+    , testCopyDiscard_ @BOOL+    , testStarAutonomous_ @BOOL+    , testBinaryCoproducts_ @BOOL+    , testDistributive_ @BOOL+    , testClosed_ @BOOL+    , testEqualizers_ @BOOL+    , testCoequalizers_ @BOOL+    , testPullbacks_ @BOOL+    , testPushouts_ @BOOL+    , testCommutativeMonoid_ @TRU+    , testGroup "FF,FT profunctor" [testProfunctor @(NonTrivialProfunctor '(TRU, FLS))]+    , testGroup "FT,TT profunctor" [testProfunctor @(NonTrivialProfunctor '(FLS, TRU))]+    , testGroup "FF,FT,TT profunctor" [testProfunctor @(NonTrivialProfunctor '(TRU, TRU))]+    , testProperty "Booleans decidable" $ propDecidable @Booleans+    , testProperty "FF,FT decidable" $ propDecidable @(NonTrivialProfunctor '(TRU, FLS))+    , testProperty "FT,TT decidable" $ propDecidable @(NonTrivialProfunctor '(FLS, TRU))+    , testProperty "Op Booleans decidable" $ propDecidable @(Op Booleans)+    , testProperty "reachability finds a path" $ withArr reachPath (pure ())+    , testProperty "Booleans is BOOL-enriched" $ do+        SomeP @a @b p <- genProfunctorElt @Booleans "p"+        testEq "enriched . underlying" "enriched (underlying p)" (E.enriched @BOOL (E.underlying @BOOL p)) "p" p+        Some @c <- genObSuchThat @BOOL \(Some @c) -> isGenNonEmpty @(b ~> c)+        g <- genNamed @(b ~> c) "g"+        testEq+          "rmap"+          "enriched (rmap . (underlying g ** underlying p))"+          (E.enriched @BOOL @Booleans (E.rmap @BOOL @Booleans @a @b @c . (E.underlying @BOOL g ** E.underlying @BOOL p)))+          "rmap g p"+          (rmap g p)+    , testProperty "thin composition round trips through withArr" $+        withArr compLeft $+          withArr compRight $+            withArr compRightCorepStar $+              withArr compSearch $+                withArr compSearch3 (pure ())+    ]++-- * Composition of thin profunctors, checked at the type level++-- | Coherence law: a corepresented left leg followed by a represented right leg is 'Direp'.+-- Both constraints reduce to @f a ≤ g c@, so the identity typechecks in either direction.+compIsDirep+  :: forall {i} {j} {k} (f :: j +-> k) (g :: i +-> k) (a :: j) (c :: i) r+   . ((HasArrow (Direp f g) a c) => r) -> ((HasArrow (Corep f :.: Rep g) a c) => r)+compIsDirep r = r++direpIsComp+  :: forall {i} {j} {k} (f :: j +-> k) (g :: i +-> k) (a :: j) (c :: i) r+   . ((HasArrow (Corep f :.: Rep g) a c) => r) -> ((HasArrow (Direp f g) a c) => r)+direpIsComp r = r++-- | On the walking arrow: a constant-@FLS@ left leg substitutes @FLS@ for the middle object,+-- and @FLS ≤ FLS@ holds, so the composite arrow exists (this only typechecks because it does).+compLeft :: (Corep (Constant FLS) :.: Booleans) TRU FLS+compLeft = arr++-- | Dually, a constant-@TRU@ right leg substitutes @TRU@: @FLS ≤ TRU@.+compRight :: (Booleans :.: Rep (Constant TRU)) FLS FLS+compRight = arr++-- | The same substitution through a corepresentable profunctor's 'CorepStar'.+compRightCorepStar :: (Booleans :.: CorepStar (Corep (Constant TRU))) FLS FLS+compRightCorepStar = arr++-- | Two non-representable legs: the middle object is found by searching @BOOL@. Here @FLS@ reaches+-- @TRU@ through either middle object, and only the search can tell.+compSearch :: (NonTrivialProfunctor '(TRU, FLS) :.: NonTrivialProfunctor '(FLS, TRU)) FLS TRU+compSearch = arr++-- | Searches nest: a composite is decidable again, so it can be the leg of a further search.+compSearch3 :: ((NonTrivialProfunctor '(TRU, FLS) :.: NonTrivialProfunctor '(FLS, TRU)) :.: Booleans) FLS TRU+compSearch3 = arr++-- | A failed search is a type-level fact too: the first leg only leaves @TRU@ at @TRU@, where the+-- second leg has nothing, so the composite has no arrow out of @TRU@.+searchMisses :: Holds (NonTrivialProfunctor '(FLS, TRU) :.: NonTrivialProfunctor '(TRU, FLS)) TRU FLS :~: FLS+searchMisses = Refl++searchHits :: Holds (NonTrivialProfunctor '(TRU, FLS) :.: NonTrivialProfunctor '(FLS, TRU)) FLS TRU :~: TRU+searchHits = Refl++-- | The exponential of profunctors is implication: it fails exactly where the antecedent holds and+-- the consequent does not.+exponentialMisses :: Holds (Booleans :~>: NonTrivialProfunctor '(FLS, TRU)) FLS FLS :~: FLS+exponentialMisses = Refl++exponentialHits :: Holds (NonTrivialProfunctor '(FLS, TRU) :~>: Booleans) FLS FLS :~: TRU+exponentialHits = Refl++-- | Decidability is structural: a product of profunctors holds when both do.+productMisses :: Holds (Booleans :*: NonTrivialProfunctor '(FLS, TRU)) FLS FLS :~: FLS+productMisses = Refl++instance Testable BOOL where+  showOb @a = case obj @a of+    Fls -> "FLS"+    Tru -> "TRU"+  genSome = genSomeFinite++instance (Ob a, Ob b) => TestableType (Booleans a b) where+  gen = case (obj @a, obj @b) of+    (Fls, Fls) -> oneElem Fls+    (Fls, Tru) -> oneElem F2T+    (Tru, Tru) -> oneElem Tru+    (Tru, Fls) -> GenEmpty \case {}+instance (Ob a, Ob b) => TestingEqShow (Booleans a b) where+  -- thin, so parallel arrows are equal for free; forcing is the one thing left to check+  eqP l r = l `seq` r `seq` pure True+  showP Fls = "F->F"+  showP F2T = "F->T"+  showP Tru = "T->T"+instance TestableProfunctor Booleans++instance (Ob ft) => TestableProfunctor (NonTrivialProfunctor ft) where+  genProfunctorElt nm = case obj @ft of+    Tru :**: Fls -> someElemNamed nm [SomeP FF, SomeP FT]+    Tru :**: Tru -> someElemNamed nm [SomeP FF, SomeP FT, SomeP TT]+    Fls :**: Tru -> someElemNamed nm [SomeP FT, SomeP TT]+    Fls :**: Fls -> discard+instance (Ob ft, TestOb a, TestOb b) => TestingEqShow (NonTrivialProfunctor ft a b)+instance (Ob ft, TestOb a, TestOb b) => TestableType (NonTrivialProfunctor ft a b) where+  gen = case (obj @ft, obj @a, obj @b) of+    (Tru :**: _, Fls, Fls) -> oneElem FF+    (Fls :**: _, Fls, Fls) -> GenEmpty \case {}+    (_, Fls, Tru) -> oneElem FT+    (_ :**: Tru, Tru, Tru) -> oneElem TT+    (_ :**: Fls, Tru, Tru) -> GenEmpty \case {}+    (_, Tru, Fls) -> GenEmpty \case {}++-- | The same closure at the value level: 'Closure' is decidable, and 'arr' searches the path.+reachPath :: Closure (NonTrivialProfunctor '(FLS, FLS)) FLS TRU+reachPath = arr++reachNoPath :: Holds (Closure (NonTrivialProfunctor '(FLS, FLS))) TRU FLS :~: FLS+reachNoPath = Refl++-- * The collage of a profunctor is enumerable++-- | Two copies of the walking arrow, glued by the profunctor that only relates @FLS@ to @TRU@.+type Glued = COLLAGE (NonTrivialProfunctor '(FLS, FLS))++-- | The left category's objects are numbered first, the right's after them.+objectsGlued :: Objects Glued :~: '[L FLS, L TRU, R FLS, R TRU]+objectsGlued = Refl++-- | The closure reaches across the glue, by the one heteromorphism.+gluedAcross :: Holds (Closure (Collage :: CAT Glued)) (L FLS) (R TRU) :~: TRU+gluedAcross = Refl++-- | It does not reach the right object the profunctor misses, even going the long way round.+gluedMisses :: Holds (Closure (Collage :: CAT Glued)) (L FLS) (R FLS) :~: FLS+gluedMisses = Refl++-- | And never back across the glue.+gluedNoWayBack :: Holds (Closure (Collage :: CAT Glued)) (R TRU) (L FLS) :~: FLS+gluedNoWayBack = Refl
+ test/Props/Cospan.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE OverloadedLists #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Props.Cospan where++import Data.Foldable (toList)+import Data.Maybe (isJust)+import Data.Typeable ((:~:) (..))+import Test.Tasty (TestTree, testGroup)+import Prelude (Bool (..), Maybe (..), pure, zip, ($), (&&), (++), (<$>), (<*>), (||))++import Proarrow.Category.Instance.Cospan (COSPAN (..), Cospan (..))+import Proarrow.Category.Instance.FinSet (FINSET (..), findIso, unFinSet)+import Proarrow.Core (CAT, CategoryOf (..), UN, (//), (\\))++import Proarrow.Testing+  ( GenTotal (..)+  , Some (..)+  , Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , mapSome+  , pattern GenNonEmpty+  )+import Proarrow.Testing.Laws+import Props.FinSet (eqFinSet)++test :: TestTree+test =+  testGroup+    "Cospan(FinSet)"+    [ testCategory @(COSPAN FINSET)+    , testDagger @(COSPAN FINSET)+    , testMonoidal_ @(COSPAN FINSET)+    , testSymMonoidal_ @(COSPAN FINSET)+    , testClosed_ @(COSPAN FINSET)+    , testStarAutonomous_ @(COSPAN FINSET)+    , testCompactClosed_ @(COSPAN FINSET)+    , testCopyDiscard_ @(COSPAN FINSET)+    , testHypergraph_ @(COSPAN FINSET)+    ]++-- instance (Testable k, HasPushouts k, TestObIsOb k) => Testable (COSPAN k) where+instance Testable (COSPAN FINSET) where+  type TestOb a = Ob a+  showOb @a = showOb @_ @(UN CS a)+  genSome = mapSome CS <$> genSome+  genSomeSmall = mapSome CS <$> genSomeSmall++-- instance (Ob a, Ob b, Testable k, TestObIsOb k) => TestingEqShow (Cospan a (b :: COSPAN k)) where+instance (Ob a, Ob b) => TestingEqShow (Cospan a (b :: COSPAN FINSET)) where+  eqP (Cospan @c1 l1 r1) (Cospan @c2 l2 r2) =+    l1 //+      l2 //+        case eqFinSet @c1 @c2 of+          Just Refl -> do+            eql <- eqP l1 l2+            eqr <- eqP r1 r2+            -- Both legs map *into* the apex, so a relabelling has to satisfy every constraint the+            -- two leg pairs impose at once, which takes an actual search. Span's legs map out, so+            -- it can settle the question by comparing multisets (see "Props.Span").+            let hasIso =+                  isJust+                    ( findIso @(UN FS c1)+                        (zip (toList (unFinSet l1)) (toList (unFinSet l2)) ++ zip (toList (unFinSet r1)) (toList (unFinSet r2)))+                    )+            pure $ (eql && eqr) || hasIso+          Nothing -> pure False+  showP (Cospan @c l r) = "Cospan @(" ++ showOb @_ @c ++ ") (" ++ showP l ++ ") (" ++ showP r ++ ")" \\ l++-- instance (TestOb a, TestOb b, Testable k, TestObIsOb k) => TestableType (Cospan a (b :: COSPAN k)) where+instance (TestOb a, TestOb b) => TestableType (Cospan a (b :: COSPAN FINSET)) where+  gen = GenNonEmpty loop+    where+      loop = do+        Some @c <- genSome @_+        case (gen @(UN CS a ~> c), gen @(UN CS b ~> c)) of+          (GenEmpty _, _) -> loop+          (_, GenEmpty _) -> loop+          (GenNonEmpty l, GenNonEmpty r) -> Cospan <$> l <*> r++instance TestableProfunctor (Cospan :: CAT (COSPAN FINSET))
+ test/Props/Cost.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Property tests for the cost category.+--+-- 'GTE' is thin, so arrow equality is trivially true and the laws cannot fail on a mismatch. What+-- they check is that every arrow the laws ask for can be built and forced without hitting an+-- unreachable @error@ branch in "Proarrow.Category.Instance.Cost", and that the type-level+-- arithmetic lines up at every object triple; 'eqP' forces both sides for that reason. The paths+-- that matter are @associator@ \/ @associatorInv@ \/ @swap@, which use 'unsafeCoerce' for+-- associativity and commutativity of @+@, and @distL@ \/ @distR@, which rely on monotonicity of @+@.+module Props.Cost where++import Control.Monad (unless)+import Data.Proxy (Proxy (..))+import Data.Type.Equality ((:~:) (Refl))+import Data.Type.Ord (OrderingI (..))+import GHC.TypeNats (cmpNat, natVal)+import Numeric.Natural (Natural)+import Test.Falsify (testFailed)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude++import Proarrow.Category.Enriched (EnrichedProfunctor (..))+import Proarrow.Category.Enriched.Thin (Finite (..), Indexed (..), Length)+import Proarrow.Category.Enriched.Thin.Composition (Closure, GradedWalk (..), shortest)+import Proarrow.Category.Instance.Cost (COST (..), GTE (..), IsCost (..), SCost (..))+import Proarrow.Category.Instance.Discrete (DISCRETE (..))+import Proarrow.Core (Ob)+import Proarrow.Profunctor.Instance.Edges (Edges)++import Proarrow.Testing+  ( GenTotal (..)+  , Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , genSomeDef+  , oneElem+  )+import Proarrow.Testing.Laws++test :: TestTree+test =+  testGroup+    "Cost"+    [ testCategory @COST+    , testProperty "GTE decidable" $ propDecidable @GTE+    , testProperty "shortest paths computed at the value level" $ do+        unless (distance @(D P) @(D R) == Just 7) (testFailed "P -> R should be 7")+        unless (distance @(D Q) @(D P) == Just 11) (testFailed "Q -> P should be 11")+        unless (distance @(D P) @(D P) == Just 0) (testFailed "P -> P should be 0")+        unless (distance @(D P) @(D Y) == Nothing) (testFailed "P -> Y should be unreachable")+    , testProperty "shortest paths as witnesses" $ do+        unless (steps (shortest @COST @N @G @(D P) @(D R)) == 2) (testFailed "P -> R should take the detour via Q")+        unless (steps (shortest @COST @N @G @(D Q) @(D P)) == 3) (testFailed "Q -> P should go around the cycle")+        unless (steps (shortest @COST @N @G @(D P) @(D P)) == 0) (testFailed "P -> P should stay put")+    , testTerminalObject @COST+    , testInitialObject @COST+    , testBinaryProducts_ @COST+    , testBinaryCoproducts_ @COST+    , testMonoidal_ @COST+    , testSymMonoidal_ @COST+    , testDistributive_ @COST+    , testEqualizers_ @COST+    , testCoequalizers_ @COST+    , testEpiMonoFactorization_ @COST+    , testPullbacks_ @COST+    , testPushouts_ @COST+    ]++instance Testable COST where+  genSome = genSomeDef @'[C 0, C 1, C 2, C 3, INF]+  showOb @a = case sing @a of+    SINF -> "INF"+    SC @n -> "C " ++ show (natVal (Proxy @n))++instance (Ob a, Ob b) => TestableType (GTE a b) where+  gen = case (sing @a, sing @b) of+    (SINF, _) -> oneElem Inf+    -- No arrow from a finite cost to INF.+    (SC, SINF) -> GenEmpty \case {}+    (SC @a', SC @b') -> case cmpNat (Proxy @b') (Proxy @a') of+      LTI -> oneElem GTE+      EQI -> oneElem GTE+      -- b' > a', so the @b' <= a'@ that GTE demands is refutable.+      GTI -> GenEmpty \case {}++instance (Ob a, Ob b) => TestingEqShow (GTE a b) where+  -- Thin, so any two arrows with the same endpoints are equal. Force both sides+  -- anyway, so that a wrongly-taken error branch surfaces as a test failure.+  eqP l r = l `seq` r `seq` pure True+  showP Inf = "Inf"+  showP GTE = "GTE"++instance TestableProfunctor GTE++-- * Shortest paths as a fixed point, at the type level and at the value level++-- | Five points; the direct edge @P -> R@ costs 9, the detour via @Q@ only 7, and @Y@ is isolated.+data V = P | Q | R | X | Y++instance Indexed V+instance Finite V where type Objects V = '[P, Q, R, X, Y]++type G = Edges '[ '(P, Q, C 3), '(Q, R, C 4), '(P, R, C 9), '(R, X, C 2), '(X, P, C 5)]++-- | The fixed point beats the direct edge.+distancePR :: ProObj COST (Closure G) (D P) (D R) :~: C 7+distancePR = Refl++-- | Around the cycle: @Q -> R -> X -> P@.+distanceQP :: ProObj COST (Closure G) (D Q) (D P) :~: C 11+distanceQP = Refl++-- | Every point is at distance @0@ from itself, and an isolated point is infinitely far.+distancePP :: ProObj COST (Closure G) (D P) (D P) :~: C 0+distancePP = Refl++distancePY :: ProObj COST (Closure G) (D P) (D Y) :~: INF+distancePY = Refl++-- | The same computation at the value level: the points are abstract here, so the distance singleton+-- can only come from 'withProObj' running the fixed point.+distance :: forall (a :: DISCRETE V) (b :: DISCRETE V). (Ob a, Ob b) => Maybe Natural+distance = withProObj @COST @(Closure G) @a @b case sing @(ProObj COST (Closure G) a b) of+  SC @n -> Just (natVal (Proxy @n))+  SINF -> Nothing++type N = Length (Objects (DISCRETE V))++-- | The shortest walk from @P@ to @R@ has grade @7@ by type, and two steps by value.+shortestPR :: GradedWalk COST N G (C 7) (D P) (D R)+shortestPR = shortest++steps :: GradedWalk v n p d a b -> Int+steps (DoneAt _) = 0+steps (StepAt _ w) = 1 + steps w
+ test/Props/DPO.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Double-pushout rewriting of directed graphs, done entirely with the generic machinery: a graph+-- is a finitary copresheaf on the two-object schema @E ⇉ V@, built from ordinary runtime data by+-- 'withSubobject' out of an ambient graph, and rewritten by 'dpoStep'. Nothing here is about graphs+-- except the schema and the ambient object; the pushouts, the pushout complement and both halves of+-- the gluing condition all come from the generic @FINITARY GRAPH ()@ instances.+module Props.DPO (test) where++import Data.List (genericIndex, genericLength)+import Numeric.Natural (Natural)+import Test.Falsify (Property, testFailed)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (id, (.))++import Examples.Graph (GRAPH (..), GraphHom (..))+import Proarrow.Category.Enriched.Finitary (Finitary (..))+import Proarrow.Category.Enriched.Finitary.Topos (FIN, withSubobject)+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Instance.Sub (Sub (..))+import Proarrow.Category.Instance.Unit (Unit (..))+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), obj)+import Proarrow.Functor (Copresheaf)+import Proarrow.Limit.Equalizer (factorEqualizer)+import Proarrow.Testing (expect)+import Proarrow.Tools.DPO (Rule (..), dpoStep)++-- * An ambient graph to carve subgraphs out of++data Node = N0 | N1 | N2+  deriving (Enum, Eq, Ord, Show)++nodes :: [Node]+nodes = [N0, N1, N2]++-- | Every node, and one edge for each ordered pair of them. Every simple digraph on at most three+-- vertices is a subobject of this, which is how one gets built from runtime data.+type Ambient :: Copresheaf GRAPH+data Ambient u b where+  Vtx :: Node -> Ambient '() V+  Edg :: Node -> Node -> Ambient '() E++deriving instance Eq (Ambient u b)+deriving instance Show (Ambient u b)++instance Profunctor Ambient where+  dimap Unit IdE x = x+  dimap Unit IdV x = x+  dimap Unit Src (Edg s _) = Vtx s+  dimap Unit Tgt (Edg _ t) = Vtx t+  r \\ x = case x of Vtx{} -> r; Edg{} -> r++-- | The ambient graph's own elements, in the order the numbering below uses.+ambient :: forall b. (Ob b) => [Ambient '() b]+ambient = case obj @b of+  IdE -> [Edg s t | s <- nodes, t <- nodes]+  IdV -> [Vtx v | v <- nodes]++instance Finitary Ambient where+  size @_ @b = genericLength (ambient @b)+  toIndex (Vtx v) = fromIntegral (fromEnum v)+  toIndex (Edg s t) = fromIntegral (fromEnum s * length nodes + fromEnum t)+  fromIndex @_ @b i = ambient @b `genericIndex` i+  elements @_ @b = ambient @b++-- * Graphs as subobjects of it++-- | A subgraph of 'Ambient', given by its inclusion.+type Incl g = FIN g ~> FIN Ambient++-- | A graph given as a list of vertices and a list of edges. Rejects a list of edges whose endpoints+-- are not all listed, since such a graph is not a subgraph.+withGraph :: [Node] -> [(Node, Node)] -> (forall g. (Finitary g) => Incl g -> r) -> r -> r+withGraph vs es = withSubobject @Ambient \case+  Vtx v -> v `elem` vs+  Edg s t -> (s, t) `elem` es++-- | Read a graph back as its lists of vertices and edges, for comparison.+graphOf :: forall g. (Finitary (g :: Copresheaf GRAPH)) => Incl g -> ([Node], [(Node, Node)])+graphOf (Sub (Prof incl)) =+  ( [v | Vtx v <- map incl (elements @g @'() @V)]+  , [(s, t) | Edg s t <- map incl (elements @g @'() @E)]+  )++-- | Apply the rule that deletes everything of @l@ which is not in @k@, matched at @l@\'s inclusion+-- into the host @g@. Every graph is given by its inclusion into 'Ambient', and the maps between them+-- are the factorizations those inclusions force.+deleteStep+  :: forall (g :: Copresheaf GRAPH) (l :: Copresheaf GRAPH) (k :: Copresheaf GRAPH)+   . (Finitary g, Finitary l, Finitary k)+  => Incl g+  -> Incl l+  -> Incl k+  -> ((Natural, Natural) -> (Natural, Natural) -> Property ())+  -- ^ given the complement's and the result's counts of vertices and edges+  -> Property ()+  -> Property ()+deleteStep gIncl lIncl kIncl ok notGlueable =+  dpoStep+    (Rule (factorEqualizer lIncl kIncl) (id :: FIN k ~> FIN k))+    (factorEqualizer gIncl lIncl)+    ( \(Sub (Prof @d _)) _ (Sub (Prof @_ @h _)) ->+        ok (size @d @'() @V, size @d @'() @E) (size @h @'() @V, size @h @'() @E)+    )+    notGlueable++-- | The host, the matched part and the interface, each as a list of vertices and a list of edges.+rewrite+  :: ([Node], [(Node, Node)])+  -> ([Node], [(Node, Node)])+  -> ([Node], [(Node, Node)])+  -> ((Natural, Natural) -> (Natural, Natural) -> Property ())+  -> Property ()+  -> Property ()+rewrite (gv, ge) (lv, le) (kv, ke) ok notGlueable =+  withGraph+    gv+    ge+    (\g -> withGraph lv le (\l -> withGraph kv ke (\k -> deleteStep g l k ok notGlueable) notSub) notSub)+    notSub++-- | What the edge-deleting rule should leave behind: both vertices and no edge, in the complement+-- and in the result alike.+edgeGone :: (Natural, Natural) -> (Natural, Natural) -> Property ()+edgeGone d h = do+  expect "the complement keeps both vertices and no edge" (2, 0) d+  expect "and so does the result" (2, 0) h++notSub :: Property ()+notSub = testFailed "should have been a subgraph"++-- | A single edge between two vertices, the host of both rewriting examples.+host :: ([Node], [(Node, Node)])+host = ([N0, N1], [(N0, N1)])++test :: TestTree+test =+  testGroup+    "DPO"+    [ testProperty "a graph from runtime data is a subgraph of the ambient one" $+        withGraph [N0, N1] [(N0, N1)] (\incl -> expect "one edge, two vertices" host (graphOf incl)) notSub+    , testProperty "an edge whose endpoints are missing is not a subgraph" $+        withGraph [N0] [(N0, N1)] (\_ -> testFailed "should not have been a subgraph") (pure ())+    , testProperty "deleting an edge keeps its endpoints" $+        -- the classical example: L is the edge with both endpoints, K and R are the endpoints alone+        rewrite host host ([N0, N1], []) edgeGone (testFailed "should have been glueable")+    , testProperty "deleting a vertex that still has an edge is refused" $+        -- the dangling condition: L is vertex N0 alone, so the edge N0->N1 would be left hanging+        rewrite host ([N0], []) ([], []) (\_ _ -> testFailed "should not have glued") (pure ())+    ]
+ test/Props/Discrete.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Props.Discrete where++import Data.Type.Equality (type (:~:))+import Data.Type.Equality qualified as Eq+import Data.Type.Nat (SNat (..), snat)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude++import Proarrow.Category.Enriched.Thin+  ( DecidableProfunctor (..)+  , Decision (..)+  , Holds+  , Indexed (..)+  , KnownIndex+  , Objects+  , ThinProfunctor (..)+  )+import Proarrow.Category.Enriched.Thin.Composition (Closure)+import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..))+import Proarrow.Category.Instance.Discrete (CODISCRETE (..), Codiscrete, DISCRETE (..), Discrete (..))+import Proarrow.Core (CAT, Profunctor (..), UN)++test :: TestTree+test =+  testGroup+    "Discrete"+    [ testProperty "reachability over a bare set finds the edge" $ withArr reachEdge (pure ())+    , testProperty "distinct points are decided apart" $ case decide @Discrete @(D FLS) @(D TRU) of+        No -> pure ()+    ]++-- | A point of the bare set @DISCRETE BOOL@ is recovered from its index alone.+pointOf :: forall (a :: DISCRETE BOOL). (KnownIndex a) => Booleans (UN D a) (UN D a)+pointOf = case snat @(Index a) of+  SZ -> Fls+  SS @i -> case snat @i of SZ -> Tru++-- | The graph with the single edge @FLS -> TRU@ on the bare two-point set: unlike over the walking+-- arrow, there is no base arrow to fall back on.+type Edge :: CAT (DISCRETE BOOL)+data Edge a b where+  FT :: Edge (D FLS) (D TRU)++instance Profunctor Edge where+  dimap Refl Refl e = e+  r \\ FT = r++type family EdgeHolds (a :: BOOL) (b :: BOOL) :: BOOL where+  EdgeHolds FLS TRU = TRU+  EdgeHolds a b = FLS++instance ThinProfunctor Edge++instance DecidableProfunctor Edge where+  type Holds Edge a b = EdgeHolds (UN D a) (UN D b)+  decide @a @b = case (pointOf @a, pointOf @b) of+    (Fls, Fls) -> No+    (Fls, Tru) -> Yes FT+    (Tru, Fls) -> No+    (Tru, Tru) -> No+  toHolds FT r = r++-- | The closure over the bare set: the edge is found, its reverse is not, and points reach themselves.+reachEdge :: Closure Edge (D FLS) (D TRU)+reachEdge = arr++noWayBack :: Holds (Closure Edge) (D TRU) (D FLS) :~: FLS+noWayBack = Eq.Refl++reachSelf :: Holds (Closure Edge) (D TRU) (D TRU) :~: TRU+reachSelf = Eq.Refl++-- | The discrete category itself is decided by comparing indices.+samePoint :: Holds (Discrete :: CAT (DISCRETE BOOL)) (D FLS) (D FLS) :~: TRU+samePoint = Eq.Refl++otherPoint :: Holds (Discrete :: CAT (DISCRETE BOOL)) (D FLS) (D TRU) :~: FLS+otherPoint = Eq.Refl++-- * The codiscrete category on the same points++-- | Its objects are the points of @k@, in the same order.+objectsCodiscrete :: Objects (CODISCRETE BOOL) :~: '[CD FLS, CD TRU]+objectsCodiscrete = Eq.Refl++-- | Every point reaches every other, and the closure computes that by searching the points. This+-- only typechecks because the codiscrete category is enumerable.+codiscreteReaches :: Holds (Closure (Codiscrete :: CAT (CODISCRETE BOOL))) (CD TRU) (CD FLS) :~: TRU+codiscreteReaches = Eq.Refl
+ test/Props/Dot.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Props.Dot where++import Control.Monad (replicateM)+import Data.Containers.ListUtils (nubOrd)+import Data.List qualified as List+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Ord (comparing)+import Data.Proxy (Proxy (..))+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Type.Equality ((:~:) (..))+import Data.Void (absurd)+import GHC.TypeLits (Symbol, decideSymbol, symbolVal)+import Test.Falsify.Generator (Gen, elem)+import Test.Tasty (TestTree, testGroup)+import Prelude hiding (elem, fst, id, snd, (.))++import Proarrow.Category.Monoidal (withOb2)+import Proarrow.Category.Monoidal.Strictified (IsList (..))+import Proarrow.Core (CategoryOf (..), Promonad (..), UN)+import Proarrow.Tools.Diagrams.Dot+  ( DOT (..)+  , Dot (..)+  , DotData (..)+  , Fin (..)+  , NodeKind (..)+  , SymRefl (..)+  , Vec (..)+  , getData+  , len+  , names+  , node+  , nodeOf+  , portOf+  )++import Proarrow.Testing+  ( GenTotal (..)+  , Some (..)+  , Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , genSomeDef+  , oneElem+  , pattern GenNonEmpty+  )+import Proarrow.Testing.Laws++test :: TestTree+test =+  testGroup+    "Dot"+    [ testCategory @DOT+    , testMonoidal_ @DOT+    , testSymMonoidal_ @DOT+    , testCopyDiscard_ @DOT+    , testMonoid_ @(D '[])+    , testMonoid_ @(D '["A"])+    , testMonoid_ @(D '["A", "B"])+    , testCommutativeMonoid_ @(D '["A", "B"])+    , testComonoid_ @(D '["A", "B"])+    , testHypergraph @DOT (\ @a @b r -> withOb2 @DOT @a @b r)+    , testClosed_ @DOT+    , testStarAutonomous_ @DOT+    , testCompactClosed_ @DOT+    , testTraced_ @DOT+    ]++foldSome :: [Some Symbol] -> Some DOT+foldSome [] = Some @(D '[])+foldSome [Some @n] = Some @(D '[n])+foldSome (Some @n : Some @m : rest) = case foldSome (Some @m : rest) of+  Some @(D ns) -> withIsList2 @'[n] @ns (Some @(D (n ': ns)))++instance Testable Symbol where+  genSome = genSomeDef @'["A", "B", "C", "D", "E"]+  showOb @s = symbolVal (Proxy @s)++instance (Ob a, Ob b) => TestingEqShow (SymRefl a b)+instance (Ob a, Ob b) => TestableType (SymRefl a b) where+  gen = case decideSymbol (Proxy @a) (Proxy @b) of+    Right Refl -> oneElem SymRefl+    Left f -> GenEmpty \SymRefl -> absurd (f Refl)+instance TestableProfunctor SymRefl+instance Testable DOT where+  genSome = do+    num <- elem [0 .. 2]+    somes <- replicateM num (genSome @Symbol)+    pure $ foldSome somes+  showOb @ns = List.intercalate "," $ unVec $ names @(UN D ns)++-- | Two diagrams are equal when they mean the same relation ('meaning'), under a few different+-- meanings of the labelled nodes.+instance (Ob a, Ob b) => TestingEqShow (Dot a b) where+  eqP l r = let dl = getData l; dr = getData r in pure (all (\seed -> meaning seed dl == meaning seed dr) ([1, 2, 3] :: [Int]))++-- | A diagram through the library's own operations, so that its nodes are numbered as the other+-- arrows' are: one labelled node from the inputs to the outputs, or two stacked through a random+-- boundary in between.+instance (Ob a, Ob b) => TestableType (Dot a b) where+  gen = GenNonEmpty (boxes @a @b \ @x @y -> node @(UN D x) @(UN D y))++-- | One box, with a random label, from the inputs to the outputs, or two stacked through a random+-- boundary in between, each made by the given function from its label.+boxes+  :: forall {k} (a :: k) (b :: k)+   . (Testable k, Ob a, Ob b)+  => (forall (x :: k) (y :: k). (Ob x, Ob y) => String -> x ~> y)+  -> Gen (a ~> b)+boxes box = do+  stacked <- elem [False, True]+  if stacked+    then do+      Some @m <- genSome @k+      (.) <$> labelled @m @b <*> labelled @a @m+    else labelled @a @b+  where+    labelled :: forall (x :: k) (y :: k). (Ob x, Ob y) => Gen (x ~> y)+    labelled = box @x @y <$> elem ["f", "g", "h"]++-- * What a diagram means++-- | A wire of a diagram: an input, an output, or an edge between two nodes.+data Wire = InWire Int | OutWire Int | EdgeWire Int+  deriving (Eq, Ord, Show)++-- | Which way a wire runs at the node it is attached to.+data End = Into | OutOf+  deriving (Eq, Ord, Show)++-- | The relation a diagram means, every wire carrying one bit: the set of pairs of input and+-- output bits it relates. A 'Spider' means that all its wires agree, a 'Crossing' swaps its two+-- wires, and a 'Box' is a free generator, which the seed gives a pseudo-random meaning that+-- depends on its label and on the wires it has, but not on their order.+meaning+  :: forall (as :: [Symbol]) (bs :: [Symbol]). (IsList as, IsList bs) => Int -> DotData as bs -> Set ([Bool], [Bool])+meaning seed (DotData is os es ns) =+  Set.fromList [(map (bitOf . InWire) inIxs, map (bitOf . OutWire) outIxs) | bitOf <- joined]+  where+    inIxs = [0 .. len @as - 1]+    outIxs = [0 .. len @bs - 1]+    inNames = unVec (names @as)+    outNames = unVec (names @bs)+    -- every attachment of a wire to a node, and every wire going straight through+    attached =+      [(nodeOf p, (Into, portOf p, inNames !! i, InWire i)) | (i, Right p) <- zip [0 ..] (unVec is)]+        ++ [(nodeOf p, (OutOf, portOf p, outNames !! j, OutWire j)) | (j, Right p) <- zip [0 ..] (unVec os)]+        ++ concat+          [ [(nodeOf p1, (OutOf, portOf p1, l, EdgeWire k)), (nodeOf p2, (Into, portOf p2, l, EdgeWire k))]+          | (k, (p1, l, p2)) <- zip [0 ..] es+          ]+    through = [(InWire i, OutWire (unFin j)) | (i, Left j) <- zip [0 ..] (unVec is)]+    factors =+      [nodeFactor seed nd [w | (m, w) <- attached, m == n] | (n, nd) <- zip [0 ..] ns]+        ++ [([x, y], [Map.fromList [(x, v), (y, v)] | v <- [False, True]]) | (x, y) <- through]+    boundary = Set.fromList (map InWire inIxs ++ map OutWire outIxs)+    -- every boundary wire is on a node or goes straight through, so each row has them all+    joined = [(t Map.!) | t <- joinAll boundary factors]++-- | A node as a table over its wires: every assignment of bits to them that it allows.+nodeFactor :: Int -> (NodeKind, String) -> [(End, String, String, Wire)] -> ([Wire], [Map Wire Bool])+nodeFactor seed (kind, opts) ws = (wires, filter holds (assignments wires))+  where+    wires = nubOrd [w | (_, _, _, w) <- ws]+    bits t = [(e, port, l, t Map.! w) | (e, port, l, w) <- ws]+    holds t = case kind of+      Crossing -> crossing (bits t)+      Spider -> allSame [b | (_, _, _, b) <- bits t]+      Box -> even (hashFrom nodeHash (show (List.sort (bits t))))+    crossing bs = lookupBit Into ":nw" bs == lookupBit OutOf ":se" bs && lookupBit Into ":ne" bs == lookupBit OutOf ":sw" bs+    lookupBit e port bs = [b | (e', port', _, b) <- bs, e' == e, port' == port]+    allSame bs = and (zipWith (==) bs (drop 1 bs))+    -- the node's own part of the hash, once rather than for every assignment+    nodeHash = hashFrom 7 (show (seed, opts))+    hashFrom = foldl (\h c -> (h * 31 + fromEnum c) `mod` 1000003)++assignments :: [Wire] -> [Map Wire Bool]+assignments = foldr (\w ts -> [Map.insert w v t | t <- ts, v <- [False, True]]) [Map.empty]++-- | The natural join of the tables, forgetting a wire once no table left mentions it and it is not+-- on the boundary. Tables are taken in order of how many wires they share with the join so far.+joinAll :: Set Wire -> [([Wire], [Map Wire Bool])] -> [Map Wire Bool]+joinAll boundary = go Set.empty [Map.empty]+  where+    go _ ts [] = ts+    go seen ts fs =+      let ((ws, rows), rest) = List.maximumBy (comparing (\(f, _) -> score f)) (picks fs)+          ts' = [Map.union t r | t <- ts, r <- rows, and (Map.intersectionWith (==) t r)]+          live = boundary `Set.union` Set.fromList (concat [ws' | (ws', _) <- rest])+      in go (seen `Set.union` Set.fromList ws) (Set.toList (Set.fromList [Map.restrictKeys t live | t <- ts'])) rest+      where+        score (ws, _) = (length (filter (`Set.member` seen) ws), negate (length ws))+    picks xs = [(x, before ++ after) | (before, x : after) <- zip (List.inits xs) (List.tails xs)]++instance TestableProfunctor Dot
+ test/Props/FinHask.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedLists #-}+{-# OPTIONS_GHC -Wno-orphans #-}++{- HLINT ignore "Use const" -}++module Props.FinHask where++import Data.Map.Strict qualified as M+import Data.Type.Equality ((:~:) (..))+import Data.Universe.Class (Finite (..))+import Data.Universe.Helpers (Tagged (..))+import Data.Void (Void)+import GHC.TypeNats (KnownNat, withKnownNat, withSomeSNat)+import Test.Tasty (TestTree, testGroup)+import Type.Reflection (Typeable, typeRep)+import Unsafe.Coerce (unsafeCoerce)+import Prelude (pure, ($))+import Prelude qualified as P++import Proarrow.Category.Enriched.Finitary (elements)+import Proarrow.Category.Instance.FinHask (FINHASK (..), Fin (..), FinHask (..), fromList)+import Proarrow.Core (CategoryOf (..), UN)++import Proarrow.Testing+  ( GenTotal (..)+  , Some (..)+  , Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , expect+  , genOb+  , genSomeDef+  , oneElem+  , optGen+  , pattern GenNonEmpty+  )+import Proarrow.Testing.Laws+import Proarrow.Tools.DPO (pushoutComplement)+import Props.Hask ()+import Test.Falsify (testFailed)+import Test.Falsify.Generator (minimalValue)+import Test.Tasty.Falsify (testProperty)++test :: TestTree+test =+  testGroup+    "FinHask"+    [ testCategory @FINHASK+    , testTerminalObject @FINHASK+    , testInitialObject @FINHASK+    , testBinaryProducts @FINHASK (\r -> r)+    , testCartesian @FINHASK (\r -> r) (\r -> r)+    , testMonoidal @FINHASK (\r -> r)+    , testSymMonoidal @FINHASK (\r -> r)+    , testCopyDiscard @FINHASK (\r -> r)+    , testBinaryCoproducts @FINHASK (\r -> r)+    , testDistributive @FINHASK (\r -> r) (\r -> r)+    , testClosed @FINHASK (\r -> r) (\r -> r)+    , testEqualizers @FINHASK withTestObFinHaskViaFin+    , testCoequalizers @FINHASK withTestObFinHaskViaFin+    , testEpiMonoFactorization @FINHASK withTestObFinHaskViaFin+    , testSubobjectClassifier @FINHASK (\r -> r)+    , testPullbacks @FINHASK withTestObFinHaskViaFin+    , testPushouts @FINHASK withTestObFinHaskViaFin+    , testFinitary @FinHask "FinHask"+    , testProperty "a pushout complement deletes what the rule does not keep" $+        -- a : Fin 1 -> l : Fin 2 keeps one of two elements; the match is the identity on Fin 2, so+        -- the complement is the one kept element+        pushoutComplement+          (fromList [(0 :: Fin 1, 0 :: Fin 2)])+          (fromList [(0 :: Fin 2, 0 :: Fin 2), (1, 1)])+          (\_ (FinHask d) -> expect "the complement is the kept element" [0 :: Fin 2] (M.elems d))+          (testFailed "should have been glueable")+    , testProperty "a match identifying a kept element with a deleted one is refused" $+        -- both elements of l map to 0, but the rule keeps only one of them+        pushoutComplement+          (fromList [(0 :: Fin 1, 0 :: Fin 2)])+          (fromList [(0 :: Fin 2, 0 :: Fin 1), (1, 0)])+          (\_ _ -> testFailed "should not have been glueable")+          (pure ())+    , testProperty "a match identifying two deleted elements is refused" $+        -- neither element of l is kept, and both map to 0, so no pushout complement exists+        pushoutComplement+          (fromList [] :: FinHask (FH (Fin 0)) (FH (Fin 2)))+          (fromList [(0 :: Fin 2, 0 :: Fin 1), (1, 0)])+          (\_ _ -> testFailed "should not have been glueable")+          (pure ())+    , testProperty "the numbering agrees with the universe" $ do+        -- 'testFinitary'\'s laws are all order-agnostic, so they would accept a numbering that+        -- disagreed with 'universe'; this is what pins the digit order.+        Some @a <- genOb @FINHASK+        Some @b <- genOb @FINHASK+        expect "elements should be the universe, in order" universeF (elements @FinHask @a @b)+    ]++-- | Only for 'testEqualizers', 'testCoequalizers', 'testPullbacks' and 'testPushouts': it assumes+-- the object is @FH (Fin n)@, as the 'FINHASK' equalizer, coequalizer, pullback and pushout+-- constructions (all via @reifyList@) produce, which the types cannot check. @n@ is recovered from+-- @e@'s cardinality and the equality is coerced, borrowing @Fin@'s 'Typeable'\/'TestableType'+-- instances. Elsewhere (e.g. 'testBinaryProducts') this is unsound: same cardinality is not same+-- runtime representation.+withTestObFinHaskViaFin :: forall (e :: FINHASK) r. (Ob e) => ((TestOb e) => r) -> r+withTestObFinHaskViaFin body = case cardinality @(UN FH e) of+  Tagged n -> withSomeSNat n \ @m snat -> withKnownNat snat (case sameAsFin @m of Refl -> body)+  where+    sameAsFin :: forall m. UN FH e :~: Fin m+    sameAsFin = unsafeCoerce Refl++instance Testable FINHASK where+  type TestOb a = (Ob a, Typeable (UN FH a), TestableType (UN FH a))+  showOb @(FH a) = P.show (typeRep @a)+  genSome = genSomeDef @'[FH Void, FH (), FH P.Bool, FH (Fin 3)]++instance (Ob a, Ob b) => TestingEqShow (FinHask a b)+instance (TestOb a, TestOb b) => TestableType (FinHask a b) where+  gen =+    case gen @(UN FH b) of+      GenEmpty absurd -> case gen @(UN FH a) of+        GenEmpty _ -> oneElem (FinHask M.empty)+        GenNonEmpty g -> GenEmpty \(FinHask m) -> absurd (m M.! minimalValue g)+      GenNonEmpty g -> GenNonEmpty (FinHask P.. M.fromList P.<$> P.traverse (\a -> (a,) P.<$> g) universeF)+instance TestableProfunctor FinHask++instance (KnownNat n) => TestingEqShow (Fin n)+instance (KnownNat n) => TestableType (Fin n) where+  gen = case universeF of+    [] -> GenEmpty \(Fin i) -> P.error ("impossible Fin 0 value: " P.++ P.show i)+    xs -> optGen xs
+ test/Props/FinRel.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE OverloadedLists #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Props.FinRel where++import Data.Type.Nat (Nat (..), Nat0, Nat1, Nat2, Nat3, SNatI, snat, snatToNat)+import Test.Falsify.Generator (Function (..), elem)+import Test.Tasty (TestTree, testGroup)+import Prelude hiding (elem, repeat)++import Proarrow.Category.Instance.FinRel (Bitstring, FINREL (..), FinRel (..))+import Proarrow.Category.Instance.Opposite (OPPOSITE (OP))+import Proarrow.Core (CAT, (\\), type (+->), type (~>))+import Proarrow.Profunctor.Corepresentable (coindex, cotabulate, withObCorep, type (%%))+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Representable (index, tabulate, withObRep, type (%))+import Proarrow.Promonad.Reader (Reader)+import Proarrow.Promonad.Writer (Writer)++import Proarrow.Testing+  ( Some (..)+  , SomeProfunctorElt (..)+  , Testable (..)+  , TestableProfunctor (..)+  , TestableType (..)+  , TestingEqShow (..)+  , genNamed+  , genOb+  , genSomeDef+  , invmap+  , pattern GenNonEmpty+  )+import Proarrow.Testing.Laws+import Props.Hask ()+import Props.Mat ()++test :: TestTree+test =+  testGroup+    "FinRel"+    [ testCategory @FINREL+    , testDagger @FINREL+    , testTerminalObject @FINREL+    , testInitialObject @FINREL+    , testBinaryProducts_ @FINREL+    , testBinaryCoproducts_ @FINREL+    , testMonoidal_ @FINREL+    , testSymMonoidal_ @FINREL+    , testDistributive_ @FINREL+    , testClosed_ @FINREL+    , testStarAutonomous_ @FINREL+    , testCompactClosed_ @FINREL+    , testTraced_ @FINREL+    , -- the tensor-hom (currying) adjunction @(FR Nat2 '**' -) ⊣ (FR Nat2 '~~>' -)@+      testAdjunction_ @(Reader (OP (FR Nat2)) :: FINREL +-> FINREL)+    , testMonStrong_ @(Reader (OP (FR Nat2)) :: FINREL +-> FINREL)+    , testMonCostrong_ @FinRel+    , testGroup "Id -| Id" [testProadjunction @(Id :: CAT FINREL) @Id]+    , testGroup "Writer -| Reader" [testProadjunction @(Writer (FR Nat2) :: FINREL +-> FINREL) @(Reader (OP (FR Nat2)))]+    , testGroup "Id procomonad" [testProcomonad @(Id :: CAT FINREL)]+    , testGroup "Writer procomonad" [testProcomonad @(Writer (FR Nat2) :: FINREL +-> FINREL)]+    , testGroup "Reader procomonad" [testProcomonad @(Reader (OP (FR Nat2)) :: FINREL +-> FINREL)]+    , testHypergraph_ @FINREL+    , testCopyDiscard_ @FINREL+    , testCommutativeMonoid_ @(FR Nat0)+    , testCommutativeMonoid_ @(FR Nat1)+    , testCommutativeMonoid_ @(FR Nat2)+    , testCommutativeMonoid_ @(FR Nat3)+    , -- morphism addition on a homset: a commutative monoid that is not Frobenius+      testCommutativeMonoid @(Id (FR Nat2) (FR Nat2)) (\r -> r)+    , testComonoid_ @(FR Nat0)+    , testComonoid_ @(FR Nat1)+    , testComonoid_ @(FR Nat2)+    , testComonoid_ @(FR Nat3)+    ]++instance Testable FINREL where+  showOb @(FR a) = show $ snatToNat $ snat @a+  genSome = genSomeDef @'[FR Z, FR (S Z), FR (S (S Z)), FR (S (S (S Z)))]+  genSomeSmall = genSomeDef @'[FR Z, FR (S Z), FR (S (S Z))]++instance (TestOb a, TestOb b) => TestableType (FinRel a b) where+  gen = invmap FinRel unFinRel gen+instance (TestOb a, TestOb b) => TestingEqShow (FinRel a b) where+  eqP (FinRel l) (FinRel r) = pure $ l == r+  showP (FinRel m) = show m+instance TestableProfunctor FinRel++instance (SNatI r, TestOb a, TestOb b) => TestingEqShow (Reader (OP (FR r)) a b) where+  eqP l r = eqP (coindex l) (coindex r) \\ coindex l+  showP m = showP (coindex m) \\ coindex m++instance (SNatI r) => TestableProfunctor (Reader (OP (FR r)) :: FINREL +-> FINREL) where+  genProfunctorElt nm = do+    Some @a <- genOb+    Some @b <- genOb+    withObCorep @(Reader (OP (FR r))) @a do+      m <- genNamed @(Reader (OP (FR r)) %% a ~> b) nm+      pure (SomeP (cotabulate @(Reader (OP (FR r))) @a @b m))++instance (SNatI r, TestOb a, TestOb b) => TestingEqShow (Writer (FR r) a b) where+  eqP l r = eqP (index l) (index r) \\ index l+  showP m = showP (index m) \\ index m++instance (SNatI r) => TestableProfunctor (Writer (FR r) :: FINREL +-> FINREL) where+  genProfunctorElt nm = do+    Some @a <- genOb+    Some @b <- genOb+    withObRep @(Writer (FR r)) @b do+      m <- genNamed @(a ~> Writer (FR r) % b) nm+      pure (SomeP (tabulate @(Writer (FR r)) @b @a m))++instance TestableProfunctor (Id :: CAT FINREL)++-- | A hom @a '~>' b@ wrapped as the identity profunctor 'Id' is a value of kind 'Type'; in a+-- biproduct category it is a commutative monoid under morphism addition. It is testable whenever+-- the underlying hom is.+instance (TestableType (a ~> b)) => TestableType (Id a b) where+  gen = invmap Id unId gen++instance (TestingEqShow (a ~> b)) => TestingEqShow (Id a b) where+  eqP (Id l) (Id r) = eqP l r+  showP (Id f) = showP f+instance Function (Id a b) where+  function = error "Function (Id a b): unused"++instance (SNatI n) => TestingEqShow (Bitstring n)+instance (SNatI n) => TestableType (Bitstring n) where+  gen = GenNonEmpty $ elem [minBound .. maxBound]
+ test/Props/FinSet.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE OverloadedLists #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Props.FinSet where++import Data.Fin (Fin, absurd, universe)+import Data.Proxy (Proxy (..))+import Data.Type.Equality (TestEquality (..), type (:~:) (..))+import Data.Type.Nat (Nat0, Nat1, Nat2, Nat3, Nat4, SNat (..), SNatI, reflect, snat)+import Data.Vec.Lazy (Vec (..), repeat)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude qualified as P++import Proarrow.Category.Instance.FinSet (FINSET (..), FinSet (..))+import Proarrow.Category.Topos (closedTopology, doubleNegation, openTopology)+import Proarrow.Core (CategoryOf (..), Promonad (..), UN)++import Proarrow.Testing+  ( GenTotal (..)+  , Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , genSomeDef+  , invmap+  , oneElem+  , optGen+  , testEq+  , pattern GenNonEmpty+  )+import Proarrow.Testing.Laws++test :: TestTree+test =+  testGroup+    "FinSet"+    [ testCategory @FINSET+    , testTerminalObject @FINSET+    , testInitialObject @FINSET+    , testBinaryProducts_ @FINSET+    , testCartesian_ @FINSET+    , testMonoidal_ @FINSET+    , testSymMonoidal_ @FINSET+    , testCopyDiscard_ @FINSET+    , testBinaryCoproducts_ @FINSET+    , testDistributive_ @FINSET+    , testClosed_ @FINSET+    , testEqualizers_ @FINSET+    , testCoequalizers_ @FINSET+    , testEpiMonoFactorization_ @FINSET+    , testSubobjectClassifier_ @FINSET+    , -- FINSET is Boolean, so its only topologies are the two extremes, and ¬¬ is the identity+      testGroup+        "Lawvere-Tierney topologies"+        [ testLawvereTierney_ @FINSET doubleNegation+        , testLawvereTierneyFamily_ @FINSET "open" openTopology+        , testLawvereTierneyFamily_ @FINSET "closed" closedTopology+        , testProperty "double negation is the identity" P.$+            testEq "¬¬" "doubleNegation" (doubleNegation @FINSET) "id" id+        , testNegation @FINSET+        ]+    , testPullbacks_ @FINSET+    , testPushouts_ @FINSET+    , testComonoid_ @(FS Nat0)+    , testComonoid_ @(FS Nat1)+    , testComonoid_ @(FS Nat2)+    , testComonoid_ @(FS Nat3)+    , testMonoid_ @(FS Nat1)+    , -- The product category, whose tensor, products and coproducts all go through the+      -- projections, so that 'Cartesian' can see the tensor as the product at all. We use+      -- FINSET, not a thin category: there parallel arrows are equal, so these laws could only+      -- check that the arrows evaluate. Both factors are the same, so mixing up the components+      -- still type-checks and has to be caught here.+      testGroup+        "FINSET x FINSET"+        [ testCategory @(FINSET, FINSET)+        , testTerminalObject @(FINSET, FINSET)+        , testInitialObject @(FINSET, FINSET)+        , testBinaryProducts_ @(FINSET, FINSET)+        , testBinaryCoproducts_ @(FINSET, FINSET)+        , testMonoidal_ @(FINSET, FINSET)+        , testSymMonoidal_ @(FINSET, FINSET)+        , testCopyDiscard_ @(FINSET, FINSET)+        , testCartesian_ @(FINSET, FINSET)+        , testDistributive_ @(FINSET, FINSET)+        ]+    ]++-- | Two finite sets are the same object when they have the same cardinality. Not a method of+-- 'Testable': no law needs to compare objects (see "Props.Span"\'s 'eqP' for why the ones that do+-- are comparing something existential).+eqFinSet :: forall (a :: FINSET) (b :: FINSET). (Ob a, Ob b) => P.Maybe (a :~: b)+eqFinSet = (\Refl -> Refl) P.<$> testEquality (snat @(UN FS a)) (snat @(UN FS b))++instance Testable FINSET where+  type TestOb a = Ob a+  showOb @(FS a) = P.show (reflect (Proxy @a))+  genSome = genSomeDef @'[FS Nat0, FS Nat1, FS Nat2, FS Nat3, FS Nat4]++instance (Ob a, Ob b) => TestingEqShow (FinSet a b)+instance (Ob a, Ob b) => TestableType (FinSet a b) where+  gen = invmap FinSet unFinSet gen+instance TestableProfunctor FinSet++instance (P.Eq a, P.Show a) => TestingEqShow (Vec n a)+instance (P.Eq a, P.Show a, TestableType a, SNatI n) => TestableType (Vec n a) where+  gen = case gen of+    GenEmpty absrd -> case snat @n of+      SZ -> oneElem VNil+      SS -> GenEmpty \(a ::: _) -> absrd a+    GenNonEmpty g -> GenNonEmpty (P.sequence (repeat @n g))++instance (SNatI n) => TestingEqShow (Fin n)+instance (SNatI n) => TestableType (Fin n) where+  gen = case snat @n of+    SZ -> GenEmpty absurd+    SS -> optGen universe
+ test/Props/Finitary.hs view
@@ -0,0 +1,409 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | (Co)equalizers, pullbacks and pushouts of finitary profunctors, on a small copresheaf over the+-- walking arrow: three rows at 'FLS', two at 'TRU', and 'F2T' carrying the first to the second.+-- The equalizer of the identity with the swap of two rows at 'FLS' is their fixed points, the+-- coequalizer identifies the swapped pair; the kernel pair of the merge of two rows at 'FLS' relates+-- exactly those two, its pushout along itself glues two copies of the rows at the merged ones, and its+-- image is the two rows it lands on. The exponentials and the subobject classifier are enumerated+-- too, completing the elementary topos structure.+module Props.Finitary (test) where++import Data.List (genericIndex, genericLength, sort)+import Numeric.Natural (Natural)+import Test.Falsify (testFailed)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (id, (.))++import Proarrow.Category.Enriched.Finitary (Finitary (..), sizes)+import Proarrow.Category.Enriched.Finitary.Topos (FIN, FINITARY, withTabulated)+import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..), IsBool (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Instance.Sub (SUBCAT (..), Sub (..))+import Proarrow.Category.Instance.Unit (Unit (..))+import Proarrow.Category.Topos (HasEpiMonoFactorization (..), isEq)+import Proarrow.Colimit.Coequalizer (HasCoequalizers (..))+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Colimit.Pushout (HasPushouts (..))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..))+import Proarrow.Functor (Copresheaf)+import Proarrow.Limit.BinaryProduct (PROD (..), Prod (..))+import Proarrow.Limit.Equalizer (HasEqualizers (..))+import Proarrow.Limit.Pullback (HasPullbacks (..), kernelPair)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Exponential ((:~>:))+import Proarrow.Profunctor.Instance.Product ((:*:) (..))+import Proarrow.Profunctor.Instance.Sieve (Sieve (..))+import Proarrow.Profunctor.Instance.Terminal (TerminalProfunctor)+import Proarrow.Testing+  ( Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , expect+  , genSomeDef+  , optGen+  )+import Proarrow.Testing.Laws+  ( propNaturalTransformation+  , testBinaryCoproducts_+  , testBinaryProducts_+  , testCategory+  , testClosed_+  , testCoequalizers_+  , testEpiMonoFactorization_+  , testEqualizers_+  , testFinitary+  , testInitialObject+  , testProfunctor+  , testPullbacks_+  , testPushouts_+  , testTerminalObject+  )+import Proarrow.Tools.DPO (Rule (..), dpoStep)+import Props.Bool ()++-- | The kind of finitary copresheaves on the walking arrow.+type Psh = FINITARY BOOL ()++type Rows :: Copresheaf BOOL+data Rows u b where+  R1, R2, R3 :: Rows '() FLS+  S1, S2 :: Rows '() TRU++deriving instance Eq (Rows u b)+deriving instance Ord (Rows u b)+deriving instance Show (Rows u b)++instance Profunctor Rows where+  dimap Unit Fls x = x+  dimap Unit Tru x = x+  dimap Unit F2T R1 = S1+  dimap Unit F2T R2 = S1+  dimap Unit F2T R3 = S2+  r \\ x = case x of+    R1 -> r+    R2 -> r+    R3 -> r+    S1 -> r+    S2 -> r++-- | The rows at one object, in the order the numbering below uses.+rows :: forall b. (IsBool b) => [Rows '() b]+rows = case boolId @b of+  Fls -> [R1, R2, R3]+  Tru -> [S1, S2]++instance Finitary Rows where+  size @_ @b = genericLength (rows @b)+  toIndex R1 = 0+  toIndex R2 = 1+  toIndex R3 = 2+  toIndex S1 = 0+  toIndex S2 = 1+  fromIndex @_ @b i = rows @b `genericIndex` i+  elements @_ @b = rows @b++instance (Ob u, Ob b) => TestingEqShow (Rows u b)++-- | Spelled out rather than taken from 'elements', so that 'testFinitary' checks the numbering+-- against something independent of it: a generator defined as @optGen elements@ can never produce a+-- row the instance has lost track of, and that is the mistake worth catching.+instance (Ob u, IsBool b) => TestableType (Rows u b) where+  gen = case boolId @b of+    Fls -> optGen [R1, R2, R3]+    Tru -> optGen [S1, S2]++instance TestableProfunctor Rows++-- | The copresheaf with one element at 'TRU' and none at 'FLS': a lone \"vertex\" for the+-- double-pushout tests. It is a subprofunctor of 'Rows' (nothing at 'FLS' can dangle off it).+type Point :: Copresheaf BOOL+data Point u b where+  Pt :: Point '() TRU++deriving instance Eq (Point u b)+deriving instance Show (Point u b)++instance Profunctor Point where+  dimap Unit Fls x = x+  dimap Unit Tru Pt = Pt+  dimap Unit F2T x = case x of {}+  r \\ Pt = r++instance Finitary Point where+  size @_ @b = genericLength (points @b)+  toIndex Pt = 0+  fromIndex @_ @b i = points @b `genericIndex` i+  elements @_ @b = points @b++points :: forall b. (IsBool b) => [Point '() b]+points = case boolId @b of+  Fls -> []+  Tru -> [Pt]++-- | One element at each object, the one at 'FLS' mapping to the one at 'TRU'. This is the+-- representable at 'FLS', and the analogue of an edge together with its endpoint.+type Edge :: Copresheaf BOOL+data Edge u b where+  Src :: Edge '() FLS+  Tgt :: Edge '() TRU++deriving instance Eq (Edge u b)+deriving instance Show (Edge u b)++instance Profunctor Edge where+  dimap Unit Fls Src = Src+  dimap Unit Tru Tgt = Tgt+  dimap Unit F2T Src = Tgt+  r \\ x = case x of Src -> r; Tgt -> r++instance Finitary Edge where+  size = 1+  toIndex _ = 0+  fromIndex @_ @b i = case boolId @b of+    Fls -> [Src] !! fromIntegral i+    Tru -> [Tgt] !! fromIntegral i++-- | Two elements at 'FLS' sharing the one at 'TRU': two edges with a common endpoint.+type TwoEdges :: Copresheaf BOOL+data TwoEdges u b where+  A1, A2 :: TwoEdges '() FLS+  T :: TwoEdges '() TRU++deriving instance Eq (TwoEdges u b)+deriving instance Show (TwoEdges u b)++instance Profunctor TwoEdges where+  dimap Unit Fls x = x+  dimap Unit Tru x = x+  dimap Unit F2T A1 = T+  dimap Unit F2T A2 = T+  r \\ x = case x of A1 -> r; A2 -> r; T -> r++instance Finitary TwoEdges where+  size @_ @b = genericLength (twoEdges @b)+  toIndex A1 = 0+  toIndex A2 = 1+  toIndex T = 0+  fromIndex @_ @b i = twoEdges @b `genericIndex` i+  elements @_ @b = twoEdges @b++twoEdges :: forall b. (IsBool b) => [TwoEdges '() b]+twoEdges = case boolId @b of+  Fls -> [A1, A2]+  Tru -> [T]++-- | Both edges matched onto 'R3', which is an identification conflict: two elements the rule deletes+-- share an image, so no pushout complement exists.+bothOnR3 :: Prof TwoEdges Rows+bothOnR3 = Prof \case+  A1 -> R3+  A2 -> R3+  T -> S2++-- | The interface of 'Edge' that keeps only its endpoint.+tgtOnly :: Prof Point Edge+tgtOnly = Prof \Pt -> Tgt++-- | 'Edge' sitting on 'R3' and the 'S2' it maps to: deleting both leaves nothing dangling.+atR3 :: Prof Edge Rows+atR3 = Prof \case+  Src -> R3+  Tgt -> S2++-- | 'Point' sitting on the second element at 'TRU', which 'R3' maps onto.+atS2 :: Prof Point Rows+atS2 = Prof \Pt -> S2++-- * The category of finitary copresheaves, as a testable kind++instance TestableProfunctor (Sub Prof :: CAT Psh)++-- | Objects are picked from a list, as 'Proarrow.Category.Instance.FinHask.FINHASK' does, since+-- generating an arbitrary finitary profunctor would mean generating a type.+--+-- 'TestOb' is just 'Ob', with no 'Typeable': a profunctor is displayed by its table of sizes, not+-- by a type name. So every property can be used in its @prop..._@ form below. Those pass the+-- constructions\' own object witnesses, which supply @Ob@ and nothing more, and @Ob@ is all+-- 'TestOb' asks for.+instance Testable Psh where+  showOb @(SUB p) = show (sizes @p)+  genSome = genSomeDef @'[FIN Rows, FIN Point, FIN Edge, FIN TwoEdges, FIN TerminalProfunctor]++-- | Swap the first two rows at 'FLS'. 'F2T' is onto, so naturality leaves no choice about the+-- component at 'TRU'; and the swap stays inside 'F2T'\'s fibres, so the component it forces is the+-- identity.+swapRows :: Prof Rows Rows+swapRows = Prof \case+  R1 -> R2+  R2 -> R1+  R3 -> R3+  S1 -> S1+  S2 -> S2++-- | Merge the first two rows at 'FLS'. As for 'swapRows', the component at 'TRU' is then forced to+-- be the identity. Not every natural family is the identity there, but this one is.+mergeRows :: Prof Rows Rows+mergeRows = Prof \case+  R2 -> R1+  x -> x++-- | The sizes of @1 ~~> Rows@ and of @Rows@ at one object, which Yoneda says must agree.+yoneda :: forall (b :: BOOL). (IsBool b) => (Natural, Natural)+yoneda = (size @(TerminalProfunctor :~>: Rows) @'() @b, size @Rows @'() @b)++test :: TestTree+test =+  testGroup+    "Finitary"+    [ testCategory @Psh+    , testTerminalObject @Psh+    , testInitialObject @Psh+    , testBinaryProducts_ @Psh+    , testBinaryCoproducts_ @Psh+    , testClosed_ @(PROD Psh)+    , testEqualizers_ @Psh+    , testCoequalizers_ @Psh+    , testEpiMonoFactorization_ @Psh+    , testPullbacks_ @Psh+    , testPushouts_ @Psh+    , testFinitary @Rows "Rows"+    , -- A profunctor presented by its tables is the same profunctor: same numbering, same action.+      -- Checked on 'Rows', whose 'F2T' action is not a bijection, so a wrong row would show.+      withTabulated @Rows \ @tab toTab _ ->+        testGroup+          "Tabulated Rows"+          [ testFinitary @tab "Tabulated Rows"+          , testProfunctor @tab+          , testProperty "the presentation is natural" $ propNaturalTransformation @Rows @tab toTab+          , -- natural and size-preserving, so an isomorphism; the round trips are 'Rows'\'s own laws+            testProperty "the presentation has the same sizes" $ expect "same sizes" (sizes @Rows) (sizes @tab)+          ]+    , -- The enumeration of natural transformations is itself a numbering, and obeys the same laws.+      -- Its generator draws from that same enumeration, so this checks the table round trip+      -- (tabulate a transformation built from a row and get the row back), not whether the+      -- enumeration is complete. The counts below check that.+      testFinitary @(Sub Prof :: CAT Psh) "Psh"+    , testProperty "the hom-sets have the sizes a hand count gives them" $ do+        -- 'F2T' is onto, so the component at TRU is forced; at FLS, R1 and R2 must land in a common+        -- fibre of it (four ways inside {R1, R2}, or both on R3), and R3 is free: 5 * 3.+        expect "Rows -> Rows" 15 (size @(Sub Prof) @(FIN Rows) @(FIN Rows))+        -- 'Edge' is the representable at 'FLS', so Yoneda says this is the size of 'Rows' there.+        expect "Edge -> Rows" 3 (size @(Sub Prof) @(FIN Edge) @(FIN Rows))+        -- two edges share an endpoint, so their images share a fibre, as R1 and R2 did above+        expect "TwoEdges -> Rows" 5 (size @(Sub Prof) @(FIN TwoEdges) @(FIN Rows))+        -- 'Point' is empty at FLS, so only its one element at TRU has to go somewhere+        expect "Point -> Rows" 2 (size @(Sub Prof) @(FIN Point) @(FIN Rows))+        -- and nothing at FLS can receive the three rows+        expect "Rows -> Point" 0 (size @(Sub Prof) @(FIN Rows) @(FIN Point))+    , testProperty "the equalizer of the identity and a swap is the fixed rows" $+        equalize @Psh @(FIN Rows) id (Sub swapRows) \(Sub (Prof @e incl)) -> do+          expect "both rows at TRU" 2 (size @e @'() @TRU)+          expect "the fixed row at FLS should be R3" [R3] (map incl (elements @e @'() @FLS))+    , testProperty "the kernel pair of a merge relates the merged rows" $+        kernelPair @Psh (Sub mergeRows) \l@(Sub (Prof @p p1)) r@(Sub (Prof p2)) -> do+          expect+            "the merged rows and the diagonal"+            [(R1, R1), (R1, R2), (R2, R1), (R2, R2), (R3, R3)]+            (sort [(p1 x, p2 x) | x <- elements @p @'() @FLS])+          expect "only the diagonal at TRU" [(S1, S1), (S2, S2)] [(p1 x, p2 x) | x <- elements @p @'() @TRU]+          -- The diagonal of 'Rows' is a cone over the kernel pair; factoring it through gives a section of+          -- either leg.+          case factorPullback @Psh l r id id of+            Sub (Prof diag) -> expect "the diagonal should factor through" [R1, R2, R3] (map (p1 . diag) (elements @Rows @'() @FLS))+    , testProperty "the coequalizer of the identity and a swap identifies the swapped rows" $+        coequalize @Psh @(FIN Rows) id (Sub swapRows) \(Sub (Prof @_ @c proj)) -> do+          expect "two classes at FLS" 2 (size @c @'() @FLS)+          expect "two classes at TRU" 2 (size @c @'() @TRU)+          expect "R1 and R2 identified, R3 apart" [0, 0, 1] (map (toIndex . proj) (elements @Rows @'() @FLS))+    , testProperty "the pushout of a merge along itself glues two copies at the merged rows" $+        pushout @Psh (Sub mergeRows) (Sub mergeRows) \l@(Sub (Prof @_ @p p1)) r@(Sub (Prof p2)) -> do+          expect "four classes at FLS" 4 (size @p @'() @FLS)+          expect "two classes at TRU" 2 (size @p @'() @TRU)+          -- The merged rows are glued, the two copies of R2 stay apart.+          expect+            "which rows the two copies share"+            [True, False, True]+            [toIndex (p1 x) == toIndex (p2 x) | x <- elements @Rows @'() @FLS]+          -- The merge itself, on both copies, is a cocone; factoring it gives a retraction of either leg.+          case factorPushout @Psh l r (Sub mergeRows) (Sub mergeRows) of+            Sub (Prof m) -> expect "the merge should factor through" [R1, R1, R3] (map (m . p1) (elements @Rows @'() @FLS))+    , testProperty "the image of a merge is the rows it lands on" $+        case factorize @Psh (Sub mergeRows) of+          Sub (Prof @_ @im epi) :.: Sub (Prof mono) -> do+            expect "two rows in the image at FLS" 2 (size @im @'() @FLS)+            expect "two rows in the image at TRU" 2 (size @im @'() @TRU)+            expect "mono after epi is the merge" [R1, R1, R3] (map (mono . epi) (elements @Rows @'() @FLS))+            expect "the epi part identifies R1 and R2" [0, 0, 1] (map (toIndex . epi) (elements @Rows @'() @FLS))+    , testProperty "deleting a row together with what it maps to has a pushout complement" $+        -- R3 and the S2 it maps to both go, so nothing is left dangling+        dpoStep+          (Rule (initiate @_ @(FIN Edge)) (initiate @_ @(FIN Edge)))+          (Sub atR3)+          ( \(Sub (Prof @d _)) _ _ -> do+              expect "R1 and R2 survive at FLS" 2 (size @d @'() @FLS)+              expect "only S1 survives at TRU" 1 (size @d @'() @TRU)+          )+          (testFailed "should have been glueable")+    , testProperty "a rule may delete a row and keep what it maps to" $+        -- the interface is the endpoint, so only R3 goes and both rows at TRU survive+        dpoStep+          (Rule (Sub tgtOnly) (id :: FIN Point ~> FIN Point))+          (Sub atR3)+          ( \(Sub (Prof @d _)) _ (Sub (Prof @_ @h _)) -> do+              expect "R1 and R2 survive at FLS" 2 (size @d @'() @FLS)+              expect "both rows survive at TRU" 2 (size @d @'() @TRU)+              -- gluing the kept endpoint back on is along an isomorphism, so the result matches+              expect "the result keeps two rows at FLS" 2 (size @h @'() @FLS)+              expect "the result keeps two rows at TRU" 2 (size @h @'() @TRU)+          )+          (testFailed "should have been glueable")+    , testProperty "an identification conflict between two deleted rows is refused" $+        -- both edges match onto R3, so the match identifies two elements the rule deletes+        dpoStep+          (Rule (initiate @_ @(FIN TwoEdges)) (initiate @_ @(FIN TwoEdges)))+          (Sub bothOnR3)+          (\_ _ _ -> testFailed "should not have been glueable")+          (pure ())+    , testProperty "the dangling condition fails when a surviving row points at a deleted one" $+        -- delete S2, which R3 maps onto: R3 would be left dangling+        dpoStep+          (Rule (initiate @_ @(FIN Point)) (initiate @_ @(FIN Point)))+          (Sub atS2)+          ( \_ _ _ ->+              testFailed "should not have been glueable"+          )+          (pure ())+    , testProperty "the exponential by the terminal object is the profunctor itself" $ do+        -- Yoneda: @1 ~~> q@ is @Nat(y(a,b), q)@, which is @q@ at that point.+        expect "1 ~~> Rows should be Rows at FLS" (3, 3) (yoneda @FLS)+        expect "1 ~~> Rows should be Rows at TRU" (2, 2) (yoneda @TRU)+        expect "Rows ~~> 1 should be the terminal object" 1 (size @(Rows :~>: TerminalProfunctor) @'() @FLS)+    , testProperty "the exponential of the rows by themselves is enumerated" $ do+        -- Counted by hand: a natural family is a pair of maps commuting with 'F2T', so summing over+        -- the four possible components at TRU gives 4 + 8 + 1 + 2 at FLS; at TRU the map is free.+        expect+          "Rows ~~> Rows"+          (15, 4)+          (size @(Rows :~>: Rows) @'() @FLS, size @(Rows :~>: Rows) @'() @TRU)+        -- Every index round trips, so the enumeration is a bijection and every family it builds is+        -- natural: 'toIndex' rejects the families that are not.+        expect+          "the exponential's indices should round trip"+          [0 .. 14]+          (map (toIndex @(Rows :~>: Rows) @'() @FLS) (elements @(Rows :~>: Rows) @'() @FLS))+    , testProperty "the subobject classifier has the three truth values of the walking arrow" $+        expect "Omega" (3, 2) (size @Sieve @'() @FLS, size @Sieve @'() @TRU)+    , testProperty "equality of rows is classified, and R1 and R2 become equal later" $+        -- 'isEq' takes only the object: its kind argument is inferred.+        case isEq @(PR (FIN Rows)) of+          Prod (Sub (Prof eq)) -> do+            let at x y = case eq (x :*: y) of Sieve s -> (s id Fls, s id F2T)+            expect "a row is equal to itself everywhere" (True, True) (at R1 R1)+            -- The middle truth value: false now, true once the arrow has merged them.+            expect "R1 and R2 should become equal at TRU" (False, True) (at R1 R2)+            expect "R1 and R3 should stay apart" (False, False) (at R1 R3)+    ]
+ test/Props/Finitary/Graph.hs view
@@ -0,0 +1,278 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The same topos laws as "Props.Finitary", but over a category with something going on in both+-- variances: @'FINITARY' 'GRAPH' 'BOOL'@. A profunctor @'GRAPH' '+->' 'BOOL'@ is a graph for each+-- object of the walking arrow together with a graph homomorphism between them, so this kind is the+-- arrow category of graphs. Being a presheaf category, it is an elementary topos like any other.+module Props.Finitary.Graph (test) where++import Data.List (genericIndex, genericLength)+import Numeric.Natural (Natural)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (id, (.))++import Examples.Graph (GRAPH (..), GraphHom (..))+import Proarrow.Category.Enriched.Finitary (Finitary (..), factorThrough, sizes)+import Proarrow.Category.Enriched.Finitary.Topos (FIN, FINITARY)+import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..), IsBool (..))+import Proarrow.Category.Instance.Opposite (OPPOSITE (..))+import Proarrow.Category.Instance.Prof (Prof)+import Proarrow.Category.Instance.Sub (SUBCAT (..), Sub)+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), obj, (//), type (+->))+import Proarrow.Limit.BinaryProduct (PROD (..))+import Proarrow.Profunctor.Instance.Coproduct ((:+:))+import Proarrow.Profunctor.Instance.Exponential ((:~>:))+import Proarrow.Profunctor.Instance.Sieve (Sieve)+import Proarrow.Profunctor.Instance.Terminal (TerminalProfunctor)+import Proarrow.Profunctor.Instance.Yoneda (Yo)+import Proarrow.Testing+  ( Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , expect+  , genSomeDef+  , optGen+  )+import Proarrow.Testing.Laws+  ( testBinaryCoproducts_+  , testBinaryProducts_+  , testCategory+  , testClosed_+  , testCoequalizers_+  , testEqualizers_+  , testFinitary+  , testInitialObject+  , testPullbacks_+  , testPushouts_+  , testTerminalObject+  )+import Props.Bool ()++-- | The kind of finitary graph homomorphisms. Contravariant in 'BOOL' and covariant in 'GRAPH':+-- @'lmap' 'F2T'@ is the homomorphism itself, carrying the graph at 'TRU' to the graph at 'FLS'.+type GHom = FINITARY GRAPH BOOL++-- * Three graph homomorphisms to test over++-- | The identity on the graph with one edge and two distinct endpoints. Nothing happens in the+-- 'BOOL' direction, and the two incidence maps disagree, so 'Src' and 'Tgt' are distinguishable.+type Same :: GRAPH +-> BOOL+data Same a b where+  SameE :: (IsBool a) => Same a E+  SameS :: (IsBool a) => Same a V+  SameT :: (IsBool a) => Same a V++deriving instance Eq (Same a b)+deriving instance Show (Same a b)++instance Profunctor Same where+  dimap ba dg x =+    ba // case (dg, x) of+      (IdE, SameE) -> SameE+      (IdV, SameS) -> SameS+      (IdV, SameT) -> SameT+      (Src, SameE) -> SameS+      (Tgt, SameE) -> SameT+  r \\ x = case x of SameE -> r; SameS -> r; SameT -> r++-- | The elements over each object, in the order the numbering below uses.+sameElements :: forall a b. (Ob a, Ob b) => [Same a b]+sameElements = case obj @b of+  IdE -> [SameE]+  IdV -> [SameS, SameT]++instance Finitary Same where+  size @a @b = genericLength (sameElements @a @b)+  toIndex SameE = 0+  toIndex SameS = 0+  toIndex SameT = 1+  fromIndex @a @b i = sameElements @a @b `genericIndex` i+  elements = sameElements++-- | The homomorphism that folds that edge into a self-loop: both endpoints go to the one vertex.+-- Non-injective in the 'BOOL' direction, and the loop makes 'Src' and 'Tgt' agree at 'FLS' while+-- they still differ at 'TRU'.+type Fold :: GRAPH +-> BOOL+data Fold a b where+  FoldE :: Fold TRU E+  FoldS :: Fold TRU V+  FoldT :: Fold TRU V+  LoopE :: Fold FLS E+  LoopV :: Fold FLS V++deriving instance Eq (Fold a b)+deriving instance Show (Fold a b)++-- | The 'FLS' layer has one element over each object, so an element there is determined by which+-- object the arrow lands on. So the action on it is forced.+atLoop :: GraphHom b d -> Fold FLS d+atLoop IdE = LoopE+atLoop IdV = LoopV+atLoop Src = LoopV+atLoop Tgt = LoopV++instance Profunctor Fold where+  dimap Fls dg _ = atLoop dg+  dimap F2T dg _ = atLoop dg+  dimap Tru IdE FoldE = FoldE+  dimap Tru IdV x = x+  dimap Tru Src FoldE = FoldS+  dimap Tru Tgt FoldE = FoldT+  r \\ x = case x of FoldE -> r; FoldS -> r; FoldT -> r; LoopE -> r; LoopV -> r++foldElements :: forall a b. (Ob a, Ob b) => [Fold a b]+foldElements = case (boolId @a, obj @b) of+  (Tru, IdE) -> [FoldE]+  (Tru, IdV) -> [FoldS, FoldT]+  (Fls, IdE) -> [LoopE]+  (Fls, IdV) -> [LoopV]++instance Finitary Fold where+  size @a @b = genericLength (foldElements @a @b)+  toIndex FoldE = 0+  toIndex FoldS = 0+  toIndex FoldT = 1+  toIndex LoopE = 0+  toIndex LoopV = 0+  fromIndex @a @b i = foldElements @a @b `genericIndex` i+  elements = foldElements++instance (Ob a, Ob b) => TestingEqShow (Same a b)+instance (Ob a, Ob b) => TestingEqShow (Fold a b)++-- | Spelled out instead of taken from 'elements', so that 'testFinitary' compares the numbering+-- against something independent of it, as in "Props.Finitary".+instance (Ob a, Ob b) => TestableType (Same a b) where+  gen = case obj @b of+    IdE -> optGen [SameE]+    IdV -> optGen [SameS, SameT]++instance (Ob a, Ob b) => TestableType (Fold a b) where+  gen = case (boolId @a, obj @b) of+    (Tru, IdE) -> optGen [FoldE]+    (Tru, IdV) -> optGen [FoldS, FoldT]+    (Fls, IdE) -> optGen [LoopE]+    (Fls, IdV) -> optGen [LoopV]++instance TestableProfunctor Same+instance TestableProfunctor Fold++-- | The identity on the graph with one vertex and no edges. Empty over 'E', so hom-sets out of it+-- are the ones that go empty, and the properties discard instead of failing.+type Dot :: GRAPH +-> BOOL+data Dot a b where+  DotV :: (IsBool a) => Dot a V++instance Profunctor Dot where+  -- 'DotV' first: only then does GHC see that @b@ is 'V', so that 'IdV' is the only arrow out of it+  dimap ba dg DotV = case dg of IdV -> ba // DotV+  r \\ DotV = r++dotElements :: forall a b. (Ob a, Ob b) => [Dot a b]+dotElements = case obj @b of+  IdE -> []+  IdV -> [DotV]++instance Finitary Dot where+  size @a @b = genericLength (dotElements @a @b)+  toIndex DotV = 0+  fromIndex @a @b i = dotElements @a @b `genericIndex` i+  elements = dotElements++-- * The arrow category of graphs, as a testable kind++instance TestableProfunctor (Sub Prof :: CAT GHom)++-- | As in "Props.Finitary": objects come from a fixed palette, and are displayed by their table of+-- sizes, here the four numbers @[FLS\/E, FLS\/V, TRU\/E, TRU\/V]@.+instance Testable GHom where+  showOb @(SUB p) = show (sizes @p)++  -- 'Same' twice over gives a palette object of size 2 at every point. Without one, nine of the+  -- ten non-empty hom-sets are singletons, where an equation between parallel arrows holds by+  -- type-correctness alone and the run asserts nothing. Built from the library's ':+:', whose+  -- 'Finitary' instance supplies the numbering.+  genSome = genSomeDef @'[FIN Same, FIN Fold, FIN Dot, FIN TerminalProfunctor, FIN (Same :+: Same)]++  -- The internal hom enumerates candidate tables by brute force, so it cannot afford the object+  -- above: @sizes \@(Same :+: Same)@ is @[2,4,2,4]@, but the hom /into/ it is @[1024,256,1024,256]@,+  -- and enumerating one such hom-set measured 13.6s and 36.6GB. 'testClosed' draws from+  -- 'genSomeSmall', so the two coexist.+  genSomeSmall = genSomeDef @'[FIN Same, FIN Fold, FIN Dot, FIN TerminalProfunctor]++-- | The sizes of @1 ~~> p@ and of @p@ over one object, which Yoneda says must agree.+yoneda :: forall (p :: GRAPH +-> BOOL). (Finitary p) => [(Natural, Natural)]+yoneda = zip (sizes @(TerminalProfunctor :~>: p)) (sizes @p)++test :: TestTree+test =+  testGroup+    "Finitary.Graph"+    [ testCategory @GHom+    , testTerminalObject @GHom+    , testInitialObject @GHom+    , testBinaryProducts_ @GHom+    , testBinaryCoproducts_ @GHom+    , testClosed_ @(PROD GHom)+    , testEqualizers_ @GHom+    , testCoequalizers_ @GHom+    , testPullbacks_ @GHom+    , testPushouts_ @GHom+    , -- 'GRAPH' is the only non-thin finite category here, so it is the only place+      -- 'factorThrough' has anything to decide. In a thin one @f . h@ and @g@ are both the unique+      -- arrow of their hom-set, so the check succeeds whenever the hom-set is non-empty. The sheaf+      -- sites are both thin, so @Props.Sheaf@ cannot exercise this.+      testProperty "factorThrough decides, where there is a choice of arrow" $ do+        expect "Src factors through itself" (Just IdE) (factorThrough Src Src)+        expect "Tgt does not factor through Src" Nothing (factorThrough Tgt Src)+        expect "Src factors through IdV" (Just Src) (factorThrough Src IdV)+    , testFinitary @Same "Same"+    , testFinitary @Fold "Fold"+    , -- the palette object added above, so its numbering is law-checked and not merely used+      testFinitary @(Same :+: Same) "Same + Same"+    , -- as in "Props.Finitary": this checks the table round trip, the counts below check that the+      -- enumeration is complete+      testFinitary @(Sub Prof :: CAT GHom) "GHom"+    , testProperty "the hom-sets have the sizes a hand count gives them" $ do+        -- a lone vertex picks an endpoint of the edge, and the same one in both layers+        expect "Dot -> Same" 2 (size @(Sub Prof) @(FIN Dot) @(FIN Same))+        expect "Dot -> Fold" 2 (size @(Sub Prof) @(FIN Dot) @(FIN Fold))+        -- the edge graph has one endomorphism and one map onto the loop, both forced by 'Src'+        -- and 'Tgt' having to be preserved+        expect "Same -> Same" 1 (size @(Sub Prof) @(FIN Same) @(FIN Same))+        expect "Same -> Fold" 1 (size @(Sub Prof) @(FIN Same) @(FIN Fold))+        -- backwards there is nothing: a loop would need its one vertex to be both endpoints+        expect "Fold -> Same" 0 (size @(Sub Prof) @(FIN Fold) @(FIN Same))+        -- and a graph with no edges cannot receive one+        expect "Same -> Dot" 0 (size @(Sub Prof) @(FIN Same) @(FIN Dot))+        -- the edge graph has no global sections, for the same reason the loop has no map into it+        expect "1 -> Same" 0 (size @(Sub Prof) @(FIN TerminalProfunctor) @(FIN Same))+    , testProperty "the exponential by the terminal object is the profunctor itself" $ do+        expect "Same" [(1, 1), (2, 2), (1, 1), (2, 2)] (yoneda @Same)+        expect "Fold" [(1, 1), (1, 1), (1, 1), (2, 2)] (yoneda @Fold)+        expect "Dot" [(0, 0), (1, 1), (0, 0), (1, 1)] (yoneda @Dot)+    , testProperty "the Yoneda embedding is numbered as a mixed radix" $ do+        -- The weight of every end here. Neither testable kind exercises its two factors together,+        -- 'BOOL' being thin, but over the schema alone both can exceed one. @Yo V (OP E)@ has+        -- @(c -> V)@ paired with @(E -> d)@, which is 2 * 1, 2 * 2, 1 * 1 and 1 * 2.+        expect+          "sizes"+          [2, 4, 1, 2]+          (sizes @(Yo V (OP E)))+        -- and the index agrees with the enumeration where the radix actually carries. The internal+        -- hom depends on this invariant, since it tabulates families against one and reads them+        -- back with the other+        expect "indices" [0, 1, 2, 3] (map (toIndex @(Yo V (OP E)) @E @V) (elements @(Yo V (OP E)) @E @V))+    , testProperty "the subobject classifier counts the sieves of the index category" $+        -- A sieve over @(a, b)@ is a set of pairs @(g : c -> a, h : b -> d)@ closed under+        -- precomposition. Over 'FLS' there is one @g@, over 'TRU' there are two, ordered. Over 'V'+        -- there is one @h@; over 'E' there are three, with 'IdE' above 'Src' and 'Tgt'. Counting the+        -- down-closed subsets of each product gives 5, 2, 14 and 3.+        expect+          "Omega"+          [5, 2, 14, 3]+          (sizes @(Sieve :: GRAPH +-> BOOL))+    ]
+ test/Props/Free.hs view
@@ -0,0 +1,399 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Props.Free where++import Control.Applicative (Alternative (..))+import Control.Monad (unless)+import Data.Foldable (for_)+import Data.Kind (Type)+import Data.Type.Equality ((:~:) (..))+import Data.Type.Nat (Nat2)+import Test.Falsify (testFailed)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (Monoid, curry, fst, id, mempty, snd, (**), (.))+import Prelude qualified as P++import Proarrow.Category.Instance.FinRel (FINREL (..))+import Proarrow.Category.Instance.Free (FREE (..), Free (..), Lower, retract, widen)+import Proarrow.Category.Instance.Opposite (OPPOSITE (..))+import Proarrow.Category.Instance.Unit (Unit (..))+import Proarrow.Category.Monoidal (Monoidal, MonoidalProfunctor (..), SymMonoidal, UnitF, withOb2, type (**!))+import Proarrow.Category.Monoidal.Cartesian (Cartesian, prodToTensor, tensorToProd, termToUnit, unitToTerm)+import Proarrow.Category.Monoidal.Closed (Closed, apply, curry, withObExp, type (-->))+import Proarrow.Category.Monoidal.CompactClosed (CompactClosed)+import Proarrow.Category.Monoidal.Distributive (Distributive)+import Proarrow.Category.Monoidal.StarAutonomous (DualF, StarAutonomous)+import Proarrow.Category.Sheaf (Cover (..), Leg (..), Sheaf (..), Summands, Sums, legArrow)+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..), type (+))+import Proarrow.Colimit.Initial (HasInitialObject (..), InitF)+import Proarrow.Core (CAT, CategoryOf (..), Promonad (..), lmap, obj, type (+->))+import Proarrow.Functor (FunctorForRep (..), type (@))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..), type (*!))+import Proarrow.Limit.Terminal (HasTerminalObject (..), TermF)+import Proarrow.Monoid (Comonoid (..), Monoid (..), Supplies)+import Proarrow.Profunctor.Instance.Initial (InitialProfunctor)+import Proarrow.Profunctor.Instance.Yoneda (Yo (..))+import Proarrow.Profunctor.Representable (Rep (..))++import Proarrow.Testing+  ( GenTotal (..)+  , MkSomeList (..)+  , Some (..)+  , Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , expect+  , genNamed+  , genSomeDef+  , oneOfTotal+  , testEq+  )+import Proarrow.Testing.Laws+import Props.Hask ()++type FREECS =+  '[ HasInitialObject+   , HasTerminalObject+   , HasBinaryProducts+   , HasBinaryCoproducts+   , Monoidal+   , SymMonoidal+   , Closed+   , Distributive+   , StarAutonomous+   , CompactClosed+   , Supplies Monoid+   , Supplies Comonoid+   ]+type FREEKIND = FREE FREECS (InitialProfunctor :: CAT ())++-- | The free category has no generating morphisms to interpret (@'InitialProfunctor'@ is+-- uninhabited), so any object at all works as the interpretation of @'()@. A small finite set+-- gives 'retract' below plenty to sample from. It is in 'FINREL', not 'Type', since+-- 'StarAutonomous'\/'CompactClosed' need a target that has dual objects.+data family Interp :: () +-> FINREL++instance FunctorForRep Interp where+  type Interp @ '() = FR Nat2+  fmap Unit = obj @(FR Nat2)++-- | The object @a@ interpreted in 'FINREL', by folding its structure through 'Interp'.+type LowerT a = Lower (Rep Interp) a++test :: TestTree+test =+  testGroup+    "Free"+    [ testCategory @FREEKIND+    , testTerminalObject @FREEKIND+    , testInitialObject @FREEKIND+    , testBinaryProducts @FREEKIND (\ @a @b r -> withObProd @FINREL @(LowerT a) @(LowerT b) r)+    , testBinaryCoproducts @FREEKIND (\ @a @b r -> withObCoprod @FINREL @(LowerT a) @(LowerT b) r)+    , testClosed @FREEKIND+        (\ @a @b r -> withOb2 @FINREL @(LowerT a) @(LowerT b) r)+        (\ @a @b r -> withObExp @FINREL @(LowerT a) @(LowerT b) r)+    , testMonoidal @FREEKIND (\ @a @b r -> withOb2 @FINREL @(LowerT a) @(LowerT b) r)+    , testSymMonoidal @FREEKIND (\ @a @b r -> withOb2 @FINREL @(LowerT a) @(LowerT b) r)+    , testDistributive @FREEKIND+        (\ @a @b r -> withOb2 @FINREL @(LowerT a) @(LowerT b) r)+        (\ @a @b r -> withObCoprod @FINREL @(LowerT a) @(LowerT b) r)+    , -- 'testStarAutonomous' isn't wired in here. Its naturality checks need e.g. an arbitrary+      -- @a ** b ~> Dual c@ for independently-drawn a,b,c, but in a free category that hom-set is+      -- empty for most palette triples (no unitor/associator-driven bridge connects a plain+      -- tensor shape to an unrelated dualized one). 'genTerm' can't conjure a morphism that+      -- doesn't exist, so every sample gets discarded. 'testCompactClosed' avoids this, since none+      -- of its checks need to generate a random Dual-involving morphism, only compose the fixed+      -- ones 'CompactClosed' already provides.+      testCompactClosed @FREEKIND+        (\ @a @b r -> withOb2 @FINREL @(LowerT a) @(LowerT b) r)+        (\ @a @b r -> withObExp @FINREL @(LowerT a) @(LowerT b) r)+        (\r -> r)+    , testHypergraph @FREEKIND (\ @a @b r -> withOb2 @FINREL @(LowerT a) @(LowerT b) r)+    , sheafTests+    , testProperty "cartesian coercions interpret to identities" P.$ do+        let roundTrip = retract @CARTCS @(Rep InterpT) (tensorToProd @(EMB '()) @(EMB '()) . prodToTensor @(EMB '()) @(EMB '()))+            unitTrip = retract @CARTCS @(Rep InterpT) (unitToTerm . termToUnit)+        unless (roundTrip (True, False) P.== (True, False) P.&& unitTrip () P.== ()) (testFailed "cartesian coercions")+    , testProperty "retract . widen = retract" P.$ do+        let l = retract @NARROWCS @(Rep Interp) narrowTerm+            r = retract @FREECS @(Rep Interp) (widen @FREECS narrowTerm)+        unless (l P.== r) (testFailed (P.show l P.++ " /= " P.++ P.show r))+    ]++-- * The cartesian coercions++-- | A free category with the 'Cartesian' marker, interpreted into @Type@ (where the coercions+-- are identities), with the one generator object standing for 'Bool'.+type CARTCS = '[Cartesian, HasTerminalObject, HasBinaryProducts, Monoidal]++data family InterpT :: () +-> Type++instance FunctorForRep InterpT where+  type InterpT @ '() = Bool+  fmap Unit = obj @Bool++-- * Widening++type NARROWCS = '[HasInitialObject, HasTerminalObject, HasBinaryProducts]++-- | A term using all three structures of the narrow list, for the widening test above.+narrowTerm+  :: Free+       ((InitF *! TermF) :: FREE NARROWCS (InitialProfunctor :: CAT ()))+       ((TermF *! InitF) *! TermF)+narrowTerm = (terminate &&& (initiate @_ @InitF . fst @_ @InitF @TermF)) &&& snd @_ @InitF @TermF++-- | A singleton witnessing the shape of an object expression, so 'genTerm' can pattern-match+-- on source and target shapes directly instead of needing a type class per shape.+data SFree (a :: FREEKIND) where+  SInit :: SFree InitF+  STerm :: SFree TermF+  SProd :: (Ob a, Ob b) => SFree a -> SFree b -> SFree (a *! b)+  SSum :: (Ob a, Ob b) => SFree a -> SFree b -> SFree (a + b)+  SUnit :: SFree UnitF+  STen :: (Ob a, Ob b) => SFree a -> SFree b -> SFree (a **! b)+  SExp :: (Ob a, Ob b) => SFree a -> SFree b -> SFree (a --> b)+  SDual :: (Ob a) => SFree a -> SFree (DualF a)++class (Ob a) => KnownFree (a :: FREEKIND) where+  theFree :: SFree a+instance KnownFree InitF where+  theFree = SInit+instance KnownFree TermF where+  theFree = STerm+instance (KnownFree a, KnownFree b) => KnownFree (a *! b) where+  theFree = SProd theFree theFree+instance (KnownFree a, KnownFree b) => KnownFree (a + b) where+  theFree = SSum theFree theFree+instance KnownFree UnitF where+  theFree = SUnit+instance (KnownFree a, KnownFree b) => KnownFree (a **! b) where+  theFree = STen theFree theFree+instance (KnownFree a, KnownFree b) => KnownFree (a --> b) where+  theFree = SExp theFree theFree+instance (KnownFree a) => KnownFree (DualF a) where+  theFree = SDual theFree++-- | Decides whether two object shapes are the same, structurally. 'genTerm' uses this to+-- check whether a generator branch's source\/target lines up with the shape it wants+-- to produce, without needing runtime type reflection.+eqSFree :: SFree a -> SFree b -> Maybe (a :~: b)+eqSFree SInit SInit = Just Refl+eqSFree STerm STerm = Just Refl+eqSFree (SProd a1 a2) (SProd b1 b2) = case (eqSFree a1 b1, eqSFree a2 b2) of+  (Just Refl, Just Refl) -> Just Refl+  _ -> Nothing+eqSFree (SSum a1 a2) (SSum b1 b2) = case (eqSFree a1 b1, eqSFree a2 b2) of+  (Just Refl, Just Refl) -> Just Refl+  _ -> Nothing+eqSFree SUnit SUnit = Just Refl+eqSFree (STen a1 a2) (STen b1 b2) = case (eqSFree a1 b1, eqSFree a2 b2) of+  (Just Refl, Just Refl) -> Just Refl+  _ -> Nothing+eqSFree (SExp a1 a2) (SExp b1 b2) = case (eqSFree a1 b1, eqSFree a2 b2) of+  (Just Refl, Just Refl) -> Just Refl+  _ -> Nothing+eqSFree (SDual a1) (SDual b1) = case eqSFree a1 b1 of+  Just Refl -> Just Refl+  Nothing -> Nothing+eqSFree _ _ = Nothing++-- | Render an object shape for test failure output.+showSFree :: SFree a -> String+showSFree SInit = "InitF"+showSFree STerm = "TermF"+showSFree (SProd a b) = "(" ++ showSFree a ++ " *! " ++ showSFree b ++ ")"+showSFree (SSum a b) = "(" ++ showSFree a ++ " + " ++ showSFree b ++ ")"+showSFree SUnit = "UnitF"+showSFree (STen a b) = "(" ++ showSFree a ++ " **! " ++ showSFree b ++ ")"+showSFree (SExp a b) = "(" ++ showSFree a ++ " --> " ++ showSFree b ++ ")"+showSFree (SDual a) = "(Dual " ++ showSFree a ++ ")"++-- | The finite palette of shapes 'Testable' picks 'Some' objects from as the /endpoints/ of a+-- generated term. @composeB@ routes through 'Intermediates'.+--+-- Every shape is built from 'UnitF', and none from 'TermF' or 'InitF'. Terms are compared by+-- interpretation into 'FINREL', where the terminal and initial objects are both the empty set, so+-- at any object built from them alone every hom-set has one element and every comparison is+-- vacuous. The unit interprets to a one-element set, and the shapes over it do not collapse.+type Palette = '[UnitF, UnitF *! UnitF, UnitF + UnitF, UnitF **! UnitF, UnitF --> UnitF]++-- | The shapes @composeB@ routes intermediates through. It is 'Palette' plus 'TermF' and 'InitF'.+-- As /endpoints/ those two are useless (every hom-set at them is a singleton in 'FINREL', so a+-- comparison there cannot fail), but as /waypoints/ they are not. Going through 'TermF' builds+-- @'counit' '.' 'terminate' :: 'UnitF' '~>' 'UnitF'@, which interprets to the empty relation and is+-- the only non-identity endomorphism of 'UnitF' the generator can reach. Without it every law+-- comparison landing at @'UnitF' '~>' 'UnitF'@ is a single fixed instance.+type Intermediates = TermF ': InitF ': Palette++intermediates :: [Some FREEKIND]+intermediates = mkSomeList @FREEKIND @Intermediates++-- | Generate a random term between two (given) object shapes. Most branches recurse+-- structurally on a strictly smaller sub-shape of the source or target, so they always+-- terminate on their own; @composeB@ is the exception (it can reach into an unrelated object+-- via composition), so it's the one branch bounded by @fuel@, which decreases on every+-- recursive call and cuts it off at zero.+genTerm :: forall a b. (Ob a, Ob b) => Int -> SFree a -> SFree b -> GenTotal (Free a b)+genTerm fuel sa sb =+  oneOfTotal [idB, initiateB, terminateB, unitB, counitB, fstSndB, applyB, recB]+  where+    recB+      | fuel <= 0 = empty+      | otherwise = oneOfTotal [prodB, tensorB, sumSrcB, sumTgtB, curryB, composeB]+    idB = case eqSFree sa sb of+      Just Refl -> pure id+      Nothing -> empty+    initiateB = case sa of+      SInit -> pure initiate+      _ -> empty+    terminateB = case sb of+      STerm -> pure terminate+      _ -> empty+    -- The unit is neither initial nor terminal, but every object is a monoid and a comonoid here,+    -- so there is a canonical arrow from it and one to it all the same.+    unitB = case sa of+      SUnit -> pure mempty+      _ -> empty+    counitB = case sb of+      SUnit -> pure counit+      _ -> empty+    fstSndB = case sa of+      SProd sa1 sa2 ->+        oneOfTotal+          [ case eqSFree sb sa1 of Just Refl -> pure fst; Nothing -> empty+          , case eqSFree sb sa2 of Just Refl -> pure snd; Nothing -> empty+          ]+      _ -> empty+    prodB = case sb of+      SProd b1 b2 -> (&&&) <$> genTerm (fuel - 1) sa b1 <*> genTerm (fuel - 1) sa b2+      _ -> empty+    tensorB = case (sa, sb) of+      (STen a1 a2, STen b1 b2) -> (**) <$> genTerm (fuel - 1) a1 b1 <*> genTerm (fuel - 1) a2 b2+      _ -> empty+    sumSrcB = case sa of+      SSum a1 a2 -> (|||) <$> genTerm (fuel - 1) a1 sb <*> genTerm (fuel - 1) a2 sb+      _ -> empty+    sumTgtB = case sb of+      SSum b1 b2 -> oneOfTotal [(lft .) <$> genTerm (fuel - 1) sa b1, (rgt .) <$> genTerm (fuel - 1) sa b2]+      _ -> empty+    -- a ~ (b --> c) **! b, with c ~ the target.+    applyB = case sa of+      STen sl sr -> case sl of+        SExp sea1 sea2 -> case (eqSFree sr sea1, eqSFree sb sea2) of+          (Just Refl, Just Refl) -> pure apply+          _ -> empty+        _ -> empty+      _ -> empty+    curryB = case sb of+      SExp b1 b2 -> curry <$> genTerm (fuel - 1) (STen sa b1) b2+      _ -> empty+    -- Route through every palette shape as a possible intermediate object. Without this the+    -- generator could never compose two otherwise-unrelated terms.+    composeB =+      oneOfTotal+        [ (.) <$> genTerm (fuel - 1) (theFree @mid) sb <*> genTerm (fuel - 1) sa (theFree @mid)+        | Some @mid <- intermediates+        ]++-- | Bridges straight to 'FINREL'\'s 'Ob' instead of its 'TestOb'. 'Testable FINREL' leaves+-- 'TestOb' at its class default ('type TestOb a = Ob a'), and an unrestated default associated+-- type equation doesn't get unfolded through an abstract type variable the way an explicit+-- instance override (like 'CategoryOf FINREL'\'s own 'Ob' equation) does.+instance Testable FREEKIND where+  type TestOb a = (KnownFree a, Ob (LowerT a))+  showOb @a = showSFree (theFree @a)+  genSome = genSomeDef @Palette++-- | Two terms are equal iff they denote the same relation once interpreted into 'FINREL' via+-- 'retract', decided by 'FinRel'\'s own 'Eq'. Structural equality on 'Free' terms would be too+-- strict for testing categorical laws: e.g. @'terminate' . f@ and @'terminate'@ are built from+-- different 'Free' constructors even though uniqueness of the terminal object makes them denote+-- the same morphism.+instance (TestOb a, TestOb b) => TestingEqShow (Free (a :: FREEKIND) b) where+  eqP l r = pure (retract @FREECS @(Rep Interp) l == retract @FREECS @(Rep Interp) r)++instance (TestOb a, TestOb b) => TestableType (Free (a :: FREEKIND) b) where+  gen = genTerm 3 (theFree @a) (theFree @b)+instance TestableProfunctor (Free :: CAT FREEKIND)++-- | The cover of the booleans by their two points. 'BySummands' is polymorphic in the summands, so+-- the cover it is used at has to be pinned. The summands are 'UnitF' and not @TermF@ for the reason+-- 'Palette' gives.+boolCover :: Cover Sums FREEKIND (UnitF + UnitF) (Summands (UnitF :: FREEKIND) UnitF)+boolCover = BySummands++-- | The sum coverage on the free category, at the cover of the booleans by their two points: the+-- representables glue by @'|||'@. So restriction along either injection gives the branch back, and+-- an element is the gluing of its restrictions.+sheafTests :: TestTree+sheafTests =+  testGroup+    "Sums"+    [ testGluesBackAt @Sums @(Yo (UnitF + UnitF) (OP '())) "BySummands, sum representable" boolCover+    , -- the two-sided representable's own profunctor laws. These exercise 'Yo'\'s action on the+      -- covariant component, which the presheaf cases above leave at the identity+      testProfunctor @(Yo (UnitF + UnitF) (OP Bool) :: Type +-> FREEKIND)+    , testGluesBackAt+        @Sums+        @(Yo (UnitF + UnitF) (OP Bool) :: Type +-> FREEKIND)+        "BySummands, representable over Hask"+        boolCover+    , -- The gluing keeps one covariant component where the family supplies two, so it is only well+      -- The gluing keeps one covariant component of the two the family supplies, which is well+      -- defined because the two agree on the overlap. After restricting along the overlap the+      -- contravariant components are always equal ('InitF' is initial), so the covariant ones+      -- decide. The un-restricted pair below is the other way round, so both halves of 'eqP' on+      -- 'Yo' are exercised.+      testProperty "the overlap decides the covariant component" do+        let overlap = initiate @FREEKIND @UnitF+            at+              :: Free (UnitF :: FREEKIND) (UnitF + UnitF) -> (Bool -> Bool) -> Yo (UnitF + UnitF) (OP Bool) (UnitF :: FREEKIND) Bool+            at inj h = Yo inj h+        for_ [(h, h') | h <- [P.id, P.not], h' <- [P.id, P.not]] \(h, h') -> do+          agree <- eqP h h'+          same <- eqP (lmap overlap (at lft h)) (lmap overlap (at rgt h'))+          expect "restricted to the overlap: equal exactly when the covariant halves agree" agree same+          apart <- eqP (at lft h) (at rgt h)+          expect "un-restricted: the differing contravariant halves separate them" False apart+    , -- The commuting conversion, in sheaf vocabulary: a map of sheaves carries a gluing to the+      -- gluing of the mapped family. At the representable, gluing is @'|||'@ and the map is+      -- post-composition, so this is @h '.' (t '|||' e) = (h '.' t) '|||' (h '.' e)@, the+      -- equation that makes @f (if b then x else y)@ and @if b then f x else f y@ the same+      -- program. It follows from restriction and uniqueness together with @h@\'s naturality, so it+      -- is not a new law but a demonstration.+      testProperty "a map of sheaves commutes with the gluing" do+        t <- genNamed @(Free (UnitF :: FREEKIND) (UnitF + UnitF)) "t"+        e <- genNamed @(Free (UnitF :: FREEKIND) (UnitF + UnitF)) "e"+        -- @h@ has to land somewhere it can be injective. Every term @(UnitF + UnitF) ~> UnitF@ the+        -- generator can build collapses the two summands, and then @h . t = h . e@ for almost any+        -- branches and the equation holds for the wrong reason.+        h <- genNamed @(Free ((UnitF :: FREEKIND) + UnitF) (UnitF + UnitF)) "h"+        let after+              :: Yo ((UnitF :: FREEKIND) + UnitF) (OP '()) z '()+              -> Yo ((UnitF :: FREEKIND) + UnitF) (OP '()) z '()+            after (Yo f g) = Yo (h . f) g+            fam+              :: forall z+               . Leg Sums FREEKIND (UnitF + UnitF) (Summands (UnitF :: FREEKIND) UnitF) z+              -> Yo ((UnitF :: FREEKIND) + UnitF) (OP '()) z '()+            fam AtLeft = Yo t Unit+            fam AtRight = Yo e Unit+        testEq+          "commuting conversion"+          "h . glue [t, e]"+          (after (glue @Sums boolCover fam))+          "glue [h . t, h . e]"+          (glue @Sums boolCover (\g -> after (fam g)))+    , testProperty "restriction at BySummands" do+        t <- genNamed @(Free UnitF (UnitF + UnitF)) "t"+        e <- genNamed @(Free UnitF (UnitF + UnitF)) "e"+        let ite = glue @Sums @(Yo (UnitF + UnitF) (OP '())) boolCover \case+              AtLeft -> Yo t Unit+              AtRight -> Yo e Unit+        testEq "then" "lmap lft (glue [t, e])" (lmap (legArrow AtLeft) ite) "t" (Yo t Unit)+        testEq "else" "lmap rgt (glue [t, e])" (lmap (legArrow AtRight) ite) "e" (Yo e Unit)+    ]
+ test/Props/Hask.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE OverloadedLists #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Props.Hask where++import Data.Falsify.ConcreteFun qualified as ConcreteFun+import Data.Kind (Type)+import Data.List (intercalate)+import Data.Void (Void)+import Proarrow.Category.Instance.Opposite (OPPOSITE)+import Proarrow.Category.Monoidal.Closed (ExpRep)+import Proarrow.Functor (Prelude (..))+import Proarrow.Profunctor.Instance.Costar (Costar)+import Proarrow.Profunctor.Instance.Star (Star)+import Proarrow.Profunctor.Representable (Rep)+import Test.Falsify.Generator (Function, choose, function, list)+import Test.Falsify.Range (inclusive)+import Test.Tasty (TestTree, testGroup)+import Type.Reflection (Typeable, typeRep)+import Prelude hiding (elem, (.))++import Control.Monad (unless)+import Proarrow.Core (Promonad (..), type (+->))+import Proarrow.Monoid qualified as Monoid+import Proarrow.Testing+  ( GenTotal (..)+  , TestOb'+  , Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , genSomeDef+  , invmap+  , oneElem+  , optGen+  , pattern GenNonEmpty+  )+import Proarrow.Testing.Laws+import Test.Falsify (testFailed)+import Test.Tasty.Falsify (testProperty)++test :: TestTree+test =+  testGroup+    "Hask"+    [ testCategory @Type+    , testTerminalObject @Type+    , testInitialObject @Type+    , testBinaryProducts @Type (\r -> r)+    , testCartesian @Type (\r -> r) (\r -> r)+    , testMonoidal @Type (\r -> r)+    , testSymMonoidal @Type (\r -> r)+    , testCopyDiscard @Type (\r -> r)+    , testBinaryCoproducts @Type (\r -> r)+    , testDistributive @Type (\r -> r) (\r -> r)+    , testClosed @Type (\r -> r) (\r -> r)+    , testFrobenius @() (\r -> r)+    , testProperty "list monoid is not Frobenius: copy-comonoid breaks speciality" $+        unless+          ((Monoid.mappend . Monoid.comult @[()]) [()] /= [()])+          (testFailed "speciality unexpectedly held for [()]")+    , testProfunctor @(Rep (ExpRep :: (OPPOSITE Type, Type) +-> Type))+    , testProfunctor @(Star (Prelude Maybe) :: Type +-> Type)+    , testPromonad @(Star (Prelude Maybe) :: Type +-> Type)+    , testRepresentable @(Star (Prelude Maybe) :: Type +-> Type) (\r -> r)+    , testMonoidalProfunctor @(Star (Prelude Maybe) :: Type +-> Type) (\r -> r) (\r -> r)+    , testCorepresentable @(Costar (Prelude Maybe) :: Type +-> Type) (\r -> r)+    ]++instance Testable Type where+  type TestOb a = (TestableType a, Typeable a, Function a)+  showOb @a = show (typeRep @a)+  genSome = genSomeDef @'[Bool, (Bool, Bool), Maybe Bool, Void]++instance TestableProfunctor (->)++instance TestableType Bool where+  gen = optGen [False, True]+instance TestableType () where+  gen = oneElem ()+instance TestableType Void where+  gen = GenEmpty \case {}+instance TestingEqShow Bool+instance TestingEqShow ()+instance TestingEqShow Void++instance (TestableType a, TestableType b) => TestableType (a, b) where+  gen = case (gen @a, gen @b) of+    (GenEmpty f, _) -> GenEmpty (f . fst)+    (_, GenEmpty g) -> GenEmpty (g . snd)+    (GenNonEmpty ga, GenNonEmpty gb) -> GenNonEmpty (liftA2 (,) ga gb)+instance (TestingEqShow a, TestingEqShow b) => TestingEqShow (a, b) where+  eqP (l1, l2) (r1, r2) = liftA2 (&&) (eqP l1 r1) (eqP l2 r2)+  showP (a, b) = "(" ++ showP a ++ ", " ++ showP b ++ ")"++instance (TestableType a, TestableType b) => TestableType (Either a b) where+  gen = case (gen @a, gen @b) of+    (GenEmpty f, GenEmpty g) -> GenEmpty (either f g)+    (GenNonEmpty ga, GenEmpty _) -> GenNonEmpty (Left <$> ga)+    (GenEmpty _, GenNonEmpty gb) -> GenNonEmpty (Right <$> gb)+    (GenNonEmpty ga, GenNonEmpty gb) -> GenNonEmpty (choose (Left <$> ga) (Right <$> gb))+instance (TestingEqShow a, TestingEqShow b) => TestingEqShow (Either a b) where+  eqP (Left l) (Left r) = eqP l r+  eqP (Right l) (Right r) = eqP l r+  eqP _ _ = pure False+  showP (Left a) = "Left " ++ showP a+  showP (Right b) = "Right " ++ showP b++instance (TestableType a) => TestableType (Maybe a) where+  gen = case gen @a of+    GenEmpty _ -> oneElem Nothing+    GenNonEmpty ga -> GenNonEmpty (choose (pure Nothing) (Just <$> ga))+instance (TestingEqShow a) => TestingEqShow (Maybe a) where+  eqP Nothing Nothing = pure True+  eqP (Just l) (Just r) = eqP l r+  eqP _ _ = pure False+  showP Nothing = "Nothing"+  showP (Just a) = "Just " ++ showP a++instance (TestingEqShow a) => TestingEqShow [a] where+  eqP l r = if length l /= length r then pure False else foldr (liftA2 (&&)) (pure True) (zipWith eqP l r)+  showP xs = "[" ++ intercalate ", " (map showP xs) ++ "]"+instance (TestableType a) => TestableType [a] where+  gen = case gen @a of+    GenEmpty _ -> GenNonEmpty (pure [])+    GenNonEmpty g -> GenNonEmpty (list (inclusive (0, 4)) g)++-- Hard to write and also unused instances.+instance Function (a -> b) where+  function = error "Should not be used"++instance TestableProfunctor (Rep (ExpRep :: (OPPOSITE Type, Type) +-> Type))++instance (TestableType (f a)) => TestableType (Prelude f a) where+  gen = invmap Prelude unPrelude gen+instance (TestingEqShow (f a)) => TestingEqShow (Prelude f a) where+  eqP (Prelude l) (Prelude r) = eqP l r+  showP (Prelude f) = showP f+instance (Function (f a)) => Function (Prelude f a) where+  function = fmap (ConcreteFun.map unPrelude Prelude) . function++instance (Functor f, Typeable f, forall b. (TestOb b) => TestOb' (f b)) => TestableProfunctor (Star (Prelude f))++instance (Functor f, Typeable f, forall b. (TestOb b) => TestOb' (f b)) => TestableProfunctor (Costar (Prelude f))
+ test/Props/Kleisli.hs view
@@ -0,0 +1,128 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Props.Kleisli where++import Data.Kind (Type)+import Data.Typeable (type (:~:) (..))+import Data.Void (Void)+import GHC.Generics (Generic)+import Test.Falsify.Generator (Function (..))+import Test.Tasty (TestTree, testGroup)+import Prelude hiding (id, (.))++import Proarrow.Category.Enriched.Thin (Holds, Objects)+import Proarrow.Category.Enriched.Thin.Composition (Closure)+import Proarrow.Category.Instance.Bool (BOOL (..), Booleans)+import Proarrow.Category.Instance.Kleisli (KLEISLI (..), Kleisli (..))+import Proarrow.Core (CAT, CategoryOf (..), Promonad (..), UN, type (+->))+import Proarrow.Functor (Prelude (..))+import Proarrow.Profunctor.Instance.Costar (Costar, pattern Costar)+import Proarrow.Profunctor.Instance.Star (Star)+import Proarrow.Promonad.Cont (Cont (..))++import Proarrow.Testing+  ( SomeProfunctorElt (..)+  , Testable (..)+  , TestableProfunctor (..)+  , TestableType (..)+  , TestableTypeP+  , TestingEqShow (..)+  , genSomeDef+  , invmap+  )+import Proarrow.Testing.Laws+import Props.Hask ()++test :: TestTree+test =+  testGroup+    "Kleisli"+    [ testGroup+        "Maybe monad"+        [ testCategory @(KLEISLI (Star (Prelude Maybe)))+        , testInitialObject @(KLEISLI (Star (Prelude Maybe)))+        , testMonoidal @(KLEISLI (Star (Prelude Maybe))) (\r -> r)+        , testSymMonoidal @(KLEISLI (Star (Prelude Maybe))) (\r -> r)+        , testCopyDiscard @(KLEISLI (Star (Prelude Maybe))) (\r -> r)+        , testBinaryCoproducts @(KLEISLI (Star (Prelude Maybe))) (\r -> r)+        ]+    , testGroup+        "Continuation promonad"+        [ testCategory @(KLEISLI (Cont Void))+        , -- No terminal object, products or 'testCartesian' here: those lift to the co-Kleisli+          -- category of a 'Comonad', and @'Cont' r@ is a monad, not a comonad. They did hold at+          -- @'Cont' 'Void'@, but only because every hom-set in this group is a singleton (see the+          -- note below), not for any reason that generalises.+          testInitialObject @(KLEISLI (Cont Void))+        , testBinaryCoproducts @(KLEISLI (Cont Void)) (\r -> r)+        , testClosed @(KLEISLI (Cont Void)) (\r -> r) (\r -> r)+        , -- This group is close to vacuous: @Cont Void a b@ is @(b -> Void) -> (a -> Void)@,+          -- and every object in the palette is inhabited, so every hom-set here is a singleton and+          -- every law holds trivially. A non-empty answer type would make it meaningful, but the+          -- generator for @(b -> r) -> (a -> r)@ does not currently support one.+          testMonoidal @(KLEISLI (Cont Void)) (\r -> r)+        ]+    , testGroup+        "Pair comonad"+        [ testCategory @(KLEISLI (Costar (Prelude Pair)))+        , testTerminalObject @(KLEISLI (Costar (Prelude Pair)))+        , -- No initial object: that lifts for a 'Monad', and @'Costar' f@ is a comonad. It did+          -- hold here because @'Pair' 'Void'@ is itself empty, which is a fact about 'Pair' rather+          -- than about comonads.+          testBinaryProducts @(KLEISLI (Costar (Prelude Pair))) (\r -> r)+        , testCartesian @(KLEISLI (Costar (Prelude Pair))) (\r -> r) (\r -> r)+        , testMonoidal @(KLEISLI (Costar (Prelude Pair))) (\r -> r)+        ]+    ]++instance (TestableTypeP p, Promonad p, TestOb a, TestOb b) => TestableType (Kleisli (a :: KLEISLI (p :: Type +-> Type)) b) where+  gen = invmap Kleisli unKleisli (gen @(p (UN KL a) (UN KL b)))+instance (TestingEqShow (p a b), Promonad p) => TestingEqShow (Kleisli (KL a :: KLEISLI (p :: Type +-> Type)) (KL b)) where+  eqP (Kleisli l) (Kleisli r) = eqP l r+  showP (Kleisli f) = "Kleisli (" ++ showP f ++ ")"+instance+  (TestableProfunctor p, TestableTypeP p, Promonad p)+  => TestableProfunctor (Kleisli :: CAT (KLEISLI (p :: Type +-> Type)))+  where+  genProfunctorElt nm = do+    SomeP p <- genProfunctorElt @p nm+    pure $ SomeP (Kleisli p)++instance (TestableProfunctor p, TestableTypeP p, Promonad p) => Testable (KLEISLI (p :: Type +-> Type)) where+  type TestOb a = (Ob a, TestOb (UN KL a))+  showOb @(KL a) = "KL " ++ showOb @_ @a+  genSome = genSomeDef @'[KL Bool, KL (), KL (Maybe Bool)]++newtype Pair a = Pair {unPair :: (a, a)}+  deriving (Eq, Show, Functor, Generic)+  deriving anyclass (Function)+instance (TestableType a) => TestableType (Pair a) where+  gen = invmap Pair unPair gen+instance (TestingEqShow a) => TestingEqShow (Pair a) where+  eqP (Pair (l1, l2)) (Pair (r1, r2)) = liftA2 (&&) (eqP l1 r1) (eqP l2 r2)+  showP (Pair (x, y)) = "Pair " ++ showP x ++ " " ++ showP y++instance Promonad (Costar (Prelude Pair)) where+  id = Costar \(Prelude (Pair (x, _))) -> x+  Costar f . Costar g = Costar (\(Prelude (Pair (a, b))) -> f (Prelude (Pair (g (Prelude (Pair (a, b))), g (Prelude (Pair (b, b)))))))++instance (TestOb a, TestOb b) => TestableType (Cont Void a b) where+  gen = invmap Cont runCont gen+instance (TestOb a, TestOb b) => TestingEqShow (Cont Void a b) where+  eqP (Cont l) (Cont r) = eqP l r+  showP (Cont f) = "Cont (" ++ showP f ++ ")"+instance TestableProfunctor (Cont Void)++-- * The Kleisli category of a decidable promonad is enumerable++-- | Its objects are those of the base, numbered the same way.+objectsKleisli :: Objects (KLEISLI Booleans) :~: '[KL FLS, KL TRU]+objectsKleisli = Refl++-- | So it can be searched: the closure of the walking arrow's own hom still only goes upwards.+-- This only typechecks because the Kleisli category is enumerable.+kleisliReaches :: Holds (Closure (Kleisli :: CAT (KLEISLI Booleans))) (KL FLS) (KL TRU) :~: TRU+kleisliReaches = Refl++kleisliNoWayBack :: Holds (Closure (Kleisli :: CAT (KLEISLI Booleans))) (KL TRU) (KL FLS) :~: FLS+kleisliNoWayBack = Refl
+ test/Props/Mat.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedLists #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Props.Mat where++import Data.Kind (Type)+import Data.Type.Nat (Nat (..), Nat0, Nat1, Nat3, SNat (..), SNatI, snat, snatToNat)+import Data.Vec.Lazy (Vec (..), repeat)+import Test.Falsify.Generator (elem)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (elem, repeat)++import Proarrow.Category.Instance.Mat (App, Mat (..), MatK (..))+import Proarrow.Category.Monoidal.CompactClosed (dimension)+import Proarrow.Core (CAT, type (+->))+import Proarrow.Profunctor.Representable (Rep)++import Proarrow.Testing+  ( GenTotal (..)+  , Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , expect+  , genSomeDef+  , invmap+  , oneElem+  , pattern GenNonEmpty+  )+import Proarrow.Testing.Laws+import Props.Hask ()++-- | The one entry of a @1x1@ matrix, which is what an endo-arrow on 'Unit' is.+scalar :: Mat (M Nat1 :: MatK Int) (M Nat1) -> Int+scalar (Mat ((x ::: VNil) ::: VNil)) = x++test :: TestTree+test =+  testGroup+    "Matrix"+    [ testCategory @(MatK Int)+    , testDagger @(MatK Int)+    , testTerminalObject @(MatK Int)+    , testInitialObject @(MatK Int)+    , testBinaryProducts_ @(MatK Int)+    , testBinaryCoproducts_ @(MatK Int)+    , testHypergraph_ @(MatK Int)+    , testMonoidal_ @(MatK Int)+    , testSymMonoidal_ @(MatK Int)+    , testDistributive_ @(MatK Int)+    , testClosed_ @(MatK Int)+    , testStarAutonomous_ @(MatK Int)+    , testCompactClosed_ @(MatK Int)+    , testTraced_ @(MatK Int)+    , testCopyDiscard_ @(MatK Int)+    , testGroup "App functor" [testProfunctor @(Rep App :: MatK Int +-> Type)]+    , -- the trace of an identity, and the one place the traced object could silently be dropped+      testProperty "dimension counts the object" $+        expect "dimensions 0, 1, 3" [0, 1, 3] (map scalar [dimension @(M Nat0), dimension @(M Nat1), dimension @(M Nat3)])+    , testEqualizers_ @(MatK Rational)+    , testCoequalizers_ @(MatK Rational)+    , testEpiMonoFactorization_ @(MatK Rational)+    , testPullbacks_ @(MatK Rational)+    , testPushouts_ @(MatK Rational)+    ]++type TestableNum n = (Num n, Eq n, Show n, TestableType n)++instance (TestableNum n) => Testable (MatK n) where+  showOb @(M a) = show $ snatToNat $ snat @a+  genSome = genSomeDef @'[M Z, M (S Z), M (S (S Z)), M (S (S (S Z)))]++instance (TestOb (a :: MatK n), TestOb b, TestableNum n) => TestableType (Mat a b) where+  gen = invmap Mat unMat gen+instance (TestOb (a :: MatK n), TestOb b, TestableNum n) => TestingEqShow (Mat a b) where+  eqP (Mat l) (Mat r) = pure $ l == r+  showP (Mat m) = show m+instance (TestableNum n) => TestableProfunctor (Mat :: CAT (MatK n))++instance (Eq a, Show a) => TestingEqShow (Vec n a)+instance (Eq a, Show a, TestableType a, SNatI n) => TestableType (Vec n a) where+  gen = case gen of+    GenEmpty absurd -> case snat @n of+      SZ -> oneElem VNil+      SS -> GenEmpty \(a ::: _) -> absurd a+    GenNonEmpty g -> GenNonEmpty $ sequence (repeat @n g)++instance TestingEqShow Int+instance TestableType Int where+  gen = GenNonEmpty $ liftA2 (*) (elem [1, -1]) (elem [0 .. 9])++instance TestingEqShow Rational+instance TestableType Rational where+  gen = GenNonEmpty $ liftA2 (*) (elem [1, -1]) (fromInteger <$> elem [0 .. 9])++instance TestableProfunctor (Rep App :: MatK Int +-> Type)
+ test/Props/Optic/FinRel.hs view
@@ -0,0 +1,42 @@+-- | Running optics in the __non-cartesian__ @FINREL@ category (the category of relations between+-- finite sets), which is 'Proarrow.Category.Monoidal.CopyDiscard.CopyDiscard' but /not/+-- 'Proarrow.Limit.Terminal.Semicartesian' (its monoidal unit @FR 1@ is not the terminal object+-- @FR 0@). Folding a prism must discard the non-matching residual, and that discard is+-- 'Proarrow.Category.Monoidal.CopyDiscard.discard', which needs only @CopyDiscard@ and not+-- @Semicartesian@, so prism/fold optics instantiate here.+module Props.Optic.FinRel (test) where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)++import Data.Type.Nat (Nat1, Nat2)+import Prelude (($))++import Proarrow.Category.Instance.FinRel (FINREL (..), FinRel, unFinRel)+import Proarrow.Category.Monoidal.CopyDiscard (discard)+import Proarrow.Colimit.BinaryCoproduct ((|||))+import Proarrow.Core (Promonad (..), (.))+import Proarrow.Monoid (Monoid (..))+import Proarrow.Optic.Fold (foldMapOf)+import Proarrow.Optic.Prism (Prism, prism)++import Props.FinRel ()+import Props.Optic.Hask (assertEq)++-- | A prism onto one summand of @FR 1 || FR 1 = FR 2@. Building it needs only 'discard' (to review+-- the residual away), not products.+prL :: Prism (FR Nat2) (FR Nat1) (FR Nat1) (FR Nat1)+prL = prism id id++test :: TestTree+test =+  testGroup+    "Proarrow.OpticFinRel"+    [ -- The optic-plumbed fold (Optic -> Forget -> Prostrong -> foldMapP) must agree with the+      -- hand-built relation @(mempty . discard ||| id)@: the focus branch reduces via @id@, the+      -- non-matching branch is discarded to @Unit@ and sent to @mempty@.+      testProperty "foldMapOf a prism in FINREL (non-cartesian CopyDiscard; discards the non-match)" $+        assertEq+          (unFinRel (foldMapOf prL (id @FinRel @(FR Nat1))))+          (unFinRel (mempty @(FR Nat1) . discard @FINREL @(FR Nat1) ||| id @FinRel @(FR Nat1)))+    ]
+ test/Props/Optic/Hask.hs view
@@ -0,0 +1,540 @@+-- | Checks that optic subtyping works: any optic can be used directly where a weaker flavor is+-- needed (iso -> lens/prism -> affine traversal -> traversal -> setter, and the fold side),+-- because the consumers only ask for @c ('ExOptic' need a b)@, which a 'Prostrong'-flavored optic+-- discharges through the quantified constraint @forall p q. w p q => 'O.Sub' need p q@. The flavor+-- superclasses play the role of the @Is k l@ class of the @optics@ library.+--+-- The conversion functions below are compile-time tests: each one only typechecks if the+-- corresponding superclass entailment holds. The 'TestTree' then checks at runtime that a lens,+-- prism or iso handed directly to the getter\/setter\/fold\/review\/preview consumers still acts+-- like the optic it came from.+module Props.Optic.Hask where++import Control.Monad (unless)+import Data.Bifunctor (bimap, first, second)+import Data.Maybe (maybeToList)+import Data.Tuple (swap)+import Data.Type.Nat (Nat2, Nat3)+import Test.Falsify (Property, genWith, testFailed)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude++import GHC.Generics qualified as G+import Proarrow.Category.Monoidal (Monoidal)+import Proarrow.Category.Monoidal.Action (ProdAction)+import Proarrow.Category.Monoidal.Cartesian (Bicartesian)+import Proarrow.Category.Monoidal.Distributive (StrongDistributiveProfunctor, baseTraverse)+import Proarrow.Category.Monoidal.Strength (Strong)+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts, type (||))+import Proarrow.Core (CategoryOf (..), type (+->))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts, type (&&))+import Proarrow.Monoid (ComonoidOn (..))+import Proarrow.Optic qualified as O+import Proarrow.Optic.AffineFold (AffineFold, preview, (^?))+import Proarrow.Optic.AffineTraversal (AffineTraversal, matching)+import Proarrow.Optic.Fold (Fold, foldMapOf, unfold)+import Proarrow.Optic.Getter (Getter, Review, review, view, (#), (^.))+import Proarrow.Optic.Glass (Glass, glass, withGlass)+import Proarrow.Optic.Grate (Grate, grate, withGrate)+import Proarrow.Optic.Iso (Iso, fromPIso, toPIso, withIso)+import Proarrow.Optic.Lens (Lens, lens, withLens)+import Proarrow.Optic.MonoidalLens (MonoidalLens, monLens, withMonLens)+import Proarrow.Optic.PowerGrate (PowerGrate, powerGrate, powerGrateOf, zipWithOf)+import Proarrow.Optic.Prism (Prism, fromOpLens, prism, toOpLens, withPrism)+import Proarrow.Optic.Setter (Setter, SetterFl (..), over, set, (%~))+import Proarrow.Optic.Tracer (Tracer, fromPTracer, toPTracer, tracer, tracerOf, withTracer)++import Proarrow.Optic.MonoidalTraversal+  ( MonoidalTraversal+  , PTraversal+  , fromPTraversal+  , monTraverseOf+  , multOptic+  , par1Optic+  , plusOptic+  , toPTraversal+  , u1Optic+  )+import Proarrow.Optic.Traversal (TravFl, Traversal, traverseOf)++import Proarrow.Category.Instance.Opposite (OPPOSITE (..))+import Proarrow.Functor (Prelude (..))+import Proarrow.Profunctor.Corepresentable (Corepresentable)+import Proarrow.Profunctor.Instance.Star (Star, unStar, pattern Star)+import Proarrow.Profunctor.Representable (CorepStar (..), RepCostar (..), Representable)+import Proarrow.Promonad.Reader (Reader (..))+import Proarrow.Promonad.Writer (Writer)++import Proarrow.Testing (GenTotal (..), TestableType (..), pattern GenNonEmpty)+import Props.Hask ()++-- * The subtyping lattice++isoToLens :: (CategoryOf k) => Iso (s :: k) t a b -> Lens s t a b+isoToLens = O.convert++-- | Compile-time proof of the theorem "every representable residual is a Setter": 'overP' for+-- the @(t, RepCostar t)@ witness resolves from just 'Representable' t, with no 'Traversable'. If the+-- old @Traversable t@ constraint were re-added to that instance, this would stop compiling.+representableResidualIsSetter+  :: forall {k} (t :: k +-> k) s a b t'+   . (Representable t, Bicartesian k) => t s a -> RepCostar t b t' -> (a ~> b) -> (s ~> t')+representableResidualIsSetter = overP++-- | Dually: every corepresentable residual is a Setter, from just 'Corepresentable' t.+corepresentableResidualIsSetter+  :: forall {k} (t :: k +-> k) s a b t'+   . (Corepresentable t, Bicartesian k) => CorepStar t s a -> t b t' -> (a ~> b) -> (s ~> t')+corepresentableResidualIsSetter = overP++isoToPrism :: (CategoryOf k) => Iso (s :: k) t a b -> Prism s t a b+isoToPrism = O.convert++isoToGetter :: (CategoryOf k) => Iso (s :: k) t a b -> Getter s t a b+isoToGetter = O.convert++isoToReview :: (CategoryOf k) => Iso (s :: k) t a b -> Review s t a b+isoToReview = O.convert++isoToGrate :: (CategoryOf k) => Iso (s :: k) t a b -> Grate s t a b+isoToGrate = O.convert++isoToKaleidoscope :: (Monoidal k) => Iso (s :: k) t a b -> PowerGrate s t a b+isoToKaleidoscope = O.convert++-- | The classic zipping grate on pairs.+pairGrate :: Grate (Bool, Bool) (Bool, Bool) Bool Bool+pairGrate = grate (\k -> (k fst, k snd))++-- | A glass on pairs: it both reads the source (keeps the second component) and, like a grate,+-- feeds the consumer a selector on the whole source. @glass f@ where @f (s, k)@ has @s@ and a+-- consumer @k :: ((s -> a) -> b)@.+pairGlass :: Glass (Bool, Bool) (Bool, Bool) Bool Bool+pairGlass = glass (\((_, y), c) -> (c fst, y))++lensToAffineTraversal :: (CategoryOf k) => Lens (s :: k) t a b -> AffineTraversal s t a b+lensToAffineTraversal = O.convert++lensToGetter :: (CategoryOf k) => Lens (s :: k) t a b -> Getter s t a b+lensToGetter = O.convert++lensToTraversal :: (CategoryOf k) => Lens (s :: k) t a b -> Traversal s t a b+lensToTraversal = O.convert++lensToSetter :: (CategoryOf k) => Lens (s :: k) t a b -> Setter s t a b+lensToSetter = O.convert++lensToAffineFold :: (CategoryOf k) => Lens (s :: k) t a b -> AffineFold s t a b+lensToAffineFold = O.convert++lensToFold :: (CategoryOf k) => Lens (s :: k) t a b -> Fold s t a b+lensToFold = O.convert++prismToAffineTraversal :: (CategoryOf k) => Prism (s :: k) t a b -> AffineTraversal s t a b+prismToAffineTraversal = O.convert++prismToReview :: (CategoryOf k) => Prism (s :: k) t a b -> Review s t a b+prismToReview = O.convert++prismToTraversal :: (CategoryOf k) => Prism (s :: k) t a b -> Traversal s t a b+prismToTraversal = O.convert++prismToSetter :: (CategoryOf k) => Prism (s :: k) t a b -> Setter s t a b+prismToSetter = O.convert++prismToAffineFold :: (CategoryOf k) => Prism (s :: k) t a b -> AffineFold s t a b+prismToAffineFold = O.convert++prismToFold :: (CategoryOf k) => Prism (s :: k) t a b -> Fold s t a b+prismToFold = O.convert++affineTraversalToTraversal :: (CategoryOf k) => AffineTraversal (s :: k) t a b -> Traversal s t a b+affineTraversalToTraversal = O.convert++affineTraversalToSetter :: (CategoryOf k) => AffineTraversal (s :: k) t a b -> Setter s t a b+affineTraversalToSetter = O.convert++affineTraversalToAffineFold :: (CategoryOf k) => AffineTraversal (s :: k) t a b -> AffineFold s t a b+affineTraversalToAffineFold = O.convert++affineTraversalToFold :: (CategoryOf k) => AffineTraversal (s :: k) t a b -> Fold s t a b+affineTraversalToFold = O.convert++getterToAffineFold :: (CategoryOf j, CategoryOf k) => Getter (s :: k) (t :: j) a b -> AffineFold s t a b+getterToAffineFold = O.convert++getterToFold :: (CategoryOf j, CategoryOf k) => Getter (s :: k) (t :: j) a b -> Fold s t a b+getterToFold = O.convert++traversalToSetter :: (CategoryOf k) => Traversal (s :: k) t a b -> Setter s t a b+traversalToSetter = O.convert++traversalToFold :: (CategoryOf k) => Traversal (s :: k) t a b -> Fold s t a b+traversalToFold = O.convert++-- | Compile-time proof that 'traverseOf' distributes an /arbitrary/ 'StrongDistributiveProfunctor'+-- (Traversable-style), not only a @'Star' f@. This only typechecks because the carrier @p@ is+-- fully polymorphic.+traverseOfIsGeneric+  :: (StrongDistributiveProfunctor p, Strong ProdAction p) => p Bool Bool -> p (Bool, Bool) (Bool, Bool)+traverseOfIsGeneric = traverseOf _1++affineFoldToFold :: (CategoryOf j, CategoryOf k) => AffineFold (s :: k) (t :: j) a b -> Fold s t a b+affineFoldToFold = O.convert++-- | Composites convert to the meet of their flavors, in one step.+compositeToAffineTraversal+  :: (CategoryOf k) => Lens (s :: k) t a b -> Prism a b c d -> AffineTraversal s t c d+compositeToAffineTraversal l p = O.convert (l O.% p)++grateToSetter :: (CategoryOf k) => Grate (s :: k) t a b -> Setter s t a b+grateToSetter = O.convert++tracerToSetter :: (CategoryOf k) => Tracer (s :: k) t a b -> Setter s t a b+tracerToSetter = O.convert++isoToTracer :: (CategoryOf k) => Iso (s :: k) t a b -> Tracer s t a b+isoToTracer = O.convert++-- | A tracer converts to a flipped setter (its witnesses are a setter's, read backwards); the+-- converse has no instance, since a flipped setter need not have a trace.+tracerToFlipSetter :: (CategoryOf k) => Tracer (s :: k) t a b -> O.Optic (O.Prostrong (O.Flip SetterFl)) s t a b+tracerToFlipSetter = O.convert++-- * The reversed (Flip) side of the lattice, reached via 're'++reLensIsReview :: (CategoryOf k, Ob (a :: k), Ob b) => Lens s t a b -> Review b a t s+reLensIsReview = O.convert . O.re++rePrismIsGetter :: (CategoryOf k, Ob (a :: k), Ob b) => Prism s t a b -> Getter b a t s+rePrismIsGetter = O.convert . O.re++reIsoIsGetter :: (CategoryOf k, Ob (a :: k), Ob b) => Iso s t a b -> Getter b a t s+reIsoIsGetter = O.convert . O.re++reReLens :: (CategoryOf k, Ob (s :: k), Ob t, Ob a, Ob b) => Lens s t a b -> Lens s t a b+reReLens = O.convert . O.re . O.re++-- * Minimal constraints++-- | Compile-time check: building and eliminating a lens needs only binary products, never+-- 'Proarrow.Category.Monoidal.Distributive.Bicartesian', even though 'AffineTravFl' sits above+-- 'Proarrow.Optic.Lens.LensFl' in the flavor hierarchy.+lensLegs :: (HasBinaryProducts k) => Lens (s :: k) t a b -> (s ~> a, (s && b) ~> t)+lensLegs l = withLens l (,)++-- | Compile-time check: building and eliminating a prism needs only binary coproducts.+prismLegs :: (HasBinaryCoproducts k) => Prism (s :: k) t a b -> (b ~> t, s ~> (t || a))+prismLegs p = withPrism p (,)++-- * Runtime checks in Hask, using the optics directly where a weaker flavor is needed++_1 :: Lens (a, c) (b, c) a b+_1 = lens fst (\((_, c), b) -> (b, c))++_Just :: Prism (Maybe a) (Maybe b) a b+_Just = prism Just (maybe (Left Nothing) Right)++-- | A monoidal lens onto the second component (@Type@'s tensor is @(,)@, so it coincides with a+-- product lens here).+_2mon :: MonoidalLens (Bool, Bool) (Bool, Bool) Bool Bool+_2mon = monLens @Bool id id++notIso :: Iso Bool Bool Bool Bool+notIso = O.iso not not++-- | The binary (pair) power grate, focusing both components of a tensor.+pairK :: PowerGrate (Bool, Bool) (Bool, Bool) Bool Bool+pairK = powerGrate @Nat2 (\(a, b) -> (a, (b, ()))) (\(a, (b, ())) -> (a, b))++-- | The arity-3 power grate, over a nested tensor triple.+triK :: PowerGrate (Bool, (Bool, (Bool, ()))) (Bool, (Bool, (Bool, ()))) Bool Bool+triK = powerGrate @Nat3 id id++-- | A tracer in Hask with a @Bool@ residual and identity legs, so @over feedback f s@ solves+-- @(m, t) = f (m, s)@ for @m@ through the lazy fixpoint of @'Proarrow.Category.Monoidal.Strength.Costrong' (->)@.+feedback :: Tracer Bool Bool (Bool, Bool) (Bool, Bool)+feedback = tracer @Bool id id++-- | Focus function for 'feedback': the new residual is @not s@ and the new target is the residual,+-- so the loop computes @not@.+loop :: (Bool, Bool) -> (Bool, Bool)+loop (m, s) = (not s, m)++-- | The same encoding-agnostic 'O.iso' at the profunctor-class-flavored traversal type.+tIsoNot :: PTraversal Bool Bool Bool Bool+tIsoNot = O.iso not not++-- | The same iso in the profunctor-class-flavored encoding, to check that the consumers are+-- encoding-agnostic.+cNot :: O.PIso Bool Bool Bool Bool+cNot = O.iso not not++cMaybeNot :: O.PIso (Maybe Bool) (Maybe Bool) (Maybe Bool) (Maybe Bool)+cMaybeNot = O.iso (fmap not) (fmap not)++swapIso :: Iso (Bool, Bool) (Bool, Bool) (Bool, Bool) (Bool, Bool)+swapIso = O.iso swap swap++notMaybeIso :: Iso (Maybe Bool) (Maybe Bool) (Maybe Bool) (Maybe Bool)+notMaybeIso = O.iso (fmap not) (fmap not)++-- | Run 'traverseOf' on a profunctor-class-flavored 'PTraversal'.+travPar1 :: Bool -> Maybe Bool+travPar1 b = G.unPar1 <$> unPrelude (unStar (traverseOf (fromPTraversal par1Optic) (Star (Prelude . Just . not))) (G.Par1 b))++-- | Check two Hask arrows for semantic equality on generated inputs.+propFnEq :: forall a b. (TestableType a, Show a, Show b, Eq b) => String -> (a -> b) -> (a -> b) -> TestTree+propFnEq nm f g = testProperty nm case gen @a of+  GenEmpty _ -> pure ()+  GenNonEmpty ga -> do+    a <- genWith (Just . show) ga+    assertEq (f a) (g a)++assertEq :: (Show b, Eq b) => b -> b -> Property ()+assertEq l r = unless (l == r) (testFailed (show l ++ " /= " ++ show r))++test :: TestTree+test =+  testGroup+    "Optic subtyping"+    [ propFnEq @(Bool, Bool) "lens as getter" (view _1) fst+    , propFnEq @(Bool, Bool) "lens as getter (^.)" (^. _1) fst+    , propFnEq @(Bool, Bool) "lens as setter" (over _1 not) (first not)+    , propFnEq @(Bool, Bool) "set lens" (set _1 False) (\(_, c) -> (False, c))+    , propFnEq @(Bool, Bool) "lens as affine fold" (preview _1) (Left . fst)+    , propFnEq @(Bool, Bool) "lens as fold" (foldMapOf _1 (: [])) (\(a, _) -> [a])+    , propFnEq @(Bool, Bool) "monoidal lens as setter" (over _2mon not) (second not)+    , propFnEq @(Bool, Bool) "monoidal lens as getter" (view _2mon) snd+    , propFnEq @(Bool, Bool)+        "traverseOf lens"+        (unPrelude . unStar (traverseOf _1 (Star (Prelude . Just . not))))+        (Just . first not)+    , propFnEq @Bool "prism as review" (review _Just) Just+    , propFnEq @Bool "prism as review (#)" (_Just #) Just+    , propFnEq @(Maybe Bool) "prism as setter" (_Just %~ not) (fmap not)+    , propFnEq @(Maybe Bool) "prism as affine fold" (preview _Just) (maybe (Right ()) Left)+    , propFnEq @(Maybe Bool) "prism as fold" (foldMapOf _Just (: [])) maybeToList+    , propFnEq @(Maybe Bool) "prism as preview" (^? _Just) id+    , propFnEq @Bool "prism ~ op-lens: fromOpLens . toOpLens preserves review" (review (fromOpLens (toOpLens _Just))) Just+    , propFnEq @Bool "prism unfold: build a Maybe through the review leg" (unfold (toOpLens _Just) not) (\x -> Just (not x))+    , propFnEq @(Maybe Bool)+        "prism ~ op-lens: fromOpLens . toOpLens preserves setter"+        (fromOpLens (toOpLens _Just) %~ not)+        (fmap not)+    , propFnEq @Bool "iso as getter" (view notIso) not+    , propFnEq @Bool "iso as review" (review notIso) not+    , propFnEq @Bool "iso as setter" (over notIso not) not+    , propFnEq @Bool "iso as kaleidoscope" (powerGrateOf notIso not) not+    , propFnEq @Bool "iso as monoidal lens (view)" (view (O.convert notIso :: MonoidalLens Bool Bool Bool Bool)) not+    , propFnEq @Bool "iso as monoidal lens (over)" (over (O.convert notIso :: MonoidalLens Bool Bool Bool Bool) not) not+    , propFnEq @(Bool, Bool)+        "withMonLens recovers the legs and the comonoid of the residual"+        ( \s -> withMonLens _2mon \co h i ->+            let (m, a) = h s in (counitOn co m, i (fst (comultOn co m), not a), i (snd (comultOn co m), a))+        )+        (\(x, y) -> ((), (x, not y), (x, y)))+    , propFnEq @(Bool, Bool)+        "withMonLens of a composite tensors the residual comonoids"+        ( \s -> withMonLens (_2mon O.% (O.convert notIso :: MonoidalLens Bool Bool Bool Bool)) \co h i ->+            let (m, a) = h s in (counitOn co m, a, i (fst (comultOn co m), a), i (snd (comultOn co m), not a))+        )+        (\(x, y) -> ((), not y, (x, y), (x, not y)))+    , propFnEq @(Bool, Bool)+        "a monoidal lens is an affine traversal (matching)"+        (matching (O.convert _2mon :: AffineTraversal (Bool, Bool) (Bool, Bool) Bool Bool))+        (\(_, y) -> Right y)+    , propFnEq @(Bool, Bool)+        "a monoidal lens is an affine traversal (over)"+        (over (O.convert _2mon :: AffineTraversal (Bool, Bool) (Bool, Bool) Bool Bool) not)+        (second not)+    , propFnEq @((Bool, Bool), Bool)+        "a monoidal lens is a glass (legs recovered)"+        (\(s, fl) -> withGlass (O.convert _2mon :: Glass (Bool, Bool) (Bool, Bool) Bool Bool) \g -> g (s, \sel -> sel s == fl))+        (\((x, y), fl) -> (x, y == fl))+    , propFnEq @(Bool, Bool) "lens as traversal as setter" (over (lensToTraversal _1) not) (first not)+    , propFnEq @(Maybe Bool) "prism as traversal as fold" (foldMapOf (prismToTraversal _Just) (: [])) maybeToList+    , propFnEq @(Bool, Bool) "kaleidoscope as setter (hom carrier)" (powerGrateOf pairK not) (bimap not not)+    , propFnEq @(Bool, Bool)+        "kaleidoscope aggregates through an applicative"+        (\ss -> unPrelude (unStar (powerGrateOf pairK (Star (Prelude . okIf))) ss))+        aggBoth+    , propFnEq @(Bool, Bool)+        "kaleidoscope as fold (it is a fixed-arity traversal)"+        (foldMapOf pairK (: []))+        (\(a, b) -> [a, b])+    , propFnEq @(Bool, Bool)+        "kaleidoscope as traversal"+        (unPrelude . unStar (traverseOf pairK (Star (Prelude . Just . not))))+        (\(a, b) -> Just (not a, not b))+    , propFnEq @(Bool, Bool) "corep-cotraversable witness as traversal (over)" (over zipSnd not) (second not)+    , propFnEq @(Bool, Bool)+        "corep-cotraversable witness as traversal (traverseOf)"+        (unPrelude . unStar (traverseOf zipSnd (Star (Prelude . Just . not))))+        (Just . second not)+    , propFnEq @(Bool, (Bool, (Bool, ()))) "n-ary (3) kaleidoscope as setter" (powerGrateOf triK not) mapTriple+    , propFnEq @(Bool, (Bool, (Bool, ())))+        "n-ary (3) kaleidoscope aggregates through an applicative"+        (\ss -> unPrelude (unStar (powerGrateOf triK (Star (Prelude . okIf))) ss))+        aggTriple+    , propFnEq @(Bool, Bool) "re lens as review" (review (O.re _1)) fst+    , propFnEq @Bool "re prism as getter" (view (O.re _Just)) Just+    , propFnEq @Bool "re iso as getter" (view (O.re notIso)) not+    , propFnEq @(Bool, Bool) "re re lens as getter" (view (reReLens _1)) fst+    , propFnEq @Bool "view on constraint-flavored iso" (view cNot) not+    , propFnEq @Bool "review on constraint-flavored iso" (review cNot) not+    , propFnEq @Bool "over on constraint-flavored iso" (over cNot not) not+    , propFnEq @Bool "traverseOf on PTraversal" travPar1 (Just . not)+    , propFnEq @Bool+        "iso constructed as PTraversal"+        (unPrelude . unStar (traverseOf (fromPTraversal tIsoNot) (Star (Prelude . Just . not))))+        (Just . not)+    , propFnEq @Bool "over on a PTraversal" (over tIsoNot not) not+    , propFnEq @(Bool, Bool) "grate as setter" (over pairGrate not) (bimap not not)+    , propFnEq @(Bool, Bool) "glass as setter maps the focus" (over pairGlass not) (first not)+    , propFnEq @(Bool, Bool)+        "a lens is a glass (as setter)"+        (over (O.convert _1 :: Glass (Bool, Bool) (Bool, Bool) Bool Bool) not)+        (first not)+    , propFnEq @(Bool, Bool)+        "a grate is a glass (as setter)"+        (over (O.convert pairGrate :: Glass (Bool, Bool) (Bool, Bool) Bool Bool) not)+        (bimap not not)+    , propFnEq @((Bool, Bool), Bool)+        "a grate is a glass (legs recovered)"+        ( \(s, fl) -> withGlass (O.convert pairGrate :: Glass (Bool, Bool) (Bool, Bool) Bool Bool) \g -> g (s, \sel -> sel s == fl)+        )+        (\((x, y), fl) -> (x == fl, y == fl))+    , propFnEq @((Bool, Bool), Bool)+        "a power grate is a glass (legs recovered)"+        (\(s, fl) -> withGlass (O.convert pairK :: Glass (Bool, Bool) (Bool, Bool) Bool Bool) \g -> g (s, \sel -> sel s == fl))+        (\((x, y), fl) -> (x == fl, y == fl))+    , propFnEq @((Bool, (Bool, (Bool, ()))), Bool)+        "an arity-3 power grate is a glass (legs recovered)"+        ( \(s, fl) -> withGlass (O.convert triK :: Glass (Bool, (Bool, (Bool, ()))) (Bool, (Bool, (Bool, ()))) Bool Bool) \g -> g (s, \sel -> sel s == fl)+        )+        (\((x, (y, (z, ()))), fl) -> (x == fl, (y == fl, (z == fl, ()))))+    , propFnEq @(Bool, Bool) "set on a grate" (set pairGrate True) (const (True, True))+    , propFnEq @Bool "iso as grate as setter" (over (isoToGrate notIso) not) not+    , propFnEq @Bool "tracer feeds the residual back through the focus" (over feedback loop) not+    , propFnEq @Bool "set on a tracer" (set feedback (True, False)) (const False)+    , propFnEq @(Bool, Bool) "re-over a tracer runs it backwards, no trace needed" (over (O.re feedback) not) (second not)+    , propFnEq @(Bool, Bool)+        "re-over a tracer converted to a flipped setter"+        (over (O.re (tracerToFlipSetter feedback)) not)+        (second not)+    , propFnEq @Bool "iso as tracer" (tracerOf notIso not) not+    , propFnEq @Bool "iso as tracer as setter" (over (isoToTracer notIso) not) not+    , propFnEq @Bool "PTracer round trip" (over (fromPTracer (toPTracer feedback)) loop) not+    , propFnEq @(Bool, Bool)+        "withTracer legs of a tracer compose to the identity"+        (\b -> withTracer feedback (\h i -> h (i b)))+        id+    , propFnEq @(Bool, Bool)+        "withTracer on an iso%tracer composite"+        (\b -> withTracer (notIso O.% feedback) (\h i -> h (i b)))+        id+    , propFnEq @(Bool, Bool) "withTracer on a PTracer" (\b -> withTracer (toPTracer feedback) (\h i -> h (i b))) id+    , propFnEq @(Bool, Bool) "composite lens%tracer over" (over (_1 O.% feedback) loop) (first not)+    , propFnEq @Bool "withIso on constraint-flavored iso" (withIso cNot const) not+    , propFnEq @Bool "withIso on re-versed iso" (withIso (O.re notIso) const) not+    , propFnEq @(Bool, Bool) "withLens on an iso" (withLens swapIso const) swap+    , propFnEq @(Bool, Bool) "withLens put leg on an iso" (withLens swapIso (\_ sbt -> curry sbt (True, False))) swap+    , propFnEq @(Maybe Bool)+        "withPrism on an iso"+        (withPrism (isoToPrism notMaybeIso) (\_ sta -> sta))+        (Right . fmap not)+    , propFnEq @Bool "withGrate zipping" (\b -> withGrate (isoToGrate notIso) (\z -> z (\g -> g ()) (\() -> b))) id+    , propFnEq @((Bool, Bool), (Bool, Bool))+        "zipWithOf a grate zips pairwise"+        (zipWithOf pairGrate (uncurry (&&)))+        (\((a, b), (c, d)) -> (a && c, b && d))+    , propFnEq @((Bool, Bool), (Bool, Bool))+        "zipWithOf a power grate agrees with the grate"+        (zipWithOf pairK (uncurry (||)))+        (zipWithOf pairGrate (uncurry (||)))+    , propFnEq @Bool "withLens on a PIso" (withLens cNot const) not+    , propFnEq @(Maybe Bool) "preview on a PIso" (^? cMaybeNot) (Just . fmap not)+    , propFnEq @Bool "PIso round trip" (view (fromPIso (toPIso notIso))) not+    , propFnEq @Bool "over via fromPIso" (over (fromPIso cNot) not) not+    , propFnEq @(Maybe Bool)+        "PTraversal round trip (prism is a MonoidalTraversal)"+        (over (fromPTraversal (toPTraversal (O.convert _Just :: MonoidalTraversal (Maybe Bool) (Maybe Bool) Bool Bool))) not)+        (fmap not)+    , -- Step 4: monTraverseOf distributes an SDP carrier through a prism (a MonoidalTraversal) with+      -- NO product-strength constraint on the carrier. The MonTravFl split exists for this.+      propFnEq @(Maybe Bool)+        "monTraverseOf a prism (MonoidalTraversal) with a list effect"+        (\m -> unPrelude (unStar (monTraverseOf _Just (Star (Prelude . ((\b -> [b, not b]) :: Bool -> [Bool])))) m))+        (traverse (\b -> [b, not b]))+    , propFnEq @(Bool, Bool)+        "fromPTraversal over both"+        (\(x, y) -> unPar2 (over fromBoth not (par2 x y)))+        (bimap not not)+    , propFnEq @(Bool, Bool)+        "fromPTraversal foci order"+        (\(x, y) -> foldMapOf fromBoth (: []) (par2 x y))+        (\(x, y) -> [x, y])+    , propFnEq @Bool "fromPTraversal on a sum, left" (\x -> foldMapOf fromEither (: []) (G.L1 (G.Par1 x))) (: [])+    , propFnEq @Bool+        "fromPTraversal on a sum, right"+        (\x -> unSum (over fromEither not (G.R1 (G.Par1 x))))+        (Right . not)+    , propFnEq @Bool+        "fromPTraversal with zero foci"+        (\_ -> foldMapOf (fromPTraversal (u1Optic @Bool)) (: []) G.U1)+        (const [])+    , propFnEq @(Maybe Bool, Bool)+        "composite lens%prism preview"+        (preview (_1 O.% _Just))+        (\(m, _) -> maybe (Right ()) Left m)+    , propFnEq @(Maybe Bool, Bool) "composite lens%prism over" (over (_1 O.% _Just) not) (first (fmap not))+    , propFnEq @(Maybe Bool, Bool)+        "traverseOf a lens%prism composite, no convert needed"+        (unPrelude . unStar (traverseOf (_1 O.% _Just) (Star (Prelude . (\b -> [b, not b])))))+        (\(m, c) -> [(m', c) | m' <- traverse (\b -> [b, not b]) m])+    , propFnEq @Bool "tracerOf a PTracer directly" (tracerOf (toPTracer feedback) loop) not+    , propFnEq @(Bool, Bool)+        "powerGrateOf a kaleidoscope%iso composite"+        (powerGrateOf (pairK O.% notIso) not)+        (bimap not not)+    , propFnEq @(Maybe Bool, Bool) "composite lens%prism fold" (foldMapOf (_1 O.% _Just) (: [])) (maybeToList . fst)+    , propFnEq @Bool "composite iso%prism review" (review (notMaybeIso O.% _Just)) (Just . not)+    , propFnEq @Bool "withPrism on composite" (withPrism (notMaybeIso O.% _Just) const) (Just . not)+    , propFnEq @(Maybe Bool, Bool)+        "converted composite preview"+        (preview (compositeToAffineTraversal _1 _Just))+        (\(m, _) -> maybe (Right ()) Left m)+    , propFnEq @(Maybe Bool, Bool)+        "cross-encoding composite over"+        (over (_1 O.% cMaybeNot) (fmap not))+        (first (fmap not))+    , -- exercise Writer's category-generic Traversable instance: distribute a real list effect+      -- through the writer functor (@Writer w % a = w ** a@, tensor-strength, any monoidal category).+      testProperty "Writer Traversable distributes a list effect" $+        assertEq+          (unPrelude (baseTraverse @(Writer [Bool]) @(Star (Prelude [])) (Prelude . \b -> [b, not b]) ([True], False)))+          [([True], False), ([True], True)]+    ]+  where+    bothPar = multOptic par1Optic par1Optic+    eitherPar = plusOptic par1Optic par1Optic+    fromBoth = fromPTraversal bothPar+    fromEither = fromPTraversal eitherPar+    par2 x y = G.Par1 x G.:*: G.Par1 y+    unPar2 (G.Par1 x G.:*: G.Par1 y) = (x, y)+    unSum (G.L1 (G.Par1 x)) = Left x+    unSum (G.R1 (G.Par1 y)) = Right y+    -- The former cotraversal, now a plain 'Traversal' via the kept+    -- @TravFl (CorepStar t) t@ instance (@t = Reader (OP Bool)@, a corepresentable+    -- 'Proarrow.Category.Monoidal.Distributive.Cotraversable' functor).+    zipSnd :: Traversal (Bool, Bool) (Bool, Bool) Bool Bool+    zipSnd =+      O.legs2prof @TravFl+        (CorepStar id :: CorepStar (Reader (OP Bool)) (Bool, Bool) Bool)+        (Reader id :: Reader (OP Bool) Bool (Bool, Bool))+    okIf b = if b then Just (not b) else Nothing+    aggBoth (x, y) = case (okIf x, okIf y) of (Just x', Just y') -> Just (x', y'); _ -> Nothing+    mapTriple (x, (y, (z, ()))) = (not x, (not y, (not z, ())))+    aggTriple (x, (y, (z, ()))) = case (okIf x, okIf y, okIf z) of (Just x', Just y', Just z') -> Just (x', (y', (z', ()))); _ -> Nothing
+ test/Props/Optic/Linear.hs view
@@ -0,0 +1,59 @@+-- | Running optics in the __non-cartesian__ @LINEAR@ category, where the tensor @('**')@ is @(,)@+-- and the product @('&&')@ is @With@ (linear logic's additive conjunction). None of these optics+-- needs 'Proarrow.Category.Monoidal.Cartesian.Cartesian': 'over' on a 'Setter' needs no+-- @Bicartesian@, and a lens's @'Proarrow.Profunctor.Representable.Rep' ('Proarrow.Limit.BinaryProduct.Product' s)@+-- witness needs only 'Proarrow.Limit.BinaryProduct.HasBinaryProducts', not @tensor = product@.+module Props.Optic.Linear (test) where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude (Bool (..), ($))++import Proarrow.Category.Instance.Linear (LINEAR (..), Linear (..), mkWith, unLinear)+import Proarrow.Category.Monoidal (type (**))+import Proarrow.Core (Promonad (..), type (~>))+import Proarrow.Limit.BinaryProduct (fst, snd, (&&&), type (&&))+import Proarrow.Optic.Getter (view)+import Proarrow.Optic.Lens (Lens, lens)+import Proarrow.Optic.MonoidalLens (MonoidalLens, monLens)+import Proarrow.Optic.Setter (over)+import Proarrow.Optic.Traversal (traverseOf)+import Proarrow.Profunctor.Instance.Identity (Id (..))++import Props.Optic.Hask (assertEq)++-- | The @_1@ lens over @LINEAR@: focus the first component of the additive product @With@.+-- Built like Hask's @_1@ (@'lens' 'fst' put@), but the product here is @With@, not a tuple.+_wfst :: Lens (L Bool && L Bool) (L Bool && L Bool) (L Bool) (L Bool)+_wfst = lens fst (snd &&& (snd . fst))++-- | Negation as a linear morphism.+notL :: L Bool ~> L Bool+notL = Linear \case True -> False; False -> True++-- | A __monoidal lens__ onto the second component of a @LINEAR@ tensor pair @L Bool '**' L Bool@.+-- Because @L Bool@ is a 'Proarrow.Monoid.Comonoid' (a @Bool@ is copied\/discarded by case-analysis,+-- which is linear), this is a lens in a non-cartesian category that both sets and views,+-- viewing by discarding the (comonoidal) first-component residual.+_2mon :: MonoidalLens (L Bool ** L Bool) (L Bool ** L Bool) (L Bool) (L Bool)+_2mon = monLens @(L Bool) id id++test :: TestTree+test =+  testGroup+    "Proarrow.OpticLinear"+    [ testProperty "over a lens in LINEAR (product = With, tensor = (,), so non-cartesian)" $+        assertEq (unLinear (over _wfst notL) (mkWith True False)) (mkWith False False)+    , testProperty "over leaves the unfocused component alone" $+        assertEq (unLinear (over _wfst notL) (mkWith True True)) (mkWith False True)+    , testProperty "view a lens in LINEAR" $+        assertEq (unLinear (view _wfst) (mkWith True False)) True+    , -- exercises travP's  act @ProdAction @(PR s)  over a category where tensor /= product+      testProperty "traverseOf a lens in LINEAR (distributes Id via the product action)" $+        assertEq (unLinear (unId (traverseOf _wfst (Id notL))) (mkWith True False)) (mkWith False False)+    , -- a monoidal lens in LINEAR: L Bool is a comonoid, so it sets and views+      testProperty "over a MonoidalLens in LINEAR (modify the tensor focus)" $+        assertEq (unLinear (over _2mon notL) (True, False)) (True, True)+    , testProperty "view a MonoidalLens in LINEAR (discard the comonoidal residual)" $+        assertEq (unLinear (view _2mon) (True, False)) False+    ]
+ test/Props/Ordinal.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The finite ordinals as an enumerable thin category: composing the order with itself is+-- transitivity, computed by searching the objects.+module Props.Ordinal where++import Data.Type.Equality ((:~:) (Refl))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude++import Proarrow.Category.Enriched.Finitary (objIndex)+import Proarrow.Category.Enriched.Thin (Holds, Objects, ThinProfunctor (..))+import Proarrow.Category.Enriched.Thin.Composition ()+import Proarrow.Category.Instance.Bool (BOOL (..))+import Proarrow.Category.Instance.Ordinal (LTE, ORDINAL (..), ORDINAL3)+import Proarrow.Core (CAT, Ob)+import Proarrow.Profunctor.Instance.Composition ((:.:))+import Proarrow.Testing+  ( Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , genElements+  , genSomeFinite+  )+import Proarrow.Testing.Laws+  ( testBinaryCoproducts_+  , testBinaryProducts_+  , testCartesian_+  , testCategory+  , testCopyDiscard_+  , testDistributive_+  , testInitialObject+  , testMonoidal_+  , testSymMonoidal_+  , testTerminalObject+  )++test :: TestTree+test =+  testGroup+    "Ordinal"+    [ testProperty "composing the order searches the objects" $ withArr transitive (pure ())+    , -- the chain as a distributive lattice: meet the minimum and tensor, join the maximum+      testCategory @ORDINAL3+    , testTerminalObject @ORDINAL3+    , testInitialObject @ORDINAL3+    , testBinaryProducts_ @ORDINAL3+    , testBinaryCoproducts_ @ORDINAL3+    , testMonoidal_ @ORDINAL3+    , testSymMonoidal_ @ORDINAL3+    , testCopyDiscard_ @ORDINAL3+    , testCartesian_ @ORDINAL3+    , testDistributive_ @ORDINAL3+    ]++instance Testable ORDINAL3 where+  showOb @a = show (objIndex @a)+  genSome = genSomeFinite++instance (Ob a, Ob b) => TestableType (LTE (a :: ORDINAL3) b) where+  gen = genElements @LTE++-- | Thin, so parallel arrows are equal for free. Forcing is the one thing left to check.+instance (Ob a, Ob b) => TestingEqShow (LTE (a :: ORDINAL3) b) where+  eqP l r = l `seq` r `seq` pure True+  showP _ = show (objIndex @a) ++ "<=" ++ show (objIndex @b)++instance TestableProfunctor (LTE :: CAT ORDINAL3)++-- | The three ordinals, in order.+objectsOrdinal3 :: Objects ORDINAL3 :~: '[OZ, OS OZ, OS (OS OZ)]+objectsOrdinal3 = Refl++-- | Neither leg is representable, so the composite is decided by searching the middle ordinal:+-- @0 <= 2@ holds because it factors through @1@ (among others).+transitive :: ((LTE :.: LTE) :: CAT ORDINAL3) OZ (OS (OS OZ))+transitive = arr++-- | And there is no way back down.+notTransitive :: Holds ((LTE :.: LTE) :: CAT ORDINAL3) (OS (OS OZ)) OZ :~: FLS+notTransitive = Refl
+ test/Props/Paths.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | The laws of "Proarrow.Category.Instance.Paths" on a schema with equations: the Employee and+-- Department schema of Fong and Spivak, /Seven Sketches in Compositionality/ (arXiv:1803.05316),+-- section 3.1.+--+-- With a 'Rewrite' instance, composition normalises and associativity holds only if the rewriting+-- system is confluent. Nothing else checks confluence, so 'testCategory' below does. The last two+-- properties check the separate obligation that the data satisfies the equations.+module Props.Paths (test) where++import Control.Monad (unless)+import Data.Type.Equality ((:~:) (..))+import Test.Falsify (testFailed)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (id, (.))++import Proarrow.Category.Enriched.Thin (Finite (..), Indexed (..), Member (..), memberIndex)+import Proarrow.Category.Instance.Discrete (DISCRETE (..))+import Proarrow.Category.Instance.Paths (EqGen (..), PATHS (..), Paths (..), Rewrite (..), emb, pathLength)+import Proarrow.Category.Instance.Unit (Unit (..))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), UN)+import Proarrow.Functor (Copresheaf)+import Proarrow.Testing+  ( GenTotal+  , Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , genSomeFinite+  , oneOfTotal+  , optGen+  )+import Proarrow.Testing.Laws (testCategory, testProfunctor)++-- | The points of the schema, as bare data: two entity points and one attribute point. The+-- category over them is 'DISCRETE', which supplies the identity arrows and makes 'Ob' the point\'s+-- own index. @(\':~:\')@ would serve as the arrows just as well, but its 'Ob' is vacuous, and then+-- the test suite has to carry a singleton class of its own to say which point it has been handed.+-- 'DISCRETE' supplies that, and enumerability with it.+type data HRPoint = EmployeeP | DepartmentP | StrP++instance Indexed HRPoint+instance Finite HRPoint where type Objects HRPoint = '[EmployeeP, DepartmentP, StrP]++type HR' = DISCRETE HRPoint++type Employee' = D EmployeeP :: HR'+type Department' = D DepartmentP :: HR'+type Str' = D StrP :: HR'++-- | A singleton for the points. 'memberIndex' already refines a point to the one it is, but+-- positionally (@There (There Here)@ says nothing about which point that is), so the three+-- positions get names, as pattern synonyms rather than as a separate type with a dispatcher.+type SHR (a :: HR') = Member a (Objects HR')++pattern SEmployee :: () => (a ~ Employee') => SHR a+pattern SEmployee = Here++pattern SDepartment :: () => (a ~ Department') => SHR a+pattern SDepartment = There Here++pattern SStr :: () => (a ~ Str') => SHR a+pattern SStr = There (There Here)++{-# COMPLETE SEmployee, SDepartment, SStr #-}++type GHR :: CAT HR'+data GHR a b where+  Mngr :: GHR Employee' Employee'+  WorksIn :: GHR Employee' Department'+  Secr :: GHR Department' Employee'+  FName :: GHR Employee' Str'+  DName :: GHR Department' Str'++deriving instance Show (GHR a b)++-- | Generators are distinguishable, and each one determines where it starts.+instance EqGen GHR where+  eqGen Mngr Mngr = Just Refl+  eqGen WorksIn WorksIn = Just Refl+  eqGen Secr Secr = Just Refl+  eqGen FName FName = Just Refl+  eqGen DName DName = Just Refl+  eqGen _ _ = Nothing++-- | The two equations, as a rewriting system: a department's secretary works in that department,+-- and an employee's manager works in the same department. Each is one clause, matching the junction+-- between the arrow being composed on and the normal path it lands on. The second recurses, because+-- dropping a @Mngr@ can expose another one.+instance Rewrite GHR where+  rewrite WorksIn (PCons Secr more) = more+  rewrite WorksIn (PCons Mngr more) = rewrite WorksIn more+  rewrite q f = PCons q f++-- | The book's own running schema (section 3.1), which the airline one deliberately avoids: two+-- entity points, one attribute point, and two path equations. Equations are what a graph cannot+-- express and a category can, and they are the reason a schema is a category at all.+type HR = PATHS GHR++type Employee = PTH Employee' :: HR+type Department = PTH Department' :: HR+type Str = PTH Str' :: HR++-- | The book's instance, equation 3.1.+--+-- > Employee | FName | WorksIn | Mngr      Department | DName | Secr+-- > 1        | Alan  | 101     | 2         101        | Sales | 1+-- > 2        | Ruth  | 101     | 2         102        | IT    | 3+-- > 3        | Kris  | 102     | 3+type Staff :: Copresheaf HR+data Staff u a where+  Emp1, Emp2, Emp3 :: Staff '() Employee+  Dep101, Dep102 :: Staff '() Department+  Txt :: String -> Staff '() Str++deriving instance Eq (Staff u a)+deriving instance Show (Staff u a)++staffStep :: GHR a b -> Staff '() (PTH a) -> Staff '() (PTH b)+staffStep Mngr Emp1 = Emp2+staffStep Mngr Emp2 = Emp2+staffStep Mngr Emp3 = Emp3+staffStep WorksIn Emp1 = Dep101+staffStep WorksIn Emp2 = Dep101+staffStep WorksIn Emp3 = Dep102+staffStep Secr Dep101 = Emp1+staffStep Secr Dep102 = Emp3+staffStep FName Emp1 = Txt "Alan"+staffStep FName Emp2 = Txt "Ruth"+staffStep FName Emp3 = Txt "Kris"+staffStep DName Dep101 = Txt "Sales"+staffStep DName Dep102 = Txt "IT"++instance Profunctor Staff where+  dimap Unit PNil x = x+  dimap Unit (PCons g rest) x = staffStep g (dimap Unit rest x)+  r \\ s = case s of+    Emp1 -> r+    Emp2 -> r+    Emp3 -> r+    Dep101 -> r+    Dep102 -> r+    Txt _ -> r++allEmployees :: [Staff '() Employee]+allEmployees = [Emp1, Emp2, Emp3]++allDepartments :: [Staff '() Department]+allDepartments = [Dep101, Dep102]++-- * Law checking++-- | The singleton at a path-category object, which is the one at its vertex.+theHR :: forall (a :: HR). (Ob a) => SHR (UN PTH a)+theHR = memberIndex @(UN PTH a)++instance Testable HR where+  showOb @a = case theHR @a of+    SEmployee -> "Employee"+    SDepartment -> "Department"+    SStr -> "Str"+  genSome = genSomeFinite++-- | Grow a path backwards from its target, normalising as it goes, so every generated arrow is in+-- normal form like every other one.+genPath :: Int -> SHR x -> SHR y -> GenTotal (Paths (PTH x :: HR) (PTH y))+genPath n sx sy = oneOfTotal (stay ++ grow)+  where+    stay = case (sx, sy) of+      (SEmployee, SEmployee) -> [pure PNil]+      (SDepartment, SDepartment) -> [pure PNil]+      (SStr, SStr) -> [pure PNil]+      _ -> []+    grow+      | n <= 0 = []+      | otherwise = case sy of+          SEmployee -> [rewrite Mngr <$> genPath (n - 1) sx SEmployee, rewrite Secr <$> genPath (n - 1) sx SDepartment]+          SDepartment -> [rewrite WorksIn <$> genPath (n - 1) sx SEmployee]+          SStr -> [rewrite FName <$> genPath (n - 1) sx SEmployee, rewrite DName <$> genPath (n - 1) sx SDepartment]++-- | Comparing paths needs nothing of the endpoints: 'EqGen' decides it from the generators.+instance TestingEqShow (Paths (a :: HR) b)++instance (Ob a, Ob b) => TestableType (Paths (a :: HR) b) where+  gen = genPath 3 (theHR @a) (theHR @b)++instance TestableProfunctor (Paths :: CAT HR)++instance TestingEqShow (Staff u b)++instance (Ob b) => TestableType (Staff '() b) where+  gen = case theHR @b of+    SEmployee -> optGen allEmployees+    SDepartment -> optGen allDepartments+    SStr -> optGen (Txt <$> ["Alan", "Ruth", "Kris", "Sales", "IT"])++instance TestableProfunctor (Staff :: Copresheaf HR)++test :: TestTree+test =+  testGroup+    "Paths"+    [ testProperty "the schema's equations hold in the schema, by construction" $ do+        unless+          (pathLength (emb WorksIn . emb Secr :: Department ~> Department) == 0)+          (testFailed "a secretary followed by where they work should be the identity")+        unless+          (pathLength (emb WorksIn . emb Mngr :: Employee ~> Department) == 1)+          (testFailed "a manager followed by where they work should be just where they work")+    , -- Normalisation makes the equations hold of the /schema/ whatever the data says, so this is+      -- not implied by the test above: it is the separate, unchecked obligation that the instance+      -- satisfies the constraints, and that is the property the approach is sold on.+      testProperty "and the instance satisfies them, which is a separate matter" $ do+        unless+          (all (\d -> staffStep WorksIn (staffStep Secr d) == d) allDepartments)+          (testFailed "every department's secretary must work in that department")+        unless+          (all (\e -> staffStep WorksIn (staffStep Mngr e) == staffStep WorksIn e) allEmployees)+          (testFailed "every employee's manager must work in the same department")+    , testCategory @HR+    , testGroup "Staff is a profunctor" [testProfunctor @Staff]+    ]
+ test/Props/PointedHask.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedLists #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Props.PointedHask where++import Data.Void (Void)+import Test.Falsify.Generator (Function (..), oneof)+import Test.Tasty (TestTree, testGroup)+import Prelude++import Proarrow.Category.Instance.PointedHask (FromPointed (..), POINTED (..), Pointed (..), These (..))+import Proarrow.Core (CategoryOf (..), UN)++import Proarrow.Testing+  ( GenTotal (..)+  , Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , genSomeDef+  , invmap+  , pattern GenNonEmpty+  )+import Proarrow.Testing.Laws+import Props.Hask ()++test :: TestTree+test =+  testGroup+    "Pointed Hask"+    [ testCategory @POINTED+    , testTerminalObject @POINTED+    , testInitialObject @POINTED+    , testBinaryProducts @POINTED (\r -> r)+    , testBinaryCoproducts @POINTED (\r -> r)+    , testMonoidal @POINTED (\r -> r)+    , testSymMonoidal @POINTED (\r -> r)+    , testCopyDiscard @POINTED (\r -> r)+    , testMonoid @(P Void) (\r -> r)+    , testMonoid @(P ()) (\r -> r)+    , testMonoid @(P [()]) (\r -> r)+    , testFunctor @(FromPointed []) (\r -> r)+    ]++instance (TestOb a, TestOb b) => TestableType (Pointed a b) where+  gen = invmap Pt unPt gen+instance (TestOb a, TestOb b) => TestingEqShow (Pointed a b) where+  eqP (Pt l) (Pt r) = eqP l r+  showP _ = "<pointed function>"+instance TestableProfunctor Pointed++instance Testable POINTED where+  type TestOb a = (Ob a, TestOb (UN P a))+  showOb @(P a) = showOb @_ @a+  genSome = genSomeDef @'[P Bool, P (Bool, Bool), P (Maybe Bool)]++instance (TestableType a, TestableType b) => TestableType (These a b) where+  gen = case (gen @a, gen @b) of+    (GenEmpty l, GenEmpty r) -> GenEmpty \case+      This x -> l x+      That y -> r y+      These x _ -> l x+    (GenNonEmpty ga, GenEmpty _) -> GenNonEmpty (This <$> ga)+    (GenEmpty _, GenNonEmpty gb) -> GenNonEmpty (That <$> gb)+    (GenNonEmpty ga, GenNonEmpty gb) -> GenNonEmpty (oneof [This <$> ga, That <$> gb, These <$> ga <*> gb])+instance (TestingEqShow a, TestingEqShow b) => TestingEqShow (These a b) where+  eqP (This l) (This r) = eqP l r+  eqP (That l) (That r) = eqP l r+  eqP (These l1 l2) (These r1 r2) = liftA2 (&&) (eqP l1 r1) (eqP l2 r2)+  eqP _ _ = pure False+  showP (This a) = "This " ++ showP a+  showP (That b) = "That " ++ showP b+  showP (These a b) = "These " ++ showP a ++ " " ++ showP b+instance (Function a, Function b) => Function (These a b)++instance (TestOb (a :: POINTED)) => TestableType (FromPointed [] a) where+  gen = invmap FromPointed unFromPointed gen+instance (TestOb (a :: POINTED)) => TestingEqShow (FromPointed [] a) where+  eqP (FromPointed l) (FromPointed r) = eqP l r+  showP (FromPointed xs) = "FromPointed " ++ showP xs+instance Function (FromPointed [] a) where+  function = error "Function (FromPointed [] a): unused"
+ test/Props/Sheaf.hs view
@@ -0,0 +1,832 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Sheaves for the library's generic coverages on two small categories, and for one coverage+-- defined here. A presheaf @p@ is a sheaf for a coverage when, for each cover of @a@, every+-- compatible choice of elements at the legs (a /matching family/) is the restriction of one and+-- only one element of @p a@. It can fail by having too few such elements or too many.+--+-- * 'Atomic' on the walking arrow covers 'TRU' by 'FLS' (and every object by its identity, which+--   constrains nothing). So a sheaf is a presheaf whose restriction along 'F2T' is a bijection,+--   such as 'Two'. The representable at 'TRU' is a sheaf; the one at 'FLS' is not (too few: it has+--   one element at 'FLS' and none at 'TRU'), so this coverage is not /subcanonical/.+-- * 'Joins' on @(BOOL, BOOL)@ is the discrete two-point space: its four opens are the whole space,+--   the two points and the empty set. The whole space is covered by the two points, the empty set+--   by the empty family. The empty cover has one matching family, so a sheaf has one element over+--   the empty set. 'Const2' has two (too many), and fails only there. Every representable presheaf+--   is a sheaf (subcanonical), but not every two-sided representable: the empty cover wants an+--   element at every object of @j@, and @'Yo' a ('OP' b)@ has none where @b@ misses.+-- * 'Overlapping', defined below, reads the same four opens with the two halves overlapping at+--   @'(FLS, FLS)@. No generic coverage gives it. It is the one site here where gluing is an+--   equalizer (the family must agree on the overlap) instead of a product.+--+-- All three satisfy the Lawvere-Tierney laws, and for all three the dense sieves are the covering+-- ones.+--+-- Presheaves are profunctors with @j ~ ()@, but there the covariant action is trivial, leaving half+-- of a two-sided profunctor untested. (The 'HasInitialObject' needed by+-- @'Proarrow.Category.Sheaf.Sheaf' 'Proarrow.Category.Sheaf.Sums'@ is only for the covariant side,+-- and its absence would go unnoticed at @j ~ ()@.) Only 'closure'\'s naturality and the two-sided+-- 'isSheaf' verdicts are run at a non-trivial @j@: the other laws are stated through+-- 'Proarrow.Category.Enriched.Finitary.Sheaf.isCovering', which is stable under 'rmap', so they+-- say the same at any @j@.+module Props.Sheaf (test) where++import Data.Foldable (for_)+import Data.List (genericIndex, genericLength)+import Test.Falsify (Property)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (const, id, (.))++import Examples.Graph (ByEnds, GRAPH (..), GraphHom (..))+import Proarrow.Category.Enriched.Finitary (Finitary (..), foreachOb, objIndex, sizes)+import Proarrow.Category.Enriched.Finitary.Sheaf+  ( ClosedSieve+  , Plus+  , SHEAVES+  , SHF+  , Sheafify+  , closure+  , isSheaf+  , lawvereTierney+  , withTabulatedSheaf+  )+import Proarrow.Category.Enriched.Finitary.Topos (FIN, FINITARY)+import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..), IsBool (..))+import Proarrow.Category.Instance.Opposite (OPPOSITE (..))+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Prof (Prof)+import Proarrow.Category.Instance.Sub (SUBCAT (..), Sub)+import Proarrow.Category.Instance.Unit (Unit (..))+import Proarrow.Category.Sheaf+  ( Atomic+  , ByImage+  , Cover (..)+  , Coverage+  , Factors (..)+  , HasFiniteCovers (..)+  , Joins+  , Leg (..)+  , PulledBack (..)+  , Sheaf (..)+  , Site (..)+  , SomeCover (..)+  , SomeLeg (..)+  , StableSite (..)+  , Trivial+  , factorThroughCover+  , pullbackAlongId+  )+import Proarrow.Category.Topos (HasSubobjectClassifier (..), closedTopology, doubleNegation, false, openTopology)+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), lmap, obj, type (+->))+import Proarrow.Functor (FunctorForRep (..), Presheaf)+import Proarrow.Limit.BinaryProduct (PROD)+import Proarrow.Limit.Terminal (const)+import Proarrow.Profunctor.Corepresentable (Corep)+import Proarrow.Profunctor.Instance.Composition ((:.:))+import Proarrow.Profunctor.Instance.Coproduct ((:+:) (..))+import Proarrow.Profunctor.Instance.Exponential ((:~>:))+import Proarrow.Profunctor.Instance.Product ((:*:) (..))+import Proarrow.Profunctor.Instance.Rift (Rift)+import Proarrow.Profunctor.Instance.Sieve (Sieve)+import Proarrow.Profunctor.Instance.Terminal (TerminalProfunctor (..))+import Proarrow.Profunctor.Instance.Yoneda (Yo)+import Proarrow.Testing+  ( Some (..)+  , Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , expect+  , genSomeDef+  , genSomeList+  , optGen+  , testEq+  )+import Proarrow.Testing.Laws+  ( propNaturalTransformation+  , testAtomicIsDoubleNegation+  , testBinaryCoproducts_+  , testBinaryProducts_+  , testCategory+  , testClosed_+  , testCoequalizers_+  , testDenseIsCovering+  , testEpiMonoFactorization_+  , testEqualizersAreSheaves+  , testEqualizers_+  , testFinitary+  , testGluesBack+  , testInitialObject+  , testLawvereTierneyFamily_+  , testLawvereTierney_+  , testNegation+  , testPlusFixes+  , testProfunctor+  , testPullbacks_+  , testPushouts_+  , testRanFullyFaithful+  , testRiftFullyFaithful+  , testSheafification+  , testSiteLaws+  , testSubobjectClassifier_+  , testTerminalObject+  )+import Props.Bool ()++type Two :: Presheaf BOOL+data Two b u where+  A, B :: Two TRU '()+  A', B' :: Two FLS '()++deriving instance Eq (Two b u)+deriving instance Show (Two b u)++instance Profunctor Two where+  dimap Tru Unit x = x+  dimap Fls Unit x = x+  dimap F2T Unit A = A'+  dimap F2T Unit B = B'+  r \\ x = case x of+    A -> r+    B -> r+    A' -> r+    B' -> r++-- | Every arrow covers, so there are three covers: the two identities, glued by taking the one+-- leg's element, and 'F2T', glued by undoing the restriction.+instance Sheaf Atomic Two where+  glue (Solely f) m = case f of+    Fls -> m (Only Fls)+    Tru -> m (Only Tru)+    F2T -> case m (Only F2T) of+      A' -> A+      B' -> B++-- | The elements at one object, in the order the numbering uses.+twos :: forall b. (IsBool b) => [Two b '()]+twos = case boolId @b of+  Fls -> [A', B']+  Tru -> [A, B]++instance Finitary Two where+  size @b @_ = genericLength (twos @b)+  toIndex A = 0+  toIndex B = 1+  toIndex A' = 0+  toIndex B' = 1+  fromIndex @b @_ i = twos @b `genericIndex` i+  elements @b @_ = twos @b++instance (Ob u, Ob b) => TestingEqShow (Two b u)++instance (Ob u, IsBool b) => TestableType (Two b u) where+  gen = case boolId @b of+    Fls -> optGen [A', B']+    Tru -> optGen [A, B]++instance TestableProfunctor Two++-- | Two elements at each object, but restriction collapses both of the ones at 'TRU' onto the same+-- element at 'FLS'. This is the case 'Proarrow.Category.Enriched.Finitary.Sheaf.isSheaf' exists to+-- catch and that no other fixture presents: the number of elements and the number of matching+-- families agree, so a verdict computed from the /counts/ would call it a sheaf, while restriction+-- is not injective and it is not one.+type Collapse :: Presheaf BOOL+data Collapse b u where+  C1, C2 :: Collapse TRU '()+  D1, D2 :: Collapse FLS '()++deriving instance Eq (Collapse b u)+deriving instance Show (Collapse b u)++instance Profunctor Collapse where+  dimap Tru Unit x = x+  dimap Fls Unit x = x+  dimap F2T Unit _ = D1+  r \\ x = case x of+    C1 -> r+    C2 -> r+    D1 -> r+    D2 -> r++collapses :: forall b. (IsBool b) => [Collapse b '()]+collapses = case boolId @b of+  Fls -> [D1, D2]+  Tru -> [C1, C2]++instance Finitary Collapse where+  size @b @_ = genericLength (collapses @b)+  toIndex C2 = 1+  toIndex D2 = 1+  toIndex _ = 0+  fromIndex @b @_ i = collapses @b `genericIndex` i+  elements @b @_ = collapses @b++instance (Ob u, Ob b) => TestingEqShow (Collapse b u)++instance (Ob u, IsBool b) => TestableType (Collapse b u) where+  gen = optGen (collapses @b)++instance TestableProfunctor Collapse++-- | The kind of finitary presheaves on the walking arrow, as a testable kind: objects from a palette,+-- shown by their tables of sizes, as "Props.Finitary" does for the copresheaves.+type Sh = FINITARY () BOOL++instance TestableProfunctor (Sub Prof :: CAT Sh)++instance Testable Sh where+  showOb @(SUB p) = show (sizes @p)+  genSome = genSomeDef @'[FIN Two, FIN (Yo TRU (OP '())), FIN (Yo FLS (OP '())), FIN (Sieve :: Presheaf BOOL)]++-- | The category of sheaves for 'Atomic', as a testable kind. Its objects need a 'Sheaf' /instance/,+-- not just a true 'isSheaf'. 'withTabulatedSheaf' supplies one for anything that is a sheaf, and+-- decides the condition on the way, so the failure branches below are where this palette asserts+-- that its members are sheaves at all. The representable at 'TRU' has no instance of its own and+-- enters tabulated, and so does the sheafification, whose own 'toIndex' re-runs the plus+-- construction (a minute at 'ShC' untabulated).+-- No product in the palette: the pullback laws would form pullbacks of products of products+-- (@'Two' ':*:' 'Two'@ here took the group from under 4s to 11s).+type ShB = SHEAVES Atomic () BOOL++instance TestableProfunctor (Sub Prof :: CAT ShB)++instance Testable ShB where+  showOb @(SUB p) = show (sizes @p)+  genSome =+    withTabulatedSheaf @Atomic @(Sheafify Atomic Collapse)+      ( \ @sheafified _ _ ->+          withTabulatedSheaf @Atomic @(Yo TRU (OP '()))+            ( \ @yoTru _ _ ->+                genSomeList+                  "ShB"+                  [ Some @(SHF Atomic Two)+                  , Some @(SHF Atomic TerminalProfunctor)+                  , Some @(SHF Atomic sheafified)+                  , Some @(SHF Atomic yoTru)+                  ]+            )+            (error "ShB: the representable at TRU is not a sheaf")+      )+      (error "ShB: the sheafification of Collapse is not a sheaf")++-- * The two-point space++-- | A sheaf on the discrete two-point space: one section over the empty set, two over @{x}@, one+-- over @{y}@, and one per compatible pair over the whole space, so two.+type Sections :: Presheaf (BOOL, BOOL)+data Sections u v where+  U0 :: Sections '(FLS, FLS) '()+  X1, X2 :: Sections '(TRU, FLS) '()+  Y1 :: Sections '(FLS, TRU) '()+  XY1, XY2 :: Sections '(TRU, TRU) '()++deriving instance Eq (Sections u v)+deriving instance Show (Sections u v)++instance Profunctor Sections where+  dimap (Fls :**: Fls) Unit s = s+  dimap (Tru :**: Fls) Unit s = s+  dimap (Fls :**: Tru) Unit s = s+  dimap (Tru :**: Tru) Unit s = s+  dimap (F2T :**: Fls) Unit _ = U0+  dimap (Fls :**: F2T) Unit _ = U0+  dimap (F2T :**: F2T) Unit _ = U0+  dimap (Tru :**: F2T) Unit XY1 = X1+  dimap (Tru :**: F2T) Unit XY2 = X2+  dimap (F2T :**: Tru) Unit _ = Y1+  r \\ s = case s of+    U0 -> r+    X1 -> r+    X2 -> r+    Y1 -> r+    XY1 -> r+    XY2 -> r++-- | A section over an open is its sections at the points. A point is join-prime (it lies below+-- a join only by lying below one of the joined), so every cover of an open has a leg over each+-- of its points, and @at@ reads the family there. Only @{x}@ has two sections, so it is the only+-- point that has to be read; over the empty set there is nothing to glue and one section to+-- produce.+instance Sheaf Joins Sections where+  glue @a c m = case obj @a of+    Fls :**: Fls -> U0+    Tru :**: Fls -> at (Tru :**: Fls)+    Fls :**: Tru -> Y1+    Tru :**: Tru -> case at (Tru :**: F2T) of+      X1 -> XY1+      X2 -> XY2+    where+      at :: forall x. x ~> a -> Sections x '()+      at h = case factorThroughCover c h of+        Just (Factors l u) -> lmap u (m l)+        Nothing -> error "Sections: no leg over the point, so the family is not over a cover"++sections :: forall a. (Ob a) => [Sections a '()]+sections = case obj @a of+  Fls :**: Fls -> [U0]+  Tru :**: Fls -> [X1, X2]+  Fls :**: Tru -> [Y1]+  Tru :**: Tru -> [XY1, XY2]++instance Finitary Sections where+  size @a @_ = genericLength (sections @a)+  toIndex X2 = 1+  toIndex XY2 = 1+  toIndex _ = 0+  fromIndex @a @_ i = sections @a `genericIndex` i+  elements @a @_ = sections @a++instance (Ob u, Ob a) => TestingEqShow (Sections a u)+instance (Ob u, Ob a) => TestableType (Sections a u) where+  gen = optGen (sections @a)+instance TestableProfunctor Sections++-- | The constant presheaf with two sections everywhere, as the coproduct of two copies of the+-- one-section presheaf. It glues over the two points (a matching pair is a diagonal one), but it+-- has two sections over the empty set where a sheaf must have exactly one, so it is not a sheaf.+--+-- 'Two' is the same shape one site over: constant with two sections, and /is/ a sheaf for+-- 'Atomic'. The difference is the empty cover, which 'Atomic' does not have.+type Const2 :: Presheaf (BOOL, BOOL)+type Const2 = TerminalProfunctor :+: TerminalProfunctor++-- * The two-point space with overlapping halves++-- | The four opens of 'Joins' at @(BOOL, BOOL)@, read as a space whose two halves /overlap/:+-- @'(TRU, TRU)@ is covered by @'(TRU, FLS)@ and @'(FLS, TRU)@ as before, but @'(FLS, FLS)@ is now+-- their intersection instead of the empty set, and gets no cover of its own. Same category, same+-- cover, different sheaves: this is why a site has the @t@ parameter.+--+-- Under 'Joins' the two legs meet only at the empty set, so any pair of sections is a matching+-- family and gluing is a product. Here they meet at @p '(FLS, FLS)@, so the pair must agree there+-- and gluing is an equalizer. The constant presheaf with two values shows the difference: no sheaf+-- for 'Joins' (two sections over the empty set, where the empty cover wants one), but a sheaf here,+-- its four pairs of local sections cut down to the two that agree.+--+-- This is a Grothendieck topology: a cover pulls back along any arrow into @'(TRU, TRU)@ to the+-- target's identity cover, which factors through whichever leg the arrow already factors through.+type Overlapping :: Coverage+type data Overlapping++-- | The name of 'Overlapping'\'s one cover, whose 'Cover' constructor is @ByHalves@ and whose+-- 'Leg' constructors are @AtFst@ and @AtSnd@.+type data Halves++instance Site Overlapping (BOOL, BOOL) where+  data Cover Overlapping (BOOL, BOOL) a c where+    ByHalves :: Cover Overlapping (BOOL, BOOL) '(TRU, TRU) Halves+  data Leg Overlapping (BOOL, BOOL) a c x where+    AtFst :: Leg Overlapping (BOOL, BOOL) '(TRU, TRU) Halves '(TRU, FLS)+    AtSnd :: Leg Overlapping (BOOL, BOOL) '(TRU, TRU) Halves '(FLS, TRU)+  legArrow AtFst = Tru :**: F2T+  legArrow AtSnd = F2T :**: Tru+  legs ByHalves = [SomeLeg AtFst, SomeLeg AtSnd]++-- | As 'Joins', minus the empty cover: the intersection factors through either half, and+-- through the first by choice.+instance StableSite Overlapping (BOOL, BOOL) where+  pullbackCover ByHalves (Tru :**: Tru) = pullbackAlongId ByHalves+  pullbackCover ByHalves (Tru :**: F2T) = AlreadyFactors (Factors AtFst id)+  pullbackCover ByHalves (F2T :**: Tru) = AlreadyFactors (Factors AtSnd id)+  pullbackCover ByHalves (F2T :**: F2T) = AlreadyFactors (Factors AtFst (F2T :**: Fls))++instance HasFiniteCovers Overlapping (BOOL, BOOL) where+  covers @a = case obj @a of+    Tru :**: Tru -> [SomeCover ByHalves]+    _ -> []++-- | Gluing for 'Overlapping': a matching family over the two halves agrees on the intersection,+-- and both halves are the same two-valued set, so the value at either leg is the glued one. The+-- smallest instance in which an overlap does any work. Under 'Joins' this same presheaf is+-- no sheaf at all.+instance Sheaf Overlapping Const2 where+  glue ByHalves m = case m AtFst of+    InjL TerminalProfunctor -> InjL TerminalProfunctor+    InjR TerminalProfunctor -> InjR TerminalProfunctor++-- | The kind of finitary presheaves on the two-point space, as a testable kind.+type Sh2 = FINITARY () (BOOL, BOOL)++instance TestableProfunctor (Sub Prof :: CAT Sh2)++instance Testable Sh2 where+  showOb @(SUB p) = show (sizes @p)+  genSome = genSomeDef @'[FIN Sections, FIN Const2, FIN (Yo '(TRU, TRU) (OP '())), FIN (Sieve :: Presheaf (BOOL, BOOL))]++-- | The edge object of the graph schema, as a functor out of the one-object category.+data family AtEdge :: () +-> GRAPH++instance FunctorForRep AtEdge where+  type AtEdge @ '() = E+  fmap Unit = IdE++-- | The inclusion of the edges, as a corepresentable: its elements are the arrows out of 'E'. The+-- coverage by its image covers 'V' by the two ends of an edge, which is 'ByEnds'.+type EdgeInc :: GRAPH +-> ()+type EdgeInc = Corep AtEdge++-- | The graph schema squashed onto the walking arrow: 'E' to 'FLS', 'V' to 'TRU', and both 'Src'+-- and 'Tgt' to the one arrow between them. It is not faithful, and so extension along it loses+-- information.+data family Squash :: GRAPH +-> BOOL++instance FunctorForRep Squash where+  type Squash @ E = FLS+  type Squash @ V = TRU+  fmap IdE = Fls+  fmap IdV = Tru+  fmap Src = F2T+  fmap Tgt = F2T++-- | The kind of finitary presheaves on the graph schema, as a testable kind. Needed for the+-- Lawvere--Tierney laws at 'ByEnds', which are stated on the presheaf classifier.+type PshG = FINITARY () GRAPH++instance TestableProfunctor (Sub Prof :: CAT PshG)++instance Testable PshG where+  showOb @(SUB p) = show (sizes @p)+  genSome = genSomeDef @'[FIN TerminalProfunctor, FIN (Yo V (OP '())), FIN (Yo E (OP '())), FIN (Sieve :: Presheaf GRAPH)]++-- | The category of sheaves for 'Overlapping', as a testable kind. The only one of the three+-- whose gluing is an equalizer, so the only one where a quotient of sheaves can have local+-- sections agreeing on the intersection without coming from a global one (the case+-- 'Proarrow.Category.Enriched.Finitary.Sheaf.factorLocally' descends for). 'Sections' is a sheaf+-- here but has no instance of its own, so it enters tabulated, as at 'ShB'.+type ShO = SHEAVES Overlapping () (BOOL, BOOL)++instance TestableProfunctor (Sub Prof :: CAT ShO)++instance Testable ShO where+  showOb @(SUB p) = show (sizes @p)+  genSome =+    withTabulatedSheaf @Overlapping @Sections+      ( \ @sections _ _ ->+          genSomeList+            "ShO"+            [ Some @(SHF Overlapping Const2)+            , Some @(SHF Overlapping TerminalProfunctor)+            , Some @(SHF Overlapping sections)+            ]+      )+      (error "ShO: Sections is not a sheaf for Overlapping")++-- | The category of sheaves for 'Joins', as a testable kind. See 'ShB', in particular for why+-- the sheafification is tabulated.+type ShC = SHEAVES Joins () (BOOL, BOOL)++instance TestableProfunctor (Sub Prof :: CAT ShC)++instance Testable ShC where+  showOb @(SUB p) = show (sizes @p)+  genSome =+    withTabulatedSheaf @Joins @(Sheafify Joins Const2)+      ( \ @tab _ _ ->+          genSomeList+            "ShC"+            [Some @(SHF Joins Sections), Some @(SHF Joins TerminalProfunctor), Some @(SHF Joins tab)]+      )+      (error "ShC: the sheafification of Const2 is not a sheaf")++test :: TestTree+test =+  testGroup+    "Sheaf"+    [ testProfunctor @Two+    , testProfunctor @Sections+    , testFinitary @Two "Two"+    , testFinitary @Sections "Sections"+    , -- the unique killer of a counts-only 'isSheaf', on a hand-written numbering+      testFinitary @Collapse "Collapse"+    , -- 'Sieve' is test infrastructure now: 'closure'\'s naturality quantifies over its 'elements'+      testFinitary @(Sieve :: BOOL +-> BOOL) "Sieve"+    , -- every 'Joins' verdict runs through this numbering, and nothing was checking it+      testFinitary @(Booleans :**: Booleans) "BOOL x BOOL"+    , -- the only law suite that pins @'Omega' = 'Sieve'@ and @true = 'maximalSieve'@ as a+      -- classifier rather than by definition+      testSubobjectClassifier_ @(PROD Sh)+    , testSubobjectClassifier_ @(PROD Sh2)+    , -- the topologies the internal logic gives, which no coverage here is written down for+      testGroup+        "Lawvere-Tierney topologies from the logic"+        [ testLawvereTierney_ @(PROD Sh) doubleNegation+        , testLawvereTierneyFamily_ @(PROD Sh) "open" openTopology+        , testLawvereTierneyFamily_ @(PROD Sh) "closed" closedTopology+        , testLawvereTierney_ @(PROD Sh2) doubleNegation+        , -- the walking arrow has pullbacks, so the Ore condition holds and the dense topology is+          -- the atomic one: two computations of one arrow, from the logic and from the coverage+          testAtomicIsDoubleNegation @BOOL+        , testNegation @(PROD Sh)+        , testNegation @(PROD Sh2)+        , testProperty "the open and closed topologies of true and false" $ do+            let constTrue = const @(Omega :: PROD Sh) true+            testEq "open true" "openTopology true" (openTopology @(PROD Sh) true) "id" id+            testEq "open false" "openTopology false" (openTopology @(PROD Sh) false) "const true" constTrue+            testEq "closed true" "closedTopology true" (closedTopology @(PROD Sh) true) "const true" constTrue+            testEq "closed false" "closedTopology false" (closedTopology @(PROD Sh) false) "id" id+        ]+    , testGroup+        "Trivial"+        [ -- With no covers, anything quantified over them asserts nothing while reporting successes,+          -- so @testGluesBack@, @isSheaf@ and @testGeneratedSieveIsSieve@ are all omitted here. What+          -- is left is a smoke test rather than a law suite: with no covers 'closure' is the+          -- identity on sieves, so the topology is the trivial one, and both of these hold of it by+          -- inspection. They still exercise the 'Omega' plumbing and the 'Sieve' equality the other+          -- two groups rely on.+          testLawvereTierney_ @(PROD Sh) (lawvereTierney @Trivial)+        , testDenseIsCovering @Trivial @() @BOOL+        , -- only the maximal sieve is dense, so one plus changes nothing, even for a non-sheaf+          testPlusFixes @Trivial @Two+        , testPlusFixes @Trivial @Collapse+        ]+    , testGroup+        "Atomic"+        [ testGluesBack @Atomic @Two+        , testLawvereTierney_ @(PROD Sh) (lawvereTierney @Atomic)+        , testProperty "restriction along F2T" $+            for_ ([A', B'] :: [Two FLS '()]) \m ->+              testEq+                "restriction"+                "lmap F2T (glue (Solely F2T) (\\(Only _) -> m))"+                (lmap F2T (glue @Atomic @Two (Solely F2T) \(Only _) -> m))+                "m"+                m+        , testProperty "isSheaf" $ do+            expect "Two is a sheaf" True (isSheaf @Atomic @Two)+            expect "the representable at TRU is a sheaf" True (isSheaf @Atomic @(Yo TRU (OP '())))+            expect "the representable at FLS is not: Atomic is not subcanonical" False (isSheaf @Atomic @(Yo FLS (OP '())))+            -- the counts agree here (2 elements, 2 matching families); only the tables differ+            expect "a collapsing restriction is not a sheaf" False (isSheaf @Atomic @Collapse)+            -- the covariant side is a bystander: the same verdicts two-sidedly+            expect "Yo TRU (OP FLS) is a sheaf" True (isSheaf @Atomic @(Yo TRU (OP FLS) :: BOOL +-> BOOL))+            expect "Yo FLS (OP TRU) is not" False (isSheaf @Atomic @(Yo FLS (OP TRU) :: BOOL +-> BOOL))+        , testGluesBack @Atomic @(Two :*: Two)+        , testProperty "closure under limits" $ do+            expect "a product of sheaves is a sheaf" True (isSheaf @Atomic @(Two :*: Two))+            expect "the terminal profunctor is a sheaf" True (isSheaf @Atomic @(TerminalProfunctor :: Presheaf BOOL))+        , -- at @j = BOOL@, not @j = ()@: over the unit category @'dimap' g h@ collapses to+          -- @'lmap' g@, so a covariant slip in 'closure' would be invisible there+          testProperty "closure is natural" $+            propNaturalTransformation @(Sieve :: BOOL +-> BOOL) (closure @Atomic)+        , testSiteLaws @Atomic @() @BOOL+        , testFinitary @(Plus Atomic Collapse) "Plus Collapse"+        , testFinitary @(Sheafify Atomic Collapse) "Sheafify Collapse"+        , testProfunctor @(Plus Atomic Collapse)+        , testSheafification @Atomic @Collapse @Two+        , -- 'isSheaf' above decides the condition by enumeration; this runs the 'glue' itself+          testGluesBack @Atomic @(Sheafify Atomic Collapse)+        , testGroup+            "the category of sheaves"+            [ testCategory @ShB+            , testTerminalObject @ShB+            , testBinaryProducts_ @ShB+            , testEqualizers_ @ShB+            , testPullbacks_ @ShB+            , -- the colimits, each the presheaf one sheafified+              testInitialObject @ShB+            , testBinaryCoproducts_ @ShB+            , testCoequalizers_ @ShB+            , testPushouts_ @ShB+            , testEpiMonoFactorization_ @ShB+            , -- the exponential is 'FINITARY'\'s, and a sheaf because the codomain is+              testClosed_ @(PROD ShB)+            , testSubobjectClassifier_ @(PROD ShB)+            , testFinitary @(ClosedSieve Atomic :: Presheaf BOOL) "ClosedSieve Atomic"+            , -- 'TRU' is covered by 'FLS', so the sieve that cover generates is dense and its+              -- closure is the maximal one: of the three sieves at 'TRU' only two are closed.+              testProperty "the closed sieves" $ do+                expect "all sieves" [2, 3] (sizes @(Sieve :: Presheaf BOOL))+                expect "closed ones" [2, 2] (sizes @(ClosedSieve Atomic :: Presheaf BOOL))+                expect "and they are a sheaf" True (isSheaf @Atomic @(ClosedSieve Atomic :: Presheaf BOOL))+            , testFinitary @(Sub Prof :: CAT ShB) "ShB"+            , testEqualizersAreSheaves @Atomic @() @BOOL+            ]+        , -- The one cover has no overlaps, so one plus is already a sheaf for /every/ presheaf here:+          -- P⁺(TRU) is the classes of (maximal, x) and ({F2T}, y), identified when x restricts to y,+          -- which is P(FLS), and restriction becomes the identity.+          testProperty "one plus suffices without overlaps" $ do+            expect "Plus Collapse is a sheaf" True (isSheaf @Atomic @(Plus Atomic Collapse))+            expect "Plus (Yo FLS) is a sheaf" True (isSheaf @Atomic @(Plus Atomic (Yo FLS (OP '()))))+            expect "Plus (Yo FLS) is the terminal presheaf" [1, 1] (sizes @(Plus Atomic (Yo FLS (OP '()))))+            expect "Sheafify Collapse keeps two elements at each object" [2, 2] (sizes @(Sheafify Atomic Collapse))+            -- and two-sidedly+            expect "Plus (Yo FLS (OP TRU)) is a sheaf" True (isSheaf @Atomic @(Plus Atomic (Yo FLS (OP TRU) :: BOOL +-> BOOL)))+        ]+    , testGroup+        "Overlapping"+        [ -- The same four objects and the same cover as 'Joins', with the empty cover dropped+          -- so that the two legs meet at a section rather than at nothing. This is the only site+          -- here whose gluing is an equalizer instead of a product.+          testProperty "isSheaf" $ do+            expect "the constant presheaf is a sheaf here" True (isSheaf @Overlapping @Const2)+            expect "and is not for Joins, which has an empty cover" False (isSheaf @Joins @Const2)+            expect "Sections is a sheaf too" True (isSheaf @Overlapping @Sections)+        , testProperty "the overlap cuts the pairs down" $ do+            -- four pairs of local sections over the top, of which the two that agree on the+            -- intersection survive; under 'Joins' the intersection is empty and all four do+            expect "sheafified here" [2, 2, 2, 2] (sizes @(Sheafify Overlapping Const2))+            expect "sheafified for Joins" [1, 2, 2, 4] (sizes @(Sheafify Joins Const2))+        , testProperty "the closed sieves are the opens" $+            -- the opens contained in each: the intersection has two, each half three, the union+            -- five. 'Joins' sees a discrete pair of points instead and counts subsets+            expect "Omega" [2, 3, 3, 5] (sizes @(ClosedSieve Overlapping :: Presheaf (BOOL, BOOL)))+        , testLawvereTierney_ @(PROD Sh2) (lawvereTierney @Overlapping)+        , testProperty "closure is natural" $+            propNaturalTransformation @(Sieve :: BOOL +-> (BOOL, BOOL)) (closure @Overlapping)+        , testSiteLaws @Overlapping @() @(BOOL, BOOL)+        , testGluesBack @Overlapping @Const2+        , -- The one place an /exponential/ is glued. Its 'Sheaf' instance searches its elements+          -- for the one that restricts to the family, and no other site here can call it with a+          -- cover whose legs overlap.+          testProperty "the exponential of sheaves is a sheaf" $+            expect "isSheaf" True (isSheaf @Overlapping @(Const2 :~>: Const2))+        , testGluesBack @Overlapping @(Const2 :~>: Const2)+        , -- and the other carrier with no 'glue' of its own: the classifier+          testGluesBack @Overlapping @(ClosedSieve Overlapping :: Presheaf (BOOL, BOOL))+        , -- The presheaf of /all/ sieves is not a sheaf here (the sixth sieve at the top is not+          -- closed), and sheafifying it gives the closed ones. So the classifier of the sheaves is+          -- the sheafification of the classifier of the presheaves.+          testProperty "sheafifying the sieves gives the closed sieves" $ do+            expect "Sieve is no sheaf here" False (isSheaf @Overlapping @(Sieve :: Presheaf (BOOL, BOOL)))+            expect+              "and its sheafification is Omega"+              (sizes @(ClosedSieve Overlapping :: Presheaf (BOOL, BOOL)))+              (sizes @(Sheafify Overlapping (Sieve :: Presheaf (BOOL, BOOL))))+        , -- 'Sieve' is no sheaf here, so 'extendSheafify' descends through 'factorLocally' along the+          -- two overlapping halves, the one kind of cover no other site here has.+          testSheafification @Overlapping @(Sieve :: Presheaf (BOOL, BOOL)) @Const2+        , testGroup+            "the category of sheaves"+            [ testCategory @ShO+            , testTerminalObject @ShO+            , testBinaryProducts_ @ShO+            , testEqualizers_ @ShO+            , testPullbacks_ @ShO+            , testInitialObject @ShO+            , -- No 'testBinaryCoproducts_' (6.3s), 'testCoequalizers_' (2.6s), 'testPushouts_' (4.4s)+              -- or 'testSubobjectClassifier_' (2.9s) here. Their laws are the same at every site,+              -- and the one branch they would reach that no other site does, 'factorLocally'+              -- descending along overlapping legs, the sheafification test above reaches for 0.2s.+              -- What is special about quotients at this site, that a matching pair is a+              -- constraint and not a choice, is asserted directly in @Props.Sheaf.Collage@. The+              -- pushout is also the one epi-mono factorization drives. The subobject classifier+              -- is tested at Atomic, and what is special about it here, that it is the five opens,+              -- is asserted directly above.+              testEpiMonoFactorization_ @ShO+            , testClosed_ @(PROD ShO)+            , testFinitary @(Sub Prof :: CAT ShO) "ShO"+            , testEqualizersAreSheaves @Overlapping @() @(BOOL, BOOL)+            ]+        ]+    , testGroup+        "ByEnds"+        [ -- The one site here that is not a poset: both legs are arrows 'E' -> 'V'. Everything+          -- else in this module runs where a hom-set has at most one arrow, which hides three+          -- things at once: a sieve cannot tell parallel arrows apart, a factorisation through+          -- a leg cannot be well typed and wrong, and matching collapses to an equation.+          testSiteLaws @ByEnds @() @GRAPH+        , testProperty "sieves tell the two legs apart" $ do+            -- five sieves at 'V': the empty one, 'Src' alone, 'Tgt' alone, both, and everything.+            -- On a poset the two singletons could not both exist. The one that is not closed is+            -- @{Src, Tgt}@, whose closure is the maximal sieve because it is the cover's sieve.+            expect "all sieves" [2, 5] (sizes @(Sieve :: Presheaf GRAPH))+            expect "closed ones" [2, 4] (sizes @(ClosedSieve ByEnds :: Presheaf GRAPH))+        , testProperty "isSheaf" $ do+            expect "the terminal presheaf is a sheaf" True (isSheaf @ByEnds @(TerminalProfunctor :: Presheaf GRAPH))+            -- not subcanonical, and for a reason the other sites cannot show: a vertex has one+            -- arrow to itself where a sheaf needs one section per pair of ends+            expect "the representable at V is not" False (isSheaf @ByEnds @(Yo V (OP '())))+            expect "nor the one at E" False (isSheaf @ByEnds @(Yo E (OP '())))+        , testProperty "sheafifying makes the vertices the pairs of ends" $ do+            expect "before" [2, 1] (sizes @(Yo V (OP '())))+            expect "after" [2, 4] (sizes @(Sheafify ByEnds (Yo V (OP '()))))+        , -- which covers "is a sheaf" as one of its four, and the reflector's laws besides+          testSheafification @ByEnds @(Yo V (OP '())) @(TerminalProfunctor :: Presheaf GRAPH)+        , testLawvereTierney_ @(PROD PshG) (lawvereTierney @ByEnds)+        , testProperty "closure is natural" $ propNaturalTransformation @(Sieve :: Presheaf GRAPH) (closure @ByEnds)+        , testGroup+            "as the image of the edges"+            [ testSiteLaws @(ByImage EdgeInc) @() @GRAPH+            , testRanFullyFaithful @EdgeInc+            , -- the hom-profunctor is fully faithful on both sides: that is the Yoneda lemma+              testGroup "the hom-profunctor" [testRanFullyFaithful @GraphHom, testRiftFullyFaithful @GraphHom]+            , -- The other side fails for the edges: their image is not dense. Its transformations+              -- V -> V are the four maps {Src, Tgt} -> {Src, Tgt}, where there is one arrow. As the+              -- edges are fully faithful, that makes the coverage not subcanonical: the+              -- representable at V is no sheaf.+              testProperty "the edges are not dense" $+                expect "transformations V -> V, arrows V -> V" (4, 1) (size @(Rift (OP EdgeInc) EdgeInc) @V @V, size @GraphHom @V @V)+            , testProperty "agrees with ByEnds" $ do+                expect+                  "closed sieves"+                  (sizes @(ClosedSieve ByEnds :: Presheaf GRAPH))+                  (sizes @(ClosedSieve (ByImage EdgeInc) :: Presheaf GRAPH))+                expect "the terminal presheaf" True (isSheaf @(ByImage EdgeInc) @(TerminalProfunctor :: Presheaf GRAPH))+                expect "the representable at V" False (isSheaf @(ByImage EdgeInc) @(Yo V (OP '())))+                expect "the representable at E" False (isSheaf @(ByImage EdgeInc) @(Yo E (OP '())))+                -- the sheafification of a presheaf is the extension of its restriction to the edges+                expect+                  "sheafifying the representable at V"+                  (sizes @(Sheafify ByEnds (Yo V (OP '()))))+                  (sizes @(Rift (OP EdgeInc) (EdgeInc :.: Yo V (OP '()))))+            ]+        , -- Extension along a functor that is not fully faithful still gives a sheaf, but+          -- restricting it back does not recover the presheaf: here the family at 'TRU' would have+          -- to be both 'Src' and 'Tgt'. The representable at 'V' has sizes [2, 1].+          testProperty "along a functor that is not faithful the counit is no isomorphism" $+            expect+              "the representable at V, restricted after extending"+              [2, 0]+              (sizes @(Corep Squash :.: Rift (OP (Corep Squash)) (Yo V (OP '()))))+        ]+    , testGroup+        "Joins"+        [ testGluesBack @Joins @Sections+        , testLawvereTierney_ @(PROD Sh2) (lawvereTierney @Joins)+        , testProperty "isSheaf" $ do+            expect "Sections is a sheaf" True (isSheaf @Joins @Sections)+            expect "the constant presheaf is not: two sections over the empty set" False (isSheaf @Joins @Const2)+            sequence_+              ( foreachOb @(BOOL, BOOL) @(Property ()) \ @a ->+                  [ expect+                      ("the representable at object " ++ show (objIndex @a) ++ " is a sheaf: Joins is subcanonical")+                      True+                      (isSheaf @Joins @(Yo a (OP '())))+                  ]+              )+            -- subcanonical is about the representable presheaves: two-sidedly the empty cover bites,+            -- since TRU has no arrow to FLS and so no section over the empty set there+            expect+              "the two-sided representable at '(TRU, FLS) over TRU is not a sheaf"+              False+              (isSheaf @Joins @(Yo '(TRU, FLS) (OP TRU) :: BOOL +-> (BOOL, BOOL)))+        , testProperty "closure is natural" $+            propNaturalTransformation @(Sieve :: BOOL +-> (BOOL, BOOL)) (closure @Joins)+        , testGluesBack @Joins @(ClosedSieve Joins :: Presheaf (BOOL, BOOL))+        , testSiteLaws @Joins @() @(BOOL, BOOL)+        , testFinitary @(Plus Joins Const2) "Plus Const2"+        , testFinitary @(Sheafify Joins Const2) "Sheafify Const2"+        , testSheafification @Joins @Const2 @Sections+        , testGluesBack @Joins @(Sheafify Joins Const2)+        , testGroup+            "the category of sheaves"+            [ testCategory @ShC+            , testTerminalObject @ShC+            , testBinaryProducts_ @ShC+            , testEqualizers_ @ShC+            , testPullbacks_ @ShC+            , testInitialObject @ShC+            , -- No 'testBinaryCoproducts_' (5.8s), 'testCoequalizers_' (2.9s) or+              -- 'testSubobjectClassifier_' (2.9s) here. Their laws are the same at every site and+              -- hold at Atomic, and a coverage comparison shows they reach no code at this site+              -- that the other tests here miss. What is special here, 'factorLocally' descending+              -- over the empty cover, the sheafification and initial object tests reach. The+              -- sheafified coproduct, whose empty cover collapses the two sections over the empty+              -- set, is built by the epi-mono factorization below, and the classifier's closed+              -- sieves are asserted directly below.+              --+              -- No 'testPushouts_' either: the apex is the sheafified coproduct, whose sections over+              -- the whole space are the pairs, and the law draws three arrows out of it, each an+              -- enumeration over 15 points where a coequalizer's is over 6 (4.2s for the group).+              -- Epi-mono factorization covers the same pushout at a quarter the cost.+              testEpiMonoFactorization_ @ShC+            , testClosed_ @(PROD ShC)+            , testFinitary @(ClosedSieve Joins :: Presheaf (BOOL, BOOL)) "ClosedSieve Joins"+            , -- The closed sieves on a space are its opens: over the empty set only the empty one,+              -- where the presheaf of all sieves has two, and the four subsets over the whole.+              testProperty "the closed sieves are the opens" $ do+                expect "all sieves" [2, 3, 3, 6] (sizes @(Sieve :: Presheaf (BOOL, BOOL)))+                expect "closed ones" [1, 2, 2, 4] (sizes @(ClosedSieve Joins :: Presheaf (BOOL, BOOL)))+                expect+                  "and they are a sheaf"+                  True+                  (isSheaf @Joins @(ClosedSieve Joins :: Presheaf (BOOL, BOOL)))+            , testFinitary @(Sub Prof :: CAT ShC) "ShC"+            , testEqualizersAreSheaves @Joins @() @(BOOL, BOOL)+            ]+        , -- Every sieve at the empty set is dense, and the empty sieve is the meet of them all, so+          -- one plus leaves 'Const2' a single section over the empty set. But the whole space still+          -- has two, where a sheaf now needs a section per pair over the two points: four. The+          -- second plus supplies them, and the result is the constant sheaf with fibre two.+          testProperty "two pluses are needed" $ do+            expect "one plus: one section over the empty set" [1, 2, 2, 2] (sizes @(Plus Joins Const2))+            expect "one plus is not yet a sheaf" False (isSheaf @Joins @(Plus Joins Const2))+            expect "two pluses: the constant sheaf" [1, 2, 2, 4] (sizes @(Sheafify Joins Const2))+        , -- the presentation that 'ShC' draws from is the same sheaf+          withTabulatedSheaf @Joins @(Sheafify Joins Const2)+            ( \ @tab _ _ ->+                testGroup+                  "the tabulated sheafification"+                  [ testProperty "is the same sheaf" $ do+                      expect "has the sheafification's sizes" [1, 2, 2, 4] (sizes @tab)+                      expect "is a sheaf" True (isSheaf @Joins @tab)+                  , -- a 'Tabulated' glues by search; this is the law that search has to satisfy+                    testGluesBack @Joins @tab+                  ]+            )+            (error "the tabulated sheafification is not a sheaf")+        ]+    ]
+ test/Props/Sheaf/Chain.hs view
@@ -0,0 +1,304 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | __A site whose covers nest.__ In the other coverages here+-- @'Proarrow.Category.Sheaf.HasFiniteCovers'@'s Composition law (if @c@ covers @a@ and every leg of+-- @c@ is covered, the composites cover @a@) holds trivially. Either no leg of a cover is itself+-- covered (the two points of the discrete space, the bottom of the walking arrow), or every cover+-- of a leg contains its identity (the image of a functor). So the idempotence of 'closure' that+-- the law buys is never tested.+--+-- On the three-element chain @0 -> 1 -> 2@, 'Atomic' lets every arrow cover, so the law holds for+-- a reason: @1 '~>' 2@ covers @2@, its leg is covered by @0 '~>' 1@, and the composite @0 '~>' 2@+-- covers @2@ too. 'Pred' covers each object only by its immediate predecessor and breaks the law:+-- @0 '~>' 2@ is not a cover, so 'closure' is not idempotent, as the last test asserts. 'Pred'+-- still passes the three @testSiteLaws@ checks and the other two Lawvere-Tierney laws, so+-- idempotence is the only law separating the two coverages.+module Props.Sheaf.Chain (test) where++import Props.Bool ()+import Props.Ordinal ()+import Props.Sheaf ()++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (id, (.))++import Proarrow.Category.Enriched.Finitary (Finitary (..), sizes)+import Proarrow.Category.Enriched.Finitary.Sheaf (ClosedSieve, closure, isClosed, isSheaf, lawvereTierney)+import Proarrow.Category.Enriched.Finitary.Topos (FIN, FINITARY, glueBySearch)+import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..))+import Proarrow.Category.Instance.Opposite (OPPOSITE (..))+import Proarrow.Category.Instance.Ordinal (LTE (..), ORDINAL (..), ORDINAL3)+import Proarrow.Category.Instance.Prof (Prof)+import Proarrow.Category.Instance.Sub (SUBCAT (..), Sub)+import Proarrow.Category.Sheaf+  ( Atomic+  , Cover (..)+  , Coverage+  , Factors (..)+  , HasFiniteCovers (..)+  , Induced+  , Joins+  , Leg (..)+  , PulledBack (..)+  , Sheaf (..)+  , Site (..)+  , SomeCover (..)+  , SomeLeg (..)+  , StableSite (..)+  , glueExtension+  , pullbackAlongId+  )+import Proarrow.Core (CAT, Hom, Kind, Promonad (..), obj, type (+->))+import Proarrow.Functor (FunctorForRep (..), Presheaf)+import Proarrow.Limit.BinaryProduct (PROD)+import Proarrow.Profunctor.Corepresentable (Corep)+import Proarrow.Profunctor.Instance.Composition ((:.:))+import Proarrow.Profunctor.Instance.Coproduct ((:+:))+import Proarrow.Profunctor.Instance.Rift (Rift)+import Proarrow.Profunctor.Instance.Sieve (Sieve (..))+import Proarrow.Profunctor.Instance.Terminal (TerminalProfunctor)+import Proarrow.Profunctor.Instance.Yoneda (Yo)+import Proarrow.Testing (Testable (..), TestableProfunctor, expect, genSomeDef)+import Proarrow.Testing.Laws+  ( testAtomicIsDoubleNegation+  , testCoveredByImage+  , testGluesBack+  , testLawvereTierney_+  , testRanFullyFaithful+  , testRiftFullyFaithful+  , testSiteLaws+  )++-- | The bottom of the chain.+type O0 :: ORDINAL3+type O0 = OZ++-- | The middle.+type O1 :: ORDINAL3+type O1 = OS OZ++-- | The top.+type O2 :: ORDINAL3+type O2 = OS (OS OZ)++-- | The kind of finitary presheaves on the chain, as a testable kind: the Lawvere--Tierney laws+-- are stated on the presheaf classifier, so this is what carries them.+type PshChain :: Kind+type PshChain = FINITARY () ORDINAL3++instance TestableProfunctor (Sub Prof :: CAT PshChain)++instance Testable PshChain where+  showOb @(SUB p) = show (sizes @p)+  genSome =+    genSomeDef+      @'[ FIN TerminalProfunctor+        , FIN (Yo O2 (OP '()))+        , FIN (Yo O0 (OP '()))+        , FIN (Sieve :: Presheaf ORDINAL3)+        ]++-- * The chain covered by its immediate predecessors++-- | The coverage that covers each object by the one below it, and nothing else. Stable, and not+-- composing: see the module header.+type Pred :: Coverage+type data Pred++-- | The name of both of 'Pred'\'s covers: @TwoByOne@ covers 'O2' by its one leg @FromOne@, and+-- @OneByZero@ covers 'O1' by @FromZero@.+type data ByPredecessor++instance Site Pred ORDINAL3 where+  data Cover Pred ORDINAL3 a c where+    TwoByOne :: Cover Pred ORDINAL3 O2 ByPredecessor+    OneByZero :: Cover Pred ORDINAL3 O1 ByPredecessor+  data Leg Pred ORDINAL3 a c x where+    FromOne :: Leg Pred ORDINAL3 O2 ByPredecessor O1+    FromZero :: Leg Pred ORDINAL3 O1 ByPredecessor O0+  legArrow FromOne = SLT (ZLT ZEQ)+  legArrow FromZero = ZLT ZEQ+  legs TwoByOne = [SomeLeg FromOne]+  legs OneByZero = [SomeLeg FromZero]++instance HasFiniteCovers Pred ORDINAL3 where+  covers @a = case obj @a of+    ZEQ -> []+    SLT ZEQ -> [SomeCover OneByZero]+    SLT (SLT ZEQ) -> [SomeCover TwoByOne]++-- | Stable: every arrow into 'O2' other than the identity already factors through @1 '~>' 2@,+-- because the chain is thin and @0 <= 1@.+instance StableSite Pred ORDINAL3 where+  pullbackCover TwoByOne (ZLT (ZLT ZEQ)) = AlreadyFactors (Factors FromOne (ZLT ZEQ))+  pullbackCover TwoByOne (SLT (ZLT ZEQ)) = AlreadyFactors (Factors FromOne id)+  pullbackCover TwoByOne (SLT (SLT ZEQ)) = pullbackAlongId TwoByOne+  pullbackCover OneByZero (ZLT ZEQ) = AlreadyFactors (Factors FromZero id)+  pullbackCover OneByZero (SLT ZEQ) = pullbackAlongId OneByZero++-- * The comparison lemma++-- | The chain's two ends, @0 '~>' 2@, as a functor from the walking arrow. Fully faithful, and+-- under 'Atomic' the middle is covered by @0 '~>' 1@, so the sheaves on the chain are the sheaves on+-- the walking arrow for the induced coverage. That coverage covers 'TRU' by @'FLS' '~>' 'TRU'@,+-- which is 'Atomic' again.+data family Ends :: BOOL +-> ORDINAL3++instance FunctorForRep Ends where+  type Ends @ FLS = O0+  type Ends @ TRU = O2+  fmap Fls = ZEQ+  fmap Tru = SLT (SLT ZEQ)+  fmap F2T = ZLT (ZLT ZEQ)++type EndsInc :: ORDINAL3 +-> BOOL+type EndsInc = Corep Ends++-- | The top two, @1 '~>' 2@. Dense in the categorical sense, since the bottom is the empty colimit,+-- but nothing from the image covers the bottom, and the lemma fails: the induced coverage gives+-- 'TRU' an empty cover, and its only sheaf is the terminal one.+data family Upper :: BOOL +-> ORDINAL3++instance FunctorForRep Upper where+  type Upper @ FLS = O1+  type Upper @ TRU = O2+  fmap Fls = SLT ZEQ+  fmap Tru = SLT (SLT ZEQ)+  fmap F2T = SLT (ZLT ZEQ)++type UpperInc :: ORDINAL3 +-> BOOL+type UpperInc = Corep Upper++-- | Two elements everywhere, on the walking arrow.+type Two :: Presheaf BOOL+type Two = TerminalProfunctor :+: TerminalProfunctor++-- | Two elements everywhere, on the chain.+type TwoC :: Presheaf ORDINAL3+type TwoC = TerminalProfunctor :+: TerminalProfunctor++instance Sheaf (Induced Atomic EndsInc) Two where+  glue = glueBySearch @(Induced Atomic EndsInc)++instance Sheaf Atomic (Rift (OP EndsInc) Two) where+  glue = glueExtension @Atomic++-- | The sieve at the top of the arrows out of the bottom: the one generated by @0 '~>' 2@, and the+-- witness that 'Pred' does not compose.+fromBottom :: Sieve (O2 :: ORDINAL3) '()+fromBottom = Sieve \g _ -> case g of+  ZLT _ -> True+  _ -> False++test :: TestTree+test =+  testGroup+    "Chain"+    [ testGroup+        "Atomic"+        [ testSiteLaws @Atomic @() @ORDINAL3+        , -- the payoff: idempotence and meet preservation on a site where composing covers+          -- actually produces a cover that was not one of the two being composed+          testLawvereTierney_ @(PROD PshChain) (lawvereTierney @Atomic)+        , -- a chain has pullbacks, so here too the atomic topology is the double-negation one --+          -- on a site where, unlike the walking arrow, covers nest+          testAtomicIsDoubleNegation @ORDINAL3+        , testProperty "isSheaf" $ do+            expect+              "the terminal presheaf is a sheaf: every restriction of it is a bijection"+              True+              (isSheaf @Atomic @(TerminalProfunctor :: Presheaf ORDINAL3))+            expect+              "the representable at the top is a sheaf -- it is the terminal presheaf"+              True+              (isSheaf @Atomic @(Yo O2 (OP '())))+            expect+              "the representable at the bottom is not: nothing over 1, one thing over 0"+              False+              (isSheaf @Atomic @(Yo O0 (OP '())))+            expect+              "the sieves are not: four at the top, three at the middle"+              False+              (isSheaf @Atomic @(Sieve :: Presheaf ORDINAL3))+        , testProperty "the truth values" $ do+            expect+              "the sieves: two at the bottom, three at the middle, four at the top"+              [2, 3, 4]+              (sizes @(Sieve :: Presheaf ORDINAL3))+            expect+              "the closed ones: the empty sieve and the maximal one, at every object"+              [2, 2, 2]+              (sizes @(ClosedSieve Atomic :: Presheaf ORDINAL3))+            expect+              "so the truth values are constant, and a sheaf -- as the classifier of a topos of sheaves must be"+              True+              (isSheaf @Atomic @(ClosedSieve Atomic :: Presheaf ORDINAL3))+        ]+    , testGroup+        "Joins"+        [ -- on a chain no element but the bottom is the join of the ones below it, so the one+          -- cover is the bottom's empty one, and a sheaf is a presheaf with one element there+          testSiteLaws @Joins @() @ORDINAL3+        , testLawvereTierney_ @(PROD PshChain) (lawvereTierney @Joins)+        , testProperty "isSheaf" $ do+            expect "the terminal presheaf is a sheaf" True (isSheaf @Joins @(TerminalProfunctor :: Presheaf ORDINAL3))+            expect "the representable at the top is a sheaf" True (isSheaf @Joins @(Yo O2 (OP '())))+            expect "and so is the one at the bottom: subcanonical" True (isSheaf @Joins @(Yo O0 (OP '())))+            expect "the sieves are not: two at the bottom" False (isSheaf @Joins @(Sieve :: Presheaf ORDINAL3))+        ]+    , testGroup+        "restricted to its ends"+        [ testSiteLaws @(Induced Atomic EndsInc) @() @BOOL+        , testLawvereTierney_ @(PROD (FINITARY () BOOL)) (lawvereTierney @(Induced Atomic EndsInc))+        , testRanFullyFaithful @EndsInc+        , testCoveredByImage @Atomic @EndsInc+        , testGluesBack @Atomic @(Rift (OP EndsInc) Two)+        , testProperty "the comparison lemma" $ do+            expect+              "restriction keeps a sheaf"+              (True, True)+              (isSheaf @Atomic @TwoC, isSheaf @(Induced Atomic EndsInc) @(EndsInc :.: TwoC))+            expect+              "extension makes one"+              (True, True)+              (isSheaf @(Induced Atomic EndsInc) @Two, isSheaf @Atomic @(Rift (OP EndsInc) Two))+            expect "the extension" [2, 2, 2] (sizes @(Rift (OP EndsInc) Two))+            expect+              "the induced coverage has the sheaves of Atomic"+              (isSheaf @Atomic @Two, isSheaf @Atomic @(Yo FLS (OP '())), isSheaf @Atomic @(Yo TRU (OP '())))+              ( isSheaf @(Induced Atomic EndsInc) @Two+              , isSheaf @(Induced Atomic EndsInc) @(Yo FLS (OP '()))+              , isSheaf @(Induced Atomic EndsInc) @(Yo TRU (OP '()))+              )+        , testProperty "the ends are not dense" $+            expect+              "transformations 1 -> 0, arrows 1 -> 0"+              (1, 0)+              (size @(Rift (OP EndsInc) EndsInc) @O1 @O0, size @(Hom ORDINAL3) @O1 @O0)+        , testRiftFullyFaithful @UpperInc+        , testLawvereTierney_ @(PROD (FINITARY () BOOL)) (lawvereTierney @(Induced Atomic UpperInc))+        , testProperty "the top two are dense, but do not cover the bottom" $ do+            expect+              "restriction loses a sheaf"+              (True, False)+              (isSheaf @Atomic @TwoC, isSheaf @(Induced Atomic UpperInc) @(UpperInc :.: TwoC))+            expect "the induced coverage has no sheaf with two elements" False (isSheaf @(Induced Atomic UpperInc) @Two)+        ]+    , testGroup+        "Pred"+        [ -- stability, generated sieves, and dense = covering all hold; only composition fails,+          -- and none of the three sees it+          testSiteLaws @Pred @() @ORDINAL3+        , testProperty "the covers do not compose, so closure is not idempotent" $ do+            expect+              "{0 -> 2} is not closed: its closure adds 1 -> 2"+              False+              (isClosed @Pred fromBottom)+            expect+              "its closure adds 1 -> 2, whose own closure is maximal"+              False+              (isClosed @Pred (closure @Pred fromBottom))+        ]+    ]
+ test/Props/Sheaf/Collage.hs view
@@ -0,0 +1,336 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | __A site that is neither a poset nor overlap-free.__ The other coverages in @Props.Sheaf@ are+-- one or the other: @Overlapping@ has legs that meet, on a poset; @Examples.Graph@'s @ByEnds@ has+-- parallel legs that do not meet. Matching needs both: a family has to agree on the overlaps, and+-- which arrow it agrees along only matters when there is more than one.+--+-- The category is the collage of 'Pair': the diamond of opens on the left, one extra object on the+-- right, and the elements of 'Pair' (two out of each open) as the parallel cross-arrows. The+-- overlaps have to come from the diamond, since a collage's cross-arrows all go one way.+module Props.Sheaf.Collage (test) where++import Data.List (genericIndex, genericLength, sort)+import Numeric.Natural (Natural)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (id, (.))++import Proarrow.Category.Enriched.Finitary (Finitary (..), FiniteCat, foreachOb, indices, sizes)+import Proarrow.Category.Enriched.Finitary.Sheaf+  ( ClosedSieve+  , Sheafify+  , generatedSieve+  , isSheaf+  , withSieve+  , withTabulatedSheaf+  )+import Proarrow.Category.Enriched.Finitary.Topos (natElements)+import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..))+import Proarrow.Category.Instance.Collage (COLLAGE (..), Collage (..), InjL)+import Proarrow.Category.Instance.Opposite (OPPOSITE (..))+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Instance.Unit (Unit (..))+import Proarrow.Category.Sheaf (ByImage, Cover (..))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), obj, type (+->))+import Proarrow.Functor (Copresheaf, Presheaf)+import Proarrow.Profunctor.Corepresentable (Corep, Corepresentable (..))+import Proarrow.Profunctor.Instance.Composition ((:.:))+import Proarrow.Profunctor.Instance.Ran (Ran)+import Proarrow.Profunctor.Instance.Rift (Rift)+import Proarrow.Profunctor.Instance.Sieve (Sieve)+import Proarrow.Profunctor.Instance.Star (Star, pattern Star)+import Proarrow.Profunctor.Instance.Terminal (TerminalProfunctor)+import Proarrow.Profunctor.Instance.Yoneda (Yo)+import Proarrow.Testing+  ( Some (..)+  , Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , expect+  , genElements+  , genSomeFinite+  , genSomeList+  , optGen+  )+import Proarrow.Testing.Laws+  ( testAdjunction+  , testCategory+  , testFinitary+  , testGluesBack+  , testRanFullyFaithful+  , testSiteLaws+  )++-- | Two sections over each half of the diamond and over their intersection, none over the whole.+-- Restriction to the intersection keeps the label, so the two @X@s agree there and so do the two+-- @Y@s. That agreement is the overlap the site is built for. There is nothing over the top, so the+-- top stays out of the coverage.+type Pair :: Presheaf (BOOL, BOOL)+data Pair u v where+  XW, YW :: Pair '(FLS, FLS) '()+  XU, YU :: Pair '(TRU, FLS) '()+  XV, YV :: Pair '(FLS, TRU) '()++instance Profunctor Pair where+  dimap (Fls :**: Fls) Unit x = x+  dimap (Tru :**: Fls) Unit x = x+  dimap (Fls :**: Tru) Unit x = x+  dimap (F2T :**: Fls) Unit XU = XW+  dimap (F2T :**: Fls) Unit YU = YW+  dimap (Fls :**: F2T) Unit XV = XW+  dimap (Fls :**: F2T) Unit YV = YW+  dimap (F2T :**: F2T) Unit x = case x of {}+  dimap (Tru :**: F2T) Unit x = case x of {}+  dimap (F2T :**: Tru) Unit x = case x of {}+  dimap (Tru :**: Tru) Unit x = x+  r \\ x = case x of XW -> r; YW -> r; XU -> r; YU -> r; XV -> r; YV -> r++-- | The elements over each object, in the order the numbering uses.+pairs :: forall u. (Ob u) => [Pair u '()]+pairs = case obj @u of+  Fls :**: Fls -> [XW, YW]+  Tru :**: Fls -> [XU, YU]+  Fls :**: Tru -> [XV, YV]+  Tru :**: Tru -> []++-- | Comparable and generable at its objects, as the generic 'Collage' instances in+-- "Proarrow.Testing" require of the profunctor a collage is built from.+deriving instance Eq (Pair u v)++deriving instance Show (Pair u v)++instance (Ob u, Ob v) => TestingEqShow (Pair u v)++instance (Ob u, Ob v) => TestableType (Pair u v) where+  gen = optGen (pairs @u)++instance Finitary Pair where+  size @u @_ = genericLength (pairs @u)+  toIndex x = case x of XW -> 0; YW -> 1; XU -> 0; YU -> 1; XV -> 0; YV -> 1+  fromIndex @u @_ i = pairs @u `genericIndex` i+  elements @u @_ = pairs @u++-- | The collage: the diamond, one further object, and 'Pair' as the arrows into it.+type Patches = COLLAGE Pair++-- | The inclusion of the diamond as the left layer of the collage, as a corepresentable.+type Inc :: Patches +-> (BOOL, BOOL)+type Inc = Corep (InjL Pair)++-- | The coverage: every object is covered by the arrows into it from the diamond. At the extra+-- object that is six legs (two out of each half and two out of the intersection), and the last two+-- factor through the first four. The two labelled alike agree on the intersection, so a matching+-- family has equations to satisfy along arrows a poset cannot tell apart, and it has them twice+-- over.+type Cov = ByImage Inc++-- | Whether the adjunction's unit is a bijection at each object: its images, as indices, are all of them.+unitIsBijective :: forall (s :: Presheaf Patches). (Finitary s) => [Bool]+unitIsBijective = case corepUniv @(Star ExtendF) @s of+  Star (Prof unit) -> foreachOb @Patches \ @x -> foreachOb @() \ @c ->+    let ix = toIndex @(Rift (OP Inc) (Inc :.: s)) @x @c+    in [sort [ix (unit y) | y <- elements @s @x @c] == indices (size @(Rift (OP Inc) (Inc :.: s)) @x @c)]++-- | Extension along 'Inc', as a functor between the two categories of presheaves.+type ExtendF :: Presheaf (BOOL, BOOL) -> Presheaf Patches+type ExtendF = Rift (OP Inc)++-- | The finitary presheaves on the diamond and on the collage, as testable kinds, so that+-- @'Star' 'ExtendF'@ can be law-checked as an 'Proarrow.Adjunction.Adjunction'.+instance TestableProfunctor (Prof :: CAT (Presheaf (BOOL, BOOL)))++instance Testable (Presheaf (BOOL, BOOL)) where+  type TestOb p = Finitary p+  showOb @p = show (sizes @p)+  genSome = genSomeList "Presheaf (BOOL, BOOL)" [Some @Pair, Some @(TerminalProfunctor :: Presheaf (BOOL, BOOL))]++instance TestableProfunctor (Prof :: CAT (Presheaf Patches))++instance Testable (Presheaf Patches) where+  type TestOb p = Finitary p+  showOb @p = show (sizes @p)+  genSome =+    genSomeList "Presheaf Patches" [Some @AtApex, Some @(TerminalProfunctor :: Presheaf Patches)]++instance TestableProfunctor (Star ExtendF)++-- | The finitary copresheaves on the diamond and on the collage, as testable kinds, so that+-- @'Star' ('Ran' ('OP' 'Inc'))@ can be law-checked as an 'Proarrow.Adjunction.Adjunction'. By+-- Yoneda @'Ran' ('OP' 'Inc') p@ at @b@ is @p@ at @'L' b@, so on copresheaves it is restriction,+-- and its left adjoint @- ':.:' 'Inc'@ is the left Kan extension.+instance TestableProfunctor (Prof :: CAT (Copresheaf (BOOL, BOOL)))++instance Testable (Copresheaf (BOOL, BOOL)) where+  type TestOb p = Finitary p+  showOb @p = show (sizes @p)+  genSome =+    genSomeList+      "Copresheaf (BOOL, BOOL)"+      [ Some @(Yo '() (OP '(FLS, FLS)))+      , Some @(Yo '() (OP '(TRU, FLS)))+      , Some @(TerminalProfunctor :: Copresheaf (BOOL, BOOL))+      ]++instance TestableProfunctor (Prof :: CAT (Copresheaf Patches))++instance Testable (Copresheaf Patches) where+  type TestOb p = Finitary p+  showOb @p = show (sizes @p)+  genSome =+    genSomeList+      "Copresheaf Patches"+      [Some @(Yo '() (OP (L '(FLS, FLS)))), Some @(Yo '() (OP (R '()))), Some @(TerminalProfunctor :: Copresheaf Patches)]++-- | Restriction of copresheaves along 'Inc', written as a right Kan extension.+type RanInc :: Copresheaf Patches -> Copresheaf (BOOL, BOOL)+type RanInc = Ran (OP Inc)++instance TestableProfunctor (Star RanInc)++-- | How many natural transformations there are from one finitary profunctor to another.+mapCount :: forall {j} {k} (x :: j +-> k) (y :: j +-> k). (Finitary x, Finitary y, FiniteCat j, FiniteCat k) => Natural+mapCount = genericLength (natElements @x @y)++-- | Compared and shown by its index. Within one hom-set the objects determine the constructor, so+-- the index is faithful, as for 'Proarrow.Category.Enriched.Finitary.Topos.Tabulated'.+--+-- Pinned to this collage: 'TestableProfunctor'\'s quantified superclass needs the instance at+-- /abstract/ objects, and a shape-agnostic instance would need nested quantified constraints,+-- which GHC will not discharge through the product kind's object decomposition.+instance (Ob a, Ob b) => TestingEqShow (Collage (a :: Patches) b) where+  eqP f g = pure (toIndex @(Collage :: CAT Patches) f == toIndex g)+  showP f = show (toIndex @(Collage :: CAT Patches) f)++instance (Ob a, Ob b) => TestableType (Collage (a :: Patches) b) where+  gen = genElements @(Collage :: CAT Patches)++instance TestableProfunctor (Collage :: CAT Patches)++instance Testable Patches where+  showOb @a = case obj @a of+    InL (Fls :**: Fls) -> "W"+    InL (Tru :**: Fls) -> "U"+    InL (Fls :**: Tru) -> "V"+    InL (Tru :**: Tru) -> "top"+    InR Unit -> "R"+  genSome = genSomeFinite++-- | The representable at the extra object: two arrows into it out of each half, and one out of+-- the object itself. It witnesses that matching has content here (see the test below).+type AtApex :: Presheaf Patches+type AtApex = Yo (R '()) (OP '())++-- | 'Pair' extended to the whole collage: 'Pair' on the left layer, and at the apex the right Kan+-- lift of 'Pair' along itself, its four relabellings.+type Extended :: Presheaf Patches+type Extended = ExtendF Pair++test :: TestTree+test =+  testGroup+    "Collage"+    [ testSiteLaws @Cov @() @Patches+    , -- the first law test of the collage's own category structure, which this module is the+      -- first to make testable+      testCategory @Patches+    , testRanFullyFaithful @Inc+    , -- not dense: at the apex there are four transformations (the relabellings of Pair) and one+      -- arrow, which is why the representable at the apex is no sheaf+      testProperty "the diamond is not dense in the collage" $+        expect+          "transformations and arrows at the apex"+          (4, 1)+          (size @(Rift (OP Inc) Inc) @(R '()) @(R '()), size @(Collage :: CAT Patches) @(R '()) @(R '()))+    , testFinitary @(Collage :: CAT Patches) "Collage Pair"+    , testProperty "the shape of the site" $ do+        expect "two sections over each half, none over the top" [2, 2, 2, 0] (sizes @Pair)+        expect "the terminal presheaf is a sheaf" True (isSheaf @Cov @(TerminalProfunctor :: Presheaf Patches))+        -- five objects, and a classifier far richer than any poset site here manages+        expect "sieves" [2, 3, 3, 6, 26] (sizes @(Sieve :: Presheaf Patches))+        expect "closed ones" [2, 3, 3, 6, 25] (sizes @(ClosedSieve Cov :: Presheaf Patches))+    , -- What the site is for. Two sections of 'AtApex' at each of the six legs is 2^6 families;+      -- the overlaps cut them to the four that agree. On the poset sites an overlap gives one+      -- equation with no choice of arrow to satisfy it along, and on @ByEnds@ there is no overlap+      -- at all, so this is the first time the condition rules anything out.+      testProperty "matching is a real constraint" $ do+        expect+          "of which matching"+          (4 :: Natural)+          (withSieve (generatedSieve @Cov @(R '()) @'() Images) \ @sub _ -> mapCount @sub @AtApex)+        -- and one section at the apex, so restriction is not the bijection a sheaf needs+        expect "the representable at the apex is no sheaf" False (isSheaf @Cov @AtApex)+    , testGroup+        "extending a presheaf on the left layer"+        [ testProperty "gives a sheaf with the presheaf on the left" $ do+            expect "Pair on the left, the four relabellings at the apex" [2, 2, 2, 0, 4] (sizes @Extended)+            expect "a sheaf" True (isSheaf @Cov @Extended)+            expect "restricted to the left layer it is Pair again" (sizes @Pair) (sizes @(Inc :.: Extended))+            -- the coend Inc :.: s is computed generically; by coYoneda it is s at the left layer+            expect "the restriction of the apex's representable is Pair" (sizes @Pair) (sizes @(Inc :.: AtApex))+            -- the unit s -> Rift (OP Inc) (Inc :.: s) is an iso exactly on the sheaves+            expect "the unit is a bijection on it" True (and (unitIsBijective @Extended))+            expect "but not on the representable at the apex, which is no sheaf" False (and (unitIsBijective @AtApex))+        , -- Extension is right adjoint to restriction: a map into the extension is a map into Pair+          -- from the left layer. This is the universal property of the right Kan lift.+          testProperty "is right adjoint to restriction" $ do+            expect "from the apex's representable" (mapCount @(Inc :.: AtApex) @Pair) (mapCount @AtApex @Extended)+            expect+              "from the terminal presheaf"+              (mapCount @(Inc :.: (TerminalProfunctor :: Presheaf Patches)) @Pair)+              (mapCount @(TerminalProfunctor :: Presheaf Patches) @Extended)+            expect "from itself" (mapCount @(Inc :.: Extended) @Pair) (mapCount @Extended @Extended)+        , testAdjunction @(Star ExtendF) (\r -> r) (\r -> r)+        , -- and on copresheaves, restriction with the left Kan extension as its left adjoint+          testAdjunction @(Star RanInc) (\r -> r) (\r -> r)+        , testFinitary @Extended "the extension of Pair"+        , testGluesBack @Cov @Extended+        ]+    , withTabulatedSheaf @Cov @(Sheafify Cov AtApex)+        ( \ @tab _ _ ->+            testGroup+              "its sheafification"+              [ testProperty "has one section at the apex per matching family" $ do+                  expect "sizes" [2, 2, 2, 0, 4] (sizes @tab)+                  -- the same sheaf, built by the plus construction twice instead of by the Kan lift+                  expect "and the unit into that extension is a bijection" True (and (unitIsBijective @tab))+              , -- The half of "a sheaf is its left layer" that the sheaf condition does not+                -- already give. isSheaf checks that a sheaf's value at the extra object is+                -- determined by its left part. This checks that restriction to the left layer+                -- loses no maps either (every presheaf map extends, and only one way). Together they say the sheaves on this site are the+                -- presheaves on its left layer, the right one carrying no information.+                testProperty "restriction to the left layer is fully faithful" $ do+                  expect+                    "the terminal sheaf to itself"+                    (mapCount @(TerminalProfunctor :: Presheaf Patches) @(TerminalProfunctor :: Presheaf Patches))+                    (mapCount @(Inc :.: (TerminalProfunctor :: Presheaf Patches)) @(Inc :.: (TerminalProfunctor :: Presheaf Patches)))+                  expect+                    "the terminal sheaf to the sheafification -- none, the top being empty"+                    (mapCount @(TerminalProfunctor :: Presheaf Patches) @tab)+                    (mapCount @(Inc :.: (TerminalProfunctor :: Presheaf Patches)) @(Inc :.: tab))+                  expect+                    "the sheafification to the terminal sheaf"+                    (mapCount @tab @(TerminalProfunctor :: Presheaf Patches))+                    (mapCount @(Inc :.: tab) @(Inc :.: (TerminalProfunctor :: Presheaf Patches)))+                  expect+                    "the sheafification to itself -- the four relabellings"+                    (mapCount @tab @tab)+                    (mapCount @(Inc :.: tab) @(Inc :.: tab))+                  -- and the control: on presheaves at large it is not full. 'AtApex' has one+                  -- section at the apex, so a self-map is pinned there, while its left part has+                  -- the same four relabellings as above, of which only one extends.+                  expect "the non-sheaf, on the collage" 1 (mapCount @AtApex @AtApex)+                  expect "the non-sheaf, on the left layer" 4 (mapCount @(Inc :.: AtApex) @(Inc :.: AtApex))+              , -- Gluing where matching rules families out: the search has four legs to satisfy+                -- and only a quarter of the families to choose from, a case no other test puts+                -- 'Proarrow.Category.Enriched.Finitary.Topos.glueBySearch'\'s uniqueness check and+                -- 'Proarrow.Category.Enriched.Finitary.Sheaf.gluePlus'\'s choice of factorisation+                -- to.+                testGluesBack @Cov @tab+              ]+        )+        (error "the sheafification of the representable at the apex is not a sheaf")+    ]
+ test/Props/Simplex.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Props.Simplex where++import Data.Falsify.ConcreteFun qualified as ConcreteFun+import Data.Fin (Fin (..), absurd, isMin)+import Data.Foldable (Foldable (..), toList)+import Data.Monoid (All (..), Ap (..))+import Data.Vec.Lazy (Vec (..), universe, zipWith)+import Data.Void qualified as Void+import Test.Falsify.Generator (Function (..), choose)+import Test.Tasty (TestTree, testGroup)+import Prelude hiding (fst, id, snd, zipWith)++import Proarrow.Category.Instance.Simplex (Forget, IsNat (..), Nat (..), Pick, SNat (..), Simplex (..))+import Proarrow.Core (Ob)++import Proarrow.Profunctor.Representable (Rep)+import Proarrow.Testing+  ( GenTotal (..)+  , ShowP (..)+  , Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , genSomeDef+  , oneElem+  , optGen+  , pattern GenNonEmpty+  )+import Proarrow.Testing.Laws+import Props.Hask ()++test :: TestTree+test =+  testGroup+    "Simplex"+    [ testCategory @Nat+    , testInitialObject @Nat+    , testTerminalObject @Nat+    , testMonoidal_ @Nat+    , testMonoid_ @Z+    , testMonoid_ @(S Z)+    , testProfunctor @(Rep Forget)+    , testProfunctor @(Rep (Pick Bool))+    ]++instance Testable Nat where+  type TestOb a = Ob a+  genSome = genSomeDef @'[Z, S Z, S (S Z), S (S (S Z))]+  showOb @a = show (singNat @a)++instance (Ob a, Ob b) => TestingEqShow (Simplex a b)+instance (Ob a, Ob b) => TestableType (Simplex a b) where+  gen = case (singNat @a, singNat @b) of+    (SZ, SZ) -> oneElem ZZ+    (SZ, SS @b') -> case gen @(Simplex Z b') of+      GenEmpty f -> GenEmpty (\(Y p) -> f p)+      GenNonEmpty gf -> GenNonEmpty (Y <$> gf)+    (SS, SZ) -> GenEmpty \case {}+    (SS @a', SS @b') -> case (gen @(Simplex a' b), gen @(Simplex (S a') b')) of+      (GenEmpty l, GenEmpty r) -> GenEmpty \case+        X f -> l f+        Y f -> r f+      (GenNonEmpty gf, GenEmpty _) -> GenNonEmpty (X <$> gf)+      (GenEmpty _, GenNonEmpty gg) -> GenNonEmpty (Y <$> gg)+      (GenNonEmpty gf, GenNonEmpty gg) -> GenNonEmpty (choose (X <$> gf) (Y <$> gg))+instance TestableProfunctor Simplex++instance (IsNat n) => TestingEqShow (Fin n)+instance (IsNat n) => TestableType (Fin n) where+  gen = case singNat @n of+    SZ -> GenEmpty absurd+    _ -> optGen (toList universe)++instance (IsNat n) => Function (Fin n) where+  function = case singNat @n of+    SZ -> fmap (ConcreteFun.map absurd Void.absurd) . function @Void.Void+    SS @m -> fmap (ConcreteFun.map isMin (maybe FZ FS)) . function @(Maybe (Fin m))++instance (TestableType a, IsNat n) => TestableType (Vec n a) where+  gen = case gen @a of+    GenEmpty ax -> case universe @n of VNil -> oneElem VNil; _ -> GenEmpty \(a ::: _) -> ax a+    GenNonEmpty ga -> GenNonEmpty (traverse (const ga) universe)+instance (TestingEqShow a, IsNat n) => TestingEqShow (Vec n a) where+  eqP VNil VNil = pure True+  eqP as bs = getAll <$> getAp (fold (zipWith (\l r -> Ap (fmap All (eqP l r))) as bs))+  showP = show . fmap ShowP++instance (IsNat n, Function a) => Function (Vec n a) where+  function = case singNat @n of+    SZ -> fmap (ConcreteFun.map (\VNil -> ()) (\() -> VNil)) . function @()+    SS @m -> fmap (ConcreteFun.map (\(x ::: xs) -> (x, xs)) (uncurry (:::))) . function @(a, Vec m a)++instance TestableProfunctor (Rep Forget)+instance TestableProfunctor (Rep (Pick Bool))
+ test/Props/Span.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedLists #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Props.Span where++import Data.Foldable (toList)+import Data.Typeable ((:~:) (..))+import Test.Tasty (TestTree, testGroup)+import Prelude (Bool (..), Maybe (..), pure, zip, ($), (&&), (++), (<$>), (<*>), (==), (||))++import Proarrow.Category.Instance.FinSet (FINSET (..), unFinSet)+import Proarrow.Category.Instance.Span (SPAN (..), Span (..))+import Proarrow.Core (CAT, CategoryOf (..), UN, (//), (\\))++import Data.List (sort)+import Proarrow.Testing+  ( GenTotal (..)+  , Some (..)+  , Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , mapSome+  , pattern GenNonEmpty+  )+import Proarrow.Testing.Laws+import Props.FinSet (eqFinSet)++test :: TestTree+test =+  testGroup+    "Span(FinSet)"+    [ testCategory @(SPAN FINSET)+    , testDagger @(SPAN FINSET)+    , testMonoidal_ @(SPAN FINSET)+    , testSymMonoidal_ @(SPAN FINSET)+    , testClosed_ @(SPAN FINSET)+    , testStarAutonomous_ @(SPAN FINSET)+    , testCompactClosed_ @(SPAN FINSET)+    , testCopyDiscard_ @(SPAN FINSET)+    , testHypergraph_ @(SPAN FINSET)+    ]++-- instance (Testable k, HasPushouts k, TestObIsOb k) => Testable (SPAN k) where+instance Testable (SPAN FINSET) where+  type TestOb a = Ob a+  showOb @a = showOb @_ @(UN SP a)+  genSome = mapSome SP <$> genSome+  genSomeSmall = mapSome SP <$> genSomeSmall++-- instance (Ob a, Ob b, Testable k, TestObIsOb k) => TestingEqShow (Span a (b :: SPAN k)) where+instance (Ob a, Ob b) => TestingEqShow (Span a (b :: SPAN FINSET)) where+  eqP (Span @c1 l1 r1) (Span @c2 l2 r2) =+    l1 //+      l2 //+        case eqFinSet @c1 @c2 of+          Just Refl -> do+            eql <- eqP l1 l2+            eqr <- eqP r1 r2+            -- Both legs map out of the apex, so any relabelling of it is admissible. Two spans+            -- are isomorphic exactly when their multisets of (left, right) image pairs agree.+            -- Cospan's legs map in, so it has to search instead (see "Props.Cospan").+            let hasIso = sort (zip (toList (unFinSet l1)) (toList (unFinSet r1))) == sort (zip (toList (unFinSet l2)) (toList (unFinSet r2)))+            pure $ (eql && eqr) || hasIso+          Nothing -> pure False+  showP (Span @c l r) = "Span @(" ++ showOb @_ @c ++ ") (" ++ showP l ++ ") (" ++ showP r ++ ")" \\ l++-- instance (TestOb a, TestOb b, Testable k, TestObIsOb k) => TestableType (Span a (b :: SPAN k)) where+instance (TestOb a, TestOb b) => TestableType (Span a (b :: SPAN FINSET)) where+  gen = GenNonEmpty loop+    where+      loop = do+        Some @c <- genSome @_+        case (gen @(c ~> UN SP a), gen @(c ~> UN SP b)) of+          (GenEmpty _, _) -> loop+          (_, GenEmpty _) -> loop+          (GenNonEmpty l, GenNonEmpty r) -> Span <$> l <*> r+instance TestableProfunctor (Span :: CAT (SPAN FINSET))
+ test/Props/Svg.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The SVG diagrams mean what the Dot diagrams they carry mean, so their laws are checked with+-- Dot's equality. Drawing is checked only by rendering every law, with the default options and+-- with every option switched.+module Props.Svg where++import Control.Monad (forM_, replicateM, when)+import Data.List qualified as List+import Test.Falsify (testFailed)+import Test.Falsify.Generator (elem)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (Monoid, elem, id, (.))++import Proarrow.Category.Monoidal (Monoidal, SymMonoidal, SymMonoidalStructures, withOb2)+import Proarrow.Category.Monoidal.Closed (ClosedStructures)+import Proarrow.Category.Monoidal.CompactClosed (CompactClosedStructures)+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscardStructures)+import Proarrow.Category.Monoidal.Hypergraph (FrobeniusStructures)+import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomousStructures)+import Proarrow.Category.Monoidal.Strength (TracedStructures)+import Proarrow.Category.Monoidal.Strictified (IsList (..))+import Proarrow.Core (CategoryOf (..), Promonad (..), UN)+import Proarrow.Monoid (CocommutativeComonoid, CommutativeMonoid, Comonoid, Monoid, Supplies)+import Proarrow.Tools.Diagrams.Svg+  ( KnownWire+  , Options (..)+  , SVG (..)+  , Svg (..)+  , W (..)+  , defaultOptions+  , lawSvgsWith+  , node+  , wires+  , withIsListErase+  )++import Proarrow.Testing+  ( Some (..)+  , Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , pattern GenNonEmpty+  )+import Proarrow.Testing.Laws+import Props.Dot (boxes)++test :: TestTree+test =+  testGroup+    "Svg"+    [ testCategory @SVG+    , testMonoidal_ @SVG+    , testSymMonoidal_ @SVG+    , testCopyDiscard_ @SVG+    , testMonoid_ @(S '[Wire "A"])+    , testMonoid_ @(S '[Wire "A", Co "B"])+    , testComonoid_ @(S '[Wire "A", I, Co "B"])+    , testHypergraph @SVG (\ @a @b r -> withOb2 @SVG @a @b r)+    , testClosed_ @SVG+    , testStarAutonomous_ @SVG+    , testCompactClosed_ @SVG+    , testTraced_ @SVG+    , testProperty "every law draws as an equation" $ do+        let everything = Options{explicitIdentities = True, explicitCoherence = True, explicitSwaps = True, fixedSpiders = False}+            structures :: [[(String, String)]]+            structures =+              [ drawn+              | o <- [defaultOptions, everything]+              , drawn <-+                  [ lawSvgsWith @'[CategoryOf] o+                  , lawSvgsWith @'[Monoidal] o+                  , lawSvgsWith @SymMonoidalStructures o+                  , lawSvgsWith @ClosedStructures o+                  , lawSvgsWith @StarAutonomousStructures o+                  , lawSvgsWith @CompactClosedStructures o+                  , lawSvgsWith @'[Monoidal, Supplies Monoid] o+                  , lawSvgsWith @'[Monoidal, Supplies Comonoid] o+                  , lawSvgsWith @'[Monoidal, SymMonoidal, Supplies CommutativeMonoid] o+                  , lawSvgsWith @'[Monoidal, SymMonoidal, Supplies CocommutativeComonoid] o+                  , lawSvgsWith @FrobeniusStructures o+                  , lawSvgsWith @TracedStructures o+                  , lawSvgsWith @CopyDiscardStructures o+                  ]+              ]+        forM_ structures \drawn -> do+          when (null drawn) (testFailed "a structure drew no laws")+          -- reads every character of the drawing, so its layout is computed in full+          forM_ drawn \(name, d) ->+            when (count '<' d == 0 || count '<' d /= count '>' d) (testFailed (name ++ " drew malformed markup"))+    ]++-- | A wire of the palette objects are drawn from.+data SomeWire where+  SomeWire :: forall (w :: W). (KnownWire w) => SomeWire++-- | Up to two wires, each a plain wire, a dual wire or the unit wire, so that the laws are checked+-- where the meaning leaves wires out or forgets that they are dual.+instance Testable SVG where+  genSome = do+    num <- elem [0 .. 2]+    ws <- replicateM num (elem [SomeWire @(Wire "A"), SomeWire @(Wire "B"), SomeWire @(Co "A"), SomeWire @I])+    pure (foldWires ws)+  showOb @ws = List.intercalate "," $ map fst $ wires @(UN S ws)++foldWires :: [SomeWire] -> Some SVG+foldWires [] = Some @(S '[])+foldWires [SomeWire @w] = Some @(S '[w])+foldWires (SomeWire @w : rest) = case foldWires rest of+  Some @(S ws) -> withIsList2 @'[w] @ws (Some @(S (w ': ws)))++instance (Ob a, Ob b) => TestingEqShow (Svg a b) where+  eqP (Svg @as @bs l _) (Svg r _) = withIsListErase @as $ withIsListErase @bs $ eqP l r++-- | Boxes through the library's own operations, as for Dot.+instance (Ob a, Ob b) => TestableType (Svg a b) where+  gen = GenNonEmpty (boxes @a @b \ @x @y -> node @(UN S x) @(UN S y))++instance TestableProfunctor Svg++-- | How often a character occurs in a string.+count :: Char -> String -> Int+count c = length . filter (== c)
+ test/Props/ZX.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedLists #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Props.ZX where++import Data.Complex (Complex (..))+import Data.Map.Strict qualified as Map+import GHC.TypeNats (Nat)+import Test.Falsify.Generator (elem)+import Test.Tasty (TestTree, testGroup)+import Prelude hiding (elem, repeat)++import Proarrow.Category.Instance.ZX (ZX (..), enumAll, isZero, nat)+import Proarrow.Testing+  ( Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , genSomeDef+  , pattern GenNonEmpty+  )+import Proarrow.Testing.Laws++test :: TestTree+test =+  testGroup+    "ZX calculus"+    [ testCategory @Nat+    , testDagger @Nat+    , testMonoidal_ @Nat+    , testHypergraph_ @Nat+    , testSymMonoidal_ @Nat+    , testClosed_ @Nat+    , testCompactClosed_ @Nat+    , testTraced_ @Nat+    , testStarAutonomous_ @Nat+    , testCopyDiscard_ @Nat+    , testCommutativeMonoid_ @0+    , testCommutativeMonoid_ @1+    , testCommutativeMonoid_ @2+    , testCommutativeMonoid_ @3+    , testCocommutativeComonoid_ @0+    , testCocommutativeComonoid_ @1+    , testCocommutativeComonoid_ @2+    , testCocommutativeComonoid_ @3+    ]++instance Testable Nat where+  showOb @n = show $ nat @n+  genSome = genSomeDef @'[0, 1, 2]++instance (TestOb n, TestOb m) => TestableType (ZX n m) where+  gen = GenNonEmpty $ do+    let valGen = elem [-1, -sqrt 2, -0.5, 0, 0.5, sqrt 2, 1]+    let matrix = Map.fromList [((o, i), liftA2 (:+) valGen valGen) | o <- enumAll @m, i <- enumAll @n]+    ZX <$> sequenceA matrix+instance (TestOb n, TestOb m) => TestingEqShow (ZX n m) where+  eqP (ZX l) (ZX r) = pure $ all isZero (l Map.\\ r) && all isZero (r Map.\\ l) && all isZero (Map.intersectionWith (-) l r)+instance TestableProfunctor ZX
+ testing/Proarrow/Testing.hs view
@@ -0,0 +1,844 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE RequiredTypeArguments #-}++-- | Generic property-testing infrastructure for categories: 'Testable' says how to generate and+-- enumerate the objects of a kind, 'TestableProfunctor' and 'TestableType' how to generate values+-- (using @falsify@ generators), and 'TestingEqShow' provides semantic equality and display for+-- values without useful structural 'Eq'\/'Show' (functions, opaque morphisms). Instances for your+-- own category plus the law checks in "Proarrow.Testing.Laws" give it a test suite.+module Proarrow.Testing+  ( -- * Describing a category+    Testable (..)+  , TestableProfunctor (..)+  , TestableType (..)+  , TestableTypeP+  , TestingEqShow (..)+  , TestObIsOb+  , TestOb'+  , obFromTestOb++    -- * Objecthood witnesses+  , WithTestOb+  , WithTestOb2+  , WithTestObProd+  , WithTestObCoprod+  , WithTestObExp+  , WithTestObDual+  , WithTestObRep+  , WithTestObCorep++    -- * Objects+  , Some (..)+  , mapSome+  , genOb+  , genObSmall+  , genObSuchThat+  , genObSuchThatWith+  , genSomeDef+  , genSomeFinite+  , genSomeList+  , MkSomeList (..)++    -- * Profunctor elements+  , SomeProfunctorElt (..)+  , someP++    -- * Generators++    -- | @falsify@ generators, wrapped so that an empty type is a first-class case rather than a+    -- generator that fails at run time: match 'GenEmpty' first, then 'GenNonEmpty'. The two are a+    -- @COMPLETE@ set. The representation behind 'GenNonEmpty' is not exported on purpose. Go+    -- through the pattern, which is total.+  , GenTotal (GenEmpty)+  , pattern GenNonEmpty+  , invmap+  , isGenNonEmpty+  , optGen+  , oneElem+  , genBoth+  , genElements+  , oneOfTotal+  , genP+  , genNamed+  , genWithNamed+  , genSuchThat+  , someElem+  , someElemNamed+  , someElemWith++    -- * Generating functions++    -- | 'ShowP' supplies the 'Show' instance @falsify@ needs on both parameters of a generated+    -- 'Test.Falsify.Fun', derived from 'showP'; 'applyFunP' unwraps on the way back out.+  , ShowP (..)+  , applyFunP++    -- * Assertions+  , expect+  , testEq+  , eqHask++    -- * Interactive debugging++    -- | Run a generator once in @ghci@ and print what it produced. These trace to stdout and are+    -- for exploring a generator by hand, not for use inside a test.+  , sampleT+  , sampleP+  , sampleK+  ) where++import Data.Falsify.ConcreteFun qualified as ConcreteFun+import Data.Kind (Constraint, Type)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe (mapMaybe)+import GHC.Exts qualified as GHC+import Test.Falsify (Fun, Property, applyFun, discard, genWith, testFailed)+import Test.Falsify.Generator (Function (..), Gen, elem, fun, minimalValue, oneof)+import Prelude hiding (elem, fst, id, snd, (.), (>>))++import Control.Applicative (Alternative (..))+import Control.Monad (ap, unless)+import Debug.Trace (traceM, traceShowM)+import Proarrow.Category.Enriched.Finitary (Finitary (..), FiniteCat, foreachOb)+import Proarrow.Category.Enriched.Finitary.Sheaf (ClosedSieve (..), Plus, plusTable, samePlus)+import Proarrow.Category.Enriched.Finitary.Topos (KnownTables, Tabulated (..), natTable, natTransformations, sieveTable)+import Proarrow.Category.Enriched.Thin (Enumerable)+import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))+import Proarrow.Category.Instance.Product (Fst, Snd, (:**:) (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Instance.Sub (SUBCAT (..), Sub (..))+import Proarrow.Category.Instance.Unit (Unit (..))+import Proarrow.Category.Monoidal qualified as M+import Proarrow.Category.Monoidal.Closed qualified as Exponential+import Proarrow.Category.Monoidal.StarAutonomous qualified as SA+import Proarrow.Category.Sheaf (HasFiniteCovers)+import Proarrow.Colimit.BinaryCoproduct qualified as BinaryCoproduct+import Proarrow.Core (CAT, CategoryOf (..), Hom, Is, OB, Profunctor (..), Promonad (..), UN, type (+->))+import Proarrow.Functor (type (@))+import Proarrow.Functor qualified as Rep+import Proarrow.Limit.BinaryProduct (PROD (..), Prod (..))+import Proarrow.Limit.BinaryProduct qualified as BinaryProduct+import Proarrow.Object (Ob')+import Proarrow.Profunctor.Corepresentable (type (%%))+import Proarrow.Profunctor.Instance.Coproduct ((:+:) (..))+import Proarrow.Profunctor.Instance.Costar (Costar, pattern Costar)+import Proarrow.Profunctor.Instance.Exponential ((:~>:) (..))+import Proarrow.Profunctor.Instance.Product (fstP, sndP, (:*:) (..))+import Proarrow.Profunctor.Instance.Ran (Ran (..))+import Proarrow.Profunctor.Instance.Rift (Rift (..))+import Proarrow.Profunctor.Instance.Sieve (Sieve)+import Proarrow.Profunctor.Instance.Star (Star, pattern Star)+import Proarrow.Profunctor.Instance.Terminal (TerminalProfunctor (..))+import Proarrow.Profunctor.Instance.Yoneda (Yo (..))+import Proarrow.Profunctor.Representable (Rep (..), type (%))+import Test.Falsify.Interactive (falsify)++data GenTotal a where+  GenEmpty :: ~(forall x. a -> x) -> GenTotal a+  GenNENonFun :: Gen a -> GenTotal a+  GenFun :: (TestableType a, TestableType b) => ((a -> b) -> p) -> Gen (Fun (ShowP a) (ShowP b)) -> GenTotal p++invmap :: (a -> b) -> (b -> a) -> GenTotal a -> GenTotal b+invmap _ f' (GenEmpty g) = GenEmpty (g . f')+invmap f _ (GenNENonFun g) = GenNENonFun (fmap f g)+invmap f _ (GenFun f' g) = GenFun (f . f') g++flatten :: GenTotal a -> Gen a+flatten (GenNENonFun g) = g+flatten (GenFun f g) = f . applyFunP <$> g+flatten (GenEmpty _) = error "flatten: Match on GenEmpty first"++pattern GenNonEmpty :: Gen a -> GenTotal a+pattern GenNonEmpty g <- (flatten -> g)+  where+    GenNonEmpty g = GenNENonFun g++{-# COMPLETE GenEmpty, GenNonEmpty #-}++instance Functor GenTotal where+  fmap f = invmap f (error "fmap GenTotal")++instance Applicative GenTotal where+  pure a = GenNENonFun (pure a)+  (<*>) = ap++instance Alternative GenTotal where+  empty = GenEmpty (error "empty")+  GenEmpty f <|> GenEmpty _ = GenEmpty f+  GenEmpty _ <|> g = g+  f <|> GenEmpty _ = f+  GenNonEmpty g <|> GenNonEmpty h = GenNonEmpty (oneof (g :| [h]))++-- | Uniformly choose among any number of alternatives, dropping the empty ones. Plain '<|>'+-- only combines two generators at 50\/50, so chaining it over more than two alternatives+-- associates pairwise and skews weight towards whichever branch ends up outermost in the+-- resulting tree. Use this whenever there are more than two alternatives to pick fairly among.+oneOfTotal :: [GenTotal a] -> GenTotal a+oneOfTotal gts = case mapMaybe toGen gts of+  [] -> empty+  g : gs -> GenNonEmpty (oneof (g :| gs))+  where+    toGen (GenEmpty _) = Nothing+    toGen (GenNonEmpty g) = Just g++instance Monad GenTotal where+  GenEmpty _ >>= _ = GenEmpty (error ">>= GenEmpty")+  GenNonEmpty g >>= f = case f (minimalValue g) of+    GenEmpty x -> GenEmpty x+    _ -> GenNonEmpty do+      p <- fmap f g+      case p of+        GenEmpty _ -> error ">>= GenEmpty"+        GenNonEmpty g' -> g'++class TestingEqShow a where+  eqP :: a -> a -> Property Bool+  default eqP :: (Eq a) => a -> a -> Property Bool+  eqP l r = pure (l == r)+  showP :: a -> String+  default showP :: (Show a) => a -> String+  showP = show++class (TestingEqShow a) => TestableType a where+  gen :: GenTotal a++-- | Supplies a 'Show' instance derived from 'showP'.+--+-- falsify's 'Show' instance for 'Fun' needs 'Show' on both parameters, and we+-- only ever have 'TestingEqShow'. Rather than reinterpret a @'Fun' a b@ at the+-- wrapped type after the fact, @GenFun@ generates at+-- @'Fun' ('ShowP' a) ('ShowP' b)@ from the start, so 'show' applies directly and+-- no coercion is involved. 'applyFunP' unwraps on the way back out.+newtype ShowP a = ShowP {unShowP :: a}++instance (TestingEqShow a) => Show (ShowP a) where+  show (ShowP a) = showP a++instance (Function a) => Function (ShowP a) where+  function = fmap (ConcreteFun.map unShowP ShowP) . function++-- | Apply a generated function, wrapping and unwrapping the 'ShowP' it was+-- generated at. Both directions are ordinary newtype constructor applications.+applyFunP :: Fun (ShowP a) (ShowP b) -> a -> b+applyFunP f = unShowP . applyFun f . ShowP++genP :: (TestableType a) => Property a+genP = case gen of+  GenNENonFun g -> genWith (Just . showP) g+  GenFun f g -> f . applyFunP <$> genWith (Just . show) g+  GenEmpty _ -> discard++genNamed :: (TestableType a) => String -> Property a+genNamed nm = case gen of+  GenNENonFun g -> genWithNamed nm (Just . showP) g+  GenFun f g -> f . applyFunP <$> genWithNamed nm (Just . show) g+  GenEmpty _ -> discard++-- | Check a measured value against the expected one, showing both. For the assertions a worked+-- example makes, which no generic law-checking property covers.+expect :: (Eq a, Show a) => String -> a -> a -> Property ()+expect what want got = unless (got == want) (testFailed (what ++ ", found " ++ show got ++ ", expected " ++ show want))++-- | Check that two values are semantically equal, naming both sides so a failure says which law+-- broke and what the two sides came out as.+testEq :: (TestingEqShow a) => String -> String -> a -> String -> a -> Property ()+testEq nm sl l sr r = do+  isEq <- eqP l r+  unless isEq $+    testFailed $+      "Failed "+        ++ nm+        ++ ":\n"+        ++ sl+        ++ " = "+        ++ showP l+        ++ "\n"+        ++ sr+        ++ " = "+        ++ showP r++genWithNamed :: String -> (a -> Maybe String) -> Gen a -> Property a+genWithNamed nm f = genWith (fmap named . f)+  where+    named s = "for " ++ nm ++ ": " ++ s++-- | 'True' if a type's generator is non-empty. A pure check on 'TestableType's 'gen'. It+-- doesn't sample anything, so it is cheap to call as often as convenient, e.g. once in a+-- 'genSuchThat' predicate and again in the 'gen'\/'genNamed' call that produces a value.+isGenNonEmpty :: forall a. (TestableType a) => Bool+isGenNonEmpty = case gen @a of+  GenEmpty _ -> False+  _ -> True++-- | Resample @genKey@ (cheaply, within 'Gen') up to @maxTries@ times until @isUsable@ accepts+-- the draw, before ever asking 'Property' to commit to a choice.+--+-- A 'Property'-level 'discard' restarts the whole property and can trip falsify's discard-ratio+-- limit, aborting the run. So when a later dependent draw (e.g. \"a morphism out of this+-- object\") is likely to be empty for a bad choice, reject that choice here. After @maxTries@ the+-- last draw is returned anyway, and the caller's own 'discard' handles it.+genSuchThat :: Gen key -> (key -> Bool) -> Gen key+genSuchThat genKey isUsable = go maxTries+  where+    go n = do+      k <- genKey+      if isUsable k || n <= (0 :: Int) then pure k else go (n - 1)++-- | How many times 'genSuchThat' resamples before giving up. There is no principled formula+-- for this, since it depends on how sparse the requirement being searched for is, which+-- 'genSuchThat' cannot know in advance. 100 is comfortably more than the number of candidates a+-- small test object palette usually offers, so a single unlucky pick is very unlikely to exhaust+-- it. It is still cheap, since each attempt is a plain 'Gen' sample and not a 'Property'-level+-- 'discard'.+maxTries :: Int+maxTries = 100++-- | 'genOb', but resampled (see 'genSuchThat') until @isUsable@ accepts the object.+genObSuchThat :: forall k. (Testable k) => (Some k -> Bool) -> Property (Some k)+genObSuchThat = genObSuchThatWith (genSome @k)++-- | 'genObSuchThat' with objects drawn from the given generator, e.g. 'genSomeSmall'.+genObSuchThatWith :: forall k. (Testable k) => Gen (Some k) -> (Some k -> Bool) -> Property (Some k)+genObSuchThatWith objects = genWith (Just . show) . genSuchThat objects++type SomeProfunctorElt :: (j +-> k) -> Type+data SomeProfunctorElt p where+  SomeP :: (TestOb a, TestOb b) => p a b -> SomeProfunctorElt p++someP :: forall {k} {j} (p :: k +-> j) a b. (Profunctor p, TestObIsOb j, TestObIsOb k) => p a b -> SomeProfunctorElt p+someP p = SomeP p \\ p++instance+  (forall a b. (TestOb (a :: k), TestOb (b :: j)) => TestingEqShow (p a b), Testable k, Testable j)+  => Show (SomeProfunctorElt p)+  where+  show (SomeP @a @b p) = showP p ++ " @" ++ showOb @k @a ++ " @" ++ showOb @j @b++type TestableTypeP :: (j +-> k) -> Constraint+class (forall a b. (TestOb (a :: k), TestOb (b :: j)) => TestableType (p a b)) => TestableTypeP (p :: j +-> k)+instance (forall a b. (TestOb (a :: k), TestOb (b :: j)) => TestableType (p a b)) => TestableTypeP (p :: j +-> k)++type TestableProfunctor :: forall {j} {k}. j +-> k -> Constraint+class+  (Testable j, Testable k, Profunctor p, forall a b. (TestOb (a :: k), TestOb (b :: j)) => TestingEqShow (p a b)) =>+  TestableProfunctor (p :: j +-> k)+  where+  -- | The default implementation generates an object @a@, then an object @b@ for which @p a b@+  -- has elements (see 'genObSuchThat'), and then a value of type @p a b@.+  genProfunctorElt :: String -> Property (SomeProfunctorElt p)+  default genProfunctorElt :: (TestableTypeP p) => String -> Property (SomeProfunctorElt p)+  genProfunctorElt nm = do+    Some @a <- genOb+    Some @b <- genObSuchThat \(Some @b') -> isGenNonEmpty @(p a b')+    p <- genNamed @(p a b) nm+    pure $ SomeP p++-- | A kind whose objects can be enumerated and displayed.+class (forall (a :: k). (TestOb a) => Ob' a, TestableProfunctor (Hom k), TestableTypeP (Hom k), CategoryOf k) => Testable k where+  type TestOb (a :: k) :: GHC.Constraint+  type TestOb a = Ob a+  showOb :: forall (a :: k). (TestOb a) => String+  genSome :: Gen (Some k)++  -- | The palette for properties whose cost grows steeply with object size: in practice those+  -- that enumerate an internal hom, which is brute force over tables and doubly exponential (an+  -- object with hom-sizes @[2,4,2,4]@ has the hom into it at @[1024,256,1024,256]@). Defaults to+  -- 'genSome'. Override it only when 'genSome' draws objects too big for+  -- 'Proarrow.Testing.Laws.testClosed' to terminate.+  --+  -- An instance that wraps another kind's palette must forward this too, as the wrapper instances+  -- below do, or 'Proarrow.Testing.Laws.testClosed' silently gets the wide one.+  genSomeSmall :: Gen (Some k)+  genSomeSmall = genSome++  {-# MINIMAL showOb, genSome #-}++genOb :: (Testable k) => Property (Some k)+genOb = genWith (Just . show) genSome++-- | 'genOb' from the small palette. See 'genSomeSmall'.+genObSmall :: (Testable k) => Property (Some k)+genObSmall = genWith (Just . show) genSomeSmall++instance (TestableProfunctor p) => TestableProfunctor (Op p) where+  genProfunctorElt nm = do+    SomeP p <- genProfunctorElt @p nm+    pure $ SomeP (Op p)+instance (Testable k) => Testable (OPPOSITE k) where+  type TestOb a = (Is OP a, TestOb (UN OP a))+  showOb @(OP a) = "OP (" ++ showOb @k @a ++ ")"+  genSome = mapSome OP <$> genSome+  genSomeSmall = mapSome OP <$> genSomeSmall++-- | The 'PROD' wrapper changes only which tensor a kind carries, so everything transports across it.+instance (TestableProfunctor p) => TestableProfunctor (Prod p) where+  genProfunctorElt nm = do+    SomeP p <- genProfunctorElt @p nm+    pure $ SomeP (Prod p)++instance (Testable k) => Testable (PROD k) where+  type TestOb a = (Is PR a, TestOb (UN PR a))+  showOb @(PR a) = "PR (" ++ showOb @k @a ++ ")"+  genSome = mapSome PR <$> genSome+  genSomeSmall = mapSome PR <$> genSomeSmall++instance TestableProfunctor Unit+instance Testable () where+  showOb = "()"+  genSome = pure (Some @'())++instance (TestableProfunctor p, TestableProfunctor q) => TestableProfunctor (p :**: q) where+  genProfunctorElt nm = do+    SomeP p <- genProfunctorElt @p (nm ++ "_0")+    SomeP q <- genProfunctorElt @q (nm ++ "_1")+    pure $ SomeP (p :**: q)+instance (Testable j, Testable k) => Testable (j, k) where+  type TestOb a = (a ~ '(Fst @ a, Snd @ a), TestOb (Fst @ a), TestOb (Snd @ a))+  showOb @'(a, b) = "(" ++ showOb @j @a ++ ", " ++ showOb @k @b ++ ")"+  genSome = do+    Some @a <- genSome @j+    Some @b <- genSome @k+    pure $ Some @'(a, b)+  genSomeSmall = do+    Some @a <- genSomeSmall @j+    Some @b <- genSomeSmall @k+    pure $ Some @'(a, b)++class (TestOb a) => TestOb' a+instance (TestOb a) => TestOb' a++class (forall (a :: k). (Ob a) => TestOb' a) => TestObIsOb k+instance (forall (a :: k). (Ob a) => TestOb' a) => TestObIsOb k++-- | Recover @'Ob' a@ from @'TestOb' a@ (the 'Testable' superclass entailment), packaged as a+-- function so that call sites with other quantified givens in scope (e.g. the comonoid supply of a+-- 'Proarrow.Category.Monoidal.CopyDiscard.CopyDiscard' category, whose head has @Ob@ as a+-- superclass) don't have to rely on GHC expanding superclasses of quantified-constraint heads.+-- With such a given in scope, @\\r -> r@ at this type fails with "Could not deduce Ob a", while+-- the same lambda compiles without it (cf. 'Proarrow.Testing.Laws.testSymMonoidal_' versus+-- 'Proarrow.Testing.Laws.testCopyDiscard_').+obFromTestOb :: forall {k} (a :: k) r. (Testable k, TestOb a) => ((Ob a) => r) -> r+-- Seen on GHC 9.10.3, likely a solver limitation. Worth retrying without this helper after a+-- GHC upgrade.+obFromTestOb r = r++-- * Objecthood witnesses++-- | How 'TestOb' is closed under the structure a law-checker is about.+--+-- Every law-checker in "Proarrow.Testing.Laws" that needs one takes it as an explicit rank-2 argument, since in+-- general a category may make only some of its objects testable; the @_@-suffixed variants supply+-- the trivial witness. These synonyms only name the shapes, which would otherwise be spelled out+-- in forty-odd signatures.+type WithTestOb k = forall (a :: k) r. (Ob a) => ((TestOb a) => r) -> r++-- | @'TestOb'@ is closed under the tensor.+type WithTestOb2 k = forall (a :: k) b r. (TestOb a, TestOb b) => ((TestOb (a M.** b)) => r) -> r++-- | @'TestOb'@ is closed under the binary product.+type WithTestObProd k = forall (a :: k) b r. (TestOb a, TestOb b) => ((TestOb (a BinaryProduct.&& b)) => r) -> r++-- | @'TestOb'@ is closed under the binary coproduct.+type WithTestObCoprod k = forall (a :: k) b r. (TestOb a, TestOb b) => ((TestOb (a BinaryCoproduct.|| b)) => r) -> r++-- | @'TestOb'@ is closed under the internal hom.+type WithTestObExp k = forall (a :: k) b r. (TestOb a, TestOb b) => ((TestOb (a Exponential.~~> b)) => r) -> r++-- | @'TestOb'@ is closed under dualization.+type WithTestObDual k = forall (a :: k) r. (TestOb a) => ((TestOb (SA.Dual a)) => r) -> r++-- | @'TestOb'@ is closed under a representable profunctor.+type WithTestObRep k p = forall (a :: k) r. (TestOb a) => ((TestOb (p % a)) => r) -> r++-- | @'TestOb'@ is closed under a corepresentable profunctor.+type WithTestObCorep k p = forall (a :: k) r. (TestOb a) => ((TestOb (p %% a)) => r) -> r++data Some k where+  Some :: forall {k} a. (TestOb (a :: k)) => Some k++mapSome :: forall {j} {k}. forall (f :: j -> k) -> (forall a. (TestOb a) => TestOb' (f a)) => Some j -> Some k+mapSome f (Some @a) = Some @(f a)++class MkSomeList (as :: [k]) where+  mkSomeList :: [Some k]+instance MkSomeList '[] where+  mkSomeList = []+instance (TestOb (a :: k), MkSomeList as) => MkSomeList (a ': as) where+  mkSomeList = Some @a : mkSomeList @k @as+instance (Testable k) => Show (Some k) where+  show (Some @a) = showOb @k @a++someElem :: (Show a) => [a] -> Property a+someElem = someElemWith show++someElemNamed :: (Show a) => String -> [a] -> Property a+someElemNamed nm = someElemWith (\a -> "for " ++ nm ++ ": " ++ show a)++someElemWith :: (a -> String) -> [a] -> Property a+someElemWith _ [] = discard+someElemWith f (x : xs) = genWith (Just . f) (elem (x :| xs))++genSomeDef :: forall {k} (obs :: [k]). (Testable k, MkSomeList obs) => Gen (Some k)+genSomeDef = genSomeList "the palette is empty" (mkSomeList @k @obs)++-- | The palette of a category that already knows its own objects: @'Proarrow.Category.Enriched.Thin.Objects' k@+-- is the list 'genSomeDef' would otherwise be given by hand, and writing it twice lets the two+-- drift apart. Only for kinds that really are finite categories. A palette like \"four+-- cardinalities out of infinitely many\" is a sample, not an enumeration, and has to stay+-- hand-picked.+genSomeFinite :: forall k. (Enumerable k, TestObIsOb k) => Gen (Some k)+genSomeFinite = genSomeList "the category has no objects" (foreachOb @k \ @a -> [Some @a])++genSomeList :: String -> [Some k] -> Gen (Some k)+genSomeList what [] = error ("genSome: " ++ what)+genSomeList _ (x : xs) = elem (x :| xs)++-- | A generator for a two-component value: if either component has no values then neither does the+-- pair, and otherwise the two are drawn independently.+--+-- 'GenEmpty' carries its proof of emptiness as a function out of the empty type, so reusing a+-- component's proof for the pair means getting at that component first. Hence the two projections+-- alongside the constructor.+genBoth+  :: forall a b c. (TestableType a, TestableType b) => (a -> b -> c) -> (c -> a) -> (c -> b) -> GenTotal c+genBoth mk outl outr = case (gen @a, gen @b) of+  (GenEmpty f, _) -> GenEmpty (\c -> f (outl c))+  (_, GenEmpty g) -> GenEmpty (\c -> g (outr c))+  (GenNonEmpty ga, GenNonEmpty gb) -> GenNonEmpty (liftA2 mk ga gb)++optGen :: [a] -> GenTotal a+optGen [] = error "optGen: empty list"+optGen (x : xs) = GenNonEmpty (elem (x :| xs))++-- | Draw from a finitary profunctor's own enumeration, an empty hom-set being 'GenEmpty' rather than+-- an error: a profunctor built by the library can be empty at a pair of objects with nothing wrong.+-- For a hand-written fixture prefer a palette of its own. 'Proarrow.Testing.Laws.testFinitary'+-- says why a generator that /is/ the enumeration makes the round-trip law vacuous.+genElements :: forall {j} {k} (p :: j +-> k) (a :: k) (b :: j). (Finitary p, Ob a, Ob b) => GenTotal (p a b)+genElements = case elements @p @a @b of+  [] -> GenEmpty \_ -> error "genElements: no elements at these objects"+  xs -> optGen xs++oneElem :: a -> GenTotal a+oneElem x = GenNonEmpty (pure x)++instance (TestableType a, TestingEqShow b) => TestingEqShow (a -> b) where+  eqP = eqHask+  showP _ = "<function>"++instance (Function a, TestableType a, TestableType b) => TestableType (a -> b) where+  gen = case gen @b of+    GenEmpty absurd -> case gen @a of+      GenEmpty absurda -> oneElem absurda+      GenNonEmpty g -> GenEmpty \ab -> absurd (ab (minimalValue g))+    GenNonEmpty gb -> GenFun id (fun (ShowP <$> gb))++eqHask :: (TestableType a, TestingEqShow b) => (a -> b) -> (a -> b) -> Property Bool+eqHask l r =+  case gen of+    GenEmpty _ -> pure True -- There can only be one function of a type with no values+    GenNonEmpty ga -> do+      a <- genWith (Just . showP) ga+      eqP (l a) (r a)++instance (TestableType (p a b)) => TestableType (Prod p (PR a) (PR b)) where+  gen = invmap Prod unProd gen+instance (TestingEqShow (p a b)) => TestingEqShow (Prod p (PR a) (PR b)) where+  eqP (Prod l) (Prod r) = eqP l r+  showP (Prod p) = "Prod (" ++ showP p ++ ")"++instance (TestableType (p b a)) => TestableType (Op p (OP a) (OP b)) where+  gen = invmap Op unOp gen+instance (TestingEqShow (p b a)) => TestingEqShow (Op p (OP a) (OP b)) where+  eqP (Op l) (Op r) = eqP l r+  showP (Op p) = "Op (" ++ showP p ++ ")"++-- | The elements of 'Star' and 'Costar' are arrows, and are compared, shown and drawn as those.+instance (TestingEqShow (a ~> f b)) => TestingEqShow (Star f a b) where+  eqP (Star l) (Star r) = eqP l r+  showP (Star f) = showP f++instance (Ob b, TestableType (a ~> f b)) => TestableType (Star f a b) where+  gen = invmap Star (\(Star f) -> f) gen++instance (TestingEqShow (f a ~> b)) => TestingEqShow (Costar f a b) where+  eqP (Costar l) (Costar r) = eqP l r+  showP (Costar f) = showP f++instance (Ob a, TestableType (f a ~> b)) => TestableType (Costar f a b) where+  gen = invmap Costar (\(Costar f) -> f) gen++instance (TestableType (a ~> (f Rep.@ b)), Ob b) => TestableType (Rep f a b) where+  gen = invmap Rep unRep (gen @(a ~> f Rep.@ b))+instance (TestingEqShow (a ~> (f Rep.@ b)), Ob b) => TestingEqShow (Rep f a b) where+  eqP (Rep l) (Rep r) = eqP l r+  showP (Rep p) = showP p++instance (TestingEqShow (catk a1 b1), TestingEqShow (catj a2 b2)) => TestingEqShow ((catk :**: catj) '(a1, a2) '(b1, b2)) where+  eqP (l1 :**: l2) (r1 :**: r2) = liftA2 (&&) (eqP l1 r1) (eqP l2 r2)+  showP (l1 :**: l2) = "(" ++ showP l1 ++ ") :**: (" ++ showP l2 ++ ")"+instance (TestableType (catk a1 b1), TestableType (catj a2 b2)) => TestableType ((catk :**: catj) '(a1, a2) '(b1, b2)) where+  gen = genBoth (:**:) fstK sndK++-- | An element of a product of profunctors is a pair of elements.+instance (TestingEqShow (p a b), TestingEqShow (q a b)) => TestingEqShow ((p :*: q) a b) where+  eqP (l1 :*: l2) (r1 :*: r2) = liftA2 (&&) (eqP l1 r1) (eqP l2 r2)+  showP (l :*: r) = "(" ++ showP l ++ ") :*: (" ++ showP r ++ ")"++instance (TestableType (p a b), TestableType (q a b)) => TestableType ((p :*: q) a b) where+  gen = genBoth (:*:) fstP sndP++instance+  (TestableProfunctor p, TestableProfunctor q, TestableTypeP p, TestableTypeP q)+  => TestableProfunctor (p :*: q)++-- | An element of a coproduct of profunctors is an element of one side, tagged.+instance (TestingEqShow (p a b), TestingEqShow (q a b)) => TestingEqShow ((p :+: q) a b) where+  eqP (InjL l) (InjL r) = eqP l r+  eqP (InjR l) (InjR r) = eqP l r+  eqP _ _ = pure False+  showP (InjL l) = "InjL (" ++ showP l ++ ")"+  showP (InjR r) = "InjR (" ++ showP r ++ ")"++instance (TestableType (p a b), TestableType (q a b)) => TestableType ((p :+: q) a b) where+  gen = case (gen @(p a b), gen @(q a b)) of+    (GenEmpty f, GenEmpty g) -> GenEmpty \case InjL l -> f l; InjR r -> g r+    (GenEmpty _, GenNonEmpty gr) -> GenNonEmpty (InjR <$> gr)+    (GenNonEmpty gl, GenEmpty _) -> GenNonEmpty (InjL <$> gl)+    (GenNonEmpty gl, GenNonEmpty gr) -> GenNonEmpty (oneof ((InjL <$> gl) :| [InjR <$> gr]))++instance+  (TestableProfunctor p, TestableProfunctor q, TestableTypeP p, TestableTypeP q)+  => TestableProfunctor (p :+: q)++-- | A 'Tabulated' value is its index, so equality and display are the index's.+instance TestingEqShow (Tabulated t lm rm a b) where+  eqP (Tabulated i) (Tabulated j) = pure (i == j)+  showP (Tabulated i) = show i++instance+  ( Testable j+  , Testable k+  , FiniteCat j+  , FiniteCat k+  , KnownTables j k lm rm+  , TestOb (a :: k)+  , TestOb (b :: j)+  )+  => TestableType (Tabulated t lm rm a b)+  where+  gen = obFromTestOb @a (obFromTestOb @b (genElements @(Tabulated t lm rm)))++instance+  ( Testable j+  , Testable k+  , FiniteCat j+  , FiniteCat k+  , KnownTables j k lm rm+  )+  => TestableProfunctor (Tabulated t lm rm :: j +-> k)++-- | The terminal profunctor has one element at every pair of objects.+instance TestingEqShow (TerminalProfunctor a b) where+  -- forcing is the one thing left to check+  eqP l r = l `seq` r `seq` pure True+  showP _ = "TerminalProfunctor"++instance (Testable j, Testable k, TestOb (a :: k), TestOb (b :: j)) => TestableType (TerminalProfunctor a b) where+  gen = obFromTestOb @a (obFromTestOb @b (oneElem TerminalProfunctor))++instance (Testable j, Testable k) => TestableProfunctor (TerminalProfunctor :: j +-> k)++-- | An element of the Yoneda embedding is an arrow into @x@ paired with an arrow out of @b@, so it+-- is testable wherever both categories are. So a representable can be used as a test fixture, at+-- either variance.+instance+  (Testable j, Testable k, TestOb (a :: k), TestOb (x :: k), TestOb (b :: j), TestOb (c :: j))+  => TestingEqShow (Yo x (OP b) a c)+  where+  eqP (Yo f h) (Yo g i) = liftA2 (&&) (eqP f g) (eqP h i)+  showP (Yo f h) = "Yo (" ++ showP f ++ ") (" ++ showP h ++ ")"++instance+  (Testable j, Testable k, TestOb (a :: k), TestOb (x :: k), TestOb (b :: j), TestOb (c :: j))+  => TestableType (Yo x (OP b) a c)+  where+  gen = genBoth Yo (\(Yo l _) -> l) (\(Yo _ r) -> r)++instance (Testable j, Testable k, TestOb (x :: k), TestOb (b :: j)) => TestableProfunctor (Yo x (OP b))++-- | A sieve is a table of booleans over the points of the representable, and 'Finitary' numbers the+-- sieves at each pair of objects. So a sieve can be generated by picking one, and compared and+-- shown by its table. Without this, nothing that quantifies over sieves as elements of a+-- profunctor (such as 'Proarrow.Testing.Laws.propNaturalTransformation') can run at 'Sieve'.+--+-- Drawing one enumerates /every/ sieve at that pair of objects, a count exponential in the size of+-- the representable, so this is the generator to look at first if a suite gets slow.+--+-- The 'TestOb' constraints pin @j@ and @k@, which @'Sieve' a b@ does not mention.+instance (FiniteCat j, FiniteCat k, TestOb (a :: k), TestOb (b :: j)) => TestingEqShow (Sieve a b) where+  eqP s t = pure (sieveTable s == sieveTable t)+  showP s = show (sieveTable s)++instance+  (Testable j, Testable k, FiniteCat j, FiniteCat k, TestOb (a :: k), TestOb (b :: j))+  => TestableType (Sieve a b)+  where+  gen = obFromTestOb @a (obFromTestOb @b (genElements @(Sieve :: j +-> k)))++instance (Testable j, Testable k, FiniteCat j, FiniteCat k) => TestableProfunctor (Sieve :: j +-> k)++-- | An element of the internal hom is a natural transformation out of a weight, which 'Finitary'+-- numbers; compare and show it by that number, as 'Tabulated' is. Drawing one enumerates them+-- all, so an exponential is expensive to quantify over.+instance+  (Finitary p, Finitary q, FiniteCat j, FiniteCat k, TestOb (a :: k), TestOb (b :: j))+  => TestingEqShow ((p :~>: q) a b)+  where+  -- matching on 'Exp' brings the objects into scope, as it does for 'Sieve'+  eqP x@Exp{} y = pure (toIndex @(p :~>: q) x == toIndex y)+  showP x@Exp{} = show (toIndex @(p :~>: q) x)++instance+  (Testable j, Testable k, Finitary p, Finitary q, FiniteCat j, FiniteCat k, TestOb (a :: k), TestOb (b :: j))+  => TestableType ((p :~>: q) a b)+  where+  gen = obFromTestOb @a (obFromTestOb @b (genElements @(p :~>: q)))++instance+  (Testable j, Testable k, Finitary p, Finitary q, FiniteCat j, FiniteCat k)+  => TestableProfunctor (p :~>: q :: j +-> k)++-- | A natural transformation between finitary profunctors, compared and shown by its table and+-- drawn from 'natTransformations'. The hom-sets of a category of finitary profunctors, with or+-- without the 'SUBCAT' wrapper.+instance (Finitary p, Finitary q, FiniteCat j, FiniteCat k) => TestingEqShow (Prof (p :: j +-> k) q) where+  eqP (Prof f) (Prof g) = pure (natTable @p @q f == natTable @p @q g)+  showP (Prof f) = show (natTable @p @q f)++instance (Finitary p, Finitary q, FiniteCat j, FiniteCat k) => TestableType (Prof (p :: j +-> k) q) where+  gen = case natTransformations @p @q of+    [] -> GenEmpty \_ -> error "no natural transformations between these profunctors"+    fs -> optGen fs++-- | The right Kan lift and extension of finitary profunctors, compared and shown by index, as the+-- internal hom is.+instance+  (Testable j, Testable k, Finitary w, Finitary p, FiniteCat i, FiniteCat j, TestOb (a :: k), TestOb (b :: j))+  => TestingEqShow (Rift (OP (w :: k +-> i)) p a b)+  where+  eqP x@Rift{} y = pure (toIndex @(Rift (OP w) p) x == toIndex y)+  showP x@Rift{} = show (toIndex @(Rift (OP w) p) x)++instance+  (Testable j, Testable k, Finitary w, Finitary p, FiniteCat i, FiniteCat j, TestOb (a :: k), TestOb (b :: j))+  => TestableType (Rift (OP (w :: k +-> i)) p a b)+  where+  gen = obFromTestOb @a (obFromTestOb @b (genElements @(Rift (OP w) p)))++instance+  (Testable j, Testable k, Finitary w, Finitary p, FiniteCat i, FiniteCat j)+  => TestableProfunctor (Rift (OP (w :: k +-> i)) p :: j +-> k)++instance+  (Testable j, Testable k, Finitary v, Finitary p, FiniteCat i, FiniteCat k, TestOb (a :: k), TestOb (b :: j))+  => TestingEqShow (Ran (OP (v :: i +-> j)) p a b)+  where+  eqP x@Ran{} y = pure (toIndex @(Ran (OP v) p) x == toIndex y)+  showP x@Ran{} = show (toIndex @(Ran (OP v) p) x)++instance+  (Testable j, Testable k, Finitary v, Finitary p, FiniteCat i, FiniteCat k, TestOb (a :: k), TestOb (b :: j))+  => TestableType (Ran (OP (v :: i +-> j)) p a b)+  where+  gen = obFromTestOb @a (obFromTestOb @b (genElements @(Ran (OP v) p)))++instance+  (Testable j, Testable k, Finitary v, Finitary p, FiniteCat i, FiniteCat k)+  => TestableProfunctor (Ran (OP (v :: i +-> j)) p :: j +-> k)++-- | A closed sieve is a sieve, and is compared and shown as one. Drawing one is dearer still than+-- drawing a sieve: the closed ones are found by taking the 'closure' of every sieve at the pair.+instance (FiniteCat j, FiniteCat k, TestOb (a :: k), TestOb (b :: j)) => TestingEqShow (ClosedSieve t a b) where+  eqP (ClosedSieve s) (ClosedSieve u) = eqP s u+  showP (ClosedSieve s) = showP s++instance+  ( Testable j+  , Testable k+  , HasFiniteCovers t k+  , FiniteCat j+  , FiniteCat k+  , TestOb (a :: k)+  , TestOb (b :: j)+  )+  => TestableType (ClosedSieve t a b)+  where+  gen = obFromTestOb @a (obFromTestOb @b (genElements @(ClosedSieve t :: j +-> k)))++instance+  (Testable j, Testable k, HasFiniteCovers t k, FiniteCat j, FiniteCat k)+  => TestableProfunctor (ClosedSieve t :: j +-> k)++-- | Compared by 'samePlus' and shown by 'plusTable'. See 'Plus' for what a value stands for.+instance+-- as for 'Sieve', the 'TestOb's are what pin @j@ and @k@+  (HasFiniteCovers t k, Finitary p, FiniteCat j, FiniteCat k, TestOb (a :: k), TestOb (b :: j))+  => TestingEqShow (Plus t p a b)+  where+  eqP x y = pure (samePlus x y)+  showP x = show (plusTable x)++instance+  (Testable j, Testable k, HasFiniteCovers t k, Finitary p, FiniteCat j, FiniteCat k, TestOb (a :: k), TestOb (b :: j))+  => TestableType (Plus t p a b)+  where+  gen = obFromTestOb @a (obFromTestOb @b (genElements @(Plus t p :: j +-> k)))++instance+  (Testable j, Testable k, HasFiniteCovers t k, Finitary p, FiniteCat j, FiniteCat k)+  => TestableProfunctor (Plus t p :: j +-> k)++-- | A hom-set of a full subcategory of finitary profunctors ('FINITARY', or the sheaves of+-- "Proarrow.Category.Enriched.Finitary.Sheaf") is enumerable, by 'natTransformations', so it can+-- be generated. Without that a category of profunctors would not be testable at all. Equality and+-- display go through the table of indices, there being nothing else to see of a natural+-- transformation. (The table is cheaper than the index into 'elements' would be, which has to+-- search for it.)+instance+  (Finitary p, Finitary q, FiniteCat j, FiniteCat k)+  => TestingEqShow (Sub Prof (SUB p :: SUBCAT (ob :: OB (j +-> k))) (SUB q))+  where+  eqP (Sub l) (Sub r) = eqP l r+  showP (Sub f) = showP f++instance+  (Finitary (Sub Prof :: CAT (SUBCAT ob)), Finitary p, Finitary q, FiniteCat j, FiniteCat k, ob p, ob q)+  => TestableType (Sub Prof (SUB p :: SUBCAT (ob :: OB (j +-> k))) (SUB q))+  where+  -- a hom-set is empty whenever @q@ runs out of elements where @p@ has some, and then the+  -- properties discard rather than fail+  gen = genElements @(Sub Prof) @(SUB p) @(SUB q)++instance (Ob a, Ob b) => TestableType (Unit a b) where+  gen = oneElem Unit+instance TestingEqShow (Unit a b) where+  showP _ = "Unit"++  -- a singleton, so equality is free; forcing is the one thing left to check+  eqP l r = l `seq` r `seq` pure True++sampleT :: forall t. (TestableType t) => IO (Maybe String)+sampleT = falsify $ do+  p <- genP @t+  traceM (showP p)++sampleP :: forall {j} {k} (p :: j +-> k). (Testable j, Testable k, TestableProfunctor p) => IO (Maybe String)+sampleP = falsify $ do+  p <- genProfunctorElt @p "p"+  traceShowM p++sampleK :: forall k. (Testable k) => IO (Maybe String)+sampleK = falsify @_ @() $ do+  Some @a <- genOb @k+  traceM $ showOb @k @a
+ testing/Proarrow/Testing/Laws.hs view
@@ -0,0 +1,1617 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++{- HLINT ignore "Redundant id" -}++-- | Reusable law-checking properties, parameterized over any 'Testable' kind: 'testCategory',+-- 'testMonoidal', 'testBinaryProducts', 'testClosed', and friends. Wiring a new category into a+-- test suite is a 'Testable' instance plus calls to these; the @test/Props@ directory of+-- proarrow's source repository has many examples.+--+-- A @test@ returns a 'TestTree', ready for a 'Test.Tasty.testGroup'. A @prop@ returns a+-- @'Property' ()@, to be composed into a property of your own. Where both exist (e.g. 'testMonoid'+-- and 'propMonoid'), the @test@ one wraps the @prop@ one.+--+-- Many of these take an explicit witness that 'TestOb' is closed under the structure being tested+-- (e.g. that @'TestOb' (a '**' b)@ follows from @'TestOb' a@ and @'TestOb' b@). The @_@-suffixed+-- variant (e.g. 'testMonoidal_') supplies it from a 'TestObIsOb' constraint, for categories where+-- every object is a 'TestOb', typically those that leave 'TestOb' at its @'Ob'@ default.+module Proarrow.Testing.Laws where++import Control.Monad (unless, when)+import Data.Default (def)+import Data.Foldable (for_)+import Data.List (genericLength, sort)+import Numeric.Natural (Natural)+import Test.Falsify (Property, testFailed)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (TestOptions, testProperty)+import Prelude hiding (elem, fst, id, snd, (.), (>>))++import Proarrow.Adjunction (Adjunction)+import Proarrow.Adjunction qualified as Adj+import Proarrow.Category.Enriched.Dagger qualified as Dagger+import Proarrow.Category.Enriched.Finitary qualified as Finitary+import Proarrow.Category.Enriched.Finitary.Sheaf qualified as FinSheaf+import Proarrow.Category.Enriched.Finitary.Topos qualified as FinTopos+import Proarrow.Category.Enriched.Thin qualified as Thin+import Proarrow.Category.Instance.Opposite (OPPOSITE (..))+import Proarrow.Category.Instance.Prof (Prof (..))+import Proarrow.Category.Instance.Sub (Sub (..))+import Proarrow.Category.Monoidal qualified as M+import Proarrow.Category.Monoidal.Cartesian qualified as Cartesian+import Proarrow.Category.Monoidal.Closed qualified as Exponential+import Proarrow.Category.Monoidal.CompactClosed qualified as CC+import Proarrow.Category.Monoidal.CopyDiscard qualified as CopyDiscard+import Proarrow.Category.Monoidal.Distributive qualified as Distributive+import Proarrow.Category.Monoidal.Hypergraph qualified as Hypergraph+import Proarrow.Category.Monoidal.StarAutonomous qualified as SA+import Proarrow.Category.Monoidal.Strength qualified as Strength+import Proarrow.Category.Sheaf qualified as Sheaf+import Proarrow.Category.Topos qualified as Topos+import Proarrow.Colimit.BinaryCoproduct qualified as BinaryCoproduct+import Proarrow.Colimit.Coequalizer qualified as Coequalizer+import Proarrow.Colimit.Initial qualified as Initial+import Proarrow.Colimit.Pushout qualified as Pushout+import Proarrow.Core+  ( CategoryOf (..)+  , Hom+  , Profunctor (..)+  , Promonad (..)+  , lmap+  , obj+  , rmap+  , (//)+  , (:~>)+  , type (+->)+  )+import Proarrow.Functor qualified as Functor+import Proarrow.Limit.BinaryProduct qualified as BinaryProduct+import Proarrow.Limit.Equalizer qualified as Equalizer+import Proarrow.Limit.Pullback qualified as Pullback+import Proarrow.Limit.Terminal qualified as Terminal+import Proarrow.Monoid qualified as Monoid+import Proarrow.Object (pattern Objs)+import Proarrow.Optic (ExOptic, Flip, Optic)+import Proarrow.Optic.Getter (GetterFl, review, view)+import Proarrow.Profunctor.Corepresentable (Corepresentable, coindex, withObCorep)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Ran (Ran (..))+import Proarrow.Profunctor.Instance.Rift (Rift (..))+import Proarrow.Profunctor.Instance.Sieve (Sieve (..))+import Proarrow.Profunctor.Instance.Yoneda (Yo (..))+import Proarrow.Profunctor.Representable (Representable, withObRep)+import Proarrow.Promonad qualified as Promonad+import Proarrow.Testing+  ( Some (..)+  , SomeProfunctorElt (..)+  , TestOb'+  , TestObIsOb+  , Testable (..)+  , TestableProfunctor (..)+  , TestableTypeP+  , TestingEqShow (..)+  , WithTestOb+  , WithTestOb2+  , WithTestObCoprod+  , WithTestObCorep+  , WithTestObDual+  , WithTestObExp+  , WithTestObProd+  , WithTestObRep+  , expect+  , genNamed+  , genOb+  , genObSmall+  , genObSuchThat+  , isGenNonEmpty+  , obFromTestOb+  , testEq+  )+import Proarrow.Testing.Laws.Run+  ( CorepresentedBy+  , RepresentedBy+  , TESTED+  , TestedP+  , Witness (..)+  , Witnesses (..)+  , testLaws+  , testLawsWith+  , testProLaws+  )+import Proarrow.Tools.Laws qualified as Laws++-- * Isomorphisms++-- | Two arrows are mutually inverse: @f . g = id@ and @g . f = id@.+propIso :: forall {k} (a :: k) b. (Testable k, TestOb a, TestOb b) => a ~> b -> b ~> a -> Property ()+propIso f g = do+  testEq "right inverse" "f . g" (f . g) "id" id+  testEq "left inverse" "g . f" (g . f) "id" id++-- | An optic is an isomorphism: its 'view' and 'review' are mutually inverse, by 'propIso'.+propIso'+  :: forall {k} c (a :: k) b+   . (Testable k, TestOb a, TestOb b, (Ob b) => c (ExOptic GetterFl b b), (Ob b) => c (ExOptic (Flip GetterFl) b b))+  => Optic c a a b b -> Property ()+propIso' o = propIso (view o) (review o)++-- | Two functions between the elements of @p a b@ and of @q c d@ are mutually inverse, at+-- generated elements.+propIsoP+  :: forall p q a b c d+   . (TestableTypeP p, TestableTypeP q, TestOb a, TestOb b, TestOb c, TestOb d)+  => (p a b -> q c d) -> (q c d -> p a b) -> Property ()+propIsoP f g = do+  p <- genNamed @(p a b) "p"+  testEq "left inverse" "g (f p)" (g (f p)) "p" p+  q <- genNamed @(q c d) "q"+  testEq "right inverse" "f (g q)" (f (g q)) "q" q++-- | Two natural transformations are mutually inverse: 'propIsoP' at generated objects, and each is+-- natural ('propNaturalTransformation').+propNaturalIsoP+  :: forall {j} {k} (p :: j +-> k) q+   . (TestableProfunctor p, TestableTypeP p, TestableProfunctor q, TestableTypeP q)+  => (p :~> q) -> (q :~> p) -> Property ()+propNaturalIsoP f g = do+  Some @a <- genOb @k+  Some @b <- genOb @j+  propIsoP @p @q @a @b f g+  propNaturalTransformation f+  propNaturalTransformation g++-- * Categories++-- | The category laws: 'id' is a left and right identity for @(.)@, and @(.)@ is associative.+testCategory :: forall k. (Testable k) => TestTree+testCategory = testLaws @'[CategoryOf] @k "Category" (CategoryW :& WNil)++-- | The laws of a dagger category: 'Laws.ProLaws' 'Dagger.DaggerProfunctor' at the hom profunctor,+-- so 'Dagger.dagger' is an involution and reverses composition.+testDagger :: forall k. (Testable k, Dagger.Dagger k) => TestTree+testDagger = testDaggerProfunctor @(Hom k)++-- | The 'Dagger.DaggerProfunctor' laws of @p@ stated as code: 'Dagger.dagger' is an involution that+-- reverses 'dimap'.+testDaggerProfunctor :: forall {k} (p :: k +-> k). (Dagger.DaggerProfunctor p, TestableProfunctor p) => TestTree+testDaggerProfunctor =+  testCategoryProLaws @Dagger.DaggerProfunctor @p defaultTestOptions "Dagger"++-- * Profunctors++-- | 'testProLaws' for a profunctor class whose laws need only the categories of @p@, with the given+-- options.+testCategoryProLaws+  :: forall {j} {k} cl (p :: j +-> k)+   . (Laws.ProLaws cl, TestableProfunctor p, cl (TestedP p :: TESTED '[CategoryOf] j +-> TESTED '[CategoryOf] k))+  => TestOptions -> String -> TestTree+testCategoryProLaws opts name = testProLaws @'[CategoryOf] @'[CategoryOf] @cl @p opts genSome name (CategoryW :& WNil) (CategoryW :& WNil)++-- | The falsify options of a plain 'testProperty', to adjust for one test, e.g. a larger+-- 'overrideMaxRatio' where a law's arrows rarely exist.+defaultTestOptions :: TestOptions+defaultTestOptions = def++-- | The profunctor laws of @p@ stated as code ('Laws.ProLaws' 'Profunctor').+testProfunctor :: forall {j} {k} (p :: j +-> k). (TestableProfunctor p) => TestTree+testProfunctor = testProfunctorWith @p defaultTestOptions++-- | 'testProfunctor' with the given falsify options for each law.+testProfunctorWith :: forall {j} {k} (p :: j +-> k). (TestableProfunctor p) => TestOptions -> TestTree+testProfunctorWith opts =+  testCategoryProLaws @Profunctor @p opts "Profunctor"++-- | 'Thin.decide' agrees with the generator: an element of @p a b@ can be generated exactly+-- when @'Thin.Holds' p a b@ decides to 'Proarrow.Category.Instance.Bool.TRU', and then (the+-- profunctor being thin) it is the decided element.+propDecidable+  :: forall {j} {k} (p :: j +-> k)+   . (Thin.DecidableProfunctor p, Testable j, Testable k, TestableTypeP p)+  => Property ()+propDecidable = do+  Some @a <- genOb @k+  Some @b <- genOb @j+  obFromTestOb @a $+    obFromTestOb @b $+      case Thin.decide @p @a @b of+        Thin.Yes x -> do+          unless (isGenNonEmpty @(p a b)) $ testFailed "decide: TRU, but no element can be generated"+          y <- genNamed @(p a b) "y"+          testEq "decide" "decide" x "y" y+        Thin.No -> when (isGenNonEmpty @(p a b)) $ testFailed "decide: FLS, but an element can be generated"++-- | A transformation @n :: p ':~>' q@ is natural: @n ('dimap' f g p) = 'dimap' f g (n p)@.+propNaturalTransformation+  :: forall {j} {k} (p :: j +-> k) q. (TestableProfunctor p, TestableProfunctor q) => p :~> q -> Property ()+propNaturalTransformation n = do+  SomeP @a @b p <- genProfunctorElt @p "p"+  -- an object with no arrow to @a@ discards the run+  Some @c <- genObSuchThat @k \(Some @c) -> isGenNonEmpty @(c ~> a)+  Some @d <- genObSuchThat @j \(Some @d) -> isGenNonEmpty @(b ~> d)+  f <- genNamed @(c ~> a) "f"+  g <- genNamed @(b ~> d) "g"+  testEq "naturality" "n (dimap f g p)" (n (dimap f g p)) "dimap f g (n p)" (dimap f g (n p))++-- | The numbering laws of a 'Finitary.Finitary' profunctor: 'Finitary.elements' has+-- 'Finitary.size' entries and is numbered in order, and 'Finitary.fromIndex' recovers any element+-- from its index ('Laws.ProLaws' 'Finitary.Finitary'), including elements the instance did not+-- itself produce. That law, @fromIndex . toIndex@, checks that 'Finitary.size' is correct and not+-- merely self-consistent, but only as far as the 'TestableType' generator is independent of the+-- instance. One defined as+-- @optGen 'Finitary.elements'@ makes it vacuous. The label names the profunctor, which nothing in+-- its type can supply.+testFinitary+  :: forall {j} {k} (p :: j +-> k)+   . (Finitary.Finitary p, TestableProfunctor p, TestableTypeP p)+  => String+  -> TestTree+testFinitary nm =+  testGroup+    ("Finitary " ++ nm)+    [ testProperty "numbering" (propNumbering @p)+    , testCategoryProLaws @Finitary.Finitary @p defaultTestOptions "laws"+    ]++-- | 'Finitary.elements' has 'Finitary.size' entries, numbered in order, and every index is below+-- 'Finitary.size'.+propNumbering+  :: forall {j} {k} (p :: j +-> k). (Finitary.Finitary p, TestableProfunctor p, TestableTypeP p) => Property ()+propNumbering = do+  Some @a <- genOb @k+  Some @b <- genOb @j+  let n = Finitary.size @p @a @b+      es = Finitary.elements @p @a @b+  unless (genericLength es == n) $+    testFailed ("size is " ++ show n ++ " but elements has " ++ show (genericLength es :: Natural) ++ " entries")+  unless (map (Finitary.toIndex @p @a @b) es == Finitary.indices n) $+    testFailed ("elements should be numbered in order, found " ++ show (map (Finitary.toIndex @p @a @b) es))+  x <- genNamed @(p a b) "x"+  -- The numbering claims every index is below 'Finitary.size', which a @Fin@-typed index would+  -- have given for free. Without this check an undersized 'Finitary.size' goes unnoticed, since+  -- the other laws only ever look at the elements it admits.+  unless (Finitary.toIndex x < n) $+    testFailed ("toIndex " ++ showP x ++ " is " ++ show (Finitary.toIndex x) ++ ", not below size " ++ show n)++-- * Functors, representability and adjunctions++-- | Check the functor laws of a 'Functor.Functor' @f@: @map id = id@ and @map (g . f) = map g . map+-- f@. The witness lifts 'TestOb' along @f@ (usually @\\ \@a r -> r@ when @'TestOb' (f a)@ follows+-- from @'TestOb' a@). Functors encoded as representable profunctors ('Functor.FunctorForRep') are+-- instead tested via their @'Proarrow.Profunctor.Representable.Rep'@ with 'testProfunctor', since+-- the profunctor laws on @Rep f@ are the functor laws on @f@.+propFunctor+  :: forall {k1} {k2} (f :: k1 -> k2)+   . (Functor.Functor f, Testable k1, Testable k2)+  => (forall (a :: k1) r. (TestOb a) => ((TestOb (f a)) => r) -> r)+  -> Property ()+propFunctor withTestObF = do+  Some @a <- genOb @k1+  Some @b <- genObSuchThat @k1 \(Some @b) -> isGenNonEmpty @(a ~> b)+  Some @c <- genObSuchThat @k1 \(Some @c) -> isGenNonEmpty @(b ~> c)+  f <- genNamed @(a ~> b) "f"+  g <- genNamed @(b ~> c) "g"+  withTestObF @a $+    withTestObF @c $+      -- 'Functor.withObF' recovers @Ob (f a)@\/@Ob (f c)@ from the functor (GHC will not extract+      -- them from the quantified @Ob' (f a)@ superclass on its own)+      Functor.withObF @f @a $+        Functor.withObF @f @c $ do+          testEq "identity" "map id" (Functor.map @f (obj @a)) "id" (obj @(f a))+          testEq+            "composition"+            "map (g . f)"+            (Functor.map @f (g . f))+            "map g . map f"+            (Functor.map @f g . Functor.map @f f)++-- | The functor laws of @f@ ('propFunctor') as a ready-made test.+testFunctor+  :: forall {k1} {k2} (f :: k1 -> k2)+   . (Functor.Functor f, Testable k1, Testable k2)+  => (forall (a :: k1) r. (TestOb a) => ((TestOb (f a)) => r) -> r)+  -> TestTree+testFunctor withTestObF = testProperty "Functor" (propFunctor @f (\ @a r -> withTestObF @a r))++testFunctor_+  :: forall {k1} {k2} (f :: k1 -> k2)+   . (Functor.Functor f, Testable k1, Testable k2, forall (a :: k1). (TestOb a) => TestOb' (f a))+  => TestTree+testFunctor_ = testFunctor @f (\r -> r)++-- | The 'M.MonoidalProfunctor' laws of @p@ stated as code ('Laws.ProLaws' 'M.MonoidalProfunctor').+-- The witnesses say how 'TestOb' is closed under the tensor of @j@ and of @k@.+testMonoidalProfunctor+  :: forall {j} {k} (p :: j +-> k)+   . (M.MonoidalProfunctor p, TestableProfunctor p, TestOb (M.Unit :: j), TestOb (M.Unit :: k))+  => WithTestOb2 j+  -> WithTestOb2 k+  -> TestTree+testMonoidalProfunctor withTestOb2J withTestOb2K =+  testProLaws @'[CategoryOf, M.Monoidal] @'[CategoryOf, M.Monoidal] @M.MonoidalProfunctor @p+    defaultTestOptions+    genSome+    "MonoidalProfunctor"+    (CategoryW :& MonoidalW (\ @a @b r -> withTestOb2J @a @b r) :& WNil)+    (CategoryW :& MonoidalW (\ @a @b r -> withTestOb2K @a @b r) :& WNil)++-- | The laws of strength of @p@ for the tensor acting on its own category, stated as code+-- ('Laws.ProLaws' @('Strength.Strong' 'M.Tensor')@). The witness says how 'TestOb' is closed under+-- the tensor.+testMonStrong+  :: forall {k} (p :: k +-> k)+   . (Strength.Strong M.Tensor p, M.Monoidal k, TestableProfunctor p, TestOb (M.Unit :: k))+  => WithTestOb2 k+  -> TestTree+testMonStrong withTestOb2 =+  testProLaws @'[CategoryOf, M.Monoidal] @'[CategoryOf, M.Monoidal] @(Strength.Strong M.Tensor) @p+    defaultTestOptions+    genSome+    "Strong Tensor"+    ws+    ws+  where+    ws = CategoryW :& MonoidalW (\ @a @b r -> withTestOb2 @a @b r) :& WNil++testMonStrong_+  :: forall {k} (p :: k +-> k). (Strength.Strong M.Tensor p, M.Monoidal k, TestableProfunctor p, TestObIsOb k) => TestTree+testMonStrong_ = testMonStrong @p (\ @a @b r -> M.withOb2 @k @a @b r)++-- | The laws of costrength of @p@ for the tensor acting on its own category, stated as code+-- ('Laws.ProLaws' @('Strength.Costrong' 'M.Tensor')@). The witness says how 'TestOb' is closed+-- under the tensor.+testMonCostrong+  :: forall {k} (p :: k +-> k)+   . (Strength.Costrong M.Tensor p, M.Monoidal k, TestableProfunctor p, TestOb (M.Unit :: k))+  => WithTestOb2 k+  -> TestTree+testMonCostrong withTestOb2 =+  -- small objects: 'coact tensor' asks for arrows into a tensor of three of them, and a relation+  -- or matrix between such tensors grows with the product of their sizes+  testProLaws @'[CategoryOf, M.Monoidal] @'[CategoryOf, M.Monoidal] @(Strength.Costrong M.Tensor) @p+    defaultTestOptions+    genSomeSmall+    "Costrong Tensor"+    ws+    ws+  where+    ws = CategoryW :& MonoidalW (\ @a @b r -> withTestOb2 @a @b r) :& WNil++testMonCostrong_+  :: forall {k} (p :: k +-> k). (Strength.Costrong M.Tensor p, M.Monoidal k, TestableProfunctor p, TestObIsOb k) => TestTree+testMonCostrong_ = testMonCostrong @p (\ @a @b r -> M.withOb2 @k @a @b r)++-- | The 'Representable' laws of @p@ stated as code ('Laws.ProLaws' 'Representable'): 'index' and+-- 'tabulate' are inverse and natural. The witness lifts 'TestOb' along @p '%' -@.+testRepresentable+  :: forall {j} {k} (p :: j +-> k)+   . (Representable p, TestableProfunctor p)+  => WithTestObRep j p+  -> TestTree+testRepresentable withTestObRep =+  testProLaws @'[CategoryOf] @'[CategoryOf, RepresentedBy '[CategoryOf] p] @Representable @p+    defaultTestOptions+    genSome+    "Representable"+    (CategoryW :& WNil)+    (CategoryW :& RepresentedW (CategoryW :& WNil) (\ @b r -> withTestObRep @b r) :& WNil)++testRepresentable_ :: forall {j} {k} (p :: j +-> k). (Representable p, TestableProfunctor p, TestObIsOb k) => TestTree+testRepresentable_ = testRepresentable @p (\ @b r -> withObRep @p @b r)++-- | The 'Corepresentable' laws of @p@ stated as code ('Laws.ProLaws' 'Corepresentable'): 'coindex'+-- and 'cotabulate' are inverse and natural. The witness lifts 'TestOb' along @p '%%' -@.+testCorepresentable+  :: forall {j} {k} (p :: j +-> k)+   . (Corepresentable p, TestableProfunctor p)+  => WithTestObCorep k p+  -> TestTree+testCorepresentable withTestObCorep =+  testProLaws @'[CategoryOf, CorepresentedBy '[CategoryOf] p] @'[CategoryOf] @Corepresentable @p+    defaultTestOptions+    genSome+    "Corepresentable"+    (CategoryW :& CorepresentedW (CategoryW :& WNil) (\ @a r -> withTestObCorep @a r) :& WNil)+    (CategoryW :& WNil)++testCorepresentable_+  :: forall {j} {k} (p :: j +-> k)+   . (Corepresentable p, TestableProfunctor p, TestObIsOb j)+  => TestTree+testCorepresentable_ = testCorepresentable @p (\ @a r -> withObCorep @p @a r)++-- | The 'Promonad' laws of @p@ stated as code: 'id' is a unit for composition, which is+-- associative, and both are natural.+testPromonad :: forall {k} (p :: k +-> k). (Promonad p, TestableProfunctor p) => TestTree+testPromonad =+  testCategoryProLaws @Promonad @p defaultTestOptions "Promonad"++-- | The 'Promonad.Procomonad' laws of @p@ stated as code: 'Promonad.proextract' is natural and a+-- counit for 'Promonad.produplicate'. The middle object of 'Promonad.produplicate' is only known to+-- be an object, hence 'TestObIsOb'.+testProcomonad :: forall {k} (p :: k +-> k). (Promonad.Procomonad p, TestableProfunctor p, TestObIsOb k) => TestTree+testProcomonad =+  testCategoryProLaws @Promonad.Procomonad @p defaultTestOptions "Procomonad"++-- | The zigzag laws of the adjunction between @p@ and @q@ stated as code, for elements of each:+-- 'Laws.ProLaws' @('Adj.LeftProadjoint' q)@ and @('Adj.Proadjunction' p)@. The middle object of+-- the unit is only known to be an object, hence 'TestObIsOb'.+testProadjunction+  :: forall {j} {k} (p :: j +-> k) (q :: k +-> j)+   . (Adj.Proadjunction p q, TestableProfunctor p, TestableProfunctor q, TestObIsOb j, TestObIsOb k)+  => TestTree+testProadjunction =+  testGroup+    "Proadjunction"+    [ testCategoryProLaws @(Adj.LeftProadjoint (TestedP q)) @p defaultTestOptions "left adjoint"+    , testCategoryProLaws @(Adj.Proadjunction (TestedP p)) @q defaultTestOptions "right adjoint"+    ]++-- | Check the adjunction laws of an 'Adjunction' @p@. An adjunction here is a profunctor that is+-- both 'Representable' and 'Corepresentable', with left adjoint @L = p '%%' -@ and right adjoint+-- @R = p '%' -@. It carries no laws of its own beyond theirs ('leftAdjunct'\/'rightAdjunct' are just+-- @'index' '.' 'cotabulate'@ and @'coindex' '.' 'tabulate'@), so this groups 'testCorepresentable'+-- (for @L@) and 'testRepresentable' (for @R@). The two witnesses lift 'TestOb' along @L@ and @R@+-- respectively.+testAdjunction+  :: forall {j} {k} (p :: j +-> k)+   . (Adjunction p, TestableProfunctor p)+  => WithTestObCorep k p+  -> WithTestObRep j p+  -> TestTree+testAdjunction withTestObL withTestObR =+  testGroup+    "Adjunction"+    [ testCorepresentable @p (\ @a r -> withTestObL @a r)+    , testRepresentable @p (\ @b r -> withTestObR @b r)+    ]++testAdjunction_+  :: forall {j} {k} (p :: j +-> k)+   . (Adjunction p, TestableProfunctor p, TestObIsOb j, TestObIsOb k)+  => TestTree+testAdjunction_ = testAdjunction @p (\ @a r -> withObCorep @p @a r) (\ @b r -> withObRep @p @b r)++-- * Limits and colimits++-- | Every arrow into the 'Terminal.TerminalObject' is 'Terminal.terminate', from+-- @'Proarrow.Tools.Laws.Laws' '['Terminal.HasTerminalObject']@.+testTerminalObject+  :: forall k+   . (Testable k, Terminal.HasTerminalObject k, TestOb (Terminal.TerminalObject :: k))+  => TestTree+testTerminalObject = testLaws @'[Terminal.HasTerminalObject] "Terminal object" (TerminalW @k :& WNil)++-- | Every arrow out of the 'Initial.InitialObject' is 'Initial.initiate', from+-- @'Proarrow.Tools.Laws.Laws' '['Initial.HasInitialObject']@.+testInitialObject :: forall k. (Testable k, Initial.HasInitialObject k, TestOb (Initial.InitialObject :: k)) => TestTree+testInitialObject = testLaws @'[Initial.HasInitialObject] "Initial object" (InitialW @k :& WNil)++-- | The universal property of the binary product, from+-- @'Proarrow.Tools.Laws.Laws' '['BinaryProduct.HasBinaryProducts']@: the projections recover the+-- components of @f '&&&' g@, pairing commutes with precomposition, and pairing the projections is+-- the identity.+testBinaryProducts :: forall k. (Testable k, BinaryProduct.HasBinaryProducts k) => WithTestObProd k -> TestTree+testBinaryProducts withTestObProd =+  testLaws @'[BinaryProduct.HasBinaryProducts] "Binary products" (ProductsW (\ @a @b r -> withTestObProd @a @b r) :& WNil)++testBinaryProducts_ :: forall k. (Testable k, BinaryProduct.HasBinaryProducts k, TestObIsOb k) => TestTree+testBinaryProducts_ = testBinaryProducts @k (\ @a @b r -> BinaryProduct.withObProd @k @a @b r)++-- | The universal property of the binary coproduct, dual to 'testBinaryProducts', from+-- @'Proarrow.Tools.Laws.Laws' '['BinaryCoproduct.HasBinaryCoproducts']@.+testBinaryCoproducts :: forall k. (Testable k, BinaryCoproduct.HasBinaryCoproducts k) => WithTestObCoprod k -> TestTree+testBinaryCoproducts withTestObCoprod =+  testLaws @'[BinaryCoproduct.HasBinaryCoproducts]+    "Binary coproducts"+    (CoproductsW (\ @a @b r -> withTestObCoprod @a @b r) :& WNil)++testBinaryCoproducts_ :: forall k. (Testable k, BinaryCoproduct.HasBinaryCoproducts k, TestObIsOb k) => TestTree+testBinaryCoproducts_ = testBinaryCoproducts @k (\ @a @b r -> BinaryCoproduct.withObCoprod @k @a @b r)++-- | Check that composing with an arrow /reflects/ equality: the composites agree exactly when the+-- two arrows already did. @eqComposed@ is the caller\'s comparison of the composites (a+-- conjunction, where two projections have to be checked together), and @desc@ names it for the+-- failure message.+--+-- This is the mono half of an equalizer, the epi half of a coequalizer, and the jointly-monic and+-- jointly-epic halves of a pullback and a pushout.+propReflectsEq :: (TestingEqShow x) => String -> String -> Bool -> x -> x -> Property ()+propReflectsEq label desc eqComposed k1 k2 = do+  eqDirect <- eqP k1 k2+  unless (eqComposed == eqDirect) $+    testFailed $+      "Failed " ++ label ++ ": (" ++ desc ++ ") = " ++ show eqComposed ++ " but (k1 == k2) = " ++ show eqDirect++-- | Checks the equalizer laws: the equalizer arrow @e@ equalizes @f@ and @g@; any @h@ that factors+-- through @e@ (generated as @e . p@) is recovered by 'Equalizer.factorEqualizer'; and @e@ is mono.+--+-- The equalizer object is not computed by a type family, so its 'Ob' comes from the arrow via+-- 'Objs', and @withTestOb@ only has to bridge that one 'Ob' to 'TestOb'.+testEqualizers :: forall k. (Testable k, Equalizer.HasEqualizers k) => WithTestOb k -> TestTree+testEqualizers withTestOb = testProperty "Equalizers" $ do+  Some @a <- genOb @k+  Some @b <- genOb @k+  f <- genNamed @(a ~> b) "f"+  g <- genNamed @(a ~> b) "g"+  Equalizer.equalize f g \ @e ee@Objs -> withTestOb @e do+    testEq "equalizing" "f . e" (f . ee) "g . e" (g . ee)+    Some @z <- genOb @k+    p <- genNamed @(z ~> e) "p"+    let h = ee . p+        factored = Equalizer.factorEqualizer ee h+    testEq "factorization" "e . factored" (ee . factored) "h" h+    -- The half the constructed @h@ cannot reach: an /arbitrary/ arrow that happens to equalize+    -- must factor too. Without it an undersized equalizer (one keeping too few elements)+    -- satisfies everything above, since every arrow it is ever handed was built through it.+    m <- genNamed @(z ~> a) "m"+    equalizes <- eqP (f . m) (g . m)+    when equalizes $+      testEq "existence" "e . factorEqualizer e m" (ee . Equalizer.factorEqualizer ee m) "m" m+    k1 <- genNamed @(z ~> e) "k1"+    k2 <- genNamed @(z ~> e) "k2"+    eqComposed <- eqP (ee . k1) (ee . k2)+    propReflectsEq "mono" "e . k1 == e . k2" eqComposed k1 k2++testEqualizers_ :: forall k. (Testable k, Equalizer.HasEqualizers k, TestObIsOb k) => TestTree+testEqualizers_ = testEqualizers @k (\r -> r)++-- | Checks the coequalizer laws, dual to 'testEqualizers': the coequalizer arrow @c@ coequalizes @f@+-- and @g@; any @h@ that factors through @c@ (built here as @p . c@ for an arbitrary @p@, so the+-- precondition holds by construction) is correctly recovered by 'Coequalizer.factorCoequalizer'; and+-- @c@ is epi (post-composing with it on the right reflects equality).+testCoequalizers :: forall k. (Testable k, Coequalizer.HasCoequalizers k) => WithTestOb k -> TestTree+testCoequalizers withTestOb = testProperty "Coequalizers" $ do+  Some @a <- genOb @k+  Some @b <- genOb @k+  f <- genNamed @(a ~> b) "f"+  g <- genNamed @(a ~> b) "g"+  Coequalizer.coequalize f g \ @c cq@Objs -> withTestOb @c do+    testEq "coequalizing" "c . f" (cq . f) "c . g" (cq . g)+    Some @z <- genOb @k+    p <- genNamed @(c ~> z) "p"+    let h = p . cq+        factored = Coequalizer.factorCoequalizer cq h+    testEq "factorization" "factored . c" (factored . cq) "h" h+    -- As in 'testEqualizers': an arbitrary arrow that coequalizes must factor, not only one+    -- built by composing through @cq@.+    m <- genNamed @(b ~> z) "m"+    coequalizes <- eqP (m . f) (m . g)+    when coequalizes $+      testEq "existence" "factorCoequalizer c m . c" (Coequalizer.factorCoequalizer cq m . cq) "m" m+    k1 <- genNamed @(c ~> z) "k1"+    k2 <- genNamed @(c ~> z) "k2"+    eqComposed <- eqP (k1 . cq) (k2 . cq)+    propReflectsEq "epi" "k1 . c == k2 . c" eqComposed k1 k2++testCoequalizers_ :: forall k. (Testable k, Coequalizer.HasCoequalizers k, TestObIsOb k) => TestTree+testCoequalizers_ = testCoequalizers @k (\r -> r)++-- | Checks the pullback laws: the pullback cone commutes; it's jointly monic (composing with both+-- legs at once reflects equality); and any compatible cone (built here as @(p1 . j, p2 . j)@ for an+-- arbitrary @j@, so compatibility holds by construction) is correctly recovered by+-- 'Pullback.factorPullback'.+testPullbacks :: forall k. (Testable k, Pullback.HasPullbacks k) => WithTestOb k -> TestTree+testPullbacks withTestOb = testProperty "Pullbacks" $ do+  Some @o <- genOb @k+  Some @a <- genOb @k+  Some @b <- genOb @k+  f <- genNamed @(a ~> o) "f"+  g <- genNamed @(b ~> o) "g"+  Pullback.pullback f g \ @p p1@Objs p2 -> withTestOb @p do+    testEq "commutes" "f . p1" (f . p1) "g . p2" (g . p2)+    Some @z <- genOb @k+    k1' <- genNamed @(z ~> p) "k1"+    k2' <- genNamed @(z ~> p) "k2"+    eq1 <- eqP (p1 . k1') (p1 . k2')+    eq2 <- eqP (p2 . k1') (p2 . k2')+    propReflectsEq "jointly monic" "p1 . k1 == p1 . k2 && p2 . k1 == p2 . k2" (eq1 && eq2) k1' k2'+    j <- genNamed @(z ~> p) "j"+    let k1 = p1 . j+        k2 = p2 . j+        factored = Pullback.factorPullback p1 p2 k1 k2+    testEq "factorization (1)" "p1 . factored" (p1 . factored) "k1" k1+    testEq "factorization (2)" "p2 . factored" (p2 . factored) "k2" k2+    -- And the half those cannot reach: an arbitrary commuting cone must factor too.+    x <- genNamed @(z ~> a) "x"+    y <- genNamed @(z ~> b) "y"+    commutes <- eqP (f . x) (g . y)+    when commutes $ do+      let fac = Pullback.factorPullback p1 p2 x y+      testEq "existence (1)" "p1 . factorPullback p1 p2 x y" (p1 . fac) "x" x+      testEq "existence (2)" "p2 . factorPullback p1 p2 x y" (p2 . fac) "y" y++testPullbacks_ :: forall k. (Testable k, Pullback.HasPullbacks k, TestObIsOb k) => TestTree+testPullbacks_ = testPullbacks @k (\r -> r)++-- | Checks the pushout laws, dual to 'testPullbacks': the pushout cocone commutes; it's jointly epic+-- (post-composing with both legs at once reflects equality); and any compatible cocone (built here as+-- @(j . p1, j . p2)@ for an arbitrary @j@, so compatibility holds by construction) is correctly+-- recovered by 'Pushout.factorPushout'.+testPushouts :: forall k. (Testable k, Pushout.HasPushouts k) => WithTestOb k -> TestTree+testPushouts withTestOb = testProperty "Pushouts" $ do+  Some @o <- genOb @k+  Some @a <- genOb @k+  Some @b <- genOb @k+  f <- genNamed @(o ~> a) "f"+  g <- genNamed @(o ~> b) "g"+  Pushout.pushout f g \ @p p1@Objs p2 -> withTestOb @p do+    testEq "commutes" "p1 . f" (p1 . f) "p2 . g" (p2 . g)+    Some @z <- genOb @k+    k1' <- genNamed @(p ~> z) "k1"+    k2' <- genNamed @(p ~> z) "k2"+    eq1 <- eqP (k1' . p1) (k2' . p1)+    eq2 <- eqP (k1' . p2) (k2' . p2)+    propReflectsEq "jointly epic" "k1 . p1 == k2 . p1 && k1 . p2 == k2 . p2" (eq1 && eq2) k1' k2'+    j <- genNamed @(p ~> z) "j"+    let k1 = j . p1+        k2 = j . p2+        factored = Pushout.factorPushout p1 p2 k1 k2+    testEq "factorization (1)" "factored . p1" (factored . p1) "k1" k1+    testEq "factorization (2)" "factored . p2" (factored . p2) "k2" k2+    -- And the half those cannot reach: an arbitrary commuting cocone must factor too.+    x <- genNamed @(a ~> z) "x"+    y <- genNamed @(b ~> z) "y"+    commutes <- eqP (x . f) (y . g)+    when commutes $ do+      let fac = Pushout.factorPushout p1 p2 x y+      testEq "existence (1)" "factorPushout p1 p2 x y . p1" (fac . p1) "x" x+      testEq "existence (2)" "factorPushout p1 p2 x y . p2" (fac . p2) "y" y++testPushouts_ :: forall k. (Testable k, Pushout.HasPushouts k, TestObIsOb k) => TestTree+testPushouts_ = testPushouts @k (\r -> r)++-- | Checks the epi-mono factorization laws: 'Topos.factorize' splits @f@ as @m . e@ through an+-- image object, with @e@ epi and @m@ mono.+--+-- As with 'testEqualizers' the image object is revealed at runtime rather than computed by a type+-- family, so @withTestOb@ bridges its recovered 'Ob' to 'TestOb'. The epi and mono halves are the+-- two directions of 'propReflectsEq': composing on the right with @e@, and on the left with @m@.+testEpiMonoFactorization+  :: forall k. (Testable k, Topos.HasEpiMonoFactorization k) => WithTestOb k -> TestTree+testEpiMonoFactorization withTestOb = testProperty "Epi-mono factorization" $ do+  Some @a <- genOb @k+  Some @b <- genOb @k+  f <- genNamed @(a ~> b) "f"+  case Topos.factorize f of+    (:.:) @x e@Objs m -> withTestOb @x do+      testEq "factorization" "m . e" (m . e) "f" f+      Some @z <- genOb @k+      k1 <- genNamed @(x ~> z) "k1"+      k2 <- genNamed @(x ~> z) "k2"+      eqEpi <- eqP (k1 . e) (k2 . e)+      propReflectsEq "epi" "k1 . e == k2 . e" eqEpi k1 k2+      j1 <- genNamed @(z ~> x) "k1"+      j2 <- genNamed @(z ~> x) "k2"+      eqMono <- eqP (m . j1) (m . j2)+      propReflectsEq "mono" "m . k1 == m . k2" eqMono j1 j2++testEpiMonoFactorization_+  :: forall k. (Testable k, Topos.HasEpiMonoFactorization k, TestObIsOb k) => TestTree+testEpiMonoFactorization_ = testEpiMonoFactorization @k (\r -> r)++-- * Monoidal structure++-- | The monoidal laws, from @'Proarrow.Tools.Laws.Laws' '['M.Monoidal']@: the unitors and the+-- associator are natural isomorphisms satisfying the triangle and pentagon identities.+testMonoidal :: forall k. (Testable k, M.Monoidal k, TestOb (M.Unit @k)) => WithTestOb2 k -> TestTree+testMonoidal withTestOb2 = testLaws @'[M.Monoidal] "Monoidal" (MonoidalW (\ @a @b r -> withTestOb2 @a @b r) :& WNil)++testMonoidal_ :: forall k. (Testable k, M.Monoidal k, TestObIsOb k) => TestTree+testMonoidal_ = testMonoidal @k (\ @a @b r -> M.withOb2 @k @a @b r)++-- | The laws of a symmetric monoidal category, from+-- @'Proarrow.Tools.Laws.Laws' 'M.SymMonoidalStructures'@: 'M.swap' is a natural+-- self-inverse satisfying the hexagon identity.+testSymMonoidal :: forall k. (Testable k, M.SymMonoidal k, TestOb (M.Unit @k)) => WithTestOb2 k -> TestTree+testSymMonoidal withTestOb2 =+  testLaws @M.SymMonoidalStructures+    "Symmetric monoidal"+    (MonoidalW (\ @a @b r -> withTestOb2 @a @b r) :& SymMonoidalW :& WNil)++testSymMonoidal_ :: forall k. (Testable k, M.SymMonoidal k, TestObIsOb k) => TestTree+testSymMonoidal_ = testSymMonoidal @k (\ @a @b r -> M.withOb2 @k @a @b r)++-- | The laws of a copy-discard category: every object is a cocommutative comonoid (the laws of its+-- supply, in "Proarrow.Monoid"), and 'CopyDiscard.copy' and 'CopyDiscard.discard' are that comonoid+-- and respect the tensor ('CopyDiscard.CopyDiscardStructures').+testCopyDiscard+  :: forall k. (Testable k, CopyDiscard.CopyDiscard k, TestOb (M.Unit @k)) => WithTestOb2 k -> TestTree+testCopyDiscard withTestOb2 =+  testGroup+    "CopyDiscard"+    [ testLaws @'[M.Monoidal, Monoid.Supplies Monoid.Comonoid] "Comonoids" (monoidal :& ComonoidSupplyW :& WNil)+    , testLaws @'[M.Monoidal, M.SymMonoidal, Monoid.Supplies Monoid.CocommutativeComonoid]+        "Cocommutative comonoids"+        (monoidal :& SymMonoidalW :& CocommutativeComonoidSupplyW :& WNil)+    , testLaws @CopyDiscard.CopyDiscardStructures "Copy and discard" (monoidal :& SymMonoidalW :& CopyDiscardW :& WNil)+    ]+  where+    monoidal = MonoidalW (\ @a @b r -> withTestOb2 @a @b r)++-- | 'testCopyDiscard' where 'TestOb' is 'Ob'. 'Ob' goes through 'obFromTestOb', because with the+-- comonoid supply in scope GHC does not find the @TestOb a => Ob' a => Ob a@ route on its own.+testCopyDiscard_ :: forall k. (Testable k, CopyDiscard.CopyDiscard k, TestObIsOb k) => TestTree+testCopyDiscard_ = testCopyDiscard @k (\ @a @b r -> obFromTestOb @a (obFromTestOb @b (M.withOb2 @k @a @b r)))++-- | The coherence law tying 'Cartesian.Cartesian' to its 'CopyDiscard.CopyDiscard' superclass+-- (Fox's theorem): the comonoid supplied on every object is the natural one, @copy = id &&& id@+-- and @discard = terminate@.+testCartesian+  :: forall k+   . (Testable k, Cartesian.Cartesian k, TestOb (M.Unit @k))+  => (forall (a :: k) r. (TestOb a) => ((Ob a) => r) -> r)+  -> WithTestOb2 k+  -> TestTree+testCartesian withOb withTestOb2 = testProperty "Cartesian" $ do+  Some @a <- genOb @k+  withOb @a (withTestOb2 @a @a (propCartesianAt @a))++-- Hoisted so that @a ** a ~ a && a@ is an ordinary given ('Cartesian.TensorIsProduct'), which the+-- quantified superclass of 'Cartesian.Cartesian' can't supply as a rewrite on its own.+propCartesianAt+  :: forall {k} (a :: k)+   . ( Testable k+     , Cartesian.Cartesian k+     , Cartesian.TensorIsProduct a a+     , TestOb (M.Unit @k)+     , TestOb a+     , Ob a+     , TestOb (a M.** a)+     )+  => Property ()+propCartesianAt = do+  testEq "copy" "copy" (CopyDiscard.copy @k @a) "id &&& id" (BinaryProduct.diag @a)+  testEq "discard" "discard" (CopyDiscard.discard @k @a) "terminate" (Terminal.terminate @k @a)++testCartesian_ :: forall k. (Testable k, Cartesian.Cartesian k, TestObIsOb k, TestOb (M.Unit @k)) => TestTree+testCartesian_ =+  testCartesian @k (\ @a r -> obFromTestOb @a r) (\ @a @b r -> obFromTestOb @a (obFromTestOb @b (M.withOb2 @k @a @b r)))++-- | The tensor distributes over coproducts and is absorbed by the initial object, from+-- @'Proarrow.Tools.Laws.Laws' 'Distributive.DistributiveStructures'@: 'Distributive.distL',+-- 'Distributive.distR', 'Distributive.absorbL' and 'Distributive.absorbR' are isomorphisms, with+-- the inverses 'Distributive.distLInv', 'Distributive.distRInv' and 'Initial.initiate'.+testDistributive+  :: forall k+   . (Testable k, Distributive.Distributive k, TestOb (M.Unit @k), TestOb (Initial.InitialObject :: k))+  => WithTestOb2 k+  -> WithTestObCoprod k+  -> TestTree+testDistributive withTestOb2 withTestObCoprod =+  testLaws @Distributive.DistributiveStructures+    "Distributive"+    ( MonoidalW (\ @a @b r -> withTestOb2 @a @b r)+        :& InitialW+        :& CoproductsW (\ @a @b r -> withTestObCoprod @a @b r)+        :& DistributiveW+        :& WNil+    )++testDistributive_ :: forall k. (Testable k, Distributive.Distributive k, TestObIsOb k) => TestTree+testDistributive_ =+  testDistributive @k+    (\ @a @b r -> M.withOb2 @k @a @b r)+    (\ @a @b r -> BinaryCoproduct.withObCoprod @k @a @b r)++-- | The laws of a closed monoidal category, from+-- @'Proarrow.Tools.Laws.Laws' 'Exponential.ClosedStructures'@: 'Exponential.apply' undoes+-- 'Exponential.curry' and every arrow into an exponential is the 'Exponential.curry' of one,+-- 'Exponential.curry' is natural, and 'Exponential.^^^' is defined from 'Exponential.curry' and+-- 'Exponential.apply'.+testClosed+  :: forall k+   . (Testable k, Exponential.Closed k, TestOb (M.Unit @k))+  => WithTestOb2 k+  -> WithTestObExp k+  -> TestTree+testClosed withTestOb2 withTestObExp =+  testLawsWith @Exponential.ClosedStructures+    (genObSmall @k)+    "Closed"+    (MonoidalW (\ @a @b r -> withTestOb2 @a @b r) :& ClosedW (\ @a @b r -> withTestObExp @a @b r) :& WNil)++testClosed_ :: forall k. (Testable k, Exponential.Closed k, TestObIsOb k) => TestTree+testClosed_ =+  testClosed @k+    (\ @a @b r -> M.withOb2 @k @a @b r)+    (\ @a @b r -> Exponential.withObExp @k @a @b r)++-- | Laws of a *-autonomous category, from+-- @'Proarrow.Tools.Laws.Laws' 'SA.StarAutonomousStructures'@:+-- 'SA.dual' is a contravariant functor, bijective on hom-sets with inverse 'SA.dualInv';+-- 'SA.doubleNeg' is an isomorphism; and 'SA.linDist' is a natural bijection+-- @Hom(a ** b, Dual c) ≅ Hom(a, Dual (b ** c))@ with inverse 'SA.linDistInv'. The exponential+-- witness is needed because 'Exponential.Closed' is a superclass, although no law builds an+-- exponential.+testStarAutonomous+  :: forall k+   . (Testable k, SA.StarAutonomous k, TestOb (M.Unit @k))+  => WithTestOb2 k+  -> WithTestObExp k+  -> WithTestObDual k+  -> TestTree+testStarAutonomous withTestOb2 withTestObExp withTestObDual =+  testLaws @SA.StarAutonomousStructures+    "*-autonomous"+    ( MonoidalW (\ @a @b r -> withTestOb2 @a @b r)+        :& SymMonoidalW+        :& ClosedW (\ @a @b r -> withTestObExp @a @b r)+        :& StarAutonomousW (\ @a r -> withTestObDual @a r)+        :& WNil+    )++testStarAutonomous_ :: forall k. (Testable k, SA.StarAutonomous k, TestObIsOb k) => TestTree+testStarAutonomous_ =+  testStarAutonomous @k+    (\ @a @b r -> M.withOb2 @k @a @b r)+    (\ @a @b r -> Exponential.withObExp @k @a @b r)+    (\ @a r -> r \\ SA.dualObj @a)++-- | Laws of a compact closed category, from+-- @'Proarrow.Tools.Laws.Laws' 'CC.CompactClosedStructures'@:+-- 'CC.distribDual' and 'CC.dualUnit' are isomorphisms (so 'SA.Dual' is strong monoidal), and+-- 'CC.dualityUnit' and 'CC.dualityCounit' satisfy the zigzag identities. See+-- 'testStarAutonomous' for the exponential witness.+testCompactClosed+  :: forall k+   . (Testable k, CC.CompactClosed k, TestOb (M.Unit @k))+  => WithTestOb2 k+  -> WithTestObExp k+  -> WithTestObDual k+  -> TestTree+testCompactClosed withTestOb2 withTestObExp withTestObDual =+  testLaws @CC.CompactClosedStructures+    "Compact closed"+    ( MonoidalW (\ @a @b r -> withTestOb2 @a @b r)+        :& SymMonoidalW+        :& ClosedW (\ @a @b r -> withTestObExp @a @b r)+        :& StarAutonomousW (\ @a r -> withTestObDual @a r)+        :& CompactClosedW+        :& WNil+    )++testCompactClosed_ :: forall k. (Testable k, CC.CompactClosed k, TestObIsOb k) => TestTree+testCompactClosed_ =+  testCompactClosed @k+    (\ @a @b r -> M.withOb2 @k @a @b r)+    (\ @a @b r -> Exponential.withObExp @k @a @b r)+    (\ @a r -> r \\ SA.dualObj @a)++-- | The laws of a category that supplies special commutative Frobenius algebras, stated for+-- every object: the monoid and comonoid laws of its points, their commutativity, and the Frobenius laws of+-- 'Hypergraph.FrobeniusStructures'.+testHypergraph+  :: forall k+   . ( Testable k+     , M.SymMonoidal k+     , Monoid.Supplies Monoid.CommutativeMonoid k+     , Monoid.Supplies Monoid.CocommutativeComonoid k+     , TestOb (M.Unit @k)+     )+  => WithTestOb2 k+  -> TestTree+testHypergraph withTestOb2 =+  testGroup+    "Hypergraph (Frobenius supply)"+    [ testLaws @'[M.Monoidal, Monoid.Supplies Monoid.Monoid] "Monoids" (monoidal :& MonoidSupplyW :& WNil)+    , testLaws @'[M.Monoidal, Monoid.Supplies Monoid.Comonoid] "Comonoids" (monoidal :& ComonoidSupplyW :& WNil)+    , testLaws @'[M.Monoidal, M.SymMonoidal, Monoid.Supplies Monoid.CommutativeMonoid]+        "Commutative monoids"+        (monoidal :& SymMonoidalW :& CommutativeMonoidSupplyW :& WNil)+    , testLaws @'[M.Monoidal, M.SymMonoidal, Monoid.Supplies Monoid.CocommutativeComonoid]+        "Cocommutative comonoids"+        (monoidal :& SymMonoidalW :& CocommutativeComonoidSupplyW :& WNil)+    , testLaws @Hypergraph.FrobeniusStructures+        "Frobenius"+        (monoidal :& SymMonoidalW :& MonoidSupplyW :& ComonoidSupplyW :& WNil)+    ]+  where+    monoidal = MonoidalW (\ @a @b r -> withTestOb2 @a @b r)++testHypergraph_+  :: forall k+   . ( Testable k+     , M.SymMonoidal k+     , TestObIsOb k+     , Monoid.Supplies Monoid.CommutativeMonoid k+     , Monoid.Supplies Monoid.CocommutativeComonoid k+     )+  => TestTree+testHypergraph_ = testHypergraph @k (\ @a @b r -> obFromTestOb @a (obFromTestOb @b (M.withOb2 @k @a @b r)))++-- * Traced monoidal categories++-- | The trace laws of "Proarrow.Category.Monoidal.Strength" ('Strength.TracedStructures').+testTraced+  :: forall k. (Testable k, Strength.TracedMonoidal k, TestOb (M.Unit @k)) => WithTestOb2 k -> TestTree+testTraced withTestOb2 =+  -- small objects: the laws tensor up to three of them together, and a relation or matrix between+  -- such tensors grows with the product of their sizes+  testLawsWith @Strength.TracedStructures+    (genObSmall @k)+    "Traced"+    (MonoidalW (\ @a @b r -> withTestOb2 @a @b r) :& SymMonoidalW :& TracedW :& WNil)++testTraced_ :: forall k. (Testable k, Strength.TracedMonoidal k, TestObIsOb k) => TestTree+testTraced_ = testTraced @k (\ @a @b r -> M.withOb2 @k @a @b r)++-- * Monoids and comonoids++-- | The monoid laws of @m@: 'Monoid.mempty' is a left and right unit for 'Monoid.mappend' (up to the+-- unitors), and 'Monoid.mappend' is associative (up to the associator).+propMonoid+  :: forall {k} m+   . (Testable k, Monoid.Monoid (m :: k), TestOb m, TestOb (M.Unit @k))+  => WithTestOb2 k+  -> Property ()+propMonoid withTestOb2 =+  withTestOb2 @M.Unit @m $+    withTestOb2 @m @M.Unit $ do+      testEq+        "left identity"+        "μ . (η ⊗ 1)"+        (Monoid.mappend . (Monoid.mempty @m M.** obj @m))+        "λ"+        (M.leftUnitor @k @m)+      testEq+        "right identity"+        "μ . (1 ⊗ η)"+        (Monoid.mappend . (obj @m M.** Monoid.mempty @m))+        "ρ"+        (M.rightUnitor @k @m)+      withTestOb2 @m @m $ withTestOb2 @(m M.** m) @m $ do+        testEq+          "associativity"+          "μ . (μ ⊗ 1)"+          (Monoid.mappend @m . (Monoid.mappend @m M.** obj @m))+          "μ . (1 ⊗ μ) . α"+          (Monoid.mappend . (obj @m M.** Monoid.mappend @m) . M.associator @k @m @m @m)++-- | The laws of a commutative monoid: 'propMonoid', and 'Monoid.mappend' is unchanged by 'M.swap'.+propCommutativeMonoid+  :: forall {k} m+   . (Testable k, Monoid.CommutativeMonoid (m :: k), TestOb m, TestOb (M.Unit @k))+  => WithTestOb2 k+  -> Property ()+propCommutativeMonoid withTestOb2 = do+  propMonoid @m (\ @x @y r -> withTestOb2 @x @y r)+  withTestOb2 @m @m $+    testEq+      "commutativity"+      "mappend . swap"+      (Monoid.mappend @m . M.swap @k @m @m)+      "mappend"+      (Monoid.mappend @m)++-- | The laws of a cocommutative comonoid, as those of a commutative monoid in the opposite category.+propCocommutativeComonoid+  :: forall {k} m+   . (Testable k, Monoid.CocommutativeComonoid (m :: k), TestOb m, TestOb (M.Unit @k))+  => WithTestOb2 k+  -> Property ()+propCocommutativeComonoid withTestOb2 = do+  propCommutativeMonoid @(OP m) (\ @(OP x) @(OP y) r -> withTestOb2 @x @y r)++-- | Check that the object @m@ is a special commutative 'Hypergraph.Frobenius' algebra: it is a+-- 'Monoid.CommutativeMonoid' (via 'propCommutativeMonoid') and a 'Monoid.CocommutativeComonoid'+-- (via 'propCocommutativeComonoid'), and satisfies speciality (@mappend . comult = id@) and the+-- Frobenius condition. A 'Hypergraph.Hypergraph' category supplies this structure, and+-- @'testHypergraph'@ samples an object and delegates here.+propFrobenius+  :: forall {k} m+   . ( Testable k+     , M.SymMonoidal k+     , Monoid.CommutativeMonoid (m :: k)+     , Monoid.CocommutativeComonoid m+     , TestOb m+     , TestOb (M.Unit @k)+     )+  => WithTestOb2 k+  -> Property ()+propFrobenius withTestOb2 = do+  propCommutativeMonoid @m (\ @x @y r -> withTestOb2 @x @y r)+  propCocommutativeComonoid @m (\ @x @y r -> withTestOb2 @x @y r)+  withTestOb2 @m @m $+    withTestOb2 @(m M.** m) @m $ do+      let mu = Monoid.mappend @m+          delta = Monoid.comult @m+      testEq+        "speciality"+        "mappend . comult"+        (mu . delta)+        "id"+        (obj @m)+      testEq+        "Frobenius condition (left)"+        "(mappend ** id) . associatorInv . (id ** comult)"+        ((mu M.** obj @m) . M.associatorInv @k @m @m @m . (obj @m M.** delta))+        "comult . mappend"+        (delta . mu)+      testEq+        "Frobenius condition (right)"+        "(id ** mappend) . associator . (comult ** id)"+        ((obj @m M.** mu) . M.associator @k @m @m @m . (delta M.** obj @m))+        "comult . mappend"+        (delta . mu)++-- | The monoid laws of @m@ ('propMonoid') as a ready-made test.+testMonoid+  :: forall {k} m+   . (Testable k, Monoid.Monoid (m :: k), TestOb m, TestOb (M.Unit @k))+  => WithTestOb2 k+  -> TestTree+testMonoid f = testProperty ("Monoid " ++ showOb @k @m) (propMonoid @m \ @a @b -> f @a @b)++testMonoid_ :: forall {k} m. (Testable k, Monoid.Monoid (m :: k), TestObIsOb k) => TestTree+testMonoid_ = testMonoid @m (\ @a @b r -> M.withOb2 @k @a @b r)++-- | The comonoid laws of @m@, as the monoid laws of @m@ in the opposite category.+testComonoid+  :: forall {k} m+   . (Testable k, Monoid.Comonoid (m :: k), TestOb m, TestOb (M.Unit @k))+  => WithTestOb2 k+  -> TestTree+testComonoid f = testProperty ("Comonoid " ++ showOb @k @m) (propMonoid @(OP m) \ @(OP a) @(OP b) r -> f @a @b r)++testComonoid_ :: forall {k} m. (Testable k, Monoid.Comonoid (m :: k), TestObIsOb k) => TestTree+testComonoid_ = testComonoid @m (\ @a @b r -> M.withOb2 @k @a @b r)++-- | The laws of a commutative monoid ('propCommutativeMonoid') as a ready-made test.+testCommutativeMonoid+  :: forall {k} m+   . (Testable k, Monoid.CommutativeMonoid (m :: k), TestOb m, TestOb (M.Unit @k))+  => WithTestOb2 k+  -> TestTree+testCommutativeMonoid f = testProperty ("CommutativeMonoid " ++ showOb @k @m) (propCommutativeMonoid @m \ @a @b -> f @a @b)++testCommutativeMonoid_ :: forall {k} m. (Testable k, Monoid.CommutativeMonoid (m :: k), TestObIsOb k) => TestTree+testCommutativeMonoid_ = testCommutativeMonoid @m (\ @a @b r -> M.withOb2 @k @a @b r)++-- | The laws of a cocommutative comonoid ('propCocommutativeComonoid') as a ready-made test.+testCocommutativeComonoid+  :: forall {k} m+   . (Testable k, Monoid.CocommutativeComonoid (m :: k), TestOb m, TestOb (M.Unit @k))+  => WithTestOb2 k+  -> TestTree+testCocommutativeComonoid f = testProperty ("CocommutativeComonoid " ++ showOb @k @m) (propCocommutativeComonoid @m \ @a @b -> f @a @b)++testCocommutativeComonoid_+  :: forall {k} m+   . (Testable k, Monoid.CocommutativeComonoid (m :: k), TestObIsOb k)+  => TestTree+testCocommutativeComonoid_ = testCocommutativeComonoid @m (\ @a @b r -> M.withOb2 @k @a @b r)++-- | The laws of a special commutative Frobenius algebra ('propFrobenius') as a ready-made test.+testFrobenius+  :: forall {k} (m :: k)+   . ( Testable k+     , Monoid.CommutativeMonoid m+     , Monoid.CocommutativeComonoid m+     , TestOb m+     , TestOb (M.Unit @k)+     )+  => WithTestOb2 k+  -> TestTree+testFrobenius f = testProperty ("Frobenius " ++ showOb @k @m) (propFrobenius @m \ @a @b -> f @a @b)++testFrobenius_+  :: forall {k} (m :: k)+   . ( Testable k+     , Monoid.CommutativeMonoid m+     , Monoid.CocommutativeComonoid m+     , TestObIsOb k+     )+  => TestTree+testFrobenius_ = testFrobenius @m (\ @a @b r -> M.withOb2 @k @a @b r)++-- * Toposes++-- | Checks the subobject classifier @'Topos.Omega'@, the object of truth values: a map into it is a+-- predicate, and each mono @m@ has one classifying map, 'Topos.true' on @m@ and nowhere else. The+-- laws quantify over generalized elements (arrows into the object):+--+-- * @'Topos.classifyGraph' f@ is 'Topos.true' at @(x, y)@ iff @y = f . x@. This is the pullback+--   condition for the graph @\<id, f\>@. At @f = 'id'@ it is 'Topos.isEq', so equality testing is+--   pinned down too.+-- * Distinct arrows get distinct classifiers, the testable consequence of the classifying map+--   being unique.+-- * @'Topos.classifyKernelPair' f@ is true at @(x, x\')@ iff @f@ identifies them, in both directions.+-- * @'Topos.classifyImage' f@ is true on the image of @f@ and nowhere else: every element it calls+--   true factors through the image mono, by 'Pullback.factorPullback'. This is the law that+--   separates a subobject classifier from an arbitrary map into 'Topos.Omega'.+--+-- The elements come from the 'Testable' palette, which is sound iff that palette generates: true+-- for the concrete finite categories, not for a presheaf topos.+testSubobjectClassifier+  :: forall k+   . ( Testable k+     , Topos.HasSubobjectClassifier k+     , Topos.HasEpiMonoFactorization k+     , Pushout.HasPushouts k+     , Pullback.HasPullbacks k+     , TestOb (Topos.Omega :: k)+     )+  => WithTestObProd k+  -> TestTree+testSubobjectClassifier withTestObProd = testProperty "Subobject classifier" $ do+  Some @a <- genOb @k+  Some @b <- genOb @k+  Some @z <- genOb @k+  f <- genNamed @(a ~> b) "f"+  x <- genNamed @(z ~> a) "x"+  y <- genNamed @(z ~> b) "y"+  inGraph <- eqP (f . x) y+  classified <-+    eqP (Topos.classifyGraph f . (x BinaryProduct.&&& y)) (Terminal.const Topos.true)+  expect "classifyGraph is true exactly on the graph of f" inGraph classified+  g <- genNamed @(a ~> b) "g"+  withTestObProd @a @b @(Property ()) do+    eqChi <- eqP (Topos.classifyGraph f) (Topos.classifyGraph g)+    propReflectsEq "classifier injective" "classifyGraph f == classifyGraph g" eqChi f g+  x' <- genNamed @(z ~> a) "x'"+  identified <- eqP (f . x) (f . x')+  kernelPair <-+    eqP (Topos.classifyKernelPair f . (x BinaryProduct.&&& x')) (Terminal.const Topos.true)+  expect "classifyKernelPair is true exactly when f identifies the pair" identified kernelPair+  -- bound once: in the sheaves this is a pushout, which sheafifies and tabulates its apex+  let chi = Topos.classifyImage f+  onImage <- eqP (chi . (f . x)) (Terminal.const Topos.true)+  expect "classifyImage f is true on the image of f" True onImage+  -- The converse, which makes this a /subobject/ classifier: anything the classifier calls true+  -- factors through the image mono. Mirrors the existence half of 'testEqualizers'.+  case Topos.factorize f of+    (:.:) _ m@Objs -> do+      w <- genNamed @(z ~> b) "w"+      classifiedTrue <- eqP (chi . w) (Terminal.const Topos.true)+      when classifiedTrue $+        testEq+          "image factorization"+          "m . factorPullback m terminate w terminate"+          (m . Pullback.factorPullback m Terminal.terminate w Terminal.terminate)+          "w"+          w++testSubobjectClassifier_+  :: forall k+   . ( Testable k+     , Topos.HasSubobjectClassifier k+     , Topos.HasEpiMonoFactorization k+     , Pushout.HasPushouts k+     , Pullback.HasPullbacks k+     , TestObIsOb k+     , TestOb (Topos.Omega :: k)+     )+  => TestTree+testSubobjectClassifier_ =+  testSubobjectClassifier @k (\ @a @b r -> BinaryProduct.withObProd @k @a @b r)++-- | Negation is implication into false:+-- @'Topos.not' = 'Topos.implies' . (id '&&&' 'Terminal.const' 'Topos.false')@. A theorem of+-- every topos; 'Topos.not' is defined as the classifying map of 'Topos.false' instead, so this+-- checks the two agree.+testNegation :: forall k. (Testable k, Topos.ElementaryTopos k, TestOb (Topos.Omega :: k)) => TestTree+testNegation =+  testProperty "negation is implication into false" $+    testEq+      "not"+      "not"+      (Topos.not @k)+      "implies . (id &&& const false)"+      (Topos.implies . (id BinaryProduct.&&& Terminal.const Topos.false))++-- | The three equations a Lawvere–Tierney topology satisfies, for an arrow+-- @j :: 'Topos.Omega' '~>' 'Topos.Omega'@: it fixes @true@, is idempotent, and preserves meets.+--+-- Such a @j@ is the same data as a Grothendieck topology: the covering sieves are the ones @j@+-- sends to @true@. 'FinSheaf.lawvereTierney' is the @j@ a coverage induces, so this is how a+-- coverage's stability and composition get checked, without quantifying over arrows the coverage+-- was never handed.+testLawvereTierney+  :: forall k+   . (Testable k, Topos.ElementaryTopos k, TestOb (Topos.Omega :: k), TestOb (Terminal.TerminalObject :: k))+  => WithTestObProd k+  -> (Topos.Omega :: k) ~> Topos.Omega+  -> TestTree+testLawvereTierney withTestObProd j =+  testGroup+    "Lawvere-Tierney topology"+    [testProperty name (law j) | (name, law) <- lawvereTierneyLaws @k (\ @a @b r -> withTestObProd @a @b r)]++-- | The three laws of 'testLawvereTierney', by name, for an arrow given later. Shared by it and+-- 'testLawvereTierneyFamily'.+lawvereTierneyLaws+  :: forall k+   . (Testable k, Topos.ElementaryTopos k, TestOb (Topos.Omega :: k), TestOb (Terminal.TerminalObject :: k))+  => WithTestObProd k+  -> [(String, (Topos.Omega :: k) ~> Topos.Omega -> Property ())]+lawvereTierneyLaws withTestObProd =+  [ ("fixes true", \j -> testEq "true" "j . true" (j . Topos.true) "true" Topos.true)+  , ("idempotent", \j -> testEq "idempotent" "j . j" (j . j) "j" j)+  ,+    ( "preserves meets"+    , \j ->+        withTestObProd @Topos.Omega @Topos.Omega @(Property ()) $+          testEq "meets" "j . and" (j . Topos.and) "and . (j *** j)" (Topos.and . (j BinaryProduct.*** j))+    )+  ]++-- | 'testLawvereTierney' for a family of arrows indexed by the truth values, at a generated one:+-- 'Topos.openTopology' and 'Topos.closedTopology' are the ones the internal logic gives.+testLawvereTierneyFamily+  :: forall k+   . (Testable k, Topos.ElementaryTopos k, TestOb (Topos.Omega :: k), TestOb (Terminal.TerminalObject :: k))+  => String+  -> WithTestObProd k+  -> ((Terminal.TerminalObject :: k) ~> Topos.Omega -> (Topos.Omega :: k) ~> Topos.Omega)+  -> TestTree+testLawvereTierneyFamily name withTestObProd family =+  testGroup+    name+    [ testProperty lawName (genNamed "u" >>= law . family)+    | (lawName, law) <- lawvereTierneyLaws @k (\ @a @b r -> withTestObProd @a @b r)+    ]++testLawvereTierney_+  :: forall k+   . ( Testable k+     , Topos.ElementaryTopos k+     , TestObIsOb k+     , TestOb (Topos.Omega :: k)+     , TestOb (Terminal.TerminalObject :: k)+     )+  => (Topos.Omega :: k) ~> Topos.Omega+  -> TestTree+testLawvereTierney_ =+  testLawvereTierney @k (\ @a @b r -> obFromTestOb @a (obFromTestOb @b (BinaryProduct.withObProd @k @a @b r)))++testLawvereTierneyFamily_+  :: forall k+   . ( Testable k+     , Topos.ElementaryTopos k+     , TestObIsOb k+     , TestOb (Topos.Omega :: k)+     , TestOb (Terminal.TerminalObject :: k)+     )+  => String+  -> ((Terminal.TerminalObject :: k) ~> Topos.Omega -> (Topos.Omega :: k) ~> Topos.Omega)+  -> TestTree+testLawvereTierneyFamily_ name =+  testLawvereTierneyFamily @k name (\ @a @b r -> obFromTestOb @a (obFromTestOb @b (BinaryProduct.withObProd @k @a @b r)))++-- * Sites and sheaves++-- | The three laws a listable, stable coverage owes, as one group: 'testStableSite',+-- 'testGeneratedSieveIsSieve' and 'testDenseIsCovering'. Checking a site starts here.+--+-- The rest of this section checks what is built on the coverage: 'testGluesBack' and+-- 'testGluesBackAt' the sheaf condition, 'testEqualizersAreSheaves' the category of sheaves, and+-- 'testSheafification' (with 'testPlusFixes') the reflector. 'testLawvereTierney', under Toposes,+-- checks the generated topology and with it 'Sheaf.HasFiniteCovers'\'s Composition law.+testSiteLaws+  :: forall t j k+   . (Sheaf.StableSite t k, Sheaf.HasFiniteCovers t k, Finitary.FiniteCat j, Finitary.FiniteCat k)+  => TestTree+testSiteLaws =+  testGroup+    "site laws"+    [testStableSite @t @k, testGeneratedSieveIsSieve @t @j @k, testDenseIsCovering @t @j @k]++-- | 'Sheaf.StableSite'\'s law: pulling a cover back along @f@ gives a cover. For every leg @l'@ of+-- the cover 'Sheaf.pullbackCover' returns, the instance names a leg @l@ of the original and a+-- factor @u@ with @f '.' 'Sheaf.legArrow' l' = 'Sheaf.legArrow' l '.' u@. This checks that+-- equation, and that the pulled-back legs generate a covering sieve, which matters for covers that+-- are built instead of listed, like the meets of 'Proarrow.Category.Sheaf.Joins'. Covering is+-- checked instead of dense so that the check does not assume covers compose. It runs at+-- @j ~ ()@, since whether a sieve covers does not depend on @j@.+--+-- On a thin site (at most one arrow between two objects) the equation holds as soon as it+-- typechecks. It bites only where two legs share a source and target: the ends of an edge in the+-- graph schema @E ⇉ V@, or 'Proarrow.Category.Sheaf.ByImage', whose legs are named by elements.+testStableSite+  :: forall t k. (Sheaf.StableSite t k, Sheaf.HasFiniteCovers t k, Finitary.FiniteCat k) => TestTree+testStableSite =+  testProperty "covers pull back" $+    sequence_+      ( Finitary.foreachOb @k @(Property ()) \ @a -> Finitary.foreachOb @k @(Property ()) \ @b ->+          [ case Sheaf.pullbackCover c f of+              -- the arrow itself factors, so the pullback is @b@\'s implicit identity cover+              Sheaf.AlreadyFactors fs -> propFactorsThroughLeg @t f fs+              Sheaf.PulledBack c' fs -> do+                expect+                  ("the pulled-back cover of object " ++ show (Finitary.objIndex @b) ++ " covers it")+                  True+                  (FinSheaf.isCovering @t (FinSheaf.generatedSieve @t @b @'() c'))+                sequence_ [propFactorsThroughLeg @t (f . Sheaf.legArrow l) (fs l) | Sheaf.SomeLeg l <- Sheaf.legs c']+          | Sheaf.SomeCover c <- Sheaf.covers @t @k @a+          , f <- Finitary.elements @(Hom k) @b @a+          ]+      )++-- | One leg\'s half of 'testStableSite': the arrow is the leg it factors through, composed with+-- the factor.+propFactorsThroughLeg+  :: forall t {k} (a :: k) c x+   . (Sheaf.Site t k, Finitary.FiniteCat k, Ob a)+  => x ~> a+  -> Sheaf.Factors t k a c x+  -> Property ()+propFactorsThroughLeg f (Sheaf.Factors l u) =+  -- the factor is what brings its own source into scope, and the result type is known here, where+  -- at the call site it would be under an untouchable variable+  u //+    expect+      "the arrow factors through the leg the pullback names"+      (Finitary.toIndex @(Hom k) @x @a f)+      (Finitary.toIndex (Sheaf.legArrow l . u))++-- | A cover's generated sieve (the arrows that factor through one of its legs) is a sieve: closed+-- under composing on either side, as 'FinTopos.closedUnder' decides. That holds for any coverage,+-- lawful or not, so this checks 'Finitary.factorsThrough' and the hom-profunctor's+-- 'Finitary.elements', which every verdict in "Proarrow.Category.Enriched.Finitary.Sheaf" is read+-- off. It catches, for instance, an argument-swapped 'Finitary.factorsThrough'.+testGeneratedSieveIsSieve+  :: forall t j k. (Sheaf.HasFiniteCovers t k, Finitary.FiniteCat j, Finitary.FiniteCat k) => TestTree+testGeneratedSieveIsSieve =+  testProperty "generated sieves are sieves" $+    sequence_+      ( Finitary.foreachOb @k @(Property ()) \ @a -> Finitary.foreachOb @j @(Property ()) \ @b ->+          [ case FinSheaf.generatedSieve @t @a @b c of+              Sieve inSieve ->+                expect+                  ("the sieve a cover of object " ++ show (Finitary.objIndex @a) ++ " generates")+                  True+                  (FinTopos.closedUnder @(Yo a (OP b)) \(Yo g h) -> inSieve g h)+          | Sheaf.SomeCover c <- Sheaf.covers @t @k @a+          ]+      )++-- | On a category with pullbacks (which give the Ore condition), the topology 'Sheaf.Atomic'+-- generates is the double-negation one: 'FinSheaf.lawvereTierney' and 'Topos.doubleNegation' are+-- the same arrow, one computed by closing sieves and one from the internal logic. At @j ~ ()@+-- only: over a non-trivial @j@, @¬¬@ is the dense topology along @j@ as well, while the coverage+-- acts on @k@ alone.+testAtomicIsDoubleNegation+  :: forall k+   . ( Pullback.HasPullbacks k+     , Finitary.FiniteCat k+     , Testable (BinaryProduct.PROD (FinTopos.FINITARY () k))+     , TestOb (Topos.Omega :: BinaryProduct.PROD (FinTopos.FINITARY () k))+     )+  => TestTree+testAtomicIsDoubleNegation =+  testProperty "double negation is the atomic topology" $+    testEq+      "¬¬"+      "doubleNegation"+      (Topos.doubleNegation @(BinaryProduct.PROD (FinTopos.FINITARY () k)))+      "lawvereTierney @Atomic"+      (FinSheaf.lawvereTierney @Sheaf.Atomic)++-- | A profunctor @p :: j +-> k@ is fully faithful in the sense of 'Ran' when the functor from @k@ to+-- copresheaves on @j@ sending @a@ to @p a (-)@ is: each hom-set @a ~> a'@ is in bijection with the+-- natural transformations @p a' (-) -> p a (-)@, which are @(p '|>' p) a a'@. For a corepresentable+-- @p@ that is the functor @p '%%' -@ being fully faithful, which is+-- 'Proarrow.Category.Sheaf.ByImage'\'s Fully faithful law. 'testRiftFullyFaithful' is the other+-- side, and neither implies the other.+testRanFullyFaithful+  :: forall {j} {k} (p :: j +-> k). (Finitary.Finitary p, Finitary.FiniteCat j, Finitary.FiniteCat k) => TestTree+testRanFullyFaithful =+  testProperty "fully faithful into copresheaves" $+    sequence_+      ( Finitary.foreachOb @k @(Property ()) \ @a -> Finitary.foreachOb @k @(Property ()) \ @a' ->+          let ix = Finitary.toIndex @(Ran (OP p) p) @a @a'+          in [ expect+                 ( "each arrow from object "+                     ++ show (Finitary.objIndex @a)+                     ++ " to object "+                     ++ show (Finitary.objIndex @a')+                     ++ " is one transformation"+                 )+                 (Finitary.indices (Finitary.size @(Ran (OP p) p) @a @a'))+                 (sort [ix (Ran (lmap f)) | f <- Finitary.elements @(Hom k) @a @a'])+             ]+      )++-- | A profunctor @p :: j +-> k@ is fully faithful in the sense of 'Rift' when the functor from @j@ to+-- presheaves on @k@ sending @b@ to @p (-) b@ is: each hom-set @b ~> b'@ is in bijection with the+-- natural transformations @p (-) b -> p (-) b'@, which are @(p '<|' p) b b'@. For a representable+-- @p@ that is the functor @p '%' -@ being fully faithful. For a corepresentable @p@ it says the+-- image of @p '%%' -@ is dense. That makes 'Proarrow.Category.Sheaf.ByImage' subcanonical, and+-- when @p '%%' -@ is fully faithful the converse holds too. The comparison lemma asks for something else, 'testCoveredByImage'.+testRiftFullyFaithful+  :: forall {j} {k} (p :: j +-> k). (Finitary.Finitary p, Finitary.FiniteCat j, Finitary.FiniteCat k) => TestTree+testRiftFullyFaithful =+  testProperty "fully faithful into presheaves" $+    sequence_+      ( Finitary.foreachOb @j @(Property ()) \ @b -> Finitary.foreachOb @j @(Property ()) \ @b' ->+          let ix = Finitary.toIndex @(Rift (OP p) p) @b @b'+          in [ expect+                 ( "each arrow from object "+                     ++ show (Finitary.objIndex @b)+                     ++ " to object "+                     ++ show (Finitary.objIndex @b')+                     ++ " is one transformation"+                 )+                 (Finitary.indices (Finitary.size @(Rift (OP p) p) @b @b'))+                 (sort [ix (Rift (rmap f)) | f <- Finitary.elements @(Hom j) @b @b'])+             ]+      )++-- | Every object of @j@ is covered, for the coverage @t@, by the arrows into it from the image of+-- the functor @w '%%' -@: the sieve they generate is covering. With @w '%%' -@ fully faithful+-- ('testRanFullyFaithful') this is the hypothesis of the comparison lemma, see+-- 'Proarrow.Category.Sheaf.Induced'. Neither this nor 'testRiftFullyFaithful' implies the other.+testCoveredByImage+  :: forall t {j} {k} (w :: j +-> k)+   . (Sheaf.HasFiniteCovers t j, Corepresentable w, Finitary.Finitary w, Finitary.FiniteCat j, Finitary.FiniteCat k)+  => TestTree+testCoveredByImage =+  testProperty "every object is covered by the image" $+    sequence_+      ( Finitary.foreachOb @j @(Property ()) \ @c ->+          [ expect+              ("object " ++ show (Finitary.objIndex @c) ++ " is covered")+              True+              (FinSheaf.isCovering @t (Sieve @c @'() \g _ -> or (fromImage g) \\ g))+          ]+      )+  where+    fromImage :: forall (c :: j) x. (Ob c, Ob x) => x ~> c -> [Bool]+    fromImage g =+      Finitary.foreachOb @k \ @e -> [Finitary.factorsThrough g f \\ f | x <- Finitary.elements @w @e @c, let f = coindex x]++-- | For every sieve at every pair of objects of a finite site: it is covering exactly when it is dense,+-- that is when its 'FinSheaf.closure' is the maximal sieve. Two independent computations of one+-- fact: 'FinSheaf.isCovering' reads it off the coverage, 'FinSheaf.closure' off the induced+-- topology.+testDenseIsCovering+  :: forall t j k. (Sheaf.HasFiniteCovers t k, Finitary.FiniteCat j, Finitary.FiniteCat k) => TestTree+testDenseIsCovering =+  testProperty "covering sieves are the dense ones" $+    sequence_+      ( Finitary.foreachOb @k @(Property ()) \ @a -> Finitary.foreachOb @j @(Property ()) \ @b ->+          [ expect+              ("sieve " ++ show (Finitary.toIndex s) ++ " at object " ++ show (Finitary.objIndex @a))+              (FinSheaf.isCovering @t s)+              (FinSheaf.isDense @t s)+          | s <- Finitary.elements @(Sieve :: j +-> k) @a @b+          ]+      )++-- | The uniqueness half of the sheaf condition at one cover: an element @x@ at the covered object+-- is the gluing of its own restrictions to the legs.+--+-- The other half (a glued element restricts back to the family) has no generic test: the only+-- matching family generic code can build is an element's own restrictions, and there it follows+-- from uniqueness. Other families come from the site, so that test is written per site. At a+-- finite site 'Proarrow.Category.Enriched.Finitary.Sheaf.isSheaf' decides both halves at once, by+-- checking that restriction is a bijection onto the matching families.+propGluesBack+  :: forall {j} {k} t (p :: j +-> k) (a :: k) (b :: j) c+   . (Sheaf.Sheaf t p, Ob a, Ob b, TestingEqShow (p a b))+  => Sheaf.Cover t k a c+  -> p a b+  -> Property ()+propGluesBack c x =+  testEq+    "uniqueness"+    "glue c (\\g -> lmap (legArrow g) x)"+    (Sheaf.glue @t c \g -> lmap (Sheaf.legArrow g) x)+    "x"+    x++-- | 'propGluesBack' at every cover of a random element's object. Named for the law and not for the+-- class, since it is half of what 'Sheaf.Sheaf' asks for (see 'propGluesBack' for the other half).+--+-- The object is drawn from those that actually have a cover: on a site where only some objects are+-- covered, drawing uniformly would leave most runs asserting nothing while reporting successes.+testGluesBack+  :: forall {j} {k} t (p :: j +-> k)+   . (Sheaf.HasFiniteCovers t k, Sheaf.Sheaf t p, TestableProfunctor p, TestableTypeP p, TestObIsOb k)+  => TestTree+testGluesBack = testProperty "glues back" do+  Some @a <- genObSuchThat @k \(Some @a) -> not (null (Sheaf.covers @t @k @a))+  Some @b <- genOb @j+  x <- genNamed @(p a b) "x"+  obFromTestOb @a $+    obFromTestOb @b $+      for_ (Sheaf.covers @t @k @a) \(Sheaf.SomeCover c) -> propGluesBack @t c x++-- | 'propGluesBack' at one named cover, for a site whose covers cannot be listed. The label names+-- the profunctor and cover, which nothing in the type can supply.+testGluesBackAt+  :: forall {j} {k} t (p :: j +-> k) (a :: k) c+   . (Sheaf.Sheaf t p, TestableProfunctor p, TestableTypeP p, TestOb a)+  => String+  -> Sheaf.Cover t k a c+  -> TestTree+testGluesBackAt lbl c = testProperty ("glues back at " ++ lbl) do+  Some @b <- genOb @j+  x <- genNamed @(p a b) "x"+  obFromTestOb @a $ obFromTestOb @b $ propGluesBack @t c x++-- | An equalizer of sheaves is a sheaf, for every coverage: the 'Sheaf.Sheaf' instance for+-- 'FinTopos.Reindex' presupposes that the table cuts out a /subsheaf/, and this decides it, by+-- 'FinSheaf.isSheaf', on the equalizer of every pair of parallel arrows the palette of+-- @'FinSheaf.SHEAVES' t j k@ can form.+testEqualizersAreSheaves+  :: forall t j k+   . (Testable (FinSheaf.SHEAVES t j k), Sheaf.HasFiniteCovers t k, Finitary.FiniteCat j, Finitary.FiniteCat k)+  => TestTree+testEqualizersAreSheaves = testProperty "equalizers are sheaves" do+  SomeP @a @b f <- genProfunctorElt @(Hom (FinSheaf.SHEAVES t j k)) "f"+  g <- genNamed @(a ~> b) "g"+  Equalizer.equalize f g \(Sub (Prof @e _)) -> expect "isSheaf of the equalizer" True (FinSheaf.isSheaf @t @e)++-- | Sheafification is the reflector into the sheaves: it turns a presheaf @p@ into the closest+-- sheaf, and every map from @p@ to a sheaf factors uniquely through it. For a finitary @p@ and a+-- sheaf @q@, decided at a finite site:+--+-- * @'FinSheaf.unitPlus'@ is natural;+-- * @'FinSheaf.Sheafify' t p@ is a sheaf, by 'FinSheaf.isSheaf';+-- * one plus construction fixes @q@ ('testPlusFixes');+-- * maps @'FinSheaf.Sheafify' t p ~> q@ correspond to maps @p ~> q@. The hom-sets of+--   @'FinTopos.FINITARY' j k@ are finite, so this is a count, made a bijection by+--   'FinSheaf.extendSheafify': extending every map @p ~> q@ gives every map out of the+--   sheafification once, and restricting an extension along the unit gives the map back.+--+-- This also makes 'FinSheaf.extendPlus'\'s choice of cover safe to leave unspecified: another+-- choice would show up here as an extension that is not one of the maps.+testSheafification+  :: forall t {j} {k} (p :: j +-> k) (q :: j +-> k)+   . ( Sheaf.HasFiniteCovers t k+     , Sheaf.Sheaf t q+     , Finitary.Finitary p+     , Finitary.Finitary q+     , Finitary.FiniteCat j+     , Finitary.FiniteCat k+     , Testable j+     , Testable k+     , TestableProfunctor p+     )+  => TestTree+testSheafification =+  testGroup+    "sheafification"+    [ testProperty "unit is natural" $ propNaturalTransformation @p @(FinSheaf.Plus t p) (FinSheaf.unitPlus @t)+    , testProperty "Sheafify p is a sheaf" $ expect "isSheaf" True (FinSheaf.isSheaf @t @(FinSheaf.Sheafify t p))+    , testPlusFixes @t @q+    , testProperty "left adjoint to inclusion" do+        -- both enumerations once: each is a full walk of the finitary hom-set+        let maps = FinTopos.natTransformations @p @q+            exts = FinTopos.natElements @(FinSheaf.Sheafify t p) @q+        -- a hom-set is empty whenever @q@ runs out of elements where @p@ has some, and then every+        -- assertion below holds of nothing+        expect "there are maps to extend" True (not (null maps))+        expect "as many maps out of the sheafification as out of p" (length maps) (length exts)+        expect+          "the extensions are exactly the maps out of the sheafification"+          (sort exts)+          (sort [FinTopos.natTable @(FinSheaf.Sheafify t p) @q (FinSheaf.extendSheafify @t n) | Prof n <- maps])+        for_ maps \(Prof n) ->+          expect+            "restricting an extension along the unit gives the map back"+            (FinTopos.natTable @p @q n)+            (FinTopos.natTable @p @q \x -> FinSheaf.extendSheafify @t n (FinSheaf.unitSheafify @t x))+    ]++-- | One plus leaves a sheaf as it was: 'FinSheaf.unitPlus' is a bijection at every pair of objects.+-- Stated for any finitary @q@ (the property needs no 'Sheaf.Sheaf' instance, only 'FinSheaf.isSheaf'+-- to be true of @q@), so it also serves at a coverage no profunctor has an instance for, such as the+-- trivial one, which fixes everything.+testPlusFixes+  :: forall t {j} {k} (q :: j +-> k)+   . (Sheaf.HasFiniteCovers t k, Finitary.Finitary q, Finitary.FiniteCat j, Finitary.FiniteCat k)+  => TestTree+testPlusFixes =+  testProperty "one plus fixes q" $+    sequence_+      ( Finitary.foreachOb @k @(Property ()) \ @a -> Finitary.foreachOb @j @(Property ()) \ @b ->+          -- bound once for the hom-set: at 'FinSheaf.Plus' one 'Finitary.toIndex' is an enumeration+          let ix = Finitary.toIndex @(FinSheaf.Plus t q) @a @b+          in [ expect+                 ("unit is a bijection at object " ++ show (Finitary.objIndex @a))+                 (Finitary.indices (Finitary.size @(FinSheaf.Plus t q) @a @b))+                 (sort [ix (FinSheaf.unitPlus @t x) | x <- Finitary.elements @q @a @b])+             ]+      )
+ testing/Proarrow/Testing/Laws/Run.hs view
@@ -0,0 +1,691 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Checking laws stated as code ("Proarrow.Tools.Laws") in a 'Testable' category: 'testLaws'+-- runs each law with random objects for its variables and random arrows for the ones it asks for,+-- and compares both sides.+--+-- The endpoints of a law's equation are built inside the law, so their 'TestOb' cannot be listed+-- up front. Instead the law is run in 'TESTED' @k@, whose objects are built from leaves by the+-- structures' object formers; there an object's 'Ob' is 'Tested', which rebuilds the 'TestOb' of+-- the object of @k@ it stands for from the 'Witnesses' passed at run time: one 'Witness' per+-- structure in the law's list, e.g. a 'WithTestOb2' for 'M.Monoidal'.+--+-- A structure this module does not cover can be added from outside it, in the same way as the ones+-- here:+--+-- * a former for each new kind of object (an open data family, or one of the free category's),+--   with a 'Tested' instance giving its 'Untest' and rebuilding its 'Ob' and 'TestOb';+-- * a 'Witness' instance for the structure, holding how 'TestOb' is closed under its formers;+-- * the structure's class instance for 'TESTED', whose arrows describe themselves ('prim' for a+--   named arrow, 'app', 'apps', 'infixlDoc', 'infixrDoc' for operations on arrows).+--+-- 'testProLaws' checks the laws of a profunctor class ("Proarrow.Tools.Laws" 'Laws.ProLaws') the+-- same way, with the profunctor interpreted as 'TestedP', whose elements describe themselves like+-- the arrows of 'TESTED' do ('TestedArr' is 'TestedP' at the hom profunctor). Its domain and+-- codomain each get their own 'Witnesses'. An object former that crosses from one to the other,+-- like 'RepF' for @p '%' b@, carries the witnesses of the side it comes from in its structure's+-- 'Witness' ('RepresentedBy', 'CorepresentedBy'). The laws of 'Adj.Proadjunction' and+-- 'Promonad.Procomonad' build composites whose middle object is only known to be an object; the+-- runner makes it a leaf, which needs 'TestOb' to follow from 'Ob'.+module Proarrow.Testing.Laws.Run+  ( testLaws+  , testLawsWith+  , testProLaws++    -- * Witnesses+  , Witness (..)+  , Witnesses (..)+  , HasWitness (..)++    -- * Interpreting with testable objects+  , TESTED (..)+  , Tested (..)+  , untestOb2+  , untestOb3+  , untestTestOb2+  , TestedArr+  , pattern TestedArr++    -- * Interpreting profunctors+  , TestedP (..)+  , RepF+  , RepresentedBy+  , CorepF+  , CorepresentedBy++    -- * Describing arrows+  , Doc+  , prim+  , atom+  , app+  , apps+  , infixlDoc+  , infixrDoc+  ) where++import Data.Kind (Constraint, Type)+import Test.Falsify (Property)+import Test.Falsify.Generator (Gen)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (TestOptions, testProperty, testPropertyWith)+import Prelude hiding (fst, id, snd, (.))++import Proarrow.Adjunction qualified as Adj+import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Proarrow.Category.Enriched.Finitary (Finitary (..))+import Proarrow.Category.Instance.Free qualified as Free+import Proarrow.Category.Monoidal qualified as M+import Proarrow.Category.Monoidal.Closed qualified as Exponential+import Proarrow.Category.Monoidal.CompactClosed qualified as CC+import Proarrow.Category.Monoidal.CopyDiscard qualified as CopyDiscard+import Proarrow.Category.Monoidal.Distributive qualified as Distributive+import Proarrow.Category.Monoidal.StarAutonomous qualified as SA+import Proarrow.Category.Monoidal.Strength qualified as Strength+import Proarrow.Colimit.BinaryCoproduct qualified as BinaryCoproduct+import Proarrow.Colimit.Initial qualified as Initial+import Proarrow.Core (CAT, CategoryOf (..), Hom, Kind, Profunctor (..), Promonad (..), type (+->))+import Proarrow.Limit.BinaryProduct qualified as BinaryProduct+import Proarrow.Limit.Terminal qualified as Terminal+import Proarrow.Monoid qualified as Monoid+import Proarrow.Profunctor.Corepresentable (Corepresentable (..), withObCorep)+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Representable (Representable (..), withObRep)+import Proarrow.Promonad qualified as Promonad+import Proarrow.Testing+  ( Some (..)+  , SomeProfunctorElt (..)+  , TestObIsOb+  , Testable (..)+  , TestableProfunctor (..)+  , WithTestOb2+  , WithTestObCoprod+  , WithTestObCorep+  , WithTestObDual+  , WithTestObExp+  , WithTestObProd+  , WithTestObRep+  , genNamed+  , genOb+  , genObSuchThatWith+  , isGenNonEmpty+  , obFromTestOb+  , testEq+  )+import Proarrow.Tools.Laws qualified as Laws++-- | Check the laws of @'Laws.Laws' cs@ in @k@, one property per law: run each law in 'TESTED'+-- with random objects for its variables and random arrows for the ones it asks for. The+-- 'Witnesses' say how 'TestOb' is closed under the structures of @cs@ (see 'Tested').+testLaws :: forall cs k. (Laws.Laws cs, Testable k, Free.All cs (TESTED cs k)) => String -> Witnesses cs k -> TestTree+testLaws = testLawsWith @cs (genOb @k)++-- | 'testLaws' with the objects for the variables drawn from the given generator, e.g.+-- 'Proarrow.Testing.genObSmall' where the laws build large objects like exponentials.+testLawsWith+  :: forall cs k+   . (Laws.Laws cs, Testable k, Free.All cs (TESTED cs k))+  => Property (Some k) -> String -> Witnesses cs k -> TestTree+testLawsWith genObject name witnesses =+  testGroup name [testProperty (Laws.lawName law) (checkLaw law) | law <- Laws.laws @cs]+  where+    checkLaw :: Laws.Law cs -> Property ()+    checkLaw (Laws.Law lawName body) = do+      Some @a <- genObject+      Some @b <- genObject+      Some @c <- genObject+      Some @d <- genObject+      Some @e <- genObject+      eq <-+        body @(TLeaf a :: TESTED cs k) @(TLeaf b) @(TLeaf c) @(TLeaf d) @(TLeaf e) (genArr witnesses)+      testEquation witnesses lawName eq++-- | Check the laws of @'Laws.ProLaws' c@ for the profunctor @p@, one property per law: run each+-- law with @p@ interpreted as 'TestedP' @p@, its elements drawn by 'genProfunctorElt' (each picks+-- its two object variables), the other variables of a 'Laws.ProLaw' drawn along the chain+-- @e '~>' c '~>' a@ and @b '~>' d '~>' f@ where those hom-sets are non-empty, and random arrows+-- for the ones it asks for. The two 'Witnesses' are for the domain @j@ and the codomain+-- @k@ of @p@, the 'TestOptions' apply to each law's property, and the other variables are drawn from+-- the given generator of objects, e.g. 'genSomeSmall' where the laws tensor several objects+-- together.+testProLaws+  :: forall {j} {k} csj csk cl (p :: j +-> k)+   . (Laws.ProLaws cl, TestableProfunctor p, cl (TestedP p :: TESTED csj j +-> TESTED csk k))+  => TestOptions+  -> (forall i. (Testable i) => Gen (Some i))+  -> String+  -> Witnesses csj j+  -> Witnesses csk k+  -> TestTree+testProLaws opts genObjects name wsj wsk =+  testGroup name [testPropertyWith opts (Laws.proLawName law) (checkLaw law) | law <- Laws.proLaws @cl]+  where+    checkLaw :: Laws.ProLaw cl -> Property ()+    checkLaw (Laws.ProLaw lawName body) = do+      SomeP @a @b p0 <- genProfunctorElt @p "p"+      Some @c <- genObSuchThatWith (genObjects @k) \(Some @c') -> isGenNonEmpty @(c' ~> a)+      Some @d <- genObSuchThatWith (genObjects @j) \(Some @d') -> isGenNonEmpty @(b ~> d')+      Some @e <- genObSuchThatWith (genObjects @k) \(Some @e') -> isGenNonEmpty @(e' ~> c)+      Some @f <- genObSuchThatWith (genObjects @j) \(Some @f') -> isGenNonEmpty @(d ~> f')+      eq <-+        body @(TestedP p) @(TLeaf a :: TESTED csk k) @(TLeaf b :: TESTED csj j) @(TLeaf c) @(TLeaf d) @(TLeaf e) @(TLeaf f)+          (prim "p" p0)+          (genArr wsk)+          (genArr wsj)+      testProEquation lawName eq+    checkLaw (Laws.ProLaw3 lawName body) = do+      SomeP @a @b p0 <- genProfunctorElt @p "p"+      SomeP @c @d p1 <- genProfunctorElt @p "p'"+      SomeP @e @f p2 <- genProfunctorElt @p "p''"+      eq <-+        body @(TestedP p) @(TLeaf a :: TESTED csk k) @(TLeaf b :: TESTED csj j) @(TLeaf c) @(TLeaf d) @(TLeaf e) @(TLeaf f)+          (prim "p" p0)+          (prim "p'" p1)+          (prim "p''" p2)+          (genArr wsk)+          (genArr wsj)+      testProEquation lawName eq+    testProEquation :: String -> Laws.ProEquation (TestedP p :: TESTED csj j +-> TESTED csk k) -> Property ()+    testProEquation lawName = \case+      l Laws.:=: r -> testTested wsj wsk lawName l r+      Laws.InK e -> testEquation wsk lawName e+      Laws.InJ e -> testEquation wsj lawName e++-- | Compare the two sides of an equation between arrows of 'TESTED', printing them on failure.+testEquation :: forall cs k. (Testable k) => Witnesses cs k -> String -> Laws.Equation (TESTED cs k) -> Property ()+testEquation ws lawName eq = Laws.withSides eq (testTested ws ws lawName)++-- | A named arbitrary arrow between the objects the endpoints stand for.+genArr+  :: forall cs k (x :: TESTED cs k) y. (Testable k, Tested x, Tested y) => Witnesses cs k -> String -> Property (x ~> y)+genArr ws s = untestTestOb2 @x @y ws (prim s <$> genNamed @(Untest x ~> Untest y) s)++-- | Compare two elements of @p@, printing their descriptions on failure.+testTested+  :: forall {csj} {csk} {j} {k} (p :: j +-> k) (x :: TESTED csk k) (y :: TESTED csj j)+   . (TestableProfunctor p)+  => Witnesses csj j -> Witnesses csk k -> String -> TestedP p x y -> TestedP p x y -> Property ()+testTested wsj wsk lawName (TestedP dl l) (TestedP dr r) =+  untestTestOb @x wsk $ untestTestOb @y @(Property ()) wsj $ testEq lawName (dl 0 "") l (dr 0 "") r++-- | Objects of @k@ built from leaves by the structures' object formers. Checking a law+-- interprets it here rather than in @k@ itself: an object's 'Ob' is then 'Tested', which+-- recovers the 'TestOb' of the object of @k@ it stands for ('Untest') from the 'Witnesses' for+-- the structures @cs@, supplied at run time.+--+-- The only constructor is the leaf. Compound objects use the free category's formers, which are+-- open data families of any kind ('M.**!', 'BinaryProduct.*!', 'SA.DualF', ...), so a new+-- structure brings its own former and its own 'Tested' instance.+type TESTED :: [Kind -> Constraint] -> Kind -> Kind+type data TESTED cs k = TLeaf k++-- * Witnesses++-- | How 'TestOb' is closed under the object formers of the structure @c@, for the category @k@.+-- Structures without formers of their own have a witness that holds nothing.+type Witness :: (Kind -> Constraint) -> Kind -> Type+data family Witness c k++data instance Witness CategoryOf k = CategoryW+newtype instance Witness M.Monoidal k = MonoidalW (WithTestOb2 k)+data instance Witness M.SymMonoidal k = SymMonoidalW+newtype instance Witness BinaryProduct.HasBinaryProducts k = ProductsW (WithTestObProd k)+newtype instance Witness BinaryCoproduct.HasBinaryCoproducts k = CoproductsW (WithTestObCoprod k)+data instance Witness Terminal.HasTerminalObject k = TerminalW+data instance Witness Initial.HasInitialObject k = InitialW+data instance Witness Distributive.Distributive k = DistributiveW+newtype instance Witness Exponential.Closed k = ClosedW (WithTestObExp k)+newtype instance Witness SA.StarAutonomous k = StarAutonomousW (WithTestObDual k)+data instance Witness CC.CompactClosed k = CompactClosedW+data instance Witness Strength.TracedMonoidal k = TracedW+data instance Witness CopyDiscard.CopyDiscard k = CopyDiscardW+data instance Witness (Monoid.Supplies Monoid.Monoid) k = MonoidSupplyW+data instance Witness (Monoid.Supplies Monoid.Comonoid) k = ComonoidSupplyW+data instance Witness (Monoid.Supplies Monoid.CommutativeMonoid) k = CommutativeMonoidSupplyW+data instance Witness (Monoid.Supplies Monoid.CocommutativeComonoid) k = CocommutativeComonoidSupplyW++infixr 5 :&++-- | One 'Witness' for each structure in @cs@, in the same order.+type Witnesses :: [Kind -> Constraint] -> Kind -> Type+data Witnesses cs k where+  WNil :: Witnesses '[] k+  (:&) :: Witness c k -> Witnesses cs k -> Witnesses (c ': cs) k++-- | Look up the witness for the structure @c@.+type HasWitness :: (Kind -> Constraint) -> [Kind -> Constraint] -> Constraint+class HasWitness c cs where+  -- | The witness for @c@ in the list.+  witness :: Witnesses cs k -> Witness c k++instance {-# OVERLAPPABLE #-} (HasWitness c cs) => HasWitness c (d ': cs) where+  witness (_ :& ws) = witness @c ws+instance HasWitness c (c ': cs) where+  witness (w :& _) = w++-- * The testable-objects category++-- | The objects of 'TESTED': those that stand for an object of @k@ ('Untest'), with how to+-- rebuild that object's 'Ob' and 'TestOb' from the ones of its parts. This is 'Ob' for 'TESTED'.+type Tested :: forall {cs} {k}. TESTED cs k -> Constraint+class Tested (a :: TESTED cs k) where+  -- | The object of @k@ that @a@ stands for. (The class variable is re-annotated so that @k@ is+  -- in scope in the result kind.)+  type Untest (a :: TESTED cs k) :: k++  -- | The 'Ob' of the object @a@ stands for, which the structures of @k@ provide.+  untestOb :: ((Ob (Untest a)) => r) -> r++  -- | The 'TestOb' of the object @a@ stands for, which the witnesses provide.+  untestTestOb :: Witnesses cs k -> ((TestOb (Untest a)) => r) -> r++instance (Testable k, TestOb (a :: k)) => Tested (TLeaf a :: TESTED cs k) where+  type Untest (TLeaf a) = a+  untestOb r = obFromTestOb @a r+  untestTestOb _ r = r+instance (Testable k, M.Monoidal k, TestOb (M.Unit :: k)) => Tested (M.UnitF :: TESTED cs k) where+  type Untest M.UnitF = M.Unit+  untestOb r = r+  untestTestOb _ r = r+instance (HasWitness M.Monoidal cs, M.Monoidal k, Tested (a :: TESTED cs k), Tested b) => Tested (a M.**! b) where+  type Untest (a M.**! b) = Untest a M.** Untest b+  untestOb r = untestOb2 @a @b (M.withOb2 @k @(Untest a) @(Untest b) r)+  untestTestOb ws r = untestTestOb2 @a @b ws (case witness @M.Monoidal ws of MonoidalW f -> f @(Untest a) @(Untest b) r)+instance+  (HasWitness BinaryProduct.HasBinaryProducts cs, BinaryProduct.HasBinaryProducts k, Tested (a :: TESTED cs k), Tested b)+  => Tested (a BinaryProduct.*! b)+  where+  type Untest (a BinaryProduct.*! b) = Untest a BinaryProduct.&& Untest b+  untestOb r = untestOb2 @a @b (BinaryProduct.withObProd @k @(Untest a) @(Untest b) r)+  untestTestOb ws r =+    untestTestOb2 @a @b ws (case witness @BinaryProduct.HasBinaryProducts ws of ProductsW f -> f @(Untest a) @(Untest b) r)+instance (Testable k, Initial.HasInitialObject k, TestOb (Initial.InitialObject :: k)) => Tested (Initial.InitF :: TESTED cs k) where+  type Untest Initial.InitF = Initial.InitialObject+  untestOb r = r+  untestTestOb _ r = r+instance+  ( HasWitness BinaryCoproduct.HasBinaryCoproducts cs+  , BinaryCoproduct.HasBinaryCoproducts k+  , Tested (a :: TESTED cs k)+  , Tested b+  )+  => Tested (a BinaryCoproduct.+ b)+  where+  type Untest (a BinaryCoproduct.+ b) = Untest a BinaryCoproduct.|| Untest b+  untestOb r = untestOb2 @a @b (BinaryCoproduct.withObCoprod @k @(Untest a) @(Untest b) r)+  untestTestOb ws r =+    untestTestOb2 @a @b+      ws+      (case witness @BinaryCoproduct.HasBinaryCoproducts ws of CoproductsW f -> f @(Untest a) @(Untest b) r)++instance+  (Testable k, Terminal.HasTerminalObject k, TestOb (Terminal.TerminalObject :: k))+  => Tested (Terminal.TermF :: TESTED cs k)+  where+  type Untest Terminal.TermF = Terminal.TerminalObject+  untestOb r = r+  untestTestOb _ r = r+instance+  (HasWitness Exponential.Closed cs, Exponential.Closed k, Tested (a :: TESTED cs k), Tested b)+  => Tested (a Exponential.--> b)+  where+  type Untest (a Exponential.--> b) = Untest a Exponential.~~> Untest b+  untestOb r = untestOb2 @a @b (Exponential.withObExp @k @(Untest a) @(Untest b) r)+  untestTestOb ws r =+    untestTestOb2 @a @b ws (case witness @Exponential.Closed ws of ClosedW f -> f @(Untest a) @(Untest b) r)++instance (HasWitness SA.StarAutonomous cs, SA.StarAutonomous k, Tested (a :: TESTED cs k)) => Tested (SA.DualF a) where+  type Untest (SA.DualF a) = SA.Dual (Untest a)+  untestOb r = untestOb @a (SA.withObDual @k @(Untest a) r)+  untestTestOb ws r = untestTestOb @a ws (case witness @SA.StarAutonomous ws of StarAutonomousW f -> f @(Untest a) r)++-- | 'untestOb' of two objects at once.+untestOb2 :: forall {cs} {k} (a :: TESTED cs k) b r. (Tested a, Tested b) => ((Ob (Untest a), Ob (Untest b)) => r) -> r+untestOb2 r = untestOb @a (untestOb @b r)++-- | 'untestTestOb' of two objects at once.+untestTestOb2+  :: forall {cs} {k} (a :: TESTED cs k) (b :: TESTED cs k) r+   . (Tested a, Tested b) => Witnesses cs k -> ((TestOb (Untest a), TestOb (Untest b)) => r) -> r+untestTestOb2 ws r = untestTestOb @a ws (untestTestOb @b ws r)++-- | 'untestOb' of three objects at once.+untestOb3+  :: forall {cs} {k} (a :: TESTED cs k) b c r+   . (Tested a, Tested b, Tested c) => ((Ob (Untest a), Ob (Untest b), Ob (Untest c)) => r) -> r+untestOb3 r = untestOb @a (untestOb @b (untestOb @c r))++-- | An arrow of @k@ between the objects the endpoints stand for, with a description of how it was+-- built: an element of the hom profunctor. These are the arrows of 'TESTED'.+type TestedArr :: forall cs k. CAT (TESTED cs k)+type TestedArr @cs @k = TestedP (Hom k)++-- | 'TestedP' at the hom profunctor.+pattern TestedArr+  :: forall cs k (a :: TESTED cs k) (b :: TESTED cs k)+   . () => (Tested a, Tested b) => Doc -> Untest a ~> Untest b -> TestedArr a b+pattern TestedArr d f = TestedP d f++{-# COMPLETE TestedArr #-}++-- | A description that can be shown at a precedence, like 'showsPrec'.+type Doc = Int -> ShowS++-- | A name, which never needs parentheses.+atom :: String -> Doc+atom s _ = showString s++-- | An element or arrow described by its name.+prim :: (Tested a, Tested b) => String -> p (Untest a) (Untest b) -> TestedP p a b+prim s = TestedP (atom s)++-- | A function applied to one argument.+app :: String -> Doc -> Doc+app f x = apps f [x]++-- | A function applied to several arguments.+apps :: String -> [Doc] -> Doc+apps f xs d = showParen (d > 10) (showString f . foldr (\x r -> showChar ' ' . x 11 . r) (\r -> r) xs)++-- | A left or right associative infix operator at the given precedence, like @infixl@ and+-- @infixr@. The operator string includes its surrounding spaces, e.g. @" . "@.+infixlDoc, infixrDoc :: Int -> String -> Doc -> Doc -> Doc+infixlDoc p op x y d = showParen (d > p) (x p . showString op . y (p + 1))+infixrDoc p op x y d = showParen (d > p) (x (p + 1) . showString op . y p)++instance (CategoryOf k) => CategoryOf (TESTED cs k) where+  type (~>) = TestedArr+  type Ob a = Tested a++instance+  ( HasWitness M.Monoidal csj+  , HasWitness M.Monoidal csk+  , Testable j+  , Testable k+  , M.MonoidalProfunctor p+  , TestOb (M.Unit :: j)+  , TestOb (M.Unit :: k)+  )+  => M.MonoidalProfunctor (TestedP p :: TESTED csj j +-> TESTED csk k)+  where+  one = prim "one" M.one+  TestedP df f ** TestedP dg g = TestedP (infixlDoc 8 " ** " df dg) (f M.** g)+instance (HasWitness M.Monoidal cs, Testable k, M.Monoidal k, TestOb (M.Unit :: k)) => M.Monoidal (TESTED cs k) where+  type Unit = M.UnitF+  type a ** b = a M.**! b+  withOb2 r = r+  leftUnitor @a = untestOb @a (prim "leftUnitor" M.leftUnitor)+  leftUnitorInv @a = untestOb @a (prim "leftUnitorInv" M.leftUnitorInv)+  rightUnitor @a = untestOb @a (prim "rightUnitor" M.rightUnitor)+  rightUnitorInv @a = untestOb @a (prim "rightUnitorInv" M.rightUnitorInv)+  associator @a @b @c = untestOb3 @a @b @c (prim "associator" (M.associator @k @(Untest a) @(Untest b) @(Untest c)))+  associatorInv @a @b @c = untestOb3 @a @b @c (prim "associatorInv" (M.associatorInv @k @(Untest a) @(Untest b) @(Untest c)))+instance (HasWitness M.Monoidal cs, Testable k, M.SymMonoidal k, TestOb (M.Unit :: k)) => M.SymMonoidal (TESTED cs k) where+  swap @a @b = untestOb2 @a @b (prim "swap" (M.swap @k @(Untest a) @(Untest b)))++instance+  (HasWitness BinaryProduct.HasBinaryProducts cs, BinaryProduct.HasBinaryProducts k)+  => BinaryProduct.HasBinaryProducts (TESTED cs k)+  where+  type a && b = a BinaryProduct.*! b+  withObProd r = r+  fst @a @b = untestOb2 @a @b (prim "fst" (BinaryProduct.fst @k @(Untest a) @(Untest b)))+  snd @a @b = untestOb2 @a @b (prim "snd" (BinaryProduct.snd @k @(Untest a) @(Untest b)))+  TestedArr df f &&& TestedArr dg g = TestedArr (infixlDoc 5 " &&& " df dg) (f BinaryProduct.&&& g)++instance (Testable k, Initial.HasInitialObject k, TestOb (Initial.InitialObject :: k)) => Initial.HasInitialObject (TESTED cs k) where+  type InitialObject = Initial.InitF+  initiate @a = untestOb @a (prim "initiate" Initial.initiate)++instance+  (HasWitness BinaryCoproduct.HasBinaryCoproducts cs, BinaryCoproduct.HasBinaryCoproducts k)+  => BinaryCoproduct.HasBinaryCoproducts (TESTED cs k)+  where+  type a || b = a BinaryCoproduct.+ b+  withObCoprod r = r+  lft @a @b = untestOb2 @a @b (prim "lft" (BinaryCoproduct.lft @k @(Untest a) @(Untest b)))+  rgt @a @b = untestOb2 @a @b (prim "rgt" (BinaryCoproduct.rgt @k @(Untest a) @(Untest b)))+  TestedArr df f ||| TestedArr dg g = TestedArr (infixlDoc 4 " ||| " df dg) (f BinaryCoproduct.||| g)++instance+  ( HasWitness M.Monoidal cs+  , HasWitness BinaryCoproduct.HasBinaryCoproducts cs+  , Testable k+  , Distributive.Distributive k+  , TestOb (M.Unit :: k)+  , TestOb (Initial.InitialObject :: k)+  )+  => Distributive.Distributive (TESTED cs k)+  where+  distL @a @b @c = untestOb3 @a @b @c (prim "distL" (Distributive.distL @k @(Untest a) @(Untest b) @(Untest c)))+  distR @a @b @c = untestOb3 @a @b @c (prim "distR" (Distributive.distR @k @(Untest a) @(Untest b) @(Untest c)))+  absorbL @a = untestOb @a (prim "absorbL" (Distributive.absorbL @k @(Untest a)))+  absorbR @a = untestOb @a (prim "absorbR" (Distributive.absorbR @k @(Untest a)))++instance+  (Testable k, Terminal.HasTerminalObject k, TestOb (Terminal.TerminalObject :: k))+  => Terminal.HasTerminalObject (TESTED cs k)+  where+  type TerminalObject = Terminal.TermF+  terminate @a = untestOb @a (prim "terminate" Terminal.terminate)++instance+  (HasWitness M.Monoidal cs, HasWitness Exponential.Closed cs, Testable k, Exponential.Closed k, TestOb (M.Unit :: k))+  => Exponential.Closed (TESTED cs k)+  where+  type a ~~> b = a Exponential.--> b+  withObExp r = r+  curry @a @b (TestedArr df f) = untestOb2 @a @b (TestedArr (app "curry" df) (Exponential.curry @k @(Untest a) @(Untest b) f))+  apply @a @b = untestOb2 @a @b (prim "apply" (Exponential.apply @k @(Untest a) @(Untest b)))++  -- '^^^' is infixl 9 and '.' infixr 9, so '^^^' is parenthesized under either side of '.'.+  TestedArr df f ^^^ TestedArr dg g =+    TestedArr (\d -> showParen (d >= 9) (df 9 . showString " ^^^ " . dg 10)) (f Exponential.^^^ g)++instance+  ( HasWitness M.Monoidal cs+  , HasWitness Exponential.Closed cs+  , HasWitness SA.StarAutonomous cs+  , Testable k+  , SA.StarAutonomous k+  , TestOb (M.Unit :: k)+  )+  => SA.StarAutonomous (TESTED cs k)+  where+  type Dual a = SA.DualF a+  withObDual r = r+  dual (TestedArr df f) = TestedArr (app "dual" df) (SA.dual f)+  dualInv @a @b (TestedArr df f) = untestOb2 @a @b (TestedArr (app "dualInv" df) (SA.dualInv @k @(Untest a) @(Untest b) f))+  linDist @a @b @c (TestedArr df f) =+    untestOb3 @a @b @c (TestedArr (app "linDist" df) (SA.linDist @k @(Untest a) @(Untest b) @(Untest c) f))+  linDistInv @a @b @c (TestedArr df f) =+    untestOb3 @a @b @c (TestedArr (app "linDistInv" df) (SA.linDistInv @k @(Untest a) @(Untest b) @(Untest c) f))+  doubleNeg @a = untestOb @a (prim "doubleNeg" (SA.doubleNeg @k @(Untest a)))+  doubleNegInv @a = untestOb @a (prim "doubleNegInv" (SA.doubleNegInv @k @(Untest a)))++instance+  ( HasWitness M.Monoidal cs+  , HasWitness Exponential.Closed cs+  , HasWitness SA.StarAutonomous cs+  , Testable k+  , CC.CompactClosed k+  , TestOb (M.Unit :: k)+  )+  => CC.CompactClosed (TESTED cs k)+  where+  distribDual @a @b = untestOb2 @a @b (prim "distribDual" (CC.distribDual @k @(Untest a) @(Untest b)))+  dualUnit = prim "dualUnit" CC.dualUnit+  dualityUnit @a = untestOb @a (prim "dualityUnit" (CC.dualityUnit @k @(Untest a)))+  dualityCounit @a = untestOb @a (prim "dualityCounit" (CC.dualityCounit @k @(Untest a)))++-- | Every object is a monoid when the category supplies them, with the monoid of the object it+-- stands for.+instance+  (HasWitness M.Monoidal cs, Testable k, M.Monoidal k, Monoid.Supplies Monoid.Monoid k, TestOb (M.Unit :: k), Tested a)+  => Monoid.Monoid (a :: TESTED cs k)+  where+  mempty = untestOb @a (prim "mempty" (Monoid.mempty @(Untest a)))+  mappend = untestOb @a (prim "mappend" (Monoid.mappend @(Untest a)))++-- | Every object is a comonoid when the category supplies them.+instance+  (HasWitness M.Monoidal cs, Testable k, M.Monoidal k, Monoid.Supplies Monoid.Comonoid k, TestOb (M.Unit :: k), Tested a)+  => Monoid.Comonoid (a :: TESTED cs k)+  where+  counit = untestOb @a (prim "counit" (Monoid.counit @(Untest a)))+  comult = untestOb @a (prim "comult" (Monoid.comult @(Untest a)))++-- | The monoids of a category that supplies commutative ones are commutative.+instance+  ( HasWitness M.Monoidal cs+  , Testable k+  , M.SymMonoidal k+  , Monoid.Supplies Monoid.CommutativeMonoid k+  , TestOb (M.Unit :: k)+  , Tested a+  )+  => Monoid.CommutativeMonoid (a :: TESTED cs k)++-- | The comonoids of a category that supplies cocommutative ones are cocommutative.+instance+  ( HasWitness M.Monoidal cs+  , Testable k+  , M.SymMonoidal k+  , Monoid.Supplies Monoid.CocommutativeComonoid k+  , TestOb (M.Unit :: k)+  , Tested a+  )+  => Monoid.CocommutativeComonoid (a :: TESTED cs k)++-- | 'Strength.act' of the tensor of @p@.+instance+  (HasWitness M.Monoidal cs, Testable k, M.Monoidal k, Strength.Strong M.Tensor p, TestOb (M.Unit :: k))+  => Strength.Strong M.Tensor (TestedP p :: CAT (TESTED cs k))+  where+  act @a (TestedP dx x) = untestOb @a (TestedP (app "act" dx) (Strength.act @M.Tensor @p @(Untest a) x))++-- | 'Strength.coact' over the tensor of @p@, e.g. the trace of the category the objects stand for.+instance+  (HasWitness M.Monoidal cs, Testable k, M.Monoidal k, Strength.Costrong M.Tensor p, TestOb (M.Unit :: k))+  => Strength.Costrong M.Tensor (TestedP p :: CAT (TESTED cs k))+  where+  coact @a @x @y (TestedP df f) =+    untestOb3 @a @x @y (TestedP (app "coact" df) (Strength.coact @M.Tensor @p @(Untest a) @(Untest x) @(Untest y) f))++-- | Copying and discarding in the category the objects stand for.+instance+  (HasWitness M.Monoidal cs, Testable k, CopyDiscard.CopyDiscard k, TestOb (M.Unit :: k))+  => CopyDiscard.CopyDiscard (TESTED cs k)+  where+  copy @a = untestOb @a (prim "copy" (CopyDiscard.copy @k @(Untest a)))+  discard @a = untestOb @a (prim "discard" (CopyDiscard.discard @k @(Untest a)))++instance (CategoryOf k) => Laws.Labelled (TESTED cs k) where+  label s (TestedArr _ f) = prim s f++-- * The testable-objects profunctor++-- | An element of @p@ between the objects the endpoints stand for, with a description of how it+-- was built, for printing a failing law.+type TestedP :: forall {csj} {csk} {j} {k}. (j +-> k) -> TESTED csj j +-> TESTED csk k+data TestedP p a b where+  TestedP :: (Tested a, Tested b) => Doc -> p (Untest a) (Untest b) -> TestedP p a b++instance (Profunctor p) => Profunctor (TestedP p :: TESTED csj j +-> TESTED csk k) where+  dimap (TestedArr df f) (TestedArr dg g) (TestedP dx x) = TestedP (apps "dimap" [df, dg, dx]) (dimap f g x)+  lmap (TestedArr df f) (TestedP dx x) = TestedP (apps "lmap" [df, dx]) (lmap f x)+  rmap (TestedArr dg g) (TestedP dx x) = TestedP (apps "rmap" [dg, dx]) (rmap g x)+  r \\ TestedP{} = r++instance (Promonad p) => Promonad (TestedP p :: CAT (TESTED cs k)) where+  id @a = untestOb @a (prim "id" id)+  TestedP dy y . TestedP dx x = TestedP (infixrDoc 9 " . " dy dx) (y . x)++-- | The object @p '%' b@, for the interpretation of a 'Representable' @p@.+type RepF :: forall {csj} {j} {k} {o}. (j +-> k) -> TESTED csj j -> o+data family RepF p b++-- | The structure of being closed under the representing functor of @p@, whose objects in 'TESTED'+-- are formed by 'RepF'. Its witness needs the witnesses of the domain @j@ of @p@, @csj@.+type RepresentedBy :: forall {j} {k}. [Kind -> Constraint] -> (j +-> k) -> Kind -> Constraint+class RepresentedBy csj p k'++instance RepresentedBy csj p k'++data instance Witness (RepresentedBy csj (p :: j +-> k)) k' = RepresentedW (Witnesses csj j) (WithTestObRep j p)++instance+  (HasWitness (RepresentedBy csj p) csk, Representable p, Tested (b :: TESTED csj j))+  => Tested (RepF (p :: j +-> k) b :: TESTED csk k)+  where+  type Untest (RepF p b) = p % Untest b+  untestOb r = untestOb @b (withObRep @p @(Untest b) r)+  untestTestOb ws r = case witness @(RepresentedBy csj p) ws of+    RepresentedW wsj f -> untestTestOb @b wsj (f @(Untest b) r)++instance+  (HasWitness (RepresentedBy csj p) csk, Representable p)+  => Representable (TestedP p :: TESTED csj j +-> TESTED csk k)+  where+  type TestedP p % b = RepF p b+  index (TestedP dx x) = TestedArr (app "index" dx) (index x)+  tabulate @b (TestedArr df f) = untestOb @b (TestedP (app "tabulate" df) (tabulate @p @(Untest b) f))+  repMap (TestedArr df f) = TestedArr (app "repMap" df) (repMap @p f)+  repUniv @b = untestOb @b (prim "repUniv" (repUniv @p @(Untest b)))++-- | The object @p '%%' a@, for the interpretation of a 'Corepresentable' @p@.+type CorepF :: forall {csk} {j} {k} {o}. (j +-> k) -> TESTED csk k -> o+data family CorepF p a++-- | The structure of being closed under the corepresenting functor of @p@, whose objects in+-- 'TESTED' are formed by 'CorepF'. Its witness needs the witnesses of the codomain @k@ of @p@,+-- @csk@.+type CorepresentedBy :: forall {j} {k}. [Kind -> Constraint] -> (j +-> k) -> Kind -> Constraint+class CorepresentedBy csk p j'++instance CorepresentedBy csk p j'++data instance Witness (CorepresentedBy csk (p :: j +-> k)) j' = CorepresentedW (Witnesses csk k) (WithTestObCorep k p)++instance+  (HasWitness (CorepresentedBy csk p) csj, Corepresentable p, Tested (a :: TESTED csk k))+  => Tested (CorepF (p :: j +-> k) a :: TESTED csj j)+  where+  type Untest (CorepF p a) = p %% Untest a+  untestOb r = untestOb @a (withObCorep @p @(Untest a) r)+  untestTestOb ws r = case witness @(CorepresentedBy csk p) ws of+    CorepresentedW wsk f -> untestTestOb @a wsk (f @(Untest a) r)++instance+  (HasWitness (CorepresentedBy csk p) csj, Corepresentable p)+  => Corepresentable (TestedP p :: TESTED csj j +-> TESTED csk k)+  where+  type TestedP p %% a = CorepF p a+  coindex (TestedP dx x) = TestedArr (app "coindex" dx) (coindex x)+  cotabulate @a (TestedArr df f) = untestOb @a (TestedP (app "cotabulate" df) (cotabulate @p @(Untest a) f))+  corepMap (TestedArr df f) = TestedArr (app "corepMap" df) (corepMap @p f)+  corepUniv @a = untestOb @a (prim "corepUniv" (corepUniv @p @(Untest a)))++instance (DaggerProfunctor p) => DaggerProfunctor (TestedP p :: CAT (TESTED cs k)) where+  dagger (TestedP d x) = TestedP (app "dagger" d) (dagger x)++instance (Finitary p) => Finitary (TestedP p :: TESTED csj j +-> TESTED csk k) where+  size @a @b = untestOb2 @a @b (size @p @(Untest a) @(Untest b))+  toIndex @a @b (TestedP _ x) = untestOb2 @a @b (toIndex @p @(Untest a) @(Untest b) x)+  fromIndex @a @b i = untestOb2 @a @b (TestedP (app "fromIndex" (\_ -> shows i)) (fromIndex @p @(Untest a) @(Untest b) i))++-- | The adjunction of the profunctors the objects stand for. The middle object of the 'Adj.unit'+-- is only known to be an object, so it becomes a leaf, which needs 'TestOb' to follow from 'Ob'.+instance+  (Adj.Proadjunction p q, Testable j, Testable k, TestObIsOb j, TestObIsOb k)+  => Adj.Proadjunction (TestedP p :: TESTED csj j +-> TESTED csk k) (TestedP q :: TESTED csk k +-> TESTED csj j)+  where+  unit @a = untestOb @a case Adj.unit @p @q @(Untest a) of+    (:.:) @m l r -> (:.:) @(TLeaf m :: TESTED csk k) (TestedP (atom "unitQ") l) (TestedP (atom "unitP") r) \\ l+  counit (TestedP dp x :.: TestedP dq y) = TestedArr (app "counit" (infixlDoc 9 " :.: " dp dq)) (Adj.counit (x :.: y))++-- | The procomonad the objects stand for. The middle object of 'Promonad.produplicate' is only+-- known to be an object, so it becomes a leaf, which needs 'TestOb' to follow from 'Ob'.+instance (Promonad.Procomonad p, Testable k, TestObIsOb k) => Promonad.Procomonad (TestedP p :: CAT (TESTED cs k)) where+  proextract (TestedP d x) = TestedArr (app "proextract" d) (Promonad.proextract x)+  produplicate (TestedP d x) = case Promonad.produplicate x of+    (:.:) @m l r -> (:.:) @(TLeaf m :: TESTED cs k) (TestedP (app "produplicate1" d) l) (TestedP (app "produplicate2" d) r) \\ l