@@ -0,0 +1,305 @@
6+ FunctionalDependencies,
19+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
21+module Control.Tuple.Morph
26+ , CheckListsForTupleIso
32+import GHC.TypeLits hiding (Nat)
36+morphTuples :: (TupleMorphable a c, TupleMorphable b c) => a -> b
37+morphTuples = morph . unmorph
40+ :: ( TupleMorphable a b
45+morphPickTuples = morph . hReorder Proxy . unmorph
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)
54+ :: ( TupleMorphable a b
57+ , CheckListsForTupleIso b d)
60+morphReorderTuples = morph . hReorder Proxy . unmorph
62+type family EqOrError a b e :: Constraint where
63+ EqOrError a a _ = a ~ a
64+ EqOrError _ _ e = TypeError e
76+data HList (ts :: [*]) where
77+ HCons :: t -> HList tt -> HList (t ': tt)
81+pattern (:+) :: (ts ~ (t : tt)) => t -> HList tt -> HList ts
82+pattern (:+) a b = HCons a b
86+class TakeableList (n :: Nat) aa bb | n aa -> bb where
87+ hTake :: Proxy n -> HList aa -> HList bb
89+instance TakeableList 'Z a '[] where
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
98+class DroppableList (n :: Nat) (aa :: [*]) (bb :: [*]) | n aa -> bb where
99+ hDrop :: Proxy n -> HList aa -> HList bb
101+instance DroppableList 'Z aa aa where
104+instance (DroppableList n aa bb) => DroppableList ('S n) (a ': aa) bb where
105+ hDrop (Proxy :: Proxy ('S n)) (_ :+ aa) = hDrop @n Proxy aa
110+class AppendableList aa bb cc | aa bb -> cc where
111+ (++:) :: HList aa -> HList bb -> HList (aa ++ bb)
113+instance AppendableList '[] bb bb where
117+ ( AppendableList aa bb cc
119+ , ((a ': aa) ++ bb) ~ (a ': cc))
120+ => AppendableList (a ': aa) bb (a ': cc) where
121+ (a :+ aa) ++: bb = a :+ (aa ++: bb)
125+class FindableList ts t where
126+ hFind :: HList ts -> t
128+instance {-# OVERLAPPING #-}
129+ (NotFindableList ts t)
130+ => FindableList (t ': ts) t where
134+ (TEq a t ~ 'False, FindableList ts a)
135+ => FindableList (t ': ts) a where
136+ hFind (_ :+ ts) = hFind ts
140+ ('Text "Could not find type " ':<>: 'ShowType a ':<>: 'Text " in tuple."))
141+ => FindableList '[] a where
142+ hFind = error "oh no"
144+class NotFindableList ts t
146+instance {-# OVERLAPPING #-}
148+ ('Text "Type " ':<>: 'ShowType t ':<>: 'Text " is not unique in tuple."))
149+ => NotFindableList (t ': ts) t
151+instance (NotFindableList ts a) => NotFindableList (t ': ts) a
153+instance NotFindableList '[] a
155+class ReorderList as bs where
156+ hReorder :: Proxy bs -> HList as -> HList bs
158+instance (FindableList as b, ReorderList as bs) => ReorderList as (b ': bs) where
159+ hReorder _ as = hFind as :+ hReorder (Proxy @bs) as
161+instance ReorderList as '[] where
164+type family TEq a b :: Bool where
170+type family (++) (as :: [k]) (bs :: [k]) :: [k] where
173+ (++) (a ': as) bs = a ': (as ++ bs)
175+type family Length (aa :: [k]) :: Nat where
177+ Length (a ': aa) = 'S (Length aa)
182+class TupleMorphable t th | t -> th where
183+ unmorph :: t -> HList th
184+ morph :: HList th -> t
186+instance (IsMophableTuple t ~ flag, TupleMorphable' t th flag) => TupleMorphable t th where
187+ unmorph = unmorph' (Proxy @flag)
188+ morph = morph' (Proxy @flag)
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
196+instance TupleMorphable' t '[t] 'False where
197+ unmorph' _ t = t :+ HNil
198+ morph' _ (t :+ HNil) = t
200+instance (GenericTupleMorphable (Rep t) th, Generic t) => TupleMorphable' t th 'True where
201+ unmorph' _ = genericUnmorph . from
202+ morph' _ = to . genericMorph
206+class GenericTupleMorphable f th | f -> th where
207+ genericUnmorph :: f p -> HList th
208+ genericMorph :: HList th -> f p
210+instance (GenericTupleMorphable f t) => GenericTupleMorphable (M1 i c f) t where
211+ genericUnmorph = genericUnmorph . unM1
212+ genericMorph = M1 . genericMorph
214+instance (TupleMorphable c t) => GenericTupleMorphable (K1 i c) t where
215+ genericUnmorph = unmorph . unK1
216+ genericMorph = K1 . morph
218+instance GenericTupleMorphable U1 '[] where
219+ genericUnmorph _ = HNil
222+type CanTakeDrop a b c =
223+ ( TakeableList (Length a) c a
224+ , DroppableList (Length a) c b
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
237+ aa = hTake @(Length a) Proxy cc
238+ bb = hDrop @(Length a) Proxy cc
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