haskell - 通过状态计算分段创建结果，具有良好的人体工程学原理

Question

我想写一个函数

step :: State S O

其中 O 是记录类型:

data O = MkO{ out1 :: Int, out2 :: Maybe Int, out3 :: Maybe Bool }

问题是我想分段组装我的 O 输出。我的意思是，在 step 定义的各个地方，我当时就了解到，例如out2 应该是 Just 3，但我不知道以非复杂的方式 out1 和 out3应该。此外，out1 有一个自然的默认值，可以从最终状态计算出来；但仍然需要有可能在step中覆盖它。

而且，最重要的是，我想“库化”它，以便用户可以提供自己的 S 和 O 类型，然后我给他们剩下的。

我当前的方法是使用 Higgledy 将所有内容包装在 WriterT (HKD O Last) 中创建与 HKD O Last 类型同构的自动方法

data OLast = MkOLast{ out1' :: Last Int, out2' :: Last (Maybe Int), out3' :: Last (Maybe String) }

这带有明显的 Monoid 实例，因此我至少在道德上可以执行以下操作:

step = do
   MkOLast{..} <- execWriterT step'
   s <- get
   return O
       { out1 = fromMaybe (defaultOut1 s) $ getLast out1'
       , out2 =  getLast out2'
       , out3 = fromMaybe False $ getLast out3'
       }

step' = do
    ...
    tell mempty{ out2' = pure $ Just 42 }
    ...
    tell mempty{ out1' = pure 3 }

这是我可以接受的代码。

问题是我只能在道德上做到这一点。在实践中，我必须编写相当复杂的代码，因为 Higgledy 的 HKD O Last 将记录字段公开为镜头，因此真正的代码最终看起来更像是以下内容:

step = do
   oLast <- execWriterT step'
   s <- get
   let def = defaultOut s
   return $ runIdentity . construct $ bzipWith (\i -> maybe i Identity . getLast) (deconstruct def) oLast 

step' = do
    ...
    tell $ set (field @"out2") (pure $ Just 42) mempty
    ... 
    tell $ set (field @"out3") (pure 3) mempty

步骤中的第一个缺点我们可以隐藏在函数后面:

update :: (Generic a, Construct Identity a, FunctorB (HKD a), ProductBC (HKD a)) => a -> HKD a Last -> a
update initial edits = runIdentity . construct $ bzipWith (\i -> maybe i Identity . getLast) (deconstruct initial) edits

所以我们可以将其“库化”为

runStep
  :: (Generic o, Construct Identity o, FunctorB (HKD o), ProductBC (HKD o))
  => (s -> o) -> WriterT (HKD o Last) (State s) () -> State s o
runStep mkDef step = do
    let updates = execWriterT step s
    def <- gets mkDef
    return $ update def updates

但令我担心的是记录部分输出的地方。到目前为止，我能想到的最好办法是使用 OverloadedLabels 提供 #out2 作为可能的语法:

instance (HasField' field (HKD a f) (f b), Applicative f) => IsLabel field (b -> Endo (HKD a f)) where
    fromLabel x = Endo $ field @field .~ pure x

output :: (Monoid (HKD o Last)) => Endo (HKD o Last) -> WriterT (HKD o Last) (State s) ()
output f = tell $ appEndo f mempty

这允许最终用户将step'编写为

step' = do
    ...
    output $ #out2 (Just 42)
    ...
    output $ #out3 3 

但是还是有点麻烦；而且，它在幕后使用了相当多的重型机械。特别是考虑到我的用例需要逐步解释所有库内部结构。

因此，我正在寻找以下方面的改进:

• 更简单的内部实现
• 为最终用户提供更好的 API
• 我也很乐意采用与第一原则完全不同的方法，只要它不要求用户在旁边定义自己的OLast O...

Answer 1

以下不是一个非常令人满意的解决方案，因为它仍然很复杂并且类型错误很可怕，但它试图实现两件事:

• 任何在未指定所有必填字段的情况下“完成”记录构造的尝试都会导致类型错误。

• “out1 有一个自然的默认值，可以从最终状态计算出来；但仍然需要有可能覆盖它”

该解决方案取消了State monad。相反，有一个可扩展的记录，新字段会逐渐添加到其中，从而更改其类型，直到它“完成”。

我们使用 red-black-record , sop-core (这些用于类似港币的功能)和 transformers (对于 Reader monad)包。

一些必要的导入:

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
import           Data.RBR (Record,unit,FromRecord(fromRecord),ToRecord,RecordCode,
                           Productlike,fromNP,toNP,ProductlikeSubset,projectSubset,
                           FromList,
                           Insertable,Insert,insert) -- from "red-black-record"
import           Data.SOP (I(I),unI,NP,All,Top) -- from "sop-core"
import           Data.SOP.NP (sequence_NP)
import           Data.Function (fix)
import           Control.Monad.Trans.Reader (Reader,runReader,reader)
import qualified GHC.Generics

数据类型通用机制:

specify :: forall k v t r. Insertable k v t 
        => v -> Record (Reader r) t -> Record (Reader r) (Insert k v t)
specify v = insert @k @v @t (reader (const v))


close :: forall r subset subsetflat whole . _ => Record (Reader r) whole -> r
close = fixRecord @r @subsetflat . projectSubset @subset @whole @subsetflat
  where
    fixRecord 
        :: forall r flat. (FromRecord r, Productlike '[] (RecordCode r) flat, All Top flat)
        => Record (Reader r) (RecordCode r)
        -> r
    fixRecord = unI . fixHelper I
    fixHelper 
        :: forall r flat f g. _
        => (NP f flat -> g (NP (Reader r) flat))
        -> Record f (RecordCode r)
        -> g r 
    fixHelper adapt r = do
        let moveFunctionOutside np = runReader . sequence_NP $ np
            record2record np = fromRecord . fromNP <$> moveFunctionOutside np
        fix . record2record <$> adapt (toNP r)

specify 将一个字段添加到可扩展的类似 HKD 的记录中，其中每个字段实际上是从已完成记录到已完成记录中字段类型的函数。它将字段作为常量函数插入。它还可以覆盖现有的默认字段。

close 采用使用 specify 构造的可扩展记录并“喜结良缘”，返回完整的非港元记录。

以下是必须为每个具体记录编写的代码:

data O = MkO { out1 :: Int, out2 :: Maybe Int, out3 :: Maybe Bool } 
         deriving (GHC.Generics.Generic, Show)
instance FromRecord O
instance ToRecord O

type ODefaults = FromList '[ '("out1",Int) ]

odefaults :: Record (Reader O) ODefaults
odefaults =
      insert @"out1" (reader $ \r -> case out2 r of
                                       Just i -> succ i
                                       Nothing -> 0)
    $ unit

在odefaults中，我们为某些字段指定可重写的默认值，这些默认值是通过检查“已完成”记录来计算的(这是有效的，因为我们稍后与close打结。 )

让一切发挥作用:

example1 :: O
example1 = 
      close
    . specify @"out3" (Just False)
    . specify @"out2" (Just 0)
    $ odefaults

example2override :: O
example2override = 
      close
    . specify @"out1" (12 :: Int)
    . specify @"out3" (Just False)
    . specify @"out2" (Just 0)
    $ odefaults

main :: IO ()
main = 
    do print $ example1
       print $ example2override
-- result:
-- MkO {out1 = 1, out2 = Just 0, out3 = Just False}
-- MkO {out1 = 12, out2 = Just 0, out3 = Just False}