ghc/tests/programs/andy_cherry/GenUtils.lhs

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