1
- {-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-}
1
+ {-# LANGUAGE CPP, FlexibleInstances, GeneralizedNewtypeDeriving #-}
2
2
{-# OPTIONS_GHC -fno-warn-orphans #-}
3
3
4
4
module Main (main ) where
@@ -7,7 +7,18 @@ import Data.Hashable (Hashable(hashWithSalt))
7
7
import Test.ChasingBottoms.IsBottom
8
8
import Test.Framework (Test , defaultMain , testGroup )
9
9
import Test.Framework.Providers.QuickCheck2 (testProperty )
10
- import Test.QuickCheck (Arbitrary (arbitrary ))
10
+ import Test.QuickCheck (Arbitrary (arbitrary ), Property , (===) , (.&&.) )
11
+ import Test.QuickCheck.Function
12
+ import Test.QuickCheck.Poly (A )
13
+ import Data.Maybe (fromMaybe , isJust )
14
+ import Control.Arrow (second )
15
+ import Control.Monad (guard )
16
+ import Data.Foldable (foldl' )
17
+ #if !MIN_VERSION_base(4,8,0)
18
+ import Data.Functor ((<$) )
19
+ import Data.Foldable (all )
20
+ import Prelude hiding (all )
21
+ #endif
11
22
12
23
import Data.HashMap.Strict (HashMap )
13
24
import qualified Data.HashMap.Strict as HM
@@ -79,10 +90,63 @@ pFromListWithKeyStrict :: (Int -> Int -> Int) -> Bool
79
90
pFromListWithKeyStrict f =
80
91
isBottom $ HM. fromListWith f [(undefined :: Key , 1 :: Int )]
81
92
82
- pFromListWithValueStrict :: [(Key , Int )] -> Bool
83
- pFromListWithValueStrict xs = case xs of
84
- [] -> True
85
- (x: _) -> isBottom $ HM. fromListWith (\ _ _ -> undefined ) (x: xs)
93
+ -- The strictness properties of 'fromListWith' are not entirely
94
+ -- trivial.
95
+ -- fromListWith f kvs is strict in the first value seen for each
96
+ -- key, but potentially lazy in the rest: the combining function
97
+ -- could be lazy in the "new" value. fromListWith must, however,
98
+ -- be strict in whatever value is actually inserted into the map.
99
+ -- Getting all these properties specified efficiently seems tricky.
100
+ -- Since it's not hard, we verify that the converted HashMap has
101
+ -- no unforced values. Rather than trying to go into detail for the
102
+ -- rest, this test compares the strictness behavior of fromListWith
103
+ -- to that of insertWith. The latter should be easier to specify
104
+ -- and (if we choose to do so) test thoroughly.
105
+ --
106
+ -- We'll fake up a representation of things that are possibly
107
+ -- bottom by using Nothing to represent bottom. The combining
108
+ -- (partial) function is represented by a "lazy total" function
109
+ -- Maybe a -> Maybe a -> Maybe a, along with a function determining
110
+ -- whether the result should be non-bottom, Maybe a -> Maybe a -> Bool,
111
+ -- indicating how the combining function should behave if neither
112
+ -- argument, just the first argument, just the second argument,
113
+ -- or both arguments are bottom. It would be quite tempting to
114
+ -- just use Maybe A -> Maybe A -> Maybe A, but that would not
115
+ -- necessarily be continous.
116
+ pFromListWithValueResultStrict :: [(Key , Maybe A )]
117
+ -> Fun (Maybe A , Maybe A ) A
118
+ -> Fun (Maybe A , Maybe A ) Bool
119
+ -> Property
120
+ pFromListWithValueResultStrict lst comb_lazy calc_good_raw
121
+ = all (all isJust) recovered .&&. (recovered === recover (fmap recover fake_map))
122
+ where
123
+ recovered :: Maybe (HashMap Key (Maybe A ))
124
+ recovered = recover (fmap recover real_map)
125
+ -- What we get out of the conversion using insertWith
126
+ fake_map = foldl' (\ m (k,v) -> HM. insertWith real_comb k v m) HM. empty real_list
127
+
128
+ -- A continuous version of calc_good_raw
129
+ calc_good Nothing Nothing = cgr Nothing Nothing
130
+ calc_good Nothing y@ (Just _) = cgr Nothing Nothing || cgr Nothing y
131
+ calc_good x@ (Just _) Nothing = cgr Nothing Nothing || cgr x Nothing
132
+ calc_good x y = cgr Nothing Nothing || cgr Nothing y || cgr x Nothing || cgr x y
133
+ cgr = curry $ apply calc_good_raw
134
+
135
+ -- The Maybe A -> Maybe A -> Maybe A that we're after, representing a
136
+ -- potentially less total function than comb_lazy
137
+ comb x y = apply comb_lazy (x, y) <$ guard (calc_good x y)
138
+
139
+ -- What we get out of the conversion using fromListWith
140
+ real_map = HM. fromListWith real_comb real_list
141
+
142
+ -- A list that may have actual bottom values in it.
143
+ real_list = map (second (fromMaybe bottom)) lst
144
+
145
+ -- A genuinely partial function mirroring comb
146
+ real_comb x y = fromMaybe bottom $ comb (recover x) (recover y)
147
+
148
+ recover :: a -> Maybe a
149
+ recover a = a <$ guard (not $ isBottom a)
86
150
87
151
------------------------------------------------------------------------
88
152
-- * Test list
@@ -108,7 +172,7 @@ tests =
108
172
, testProperty " fromList is key-strict" pFromListKeyStrict
109
173
, testProperty " fromList is value-strict" pFromListValueStrict
110
174
, testProperty " fromListWith is key-strict" pFromListWithKeyStrict
111
- , testProperty " fromListWith is value-strict" pFromListWithValueStrict
175
+ , testProperty " fromListWith is value-strict" pFromListWithValueResultStrict
112
176
]
113
177
]
114
178
0 commit comments