-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

{- | 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.Internal.Field
       ( AccessFieldC
       , fetchField
       , assignField

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

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

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

-- | 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 :: proxy name -> Rec f (ConstructorFieldNames a) -> f name
fetchField _ = forall (rs :: [Symbol]) (f :: Symbol -> *)
       (record :: (Symbol -> *) -> [Symbol] -> *).
(RecElem record name name rs rs (RIndex name rs),
 RecElemFCtx record f) =>
record f rs -> f 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
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 :: proxy name
-> f name
-> Rec f (ConstructorFieldNames a)
-> Rec f (ConstructorFieldNames a)
assignField _ = forall (rs :: [Symbol]) (record :: (Symbol -> *) -> [Symbol] -> *)
       (f :: Symbol -> *).
(RecElem record name name rs rs (RIndex name rs),
 RecElemFCtx record f) =>
f name -> record f rs -> record f rs
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 :: FieldLens dt fname ftype -> StoreFieldOps dt fname ftype
flSFO (TargetField _ sfo :: StoreFieldOps dt fname ftype
sfo) = StoreFieldOps dt fname ftype
sfo
flSFO (DeeperField _ sfo :: 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 :: Label fname -> FieldLens dt targetFName targetFType
fieldLensADT lb :: Label fname
lb =
  let sfo :: StoreFieldOps dt fname targetFType
sfo = forall ftype.
HasFieldOfType dt fname ftype =>
StoreFieldOps dt fname ftype
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 dt (fname :: Symbol) targetFType (targetFName :: Symbol).
(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
$ $WStoreFieldOps :: forall store (fname :: Symbol) ftype.
(forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s))
-> (forall (s :: [*]).
    Label fname -> (ftype : store : s) :-> (store : s))
-> StoreFieldOps store fname ftype
StoreFieldOps
    { sopToField :: forall (s :: [*]).
Label targetFName -> (dt : s) :-> (targetFType : s)
sopToField = \_ -> StoreFieldOps dt fname targetFType
-> Label fname -> (dt : s) :-> (targetFType : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s)
sopToField StoreFieldOps dt fname targetFType
sfo Label fname
lb
    , sopSetField :: forall (s :: [*]).
Label targetFName -> (targetFType : dt : s) :-> (dt : s)
sopSetField = \_ -> StoreFieldOps dt fname targetFType
-> Label fname -> (targetFType : dt : s) :-> (dt : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]).
   Label fname -> (ftype : store : s) :-> (store : s)
sopSetField StoreFieldOps dt fname targetFType
sfo Label fname
lb
    }

-- | 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)
  , HasField (GetFieldType dt fname) targetName targetType
  )
  => Label fname
  -> FieldLens dt targetName targetType
fieldLensDeeper :: Label fname -> FieldLens dt targetName targetType
fieldLensDeeper lb :: Label fname
lb =
  Label fname
-> StoreFieldOps dt targetName targetType
-> FieldLens dt targetName targetType
forall dt (fname :: Symbol) (targetFName :: Symbol) 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 (Label fname
-> StoreFieldOps
     dt
     fname
     (LnrFieldType
        (LNRequireFound fname dt (GLookupNamed fname (Rep dt))))
-> StoreFieldOps
     (LnrFieldType
        (LNRequireFound fname dt (GLookupNamed fname (Rep dt))))
     targetName
     targetType
-> StoreFieldOps dt targetName targetType
forall (nameInStore :: Symbol) store substore
       (nameInSubstore :: Symbol) field.
Label nameInStore
-> StoreFieldOps store nameInStore substore
-> StoreFieldOps substore nameInSubstore field
-> StoreFieldOps store nameInSubstore field
composeStoreFieldOps Label fname
lb (forall dt (fname :: Symbol) ftype.
HasFieldOfType dt fname ftype =>
StoreFieldOps dt fname ftype
forall (fname :: Symbol) ftype.
HasFieldOfType dt fname ftype =>
StoreFieldOps dt fname ftype
storeFieldOpsADT @dt) (FieldLens
  (LnrFieldType
     (LNRequireFound fname dt (GLookupNamed fname (Rep dt))))
  targetName
  targetType
-> StoreFieldOps
     (LnrFieldType
        (LNRequireFound fname dt (GLookupNamed fname (Rep dt))))
     targetName
     targetType
forall dt (fname :: Symbol) ftype.
FieldLens dt fname ftype -> StoreFieldOps dt fname ftype
flSFO FieldLens
  (LnrFieldType
     (LNRequireFound fname dt (GLookupNamed fname (Rep dt))))
  targetName
  targetType
forall dt (fname :: Symbol) 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 dt (fname :: Symbol) targetFType (targetFName :: Symbol).
(InstrGetFieldC dt fname, InstrSetFieldC dt fname,
 GetFieldType dt fname ~ targetFType, AccessFieldC dt fname) =>
Label fname
-> StoreFieldOps dt targetFName targetFType
-> FieldLens dt targetFName targetFType
TargetField (KnownSymbol fname => Label fname
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