A monad for building test data - haskell

Question

OK, so I'm trying to write a monad for building test data, but I can't quite get it to work how I want it. It looks something like this:
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.
In other words, it's a supply monad, writer monad and list monad. The idea is that I can write something like this:
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 ++ ")"
The idea is to generate all possible combinations of data. You can do that just using list comprehensions, but the result ends up syntactically awful. This is much more readable. Unfortunately, it doesn't actually work...
The problem seems to boil down to the local function not behaving correctly. The intention is for any source calls in the sub-computation to have no effect outside of it. (I.e., subsequent calls to source from outside the local block get the first token again.) However, what my implementation of local actually does is reset the next token for everything (i.e., including the contents of the sub-computation). This is clearly incorrect, but I cannot for the life of me bend my mind around how to make it work correctly.
The fact that I'm having this much trouble getting the code to work as required probably means the actual internal representation of my monad is just wrong. Can anybody take a stab at implementing this correctly?
EDIT: I should perhaps have realised this, but I didn't actually specify the expected result I'm trying to get. The above code is supposed to produce this:
["A", "a", "[]", "()", "(A)", "(a)", "[A]", "[a]", "(A, B)", "(A, b)", "(a, B)", "(a, b)"]
It's not super-critical that the results appear in exactly this order. I'd like the single cases to appear before the compound ones, but I'm not too fussed exactly what order the compounds appear. The rule is that the same variable never appears twice in any individual expression.
If we allow the depth to be a bit deeper, we additionally get terms such as
"((A))", "([A])", "[(A)]", "((A, B), C)", "(A, (B, C))"
and so on.
It's clearly broken, but here's what I have so far:
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, () )

Answer 1

You are trying to reinvent pipes. Your source and yield are pipes await and yield. The other two concerns you are trying to handle are a ReaderT and a WriterT respectively. If you put the entire list of inputs in the environment of the ReaderT you can run local sub computations that start over at the beginning of the list. You can collect all of the results from a sub-computation by adding a WriterT layer to collect the output.
For the nice syntax with gather you are trying to recreate ListT.
Pipes, Readers, and Writers
We're going to use all of the following in very short order.
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)
Your builder is a Pipe i o over a Reader [i] which allows you to reset at the beginning of the input. We will define two versions of it, BuildT which is a monad transformer, and BuildM which is a monad. BuildM is jsut the transformer applied to 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 runs a builder feeding it the entire input read from the environment. We might want to give this a different name to avoid conflicting with local defined for ReaderT
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
To collect the results of the sub computations, we take advantage of the fact that pipes are so pure that you can swap out the underlying monad provided you have a natural transformation forall x. m x -> n x. The proxies from pipes have an MFunctor instance that provides a function hoist :: (forall x. m x -> n x) -> Proxy a' a b' b m r -> Proxy a' a b' b n r; it lets us lift all of the underlying monad operations under a pipe to use the pipe over another transformer, in this case WriterT.
collect :: (Monad m) => Proxy a' a () b m r -> Proxy a' a c' c m ([b], r)
collect subDef = do
(r, w) <- runWriterP $
hoist lift subDef //> \x -> lift $ tell (++[x])
return (w [], r)
To run a builder we feed it all of the input from the environment, provide the initial environment, collect the results, and run the entire pipe.
runBuildT :: (Monad m) => [i] -> BuildT [i] i o m () -> m [o]
runBuildT e = runEffect . fmap fst . collect . runReaderP e . local
Running the monad instead of the transformer is just
runBuildM :: [i] -> BuildM [i] i o () -> [o]
runBuildM e = runIdentity . runBuildT e
ListT
This section lets us use do-notation when generating all combinations of things. It's equivalent to using pipes' for in place of each >>= and yield in place of each return.
The syntax that gathers all of the results from a sub computation is reinventing ListT. a ListT m a holds a Producer a m () that only returns data downstream. Pipes that get data from upstream and return data downstream don't fit into the Producer b m (). This will take a bit of conversion.
We can convert a Proxy that has both an upstream and a downstream interface into one with only a downstream interface wrapped around another proxy with the upstream interface. To do so, we hoist the underlying monad into our new inner upstream proxy, then replace all of the requests in the outer downstream proxy with requests lifted from the inner upstream proxy.
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
These can be converted into a ListT. We'll discard any returned data to get a more polymorphic type.
gather :: (Monad m) => Proxy a' a () b m r -> P.ListT (Proxy a' a c' c m) b
gather = P.Select . floatRespond . (>>= return . const ())
Using ListT is a bit cumbersome to use; you need an mplus between returns to get both outputs. It's frequently convenient to shove a proxy into a ListT so you can lift . yield instead of returning. We are going to discard all our ListT results an rely on the output coming from lift . yield.enumeratejust runs aListT` wrapped around anything, discarding all the results
enumerate = P.runListT
Example
We're now equipped to write and run your example. I thing you mean for source to get one value from the source and for yield to return one value. If you don't need to be able to get values one at a time your question is over-specified and this answer is overkill.
source = P.await
yield = P.yield
In the example, where we use gather to build lists, we run that portion of the code with enumerate and yield results with lift . yield.
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 ++ ")"
If we run this example with the input ["A", "B"] the "B" input is never used because source is only ever used once inside each local.
main = do
putStrLn "Depth 2"
print =<< runBuildT ["A", "B"] (build_tests 2)
putStrLn "Depth 3"
print =<< runBuildT ["A", "B"] (build_tests 3)
The output for depths less than 4 is small enough to repeat here.
["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)","((),[])","((),())"]
This might be overkill
I suspect that you might have meant for source to get everything from the source.
source = gather P.cat
yield = P.yield
If we use this for the example instead of getting a single item from the source we'll enumerate the first local block and yield results by returning in 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 ++ ")"
This uses both source values when we run the example with two sources.
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)","((),[])","((),())"]
If you never get a single value from the source you could just use ListT (ReaderT [i] m) o instead. You might still want a proxy to avoid messing around with mplus.

Answer 2

You are trying to reinvent pipes and some nice syntax for building lists. The problem is much simpler than how you characterize it. The source of strings can be completely separated from building the structures.
You want to generate structures that draw symbols from some source. Without worrying about the source, let's build the structures. Each structure is a Pipe that will draw from some source and yield strings to concatenate together to build the expression.
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 ")"
This code uses the ContT yield trick from the continuation answer.
We run one of these structures by feeding it the symbols and concatenating the results.
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)
The examples produce the desired strings. I'll leave producing the two special cases "[]" and "()", which do not appear in recursive terms, as an exercise.
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
This results in
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])",...

Answer 3

If my other answer is overkill, the continuation monad transformer provides a convenient way to construct any MonadPlus values.
The continuation monad lets us easily capture the idea of doing something mplus the as yet unknown remainder.
import Control.Monad
import Control.Monad.Trans.Cont
once :: MonadPlus m => m a -> ContT a m ()
once m = ContT $ \k -> m `mplus` k ()
Yielding a result is just returning it once.
yield :: MonadPlus m => a -> ContT a m ()
yield = once . return
We can gather up all the results by sticking mzero at the end.
gather :: MonadPlus m => ContT a m r -> m a
gather m = runContT m (const mzero)
Your example is written in terms of yield, gather, once, and lift.
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
This outputs the following:
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)","((),[])","((),())"]
I've taken the liberty of getting rid of the requirement to read the original source from the environment for simplicity. You can add a ReaderT to the transformer stack to get it back. I also haven't chosen a list transfomer for you, the example is running using the ordinary list monad. Since it's written in terms of MonadPlus it will work for any (MonadTrans t, MonadPlus (t m)) => t m as well.