NonDupable.hs

-- 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 tyCtor nonDupableFieldsNum = fmap concat $ sequence
  [ customGeneric tyCtor (semiDupableGenericStrategy 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 nonDupableFieldsNum =
  (fromDepthsStrategy'
    makeRightBalDepths  -- ← doesn't matter, we expect exactly 1 constructor
    (\n -> makeSplittedDepths makeRightBalDepths (n - nonDupableFieldsNum) 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 mkInnerDepths leftN n
  | leftN == 0 || leftN == n = mkInnerDepths n
  | otherwise = fmap succ $ mkInnerDepths leftN ++ mkInnerDepths (n - leftN)