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

-- '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
  { cCode         :: ContractCode' instr cp st
  , cParamNotes   :: ParamNotes cp
  , cStoreNotes   :: Notes st
  , cViews        :: ViewsSet' instr st
  , 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 a b c d e) = rnf (a, b, c, d, e)

defaultContract :: (ParameterScope cp, StorageScope st) => ContractCode' instr cp st -> Contract' instr cp st
defaultContract code = Contract
  { cCode = code
  , cParamNotes = starParamNotes
  , cStoreNotes = starNotes
  , cEntriesOrder = def
  , cViews = 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 f contract = contract { cCode = f $ cCode contract }

mapContractViewBlocks
  :: (forall arg ret. ViewCode' instr arg st ret -> ViewCode' instr arg st ret)
  -> Contract' instr cp st
  -> Contract' instr cp st
mapContractViewBlocks f contract = contract
  { cViews = UnsafeViewsSet $
      unViewsSet (cViews contract) <&> \(SomeView v) -> SomeView v{ vCode = f $ vCode 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 f =
  mapContractCodeBlock f .
  mapContractViewBlocks 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{..} fParam fStorage fCode =
  fmap snd
    $ sortWith fst
        [ (paramPos, fParam cParamNotes)
        , (storagePos, fStorage cStoreNotes)
        , (codePos, fCode cCode)
        ]
  where
    (paramPos, storagePos, codePos) = entriesOrderToInt cEntriesOrder