-----------------------------------------------------------------------------
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Lens.Generic
-- Copyright   :  (C) 2016-2026 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
-----------------------------------------------------------------------------
module Miso.Lens.Generic (HasLens(..), field) where

-----------------------------------------------------------------------------
import Data.Kind (Constraint, Type)
import GHC.Generics (C1, D1, Generic (..), K1 (..), M1 (..), Meta (..), Rec0, S1, (:*:) (..), (:+:) (..))
import GHC.OverloadedLabels (IsLabel (..))
import GHC.Records (HasField (..))
import GHC.TypeLits (ErrorMessage (..), Symbol, TypeError)
-----------------------------------------------------------------------------
import Miso.Lens (Lens, lens)
-----------------------------------------------------------------------------

class Generic s => HasLens (name :: Symbol) s a | name s -> a where 
  getLens :: Lens s a

instance 
  (HasField name s a, TotalityCheck name s a (GetFieldType name (Rep s)), GSet name a (Rep s), Generic s) => 
  HasLens name s a where
  getLens :: Lens s a
getLens = (s -> a) -> (s -> a -> s) -> Lens s a
forall record field.
(record -> field)
-> (record -> field -> record) -> Lens record field
lens (forall {k} (x :: k) r a. HasField x r a => r -> a
forall (x :: Symbol) r a. HasField x r a => r -> a
getField @name) (\s
s a
v -> Rep s (ZonkAny 0) -> s
forall a x. Generic a => Rep a x -> a
forall x. Rep s x -> s
to (Rep s (ZonkAny 0) -> s) -> (s -> Rep s (ZonkAny 0)) -> s -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (name :: Symbol) typ (f :: * -> *) x.
GSet name typ f =>
typ -> f x -> f x
gSet @name a
v (Rep s (ZonkAny 0) -> Rep s (ZonkAny 0))
-> (s -> Rep s (ZonkAny 0)) -> s -> Rep s (ZonkAny 0)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Rep s (ZonkAny 0)
forall x. s -> Rep s x
forall a x. Generic a => a -> Rep a x
from (s -> s) -> s -> s
forall a b. (a -> b) -> a -> b
$ s
s)
  {-# INLINE getLens #-}

instance HasLens name s a => IsLabel name (Lens s a)
  where fromLabel :: Lens s a
fromLabel = forall (name :: Symbol) s a. HasLens name s a => Lens s a
getLens @name

{-# INLINE field #-}
field :: forall name s a. HasLens name s a => Lens s a 
field :: forall (name :: Symbol) s a. HasLens name s a => Lens s a
field = forall (x :: Symbol) a. IsLabel x a => a
fromLabel @name

class GSet (name :: Symbol) typ f where
  gSet :: typ -> f x -> f x

instance (GSet name typ a, GSet name typ b) => GSet name typ (a :*: b) where
  gSet :: forall x. typ -> (:*:) a b x -> (:*:) a b x
gSet typ
v (a x
l :*: b x
r) = forall (name :: Symbol) typ (f :: * -> *) x.
GSet name typ f =>
typ -> f x -> f x
gSet @name typ
v a x
l a x -> b x -> (:*:) a b x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall (name :: Symbol) typ (f :: * -> *) x.
GSet name typ f =>
typ -> f x -> f x
gSet @name typ
v b x
r
  {-# INLINE gSet #-}

instance (GSet name typ a, GSet name typ b) => GSet name typ (a :+: b) where
  gSet :: forall x. typ -> (:+:) a b x -> (:+:) a b x
gSet typ
v (L1 a x
l) = a x -> (:+:) a b x
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (a x -> (:+:) a b x) -> a x -> (:+:) a b x
forall a b. (a -> b) -> a -> b
$ forall (name :: Symbol) typ (f :: * -> *) x.
GSet name typ f =>
typ -> f x -> f x
gSet @name typ
v a x
l
  gSet typ
v (R1 b x
r) = b x -> (:+:) a b x
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (b x -> (:+:) a b x) -> b x -> (:+:) a b x
forall a b. (a -> b) -> a -> b
$ forall (name :: Symbol) typ (f :: * -> *) x.
GSet name typ f =>
typ -> f x -> f x
gSet @name typ
v b x
r
  {-# INLINE gSet #-}

instance (GSet name typ f) => GSet name typ (C1 x f) where
  gSet :: forall x. typ -> C1 x f x -> C1 x f x
gSet typ
v (M1 f x
f) = f x -> M1 C x f x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f x -> M1 C x f x) -> f x -> M1 C x f x
forall a b. (a -> b) -> a -> b
$ forall (name :: Symbol) typ (f :: * -> *) x.
GSet name typ f =>
typ -> f x -> f x
gSet @name typ
v f x
f
  {-# INLINE gSet #-}

instance (GSet name typ f) => GSet name typ (D1 x f) where
  gSet :: forall x. typ -> D1 x f x -> D1 x f x
gSet typ
v (M1 f x
f) = f x -> M1 D x f x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f x -> M1 D x f x) -> f x -> M1 D x f x
forall a b. (a -> b) -> a -> b
$ forall (name :: Symbol) typ (f :: * -> *) x.
GSet name typ f =>
typ -> f x -> f x
gSet @name typ
v f x
f
  {-# INLINE gSet #-}

instance {-# OVERLAPPING #-} GSet name typ (S1 ('MetaSel ('Just name) b c d) (Rec0 typ)) where
  gSet :: forall x.
typ
-> S1 ('MetaSel ('Just name) b c d) (Rec0 typ) x
-> S1 ('MetaSel ('Just name) b c d) (Rec0 typ) x
gSet typ
v (M1 (K1 typ
_)) = K1 R typ x -> M1 S ('MetaSel ('Just name) b c d) (Rec0 typ) x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (typ -> K1 R typ x
forall k i c (p :: k). c -> K1 i c p
K1 typ
v)

instance {-# OVERLAPPABLE #-} GSet name typ (S1 ('MetaSel ('Just anotherName) b c d) x) where
  gSet :: forall x.
typ
-> S1 ('MetaSel ('Just anotherName) b c d) x x
-> S1 ('MetaSel ('Just anotherName) b c d) x x
gSet typ
_ S1 ('MetaSel ('Just anotherName) b c d) x x
f = S1 ('MetaSel ('Just anotherName) b c d) x x
f
  {-# INLINE gSet #-}

type family TotalityCheck (name :: Symbol) r a (res :: Maybe Type) :: Constraint where
  TotalityCheck _ _ _ ('Just _) = ()
  TotalityCheck name r a 'Nothing =
    TypeError
      ( 'ShowType r
          ':<>: 'Text ": "
          ':<>: 'Text name
          ':<>: 'Text " field missing or not in all constructors"
      )

type family GetFieldType (field :: Symbol) f :: Maybe Type where
  GetFieldType field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t)) ='Just t
  GetFieldType field (l :*: r) = Or (GetFieldType field l) (GetFieldType field r)
  GetFieldType field (l :+: r) = And (GetFieldType field l) (GetFieldType field r)
  GetFieldType field (C1 _ f) = GetFieldType field f
  GetFieldType field (D1 _ f) = GetFieldType field f
  GetFieldType field x = 'Nothing

type family And (l :: Maybe Type) (r :: Maybe Type) :: Maybe Type where
  And ('Just a) ('Just a) = 'Just a
  And l r = 'Nothing

type family Or (l :: Maybe Type) (r :: Maybe Type) :: Maybe Type where
  Or ('Just l) _ = 'Just l
  Or _ r = r