Skip to content
This repository was archived by the owner on Oct 4, 2020. It is now read-only.

Commit 7a76db9

Browse files
committed
Merge pull request #12 from joneshf/master
Added Foldable/Traversable Instances.
2 parents c81af7c + 1463e59 commit 7a76db9

File tree

3 files changed

+71
-50
lines changed

3 files changed

+71
-50
lines changed

README.md

Lines changed: 10 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -5,14 +5,14 @@
55
### Types
66

77
data Edge k where
8-
Edge :: k -> k -> Edge k
8+
Edge :: k -> k -> Edge
99

1010
data Graph k v where
11-
Graph :: [v] -> [Edge k] -> Graph k v
11+
Graph :: [v] -> [Edge k] -> Graph
1212

1313
data SCC v where
14-
AcyclicSCC :: v -> SCC v
15-
CyclicSCC :: [v] -> SCC v
14+
AcyclicSCC :: v -> SCC
15+
CyclicSCC :: [v] -> SCC
1616

1717

1818
### Type Class Instances
@@ -46,10 +46,14 @@
4646

4747
instance eqMap :: (P.Eq k, P.Eq v) => P.Eq (Map k v)
4848

49+
instance foldableMap :: Foldable (Map k)
50+
4951
instance functorMap :: P.Functor (Map k)
5052

5153
instance showMap :: (P.Show k, P.Show v) => P.Show (Map k v)
5254

55+
instance traversableMap :: (P.Ord k) => Traversable (Map k)
56+
5357

5458
### Values
5559

@@ -148,6 +152,8 @@
148152

149153
instance showStrMap :: (P.Show a) => P.Show (StrMap a)
150154

155+
instance traversableStrMap :: Traversable StrMap
156+
151157

152158
### Values
153159

src/Data/Map.purs

Lines changed: 48 additions & 38 deletions
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,7 @@
44
-- Based on http://www.cs.princeton.edu/~dpw/courses/cos326-12/ass/2-3-trees.pdf
55
--
66

7-
module Data.Map
7+
module Data.Map
88
( Map(),
99
showTree,
1010
empty,
@@ -25,15 +25,16 @@ module Data.Map
2525
unions,
2626
map
2727
) where
28-
28+
2929
import qualified Prelude as P
3030

3131
import qualified Data.Array as A
32-
import Data.Maybe
32+
import Data.Maybe
3333
import Data.Tuple
34-
import Data.Foldable (foldl)
35-
36-
data Map k v
34+
import Data.Foldable (foldl, foldMap, foldr, Foldable)
35+
import Data.Traversable (traverse, Traversable)
36+
37+
data Map k v
3738
= Leaf
3839
| Two (Map k v) k v (Map k v)
3940
| Three (Map k v) k v (Map k v) k v (Map k v)
@@ -43,29 +44,38 @@ instance eqMap :: (P.Eq k, P.Eq v) => P.Eq (Map k v) where
4344
(/=) m1 m2 = P.not (m1 P.== m2)
4445

4546
instance showMap :: (P.Show k, P.Show v) => P.Show (Map k v) where
46-
show m = "fromList " P.++ P.show (toList m)
47+
show m = "fromList " P.++ P.show (toList m)
4748

4849
instance functorMap :: P.Functor (Map k) where
4950
(<$>) _ Leaf = Leaf
5051
(<$>) f (Two left k v right) = Two (f P.<$> left) k (f v) (f P.<$> right)
5152
(<$>) f (Three left k1 v1 mid k2 v2 right) = Three (f P.<$> left) k1 (f v1) (f P.<$> mid) k2 (f v2) (f P.<$> right)
52-
53-
showTree :: forall k v. (P.Show k, P.Show v) => Map k v -> String
53+
54+
instance foldableMap :: Foldable (Map k) where
55+
foldl f z m = foldl f z (values m)
56+
foldr f z m = foldr f z (values m)
57+
foldMap f m = foldMap f (values m)
58+
59+
instance traversableMap :: (P.Ord k) => Traversable (Map k) where
60+
traverse f ms = foldr (\x acc -> union P.<$> x P.<*> acc) (P.pure empty) ((P.(<$>) (uncurry singleton)) P.<$> (traverse f P.<$> toList ms))
61+
sequence = traverse P.id
62+
63+
showTree :: forall k v. (P.Show k, P.Show v) => Map k v -> String
5464
showTree Leaf = "Leaf"
55-
showTree (Two left k v right) =
56-
"Two (" P.++ showTree left P.++
57-
") (" P.++ P.show k P.++
58-
") (" P.++ P.show v P.++
65+
showTree (Two left k v right) =
66+
"Two (" P.++ showTree left P.++
67+
") (" P.++ P.show k P.++
68+
") (" P.++ P.show v P.++
5969
") (" P.++ showTree right P.++ ")"
60-
showTree (Three left k1 v1 mid k2 v2 right) =
61-
"Three (" P.++ showTree left P.++
62-
") (" P.++ P.show k1 P.++
63-
") (" P.++ P.show v1 P.++
70+
showTree (Three left k1 v1 mid k2 v2 right) =
71+
"Three (" P.++ showTree left P.++
72+
") (" P.++ P.show k1 P.++
73+
") (" P.++ P.show v1 P.++
6474
") (" P.++ showTree mid P.++
65-
") (" P.++ P.show k2 P.++
66-
") (" P.++ P.show v2 P.++
75+
") (" P.++ P.show k2 P.++
76+
") (" P.++ P.show v2 P.++
6777
") (" P.++ showTree right P.++ ")"
68-
78+
6979
empty :: forall k v. Map k v
7080
empty = Leaf
7181

@@ -75,15 +85,15 @@ isEmpty _ = false
7585

7686
singleton :: forall k v. k -> v -> Map k v
7787
singleton k v = Two Leaf k v Leaf
78-
88+
7989
checkValid :: forall k v. Map k v -> Boolean
8090
checkValid tree = A.length (A.nub (allHeights tree)) P.== 1
8191
where
8292
allHeights :: forall k v. Map k v -> [Number]
8393
allHeights Leaf = [0]
8494
allHeights (Two left _ _ right) = A.map (\n -> n P.+ 1) (allHeights left P.++ allHeights right)
85-
allHeights (Three left _ _ mid _ _ right) = A.map (\n -> n P.+ 1) (allHeights left P.++ allHeights mid P.++ allHeights right)
86-
95+
allHeights (Three left _ _ mid _ _ right) = A.map (\n -> n P.+ 1) (allHeights left P.++ allHeights mid P.++ allHeights right)
96+
8797
lookup :: forall k v. (P.Ord k) => k -> Map k v -> Maybe v
8898
lookup _ Leaf = Nothing
8999
lookup k (Two _ k1 v _) | k P.== k1 = Just v
@@ -104,15 +114,15 @@ data TreeContext k v
104114
| ThreeLeft k v (Map k v) k v (Map k v)
105115
| ThreeMiddle (Map k v) k v k v (Map k v)
106116
| ThreeRight (Map k v) k v (Map k v) k v
107-
117+
108118
fromZipper :: forall k v. (P.Ord k) => [TreeContext k v] -> Map k v -> Map k v
109119
fromZipper [] tree = tree
110120
fromZipper (TwoLeft k1 v1 right : ctx) left = fromZipper ctx (Two left k1 v1 right)
111121
fromZipper (TwoRight left k1 v1 : ctx) right = fromZipper ctx (Two left k1 v1 right)
112122
fromZipper (ThreeLeft k1 v1 mid k2 v2 right : ctx) left = fromZipper ctx (Three left k1 v1 mid k2 v2 right)
113123
fromZipper (ThreeMiddle left k1 v1 k2 v2 right : ctx) mid = fromZipper ctx (Three left k1 v1 mid k2 v2 right)
114124
fromZipper (ThreeRight left k1 v1 mid k2 v2 : ctx) right = fromZipper ctx (Three left k1 v1 mid k2 v2 right)
115-
125+
116126
data KickUp k v = KickUp (Map k v) k v (Map k v)
117127

118128
insert :: forall k v. (P.Ord k) => k -> v -> Map k v -> Map k v
@@ -127,39 +137,39 @@ insert = down []
127137
down ctx k v (Three left k1 v1 mid k2 _ right) | k P.== k2 = fromZipper ctx (Three left k1 v1 mid k v right)
128138
down ctx k v (Three left k1 v1 mid k2 v2 right) | k P.< k1 = down (ThreeLeft k1 v1 mid k2 v2 right P.: ctx) k v left
129139
down ctx k v (Three left k1 v1 mid k2 v2 right) | k1 P.< k P.&& k P.<= k2 = down (ThreeMiddle left k1 v1 k2 v2 right P.: ctx) k v mid
130-
down ctx k v (Three left k1 v1 mid k2 v2 right) = down (ThreeRight left k1 v1 mid k2 v2 P.: ctx) k v right
131-
140+
down ctx k v (Three left k1 v1 mid k2 v2 right) = down (ThreeRight left k1 v1 mid k2 v2 P.: ctx) k v right
141+
132142
up :: forall k v. (P.Ord k) => [TreeContext k v] -> KickUp k v -> Map k v
133143
up [] (KickUp left k v right) = Two left k v right
134144
up (TwoLeft k1 v1 right : ctx) (KickUp left k v mid) = fromZipper ctx (Three left k v mid k1 v1 right)
135145
up (TwoRight left k1 v1 : ctx) (KickUp mid k v right) = fromZipper ctx (Three left k1 v1 mid k v right)
136146
up (ThreeLeft k1 v1 c k2 v2 d : ctx) (KickUp a k v b) = up ctx (KickUp (Two a k v b) k1 v1 (Two c k2 v2 d))
137147
up (ThreeMiddle a k1 v1 k2 v2 d : ctx) (KickUp b k v c) = up ctx (KickUp (Two a k1 v1 b) k v (Two c k2 v2 d))
138-
up (ThreeRight a k1 v1 b k2 v2 : ctx) (KickUp c k v d) = up ctx (KickUp (Two a k1 v1 b) k2 v2 (Two c k v d))
139-
148+
up (ThreeRight a k1 v1 b k2 v2 : ctx) (KickUp c k v d) = up ctx (KickUp (Two a k1 v1 b) k2 v2 (Two c k v d))
149+
140150
delete :: forall k v. (P.Ord k) => k -> Map k v -> Map k v
141151
delete = down []
142152
where
143153
down :: forall k v. (P.Ord k) => [TreeContext k v] -> k -> Map k v -> Map k v
144154
down ctx _ Leaf = fromZipper ctx Leaf
145155
down ctx k (Two Leaf k1 _ Leaf) | k P.== k1 = up ctx Leaf
146-
down ctx k (Two left k1 _ right) | k P.== k1 =
156+
down ctx k (Two left k1 _ right) | k P.== k1 =
147157
let max = maxNode left
148158
in removeMaxNode (TwoLeft max.key max.value right P.: ctx) left
149159
down ctx k (Two left k1 v1 right) | k P.< k1 = down (TwoLeft k1 v1 right P.: ctx) k left
150160
down ctx k (Two left k1 v1 right) = down (TwoRight left k1 v1 P.: ctx) k right
151161
down ctx k (Three Leaf k1 _ Leaf k2 v2 Leaf) | k P.== k1 = fromZipper ctx (Two Leaf k2 v2 Leaf)
152162
down ctx k (Three Leaf k1 v1 Leaf k2 _ Leaf) | k P.== k2 = fromZipper ctx (Two Leaf k1 v1 Leaf)
153-
down ctx k (Three left k1 _ mid k2 v2 right) | k P.== k1 =
163+
down ctx k (Three left k1 _ mid k2 v2 right) | k P.== k1 =
154164
let max = maxNode left
155165
in removeMaxNode (ThreeLeft max.key max.value mid k2 v2 right P.: ctx) left
156166
down ctx k (Three left k1 v1 mid k2 _ right) | k P.== k2 =
157167
let max = maxNode mid
158168
in removeMaxNode (ThreeMiddle left k1 v1 max.key max.value right P.: ctx) mid
159169
down ctx k (Three left k1 v1 mid k2 v2 right) | k P.< k1 = down (ThreeLeft k1 v1 mid k2 v2 right P.: ctx) k left
160170
down ctx k (Three left k1 v1 mid k2 v2 right) | k1 P.< k P.&& k P.< k2 = down (ThreeMiddle left k1 v1 k2 v2 right P.: ctx) k mid
161-
down ctx k (Three left k1 v1 mid k2 v2 right) = down (ThreeRight left k1 v1 mid k2 v2 P.: ctx) k right
162-
171+
down ctx k (Three left k1 v1 mid k2 v2 right) = down (ThreeRight left k1 v1 mid k2 v2 P.: ctx) k right
172+
163173
up :: forall k v. (P.Ord k) => [TreeContext k v] -> Map k v -> Map k v
164174
up [] tree = tree
165175
up (TwoLeft k1 v1 Leaf : ctx) Leaf = fromZipper ctx (Two Leaf k1 v1 Leaf)
@@ -179,27 +189,27 @@ delete = down []
179189
up (ThreeMiddle (Three a k1 v1 b k2 v2 c) k3 v3 k4 v4 e : ctx) d = fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
180190
up (ThreeMiddle a k1 v1 k2 v2 (Three c k3 v3 d k4 v4 e) : ctx) b = fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))
181191
up (ThreeRight a k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4 : ctx) e = fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))
182-
192+
183193
maxNode :: forall k v. (P.Ord k) => Map k v -> { key :: k, value :: v }
184194
maxNode (Two _ k v Leaf) = { key: k, value: v }
185195
maxNode (Two _ _ _ right) = maxNode right
186196
maxNode (Three _ _ _ _ k v Leaf) = { key: k, value: v }
187197
maxNode (Three _ _ _ _ _ _ right) = maxNode right
188-
198+
189199
removeMaxNode :: forall k v. (P.Ord k) => [TreeContext k v] -> Map k v -> Map k v
190200
removeMaxNode ctx (Two Leaf _ _ Leaf) = up ctx Leaf
191201
removeMaxNode ctx (Two left k v right) = removeMaxNode (TwoRight left k v P.: ctx) right
192202
removeMaxNode ctx (Three Leaf k1 v1 Leaf _ _ Leaf) = up (TwoRight Leaf k1 v1 P.: ctx) Leaf
193203
removeMaxNode ctx (Three left k1 v1 mid k2 v2 right) = removeMaxNode (ThreeRight left k1 v1 mid k2 v2 P.: ctx) right
194-
204+
195205
alter :: forall k v. (P.Ord k) => (Maybe v -> Maybe v) -> k -> Map k v -> Map k v
196206
alter f k m = case f (k `lookup` m) of
197207
Nothing -> delete k m
198208
Just v -> insert k v m
199209

200210
update :: forall k v. (P.Ord k) => (v -> Maybe v) -> k -> Map k v -> Map k v
201-
update f k m = alter (maybe Nothing f) k m
202-
211+
update f k m = alter (maybe Nothing f) k m
212+
203213
toList :: forall k v. Map k v -> [Tuple k v]
204214
toList Leaf = []
205215
toList (Two left k v right) = toList left P.++ [Tuple k v] P.++ toList right

src/Data/StrMap.purs

Lines changed: 13 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -34,18 +34,19 @@ module Data.StrMap
3434
freezeST,
3535
runST
3636
) where
37-
37+
3838
import qualified Prelude as P
3939

4040
import Control.Monad.Eff (Eff(), runPure)
41-
import qualified Control.Monad.ST as ST
42-
import qualified Data.Array as A
43-
import Data.Maybe
44-
import Data.Function
45-
import Data.Tuple
4641
import Data.Foldable (Foldable, foldl, foldr, for_)
42+
import Data.Function
43+
import Data.Maybe
4744
import Data.Monoid
4845
import Data.Monoid.All
46+
import Data.Tuple
47+
import Data.Traversable (Traversable, traverse)
48+
import qualified Control.Monad.ST as ST
49+
import qualified Data.Array as A
4950
import qualified Data.StrMap.ST as SM
5051

5152
foreign import data StrMap :: * -> *
@@ -128,6 +129,10 @@ instance foldableStrMap :: Foldable StrMap where
128129
foldr f z m = foldr f z (values m)
129130
foldMap f = foldMap (P.const f)
130131

132+
instance traversableStrMap :: Traversable StrMap where
133+
traverse f ms = foldr (\x acc -> union P.<$> x P.<*> acc) (P.pure empty) ((P.(<$>) (uncurry singleton)) P.<$> (traverse f P.<$> toList ms))
134+
sequence = traverse P.id
135+
131136
-- Unfortunately the above are not short-circuitable (consider using purescript-machines)
132137
-- so we need special cases:
133138

@@ -213,10 +218,10 @@ alter f k m = case f (k `lookup` m) of
213218
Just v -> insert k v m
214219

215220
update :: forall a. (a -> Maybe a) -> String -> StrMap a -> StrMap a
216-
update f k m = alter (maybe Nothing f) k m
221+
update f k m = alter (maybe Nothing f) k m
217222

218223
fromList :: forall a. [Tuple String a] -> StrMap a
219-
fromList l = pureST (do
224+
fromList l = pureST (do
220225
s <- SM.new
221226
for_ l (\(Tuple k v) -> SM.poke s k v)
222227
P.return s)

0 commit comments

Comments
 (0)