@@ -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