Generic.hs

-----------------------------------------------------------------------------
{-# 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 (getField @name) (\s v -> to . gSet @name v . from $ s)
  {-# INLINE getLens #-}

instance HasLens name s a => IsLabel name (Lens s a)
  where fromLabel = getLens @name

{-# INLINE field #-}
field :: forall name s a. HasLens name s a => Lens s a 
field = 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 v (l :*: r) = gSet @name v l :*: gSet @name v r
  {-# INLINE gSet #-}

instance (GSet name typ a, GSet name typ b) => GSet name typ (a :+: b) where
  gSet v (L1 l) = L1 $ gSet @name v l
  gSet v (R1 r) = R1 $ gSet @name v r
  {-# INLINE gSet #-}

instance (GSet name typ f) => GSet name typ (C1 x f) where
  gSet v (M1 f) = M1 $ gSet @name v f
  {-# INLINE gSet #-}

instance (GSet name typ f) => GSet name typ (D1 x f) where
  gSet v (M1 f) = M1 $ gSet @name v f
  {-# INLINE gSet #-}

instance {-# OVERLAPPING #-} GSet name typ (S1 ('MetaSel ('Just name) b c d) (Rec0 typ)) where
  gSet v (M1 (K1 _)) = M1 (K1 v)

instance {-# OVERLAPPABLE #-} GSet name typ (S1 ('MetaSel ('Just anotherName) b c d) x) where
  gSet _ f = 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