Run.hs

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

{- | Lorentz contracts compilation.

Compilation in one scheme:

@
                    mkContract
                  mkContractWith
  ContractCode  -----------------→  Contract
 (Lorentz code)              (ready compiled contract)
        ↓                                ↑
        ↓                                ↑
defaultContractData            compileLorentzContract
   ContractData                          ↑
        ↓         ContractData           ↑
       (Lorentz code + compilation options)
@

-}
module Lorentz.Run
  ( Contract(..)
  , toMichelsonContract
  , defaultContract

  , CompilationOptions(..)
  , defaultCompilationOptions
  , intactCompilationOptions
  , coBytesTransformerL
  , coOptimizerConfL
  , coStringTransformerL

  , compileLorentz
  , compileLorentzWithOptions

  , mkContract
  , mkContractWith

  , ContractData(..)
  , defaultContractData
  , compileLorentzContract
  , cdCodeL
  , coDisableInitialCastL
  , cdCompilationOptionsL

  , interpretLorentzInstr
  , interpretLorentzLambda

  , analyzeLorentz
  ) where

import Control.Lens.Type as Lens (Lens, Lens')
import Data.Constraint ((\\))
import Data.Default (def)
import Data.Vinyl.Core (Rec(..))

import Lorentz.Annotation
import Lorentz.Base
import Lorentz.Constraints
import Lorentz.Doc
import Lorentz.Entrypoints
import Lorentz.Entrypoints.Doc
import Michelson.Analyzer (AnalyzerRes, analyze)
import Michelson.Interpret
import Michelson.Optimizer (OptimizerConf, optimizeWithConf)
import Michelson.Text (MText)
import Michelson.Typed (Instr(..), IsoValue, IsoValuesStack(..), ToTs, starParamNotes)
import qualified Michelson.Typed as M (Contract(..))
import qualified Michelson.Untyped as U (canonicalEntriesOrder)
import Util.Lens

-- | Options to control Lorentz to Michelson compilation.
data CompilationOptions = CompilationOptions
  { coOptimizerConf :: Maybe OptimizerConf
  -- ^ Config for Michelson optimizer.
  , coStringTransformer :: (Bool, MText -> MText)
  -- ^ Function to transform strings with. See 'transformStringsLorentz'.
  , coBytesTransformer :: (Bool, ByteString -> ByteString)
  -- ^ Function to transform byte strings with. See 'transformBytesLorentz'.
  , coDisableInitialCast :: Bool
  -- ^ Flag which defines whether compiled Michelson contract
  -- will have @CAST@ (which drops parameter annotations)
  -- as a first instruction. Note that when
  -- flag is false, there still may be no @CAST@ (in case
  -- when parameter type has no annotations).
  }

-- | Runs Michelson optimizer with default config and does not touch strings and bytes.
defaultCompilationOptions :: CompilationOptions
defaultCompilationOptions = CompilationOptions
  { coOptimizerConf = Just def
  , coStringTransformer = (False, id)
  , coBytesTransformer = (False, id)
  , coDisableInitialCast = False
  }

-- | Leave contract without any modifications. For testing purposes.
intactCompilationOptions :: CompilationOptions
intactCompilationOptions = CompilationOptions
  { coOptimizerConf = Nothing
  , coStringTransformer = (False, id)
  , coBytesTransformer = (False, id)
  , coDisableInitialCast = False
  }

-- | For use outside of Lorentz. Will use 'defaultCompilationOptions'.
compileLorentz :: (inp :-> out) -> Instr (ToTs inp) (ToTs out)
compileLorentz = compileLorentzWithOptions defaultCompilationOptions

-- | Compile Lorentz code, optionally running the optimizer, string and byte transformers.
compileLorentzWithOptions :: CompilationOptions -> (inp :-> out) -> Instr (ToTs inp) (ToTs out)
compileLorentzWithOptions CompilationOptions{..} =
  maybe id optimizeWithConf coOptimizerConf
  . iAnyCode
  . uncurry transformStringsLorentz coStringTransformer
  . uncurry transformBytesLorentz coBytesTransformer

-- | Construct and compile Lorentz contract.
--
-- This is an alias for 'mkContract'.
defaultContract
  :: (NiceParameterFull cp, NiceStorage st)
  => ContractCode cp st -> Contract cp st
defaultContract code =
  compileLorentzContract $ ContractData code defaultCompilationOptions

-- | Construct and compile Lorentz contract.
--
-- Note that this accepts code with initial and final stacks unpaired for
-- simplicity.
mkContract
  :: (NiceParameterFull cp, NiceStorage st)
  => ContractCode cp st -> Contract cp st
mkContract = mkContractWith defaultCompilationOptions

-- | Version of 'mkContract' that accepts custom compilation options.
mkContractWith
  :: (NiceParameterFull cp, NiceStorage st)
  => CompilationOptions -> ContractCode cp st -> Contract cp st
mkContractWith opts code =
  compileLorentzContract $ ContractData code opts

-- | Code for a contract along with compilation options for the Lorentz compiler.
--
-- It is expected that a 'Contract' is one packaged entity, wholly controlled by its author.
-- Therefore the author should be able to set all options that control contract's behavior.
--
-- This helps ensure that a given contract will be interpreted in the same way in all
-- environments, like production and testing.
--
-- Raw 'ContractCode' should not be used for distribution of contracts.
data ContractData cp st = (NiceParameterFull cp, NiceStorage st) => ContractData
  { cdCode :: ContractCode cp st
  -- ^ The contract itself.
  , cdCompilationOptions :: CompilationOptions
  -- ^ General compilation options for the Lorentz compiler.
  }

-- | Compile contract with 'defaultCompilationOptions'.
defaultContractData
  :: forall cp st. (NiceParameterFull cp, NiceStorage st)
  => ContractCode cp st -> ContractData cp st
defaultContractData code = ContractData
  { cdCode = code
  , cdCompilationOptions = defaultCompilationOptions
  }

-- | Compile a whole contract to Michelson.
--
-- Note that compiled contract can be ill-typed in terms of Michelson code
-- when some of the compilation options are used (e.g. when 'ccoDisableInitialCast'
-- is @True@, resulted contract can be ill-typed).
-- However, compilation with 'defaultContractCompilationOptions' should be valid.
compileLorentzContract
  :: forall cp st. ContractData cp st -> Contract cp st
compileLorentzContract ContractData{..} = Contract{..}
  where
    cMichelsonContract = M.Contract
      { cCode = if (cpNotes == starParamNotes || coDisableInitialCast cdCompilationOptions)
          then -- If contract parameter type has no annotations or explicitly asked, we drop CAST.
            compileLorentzWithOptions cdCompilationOptions cdCode
          else -- Perform CAST otherwise.
            compileLorentzWithOptions cdCompilationOptions (I CAST # cdCode :: ContractCode cp st)
      , cParamNotes = cpNotes
      , cStoreNotes = getAnnotation @st NotFollowEntrypoint
      , cEntriesOrder = U.canonicalEntriesOrder
      } \\ niceParameterEvi @cp
        \\ niceStorageEvi @st

    cDocumentedCode = finalizeParamCallingDoc' (Proxy @cp) cdCode

    cpNotes = parameterEntrypointsToNotes @cp

-- | Interpret a Lorentz instruction, for test purposes. Note that this does not run the
-- optimizer.
interpretLorentzInstr
  :: (IsoValuesStack inp, IsoValuesStack out)
  => ContractEnv
  -> inp :-> out
  -> Rec Identity inp
  -> Either MichelsonFailed (Rec Identity out)
interpretLorentzInstr env (compileLorentz -> instr) inp =
  fromValStack <$> interpretInstr env instr (toValStack inp)

-- | Like 'interpretLorentzInstr', but works on lambda rather than
-- arbitrary instruction.
interpretLorentzLambda
  :: (IsoValue inp, IsoValue out)
  => ContractEnv
  -> Lambda inp out
  -> inp
  -> Either MichelsonFailed out
interpretLorentzLambda env instr inp = do
  res <- interpretLorentzInstr env instr (Identity inp :& RNil)
  let Identity out :& RNil = res
  return out

instance ContainsDoc (ContractData cp st) where
  buildDocUnfinalized =
    buildDocUnfinalized . compileLorentzContract
instance ContainsUpdateableDoc (ContractData cp st) where
  modifyDocEntirely how c =
    c{ cdCode = modifyDocEntirely how (cdCode c) }

-- | Lorentz version of analyzer.
analyzeLorentz :: inp :-> out -> AnalyzerRes
analyzeLorentz = analyze . compileLorentz

makeLensesWith postfixLFields ''CompilationOptions

cdCodeL ::
  forall cp st cp1 st1. (NiceParameterFull cp1, NiceStorage st1) =>
  Lens.Lens (ContractData cp st) (ContractData cp1 st1) (ContractCode cp st) (ContractCode cp1 st1)
cdCodeL f (ContractData code options)
  = fmap (`ContractData` options) (f code)

cdCompilationOptionsL ::
  forall cp st.
  Lens.Lens' (ContractData cp st) CompilationOptions
cdCompilationOptionsL f (ContractData code options)
  = fmap (ContractData code) (f options)