From: andy Date: Thu, 9 Mar 2000 05:59:48 +0000 (+0000) Subject: [project @ 2000-03-09 05:59:48 by andy] X-Git-Tag: Approximately_9120_patches~5037 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=075e0c07f4c873dbdb41bccdfa883b65c4ffb0f4;p=ghc-hetmet.git [project @ 2000-03-09 05:59:48 by andy] Changing use literate programming, to allow hugs to compile this program. --- diff --git a/ghc/tests/programs/andy_cherry/GenUtils.lhs b/ghc/tests/programs/andy_cherry/GenUtils.lhs index e10035a..1e93589 100644 --- a/ghc/tests/programs/andy_cherry/GenUtils.lhs +++ b/ghc/tests/programs/andy_cherry/GenUtils.lhs @@ -2,242 +2,246 @@ Some General Utilities, including sorts, etc. This is realy just an extended prelude. All the code below is understood to be in the public domain. -> module GenUtils ( +Changed to use \begin\end code, to help +as a test example for STG Hugs. - trace, +\begin{code} +module GenUtils ( -> 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 Array -- 1.3 -> import Ix -- 1.3 - ->#ifndef __GLASGOW_HASKELL__ - -> import {-fool mkdependHS-} -> Trace - ->#endif - -%------------------------------------------------------------------------------ - -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 + 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 Array -- 1.3 +import Ix -- 1.3 + +#ifndef __GLASGOW_HASKELL__ + +import {-fool mkdependHS-} + IOExts( trace ) + +#endif + +-- ------------------------------------------------------------------------- + +-- 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 + +\end{code}