@@ -1,39 +1,59 @@
1−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE ConstraintKinds #-}
24{-# LANGUAGE FlexibleInstances #-}
35{-# LANGUAGE FunctionalDependencies #-}
46{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE KindSignatures #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE PolyKinds #-}
87{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TupleSections #-}
9+{-# LANGUAGE TypeApplications #-}
910{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE TypeInType #-}
1012{-# LANGUAGE TypeOperators #-}
1113{-# LANGUAGE UndecidableInstances #-}
1214
15+#if __GLASGOW_HASKELL__ == 802
16+{-# OPTIONS_GHC -fno-solve-constant-dicts #-}
17+#endif
18+
19+
1320-----------------------------------------------------------------------------
1421-- |
15−-- Module : Data.Generics.Internal.HList
16−-- Copyright : (C) 2017 Csongor Kiss
22+-- Module : Data.Generics.Product.Internal.HList
23+-- Copyright : (C) 2019 Csongor Kiss
1724-- License : BSD3
1825-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1926-- Stability : experimental
2027-- Portability : non-portable
2128--
29+-- Derive an isomorphism between a product type and a flat HList.
30+--
2231-----------------------------------------------------------------------------
23−module Data.Generics.Internal.HList
24− ( type (++)
2532
33+module Data.Generics.Product.Internal.HList
34+ ( GIsList(..)
35+ , IndexList (..)
36+ , HList (..)
37+ , type (++)
38+ , Elem
2639 , ListTuple (..)
27−
28− , GCollectible (..)
40+ , TupleToList
2941 ) where
3042
31−import Data.Kind (Type)
43+#if __GLASGOW_HASKELL__ < 804
44+import Data.Semigroup
45+#endif
46+import GHC.TypeLits
47+
48+import Data.Kind (Type)
3249import GHC.Generics
50+import Data.Profunctor
51+import Data.Generics.Internal.Profunctor.Lens
52+import Data.Generics.Internal.Profunctor.Iso
3353
34−data HList (xs :: [Type]) where
35− Nil :: HList '[]
36− (:>) :: x -> HList xs -> HList (x ': xs)
54+data HList (as :: [Type]) where
55+ Nil :: HList '[]
56+ (:>) :: a -> HList as -> HList (a ': as)
3757
3858infixr 5 :>
3959
@@ -41,32 +61,118 @@ type family ((as :: [k]) ++ (bs :: [k])) :: [k] where
4161 '[] ++ bs = bs
4262 (a ': as) ++ bs = a ': as ++ bs
4363
44−append :: HList as -> HList bs -> HList (as ++ bs)
45−append Nil ys = ys
46−append (x :> xs) ys = x :> append xs ys
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
47103
48−head' :: HList (a ': as) -> a
49−head' (x :> _) = x
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 #-}
50118
51119--------------------------------------------------------------------------------
52−-- * Split HList
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)
53142
54−class Splittable (as :: [Type]) (bs :: [Type]) (cs :: [Type]) | as bs -> cs, as cs -> bs where
55− split :: HList cs -> (HList as, HList bs)
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
56152
57−instance Splittable '[] bs bs where
58− split bs = (Nil, bs)
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 #-}
59159
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
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 #-}
64167
65168--------------------------------------------------------------------------------
66169-- * Convert tuples to/from HLists
67170
68171class ListTuple (tuple :: Type) (as :: [Type]) | as -> tuple where
69172 type ListToTuple as :: Type
173+ tupled :: Iso' (HList as) tuple
174+ tupled = iso listToTuple tupleToList
175+
70176 tupleToList :: tuple -> HList as
71177 listToTuple :: HList as -> tuple
72178
@@ -201,39 +307,23 @@ instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) '[a, b
201307 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)
202308 = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
203309
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
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]