{-# LANGUAGE EmptyCase, PolyKinds, UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
-- | Derive @generics-sop@ boilerplate instances from GHC's 'GHC.Generic'.
--
-- The technique being used here is described in the following paper:
--
-- * José Pedro Magalhães and Andres Löh.
-- .
-- Practical Aspects of Declarative Languages (PADL) 2014.
--
module Generics.SOP.GGP
( GCode
, GFrom
, GTo
, GDatatypeInfo
, GDatatypeInfoOf
, gfrom
, gto
, gdatatypeInfo
) where
import Data.Proxy (Proxy (..))
import Data.Kind (Type)
import GHC.Generics as GHC
import Generics.SOP.NP as SOP
import Generics.SOP.NS as SOP
import Generics.SOP.BasicFunctors as SOP
import qualified Generics.SOP.Type.Metadata as SOP.T
import Generics.SOP.Metadata as SOP
type family ToSingleCode (a :: Type -> Type) :: Type
type instance ToSingleCode (K1 _i a) = a
type family ToProductCode (a :: Type -> Type) (xs :: [Type]) :: [Type]
type instance ToProductCode (a :*: b) xs = ToProductCode a (ToProductCode b xs)
type instance ToProductCode U1 xs = xs
type instance ToProductCode (M1 S _c a) xs = ToSingleCode a ': xs
type family ToSumCode (a :: Type -> Type) (xs :: [[Type]]) :: [[Type]]
type instance ToSumCode (a :+: b) xs = ToSumCode a (ToSumCode b xs)
type instance ToSumCode V1 xs = xs
type instance ToSumCode (M1 D _c a) xs = ToSumCode a xs
type instance ToSumCode (M1 C _c a) xs = ToProductCode a '[] ': xs
data InfoProxy (c :: Meta) (f :: Type -> Type) (x :: Type) = InfoProxy
type family ToInfo (a :: Type -> Type) :: SOP.T.DatatypeInfo
type instance ToInfo (M1 D (MetaData n m p False) a) =
SOP.T.ADT m n (ToSumInfo a '[])
type instance ToInfo (M1 D (MetaData n m p True) a) =
SOP.T.Newtype m n (ToSingleConstructorInfo a)
type family ToSumInfo (a :: Type -> Type) (xs :: [SOP.T.ConstructorInfo]) :: [SOP.T.ConstructorInfo]
type instance ToSumInfo (a :+: b) xs = ToSumInfo a (ToSumInfo b xs)
type instance ToSumInfo V1 xs = xs
type instance ToSumInfo (M1 C c a) xs = ToSingleConstructorInfo (M1 C c a) ': xs
type family ToSingleConstructorInfo (a :: Type -> Type) :: SOP.T.ConstructorInfo
type instance ToSingleConstructorInfo (M1 C (MetaCons n PrefixI False) a) =
SOP.T.Constructor n
type instance ToSingleConstructorInfo (M1 C (MetaCons n (InfixI assoc fix) False) a) =
SOP.T.Infix n assoc fix
type instance ToSingleConstructorInfo (M1 C (MetaCons n f True) a) =
SOP.T.Record n (ToProductInfo a '[])
type family ToProductInfo (a :: Type -> Type) (xs :: [SOP.T.FieldInfo]) :: [SOP.T.FieldInfo]
type instance ToProductInfo (a :*: b) xs = ToProductInfo a (ToProductInfo b xs)
type instance ToProductInfo U1 xs = xs
type instance ToProductInfo (M1 S c a) xs = ToSingleInfo (M1 S c a) ': xs
type family ToSingleInfo (a :: Type -> Type) :: SOP.T.FieldInfo
type instance ToSingleInfo (M1 S (MetaSel (Just n) _su _ss _ds) a) = 'SOP.T.FieldInfo n
class GFieldInfos (a :: Type -> Type) where
gFieldInfos :: proxy a -> NP FieldInfo xs -> NP FieldInfo (ToProductCode a xs)
instance (GFieldInfos a, GFieldInfos b) => GFieldInfos (a :*: b) where
gFieldInfos _ xs = gFieldInfos (Proxy :: Proxy a) (gFieldInfos (Proxy :: Proxy b) xs)
instance GFieldInfos U1 where
gFieldInfos _ xs = xs
instance (Selector c) => GFieldInfos (M1 S c a) where
gFieldInfos _ xs = FieldInfo (selName p) :* xs
where
p :: InfoProxy c a x
p = InfoProxy
class GSingleFrom (a :: Type -> Type) where
gSingleFrom :: a x -> ToSingleCode a
instance GSingleFrom (K1 i a) where
gSingleFrom (K1 a) = a
class GProductFrom (a :: Type -> Type) where
gProductFrom :: a x -> NP I xs -> NP I (ToProductCode a xs)
instance (GProductFrom a, GProductFrom b) => GProductFrom (a :*: b) where
gProductFrom (a :*: b) xs = gProductFrom a (gProductFrom b xs)
instance GProductFrom U1 where
gProductFrom U1 xs = xs
instance GSingleFrom a => GProductFrom (M1 S c a) where
gProductFrom (M1 a) xs = I (gSingleFrom a) :* xs
class GSingleTo (a :: Type -> Type) where
gSingleTo :: ToSingleCode a -> a x
instance GSingleTo (K1 i a) where
gSingleTo a = K1 a
class GProductTo (a :: Type -> Type) where
gProductTo :: NP I (ToProductCode a xs) -> (a x -> NP I xs -> r) -> r
instance (GProductTo a, GProductTo b) => GProductTo (a :*: b) where
gProductTo xs k = gProductTo xs (\ a ys -> gProductTo ys (\ b zs -> k (a :*: b) zs))
instance GSingleTo a => GProductTo (M1 S c a) where
gProductTo (SOP.I a :* xs) k = k (M1 (gSingleTo a)) xs
instance GProductTo U1 where
gProductTo xs k = k U1 xs
-- This can most certainly be simplified
class GSumFrom (a :: Type -> Type) where
gSumFrom :: a x -> SOP I xss -> SOP I (ToSumCode a xss)
gSumSkip :: proxy a -> SOP I xss -> SOP I (ToSumCode a xss)
instance GSumFrom V1 where
gSumFrom x = case x of {}
gSumSkip _ xss = xss
instance (GSumFrom a, GSumFrom b) => GSumFrom (a :+: b) where
gSumFrom (L1 a) xss = gSumFrom a (gSumSkip (Proxy :: Proxy b) xss)
gSumFrom (R1 b) xss = gSumSkip (Proxy :: Proxy a) (gSumFrom b xss)
gSumSkip _ xss = gSumSkip (Proxy :: Proxy a) (gSumSkip (Proxy :: Proxy b) xss)
instance (GSumFrom a) => GSumFrom (M1 D c a) where
gSumFrom (M1 a) xss = gSumFrom a xss
gSumSkip _ xss = gSumSkip (Proxy :: Proxy a) xss
instance (GProductFrom a) => GSumFrom (M1 C c a) where
gSumFrom (M1 a) _ = SOP (Z (gProductFrom a Nil))
gSumSkip _ (SOP xss) = SOP (S xss)
class GSumTo (a :: Type -> Type) where
gSumTo :: SOP I (ToSumCode a xss) -> (a x -> r) -> (SOP I xss -> r) -> r
instance GSumTo V1 where
gSumTo x _ k = k x
instance (GSumTo a, GSumTo b) => GSumTo (a :+: b) where
gSumTo xss s k = gSumTo xss (s . L1) (\ r -> gSumTo r (s . R1) k)
instance (GProductTo a) => GSumTo (M1 C c a) where
gSumTo (SOP (Z xs)) s _ = s (M1 (gProductTo xs ((\ x Nil -> x) :: a x -> NP I '[] -> a x)))
gSumTo (SOP (S xs)) _ k = k (SOP xs)
instance (GSumTo a) => GSumTo (M1 D c a) where
gSumTo xss s k = gSumTo xss (s . M1) k
-- | Compute the SOP code of a datatype.
--
-- This requires that 'GHC.Rep' is defined, which in turn requires that
-- the type has a 'GHC.Generic' (from module "GHC.Generics") instance.
--
-- This is the default definition for 'Generics.SOP.Code'.
-- For more info, see 'Generics.SOP.Generic'.
--
type GCode (a :: Type) = ToSumCode (GHC.Rep a) '[]
-- | Constraint for the class that computes 'gfrom'.
type GFrom a = GSumFrom (GHC.Rep a)
-- | Constraint for the class that computes 'gto'.
type GTo a = GSumTo (GHC.Rep a)
-- | Constraint for the class that computes 'gdatatypeInfo'.
type GDatatypeInfo a = SOP.T.DemoteDatatypeInfo (GDatatypeInfoOf a) (GCode a)
-- | Compute the datatype info of a datatype.
--
-- @since 0.3.0.0
--
type GDatatypeInfoOf (a :: Type) = ToInfo (GHC.Rep a)
-- | An automatically computed version of 'Generics.SOP.from'.
--
-- This requires that the type being converted has a
-- 'GHC.Generic' (from module "GHC.Generics") instance.
--
-- This is the default definition for 'Generics.SOP.from'.
-- For more info, see 'Generics.SOP.Generic'.
--
gfrom :: (GFrom a, GHC.Generic a) => a -> SOP I (GCode a)
gfrom x = gSumFrom (GHC.from x) (error "gfrom: internal error" :: SOP.SOP SOP.I '[])
-- | An automatically computed version of 'Generics.SOP.to'.
--
-- This requires that the type being converted has a
-- 'GHC.Generic' (from module "GHC.Generics") instance.
--
-- This is the default definition for 'Generics.SOP.to'.
-- For more info, see 'Generics.SOP.Generic'.
--
gto :: forall a. (GTo a, GHC.Generic a) => SOP I (GCode a) -> a
gto x = GHC.to (gSumTo x id ((\y -> case y of {}) :: SOP I '[] -> (GHC.Rep a) x))
-- | An automatically computed version of 'Generics.SOP.datatypeInfo'.
--
-- This requires that the type being converted has a
-- 'GHC.Generic' (from module "GHC.Generics") instance.
--
-- This is the default definition for 'Generics.SOP.datatypeInfo'.
-- For more info, see 'Generics.SOP.HasDatatypeInfo'.
--
gdatatypeInfo :: forall proxy a. (GDatatypeInfo a) => proxy a -> DatatypeInfo (GCode a)
gdatatypeInfo _ = SOP.T.demoteDatatypeInfo (Proxy :: Proxy (GDatatypeInfoOf a))