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

-- | Different approaches to batching.
--
-- For now we do not support perfect batching because operation size evaluation
-- (as well as gas consumption evaluation) is not implemented yet.
-- The only non-trivial batching implementation we provide is
-- 'mbSeparateLambdas'.
module Lorentz.UStore.Migration.Batching
  ( -- * Separate-lambdas batching
    SlBatchType (..)
  , SlBatchInfo (..)
  , mbSeparateLambdas
  ) where

import qualified Data.List as L
import Fmt (Buildable(..))
import System.Console.Pretty (Color(..), color)

import Lorentz.UStore.Migration.Base
import Michelson.Typed

----------------------------------------------------------------------------
-- Separating lambdas
----------------------------------------------------------------------------

-- | Type of batch.
data SlBatchType
  = SlbtData
    -- ^ Addition of any type of data.
  | SlbtLambda
    -- ^ Addition of code.
  | SlbtCustom
    -- ^ Several joined actions of different types.
  | SlbtUnknown
    -- ^ No information to chooseType about batching.
    -- This means that the given action does not contain 'DMigrationActionDesc'.
  deriving stock (Int -> SlBatchType -> ShowS
[SlBatchType] -> ShowS
SlBatchType -> String
(Int -> SlBatchType -> ShowS)
-> (SlBatchType -> String)
-> ([SlBatchType] -> ShowS)
-> Show SlBatchType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SlBatchType] -> ShowS
$cshowList :: [SlBatchType] -> ShowS
show :: SlBatchType -> String
$cshow :: SlBatchType -> String
showsPrec :: Int -> SlBatchType -> ShowS
$cshowsPrec :: Int -> SlBatchType -> ShowS
Show, SlBatchType -> SlBatchType -> Bool
(SlBatchType -> SlBatchType -> Bool)
-> (SlBatchType -> SlBatchType -> Bool) -> Eq SlBatchType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SlBatchType -> SlBatchType -> Bool
$c/= :: SlBatchType -> SlBatchType -> Bool
== :: SlBatchType -> SlBatchType -> Bool
$c== :: SlBatchType -> SlBatchType -> Bool
Eq)

slbtIsData :: SlBatchType -> Bool
slbtIsData :: SlBatchType -> Bool
slbtIsData = \case { SlbtData -> Bool
True; _ -> Bool
False }

data SlBatchInfo = SlBatchInfo
  { SlBatchInfo -> SlBatchType
slbiType :: SlBatchType
  , SlBatchInfo -> [Text]
slbiActions :: [Text]
  }

instance Buildable SlBatchInfo where
  build :: SlBatchInfo -> Builder
build (SlBatchInfo ty :: SlBatchType
ty actions :: [Text]
actions) = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ Buildable Text => Text -> Builder
forall p. Buildable p => p -> Builder
build @Text (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ case SlBatchType
ty of
        SlbtData -> Color -> Text -> Text
forall a. Pretty a => Color -> a -> a
color Color
Blue "[data]"
        SlbtLambda -> Color -> Text -> Text
forall a. Pretty a => Color -> a -> a
color Color
Green "[code]"
        SlbtCustom -> Color -> Text -> Text
forall a. Pretty a => Color -> a -> a
color Color
Yellow "[custom]"
        SlbtUnknown -> Color -> Text -> Text
forall a. Pretty a => Color -> a -> a
color Color
Red "[unknown]"
    , " "
    , case [Text]
actions of
        [] -> "-"
        [a :: Text
a] -> Text -> Builder
forall p. Buildable p => p -> Builder
build Text
a
        as :: [Text]
as -> (Element [Text] -> Builder) -> [Text] -> Builder
forall t m. (Container t, Monoid m) => (Element t -> m) -> t -> m
foldMap (\a :: Element [Text]
a -> "\n  * " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
forall p. Buildable p => p -> Builder
build Text
Element [Text]
a) [Text]
as
    ]

-- | Puts all data updates in one batch, and all lambdas in separate batches,
-- one per batch.
--
-- The reason for such behaviour is that in production contracts amount of
-- changed data (be it in contract initialization or contract upgrade) is small,
-- while stored entrypoints are huge and addition of even one entrypoint often
-- barely fits into gas limit.
mbSeparateLambdas :: MigrationBatching [] SlBatchInfo
mbSeparateLambdas :: MigrationBatching [] SlBatchInfo
mbSeparateLambdas = ([MigrationAtom] -> [(SlBatchInfo, MigrationScript_)])
-> MigrationBatching [] SlBatchInfo
forall (structure :: * -> *) batchInfo.
([MigrationAtom] -> structure (batchInfo, MigrationScript_))
-> MigrationBatching structure batchInfo
MigrationBatching (([MigrationAtom] -> [(SlBatchInfo, MigrationScript_)])
 -> MigrationBatching [] SlBatchInfo)
-> ([MigrationAtom] -> [(SlBatchInfo, MigrationScript_)])
-> MigrationBatching [] SlBatchInfo
forall a b. (a -> b) -> a -> b
$ \atoms :: [MigrationAtom]
atoms ->
  let
    atomsWithType :: [(SlBatchType, MigrationAtom)]
atomsWithType = [MigrationAtom]
atoms [MigrationAtom]
-> (MigrationAtom -> (SlBatchType, MigrationAtom))
-> [(SlBatchType, MigrationAtom)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \a :: MigrationAtom
a -> (MigrationAtom -> SlBatchType
atomType MigrationAtom
a, MigrationAtom
a)
    (dataAtoms :: [(SlBatchType, MigrationAtom)]
dataAtoms, otherAtoms :: [(SlBatchType, MigrationAtom)]
otherAtoms) = ((SlBatchType, MigrationAtom) -> Bool)
-> [(SlBatchType, MigrationAtom)]
-> ([(SlBatchType, MigrationAtom)], [(SlBatchType, MigrationAtom)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (SlBatchType -> Bool
slbtIsData (SlBatchType -> Bool)
-> ((SlBatchType, MigrationAtom) -> SlBatchType)
-> (SlBatchType, MigrationAtom)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SlBatchType, MigrationAtom) -> SlBatchType
forall a b. (a, b) -> a
fst) [(SlBatchType, MigrationAtom)]
atomsWithType
    dataMigration :: (SlBatchInfo, MigrationScript_)
dataMigration =
      ( SlBatchType -> [Text] -> SlBatchInfo
SlBatchInfo SlBatchType
SlbtData ([Text] -> [Text]
nubCounting ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ MigrationAtom -> Text
maName (MigrationAtom -> Text)
-> ((SlBatchType, MigrationAtom) -> MigrationAtom)
-> (SlBatchType, MigrationAtom)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SlBatchType, MigrationAtom) -> MigrationAtom
forall a b. (a, b) -> b
snd ((SlBatchType, MigrationAtom) -> Text)
-> [(SlBatchType, MigrationAtom)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SlBatchType, MigrationAtom)]
dataAtoms)
      , [MigrationScript_] -> MigrationScript_
forall os ns. [MigrationScript os ns] -> MigrationScript os ns
manualConcatMigrationScripts (MigrationAtom -> MigrationScript_
maScript (MigrationAtom -> MigrationScript_)
-> ((SlBatchType, MigrationAtom) -> MigrationAtom)
-> (SlBatchType, MigrationAtom)
-> MigrationScript_
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SlBatchType, MigrationAtom) -> MigrationAtom
forall a b. (a, b) -> b
snd ((SlBatchType, MigrationAtom) -> MigrationScript_)
-> [(SlBatchType, MigrationAtom)] -> [MigrationScript_]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SlBatchType, MigrationAtom)]
dataAtoms)
      )
    otherMigrations :: [(SlBatchInfo, MigrationScript_)]
otherMigrations =
      [ (SlBatchType -> [Text] -> SlBatchInfo
SlBatchInfo SlBatchType
ty [MigrationAtom -> Text
maName MigrationAtom
atom], MigrationAtom -> MigrationScript_
maScript MigrationAtom
atom)
      | (ty :: SlBatchType
ty, atom :: MigrationAtom
atom) <- [(SlBatchType, MigrationAtom)]
otherAtoms
      ]
  in (SlBatchInfo, MigrationScript_)
dataMigration (SlBatchInfo, MigrationScript_)
-> [(SlBatchInfo, MigrationScript_)]
-> [(SlBatchInfo, MigrationScript_)]
forall a. a -> [a] -> [a]
: [(SlBatchInfo, MigrationScript_)]
otherMigrations
  where
    atomType :: MigrationAtom -> SlBatchType
    atomType :: MigrationAtom -> SlBatchType
atomType = [DMigrationActionDesc] -> SlBatchType
chooseType ([DMigrationActionDesc] -> SlBatchType)
-> (MigrationAtom -> [DMigrationActionDesc])
-> MigrationAtom
-> SlBatchType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MigrationAtom -> [DMigrationActionDesc]
maActionsDesc

    chooseType :: [DMigrationActionDesc] -> SlBatchType
    chooseType :: [DMigrationActionDesc] -> SlBatchType
chooseType = \case
      [] -> SlBatchType
SlbtUnknown
      xs :: [DMigrationActionDesc]
xs | (Element [DMigrationActionDesc] -> Bool)
-> [DMigrationActionDesc] -> Bool
forall t. Container t => (Element t -> Bool) -> t -> Bool
all Element [DMigrationActionDesc] -> Bool
DMigrationActionDesc -> Bool
isLambda [DMigrationActionDesc]
xs -> SlBatchType
SlbtLambda
      xs :: [DMigrationActionDesc]
xs | (Bool -> Bool
not (Bool -> Bool)
-> ([DMigrationActionDesc] -> Bool)
-> [DMigrationActionDesc]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Element [DMigrationActionDesc] -> Bool)
-> [DMigrationActionDesc] -> Bool
forall t. Container t => (Element t -> Bool) -> t -> Bool
any Element [DMigrationActionDesc] -> Bool
DMigrationActionDesc -> Bool
isAddLambda) [DMigrationActionDesc]
xs -> SlBatchType
SlbtData
         | Bool
otherwise -> SlBatchType
SlbtCustom

    isLambda :: DMigrationActionDesc -> Bool
    isLambda :: DMigrationActionDesc -> Bool
isLambda = \case { TLambda{} -> Bool
True; _ -> Bool
False } (T -> Bool)
-> (DMigrationActionDesc -> T) -> DMigrationActionDesc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DMigrationActionDesc -> T
manFieldType

    isAddLambda :: DMigrationActionDesc -> Bool
    isAddLambda :: DMigrationActionDesc -> Bool
isAddLambda a :: DMigrationActionDesc
a = [Bool] -> Bool
forall t. (Container t, Element t ~ Bool) => t -> Bool
and
      [ DMigrationActionDesc -> Bool
isLambda DMigrationActionDesc
a
      , case DMigrationActionDesc -> DMigrationActionType
manAction DMigrationActionDesc
a of { DAddAction _ -> Bool
True; _ -> Bool
False }
      ]

-- | Similar to 'nub', counts number of invocations and attaches to text entry.
--
-- >>> nubCounting ["a", "b", "a"]
-- ["a (x2)", "b"]
nubCounting :: [Text] -> [Text]
nubCounting :: [Text] -> [Text]
nubCounting = \case
  [] -> []
  x :: Text
x : xs :: [Text]
xs ->
    let (([Text] -> Int
forall t. Container t => t -> Int
length -> Int
repetitions), others :: [Text]
others) = (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
x) [Text]
xs
        x' :: Text
x' = if Int
repetitions Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
             then Text
x
             else Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " (x" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (Int
repetitions Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"
    in Text
x' Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
nubCounting [Text]
others