ghc/lib/hbc/ListUtil.hs

   1 #if __HASKELL1__ < 3
   2 module ListUtil(assoc, concatMap, unfoldr, mapAccuml, union, intersection, chopList, assocDef, lookup, Maybe..,
   3                 rept, tails, groupEq, group, readListLazily, nubEq, elemEq) where
   4 import {-flummox mkdependHS-}
   5         Maybe
   6 #else
   7 module ListUtil(assoc, concatMap, unfoldr, mapAccuml, union, intersection, chopList, assocDef, lookup, -- Maybe..,
   8                 rept, tails, groupEq, group, readListLazily, nubEq, elemEq) where
   9 --import Maybe
  10 #endif
  11
  12 -- Lookup an item in an association list.  Apply a function to it if it is found, otherwise return a default value.
  13 assoc :: (Eq c) => (a -> b) -> b -> [(c, a)] -> c -> b
  14 assoc f d [] x                       = d
  15 assoc f d ((x',y):xys) x | x' == x   = f y
  16                          | otherwise = assoc f d xys x
  17
  18 -- Map and concatename results.
  19 concatMap :: (a -> [b]) -> [a] -> [b]
  20 concatMap f []     = []
  21 concatMap f (x:xs) =
  22         case f x of
  23         [] -> concatMap f xs
  24         ys -> ys ++ concatMap f xs
  25
  26 -- Repeatedly extract (and transform) values until a predicate hold.  Return the list of values.
  27 unfoldr :: (a -> (b, a)) -> (a -> Bool) -> a -> [b]
  28 unfoldr f p x | p x       = []
  29               | otherwise = y:unfoldr f p x'
  30                               where (y, x') = f x
  31
  32 -- Map, but plumb a state through the map operation.
  33 mapAccuml :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])
  34 mapAccuml f s []     = (s, [])
  35 mapAccuml f s (x:xs) = (s'', y:ys)
  36                        where (s',  y)  = f s x
  37                              (s'', ys) = mapAccuml f s' xs
  38
  39 -- Union of sets as lists.
  40 union :: (Eq a) => [a] -> [a] -> [a]
  41 union xs ys = xs ++ (ys \\ xs)
  42
  43 -- Intersection of sets as lists.
  44 intersection :: (Eq a) => [a] -> [a] -> [a]
  45 intersection xs ys = [x | x<-xs, x `elem` ys]
  46
  47 --- Functions derived from those above
  48
  49 chopList :: ([a] -> (b, [a])) -> [a] -> [b]
  50 chopList f l = unfoldr f null l
  51
  52 assocDef :: (Eq a) => [(a, b)] -> b -> a -> b
  53 --assocDef l d x = assoc id d l x
  54 assocDef [] d _ = d
  55 assocDef ((x,y):xys) d x' = if x == x' then y else assocDef xys d x'
  56
  57 lookup :: (Eq a) => [(a, b)] -> a -> Maybe b
  58 --lookup l x = assoc Just Nothing l x
  59 lookup [] _ = Nothing
  60 lookup ((x,y):xys) x' = if x == x' then Just y else lookup xys x'
  61
  62 -- Repeat an element n times
  63 rept :: (Integral a) => a -> b -> [b]
  64 rept n x = irept (fromIntegral n) x
  65         where irept :: Int -> a -> [a]
  66               irept n x = if n <= 0 then [] else x : irept (n-1) x
  67
  68 -- Take all the tails
  69 tails :: [a] -> [[a]]
  70 tails []         = []
  71 tails xxs@(_:xs) = xxs : tails xs
  72
  73 -- group list elements according to an equality predicate
  74 groupEq :: (a->a->Bool) -> [a] -> [[a]]
  75 groupEq eq xs = chopList f xs
  76                 where f xs@(x:_) = span (eq x) xs
  77
  78 group :: (Eq a) => [a] -> [[a]]
  79 group xs = groupEq (==) xs
  80
  81 -- Read a list lazily (in contrast with reads which requires
  82 -- to see the ']' before returning the list.
  83 readListLazily :: (Text a) => String -> [a]
  84 readListLazily cs =
  85     case lex cs of
  86       [("[",cs)] -> readl' cs
  87       _          -> error "No leading '['"
  88     where readl' cs  =
  89                 case reads cs of
  90                   [(x,cs)]  -> x : readl cs
  91                   []        -> error "No parse for list element"
  92                   _         -> error "Ambigous parse for list element"
  93           readl cs =
  94                 case lex cs of
  95                   [("]",_)]  -> []
  96                   [(",",cs)] -> readl' cs
  97                   _          -> error "No ',' or ']'"
  98
  99 nubEq :: (a->a->Bool) -> [a] -> [a]
 100 nubEq eq l = nub' l []
 101         where nub' [] _     = []
 102               nub' (x:xs) l = if elemEq eq x l then nub' xs l else x : nub' xs (x:l)
 103
 104 elemEq :: (a->a->Bool) -> a -> [a] -> Bool
 105 elemEq eq _ []     = False
 106 elemEq eq x (y:ys) = eq x y || elemEq eq x ys
 107
 108 mapFst f xys = [(f x, y) | (x, y) <- xys]
 109 mapSnd f xys = [(x, f y) | (x, y) <- xys]