-- 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
  , mapEntriesOrdered
  ) 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, 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 ]

-- | 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 { forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
ContractCode' instr cp st
-> instr (ContractInp cp st) (ContractOut st)
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 :: forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
(IsNotInView => instr (ContractInp cp st) (ContractOut st))
-> ContractCode' instr cp st
mkContractCode IsNotInView => instr (ContractInp cp st) (ContractOut st)
x = instr (ContractInp cp st) (ContractOut st)
-> ContractCode' instr cp st
forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
instr (ContractInp cp st) (ContractOut st)
-> ContractCode' instr cp st
ContractCode (instr (ContractInp cp st) (ContractOut st)
 -> ContractCode' instr cp st)
-> instr (ContractInp cp st) (ContractOut st)
-> ContractCode' instr cp st
forall a b. (a -> b) -> a -> b
$ (IsNotInView => instr (ContractInp cp st) (ContractOut st))
-> instr (ContractInp cp st) (ContractOut st)
forall r. (IsNotInView => r) -> r
giveNotInView IsNotInView => instr (ContractInp cp st) (ContractOut st)
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
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 :: forall r. (IsNotInView => r) -> r
giveNotInView = Dict IsNotInView -> (IsNotInView => r) -> r
forall (c :: Constraint) e r. HasDict c e => e -> (c => r) -> r
withDict (Dict FakeClass -> Dict IsNotInView
forall a b. a -> b
unsafeCoerce (Dict FakeClass
forall (a :: Constraint). a => Dict a
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
  { forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
Contract' instr cp st -> ContractCode' instr cp st
cCode         :: ContractCode' instr cp st
  , forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
Contract' instr cp st -> ParamNotes cp
cParamNotes   :: ParamNotes cp
  , forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
Contract' instr cp st -> Notes st
cStoreNotes   :: Notes st
  , forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
Contract' instr cp st -> ViewsSet' instr st
cViews        :: ViewsSet' instr st
  , forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
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)
  => (IsNotInView => instr (ContractInp cp st) (ContractOut st))
  -> Contract' instr cp st
defaultContract :: forall (cp :: T) (st :: T) (instr :: [T] -> [T] -> *).
(ParameterScope cp, StorageScope st) =>
(IsNotInView => instr (ContractInp cp st) (ContractOut st))
-> Contract' instr cp st
defaultContract IsNotInView => instr (ContractInp cp st) (ContractOut 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 = (IsNotInView => instr (ContractInp cp st) (ContractOut st))
-> ContractCode' instr cp st
forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
(IsNotInView => instr (ContractInp cp st) (ContractOut st))
-> ContractCode' instr cp st
mkContractCode IsNotInView => instr (ContractInp cp st) (ContractOut 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
  :: (instr (ContractInp cp st) (ContractOut st)
    -> instr (ContractInp cp st) (ContractOut st))
  -> Contract' instr cp st
  -> Contract' instr cp st
mapContractCodeBlock :: forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
(instr (ContractInp cp st) (ContractOut st)
 -> instr (ContractInp cp st) (ContractOut st))
-> Contract' instr cp st -> Contract' instr cp st
mapContractCodeBlock instr (ContractInp cp st) (ContractOut st)
-> instr (ContractInp cp st) (ContractOut st)
f Contract' instr cp st
contract = Contract' instr cp st
contract { cCode :: ContractCode' instr cp st
cCode =
  case 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 of
    ContractCode instr (ContractInp cp st) (ContractOut st)
c -> instr (ContractInp cp st) (ContractOut st)
-> ContractCode' instr cp st
forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
instr (ContractInp cp st) (ContractOut st)
-> ContractCode' instr cp st
ContractCode (instr (ContractInp cp st) (ContractOut st)
 -> ContractCode' instr cp st)
-> instr (ContractInp cp st) (ContractOut st)
-> ContractCode' instr cp st
forall a b. (a -> b) -> a -> b
$ instr (ContractInp cp st) (ContractOut st)
-> instr (ContractInp cp st) (ContractOut st)
f instr (ContractInp cp st) (ContractOut st)
c }

mapContractViewBlocks
  :: (forall arg ret. ViewCode' instr arg st ret -> ViewCode' instr arg st ret)
  -> Contract' instr cp st
  -> Contract' instr cp st
mapContractViewBlocks :: 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 (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 (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
(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 =
  (instr (ContractInp cp st) (ContractOut st)
 -> instr (ContractInp cp st) (ContractOut st))
-> Contract' instr cp st -> Contract' instr cp st
forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
(instr (ContractInp cp st) (ContractOut st)
 -> instr (ContractInp cp st) (ContractOut st))
-> Contract' instr cp st -> Contract' instr cp st
mapContractCodeBlock instr (ContractInp cp st) (ContractOut st)
-> instr (ContractInp cp st) (ContractOut 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 :: forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T) a.
Contract' instr cp st
-> (ParamNotes cp -> a)
-> (Notes st -> a)
-> (ContractCode' instr cp st -> a)
-> [a]
mapEntriesOrdered Contract{EntriesOrder
Notes st
ViewsSet' instr st
ParamNotes cp
ContractCode' instr cp st
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