@@ -1,5 +1,8 @@
1+{-# LANGUAGE RankNTypes #-}
1{-# LANGUAGE TypeFamilies #-}
2{-# LANGUAGE TypeFamilies #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE ConstraintKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
4Module : Control.SIArrow
7Module : Control.SIArrow
5Description : Categories of reversible computations.
8Description : Categories of reversible computations.
@@ -15,6 +18,7 @@ module Control.SIArrow (
15 -- * Arrow.
18 -- * Arrow.
16 SIArrow(..),
19 SIArrow(..),
17 (^>>), (>>^), (^<<), (<<^),
20 (^>>), (>>^), (^<<), (<<^),
21+ (#>>), (>>#), (#<<), (<<#),
19 -- * Functor and applicative.
23 -- * Functor and applicative.
20 (/$/), (/$~),
24 (/$/), (/$~),
@@ -30,18 +34,18 @@ module Control.SIArrow (
30 sireplicate_
34 sireplicate_
33−import Control.Arrow (Kleisli(..))
37+import Control.Arrow (Kleisli(..))
34−import Control.Category
38+import Control.Category
35−import Control.Category.Structures
39+import Control.Category.Structures
36−import Control.Lens.Cons
40+import Control.Lens.Cons
37−import Control.Lens.Empty
41+import Control.Lens.Empty
38−import Control.Lens.SemiIso
42+import Control.Lens.SemiIso
39−import Control.Monad
43+import Control.Monad
40−import Data.Tuple.Morph
44+import Data.Tuple.Morph
41−import Prelude hiding (id, (.))
45+import Prelude hiding (id, (.))
43−infixr 1 ^>>, >>^
47+infixr 1 ^>>, ^<<, #>>, #<<
44−infixr 1 ^<<, <<^
48+infixr 1 >>^, <<^, >>#, <<#
45infixl 4 /$/, /$~
49infixl 4 /$/, /$~
46infixl 5 /*/, */, /*
50infixl 5 /*/, */, /*
47infixl 3 /?/
51infixl 3 /?/
@@ -59,6 +63,7 @@ class (Products cat, Coproducts cat, CatPlus cat) => SIArrow cat where
59 -- in some sense minimal or \"pure\", similiar to 'pure', 'return' and
63 -- in some sense minimal or \"pure\", similiar to 'pure', 'return' and
60 -- 'arr' from "Control.Category".
64 -- 'arr' from "Control.Category".
61 siarr :: ASemiIso' a b -> cat a b
65 siarr :: ASemiIso' a b -> cat a b
63 -- | Reversed version of 'siarr'.
68 -- | Reversed version of 'siarr'.
@@ -66,6 +71,15 @@ class (Products cat, Coproducts cat, CatPlus cat) => SIArrow cat where
66 sipure :: ASemiIso' b a -> cat a b
71 sipure :: ASemiIso' b a -> cat a b
67 sipure = siarr . rev
72 sipure = siarr . rev
74+ -- | Allows a computation to depend on a its input value.
76+ -- I am not sure if this is the right way to get that ArrowApply or Monad
77+ -- like power. It seems quite easy to break the parser/pretty-printer inverse
78+ -- guarantee using this. On the other hand we have to be careful only when
79+ -- constructing the SemiIso using 'iso'/'semiIso' - and with an invalid SemiIso
80+ -- we could break everything anyway using 'siarr'.
81+ sibind :: ASemiIso a (cat a b) (cat a b) b -> cat a b
69 -- | @sisome v@ repeats @v@ as long as possible, but no less then once.
83 -- | @sisome v@ repeats @v@ as long as possible, but no less then once.
70 sisome :: cat () b -> cat () [b]
84 sisome :: cat () b -> cat () [b]
71 sisome v = _Cons /$/ v /*/ simany v
85 sisome v = _Cons /$/ v /*/ simany v
@@ -74,13 +88,17 @@ class (Products cat, Coproducts cat, CatPlus cat) => SIArrow cat where
74 simany :: cat () b -> cat () [b]
88 simany :: cat () b -> cat () [b]
75 simany v = sisome v /+/ sipure _Empty
89 simany v = sisome v /+/ sipure _Empty
77− {-# MINIMAL siarr #-}
91+ {-# MINIMAL (siarr | sipure), sibind #-}
79instance MonadPlus m => SIArrow (Kleisli m) where
93instance MonadPlus m => SIArrow (Kleisli m) where
80 siarr ai = Kleisli $ either fail return . apply ai
94 siarr ai = Kleisli $ either fail return . apply ai
95+ sibind ai = Kleisli $ \a -> either fail (($ a) . runKleisli) $ apply ai a
82instance SIArrow ReifiedSemiIso' where
97instance SIArrow ReifiedSemiIso' where
83 siarr = reifySemiIso
98 siarr = reifySemiIso
99+ sibind ai = ReifiedSemiIso' $
100+ semiIso (\a -> apply ai a >>= flip apply a . runSemiIso)
101+ (\b -> unapply ai b >>= flip unapply b . runSemiIso)
85-- | Composes a SemiIso with an arrow.
103-- | Composes a SemiIso with an arrow.
86(^>>) :: SIArrow cat => ASemiIso' a b -> cat b c -> cat a c
104(^>>) :: SIArrow cat => ASemiIso' a b -> cat b c -> cat a c
@@ -98,9 +116,26 @@ f ^<< a = siarr f . a
98(<<^) :: SIArrow cat => cat b c -> ASemiIso' a b -> cat a c
116(<<^) :: SIArrow cat => cat b c -> ASemiIso' a b -> cat a c
99a <<^ f = a . siarr f
117a <<^ f = a . siarr f
119+-- | Composes a reversed SemiIso with an arrow.
120+(#>>) :: SIArrow cat => ASemiIso' b a -> cat b c -> cat a c
121+f #>> a = a . sipure f
123+-- | Composes an arrow with a reversed SemiIso.
124+(>>#) :: SIArrow cat => cat a b -> ASemiIso' c b -> cat a c
125+a >># f = sipure f . a
127+-- | Composes a reversed SemiIso with an arrow, backwards.
128+(#<<) :: SIArrow cat => ASemiIso' c b -> cat a b -> cat a c
129+f #<< a = sipure f . a
131+-- | Composes an arrow with a reversed SemiIso, backwards.
132+(<<#) :: SIArrow cat => cat b c -> ASemiIso' b a -> cat a c
133+a <<# f = a . sipure f
101−-- | Postcomposes an arrow with a reversed SemiIso. The analogue of '<$>'.
135+-- | Postcomposes an arrow with a reversed SemiIso.
136+-- The analogue of '<$>' and synonym for '#<<'.
102(/$/) :: SIArrow cat => ASemiIso' b' b -> cat a b -> cat a b'
137(/$/) :: SIArrow cat => ASemiIso' b' b -> cat a b -> cat a b'
103−ai /$/ f = sipure ai . f
138+(/$/) = (#<<)
105-- | Convenient fmap.
140-- | Convenient fmap.