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