-> 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
projects / ghc-hetmet.git / commitdiff