git.iko.soy/semi-iso-optics
on master help sign in
swap
de16c6d14 ahead, 0 behind
15 files changed+703−291
since splitsnapshots
unifiedsplit
.github/workflows/haskell.yml+22 .gitignore+15−38 .travis.yml+132 Control/Category/Structures.hs−113 LICENSE+1 package.yaml+44 semi-iso.cabal−71 Control/Category/Reader.hs → src/Control/Category/Reader.hs+9−5 src/Control/Category/Structures.hs+31 Control/Lens/Internal/SemiIso.hs → src/Control/Lens/Internal/SemiIso.hs+5−3 Control/Lens/SemiIso.hs → src/Control/Lens/SemiIso.hs+41−22 Control/SIArrow.hs → src/Control/SIArrow.hs+22−34 src/Control/Tuple/Morph.hs+305 Data/Profunctor/Exposed.hs → src/Data/Profunctor/Exposed.hs+7−5 stack.yaml+69
.github/workflows/haskell.ymlnew file+22
@@ -0,0 +1,22 @@
1+name: Haskell CI
2+
3+on: [pull_request]
4+
5+jobs:
6+ build:
7+
8+ runs-on: ubuntu-latest
9+
10+ steps:
11+ - uses: actions/checkout@v1
12+ - name: Install Stack
13+ run: |
14+ wget -qO- https://get.haskellstack.org/ | sh
15+
16+ - name: Build
17+ run: |
18+ stack build --fast --pedantic --ghc-options '-j'
19+
20+ - name: Weeder
21+ run: |
22+ curl -sSL https://raw.github.com/ndmitchell/weeder/master/misc/run.sh | sh -s . --build
.gitignore+15−38
@@ -1,47 +1,24 @@
1−# Created by https://www.gitignore.io
2−
3−### Haskell ###
41dist
2+dist-*
53cabal-dev
64*.o
75*.hi
6+*.hie
87*.chi
98*.chs.h
10−.virtualenv
9+*.dyn_o
10+*.dyn_hi
11+.hpc
1112.hsenv
1213.cabal-sandbox/
1314cabal.sandbox.config
14−cabal.config
15−
16−
17−### Emacs ###
18−# -*- mode: gitignore; -*-
19−*~
20−\#*\#
21−/.emacs.desktop
22−/.emacs.desktop.lock
23−*.elc
24−auto-save-list
25−tramp
26−.\#*
27−
28−# Org-mode
29−.org-id-locations
30−*_archive
31−
32−# flymake-mode
33−*_flymake.*
34−
35−# eshell files
36−/eshell/history
37−/eshell/lastdir
38−
39−# elpa packages
40−/elpa/
41−
42−# reftex files
43−*.rel
44−
45−# AUCTeX auto folder
46−/auto/
47−
15+*.prof
16+*.aux
17+*.hp
18+*.eventlog
19+.stack-work/
20+cabal.project.local
21+cabal.project.local~
22+.HTF/
23+.ghc.environment.*
24+*.cabal
.travis.ymlnew file+132
@@ -0,0 +1,132 @@
1+# This Travis job script has been generated by a script via
2+#
3+# runghc make_travis_yml_2.hs 'semi-iso.cabal'
4+#
5+# For more information, see https://github.com/haskell-CI/haskell-ci
6+#
7+language: c
8+sudo: false
9+
10+git:
11+ submodules: false # whether to recursively clone submodules
12+
13+cache:
14+ directories:
15+ - $HOME/.cabal/packages
16+ - $HOME/.cabal/store
17+
18+before_cache:
19+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
20+ # remove files that are regenerated by 'cabal update'
21+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*
22+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json
23+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache
24+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar
25+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx
26+
27+ - rm -rfv $HOME/.cabal/packages/head.hackage
28+
29+matrix:
30+ include:
31+ - compiler: "ghc-8.6.1"
32+ env: GHCHEAD=true
33+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.6.1], sources: [hvr-ghc]}}
34+ - compiler: "ghc-8.4.3"
35+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
36+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}
37+ - compiler: "ghc-8.2.2"
38+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
39+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.2.2], sources: [hvr-ghc]}}
40+ - compiler: "ghc-8.0.2"
41+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
42+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.0.2], sources: [hvr-ghc]}}
43+
44+ allow_failures:
45+ - compiler: "ghc-8.6.1"
46+
47+before_install:
48+ - HC=${CC}
49+ - HCPKG=${HC/ghc/ghc-pkg}
50+ - unset CC
51+ - ROOTDIR=$(pwd)
52+ - mkdir -p $HOME/.local/bin
53+ - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"
54+ - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))
55+ - echo $HCNUMVER
56+
57+install:
58+ - cabal --version
59+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
60+ - BENCH=${BENCH---enable-benchmarks}
61+ - TEST=${TEST---enable-tests}
62+ - HADDOCK=${HADDOCK-true}
63+ - UNCONSTRAINED=${UNCONSTRAINED-true}
64+ - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false}
65+ - GHCHEAD=${GHCHEAD-false}
66+ - travis_retry cabal update -v
67+ - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"
68+ - rm -fv cabal.project cabal.project.local
69+ # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage
70+ - |
71+ if $GHCHEAD; then
72+ sed -i 's/-- allow-newer: .*/allow-newer: *:base/' ${HOME}/.cabal/config
73+ for pkg in $($HCPKG list --simple-output); do pkg=$(echo $pkg | sed 's/-[^-]*$//'); sed -i "s/allow-newer: /allow-newer: *:$pkg, /" ${HOME}/.cabal/config; done
74+
75+ echo 'repository head.hackage' >> ${HOME}/.cabal/config
76+ echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config
77+ echo ' secure: True' >> ${HOME}/.cabal/config
78+ echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config
79+ echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config
80+ echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config
81+ echo ' key-threshold: 3' >> ${HOME}/.cabal.config
82+
83+ grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'
84+
85+ cabal new-update head.hackage -v
86+ fi
87+ - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'
88+ - "printf 'packages: \".\"\\n' > cabal.project"
89+ - touch cabal.project.local
90+ - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- semi-iso | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"
91+ - cat cabal.project || true
92+ - cat cabal.project.local || true
93+ - if [ -f "./configure.ac" ]; then
94+ (cd "." && autoreconf -i);
95+ fi
96+ - rm -f cabal.project.freeze
97+ - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all
98+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all
99+ - rm -rf .ghc.environment.* "."/dist
100+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
101+
102+# Here starts the actual work to be performed for the package under test;
103+# any command which exits with a non-zero exit code causes the build to fail.
104+script:
105+ # test that source-distributions can be generated
106+ - (cd "." && cabal sdist)
107+ - mv "."/dist/semi-iso-*.tar.gz ${DISTDIR}/
108+ - cd ${DISTDIR} || false
109+ - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
110+ - "printf 'packages: semi-iso-*/*.cabal\\n' > cabal.project"
111+ - touch cabal.project.local
112+ - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- semi-iso | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"
113+ - cat cabal.project || true
114+ - cat cabal.project.local || true
115+ # this builds all libraries and executables (without tests/benchmarks)
116+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
117+
118+ # build & run tests, build benchmarks
119+ - cabal new-build -w ${HC} ${TEST} ${BENCH} all
120+
121+ # cabal check
122+ - (cd semi-iso-* && cabal check)
123+
124+ # haddock
125+ - rm -rf ./dist-newstyle
126+ - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi
127+
128+ # Build without installed constraints for packages in global-db
129+ - if $UNCONSTRAINED; then rm -f cabal.project.local; echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks all; else echo "Not building without installed constraints"; fi
130+
131+# REGENDATA ["semi-iso.cabal"]
132+# EOF
Control/Category/Structures.hsdeleted−113
@@ -1,113 +0,0 @@
1−{-# LANGUAGE TypeFamilies #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE ConstraintKinds #-}
4−{- |
5−Module : Control.Category.Structures
6−Description : Structures in a category.
7−Copyright : (c) Paweł Nowak
8−License : MIT
9−
10−Maintainer : Paweł Nowak <pawel834@gmail.com>
11−Stability : experimental
12−
13−This module defines some basic structures in a category in a more fine-grained
14−way then "Control.Arrow".
15−
16−Unfortunately names in this module clash with "Control.Arrow".
17−-}
18−module Control.Category.Structures where
19−
20−import Control.Arrow (Kleisli(..))
21−import qualified Control.Arrow as BadArrow
22−import Control.Category
23−import Control.Monad
24−import Data.Semigroupoid.Dual
25−import Prelude hiding (id, (.))
26−
27−infixl 3 ***
28−infixl 2 +++
29−infixl 3 /+/
30−
31−-- | A category with finite products.
32−class Category cat => Products cat where
33− -- | Send the first component of the input through the argument arrow, and copy the rest unchanged to the output.
34− --
35− -- @first a@ is equal to @a *** id@.
36− first :: cat a b -> cat (a, c) (b, c)
37− first a = a *** id
38−
39− -- | A mirror image of 'first'.
40− --
41− -- @second a@ is equal to @id *** a@.
42− second :: cat a b -> cat (c, a) (c, b)
43− second a = id *** a
44−
45− -- | A product of two arrows.
46− -- Split the input between the two argument arrows and combine their output.
47− (***) :: cat a b -> cat c d -> cat (a, c) (b, d)
48− a *** b = first a >>> second b
49−
50− {-# MINIMAL (***) | first, second #-}
51−
52−instance Monad m => Products (Kleisli m) where
53− (***) = (BadArrow.***)
54−
55−instance Products cat => Products (Dual cat) where
56− Dual f *** Dual g = Dual $ second g >>> first f
57−
58−instance Products (->) where
59− (***) = (BadArrow.***)
60−
61−-- | A category with finite coproducts.
62−class Category cat => Coproducts cat where
63− -- | Feed marked inputs through the argument arrow, passing the rest through unchanged to the output.
64− --
65− -- @left a@ is equal to @a +++ id@.
66− left :: cat a b -> cat (Either a c) (Either b c)
67− left a = a +++ id
68−
69− -- | A mirror image of left.
70− --
71− -- @right a@ is equal to @id +++ a@.
72− right :: cat a b -> cat (Either c a) (Either c b)
73− right a = id +++ a
74−
75− -- | A coproduct of two arrows.
76− -- Split the input between the two argument arrows, retagging and merging their outputs.
77− (+++) :: cat a b -> cat c d -> cat (Either a c) (Either b d)
78− a +++ b = left a >>> right b
79−
80− {-# MINIMAL (+++) | left, right #-}
81−
82−instance Monad m => Coproducts (Kleisli m) where
83− (+++) = (BadArrow.+++)
84−
85−instance Coproducts cat => Coproducts (Dual cat) where
86− Dual f +++ Dual g = Dual $ right g >>> left f
87−
88−instance Coproducts (->) where
89− (+++) = (BadArrow.+++)
90−
91−-- | A category @cat@ is a CatPlus when @cat a b@ is a monoid for all a, b.
92−class Category cat => CatPlus cat where
93− -- | The identity of '/+/'.
94− cempty :: cat a b
95− -- | An associative operation on arrows.
96− (/+/) :: cat a b -> cat a b -> cat a b
97−
98− {-# MINIMAL cempty, (/+/) #-}
99−
100−instance MonadPlus m => CatPlus (Kleisli m) where
101− cempty = BadArrow.zeroArrow
102− (/+/) = (BadArrow.<+>)
103−
104−instance CatPlus cat => CatPlus (Dual cat) where
105− cempty = Dual cempty
106− Dual f /+/ Dual g = Dual $ f /+/ g
107−
108−-- | A category transformer.
109−class CatTrans t where
110− -- | Lift an arrow from the base category.
111− clift :: Category cat => cat a b -> t cat a b
112−
113− {-# MINIMAL clift #-}
LICENSE+1
@@ -1,4 +1,5 @@
11Copyright (c) 2014 Paweł Nowak
2+Copyright (c) 2019 Ilya Kostyuchenko
23
34Permission is hereby granted, free of charge, to any person obtaining
45a copy of this software and associated documentation files (the
package.yamlnew file+44
@@ -0,0 +1,44 @@
1+name: semi-iso
2+version: 0.1.0.0
3+github: "ilyakooo0/semi-iso-optics"
4+license: MIT
5+author: "Ilya Kostyuchenko"
6+maintainer: "ilyakooo0@gmail.com"
7+copyright: "2019 Ilya Kostyuchenko, 2014 Paweł Nowak"
8+
9+extra-source-files: []
10+
11+# Metadata used when publishing your package
12+# synopsis: Short description of your package
13+# category: Web
14+
15+# To avoid duplicated efforts in documentation and dealing with the
16+# complications of embedding Haddock markup inside cabal files, it is
17+# common to point users to the README.md file.
18+description: Please see the README on GitHub at <https://github.com/ilyakooo0/semi-iso-optics#readme>
19+
20+dependencies:
21+- base >= 4.7 && < 5
22+- profunctors
23+- lens
24+
25+library:
26+ source-dirs: src
27+ exposed-modules:
28+ - Control.Lens.SemiIso
29+ - Control.Lens.Internal.SemiIso
30+ - Control.SIArrow
31+ - Control.Category.Reader
32+ - Control.Category.Structures
33+ - Data.Profunctor.Exposed
34+ - Control.Tuple.Morph
35+ ghc-options:
36+ - -Wall
37+ - -Wincomplete-uni-patterns
38+ - -Wincomplete-record-updates
39+ - -Wpartial-fields
40+ - -Werror=missing-home-modules
41+ - -Wmissing-home-modules
42+ - -Widentities
43+ - -Wredundant-constraints
44+ - -Wmissing-export-lists
semi-iso.cabaldeleted−71
@@ -1,71 +0,0 @@
1−name: semi-iso
2−version: 1.0.0.0
3−synopsis: Weakened partial isomorphisms, reversible computations.
4−description:
5− Semi-isomorphisms are partial isomorphisms with weakened iso laws. They are a basic
6− building block of reversible computations. And they work with Iso and Prism from @lens@!
7− .
8− The module "Control.Lens.SemiIso" defines semi-isomorphisms and provides some
9− basic semi-isos and combinators. A @SemiIso' a b@ can be applied in both directions
10− to get a @a -> Either String b@ and @b -> Either String a@. SemiIsos can be composed
11− with Isos and Prisms (to get another SemiIso). Isos and Prisms can be directly
12− used as SemiIsos.
13− .
14− Semi-isomorphisms obey weaker laws then isomorphisms. We require only
15− .
16− > apply f >=> unapply f >=> apply f = apply f
17− > unapply f >=> apply f >=> unapply f = unapply f
18− .
19− instead of
20− .
21− > apply f >=> unapply f = f
22− > unapply f >=> apply f = f
23− .
24− Modules "Control.SIArrow" and "Control.Category.Structures" define an @Arrow@-like class
25− hierarchy. Unfortunately "Control.Arrow" cannot be used, as it is too restrictive (the
26− dreaded @arr@).
27−
28− SIArrow abstracts categories of reversible computations (with reversible side effects). In
29− the case of parsing and pretty-printing using the "syntax" library if we have an arrow
30− @SIArrow cat => cat a b@ then we can:
31− .
32− * Evaluate it from left to right, turning a value of type @a@ into a value of type @b@,
33− with the side effect of consuming a sequence. (Parsing)
34− .
35− * Evaluate it from right to left, turning a value of type @b@ into a value of type @a@,
36− with the side effect of generating a sequence. (Pretty-printing)
37− .
38− In the particular case of parsing/pretty-printing the type @a@ will be usually @()@, e.g.
39− we just produce a value during parsing and just consume a value during pretty-printing.
40− To support this style we define a functor and applicative structure on @cat () b@, for example
41− '/*/' (equivalent of '<*>') has type @(\/*\/) :: SIArrow cat => cat () a -> cat () b -> cat () (a, b)@.
42− .
43− When more power then applicative is needed - for example when the syntax depends on the
44− parsed value - we turn back to arrow composition.
45− .
46− Module "Control.Category.Reader" defines a Reader category transformer. It is like a monad
47− transformer, but for categories. The next version will include some more transformers and
48− mtl-style classes.
49−license: MIT
50−license-file: LICENSE
51−author: Paweł Nowak
52−maintainer: Paweł Nowak <pawel834@gmail.com>
53−copyright: Paweł Nowak 2014
54−category: Control, Data
55−build-type: Simple
56−cabal-version: >=1.10
57−
58−source-repository head
59− type: git
60− location: git@github.com:Pawel834/semi-iso.git
61−
62−library
63− exposed-modules: Control.Lens.SemiIso
64− Control.Lens.Internal.SemiIso
65− Control.SIArrow
66− Control.Category.Reader
67− Control.Category.Structures
68− Data.Profunctor.Exposed
69− build-depends: base >= 4 && < 5, profunctors, transformers, lens, tuple-morph, semigroupoids
70− default-language: Haskell2010
71− ghc-options: -Wall
Control/Category/Reader.hs → src/Control/Category/Reader.hsrenamed+9−5
@@ -15,6 +15,7 @@ module Control.Category.Reader (
1515 ReaderCT(..)
1616 ) where
1717
18+import Control.Arrow
1819import Control.Category
1920import Control.Category.Structures
2021import Control.Lens.Iso
@@ -31,15 +32,18 @@ instance Category cat => Category (ReaderCT env cat) where
3132 id = clift id
3233 ReaderCT f . ReaderCT g = ReaderCT $ \x -> f x . g x
3334
34−instance Products cat => Products (ReaderCT env cat) where
35+instance Arrow cat => Arrow (ReaderCT env cat) where
36+ arr f = ReaderCT $ \_ -> arr f
3537 ReaderCT f *** ReaderCT g = ReaderCT $ \x -> f x *** g x
3638
37−instance Coproducts cat => Coproducts (ReaderCT env cat) where
39+instance ArrowChoice cat => ArrowChoice (ReaderCT env cat) where
3840 ReaderCT f +++ ReaderCT g = ReaderCT $ \x -> f x +++ g x
3941
40−instance CatPlus cat => CatPlus (ReaderCT env cat) where
41− cempty = clift cempty
42− ReaderCT f /+/ ReaderCT g = ReaderCT $ \x -> f x /+/ g x
42+instance ArrowZero cat => ArrowZero (ReaderCT env cat) where
43+ zeroArrow = clift zeroArrow
44+
45+instance ArrowPlus cat => ArrowPlus (ReaderCT env cat) where
46+ ReaderCT f <+> ReaderCT g = ReaderCT $ \x -> f x <+> g x
4347
4448instance SIArrow cat => SIArrow (ReaderCT env cat) where
4549 siarr = clift . siarr
src/Control/Category/Structures.hsnew file+31
@@ -0,0 +1,31 @@
1+{-# LANGUAGE TypeFamilies #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE ConstraintKinds #-}
4+{- |
5+Module : Control.Category.Structures
6+Description : Structures in a category.
7+Copyright : (c) Paweł Nowak
8+License : MIT
9+
10+Maintainer : Paweł Nowak <pawel834@gmail.com>
11+Stability : experimental
12+
13+This module defines some basic structures in a category in a more fine-grained
14+way then "Control.Arrow".
15+
16+Unfortunately names in this module clash with "Control.Arrow".
17+-}
18+module Control.Category.Structures
19+ ( CatTrans(..)
20+ ) where
21+
22+import Control.Category
23+import Prelude hiding (id, (.))
24+
25+
26+-- | A category transformer.
27+class CatTrans t where
28+ -- | Lift an arrow from the base category.
29+ clift :: Category cat => cat a b -> t cat a b
30+
31+ {-# MINIMAL clift #-}
Control/Lens/Internal/SemiIso.hs → src/Control/Lens/Internal/SemiIso.hsrenamed+5−3
@@ -9,7 +9,9 @@ License : MIT
99Maintainer : Paweł Nowak <pawel834@gmail.com>
1010Stability : experimental
1111-}
12−module Control.Lens.Internal.SemiIso where
12+module Control.Lens.Internal.SemiIso
13+ ( Retail(..)
14+ ) where
1315
1416import Control.Monad
1517import Data.Profunctor
@@ -25,9 +27,9 @@ instance Profunctor (Retail s t) where
2527 rmap f (Retail l r) = Retail l (fmap f . r)
2628
2729instance Choice (Retail s t) where
28− left' (Retail as st) = Retail
30+ left' (Retail as st) = Retail
2931 (either as (\_ -> Left "semi-iso failed")) (fmap Left . st)
30− right' (Retail as st) = Retail
32+ right' (Retail as st) = Retail
3133 (either (\_ -> Left "semi-iso failed") as) (fmap Right . st)
3234
3335-- Proof of 'Exposed' laws:
Control/Lens/SemiIso.hs → src/Control/Lens/SemiIso.hsrenamed+41−22
@@ -4,6 +4,8 @@
44{-# LANGUAGE ViewPatterns #-}
55{-# LANGUAGE PatternSynonyms #-}
66{-# LANGUAGE FlexibleContexts #-}
7+
8+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
79{- |
810Module : Control.Lens.SemiIso
911Description : Semi-isomorphisms.
@@ -33,7 +35,7 @@ Our semi-isomorphisms will obey weakened laws:
3335
3436When you see an "Either String a", the String is usually an error message.
3537
36−Disclaimer: the name "semi-isomorphism" is fictitious and made up for this library.
38+Disclaimer: the name "semi-isomorphism" is fictitious and made up for this library.
3739Any resemblance to known mathematical objects of the same name is purely coincidental.
3840-}
3941module Control.Lens.SemiIso (
@@ -65,6 +67,7 @@ module Control.Lens.SemiIso (
6567 swapped,
6668 associated,
6769 morphed,
70+ reorderMorphed,
6871 constant,
6972 exact,
7073 bifiltered,
@@ -97,28 +100,27 @@ module Control.Lens.SemiIso (
97100 bifoldl1_
98101 ) where
99102
100−import Control.Arrow (Kleisli(..))
103+import Control.Arrow
101104import Control.Category
102−import Control.Category.Structures
103105import Control.Lens.Internal.SemiIso
104106import Control.Lens.Iso
107+import Control.Tuple.Morph
105108import Data.Foldable
106109import Data.Functor.Identity
107110import Data.Profunctor.Exposed
108111import Data.Traversable
109−import Data.Tuple.Morph
110112import Prelude hiding (id, (.))
111113
112114-- | A semi-isomorphism is a partial isomorphism with weakened laws.
113−--
115+--
114116-- Should satisfy laws:
115−--
117+--
116118-- > apply i >=> unapply i >=> apply i = apply i
117119-- > unapply i >=> apply i >=> unapply i = unapply i
118120--
119121-- Every 'Prism' is a 'SemiIso'.
120122-- Every 'Iso' is a 'Prism'.
121−type SemiIso s t a b = forall p f. (Exposed (Either String) p, Traversable f)
123+type SemiIso s t a b = forall p f. (Exposed (Either String) p, Traversable f)
122124 => p a (f b) -> p s (f t)
123125
124126-- | Non-polymorphic variant of 'SemiIso'.
@@ -132,6 +134,10 @@ type ASemiIso' s a = ASemiIso s s a a
132134
133135-- | A nice pattern synonym for SemiIso's. Gives you the two functions, just like
134136-- 'viewSemiIso' or 'fromSemiIso'.
137+pattern SemiIso
138+ :: (s -> Either String a)
139+ -> (b -> Either String t)
140+ -> ASemiIso s t a b
135141pattern SemiIso sa bt <- (viewSemiIso -> (sa, bt))
136142
137143-- | A semi-iso stored in a container.
@@ -141,7 +147,8 @@ instance Category ReifiedSemiIso' where
141147 id = ReifiedSemiIso' id
142148 ReifiedSemiIso' f . ReifiedSemiIso' g = ReifiedSemiIso' (g . f)
143149
144−instance Products ReifiedSemiIso' where
150+instance Arrow ReifiedSemiIso' where
151+ arr f = ReifiedSemiIso' $ semiIso (Right . f) (const $ Left "oh no")
145152 -- TODO: pattern synonyms dont work here for some reason
146153 first (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
147154 ReifiedSemiIso' $ cloneSemiIso $
@@ -158,7 +165,7 @@ instance Products ReifiedSemiIso' where
158165 semiIso (runKleisli $ Kleisli f *** Kleisli f')
159166 (runKleisli $ Kleisli g *** Kleisli g')
160167
161−instance Coproducts ReifiedSemiIso' where
168+instance ArrowChoice ReifiedSemiIso' where
162169 left (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
163170 ReifiedSemiIso' $ cloneSemiIso $
164171 semiIso (runKleisli $ left $ Kleisli f)
@@ -174,18 +181,19 @@ instance Coproducts ReifiedSemiIso' where
174181 semiIso (runKleisli $ Kleisli f +++ Kleisli f')
175182 (runKleisli $ Kleisli g +++ Kleisli g')
176183
177−instance CatPlus ReifiedSemiIso' where
178− cempty = ReifiedSemiIso' $ alwaysFailing "cempty"
184+instance ArrowZero ReifiedSemiIso' where
185+ zeroArrow = ReifiedSemiIso' $ alwaysFailing "zeroArrow"
179186
180− ReifiedSemiIso' ai /+/ ReifiedSemiIso' ai' = ReifiedSemiIso' $
187+instance ArrowPlus ReifiedSemiIso' where
188+ ReifiedSemiIso' ai <+> ReifiedSemiIso' ai' = ReifiedSemiIso' $
181189 withSemiIso ai $ \f g -> withSemiIso ai' $ \f' g' ->
182− semiIso (runKleisli $ Kleisli f /+/ Kleisli f')
183− (runKleisli $ Kleisli g /+/ Kleisli g')
190+ semiIso (runKleisli $ Kleisli f <+> Kleisli f')
191+ (runKleisli $ Kleisli g <+> Kleisli g')
184192
185193-- | Constructs a semi isomorphism from a pair of functions that can
186194-- fail with an error message.
187195semiIso :: (s -> Either String a) -> (b -> Either String t) -> SemiIso s t a b
188−semiIso sa bt = merge . dimap sa (sequenceA . fmap bt) . expose
196+semiIso sa bt = merge . dimap sa (traverse bt) . expose
189197
190198-- | Clones a semi-iso.
191199cloneSemiIso :: ASemiIso s t a b -> SemiIso s t a b
@@ -200,8 +208,8 @@ unapply :: ASemiIso s t a b -> b -> Either String t
200208unapply (SemiIso _ bt) = bt
201209
202210-- | Extracts the two functions that characterize the 'SemiIso'.
203−withSemiIso :: ASemiIso s t a b
204− -> ((s -> Either String a) -> (b -> Either String t) -> r)
211+withSemiIso :: ASemiIso s t a b
212+ -> ((s -> Either String a) -> (b -> Either String t) -> r)
205213 -> r
206214withSemiIso ai k = case ai (Retail Right (Right . Identity)) of
207215 Retail sa bt -> k sa (rmap (runIdentity . sequenceA) bt)
@@ -226,9 +234,20 @@ associated = iso (\(a, (b, c)) -> ((a, b), c)) (\((a, b), c) -> (a, (b, c)))
226234-- types (ignoring units!) read from left to right are the same.
227235--
228236-- This is implemented using 'Data.Tuple.Morph.morph' from 'tuple-morph'.
229−morphed :: (HFoldable a, HUnfoldable a, HFoldable b, HUnfoldable b, Rep a ~ Rep b)
237+morphed :: (TupleMorphable a c, TupleMorphable b c)
230238 => Iso' a b
231−morphed = iso morph morph
239+morphed = iso morphTuples morphTuples
240+
241+-- | Like @morphed@ but also reorders elements if uniquely defined.
242+reorderMorphed
243+ :: ( TupleMorphable a b
244+ , TupleMorphable c d
245+ , ReorderList b d
246+ , ReorderList d b
247+ , CheckListsForTupleIso b d
248+ , CheckListsForTupleIso d b)
249+ => Iso' a c
250+reorderMorphed = iso morphReorderTuples morphReorderTuples
232251
233252-- | \-> Always returns the argument.
234253--
@@ -289,7 +308,7 @@ elimFirst ai = swapped . elimSecond ai
289308-- | Uses an @SemiIso b ()@ to construct a @SemiIso (a, b) a@,
290309-- i.e. eliminates the second pair element.
291310elimSecond :: ASemiIso' s () -> SemiIso' (t, s) t
292−elimSecond ai = runSemiIso (id *** reifySemiIso ai) . rev unit
311+elimSecond ai = runSemiIso (second $ reifySemiIso ai) . rev unit
293312
294313-- | Transforms the semi-iso so that applying it in both directions never fails,
295314-- but instead catches any errors and returns them as an @Either String a@.
@@ -384,7 +403,7 @@ bifoldr = bifoldr_ . attemptAp_
384403
385404-- | Constructs a bidirectional fold. Works with prisms.
386405--
387−-- \-> Right unfolds using the (->) part of the given semi-iso, until it fails.
406+-- \-> Right unfolds using the (->) part of the given semi-iso, until it fails.
388407-- It should produce a non-empty list.
389408--
390409-- \<- Right folds a non-empty list using the (<-) part of the given semi-iso.
@@ -401,7 +420,7 @@ bifoldl = bifoldl_ . attemptAp_
401420
402421-- | Constructs a bidirectional fold. Works with prisms.
403422--
404−-- \-> Left unfolds using the (->) part of the given semi-iso, until it fails.
423+-- \-> Left unfolds using the (->) part of the given semi-iso, until it fails.
405424-- It should produce a non-empty list.
406425--
407426-- \<- Left folds a non-empty list using the (<-) part of the given semi-iso.
Control/SIArrow.hs → src/Control/SIArrow.hsrenamed+22−34
@@ -21,8 +21,7 @@ module Control.SIArrow (
2121 (#>>), (>>#), (#<<), (<<#),
2222
2323 -- * Functor and applicative.
24− (/$/), (/$~),
25− (/*/), (/*), (*/),
24+ (/$/), (/$~), (/$<~>), (/*/), (/*), (*/),
2625
2726 -- * Signaling errors.
2827 sifail, (/?/),
@@ -34,20 +33,18 @@ module Control.SIArrow (
3433 sireplicate_
3534 ) where
3635
37−import Control.Arrow (Kleisli(..))
36+import Control.Arrow
3837import Control.Category
39−import Control.Category.Structures
4038import Control.Lens.Cons
4139import Control.Lens.Empty
4240import Control.Lens.Iso
4341import Control.Lens.SemiIso
4442import Control.Monad
45−import Data.Semigroupoid.Dual
46−import Data.Tuple.Morph
43+import Control.Tuple.Morph
4744import Prelude hiding (id, (.))
4845
49−infixr 1 ^>>, ^<<, #>>, #<<
50−infixr 1 >>^, <<^, >>#, <<#
46+infixr 1 #>>, #<<
47+infixr 1 >>#, <<#
5148infixl 4 /$/, /$~
5249infixl 5 /*/, */, /*
5350infixl 3 /?/
@@ -60,7 +57,7 @@ infixl 3 /?/
6057--
6158-- The category @cat@ should contain @SemiIso@ as a sort of
6259-- \"subcategory of pure computations\".
63−class (Products cat, Coproducts cat, CatPlus cat) => SIArrow cat where
60+class (Arrow cat, ArrowChoice cat, ArrowPlus cat) => SIArrow cat where
6461 -- | Allows you to lift a SemiIso into @cat@. The resulting arrow should be
6562 -- in some sense minimal or \"pure\", similiar to 'pure', 'return' and
6663 -- 'arr' from "Control.Category".
@@ -88,7 +85,7 @@ class (Products cat, Coproducts cat, CatPlus cat) => SIArrow cat where
8885
8986 -- | @simany v@ repeats @v@ as long as possible.
9087 simany :: cat () b -> cat () [b]
91− simany v = sisome v /+/ sipure _Empty
88+ simany v = sisome v <+> sipure _Empty
9289
9390 {-# MINIMAL (siarr | sipure), sibind #-}
9491
@@ -96,32 +93,12 @@ instance MonadPlus m => SIArrow (Kleisli m) where
9693 siarr ai = Kleisli $ either fail return . apply ai
9794 sibind ai = Kleisli $ \a -> either fail (($ a) . runKleisli) $ apply ai a
9895
99−instance SIArrow cat => SIArrow (Dual cat) where
100− siarr = Dual . sipure
101− sibind ai = Dual $ sibind (iso id getDual . rev ai . iso getDual id)
102−
10396instance SIArrow ReifiedSemiIso' where
10497 siarr = reifySemiIso
10598 sibind ai = ReifiedSemiIso' $
10699 semiIso (\a -> apply ai a >>= flip apply a . runSemiIso)
107100 (\b -> unapply ai b >>= flip unapply b . runSemiIso)
108101
109−-- | Composes a SemiIso with an arrow.
110−(^>>) :: SIArrow cat => ASemiIso' a b -> cat b c -> cat a c
111−f ^>> a = a . siarr f
112−
113−-- | Composes an arrow with a SemiIso.
114−(>>^) :: SIArrow cat => cat a b -> ASemiIso' b c -> cat a c
115−a >>^ f = siarr f . a
116−
117−-- | Composes a SemiIso with an arrow, backwards.
118−(^<<) :: SIArrow cat => ASemiIso' b c -> cat a b -> cat a c
119−f ^<< a = siarr f . a
120−
121−-- | Composes an arrow with a SemiIso, backwards.
122−(<<^) :: SIArrow cat => cat b c -> ASemiIso' a b -> cat a c
123−a <<^ f = a . siarr f
124−
125102-- | Composes a reversed SemiIso with an arrow.
126103(#>>) :: SIArrow cat => ASemiIso' b a -> cat b c -> cat a c
127104f #>> a = a . sipure f
@@ -151,17 +128,28 @@ a <<# f = a . sipure f
151128-- it reassociates the argument tuple and removes unnecessary (or adds necessary)
152129-- units to match the function type. You don't have to use @/*@ and @*/@ with this
153130-- operator.
154−(/$~) :: (SIArrow cat, HFoldable b', HFoldable b,
155− HUnfoldable b', HUnfoldable b, Rep b' ~ Rep b)
131+(/$~) :: (SIArrow cat, TupleMorphable b u, TupleMorphable b' u)
156132 => ASemiIso' a b' -> cat c b -> cat c a
157133ai /$~ h = cloneSemiIso ai . morphed /$/ h
158134
135+-- | Like @/$~@ but also reorders elements if uniquely defined.
136+(/$<~>)
137+ :: ( SIArrow cat
138+ , TupleMorphable b u
139+ , TupleMorphable b' v
140+ , ReorderList u v
141+ , ReorderList v u
142+ , CheckListsForTupleIso u v
143+ , CheckListsForTupleIso v u)
144+ => ASemiIso' a b' -> cat c b -> cat c a
145+ai /$<~> h = cloneSemiIso ai . reorderMorphed /$/ h
146+
159147-- | The product of two arrows with duplicate units removed. Side effect are
160148-- sequenced from left to right.
161149--
162150-- The uncurried analogue of '<*>'.
163151(/*/) :: SIArrow cat => cat () b -> cat () c -> cat () (b, c)
164−a /*/ b = unit ^>> (a *** b)
152+a /*/ b = siarr unit >>> (a *** b)
165153
166154-- | The product of two arrows, where the second one has no input and no output
167155-- (but can have side effects), with duplicate units removed. Side effect are
@@ -185,7 +173,7 @@ sifail = siarr . alwaysFailing
185173
186174-- | Provides an error message in the case of failure.
187175(/?/) :: SIArrow cat => cat a b -> String -> cat a b
188−f /?/ msg = f /+/ sifail msg
176+f /?/ msg = f <+> sifail msg
189177
190178-- | Equivalent of 'sequence'.
191179sisequence :: SIArrow cat => [cat () a] -> cat () [a]
src/Control/Tuple/Morph.hsnew file+305
@@ -0,0 +1,305 @@
1+{-# LANGUAGE
2+ PolyKinds,
3+ DataKinds,
4+ TypeOperators,
5+ GADTs,
6+ FunctionalDependencies,
7+ TypeFamilies,
8+ FlexibleInstances,
9+ UndecidableInstances,
10+ PatternSynonyms,
11+ RankNTypes,
12+ AllowAmbiguousTypes,
13+ TypeApplications,
14+ ScopedTypeVariables,
15+ ConstraintKinds,
16+ FlexibleContexts
17+ #-}
18+
19+{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-redundant-constraints #-}
20+
21+module Control.Tuple.Morph
22+ ( morphTuples
23+ , morphReorderTuples
24+ , morphPickTuples
25+ , TupleMorphable
26+ , CheckListsForTupleIso
27+ , ReorderList
28+ ) where
29+
30+import Data.Proxy
31+import GHC.Generics
32+import GHC.TypeLits hiding (Nat)
33+import Data.Kind
34+
35+
36+morphTuples :: (TupleMorphable a c, TupleMorphable b c) => a -> b
37+morphTuples = morph . unmorph
38+
39+morphPickTuples
40+ :: ( TupleMorphable a b
41+ , TupleMorphable c d
42+ , ReorderList b d )
43+ => a
44+ -> c
45+morphPickTuples = morph . hReorder Proxy . unmorph
46+
47+type CheckListsForTupleIso b d
48+ = EqOrError (Length b) (Length d)
49+ ('Text "Not isomorphic tuple contents:"
50+ ':$$: 'Text " " ':<>: 'ShowType b
51+ ':$$: 'Text " " ':<>: 'ShowType d)
52+
53+morphReorderTuples
54+ :: ( TupleMorphable a b
55+ , TupleMorphable c d
56+ , ReorderList b d
57+ , CheckListsForTupleIso b d)
58+ => a
59+ -> c
60+morphReorderTuples = morph . hReorder Proxy . unmorph
61+
62+type family EqOrError a b e :: Constraint where
63+ EqOrError a a _ = a ~ a
64+ EqOrError _ _ e = TypeError e
65+
66+
67+-- # Nat
68+
69+data Nat where
70+ S :: Nat -> Nat
71+ Z :: Nat
72+
73+
74+-- # HList
75+
76+data HList (ts :: [*]) where
77+ HCons :: t -> HList tt -> HList (t ': tt)
78+ HNil :: HList '[]
79+
80+infixr 5 :+
81+pattern (:+) :: (ts ~ (t : tt)) => t -> HList tt -> HList ts
82+pattern (:+) a b = HCons a b
83+
84+-- ## Taking
85+
86+class TakeableList (n :: Nat) aa bb | n aa -> bb where
87+ hTake :: Proxy n -> HList aa -> HList bb
88+
89+instance TakeableList 'Z a '[] where
90+ hTake _ _ = HNil
91+
92+instance (TakeableList n aa bb', bb ~ (a ': bb'))
93+ => TakeableList ('S n) (a ': aa) bb where
94+ hTake (Proxy :: Proxy ('S n)) (a :+ aa) = a :+ hTake @n Proxy aa
95+
96+-- ## Dropping
97+
98+class DroppableList (n :: Nat) (aa :: [*]) (bb :: [*]) | n aa -> bb where
99+ hDrop :: Proxy n -> HList aa -> HList bb
100+
101+instance DroppableList 'Z aa aa where
102+ hDrop _ aa = aa
103+
104+instance (DroppableList n aa bb) => DroppableList ('S n) (a ': aa) bb where
105+ hDrop (Proxy :: Proxy ('S n)) (_ :+ aa) = hDrop @n Proxy aa
106+
107+-- ## Appending
108+
109+infixr 4 ++:
110+class AppendableList aa bb cc | aa bb -> cc where
111+ (++:) :: HList aa -> HList bb -> HList (aa ++ bb)
112+
113+instance AppendableList '[] bb bb where
114+ HNil ++: bb = bb
115+
116+instance
117+ ( AppendableList aa bb cc
118+ , cc ~ (aa ++ bb)
119+ , ((a ': aa) ++ bb) ~ (a ': cc))
120+ => AppendableList (a ': aa) bb (a ': cc) where
121+ (a :+ aa) ++: bb = a :+ (aa ++: bb)
122+
123+-- ## Finding
124+
125+class FindableList ts t where
126+ hFind :: HList ts -> t
127+
128+instance {-# OVERLAPPING #-}
129+ (NotFindableList ts t)
130+ => FindableList (t ': ts) t where
131+ hFind (t :+ _) = t
132+
133+instance
134+ (TEq a t ~ 'False, FindableList ts a)
135+ => FindableList (t ': ts) a where
136+ hFind (_ :+ ts) = hFind ts
137+
138+instance
139+ (TypeError
140+ ('Text "Could not find type " ':<>: 'ShowType a ':<>: 'Text " in tuple."))
141+ => FindableList '[] a where
142+ hFind = error "oh no"
143+
144+class NotFindableList ts t
145+
146+instance {-# OVERLAPPING #-}
147+ (TypeError
148+ ('Text "Type " ':<>: 'ShowType t ':<>: 'Text " is not unique in tuple."))
149+ => NotFindableList (t ': ts) t
150+
151+instance (NotFindableList ts a) => NotFindableList (t ': ts) a
152+
153+instance NotFindableList '[] a
154+
155+class ReorderList as bs where
156+ hReorder :: Proxy bs -> HList as -> HList bs
157+
158+instance (FindableList as b, ReorderList as bs) => ReorderList as (b ': bs) where
159+ hReorder _ as = hFind as :+ hReorder (Proxy @bs) as
160+
161+instance ReorderList as '[] where
162+ hReorder _ _ = HNil
163+
164+type family TEq a b :: Bool where
165+ TEq a a = 'True
166+ TEq a b = 'False
167+
168+-- ## Other
169+
170+type family (++) (as :: [k]) (bs :: [k]) :: [k] where
171+ (++) a '[] = a
172+ (++) '[] b = b
173+ (++) (a ': as) bs = a ': (as ++ bs)
174+
175+type family Length (aa :: [k]) :: Nat where
176+ Length '[] = 'Z
177+ Length (a ': aa) = 'S (Length aa)
178+
179+
180+-- # Morphing
181+
182+class TupleMorphable t th | t -> th where
183+ unmorph :: t -> HList th
184+ morph :: HList th -> t
185+
186+instance (IsMophableTuple t ~ flag, TupleMorphable' t th flag) => TupleMorphable t th where
187+ unmorph = unmorph' (Proxy @flag)
188+ morph = morph' (Proxy @flag)
189+
190+-- ## Implementation
191+
192+class TupleMorphable' t th (flag :: Bool) | t flag -> th where
193+ unmorph' :: Proxy flag -> t -> HList th
194+ morph' :: Proxy flag -> HList th -> t
195+
196+instance TupleMorphable' t '[t] 'False where
197+ unmorph' _ t = t :+ HNil
198+ morph' _ (t :+ HNil) = t
199+
200+instance (GenericTupleMorphable (Rep t) th, Generic t) => TupleMorphable' t th 'True where
201+ unmorph' _ = genericUnmorph . from
202+ morph' _ = to . genericMorph
203+
204+-- ### Generics
205+
206+class GenericTupleMorphable f th | f -> th where
207+ genericUnmorph :: f p -> HList th
208+ genericMorph :: HList th -> f p
209+
210+instance (GenericTupleMorphable f t) => GenericTupleMorphable (M1 i c f) t where
211+ genericUnmorph = genericUnmorph . unM1
212+ genericMorph = M1 . genericMorph
213+
214+instance (TupleMorphable c t) => GenericTupleMorphable (K1 i c) t where
215+ genericUnmorph = unmorph . unK1
216+ genericMorph = K1 . morph
217+
218+instance GenericTupleMorphable U1 '[] where
219+ genericUnmorph _ = HNil
220+ genericMorph _ = U1
221+
222+type CanTakeDrop a b c =
223+ ( TakeableList (Length a) c a
224+ , DroppableList (Length a) c b
225+ , c ~ (a ++ b)
226+ )
227+
228+instance
229+ ( GenericTupleMorphable f a
230+ , GenericTupleMorphable g b
231+ , AppendableList a b c
232+ , CanTakeDrop a b c)
233+ => GenericTupleMorphable (f :*: g) c where
234+ genericUnmorph (a :*: b) = genericUnmorph a ++: genericUnmorph b
235+ genericMorph cc = genericMorph aa :*: genericMorph bb
236+ where
237+ aa = hTake @(Length a) Proxy cc
238+ bb = hDrop @(Length a) Proxy cc
239+
240+-- ## Other
241+
242+type family (IsMophableTuple t) :: Bool where
243+ IsMophableTuple () = 'True
244+ IsMophableTuple (a, b) = 'True
245+ IsMophableTuple (a, b, c) = 'True
246+ IsMophableTuple (a, b, c, d) = 'True
247+ IsMophableTuple (a, b, c, d, e) = 'True
248+ IsMophableTuple (a, b, c, d, e, f) = 'True
249+ IsMophableTuple (a, b, c, d, e, f, g) = 'True
250+ IsMophableTuple (a, b, c, d, e, f, g, h) = 'True
251+ IsMophableTuple (a, b, c, d, e, f, g, h, i) = 'True
252+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j) = 'True
253+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k) = 'True
254+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l) = 'True
255+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m) = 'True
256+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = 'True
257+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = 'True
258+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = 'True
259+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) = 'True
260+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) = 'True
261+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) = 'True
262+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) = 'True
263+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) = 'True
264+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) = 'True
265+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) = 'True
266+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) = 'True
267+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y) = 'True
268+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z) = 'True
269+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1) = 'True
270+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1) = 'True
271+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1) = 'True
272+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1) = 'True
273+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1) = 'True
274+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1) = 'True
275+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1) = 'True
276+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1) = 'True
277+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1) = 'True
278+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1) = 'True
279+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1) = 'True
280+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1) = 'True
281+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1) = 'True
282+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1) = 'True
283+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1) = 'True
284+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1) = 'True
285+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1) = 'True
286+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1) = 'True
287+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1) = 'True
288+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1) = 'True
289+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1) = 'True
290+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1) = 'True
291+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1) = 'True
292+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1) = 'True
293+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1) = 'True
294+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1) = 'True
295+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2) = 'True
296+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2) = 'True
297+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2) = 'True
298+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2) = 'True
299+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2) = 'True
300+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2) = 'True
301+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2) = 'True
302+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2) = 'True
303+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2) = 'True
304+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2) = 'True
305+ IsMophableTuple c = 'False
Data/Profunctor/Exposed.hs → src/Data/Profunctor/Exposed.hsrenamed+7−5
@@ -1,5 +1,5 @@
11{-# LANGUAGE FunctionalDependencies #-}
2−{-# LANGUAGE MultiParamTypeClasses #-}
2+
33{- |
44Module : Data.Profunctor.Exposed
55Description : Exposes Kleisli category structure beneath a profunctor.
@@ -9,18 +9,20 @@ License : MIT
99Maintainer : Paweł Nowak <pawel834@gmail.com>
1010Stability : experimental
1111-}
12−module Data.Profunctor.Exposed where
12+module Data.Profunctor.Exposed
13+ ( Exposed(..)
14+ ) where
1315
1416import Data.Profunctor
1517
1618-- | Exposes structure of a Kleisli category beneath a profunctor.
17−--
19+--
1820-- Should obey laws:
19−--
21+--
2022-- prop> merge . rmap return = id
2123-- prop> lmap return . expose = id
2224-- prop> rmap (>>= f) = merge . rmap (fmap f)
2325-- prop> lmap (fmap f) . expose = expose . lmap f
2426class (Monad m, Profunctor p) => Exposed m p | p -> m where
2527 expose :: p a b -> p (m a) b
26− merge :: p a (m b) -> p a b
28+ merge :: p a (m b) -> p a b
stack.yamlnew file+69
@@ -0,0 +1,69 @@
1+# This file was automatically generated by 'stack init'
2+#
3+# Some commonly used options have been documented as comments in this file.
4+# For advanced use and comprehensive documentation of the format, please see:
5+# https://docs.haskellstack.org/en/stable/yaml_configuration/
6+
7+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
8+# A snapshot resolver dictates the compiler version and the set of packages
9+# to be used for project dependencies. For example:
10+#
11+# resolver: lts-3.5
12+# resolver: nightly-2015-09-21
13+# resolver: ghc-7.10.2
14+#
15+# The location of a snapshot can be provided as a file or url. Stack assumes
16+# a snapshot provided as a file might change, whereas a url resource does not.
17+#
18+# resolver: ./custom-snapshot.yaml
19+# resolver: https://example.com/snapshots/2018-01-01.yaml
20+resolver: lts-14.6
21+
22+# User packages to be built.
23+# Various formats can be used as shown in the example below.
24+#
25+# packages:
26+# - some-directory
27+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
28+# subdirs:
29+# - auto-update
30+# - wai
31+packages:
32+- .
33+# Dependency packages to be pulled from upstream that are not in the resolver.
34+# These entries can reference officially published versions as well as
35+# forks / in-progress versions pinned to a git hash. For example:
36+#
37+# extra-deps:
38+# - acme-missiles-0.3
39+# - git: https://github.com/commercialhaskell/stack.git
40+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
41+#
42+# extra-deps: []
43+
44+# Override default flag values for local packages and extra-deps
45+# flags: {}
46+
47+# Extra package databases containing global packages
48+# extra-package-dbs: []
49+
50+# Control whether we use the GHC we find on the path
51+# system-ghc: true
52+#
53+# Require a specific version of stack, using version ranges
54+# require-stack-version: -any # Default
55+# require-stack-version: ">=2.1"
56+#
57+# Override the architecture used by stack, especially useful on Windows
58+# arch: i386
59+# arch: x86_64
60+#
61+# Extra directories used by stack for building
62+# extra-include-dirs: [/path/to/dir]
63+# extra-lib-dirs: [/path/to/dir]
64+#
65+# Allow a newer minor version of GHC than the snapshot specifies
66+# compiler-check: newer-minor
67+
68+ghc-options:
69+ "$locals": -ddump-to-file -ddump-hi -fwarn-unused-binds -fwarn-unused-imports