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