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

我想写一个函数

step :: State S O

其中O是记录类型：

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

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

最重要的是，我想将其"库化"，这样用户就可以提供自己的S和O类型，剩下的我就交给他们了

我目前的方法是使用Higledy创建同构于的类型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 }

这是我可以接受的代码。

问题是，我只能在道德上这样做。在实践中，我必须写的是相当复杂的代码，因为Higledy的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

step中我们可以隐藏在一个函数后面的第一个疣：

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
我很乐意使用与第一原则完全不同的方法，只要它不需要用户在O旁边定义自己的OLast

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

任何试图在没有指定所有必填字段的情况下"完成"记录构造的操作都会导致类型错误。
"out1有一个自然默认值，可以从结束状态计算出来；但仍有可能覆盖它">

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

我们使用红黑唱片、sop核心(用于类似HKD的功能)和变压器(用于Readermonad)包。

一些必要的进口：

{-# 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)

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

close取用specify构造的可扩展记录"打结"，返回已完成的非HKD记录。

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

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}

以下是我目前使用的方法：基本上与我最初的问题中基于Barbies的技术相同，但使用barbies-th和lens来创建正确命名的场透镜。

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

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

使用barbies-th为CPUOut创建Barbie，将_前缀添加到字段名称，并使用lens的makeLensesTH宏生成字段访问器：

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

编写updates.t.它适用于包装在Barbienewtype包装器中的部分值：

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)

Barbie包装器的作用是，如果只有b f的所有字段本身都是单胚，则Barbie b f具有Monoid实例。这正是Partial CPUOut的情况，所以这就是我们将在WriterT中收集的内容：

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

编写通用输出赋值组合子。这就是它比原始问题中的方法更好的原因，因为Setter'是正确命名的场存取器透镜，而不是过载标签：

(.:=) 
:: (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

相关内容

最新更新

热门标签：