diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for proarrow + +## 0.1.0.0 -- 2026-09-28 + +* First release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/fix-github-links.py b/fix-github-links.py new file mode 100644 --- /dev/null +++ b/fix-github-links.py @@ -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/.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/.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'(Source\s* 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; +} diff --git a/lattice.svg b/lattice.svg new file mode 100644 --- /dev/null +++ b/lattice.svg @@ -0,0 +1,298 @@ + + + + + + +optics + + + +Fold + +Fold + + + +AffineFold + +AffineFold + + + +Fold->AffineFold + + + + +Traversal + +Traversal + + + +Fold->Traversal + + + + +Getter + +Getter + + + +AffineFold->Getter + + + + +AffineTraversal + +AffineTraversal + + + +AffineFold->AffineTraversal + + + + +Lens + +Lens + + + +Getter->Lens + + + + +MonoidalLens + +MonoidalLens + + + +Getter->MonoidalLens + + + + +Review + +Review + + + +Prism + +Prism + + + +Review->Prism + + + + +AlgebraicLens + +AlgebraicLens m + + + +ClassifyingLens + +ClassifyingLens l + + + +AlgebraicLens->ClassifyingLens + + + + +Setter + +Setter + + + +Setter->Traversal + + + + +Cotraversal + +Cotraversal + + + +Setter->Cotraversal + + + + +Tracer + +Tracer + + + +Setter->Tracer + + + + +Glass + +Glass + + + +Setter->Glass + + + + +Traversal->AffineTraversal + + + + +MonoidalTraversal + +MonoidalTraversal + + + +Traversal->MonoidalTraversal + + + + +Kaleidoscope + +Kaleidoscope + + + +Cotraversal->Kaleidoscope + + + + +Iso + +Iso + + + +Tracer->Iso + + + + +Grate + +Grate + + + +Glass->Grate + + + + +Glass->Lens + + + + +Glass->MonoidalLens + + + + +AffineTraversal->Lens + + + + +AffineTraversal->MonoidalLens + + + + +AffineTraversal->Prism + + + + +MonoidalTraversal->MonoidalLens + + + + +MonoidalTraversal->Prism + + + + +PowerGrate + +PowerGrate + + + +MonoidalTraversal->PowerGrate + + + + +Kaleidoscope->ClassifyingLens + + + + +Kaleidoscope->Grate + + + + +Grate->PowerGrate + + + + +Lens->Iso + + + + +MonoidalLens->AlgebraicLens + + + + +MonoidalLens->Iso + + + + +Prism->Iso + + + + +PowerGrate->Iso + + + + diff --git a/mkdocs.sh b/mkdocs.sh new file mode 100644 --- /dev/null +++ b/mkdocs.sh @@ -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 <> 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 )?CommentsGithub=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 diff --git a/src/Proarrow.hs b/src/Proarrow.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow.hs @@ -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 (..)) diff --git a/src/Proarrow/Adjunction.hs b/src/Proarrow/Adjunction.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Adjunction.hs @@ -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) diff --git a/src/Proarrow/Category/Enriched.hs b/src/Proarrow/Category/Enriched.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Enriched.hs @@ -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 diff --git a/src/Proarrow/Category/Enriched/Dagger.hs b/src/Proarrow/Category/Enriched/Dagger.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Enriched/Dagger.hs @@ -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) diff --git a/src/Proarrow/Category/Enriched/Finitary.hs b/src/Proarrow/Category/Enriched/Finitary.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Enriched/Finitary.hs @@ -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)) diff --git a/src/Proarrow/Category/Enriched/Finitary/Sheaf.hs b/src/Proarrow/Category/Enriched/Finitary/Sheaf.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Enriched/Finitary/Sheaf.hs @@ -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)) diff --git a/src/Proarrow/Category/Enriched/Finitary/Topos.hs b/src/Proarrow/Category/Enriched/Finitary/Topos.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Enriched/Finitary/Topos.hs @@ -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)) diff --git a/src/Proarrow/Category/Enriched/Quantale.hs b/src/Proarrow/Category/Enriched/Quantale.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Enriched/Quantale.hs @@ -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" diff --git a/src/Proarrow/Category/Enriched/Thin.hs b/src/Proarrow/Category/Enriched/Thin.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Enriched/Thin.hs @@ -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 diff --git a/src/Proarrow/Category/Enriched/Thin/Composition.hs b/src/Proarrow/Category/Enriched/Thin/Composition.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Enriched/Thin/Composition.hs @@ -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 diff --git a/src/Proarrow/Category/Instance/Bool.hs b/src/Proarrow/Category/Instance/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Bool.hs @@ -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 diff --git a/src/Proarrow/Category/Instance/Collage.hs b/src/Proarrow/Category/Instance/Collage.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Collage.hs @@ -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') diff --git a/src/Proarrow/Category/Instance/Constraint.hs b/src/Proarrow/Category/Instance/Constraint.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Constraint.hs @@ -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 diff --git a/src/Proarrow/Category/Instance/Coproduct.hs b/src/Proarrow/Category/Instance/Coproduct.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Coproduct.hs @@ -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 diff --git a/src/Proarrow/Category/Instance/Cospan.hs b/src/Proarrow/Category/Instance/Cospan.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Cospan.hs @@ -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 diff --git a/src/Proarrow/Category/Instance/Cost.hs b/src/Proarrow/Category/Instance/Cost.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Cost.hs @@ -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 diff --git a/src/Proarrow/Category/Instance/Discrete.hs b/src/Proarrow/Category/Instance/Discrete.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Discrete.hs @@ -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 diff --git a/src/Proarrow/Category/Instance/Duploid.hs b/src/Proarrow/Category/Instance/Duploid.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Duploid.hs @@ -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)) diff --git a/src/Proarrow/Category/Instance/Fam.hs b/src/Proarrow/Category/Instance/Fam.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Fam.hs @@ -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) diff --git a/src/Proarrow/Category/Instance/FinHask.hs b/src/Proarrow/Category/Instance/FinHask.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/FinHask.hs @@ -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 diff --git a/src/Proarrow/Category/Instance/FinRel.hs b/src/Proarrow/Category/Instance/FinRel.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/FinRel.hs @@ -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)) diff --git a/src/Proarrow/Category/Instance/FinSet.hs b/src/Proarrow/Category/Instance/FinSet.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/FinSet.hs @@ -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 diff --git a/src/Proarrow/Category/Instance/Free.hs b/src/Proarrow/Category/Instance/Free.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Free.hs @@ -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 diff --git a/src/Proarrow/Category/Instance/Graph.hs b/src/Proarrow/Category/Instance/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Graph.hs @@ -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) diff --git a/src/Proarrow/Category/Instance/Hask.hs b/src/Proarrow/Category/Instance/Hask.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Hask.hs @@ -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 diff --git a/src/Proarrow/Category/Instance/IntConstruction.hs b/src/Proarrow/Category/Instance/IntConstruction.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/IntConstruction.hs @@ -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)) diff --git a/src/Proarrow/Category/Instance/Kleisli.hs b/src/Proarrow/Category/Instance/Kleisli.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Kleisli.hs @@ -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 #-} diff --git a/src/Proarrow/Category/Instance/Linear.hs b/src/Proarrow/Category/Instance/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Linear.hs @@ -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) diff --git a/src/Proarrow/Category/Instance/Mat.hs b/src/Proarrow/Category/Instance/Mat.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Mat.hs @@ -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)) diff --git a/src/Proarrow/Category/Instance/Monoid.hs b/src/Proarrow/Category/Instance/Monoid.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Monoid.hs @@ -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 diff --git a/src/Proarrow/Category/Instance/Nat.hs b/src/Proarrow/Category/Instance/Nat.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Nat.hs @@ -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 diff --git a/src/Proarrow/Category/Instance/Opposite.hs b/src/Proarrow/Category/Instance/Opposite.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Opposite.hs @@ -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 diff --git a/src/Proarrow/Category/Instance/Ordinal.hs b/src/Proarrow/Category/Instance/Ordinal.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Ordinal.hs @@ -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) diff --git a/src/Proarrow/Category/Instance/Paths.hs b/src/Proarrow/Category/Instance/Paths.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Paths.hs @@ -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 diff --git a/src/Proarrow/Category/Instance/PointedHask.hs b/src/Proarrow/Category/Instance/PointedHask.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/PointedHask.hs @@ -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 (): 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)) diff --git a/src/Proarrow/Category/Instance/Product.hs b/src/Proarrow/Category/Instance/Product.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Product.hs @@ -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 diff --git a/src/Proarrow/Category/Instance/Prof.hs b/src/Proarrow/Category/Instance/Prof.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Prof.hs @@ -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 diff --git a/src/Proarrow/Category/Instance/Rel.hs b/src/Proarrow/Category/Instance/Rel.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Rel.hs @@ -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 diff --git a/src/Proarrow/Category/Instance/Rep.hs b/src/Proarrow/Category/Instance/Rep.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Rep.hs @@ -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) diff --git a/src/Proarrow/Category/Instance/Simplex.hs b/src/Proarrow/Category/Instance/Simplex.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Simplex.hs @@ -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 diff --git a/src/Proarrow/Category/Instance/Span.hs b/src/Proarrow/Category/Instance/Span.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Span.hs @@ -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. diff --git a/src/Proarrow/Category/Instance/Sub.hs b/src/Proarrow/Category/Instance/Sub.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Sub.hs @@ -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 diff --git a/src/Proarrow/Category/Instance/Unit.hs b/src/Proarrow/Category/Instance/Unit.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Unit.hs @@ -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 diff --git a/src/Proarrow/Category/Instance/ZX.hs b/src/Proarrow/Category/Instance/ZX.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/ZX.hs @@ -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 diff --git a/src/Proarrow/Category/Instance/Zero.hs b/src/Proarrow/Category/Instance/Zero.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Instance/Zero.hs @@ -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 {} diff --git a/src/Proarrow/Category/Internal.hs b/src/Proarrow/Category/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Internal.hs @@ -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 diff --git a/src/Proarrow/Category/Monoidal.hs b/src/Proarrow/Category/Monoidal.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Monoidal.hs @@ -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' + ] diff --git a/src/Proarrow/Category/Monoidal/Action.hs b/src/Proarrow/Category/Monoidal/Action.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Monoidal/Action.hs @@ -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 diff --git a/src/Proarrow/Category/Monoidal/Applicative.hs b/src/Proarrow/Category/Monoidal/Applicative.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Monoidal/Applicative.hs @@ -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 diff --git a/src/Proarrow/Category/Monoidal/Cartesian.hs b/src/Proarrow/Category/Monoidal/Cartesian.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Monoidal/Cartesian.hs @@ -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 diff --git a/src/Proarrow/Category/Monoidal/Closed.hs b/src/Proarrow/Category/Monoidal/Closed.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Monoidal/Closed.hs @@ -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))) + ] diff --git a/src/Proarrow/Category/Monoidal/Coclosed.hs b/src/Proarrow/Category/Monoidal/Coclosed.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Monoidal/Coclosed.hs @@ -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 diff --git a/src/Proarrow/Category/Monoidal/CompactClosed.hs b/src/Proarrow/Category/Monoidal/CompactClosed.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Monoidal/CompactClosed.hs @@ -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 + ] diff --git a/src/Proarrow/Category/Monoidal/CopyDiscard.hs b/src/Proarrow/Category/Monoidal/CopyDiscard.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Monoidal/CopyDiscard.hs @@ -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 diff --git a/src/Proarrow/Category/Monoidal/Distributive.hs b/src/Proarrow/Category/Monoidal/Distributive.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Monoidal/Distributive.hs @@ -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)) diff --git a/src/Proarrow/Category/Monoidal/EndoProf.hs b/src/Proarrow/Category/Monoidal/EndoProf.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Monoidal/EndoProf.hs @@ -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) diff --git a/src/Proarrow/Category/Monoidal/Hypergraph.hs b/src/Proarrow/Category/Monoidal/Hypergraph.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Monoidal/Hypergraph.hs @@ -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) + ] diff --git a/src/Proarrow/Category/Monoidal/Rev.hs b/src/Proarrow/Category/Monoidal/Rev.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Monoidal/Rev.hs @@ -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 diff --git a/src/Proarrow/Category/Monoidal/StarAutonomous.hs b/src/Proarrow/Category/Monoidal/StarAutonomous.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Monoidal/StarAutonomous.hs @@ -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) diff --git a/src/Proarrow/Category/Monoidal/Strength.hs b/src/Proarrow/Category/Monoidal/Strength.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Monoidal/Strength.hs @@ -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)) + ] diff --git a/src/Proarrow/Category/Monoidal/Strictified.hs b/src/Proarrow/Category/Monoidal/Strictified.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Monoidal/Strictified.hs @@ -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] diff --git a/src/Proarrow/Category/Promonoidal.hs b/src/Proarrow/Category/Promonoidal.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Promonoidal.hs @@ -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)) diff --git a/src/Proarrow/Category/Sheaf.hs b/src/Proarrow/Category/Sheaf.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Sheaf.hs @@ -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, ). +-- 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 diff --git a/src/Proarrow/Category/Topos.hs b/src/Proarrow/Category/Topos.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Category/Topos.hs @@ -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 diff --git a/src/Proarrow/Colimit.hs b/src/Proarrow/Colimit.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Colimit.hs @@ -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) diff --git a/src/Proarrow/Colimit/BinaryCoproduct.hs b/src/Proarrow/Colimit/BinaryCoproduct.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Colimit/BinaryCoproduct.hs @@ -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) + ] diff --git a/src/Proarrow/Colimit/Coequalizer.hs b/src/Proarrow/Colimit/Coequalizer.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Colimit/Coequalizer.hs @@ -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) diff --git a/src/Proarrow/Colimit/Copower.hs b/src/Proarrow/Colimit/Copower.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Colimit/Copower.hs @@ -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)))) diff --git a/src/Proarrow/Colimit/Initial.hs b/src/Proarrow/Colimit/Initial.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Colimit/Initial.hs @@ -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 + ] diff --git a/src/Proarrow/Colimit/NaturalNumbers.hs b/src/Proarrow/Colimit/NaturalNumbers.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Colimit/NaturalNumbers.hs @@ -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 diff --git a/src/Proarrow/Colimit/Pushout.hs b/src/Proarrow/Colimit/Pushout.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Colimit/Pushout.hs @@ -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) diff --git a/src/Proarrow/Core.hs b/src/Proarrow/Core.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Core.hs @@ -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)) diff --git a/src/Proarrow/Functor.hs b/src/Proarrow/Functor.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Functor.hs @@ -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) diff --git a/src/Proarrow/Limit.hs b/src/Proarrow/Limit.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Limit.hs @@ -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) diff --git a/src/Proarrow/Limit/BinaryProduct.hs b/src/Proarrow/Limit/BinaryProduct.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Limit/BinaryProduct.hs @@ -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) + ] diff --git a/src/Proarrow/Limit/Equalizer.hs b/src/Proarrow/Limit/Equalizer.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Limit/Equalizer.hs @@ -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 diff --git a/src/Proarrow/Limit/Power.hs b/src/Proarrow/Limit/Power.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Limit/Power.hs @@ -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)))) diff --git a/src/Proarrow/Limit/Pullback.hs b/src/Proarrow/Limit/Pullback.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Limit/Pullback.hs @@ -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 diff --git a/src/Proarrow/Limit/Terminal.hs b/src/Proarrow/Limit/Terminal.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Limit/Terminal.hs @@ -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 + ] diff --git a/src/Proarrow/Monoid.hs b/src/Proarrow/Monoid.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Monoid.hs @@ -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)] diff --git a/src/Proarrow/Object.hs b/src/Proarrow/Object.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Object.hs @@ -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 #-} diff --git a/src/Proarrow/Optic.hs b/src/Proarrow/Optic.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Optic.hs @@ -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) diff --git a/src/Proarrow/Optic/Action.hs b/src/Proarrow/Optic/Action.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Optic/Action.hs @@ -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 diff --git a/src/Proarrow/Optic/AffineFold.hs b/src/Proarrow/Optic/AffineFold.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Optic/AffineFold.hs @@ -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) diff --git a/src/Proarrow/Optic/AffineTraversal.hs b/src/Proarrow/Optic/AffineTraversal.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Optic/AffineTraversal.hs @@ -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 diff --git a/src/Proarrow/Optic/Day.hs b/src/Proarrow/Optic/Day.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Optic/Day.hs @@ -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 diff --git a/src/Proarrow/Optic/Fold.hs b/src/Proarrow/Optic/Fold.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Optic/Fold.hs @@ -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)) diff --git a/src/Proarrow/Optic/Getter.hs b/src/Proarrow/Optic/Getter.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Optic/Getter.hs @@ -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 diff --git a/src/Proarrow/Optic/Glass.hs b/src/Proarrow/Optic/Glass.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Optic/Glass.hs @@ -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) diff --git a/src/Proarrow/Optic/Grate.hs b/src/Proarrow/Optic/Grate.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Optic/Grate.hs @@ -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) diff --git a/src/Proarrow/Optic/Iso.hs b/src/Proarrow/Optic/Iso.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Optic/Iso.hs @@ -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 diff --git a/src/Proarrow/Optic/Kaleidoscope.hs b/src/Proarrow/Optic/Kaleidoscope.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Optic/Kaleidoscope.hs @@ -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 diff --git a/src/Proarrow/Optic/Lens.hs b/src/Proarrow/Optic/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Optic/Lens.hs @@ -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))) diff --git a/src/Proarrow/Optic/MonoidalLens.hs b/src/Proarrow/Optic/MonoidalLens.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Optic/MonoidalLens.hs @@ -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 diff --git a/src/Proarrow/Optic/MonoidalTraversal.hs b/src/Proarrow/Optic/MonoidalTraversal.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Optic/MonoidalTraversal.hs @@ -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)) diff --git a/src/Proarrow/Optic/PowerGrate.hs b/src/Proarrow/Optic/PowerGrate.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Optic/PowerGrate.hs @@ -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') diff --git a/src/Proarrow/Optic/Prism.hs b/src/Proarrow/Optic/Prism.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Optic/Prism.hs @@ -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)) diff --git a/src/Proarrow/Optic/Prod.hs b/src/Proarrow/Optic/Prod.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Optic/Prod.hs @@ -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) diff --git a/src/Proarrow/Optic/Setter.hs b/src/Proarrow/Optic/Setter.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Optic/Setter.hs @@ -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) diff --git a/src/Proarrow/Optic/Sum.hs b/src/Proarrow/Optic/Sum.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Optic/Sum.hs @@ -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) diff --git a/src/Proarrow/Optic/Tracer.hs b/src/Proarrow/Optic/Tracer.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Optic/Tracer.hs @@ -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) diff --git a/src/Proarrow/Optic/Traversal.hs b/src/Proarrow/Optic/Traversal.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Optic/Traversal.hs @@ -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 diff --git a/src/Proarrow/Optics.hs b/src/Proarrow/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Optics.hs @@ -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': +-- +-- <> +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) diff --git a/src/Proarrow/Path.hs b/src/Proarrow/Path.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Path.hs @@ -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 diff --git a/src/Proarrow/Profunctor/Cofree.hs b/src/Proarrow/Profunctor/Cofree.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Cofree.hs @@ -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 diff --git a/src/Proarrow/Profunctor/Corepresentable.hs b/src/Proarrow/Profunctor/Corepresentable.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Corepresentable.hs @@ -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 diff --git a/src/Proarrow/Profunctor/Free.hs b/src/Proarrow/Profunctor/Free.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Free.hs @@ -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] diff --git a/src/Proarrow/Profunctor/Instance/Adj.hs b/src/Proarrow/Profunctor/Instance/Adj.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Adj.hs @@ -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)) diff --git a/src/Proarrow/Profunctor/Instance/Arrow.hs b/src/Proarrow/Profunctor/Instance/Arrow.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Arrow.hs @@ -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)) diff --git a/src/Proarrow/Profunctor/Instance/Cocone.hs b/src/Proarrow/Profunctor/Instance/Cocone.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Cocone.hs @@ -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 diff --git a/src/Proarrow/Profunctor/Instance/Composition.hs b/src/Proarrow/Profunctor/Instance/Composition.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Composition.hs @@ -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) diff --git a/src/Proarrow/Profunctor/Instance/Cone.hs b/src/Proarrow/Profunctor/Instance/Cone.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Cone.hs @@ -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 diff --git a/src/Proarrow/Profunctor/Instance/Constant.hs b/src/Proarrow/Profunctor/Instance/Constant.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Constant.hs @@ -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 diff --git a/src/Proarrow/Profunctor/Instance/Coproduct.hs b/src/Proarrow/Profunctor/Instance/Coproduct.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Coproduct.hs @@ -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) diff --git a/src/Proarrow/Profunctor/Instance/Costar.hs b/src/Proarrow/Profunctor/Instance/Costar.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Costar.hs @@ -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 diff --git a/src/Proarrow/Profunctor/Instance/Coyoneda.hs b/src/Proarrow/Profunctor/Instance/Coyoneda.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Coyoneda.hs @@ -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 diff --git a/src/Proarrow/Profunctor/Instance/Day.hs b/src/Proarrow/Profunctor/Instance/Day.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Day.hs @@ -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 diff --git a/src/Proarrow/Profunctor/Instance/Direp.hs b/src/Proarrow/Profunctor/Instance/Direp.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Direp.hs @@ -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 diff --git a/src/Proarrow/Profunctor/Instance/Edges.hs b/src/Proarrow/Profunctor/Instance/Edges.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Edges.hs @@ -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)) diff --git a/src/Proarrow/Profunctor/Instance/Exponential.hs b/src/Proarrow/Profunctor/Instance/Exponential.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Exponential.hs @@ -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 diff --git a/src/Proarrow/Profunctor/Instance/Fix.hs b/src/Proarrow/Profunctor/Instance/Fix.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Fix.hs @@ -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' diff --git a/src/Proarrow/Profunctor/Instance/Fold.hs b/src/Proarrow/Profunctor/Instance/Fold.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Fold.hs @@ -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 diff --git a/src/Proarrow/Profunctor/Instance/HaskValue.hs b/src/Proarrow/Profunctor/Instance/HaskValue.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/HaskValue.hs @@ -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 diff --git a/src/Proarrow/Profunctor/Instance/Identity.hs b/src/Proarrow/Profunctor/Instance/Identity.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Identity.hs @@ -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 diff --git a/src/Proarrow/Profunctor/Instance/Initial.hs b/src/Proarrow/Profunctor/Instance/Initial.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Initial.hs @@ -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 {} diff --git a/src/Proarrow/Profunctor/Instance/List.hs b/src/Proarrow/Profunctor/Instance/List.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/List.hs @@ -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) diff --git a/src/Proarrow/Profunctor/Instance/PastroTambara.hs b/src/Proarrow/Profunctor/Instance/PastroTambara.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/PastroTambara.hs @@ -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)) diff --git a/src/Proarrow/Profunctor/Instance/Product.hs b/src/Proarrow/Profunctor/Instance/Product.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Product.hs @@ -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 diff --git a/src/Proarrow/Profunctor/Instance/Ran.hs b/src/Proarrow/Profunctor/Instance/Ran.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Ran.hs @@ -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) diff --git a/src/Proarrow/Profunctor/Instance/Rift.hs b/src/Proarrow/Profunctor/Instance/Rift.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Rift.hs @@ -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) diff --git a/src/Proarrow/Profunctor/Instance/Sieve.hs b/src/Proarrow/Profunctor/Instance/Sieve.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Sieve.hs @@ -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 diff --git a/src/Proarrow/Profunctor/Instance/Star.hs b/src/Proarrow/Profunctor/Instance/Star.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Star.hs @@ -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 diff --git a/src/Proarrow/Profunctor/Instance/Terminal.hs b/src/Proarrow/Profunctor/Instance/Terminal.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Terminal.hs @@ -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 diff --git a/src/Proarrow/Profunctor/Instance/Wrapped.hs b/src/Proarrow/Profunctor/Instance/Wrapped.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Wrapped.hs @@ -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 diff --git a/src/Proarrow/Profunctor/Instance/Yoneda.hs b/src/Proarrow/Profunctor/Instance/Yoneda.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Instance/Yoneda.hs @@ -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) diff --git a/src/Proarrow/Profunctor/Representable.hs b/src/Proarrow/Profunctor/Representable.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Profunctor/Representable.hs @@ -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)) diff --git a/src/Proarrow/Promonad.hs b/src/Proarrow/Promonad.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Promonad.hs @@ -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 diff --git a/src/Proarrow/Promonad/Cont.hs b/src/Proarrow/Promonad/Cont.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Promonad/Cont.hs @@ -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 diff --git a/src/Proarrow/Promonad/Reader.hs b/src/Proarrow/Promonad/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Promonad/Reader.hs @@ -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) diff --git a/src/Proarrow/Promonad/State.hs b/src/Proarrow/Promonad/State.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Promonad/State.hs @@ -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) diff --git a/src/Proarrow/Promonad/Writer.hs b/src/Proarrow/Promonad/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Promonad/Writer.hs @@ -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 diff --git a/src/Proarrow/Squares.hs b/src/Proarrow/Squares.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Squares.hs @@ -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 +-- > | | +-- > | /- | 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<--@-- 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' diff --git a/src/Proarrow/Tools/CCC.hs b/src/Proarrow/Tools/CCC.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Tools/CCC.hs @@ -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)) diff --git a/src/Proarrow/Tools/DPO.hs b/src/Proarrow/Tools/DPO.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Tools/DPO.hs @@ -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)]) diff --git a/src/Proarrow/Tools/Diagrams/Dot.hs b/src/Proarrow/Tools/Diagrams/Dot.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Tools/Diagrams/Dot.hs @@ -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=<" + ++ "
" + ++ ports "i" ins + ++ "
" + ++ htmlEscape s + ++ "
" + ++ ports "o" outs + ++ "
>" + where + ports :: String -> Int -> String + ports port n = + "" + ++ "" + ++ List.intercalate + "" + ["" | i <- [0 .. n - 1 :: Int]] + ++ "
" + +-- | 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 '<' -> "<"; '>' -> ">"; '&' -> "&"; 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=<" + ++ foldMap (\(i, n) -> "") (zip [0 :: Int ..] ws) + ++ "
" ++ htmlEscape n ++ "
>];" + +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=ϵ" diff --git a/src/Proarrow/Tools/Diagrams/Svg.hs b/src/Proarrow/Tools/Diagrams/Svg.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Tools/Diagrams/Svg.hs @@ -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 = + "" + -- 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] + ++ "" + 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 = "" ++ concatMap path ds ++ "" + 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 = "" + +-- | 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 "" + Point (x, y) filled -> "" + 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) = + "" + text cls (x, y) s = "" ++ Dot.htmlEscape s ++ "" + +-- | 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 "" diff --git a/src/Proarrow/Tools/Laws.hs b/src/Proarrow/Tools/Laws.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Tools/Laws.hs @@ -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 diff --git a/src/Proarrow/Universal.hs b/src/Proarrow/Universal.hs new file mode 100644 --- /dev/null +++ b/src/Proarrow/Universal.hs @@ -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 diff --git a/test/Examples/Cofree.hs b/test/Examples/Cofree.hs new file mode 100644 --- /dev/null +++ b/test/Examples/Cofree.hs @@ -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) diff --git a/test/Examples/CustomLaws.hs b/test/Examples/CustomLaws.hs new file mode 100644 --- /dev/null +++ b/test/Examples/CustomLaws.hs @@ -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) diff --git a/test/Examples/Database.hs b/test/Examples/Database.hs new file mode 100644 --- /dev/null +++ b/test/Examples/Database.hs @@ -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") + ] diff --git a/test/Examples/Free.hs b/test/Examples/Free.hs new file mode 100644 --- /dev/null +++ b/test/Examples/Free.hs @@ -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")) + ] diff --git a/test/Examples/FrontDoor.hs b/test/Examples/FrontDoor.hs new file mode 100644 --- /dev/null +++ b/test/Examples/FrontDoor.hs @@ -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 diff --git a/test/Examples/Graph.hs b/test/Examples/Graph.hs new file mode 100644 --- /dev/null +++ b/test/Examples/Graph.hs @@ -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" + ] diff --git a/test/Examples/Readme.hs b/test/Examples/Readme.hs new file mode 100644 --- /dev/null +++ b/test/Examples/Readme.hs @@ -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 diff --git a/test/Examples/SimplyTypedLambdaCalculus.hs b/test/Examples/SimplyTypedLambdaCalculus.hs new file mode 100644 --- /dev/null +++ b/test/Examples/SimplyTypedLambdaCalculus.hs @@ -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] + ] diff --git a/test/Examples/UntypedLambdaCalculus.hs b/test/Examples/UntypedLambdaCalculus.hs new file mode 100644 --- /dev/null +++ b/test/Examples/UntypedLambdaCalculus.hs @@ -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)) diff --git a/test/Examples/Vitrea.hs b/test/Examples/Vitrea.hs new file mode 100644 --- /dev/null +++ b/test/Examples/Vitrea.hs @@ -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"] + ] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ] + ] diff --git a/test/Props/Bool.hs b/test/Props/Bool.hs new file mode 100644 --- /dev/null +++ b/test/Props/Bool.hs @@ -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 diff --git a/test/Props/Cospan.hs b/test/Props/Cospan.hs new file mode 100644 --- /dev/null +++ b/test/Props/Cospan.hs @@ -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)) diff --git a/test/Props/Cost.hs b/test/Props/Cost.hs new file mode 100644 --- /dev/null +++ b/test/Props/Cost.hs @@ -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 diff --git a/test/Props/DPO.hs b/test/Props/DPO.hs new file mode 100644 --- /dev/null +++ b/test/Props/DPO.hs @@ -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 ()) + ] diff --git a/test/Props/Discrete.hs b/test/Props/Discrete.hs new file mode 100644 --- /dev/null +++ b/test/Props/Discrete.hs @@ -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 diff --git a/test/Props/Dot.hs b/test/Props/Dot.hs new file mode 100644 --- /dev/null +++ b/test/Props/Dot.hs @@ -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 diff --git a/test/Props/FinHask.hs b/test/Props/FinHask.hs new file mode 100644 --- /dev/null +++ b/test/Props/FinHask.hs @@ -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 diff --git a/test/Props/FinRel.hs b/test/Props/FinRel.hs new file mode 100644 --- /dev/null +++ b/test/Props/FinRel.hs @@ -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] diff --git a/test/Props/FinSet.hs b/test/Props/FinSet.hs new file mode 100644 --- /dev/null +++ b/test/Props/FinSet.hs @@ -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 diff --git a/test/Props/Finitary.hs b/test/Props/Finitary.hs new file mode 100644 --- /dev/null +++ b/test/Props/Finitary.hs @@ -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) + ] diff --git a/test/Props/Finitary/Graph.hs b/test/Props/Finitary/Graph.hs new file mode 100644 --- /dev/null +++ b/test/Props/Finitary/Graph.hs @@ -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)) + ] diff --git a/test/Props/Free.hs b/test/Props/Free.hs new file mode 100644 --- /dev/null +++ b/test/Props/Free.hs @@ -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) + ] diff --git a/test/Props/Hask.hs b/test/Props/Hask.hs new file mode 100644 --- /dev/null +++ b/test/Props/Hask.hs @@ -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)) diff --git a/test/Props/Kleisli.hs b/test/Props/Kleisli.hs new file mode 100644 --- /dev/null +++ b/test/Props/Kleisli.hs @@ -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 diff --git a/test/Props/Mat.hs b/test/Props/Mat.hs new file mode 100644 --- /dev/null +++ b/test/Props/Mat.hs @@ -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) diff --git a/test/Props/Optic/FinRel.hs b/test/Props/Optic/FinRel.hs new file mode 100644 --- /dev/null +++ b/test/Props/Optic/FinRel.hs @@ -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))) + ] diff --git a/test/Props/Optic/Hask.hs b/test/Props/Optic/Hask.hs new file mode 100644 --- /dev/null +++ b/test/Props/Optic/Hask.hs @@ -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 diff --git a/test/Props/Optic/Linear.hs b/test/Props/Optic/Linear.hs new file mode 100644 --- /dev/null +++ b/test/Props/Optic/Linear.hs @@ -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 + ] diff --git a/test/Props/Ordinal.hs b/test/Props/Ordinal.hs new file mode 100644 --- /dev/null +++ b/test/Props/Ordinal.hs @@ -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 diff --git a/test/Props/Paths.hs b/test/Props/Paths.hs new file mode 100644 --- /dev/null +++ b/test/Props/Paths.hs @@ -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] + ] diff --git a/test/Props/PointedHask.hs b/test/Props/PointedHask.hs new file mode 100644 --- /dev/null +++ b/test/Props/PointedHask.hs @@ -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 _ = "" +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" diff --git a/test/Props/Sheaf.hs b/test/Props/Sheaf.hs new file mode 100644 --- /dev/null +++ b/test/Props/Sheaf.hs @@ -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") + ] + ] diff --git a/test/Props/Sheaf/Chain.hs b/test/Props/Sheaf/Chain.hs new file mode 100644 --- /dev/null +++ b/test/Props/Sheaf/Chain.hs @@ -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)) + ] + ] diff --git a/test/Props/Sheaf/Collage.hs b/test/Props/Sheaf/Collage.hs new file mode 100644 --- /dev/null +++ b/test/Props/Sheaf/Collage.hs @@ -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") + ] diff --git a/test/Props/Simplex.hs b/test/Props/Simplex.hs new file mode 100644 --- /dev/null +++ b/test/Props/Simplex.hs @@ -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)) diff --git a/test/Props/Span.hs b/test/Props/Span.hs new file mode 100644 --- /dev/null +++ b/test/Props/Span.hs @@ -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)) diff --git a/test/Props/Svg.hs b/test/Props/Svg.hs new file mode 100644 --- /dev/null +++ b/test/Props/Svg.hs @@ -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) diff --git a/test/Props/ZX.hs b/test/Props/ZX.hs new file mode 100644 --- /dev/null +++ b/test/Props/ZX.hs @@ -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 diff --git a/testing/Proarrow/Testing.hs b/testing/Proarrow/Testing.hs new file mode 100644 --- /dev/null +++ b/testing/Proarrow/Testing.hs @@ -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 _ = "" + +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 diff --git a/testing/Proarrow/Testing/Laws.hs b/testing/Proarrow/Testing/Laws.hs new file mode 100644 --- /dev/null +++ b/testing/Proarrow/Testing/Laws.hs @@ -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 @\@. 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]) + ] + ) diff --git a/testing/Proarrow/Testing/Laws/Run.hs b/testing/Proarrow/Testing/Laws/Run.hs new file mode 100644 --- /dev/null +++ b/testing/Proarrow/Testing/Laws/Run.hs @@ -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