{-# LANGUAGE NoRebindableSyntax #-}
module Lorentz.UStore.Migration.Batching
(
SlBatchType (..)
, SlBatchInfo (..)
, mbSeparateLambdas
) where
import Prelude
import Colourista (blue, formatWith, green, red, yellow)
import qualified Data.List as L
import Fmt (Buildable(..))
import Lorentz.UStore.Migration.Base
import Michelson.Typed
data SlBatchType
= SlbtData
| SlbtLambda
| SlbtCustom
| SlbtUnknown
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 { SlBatchType
SlbtData -> Bool
True; SlBatchType
_ -> Bool
False }
data SlBatchInfo = SlBatchInfo
{ SlBatchInfo -> SlBatchType
slbiType :: SlBatchType
, SlBatchInfo -> [Text]
slbiActions :: [Text]
}
instance Buildable SlBatchInfo where
build :: SlBatchInfo -> Builder
build (SlBatchInfo SlBatchType
ty [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
SlBatchType
SlbtData -> [Text] -> Text -> Text
forall str. (IsString str, Semigroup str) => [str] -> str -> str
formatWith [Text
forall str. IsString str => str
blue] Text
"[data]"
SlBatchType
SlbtLambda -> [Text] -> Text -> Text
forall str. (IsString str, Semigroup str) => [str] -> str -> str
formatWith [Text
forall str. IsString str => str
green] Text
"[code]"
SlBatchType
SlbtCustom -> [Text] -> Text -> Text
forall str. (IsString str, Semigroup str) => [str] -> str -> str
formatWith [Text
forall str. IsString str => str
yellow] Text
"[custom]"
SlBatchType
SlbtUnknown -> [Text] -> Text -> Text
forall str. (IsString str, Semigroup str) => [str] -> str -> str
formatWith [Text
forall str. IsString str => str
red] Text
"[unknown]"
, Builder
" "
, case [Text]
actions of
[] -> Builder
"-"
[Text
a] -> Text -> Builder
forall p. Buildable p => p -> Builder
build Text
a
[Text]
as -> (Element [Text] -> Builder) -> [Text] -> Builder
forall t m. (Container t, Monoid m) => (Element t -> m) -> t -> m
foldMap (\Element [Text]
a -> Builder
"\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
]
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
$ \[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
<&> \MigrationAtom
a -> (MigrationAtom -> SlBatchType
atomType MigrationAtom
a, MigrationAtom
a)
([(SlBatchType, MigrationAtom)]
dataAtoms, [(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)
| (SlBatchType
ty, 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
[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
[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; T
_ -> 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 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 Text
_ -> Bool
True; DMigrationActionType
_ -> Bool
False }
]
nubCounting :: [Text] -> [Text]
nubCounting :: [Text] -> [Text]
nubCounting = \case
[] -> []
Text
x : [Text]
xs ->
let (([Text] -> Int
forall t. Container t => t -> Int
length -> Int
repetitions), [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
== Int
0
then Text
x
else Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (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
+ Int
1) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
in Text
x' Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
nubCounting [Text]
others