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 > module GenUtils (
   6
   7         trace,
   8
   9 >       assocMaybe, assocMaybeErr,
  10 >       arrElem,
  11 >       arrCond,
  12 >       memoise,
  13 >       Maybe(..),
  14 >       MaybeErr(..),
  15 >       mapMaybe,
  16 >       mapMaybeFail,
  17 >       maybeToBool,
  18 >       maybeToObj,
  19 >       maybeMap,
  20 >       joinMaybe,
  21 >       mkClosure,
  22 >       foldb,
  23
  24 >       mapAccumL,
  25
  26 >       sortWith,
  27 >       sort,
  28 >       cjustify,
  29 >       ljustify,
  30 >       rjustify,
  31 >       space,
  32 >       copy,
  33 >       combinePairs,
  34 >       formatText ) where
  35
  36 > import Array  -- 1.3
  37 > import Ix     -- 1.3
  38
  39 >#ifndef __GLASGOW_HASKELL__
  40
  41 > import {-fool mkdependHS-}
  42 >        Trace
  43
  44 >#endif
  45
  46 %------------------------------------------------------------------------------
  47
  48 Here are two defs that everyone seems to define ...
  49 HBC has it in one of its builtin modules
  50
  51 >#if defined(__GLASGOW_HASKELL__) || defined(__GOFER__)
  52
  53 > --in 1.3: data Maybe a = Nothing | Just a deriving (Eq,Ord,Text)
  54
  55 >#endif
  56 > infix 1 =: -- 1.3
  57 > type Assoc a b = (a,b) -- 1.3
  58 > (=:) a b = (a,b)
  59
  60 > mapMaybe :: (a -> Maybe b) -> [a] -> [b]
  61 > mapMaybe f [] = []
  62 > mapMaybe f (a:r) = case f a of
  63 >                       Nothing -> mapMaybe f r
  64 >                       Just b  -> b : mapMaybe f r
  65
  66 This version returns nothing, if *any* one fails.
  67
  68 > mapMaybeFail f (x:xs) = case f x of
  69 >                       Just x' -> case mapMaybeFail f xs of
  70 >                                   Just xs' -> Just (x':xs')
  71 >                                   Nothing -> Nothing
  72 >                       Nothing -> Nothing
  73 > mapMaybeFail f [] = Just []
  74
  75 > maybeToBool :: Maybe a -> Bool
  76 > maybeToBool (Just _) = True
  77 > maybeToBool _        = False
  78
  79 > maybeToObj  :: Maybe a -> a
  80 > maybeToObj (Just a) = a
  81 > maybeToObj _        = error "Trying to extract object from a Nothing"
  82
  83 > maybeMap :: (a -> b) -> Maybe a -> Maybe b
  84 > maybeMap f (Just a) = Just (f a)
  85 > maybeMap f Nothing  = Nothing
  86
  87
  88 > joinMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
  89 > joinMaybe _ Nothing  Nothing  = Nothing
  90 > joinMaybe _ (Just g) Nothing  = Just g
  91 > joinMaybe _ Nothing  (Just g) = Just g
  92 > joinMaybe f (Just g) (Just h) = Just (f g h)
  93
  94 > data MaybeErr a err = Succeeded a | Failed err deriving (Eq,Show{-was:Text-})
  95
  96 @mkClosure@ makes a closure, when given a comparison and iteration loop.
  97 Be careful, because if the functional always makes the object different,
  98 This will never terminate.
  99
 100 > mkClosure :: (a -> a -> Bool) -> (a -> a) -> a -> a
 101 > mkClosure eq f = match . iterate f
 102 >   where
 103 >       match (a:b:c) | a `eq` b = a
 104 >       match (_:c)              = match c
 105
 106 fold-binary.
 107 It combines the element of the list argument in balanced mannerism.
 108
 109 > foldb :: (a -> a -> a) -> [a] -> a
 110 > foldb f [] = error "can't reduce an empty list using foldb"
 111 > foldb f [x] = x
 112 > foldb f l  = foldb f (foldb' l)
 113 >    where
 114 >       foldb' (x:y:x':y':xs) = f (f x y) (f x' y') : foldb' xs
 115 >       foldb' (x:y:xs) = f x y : foldb' xs
 116 >       foldb' xs = xs
 117
 118 Merge two ordered lists into one ordered list.
 119
 120 > mergeWith               :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 121 > mergeWith _ []     ys      = ys
 122 > mergeWith _ xs     []      = xs
 123 > mergeWith le (x:xs) (y:ys)
 124 >        | x `le` y  = x : mergeWith le xs (y:ys)
 125 >        | otherwise = y : mergeWith le (x:xs) ys
 126
 127 > insertWith              :: (a -> a -> Bool) -> a -> [a] -> [a]
 128 > insertWith _ x []          = [x]
 129 > insertWith le x (y:ys)
 130 >        | x `le` y     = x:y:ys
 131 >        | otherwise    = y:insertWith le x ys
 132
 133 Sorting is something almost every program needs, and this is the
 134 quickest sorting function I know of.
 135
 136 > sortWith :: (a -> a -> Bool) -> [a] -> [a]
 137 > sortWith le [] = []
 138 > sortWith le lst = foldb (mergeWith le) (splitList lst)
 139 >   where
 140 >       splitList (a1:a2:a3:a4:a5:xs) =
 141 >                insertWith le a1
 142 >               (insertWith le a2
 143 >               (insertWith le a3
 144 >               (insertWith le a4 [a5]))) : splitList xs
 145 >       splitList [] = []
 146 >       splitList (r:rs) = [foldr (insertWith le) [r] rs]
 147
 148 > sort :: (Ord a) => [a] -> [a]
 149 > sort = sortWith (<=)
 150
 151 Gofer-like stuff:
 152
 153 > cjustify, ljustify, rjustify :: Int -> String -> String
 154 > cjustify n s = space halfm ++ s ++ space (m - halfm)
 155 >                where m     = n - length s
 156 >                      halfm = m `div` 2
 157 > ljustify n s = s ++ space (max 0 (n - length s))
 158 > rjustify n s = space (max 0 (n - length s)) ++ s
 159
 160 > space       :: Int -> String
 161 > space n      = copy n ' '
 162
 163 > copy  :: Int -> a -> [a]      -- make list of n copies of x
 164 > copy n x = take n xs where xs = x:xs
 165
 166 > combinePairs :: (Ord a) => [(a,b)] -> [(a,[b])]
 167 > combinePairs xs =
 168 >       combine [ (a,[b]) | (a,b) <- sortWith (\ (a,_) (b,_) -> a <= b) xs]
 169 >  where
 170 >       combine [] = []
 171 >       combine ((a,b):(c,d):r) | a == c = combine ((a,b++d) : r)
 172 >       combine (a:r) = a : combine r
 173 >
 174
 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