git.iko.soy/semi-iso
on master help sign in
swap
4d602bd33 ahead, 0 behind
15 files changed+1110−229
since splitsnapshots
unifiedsplit
.github/workflows/haskell.yml+21 .gitignore+15−4 .travis.yml+132 Control/Tuple/Morph.hs+305 Data/SemiIsoFunctor.hs−171 LICENSE+1 package.yaml+45 semi-iso.cabal+34−20 src/Control/Category/Reader.hs+47 src/Control/Category/Structures.hs+113 Control/Lens/Internal/SemiIso.hs → src/Control/Lens/Internal/SemiIso.hs Control/Lens/SemiIso.hs → src/Control/Lens/SemiIso.hs+108−30 src/Control/SIArrow.hs+216 Data/Profunctor/Exposed.hs → src/Data/Profunctor/Exposed.hs+4−4 stack.yaml+69
.github/workflows/haskell.ymlnew file+21
@@ -0,0 +1,21 @@
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+# - name: Install dependencies
16+# run: cabal install --only-dependencies --enable-tests
17+ - name: Build
18+ run: |
19+ stack build --fast --pedantic
20+# - name: Run tests
21+# run: cabal test
.gitignore+15−4
@@ -1,13 +1,14 @@
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
@@ -45,3 +46,13 @@ tramp
4546# AUCTeX auto folder
4647/auto/
4748
49+.stack-work
50+*.prof
51+*.aux
52+*.hp
53+*.eventlog
54+.stack-work/
55+cabal.project.local
56+cabal.project.local~
57+.HTF/
58+.ghc.environment.*
.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/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 #-}
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/SemiIsoFunctor.hsdeleted−171
@@ -1,171 +0,0 @@
1−{-# LANGUAGE TypeFamilies #-}
2−{-# LANGUAGE PatternSynonyms #-}
3−{- |
4−Module : Data.SemiIsoFunctor
5−Description : Functors from the category of semi-isomoprihsms to Hask.
6−Copyright : (c) Paweł Nowak
7−License : MIT
8−
9−Maintainer : Paweł Nowak <pawel834@gmail.com>
10−Stability : experimental
11−
12−Defines a functor from the category of semi-isomoprihsms to Hask.
13−
14−The most interesting property of that class is that it can be
15−instantiated by both covariant (like Parser) and contravariant (like Printer)
16−functors. Therefore it can be used as a common interface to unify
17−parsing and pretty printing.
18−-}
19−module Data.SemiIsoFunctor where
20−
21−import Control.Lens.Cons
22−import Control.Lens.Empty
23−import Control.Lens.SemiIso
24−import Data.Tuple.Morph
25−
26−infixl 3 /|/
27−infixl 4 /$/, ~$/, /$~, ~$~
28−infixl 5 /*/, /*, */
29−infixl 1 //=
30−infixr 1 =//
31−
32−-- | A functor from the category of semi-isomorphisms to Hask.
33−--
34−-- It is both covariant and contravariant in its single arugment.
35−--
36−-- The contravariant map is used by default to provide compatibility with
37−-- Prisms (otherwise you would have to reverse them in most cases).
38−--
39−-- Instances should satisfy laws:
40−--
41−-- > simap id = id
42−-- > simap (f . g) = simap g . simap f
43−-- > simap = simapCo . fromSemi
44−-- > simapCo = simap . fromSemi
45−class SemiIsoFunctor f where
46− -- | The contravariant map.
47− simap :: ASemiIso' a b -> f b -> f a
48− simap = simapCo . rev
49−
50− -- | The covariant map.
51− simapCo :: ASemiIso' a b -> f a -> f b
52− simapCo = simap . rev
53−
54− {-# MINIMAL simap | simapCo #-}
55−
56−-- | A infix operator for 'simap'.
57−(/$/) :: SemiIsoFunctor f => ASemiIso' a b -> f b -> f a
58−(/$/) = simap
59−
60−-- | > ai /$~ f = ai . morphed /$/ f
61−--
62−-- This operator handles all the hairy stuff with uncurried application:
63−-- it reassociates the argument tuple and removes unnecessary (or adds necessary)
64−-- units to match the function type. You don't have to use @/*@ and @*/@ with this
65−-- operator.
66−(/$~) :: (SemiIsoFunctor f, HFoldable b', HFoldable b,
67− HUnfoldable b', HUnfoldable b, Rep b' ~ Rep b)
68− => ASemiIso' a b' -> f b -> f a
69−-- TODO GHC 7.10: haddock doesn't work with pattern synynonyms yet
70−-- (SemiIso f g) /$~ h = semiIso f g . morphed /$/ h
71−ai /$~ h = withSemiIso ai $ \f g -> semiIso f g . morphed /$/ h
72−
73−-- | > ai ~$/ f = morphed . ai /$/ f
74−(~$/) :: (SemiIsoFunctor f, HFoldable a', HFoldable a,
75− HUnfoldable a', HUnfoldable a, Rep a' ~ Rep a)
76− => ASemiIso' a' b -> f b -> f a
77−-- TODO GHC 7.10: haddock doesn't work with pattern synynonyms yet
78−--(SemiIso f g) ~$/ h = morphed . semiIso f g /$/ h
79−ai ~$/ h = withSemiIso ai $ \f g -> morphed . semiIso f g /$/ h
80−
81−-- | > ai ~$~ f = morphed . ai . morphed /$/ f
82−(~$~) :: (SemiIsoFunctor f,
83− HFoldable a, HUnfoldable a,
84− HFoldable b, HUnfoldable b,
85− HFoldable b', HUnfoldable b',
86− Rep b' ~ Rep b, Rep b' ~ Rep a)
87− => ASemiIso b' b' b' b' -> f b -> f a
88−-- TODO GHC 7.10: haddock doesn't work with pattern synynonyms yet
89−--(SemiIso f g) ~$~ h = morphed . semiIso f g . morphed /$/ h
90−ai ~$~ h = withSemiIso ai $ \f g -> morphed . semiIso f g . morphed /$/ h
91−
92−-- | Equivalent of 'Applicative' for 'SemiIsoFunctor'.
93−--
94−-- However, this class implements uncurried application, unlike
95−-- 'Control.Applicative' which gives you curried application.
96−--
97−-- Instances should satisfy laws:
98−--
99−-- > TODO (they should be fine)
100−class SemiIsoFunctor f => SemiIsoApply f where
101− siunit :: f ()
102− siunit = sipure id
103−
104− sipure :: ASemiIso' a () -> f a
105− sipure ai = ai /$/ siunit
106−
107− sipureCo :: ASemiIso' () a -> f a
108− sipureCo ai = ai `simapCo` siunit
109−
110− (/*/) :: f a -> f b -> f (a, b)
111−
112− (/*) :: f a -> f () -> f a
113− f /* g = unit /$/ f /*/ g
114−
115− (*/) :: f () -> f b -> f b
116− f */ g = unit . swapped /$/ f /*/ g
117−
118− {-# MINIMAL (siunit | sipure), (/*/) #-}
119−
120−-- | Equivalent of 'Alternative' for 'SemiIsoFunctor'.
121−--
122−-- @f a@ should form a monoid with identity 'siempty' and binary
123−-- operation '/|/'.
124−class SemiIsoApply f => SemiIsoAlternative f where
125− siempty :: f a
126− (/|/) :: f a -> f a -> f a
127−
128− sisome :: f a -> f [a]
129− sisome v = _Cons /$/ v /*/ simany v
130−
131− simany :: f a -> f [a]
132− simany v = sisome v /|/ sipure _Empty
133−
134− {-# MINIMAL siempty, (/|/) #-}
135−
136−-- | An analogue of 'Monad' for 'SemiIsoFunctor'.
137−--
138−-- Because of the 'no throwing away' rule bind has to \"return\"
139−-- both @a@ and @b@.
140−class SemiIsoApply m => SemiIsoMonad m where
141− (//=) :: m a -> (a -> m b) -> m (a, b)
142− m //= f = swapped /$/ (f =// m)
143−
144− (=//) :: (b -> m a) -> m b -> m (a, b)
145− f =// m = swapped /$/ (m //= f)
146−
147− {-# MINIMAL (//=) | (=//) #-}
148−
149−-- | A SemiIsoMonad with fixed point operator.
150−class SemiIsoMonad m => SemiIsoFix m where
151− sifix :: (a -> m a) -> m a
152− sifix f = dup /$/ (f =//= f)
153− where dup = semiIso (\a -> Right (a, a)) (Right . fst)
154−
155− -- | Fixed point combined with bind, it's so symmetric!
156− (=//=) :: (a -> m b) -> (b -> m a) -> m (a, b)
157− f =//= g = sifix (\(a, b) -> g b /*/ f a)
158−
159− {-# MINIMAL sifix | (=//=) #-}
160−
161−-- | Equivalent of 'sequence'.
162−--
163−-- Note that it is not possible to write sequence_, because
164−-- you cannot void a SemiIsoFunctor.
165−sisequence :: SemiIsoApply f => [f a] -> f [a]
166−sisequence [] = sipure _Empty
167−sisequence (x:xs) = _Cons /$/ x /*/ sisequence xs
168−
169−-- | Equivalent of 'replicateM'.
170−sireplicate :: SemiIsoApply f => Int -> f a -> f [a]
171−sireplicate n f = sisequence (replicate n f)
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+45
@@ -0,0 +1,45 @@
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+- transformers
24+- lens
25+- semigroupoids
26+
27+library:
28+ source-dirs: src
29+ exposed-modules:
30+ - Control.Lens.SemiIso
31+ - Control.Lens.Internal.SemiIso
32+ - Control.SIArrow
33+ - Control.Category.Reader
34+ - Control.Category.Structures
35+ - Data.Profunctor.Exposed
36+ ghc-options:
37+ - -Wall
38+ - -Wincomplete-uni-patterns
39+ - -Wincomplete-record-updates
40+ - -Wpartial-fields
41+ - -Werror=missing-home-modules
42+ - -Wmissing-home-modules
43+ - -Widentities
44+ - -Wredundant-constraints
45+ - -Wmissing-export-lists
semi-iso.cabal+34−20
@@ -1,29 +1,43 @@
1−name: semi-iso
2−version: 0.4.0.0
3−synopsis: Weakened partial isomorphisms that work with lenses.
4−description: Semi-isomorphisms are partial isomorphisms with weakened iso laws.
5− And they work with Iso and Prism from @lens@!
6− .
7− See first "Control.Lens.SemiIso" for semi-isomoprhisms.
8− After that look at "Data.SemiIsoFunctor".
9−license: MIT
10−license-file: LICENSE
11−author: Paweł Nowak
12−maintainer: Paweł Nowak <pawel834@gmail.com>
13−copyright: Paweł Nowak 2014
14−category: Control, Data
15−build-type: Simple
16−cabal-version: >=1.10
1+cabal-version: 1.12
2+
3+-- This file has been generated from package.yaml by hpack version 0.31.2.
4+--
5+-- see: https://github.com/sol/hpack
6+--
7+-- hash: 9fe627e0673c25d1622d6bbc274fa58649b56cc4796f5b740e346f1496b40f1a
8+
9+name: semi-iso
10+version: 0.1.0.0
11+description: Please see the README on GitHub at <https://github.com/ilyakooo0/semi-iso-optics#readme>
12+homepage: https://github.com/ilyakooo0/semi-iso-optics#readme
13+bug-reports: https://github.com/ilyakooo0/semi-iso-optics/issues
14+author: Ilya Kostyuchenko
15+maintainer: ilyakooo0@gmail.com
16+copyright: 2019 Ilya Kostyuchenko, 2014 Paweł Nowak
17+license: MIT
18+license-file: LICENSE
19+build-type: Simple
1720
1821source-repository head
19− type: git
20− location: git@github.com:Pawel834/semi-iso.git
22+ type: git
23+ location: https://github.com/ilyakooo0/semi-iso-optics
2124
2225library
2326 exposed-modules: Control.Lens.SemiIso
2427 Control.Lens.Internal.SemiIso
25− Data.SemiIsoFunctor
28+ Control.SIArrow
29+ Control.Category.Reader
30+ Control.Category.Structures
2631 Data.Profunctor.Exposed
27− build-depends: base >= 4 && < 5, profunctors, transformers, lens, tuple-morph
32+ Control.Tuple.Morph
33+ other-modules:
34+ Paths_semi_iso
35+ hs-source-dirs:
36+ src
37+ build-depends: base >= 4.9 && <4.13
38+ , profunctors == 5.*
39+ , transformers
40+ , lens == 4.*
41+ , semigroupoids
2842 default-language: Haskell2010
2943 ghc-options: -Wall
src/Control/Category/Reader.hsnew file+47
@@ -0,0 +1,47 @@
1+{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{- |
4+Module : Control.Category.Reader
5+Description : Reader category transformer.
6+Copyright : (c) Paweł Nowak
7+License : MIT
8+
9+Maintainer : Paweł Nowak <pawel834@gmail.com>
10+Stability : experimental
11+
12+Provides a Reader category transformer.
13+-}
14+module Control.Category.Reader (
15+ ReaderCT(..)
16+ ) where
17+
18+import Control.Category
19+import Control.Category.Structures
20+import Control.Lens.Iso
21+import Control.Lens.SemiIso
22+import Control.SIArrow
23+import Prelude hiding (id, (.))
24+
25+newtype ReaderCT env cat a b = ReaderCT { runReaderCT :: env -> cat a b }
26+
27+instance CatTrans (ReaderCT env) where
28+ clift = ReaderCT . const
29+
30+instance Category cat => Category (ReaderCT env cat) where
31+ id = clift id
32+ ReaderCT f . ReaderCT g = ReaderCT $ \x -> f x . g x
33+
34+instance Products cat => Products (ReaderCT env cat) where
35+ ReaderCT f *** ReaderCT g = ReaderCT $ \x -> f x *** g x
36+
37+instance Coproducts cat => Coproducts (ReaderCT env cat) where
38+ ReaderCT f +++ ReaderCT g = ReaderCT $ \x -> f x +++ g x
39+
40+instance CatPlus cat => CatPlus (ReaderCT env cat) where
41+ cempty = clift cempty
42+ ReaderCT f /+/ ReaderCT g = ReaderCT $ \x -> f x /+/ g x
43+
44+instance SIArrow cat => SIArrow (ReaderCT env cat) where
45+ siarr = clift . siarr
46+ sibind ai = ReaderCT $ \env -> sibind
47+ (iso id (flip runReaderCT env) . cloneSemiIso ai . iso (flip runReaderCT env) id)
src/Control/Category/Structures.hsnew file+113
@@ -0,0 +1,113 @@
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 #-}
Control/Lens/Internal/SemiIso.hs → src/Control/Lens/Internal/SemiIso.hsrenamed

The content is the same.

Control/Lens/SemiIso.hs → src/Control/Lens/SemiIso.hsrenamed+108−30
@@ -33,7 +33,7 @@ Our semi-isomorphisms will obey weakened laws:
3333
3434When you see an "Either String a", the String is usually an error message.
3535
36−Disclaimer: the name "semi-isomorphism" is fictitious and made up for this library.
36+Disclaimer: the name "semi-isomorphism" is fictitious and made up for this library.
3737Any resemblance to known mathematical objects of the same name is purely coincidental.
3838-}
3939module Control.Lens.SemiIso (
@@ -48,6 +48,11 @@ module Control.Lens.SemiIso (
4848
4949 -- * Constructing semi-isos.
5050 semiIso,
51+ cloneSemiIso,
52+
53+ -- * Reified semi-isos.
54+ ReifiedSemiIso'(..),
55+ reifySemiIso,
5156
5257 -- * Consuming semi-isos.
5358 apply,
@@ -60,9 +65,11 @@ module Control.Lens.SemiIso (
6065 swapped,
6166 associated,
6267 morphed,
68+ reorderMorphed,
6369 constant,
6470 exact,
6571 bifiltered,
72+ alwaysFailing,
6673
6774 -- * Semi-isos for numbers.
6875 _Negative,
@@ -91,25 +98,28 @@ module Control.Lens.SemiIso (
9198 bifoldl1_
9299 ) where
93100
94−import Control.Arrow
101+import Control.Arrow (Kleisli(..))
102+import Control.Category
103+import Control.Category.Structures
95104import Control.Lens.Internal.SemiIso
96105import Control.Lens.Iso
106+import Control.Tuple.Morph
97107import Data.Foldable
98108import Data.Functor.Identity
99109import Data.Profunctor.Exposed
100110import Data.Traversable
101−import Data.Tuple.Morph
111+import Prelude hiding (id, (.))
102112
103113-- | A semi-isomorphism is a partial isomorphism with weakened laws.
104−--
114+--
105115-- Should satisfy laws:
106−--
116+--
107117-- > apply i >=> unapply i >=> apply i = apply i
108118-- > unapply i >=> apply i >=> unapply i = unapply i
109119--
110120-- Every 'Prism' is a 'SemiIso'.
111121-- Every 'Iso' is a 'Prism'.
112−type SemiIso s t a b = forall p f. (Exposed (Either String) p, Traversable f)
122+type SemiIso s t a b = forall p f. (Exposed (Either String) p, Traversable f)
113123 => p a (f b) -> p s (f t)
114124
115125-- | Non-polymorphic variant of 'SemiIso'.
@@ -125,11 +135,63 @@ type ASemiIso' s a = ASemiIso s s a a
125135-- 'viewSemiIso' or 'fromSemiIso'.
126136pattern SemiIso sa bt <- (viewSemiIso -> (sa, bt))
127137
138+-- | A semi-iso stored in a container.
139+newtype ReifiedSemiIso' s a = ReifiedSemiIso' { runSemiIso :: SemiIso' s a }
140+
141+instance Category ReifiedSemiIso' where
142+ id = ReifiedSemiIso' id
143+ ReifiedSemiIso' f . ReifiedSemiIso' g = ReifiedSemiIso' (g . f)
144+
145+instance Products ReifiedSemiIso' where
146+ -- TODO: pattern synonyms dont work here for some reason
147+ first (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
148+ ReifiedSemiIso' $ cloneSemiIso $
149+ semiIso (runKleisli $ first $ Kleisli f)
150+ (runKleisli $ first $ Kleisli g)
151+
152+ second (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
153+ ReifiedSemiIso' $ cloneSemiIso $
154+ semiIso (runKleisli $ second $ Kleisli f)
155+ (runKleisli $ second $ Kleisli g)
156+
157+ ReifiedSemiIso' ai *** ReifiedSemiIso' ai' = ReifiedSemiIso' $
158+ withSemiIso ai $ \f g -> withSemiIso ai' $ \f' g' ->
159+ semiIso (runKleisli $ Kleisli f *** Kleisli f')
160+ (runKleisli $ Kleisli g *** Kleisli g')
161+
162+instance Coproducts ReifiedSemiIso' where
163+ left (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
164+ ReifiedSemiIso' $ cloneSemiIso $
165+ semiIso (runKleisli $ left $ Kleisli f)
166+ (runKleisli $ left $ Kleisli g)
167+
168+ right (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
169+ ReifiedSemiIso' $ cloneSemiIso $
170+ semiIso (runKleisli $ right $ Kleisli f)
171+ (runKleisli $ right $ Kleisli g)
172+
173+ ReifiedSemiIso' ai +++ ReifiedSemiIso' ai' = ReifiedSemiIso' $
174+ withSemiIso ai $ \f g -> withSemiIso ai' $ \f' g' ->
175+ semiIso (runKleisli $ Kleisli f +++ Kleisli f')
176+ (runKleisli $ Kleisli g +++ Kleisli g')
177+
178+instance CatPlus ReifiedSemiIso' where
179+ cempty = ReifiedSemiIso' $ alwaysFailing "cempty"
180+
181+ ReifiedSemiIso' ai /+/ ReifiedSemiIso' ai' = ReifiedSemiIso' $
182+ withSemiIso ai $ \f g -> withSemiIso ai' $ \f' g' ->
183+ semiIso (runKleisli $ Kleisli f /+/ Kleisli f')
184+ (runKleisli $ Kleisli g /+/ Kleisli g')
185+
128186-- | Constructs a semi isomorphism from a pair of functions that can
129187-- fail with an error message.
130188semiIso :: (s -> Either String a) -> (b -> Either String t) -> SemiIso s t a b
131189semiIso sa bt = merge . dimap sa (sequenceA . fmap bt) . expose
132190
191+-- | Clones a semi-iso.
192+cloneSemiIso :: ASemiIso s t a b -> SemiIso s t a b
193+cloneSemiIso (SemiIso sa bt) = semiIso sa bt
194+
133195-- | Applies the 'SemiIso'.
134196apply :: ASemiIso s t a b -> s -> Either String a
135197apply (SemiIso sa _) = sa
@@ -139,8 +201,8 @@ unapply :: ASemiIso s t a b -> b -> Either String t
139201unapply (SemiIso _ bt) = bt
140202
141203-- | Extracts the two functions that characterize the 'SemiIso'.
142−withSemiIso :: ASemiIso s t a b
143− -> ((s -> Either String a) -> (b -> Either String t) -> r)
204+withSemiIso :: ASemiIso s t a b
205+ -> ((s -> Either String a) -> (b -> Either String t) -> r)
144206 -> r
145207withSemiIso ai k = case ai (Retail Right (Right . Identity)) of
146208 Retail sa bt -> k sa (rmap (runIdentity . sequenceA) bt)
@@ -149,6 +211,10 @@ withSemiIso ai k = case ai (Retail Right (Right . Identity)) of
149211viewSemiIso :: ASemiIso s t a b -> (s -> Either String a, b -> Either String t)
150212viewSemiIso ai = withSemiIso ai (,)
151213
214+-- | Reifies a semi-iso.
215+reifySemiIso :: ASemiIso' s a -> ReifiedSemiIso' s a
216+reifySemiIso ai = ReifiedSemiIso' $ cloneSemiIso ai
217+
152218-- | A trivial isomorphism between a and (a, ()).
153219unit :: Iso' a (a, ())
154220unit = iso (, ()) fst
@@ -161,9 +227,20 @@ associated = iso (\(a, (b, c)) -> ((a, b), c)) (\((a, b), c) -> (a, (b, c)))
161227-- types (ignoring units!) read from left to right are the same.
162228--
163229-- This is implemented using 'Data.Tuple.Morph.morph' from 'tuple-morph'.
164−morphed :: (HFoldable a, HUnfoldable a, HFoldable b, HUnfoldable b, Rep a ~ Rep b)
230+morphed :: (TupleMorphable a c, TupleMorphable b c)
165231 => Iso' a b
166−morphed = iso morph morph
232+morphed = iso morphTuples morphTuples
233+
234+-- | Like @morphed@ but also reorders elements if uniquely defined.
235+reorderMorphed
236+ :: ( TupleMorphable a b
237+ , TupleMorphable c d
238+ , ReorderList b d
239+ , ReorderList d b
240+ , CheckListsForTupleIso b d
241+ , CheckListsForTupleIso d b)
242+ => Iso' a c
243+reorderMorphed = iso morphReorderTuples morphReorderTuples
167244
168245-- | \-> Always returns the argument.
169246--
@@ -177,15 +254,15 @@ morphed = iso morph morph
177254constant :: a -> SemiIso' () a
178255constant x = semiIso (\_ -> Right x) (\_ -> Right ())
179256
180−-- | \-> Always returns the argument.
257+-- | \-> Filters out all values not equal to the argument.
181258--
182−-- \<- Filters out all values not equal to the argument.
183−exact :: Eq a => a -> SemiIso' () a
259+-- \<- Always returns the argument.
260+exact :: Eq a => a -> SemiIso' a ()
184261exact x = semiIso f g
185262 where
186− f _ = Right x
187− g y | x == y = Right ()
263+ f y | x == y = Right ()
188264 | otherwise = Left "exact: not equal"
265+ g _ = Right x
189266
190267-- | Like 'filtered' but checks the predicate in both ways.
191268bifiltered :: (a -> Bool) -> SemiIso' a a
@@ -193,6 +270,10 @@ bifiltered p = semiIso check check
193270 where check x | p x = Right x
194271 | otherwise = Left "bifiltered: predicate failed"
195272
273+-- | A semi-iso that fails in both directions.
274+alwaysFailing :: String -> SemiIso s t a b
275+alwaysFailing msg = semiIso (\_ -> Left msg) (\_ -> Left msg)
276+
196277-- | \-> Matches only negative numbers, turns it into a positive one.
197278--
198279-- \<- Matches only positive numbers, turns it into a negative one.
@@ -208,22 +289,19 @@ _Negative = semiIso f g
208289rev :: ASemiIso s t a b -> SemiIso b a t s
209290rev ai = withSemiIso ai $ \l r -> semiIso r l
210291
211−-- | A product of SemiIso's.
212−prod :: ASemiIso s t a b -> ASemiIso s' t' a' b'
213− -> SemiIso (s, s') (t, t') (a, a') (b, b')
214−prod (SemiIso sa bt) (SemiIso sa' bt') = semiIso
215− (runKleisli (Kleisli sa *** Kleisli sa'))
216− (runKleisli (Kleisli bt *** Kleisli bt'))
292+-- | A product of semi-isos.
293+prod :: ASemiIso' s a -> ASemiIso' t b -> SemiIso' (s, t) (a, b)
294+prod a b = runSemiIso (reifySemiIso a *** reifySemiIso b)
217295
218−-- | In the non-polymorphic case uses an @SemiIso a ()@ to construct a
219−-- @SemiIso (a, b) b@, i.e. eliminates the first pair element.
220−elimFirst :: ASemiIso s' t' () () -> SemiIso (s', t) (t', t) t t
296+-- | Uses an @SemiIso' a ()@ to construct a @SemiIso' (a, b) b@,
297+-- i.e. eliminates the first pair element.
298+elimFirst :: ASemiIso' s () -> SemiIso' (s, t) t
221299elimFirst ai = swapped . elimSecond ai
222300
223−-- | In the non-polymorphic case uses an @SemiIso b ()@ to construct a
224−-- @SemiIso (a, b) a@, i.e. eliminates the second pair element.
225−elimSecond :: ASemiIso s' t' () () -> SemiIso (t, s') (t, t') t t
226−elimSecond ai = prod id ai . rev unit
301+-- | Uses an @SemiIso b ()@ to construct a @SemiIso (a, b) a@,
302+-- i.e. eliminates the second pair element.
303+elimSecond :: ASemiIso' s () -> SemiIso' (t, s) t
304+elimSecond ai = runSemiIso (id *** reifySemiIso ai) . rev unit
227305
228306-- | Transforms the semi-iso so that applying it in both directions never fails,
229307-- but instead catches any errors and returns them as an @Either String a@.
@@ -318,7 +396,7 @@ bifoldr = bifoldr_ . attemptAp_
318396
319397-- | Constructs a bidirectional fold. Works with prisms.
320398--
321−-- \-> Right unfolds using the (->) part of the given semi-iso, until it fails.
399+-- \-> Right unfolds using the (->) part of the given semi-iso, until it fails.
322400-- It should produce a non-empty list.
323401--
324402-- \<- Right folds a non-empty list using the (<-) part of the given semi-iso.
@@ -335,7 +413,7 @@ bifoldl = bifoldl_ . attemptAp_
335413
336414-- | Constructs a bidirectional fold. Works with prisms.
337415--
338−-- \-> Left unfolds using the (->) part of the given semi-iso, until it fails.
416+-- \-> Left unfolds using the (->) part of the given semi-iso, until it fails.
339417-- It should produce a non-empty list.
340418--
341419-- \<- Left folds a non-empty list using the (<-) part of the given semi-iso.
src/Control/SIArrow.hsnew file+216
@@ -0,0 +1,216 @@
1+{-# LANGUAGE RankNTypes #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE ConstraintKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{- |
7+Module : Control.SIArrow
8+Description : Categories of reversible computations.
9+Copyright : (c) Paweł Nowak
10+License : MIT
11+
12+Maintainer : Paweł Nowak <pawel834@gmail.com>
13+Stability : experimental
14+
15+Categories of reversible computations.
16+-}
17+module Control.SIArrow (
18+ -- * Arrow.
19+ SIArrow(..),
20+ (^>>), (>>^), (^<<), (<<^),
21+ (#>>), (>>#), (#<<), (<<#),
22+
23+ -- * Functor and applicative.
24+ (/$/), (/$~), (/$<~>), (/*/), (/*), (*/),
25+
26+ -- * Signaling errors.
27+ sifail, (/?/),
28+
29+ -- * Combinators.
30+ sisequence,
31+ sisequence_,
32+ sireplicate,
33+ sireplicate_
34+ ) where
35+
36+import Control.Arrow (Kleisli(..))
37+import Control.Category
38+import Control.Category.Structures
39+import Control.Lens.Cons
40+import Control.Lens.Empty
41+import Control.Lens.Iso
42+import Control.Lens.SemiIso
43+import Control.Monad
44+import Control.Tuple.Morph
45+import Data.Semigroupoid.Dual
46+import Prelude hiding (id, (.))
47+
48+infixr 1 ^>>, ^<<, #>>, #<<
49+infixr 1 >>^, <<^, >>#, <<#
50+infixl 4 /$/, /$~
51+infixl 5 /*/, */, /*
52+infixl 3 /?/
53+
54+-- | A category equipped with an embedding 'siarr' from @SemiIso@ into @cat@ and some
55+-- additional structure.
56+--
57+-- SIArrow abstracts categories of reversible computations
58+-- (with reversible side effects).
59+--
60+-- The category @cat@ should contain @SemiIso@ as a sort of
61+-- \"subcategory of pure computations\".
62+class (Products cat, Coproducts cat, CatPlus cat) => SIArrow cat where
63+ -- | Allows you to lift a SemiIso into @cat@. The resulting arrow should be
64+ -- in some sense minimal or \"pure\", similiar to 'pure', 'return' and
65+ -- 'arr' from "Control.Category".
66+ siarr :: ASemiIso' a b -> cat a b
67+ siarr = sipure . rev
68+
69+ -- | Reversed version of 'siarr'.
70+ --
71+ -- Use this where you would use 'pure'.
72+ sipure :: ASemiIso' b a -> cat a b
73+ sipure = siarr . rev
74+
75+ -- | Allows a computation to depend on a its input value.
76+ --
77+ -- I am not sure if this is the right way to get that ArrowApply or Monad
78+ -- like power. It seems quite easy to break the parser/pretty-printer inverse
79+ -- guarantee using this. On the other hand we have to be careful only when
80+ -- constructing the SemiIso using 'iso'/'semiIso' - and with an invalid SemiIso
81+ -- we could break everything anyway using 'siarr'.
82+ sibind :: ASemiIso a (cat a b) (cat a b) b -> cat a b
83+
84+ -- | @sisome v@ repeats @v@ as long as possible, but no less then once.
85+ sisome :: cat () b -> cat () [b]
86+ sisome v = _Cons /$/ v /*/ simany v
87+
88+ -- | @simany v@ repeats @v@ as long as possible.
89+ simany :: cat () b -> cat () [b]
90+ simany v = sisome v /+/ sipure _Empty
91+
92+ {-# MINIMAL (siarr | sipure), sibind #-}
93+
94+instance MonadPlus m => SIArrow (Kleisli m) where
95+ siarr ai = Kleisli $ either fail return . apply ai
96+ sibind ai = Kleisli $ \a -> either fail (($ a) . runKleisli) $ apply ai a
97+
98+instance SIArrow cat => SIArrow (Dual cat) where
99+ siarr = Dual . sipure
100+ sibind ai = Dual $ sibind (iso id getDual . rev ai . iso getDual id)
101+
102+instance SIArrow ReifiedSemiIso' where
103+ siarr = reifySemiIso
104+ sibind ai = ReifiedSemiIso' $
105+ semiIso (\a -> apply ai a >>= flip apply a . runSemiIso)
106+ (\b -> unapply ai b >>= flip unapply b . runSemiIso)
107+
108+-- | Composes a SemiIso with an arrow.
109+(^>>) :: SIArrow cat => ASemiIso' a b -> cat b c -> cat a c
110+f ^>> a = a . siarr f
111+
112+-- | Composes an arrow with a SemiIso.
113+(>>^) :: SIArrow cat => cat a b -> ASemiIso' b c -> cat a c
114+a >>^ f = siarr f . a
115+
116+-- | Composes a SemiIso with an arrow, backwards.
117+(^<<) :: SIArrow cat => ASemiIso' b c -> cat a b -> cat a c
118+f ^<< a = siarr f . a
119+
120+-- | Composes an arrow with a SemiIso, backwards.
121+(<<^) :: SIArrow cat => cat b c -> ASemiIso' a b -> cat a c
122+a <<^ f = a . siarr f
123+
124+-- | Composes a reversed SemiIso with an arrow.
125+(#>>) :: SIArrow cat => ASemiIso' b a -> cat b c -> cat a c
126+f #>> a = a . sipure f
127+
128+-- | Composes an arrow with a reversed SemiIso.
129+(>>#) :: SIArrow cat => cat a b -> ASemiIso' c b -> cat a c
130+a >># f = sipure f . a
131+
132+-- | Composes a reversed SemiIso with an arrow, backwards.
133+(#<<) :: SIArrow cat => ASemiIso' c b -> cat a b -> cat a c
134+f #<< a = sipure f . a
135+
136+-- | Composes an arrow with a reversed SemiIso, backwards.
137+(<<#) :: SIArrow cat => cat b c -> ASemiIso' b a -> cat a c
138+a <<# f = a . sipure f
139+
140+-- | Postcomposes an arrow with a reversed SemiIso.
141+-- The analogue of '<$>' and synonym for '#<<'.
142+(/$/) :: SIArrow cat => ASemiIso' b' b -> cat a b -> cat a b'
143+(/$/) = (#<<)
144+
145+-- | Convenient fmap.
146+--
147+-- > ai /$~ f = ai . morphed /$/ f
148+--
149+-- This operator handles all the hairy stuff with uncurried application:
150+-- it reassociates the argument tuple and removes unnecessary (or adds necessary)
151+-- units to match the function type. You don't have to use @/*@ and @*/@ with this
152+-- operator.
153+(/$~) :: (SIArrow cat, TupleMorphable b u, TupleMorphable b' u)
154+ => ASemiIso' a b' -> cat c b -> cat c a
155+ai /$~ h = cloneSemiIso ai . morphed /$/ h
156+
157+-- | Like @/$~@ but also reorders elements if uniquely defined.
158+(/$<~>)
159+ :: ( SIArrow cat
160+ , TupleMorphable b u
161+ , TupleMorphable b' v
162+ , ReorderList u v
163+ , ReorderList v u
164+ , CheckListsForTupleIso u v
165+ , CheckListsForTupleIso v u)
166+ => ASemiIso' a b' -> cat c b -> cat c a
167+ai /$<~> h = cloneSemiIso ai . reorderMorphed /$/ h
168+
169+-- | The product of two arrows with duplicate units removed. Side effect are
170+-- sequenced from left to right.
171+--
172+-- The uncurried analogue of '<*>'.
173+(/*/) :: SIArrow cat => cat () b -> cat () c -> cat () (b, c)
174+a /*/ b = unit ^>> (a *** b)
175+
176+-- | The product of two arrows, where the second one has no input and no output
177+-- (but can have side effects), with duplicate units removed. Side effect are
178+-- sequenced from left to right.
179+--
180+-- The uncurried analogue of '<*'.
181+(/*) :: SIArrow cat => cat () a -> cat () () -> cat () a
182+f /* g = unit /$/ f /*/ g
183+
184+-- | The product of two arrows, where the first one has no input and no output
185+-- (but can have side effects), with duplicate units removed. Side effect are
186+-- sequenced from left to right.
187+--
188+-- The uncurried analogue of '*>'.
189+(*/) :: SIArrow cat => cat () () -> cat () a -> cat () a
190+f */ g = unit . swapped /$/ f /*/ g
191+
192+-- | An arrow that fails with an error message.
193+sifail :: SIArrow cat => String -> cat a b
194+sifail = siarr . alwaysFailing
195+
196+-- | Provides an error message in the case of failure.
197+(/?/) :: SIArrow cat => cat a b -> String -> cat a b
198+f /?/ msg = f /+/ sifail msg
199+
200+-- | Equivalent of 'sequence'.
201+sisequence :: SIArrow cat => [cat () a] -> cat () [a]
202+sisequence [] = sipure _Empty
203+sisequence (x:xs) = _Cons /$/ x /*/ sisequence xs
204+
205+-- | Equivalent of 'sequence_', restricted to units.
206+sisequence_ :: SIArrow cat => [cat () ()] -> cat () ()
207+sisequence_ [] = sipure _Empty
208+sisequence_ (x:xs) = unit /$/ x /*/ sisequence_ xs
209+
210+-- | Equivalent of 'replicateM'.
211+sireplicate :: SIArrow cat => Int -> cat () a -> cat () [a]
212+sireplicate n f = sisequence (replicate n f)
213+
214+-- | Equivalent of 'replicateM_', restricted to units.
215+sireplicate_ :: SIArrow cat => Int -> cat () () -> cat () ()
216+sireplicate_ n f = sisequence_ (replicate n f)
Data/Profunctor/Exposed.hs → src/Data/Profunctor/Exposed.hsrenamed+4−4
@@ -17,10 +17,10 @@ import Data.Profunctor
1717--
1818-- Should obey laws:
1919--
20−-- > merge . rmap return = id
21−-- > lmap return . expose = id
22−-- > rmap (>>= f) = merge . rmap (fmap f)
23−-- > lmap (fmap f) . expose = expose . lmap f
20+-- prop> merge . rmap return = id
21+-- prop> lmap return . expose = id
22+-- prop> rmap (>>= f) = merge . rmap (fmap f)
23+-- prop> lmap (fmap f) . expose = expose . lmap f
2424class (Monad m, Profunctor p) => Exposed m p | p -> m where
2525 expose :: p a b -> p (m a) b
2626 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