@@ -1,59 +1,39 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE ConstraintKinds #-}
1+{-# LANGUAGE DataKinds #-}
42{-# LANGUAGE FlexibleInstances #-}
53{-# LANGUAGE FunctionalDependencies #-}
64{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE KindSignatures #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE PolyKinds #-}
78{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TupleSections #-}
9−{-# LANGUAGE TypeApplications #-}
109{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE TypeInType #-}
1210{-# LANGUAGE TypeOperators #-}
1311{-# LANGUAGE UndecidableInstances #-}
1412
15−#if __GLASGOW_HASKELL__ == 802
16−{-# OPTIONS_GHC -fno-solve-constant-dicts #-}
17−#endif
18−
19−
2013-----------------------------------------------------------------------------
2114-- |
22−-- Module : Data.Generics.Product.Internal.HList
23−-- Copyright : (C) 2019 Csongor Kiss
15+-- Module : Data.Generics.Internal.HList
16+-- Copyright : (C) 2017 Csongor Kiss
2417-- License : BSD3
2518-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
2619-- Stability : experimental
2720-- Portability : non-portable
2821--
29−-- Derive an isomorphism between a product type and a flat HList.
30−--
3122-----------------------------------------------------------------------------
23+module Data.Generics.Internal.HList
24+ ( type (++)
3225
33−module Data.Generics.Product.Internal.HList
34− ( GIsList(..)
35− , IndexList (..)
36− , HList (..)
37− , type (++)
38− , Elem
3926 , ListTuple (..)
40− , TupleToList
41− ) where
4227
43−#if __GLASGOW_HASKELL__ < 804
44−import Data.Semigroup
45−#endif
46−import GHC.TypeLits
28+ , GCollectible (..)
29+ ) where
4730
48−import Data.Kind (Type)
31+import Data.Kind (Type)
4932import GHC.Generics
50−import Data.Profunctor
51−import Data.Generics.Internal.Profunctor.Lens
52−import Data.Generics.Internal.Profunctor.Iso
5333
54−data HList (as :: [Type]) where
55− Nil :: HList '[]
56− (:>) :: a -> HList as -> HList (a ': as)
34+data HList (xs :: [Type]) where
35+ Nil :: HList '[]
36+ (:>) :: x -> HList xs -> HList (x ': xs)
5737
5838infixr 5 :>
5939
@@ -61,118 +41,32 @@ type family ((as :: [k]) ++ (bs :: [k])) :: [k] where
6141 '[] ++ bs = bs
6242 (a ': as) ++ bs = a ': as ++ bs
6343
64−instance Semigroup (HList '[]) where
65− _ <> _ = Nil
66−
67−instance Monoid (HList '[]) where
68− mempty = Nil
69− mappend _ _ = Nil
70−
71−instance (Semigroup a, Semigroup (HList as)) => Semigroup (HList (a ': as)) where
72− (x :> xs) <> (y :> ys) = (x <> y) :> (xs <> ys)
73−
74−instance (Monoid a, Monoid (HList as)) => Monoid (HList (a ': as)) where
75− mempty = mempty :> mempty
76− mappend (x :> xs) (y :> ys) = mappend x y :> mappend xs ys
77−
78−class Elem (as :: [(k, Type)]) (key :: k) (i :: Nat) a | as key -> i a
79−instance {-# OVERLAPPING #-} pos ~ 0 => Elem (a ': xs) key pos a
80−instance (Elem xs key i a, pos ~ (i + 1)) => Elem (x ': xs) key pos a
81−
82−class GIsList
83− (f :: Type -> Type)
84− (g :: Type -> Type)
85− (as :: [Type])
86− (bs :: [Type]) | f -> as, g -> bs, bs f -> g, as g -> f where
87−
88− glist :: Iso (f x) (g x) (HList as) (HList bs)
89−
90− -- We define this reversed version, otherwise uses of `fromIso glist` are not
91− -- properly inlined by GHC 8.0.2.
92− -- This is not actually used.
93− glistR :: Iso (HList bs) (HList as) (g x) (f x)
94− glistR = fromIso glist
95−
96−instance
97− ( GIsList l l' as as'
98− , GIsList r r' bs bs'
99− , Appending as bs cs as' bs' cs'
100− , cs ~ (as ++ bs)
101− , cs' ~ (as' ++ bs')
102− ) => GIsList (l :*: r) (l' :*: r') cs cs' where
44+append :: HList as -> HList bs -> HList (as ++ bs)
45+append Nil ys = ys
46+append (x :> xs) ys = x :> append xs ys
10347
104− glist = prodIso . pairing glist glist . appending
105− {-# INLINE glist #-}
106−
107−instance GIsList f g as bs => GIsList (M1 t meta f) (M1 t meta g) as bs where
108− glist = mIso . glist
109− {-# INLINE glist #-}
110−
111−instance GIsList (Rec0 a) (Rec0 b) '[a] '[b] where
112− glist = kIso . singleton
113− {-# INLINE glist #-}
114−
115−instance GIsList U1 U1 '[] '[] where
116− glist = iso (const Nil) (const U1)
117− {-# INLINE glist #-}
48+head' :: HList (a ': as) -> a
49+head' (x :> _) = x
11850
11951--------------------------------------------------------------------------------
120−-- | as ++ bs === cs
121−class Appending as bs cs as' bs' cs'
122− | as bs cs cs' -> as' bs'
123− , as' bs' cs cs' -> as bs
124− , as bs -> cs
125− , as' bs' -> cs'
126− where
127− appending :: Iso (HList as, HList bs) (HList as', HList bs') (HList cs) (HList cs')
128−
129−-- | [] ++ bs === bs
130−instance Appending '[] bs bs '[] bs' bs' where
131− appending = iso snd (Nil,)
132−
133−-- | (a : as) ++ bs === (a : cs)
134−instance
135− Appending as bs cs as' bs' cs' -- as ++ bs == cs
136− => Appending (a ': as) bs (a ': cs) (a' ': as') bs' (a' ': cs') where
137− appending
138− = pairing (fromIso consing) id -- ((a, as), bs)
139− . assoc3 -- (a, (as, bs))
140− . pairing id appending -- (a, cs)
141− . consing -- (a : cs)
52+-- * Split HList
14253
143−singleton :: Iso a b (HList '[a]) (HList '[ b])
144−singleton = iso (:> Nil) (\(x :> _) -> x)
145−
146−consing :: Iso (a, HList as) (b, HList bs) (HList (a ': as)) (HList (b ': bs))
147−consing = iso (\(x, xs) -> x :> xs) (\(x :> xs) -> (x, xs))
148−
149−--------------------------------------------------------------------------------
150−class IndexList (i :: Nat) as bs a b | i as -> a, i bs -> b, i as b -> bs, i bs a -> as where
151− point :: Lens (HList as) (HList bs) a b
54+class Splittable (as :: [Type]) (bs :: [Type]) (cs :: [Type]) | as bs -> cs, as cs -> bs where
55+ split :: HList cs -> (HList as, HList bs)
15256
153−instance {-# OVERLAPPING #-}
154− ( as ~ (a ': as')
155− , bs ~ (b ': as')
156− ) => IndexList 0 as bs a b where
157− point = lens (\(x :> xs) -> (xs, x)) (\(xs, x') -> x' :> xs)
158− {-# INLINE point #-}
57+instance Splittable '[] bs bs where
58+ split bs = (Nil, bs)
15959
160−instance
161− ( IndexList (n - 1) as' bs' a b
162− , as ~ (x ': as')
163− , bs ~ (x ': bs')
164− ) => IndexList n as bs a b where
165− point = fromIso consing . alongside id (point @(n-1)) . second'
166− {-# INLINE point #-}
60+instance Splittable as bs cs => Splittable (a ': as) bs (a ': cs) where
61+ split (a :> as)
62+ = (a :> as', bs)
63+ where (as', bs) = split as
16764
16865--------------------------------------------------------------------------------
16966-- * Convert tuples to/from HLists
17067
17168class ListTuple (tuple :: Type) (as :: [Type]) | as -> tuple where
17269 type ListToTuple as :: Type
173− tupled :: Iso' (HList as) tuple
174− tupled = iso listToTuple tupleToList
175−
17670 tupleToList :: tuple -> HList as
17771 listToTuple :: HList as -> tuple
17872
@@ -307,23 +201,39 @@ instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) '[a, b
307201 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)
308202 = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
309203
310−type family TupleToList a where
311− TupleToList () = '[]
312− TupleToList (a, b) = '[a, b]
313− TupleToList (a, b, c) = '[a, b, c]
314− TupleToList (a, b, c, d) = '[a, b, c, d]
315− TupleToList (a, b, c, d, e) = '[a, b, c, d, e]
316− TupleToList (a, b, c, d, e, f) = '[a, b, c, d, e, f]
317− TupleToList (a, b, c, d, e, f, g) = '[a, b, c, d, e, f, g]
318− TupleToList (a, b, c, d, e, f, g, h) = '[a, b, c, d, e, f, g, h]
319− TupleToList (a, b, c, d, e, f, g, h, j) = '[a, b, c, d, e, f, g, h, j]
320− TupleToList (a, b, c, d, e, f, g, h, j, k) = '[a, b, c, d, e, f, g, h, j, k]
321− TupleToList (a, b, c, d, e, f, g, h, j, k, l) = '[a, b, c, d, e, f, g, h, j, k, l]
322− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m) = '[a, b, c, d, e, f, g, h, j, k, l, m]
323− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n) = '[a, b, c, d, e, f, g, h, j, k, l, m, n]
324− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o]
325− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p]
326− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q]
327− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r]
328− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s]
329− TupleToList a = '[a]
204+--------------------------------------------------------------------------------
205+
206+class GCollectible (f :: Type -> Type) (as :: [Type]) | f -> as where
207+ type GCollect f :: [Type]
208+ gtoCollection :: f x -> HList as
209+ gfromCollection :: HList as -> f x
210+
211+instance
212+ ( GCollectible l as
213+ , GCollectible r bs
214+ , cs ~ (as ++ bs)
215+ , Splittable as bs cs
216+ ) => GCollectible (l :*: r) cs where
217+ type GCollect (l :*: r) = GCollect l ++ GCollect r
218+
219+ gtoCollection (l :*: r)
220+ = gtoCollection l `append` gtoCollection r
221+
222+ gfromCollection cs
223+ = gfromCollection as :*: gfromCollection bs
224+ where (as, bs) = split cs
225+
226+instance GCollectible (Rec0 a) '[a] where
227+ type GCollect (Rec0 a) = '[a]
228+ gtoCollection = (:> Nil) . unK1
229+ gfromCollection = K1 . head'
230+
231+instance GCollectible U1 '[] where
232+ type GCollect U1 = '[]
233+ gtoCollection U1 = Nil
234+ gfromCollection Nil = U1
235+
236+instance GCollectible f as => GCollectible (M1 m meta f) as where
237+ type GCollect (M1 m meta f) = GCollect f
238+ gtoCollection = gtoCollection . unM1
239+ gfromCollection = M1 . gfromCollection