module Lorentz.UStore.Migration.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
data SlBatchType
= SlbtData
| SlbtLambda
| SlbtCustom
| SlbtUnknown
deriving stock (Show, Eq)
slbtIsData :: SlBatchType -> Bool
slbtIsData = \case { SlbtData -> True; _ -> False }
data SlBatchInfo = SlBatchInfo
{ slbiType :: SlBatchType
, slbiActions :: [Text]
}
instance Buildable SlBatchInfo where
build (SlBatchInfo ty actions) = mconcat
[ build @Text $ case ty of
SlbtData -> color Blue "[data]"
SlbtLambda -> color Green "[code]"
SlbtCustom -> color Yellow "[custom]"
SlbtUnknown -> color Red "[unknown]"
, " "
, case actions of
[] -> "-"
[a] -> build a
as -> foldMap (\a -> "\n * " <> build a) as
]
mbSeparateLambdas :: MigrationBatching [] SlBatchInfo
mbSeparateLambdas = MigrationBatching $ \atoms ->
let
atomsWithType = atoms <&> \a -> (atomType a, a)
(dataAtoms, otherAtoms) = L.partition (slbtIsData . fst) atomsWithType
dataMigration =
( SlBatchInfo SlbtData (nubCounting $ maName . snd <$> dataAtoms)
, manualConcatMigrationScripts (maScript . snd <$> dataAtoms)
)
otherMigrations =
[ (SlBatchInfo ty [maName atom], maScript atom)
| (ty, atom) <- otherAtoms
]
in dataMigration : otherMigrations
where
atomType :: MigrationAtom -> SlBatchType
atomType = chooseType . maActionsDesc
chooseType :: [DMigrationActionDesc] -> SlBatchType
chooseType = \case
[] -> SlbtUnknown
xs | all isLambda xs -> SlbtLambda
xs | all (not . isAddLambda) xs -> SlbtData
| otherwise -> SlbtCustom
isLambda :: DMigrationActionDesc -> Bool
isLambda = \case { TLambda{} -> True; _ -> False } . manFieldType
isAddLambda :: DMigrationActionDesc -> Bool
isAddLambda a = and
[ isLambda a
, case manAction a of { DAddAction _ -> True; _ -> False }
]
nubCounting :: [Text] -> [Text]
nubCounting = \case
[] -> []
x : xs ->
let ((length -> repetitions), others) = L.partition (== x) xs
x' = if repetitions == 0
then x
else x <> " (x" <> show (repetitions + 1) <> ")"
in x' : nubCounting others