-- 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' (..)
  , mkContractCode
  , Contract' (..)
  , IsNotInView
  , giveNotInView
  , defaultContract
  , mapContractCode
  , mapContractCodeBlock
  , mapContractViewBlocks
  , mapContractCodeM
  , mapContractCodeBlockM
  , mapContractViewBlocksM
  ) where

import Data.Constraint (Dict(..))
import Data.Default (Default(..))
import GHC.TypeLits (TypeError, pattern Text)
import Unsafe.Coerce (unsafeCoerce)

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)

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 ]

-- | A wrapper for contract code. The newtype is mostly there to avoid
-- accidentally passing code from inside @ContractCode@ into a view for example,
-- as semantics are slightly different.
newtype ContractCode' instr cp st =
  ContractCode { unContractCode :: instr (ContractInp cp st) (ContractOut st) }

deriving stock instance Show (instr (ContractInp cp st) (ContractOut st))
  => Show (ContractCode' instr cp st)

deriving stock instance Eq (instr (ContractInp cp st) (ContractOut st))
  => Eq (ContractCode' instr cp st)

deriving newtype instance NFData (instr (ContractInp cp st) (ContractOut st))
  => NFData (ContractCode' instr cp st)

-- | A helper to construct @ContractCode'@. This helper provides the constraint
-- that the contract code is not in a view.
mkContractCode
  :: (IsNotInView => instr (ContractInp cp st) (ContractOut st))
  -> ContractCode' instr cp st
mkContractCode x = ContractCode $ giveNotInView x

-- | Constraint ensuring the given code does not appear on the top level of a
-- view. Some Michelson instructions are forbidden on the top level of views,
-- but allowed in main contract code, and also inside lambdas in views. Hence,
-- this constraint can be provided by 'mkContractCode' or by @mkVLam@.
class IsNotInView

-- NB: This instance is a giant hack. It happens to work because explicit dicts
-- override other in-scope instances. The good news is, if this hack stops
-- working, we'll notice right away because morley will refuse to compile.
instance TypeError ('Text "Not allowed on the top level of a view") => IsNotInView

-- | An empty typeclass that has an in-scope instance that we @unsafeCoerce@
-- into 'IsNotInView' in 'giveNotInView'. Not intended to be exported.
--
-- Dicts of all empty classes are representationally equivalent, so this is
-- "safe" (as in we won't get segfaults).
class FakeClass
instance FakeClass

-- | Pull a constraint 'IsNotInView' out of thin air. Use this with caution,
-- as you could easily construct an invalid contract by using this directly.
giveNotInView :: (IsNotInView => r) -> r
giveNotInView = withDict (unsafeCoerce (Dict :: Dict FakeClass) :: Dict IsNotInView)

-- | 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)
  => (IsNotInView => instr (ContractInp cp st) (ContractOut st))
  -> Contract' instr cp st
defaultContract code = Contract
  { cCode = mkContractCode code
  , cParamNotes = starParamNotes
  , cStoreNotes = starNotes
  , cEntriesOrder = def
  , cViews = def
  }

-- | Transform contract @code@ block.
--
-- To map e.g. views too, see 'mapContractCode'.
mapContractCodeBlock
  :: (instr (ContractInp cp st) (ContractOut st)
    -> instr (ContractInp cp st) (ContractOut st))
  -> Contract' instr cp st
  -> Contract' instr cp st
mapContractCodeBlock f = runIdentity . mapContractCodeBlockM (pure . f)

-- | Transform contract @code@ block, monadic version.
--
-- To map e.g. views too, see 'mapContractCodeM'.
mapContractCodeBlockM
  :: Monad m
  => (instr (ContractInp cp st) (ContractOut st)
    -> m (instr (ContractInp cp st) (ContractOut st)))
  -> Contract' instr cp st
  -> m (Contract' instr cp st)
mapContractCodeBlockM f contract = do
  code <- case cCode contract of ContractCode c -> ContractCode <$> f c
  pure contract { cCode = code }

mapContractViewBlocks
  :: (forall arg ret. ViewCode' instr arg st ret -> ViewCode' instr arg st ret)
  -> Contract' instr cp st
  -> Contract' instr cp st
mapContractViewBlocks f = runIdentity . mapContractViewBlocksM (pure . f)

mapContractViewBlocksM
  :: Monad m
  => (forall arg ret. ViewCode' instr arg st ret -> m (ViewCode' instr arg st ret))
  -> Contract' instr cp st
  -> m (Contract' instr cp st)
mapContractViewBlocksM f contract = do
  views <- ViewsSet <$> forM (unViewsSet (cViews contract)) \(SomeView v) -> do
    code <- f $ vCode v
    pure $ SomeView v{ vCode = code }
  pure contract{ cViews = views }

-- | 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 = runIdentity . mapContractCodeM (pure . f)

-- | Map all the blocks with some code in the contract, monadic version.
mapContractCodeM
  :: Monad m
  => (forall i o. instr i o -> m (instr i o))
  -> Contract' instr cp st
  -> m (Contract' instr cp st)
mapContractCodeM f = mapContractCodeBlockM f <=< mapContractViewBlocksM f