diff options
Diffstat (limited to 'testsuite/tests/ghc-regress/programs/andy_cherry/GenUtils.hs')
| -rw-r--r-- | testsuite/tests/ghc-regress/programs/andy_cherry/GenUtils.hs | 244 |
1 files changed, 0 insertions, 244 deletions
diff --git a/testsuite/tests/ghc-regress/programs/andy_cherry/GenUtils.hs b/testsuite/tests/ghc-regress/programs/andy_cherry/GenUtils.hs deleted file mode 100644 index 3e1de07fb8..0000000000 --- a/testsuite/tests/ghc-regress/programs/andy_cherry/GenUtils.hs +++ /dev/null @@ -1,244 +0,0 @@ - - - - - - - - - -module GenUtils ( - - trace, - - assocMaybe, assocMaybeErr, - arrElem, - arrCond, - memoise, - Maybe(..), - MaybeErr(..), - mapMaybe, - mapMaybeFail, - maybeToBool, - maybeToObj, - maybeMap, - joinMaybe, - mkClosure, - foldb, - - mapAccumL, - - sortWith, - sort, - cjustify, - ljustify, - rjustify, - space, - copy, - combinePairs, - formatText ) where - -import Data.Array -- 1.3 -import Data.Ix -- 1.3 - -import Debug.Trace ( trace ) - - --- ------------------------------------------------------------------------- - --- Here are two defs that everyone seems to define ... --- HBC has it in one of its builtin modules - -#if defined(__GLASGOW_HASKELL__) || defined(__GOFER__) - ---in 1.3: data Maybe a = Nothing | Just a deriving (Eq,Ord,Text) - -#endif - -infix 1 =: -- 1.3 -type Assoc a b = (a,b) -- 1.3 -(=:) a b = (a,b) - -mapMaybe :: (a -> Maybe b) -> [a] -> [b] -mapMaybe f [] = [] -mapMaybe f (a:r) = case f a of - Nothing -> mapMaybe f r - Just b -> b : mapMaybe f r - --- This version returns nothing, if *any* one fails. - -mapMaybeFail f (x:xs) = case f x of - Just x' -> case mapMaybeFail f xs of - Just xs' -> Just (x':xs') - Nothing -> Nothing - Nothing -> Nothing -mapMaybeFail f [] = Just [] - -maybeToBool :: Maybe a -> Bool -maybeToBool (Just _) = True -maybeToBool _ = False - -maybeToObj :: Maybe a -> a -maybeToObj (Just a) = a -maybeToObj _ = error "Trying to extract object from a Nothing" - -maybeMap :: (a -> b) -> Maybe a -> Maybe b -maybeMap f (Just a) = Just (f a) -maybeMap f Nothing = Nothing - - -joinMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a -joinMaybe _ Nothing Nothing = Nothing -joinMaybe _ (Just g) Nothing = Just g -joinMaybe _ Nothing (Just g) = Just g -joinMaybe f (Just g) (Just h) = Just (f g h) - -data MaybeErr a err = Succeeded a | Failed err deriving (Eq,Show{-was:Text-}) - --- @mkClosure@ makes a closure, when given a comparison and iteration loop. --- Be careful, because if the functional always makes the object different, --- This will never terminate. - -mkClosure :: (a -> a -> Bool) -> (a -> a) -> a -> a -mkClosure eq f = match . iterate f - where - match (a:b:c) | a `eq` b = a - match (_:c) = match c - --- fold-binary. --- It combines the element of the list argument in balanced mannerism. - -foldb :: (a -> a -> a) -> [a] -> a -foldb f [] = error "can't reduce an empty list using foldb" -foldb f [x] = x -foldb f l = foldb f (foldb' l) - where - foldb' (x:y:x':y':xs) = f (f x y) (f x' y') : foldb' xs - foldb' (x:y:xs) = f x y : foldb' xs - foldb' xs = xs - --- Merge two ordered lists into one ordered list. - -mergeWith :: (a -> a -> Bool) -> [a] -> [a] -> [a] -mergeWith _ [] ys = ys -mergeWith _ xs [] = xs -mergeWith le (x:xs) (y:ys) - | x `le` y = x : mergeWith le xs (y:ys) - | otherwise = y : mergeWith le (x:xs) ys - -insertWith :: (a -> a -> Bool) -> a -> [a] -> [a] -insertWith _ x [] = [x] -insertWith le x (y:ys) - | x `le` y = x:y:ys - | otherwise = y:insertWith le x ys - --- Sorting is something almost every program needs, and this is the --- quickest sorting function I know of. - -sortWith :: (a -> a -> Bool) -> [a] -> [a] -sortWith le [] = [] -sortWith le lst = foldb (mergeWith le) (splitList lst) - where - splitList (a1:a2:a3:a4:a5:xs) = - insertWith le a1 - (insertWith le a2 - (insertWith le a3 - (insertWith le a4 [a5]))) : splitList xs - splitList [] = [] - splitList (r:rs) = [foldr (insertWith le) [r] rs] - -sort :: (Ord a) => [a] -> [a] -sort = sortWith (<=) - --- Gofer-like stuff: - -cjustify, ljustify, rjustify :: Int -> String -> String -cjustify n s = space halfm ++ s ++ space (m - halfm) - where m = n - length s - halfm = m `div` 2 -ljustify n s = s ++ space (max 0 (n - length s)) -rjustify n s = space (max 0 (n - length s)) ++ s - -space :: Int -> String -space n = copy n ' ' - -copy :: Int -> a -> [a] -- make list of n copies of x -copy n x = take n xs where xs = x:xs - -combinePairs :: (Ord a) => [(a,b)] -> [(a,[b])] -combinePairs xs = - combine [ (a,[b]) | (a,b) <- sortWith (\ (a,_) (b,_) -> a <= b) xs] - where - combine [] = [] - combine ((a,b):(c,d):r) | a == c = combine ((a,b++d) : r) - combine (a:r) = a : combine r - -assocMaybe :: (Eq a) => [(a,b)] -> a -> Maybe b -assocMaybe env k = case [ val | (key,val) <- env, k == key] of - [] -> Nothing - (val:vs) -> Just val - -assocMaybeErr :: (Eq a) => [(a,b)] -> a -> MaybeErr b String -assocMaybeErr env k = case [ val | (key,val) <- env, k == key] of - [] -> Failed "assoc: " - (val:vs) -> Succeeded val - - -deSucc (Succeeded e) = e - -mapAccumL :: (a -> b -> (c,a)) -> a -> [b] -> ([c],a) -mapAccumL f s [] = ([],s) -mapAccumL f s (b:bs) = (c:cs,s'') - where - (c,s') = f s b - (cs,s'') = mapAccumL f s' bs - - - --- Now some utilties involving arrays. --- Here is a version of @elem@ that uses partual application --- to optimise lookup. - -arrElem :: (Ix a) => [a] -> a -> Bool -arrElem obj = \x -> inRange size x && arr ! x - where - size = (maximum obj,minimum obj) - arr = listArray size [ i `elem` obj | i <- range size ] - --- Here is the functional version of a multi-way conditional, --- again using arrays, of course. Remember @b@ can be a function ! --- Note again the use of partiual application. - -arrCond :: (Ix a) - => (a,a) -- the bounds - -> [(Assoc [a] b)] -- the simple lookups - -> [(Assoc (a -> Bool) b)] -- the functional lookups - -> b -- the default - -> a -> b -- the (functional) result - -arrCond bds pairs fnPairs def = (!) arr' - where - arr' = array bds [ t =: head - ([ r | (p, r) <- pairs, elem t p ] ++ - [ r | (f, r) <- fnPairs, f t ] ++ - [ def ]) - | t <- range bds ] - -memoise :: (Ix a) => (a,a) -> (a -> b) -> a -> b -memoise bds f = (!) arr - where arr = array bds [ t =: f t | t <- range bds ] - --- Quite neat this. Formats text to fit in a column. - -formatText :: Int -> [String] -> [String] -formatText n = map unwords . cutAt n [] - where - cutAt :: Int -> [String] -> [String] -> [[String]] - cutAt m wds [] = [reverse wds] - cutAt m wds (wd:rest) = if len <= m || null wds - then cutAt (m-(len+1)) (wd:wds) rest - else reverse wds : cutAt n [] (wd:rest) - where len = length wd - - - |