3e1de07fb86521f496be58daa0c43058b8fed65e
[ghc.git] / testsuite / tests / programs / andy_cherry / GenUtils.hs
1
2
3
4
5
6
7
8
9
10 module GenUtils (
11
12 trace,
13
14 assocMaybe, assocMaybeErr,
15 arrElem,
16 arrCond,
17 memoise,
18 Maybe(..),
19 MaybeErr(..),
20 mapMaybe,
21 mapMaybeFail,
22 maybeToBool,
23 maybeToObj,
24 maybeMap,
25 joinMaybe,
26 mkClosure,
27 foldb,
28
29 mapAccumL,
30
31 sortWith,
32 sort,
33 cjustify,
34 ljustify,
35 rjustify,
36 space,
37 copy,
38 combinePairs,
39 formatText ) where
40
41 import Data.Array -- 1.3
42 import Data.Ix -- 1.3
43
44 import Debug.Trace ( trace )
45
46
47 -- -------------------------------------------------------------------------
48
49 -- Here are two defs that everyone seems to define ...
50 -- HBC has it in one of its builtin modules
51
52 #if defined(__GLASGOW_HASKELL__) || defined(__GOFER__)
53
54 --in 1.3: data Maybe a = Nothing | Just a deriving (Eq,Ord,Text)
55
56 #endif
57
58 infix 1 =: -- 1.3
59 type Assoc a b = (a,b) -- 1.3
60 (=:) a b = (a,b)
61
62 mapMaybe :: (a -> Maybe b) -> [a] -> [b]
63 mapMaybe f [] = []
64 mapMaybe f (a:r) = case f a of
65 Nothing -> mapMaybe f r
66 Just b -> b : mapMaybe f r
67
68 -- This version returns nothing, if *any* one fails.
69
70 mapMaybeFail f (x:xs) = case f x of
71 Just x' -> case mapMaybeFail f xs of
72 Just xs' -> Just (x':xs')
73 Nothing -> Nothing
74 Nothing -> Nothing
75 mapMaybeFail f [] = Just []
76
77 maybeToBool :: Maybe a -> Bool
78 maybeToBool (Just _) = True
79 maybeToBool _ = False
80
81 maybeToObj :: Maybe a -> a
82 maybeToObj (Just a) = a
83 maybeToObj _ = error "Trying to extract object from a Nothing"
84
85 maybeMap :: (a -> b) -> Maybe a -> Maybe b
86 maybeMap f (Just a) = Just (f a)
87 maybeMap f Nothing = Nothing
88
89
90 joinMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
91 joinMaybe _ Nothing Nothing = Nothing
92 joinMaybe _ (Just g) Nothing = Just g
93 joinMaybe _ Nothing (Just g) = Just g
94 joinMaybe f (Just g) (Just h) = Just (f g h)
95
96 data MaybeErr a err = Succeeded a | Failed err deriving (Eq,Show{-was:Text-})
97
98 -- @mkClosure@ makes a closure, when given a comparison and iteration loop.
99 -- Be careful, because if the functional always makes the object different,
100 -- This will never terminate.
101
102 mkClosure :: (a -> a -> Bool) -> (a -> a) -> a -> a
103 mkClosure eq f = match . iterate f
104 where
105 match (a:b:c) | a `eq` b = a
106 match (_:c) = match c
107
108 -- fold-binary.
109 -- It combines the element of the list argument in balanced mannerism.
110
111 foldb :: (a -> a -> a) -> [a] -> a
112 foldb f [] = error "can't reduce an empty list using foldb"
113 foldb f [x] = x
114 foldb f l = foldb f (foldb' l)
115 where
116 foldb' (x:y:x':y':xs) = f (f x y) (f x' y') : foldb' xs
117 foldb' (x:y:xs) = f x y : foldb' xs
118 foldb' xs = xs
119
120 -- Merge two ordered lists into one ordered list.
121
122 mergeWith :: (a -> a -> Bool) -> [a] -> [a] -> [a]
123 mergeWith _ [] ys = ys
124 mergeWith _ xs [] = xs
125 mergeWith le (x:xs) (y:ys)
126 | x `le` y = x : mergeWith le xs (y:ys)
127 | otherwise = y : mergeWith le (x:xs) ys
128
129 insertWith :: (a -> a -> Bool) -> a -> [a] -> [a]
130 insertWith _ x [] = [x]
131 insertWith le x (y:ys)
132 | x `le` y = x:y:ys
133 | otherwise = y:insertWith le x ys
134
135 -- Sorting is something almost every program needs, and this is the
136 -- quickest sorting function I know of.
137
138 sortWith :: (a -> a -> Bool) -> [a] -> [a]
139 sortWith le [] = []
140 sortWith le lst = foldb (mergeWith le) (splitList lst)
141 where
142 splitList (a1:a2:a3:a4:a5:xs) =
143 insertWith le a1
144 (insertWith le a2
145 (insertWith le a3
146 (insertWith le a4 [a5]))) : splitList xs
147 splitList [] = []
148 splitList (r:rs) = [foldr (insertWith le) [r] rs]
149
150 sort :: (Ord a) => [a] -> [a]
151 sort = sortWith (<=)
152
153 -- Gofer-like stuff:
154
155 cjustify, ljustify, rjustify :: Int -> String -> String
156 cjustify n s = space halfm ++ s ++ space (m - halfm)
157 where m = n - length s
158 halfm = m `div` 2
159 ljustify n s = s ++ space (max 0 (n - length s))
160 rjustify n s = space (max 0 (n - length s)) ++ s
161
162 space :: Int -> String
163 space n = copy n ' '
164
165 copy :: Int -> a -> [a] -- make list of n copies of x
166 copy n x = take n xs where xs = x:xs
167
168 combinePairs :: (Ord a) => [(a,b)] -> [(a,[b])]
169 combinePairs xs =
170 combine [ (a,[b]) | (a,b) <- sortWith (\ (a,_) (b,_) -> a <= b) xs]
171 where
172 combine [] = []
173 combine ((a,b):(c,d):r) | a == c = combine ((a,b++d) : r)
174 combine (a:r) = a : combine r
175
176 assocMaybe :: (Eq a) => [(a,b)] -> a -> Maybe b
177 assocMaybe env k = case [ val | (key,val) <- env, k == key] of
178 [] -> Nothing
179 (val:vs) -> Just val
180
181 assocMaybeErr :: (Eq a) => [(a,b)] -> a -> MaybeErr b String
182 assocMaybeErr env k = case [ val | (key,val) <- env, k == key] of
183 [] -> Failed "assoc: "
184 (val:vs) -> Succeeded val
185
186
187 deSucc (Succeeded e) = e
188
189 mapAccumL :: (a -> b -> (c,a)) -> a -> [b] -> ([c],a)
190 mapAccumL f s [] = ([],s)
191 mapAccumL f s (b:bs) = (c:cs,s'')
192 where
193 (c,s') = f s b
194 (cs,s'') = mapAccumL f s' bs
195
196
197
198 -- Now some utilties involving arrays.
199 -- Here is a version of @elem@ that uses partual application
200 -- to optimise lookup.
201
202 arrElem :: (Ix a) => [a] -> a -> Bool
203 arrElem obj = \x -> inRange size x && arr ! x
204 where
205 size = (maximum obj,minimum obj)
206 arr = listArray size [ i `elem` obj | i <- range size ]
207
208 -- Here is the functional version of a multi-way conditional,
209 -- again using arrays, of course. Remember @b@ can be a function !
210 -- Note again the use of partiual application.
211
212 arrCond :: (Ix a)
213 => (a,a) -- the bounds
214 -> [(Assoc [a] b)] -- the simple lookups
215 -> [(Assoc (a -> Bool) b)] -- the functional lookups
216 -> b -- the default
217 -> a -> b -- the (functional) result
218
219 arrCond bds pairs fnPairs def = (!) arr'
220 where
221 arr' = array bds [ t =: head
222 ([ r | (p, r) <- pairs, elem t p ] ++
223 [ r | (f, r) <- fnPairs, f t ] ++
224 [ def ])
225 | t <- range bds ]
226
227 memoise :: (Ix a) => (a,a) -> (a -> b) -> a -> b
228 memoise bds f = (!) arr
229 where arr = array bds [ t =: f t | t <- range bds ]
230
231 -- Quite neat this. Formats text to fit in a column.
232
233 formatText :: Int -> [String] -> [String]
234 formatText n = map unwords . cutAt n []
235 where
236 cutAt :: Int -> [String] -> [String] -> [[String]]
237 cutAt m wds [] = [reverse wds]
238 cutAt m wds (wd:rest) = if len <= m || null wds
239 then cutAt (m-(len+1)) (wd:wds) rest
240 else reverse wds : cutAt n [] (wd:rest)
241 where len = length wd
242
243
244