{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Override.Internal where
import Data.Coerce (Coercible, coerce)
import GHC.Generics
import GHC.TypeLits (type (+), Nat, Symbol)
newtype Override a (xs :: [*]) = Override a
unOverride :: Override a xs -> a
unOverride :: Override a xs -> a
unOverride (Override a
a) = a
a
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
data As (o :: k) n
data With (o :: k) (w :: * -> *)
data At (c :: Symbol) (p :: Nat) (n :: *)
instance
( Generic a
, GOverride xs (Rep a)
) => Generic (Override a xs)
where
type Rep (Override a xs) = OverrideRep EmptyInspect xs (Rep a)
from :: Override a xs -> Rep (Override a xs) x
from = forall (i :: Inspect) (xs :: [*]) (f :: * -> *) x.
GOverride' i xs f =>
f x -> OverrideRep i xs f x
forall (f :: * -> *) x.
GOverride' EmptyInspect xs f =>
f x -> OverrideRep EmptyInspect xs f x
overrideFrom @EmptyInspect @xs (Rep a x -> OverrideRep EmptyInspect xs (Rep a) x)
-> (Override a xs -> Rep a x)
-> Override a xs
-> OverrideRep EmptyInspect 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 EmptyInspect xs (Rep a) x -> a)
-> OverrideRep EmptyInspect 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 EmptyInspect xs (Rep a) x -> Rep a x)
-> OverrideRep EmptyInspect xs (Rep a) x
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (i :: Inspect) (xs :: [*]) (f :: * -> *) x.
GOverride' i xs f =>
OverrideRep i xs f x -> f x
forall (f :: * -> *) x.
GOverride' EmptyInspect xs f =>
OverrideRep EmptyInspect xs f x -> f x
overrideTo @EmptyInspect @xs
type GOverride = GOverride' EmptyInspect
class GOverride' (i :: Inspect) (xs :: [*]) (f :: * -> *) where
type OverrideRep i xs f :: * -> *
overrideFrom :: f x -> OverrideRep i xs f x
overrideTo :: OverrideRep i xs f x -> f x
instance (GOverride' i xs f) => GOverride' i xs (M1 D c f) where
type OverrideRep i xs (M1 D c f) = M1 D c (OverrideRep i xs f)
overrideFrom :: M1 D c f x -> OverrideRep i xs (M1 D c f) x
overrideFrom (M1 f x
x) = OverrideRep i xs f x -> M1 D c (OverrideRep i xs f) x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f x -> OverrideRep i xs f x
forall (i :: Inspect) (xs :: [*]) (f :: * -> *) x.
GOverride' i xs f =>
f x -> OverrideRep i xs f x
overrideFrom @i @xs f x
x)
{-# INLINE overrideFrom #-}
overrideTo :: OverrideRep i 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 i xs f x -> f x
forall (i :: Inspect) (xs :: [*]) (f :: * -> *) x.
GOverride' i xs f =>
OverrideRep i xs f x -> f x
overrideTo @i @xs OverrideRep i xs f x
x)
{-# INLINE overrideTo #-}
instance
( GOverride' ('Inspect ('Just conName) ms mp) xs f
) => GOverride' ('Inspect ignore ms mp) xs
(M1 C ('MetaCons conName conFixity conIsRecord) f)
where
type OverrideRep ('Inspect ignore ms mp) xs
(M1 C ('MetaCons conName conFixity conIsRecord) f) =
M1 C
('MetaCons conName conFixity conIsRecord)
(OverrideRep ('Inspect ('Just conName) ms mp) xs f)
overrideFrom :: M1 C ('MetaCons conName conFixity conIsRecord) f x
-> OverrideRep
('Inspect ignore ms mp)
xs
(M1 C ('MetaCons conName conFixity conIsRecord) f)
x
overrideFrom (M1 f x
x) = OverrideRep ('Inspect ('Just conName) ms mp) xs f x
-> M1
C
('MetaCons conName conFixity conIsRecord)
(OverrideRep ('Inspect ('Just conName) ms mp) xs f)
x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f x -> OverrideRep ('Inspect ('Just conName) ms mp) xs f x
forall (i :: Inspect) (xs :: [*]) (f :: * -> *) x.
GOverride' i xs f =>
f x -> OverrideRep i xs f x
overrideFrom @('Inspect ('Just conName) ms mp) @xs f x
x)
{-# INLINE overrideFrom #-}
overrideTo :: OverrideRep
('Inspect ignore ms mp)
xs
(M1 C ('MetaCons conName conFixity conIsRecord) f)
x
-> M1 C ('MetaCons conName conFixity conIsRecord) f x
overrideTo (M1 x) = f x -> M1 C ('MetaCons conName conFixity conIsRecord) f x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (OverrideRep ('Inspect ('Just conName) ms mp) xs f x -> f x
forall (i :: Inspect) (xs :: [*]) (f :: * -> *) x.
GOverride' i xs f =>
OverrideRep i xs f x -> f x
overrideTo @('Inspect ('Just conName) ms mp) @xs OverrideRep ('Inspect ('Just conName) ms mp) xs f x
x)
{-# INLINE overrideTo #-}
instance
( GOverride' ('Inspect mc ms ('Just 0)) xs f
, GOverride' ('Inspect mc ms ('Just 1)) xs g
) => GOverride' ('Inspect mc ms 'Nothing) xs (f :*: g)
where
type OverrideRep ('Inspect mc ms 'Nothing) xs (f :*: g) =
OverrideRep ('Inspect mc ms ('Just 0)) xs f
:*: OverrideRep ('Inspect mc ms ('Just 1)) xs g
overrideFrom :: (:*:) f g x -> OverrideRep ('Inspect mc ms 'Nothing) xs (f :*: g) x
overrideFrom (f x
f :*: g x
g) =
f x -> OverrideRep ('Inspect mc ms ('Just 0)) xs f x
forall (i :: Inspect) (xs :: [*]) (f :: * -> *) x.
GOverride' i xs f =>
f x -> OverrideRep i xs f x
overrideFrom @('Inspect mc ms ('Just 0)) @xs f x
f
OverrideRep ('Inspect mc ms ('Just 0)) xs f x
-> OverrideRep ('Inspect mc ms ('Just 1)) xs g x
-> (:*:)
(OverrideRep ('Inspect mc ms ('Just 0)) xs f)
(OverrideRep ('Inspect mc ms ('Just 1)) xs g)
x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g x -> OverrideRep ('Inspect mc ms ('Just 1)) xs g x
forall (i :: Inspect) (xs :: [*]) (f :: * -> *) x.
GOverride' i xs f =>
f x -> OverrideRep i xs f x
overrideFrom @('Inspect mc ms ('Just 1)) @xs g x
g
{-# INLINE overrideFrom #-}
overrideTo :: OverrideRep ('Inspect mc ms 'Nothing) xs (f :*: g) x -> (:*:) f g x
overrideTo (f :*: g) =
OverrideRep ('Inspect mc ms ('Just 0)) xs f x -> f x
forall (i :: Inspect) (xs :: [*]) (f :: * -> *) x.
GOverride' i xs f =>
OverrideRep i xs f x -> f x
overrideTo @('Inspect mc ms ('Just 0)) @xs OverrideRep ('Inspect mc ms ('Just 0)) 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 ('Inspect mc ms ('Just 1)) xs g x -> g x
forall (i :: Inspect) (xs :: [*]) (f :: * -> *) x.
GOverride' i xs f =>
OverrideRep i xs f x -> f x
overrideTo @('Inspect mc ms ('Just 1)) @xs OverrideRep ('Inspect mc ms ('Just 1)) xs g x
g
{-# INLINE overrideTo #-}
instance
( GOverride' ('Inspect mc ms ('Just p)) xs f
, GOverride' ('Inspect mc ms ('Just (p + 1))) xs g
) => GOverride' ('Inspect mc ms ('Just p)) xs (f :*: g)
where
type OverrideRep ('Inspect mc ms ('Just p)) xs (f :*: g) =
OverrideRep ('Inspect mc ms ('Just p)) xs f
:*: OverrideRep ('Inspect mc ms ('Just (p + 1))) xs g
overrideFrom :: (:*:) f g x
-> OverrideRep ('Inspect mc ms ('Just p)) xs (f :*: g) x
overrideFrom (f x
f :*: g x
g) =
f x -> OverrideRep ('Inspect mc ms ('Just p)) xs f x
forall (i :: Inspect) (xs :: [*]) (f :: * -> *) x.
GOverride' i xs f =>
f x -> OverrideRep i xs f x
overrideFrom @('Inspect mc ms ('Just p)) @xs f x
f
OverrideRep ('Inspect mc ms ('Just p)) xs f x
-> OverrideRep ('Inspect mc ms ('Just (p + 1))) xs g x
-> (:*:)
(OverrideRep ('Inspect mc ms ('Just p)) xs f)
(OverrideRep ('Inspect mc ms ('Just (p + 1))) xs g)
x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g x -> OverrideRep ('Inspect mc ms ('Just (p + 1))) xs g x
forall (i :: Inspect) (xs :: [*]) (f :: * -> *) x.
GOverride' i xs f =>
f x -> OverrideRep i xs f x
overrideFrom @('Inspect mc ms ('Just (p + 1))) @xs g x
g
{-# INLINE overrideFrom #-}
overrideTo :: OverrideRep ('Inspect mc ms ('Just p)) xs (f :*: g) x
-> (:*:) f g x
overrideTo (f :*: g) =
OverrideRep ('Inspect mc ms ('Just p)) xs f x -> f x
forall (i :: Inspect) (xs :: [*]) (f :: * -> *) x.
GOverride' i xs f =>
OverrideRep i xs f x -> f x
overrideTo @('Inspect mc ms ('Just p)) @xs OverrideRep ('Inspect mc ms ('Just p)) 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 ('Inspect mc ms ('Just (p + 1))) xs g x -> g x
forall (i :: Inspect) (xs :: [*]) (f :: * -> *) x.
GOverride' i xs f =>
OverrideRep i xs f x -> f x
overrideTo @('Inspect mc ms ('Just (p + 1))) @xs OverrideRep ('Inspect mc ms ('Just (p + 1))) xs g x
g
{-# INLINE overrideTo #-}
instance
( GOverride' i xs f
, GOverride' i xs g
) => GOverride' i xs (f :+: g)
where
type OverrideRep i xs (f :+: g) = OverrideRep i xs f :+: OverrideRep i xs g
overrideFrom :: (:+:) f g x -> OverrideRep i xs (f :+: g) x
overrideFrom = \case
L1 f x
f -> OverrideRep i xs f x
-> (:+:) (OverrideRep i xs f) (OverrideRep i xs g) x
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (OverrideRep i xs f x
-> (:+:) (OverrideRep i xs f) (OverrideRep i xs g) x)
-> OverrideRep i xs f x
-> (:+:) (OverrideRep i xs f) (OverrideRep i xs g) x
forall a b. (a -> b) -> a -> b
$ f x -> OverrideRep i xs f x
forall (i :: Inspect) (xs :: [*]) (f :: * -> *) x.
GOverride' i xs f =>
f x -> OverrideRep i xs f x
overrideFrom @i @xs f x
f
R1 g x
g -> OverrideRep i xs g x
-> (:+:) (OverrideRep i xs f) (OverrideRep i xs g) x
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (OverrideRep i xs g x
-> (:+:) (OverrideRep i xs f) (OverrideRep i xs g) x)
-> OverrideRep i xs g x
-> (:+:) (OverrideRep i xs f) (OverrideRep i xs g) x
forall a b. (a -> b) -> a -> b
$ g x -> OverrideRep i xs g x
forall (i :: Inspect) (xs :: [*]) (f :: * -> *) x.
GOverride' i xs f =>
f x -> OverrideRep i xs f x
overrideFrom @i @xs g x
g
{-# INLINE overrideFrom #-}
overrideTo :: OverrideRep i xs (f :+: g) x -> (:+:) f g x
overrideTo = \case
L1 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
$ OverrideRep i xs f x -> f x
forall (i :: Inspect) (xs :: [*]) (f :: * -> *) x.
GOverride' i xs f =>
OverrideRep i xs f x -> f x
overrideTo @i @xs OverrideRep i xs f x
f
R1 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
$ OverrideRep i xs g x -> g x
forall (i :: Inspect) (xs :: [*]) (f :: * -> *) x.
GOverride' i xs f =>
OverrideRep i xs f x -> f x
overrideTo @i @xs OverrideRep i xs g x
g
{-# INLINE overrideTo #-}
instance
( GOverride' ('Inspect mc selName mp) xs f
) => GOverride' ('Inspect mc ignore mp) xs (M1 S ('MetaSel selName selSU selSS selDS) f)
where
type OverrideRep ('Inspect mc ignore mp) xs (M1 S ('MetaSel selName selSU selSS selDS) f) =
M1 S ('MetaSel selName selSU selSS selDS) (OverrideRep ('Inspect mc selName mp) xs f)
overrideFrom :: M1 S ('MetaSel selName selSU selSS selDS) f x
-> OverrideRep
('Inspect mc ignore mp)
xs
(M1 S ('MetaSel selName selSU selSS selDS) f)
x
overrideFrom (M1 f x
x) = OverrideRep ('Inspect mc selName mp) xs f x
-> M1
S
('MetaSel selName selSU selSS selDS)
(OverrideRep ('Inspect mc selName mp) xs f)
x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f x -> OverrideRep ('Inspect mc selName mp) xs f x
forall (i :: Inspect) (xs :: [*]) (f :: * -> *) x.
GOverride' i xs f =>
f x -> OverrideRep i xs f x
overrideFrom @('Inspect mc selName mp) @xs f x
x)
{-# INLINE overrideFrom #-}
overrideTo :: OverrideRep
('Inspect mc ignore mp)
xs
(M1 S ('MetaSel selName selSU selSS selDS) f)
x
-> M1 S ('MetaSel selName selSU selSS selDS) f x
overrideTo (M1 x) = f x -> M1 S ('MetaSel selName selSU selSS selDS) f x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (OverrideRep ('Inspect mc selName mp) xs f x -> f x
forall (i :: Inspect) (xs :: [*]) (f :: * -> *) x.
GOverride' i xs f =>
OverrideRep i xs f x -> f x
overrideTo @('Inspect mc selName mp) @xs OverrideRep ('Inspect mc selName mp) xs f x
x)
{-# INLINE overrideTo #-}
instance
( Coercible a (Using ('Inspect mc ms ('Just 0)) a xs)
) => GOverride' ('Inspect mc ms 'Nothing) xs (K1 R a)
where
type OverrideRep ('Inspect mc ms 'Nothing) xs (K1 R a) =
K1 R (Using ('Inspect mc ms ('Just 0)) a xs)
overrideFrom :: K1 R a x -> OverrideRep ('Inspect mc ms 'Nothing) xs (K1 R a) x
overrideFrom (K1 a
a) = Using ('Inspect mc ms ('Just 0)) a xs
-> K1 R (Using ('Inspect mc ms ('Just 0)) a xs) x
forall k i c (p :: k). c -> K1 i c p
K1 (a -> Using ('Inspect mc ms ('Just 0)) a xs
coerce a
a :: Using ('Inspect mc ms ('Just 0)) a xs)
{-# INLINE overrideFrom #-}
overrideTo :: OverrideRep ('Inspect mc ms 'Nothing) xs (K1 R a) x -> K1 R a x
overrideTo (K1 u) = a -> K1 R a x
forall k i c (p :: k). c -> K1 i c p
K1 (Using ('Inspect mc ms ('Just 0)) a xs -> a
coerce Using ('Inspect mc ms ('Just 0)) a xs
u :: a)
{-# INLINE overrideTo #-}
instance
( Coercible a (Using ('Inspect mc ms ('Just p)) a xs)
) => GOverride' ('Inspect mc ms ('Just p)) xs (K1 R a)
where
type OverrideRep ('Inspect mc ms ('Just p)) xs (K1 R a) =
K1 R (Using ('Inspect mc ms ('Just p)) a xs)
overrideFrom :: K1 R a x -> OverrideRep ('Inspect mc ms ('Just p)) xs (K1 R a) x
overrideFrom (K1 a
a) = Using ('Inspect mc ms ('Just p)) a xs
-> K1 R (Using ('Inspect mc ms ('Just p)) a xs) x
forall k i c (p :: k). c -> K1 i c p
K1 (a -> Using ('Inspect mc ms ('Just p)) a xs
coerce a
a :: Using ('Inspect mc ms ('Just p)) a xs)
{-# INLINE overrideFrom #-}
overrideTo :: OverrideRep ('Inspect mc ms ('Just p)) xs (K1 R a) x -> K1 R a x
overrideTo (K1 u) = a -> K1 R a x
forall k i c (p :: k). c -> K1 i c p
K1 (Using ('Inspect mc ms ('Just p)) a xs -> a
coerce Using ('Inspect mc ms ('Just p)) a xs
u :: a)
{-# INLINE overrideTo #-}
instance GOverride' i xs U1 where
type OverrideRep i xs U1 = U1
overrideFrom :: U1 x -> OverrideRep i xs U1 x
overrideFrom U1 x
U1 = OverrideRep i xs U1 x
forall k (p :: k). U1 p
U1
{-# INLINE overrideFrom #-}
overrideTo :: OverrideRep i xs U1 x -> U1 x
overrideTo OverrideRep i xs U1 x
U1 = U1 x
forall k (p :: k). U1 p
U1
{-# INLINE overrideTo #-}
data Inspect =
Inspect
(Maybe Symbol)
(Maybe Symbol)
(Maybe Nat)
type EmptyInspect = 'Inspect 'Nothing 'Nothing 'Nothing
type family Using (i :: Inspect) (a :: *) (xs :: [*]) where
Using i a '[] = a
Using ('Inspect mc ('Just o) mp) a (As o n ': xs) = n
Using ('Inspect mc ('Just o) mp) a (With o w ': xs) = w a
Using i a (With a w ': xs) = w a
Using i a (As a n ': xs) = n
Using i (f a0) (As f g ': xs) = g a0
Using i (f a0 a1) (As f g ': xs) = g a0 a1
Using i (f a0 a1 a2) (As f g ': xs) = g a0 a1 a2
Using i (f a0 a1 a2 a3) (As f g ': xs) = g a0 a1 a2 a3
Using i (f a0 a1 a2 a3 a4) (As f g ': xs) = g a0 a1 a2 a3 a4
Using i (f a0 a1 a2 a3 a4 a5) (As f g ': xs) = g a0 a1 a2 a3 a4 a5
Using i (f a0 a1 a2 a3 a4 a5 a6) (As f g ': xs) = g a0 a1 a2 a3 a4 a5 a6
Using i (f a0 a1 a2 a3 a4 a5 a6 a7) (As f g ': xs) = g a0 a1 a2 a3 a4 a5 a6 a7
Using i (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 i (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
Using ('Inspect ('Just c) ms ('Just p)) a (At c p n ': xs) = n
Using i a (x ': xs) = Using i a xs