Field.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{- | This module contains a datatype representing a lens to a field,
helpers to compose new lens, and type class like StoreHasField returning a lens. -}

module Indigo.Common.Field
       ( AccessFieldC
       , fetchField
       , assignField

       -- * Lens
       , FieldLens (..)
       , flSFO
       -- * HasLens
       , HasField (..)
       , fieldLensDeeper
       , fieldLensADT
       ) where

import Data.Vinyl (RElem)
import Data.Vinyl.Lens (rget, rput)
import Data.Vinyl.TypeLevel (RIndex)
import GHC.TypeLits (KnownSymbol)

import Indigo.Lorentz
import Indigo.Prelude
import Lorentz.ADT qualified as L
import Morley.Michelson.Typed.Haskell.Instr.Product
  (ConstructorFieldNames, GetFieldType, InstrGetFieldC, InstrSetFieldC)

-- | Constraint to access/assign field stored in Rec
type AccessFieldC a name =
  RElem name (ConstructorFieldNames a) (RIndex name (ConstructorFieldNames a))

-- | Get a field from list of fields
fetchField
  :: forall a name f proxy . AccessFieldC a name
  => proxy name -> Rec f (ConstructorFieldNames a) -> f name
fetchField _ = rget @name

-- | Assign a field to a value
assignField
  :: forall a name f proxy . AccessFieldC a name
  => proxy name -> f name -> Rec f (ConstructorFieldNames a) -> Rec f (ConstructorFieldNames a)
assignField _ = rput @_ @name

-- | Lens to a field.
-- @obj.f1.f2.f3@ is represented as list names of @[f1, f2, f3]@.
--
-- @dt@ is a type of source object (type of obj in example above)
-- @fname@ is a name of target field (@"f3"@ in example above)
-- @ftype@ is a type of target field
--
-- However, a lens contains not only name of field
-- but for each field it contains operations to get and set
-- target field.
data FieldLens dt fname ftype where
  -- Direct field of @dt@ (which is target one).
  -- Pay attention that it holds a label of existential type @fname@ but not @targetFName@.
  -- It's made to allow a developer to refer to a field
  -- with a custom name.
  -- The another argument is 'StoreFieldOps'.
  TargetField
    :: ( InstrGetFieldC dt fname
       , InstrSetFieldC dt fname
       , GetFieldType dt fname ~ targetFType
       , AccessFieldC dt fname
       )
    => Label fname
    -> StoreFieldOps dt targetFName targetFType
    -> FieldLens dt targetFName targetFType

  -- Deeper field of @dt@.
  -- It takes a label with name of direct field and
  -- 'HasField' with deeper field as source and
  -- with the same target field,
  -- so it's how this datatype is alike list of fields.
  -- The last argument is Lorentz operations to get and set target field.
  DeeperField
    :: ( AccessFieldC dt fname
       , InstrSetFieldC dt fname
       , HasField (GetFieldType dt fname) targetFName targetFType
       )
    => Label fname
    -> StoreFieldOps dt targetFName targetFType
    -> FieldLens dt targetFName targetFType

-- | Access to 'StoreFieldOps'
flSFO :: FieldLens dt fname ftype -> StoreFieldOps dt fname ftype
flSFO (TargetField _ sfo) = sfo
flSFO (DeeperField _ sfo) = sfo

-- | Class like 'StoreHasField' type class but holding a lens to a field.
class (KnownValue ftype, KnownValue dt) => HasField dt fname ftype | dt fname -> ftype  where
  fieldLens :: FieldLens dt fname ftype

-- | Build a lens to a direct field of an object.
fieldLensADT
  :: forall dt targetFName targetFType fname  .
  ( InstrGetFieldC dt fname
  , InstrSetFieldC dt fname
  , GetFieldType dt fname ~ targetFType
  , AccessFieldC dt fname
  )
 => Label fname -> FieldLens dt targetFName targetFType
fieldLensADT lb =
  let sfo = storeFieldOpsADT @dt @fname in
  TargetField lb $ storeFieldOpsReferTo (fieldNameFromLabel lb) sfo

-- | Build a lens to deeper field of an object.
fieldLensDeeper
  :: forall dt targetName targetType fname .
  ( AccessFieldC dt fname
  , L.HasFieldOfType dt fname (GetFieldType dt fname)
  , HasDupableGetters (GetFieldType dt fname)
  , HasField (GetFieldType dt fname) targetName targetType
  )
  => Label fname
  -> FieldLens dt targetName targetType
fieldLensDeeper lb =
  DeeperField lb $
    composeStoreFieldOps (fieldNameFromLabel lb) (storeFieldOpsADT @dt) (flSFO fieldLens)

-- | Default instance for datatype and its direct field name.
-- It will be useful unless you want to refer to a field using a custom name.
instance {-# OVERLAPPABLE #-}
         ( InstrSetFieldC dt fname
         , InstrGetFieldC dt fname
         , GetFieldType dt fname ~ ftype
         , AccessFieldC dt fname
         , KnownSymbol fname
         , KnownValue ftype, KnownValue dt
         )
         => HasField dt fname ftype where
  fieldLens = TargetField (Label @fname) storeFieldOpsADT