-- 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 :: forall a (name :: Symbol) (f :: Symbol -> *)
       (proxy :: Symbol -> *).
AccessFieldC a name =>
proxy name -> Rec f (ConstructorFieldNames a) -> f name
fetchField proxy name
_ = forall {k} (r :: k) (rs :: [k]) (f :: k -> *)
       (record :: (k -> *) -> [k] -> *).
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f) =>
record f rs -> f r
forall (r :: Symbol) (rs :: [Symbol]) (f :: Symbol -> *)
       (record :: (Symbol -> *) -> [Symbol] -> *).
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f) =>
record f rs -> f r
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 :: forall a (name :: Symbol) (f :: Symbol -> *)
       (proxy :: Symbol -> *).
AccessFieldC a name =>
proxy name
-> f name
-> Rec f (ConstructorFieldNames a)
-> Rec f (ConstructorFieldNames a)
assignField proxy name
_ = forall k (r :: k) (rs :: [k]) (record :: (k -> *) -> [k] -> *)
       (f :: k -> *).
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f) =>
f r -> record f rs -> record f rs
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 :: forall {k} dt (fname :: k) ftype.
FieldLens dt fname ftype -> StoreFieldOps dt fname ftype
flSFO (TargetField Label fname
_ StoreFieldOps dt fname ftype
sfo) = StoreFieldOps dt fname ftype
sfo
flSFO (DeeperField Label fname
_ StoreFieldOps dt fname ftype
sfo) = StoreFieldOps dt fname ftype
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 :: forall {k} dt (targetFName :: k) targetFType (fname :: Symbol).
(InstrGetFieldC dt fname, InstrSetFieldC dt fname,
 GetFieldType dt fname ~ targetFType, AccessFieldC dt fname) =>
Label fname -> FieldLens dt targetFName targetFType
fieldLensADT Label fname
lb =
  let sfo :: StoreFieldOps dt fname targetFType
sfo = forall dt (fname :: Symbol) ftype.
HasFieldOfType dt fname ftype =>
StoreFieldOps dt fname ftype
storeFieldOpsADT @dt @fname in
  Label fname
-> StoreFieldOps dt targetFName targetFType
-> FieldLens dt targetFName targetFType
forall {k} dt (fname :: Symbol) targetFType (targetFName :: k).
(InstrGetFieldC dt fname, InstrSetFieldC dt fname,
 GetFieldType dt fname ~ targetFType, AccessFieldC dt fname) =>
Label fname
-> StoreFieldOps dt targetFName targetFType
-> FieldLens dt targetFName targetFType
TargetField Label fname
lb (StoreFieldOps dt targetFName targetFType
 -> FieldLens dt targetFName targetFType)
-> StoreFieldOps dt targetFName targetFType
-> FieldLens dt targetFName targetFType
forall a b. (a -> b) -> a -> b
$ FieldRef fname
-> StoreFieldOps dt fname targetFType
-> StoreFieldOps dt targetFName targetFType
forall {k1} {k2} (name :: k1) storage field (desiredName :: k2).
FieldRef name
-> StoreFieldOps storage name field
-> StoreFieldOps storage desiredName field
storeFieldOpsReferTo (Label fname -> FieldRef fname
forall (n :: Symbol). Label n -> FieldSymRef n
fieldNameFromLabel Label fname
lb) StoreFieldOps dt fname targetFType
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 :: forall {k} dt (targetName :: k) targetType (fname :: Symbol).
(AccessFieldC dt fname,
 HasFieldOfType dt fname (GetFieldType dt fname),
 HasDupableGetters (GetFieldType dt fname),
 HasField (GetFieldType dt fname) targetName targetType) =>
Label fname -> FieldLens dt targetName targetType
fieldLensDeeper Label fname
lb =
  Label fname
-> StoreFieldOps dt targetName targetType
-> FieldLens dt targetName targetType
forall {k} dt (fname :: Symbol) (targetFName :: k) targetFType.
(AccessFieldC dt fname, InstrSetFieldC dt fname,
 HasField (GetFieldType dt fname) targetFName targetFType) =>
Label fname
-> StoreFieldOps dt targetFName targetFType
-> FieldLens dt targetFName targetFType
DeeperField Label fname
lb (StoreFieldOps dt targetName targetType
 -> FieldLens dt targetName targetType)
-> StoreFieldOps dt targetName targetType
-> FieldLens dt targetName targetType
forall a b. (a -> b) -> a -> b
$
    FieldRef fname
-> StoreFieldOps dt fname (GetFieldType dt fname)
-> StoreFieldOps (GetFieldType dt fname) targetName targetType
-> StoreFieldOps dt targetName targetType
forall {k1} {k2} substore (nameInStore :: k1) store
       (nameInSubstore :: k2) field.
HasDupableGetters substore =>
FieldRef nameInStore
-> StoreFieldOps store nameInStore substore
-> StoreFieldOps substore nameInSubstore field
-> StoreFieldOps store nameInSubstore field
composeStoreFieldOps (Label fname -> FieldRef fname
forall (n :: Symbol). Label n -> FieldSymRef n
fieldNameFromLabel Label fname
lb) (forall dt (fname :: Symbol) ftype.
HasFieldOfType dt fname ftype =>
StoreFieldOps dt fname ftype
storeFieldOpsADT @dt) (FieldLens (GetFieldType dt fname) targetName targetType
-> StoreFieldOps (GetFieldType dt fname) targetName targetType
forall {k} dt (fname :: k) ftype.
FieldLens dt fname ftype -> StoreFieldOps dt fname ftype
flSFO FieldLens (GetFieldType dt fname) targetName targetType
forall {k} dt (fname :: k) ftype.
HasField dt fname ftype =>
FieldLens dt fname ftype
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 :: FieldLens dt fname ftype
fieldLens = Label fname
-> StoreFieldOps dt fname ftype -> FieldLens dt fname ftype
forall {k} dt (fname :: Symbol) targetFType (targetFName :: k).
(InstrGetFieldC dt fname, InstrSetFieldC dt fname,
 GetFieldType dt fname ~ targetFType, AccessFieldC dt fname) =>
Label fname
-> StoreFieldOps dt targetFName targetFType
-> FieldLens dt targetFName targetFType
TargetField (forall (name :: Symbol). KnownSymbol name => Label name
Label @fname) StoreFieldOps dt fname ftype
forall dt (fname :: Symbol) ftype.
HasFieldOfType dt fname ftype =>
StoreFieldOps dt fname ftype
storeFieldOpsADT