-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | Foundation of Lorentz development.
module Lorentz.Base
  ( (:->) (..)
  , type (%>)
  , type (&)
  , (#)
  , pattern I
  , pattern FI
  , iGenericIf
  , iAnyCode
  , iNonFailingCode
  , iMapAnyCode
  , iForceNotFail

  , parseLorentzValue
  , transformStringsLorentz
  , transformBytesLorentz
  , optimizeLorentz
  , optimizeLorentzWithConf
  , MapLorentzInstr (..)

  , ContractOut
  , ContractCode (..)
  , mkContractCode
  , IsNotInView
  , SomeContractCode (..)
  , ViewCode
  , Contract (..)
  , toMichelsonContract
  , Fn
  ) where

import Data.Default (def)
import Fmt (Buildable(..))

import Lorentz.Constraints
import Morley.Micheline (ToExpression(..))
import Morley.Michelson.Optimizer (OptimizerConf, optimizeWithConf)
import Morley.Michelson.Parser (MichelsonSource, ParserException, parseExpandValue)
import Morley.Michelson.Preprocess (transformBytes, transformStrings)
import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDocExtended)
import Morley.Michelson.Text (MText)
import Morley.Michelson.TypeCheck (TCError, typeCheckValue, typeCheckingWith)
import Morley.Michelson.Typed
  (Instr(..), IsNotInView, IsoValue(..), Operation, RemFail(..), ToT, ToTs, Value, rfAnyInstr,
  rfMapAnyInstr, rfMerge)
import Morley.Michelson.Typed qualified as M (Contract)
import Morley.Michelson.Typed.Contract (giveNotInView)
import Morley.Michelson.Untyped qualified as U

-- | Alias for instruction which hides inner types representation via @T@.
newtype (inp :: [Type]) :-> (out :: [Type]) = LorentzInstr
  { forall (inp :: [*]) (out :: [*]).
(inp :-> out) -> RemFail Instr (ToTs inp) (ToTs out)
unLorentzInstr :: RemFail Instr (ToTs inp) (ToTs out)
  } deriving newtype (Int -> (inp :-> out) -> ShowS
[inp :-> out] -> ShowS
(inp :-> out) -> String
(Int -> (inp :-> out) -> ShowS)
-> ((inp :-> out) -> String)
-> ([inp :-> out] -> ShowS)
-> Show (inp :-> out)
forall (inp :: [*]) (out :: [*]). Int -> (inp :-> out) -> ShowS
forall (inp :: [*]) (out :: [*]). [inp :-> out] -> ShowS
forall (inp :: [*]) (out :: [*]). (inp :-> out) -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [inp :-> out] -> ShowS
$cshowList :: forall (inp :: [*]) (out :: [*]). [inp :-> out] -> ShowS
show :: (inp :-> out) -> String
$cshow :: forall (inp :: [*]) (out :: [*]). (inp :-> out) -> String
showsPrec :: Int -> (inp :-> out) -> ShowS
$cshowsPrec :: forall (inp :: [*]) (out :: [*]). Int -> (inp :-> out) -> ShowS
Show, (inp :-> out) -> (inp :-> out) -> Bool
((inp :-> out) -> (inp :-> out) -> Bool)
-> ((inp :-> out) -> (inp :-> out) -> Bool) -> Eq (inp :-> out)
forall (inp :: [*]) (out :: [*]).
(inp :-> out) -> (inp :-> out) -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: (inp :-> out) -> (inp :-> out) -> Bool
$c/= :: forall (inp :: [*]) (out :: [*]).
(inp :-> out) -> (inp :-> out) -> Bool
== :: (inp :-> out) -> (inp :-> out) -> Bool
$c== :: forall (inp :: [*]) (out :: [*]).
(inp :-> out) -> (inp :-> out) -> Bool
Eq)
infixr 1 :->

instance Buildable (inp :-> out) where
  build :: (inp :-> out) -> Builder
build = (inp :-> out) -> Builder
forall a. RenderDoc a => a -> Builder
buildRenderDocExtended

instance RenderDoc (inp :-> out) where
  renderDoc :: RenderContext -> (inp :-> out) -> Doc
renderDoc RenderContext
context = RenderContext -> Instr (ToTs inp) (ToTs out) -> Doc
forall a. RenderDoc a => RenderContext -> a -> Doc
renderDoc RenderContext
context (Instr (ToTs inp) (ToTs out) -> Doc)
-> ((inp :-> out) -> Instr (ToTs inp) (ToTs out))
-> (inp :-> out)
-> Doc
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

instance NFData (i :-> o) where
  rnf :: (i :-> o) -> ()
rnf (LorentzInstr RemFail Instr (ToTs i) (ToTs o)
i) = RemFail Instr (ToTs i) (ToTs o) -> ()
forall a. NFData a => a -> ()
rnf RemFail Instr (ToTs i) (ToTs o)
i

instance Semigroup (s :-> s) where
  <> :: (s :-> s) -> (s :-> s) -> s :-> s
(<>) = (s :-> s) -> (s :-> s) -> s :-> s
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
(#)
instance Monoid (s :-> s) where
  mempty :: s :-> s
mempty = Instr (ToTs s) (ToTs s) -> s :-> s
forall (inp :: [*]) (out :: [*]).
Instr (ToTs inp) (ToTs out) -> inp :-> out
I Instr (ToTs s) (ToTs s)
forall (inp :: [T]). Instr inp inp
Nop

pattern I :: Instr (ToTs inp) (ToTs out) -> inp :-> out
pattern $bI :: forall (inp :: [*]) (out :: [*]).
Instr (ToTs inp) (ToTs out) -> inp :-> out
$mI :: forall {r} {inp :: [*]} {out :: [*]}.
(inp :-> out)
-> (Instr (ToTs inp) (ToTs out) -> r) -> (Void# -> r) -> r
I i = LorentzInstr (RfNormal i)

pattern FI :: (forall out'. Instr (ToTs inp) out') -> inp :-> out
pattern $bFI :: forall (inp :: [*]) (out :: [*]).
(forall (out' :: [T]). Instr (ToTs inp) out') -> inp :-> out
$mFI :: forall {r} {inp :: [*]} {out :: [*]}.
(inp :-> out)
-> ((forall (out' :: [T]). Instr (ToTs inp) out') -> r)
-> (Void# -> r)
-> r
FI i = LorentzInstr (RfAlwaysFails i)

{-# COMPLETE I, FI #-}

iGenericIf
  :: (forall s'. Instr (ToTs a) s' -> Instr (ToTs b) s' -> Instr (ToTs c) s')
  -> (a :-> s) -> (b :-> s) -> (c :-> s)
iGenericIf :: forall (a :: [*]) (b :: [*]) (c :: [*]) (s :: [*]).
(forall (s' :: [T]).
 Instr (ToTs a) s' -> Instr (ToTs b) s' -> Instr (ToTs c) s')
-> (a :-> s) -> (b :-> s) -> c :-> s
iGenericIf forall (s' :: [T]).
Instr (ToTs a) s' -> Instr (ToTs b) s' -> Instr (ToTs c) s'
merger (LorentzInstr RemFail Instr (ToTs a) (ToTs s)
instr1) (LorentzInstr RemFail Instr (ToTs b) (ToTs s)
instr2) =
  RemFail Instr (ToTs c) (ToTs s) -> c :-> s
forall (inp :: [*]) (out :: [*]).
RemFail Instr (ToTs inp) (ToTs out) -> inp :-> out
LorentzInstr ((forall (s' :: [T]).
 Instr (ToTs a) s' -> Instr (ToTs b) s' -> Instr (ToTs c) s')
-> RemFail Instr (ToTs a) (ToTs s)
-> RemFail Instr (ToTs b) (ToTs s)
-> RemFail Instr (ToTs c) (ToTs s)
forall {k} (instr :: k -> k -> *) (i1 :: k) (i2 :: k) (i3 :: k)
       (o :: k).
(forall (o' :: k). instr i1 o' -> instr i2 o' -> instr i3 o')
-> RemFail instr i1 o -> RemFail instr i2 o -> RemFail instr i3 o
rfMerge forall (s' :: [T]).
Instr (ToTs a) s' -> Instr (ToTs b) s' -> Instr (ToTs c) s'
merger RemFail Instr (ToTs a) (ToTs s)
instr1 RemFail Instr (ToTs b) (ToTs s)
instr2)

iAnyCode :: inp :-> out -> Instr (ToTs inp) (ToTs out)
iAnyCode :: forall (inp :: [*]) (out :: [*]).
(inp :-> out) -> Instr (ToTs inp) (ToTs out)
iAnyCode = RemFail Instr (ToTs inp) (ToTs out) -> Instr (ToTs inp) (ToTs out)
forall {k} (instr :: k -> k -> *) (i :: k) (o :: k).
RemFail instr i o -> instr i o
rfAnyInstr (RemFail Instr (ToTs inp) (ToTs out)
 -> Instr (ToTs inp) (ToTs out))
-> ((inp :-> out) -> RemFail Instr (ToTs inp) (ToTs out))
-> (inp :-> out)
-> Instr (ToTs inp) (ToTs out)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (inp :-> out) -> RemFail Instr (ToTs inp) (ToTs out)
forall (inp :: [*]) (out :: [*]).
(inp :-> out) -> RemFail Instr (ToTs inp) (ToTs out)
unLorentzInstr

iNonFailingCode :: HasCallStack => inp :-> out -> Instr (ToTs inp) (ToTs out)
iNonFailingCode :: forall (inp :: [*]) (out :: [*]).
HasCallStack =>
(inp :-> out) -> Instr (ToTs inp) (ToTs out)
iNonFailingCode (I Instr (ToTs inp) (ToTs out)
i) = Instr (ToTs inp) (ToTs out)
i
iNonFailingCode (FI forall (out' :: [T]). Instr (ToTs inp) out'
_) = Text -> Instr (ToTs inp) (ToTs out)
forall a. HasCallStack => Text -> a
error Text
"Always failing code cannot appear here"

iMapAnyCode
  :: (forall o'. Instr (ToTs i1) o' -> Instr (ToTs i2) o')
  -> (i1 :-> o)
  -> (i2 :-> o)
iMapAnyCode :: forall (i1 :: [*]) (i2 :: [*]) (o :: [*]).
(forall (o' :: [T]). Instr (ToTs i1) o' -> Instr (ToTs i2) o')
-> (i1 :-> o) -> i2 :-> o
iMapAnyCode forall (o' :: [T]). Instr (ToTs i1) o' -> Instr (ToTs i2) o'
f (LorentzInstr RemFail Instr (ToTs i1) (ToTs o)
i) = RemFail Instr (ToTs i2) (ToTs o) -> i2 :-> o
forall (inp :: [*]) (out :: [*]).
RemFail Instr (ToTs inp) (ToTs out) -> inp :-> out
LorentzInstr (RemFail Instr (ToTs i2) (ToTs o) -> i2 :-> o)
-> RemFail Instr (ToTs i2) (ToTs o) -> i2 :-> o
forall a b. (a -> b) -> a -> b
$ (forall (o' :: [T]). Instr (ToTs i1) o' -> Instr (ToTs i2) o')
-> RemFail Instr (ToTs i1) (ToTs o)
-> RemFail Instr (ToTs i2) (ToTs o)
forall {k} (instr :: k -> k -> *) (i1 :: k) (i2 :: k) (o :: k).
(forall (o' :: k). instr i1 o' -> instr i2 o')
-> RemFail instr i1 o -> RemFail instr i2 o
rfMapAnyInstr forall (o' :: [T]). Instr (ToTs i1) o' -> Instr (ToTs i2) o'
f RemFail Instr (ToTs i1) (ToTs o)
i

iForceNotFail :: (i :-> o) -> (i :-> o)
iForceNotFail :: forall (i :: [*]) (o :: [*]). (i :-> o) -> i :-> o
iForceNotFail = Instr (ToTs i) (ToTs o) -> i :-> o
forall (inp :: [*]) (out :: [*]).
Instr (ToTs inp) (ToTs out) -> inp :-> out
I (Instr (ToTs i) (ToTs o) -> i :-> o)
-> ((i :-> o) -> Instr (ToTs i) (ToTs o)) -> (i :-> o) -> i :-> o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i :-> o) -> Instr (ToTs i) (ToTs o)
forall (inp :: [*]) (out :: [*]).
(inp :-> out) -> Instr (ToTs inp) (ToTs out)
iAnyCode

-- There is also @instance IsoValue (i :-> o)@ in the "Lorentz.Zip" module.

-- | Alias for ':->', seems to make signatures more readable sometimes.
--
-- Let's someday decide which one of these two should remain.
type (%>) = (:->)
infixr 1 %>

type ContractOut st = '[([Operation], st)]

-- | Wrap contract code capturing the constraint that the code is not inside a
-- view.
newtype ContractCode cp st = ContractCode
  { forall cp st. ContractCode cp st -> '[(cp, st)] :-> ContractOut st
unContractCode :: '[(cp, st)] :-> ContractOut st }
  deriving stock (Int -> ContractCode cp st -> ShowS
[ContractCode cp st] -> ShowS
ContractCode cp st -> String
(Int -> ContractCode cp st -> ShowS)
-> (ContractCode cp st -> String)
-> ([ContractCode cp st] -> ShowS)
-> Show (ContractCode cp st)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall cp st. Int -> ContractCode cp st -> ShowS
forall cp st. [ContractCode cp st] -> ShowS
forall cp st. ContractCode cp st -> String
showList :: [ContractCode cp st] -> ShowS
$cshowList :: forall cp st. [ContractCode cp st] -> ShowS
show :: ContractCode cp st -> String
$cshow :: forall cp st. ContractCode cp st -> String
showsPrec :: Int -> ContractCode cp st -> ShowS
$cshowsPrec :: forall cp st. Int -> ContractCode cp st -> ShowS
Show, ContractCode cp st -> ContractCode cp st -> Bool
(ContractCode cp st -> ContractCode cp st -> Bool)
-> (ContractCode cp st -> ContractCode cp st -> Bool)
-> Eq (ContractCode cp st)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall cp st. ContractCode cp st -> ContractCode cp st -> Bool
/= :: ContractCode cp st -> ContractCode cp st -> Bool
$c/= :: forall cp st. ContractCode cp st -> ContractCode cp st -> Bool
== :: ContractCode cp st -> ContractCode cp st -> Bool
$c== :: forall cp st. ContractCode cp st -> ContractCode cp st -> Bool
Eq)
  deriving newtype ContractCode cp st -> ()
(ContractCode cp st -> ()) -> NFData (ContractCode cp st)
forall a. (a -> ()) -> NFData a
forall cp st. ContractCode cp st -> ()
rnf :: ContractCode cp st -> ()
$crnf :: forall cp st. ContractCode cp st -> ()
NFData

data SomeContractCode where
  SomeContractCode
    :: (NiceParameter cp, NiceStorage st)
    => ContractCode cp st
    -> SomeContractCode

type ViewCode arg st ret = '[(arg, st)] :-> '[ret]

-- | A helper to construct 'ContractCode' that provides 'IsNotInView' constraint.
mkContractCode :: (IsNotInView => '[(cp, st)] :-> ContractOut st) -> ContractCode cp st
mkContractCode :: forall cp st.
(IsNotInView => '[(cp, st)] :-> ContractOut st)
-> ContractCode cp st
mkContractCode IsNotInView => '[(cp, st)] :-> ContractOut st
x = ('[(cp, st)] :-> ContractOut st) -> ContractCode cp st
forall cp st.
('[(cp, st)] :-> ContractOut st) -> ContractCode cp st
ContractCode (('[(cp, st)] :-> ContractOut st) -> ContractCode cp st)
-> ('[(cp, st)] :-> ContractOut st) -> ContractCode cp st
forall a b. (a -> b) -> a -> b
$ (IsNotInView => '[(cp, st)] :-> ContractOut st)
-> '[(cp, st)] :-> ContractOut st
forall r. (IsNotInView => r) -> r
giveNotInView IsNotInView => '[(cp, st)] :-> ContractOut st
x

-- | Compiled Lorentz contract.
--
-- Note, that the views argument (views descriptor) is added comparing to the
-- Michelson. In Michelson, ability to call a view is fully checked at runtime,
-- but in Lorentz we want to make calls safer at compile-time.
data Contract cp st vd =
  (NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd) =>
  Contract
  { -- | Ready contract code.
    forall cp st vd. Contract cp st vd -> Contract (ToT cp) (ToT st)
cMichelsonContract :: M.Contract (ToT cp) (ToT st)

    -- | Contract that contains documentation.
    --
    -- We have to keep it separately, since optimizer is free to destroy
    -- documentation blocks.
    -- Also, it is not 'Lorentz.Doc.ContractDoc' but Lorentz code because the latter is
    -- easier to modify.
  , forall cp st vd. Contract cp st vd -> ContractCode cp st
cDocumentedCode :: ~(ContractCode cp st)
  }

deriving stock instance Show (Contract cp st vd)
deriving stock instance Eq (Contract cp st vd)
instance NFData (Contract cp st vd) where
  rnf :: Contract cp st vd -> ()
rnf (Contract Contract (ToT cp) (ToT st)
c ContractCode cp st
d) = Contract (ToT cp) (ToT st) -> ()
forall a. NFData a => a -> ()
rnf Contract (ToT cp) (ToT st)
c () -> () -> ()
`seq` ContractCode cp st -> ()
forall a. NFData a => a -> ()
rnf ContractCode cp st
d

instance ToExpression (Contract cp st vd) where
  toExpression :: Contract cp st vd -> Expression
toExpression = Contract (ToT cp) (ToT st) -> Expression
forall a. ToExpression a => a -> Expression
toExpression (Contract (ToT cp) (ToT st) -> Expression)
-> (Contract cp st vd -> Contract (ToT cp) (ToT st))
-> Contract cp st vd
-> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Contract cp st vd -> Contract (ToT cp) (ToT st)
forall cp st vd. Contract cp st vd -> Contract (ToT cp) (ToT st)
toMichelsonContract

-- | Demote Lorentz 'Contract' to Michelson typed 'M.Contract'.
toMichelsonContract :: Contract cp st vd -> M.Contract (ToT cp) (ToT st)
toMichelsonContract :: forall cp st vd. Contract cp st vd -> Contract (ToT cp) (ToT st)
toMichelsonContract = Contract cp st vd -> Contract (ToT cp) (ToT st)
forall cp st vd. Contract cp st vd -> Contract (ToT cp) (ToT st)
cMichelsonContract

-- | An alias for @':@.
--
-- We discourage its use as this hinders reading error messages
-- (the compiler inserts unnecessary parentheses and indentation).
type (&) (a :: Type) (b :: [Type]) = a ': b
infixr 2 &

-- | Function composition for instructions.
--
-- Note that, unlike Morley's 'Morley.Michelson.Typed.Instr.:#' operator, '(#)' is left-associative.
(#) :: (a :-> b) -> (b :-> c) -> a :-> c
I Instr (ToTs a) (ToTs b)
l # :: forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# I Instr (ToTs b) (ToTs c)
r = Instr (ToTs a) (ToTs c) -> a :-> c
forall (inp :: [*]) (out :: [*]).
Instr (ToTs inp) (ToTs out) -> inp :-> out
I (Instr (ToTs a) (ToTs b)
l Instr (ToTs a) (ToTs b)
-> Instr (ToTs b) (ToTs c) -> Instr (ToTs a) (ToTs c)
forall (inp :: [T]) (b :: [T]) (out :: [T]).
Instr inp b -> Instr b out -> Instr inp out
`Seq` Instr (ToTs b) (ToTs c)
r)
I Instr (ToTs a) (ToTs b)
l # FI forall (out' :: [T]). Instr (ToTs b) out'
r = (forall (out' :: [T]). Instr (ToTs a) out') -> a :-> c
forall (inp :: [*]) (out :: [*]).
(forall (out' :: [T]). Instr (ToTs inp) out') -> inp :-> out
FI (Instr (ToTs a) (ToTs b)
l Instr (ToTs a) (ToTs b)
-> Instr (ToTs b) out' -> Instr (ToTs a) out'
forall (inp :: [T]) (b :: [T]) (out :: [T]).
Instr inp b -> Instr b out -> Instr inp out
`Seq` Instr (ToTs b) out'
forall (out' :: [T]). Instr (ToTs b) out'
r)
FI forall (out' :: [T]). Instr (ToTs a) out'
l # b :-> c
_ = (forall (out' :: [T]). Instr (ToTs a) out') -> a :-> c
forall (inp :: [*]) (out :: [*]).
(forall (out' :: [T]). Instr (ToTs inp) out') -> inp :-> out
FI forall (out' :: [T]). Instr (ToTs a) out'
l
infixl 8 #

-- | An instruction sequence taking one stack element as input and returning one
-- stack element as output. Essentially behaves as a Michelson lambda without
-- any additional semantical meaning.
--
-- The reason for this distinction is Michelson lambdas allow instructions
-- inside them that might be forbidden in the outer scope. This type doesn't add
-- any such conditions.
type Fn a b = '[a] :-> '[b]

-- | Errors that can happen during parsing into a Lorentz value.
data ParseLorentzError
  = ParseLorentzParseError ParserException
  | ParseLorentzTypecheckError TCError
  deriving stock (Int -> ParseLorentzError -> ShowS
[ParseLorentzError] -> ShowS
ParseLorentzError -> String
(Int -> ParseLorentzError -> ShowS)
-> (ParseLorentzError -> String)
-> ([ParseLorentzError] -> ShowS)
-> Show ParseLorentzError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseLorentzError] -> ShowS
$cshowList :: [ParseLorentzError] -> ShowS
show :: ParseLorentzError -> String
$cshow :: ParseLorentzError -> String
showsPrec :: Int -> ParseLorentzError -> ShowS
$cshowsPrec :: Int -> ParseLorentzError -> ShowS
Show, ParseLorentzError -> ParseLorentzError -> Bool
(ParseLorentzError -> ParseLorentzError -> Bool)
-> (ParseLorentzError -> ParseLorentzError -> Bool)
-> Eq ParseLorentzError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParseLorentzError -> ParseLorentzError -> Bool
$c/= :: ParseLorentzError -> ParseLorentzError -> Bool
== :: ParseLorentzError -> ParseLorentzError -> Bool
$c== :: ParseLorentzError -> ParseLorentzError -> Bool
Eq)

instance Buildable ParseLorentzError where
  build :: ParseLorentzError -> Builder
build =
    \case
      ParseLorentzParseError ParserException
e -> ParserException -> Builder
forall p. Buildable p => p -> Builder
build ParserException
e
      ParseLorentzTypecheckError TCError
e -> TCError -> Builder
forall p. Buildable p => p -> Builder
build TCError
e

-- | Parse textual representation of a Michelson value and turn it
-- into corresponding Haskell value.
--
-- Note: it won't work in some complex cases, e. g. if there is a
-- lambda which uses an instruction which depends on current
-- contract's type. Obviously it can not work, because we don't have
-- any information about a contract to which this value belongs (there
-- is no such contract at all).
parseLorentzValue
  :: forall v. KnownValue v
  => MichelsonSource
  -> Text
  -> Either ParseLorentzError v
parseLorentzValue :: forall v.
KnownValue v =>
MichelsonSource -> Text -> Either ParseLorentzError v
parseLorentzValue MichelsonSource
src =
  (Value (ToT v) -> v)
-> Either ParseLorentzError (Value (ToT v))
-> Either ParseLorentzError v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value (ToT v) -> v
forall a. IsoValue a => Value (ToT a) -> a
fromVal (Either ParseLorentzError (Value (ToT v))
 -> Either ParseLorentzError v)
-> (Text -> Either ParseLorentzError (Value (ToT v)))
-> Text
-> Either ParseLorentzError v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Either ParseLorentzError (Value (ToT v))
toTyped (Value -> Either ParseLorentzError (Value (ToT v)))
-> (Text -> Either ParseLorentzError Value)
-> Text
-> Either ParseLorentzError (Value (ToT v))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (ParserException -> ParseLorentzError)
-> Either ParserException Value -> Either ParseLorentzError Value
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParserException -> ParseLorentzError
ParseLorentzParseError (Either ParserException Value -> Either ParseLorentzError Value)
-> (Text -> Either ParserException Value)
-> Text
-> Either ParseLorentzError Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MichelsonSource -> Text -> Either ParserException Value
parseExpandValue MichelsonSource
src)
  where
    toTyped :: U.Value -> Either ParseLorentzError (Value (ToT v))
    toTyped :: Value -> Either ParseLorentzError (Value (ToT v))
toTyped =
      (TCError -> ParseLorentzError)
-> Either TCError (Value (ToT v))
-> Either ParseLorentzError (Value (ToT v))
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TCError -> ParseLorentzError
ParseLorentzTypecheckError (Either TCError (Value (ToT v))
 -> Either ParseLorentzError (Value (ToT v)))
-> (Value -> Either TCError (Value (ToT v)))
-> Value
-> Either ParseLorentzError (Value (ToT v))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      TypeCheckOptions
-> TypeCheckResult (Value (ToT v))
-> Either TCError (Value (ToT v))
forall a. TypeCheckOptions -> TypeCheckResult a -> Either TCError a
typeCheckingWith TypeCheckOptions
forall a. Default a => a
def (TypeCheckResult (Value (ToT v)) -> Either TCError (Value (ToT v)))
-> (Value -> TypeCheckResult (Value (ToT v)))
-> Value
-> Either TCError (Value (ToT v))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Value -> TypeCheckResult (Value (ToT v))
forall (t :: T). SingI t => Value -> TypeCheckResult (Value t)
typeCheckValue

-- | Lorentz version of 'transformStrings'.
transformStringsLorentz ::
  Bool -> (MText -> MText) -> inp :-> out -> inp :-> out
transformStringsLorentz :: forall (inp :: [*]) (out :: [*]).
Bool -> (MText -> MText) -> (inp :-> out) -> inp :-> out
transformStringsLorentz Bool
goToValues MText -> MText
f =
  (forall (o' :: [T]). Instr (ToTs inp) o' -> Instr (ToTs inp) o')
-> (inp :-> out) -> inp :-> out
forall (i1 :: [*]) (i2 :: [*]) (o :: [*]).
(forall (o' :: [T]). Instr (ToTs i1) o' -> Instr (ToTs i2) o')
-> (i1 :-> o) -> i2 :-> o
iMapAnyCode ((forall (o' :: [T]). Instr (ToTs inp) o' -> Instr (ToTs inp) o')
 -> (inp :-> out) -> inp :-> out)
-> (forall (o' :: [T]). Instr (ToTs inp) o' -> Instr (ToTs inp) o')
-> (inp :-> out)
-> inp :-> out
forall a b. (a -> b) -> a -> b
$ Bool
-> (MText -> MText) -> Instr (ToTs inp) o' -> Instr (ToTs inp) o'
forall (inp :: [T]) (out :: [T]).
Bool -> (MText -> MText) -> Instr inp out -> Instr inp out
transformStrings Bool
goToValues MText -> MText
f

-- | Lorentz version of 'transformBytes'.
transformBytesLorentz ::
  Bool -> (ByteString -> ByteString) -> inp :-> out -> inp :-> out
transformBytesLorentz :: forall (inp :: [*]) (out :: [*]).
Bool -> (ByteString -> ByteString) -> (inp :-> out) -> inp :-> out
transformBytesLorentz Bool
goToValues ByteString -> ByteString
f =
  (forall (o' :: [T]). Instr (ToTs inp) o' -> Instr (ToTs inp) o')
-> (inp :-> out) -> inp :-> out
forall (i1 :: [*]) (i2 :: [*]) (o :: [*]).
(forall (o' :: [T]). Instr (ToTs i1) o' -> Instr (ToTs i2) o')
-> (i1 :-> o) -> i2 :-> o
iMapAnyCode ((forall (o' :: [T]). Instr (ToTs inp) o' -> Instr (ToTs inp) o')
 -> (inp :-> out) -> inp :-> out)
-> (forall (o' :: [T]). Instr (ToTs inp) o' -> Instr (ToTs inp) o')
-> (inp :-> out)
-> inp :-> out
forall a b. (a -> b) -> a -> b
$ Bool
-> (ByteString -> ByteString)
-> Instr (ToTs inp) o'
-> Instr (ToTs inp) o'
forall (inp :: [T]) (out :: [T]).
Bool
-> (ByteString -> ByteString) -> Instr inp out -> Instr inp out
transformBytes Bool
goToValues ByteString -> ByteString
f

optimizeLorentzWithConf
  :: OptimizerConf
  -> inp :-> out
  -> inp :-> out
optimizeLorentzWithConf :: forall (inp :: [*]) (out :: [*]).
OptimizerConf -> (inp :-> out) -> inp :-> out
optimizeLorentzWithConf OptimizerConf
conf =
  -- Optimizer can produce dead code.
  -- Example: @push True # if_ failWith nop # ...@ will fold to @failWith # ...@.
  -- But let's not care about this case for now until need in it fires.
  (forall (o' :: [T]). Instr (ToTs inp) o' -> Instr (ToTs inp) o')
-> (inp :-> out) -> inp :-> out
forall (i1 :: [*]) (i2 :: [*]) (o :: [*]).
(forall (o' :: [T]). Instr (ToTs i1) o' -> Instr (ToTs i2) o')
-> (i1 :-> o) -> i2 :-> o
iMapAnyCode (OptimizerConf -> Instr (ToTs inp) o' -> Instr (ToTs inp) o'
forall (inp :: [T]) (out :: [T]).
OptimizerConf -> Instr inp out -> Instr inp out
optimizeWithConf OptimizerConf
conf)

optimizeLorentz
  :: inp :-> out
  -> inp :-> out
optimizeLorentz :: forall (i :: [*]) (o :: [*]). (i :-> o) -> i :-> o
optimizeLorentz = OptimizerConf -> (inp :-> out) -> inp :-> out
forall (inp :: [*]) (out :: [*]).
OptimizerConf -> (inp :-> out) -> inp :-> out
optimizeLorentzWithConf OptimizerConf
forall a. Default a => a
def

-- | Applicable for wrappers over Lorentz code.
class MapLorentzInstr instr where
  -- | Modify all the code under given entity.
  mapLorentzInstr :: (forall i o. (i :-> o) -> (i :-> o)) -> instr -> instr

instance MapLorentzInstr (i :-> o) where
  mapLorentzInstr :: (forall (i :: [*]) (o :: [*]). (i :-> o) -> i :-> o)
-> (i :-> o) -> i :-> o
mapLorentzInstr forall (i :: [*]) (o :: [*]). (i :-> o) -> i :-> o
f = (i :-> o) -> i :-> o
forall (i :: [*]) (o :: [*]). (i :-> o) -> i :-> o
f