scc-0.1: Test.hs
{-
Copyright 2008 Mario Blazevic
This file is part of the Streaming Component Combinators (SCC) project.
The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
version.
SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
You should have received a copy of the GNU General Public License along with SCC. If not, see
<http://www.gnu.org/licenses/>.
-}
{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, ScopedTypeVariables, PatternSignatures #-}
module Test where
import Control.Concurrent.SCC.Foundation
import Control.Concurrent.SCC.ComponentTypes
import Control.Concurrent.SCC.Components
import Control.Concurrent.SCC.Combinators hiding ((&&), (||))
import qualified Control.Concurrent.SCC.Combinators as Combinators
import Control.Monad (liftM)
import Data.Char (ord, isLetter, isSpace, toUpper)
import Data.Dynamic (Typeable)
import Data.List (find, stripPrefix, groupBy, intersect, union, intercalate, isInfixOf, isPrefixOf, isSuffixOf, sort)
import Data.Maybe (fromJust)
import qualified Data.List as List
import qualified Data.Foldable as Foldable
import qualified Data.Sequence as Seq
import Data.Sequence (Seq, (|>), ViewL (EmptyL, (:<)))
import Debug.Trace (trace)
import Prelude hiding (even, last)
import qualified Prelude
import Test.QuickCheck (Arbitrary, Property,
arbitrary, coarbitrary, label, choose, oneof, sized, quickCheck, trivial, variant, (==>))
sublists [] _ = []
sublists _ [] = []
sublists sublist input = case stripPrefix sublist input
of Just rest -> sublist ++ sublists sublist rest
Nothing -> sublists sublist (tail input)
main = mapM_ quickCheck tests
tests = [label "pipe" $ \(input :: [Int])-> runPipes (pipe (putList input) getList) == Just ([], input),
label "pour" prop_pour,
label "asis" prop_asis,
label "suppress" prop_suppress,
label "substitute" prop_substitute,
label "prepend" prop_prepend,
label "append" prop_append,
label "allTrue" prop_allTrue,
label "allFalse" prop_allFalse,
label "substring" prop_substring,
label "group" prop_group,
label "concatenate" prop_concatenate,
label "concatSeparate" prop_concatSeparate,
label "uppercase ->>" $ \s-> runPipes (pipe (putList s) (uppercase ->> getList)) == Just ([], map toUpper s),
label "uppercase <<-" $ \s-> runPipes (pipe (uppercase <<- putList s) getList) == Just ([], map toUpper s),
label "uppercase `join` asis" $ \s-> transducerOutput (uppercase `join` asis) s == map toUpper s ++ s,
label "prepend >-> append" $ \s-> transducerOutput (prepend "Hello, " >-> append "!") s == "Hello, "++ s ++ "!",
label "whitespace" $ \s-> splitterOutputs whitespace s == (filter isSpace s, filter (not . isSpace) s),
label "ifs allTrue asis asis" $ \(s :: [TestEnum])-> transducerOutput (ifs allTrue asis asis) s == s,
label "substring" $ \s (c :: TestEnum)-> splitterOutputs (substring [c]) s == (filter (==c) s, filter (/=c) s),
label "ifs (substring X) uppercase asis" $
\s (LowercaseLetter c)-> transducerOutput (ifs (substring [c]) uppercase asis) s
== map (\x-> if x == c then toUpper x else x) s,
label "count >-> toString >-> concatenate" $
\(s :: [TestEnum])-> transducerOutput (count >-> toString >-> concatenate) s == show (length s),
label "foreach whitespace asis (prepend \"[\" >-> append \"]\")" $
\s-> transducerOutput (foreach whitespace asis (prepend "[" >-> append "]")) s == mapWords (("[" ++) . (++ "]")) s,
label "foreach whitespace asis (count >-> toString >-> concatenate)" $
\s-> transducerOutput (foreach whitespace asis (count >-> toString >-> concatenate)) s == mapWords (show . length) s,
label "uppercase `wherever` (snot whitespace `having` substring X)" $
\s1 s2-> not (null s1) && length s1 < length s2 ==> trivial (not (s1 `isInfixOf` s2)) $
transducerOutput (uppercase `wherever` (snot whitespace `having` substring s1)) s2
== mapWords (\w-> if s1 `isInfixOf` w then map toUpper w else w) s2,
label "(uppercase `wherever` (snot whitespace `havingOnly` letters))" $
\s-> transducerOutput (uppercase `wherever` (snot whitespace `havingOnly` letters)) s
== mapWords (\w-> if all isLetter w then map toUpper w else w) s,
label "select $ substring" $ transducerOutput (select $ substring "o, ") "Hello, World!" == "o, ",
label "(uppercase `wherever` (first letters))"
(transducerOutput (uppercase `wherever` (first letters)) "... Hello, World !" == "... HELLO, World !"
&& transducerOutput (uppercase `wherever` (first letters)) "Hello, World !" == "HELLO, World !"),
label "(uppercase `wherever` (prefix letters))"
(transducerOutput (wherever uppercase (prefix letters)) "... Hello, World !" == "... Hello, World !"
&& transducerOutput (uppercase `wherever` (prefix letters)) "Hello, World !" == "HELLO, World !"),
label "(uppercase `wherever` (suffix letters))"
(transducerOutput (uppercase `wherever` (suffix letters)) "Hello, World!" == "Hello, World!"
&& transducerOutput (uppercase `wherever` (suffix letters)) "Hello, World" == "Hello, WORLD"),
label "(uppercase `wherever` (last letters))"
(transducerOutput (uppercase `wherever` (last letters)) "Hello, World!" == "Hello, WORLD!"
&& transducerOutput (uppercase `wherever` (last letters)) "Hello, World" == "Hello, WORLD"),
label "(select (prefix letters))" (transducerOutput (select (prefix letters)) "Hello, World!" == "Hello"),
label "(foreach letters (count >-> toString >-> concatenate) asis)"
(transducerOutput (foreach letters (count >-> toString >-> concatenate) asis) "Hola, Mundo!" == "4, 5!"),
label "(foreach (letters `having` prefix (substring \"H\")) uppercase asis)"
(transducerOutput (foreach (letters `having` prefix (substring "H")) uppercase asis) "Hello, World! Hola, Mundo!"
== "HELLO, World! HOLA, Mundo!"),
label "(foreach (letters `having` suffix (substring \"o\")) uppercase asis)"
(transducerOutput (foreach (letters `having` suffix (substring "o")) uppercase asis) "Hello, World! Hola, Mundo!"
== "HELLO, World! Hola, MUNDO!"),
label "first one" $ \s-> splitterOutputs (first one) s == if null s then ("", "") else ([head s], tail s),
label "last one" $ \s-> splitterOutputs (last one) s == if null s then ("", "") else ([List.last s], init s),
label "prefix one" $ \s-> splitterOutputs (prefix one) s == if null s then ("", "") else ([head s], tail s),
label "suffix one" $ \s-> splitterOutputs (suffix one) s == if null s then ("", "") else ([List.last s], init s),
label "uptoFirst one" $ \s-> splitterOutputs (uptoFirst one) s == if null s then ("", "") else ([head s], tail s),
label "lastAndAfter one" $ \s-> splitterOutputs (lastAndAfter one) s == if null s then ("", "")
else ([List.last s], init s),
label "snot" $ prop_snot . splitterFromTrace,
label "DeMorgan 1" $ \trace1 trace2-> prop_DeMorgan1 (splitterFromTrace trace1) (splitterFromTrace trace2),
label "DeMorgan 2" $ \trace1 trace2-> prop_DeMorgan2 (splitterFromTrace trace1) (splitterFromTrace trace2),
label "&&" $ \trace1 trace2-> prop_and (splitterFromTrace trace1) (splitterFromTrace trace2),
label "||" $ \trace1 trace2-> prop_or (splitterFromTrace trace1) (splitterFromTrace trace2),
label "even" $ prop_even . splitterFromTrace,
label "prefix 1" $ prop_prefix_1 . splitterFromTrace,
label "prefix 2" $ prop_prefix_2 . splitterFromTrace,
label "suffix 1" $ prop_suffix_1 . splitterFromTrace,
label "suffix 2" $ prop_suffix_2 . splitterFromTrace,
label "first" $ prop_first . splitterFromTrace,
label "last" $ prop_last . splitterFromTrace,
label "uptoFirst" $ prop_uptoFirst . splitterFromTrace,
label "lastAndAfter" $ prop_lastAndAfter . splitterFromTrace,
label "followedBy prefix" $ \trace1 trace2 n-> prop_followedBy1 (splitterFromTrace trace1) (splitterFromTrace trace2) n,
label "first followedBy" $ \trace1 trace2 n-> prop_followedBy2 (splitterFromTrace trace1) (splitterFromTrace trace2) n,
label "substring followedBy substring 1" prop_followedBy3,
label "substring followedBy substring 2" prop_followedBy4,
label "between..." $ \trace1 trace2 n-> prop_between_first_last (simpleSplitterFromTrace trace1)
(simpleSplitterFromTrace trace2) n]
prop_pour :: [Int] -> Bool
prop_pour input = runPipes (pipeD "input" (putList input) (\source-> pipeD "output" (\sink-> pour source sink) getList))
== Just ([], ((), input))
prop_asis :: [Int] -> Bool
prop_asis input = transducerOutput asis input == input
prop_suppress :: [Int] -> Bool
prop_suppress input = null (transducerOutput (suppress :: Transducer Maybe Int ()) input)
prop_substitute :: [Int] -> [Maybe Int] -> Bool
prop_substitute input replacement = transducerOutput (substitute replacement) input == replacement
prop_prepend :: [Int] -> [Int] -> Bool
prop_prepend input prefix = transducerOutput (prepend prefix) input == prefix ++ input
prop_append :: [Int] -> [Int] -> Bool
prop_append input suffix = transducerOutput (append suffix) input == input ++ suffix
prop_allTrue :: [Int] -> Bool
prop_allTrue input = splitterOutputs allTrue input == (input, [])
prop_allFalse :: [Int] -> Bool
prop_allFalse input = splitterOutputs allFalse input == ([], input)
prop_substring :: [TestEnum] -> [TestEnum] -> Property
prop_substring input sublist = trivial (not (isInfixOf sublist input)) (fst (splitterOutputs (substring sublist) input)
== sublists sublist input)
prop_group :: [Int] -> Bool
prop_group input = transducerOutput group input == [input]
prop_concatenate :: [[TestEnum]] -> Bool
prop_concatenate input = transducerOutput concatenate input == concat input
prop_concatSeparate :: [[TestEnum]] -> [TestEnum] -> Bool
prop_concatSeparate input separator = transducerOutput (concatSeparate separator) input == intercalate separator input
prop_snot :: Splitter Maybe Int -> [Int] -> Bool
prop_snot splitter input = splitterOutputs (snot splitter) input == swap (splitterOutputs splitter input)
prop_andAssoc :: SplitterTrace -> SplitterTrace -> SplitterTrace -> [Int] -> Bool
prop_andAssoc st1 st2 st3 input = --trace (show $ (splitterOutputs (s1 >& (s2 >& s3)) input, splitterOutputs ((s1 >& s2) >& s3) input)) $
splitterOutputs (s1 >& (s2 >& s3)) input == splitterOutputs ((s1 >& s2) >& s3) input
where s1 = splitterFromTrace st1
s2 = splitterFromTrace st2
s3 = splitterFromTrace st3
prop_orAssoc :: SplitterTrace -> SplitterTrace -> SplitterTrace -> [Int] -> Bool
prop_orAssoc st1 st2 st3 input = splitterOutputs (s1 >| (s2 >| s3)) input == splitterOutputs ((s1 >| s2) >| s3) input
where s1 = splitterFromTrace st1
s2 = splitterFromTrace st2
s3 = splitterFromTrace st3
prop_DeMorgan1 :: Splitter Maybe Int -> Splitter Maybe Int -> [Int] -> Bool
prop_DeMorgan1 s1 s2 input = splitterOutputs (snot (s1 >& s2)) input == splitterOutputs (snot s1 >| snot s2) input
prop_DeMorgan2 :: Splitter Maybe Int -> Splitter Maybe Int -> [Int] -> Bool
prop_DeMorgan2 s1 s2 input = splitterOutputs (snot (s1 >| s2)) input == splitterOutputs (snot s1 >& snot s2) input
prop_and :: Splitter Maybe Int -> Splitter Maybe Int -> Int -> Bool
prop_and s1 s2 n = fst (splitterOutputs (s1 Combinators.&& s2) l)
== fst (splitterOutputs s1 l) `intersect` fst (splitterOutputs s2 l)
where l = [1 .. abs n]
prop_or :: Splitter Maybe Int -> Splitter Maybe Int -> Int -> Bool
prop_or s1 s2 n = fst (splitterOutputs (s1 Combinators.|| s2) l)
== sort (fst (splitterOutputs s1 l) `union` fst (splitterOutputs s2 l))
where l = [1 .. abs n]
prop_even :: Splitter Maybe TestEnum -> [TestEnum] -> Bool
prop_even splitter input = let splitOddEven [] = ([], [])
splitOddEven (head:tail) = let (evens, odds) = splitOddEven tail in (head:odds, evens)
in fst (splitterOutputs (even splitter) input)
== concat (snd $ splitOddEven $ transducerOutput (foreach splitter group suppress) input)
prop_prefix_1 :: Splitter Maybe TestEnum -> [TestEnum] -> Bool
prop_prefix_1 splitter input = let (pfx, rest) = splitterOutputs (prefix splitter) input
(true, false) = splitterOutputs splitter input
in pfx ++ rest == input && pfx `isPrefixOf` true
prop_prefix_2 :: Splitter Maybe TestEnum -> [TestEnum] -> Bool
prop_prefix_2 splitter input = let (prefix1, rest1) = splitterOutputs (prefix splitter) input
in case splitterOutputChunks splitter input
of (prefix2, True):rest2 -> prefix1 == prefix2 && rest1 == concat (map fst rest2)
(prefix2, False):rest2 -> prefix1 == [] && rest1 == prefix2 ++ concat (map fst rest2)
[] -> prefix1 ++ rest1 == []
prop_suffix_1 :: Splitter Maybe TestEnum -> [TestEnum] -> Bool
prop_suffix_1 splitter input = let (sfx, rest) = splitterOutputs (suffix splitter) input
(true, false) = splitterOutputs splitter input
in rest ++ sfx == input && sfx `isSuffixOf` true
prop_suffix_2 :: Splitter Maybe TestEnum -> [TestEnum] -> Bool
prop_suffix_2 splitter input = let (suffix1, rest1) = splitterOutputs (suffix splitter) input
in case reverse (splitterOutputChunks splitter input)
of (suffix2, True):rest2 -> suffix1 == suffix2 && rest1 == concat (map fst (reverse rest2))
(suffix2, False):rest2 -> suffix1 == [] && rest1 == concat (map fst (reverse rest2)) ++ suffix2
[] -> rest1 ++ suffix1 == []
prop_first :: Splitter Maybe TestEnum -> [TestEnum] -> Bool
prop_first splitter input = let (first1, rest1) = splitterOutputs (first splitter) input
in case splitterOutputChunks splitter input
of (first2, True):rest2 -> first1 == first2 && rest1 == concat (map fst rest2)
(prefix, False):(first2, True):rest2 -> first1 == first2
&& rest1 == prefix ++ concat (map fst rest2)
(prefix, False):[] -> first1 == [] && rest1 == prefix
[] -> first1 ++ rest1 == []
prop_last :: Splitter Maybe TestEnum -> [TestEnum] -> Bool
prop_last splitter input = let (last1, rest1) = splitterOutputs (last splitter) input
in -- trace (show (last1, rest1)) $ trace (show (splitterOutputChunks splitter input)) $
case reverse (splitterOutputChunks splitter input)
of (last2, True):rest2 -> last1 == last2 && rest1 == concat (map fst (reverse rest2))
(suffix, False):(last2, True):rest2 -> last1 == last2
&& rest1 == concat (map fst (reverse rest2)) ++ suffix
(suffix, False):[] -> last1 == [] && rest1 == suffix
[] -> last1 ++ rest1 == []
prop_uptoFirst :: Splitter Maybe TestEnum -> [TestEnum] -> Bool
prop_uptoFirst splitter input = let (first1, rest1) = splitterOutputs (uptoFirst splitter) input
in case splitterOutputChunks splitter input
of (first2, True):rest2 -> first1 == first2 && rest1 == concat (map fst rest2)
(prefix, False):(first2, True):rest2 -> first1 == prefix ++ first2
&& rest1 == concat (map fst rest2)
(prefix, False):[] -> first1 == [] && rest1 == prefix
[] -> first1 ++ rest1 == []
prop_lastAndAfter :: Splitter Maybe TestEnum -> [TestEnum] -> Bool
prop_lastAndAfter splitter input = let (last1, rest1) = splitterOutputs (lastAndAfter splitter) input
in case reverse (splitterOutputChunks splitter input)
of (last2, True):rest2 -> last1 == last2 && rest1 == concat (map fst (reverse rest2))
(suffix, False):(last2, True):rest2 -> last1 == last2 ++ suffix
&& rest1 == concat (map fst (reverse rest2))
(suffix, False):[] -> last1 == [] && rest1 == suffix
[] -> last1 ++ rest1 == []
prop_followedBy1 :: Splitter Maybe Int -> Splitter Maybe Int -> Int -> Bool
prop_followedBy1 s1 s2 n = splitterOutputs (s1 `followedBy` s2) l == splitterOutputs (s1 `followedBy` prefix s2) l
where l = [1 .. abs n]
prop_followedBy2 :: Splitter Maybe Int -> Splitter Maybe Int -> Int -> Bool
prop_followedBy2 s1 s2 n = splitterOutputs (first (s1 `followedBy` s2)) l == splitterOutputs (first s1 `followedBy` s2) l
where l = [1 .. abs n]
prop_followedBy3 :: [TestEnum] -> [TestEnum] -> [TestEnum] -> Property
prop_followedBy3 l1 l2 l3 = trivial (not (isInfixOf l1 l3)) (fst (splitterOutputs (substring l1 `followedBy` substring l2) l3)
== sublists (l1 ++ l2) l3)
prop_followedBy4 :: [TestEnum] -> [TestEnum] -> [TestEnum] -> Property
prop_followedBy4 l1 l2 l3 = isInfixOf l1 l3
==> trivial (not (isInfixOf (l1 ++ l2) l3)) (fst (splitterOutputs (substring l1
`followedBy` substring l2) l3)
== sublists (l1 ++ l2) l3)
prop_between_first_last :: Splitter Maybe Int -> Splitter Maybe Int -> Int -> Bool
prop_between_first_last s1 s2 n = fst (splitterOutputs (first s1 ... last s2) l)
== sort (fst (splitterOutputs (first s1 `between` last s2) l)
`union`
limits (fst $ splitterOutputs (first s1) l) (fst $ splitterOutputs (last s2) l))
where limits [] _ = []
limits l1 [] = l1
limits l1 l2 | head l1 <= head l2 = l1 `union` l2
| head l1 <= Prelude.last l2 = [head l1 .. Prelude.last l2]
| otherwise = l1
l = [1 .. abs n]
transducerOutput :: (Typeable x, Typeable y) => Transducer Maybe x y -> [x] -> [y]
transducerOutput t input = case runPipes (pipeD "transducerOutput input"
(putList input)
(\source-> pipeD "transducerOutput output"
(\sink-> transduce t source sink)
getList))
of Just ([], ([], output)) -> output
splitterOutputs :: Typeable x => Splitter Maybe x -> [x] -> ([x], [x])
splitterOutputs s input = case runPipes (pipeD "splitterOutputs input"
(putList input)
(\source-> pipeD "splitterOutputs true"
(\true-> pipeD "splitterOutputs false"
(split s source true)
getList)
getList))
of Just ([], (([], false), true)) -> (true, false)
splitterOutputChunks :: Typeable x => Splitter Maybe x -> [x] -> [([x], Bool)]
splitterOutputChunks s input = transducerOutput (foreach s
(group >-> lift121Transducer (\chunk-> (chunk, True)))
(group >-> lift121Transducer (\chunk-> (chunk, False))))
input
simpleSplitterFromTrace :: (Show x, Typeable x) => SimpleSplitterTrace -> Splitter Maybe x
simpleSplitterFromTrace (init, last) = splitterFromTrace (map (maybe Nothing (Just . (,) True)) init, last)
splitterFromTrace :: (Show x, Typeable x) => SplitterTrace -> Splitter Maybe x
splitterFromTrace trace1 = liftSectionSplitter $
\source true false->
let follow trace2@(head:tail) q = get source >>= maybe fail succeed
where succeed x = let q' = q |> Just x
in case head
of Nothing -> follow tail q'
Just (False, b) -> (if b then put true else put false) Nothing
>>= cond
(follow tail q')
(return $ Foldable.toList (Seq.viewl q))
Just (True, True) -> putList (Foldable.toList (Seq.viewl q')) true
>>= whenNull (follow tail Seq.empty)
Just (True, False) -> putList (Foldable.toList (Seq.viewl q')) false
>>= whenNull (follow tail Seq.empty)
fail = if find (maybe False fst) trace2 == Just (Just (True, True))
then putList (Foldable.toList (Seq.viewl q)) true
else putList (Foldable.toList (Seq.viewl q)) false
in liftM (map fromJust) $ follow (cycle (fst trace1 ++ [Just (True, snd trace1)])) Seq.empty
swap :: (x, y) -> (y, x)
swap (x, y) = (y, x)
mapWords :: (String -> String) -> String -> String
mapWords f s = concat (map (\w@(c:_)-> if isSpace c then w else f w) (groupBy (\x y-> isSpace x == isSpace y) s))
type SimpleSplitterTrace = ([Maybe Bool], Bool)
type SplitterTrace = ([Maybe (Bool, Bool)], Bool)
data TestEnum = One | Two | Three | Four | Five deriving (Eq, Show, Typeable)
newtype LowercaseLetter = LowercaseLetter Char deriving (Eq, Show, Typeable)
instance Arbitrary TestEnum where
arbitrary = oneof (map return [One, Two, Three, Four, Five])
coarbitrary enum = variant (case enum of {One -> 0; Two -> 1; Three -> 2; Four -> 3; Five -> 4})
instance Arbitrary Char where
arbitrary = choose ('\32', '\128')
coarbitrary c = variant ((ord c - 32) `rem` 128)
instance Arbitrary LowercaseLetter where
arbitrary = fmap LowercaseLetter (choose ('a', 'z'))
coarbitrary (LowercaseLetter c) = variant ((ord c - 65) `rem` 26)
instance Arbitrary (Splitter Maybe Int) where
arbitrary = fmap splitterFromTrace arbitrary
coarbitrary s gen = sized (\n-> coarbitrary (transducerOutput (ifs s
(lift121Transducer $ const True)
(lift121Transducer $ const False))
[1..n]) gen)