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

-- | Product type Michelson layout optimized for non-dupable fields case.
module Lorentz.Layouts.NonDupable
  ( deriveSemiDupableGeneric
  ) where

import Language.Haskell.TH qualified as TH

import Lorentz.ADT (HasDupableGetters)
import Morley.Util.CustomGeneric
import Morley.Util.TH

-- | Produce 'Generic' instance for a datatype containing non-dupable and
-- plain dupable elements so that operations on this datatype
-- (like @getField@) remain optimal in average.
--
-- Derivation strategies available for 'customGeneric' suffer from a problem:
-- @getField@ is non-optimal as long as during its recursive descend it
-- operates with a non-dupable pairs subtree. 'deriveSemiDupableGeneric'
-- tries to keep all dupable elements in the left subtree of the root
-- (speeding up @getField@ on them), and all non-dupable elements in the right
-- subtree.
--
-- Prerequisites for calling this function:
--
-- 1. All the fields of dupable types must locate before all the fields of
--    non-dupable types.
-- 2. You have to supply the expected number of /non-dupable/ fields as an
--    argument.
--    We expect this number, not the number of dupable fields, since
--    non-dupable elements are rare and so are supposed to be updated
--    less often.
--
-- Unfortunatelly, there seems to be no decent way to see whether a type is
-- dupable or not at TH time, so we have to accept some information explicitly.
-- To ensure that this information is up to date, each time calling this
-- function __we encourage the user to also add a test__ using utilities from
-- "Lorentz.Test.DupableScan" module.
deriveSemiDupableGeneric :: String -> Int -> TH.DecsQ
deriveSemiDupableGeneric :: String -> Int -> DecsQ
deriveSemiDupableGeneric String
tyCtor Int
nonDupableFieldsNum = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> DecsQ) -> Q [[Dec]] -> DecsQ
forall a b. (a -> b) -> a -> b
$ [DecsQ] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
  [ String -> GenericStrategy -> DecsQ
customGeneric String
tyCtor (Int -> GenericStrategy
semiDupableGenericStrategy Int
nonDupableFieldsNum)
  , [d| instance HasDupableGetters $(addTypeVariables =<< lookupTypeNameOrFail tyCtor) |]
  ]

-- | Given number of non-dupable field (that must be last fields in the
-- datatype), produces a strategy that puts dupable fields at the left pair
-- subtree and non-dupable fields at the right pair subtree.
semiDupableGenericStrategy :: Int -> GenericStrategy
semiDupableGenericStrategy :: Int -> GenericStrategy
semiDupableGenericStrategy Int
nonDupableFieldsNum =
  ((Int -> [Natural]) -> (Int -> [Natural]) -> GenericStrategy
fromDepthsStrategy'
    Int -> [Natural]
makeRightBalDepths  -- ← doesn't matter, we expect exactly 1 constructor
    (\Int
n -> (Int -> [Natural]) -> Int -> Int -> [Natural]
makeSplittedDepths Int -> [Natural]
makeRightBalDepths (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nonDupableFieldsNum) Int
n))

-- | Depths distribution generator to be passed to 'fromDepthsStrategy',
-- it splits entries into two large groups and applies another depths
-- generator to each group.
makeSplittedDepths :: (Int -> [Natural]) -> Int -> (Int -> [Natural])
makeSplittedDepths :: (Int -> [Natural]) -> Int -> Int -> [Natural]
makeSplittedDepths Int -> [Natural]
mkInnerDepths Int
leftN Int
n
  | Int
leftN Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
|| Int
leftN Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n = Int -> [Natural]
mkInnerDepths Int
n
  | Bool
otherwise = (Natural -> Natural) -> [Natural] -> [Natural]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Natural -> Natural
forall a. Enum a => a -> a
succ ([Natural] -> [Natural]) -> [Natural] -> [Natural]
forall a b. (a -> b) -> a -> b
$ Int -> [Natural]
mkInnerDepths Int
leftN [Natural] -> [Natural] -> [Natural]
forall a. [a] -> [a] -> [a]
++ Int -> [Natural]
mkInnerDepths (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
leftN)