-----------------------------------------------------------------------------
{-# 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
--
-- = Overview
--
-- "Miso.Lens.Generic" derives 'Miso.Lens.Lens' values for record fields
-- at compile time using @GHC.Generics@ and @GHC.Records@, without
-- Template Haskell. Fields are addressed by name via 'GHC.OverloadedLabels'
-- or the explicit 'field' combinator.
--
-- Enable the required extensions:
--
-- @
-- {-\# LANGUAGE OverloadedLabels, DeriveGeneric \#-}
-- import GHC.Generics (Generic)
-- import "Miso.Lens.Generic" ('HasLens', 'field')
-- import "Miso.Lens"         ('Lens', 'view', 'set', ('.='), ('++='))
-- @
--
-- = Quick start
--
-- @
-- data Counter = Counter { _count :: Int, _label :: 'Miso.String.MisoString' }
--   deriving ('GHC.Generics.Generic')
--
-- -- Label syntax (requires OverloadedLabels):
-- countLens :: 'Miso.Lens.Lens' Counter Int
-- countLens = #_count
--
-- -- Explicit syntax (works without OverloadedLabels):
-- labelLens :: 'Miso.Lens.Lens' Counter 'Miso.String.MisoString'
-- labelLens = 'field' \@\"_label\"
--
-- update :: Action -> 'Miso.Effect.Effect' p props Counter Action
-- update Increment = #_count '+=' 1
-- update (SetLabel l) = #_label '.=' l
-- @
--
-- = How it works
--
-- The 'HasLens' instance is resolved via 'GHC.Records.HasField' for the
-- getter and a generic traversal ('GSet') for the setter. A type-level
-- 'TotalityCheck' produces a descriptive compile error if the field name
-- is absent from (or inconsistent across) the constructors.
--
-- = Comparison with Template Haskell
--
-- [Overloaded labels] "Miso.Lens.Generic" — no TH; derives via @Generic@
-- [Template Haskell] "Miso.Lens.TH" — @makeLenses@ \/ @makeClassy@
--
-- = See also
--
-- * "Miso.Lens" — 'Miso.Lens.Lens', 'Miso.Lens.lens', operators
-- * "Miso.Lens.TH" — Template Haskell alternative
-----------------------------------------------------------------------------
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