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