Fuzzer monad

gistfile1.hs

{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}

import Control.Applicative
import Control.Monad
import qualified Control.Monad.Random as R
import qualified Control.Monad.State as S
import qualified Control.Monad.Trans.Either as E

newtype Fuzzer s a = Fuzzer {
    runFuzzer :: E.EitherT () (S.StateT s (R.Rand R.StdGen)) a
}

evalFuzzer :: Fuzzer s a -> s -> R.StdGen -> Either () a
evalFuzzer f s g = R.evalRand (S.evalStateT (E.runEitherT $ runFuzzer f) s) g

instance Functor (Fuzzer s) where
    fmap f = Fuzzer . fmap f . runFuzzer

instance Applicative (Fuzzer s) where
    pure      = Fuzzer . pure
    ff <*> fa = Fuzzer $ runFuzzer ff <*> runFuzzer fa

instance Monad (Fuzzer s) where
    return   = pure
    ma >>= f = Fuzzer $ runFuzzer ma >>= (runFuzzer . f)

instance Alternative (Fuzzer s) where
    empty     = Fuzzer empty
    fa <|> fb = Fuzzer $ runFuzzer fa <|> runFuzzer fb

instance MonadPlus (Fuzzer s) where
    mzero = empty
    mplus = (<|>)

instance R.MonadRandom (Fuzzer s) where
    getRandom   = Fuzzer R.getRandom
    getRandoms  = Fuzzer R.getRandoms
    getRandomR  = Fuzzer . R.getRandomR
    getRandomRs = Fuzzer . R.getRandomRs

instance S.MonadState s (Fuzzer s) where
    get = Fuzzer S.get
    put = Fuzzer . S.put

try :: Fuzzer s a -> Fuzzer s a
try f = Fuzzer $ E.EitherT $ S.get >>= \s ->
    E.eitherT ((S.put s >>) . return . Left) (return . Right) (runFuzzer f)

toss c = (R.getRandom >>= guard) >> return c

oneOf :: [Fuzzer s a] -> Fuzzer s a
oneOf fs = R.getRandomRs (0, length fs - 1) >>= msum . map (fs !!)

main = do
    g <- R.getStdGen
    let Right x = evalFuzzer (oneOf [toss "a", toss "b", toss "c"]) () g
    putStrLn x