1{-# LANGUAGE EmptyCase, PolyKinds, UndecidableInstances #-}
2{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
3-- | Derive @generics-sop@ boilerplate instances from GHC's 'GHC.Generic'.
4--
5-- The technique being used here is described in the following paper:
6--
7--   * José Pedro Magalhães and Andres Löh.
8--     <http://www.andres-loeh.de/GenericGenericProgramming Generic Generic Programming>.
9--     Practical Aspects of Declarative Languages (PADL) 2014.
10--
11module Generics.SOP.GGP
12  ( GCode
13  , GFrom
14  , GTo
15  , GDatatypeInfo
16  , GDatatypeInfoOf
17  , gfrom
18  , gto
19  , gdatatypeInfo
20  ) where
21
22import Data.Proxy (Proxy (..))
23import Data.Kind (Type)
24import GHC.Generics as GHC
25import Generics.SOP.NP as SOP
26import Generics.SOP.NS as SOP
27import Generics.SOP.BasicFunctors as SOP
28import qualified Generics.SOP.Type.Metadata as SOP.T
29import Generics.SOP.Metadata as SOP
30
31type family ToSingleCode (a :: Type -> Type) :: Type
32type instance ToSingleCode (K1 _i a) = a
33
34type family ToProductCode (a :: Type -> Type) (xs :: [Type]) :: [Type]
35type instance ToProductCode (a :*: b)   xs = ToProductCode a (ToProductCode b xs)
36type instance ToProductCode U1          xs = xs
37type instance ToProductCode (M1 S _c a) xs = ToSingleCode a ': xs
38
39type family ToSumCode (a :: Type -> Type) (xs :: [[Type]]) :: [[Type]]
40type instance ToSumCode (a :+: b)   xs = ToSumCode a (ToSumCode b xs)
41type instance ToSumCode V1          xs = xs
42type instance ToSumCode (M1 D _c a) xs = ToSumCode a xs
43type instance ToSumCode (M1 C _c a) xs = ToProductCode a '[] ': xs
44
45data InfoProxy (c :: Meta) (f :: Type -> Type) (x :: Type) = InfoProxy
46
47type family ToInfo (a :: Type -> Type) :: SOP.T.DatatypeInfo
48type instance ToInfo (M1 D (MetaData n m p False) a) =
49  SOP.T.ADT m n (ToSumInfo a '[]) (ToStrictnessInfoss a '[])
50type instance ToInfo (M1 D (MetaData n m p True) a) =
51  SOP.T.Newtype m n (ToSingleConstructorInfo a)
52
53type family ToStrictnessInfoss (a :: Type -> Type) (xss :: [[SOP.T.StrictnessInfo]]) :: [[SOP.T.StrictnessInfo]]
54type instance ToStrictnessInfoss (a :+: b)  xss = ToStrictnessInfoss a (ToStrictnessInfoss b xss)
55type instance ToStrictnessInfoss V1         xss = xss
56type instance ToStrictnessInfoss (M1 C _ a) xss = ToStrictnessInfos a '[] ': xss
57
58type family ToStrictnessInfos (a :: Type -> Type) (xs :: [SOP.T.StrictnessInfo]) :: [SOP.T.StrictnessInfo]
59type instance ToStrictnessInfos (a :*: b)  xs = ToStrictnessInfos a (ToStrictnessInfos b xs)
60type instance ToStrictnessInfos U1         xs = xs
61type instance ToStrictnessInfos (M1 S s a) xs = ToStrictnessInfo s ': xs
62
63type family ToStrictnessInfo (s :: Meta) :: SOP.T.StrictnessInfo
64type instance ToStrictnessInfo (MetaSel _ su ss ds) = 'SOP.T.StrictnessInfo su ss ds
65
66type family ToSumInfo (a :: Type -> Type) (xs :: [SOP.T.ConstructorInfo]) :: [SOP.T.ConstructorInfo]
67type instance ToSumInfo (a :+: b)  xs = ToSumInfo a (ToSumInfo b xs)
68type instance ToSumInfo V1         xs = xs
69type instance ToSumInfo (M1 C c a) xs = ToSingleConstructorInfo (M1 C c a) ': xs
70
71type family ToSingleConstructorInfo (a :: Type -> Type) :: SOP.T.ConstructorInfo
72type instance ToSingleConstructorInfo (M1 C (MetaCons n PrefixI False) a) =
73  SOP.T.Constructor n
74type instance ToSingleConstructorInfo (M1 C (MetaCons n (InfixI assoc fix) False) a) =
75  SOP.T.Infix n assoc fix
76type instance ToSingleConstructorInfo (M1 C (MetaCons n f True) a) =
77  SOP.T.Record n (ToProductInfo a '[])
78
79type family ToProductInfo (a :: Type -> Type) (xs :: [SOP.T.FieldInfo]) :: [SOP.T.FieldInfo]
80type instance ToProductInfo (a :*: b)  xs = ToProductInfo a (ToProductInfo b xs)
81type instance ToProductInfo U1         xs = xs
82type instance ToProductInfo (M1 S c a) xs = ToSingleInfo (M1 S c a) ': xs
83
84type family ToSingleInfo (a :: Type -> Type) :: SOP.T.FieldInfo
85type instance ToSingleInfo (M1 S (MetaSel (Just n) _su _ss _ds) a) = 'SOP.T.FieldInfo n
86
87class GFieldInfos (a :: Type -> Type) where
88  gFieldInfos :: proxy a -> NP FieldInfo xs -> NP FieldInfo (ToProductCode a xs)
89
90instance (GFieldInfos a, GFieldInfos b) => GFieldInfos (a :*: b) where
91  gFieldInfos _ xs = gFieldInfos (Proxy :: Proxy a) (gFieldInfos (Proxy :: Proxy b) xs)
92
93instance GFieldInfos U1 where
94  gFieldInfos _ xs = xs
95
96instance (Selector c) => GFieldInfos (M1 S c a) where
97  gFieldInfos _ xs = FieldInfo (selName p) :* xs
98    where
99      p :: InfoProxy c a x
100      p = InfoProxy
101
102class GSingleFrom (a :: Type -> Type) where
103  gSingleFrom :: a x -> ToSingleCode a
104
105instance GSingleFrom (K1 i a) where
106  gSingleFrom (K1 a) = a
107
108class GProductFrom (a :: Type -> Type) where
109  gProductFrom :: a x -> NP I xs -> NP I (ToProductCode a xs)
110
111instance (GProductFrom a, GProductFrom b) => GProductFrom (a :*: b) where
112  gProductFrom (a :*: b) xs = gProductFrom a (gProductFrom b xs)
113
114instance GProductFrom U1 where
115  gProductFrom U1 xs = xs
116
117instance GSingleFrom a => GProductFrom (M1 S c a) where
118  gProductFrom (M1 a) xs = I (gSingleFrom a) :* xs
119
120class GSingleTo (a :: Type -> Type) where
121  gSingleTo :: ToSingleCode a -> a x
122
123instance GSingleTo (K1 i a) where
124  gSingleTo a = K1 a
125
126class GProductTo (a :: Type -> Type) where
127  gProductTo :: NP I (ToProductCode a xs) -> (a x -> NP I xs -> r) -> r
128
129instance (GProductTo a, GProductTo b) => GProductTo (a :*: b) where
130  gProductTo xs k = gProductTo xs (\ a ys -> gProductTo ys (\ b zs -> k (a :*: b) zs))
131
132instance GSingleTo a => GProductTo (M1 S c a) where
133  gProductTo (SOP.I a :* xs) k = k (M1 (gSingleTo a)) xs
134
135instance GProductTo U1 where
136  gProductTo xs k = k U1 xs
137
138-- This can most certainly be simplified
139class GSumFrom (a :: Type -> Type) where
140  gSumFrom :: a x -> proxy xss -> SOP I (ToSumCode a xss)
141  gSumSkip :: proxy a -> SOP I xss -> SOP I (ToSumCode a xss)
142
143instance GSumFrom V1 where
144  gSumFrom x = case x of {}
145  gSumSkip _ xss = xss
146
147instance (GSumFrom a, GSumFrom b) => GSumFrom (a :+: b) where
148  gSumFrom (L1 a) xss = gSumFrom a (toSumCodeProxy xss) where
149    toSumCodeProxy :: proxy xss -> Proxy (ToSumCode b xss)
150    toSumCodeProxy _ = Proxy
151
152  gSumFrom (R1 b) xss = gSumSkip (Proxy :: Proxy a) (gSumFrom b xss)
153
154  gSumSkip _ xss = gSumSkip (Proxy :: Proxy a) (gSumSkip (Proxy :: Proxy b) xss)
155
156instance (GSumFrom a) => GSumFrom (M1 D c a) where
157  gSumFrom (M1 a) xss = gSumFrom a xss
158  gSumSkip _      xss = gSumSkip (Proxy :: Proxy a) xss
159
160instance (GProductFrom a) => GSumFrom (M1 C c a) where
161  gSumFrom (M1 a) _    = SOP (Z (gProductFrom a Nil))
162  gSumSkip _ (SOP xss) = SOP (S xss)
163
164class GSumTo (a :: Type -> Type) where
165  gSumTo :: SOP I (ToSumCode a xss) -> (a x -> r) -> (SOP I xss -> r) -> r
166
167instance GSumTo V1 where
168  gSumTo x _ k = k x
169
170instance (GSumTo a, GSumTo b) => GSumTo (a :+: b) where
171  gSumTo xss s k = gSumTo xss (s . L1) (\ r -> gSumTo r (s . R1) k)
172
173instance (GProductTo a) => GSumTo (M1 C c a) where
174  gSumTo (SOP (Z xs)) s _ = s (M1 (gProductTo xs ((\ x Nil -> x) :: a x -> NP I '[] -> a x)))
175  gSumTo (SOP (S xs)) _ k = k (SOP xs)
176
177instance (GSumTo a) => GSumTo (M1 D c a) where
178  gSumTo xss s k = gSumTo xss (s . M1) k
179
180-- | Compute the SOP code of a datatype.
181--
182-- This requires that 'GHC.Rep' is defined, which in turn requires that
183-- the type has a 'GHC.Generic' (from module "GHC.Generics") instance.
184--
185-- This is the default definition for 'Generics.SOP.Code'.
186-- For more info, see 'Generics.SOP.Generic'.
187--
188type GCode (a :: Type) = ToSumCode (GHC.Rep a) '[]
189
190-- | Constraint for the class that computes 'gfrom'.
191type GFrom a = GSumFrom (GHC.Rep a)
192
193-- | Constraint for the class that computes 'gto'.
194type GTo a = GSumTo (GHC.Rep a)
195
196-- | Constraint for the class that computes 'gdatatypeInfo'.
197type GDatatypeInfo a = SOP.T.DemoteDatatypeInfo (GDatatypeInfoOf a) (GCode a)
198
199-- | Compute the datatype info of a datatype.
200--
201-- @since 0.3.0.0
202--
203type GDatatypeInfoOf (a :: Type) = ToInfo (GHC.Rep a)
204
205-- | An automatically computed version of 'Generics.SOP.from'.
206--
207-- This requires that the type being converted has a
208-- 'GHC.Generic' (from module "GHC.Generics") instance.
209--
210-- This is the default definition for 'Generics.SOP.from'.
211-- For more info, see 'Generics.SOP.Generic'.
212--
213gfrom :: (GFrom a, GHC.Generic a) => a -> SOP I (GCode a)
214gfrom x = gSumFrom (GHC.from x) (Proxy :: Proxy '[])
215
216-- | An automatically computed version of 'Generics.SOP.to'.
217--
218-- This requires that the type being converted has a
219-- 'GHC.Generic' (from module "GHC.Generics") instance.
220--
221-- This is the default definition for 'Generics.SOP.to'.
222-- For more info, see 'Generics.SOP.Generic'.
223--
224gto :: forall a. (GTo a, GHC.Generic a) => SOP I (GCode a) -> a
225gto x = GHC.to (gSumTo x id ((\y -> case y of {}) :: SOP I '[] -> (GHC.Rep a) x))
226
227-- | An automatically computed version of 'Generics.SOP.datatypeInfo'.
228--
229-- This requires that the type being converted has a
230-- 'GHC.Generic' (from module "GHC.Generics") instance.
231--
232-- This is the default definition for 'Generics.SOP.datatypeInfo'.
233-- For more info, see 'Generics.SOP.HasDatatypeInfo'.
234--
235gdatatypeInfo :: forall proxy a. (GDatatypeInfo a) => proxy a -> DatatypeInfo (GCode a)
236gdatatypeInfo _ = SOP.T.demoteDatatypeInfo (Proxy :: Proxy (GDatatypeInfoOf a))
237
238