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

-- 'newtype Container' deriving produced some fake warnings
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | Module, containing top-level entries of a Michelson contract.
module Morley.Michelson.Typed.Contract
  ( -- * Contract
    ContractInp1
  , ContractInp
  , ContractOut1
  , ContractOut
  , ContractCode'
  , Contract' (..)
  , defaultContract
  , mapContractCode
  , mapContractCodeBlock
  , mapContractViewBlocks
  , mapEntriesOrdered
  ) where

import Data.Default (Default(..))

import Morley.Michelson.Typed.Annotation
import Morley.Michelson.Typed.Entrypoints
import Morley.Michelson.Typed.Scope
import Morley.Michelson.Typed.T (T(..))
import Morley.Michelson.Typed.View
import Morley.Michelson.Untyped.Contract (EntriesOrder, entriesOrderToInt)

type ContractInp1 param st = 'TPair param st
type ContractInp param st = '[ ContractInp1 param st ]

type ContractOut1 st = 'TPair ('TList 'TOperation) st
type ContractOut st = '[ ContractOut1 st ]

type ContractCode' instr cp st = instr (ContractInp cp st) (ContractOut st)

-- | Typed contract and information about annotations
-- which is not present in the contract code.
data Contract' instr cp st = (ParameterScope cp, StorageScope st) => Contract
  { Contract' instr cp st -> ContractCode' instr cp st
cCode         :: ContractCode' instr cp st
  , Contract' instr cp st -> ParamNotes cp
cParamNotes   :: ParamNotes cp
  , Contract' instr cp st -> Notes st
cStoreNotes   :: Notes st
  , Contract' instr cp st -> ViewsSet' instr st
cViews        :: ViewsSet' instr st
  , Contract' instr cp st -> EntriesOrder
cEntriesOrder :: EntriesOrder
  }

deriving stock instance
  (forall i o. Show (instr i o)) =>
  Show (Contract' instr cp st)

deriving stock instance
  (forall i o. Eq (instr i o)) =>
  Eq (Contract' instr cp st)

instance
  (forall i o. NFData (instr i o)) =>
  NFData (Contract' instr cp st) where
  rnf :: Contract' instr cp st -> ()
rnf (Contract ContractCode' instr cp st
a ParamNotes cp
b Notes st
c ViewsSet' instr st
d EntriesOrder
e) = (ContractCode' instr cp st, ParamNotes cp, Notes st,
 ViewsSet' instr st, EntriesOrder)
-> ()
forall a. NFData a => a -> ()
rnf (ContractCode' instr cp st
a, ParamNotes cp
b, Notes st
c, ViewsSet' instr st
d, EntriesOrder
e)

defaultContract :: (ParameterScope cp, StorageScope st) => ContractCode' instr cp st -> Contract' instr cp st
defaultContract :: ContractCode' instr cp st -> Contract' instr cp st
defaultContract ContractCode' instr cp st
code = Contract :: forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
(ParameterScope cp, StorageScope st) =>
ContractCode' instr cp st
-> ParamNotes cp
-> Notes st
-> ViewsSet' instr st
-> EntriesOrder
-> Contract' instr cp st
Contract
  { cCode :: ContractCode' instr cp st
cCode = ContractCode' instr cp st
code
  , cParamNotes :: ParamNotes cp
cParamNotes = ParamNotes cp
forall (t :: T). SingI t => ParamNotes t
starParamNotes
  , cStoreNotes :: Notes st
cStoreNotes = Notes st
forall (t :: T). SingI t => Notes t
starNotes
  , cEntriesOrder :: EntriesOrder
cEntriesOrder = EntriesOrder
forall a. Default a => a
def
  , cViews :: ViewsSet' instr st
cViews = ViewsSet' instr st
forall a. Default a => a
def
  }

-- | Transform contract @code@ block.
--
-- To map e.g. views too, see 'mapContractCode'.
mapContractCodeBlock
  :: (ContractCode' instr cp st -> ContractCode' instr cp st)
  -> Contract' instr cp st
  -> Contract' instr cp st
mapContractCodeBlock :: (ContractCode' instr cp st -> ContractCode' instr cp st)
-> Contract' instr cp st -> Contract' instr cp st
mapContractCodeBlock ContractCode' instr cp st -> ContractCode' instr cp st
f Contract' instr cp st
contract = Contract' instr cp st
contract { cCode :: ContractCode' instr cp st
cCode = ContractCode' instr cp st -> ContractCode' instr cp st
f (ContractCode' instr cp st -> ContractCode' instr cp st)
-> ContractCode' instr cp st -> ContractCode' instr cp st
forall a b. (a -> b) -> a -> b
$ Contract' instr cp st -> ContractCode' instr cp st
forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
Contract' instr cp st -> ContractCode' instr cp st
cCode Contract' instr cp st
contract }

mapContractViewBlocks
  :: (forall arg ret. ViewCode' instr arg st ret -> ViewCode' instr arg st ret)
  -> Contract' instr cp st
  -> Contract' instr cp st
mapContractViewBlocks :: (forall (arg :: T) (ret :: T).
 ViewCode' instr arg st ret -> ViewCode' instr arg st ret)
-> Contract' instr cp st -> Contract' instr cp st
mapContractViewBlocks forall (arg :: T) (ret :: T).
ViewCode' instr arg st ret -> ViewCode' instr arg st ret
f Contract' instr cp st
contract = Contract' instr cp st
contract
  { cViews :: ViewsSet' instr st
cViews = (Seq $ SomeView' instr st) -> ViewsSet' instr st
forall (instr :: [T] -> [T] -> *) (st :: T).
(Seq $ SomeView' instr st) -> ViewsSet' instr st
UnsafeViewsSet ((Seq $ SomeView' instr st) -> ViewsSet' instr st)
-> (Seq $ SomeView' instr st) -> ViewsSet' instr st
forall a b. (a -> b) -> a -> b
$
      ViewsSet' instr st -> Seq $ SomeView' instr st
forall (instr :: [T] -> [T] -> *) (st :: T).
ViewsSet' instr st -> Seq $ SomeView' instr st
unViewsSet (Contract' instr cp st -> ViewsSet' instr st
forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
Contract' instr cp st -> ViewsSet' instr st
cViews Contract' instr cp st
contract) (Seq $ SomeView' instr st)
-> (SomeView' instr st -> SomeView' instr st)
-> Seq $ SomeView' instr st
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(SomeView View' instr arg st ret
v) -> View' instr arg st ret -> SomeView' instr st
forall (instr :: [T] -> [T] -> *) (arg :: T) (st :: T) (ret :: T).
View' instr arg st ret -> SomeView' instr st
SomeView View' instr arg st ret
v{ vCode :: ViewCode' instr arg st ret
vCode = ViewCode' instr arg st ret -> ViewCode' instr arg st ret
forall (arg :: T) (ret :: T).
ViewCode' instr arg st ret -> ViewCode' instr arg st ret
f (ViewCode' instr arg st ret -> ViewCode' instr arg st ret)
-> ViewCode' instr arg st ret -> ViewCode' instr arg st ret
forall a b. (a -> b) -> a -> b
$ View' instr arg st ret -> ViewCode' instr arg st ret
forall (instr :: [T] -> [T] -> *) (arg :: T) (st :: T) (ret :: T).
View' instr arg st ret -> ViewCode' instr arg st ret
vCode View' instr arg st ret
v }
  }

-- | Map all the blocks with some code in the contract.
mapContractCode
  :: (forall i o. instr i o -> instr i o)
  -> Contract' instr cp st
  -> Contract' instr cp st
mapContractCode :: (forall (i :: [T]) (o :: [T]). instr i o -> instr i o)
-> Contract' instr cp st -> Contract' instr cp st
mapContractCode forall (i :: [T]) (o :: [T]). instr i o -> instr i o
f =
  (ContractCode' instr cp st -> ContractCode' instr cp st)
-> Contract' instr cp st -> Contract' instr cp st
forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
(ContractCode' instr cp st -> ContractCode' instr cp st)
-> Contract' instr cp st -> Contract' instr cp st
mapContractCodeBlock ContractCode' instr cp st -> ContractCode' instr cp st
forall (i :: [T]) (o :: [T]). instr i o -> instr i o
f (Contract' instr cp st -> Contract' instr cp st)
-> (Contract' instr cp st -> Contract' instr cp st)
-> Contract' instr cp st
-> Contract' instr cp st
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (forall (arg :: T) (ret :: T).
 ViewCode' instr arg st ret -> ViewCode' instr arg st ret)
-> Contract' instr cp st -> Contract' instr cp st
forall (instr :: [T] -> [T] -> *) (st :: T) (cp :: T).
(forall (arg :: T) (ret :: T).
 ViewCode' instr arg st ret -> ViewCode' instr arg st ret)
-> Contract' instr cp st -> Contract' instr cp st
mapContractViewBlocks forall (i :: [T]) (o :: [T]). instr i o -> instr i o
forall (arg :: T) (ret :: T).
ViewCode' instr arg st ret -> ViewCode' instr arg st ret
f

-- | Map each typed contract fields by the given function and sort the output
-- based on the 'EntriesOrder'.
mapEntriesOrdered
  :: Contract' instr cp st
  -> (ParamNotes cp -> a)
  -> (Notes st -> a)
  -> (ContractCode' instr cp st -> a)
  -> [a]
mapEntriesOrdered :: Contract' instr cp st
-> (ParamNotes cp -> a)
-> (Notes st -> a)
-> (ContractCode' instr cp st -> a)
-> [a]
mapEntriesOrdered Contract{ContractCode' instr cp st
EntriesOrder
Notes st
ViewsSet' instr st
ParamNotes cp
cEntriesOrder :: EntriesOrder
cViews :: ViewsSet' instr st
cStoreNotes :: Notes st
cParamNotes :: ParamNotes cp
cCode :: ContractCode' instr cp st
cEntriesOrder :: forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
Contract' instr cp st -> EntriesOrder
cViews :: forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
Contract' instr cp st -> ViewsSet' instr st
cStoreNotes :: forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
Contract' instr cp st -> Notes st
cParamNotes :: forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
Contract' instr cp st -> ParamNotes cp
cCode :: forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
Contract' instr cp st -> ContractCode' instr cp st
..} ParamNotes cp -> a
fParam Notes st -> a
fStorage ContractCode' instr cp st -> a
fCode =
  ((Int, a) -> a) -> [(Int, a)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, a) -> a
forall a b. (a, b) -> b
snd
    ([(Int, a)] -> [a]) -> [(Int, a)] -> [a]
forall a b. (a -> b) -> a -> b
$ ((Int, a) -> Int) -> [(Int, a)] -> [(Int, a)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith (Int, a) -> Int
forall a b. (a, b) -> a
fst
        [ (Int
paramPos, ParamNotes cp -> a
fParam ParamNotes cp
cParamNotes)
        , (Int
storagePos, Notes st -> a
fStorage Notes st
cStoreNotes)
        , (Int
codePos, ContractCode' instr cp st -> a
fCode ContractCode' instr cp st
cCode)
        ]
  where
    (Int
paramPos, Int
storagePos, Int
codePos) = EntriesOrder -> (Int, Int, Int)
entriesOrderToInt EntriesOrder
cEntriesOrder