{- | Something to coerce between two records with the same field names and
 compatible field types
-}
module Calamity.Internal.ShapeCoerce (
    shapeCoerce,
    ShapeCoerce,
    GShapeCoerce (..),
) where

import Data.Coerce (Coercible, coerce)
import GHC.Generics

type ShapeCoerce a b = (Generic a, Generic b, GShapeCoerce (Rep a) (Rep b))

shapeCoerce :: (Generic a, Generic b, GShapeCoerce (Rep a) (Rep b)) => a -> b
shapeCoerce :: a -> b
shapeCoerce = Rep b Any -> b
forall a x. Generic a => Rep a x -> a
to (Rep b Any -> b) -> (a -> Rep b Any) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a Any -> Rep b Any
forall k k (f :: k -> *) (g :: k -> *) (a :: k) (b :: k).
GShapeCoerce f g =>
f a -> g b
gshapeCoerce (Rep a Any -> Rep b Any) -> (a -> Rep a Any) -> a -> Rep b Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from

class GShapeCoerce f g where
    gshapeCoerce :: f a -> g b

instance (GShapeCoerce fa ga, GShapeCoerce fb gb) => GShapeCoerce (fa :*: fb) (ga :*: gb) where
    gshapeCoerce :: (:*:) fa fb a -> (:*:) ga gb b
gshapeCoerce (fa a
la :*: fb a
lb) = fa a -> ga b
forall k k (f :: k -> *) (g :: k -> *) (a :: k) (b :: k).
GShapeCoerce f g =>
f a -> g b
gshapeCoerce fa a
la ga b -> gb b -> (:*:) ga gb b
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: fb a -> gb b
forall k k (f :: k -> *) (g :: k -> *) (a :: k) (b :: k).
GShapeCoerce f g =>
f a -> g b
gshapeCoerce fb a
lb

instance GShapeCoerce f g => GShapeCoerce (M1 D da f) (M1 D db g) where
    gshapeCoerce :: M1 D da f a -> M1 D db g b
gshapeCoerce (M1 f a
a) = g b -> M1 D db g b
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> g b
forall k k (f :: k -> *) (g :: k -> *) (a :: k) (b :: k).
GShapeCoerce f g =>
f a -> g b
gshapeCoerce f a
a)

instance GShapeCoerce f g => GShapeCoerce (M1 C da f) (M1 C db g) where
    gshapeCoerce :: M1 C da f a -> M1 C db g b
gshapeCoerce (M1 f a
a) = g b -> M1 C db g b
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> g b
forall k k (f :: k -> *) (g :: k -> *) (a :: k) (b :: k).
GShapeCoerce f g =>
f a -> g b
gshapeCoerce f a
a)

instance GShapeCoerce f g => GShapeCoerce (S1 ( 'MetaSel ( 'Just name) fsu fss fl) f) (S1 ( 'MetaSel ( 'Just name') gsu gss gl) g) where
    gshapeCoerce :: S1 ('MetaSel ('Just name) fsu fss fl) f a
-> S1 ('MetaSel ('Just name') gsu gss gl) g b
gshapeCoerce (M1 f a
a) = g b -> S1 ('MetaSel ('Just name') gsu gss gl) g b
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> g b
forall k k (f :: k -> *) (g :: k -> *) (a :: k) (b :: k).
GShapeCoerce f g =>
f a -> g b
gshapeCoerce f a
a)

instance GShapeCoerce f g => GShapeCoerce (S1 ( 'MetaSel 'Nothing fsu fss fl) f) (S1 ( 'MetaSel 'Nothing gsu gss gl) g) where
    gshapeCoerce :: S1 ('MetaSel 'Nothing fsu fss fl) f a
-> S1 ('MetaSel 'Nothing gsu gss gl) g b
gshapeCoerce (M1 f a
a) = g b -> S1 ('MetaSel 'Nothing gsu gss gl) g b
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> g b
forall k k (f :: k -> *) (g :: k -> *) (a :: k) (b :: k).
GShapeCoerce f g =>
f a -> g b
gshapeCoerce f a
a)

instance Coercible a b => GShapeCoerce (Rec0 a) (Rec0 b) where
    gshapeCoerce :: Rec0 a a -> Rec0 b b
gshapeCoerce (K1 a
a) = b -> Rec0 b b
forall k i c (p :: k). c -> K1 i c p
K1 (b -> Rec0 b b) -> b -> Rec0 b b
forall a b. (a -> b) -> a -> b
$ a -> b
coerce a
a