git.iko.soy/typeable/wai
on master help sign in
using IntMap for MultiMap.
690dc01Kazu Yamamoto
warp/Network/Wai/Handler/Warp/FdCache.hs+5−21
compare with master
unifiedsplit
@@ -98,12 +98,7 @@ fdCache (MutableFdCache reaper) = reaperRead reaper
98look :: MutableFdCache -> FilePath -> Hash -> IO (Maybe FdEntry)
98look :: MutableFdCache -> FilePath -> Hash -> IO (Maybe FdEntry)
99look mfc path key = searchWith key check <$> fdCache mfc
99look mfc path key = searchWith key check <$> fdCache mfc
100 where
100 where
101− check (One ent@(FdEntry path' _ _))
101+ check (FdEntry path' _ _) = path == path'
102− | path == path' = Just ent
103− | otherwise = Nothing
104− check (Tom ent@(FdEntry path' _ _) vs)
105− | path == path' = Just ent
106− | otherwise = check vs
107
102
108----------------------------------------------------------------
103----------------------------------------------------------------
109
104
@@ -123,22 +118,11 @@ clean :: FdCache -> IO (FdCache -> FdCache)
123clean old = do
118clean old = do
124 new <- pruneWith old prune
119 new <- pruneWith old prune
125 return $ merge new
120 return $ merge new
126−
127−prune :: (t,Some FdEntry) -> IO [(t, Some FdEntry)]
128−prune (k,v@(One (FdEntry _ fd mst))) = status mst >>= prune'
129− where
130− prune' Active = inactive mst >> return [(k,v)]
131− prune' Inactive = closeFd fd >> return []
132−prune (k,(Tom ent@(FdEntry _ fd mst) vs)) = status mst >>= prune'
133 where
121 where
134− prune' Active = do
122+ prune (FdEntry _ fd mst) = status mst >>= act
123+ where
135− inactive mst
124+ act Active = inactive mst >> return True
136− zs <- prune (k,vs)
137− case zs of
138− [] -> return [(k,One ent)]
139− [(_,zvs)] -> return [(k,Tom ent zvs)]
140− _ -> error "prune"
141− prune' Inactive = closeFd fd >> prune (k,vs)
125+ act Inactive = closeFd fd >> return False
142
126
143----------------------------------------------------------------
127----------------------------------------------------------------
144
128
warp/Network/Wai/Handler/Warp/MultiMap.hs+30−59
@@ -1,18 +1,15 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE CPP, BangPatterns #-}
2
2
3module Network.Wai.Handler.Warp.MultiMap (
3module Network.Wai.Handler.Warp.MultiMap (
4 MMap
4 MMap
5− , Some(..)
5+ , isEmpty
6 , empty
6 , empty
7 , singleton
7 , singleton
8 , insert
8 , insert
9 , search
9 , search
10 , searchWith
10 , searchWith
11− , isEmpty
12 , pruneWith
11 , pruneWith
13 , toList
12 , toList
14− , fromSortedList
15− , toSortedList
16 , merge
13 , merge
17 ) where
14 ) where
18
15
@@ -21,30 +18,27 @@ import Control.Applicative ((<$>))
21#endif
18#endif
22import Data.IntMap (IntMap)
19import Data.IntMap (IntMap)
23import qualified Data.IntMap as I
20import qualified Data.IntMap as I
21+import qualified Network.Wai.Handler.Warp.Some as S
24
22
25----------------------------------------------------------------
23----------------------------------------------------------------
26
24
27−-- | One ore more list to implement multimap.
25+type MMap v = IntMap (S.Some v)
28−data Some a = One !a
29− | Tom !a !(Some a) -- Two or more
30− deriving (Eq,Show)
31
26
32−{-
27+----------------------------------------------------------------
33−cons :: Some a -> a -> Some a
34−cons s x = Tom x s
35−-}
36
28
37−top :: Some a -> a
29+-- | O(1)
38−top (One x) = x
30+isEmpty :: MMap v -> Bool
39−top (Tom x _) = x
31+isEmpty = I.null
40
32
41−union :: Some a -> Some a -> Some a
33+-- | O(1)
42−union (One x) s = Tom x s
34+empty :: MMap v
43−union (Tom x xs) s = union xs (Tom x s)
35+empty = I.empty
44
36
45----------------------------------------------------------------
37----------------------------------------------------------------
46
38
47−type MMap v = IntMap (Some v)
39+-- | O(1)
40+singleton :: Int -> v -> MMap v
41+singleton k v = I.singleton k (S.singleton v)
48
42
49----------------------------------------------------------------
43----------------------------------------------------------------
50
44
@@ -52,35 +46,19 @@ type MMap v = IntMap (Some v)
52search :: Int -> MMap v -> Maybe v
46search :: Int -> MMap v -> Maybe v
53search k m = case I.lookup k m of
47search k m = case I.lookup k m of
54 Nothing -> Nothing
48 Nothing -> Nothing
55− Just s -> Just $! top s
49+ Just s -> Just $! S.top s
56
50
57-- | O(log n)
51-- | O(log n)
58−searchWith :: Int -> (Some v -> Maybe v) -> MMap v -> Maybe v
52+searchWith :: Int -> (v -> Bool) -> MMap v -> Maybe v
59searchWith k f m = case I.lookup k m of
53searchWith k f m = case I.lookup k m of
60 Nothing -> Nothing
54 Nothing -> Nothing
61− Just s -> f s
55+ Just s -> S.lookupWith f s
62−
63−----------------------------------------------------------------
64−
65−-- | O(1)
66−isEmpty :: MMap v -> Bool
67−isEmpty = I.null
68−
69−-- | O(1)
70−empty :: MMap v
71−empty = I.empty
72−
73−----------------------------------------------------------------
74−
75−-- | O(1)
76−singleton :: Int -> v -> MMap v
77−singleton k v = I.singleton k (One v)
78
56
79----------------------------------------------------------------
57----------------------------------------------------------------
80
58
81-- | O(log n)
59-- | O(log n)
82insert :: Int -> v -> MMap v -> MMap v
60insert :: Int -> v -> MMap v -> MMap v
83−insert k v m = I.insertWith union k (One v) m
61+insert k v m = I.insertWith S.union k (S.singleton v) m
84
62
85----------------------------------------------------------------
63----------------------------------------------------------------
86
64
@@ -88,33 +66,26 @@ insert k v m = I.insertWith union k (One v) m
88toList :: MMap v -> [v]
66toList :: MMap v -> [v]
89toList m = concatMap f $ I.toAscList m
67toList m = concatMap f $ I.toAscList m
90 where
68 where
91− f (_,s) = go s []
69+ f (_,s) = S.toList s
92− where
93− go (One x) acc = x : acc
94− go (Tom x xs) acc = go xs (x : acc)
95−
96−----------------------------------------------------------------
97−
98−-- | O(n)
99−fromSortedList :: [(Int,Some v)] -> MMap v
100−fromSortedList = I.fromAscList
101−
102−----------------------------------------------------------------
103−
104−-- | O(n)
105−toSortedList :: MMap v -> [(Int,Some v)]
106−toSortedList = I.toAscList
107
70
108----------------------------------------------------------------
71----------------------------------------------------------------
109
72
110-- | O(n)
73-- | O(n)
111pruneWith :: MMap v
74pruneWith :: MMap v
112− -> ((Int,Some v) -> IO [(Int, Some v)])
75+ -> (v -> IO Bool)
113 -> IO (MMap v)
76 -> IO (MMap v)
114−pruneWith m action = fromSortedList . concat <$> mapM action (toSortedList m)
77+pruneWith m action = I.fromAscList <$> go (I.toAscList m)
78+ where
79+ go [] = return []
80+ go ((k,s):kss) = do
81+ mt <- S.prune action s
82+ lst <- go kss
83+ case mt of
84+ Nothing -> return lst
85+ Just t -> return $ (k,t) : lst
115
86
116----------------------------------------------------------------
87----------------------------------------------------------------
117
88
118-- O(n + m) where N is the size of the second argument
89-- O(n + m) where N is the size of the second argument
119merge :: MMap v -> MMap v -> MMap v
90merge :: MMap v -> MMap v -> MMap v
120−merge m1 m2 = I.unionWith union m1 m2
91+merge m1 m2 = I.unionWith S.union m1 m2
warp/Network/Wai/Handler/Warp/Some.hsnew file+73
@@ -0,0 +1,73 @@
1+{-# LANGUAGE BangPatterns #-}
2+
3+module Network.Wai.Handler.Warp.Some (
4+ Some
5+ , singleton
6+ , top
7+ , lookupWith
8+ , union
9+ , toList
10+ , prune
11+ ) where
12+
13+----------------------------------------------------------------
14+
15+-- | One ore more list to implement multimap.
16+data Some a = One !a
17+ | Tom !a !(Some a) -- Two or more
18+ deriving (Eq,Show)
19+
20+{-# INLINE singleton #-}
21+singleton :: a -> Some a
22+singleton x = One x
23+
24+{-# INLINE top #-}
25+top :: Some a -> a
26+top (One x) = x
27+top (Tom x _) = x
28+
29+{-# INLINE lookupWith #-}
30+lookupWith :: (a -> Bool) -> Some a -> Maybe a
31+lookupWith f s = go s
32+ where
33+ go (One x)
34+ | f x = Just x
35+ | otherwise = Nothing
36+ go (Tom x xs)
37+ | f x = Just x
38+ | otherwise = go xs
39+
40+{-# INLINE union #-}
41+union :: Some a -> Some a -> Some a
42+union s t = go s t
43+ where
44+ go (One x) u = Tom x u
45+ go (Tom x xs) u = go xs (Tom x u)
46+
47+{-# INLINE toList #-}
48+toList :: Some a -> [a]
49+toList s = go s []
50+ where
51+ go (One x) !acc = x : acc
52+ go (Tom x xs) !acc = go xs (x : acc)
53+
54+{-# INLINE prune #-}
55+prune :: (a -> IO Bool) -> Some a -> IO (Maybe (Some a))
56+prune act s = go s
57+ where
58+ go (One x) = do
59+ keep <- act x
60+ return $ if keep then
61+ Just (One x)
62+ else
63+ Nothing
64+ go (Tom x xs) = do
65+ keep <- act x
66+ mys <- go xs
67+ return $ if keep then
68+ case mys of
69+ Nothing -> Just (One x)
70+ Just ys -> Just (Tom x ys)
71+ else
72+ mys
73+
warp/test/MultiMapSpec.hsdeleted−30
@@ -1,30 +0,0 @@
1−module MultiMapSpec where
2−
3−import Network.Wai.Handler.Warp.MultiMap
4−import Test.Hspec
5−import Test.QuickCheck (property)
6−
7−type Alist = [(Int,Char)]
8−
9−spec :: Spec
10−spec = do
11− describe "fromList" $ do
12− it "generates a valid tree" $ property $ \xs ->
13− valid $ fromList (xs :: Alist)
14− describe "toSortedList" $ do
15− it "generated a sorted list" $ property $ \xs ->
16− ordered $ toSortedList $ fromList (xs :: Alist)
17− describe "search" $ do
18− it "acts as the list model" $ property $ \x xs ->
19− search x (fromList xs) == lookup x (xs :: Alist)
20− describe "fromSortedList" $ do
21− it "generates a valid tree" $ property $ \xs ->
22− valid . fromSortedList . toSortedList . fromList $ (xs :: Alist)
23− it "maintains the tree with toSortedList" $ property $ \xs ->
24− let t1 = fromList (xs :: Alist)
25− t2 = fromSortedList $ toSortedList t1
26− in t1 == t2
27−
28−ordered :: Ord a => [(a, b)] -> Bool
29−ordered (x:y:xys) = fst x <= fst y && ordered (y:xys)
30−ordered _ = True
warp/warp.cabal+1−1
@@ -91,6 +91,7 @@ Library
91 Network.Wai.Handler.Warp.Run
91 Network.Wai.Handler.Warp.Run
92 Network.Wai.Handler.Warp.SendFile
92 Network.Wai.Handler.Warp.SendFile
93 Network.Wai.Handler.Warp.Settings
93 Network.Wai.Handler.Warp.Settings
94+ Network.Wai.Handler.Warp.Some
94 Network.Wai.Handler.Warp.Timeout
95 Network.Wai.Handler.Warp.Timeout
95 Network.Wai.Handler.Warp.Types
96 Network.Wai.Handler.Warp.Types
96 Network.Wai.Handler.Warp.Windows
97 Network.Wai.Handler.Warp.Windows
@@ -124,7 +125,6 @@ Test-Suite spec
124 ExceptionSpec
125 ExceptionSpec
125 FdCacheSpec
126 FdCacheSpec
126 FileSpec
127 FileSpec
127− MultiMapSpec
128 ReadIntSpec
128 ReadIntSpec
129 RequestSpec
129 RequestSpec
130 ResponseHeaderSpec
130 ResponseHeaderSpec