Обход полиморфных структур и выполнение преобразования только в нескольких случаях

Question

Предположим, мы представляем иерархию компании следующим образом:

{-# LANGUAGE DeriveDataTypeable #-}

import           Data.Data
import           Data.Generics.Aliases
import           Data.Generics.Schemes

data CompanyAsset = Employee Name Salary
                  | Plant Name
                  | Boss Name Performance Salary [CompanyAsset]
                  | Pet Name
                  | Car Id
                  | Guild [CompanyAsset]
                  | Fork CompanyAsset CompanyAsset
                  -- ... and imagine 100 more options that recursively use `CompanyAsset`.
                  deriving (Show, Data)

-- Performance of the department.
data Performance = Good | Bad deriving (Show, Data)

type Name = String

type Id = Int

newtype Salary = Salary Double deriving (Show, Data, Typeable)

raise :: Salary -> Salary

И я хотел бы определить функцию, которая повышает зарплату активов компании, которые не имеют Boss предок, отдел которого имел Bad спектакль. Такая функция может быть легко определена следующим образом:

raiseSalaries :: CompanyAsset -> CompanyAsset
raiseSalaries (Boss n Good s as) = Boss n Good (raise s) (raiseSalaries <$> as)
raiseSalaries a@(Boss _ Bad _ _) = a -- The salaries of everything below are not raised if the performance is 'Bad'
raiseSalaries ... -- and from here onwards we have **boilerplate**!

Проблема в том, что для этого требуется много шаблонов (для обсуждения, пожалуйста, предположите, что CompanyAsset дано и не может быть изменено).

Поэтому мой вопрос заключается в том, существует ли способ обхода структур данных таким образом, чтобы избежать вышеприведенного примера.

Этот вопрос связан с аналогичным, который я опубликовал, но в этом случае использование everywhere' не поможет, поскольку есть случаи, когда зарплаты не должны повышаться.

Answer 1

Это может быть достигнуто с Traversal за CompanyAsset, Вы можете написать это самостоятельно или использовать uniplate или же plate от объектива.

Для иллюстрации я собираюсь написать обход CompanyAsset в явном виде. Применяется операция (которую я называю p как в pure) каждому непосредственному потомку актива компании. Обратите внимание, что traverse_ca pure == pure,

traverse_ca :: Applicative f => (CompanyAsset -> f CompanyAsset) -> CompanyAsset -> f CompanyAsset
traverse_ca p ca =
  case ca of
    Fork ca1 ca2      -> Fork <$> p ca1 <*> p ca2
    Boss n perf s cas -> Boss n perf s <$> traverse p cas
    Guild cas         -> Guild <$> traverse p cas
    otherwise         -> pure ca

Само по себе этого достаточно, чтобы определить raiseSalaries без каких-либо дополнительных шаблонов.

import Data.Functor.Identity

raiseSalaries :: CompanyAsset -> CompanyAsset
raiseSalaries (Boss n Good s as) = Boss n Good (raise s) (raiseSalaries <$> as)
raiseSalaries a@(Boss _ Bad _ _) = a -- The salaries of everything below are not raised if the performance is 'Bad'
raiseSalaries a = runIdentity $ traverse_ca (pure . raiseSalaries) a

Answer 2

Решение, которое использует схемы рекурсии, а также немного Template Haskell для генерации базы CompanyAssetF функтор:

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}

import Data.Functor.Foldable (cata,embed)
import Data.Functor.Foldable.TH (makeBaseFunctor)

$(makeBaseFunctor ''CompanyAsset)

raiseSalaries :: CompanyAsset -> CompanyAsset
raiseSalaries asset = cata go asset raise'
    where
    go c raiser = embed $
        case c of
            BossF _ Bad _ _ -> fmap ($ id) c
            _ -> raiser $ fmap ($ raiser) c
    raise' (BossF name perf salary rec) = BossF name perf (raise salary) rec
    raise' (EmployeeF name salary) = EmployeeF name (raise salary)
    raise' other = other

Алгебра возвращает функцию для того, чтобы информация "должна получить повышение" передавалась от корня к листьям.