git.iko.soy/semi-iso
on master help sign in
swap
4d602bd4 ahead, 0 behind
12 files changed+517−72
since splitsnapshots
unifiedsplit
.gitignore+15−4 Control/Tuple/Morph.hs+305 LICENSE+1 package.yaml+45 semi-iso.cabal+25−58 Control/Category/Reader.hs → src/Control/Category/Reader.hs Control/Category/Structures.hs → src/Control/Category/Structures.hs Control/Lens/Internal/SemiIso.hs → src/Control/Lens/Internal/SemiIso.hs Control/Lens/SemiIso.hs → src/Control/Lens/SemiIso.hs+30−8 Control/SIArrow.hs → src/Control/SIArrow.hs+27−2 Data/Profunctor/Exposed.hs → src/Data/Profunctor/Exposed.hs stack.yaml+69
.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.*
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
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+25−58
@@ -1,64 +1,26 @@
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@).
1+cabal-version: 1.12
272
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
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
5820
5921source-repository head
60− type: git
61− location: git@github.com:Pawel834/semi-iso.git
22+ type: git
23+ location: https://github.com/ilyakooo0/semi-iso-optics
6224
6325library
6426 exposed-modules: Control.Lens.SemiIso
@@ -67,6 +29,11 @@ library
6729 Control.Category.Reader
6830 Control.Category.Structures
6931 Data.Profunctor.Exposed
32+ Control.Tuple.Morph
33+ other-modules:
34+ Paths_semi_iso
35+ hs-source-dirs:
36+ src
7037 build-depends: base >= 4.9 && <4.13
7138 , profunctors == 5.*
7239 , transformers
Control/Category/Reader.hs → src/Control/Category/Reader.hsrenamed

The content is the same.

Control/Category/Structures.hs → src/Control/Category/Structures.hsrenamed

The content is the same.

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+30−8
@@ -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 (
@@ -64,6 +64,8 @@ module Control.Lens.SemiIso (
6464 unit,
6565 swapped,
6666 associated,
67+ morphed,
68+ reorderMorphed,
6769 constant,
6870 exact,
6971 bifiltered,
@@ -101,6 +103,7 @@ import Control.Category
101103import Control.Category.Structures
102104import Control.Lens.Internal.SemiIso
103105import Control.Lens.Iso
106+import Control.Tuple.Morph
104107import Data.Foldable
105108import Data.Functor.Identity
106109import Data.Profunctor.Exposed
@@ -108,15 +111,15 @@ import Data.Traversable
108111import Prelude hiding (id, (.))
109112
110113-- | A semi-isomorphism is a partial isomorphism with weakened laws.
111−--
114+--
112115-- Should satisfy laws:
113−--
116+--
114117-- > apply i >=> unapply i >=> apply i = apply i
115118-- > unapply i >=> apply i >=> unapply i = unapply i
116119--
117120-- Every 'Prism' is a 'SemiIso'.
118121-- Every 'Iso' is a 'Prism'.
119−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)
120123 => p a (f b) -> p s (f t)
121124
122125-- | Non-polymorphic variant of 'SemiIso'.
@@ -198,8 +201,8 @@ unapply :: ASemiIso s t a b -> b -> Either String t
198201unapply (SemiIso _ bt) = bt
199202
200203-- | 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)
204+withSemiIso :: ASemiIso s t a b
205+ -> ((s -> Either String a) -> (b -> Either String t) -> r)
203206 -> r
204207withSemiIso ai k = case ai (Retail Right (Right . Identity)) of
205208 Retail sa bt -> k sa (rmap (runIdentity . sequenceA) bt)
@@ -220,6 +223,25 @@ unit = iso (, ()) fst
220223associated :: Iso' (a, (b, c)) ((a, b), c)
221224associated = iso (\(a, (b, c)) -> ((a, b), c)) (\((a, b), c) -> (a, (b, c)))
222225
226+-- | An isomorphism between two arbitrary nested tuples, as long the contained
227+-- types (ignoring units!) read from left to right are the same.
228+--
229+-- This is implemented using 'Data.Tuple.Morph.morph' from 'tuple-morph'.
230+morphed :: (TupleMorphable a c, TupleMorphable b c)
231+ => Iso' a b
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
244+
223245-- | \-> Always returns the argument.
224246--
225247-- \<- Maps everything to a @()@.
@@ -374,7 +396,7 @@ bifoldr = bifoldr_ . attemptAp_
374396
375397-- | Constructs a bidirectional fold. Works with prisms.
376398--
377−-- \-> 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.
378400-- It should produce a non-empty list.
379401--
380402-- \<- Right folds a non-empty list using the (<-) part of the given semi-iso.
@@ -391,7 +413,7 @@ bifoldl = bifoldl_ . attemptAp_
391413
392414-- | Constructs a bidirectional fold. Works with prisms.
393415--
394−-- \-> 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.
395417-- It should produce a non-empty list.
396418--
397419-- \<- Left folds a non-empty list using the (<-) part of the given semi-iso.
Control/SIArrow.hs → src/Control/SIArrow.hsrenamed+27−2
@@ -21,7 +21,7 @@ module Control.SIArrow (
2121 (#>>), (>>#), (#<<), (<<#),
2222
2323 -- * Functor and applicative.
24− (/$/), (/*/), (/*), (*/),
24+ (/$/), (/$~), (/$<~>), (/*/), (/*), (*/),
2525
2626 -- * Signaling errors.
2727 sifail, (/?/),
@@ -41,12 +41,13 @@ import Control.Lens.Empty
4141import Control.Lens.Iso
4242import Control.Lens.SemiIso
4343import Control.Monad
44+import Control.Tuple.Morph
4445import Data.Semigroupoid.Dual
4546import Prelude hiding (id, (.))
4647
4748infixr 1 ^>>, ^<<, #>>, #<<
4849infixr 1 >>^, <<^, >>#, <<#
49−infixl 4 /$/
50+infixl 4 /$/, /$~
5051infixl 5 /*/, */, /*
5152infixl 3 /?/
5253
@@ -141,6 +142,30 @@ a <<# f = a . sipure f
141142(/$/) :: SIArrow cat => ASemiIso' b' b -> cat a b -> cat a b'
142143(/$/) = (#<<)
143144
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+
144169-- | The product of two arrows with duplicate units removed. Side effect are
145170-- sequenced from left to right.
146171--
Data/Profunctor/Exposed.hs → src/Data/Profunctor/Exposed.hsrenamed

The content is the same.

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