@@ -1,39 +1,59 @@
1−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
3+{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FunctionalDependencies #-}
5{-# LANGUAGE FunctionalDependencies #-}
4{-# LANGUAGE GADTs #-}
6{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE KindSignatures #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE PolyKinds #-}
8{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TupleSections #-}
9+{-# LANGUAGE TypeApplications #-}
9{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE TypeInType #-}
10{-# LANGUAGE TypeOperators #-}
12{-# LANGUAGE TypeOperators #-}
11{-# LANGUAGE UndecidableInstances #-}
13{-# LANGUAGE UndecidableInstances #-}
15+#if __GLASGOW_HASKELL__ == 802
16+{-# OPTIONS_GHC -fno-solve-constant-dicts #-}
13-----------------------------------------------------------------------------
20-----------------------------------------------------------------------------
15−-- Module : Data.Generics.Internal.HList
22+-- Module : Data.Generics.Product.Internal.HList
16−-- Copyright : (C) 2017 Csongor Kiss
23+-- Copyright : (C) 2019 Csongor Kiss
17-- License : BSD3
24-- License : BSD3
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
25-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Stability : experimental
26-- Stability : experimental
20-- Portability : non-portable
27-- Portability : non-portable
29+-- Derive an isomorphism between a product type and a flat HList.
22-----------------------------------------------------------------------------
31-----------------------------------------------------------------------------
23−module Data.Generics.Internal.HList
33+module Data.Generics.Product.Internal.HList
26 , ListTuple (..)
39 , ListTuple (..)
43+#if __GLASGOW_HASKELL__ < 804
31−import Data.Kind (Type)
48+import Data.Kind (Type)
32import GHC.Generics
49import GHC.Generics
50+import Data.Profunctor
51+import Data.Generics.Internal.Profunctor.Lens
52+import Data.Generics.Internal.Profunctor.Iso
34−data HList (xs :: [Type]) where
54+data HList (as :: [Type]) where
35− Nil :: HList '[]
55+ Nil :: HList '[]
36− (:>) :: x -> HList xs -> HList (x ': xs)
56+ (:>) :: a -> HList as -> HList (a ': as)
38infixr 5 :>
58infixr 5 :>
@@ -41,32 +61,118 @@ type family ((as :: [k]) ++ (bs :: [k])) :: [k] where
41 '[] ++ bs = bs
61 '[] ++ bs = bs
42 (a ': as) ++ bs = a ': as ++ bs
62 (a ': as) ++ bs = a ': as ++ bs
44−append :: HList as -> HList bs -> HList (as ++ bs)
64+instance Semigroup (HList '[]) where
45−append Nil ys = ys
65+ _ <> _ = Nil
46−append (x :> xs) ys = x :> append xs ys
66+
67+instance Monoid (HList '[]) where
71+instance (Semigroup a, Semigroup (HList as)) => Semigroup (HList (a ': as)) where
72+ (x :> xs) <> (y :> ys) = (x <> y) :> (xs <> ys)
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
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
86+ (bs :: [Type]) | f -> as, g -> bs, bs f -> g, as g -> f where
88+ glist :: Iso (f x) (g x) (HList as) (HList bs)
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
97+ ( GIsList l l' as as'
98+ , GIsList r r' bs bs'
99+ , Appending as bs cs as' bs' cs'
101+ , cs' ~ (as' ++ bs')
102+ ) => GIsList (l :*: r) (l' :*: r') cs cs' where
48−head' :: HList (a ': as) -> a
104+ glist = prodIso . pairing glist glist . appending
49−head' (x :> _) = x
105+ {-# INLINE glist #-}
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 #-}
111+instance GIsList (Rec0 a) (Rec0 b) '[a] '[b] where
112+ glist = kIso . singleton
113+ {-# INLINE glist #-}
115+instance GIsList U1 U1 '[] '[] where
116+ glist = iso (const Nil) (const U1)
117+ {-# INLINE glist #-}
51--------------------------------------------------------------------------------
119--------------------------------------------------------------------------------
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
127+ appending :: Iso (HList as, HList bs) (HList as', HList bs') (HList cs) (HList cs')
130+instance Appending '[] bs bs '[] bs' bs' where
131+ appending = iso snd (Nil,)
133+-- | (a : as) ++ bs === (a : cs)
135+ Appending as bs cs as' bs' cs' -- as ++ bs == cs
136+ => Appending (a ': as) bs (a ': cs) (a' ': as') bs' (a' ': cs') where
138+ = pairing (fromIso consing) id -- ((a, as), bs)
139+ . assoc3 -- (a, (as, bs))
140+ . pairing id appending -- (a, cs)
141+ . consing -- (a : cs)
143+singleton :: Iso a b (HList '[a]) (HList '[ b])
144+singleton = iso (:> Nil) (\(x :> _) -> x)
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))
149+--------------------------------------------------------------------------------
54−class Splittable (as :: [Type]) (bs :: [Type]) (cs :: [Type]) | as bs -> cs, as cs -> bs where
150+class IndexList (i :: Nat) as bs a b | i as -> a, i bs -> b, i as b -> bs, i bs a -> as where
55− split :: HList cs -> (HList as, HList bs)
151+ point :: Lens (HList as) (HList bs) a b
57−instance Splittable '[] bs bs where
153+instance {-# OVERLAPPING #-}
58− split bs = (Nil, bs)
154+ ( as ~ (a ': as')
156+ ) => IndexList 0 as bs a b where
157+ point = lens (\(x :> xs) -> (xs, x)) (\(xs, x') -> x' :> xs)
158+ {-# INLINE point #-}
60−instance Splittable as bs cs => Splittable (a ': as) bs (a ': cs) where
160+instance
61− split (a :> as)
161+ ( IndexList (n - 1) as' bs' a b
62− = (a :> as', bs)
162+ , as ~ (x ': as')
63− where (as', bs) = split 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 #-}
65--------------------------------------------------------------------------------
168--------------------------------------------------------------------------------
66-- * Convert tuples to/from HLists
169-- * Convert tuples to/from HLists
68class ListTuple (tuple :: Type) (as :: [Type]) | as -> tuple where
171class ListTuple (tuple :: Type) (as :: [Type]) | as -> tuple where
69 type ListToTuple as :: Type
172 type ListToTuple as :: Type
173+ tupled :: Iso' (HList as) tuple
174+ tupled = iso listToTuple tupleToList
70 tupleToList :: tuple -> HList as
176 tupleToList :: tuple -> HList as
71 listToTuple :: HList as -> tuple
177 listToTuple :: HList as -> tuple
@@ -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
201 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)
307 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)
202 = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
308 = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
204−--------------------------------------------------------------------------------
310+type family TupleToList a where
205−
311+ TupleToList () = '[]
206−class GCollectible (f :: Type -> Type) (as :: [Type]) | f -> as where
312+ TupleToList (a, b) = '[a, b]
207− type GCollect f :: [Type]
313+ TupleToList (a, b, c) = '[a, b, c]
208− gtoCollection :: f x -> HList as
314+ TupleToList (a, b, c, d) = '[a, b, c, d]
209− gfromCollection :: HList as -> f x
315+ TupleToList (a, b, c, d, e) = '[a, b, c, d, e]
210−
316+ TupleToList (a, b, c, d, e, f) = '[a, b, c, d, e, f]
211−instance
317+ TupleToList (a, b, c, d, e, f, g) = '[a, b, c, d, e, f, g]
212− ( GCollectible l as
318+ TupleToList (a, b, c, d, e, f, g, h) = '[a, b, c, d, e, f, g, h]
213− , GCollectible r bs
319+ TupleToList (a, b, c, d, e, f, g, h, j) = '[a, b, c, d, e, f, g, h, j]
214− , cs ~ (as ++ bs)
320+ TupleToList (a, b, c, d, e, f, g, h, j, k) = '[a, b, c, d, e, f, g, h, j, k]
215− , Splittable as bs cs
321+ TupleToList (a, b, c, d, e, f, g, h, j, k, l) = '[a, b, c, d, e, f, g, h, j, k, l]
216− ) => GCollectible (l :*: r) cs where
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]
217− type GCollect (l :*: r) = GCollect l ++ GCollect r
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]
218−
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]
219− gtoCollection (l :*: r)
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]
220− = gtoCollection l `append` gtoCollection r
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]
221−
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]
222− gfromCollection cs
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]
223− = gfromCollection as :*: gfromCollection bs
329+ TupleToList a = '[a]
224− where (as, bs) = split cs
226−instance GCollectible (Rec0 a) '[a] where
227− type GCollect (Rec0 a) = '[a]
228− gtoCollection = (:> Nil) . unK1
229− gfromCollection = K1 . head'
231−instance GCollectible U1 '[] where
232− type GCollect U1 = '[]
233− gtoCollection U1 = Nil
234− gfromCollection Nil = U1
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