Haskell 从有状态计算中创建分段结果，具有良好的人体工程学

我想写一个函数

step :: State S O

其中，

O

是一种记录类型：

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

问题是我想分段组装我的

O

输出。我的意思是，在

step

定义的各个地方，我不时地了解到，例如

out2

应该是

只有3

，但我不知道

out1

和

out3

应该是什么。另外，

out1

有一个自然的默认值，可以从结束状态开始计算；但是仍然需要在

步骤中覆盖它

而且，最重要的是，我想将其“库化”，以便用户可以提供他们自己的
S
和
O
类型，其余的我都给他们

我目前的方法是使用的自动创建类型
HKD O Last
的方法将所有内容包装在
WriterT（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 }

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

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

这允许最终用户编写
step'
as

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

但还是有点麻烦；此外，它在幕后使用了相当多的重型机械。特别是考虑到我的用例是这样的，所有的库内部都需要一步一步地解释

因此，我希望在以下方面有所改进：


更简单的内部实施

为最终用户提供更好的API
我很乐意采用与第一原则完全不同的方法，只要它不要求用户在
O
旁边定义自己的
OLast
以下不是一个非常令人满意的解决方案，因为它仍然很复杂，并且类型错误非常可怕，但它试图实现两个目标：


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

“对于
out1
，有一个可以从结束状态计算的自然默认值；但是仍然需要有可能覆盖它”


该解决方案消除了
状态
单子。相反，有一个可扩展的记录，新字段会逐渐添加到该记录中，因此会更改其类型，直到“完成”

我们使用（这些用于类似HKD的功能）和（用于
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)

在
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}

以下是我目前使用的方法：基本上与我最初的问题相同的基于芭比娃娃的技术，但使用
Barbies th
和
lens
创建正确命名的视野镜头

我将用一个例子来说明这一点。假设我要收集此结果：

data CPUOut = CPUOut
    { inputNeeded :: Bool
    , ...
    }

使用
barbies th
为
CPUOut
创建芭比娃娃，在字段名称中添加
\ucode>前缀，并使用
lens
的
makelens
th宏生成字段访问器：

写入
update
s.t。它对包装在
Barbie
newtype包装中的部分值起作用：
Barbie
包装器的作用是
barbiebf
有一个
Monoid
实例，只要
bf
的所有字段本身都是Monoid。这正是
部分CPUOut
的情况，因此这就是我们将在
writer
中收集的内容：
编写通用输出赋值组合符。这就是为什么它比原始问题中的方法更好的原因，因为
Setter'
s是正确命名的字段访问器镜头，而不是重载标签：
示例用法：
有什么理由不能只做
step=do吗{…；out2@bradrn不同的分支来设置不同的部分，或者根本没有。@bradrn这里有一个真实的例子：谢谢你给我一个例子，但是我应该查看该文件的哪一部分？乍一看，我不知道哪一部分是相关的。我想我现在明白了-你是说有很多函数只有输出一个
O
？在这种情况下，您不能只执行
step=do{…；out2这个答案是对这里描述的技术的改编
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

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}

data CPUOut = CPUOut
    { inputNeeded :: Bool
    , ...
    }

declareBareB [d|
data CPUOut = CPUOut
   { _inputNeeded :: Bool
   , ...
   } |]
makeLenses ''CPUState

type Raw b = b Bare Identity
type Partial b = Barbie (b Covered) Last

update 
    :: (BareB b, ApplicativeB (b Covered)) 
    => Raw b -> Partial b -> Raw b
update initials edits = 
    bstrip $ bzipWith update1 (bcover initials) (getBarbie edits)
  where
    update1 :: Identity a -> Last a -> Identity a
    update1 initial edit = maybe initial Identity (getLast edit)

type CPU = WriterT (Partial CPUOut) (State CPUState)

(.:=) 
    :: (Applicative f, MonadWriter (Barbie b f) m) 
    => Setter' (b f) (f a) -> a -> m ()
fd .:= x = scribe (iso getBarbie Barbie . fd) (pure x)

startInput :: CPU ()
startInput = do
    inputNeeded .:= True
    phase .= WaitInput