70 lines
2 KiB
Haskell
70 lines
2 KiB
Haskell
{-# LANGUAGE Unsafe #-}
|
|
{-# LANGUAGE RoleAnnotations #-}
|
|
{-# LANGUAGE StandaloneKindSignatures #-}
|
|
{-# LANGUAGE InstanceSigs #-}
|
|
{-# OPTIONS_GHC -Wno-unsafe #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
{-# LANGUAGE ImportQualifiedPost #-}
|
|
|
|
module GHC.Generics.CoerceTo
|
|
(GenericCoerceTo(..))
|
|
where
|
|
|
|
import Prelude ((.), ($))
|
|
|
|
import GHC.Generics (Generic(Rep))
|
|
import GHC.Generics.Coerce (GenericCoerce())
|
|
|
|
import GHC.Generics qualified as Generics
|
|
import GHC.Generics.Coerce qualified as GenericCoerce
|
|
|
|
import Data.Kind (Type)
|
|
|
|
import Data.List qualified as List
|
|
import Data.List.NonEmpty (NonEmpty)
|
|
import Data.List.NonEmpty qualified as NonEmpty
|
|
|
|
import Data.Semigroup (Semigroup ((<>), sconcat))
|
|
import Data.Monoid (Monoid (mempty, mconcat))
|
|
|
|
type role GenericCoerceTo representational phantom
|
|
|
|
type GenericCoerceTo :: Type -> Type -> Type
|
|
|
|
newtype GenericCoerceTo self other = GenericCoerceTo { get :: self }
|
|
|
|
|
|
toOther :: (Generic b, Generic a, GenericCoerce (Rep a) (Rep b)) => GenericCoerceTo a b -> b
|
|
toOther = Generics.to . GenericCoerce.gfrom . Generics.from . get
|
|
|
|
fromOther :: (Generic a, Generic b, GenericCoerce (Rep a) (Rep b)) => b -> GenericCoerceTo a b
|
|
fromOther = GenericCoerceTo . Generics.to . GenericCoerce.gto . Generics.from
|
|
|
|
|
|
instance
|
|
(Generic this
|
|
, Generic other
|
|
, GenericCoerce (Rep this) (Rep other)
|
|
, Semigroup other)
|
|
=> Semigroup (GenericCoerceTo this other) where
|
|
|
|
(<>) :: GenericCoerceTo this other -> GenericCoerceTo this other -> GenericCoerceTo this other
|
|
lhs <> rhs = fromOther $ toOther lhs <> toOther rhs
|
|
|
|
sconcat :: NonEmpty (GenericCoerceTo this other) -> GenericCoerceTo this other
|
|
sconcat = fromOther . sconcat . NonEmpty.map toOther
|
|
|
|
instance
|
|
(Generic this
|
|
, Generic other
|
|
, GenericCoerce (Rep this) (Rep other)
|
|
, Monoid other)
|
|
=> Monoid (GenericCoerceTo this other) where
|
|
|
|
mempty :: GenericCoerceTo this other
|
|
mempty = fromOther mempty
|
|
|
|
mconcat :: [GenericCoerceTo this other] -> GenericCoerceTo this other
|
|
mconcat = fromOther . mconcat . List.map toOther
|
|
|