module Lorentz.Run
  ( CompilationOptions(..)
  , compileLorentz
  , compileLorentzContract
  , compileLorentzContractWithOptions
  , interpretLorentzInstr
  , interpretLorentzLambda
  , analyzeLorentz
  ) where

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

import Lorentz.Base
import Lorentz.Constraints
import Lorentz.EntryPoints
import Michelson.Analyzer (AnalyzerRes, analyze)
import Michelson.Interpret
import Michelson.Typed
  (FullContract(..), Instr(..), IsoValue, IsoValuesStack(..), ParamNotes(..), ToT, ToTs, isStar,
  starNotes, unParamNotes)

-- | For use outside of Lorentz.
compileLorentz :: (inp :-> out) -> Instr (ToTs inp) (ToTs out)
compileLorentz = iAnyCode

-- | Version of 'compileLorentz' specialized to instruction corresponding to
-- contract code.
compileLorentzContract
  :: forall cp st.
     (NiceParameterFull cp, NiceStorage st)
  => Contract cp st -> FullContract (ToT cp) (ToT st)
compileLorentzContract =
  compileLorentzContractWithOptions defaultCompilationOptions

data CompilationOptions = CompilationOptions
  { 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 can be no @CAST@ (in case
  -- when parameter type has no annotations).
  }

defaultCompilationOptions :: CompilationOptions
defaultCompilationOptions = CompilationOptions { coDisableInitialCast = False }

-- | Version on 'compileLorentzContract' which accepts @CompilationOptions@.
--
-- Note that compiled contract can be ill-typed in terms of Michelson code
-- when some of the compilation options are used (e.g. when coDoInitialCast
-- is False, resulted contract can be ill-typed).
-- However, compilation with @defaultCompilationOptions@ should be valid.
compileLorentzContractWithOptions
  :: forall cp st.
     (NiceParameterFull cp, NiceStorage st)
  => CompilationOptions -> Contract cp st -> FullContract (ToT cp) (ToT st)
compileLorentzContractWithOptions CompilationOptions{..} contract =
  FullContract
  { fcCode = if (isStar (unParamNotes cpNotes) || coDisableInitialCast)
      then -- If contract parameter type has no annotations or explicitly asked, we drop CAST.
        compileLorentz contract
      else -- Perform CAST otherwise.
        compileLorentz (I CAST # contract :: Contract cp st)
  , fcParamNotesSafe = cpNotes
  , fcStoreNotes = starNotes
  } \\ niceParameterEvi @cp
    \\ niceStorageEvi @st
  where
    cpNotes = parameterEntryPointsToNotes @cp

-- | Interpret a Lorentz instruction, for test purposes.
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

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