-- based on the logict test-suite
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
module Main where
import Test.Tasty
import Test.Tasty.HUnit
import Control.Arrow ( left )
import Control.Concurrent ( threadDelay )
import Control.Concurrent.Async ( race )
import Control.Exception
import Control.Monad.Identity
import Control.Monad.Stream
import Control.Monad.Reader
import qualified Control.Monad.State.Lazy as SL
import qualified Control.Monad.State.Strict as SS
import Data.Maybe
#if MIN_VERSION_base(4,9,0)
#if MIN_VERSION_base(4,11,0)
#else
import Data.Semigroup (Semigroup (..))
#endif
#else
import Data.Monoid
#endif
monadReader1 :: Assertion
monadReader1 = assertEqual "should be equal" [5 :: Int] $
runReader (observeAllT (local (+ 5) ask)) 0
monadReader2 :: Assertion
monadReader2 = assertEqual "should be equal" [(5, 0)] $
runReader (observeAllT foo) 0
where
foo :: MonadReader Int m => m (Int,Int)
foo = do
x <- local (5+) ask
y <- ask
return (x,y)
monadReader3 :: Assertion
monadReader3 = assertEqual "should be equal" [5,3] $
runReader (observeAllT (plus5 `mplus` mzero `mplus` plus3)) (0 :: Int)
where
plus5 = local (5+) ask
plus3 = local (3+) ask
nats, odds, oddsOrTwo,
oddsOrTwoUnfair, oddsOrTwoFair,
odds5down :: Monad m => StreamT m Integer
#if MIN_VERSION_base(4,8,0)
nats = pure 0 `mplus` ((1 +) <$> nats)
#else
nats = return 0 `mplus` liftM (1 +) nats
#endif
odds = return 1 `mplus` liftM (2+) odds
oddsOrTwoUnfair = odds `mplus` return 2
oddsOrTwoFair = odds `interleave` return 2
oddsOrTwo = do x <- oddsOrTwoFair
if even x then once (return x) else mzero
odds5down = return 5 `mplus` mempty `mplus` mempty `mplus` return 3 `mplus` return 1
pythagoreanTriples :: MonadPlus m => m (Int,Int,Int)
pythagoreanTriples = do
let number = (return 0) `mplus` (number >>= return . succ)
i <- number
guard $ i > 0
j <- number
guard $ j > 0
k <- number
guard $ k > 0
guard $ i*i + j*j == k*k
return (i,j,k)
pythagoreanTriplesLeftRecursion :: Monad m => StreamT m (Int,Int,Int)
pythagoreanTriplesLeftRecursion = do
let number = (suspended number >>= return . succ) `mplus` return 0
i <- number
j <- number
k <- number
guard $ i*i + j*j == k*k
return (i,j,k)
-- a serious test of left recursion (due to Will Byrd)
flaz :: Int -> Stream Int
flaz x = suspended (flaz x) `mplus` (suspended (flaz x) `mplus` if x == 5 then return x else mzero)
main :: IO ()
main = defaultMain $
#if __GLASGOW_HASKELL__ >= 702
localOption (mkTimeout 3000000) $ -- 3 second deadman timeout
#endif
testGroup "All"
[ testGroup "Monad Reader + env"
[ testCase "Monad Reader 1" monadReader1
, testCase "Monad Reader 2" monadReader2
, testCase "Monad Reader 3" monadReader3
]
, testGroup "Various monads"
[
-- nats will generate an infinite number of results; demonstrate
-- various ways of observing them via Stream/StreamT
testCase "runIdentity all" $ [0..4] @=? (take 5 $ runIdentity $ observeAllT nats)
, testCase "runIdentity many" $ [0..4] @=? (runIdentity $ observeManyT 5 nats)
, testCase "observeAll" $ [0..4] @=? (take 5 $ observeAll nats)
, testCase "observeMany" $ [0..4] @=? (observeMany 5 nats)
-- Ensure StreamT can be run over other base monads other than
-- List. Some are productive (Reader) and some are non-productive
-- (ExceptT, ContT) in the observeAll case.
, testCase "runReader is productive" $
[0..4] @=? (take 5 $ runReader (observeAllT nats) "!")
, testCase "observeManyT can be used with Either" $
(Right [0..4] :: Either Char [Integer]) @=?
(observeManyT 5 nats)
]
--------------------------------------------------
, testGroup "Control.Monad.Logic compatibility tests"
[
testCase "observe multi" $ 5 @=? observe odds5down
, testCase "observe none" $ (Left "No answer." @=?) =<< safely (observe mzero)
, testCase "observeAll multi" $ [5,1,3] @=? observeAll odds5down
, testCase "observeAll none" $ ([] :: [Integer]) @=? observeAll mzero
, testCase "observeMany multi" $ [5,1] @=? observeMany 2 odds5down
, testCase "observeMany none" $ ([] :: [Integer]) @=? observeMany 2 mzero
]
--------------------------------------------------
, testGroup "Control.Monad.Stream tests"
[
testCase "Pythagorean triples" $ [(3,4,5),(4,3,5),(6,8,10),(8,6,10),(5,12,13),(12,5,13),(9,12,15)] @=?
observeMany 7 pythagoreanTriples
, testCase "Pythagorean triples (left recursion)" $ [(3,4,5),(4,3,5),(6,8,10),(8,6,10)] @=?
filter (\(i,j,k) -> i /= 0 && j /= 0 && k /= 0)
(observeMany 27 pythagoreanTriplesLeftRecursion)
, testCase "flaz (left recursion)" $ replicate 15 5 @=?
observeMany 15 (flaz 5)
]
--------------------------------------------------
, testGroup "Control.Monad.Logic.Class tests"
[
testGroup "msplit laws"
[
testGroup "msplit mzero == return Nothing"
[
testCase "msplit mzero :: []" $
msplit mzero @=? return (Nothing :: Maybe (String, [String]))
, testCase "msplit mzero :: ReaderT" $
let z :: ReaderT Int [] String
z = mzero
in assertBool "ReaderT" $ null $ catMaybes $ runReaderT (msplit z) 0
, testCase "msplit mzero :: StreamT" $
let z :: StreamT [] String
z = mzero
in assertBool "StreamT" $ null $ catMaybes $ concat $ observeAllT (msplit z)
, testCase "msplit mzero :: strict StateT" $
let z :: SS.StateT Int [] String
z = mzero
in assertBool "strict StateT" $ null $ catMaybes $ SS.evalStateT (msplit z) 0
, testCase "msplit mzero :: lazy StateT" $
let z :: SL.StateT Int [] String
z = mzero
in assertBool "lazy StateT" $ null $ catMaybes $ SL.evalStateT (msplit z) 0
]
, testGroup "msplit (return a `mplus` m) == return (Just a, m)" $
let sample = [1::Integer,2,3] in
[
testCase "msplit []" $ do
let op = sample
extract = fmap (fmap fst)
extract (msplit op) @?= [Just 1]
extract (msplit op >>= (\(Just (_,nxt)) -> msplit nxt)) @?= [Just 2]
, testCase "msplit ReaderT" $ do
let op = ask
extract = fmap fst . catMaybes . flip runReaderT sample
extract (msplit op) @?= [sample]
extract (msplit op >>= (\(Just (_,nxt)) -> msplit nxt)) @?= []
, testCase "msplit StreamT" $ do
let op :: StreamT [] Integer
op = foldr (mplus . return) mzero sample
extract = fmap fst . catMaybes . concat . observeAllT
extract (msplit op) @?= [1]
extract (msplit op >>= (\(Just (_,nxt)) -> msplit nxt)) @?= [2]
, testCase "msplit strict StateT" $ do
let op :: SS.StateT Integer [] Integer
op = (SS.modify (+1) >> SS.get `mplus` op)
extract = fmap fst . catMaybes . flip SS.evalStateT 0
extract (msplit op) @?= [1]
extract (msplit op >>= \(Just (_,nxt)) -> msplit nxt) @?= [2]
, testCase "msplit lazy StateT" $ do
let op :: SL.StateT Integer [] Integer
op = (SL.modify (+1) >> SL.get `mplus` op)
extract = fmap fst . catMaybes . flip SL.evalStateT 0
extract (msplit op) @?= [1]
extract (msplit op >>= \(Just (_,nxt)) -> msplit nxt) @?= [2]
]
]
, testGroup "fair disjunction"
[
-- base case
testCase "some odds" $ [1,3,5,7] @=? observeMany 4 odds
-- identical to fair disjunction
, testCase "unfair disjunction" $ [1,2,3,5] @=? observeMany 4 oddsOrTwoUnfair
-- with fairness, the results are interleaved
, testCase "fair disjunction :: StreamT" $ [1,2,3,5] @=? observeMany 4 oddsOrTwoFair
-- without fairness nothing would be produced, but with
-- fairness, a production is obtained
, testCase "fair production" $ [2] @=? observeT oddsOrTwo
-- however, asking for additional productions will not
-- terminate (there are none, since the first clause generates
-- an infinity of mzero "failures")
, testCase "NONTERMINATION even when fair" $
(Left () @=?) =<< (nonTerminating $ observeManyT 2 oddsOrTwo)
-- Validate fair disjunction works for other
-- Control.Monad.Logic.Class instances
, testCase "fair disjunction :: []" $ [1,2,3,5] @=?
(take 4 $ let oddsL = [ 1::Integer ] `mplus` [ o | o <- [3..], odd o ]
oddsOrTwoLFair = oddsL `interleave` [2]
in oddsOrTwoLFair)
, testCase "fair disjunction :: ReaderT" $ [1,2,3,5] @=?
(take 4 $ runReaderT (let oddsR = return 1 `mplus` liftM (2+) oddsR
in oddsR `interleave` return (2 :: Integer)) "go")
, testCase "fair disjunction :: strict StateT" $ [1,2,3,5] @=?
(take 4 $ SS.evalStateT (let oddsS = return 1 `mplus` liftM (2+) oddsS
in oddsS `interleave` return (2 :: Integer)) "go")
, testCase "fair disjunction :: lazy StateT" $ [1,2,3,5] @=?
(take 4 $ SL.evalStateT (let oddsS = return 1 `mplus` liftM (2+) oddsS
in oddsS `interleave` return (2 :: Integer)) "go")
]
, testGroup "fair conjunction" $
[
-- Using the fair conjunction operator (>>-) the test produces values
testCase "fair conjunction :: StreamT" $ [2,4,6,8] @=?
observeMany 4 (let oddsPlus n = odds >>= \a -> return (a + n) in
do x <- (return 0 `mplus` return 1) >>- oddsPlus
if even x then return x else mzero
)
-- The first >>- results in a term that produces only a stream
-- of evens, so the >>- can produce from that stream. The
-- operation is effectively:
--
-- (interleave (return 0) (return 1)) >>- oddsPlus >>- if ...
--
-- And so the values produced for oddsPlus to consume are
-- alternated between 0 and 1, allowing oddsPlus to produce a
-- value for every 1 received.
, testCase "fair conjunction OK" $ [2,4,6,8] @=?
observeMany 4 (let oddsPlus n = odds >>= \a -> return (a + n) in
(return 0 `mplus` return 1) >>-
oddsPlus >>-
(\x -> if even x then return x else mzero)
)
-- This demonstrates that there is no choice to be made for
-- oddsPlus productions in the above and >>- is effectively >>=.
, testCase "fair conjunction also OK" $ [2,4,6,8] @=?
observeMany 4 (let oddsPlus n = odds >>= \a -> return (a + n) in
((return 0 `mplus` return 1) >>-
\a -> oddsPlus a) >>=
(\x -> if even x then return x else mzero)
)
-- Here the application is effectively rewritten as
--
-- interleave (oddsPlus 0 >>- \x -> if ...)
-- (oddsPlus 1 >>- \x -> if ...)
--
-- which produces values because interleaving suspended
-- Streams does *not* require production of values from
-- branches to switch between them (the first
-- (oddsPlus 0 ...) never produces any values).
, testCase "fair conjunction PRODUCTIVE" $ [2,4,6,8] @=?
observeMany 4 (let oddsPlus n = odds >>= \a -> return (a + n) in
(return 0 `mplus` return 1) >>-
\a -> oddsPlus a >>-
(\x -> if even x then return x else mzero)
)
-- This shows that the second >>- is effectively >>= since
-- there's no choice point for it, and values can still be
-- produced.
, testCase "fair conjunction also PRODUCTIVE" $ [2,4,6,8] @=?
observeMany 4 (let oddsPlus n = odds >>= \a -> return (a + n) in
(return 0 `mplus` return 1) >>-
\a -> oddsPlus a >>=
(\x -> if even x then return x else mzero)
)
-- identical to fair conjunction
, testCase "unfair conjunction is PRODUCTIVE" $ [2,4,6,8] @=?
observeMany 4 (let oddsPlus n = odds >>= \a -> return (a + n) in
do x <- (return 0 `mplus` return 1) >>= oddsPlus
if even x then return x else mzero
)
, testCase "fair conjunction :: []" $ [2,4,6,8] @=?
(take 4 $ let oddsL = [ 1 :: Integer ] `mplus` [ o | o <- [3..], odd o ]
oddsPlus n = [ a + n | a <- oddsL ]
in do x <- [0] `mplus` [1] >>- oddsPlus
if even x then return x else mzero
)
, testCase "fair conjunction :: ReaderT" $ [2,4,6,8] @=?
(take 4 $ runReaderT (let oddsR = return (1 :: Integer) `mplus` liftM (2+) oddsR
oddsPlus n = oddsR >>= \a -> return (a + n)
in do x <- (return 0 `mplus` return 1) >>- oddsPlus
if even x then return x else mzero
) "env")
, testCase "fair conjunction :: strict StateT" $ [2,4,6,8] @=?
(take 4 $ SS.evalStateT (let oddsS = return (1 :: Integer) `mplus` liftM (2+) oddsS
oddsPlus n = oddsS >>= \a -> return (a + n)
in do x <- (return 0 `mplus` return 1) >>- oddsPlus
if even x then return x else mzero
) "state")
, testCase "fair conjunction :: lazy StateT" $ [2,4,6,8] @=?
(take 4 $ SL.evalStateT (let oddsS = return (1 :: Integer) `mplus` liftM (2+) oddsS
oddsPlus n = oddsS >>= \a -> return (a + n)
in do x <- (return 0 `mplus` return 1) >>- oddsPlus
if even x then return x else mzero
) "env")
]
, testGroup "ifte logical conditional (soft-cut)"
[
-- Initial example returns all odds which are divisible by
-- another number. Nothing special is needed to implement this.
let iota n = msum (map return [1..n])
oc = do n <- odds
guard (n > 1)
d <- iota (n - 1)
guard (d > 1 && n `mod` d == 0)
return n
in testCase "divisible odds" $ [9,15,15,21,21,25,27,27,33,33] @=?
observeMany 10 oc
-- To get the inverse: all odds which are *not* divisible by
-- another number, the guard test cannot simply be reversed:
-- there are many produced values that are not divisors, but
-- some that are:
, let iota n = msum (map return [1..n])
oc = do n <- odds
guard (n > 1)
d <- iota (n - 1)
guard (d > 1 && n `mod` d /= 0)
return n
in testCase "indivisible odds, wrong" $
[3,5,5,7,5,7,7,9,7,7] @=?
observeMany 10 oc
-- For the inverse logic to work correctly, it should return
-- values only when there are *no* divisors at all. This can be
-- done using the "soft cut" or "negation as finite failure" to
-- needed to fail the current solution entirely. This is
-- provided by logict as the 'ifte' operator.
, let iota n = msum (map return [1..n])
oc = do n <- odds
guard (n > 1)
ifte (do d <- iota (n - 1)
guard (d > 1 && n `mod` d == 0))
(const mzero)
(return n)
in testCase "indivisible odds :: StreamT" $ [3,5,7,11,13,17,19,23,29,31] @=?
observeMany 10 oc
, let iota n = [1..n]
oddsL = [ 1 :: Integer ] `mplus` [ o | o <- [3..], odd o ]
oc = [ n
| n <- oddsL
, (n > 1)
] >>= \n -> ifte (do d <- iota (n - 1)
guard (d > 1 && n `mod` d == 0))
(const mzero)
(return n)
in testCase "indivisible odds :: []" $ [3,5,7,11,13,17,19,23,29,31] @=?
take 10 oc
, let iota n = msum (map return [1..n])
oddsR = return (1 :: Integer) `mplus` liftM (2+) oddsR
oc = do n <- oddsR
guard (n > 1)
ifte (do d <- iota (n - 1)
guard (d > 1 && n `mod` d == 0))
(const mzero)
(return n)
in testCase "indivisible odds :: ReaderT" $ [3,5,7,11,13,17,19,23,29,31] @=?
(take 10 $ runReaderT oc "env")
, let iota n = msum (map return [1..n])
oddsS = return (1 :: Integer) `mplus` liftM (2+) oddsS
oc = do n <- oddsS
guard (n > 1)
ifte (do d <- iota (n - 1)
guard (d > 1 && n `mod` d == 0))
(const mzero)
(return n)
in testCase "indivisible odds :: strict StateT" $ [3,5,7,11,13,17,19,23,29,31] @=?
(take 10 $ SS.evalStateT oc "state")
, let iota n = msum (map return [1..n])
oddsS = return (1 :: Integer) `mplus` liftM (2+) oddsS
oc = do n <- oddsS
guard (n > 1)
ifte (do d <- iota (n - 1)
guard (d > 1 && n `mod` d == 0))
(const mzero)
(return n)
in testCase "indivisible odds :: strict StateT" $ [3,5,7,11,13,17,19,23,29,31] @=?
(take 10 $ SL.evalStateT oc "state")
]
, testGroup "once (pruning)" $
-- the pruning primitive 'once' selects (non-deterministically)
-- a single candidate from many results and disables any further
-- backtracking on this choice.
let bogosort l = do p <- permute l
if sorted p then return p else mzero
sorted (e:e':r) = e <= e' && sorted (e':r)
sorted _ = True
permute [] = return []
permute (h:t) = do { t' <- permute t; insert h t' }
insert e [] = return [e]
insert e l@(h:t) = return (e:l) `mplus`
do { t' <- insert e t; return (h : t') }
inp = [5,0,3,4,0,1 :: Integer]
in
[
-- without pruning, get two results because 0 appears twice
testCase "no pruning" $ [[0,0,1,3,4,5], [0,0,1,3,4,5]] @=?
observeAll (bogosort inp)
-- with pruning, stops after the first result
, testCase "with pruning" $ [[0,0,1,3,4,5]] @=?
observeAll (once (bogosort inp))
]
]
, testGroup "lnot (inversion)" $
let isEven n = if even n then return n else mzero in
[
testCase "inversion :: StreamT" $ [1,3,5,7,9] @=?
observeMany 5 (do v <- foldr (mplus . return) mzero [(1::Integer)..]
lnot (isEven v)
return v)
, testCase "inversion :: []" $ [1,3,5,7,9] @=?
(take 5 $ do v <- [(1::Integer)..]
lnot (isEven v)
return v)
, testCase "inversion :: ReaderT" $ [1,3,5,7,9] @=?
(take 5 $ runReaderT (do v <- foldr (mplus . return) mzero [(1::Integer)..]
lnot (isEven v)
return v) "env")
, testCase "inversion :: strict StateT" $ [1,3,5,7,9] @=?
(take 5 $ SS.evalStateT (do v <- foldr (mplus . return) mzero [(1::Integer)..]
lnot (isEven v)
return v) "state")
, testCase "inversion :: lazy StateT" $ [1,3,5,7,9] @=?
(take 5 $ SL.evalStateT (do v <- foldr (mplus . return) mzero [(1::Integer)..]
lnot (isEven v)
return v) "state")
]
]
safely :: IO Integer -> IO (Either String Integer)
safely o = fmap (left (head . lines . show)) (try o :: IO (Either SomeException Integer))
-- | This is used to test logic operations that don't typically
-- terminate by running a parallel race between the operation and a
-- timer. A result of @Left ()@ means that the timer won and the
-- operation did not terminate within that time period.
nonTerminating :: IO a -> IO (Either () a)
nonTerminating op = race (threadDelay 100000) op -- returns Left () after 0.1s