@@ -1,204 +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−It can be instantiated by both covariant (like Parser) and contravariant
15−(like Printer) functors. Therefore it can be used as a common interface to unify
16−parsing and pretty printing.
17−-}
18−module Data.SemiIsoFunctor where
19−
20−import Control.Lens.Cons
21−import Control.Lens.Empty
22−import Control.Lens.SemiIso
23−import Data.Tuple.Morph
24−
25−infixl 3 /|/, /?/
26−infixl 4 /$/, ~$/, /$~, ~$~
27−infixl 5 /*/, /*, */
28−infixl 1 //=
29−infixr 1 =//
30−
31−-- | A functor from the category of semi-isomorphisms to Hask. We can think of it as
32−-- if it was both covariant and contravariant in its single argument.
33−--
34−-- The contravariant map is used by default to provide compatibility with
35−-- Prisms (otherwise you would have to reverse them in most cases).
36−--
37−-- This is really a pair of functors @F : SemiIso -> Hask@,
38−-- @G : SemiIso^op -> Hask@ satisfying:
39−--
40−-- > F(X) = G(X)
41−-- > F(f) = G(f^-1)
42−--
43−-- Instances should satisfy laws:
44−--
45−-- [/functoriality/]
46−--
47−-- prop> simap id = id
48−-- prop> simap (f . g) = simap g . simap f
49−--
50−-- [/inverse/]
51−--
52−-- prop> simap f = simapCo (rev f)
53−class SemiIsoFunctor f where
54− -- | The contravariant map.
55− simap :: ASemiIso' a b -> f b -> f a
56− simap = simapCo . rev
57−
58− -- | The covariant map.
59− simapCo :: ASemiIso' a b -> f a -> f b
60− simapCo = simap . rev
61−
62− {-# MINIMAL simap | simapCo #-}
63−
64−-- | A infix operator for 'simap'.
65−(/$/) :: SemiIsoFunctor f => ASemiIso' a b -> f b -> f a
66−(/$/) = simap
67−
68−-- | > ai /$~ f = ai . morphed /$/ f
69−--
70−-- This operator handles all the hairy stuff with uncurried application:
71−-- it reassociates the argument tuple and removes unnecessary (or adds necessary)
72−-- units to match the function type. You don't have to use @/*@ and @*/@ with this
73−-- operator.
74−(/$~) :: (SemiIsoFunctor f, HFoldable b', HFoldable b,
75− HUnfoldable b', HUnfoldable b, Rep b' ~ Rep b)
76− => ASemiIso' a b' -> f b -> f a
77−ai /$~ h = cloneSemiIso ai . morphed /$/ h
78−
79−-- | > ai ~$/ f = morphed . ai /$/ f
80−(~$/) :: (SemiIsoFunctor f, HFoldable a', HFoldable a,
81− HUnfoldable a', HUnfoldable a, Rep a' ~ Rep a)
82− => ASemiIso' a' b -> f b -> f a
83−ai ~$/ h = morphed . cloneSemiIso ai /$/ h
84−
85−-- | > ai ~$~ f = morphed . ai . morphed /$/ f
86−(~$~) :: (SemiIsoFunctor f,
87− HFoldable a, HUnfoldable a,
88− HFoldable b, HUnfoldable b,
89− HFoldable b', HUnfoldable b',
90− Rep b' ~ Rep b, Rep b' ~ Rep a)
91− => ASemiIso b' b' b' b' -> f b -> f a
92−ai ~$~ h = morphed . cloneSemiIso ai . morphed /$/ h
93−
94−-- | An applicative semi-iso functor, i. e. a lax monoidal functor from @SemiIso@
95−-- to @Hask@.
96−--
97−-- Instances should satisfy laws:
98−--
99−-- [/homomorphism/]
100−--
101−-- prop> sipure f /*/ sipure g = sipure (f `prod` g)
102−--
103−-- [/associativity/]
104−--
105−-- prop> f /*/ (g /*/ h) = associated /$/ (f /*/ g) /*/ h
106−--
107−-- [/unitality/]
108−--
109−-- prop> siunit /*/ x = swapped . rev unit /$/ x
110−-- prop> x /*/ siunit = rev unit /$/ x
111−--
112−-- Additionally it should be consistent with the default implementation:
113−--
114−-- prop> sipure ai = ai /$/ siunit
115−-- prop> sipureCo ai = ai `simapCo` siunit
116−--
117−-- prop> f /* g = unit /$/ f /*/ g
118−-- prop> f */ g = unit . swapped /$/ f /*/ g
119−class SemiIsoFunctor f => SemiIsoApply f where
120− siunit :: f ()
121− siunit = sipure id
122−
123− sipure :: ASemiIso' a () -> f a
124− sipure ai = ai /$/ siunit
125−
126− sipureCo :: ASemiIso' () a -> f a
127− sipureCo ai = ai `simapCo` siunit
128−
129− (/*/) :: f a -> f b -> f (a, b)
130−
131− (/*) :: f a -> f () -> f a
132− f /* g = unit /$/ f /*/ g
133−
134− (*/) :: f () -> f b -> f b
135− f */ g = unit . swapped /$/ f /*/ g
136−
137− {-# MINIMAL (siunit | sipure), (/*/) #-}
138−
139−-- | Fails with a message.
140−sifail :: SemiIsoApply f => String -> f a
141−sifail msg = alwaysFailing msg /$/ siunit
142−
143−-- | Equivalent of 'Alternative' for 'SemiIsoFunctor'.
144−--
145−-- @f a@ should form a monoid with identity 'siempty' and binary
146−-- operation '/|/'.
147−class SemiIsoApply f => SemiIsoAlternative f where
148− siempty :: f a
149− (/|/) :: f a -> f a -> f a
150−
151− sisome :: f a -> f [a]
152− sisome v = _Cons /$/ v /*/ simany v
153−
154− simany :: f a -> f [a]
155− simany v = sisome v /|/ sipure _Empty
156−
157− {-# MINIMAL siempty, (/|/) #-}
158−
159−-- | Provides an error message in the case of failure.
160−(/?/) :: SemiIsoAlternative f => f a -> String -> f a
161−f /?/ msg = f /|/ sifail msg
162−
163−-- | An analogue of 'Monad' for 'SemiIsoFunctor'.
164−--
165−-- Because of the 'no throwing away' rule bind has to \"return\"
166−-- both @a@ and @b@.
167−class SemiIsoApply m => SemiIsoMonad m where
168− (//=) :: m a -> (a -> m b) -> m (a, b)
169− m //= f = swapped /$/ (f =// m)
170−
171− (=//) :: (b -> m a) -> m b -> m (a, b)
172− f =// m = swapped /$/ (m //= f)
173−
174− {-# MINIMAL (//=) | (=//) #-}
175−
176−-- | A SemiIsoMonad with fixed point operator.
177−class SemiIsoMonad m => SemiIsoFix m where
178− sifix :: (a -> m a) -> m a
179− sifix f = dup /$/ (f =//= f)
180− where dup = semiIso (\a -> Right (a, a)) (Right . fst)
181−
182− -- | Fixed point combined with bind, it's so symmetric!
183− (=//=) :: (a -> m b) -> (b -> m a) -> m (a, b)
184− f =//= g = sifix (\(a, b) -> g b /*/ f a)
185−
186− {-# MINIMAL sifix | (=//=) #-}
187−
188−-- | Equivalent of 'sequence'.
189−sisequence :: SemiIsoApply f => [f a] -> f [a]
190−sisequence [] = sipure _Empty
191−sisequence (x:xs) = _Cons /$/ x /*/ sisequence xs
192−
193−-- | Equivalent of 'sequence_', restricted to units.
194−sisequence_ :: SemiIsoApply f => [f ()] -> f ()
195−sisequence_ [] = sipure _Empty
196−sisequence_ (x:xs) = unit /$/ x /*/ sisequence_ xs
197−
198−-- | Equivalent of 'replicateM'.
199−sireplicate :: SemiIsoApply f => Int -> f a -> f [a]
200−sireplicate n f = sisequence (replicate n f)
201−
202−-- | Equivalent of 'replicateM_', restricted to units.
203−sireplicate_ :: SemiIsoApply f => Int -> f () -> f ()
204−sireplicate_ n f = sisequence_ (replicate n f)