-- | This is the internal generic-override API and should be considered
-- unstable and subject to change. This module is exposed for library integrators
-- (e.g. generic-override-aeson). In general, unless you are integrating
-- some type class with generic-override, you should prefer to use the
-- public, stable API provided by 'Data.Override'.

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Override.Internal where

import GHC.Generics
import GHC.TypeLits (Symbol)

-- | The feature of this library. For use with DerivingVia.
-- Apply it to a type @a@ and supply a type-level list of instance
-- overrides @xs@.
newtype Override a (xs :: [*]) = Override a

-- | Unwrap an 'Override' value.
unOverride :: Override a xs -> a
unOverride :: forall a (xs :: [*]). Override a xs -> a
unOverride (Override a
a) = a
a

-- | Construct an 'Override' using a proxy of overrides.
override :: a -> proxy xs -> Override a xs
override :: forall a (proxy :: [*] -> *) (xs :: [*]).
a -> proxy xs -> Override a xs
override a
a proxy xs
_ = a -> Override a xs
forall a (xs :: [*]). a -> Override a xs
Override a
a

-- | Used to construct a type-level override. Usually used infix.
-- The @o@ should be either a type (kind '*') or a type-level string
-- (kind 'Symbol').
data As (o :: k) n

-- | Used to wrap a field into a something of kind @* -> *@, for example another newtype.
data With (o :: k) (w :: * -> *)

-- | Used at the leaf nodes of a generic 'Rep'
newtype Overridden (ms :: Maybe Symbol) a (xs :: [*]) = Overridden a

-- | Unwrap an 'Overridden' value.
unOverridden :: Overridden ms a xs -> a
unOverridden :: forall (ms :: Maybe Symbol) a (xs :: [*]). Overridden ms a xs -> a
unOverridden (Overridden a
a) = a
a

-- | Same as 'override' but for 'Overridden' types.
overridden
  :: forall a (ms :: Maybe Symbol) (xs :: [*]) proxy0 proxy1.
     a -> proxy0 ms -> proxy1 xs -> Overridden ms a xs
overridden :: forall a (ms :: Maybe Symbol) (xs :: [*])
       (proxy0 :: Maybe Symbol -> *) (proxy1 :: [*] -> *).
a -> proxy0 ms -> proxy1 xs -> Overridden ms a xs
overridden a
a proxy0 ms
_ proxy1 xs
_ = a -> Overridden ms a xs
forall (ms :: Maybe Symbol) a (xs :: [*]). a -> Overridden ms a xs
Overridden a
a

instance (Generic a, GOverride xs (Rep a)) => Generic (Override a xs) where
  type Rep (Override a xs) = OverrideRep xs (Rep a)
  from :: forall x. Override a xs -> Rep (Override a xs) x
from = forall (xs :: [*]) (f :: * -> *) x.
GOverride xs f =>
f x -> OverrideRep xs f x
overrideFrom @xs (Rep a x -> OverrideRep xs (Rep a) x)
-> (Override a xs -> Rep a x)
-> Override a xs
-> OverrideRep xs (Rep a) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from (a -> Rep a x) -> (Override a xs -> a) -> Override a xs -> Rep a x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Override a xs -> a
forall a (xs :: [*]). Override a xs -> a
unOverride
  to :: forall x. Rep (Override a xs) x -> Override a xs
to = a -> Override a xs
forall a (xs :: [*]). a -> Override a xs
Override (a -> Override a xs)
-> (OverrideRep xs (Rep a) x -> a)
-> OverrideRep xs (Rep a) x
-> Override a xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a x -> a
forall a x. Generic a => Rep a x -> a
to (Rep a x -> a)
-> (OverrideRep xs (Rep a) x -> Rep a x)
-> OverrideRep xs (Rep a) x
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (xs :: [*]) (f :: * -> *) x.
GOverride xs f =>
OverrideRep xs f x -> f x
overrideTo @xs

-- | Type class used to build the 'Generic' instance for 'Override'.
class GOverride (xs :: [*]) (f :: * -> *) where
  -- | Analogous to 'Rep'; rewrites the type for a given 'Rep' and injects
  -- 'Overridden' at the leaves.
  type OverrideRep xs f :: * -> *
  overrideFrom :: f x -> OverrideRep xs f x
  overrideTo :: OverrideRep xs f x -> f x

instance (GOverride xs f) => GOverride xs (M1 D c f) where
  type OverrideRep xs (M1 D c f) = M1 D c (OverrideRep xs f)
  overrideFrom :: forall x. M1 D c f x -> OverrideRep xs (M1 D c f) x
overrideFrom (M1 f x
x) = OverrideRep xs f x -> M1 D c (OverrideRep xs f) x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall (xs :: [*]) (f :: * -> *) x.
GOverride xs f =>
f x -> OverrideRep xs f x
overrideFrom @xs f x
x)
  overrideTo :: forall x. OverrideRep xs (M1 D c f) x -> M1 D c f x
overrideTo (M1 OverrideRep xs f x
x) = f x -> M1 D c f x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall (xs :: [*]) (f :: * -> *) x.
GOverride xs f =>
OverrideRep xs f x -> f x
overrideTo @xs OverrideRep xs f x
x)

instance (GOverride xs f) => GOverride xs (M1 C c f) where
  type OverrideRep xs (M1 C c f) = M1 C c (OverrideRep xs f)
  overrideFrom :: forall x. M1 C c f x -> OverrideRep xs (M1 C c f) x
overrideFrom (M1 f x
x) = OverrideRep xs f x -> M1 C c (OverrideRep xs f) x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall (xs :: [*]) (f :: * -> *) x.
GOverride xs f =>
f x -> OverrideRep xs f x
overrideFrom @xs f x
x)
  overrideTo :: forall x. OverrideRep xs (M1 C c f) x -> M1 C c f x
overrideTo (M1 OverrideRep xs f x
x) = f x -> M1 C c f x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall (xs :: [*]) (f :: * -> *) x.
GOverride xs f =>
OverrideRep xs f x -> f x
overrideTo @xs OverrideRep xs f x
x)

instance (GOverride xs f, GOverride xs g) => GOverride xs (f :*: g) where
  type OverrideRep xs (f :*: g) = OverrideRep xs f :*: OverrideRep xs g
  overrideFrom :: forall x. (:*:) f g x -> OverrideRep xs (f :*: g) x
overrideFrom (f x
f :*: g x
g) = forall (xs :: [*]) (f :: * -> *) x.
GOverride xs f =>
f x -> OverrideRep xs f x
overrideFrom @xs f x
f OverrideRep xs f x
-> OverrideRep xs g x
-> (:*:) (OverrideRep xs f) (OverrideRep xs g) x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall (xs :: [*]) (f :: * -> *) x.
GOverride xs f =>
f x -> OverrideRep xs f x
overrideFrom @xs g x
g
  overrideTo :: forall x. OverrideRep xs (f :*: g) x -> (:*:) f g x
overrideTo (OverrideRep xs f x
f :*: OverrideRep xs g x
g) = forall (xs :: [*]) (f :: * -> *) x.
GOverride xs f =>
OverrideRep xs f x -> f x
overrideTo @xs OverrideRep xs f x
f f x -> g x -> (:*:) f g x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall (xs :: [*]) (f :: * -> *) x.
GOverride xs f =>
OverrideRep xs f x -> f x
overrideTo @xs OverrideRep xs g x
g

instance (GOverride xs f, GOverride xs g) => GOverride xs (f :+: g) where
  type OverrideRep xs (f :+: g) = OverrideRep xs f :+: OverrideRep xs g

  overrideFrom :: forall x. (:+:) f g x -> OverrideRep xs (f :+: g) x
overrideFrom = \case
    L1 f x
f -> OverrideRep xs f x -> (:+:) (OverrideRep xs f) (OverrideRep xs g) x
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (OverrideRep xs f x
 -> (:+:) (OverrideRep xs f) (OverrideRep xs g) x)
-> OverrideRep xs f x
-> (:+:) (OverrideRep xs f) (OverrideRep xs g) x
forall a b. (a -> b) -> a -> b
$ forall (xs :: [*]) (f :: * -> *) x.
GOverride xs f =>
f x -> OverrideRep xs f x
overrideFrom @xs f x
f
    R1 g x
g -> OverrideRep xs g x -> (:+:) (OverrideRep xs f) (OverrideRep xs g) x
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (OverrideRep xs g x
 -> (:+:) (OverrideRep xs f) (OverrideRep xs g) x)
-> OverrideRep xs g x
-> (:+:) (OverrideRep xs f) (OverrideRep xs g) x
forall a b. (a -> b) -> a -> b
$ forall (xs :: [*]) (f :: * -> *) x.
GOverride xs f =>
f x -> OverrideRep xs f x
overrideFrom @xs g x
g

  overrideTo :: forall x. OverrideRep xs (f :+: g) x -> (:+:) f g x
overrideTo = \case
    L1 OverrideRep xs f x
f -> f x -> (:+:) f g x
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f x -> (:+:) f g x) -> f x -> (:+:) f g x
forall a b. (a -> b) -> a -> b
$ forall (xs :: [*]) (f :: * -> *) x.
GOverride xs f =>
OverrideRep xs f x -> f x
overrideTo @xs OverrideRep xs f x
f
    R1 OverrideRep xs g x
g -> g x -> (:+:) f g x
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g x -> (:+:) f g x) -> g x -> (:+:) f g x
forall a b. (a -> b) -> a -> b
$ forall (xs :: [*]) (f :: * -> *) x.
GOverride xs f =>
OverrideRep xs f x -> f x
overrideTo @xs OverrideRep xs g x
g

instance GOverride xs (M1 S ('MetaSel ms su ss ds) (K1 R c)) where
  type OverrideRep xs (M1 S ('MetaSel ms su ss ds) (K1 R c)) =
    M1 S ('MetaSel ms su ss ds) (K1 R (Overridden ms c xs))
  overrideFrom :: forall x.
M1 S ('MetaSel ms su ss ds) (K1 R c) x
-> OverrideRep xs (M1 S ('MetaSel ms su ss ds) (K1 R c)) x
overrideFrom (M1 (K1 c
x)) = K1 R (Overridden ms c xs) x
-> M1 S ('MetaSel ms su ss ds) (K1 R (Overridden ms c xs)) x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Overridden ms c xs -> K1 R (Overridden ms c xs) x
forall k i c (p :: k). c -> K1 i c p
K1 (forall (ms :: Maybe Symbol) a (xs :: [*]). a -> Overridden ms a xs
Overridden @ms c
x))
  overrideTo :: forall x.
OverrideRep xs (M1 S ('MetaSel ms su ss ds) (K1 R c)) x
-> M1 S ('MetaSel ms su ss ds) (K1 R c) x
overrideTo (M1 (K1 (Overridden c
x))) = K1 R c x -> M1 S ('MetaSel ms su ss ds) (K1 R c) x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (c -> K1 R c x
forall k i c (p :: k). c -> K1 i c p
K1 c
x)

instance GOverride xs U1 where
  type OverrideRep xs U1 = U1
  overrideFrom :: forall x. U1 x -> OverrideRep xs U1 x
overrideFrom U1 x
U1 = OverrideRep xs U1 x
forall k (p :: k). U1 p
U1
  overrideTo :: forall x. OverrideRep xs U1 x -> U1 x
overrideTo U1 x
OverrideRep xs U1 x
U1 = U1 x
forall k (p :: k). U1 p
U1

-- | Type family used to determine which override from @xs@
-- to replace @a@ with, if any. The @ms@ holds the field name
-- for @a@, if applicable.
type family Using (ms :: Maybe Symbol) (a :: *) (xs :: [*]) where
  -- No matching override found.
  Using ms a '[] = a

  -- Override the matching field.
  Using ('Just o) a (As o n ': xs) = n
  Using ('Just o) a (With o w ': xs) = w a

  -- Override the matching type.
  Using ms a (As a n ': xs) = n
  Using ms a (With a w ': xs) = w a

  -- Override the matching kind (up to 10).
  Using ms (f a0) (As f g ': xs) = g a0
  Using ms (f a0 a1) (As f g ': xs) = g a0 a1
  Using ms (f a0 a1 a2) (As f g ': xs) = g a0 a1 a2
  Using ms (f a0 a1 a2 a3) (As f g ': xs) = g a0 a1 a2 a3
  Using ms (f a0 a1 a2 a3 a4) (As f g ': xs) = g a0 a1 a2 a3 a4
  Using ms (f a0 a1 a2 a3 a4 a5) (As f g ': xs) = g a0 a1 a2 a3 a4 a5
  Using ms (f a0 a1 a2 a3 a4 a5 a6) (As f g ': xs) = g a0 a1 a2 a3 a4 a5 a6
  Using ms (f a0 a1 a2 a3 a4 a5 a6 a7) (As f g ': xs) = g a0 a1 a2 a3 a4 a5 a6 a7
  Using ms (f a0 a1 a2 a3 a4 a5 a6 a7 a8) (As f g ': xs) = g a0 a1 a2 a3 a4 a5 a6 a7 a8
  Using ms (f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9) (As f g ': xs) = g a0 a1 a2 a3 a4 a5 a6 a7 a8 a9

  -- No match on this override, recurse.
  Using ms a (x ': xs) = Using ms a xs