{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-|
Module      : Polytropos.Optics
Description : optics-core integration for polytropos open records and variants
Copyright   : (c) 2026 The Polytropos Authors
License     : EUPL-1.2 OR Apache-2.0
Maintainer  : nadia.yvette.chambers@ik.me
Stability   : experimental
Portability : non-portable (GHC extensions)

Integration between @polytropos@ and the @optics@ \/ @optics-core@ ecosystem.

This module provides first-class optics for open records and variants:
* Van Laarhoven lenses for record fields via 'fieldLens'.
* First-class prisms for variant constructors via 'ctorOptic'.
* Overloaded labels ('LabelOptic') allowing @#fieldname@ lens syntax with @OverloadedLabels@.

= Architectural Overview & Rationale

Rather than treating record fields as string lookups in runtime maps, @polytropos-optics@
relies on the literal zero-based slot indices synthesized by @polytropos-plugin@.
Each lens focuses directly on an array slot in the underlying contiguous 'Data.Primitive.SmallArray.SmallArray'.
Prisms inspect the unboxed constructor tag in \(O(1)\) and extract the constructor's payload.

= When to Use This Module

* When your application uses the @optics@ library and you want idiomatic lens and prism
  operations over @polytropos@ records and variants.
* When you want @#fieldName@ syntax for record field access and update.

= When Not to Use This Module

* If your project is built around Edward Kmett's @lens@ library, use "Polytropos.Lens" instead.
* If your project aims for minimal dependencies and uses @microlens@, use "Polytropos.Microlens" instead.

= Worked Example

> {-# LANGUAGE DataKinds #-}
> {-# LANGUAGE OverloadedLabels #-}
> {-# LANGUAGE TypeApplications #-}
> {-# OPTIONS_GHC -fplugin=Polytropos.Plugin #-}
>
> import Optics.Core
> import Polytropos
> import Polytropos.Optics
>
> type Person = Record '["name" ':= String, "age" ':= Int]
>
> alice :: Person
> alice = REC { name = "Alice", age = 30 }
>
> -- Reading via overloaded label:
> aliceAge :: Int
> aliceAge = alice ^. #age  -- 30
>
> -- Updating via overloaded label:
> olderAlice :: Person
> olderAlice = alice & #age %~ (+ 1)  -- age = 31
>
> -- Working with variant prisms:
> type Shape = Variant '["Circle" ':= '["radius" ':= Double]]
>
> myCircle :: Shape
> myCircle = VAR { Circle = REC { radius = 5.0 } }
>
> circleRadius :: Maybe Double
> circleRadius = preview (ctorOptic (Field @"Circle") % #radius) myCircle  -- Just 5.0
-}
module Polytropos.Optics (
    -- * Record Field Lenses
    fieldLens

    -- * Variant Constructor Prisms
  , ctorOptic
  ) where

import Optics.Core
import Polytropos
import Polytropos.Core
import GHC.TypeLits
import GHC.Records
import Unsafe.Coerce
import Data.Functor.Identity

-- | Van Laarhoven lens for a record field specified by label.
fieldLens :: forall n r a. FieldIndex n r a => Field n -> LensVL (Record r) (Record r) a a
fieldLens :: forall (n :: Symbol) (r :: Row) a.
FieldIndex n r a =>
Field n -> LensVL (Record r) (Record r) a a
fieldLens Field n
_ a -> f a
f (RowRep Rep Identity ()
r) =
  (a -> RowRep Identity 'ProductRowT r ())
-> f a -> f (RowRep Identity 'ProductRowT r ())
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
a' -> Rep Identity () -> RowRep Identity 'ProductRowT r ()
forall {k} k1 (f :: * -> *) (r :: RowType) (row :: k1) (a :: k).
Rep f a -> RowRep f r row a
RowRep (Int -> Identity Any -> Rep Identity () -> Rep Identity ()
forall {k} (f :: * -> *) (a :: k).
Int -> f Any -> Rep f a -> Rep f a
setFieldAt (forall {kn} k {ka} (n :: kn) (row :: k) (a :: ka).
FieldIndex n row a =>
Int
forall k {ka} (n :: Symbol) (row :: k) (a :: ka).
FieldIndex n row a =>
Int
fieldIndex @_ @n @r @a) (Any -> Identity Any
forall a. a -> Identity a
Identity (a -> Any
forall a b. a -> b
unsafeCoerce a
a')) Rep Identity ()
r))
       (a -> f a
f (ZonkAny 0 -> a
forall a b. a -> b
unsafeCoerce (Identity (ZonkAny 0) -> ZonkAny 0
forall a. Identity a -> a
runIdentity (Int -> Rep Identity () -> Identity (ZonkAny 0)
forall {k} (f :: * -> *) (a :: k) x. Int -> Rep f a -> f x
fieldAt (forall {kn} k {ka} (n :: kn) (row :: k) (a :: ka).
FieldIndex n row a =>
Int
forall k {ka} (n :: Symbol) (row :: k) (a :: ka).
FieldIndex n row a =>
Int
fieldIndex @_ @n @r @a) Rep Identity ()
r))))

instance {-# OVERLAPPING #-} (KnownSymbol n, HasField n (Record r) field, FieldIndex n r field, a ~ field, b ~ field)
      => LabelOptic n A_Lens (Record r) (Record r) a b where
  labelOptic :: Optic A_Lens NoIx (Record r) (Record r) a b
labelOptic = LensVL (Record r) (Record r) a b
-> Optic A_Lens NoIx (Record r) (Record r) a b
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (Field n -> LensVL (Record r) (Record r) a a
forall (n :: Symbol) (r :: Row) a.
FieldIndex n r a =>
Field n -> LensVL (Record r) (Record r) a a
fieldLens (forall (n :: Symbol). Field n
Field @n))

-- | Prism optic for a variant constructor specified by label.
ctorOptic :: forall c s fs. ConstructorIndex c s => Field c -> Optic A_Prism NoIx (Variant s) (Variant s) (Record fs) (Record fs)
ctorOptic :: forall (c :: Symbol) (s :: SumRow) (fs :: Row).
ConstructorIndex c s =>
Field c
-> Optic
     A_Prism NoIx (Variant s) (Variant s) (Record fs) (Record fs)
ctorOptic Field c
f = (Record fs -> Variant s)
-> (Variant s -> Maybe (Record fs))
-> Prism (Variant s) (Variant s) (Record fs) (Record fs)
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (Field c -> Record fs -> Variant s
forall (n :: Symbol) (s :: SumRow) (fs :: Row).
ConstructorIndex n s =>
Field n -> Record fs -> Variant s
injectVariant Field c
f) Variant s -> Maybe (Record fs)
project
  where
    project :: Variant s -> Maybe (Record fs)
    project :: Variant s -> Maybe (Record fs)
project (RowRep Rep Identity ()
r) = case Word -> Rep Identity () -> Maybe [Identity Any]
forall {k} (f :: * -> *) (a :: k). Word -> Rep f a -> Maybe [f Any]
projectRep (forall {kn} k (n :: kn) (row :: k). ConstructorIndex n row => Word
forall k (n :: Symbol) (row :: k). ConstructorIndex n row => Word
constructorIndex @_ @c @s) Rep Identity ()
r of
      Just [Identity Any]
vals -> Record fs -> Maybe (Record fs)
forall a. a -> Maybe a
Just (Rep Identity () -> Record fs
forall {k} k1 (f :: * -> *) (r :: RowType) (row :: k1) (a :: k).
Rep f a -> RowRep f r row a
RowRep ([Identity Any] -> Rep Identity ()
forall {k} (f :: * -> *) (a :: k). [f Any] -> Rep f a
productRep [Identity Any]
vals))
      Maybe [Identity Any]
Nothing   -> Maybe (Record fs)
forall a. Maybe a
Nothing