1 files changed, 244 insertions, 0 deletions
diff --git a/testsuite/tests/programs/andy_cherry/GenUtils.hs b/testsuite/tests/programs/andy_cherry/GenUtils.hs
new file mode 100644
index 0000000000..3e1de07fb8
--- /dev/null
+++ b/testsuite/tests/programs/andy_cherry/GenUtils.hs
@@ -0,0 +1,244 @@
+
+
+
+
+
+
+
+
+
+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
+
+
+