{-# LANGUAGE AllowAmbiguousTypes    #-}
{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE EmptyCase              #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE UndecidableInstances   #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
-- | Derive record field lenses generically.
module Data.Generics.Lens.Lite (
    field,
    HasField,
    ) where

import Data.Functor.Confusing (LensLike, Yoneda, fusing)
import Data.Kind              (Constraint, Type)
import Data.Proxy             (Proxy (..))
import GHC.TypeLits           (ErrorMessage (..), Symbol, TypeError)

import GHC.Generics

-------------------------------------------------------------------------------
-- Public API
-------------------------------------------------------------------------------

-- | Type-class restricting 'field' usage.
class HasField (name :: Symbol) r a | name r -> a where
    field__ :: Proxy name -> LensLikeYoneda' f r a

class HasFieldInternal (name :: Symbol) r a | name r -> a where
    field_ :: Proxy name -> LensLikeYoneda' f r a

-- | A lens that focuses on a field with a given name.
-- Compatible with the lens package's 'Control.Lens.Lens' type.
--
-- __Note:__ the lens is /simple/, i.e. doesn't allow type-changing updates.
-- This keeps the implementation small and quick.
--
-- You also may want to specify
-- @
-- {-\# OPTIONS_GHC -funfolding-keeness-factor=100 #-} (or some other arbitrarily large number)
-- @
-- for GHC to inline more aggressively.
--
field
    :: forall (name :: Symbol) (r :: Type) (a :: Type) (f :: Type -> Type). (HasField name r a, Functor f)
    => (a -> f a) -> r -> f r
field :: forall (name :: Symbol) r a (f :: * -> *).
(HasField name r a, Functor f) =>
(a -> f a) -> r -> f r
field = LensLike (Yoneda f) r r a a -> LensLike f r r a a
forall (f :: * -> *) s t a b.
Functor f =>
LensLike (Yoneda f) s t a b -> LensLike f s t a b
fusing (Proxy name -> LensLike (Yoneda f) r r a a
forall (name :: Symbol) r a (f :: * -> *).
HasField name r a =>
Proxy name -> LensLikeYoneda' f r a
forall (f :: * -> *). Proxy name -> LensLikeYoneda' f r a
field__ (Proxy name
forall {k} (t :: k). Proxy t
Proxy :: Proxy name))

instance HasFieldInternal name r a => HasField name r a where
    field__ :: forall (f :: * -> *). Proxy name -> LensLikeYoneda' f r a
field__ = Proxy name -> LensLikeYoneda' f r a
forall (name :: Symbol) r a (f :: * -> *).
HasFieldInternal name r a =>
Proxy name -> LensLikeYoneda' f r a
forall (f :: * -> *). Proxy name -> LensLikeYoneda' f r a
field_
    {-# INLINE field__ #-}

instance
    ( Generic r
    , ErrorCheck name r a (HasFieldPred name (Rep r))
    , HasFieldPred name (Rep r) ~ 'Just a
    , GField name (Rep r) a
    ) => HasFieldInternal name r a
  where
    field_ :: forall (f :: * -> *). Proxy name -> LensLikeYoneda' f r a
field_ Proxy name
pname a -> Yoneda f a
f r
s = (Rep r () -> r) -> Yoneda f (Rep r ()) -> Yoneda f r
forall a b. (a -> b) -> Yoneda f a -> Yoneda f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep r () -> r
forall a x. Generic a => Rep a x -> a
forall x. Rep r x -> r
to (Proxy name -> LensLikeYoneda' f (Rep r ()) a
forall (name :: Symbol) (f :: * -> *) a (h :: * -> *).
GField name f a =>
Proxy name -> LensLikeYoneda' h (f ()) a
forall (h :: * -> *). Proxy name -> LensLikeYoneda' h (Rep r ()) a
gfield Proxy name
pname a -> Yoneda f a
f (r -> Rep r ()
forall x. r -> Rep r x
forall a x. Generic a => a -> Rep a x
from r
s))
    {-# INLINE field_ #-}

-------------------------------------------------------------------------------
-- Errors
-------------------------------------------------------------------------------

type family ErrorCheck (name :: Symbol) r a (res :: Maybe Type) :: Constraint where
    ErrorCheck _    _ _ ('Just _) = ()
    ErrorCheck name r a 'Nothing  = TypeError
      ( 'Text "Type " ':<>: 'ShowType r
      ':<>: 'Text " doesn't have field named " ':<>: 'Text name
      )

-- this prevents expansion of HasField "alias".
data Void1 a

instance {-# OVERLAPPING #-} HasField name (Void1 a) a where
    field__ :: forall (f :: * -> *). Proxy name -> LensLikeYoneda' f (Void1 a) a
field__ Proxy name
_ a -> Yoneda f a
_ Void1 a
n = case Void1 a
n of {}

-------------------------------------------------------------------------------
-- Generics
-------------------------------------------------------------------------------

type LensLikeYoneda' f r a = LensLike (Yoneda f) r r a a

class (HasFieldPred name f ~ 'Just a) => GField (name :: Symbol) f a | name f -> a where
    gfield :: Proxy name -> LensLikeYoneda' h (f ()) a

instance (GFieldSum name f a, i ~ D, HasFieldPred name f ~ 'Just a) => GField name (M1 i c f) a where
    gfield :: forall (h :: * -> *).
Proxy name -> LensLikeYoneda' h (M1 i c f ()) a
gfield Proxy name
pname a -> Yoneda h a
f (M1 f ()
x) = (f () -> M1 i c f ()) -> Yoneda h (f ()) -> Yoneda h (M1 i c f ())
forall a b. (a -> b) -> Yoneda h a -> Yoneda h b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f () -> M1 i c f ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Proxy name -> LensLikeYoneda' h (f ()) a
forall (name :: Symbol) (f :: * -> *) a (h :: * -> *).
GFieldSum name f a =>
Proxy name -> LensLikeYoneda' h (f ()) a
forall (h :: * -> *). Proxy name -> LensLikeYoneda' h (f ()) a
gfieldsum Proxy name
pname a -> Yoneda h a
f f ()
x)
    {-# INLINE gfield #-}

class HasFieldPred name f ~ 'Just a => GFieldSum (name :: Symbol) f a | name f -> a where
    gfieldsum :: Proxy name -> LensLikeYoneda' h (f ()) a

instance (HasFieldPred name (f :+: g) ~ 'Just a, GFieldSum name f a, GFieldSum name g a) => GFieldSum name (f :+: g) a where
    gfieldsum :: forall (h :: * -> *).
Proxy name -> LensLikeYoneda' h ((:+:) f g ()) a
gfieldsum Proxy name
pname a -> Yoneda h a
f (L1 f ()
x) = (f () -> (:+:) f g ())
-> Yoneda h (f ()) -> Yoneda h ((:+:) f g ())
forall a b. (a -> b) -> Yoneda h a -> Yoneda h b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f () -> (:+:) f g ()
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (Proxy name -> LensLikeYoneda' h (f ()) a
forall (name :: Symbol) (f :: * -> *) a (h :: * -> *).
GFieldSum name f a =>
Proxy name -> LensLikeYoneda' h (f ()) a
forall (h :: * -> *). Proxy name -> LensLikeYoneda' h (f ()) a
gfieldsum Proxy name
pname a -> Yoneda h a
f f ()
x)
    gfieldsum Proxy name
pname a -> Yoneda h a
f (R1 g ()
y) = (g () -> (:+:) f g ())
-> Yoneda h (g ()) -> Yoneda h ((:+:) f g ())
forall a b. (a -> b) -> Yoneda h a -> Yoneda h b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap g () -> (:+:) f g ()
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (Proxy name -> LensLikeYoneda' h (g ()) a
forall (name :: Symbol) (f :: * -> *) a (h :: * -> *).
GFieldSum name f a =>
Proxy name -> LensLikeYoneda' h (f ()) a
forall (h :: * -> *). Proxy name -> LensLikeYoneda' h (g ()) a
gfieldsum Proxy name
pname a -> Yoneda h a
f g ()
y)
    {-# INLINE gfieldsum #-}

instance (GFieldProd name f a, i ~ C, HasFieldPred name f ~ 'Just a) => GFieldSum name (M1 i c f) a where
    gfieldsum :: forall (h :: * -> *).
Proxy name -> LensLikeYoneda' h (M1 i c f ()) a
gfieldsum Proxy name
pname a -> Yoneda h a
f (M1 f ()
x)  = (f () -> M1 i c f ()) -> Yoneda h (f ()) -> Yoneda h (M1 i c f ())
forall a b. (a -> b) -> Yoneda h a -> Yoneda h b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f () -> M1 i c f ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Proxy name -> LensLikeYoneda' h (f ()) a
forall (name :: Symbol) (f :: * -> *) a (h :: * -> *).
GFieldProd name f a =>
Proxy name -> LensLikeYoneda' h (f ()) a
forall (h :: * -> *). Proxy name -> LensLikeYoneda' h (f ()) a
gfieldprod Proxy name
pname a -> Yoneda h a
f f ()
x)
    {-# INLINE gfieldsum #-}

class (HasFieldPred name f ~ 'Just a) => GFieldProd (name :: Symbol) f a | name f -> a where
    gfieldprod :: Proxy name -> LensLikeYoneda' h (f ()) a

instance (c ~ 'MetaSel ('Just name) u s l, f ~ Rec0 a, i ~ S) => GFieldProd name (M1 i c f) a where
    gfieldprod :: forall (h :: * -> *).
Proxy name -> LensLikeYoneda' h (M1 i c f ()) a
gfieldprod Proxy name
_ a -> Yoneda h a
f (M1 (K1 a
x)) = (a -> M1 i c f ()) -> Yoneda h a -> Yoneda h (M1 i c f ())
forall a b. (a -> b) -> Yoneda h a -> Yoneda h b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (f () -> M1 i c f ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f () -> M1 i c f ()) -> (a -> f ()) -> a -> M1 i c f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f ()
a -> K1 R a ()
forall k i c (p :: k). c -> K1 i c p
K1) (a -> Yoneda h a
f a
x)
    {-# INLINE gfieldprod #-}

instance GFieldProd' name f g (HasFieldPred name f) a => GFieldProd name (f :*: g) a where
    gfieldprod :: forall (h :: * -> *).
Proxy name -> LensLikeYoneda' h ((:*:) f g ()) a
gfieldprod = Proxy (HasFieldPred name f)
-> Proxy name -> LensLikeYoneda' h ((:*:) f g ()) a
forall (name :: Symbol) (f :: * -> *) (g :: * -> *)
       (res :: Maybe (*)) a (h :: * -> *).
GFieldProd' name f g res a =>
Proxy res -> Proxy name -> LensLikeYoneda' h ((:*:) f g ()) a
forall (h :: * -> *).
Proxy (HasFieldPred name f)
-> Proxy name -> LensLikeYoneda' h ((:*:) f g ()) a
gfieldprod' (Proxy (HasFieldPred name f)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (HasFieldPred name f))
    {-# INLINE gfieldprod #-}

class (HasFieldPred name (f :*: g) ~ 'Just a) => GFieldProd' (name :: Symbol) f g (res :: Maybe Type) a where
    gfieldprod' :: Proxy res -> Proxy name ->  LensLikeYoneda' h ((f :*: g) ()) a

instance (a ~ a', GFieldProd name f a', HasFieldPred name (f :*: g) ~ 'Just a) => GFieldProd' name f g ('Just a') a where
    gfieldprod' :: forall (h :: * -> *).
Proxy ('Just a')
-> Proxy name -> LensLikeYoneda' h ((:*:) f g ()) a
gfieldprod' Proxy ('Just a')
_ Proxy name
pname a -> Yoneda h a
f (f ()
x :*: g ()
y) = (f () -> (:*:) f g ())
-> Yoneda h (f ()) -> Yoneda h ((:*:) f g ())
forall a b. (a -> b) -> Yoneda h a -> Yoneda h b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (f () -> g () -> (:*:) f g ()
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g ()
y) (Proxy name -> LensLikeYoneda' h (f ()) a
forall (name :: Symbol) (f :: * -> *) a (h :: * -> *).
GFieldProd name f a =>
Proxy name -> LensLikeYoneda' h (f ()) a
forall (h :: * -> *). Proxy name -> LensLikeYoneda' h (f ()) a
gfieldprod Proxy name
pname a -> Yoneda h a
f f ()
x)
    {-# INLINE gfieldprod' #-}

instance (a ~ a', GFieldProd name g a', HasFieldPred name (f :*: g) ~ 'Just a) => GFieldProd' name f g 'Nothing a where
    gfieldprod' :: forall (h :: * -> *).
Proxy 'Nothing -> Proxy name -> LensLikeYoneda' h ((:*:) f g ()) a
gfieldprod' Proxy 'Nothing
_ Proxy name
pname a -> Yoneda h a
f (f ()
x :*: g ()
y) = (g () -> (:*:) f g ())
-> Yoneda h (g ()) -> Yoneda h ((:*:) f g ())
forall a b. (a -> b) -> Yoneda h a -> Yoneda h b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (f ()
x f () -> g () -> (:*:) f g ()
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*:) (Proxy name -> LensLikeYoneda' h (g ()) a
forall (name :: Symbol) (f :: * -> *) a (h :: * -> *).
GFieldProd name f a =>
Proxy name -> LensLikeYoneda' h (f ()) a
forall (h :: * -> *). Proxy name -> LensLikeYoneda' h (g ()) a
gfieldprod Proxy name
pname a -> Yoneda h a
f g ()
y)
    {-# INLINE gfieldprod' #-}

-------------------------------------------------------------------------------
-- TotalField
-------------------------------------------------------------------------------

type family Both (m1 :: Maybe Type) (m2 :: Maybe Type) :: Maybe Type where
    Both ('Just a) ('Just a) = 'Just a

type family Alt (m1 :: Maybe Type) (m2 :: Maybe Type) :: Maybe Type where
    Alt ('Just a) _ = 'Just a
    Alt _ b = b

type family HasFieldPred (field :: Symbol) f :: Maybe Type where
    HasFieldPred field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t)) =
        'Just t
    HasFieldPred field (S1 _ _)  = 'Nothing
    HasFieldPred field (l :*: r) = Alt (HasFieldPred field l) (HasFieldPred field r)
    HasFieldPred field (l :+: r) = Both (HasFieldPred field l) (HasFieldPred field r)
    HasFieldPred field (C1 _ f)  = HasFieldPred field f
    HasFieldPred field (D1 _ f)  = HasFieldPred field f
    HasFieldPred field (K1 _ _)  = 'Nothing
    HasFieldPred field U1        = 'Nothing
    HasFieldPred field V1        = 'Nothing