1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
module Main where
import Prelude hiding (foldr, foldl, foldl', foldr1, foldl1, length, null, sum,
product, all, any, and, or)
import Data.Foldable
import Control.Exception
import Data.Array
import Data.Foldable
import Data.Typeable
import Data.Either
import Control.Applicative
import Control.DeepSeq
#if __GLASGOW_HASKELL__ < 709
import qualified Data.List as L
#else
import qualified GHC.List as L
#endif
data BadElementException = BadFirst | BadLast deriving (Show, Eq)
instance Exception BadElementException
newtype ForceDefault f a = ForceDefault (f a)
instance Foldable f => Foldable (ForceDefault f) where
foldMap f (ForceDefault c) = foldMap f c
goodLists, badFronts, badBacks :: [[Integer]]
goodLists = [[0..n] | n <- [(-1)..5]]
badFronts = map (throw BadFirst :) goodLists
badBacks = map (++ [throw BadLast]) goodLists
doubleBads = map (\l -> throw BadFirst : l ++ [throw BadLast]) goodLists
lists =
goodLists
++ badFronts
++ badBacks
++ doubleBads
makeArray xs = array (1::Int, length xs) (zip [1..] xs)
arrays = map makeArray lists
goodArrays = map makeArray goodLists
strictCons x y = x + 10*y
rightLazyCons x y = x
leftLazyCons x y = y
conses :: [Integer -> Integer -> Integer]
conses = [(+), strictCons, rightLazyCons, leftLazyCons]
runOneRight :: forall f . Foldable f =>
(forall a b . (a -> b -> b) -> b -> f a -> b) ->
(Integer -> Integer -> Integer) -> f Integer ->
IO (Either BadElementException Integer)
runOneRight fol f container = try (evaluate (fol f 12 container))
runOne1 :: forall f . Foldable f => (forall a . (a -> a -> a) -> f a -> a) ->
(Integer -> Integer -> Integer) -> f Integer ->
IO (Either BadElementException Integer)
runOne1 fol f container = try (evaluate (fol f container))
runOneLeft :: forall f . Foldable f =>
(forall a b . (b -> a -> b) -> b -> f a -> b) ->
(Integer -> Integer -> Integer) -> f Integer ->
IO (Either BadElementException Integer)
runOneLeft fol f container = try (evaluate (fol f 13 container))
runWithAllRight :: forall f . Foldable f =>
(forall a b . (a -> b -> b) -> b -> f a -> b) ->
[f Integer] -> IO [Either BadElementException Integer]
runWithAllRight fol containers =
mapM (uncurry (runOneRight fol)) [(f,c) | f <- conses, c <- containers]
runWithAll1 :: forall f . Foldable f =>
(forall a . (a -> a -> a) -> f a -> a) ->
[f Integer] -> IO [Either BadElementException Integer]
runWithAll1 fol containers =
mapM (uncurry (runOne1 fol)) [(f,c) | f <- conses, c <- containers]
runWithAllLeft :: forall f . Foldable f =>
(forall a b . (b -> a -> b) -> b -> f a -> b) ->
[f Integer] -> IO [Either BadElementException Integer]
runWithAllLeft fol containers = mapM (uncurry (runOneLeft fol))
[(f,c) | f <- map flip conses, c <- containers]
testWithAllRight :: forall f . Foldable f =>
(forall a b . (a -> b -> b) -> b -> f a -> b) ->
(forall a b . (a -> b -> b) -> b -> ForceDefault f a -> b) ->
[f Integer] -> IO Bool
testWithAllRight fol1 fol2 containers = (==) <$>
runWithAllRight fol1 containers <*>
runWithAllRight fol2 (map ForceDefault containers)
testWithAllLeft :: forall f . Foldable f =>
(forall a b . (b -> a -> b) -> b -> f a -> b) ->
(forall a b . (b -> a -> b) -> b -> ForceDefault f a -> b) ->
[f Integer] -> IO Bool
testWithAllLeft fol1 fol2 containers = (==) <$>
runWithAllLeft fol1 containers <*>
runWithAllLeft fol2 (map ForceDefault containers)
testWithAll1 :: forall f . Foldable f =>
(forall a . (a -> a -> a) -> f a -> a) ->
(forall a . (a -> a -> a) -> ForceDefault f a -> a) ->
[f Integer] -> IO Bool
testWithAll1 fol1 fol2 containers =
(==) <$> runWithAll1 fol1 containers
<*> runWithAll1 fol2 (map ForceDefault containers)
checkup f g cs = map f cs == map g (map ForceDefault cs)
main = do
testWithAllRight foldr foldr arrays >>= print
testWithAllRight foldr' foldr' arrays >>= print
testWithAllLeft foldl foldl arrays >>= print
testWithAllLeft foldl' foldl' arrays >>= print
testWithAll1 foldl1 foldl1 (filter (not . null) arrays) >>= print
testWithAll1 foldr1 foldr1 (filter (not . null) arrays) >>= print
-- we won't bother with the fancy laziness tests for the rest
print $ checkup length length goodArrays
print $ checkup sum sum goodArrays
print $ checkup product product goodArrays
print $ checkup maximum maximum $ filter (not . null) goodArrays
print $ checkup minimum minimum $ filter (not . null) goodArrays
print $ checkup toList toList goodArrays
print $ checkup null null arrays
|
