-- | 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 MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Override.Internal where

import Data.Type.Bool (If)
import Data.Type.Equality (type (==))
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 :: 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 :: 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 :: 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 :: 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 :: Override a xs -> Rep (Override a xs) x
from = forall (xs :: [*]) (f :: * -> *) x.
GOverride xs f =>
f x -> OverrideRep xs f x
forall (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 :: 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
forall (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 :: 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 (f x -> OverrideRep xs f x
forall (xs :: [*]) (f :: * -> *) x.
GOverride xs f =>
f x -> OverrideRep xs f x
overrideFrom @xs f x
x)
  overrideTo :: OverrideRep xs (M1 D c f) x -> M1 D c f x
overrideTo (M1 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 (OverrideRep xs f x -> f x
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 :: 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 (f x -> OverrideRep xs f x
forall (xs :: [*]) (f :: * -> *) x.
GOverride xs f =>
f x -> OverrideRep xs f x
overrideFrom @xs f x
x)
  overrideTo :: OverrideRep xs (M1 C c f) x -> M1 C c f x
overrideTo (M1 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 (OverrideRep xs f x -> f x
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 :: (:*:) f g x -> OverrideRep xs (f :*: g) x
overrideFrom (f x
f :*: g x
g) = f x -> OverrideRep xs f x
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
:*: g x -> OverrideRep xs g x
forall (xs :: [*]) (f :: * -> *) x.
GOverride xs f =>
f x -> OverrideRep xs f x
overrideFrom @xs g x
g
  overrideTo :: OverrideRep xs (f :*: g) x -> (:*:) f g x
overrideTo (f :*: g) = OverrideRep xs f x -> f x
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
:*: OverrideRep xs g x -> g x
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 :: 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 (c -> Overridden ms c xs
forall (ms :: Maybe Symbol) a (xs :: [*]). a -> Overridden ms a xs
Overridden @ms c
x))
  overrideTo :: 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 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)

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

  -- Override the matching field.
  Using ms x (As (o :: Symbol) n ': xs) =
    If (ms == 'Just o) n (Using ms x xs)

  Using ms x (With (o :: Symbol) w ': xs) =
    If (ms == 'Just o) (w x) (Using ms x xs)

  -- Override the matching type.
  Using ms x (As (o :: *) n ': xs) =
    If (x == o) n (Using ms x xs)

  Using ms x (With (o :: *) w ': xs) =
    If (x == o) (w x) (Using ms x xs)