git.iko.soy/semi-iso-optics
on master help sign in
swap
de16c6d5 ahead, 0 behind
.github/workflows/haskell.yml+7−6
since splitsnapshots
unifiedsplit
@@ -4,7 +4,7 @@ on: [pull_request]
4
4
5jobs:
5jobs:
6 build:
6 build:
7−
7+
8 runs-on: ubuntu-latest
8 runs-on: ubuntu-latest
9
9
10 steps:
10 steps:
@@ -12,10 +12,11 @@ jobs:
12 - name: Install Stack
12 - name: Install Stack
13 run: |
13 run: |
14 wget -qO- https://get.haskellstack.org/ | sh
14 wget -qO- https://get.haskellstack.org/ | sh
15−# - name: Install dependencies
15+
16−# run: cabal install --only-dependencies --enable-tests
17 - name: Build
16 - name: Build
18 run: |
17 run: |
19− stack build --fast --pedantic
18+ stack build --fast --pedantic --ghc-options '-j'
20−# - name: Run tests
19+
20+ - name: Weeder
21−# run: cabal test
21+ run: |
22+ curl -sSL https://raw.github.com/ndmitchell/weeder/master/misc/run.sh | sh -s . --build
.gitignore+15−39
@@ -1,48 +1,24 @@
1−# Created by https://www.gitignore.io
2−
3−### Haskell ###
4dist
1dist
2+dist-*
5cabal-dev
3cabal-dev
6*.o
4*.o
7*.hi
5*.hi
6+*.hie
8*.chi
7*.chi
9*.chs.h
8*.chs.h
10−.virtualenv
9+*.dyn_o
10+*.dyn_hi
11+.hpc
11.hsenv
12.hsenv
12.cabal-sandbox/
13.cabal-sandbox/
13cabal.sandbox.config
14cabal.sandbox.config
14−cabal.config
15+*.prof
15−
16+*.aux
16−
17+*.hp
17−### Emacs ###
18+*.eventlog
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−
48−.stack-work
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 @@
1Copyright (c) 2014 Paweł Nowak
1Copyright (c) 2014 Paweł Nowak
2+Copyright (c) 2019 Ilya Kostyuchenko
2
3
3Permission is hereby granted, free of charge, to any person obtaining
4Permission is hereby granted, free of charge, to any person obtaining
4a copy of this software and associated documentation files (the
5a 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−77
@@ -1,77 +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− Control.Tuple.Morph
71− build-depends: base >= 4.9 && <4.13
72− , profunctors == 5.*
73− , transformers
74− , lens == 4.*
75− , semigroupoids
76− default-language: Haskell2010
77− ghc-options: -Wall
Control/Category/Reader.hs → src/Control/Category/Reader.hsrenamed+9−5
@@ -15,6 +15,7 @@ module Control.Category.Reader (
15 ReaderCT(..)
15 ReaderCT(..)
16 ) where
16 ) where
17
17
18+import Control.Arrow
18import Control.Category
19import Control.Category
19import Control.Category.Structures
20import Control.Category.Structures
20import Control.Lens.Iso
21import Control.Lens.Iso
@@ -31,15 +32,18 @@ instance Category cat => Category (ReaderCT env cat) where
31 id = clift id
32 id = clift id
32 ReaderCT f . ReaderCT g = ReaderCT $ \x -> f x . g x
33 ReaderCT f . ReaderCT g = ReaderCT $ \x -> f x . g x
33
34
34−instance Products cat => Products (ReaderCT env cat) where
35+instance Arrow cat => Arrow (ReaderCT env cat) where
36+ arr f = ReaderCT $ \_ -> arr f
35 ReaderCT f *** ReaderCT g = ReaderCT $ \x -> f x *** g x
37 ReaderCT f *** ReaderCT g = ReaderCT $ \x -> f x *** g x
36
38
37−instance Coproducts cat => Coproducts (ReaderCT env cat) where
39+instance ArrowChoice cat => ArrowChoice (ReaderCT env cat) where
38 ReaderCT f +++ ReaderCT g = ReaderCT $ \x -> f x +++ g x
40 ReaderCT f +++ ReaderCT g = ReaderCT $ \x -> f x +++ g x
39
41
40−instance CatPlus cat => CatPlus (ReaderCT env cat) where
42+instance ArrowZero cat => ArrowZero (ReaderCT env cat) where
41− cempty = clift cempty
43+ zeroArrow = clift zeroArrow
44+
45+instance ArrowPlus cat => ArrowPlus (ReaderCT env cat) where
42− ReaderCT f /+/ ReaderCT g = ReaderCT $ \x -> f x /+/ g x
46+ ReaderCT f <+> ReaderCT g = ReaderCT $ \x -> f x <+> g x
43
47
44instance SIArrow cat => SIArrow (ReaderCT env cat) where
48instance SIArrow cat => SIArrow (ReaderCT env cat) where
45 siarr = clift . siarr
49 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
9Maintainer : Paweł Nowak <pawel834@gmail.com>
9Maintainer : Paweł Nowak <pawel834@gmail.com>
10Stability : experimental
10Stability : experimental
11-}
11-}
12−module Control.Lens.Internal.SemiIso where
12+module Control.Lens.Internal.SemiIso
13+ ( Retail(..)
14+ ) where
13
15
14import Control.Monad
16import Control.Monad
15import Data.Profunctor
17import Data.Profunctor
@@ -25,9 +27,9 @@ instance Profunctor (Retail s t) where
25 rmap f (Retail l r) = Retail l (fmap f . r)
27 rmap f (Retail l r) = Retail l (fmap f . r)
26
28
27instance Choice (Retail s t) where
29instance Choice (Retail s t) where
28− left' (Retail as st) = Retail
30+ left' (Retail as st) = Retail
29 (either as (\_ -> Left "semi-iso failed")) (fmap Left . st)
31 (either as (\_ -> Left "semi-iso failed")) (fmap Left . st)
30− right' (Retail as st) = Retail
32+ right' (Retail as st) = Retail
31 (either (\_ -> Left "semi-iso failed") as) (fmap Right . st)
33 (either (\_ -> Left "semi-iso failed") as) (fmap Right . st)
32
34
33-- Proof of 'Exposed' laws:
35-- Proof of 'Exposed' laws:
Control/Lens/SemiIso.hs → src/Control/Lens/SemiIso.hsrenamed+18−11
@@ -4,6 +4,8 @@
4{-# LANGUAGE ViewPatterns #-}
4{-# LANGUAGE ViewPatterns #-}
5{-# LANGUAGE PatternSynonyms #-}
5{-# LANGUAGE PatternSynonyms #-}
6{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleContexts #-}
7+
8+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
7{- |
9{- |
8Module : Control.Lens.SemiIso
10Module : Control.Lens.SemiIso
9Description : Semi-isomorphisms.
11Description : Semi-isomorphisms.
@@ -98,9 +100,8 @@ module Control.Lens.SemiIso (
98 bifoldl1_
100 bifoldl1_
99 ) where
101 ) where
100
102
101−import Control.Arrow (Kleisli(..))
103+import Control.Arrow
102import Control.Category
104import Control.Category
103−import Control.Category.Structures
104import Control.Lens.Internal.SemiIso
105import Control.Lens.Internal.SemiIso
105import Control.Lens.Iso
106import Control.Lens.Iso
106import Control.Tuple.Morph
107import Control.Tuple.Morph
@@ -133,6 +134,10 @@ type ASemiIso' s a = ASemiIso s s a a
133
134
134-- | A nice pattern synonym for SemiIso's. Gives you the two functions, just like
135-- | A nice pattern synonym for SemiIso's. Gives you the two functions, just like
135-- 'viewSemiIso' or 'fromSemiIso'.
136-- 'viewSemiIso' or 'fromSemiIso'.
137+pattern SemiIso
138+ :: (s -> Either String a)
139+ -> (b -> Either String t)
140+ -> ASemiIso s t a b
136pattern SemiIso sa bt <- (viewSemiIso -> (sa, bt))
141pattern SemiIso sa bt <- (viewSemiIso -> (sa, bt))
137
142
138-- | A semi-iso stored in a container.
143-- | A semi-iso stored in a container.
@@ -142,7 +147,8 @@ instance Category ReifiedSemiIso' where
142 id = ReifiedSemiIso' id
147 id = ReifiedSemiIso' id
143 ReifiedSemiIso' f . ReifiedSemiIso' g = ReifiedSemiIso' (g . f)
148 ReifiedSemiIso' f . ReifiedSemiIso' g = ReifiedSemiIso' (g . f)
144
149
145−instance Products ReifiedSemiIso' where
150+instance Arrow ReifiedSemiIso' where
151+ arr f = ReifiedSemiIso' $ semiIso (Right . f) (const $ Left "oh no")
146 -- TODO: pattern synonyms dont work here for some reason
152 -- TODO: pattern synonyms dont work here for some reason
147 first (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
153 first (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
148 ReifiedSemiIso' $ cloneSemiIso $
154 ReifiedSemiIso' $ cloneSemiIso $
@@ -159,7 +165,7 @@ instance Products ReifiedSemiIso' where
159 semiIso (runKleisli $ Kleisli f *** Kleisli f')
165 semiIso (runKleisli $ Kleisli f *** Kleisli f')
160 (runKleisli $ Kleisli g *** Kleisli g')
166 (runKleisli $ Kleisli g *** Kleisli g')
161
167
162−instance Coproducts ReifiedSemiIso' where
168+instance ArrowChoice ReifiedSemiIso' where
163 left (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
169 left (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
164 ReifiedSemiIso' $ cloneSemiIso $
170 ReifiedSemiIso' $ cloneSemiIso $
165 semiIso (runKleisli $ left $ Kleisli f)
171 semiIso (runKleisli $ left $ Kleisli f)
@@ -175,18 +181,19 @@ instance Coproducts ReifiedSemiIso' where
175 semiIso (runKleisli $ Kleisli f +++ Kleisli f')
181 semiIso (runKleisli $ Kleisli f +++ Kleisli f')
176 (runKleisli $ Kleisli g +++ Kleisli g')
182 (runKleisli $ Kleisli g +++ Kleisli g')
177
183
178−instance CatPlus ReifiedSemiIso' where
184+instance ArrowZero ReifiedSemiIso' where
179− cempty = ReifiedSemiIso' $ alwaysFailing "cempty"
185+ zeroArrow = ReifiedSemiIso' $ alwaysFailing "zeroArrow"
180
186
187+instance ArrowPlus ReifiedSemiIso' where
181− ReifiedSemiIso' ai /+/ ReifiedSemiIso' ai' = ReifiedSemiIso' $
188+ ReifiedSemiIso' ai <+> ReifiedSemiIso' ai' = ReifiedSemiIso' $
182 withSemiIso ai $ \f g -> withSemiIso ai' $ \f' g' ->
189 withSemiIso ai $ \f g -> withSemiIso ai' $ \f' g' ->
183− semiIso (runKleisli $ Kleisli f /+/ Kleisli f')
190+ semiIso (runKleisli $ Kleisli f <+> Kleisli f')
184− (runKleisli $ Kleisli g /+/ Kleisli g')
191+ (runKleisli $ Kleisli g <+> Kleisli g')
185
192
186-- | Constructs a semi isomorphism from a pair of functions that can
193-- | Constructs a semi isomorphism from a pair of functions that can
187-- fail with an error message.
194-- fail with an error message.
188semiIso :: (s -> Either String a) -> (b -> Either String t) -> SemiIso s t a b
195semiIso :: (s -> Either String a) -> (b -> Either String t) -> SemiIso s t a b
189−semiIso sa bt = merge . dimap sa (sequenceA . fmap bt) . expose
196+semiIso sa bt = merge . dimap sa (traverse bt) . expose
190
197
191-- | Clones a semi-iso.
198-- | Clones a semi-iso.
192cloneSemiIso :: ASemiIso s t a b -> SemiIso s t a b
199cloneSemiIso :: ASemiIso s t a b -> SemiIso s t a b
@@ -301,7 +308,7 @@ elimFirst ai = swapped . elimSecond ai
301-- | Uses an @SemiIso b ()@ to construct a @SemiIso (a, b) a@,
308-- | Uses an @SemiIso b ()@ to construct a @SemiIso (a, b) a@,
302-- i.e. eliminates the second pair element.
309-- i.e. eliminates the second pair element.
303elimSecond :: ASemiIso' s () -> SemiIso' (t, s) t
310elimSecond :: ASemiIso' s () -> SemiIso' (t, s) t
304−elimSecond ai = runSemiIso (id *** reifySemiIso ai) . rev unit
311+elimSecond ai = runSemiIso (second $ reifySemiIso ai) . rev unit
305
312
306-- | Transforms the semi-iso so that applying it in both directions never fails,
313-- | Transforms the semi-iso so that applying it in both directions never fails,
307-- but instead catches any errors and returns them as an @Either String a@.
314-- but instead catches any errors and returns them as an @Either String a@.
Control/SIArrow.hs → src/Control/SIArrow.hsrenamed+7−29
@@ -33,20 +33,18 @@ module Control.SIArrow (
33 sireplicate_
33 sireplicate_
34 ) where
34 ) where
35
35
36−import Control.Arrow (Kleisli(..))
36+import Control.Arrow
37import Control.Category
37import Control.Category
38−import Control.Category.Structures
39import Control.Lens.Cons
38import Control.Lens.Cons
40import Control.Lens.Empty
39import Control.Lens.Empty
41import Control.Lens.Iso
40import Control.Lens.Iso
42import Control.Lens.SemiIso
41import Control.Lens.SemiIso
43import Control.Monad
42import Control.Monad
44import Control.Tuple.Morph
43import Control.Tuple.Morph
45−import Data.Semigroupoid.Dual
46import Prelude hiding (id, (.))
44import Prelude hiding (id, (.))
47
45
48−infixr 1 ^>>, ^<<, #>>, #<<
46+infixr 1 #>>, #<<
49−infixr 1 >>^, <<^, >>#, <<#
47+infixr 1 >>#, <<#
50infixl 4 /$/, /$~
48infixl 4 /$/, /$~
51infixl 5 /*/, */, /*
49infixl 5 /*/, */, /*
52infixl 3 /?/
50infixl 3 /?/
@@ -59,7 +57,7 @@ infixl 3 /?/
59--
57--
60-- The category @cat@ should contain @SemiIso@ as a sort of
58-- The category @cat@ should contain @SemiIso@ as a sort of
61-- \"subcategory of pure computations\".
59-- \"subcategory of pure computations\".
62−class (Products cat, Coproducts cat, CatPlus cat) => SIArrow cat where
60+class (Arrow cat, ArrowChoice cat, ArrowPlus cat) => SIArrow cat where
63 -- | Allows you to lift a SemiIso into @cat@. The resulting arrow should be
61 -- | 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
62 -- in some sense minimal or \"pure\", similiar to 'pure', 'return' and
65 -- 'arr' from "Control.Category".
63 -- 'arr' from "Control.Category".
@@ -87,7 +85,7 @@ class (Products cat, Coproducts cat, CatPlus cat) => SIArrow cat where
87
85
88 -- | @simany v@ repeats @v@ as long as possible.
86 -- | @simany v@ repeats @v@ as long as possible.
89 simany :: cat () b -> cat () [b]
87 simany :: cat () b -> cat () [b]
90− simany v = sisome v /+/ sipure _Empty
88+ simany v = sisome v <+> sipure _Empty
91
89
92 {-# MINIMAL (siarr | sipure), sibind #-}
90 {-# MINIMAL (siarr | sipure), sibind #-}
93
91
@@ -95,32 +93,12 @@ instance MonadPlus m => SIArrow (Kleisli m) where
95 siarr ai = Kleisli $ either fail return . apply ai
93 siarr ai = Kleisli $ either fail return . apply ai
96 sibind ai = Kleisli $ \a -> either fail (($ a) . runKleisli) $ apply ai a
94 sibind ai = Kleisli $ \a -> either fail (($ a) . runKleisli) $ apply ai a
97
95
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−
102instance SIArrow ReifiedSemiIso' where
96instance SIArrow ReifiedSemiIso' where
103 siarr = reifySemiIso
97 siarr = reifySemiIso
104 sibind ai = ReifiedSemiIso' $
98 sibind ai = ReifiedSemiIso' $
105 semiIso (\a -> apply ai a >>= flip apply a . runSemiIso)
99 semiIso (\a -> apply ai a >>= flip apply a . runSemiIso)
106 (\b -> unapply ai b >>= flip unapply b . runSemiIso)
100 (\b -> unapply ai b >>= flip unapply b . runSemiIso)
107
101
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.
102-- | Composes a reversed SemiIso with an arrow.
125(#>>) :: SIArrow cat => ASemiIso' b a -> cat b c -> cat a c
103(#>>) :: SIArrow cat => ASemiIso' b a -> cat b c -> cat a c
126f #>> a = a . sipure f
104f #>> a = a . sipure f
@@ -171,7 +149,7 @@ ai /$<~> h = cloneSemiIso ai . reorderMorphed /$/ h
171--
149--
172-- The uncurried analogue of '<*>'.
150-- The uncurried analogue of '<*>'.
173(/*/) :: SIArrow cat => cat () b -> cat () c -> cat () (b, c)
151(/*/) :: SIArrow cat => cat () b -> cat () c -> cat () (b, c)
174−a /*/ b = unit ^>> (a *** b)
152+a /*/ b = siarr unit >>> (a *** b)
175
153
176-- | The product of two arrows, where the second one has no input and no output
154-- | 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
155-- (but can have side effects), with duplicate units removed. Side effect are
@@ -195,7 +173,7 @@ sifail = siarr . alwaysFailing
195
173
196-- | Provides an error message in the case of failure.
174-- | Provides an error message in the case of failure.
197(/?/) :: SIArrow cat => cat a b -> String -> cat a b
175(/?/) :: SIArrow cat => cat a b -> String -> cat a b
198−f /?/ msg = f /+/ sifail msg
176+f /?/ msg = f <+> sifail msg
199
177
200-- | Equivalent of 'sequence'.
178-- | Equivalent of 'sequence'.
201sisequence :: SIArrow cat => [cat () a] -> cat () [a]
179sisequence :: SIArrow cat => [cat () a] -> cat () [a]
Control/Tuple/Morph.hs → src/Control/Tuple/Morph.hsrenamed+1−1
@@ -16,7 +16,7 @@
16 FlexibleContexts
16 FlexibleContexts
17 #-}
17 #-}
18
18
19−{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
19+{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-redundant-constraints #-}
20
20
21module Control.Tuple.Morph
21module Control.Tuple.Morph
22 ( morphTuples
22 ( morphTuples
Data/Profunctor/Exposed.hs → src/Data/Profunctor/Exposed.hsrenamed+7−5
@@ -1,5 +1,5 @@
1{-# LANGUAGE FunctionalDependencies #-}
1{-# LANGUAGE FunctionalDependencies #-}
2−{-# LANGUAGE MultiParamTypeClasses #-}
2+
3{- |
3{- |
4Module : Data.Profunctor.Exposed
4Module : Data.Profunctor.Exposed
5Description : Exposes Kleisli category structure beneath a profunctor.
5Description : Exposes Kleisli category structure beneath a profunctor.
@@ -9,18 +9,20 @@ License : MIT
9Maintainer : Paweł Nowak <pawel834@gmail.com>
9Maintainer : Paweł Nowak <pawel834@gmail.com>
10Stability : experimental
10Stability : experimental
11-}
11-}
12−module Data.Profunctor.Exposed where
12+module Data.Profunctor.Exposed
13+ ( Exposed(..)
14+ ) where
13
15
14import Data.Profunctor
16import Data.Profunctor
15
17
16-- | Exposes structure of a Kleisli category beneath a profunctor.
18-- | Exposes structure of a Kleisli category beneath a profunctor.
17−--
19+--
18-- Should obey laws:
20-- Should obey laws:
19−--
21+--
20-- prop> merge . rmap return = id
22-- prop> merge . rmap return = id
21-- prop> lmap return . expose = id
23-- prop> lmap return . expose = id
22-- prop> rmap (>>= f) = merge . rmap (fmap f)
24-- prop> rmap (>>= f) = merge . rmap (fmap f)
23-- prop> lmap (fmap f) . expose = expose . lmap f
25-- prop> lmap (fmap f) . expose = expose . lmap f
24class (Monad m, Profunctor p) => Exposed m p | p -> m where
26class (Monad m, Profunctor p) => Exposed m p | p -> m where
25 expose :: p a b -> p (m a) b
27 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