{- 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 . -} {-# LANGUAGE DeriveDataTypeable, FlexibleInstances, ScopedTypeVariables, PatternSignatures #-} module Main 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 Control.Monad.Identity (Identity (Identity)) 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 "everything" prop_allTrue, label "nothing" 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) (consume $ uppercase >-> liftAtomicConsumer "getList" 1 getList)) == Just ([], map toUpper s), label "uppercase <<-" $ \s-> runPipes (pipe (produce $ liftAtomicProducer "putList" 1 (putList s) >-> uppercase) getList) == Just ([], map toUpper s), label "uppercase `join` asis" $ \s-> transducerOutput (uppercase `join` asis) s == map toUpper s ++ s, label "prepend >-> append" (\(s :: String) prefix suffix-> transducerOutput (prepend (fromList prefix) >-> append (fromList suffix)) s == prefix ++ s ++ suffix), label "prepend == (`join` asis) . substitute" $ \(s :: String) prefix-> transducerOutput (prepend (fromList prefix)) s == transducerOutput (substitute (fromList prefix) `join` asis) s, label "append == (asis `join`) . substitute" $ \(s :: String) suffix-> transducerOutput (append (fromList suffix)) s == transducerOutput (asis `join` substitute (fromList suffix)) s, label "whitespace" $ \s-> splitterOutputs whitespace s == (filter isSpace s, filter (not . isSpace) s), label "ifs everything asis asis" $ \(s :: [TestEnum])-> transducerOutput (ifs everything 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 (fromList "[") >-> append (fromList "]"))) 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 "substring followedBy substring 3" prop_followedBy5, label "... followedBy ..." prop_followedByBetween, label "start ... end" $ \trace n-> prop_between1 (simpleSplitterFromTrace trace) n, label "start everything ... end" $ \trace n-> prop_between2 (simpleSplitterFromTrace trace) 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 (consumeBy suppress :: Transducer Identity Int ()) input) prop_substitute :: [Int] -> [Maybe Int] -> Bool prop_substitute input replacement = transducerOutput (substitute $ fromList replacement) input == replacement prop_prepend :: [Int] -> [Int] -> Int -> Property prop_prepend input prefix threads = threads > 0 ==> transducerOutput (usingThreads threads $ prepend $ fromList prefix) input == prefix ++ input prop_append :: [Int] -> [Int] -> Int -> Property prop_append input suffix threads = threads > 0 ==> transducerOutput (usingThreads threads $ append $ fromList suffix) input == input ++ suffix prop_allTrue :: [Int] -> Bool prop_allTrue input = splitterOutputs everything input == (input, []) prop_allFalse :: [Int] -> Bool prop_allFalse input = splitterOutputs nothing 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 Identity Int -> [Int] -> Bool prop_snot splitter input = splitterOutputs (snot splitter) input == swap (splitterOutputs splitter input) prop_andAssoc :: SplitterTrace -> SplitterTrace -> SplitterTrace -> [Int] -> Int -> Int -> Property prop_andAssoc st1 st2 st3 input t1 t2 = t1 > 0 && t2 > 0 ==> splitterOutputs (usingThreads t1 $ s1 >& (s2 >& s3)) input == splitterOutputs (usingThreads t2 $ (s1 >& s2) >& s3) input where s1 = splitterFromTrace st1 s2 = splitterFromTrace st2 s3 = splitterFromTrace st3 prop_orAssoc :: SplitterTrace -> SplitterTrace -> SplitterTrace -> [Int] -> Int -> Int -> Property prop_orAssoc st1 st2 st3 input t1 t2 = t1 > 0 && t2 > 0 ==> splitterOutputs (usingThreads t1 $ s1 >| (s2 >| s3)) input == splitterOutputs (usingThreads t2 $ (s1 >| s2) >| s3) input where s1 = splitterFromTrace st1 s2 = splitterFromTrace st2 s3 = splitterFromTrace st3 prop_DeMorgan1 :: Splitter Identity Int -> Splitter Identity Int -> [Int] -> Int -> Int -> Property prop_DeMorgan1 s1 s2 input t1 t2 = t1 > 0 && t2 > 0 ==> splitterOutputs (usingThreads t1 $ snot (s1 >& s2)) input == splitterOutputs (usingThreads t2 $ snot s1 >| snot s2) input prop_DeMorgan2 :: Splitter Identity Int -> Splitter Identity Int -> [Int] -> Int -> Int -> Property prop_DeMorgan2 s1 s2 input t1 t2 = t1 > 0 && t2 > 0 ==> splitterOutputs (usingThreads t1 $ snot (s1 >| s2)) input == splitterOutputs (usingThreads t2 $ snot s1 >& snot s2) input prop_and :: Splitter Identity Int -> Splitter Identity 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 Identity Int -> Splitter Identity 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 Identity 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 (consumeBy suppress)) input) prop_prefix_1 :: Splitter Identity 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 Identity 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 Identity 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 Identity 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 Identity 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 Identity 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 Identity 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 Identity 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 Identity Int -> Splitter Identity 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 Identity Int -> Splitter Identity 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_followedBy5 :: Int -> Int -> Int -> Int -> Bool prop_followedBy5 i1 i2 i3 i4 = let n1 = abs i1 n2 = n1 + abs i2 n3 = n2 + abs i3 + 1 n4 = n3 + abs i4 in splitterOutputs (substring [n1 .. n2] `followedBy` substring [n2 + 1 .. n3]) [0 .. n4] == ([n1 .. n3], [0 .. n1 - 1] ++ [n3 + 1 .. n4]) prop_followedByBetween :: Int -> Int -> Int -> Int -> Bool prop_followedByBetween i1 i2 i3 i4 = let n1 = abs i1 n2 = n1 + abs i2 n3 = n2 + abs i3 + 1 n4 = n3 + abs i4 in splitterOutputs ((substring [n1] ... substring [n2]) `followedBy` (substring [n2 + 1] ... substring [n3])) [0 .. n4] == ([n1 .. n3], [0 .. n1 - 1] ++ [n3 + 1 .. n4]) prop_between1 :: Splitter Identity Int -> Int -> Bool prop_between1 splitter n = splitterOutputs (startOf splitter ... endOf splitter) input == splitterOutputs splitter input && splitterOutputs (endOf splitter ... startOf splitter) input == ([], input) where input = [1 .. abs n] prop_between2 :: Splitter Identity Int -> Int -> Bool prop_between2 splitter n = splitterOutputs (startOf everything ... endOf splitter) input == splitterOutputs (uptoFirst splitter) input || null (fst $ splitterOutputs splitter input) where input = [1 .. abs n] transducerOutput :: (Typeable x, Typeable y) => Transducer Identity 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 Identity ([], ([], output)) -> output splitterOutputs :: Typeable x => Splitter Identity 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 Identity ([], (([], false), true)) -> (true, false) splitterOutputChunks :: Typeable x => Splitter Identity x -> [x] -> [([x], Bool)] splitterOutputChunks s input = transducerOutput (foreach s (group >-> lift121Transducer "true" (\chunk-> (chunk, True))) (group >-> lift121Transducer "false" (\chunk-> (chunk, False)))) input simpleSplitterFromTrace :: (Show x, Typeable x) => SimpleSplitterTrace -> Splitter Identity x simpleSplitterFromTrace (init, last) = splitterFromTrace (map (maybe Nothing (Just . (,) True)) init, last) splitterFromTrace :: (Show x, Typeable x) => SplitterTrace -> Splitter Identity x splitterFromTrace trace1 = liftAtomicSectionSplitter "splitterFromTrace" 1 $ \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 (Enum, 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 Identity Int) where arbitrary = fmap splitterFromTrace arbitrary coarbitrary s gen = sized (\n-> coarbitrary (transducerOutput (ifs s (lift121Transducer "true" $ const True) (lift121Transducer "false" $ const False)) [1..n]) gen)