git.iko.soy/semi-iso-optics
on master help sign in
swap
de16c6d6 ahead, 0 behind
14 files changed+575−296
since splitsnapshots
unifiedsplit
.github/workflows/haskell.yml+7−6 .gitignore+15−38 Control/Category/Structures.hs−113 LICENSE+1 package.yaml+44 semi-iso.cabal−76 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+48−19 Control/SIArrow.hs → src/Control/SIArrow.hs+34−31 src/Control/Tuple/Morph.hs+305 Data/Profunctor/Exposed.hs → src/Data/Profunctor/Exposed.hs+7−5 stack.yaml+69
.github/workflows/haskell.yml+7−6
@@ -4,7 +4,7 @@ on: [pull_request]
44
55jobs:
66 build:
7−
7+
88 runs-on: ubuntu-latest
99
1010 steps:
@@ -12,10 +12,11 @@ jobs:
1212 - name: Install Stack
1313 run: |
1414 wget -qO- https://get.haskellstack.org/ | sh
15−# - name: Install dependencies
16−# run: cabal install --only-dependencies --enable-tests
15+
1716 - name: Build
1817 run: |
19− stack build --fast --pedantic
20−# - name: Run tests
21−# run: cabal test
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
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−76
@@ -1,76 +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.11
57−Tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.1
58−
59−source-repository head
60− type: git
61− location: git@github.com:Pawel834/semi-iso.git
62−
63−library
64− exposed-modules: Control.Lens.SemiIso
65− Control.Lens.Internal.SemiIso
66− Control.SIArrow
67− Control.Category.Reader
68− Control.Category.Structures
69− Data.Profunctor.Exposed
70− build-depends: base >= 4.9 && <4.13
71− , profunctors == 5.*
72− , transformers
73− , lens == 4.*
74− , semigroupoids
75− default-language: Haskell2010
76− 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+48−19
@@ -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 (
@@ -64,6 +66,8 @@ module Control.Lens.SemiIso (
6466 unit,
6567 swapped,
6668 associated,
69+ morphed,
70+ reorderMorphed,
6771 constant,
6872 exact,
6973 bifiltered,
@@ -96,11 +100,11 @@ module Control.Lens.SemiIso (
96100 bifoldl1_
97101 ) where
98102
99−import Control.Arrow (Kleisli(..))
103+import Control.Arrow
100104import Control.Category
101−import Control.Category.Structures
102105import Control.Lens.Internal.SemiIso
103106import Control.Lens.Iso
107+import Control.Tuple.Morph
104108import Data.Foldable
105109import Data.Functor.Identity
106110import Data.Profunctor.Exposed
@@ -108,15 +112,15 @@ import Data.Traversable
108112import Prelude hiding (id, (.))
109113
110114-- | A semi-isomorphism is a partial isomorphism with weakened laws.
111−--
115+--
112116-- Should satisfy laws:
113−--
117+--
114118-- > apply i >=> unapply i >=> apply i = apply i
115119-- > unapply i >=> apply i >=> unapply i = unapply i
116120--
117121-- Every 'Prism' is a 'SemiIso'.
118122-- Every 'Iso' is a 'Prism'.
119−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)
120124 => p a (f b) -> p s (f t)
121125
122126-- | Non-polymorphic variant of 'SemiIso'.
@@ -130,6 +134,10 @@ type ASemiIso' s a = ASemiIso s s a a
130134
131135-- | A nice pattern synonym for SemiIso's. Gives you the two functions, just like
132136-- 'viewSemiIso' or 'fromSemiIso'.
137+pattern SemiIso
138+ :: (s -> Either String a)
139+ -> (b -> Either String t)
140+ -> ASemiIso s t a b
133141pattern SemiIso sa bt <- (viewSemiIso -> (sa, bt))
134142
135143-- | A semi-iso stored in a container.
@@ -139,7 +147,8 @@ instance Category ReifiedSemiIso' where
139147 id = ReifiedSemiIso' id
140148 ReifiedSemiIso' f . ReifiedSemiIso' g = ReifiedSemiIso' (g . f)
141149
142−instance Products ReifiedSemiIso' where
150+instance Arrow ReifiedSemiIso' where
151+ arr f = ReifiedSemiIso' $ semiIso (Right . f) (const $ Left "oh no")
143152 -- TODO: pattern synonyms dont work here for some reason
144153 first (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
145154 ReifiedSemiIso' $ cloneSemiIso $
@@ -156,7 +165,7 @@ instance Products ReifiedSemiIso' where
156165 semiIso (runKleisli $ Kleisli f *** Kleisli f')
157166 (runKleisli $ Kleisli g *** Kleisli g')
158167
159−instance Coproducts ReifiedSemiIso' where
168+instance ArrowChoice ReifiedSemiIso' where
160169 left (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
161170 ReifiedSemiIso' $ cloneSemiIso $
162171 semiIso (runKleisli $ left $ Kleisli f)
@@ -172,18 +181,19 @@ instance Coproducts ReifiedSemiIso' where
172181 semiIso (runKleisli $ Kleisli f +++ Kleisli f')
173182 (runKleisli $ Kleisli g +++ Kleisli g')
174183
175−instance CatPlus ReifiedSemiIso' where
176− cempty = ReifiedSemiIso' $ alwaysFailing "cempty"
184+instance ArrowZero ReifiedSemiIso' where
185+ zeroArrow = ReifiedSemiIso' $ alwaysFailing "zeroArrow"
177186
178− ReifiedSemiIso' ai /+/ ReifiedSemiIso' ai' = ReifiedSemiIso' $
187+instance ArrowPlus ReifiedSemiIso' where
188+ ReifiedSemiIso' ai <+> ReifiedSemiIso' ai' = ReifiedSemiIso' $
179189 withSemiIso ai $ \f g -> withSemiIso ai' $ \f' g' ->
180− semiIso (runKleisli $ Kleisli f /+/ Kleisli f')
181− (runKleisli $ Kleisli g /+/ Kleisli g')
190+ semiIso (runKleisli $ Kleisli f <+> Kleisli f')
191+ (runKleisli $ Kleisli g <+> Kleisli g')
182192
183193-- | Constructs a semi isomorphism from a pair of functions that can
184194-- fail with an error message.
185195semiIso :: (s -> Either String a) -> (b -> Either String t) -> SemiIso s t a b
186−semiIso sa bt = merge . dimap sa (sequenceA . fmap bt) . expose
196+semiIso sa bt = merge . dimap sa (traverse bt) . expose
187197
188198-- | Clones a semi-iso.
189199cloneSemiIso :: ASemiIso s t a b -> SemiIso s t a b
@@ -198,8 +208,8 @@ unapply :: ASemiIso s t a b -> b -> Either String t
198208unapply (SemiIso _ bt) = bt
199209
200210-- | Extracts the two functions that characterize the 'SemiIso'.
201−withSemiIso :: ASemiIso s t a b
202− -> ((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)
203213 -> r
204214withSemiIso ai k = case ai (Retail Right (Right . Identity)) of
205215 Retail sa bt -> k sa (rmap (runIdentity . sequenceA) bt)
@@ -220,6 +230,25 @@ unit = iso (, ()) fst
220230associated :: Iso' (a, (b, c)) ((a, b), c)
221231associated = iso (\(a, (b, c)) -> ((a, b), c)) (\((a, b), c) -> (a, (b, c)))
222232
233+-- | An isomorphism between two arbitrary nested tuples, as long the contained
234+-- types (ignoring units!) read from left to right are the same.
235+--
236+-- This is implemented using 'Data.Tuple.Morph.morph' from 'tuple-morph'.
237+morphed :: (TupleMorphable a c, TupleMorphable b c)
238+ => Iso' a b
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
251+
223252-- | \-> Always returns the argument.
224253--
225254-- \<- Maps everything to a @()@.
@@ -279,7 +308,7 @@ elimFirst ai = swapped . elimSecond ai
279308-- | Uses an @SemiIso b ()@ to construct a @SemiIso (a, b) a@,
280309-- i.e. eliminates the second pair element.
281310elimSecond :: ASemiIso' s () -> SemiIso' (t, s) t
282−elimSecond ai = runSemiIso (id *** reifySemiIso ai) . rev unit
311+elimSecond ai = runSemiIso (second $ reifySemiIso ai) . rev unit
283312
284313-- | Transforms the semi-iso so that applying it in both directions never fails,
285314-- but instead catches any errors and returns them as an @Either String a@.
@@ -374,7 +403,7 @@ bifoldr = bifoldr_ . attemptAp_
374403
375404-- | Constructs a bidirectional fold. Works with prisms.
376405--
377−-- \-> 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.
378407-- It should produce a non-empty list.
379408--
380409-- \<- Right folds a non-empty list using the (<-) part of the given semi-iso.
@@ -391,7 +420,7 @@ bifoldl = bifoldl_ . attemptAp_
391420
392421-- | Constructs a bidirectional fold. Works with prisms.
393422--
394−-- \-> 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.
395424-- It should produce a non-empty list.
396425--
397426-- \<- Left folds a non-empty list using the (<-) part of the given semi-iso.
Control/SIArrow.hs → src/Control/SIArrow.hsrenamed+34−31
@@ -21,7 +21,7 @@ module Control.SIArrow (
2121 (#>>), (>>#), (#<<), (<<#),
2222
2323 -- * Functor and applicative.
24− (/$/), (/*/), (/*), (*/),
24+ (/$/), (/$~), (/$<~>), (/*/), (/*), (*/),
2525
2626 -- * Signaling errors.
2727 sifail, (/?/),
@@ -33,20 +33,19 @@ module Control.SIArrow (
3333 sireplicate_
3434 ) where
3535
36−import Control.Arrow (Kleisli(..))
36+import Control.Arrow
3737import Control.Category
38−import Control.Category.Structures
3938import Control.Lens.Cons
4039import Control.Lens.Empty
4140import Control.Lens.Iso
4241import Control.Lens.SemiIso
4342import Control.Monad
44−import Data.Semigroupoid.Dual
43+import Control.Tuple.Morph
4544import Prelude hiding (id, (.))
4645
47−infixr 1 ^>>, ^<<, #>>, #<<
48−infixr 1 >>^, <<^, >>#, <<#
49−infixl 4 /$/
46+infixr 1 #>>, #<<
47+infixr 1 >>#, <<#
48+infixl 4 /$/, /$~
5049infixl 5 /*/, */, /*
5150infixl 3 /?/
5251
@@ -58,7 +57,7 @@ infixl 3 /?/
5857--
5958-- The category @cat@ should contain @SemiIso@ as a sort of
6059-- \"subcategory of pure computations\".
61−class (Products cat, Coproducts cat, CatPlus cat) => SIArrow cat where
60+class (Arrow cat, ArrowChoice cat, ArrowPlus cat) => SIArrow cat where
6261 -- | Allows you to lift a SemiIso into @cat@. The resulting arrow should be
6362 -- in some sense minimal or \"pure\", similiar to 'pure', 'return' and
6463 -- 'arr' from "Control.Category".
@@ -86,7 +85,7 @@ class (Products cat, Coproducts cat, CatPlus cat) => SIArrow cat where
8685
8786 -- | @simany v@ repeats @v@ as long as possible.
8887 simany :: cat () b -> cat () [b]
89− simany v = sisome v /+/ sipure _Empty
88+ simany v = sisome v <+> sipure _Empty
9089
9190 {-# MINIMAL (siarr | sipure), sibind #-}
9291
@@ -94,32 +93,12 @@ instance MonadPlus m => SIArrow (Kleisli m) where
9493 siarr ai = Kleisli $ either fail return . apply ai
9594 sibind ai = Kleisli $ \a -> either fail (($ a) . runKleisli) $ apply ai a
9695
97−instance SIArrow cat => SIArrow (Dual cat) where
98− siarr = Dual . sipure
99− sibind ai = Dual $ sibind (iso id getDual . rev ai . iso getDual id)
100−
10196instance SIArrow ReifiedSemiIso' where
10297 siarr = reifySemiIso
10398 sibind ai = ReifiedSemiIso' $
10499 semiIso (\a -> apply ai a >>= flip apply a . runSemiIso)
105100 (\b -> unapply ai b >>= flip unapply b . runSemiIso)
106101
107−-- | Composes a SemiIso with an arrow.
108−(^>>) :: SIArrow cat => ASemiIso' a b -> cat b c -> cat a c
109−f ^>> a = a . siarr f
110−
111−-- | Composes an arrow with a SemiIso.
112−(>>^) :: SIArrow cat => cat a b -> ASemiIso' b c -> cat a c
113−a >>^ f = siarr f . a
114−
115−-- | Composes a SemiIso with an arrow, backwards.
116−(^<<) :: SIArrow cat => ASemiIso' b c -> cat a b -> cat a c
117−f ^<< a = siarr f . a
118−
119−-- | Composes an arrow with a SemiIso, backwards.
120−(<<^) :: SIArrow cat => cat b c -> ASemiIso' a b -> cat a c
121−a <<^ f = a . siarr f
122−
123102-- | Composes a reversed SemiIso with an arrow.
124103(#>>) :: SIArrow cat => ASemiIso' b a -> cat b c -> cat a c
125104f #>> a = a . sipure f
@@ -141,12 +120,36 @@ a <<# f = a . sipure f
141120(/$/) :: SIArrow cat => ASemiIso' b' b -> cat a b -> cat a b'
142121(/$/) = (#<<)
143122
123+-- | Convenient fmap.
124+--
125+-- > ai /$~ f = ai . morphed /$/ f
126+--
127+-- This operator handles all the hairy stuff with uncurried application:
128+-- it reassociates the argument tuple and removes unnecessary (or adds necessary)
129+-- units to match the function type. You don't have to use @/*@ and @*/@ with this
130+-- operator.
131+(/$~) :: (SIArrow cat, TupleMorphable b u, TupleMorphable b' u)
132+ => ASemiIso' a b' -> cat c b -> cat c a
133+ai /$~ h = cloneSemiIso ai . morphed /$/ h
134+
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+
144147-- | The product of two arrows with duplicate units removed. Side effect are
145148-- sequenced from left to right.
146149--
147150-- The uncurried analogue of '<*>'.
148151(/*/) :: SIArrow cat => cat () b -> cat () c -> cat () (b, c)
149−a /*/ b = unit ^>> (a *** b)
152+a /*/ b = siarr unit >>> (a *** b)
150153
151154-- | The product of two arrows, where the second one has no input and no output
152155-- (but can have side effects), with duplicate units removed. Side effect are
@@ -170,7 +173,7 @@ sifail = siarr . alwaysFailing
170173
171174-- | Provides an error message in the case of failure.
172175(/?/) :: SIArrow cat => cat a b -> String -> cat a b
173−f /?/ msg = f /+/ sifail msg
176+f /?/ msg = f <+> sifail msg
174177
175178-- | Equivalent of 'sequence'.
176179sisequence :: 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