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

module Lorentz.Run
  ( CompilationOptions(..)
  , defaultCompilationOptions

  , compileLorentz
  , compileLorentzWithOptions

  , Contract(..)
  , defaultContract
  , compileLorentzContract

  , interpretLorentzInstr
  , interpretLorentzLambda

  , analyzeLorentz
  ) where

import Data.Constraint ((\\))
import Data.Default (def)
import Data.Vinyl.Core (Rec(..))

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

-- | Options to control Lorentz to Michelson compilation.
data CompilationOptions = CompilationOptions
  { CompilationOptions -> Maybe OptimizerConf
coOptimizerConf :: Maybe OptimizerConf
  -- ^ Config for Michelson optimizer.
  , CompilationOptions -> (Bool, MText -> MText)
coStringTransformer :: (Bool, MText -> MText)
  -- ^ Function to transform strings with. See 'transformStringsLorentz'.
  , CompilationOptions -> (Bool, ByteString -> ByteString)
coBytesTransformer :: (Bool, ByteString -> ByteString)
  -- ^ Function to transform byte strings with. See 'transformBytesLorentz'.
  }

-- | Runs Michelson optimizer with default config and does not touch strings and bytes.
defaultCompilationOptions :: CompilationOptions
defaultCompilationOptions :: CompilationOptions
defaultCompilationOptions = $WCompilationOptions :: Maybe OptimizerConf
-> (Bool, MText -> MText)
-> (Bool, ByteString -> ByteString)
-> CompilationOptions
CompilationOptions
  { coOptimizerConf :: Maybe OptimizerConf
coOptimizerConf = OptimizerConf -> Maybe OptimizerConf
forall a. a -> Maybe a
Just OptimizerConf
forall a. Default a => a
def
  , coStringTransformer :: (Bool, MText -> MText)
coStringTransformer = (Bool
False, MText -> MText
forall a. a -> a
id)
  , coBytesTransformer :: (Bool, ByteString -> ByteString)
coBytesTransformer = (Bool
False, ByteString -> ByteString
forall a. a -> a
id)
  }

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

-- | Compile Lorentz code, optionally running the optimizer, string and byte transformers.
compileLorentzWithOptions :: CompilationOptions -> (inp :-> out) -> Instr (ToTs inp) (ToTs out)
compileLorentzWithOptions :: CompilationOptions -> (inp :-> out) -> Instr (ToTs inp) (ToTs out)
compileLorentzWithOptions CompilationOptions{..} =
  (Instr (ToTs inp) (ToTs out) -> Instr (ToTs inp) (ToTs out))
-> (OptimizerConf
    -> Instr (ToTs inp) (ToTs out) -> Instr (ToTs inp) (ToTs out))
-> Maybe OptimizerConf
-> Instr (ToTs inp) (ToTs out)
-> Instr (ToTs inp) (ToTs out)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Instr (ToTs inp) (ToTs out) -> Instr (ToTs inp) (ToTs out)
forall a. a -> a
id OptimizerConf
-> Instr (ToTs inp) (ToTs out) -> Instr (ToTs inp) (ToTs out)
forall (inp :: [T]) (out :: [T]).
OptimizerConf -> Instr inp out -> Instr inp out
optimizeWithConf Maybe OptimizerConf
coOptimizerConf
  (Instr (ToTs inp) (ToTs out) -> Instr (ToTs inp) (ToTs out))
-> ((inp :-> out) -> Instr (ToTs inp) (ToTs out))
-> (inp :-> out)
-> Instr (ToTs inp) (ToTs out)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (inp :-> out) -> Instr (ToTs inp) (ToTs out)
forall (inp :: [*]) (out :: [*]).
(inp :-> out) -> Instr (ToTs inp) (ToTs out)
iAnyCode
  ((inp :-> out) -> Instr (ToTs inp) (ToTs out))
-> ((inp :-> out) -> inp :-> out)
-> (inp :-> out)
-> Instr (ToTs inp) (ToTs out)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> (MText -> MText) -> (inp :-> out) -> inp :-> out)
-> (Bool, MText -> MText) -> (inp :-> out) -> inp :-> out
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Bool -> (MText -> MText) -> (inp :-> out) -> inp :-> out
forall (inp :: [*]) (out :: [*]).
Bool -> (MText -> MText) -> (inp :-> out) -> inp :-> out
transformStringsLorentz (Bool, MText -> MText)
coStringTransformer
  ((inp :-> out) -> inp :-> out)
-> ((inp :-> out) -> inp :-> out) -> (inp :-> out) -> inp :-> out
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool
 -> (ByteString -> ByteString) -> (inp :-> out) -> inp :-> out)
-> (Bool, ByteString -> ByteString) -> (inp :-> out) -> inp :-> out
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Bool -> (ByteString -> ByteString) -> (inp :-> out) -> inp :-> out
forall (inp :: [*]) (out :: [*]).
Bool -> (ByteString -> ByteString) -> (inp :-> out) -> inp :-> out
transformBytesLorentz (Bool, ByteString -> ByteString)
coBytesTransformer

-- | 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 Contract cp st = Contract
  { Contract cp st -> ContractCode cp st
cCode :: ContractCode cp st
    -- ^ The contract itself.
  , Contract cp st -> Bool
cDisableInitialCast :: 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).
  , Contract cp st -> CompilationOptions
cCompilationOptions :: CompilationOptions
  -- ^ General compilation options for the Lorentz compiler.
  }

-- | Compile contract with 'defaultCompilationOptions' and 'cDisableInitialCast' set to @False@.
defaultContract :: ContractCode cp st -> Contract cp st
defaultContract :: ContractCode cp st -> Contract cp st
defaultContract code :: ContractCode cp st
code = $WContract :: forall cp st.
ContractCode cp st -> Bool -> CompilationOptions -> Contract cp st
Contract
  { cCode :: ContractCode cp st
cCode = ContractCode cp st
code
  , cDisableInitialCast :: Bool
cDisableInitialCast = Bool
False
  , cCompilationOptions :: CompilationOptions
cCompilationOptions = CompilationOptions
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.
     (NiceParameterFull cp, NiceStorage st)
  => Contract cp st -> M.Contract (ToT cp) (ToT st)
compileLorentzContract :: Contract cp st -> Contract (ToT cp) (ToT st)
compileLorentzContract Contract{..} =
  $WContract :: forall (cp :: T) (st :: T).
(ParameterScope cp, StorageScope st) =>
ContractCode cp st
-> ParamNotes cp -> Notes st -> EntriesOrder -> Contract cp st
M.Contract
  { cCode :: ContractCode (ToT cp) (ToT st)
cCode = if (ParamNotes (ToT cp)
cpNotes ParamNotes (ToT cp) -> ParamNotes (ToT cp) -> Bool
forall a. Eq a => a -> a -> Bool
== ParamNotes (ToT cp)
forall (t :: T). SingI t => ParamNotes t
starParamNotes Bool -> Bool -> Bool
|| Bool
cDisableInitialCast)
      then -- If contract parameter type has no annotations or explicitly asked, we drop CAST.
        CompilationOptions
-> ContractCode cp st
-> Instr (ToTs '[(cp, st)]) (ToTs (ContractOut st))
forall (inp :: [*]) (out :: [*]).
CompilationOptions -> (inp :-> out) -> Instr (ToTs inp) (ToTs out)
compileLorentzWithOptions CompilationOptions
cCompilationOptions ContractCode cp st
cCode
      else -- Perform CAST otherwise.
        CompilationOptions
-> ContractCode cp st
-> Instr (ToTs '[(cp, st)]) (ToTs (ContractOut st))
forall (inp :: [*]) (out :: [*]).
CompilationOptions -> (inp :-> out) -> Instr (ToTs inp) (ToTs out)
compileLorentzWithOptions CompilationOptions
cCompilationOptions (Instr (ToTs '[(cp, st)]) (ToTs '[(cp, st)])
-> '[(cp, st)] :-> '[(cp, st)]
forall (inp :: [*]) (out :: [*]).
Instr (ToTs inp) (ToTs out) -> inp :-> out
I Instr (ToTs '[(cp, st)]) (ToTs '[(cp, st)])
forall (a :: T) (s :: [T]). SingI a => Instr (a : s) (a : s)
CAST ('[(cp, st)] :-> '[(cp, st)])
-> ContractCode cp st -> ContractCode cp st
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# ContractCode cp st
cCode :: ContractCode cp st)
  , cParamNotes :: ParamNotes (ToT cp)
cParamNotes = ParamNotes (ToT cp)
cpNotes
  , cStoreNotes :: Notes (ToT st)
cStoreNotes = FollowEntrypointFlag -> Notes (ToT st)
forall a. HasAnnotation a => FollowEntrypointFlag -> Notes (ToT a)
getAnnotation @st FollowEntrypointFlag
NotFollowEntrypoint
  , cEntriesOrder :: EntriesOrder
cEntriesOrder = EntriesOrder
U.canonicalEntriesOrder
  } ((KnownT (ToT cp), HasNoOp (ToT cp),
  HasNoNestedBigMaps (ToT cp)) =>
 Contract (ToT cp) (ToT st))
-> ((KnownValue cp,
     (KnownT (ToT cp), FailOnOperationFound (ContainsOp (ToT cp)),
      FailOnNestedBigMapsFound (ContainsNestedBigMaps (ToT cp))))
    :- (KnownT (ToT cp), HasNoOp (ToT cp),
        HasNoNestedBigMaps (ToT cp)))
-> Contract (ToT cp) (ToT st)
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ (KnownValue cp,
 (KnownT (ToT cp), FailOnOperationFound (ContainsOp (ToT cp)),
  FailOnNestedBigMapsFound (ContainsNestedBigMaps (ToT cp))))
:- (KnownT (ToT cp), HasNoOp (ToT cp), HasNoNestedBigMaps (ToT cp))
forall a. NiceParameter a :- ParameterScope (ToT a)
niceParameterEvi @cp
    ((KnownT (ToT st), HasNoOp (ToT st), HasNoNestedBigMaps (ToT st),
  HasNoContract (ToT st)) =>
 Contract (ToT cp) (ToT st))
-> ((HasAnnotation st, KnownValue st,
     (KnownT (ToT st), FailOnOperationFound (ContainsOp (ToT st)),
      FailOnNestedBigMapsFound (ContainsNestedBigMaps (ToT st)),
      FailOnContractFound (ContainsContract (ToT st))))
    :- (KnownT (ToT st), HasNoOp (ToT st), HasNoNestedBigMaps (ToT st),
        HasNoContract (ToT st)))
-> Contract (ToT cp) (ToT st)
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ (HasAnnotation st, KnownValue st,
 (KnownT (ToT st), FailOnOperationFound (ContainsOp (ToT st)),
  FailOnNestedBigMapsFound (ContainsNestedBigMaps (ToT st)),
  FailOnContractFound (ContainsContract (ToT st))))
:- (KnownT (ToT st), HasNoOp (ToT st), HasNoNestedBigMaps (ToT st),
    HasNoContract (ToT st))
forall a. NiceStorage a :- StorageScope (ToT a)
niceStorageEvi @st
  where
    cpNotes :: ParamNotes (ToT cp)
cpNotes = ParameterDeclaresEntrypoints cp => ParamNotes (ToT cp)
forall cp. ParameterDeclaresEntrypoints cp => ParamNotes (ToT cp)
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 :: ContractEnv
-> (inp :-> out)
-> Rec Identity inp
-> Either MichelsonFailed (Rec Identity out)
interpretLorentzInstr env :: ContractEnv
env ((inp :-> out) -> Instr (ToTs inp) (ToTs out)
forall (inp :: [*]) (out :: [*]).
(inp :-> out) -> Instr (ToTs inp) (ToTs out)
compileLorentz -> Instr (ToTs inp) (ToTs out)
instr) inp :: Rec Identity inp
inp =
  Rec Value (ToTs out) -> Rec Identity out
forall (ts :: [*]).
IsoValuesStack ts =>
Rec Value (ToTs ts) -> Rec Identity ts
fromValStack (Rec Value (ToTs out) -> Rec Identity out)
-> Either MichelsonFailed (Rec Value (ToTs out))
-> Either MichelsonFailed (Rec Identity out)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContractEnv
-> Instr (ToTs inp) (ToTs out)
-> Rec Value (ToTs inp)
-> Either MichelsonFailed (Rec Value (ToTs out))
forall (inp :: [T]) (out :: [T]).
ContractEnv
-> Instr inp out
-> Rec Value inp
-> Either MichelsonFailed (Rec Value out)
interpretInstr ContractEnv
env Instr (ToTs inp) (ToTs out)
instr (Rec Identity inp -> Rec Value (ToTs inp)
forall (ts :: [*]).
IsoValuesStack ts =>
Rec Identity ts -> Rec Value (ToTs ts)
toValStack Rec Identity inp
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 :: ContractEnv -> Lambda inp out -> inp -> Either MichelsonFailed out
interpretLorentzLambda env :: ContractEnv
env instr :: Lambda inp out
instr inp :: inp
inp = do
  Rec Identity '[out]
res <- ContractEnv
-> Lambda inp out
-> Rec Identity '[inp]
-> Either MichelsonFailed (Rec Identity '[out])
forall (inp :: [*]) (out :: [*]).
(IsoValuesStack inp, IsoValuesStack out) =>
ContractEnv
-> (inp :-> out)
-> Rec Identity inp
-> Either MichelsonFailed (Rec Identity out)
interpretLorentzInstr ContractEnv
env Lambda inp out
instr (inp -> Identity inp
forall a. a -> Identity a
Identity inp
inp Identity inp -> Rec Identity '[] -> Rec Identity '[inp]
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec Identity '[]
forall u (a :: u -> *). Rec a '[]
RNil)
  let Identity out :& RNil = Rec Identity '[out]
res
  out -> Either MichelsonFailed out
forall (m :: * -> *) a. Monad m => a -> m a
return out
out

-- | Lorentz version of analyzer.
analyzeLorentz :: inp :-> out -> AnalyzerRes
analyzeLorentz :: (inp :-> out) -> AnalyzerRes
analyzeLorentz = Instr (ToTs inp) (ToTs out) -> AnalyzerRes
forall (inp :: [T]) (out :: [T]). Instr inp out -> AnalyzerRes
analyze (Instr (ToTs inp) (ToTs out) -> AnalyzerRes)
-> ((inp :-> out) -> Instr (ToTs inp) (ToTs out))
-> (inp :-> out)
-> AnalyzerRes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (inp :-> out) -> Instr (ToTs inp) (ToTs out)
forall (inp :: [*]) (out :: [*]).
(inp :-> out) -> Instr (ToTs inp) (ToTs out)
compileLorentz