Haskell 构建测试数据的monad_Haskell_Monads

Haskell 构建测试数据的monad

haskell

Haskell 构建测试数据的monad,haskell,monads,Haskell,Monads,好的，所以我正试图编写一个用于构建测试数据的monad，但是我不能让它按照我想要的方式工作。它看起来像这样： runBuildM :: [i] -> BuildM i o x -> [o] -- Given a list of i, build a list of o. source :: BuildM i o i -- Fetch unique i. yield :: o -> BuildM i o () -- Return a new o to the caller.

好的，所以我正试图编写一个用于构建测试数据的monad，但是我不能让它按照我想要的方式工作。它看起来像这样：

runBuildM :: [i] -> BuildM i o x -> [o]
-- Given a list of i, build a list of o.

source :: BuildM i o i
-- Fetch unique i.

yield :: o -> BuildM i o ()
-- Return a new o to the caller.

gather :: BuildM i o x -> BuildM i o o
-- Fetch every possible o from sub-computation.

local :: BuildM i o x -> BuildM i o x
-- Isolate any source invocations from the rest of the code.

build_tests depth = do
  local $ do
    v <- source
    yield v
    yield (map toLower v)
  yield "[]"
  yield "()"
  when (depth > 2) $ do
    t1 <- gather $ build_tests (depth-1)
    yield $ "(" ++ t1 ++ ")"
    yield $ "[" ++ t1 ++ "]"
    t2 <- gather $ build_tests (depth-1)
    yield $ "(" ++ t1 ++ "," ++ t2 ++ ")"

换句话说，它是一个供给单子、书写单子和列表单子。我的想法是我可以这样写：

runBuildM :: [i] -> BuildM i o x -> [o]
-- Given a list of i, build a list of o.

source :: BuildM i o i
-- Fetch unique i.

yield :: o -> BuildM i o ()
-- Return a new o to the caller.

gather :: BuildM i o x -> BuildM i o o
-- Fetch every possible o from sub-computation.

local :: BuildM i o x -> BuildM i o x
-- Isolate any source invocations from the rest of the code.

build_tests depth = do
  local $ do
    v <- source
    yield v
    yield (map toLower v)
  yield "[]"
  yield "()"
  when (depth > 2) $ do
    t1 <- gather $ build_tests (depth-1)
    yield $ "(" ++ t1 ++ ")"
    yield $ "[" ++ t1 ++ "]"
    t2 <- gather $ build_tests (depth-1)
    yield $ "(" ++ t1 ++ "," ++ t2 ++ ")"

结果以这样的顺序出现并不是非常关键的。我希望单个案例出现在复合案例之前，但我并不太在意复合案例出现的顺序。规则是，同一个变量在任何单个表达式中都不会出现两次

import Data.Char

import Data.Functor.Identity

import Pipes.Core
import Pipes ((>->))
import qualified Pipes as P
import qualified Pipes.Prelude as P

build_structures :: Int -> [Pipe String String Identity ()]
build_structures depth = gather $ do
    yield $ P.take 1
    yield $ P.map (map toLower) >-> P.take 1
    when (depth > 2) $ do
        t1 <- lift $ build_structures (depth - 1)
        yield $ P.yield "(" >> t1 >> P.yield ")"
        yield $ P.yield "[" >> t1 >> P.yield "]"
        t2 <- lift $ build_structures (depth - 1)
        yield $ P.yield "(" >> t1 >> P.yield "," >> t2 >> P.yield ")"

如果我们允许深度更深一点，我们还可以得到如下术语

"((A))", "([A])", "[(A)]", "((A, B), C)", "(A, (B, C))"

等等

很明显，它坏了，但到目前为止，我得到的是：

newtype BuildM i o x = BuildM ([i] -> SEQ.Seq ([i], SEQ.Seq o, x))

instance Functor (BuildM i o) where
  fmap uf (BuildM sf) =
    BuildM $ \ is0 -> do
      (is1, os, x) <- sf is0
      return (is1, os, uf x)

instance Applicative (BuildM i o) where
  pure x = BuildM $ \ is0 -> return (is0, SEQ.empty, x)

  BuildM sf1 <*> BuildM sf2 =
    BuildM $ \ is1 -> do
      (is2, os2, f) <- sf1 is1
      (is3, os3, x) <- sf2 is2
      return (is3, os2 >< os3, f x)

instance Monad (BuildM i o) where
  return = pure

  BuildM sf1 >>= uf =
    BuildM $ \ is1 -> do
      (is2, os2, x) <- sf1 is1
      let BuildM sf2 = uf x
      (is3, os3, y) <- sf2 is2
      return (is3, os2 >< os3, y)

runBuildM :: [i] -> BuildM i o x -> [o]
runBuildM is0 (BuildM sf) =
  toList $ do
    (is, os, x) <- sf is0
    os

source :: BuildM i o i
source =
  BuildM $ \ is ->
    if null is
      then error "AHC.Tests.TestBuilder.source: end of input"
      else return (tail is, SEQ.empty, head is)

yield :: o -> BuildM i o ()
yield o = BuildM $ \ is -> return (is, SEQ.singleton o, () )

gather :: BuildM i o x -> BuildM i o' o
gather (BuildM sf1) =
  BuildM $ \ is1 -> do
    (is2, os2, _) <- sf1 is1
    o <- os2
    return (is2, SEQ.empty, o)

local :: BuildM i o x -> BuildM i o ()
local (BuildM sf1) =
  BuildM $ \ is1 ->
    let os = do (is2, os2, x) <- sf1 is1; os2
    in  return (is1, os, () )

newtype BuildM i o x=BuildM（[i]>SEQ.SEQ（[i]，SEQ.SEQ o，x））
实例函子（BuildM i o）其中
fmap uf（BuildM sf）=
BuildM$\is0->do
（is1，os，x）返回（is0，序号为空，x）
BuildM sf1 BuildM sf2=
BuildM$\is1->do
（is2，os2，f）>=uf=
BuildM$\is1->do
（is2，os2，x）BuildM i o x->[o]
runBuildM is0（BuildM sf）=
托利斯$do
（is，os，x）
如果null为
然后出现错误“AHC.Tests.TestBuilder.source:输入结束”
否则返回（尾部为空，序号为空，头部为空）
收益率：：o->BuildM i o（）
收益率o=BuildM$\is->return（is，SEQ.singleton o，（））
聚集：：BuildM i o x->BuildM i o'o
聚集（BuildM sf1）=
BuildM$\is1->do
（is2，os2，2;
让os=do（is2，os2，x）您正在尝试重新发明。您的源代码
和收益率
是管道等待
和收益率
。您试图处理的另外两个问题分别是ReaderT
和WriterT
。如果将整个输入列表放在ReaderT
的环境中，则可以运行从列表开头重新开始的local
子计算。通过添加WriterT
层来收集输出，可以从子计算中收集所有结果
对于gather
的漂亮语法，您正在尝试重新创建ListT

build_tests :: Monad m => Int -> BuildT [String] String String m ()
build_tests depth = do
  local $ enumerate $ do
    v <- source
    lift . yield $ v
    lift . yield $ (map toLower v)
  yield "[]"
  yield "()"
  when (depth > 2) $ enumerate $ do
    t1 <- gather $ build_tests (depth-1)
    lift . yield $ "(" ++ t1 ++ ")"
    lift . yield $ "[" ++ t1 ++ "]"
    t2 <- gather $ build_tests (depth-1)
    lift . yield $ "(" ++ t1 ++ "," ++ t2 ++ ")"

管道、读者和作者
我们将在很短的时间内使用以下所有内容
import Data.Functor.Identity
import Data.Foldable

import Control.Monad
import Control.Monad.Morph
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader hiding (local)
import Control.Monad.Trans.Writer.Strict

import Pipes.Core
import Pipes ((>->))
import qualified Pipes as P
import qualified Pipes.Prelude as P

import Pipes.Lift (runWriterP, runReaderP)

构建器是一个读卡器[i]
上的管道IO
，允许您在输入开始时重置。我们将定义它的两个版本，BuildT
是monad转换器，而BuildM
是monad转换器BuildM
是应用于Identity
的转换器
type BuildT e i o m r = Pipe i o (ReaderT e m) r
type BuildM e i o   r = BuildT e i o Identity r

local
运行一个构建器，将从环境中读取的全部输入提供给它。我们可能希望给它一个不同的名称，以避免与为ReaderT
定义的local
冲突
local :: (Monad m, Foldable f) => BuildT (f i) i o m () -> Proxy a' a () o (ReaderT (f i) m) ()
local subDef = do
    e <- lift ask
    hoist lift $ runReaderP e $
        P.each e >->
        subDef

要运行构建器，我们将从环境中输入所有内容，提供初始环境，收集结果，然后运行整个管道
runBuildT :: (Monad m) => [i] -> BuildT [i] i o m () -> m [o]
runBuildT e = runEffect . fmap fst . collect . runReaderP e . local

运行monad而不是transformer只是
runBuildM :: [i] -> BuildM [i] i o () -> [o]
runBuildM e = runIdentity . runBuildT e

利斯特
本节允许我们在生成所有事物组合时使用do
-符号。这相当于使用管道代替每个>=
和产量
代替每个返回

收集子计算的所有结果的语法正在重新发明。listtma
包含一个只返回下游数据的Producer a m（）
。从上游获取数据并在下游返回数据的管道不适合Producer b m（）
。这需要一点转换
我们可以将既有上游接口又有下游接口的代理
转换为只有下游接口缠绕在另一个具有上游接口的代理上的代理。为此，我们将底层monad提升到新的内部上游代理中，然后将外部下游代理中的所有请求
s替换为从内部上游代理中提升的请求
s
floatRespond :: (Monad m) => Proxy a' a b' b m r -> Proxy c' c b' b (Proxy a' a d' d m) r
floatRespond = (lift . request >\\) . hoist lift

这些可以转换为列表
。我们将丢弃所有返回的数据以获得更多态的类型
gather :: (Monad m) => Proxy a' a () b m r -> P.ListT (Proxy a' a c' c m) b
gather = P.Select . floatRespond . (>>= return . const ())

使用ListT
有点麻烦；您需要在return
s之间使用mplus
，以获得两个输出。将代理插入ListT
通常很方便，这样您就可以提起。收益率
而不是返回
ing。我们将放弃所有的ListT
结果，并依赖lift的输出。yield.
enumerate只运行一个
ListT`环绕任何内容，丢弃所有结果
enumerate = P.runListT

例子
我们现在可以编写并运行您的示例。我想你的意思是，source
从源代码中获取一个值，yield
返回一个值。如果您不需要一次只获取一个值，那么您的问题就被过度指定了，而这个答案就被过度使用了
source = P.await
yield = P.yield

在本例中，我们使用collect
来构建列表，我们使用enumerate
运行代码的该部分，并使用lift生成结果。产量

import Data.Char

build_tests :: Monad m => Int -> BuildT [String] String String m ()
build_tests depth = do
  local $ do
    v <- source
    yield $ v
    yield $ (map toLower v)
  yield "[]"
  yield "()"
  when (depth > 2) $ enumerate $ do
    t1 <- gather $ build_tests (depth-1)
    lift . yield $ "(" ++ t1 ++ ")"
    lift . yield $ "[" ++ t1 ++ "]"
    t2 <- gather $ build_tests (depth-1)
    lift . yield $ "(" ++ t1 ++ "," ++ t2 ++ ")"

深度小于4的输出足够小，可以在此重复
["A","a","[]","()"]
Depth 3
["A","a","[]","()","(A)","[A]","(A,A)","(A,a)","(A,[])","(A,())","(a)","[a]","(a,A)","(a,a)","(a,[])","(a,())","([])","[[]]","([],A)","([],a)","([],[])","([],())","(())","[()]","((),A)","((),a)","((),[])","((),())"]

这可能太过分了
我想你可能是想让source
从源代码中获取所有信息
source = gather P.cat
yield = P.yield

如果我们将其用于示例，而不是从源代码中获取单个项，我们将枚举第一个本地块，并通过返回在列表中键入来生成结果
build_tests :: Monad m => Int -> BuildT [String] String String m ()
build_tests depth = do
  local $ enumerate $ do
    v <- source
    lift . yield $ v
    lift . yield $ (map toLower v)
  yield "[]"
  yield "()"
  when (depth > 2) $ enumerate $ do
    t1 <- gather $ build_tests (depth-1)
    lift . yield $ "(" ++ t1 ++ ")"
    lift . yield $ "[" ++ t1 ++ "]"
    t2 <- gather $ build_tests (depth-1)
    lift . yield $ "(" ++ t1 ++ "," ++ t2 ++ ")"

如果您从未从源代码中获得任何值，您可以使用ListT（ReaderT[i]m）o
。您可能仍然需要一个代理，以避免与mplus混为一谈
如果是过度使用，延续monad转换器提供了一种方便的方法来构造任何值
延续单子让我们很容易地捕捉到做某事的想法mplus
到目前为止未知的剩余部分
import Control.Monad
import Control.Monad.Trans.Cont

once :: MonadPlus m => m a -> ContT a m ()
once m = ContT $ \k -> m `mplus` k ()

产生结果
yield :: MonadPlus m => a -> ContT a m ()
yield = once . return

gather :: MonadPlus m => ContT a m r -> m a
gather m = runContT m (const mzero)

import Data.Char

import Control.Monad.Trans.Class

build_tests :: MonadPlus m => m String -> Int -> ContT String m ()
build_tests source = go
  where
    go depth = do
      once . gather $ do
        v <- lift source
        yield v
        yield (map toLower v)
      yield "[]"
      yield "()"
      when (depth > 2) $ do
        t1 <- lift . gather $ go (depth-1)
        yield $ "(" ++ t1 ++ ")"
        yield $ "[" ++ t1 ++ "]"
        t2 <- lift . gather $ go (depth-1)
        yield $ "(" ++ t1 ++ "," ++ t2 ++ ")"

main = print . gather $ build_tests ["A", "B"] 3

Depth 2
["A","a","B","b","[]","()"]
Depth 3
["A","a","B","b","[]","()","(A)","[A]","(A,A)","(A,a)","(A,B)","(A,b)","(A,[])","(A,())","(a)","[a]","(a,A)","(a,a)","(a,B)","(a,b)","(a,[])","(a,())","(B)","[B]","(B,A)","(B,a)","(B,B)","(B,b)","(B,[])","(B,())","(b)","[b]","(b,A)","(b,a)","(b,B)","(b,b)","(b,[])","(b,())","([])","[[]]","([],A)","([],a)","([],B)","([],b)","([],[])","([],())","(())","[()]","((),A)","((),a)","((),B)","((),b)","((),[])","((),())"]

import Data.Char

import Data.Functor.Identity

import Pipes.Core
import Pipes ((>->))
import qualified Pipes as P
import qualified Pipes.Prelude as P

build_structures :: Int -> [Pipe String String Identity ()]
build_structures depth = gather $ do
    yield $ P.take 1
    yield $ P.map (map toLower) >-> P.take 1
    when (depth > 2) $ do
        t1 <- lift $ build_structures (depth - 1)
        yield $ P.yield "(" >> t1 >> P.yield ")"
        yield $ P.yield "[" >> t1 >> P.yield "]"
        t2 <- lift $ build_structures (depth - 1)
        yield $ P.yield "(" >> t1 >> P.yield "," >> t2 >> P.yield ")"

run :: Pipe String String Identity () -> String
run p = concat . P.toList $ P.each symbols >-> p

-- an infinite source of unique symbols
symbols :: [String]
symbols = drop 1 symbols'
    where
        symbols' = [""] ++ do
            tail <- symbols'
            first <- ['A'..'Z']
            return (first : tail)

import Data.Functor

main = do
    putStrLn "Depth 2"
    print $ run <$> build_structures 2
    putStrLn "Depth 3"
    print $ run <$> build_structures 3
    putStrLn "Depth 4"
    print $ run <$> build_structures 4

Depth 2
["A","a"]
Depth 3
["A","a","(A)","[A]","(A,B)","(A,b)","(a)","[a]","(a,B)","(a,b)"]
Depth 4
["A","a","(A)","[A]","(A,B)","(A,b)","(A,(B))","(A,[B])","(A,(B,C))","(A,(B,c))","(A,(b))","(A,[b])","(A,(b,C))","(A,(b,c))","(a)","[a]","(a,B)","(a,b)","(a,(B))","(a,[B])","(a,(B,C))","(a,(B,c))","(a,(b))","(a,[b])",...