{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Witch.Generic where

import qualified GHC.Generics as Generics
import qualified Witch.From as From

-- | This type class is used to implement generic conversions using the 'Generics.Generically' helper.
-- This is an advanced use case.
-- Most users will not need to know about this type class.
-- And even for those that want to derive 'Generics.Generically', this type class should be an implementation detail.
--
-- This type class can convert between any two types as long as they have 'Generics.Generic' instances and they are structurally similar.
-- For example, if you define your own empty type you could convert it to the typical 'Data.Void.Void' type:
--
-- > data Empty deriving Generic
-- > deriving via Generically Void instance From Empty Void
--
-- Or your own unit type:
--
-- > data Unit = MkUnit deriving Generic
-- > deriving via Generically () instance From Unit ()
--
-- Note that this looks superficially similar to @newtype Unit = MkUnit ()@ together with @instance From Unit ()@, but that goes through 'Data.Coerce.Coercible' and requires the types to be representationally equal.
-- This approach (with 'Generics.Generically') only requires the types to be /structurally/ equal.
-- In this case, @Unit@ is structurally equal to @()@ since they both have a single constructor with no arguments.
--
-- This also works with arbitrary product types, like a custom pair type:
--
-- > data Pair a b = MkPair a b deriving Generic
-- > deriving via Generically (Pair c d)
-- >   instance (From a c, From b d) => From (a, b) (Pair c d)
--
-- Note that this can also convert the type variables as long as they have 'From.From' instances as well.
-- This allows converting from @(Int, Int)@ to @Pair Integer Integer@ in one step, for example.
--
-- And this works with arbitrary sum types as well:
--
-- > data Result a b = Failure a | Success b deriving Generic
-- > deriving via Generically (Result c d)
-- >   instance (From a c, From b d) => From (Either a b) (Result c d)
--
-- Note that these conversions are all /structural/ not semantic.
-- That means if you had defined @Result@ as @Success b | Failure a@, then converting from 'Either' would be "wrong".
-- 'Left' would convert into @Success@ and 'Right' would convert into @Failure@.
class GFrom s t where
  gFrom :: s x -> t x

instance GFrom Generics.V1 Generics.V1 where
  gFrom :: forall x. V1 x -> V1 x
gFrom = V1 x -> V1 x
forall a. a -> a
id

instance GFrom Generics.U1 Generics.U1 where
  gFrom :: forall x. U1 x -> U1 x
gFrom = U1 x -> U1 x
forall a. a -> a
id

instance (From.From s t) => GFrom (Generics.K1 a s) (Generics.K1 b t) where
  gFrom :: forall x. K1 a s x -> K1 b t x
gFrom = t -> K1 b t x
forall k i c (p :: k). c -> K1 i c p
Generics.K1 (t -> K1 b t x) -> (K1 a s x -> t) -> K1 a s x -> K1 b t x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> t
forall source target. From source target => source -> target
From.from (s -> t) -> (K1 a s x -> s) -> K1 a s x -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 a s x -> s
forall k i c (p :: k). K1 i c p -> c
Generics.unK1

instance (GFrom s t) => GFrom (Generics.M1 a b s) (Generics.M1 c d t) where
  gFrom :: forall x. M1 a b s x -> M1 c d t x
gFrom = t x -> M1 c d t x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
Generics.M1 (t x -> M1 c d t x)
-> (M1 a b s x -> t x) -> M1 a b s x -> M1 c d t x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s x -> t x
forall x. s x -> t x
forall (s :: * -> *) (t :: * -> *) x. GFrom s t => s x -> t x
gFrom (s x -> t x) -> (M1 a b s x -> s x) -> M1 a b s x -> t x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 a b s x -> s x
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
Generics.unM1

instance (GFrom s1 t1, GFrom s2 t2) => GFrom (s1 Generics.:+: s2) (t1 Generics.:+: t2) where
  gFrom :: forall x. (:+:) s1 s2 x -> (:+:) t1 t2 x
gFrom (:+:) s1 s2 x
x = case (:+:) s1 s2 x
x of
    Generics.L1 s1 x
l -> t1 x -> (:+:) t1 t2 x
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
Generics.L1 (t1 x -> (:+:) t1 t2 x) -> t1 x -> (:+:) t1 t2 x
forall a b. (a -> b) -> a -> b
$ s1 x -> t1 x
forall x. s1 x -> t1 x
forall (s :: * -> *) (t :: * -> *) x. GFrom s t => s x -> t x
gFrom s1 x
l
    Generics.R1 s2 x
r -> t2 x -> (:+:) t1 t2 x
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
Generics.R1 (t2 x -> (:+:) t1 t2 x) -> t2 x -> (:+:) t1 t2 x
forall a b. (a -> b) -> a -> b
$ s2 x -> t2 x
forall x. s2 x -> t2 x
forall (s :: * -> *) (t :: * -> *) x. GFrom s t => s x -> t x
gFrom s2 x
r

instance (GFrom s1 t1, GFrom s2 t2) => GFrom (s1 Generics.:*: s2) (t1 Generics.:*: t2) where
  gFrom :: forall x. (:*:) s1 s2 x -> (:*:) t1 t2 x
gFrom (s1 x
l Generics.:*: s2 x
r) = s1 x -> t1 x
forall x. s1 x -> t1 x
forall (s :: * -> *) (t :: * -> *) x. GFrom s t => s x -> t x
gFrom s1 x
l t1 x -> t2 x -> (:*:) t1 t2 x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
Generics.:*: s2 x -> t2 x
forall x. s2 x -> t2 x
forall (s :: * -> *) (t :: * -> *) x. GFrom s t => s x -> t x
gFrom s2 x
r

-- | See the 'GFrom' type class for an explanation of this instance.
instance
  ( Generics.Generic s,
    Generics.Generic t,
    GFrom (Generics.Rep s) (Generics.Rep t)
  ) =>
  From.From s (Generics.Generically t)
  where
  from :: s -> Generically t
from = t -> Generically t
forall a. a -> Generically a
Generics.Generically (t -> Generically t) -> (s -> t) -> s -> Generically t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep t Any -> t
forall a x. Generic a => Rep a x -> a
forall x. Rep t x -> t
Generics.to (Rep t Any -> t) -> (s -> Rep t Any) -> s -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep s Any -> Rep t Any
forall x. Rep s x -> Rep t x
forall (s :: * -> *) (t :: * -> *) x. GFrom s t => s x -> t x
gFrom (Rep s Any -> Rep t Any) -> (s -> Rep s Any) -> s -> Rep t Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Rep s Any
forall x. s -> Rep s x
forall a x. Generic a => a -> Rep a x
Generics.from