path: root/progs/prelude/PreludeList.hs

-- Standard list functions

-- build really shouldn't be exported, but what the heck.
-- some of the helper functions in this file shouldn't be
-- exported either!

module PreludeList (PreludeList.., foldr, build) where

import PreludePrims(build, foldr)

{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols

infixl 9  !!
infix  5  \\
infixr 5  ++
infix  4 `elem`, `notElem`


-- These are primitives used by the deforestation stuff in the optimizer.
-- the optimizer will turn references to foldr and build into
-- inlineFoldr and inlineBuild, respectively, but doesn't want to
-- necessarily inline all references immediately.

inlineFoldr :: (a -> b -> b) -> b -> [a] -> b
inlineFoldr f z l =
  let foldr' []	 	= z
      foldr' (x:xs)	= f x (foldr' xs)
  in foldr' l
{-# inlineFoldr :: Inline #-}


inlineBuild :: ((a -> [a] -> [a]) -> [b] -> [c]) -> [c]
inlineBuild g           = g (:) []
{-# inlineBuild :: Inline #-}


-- head and tail extract the first element and remaining elements,
-- respectively, of a list, which must be non-empty.  last and init
-- are the dual functions working from the end of a finite list,
-- rather than the beginning.

head			:: [a] -> a
head (x:_)		=  x
head []			=  error "head{PreludeList}: head []"

last			:: [a] -> a
last [x]		=  x
last (_:xs)		=  last xs
last []			=  error "last{PreludeList}: last []"

tail			:: [a] -> [a]
tail (_:xs)		=  xs
tail []			=  error "tail{PreludeList}: tail []"

init			:: [a] -> [a]
init [x]		=  []
init (x:xs)		=  x : init xs
init []			=  error "init{PreludeList}: init []"

-- null determines if a list is empty.
null			:: [a] -> Bool
null []			=  True
null (_:_)		=  False


-- list concatenation (right-associative)

(++)			:: [a] -> [a] -> [a]
xs ++ ys		= build (\ c n -> foldr c (foldr c n ys) xs)
{-# (++) :: Inline #-}


-- the first occurrence of each element of ys in turn (if any)
-- has been removed from xs.  Thus, (xs ++ ys) \\ xs == ys.
(\\)			:: (Eq a) => [a] -> [a] -> [a]
(\\)			=  foldl del
			   where [] `del` _	    = []
				 (x:xs) `del` y
					| x == y    = xs
					| otherwise = x : xs `del` y

-- length returns the length of a finite list as an Int; it is an instance
-- of the more general genericLength, the result type of which may be
-- any kind of number.

genericLength		:: (Num a) => [b] -> a
genericLength l         = foldr (\ x n -> 1 + n) 0 l
--genericLength []	=  0
--genericLength (x:xs)    =  1 + genericLength xs
{-# genericLength :: Inline #-}


length			:: [a] -> Int
length l		= foldr (\ x n -> 1 + n) 0 l
--length []               = 0
--length (x:xs)           = 1 + length xs
{-# length :: Inline #-}

-- List index (subscript) operator, 0-origin
(!!)			:: (Integral a) => [b] -> a -> b
l !! i			=  nth l (fromIntegral i)
{-# (!!)  :: Inline #-}

nth                     :: [b] -> Int -> b
nth l m	= let f x g 0 = x
	      f x g i = g (i - 1)
	      fail _ = error "(!!){PreludeList}: index too large"
	  in foldr f fail l m
{-# nth  :: Inline #-}
--nth _ n  | n < 0	= error "(!!){PreludeList}: negative index"
--nth [] n		= error "(!!){PreludeList}: index too large"
--nth (x:xs) n 
--	| n == 0	= x
--	| otherwise     = nth xs (n - 1)
--{-# nth  :: Strictness("S,S") #-}

-- map f xs applies f to each element of xs; i.e., map f xs == [f x | x <- xs].
map			:: (a -> b) -> [a] -> [b]
map f xs		= build (\ c n -> foldr (\ a b -> c (f a) b) n xs)
--map f []		=  []
--map f (x:xs)		=  f x : map f xs
{-# map  :: Inline #-}


-- filter, applied to a predicate and a list, returns the list of those
-- elements that satisfy the predicate; i.e.,
-- filter p xs == [x | x <- xs, p x].
filter			:: (a -> Bool) -> [a] -> [a]
filter f xs		= build (\ c n ->
                                  foldr (\ a b -> if f a then c a b else b)
				  n xs)
--filter p		=  foldr (\x xs -> if p x then x:xs else xs) []
{-# filter  :: Inline #-}

 
-- partition takes a predicate and a list and returns a pair of lists:
-- those elements of the argument list that do and do not satisfy the
-- predicate, respectively; i.e.,
-- partition p xs == (filter p xs, filter (not . p) xs).
partition		:: (a -> Bool) -> [a] -> ([a],[a])
partition p		=  foldr select ([],[])
			   where select x (ts,fs) | p x	      = (x:ts,fs)
						  | otherwise = (ts,x:fs)
{-# partition  :: Inline #-}


-- foldl, applied to a binary operator, a starting value (typically the
-- left-identity of the operator), and a list, reduces the list using
-- the binary operator, from left to right:
--	foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn
-- foldl1 is a variant that has no starting value argument, and  thus must
-- be applied to non-empty lists.  scanl is similar to foldl, but returns
-- a list of successive reduced values from the left:
--	scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]
-- Note that  last (scanl f z xs) == foldl f z xs.
-- scanl1 is similar, again without the starting element:
--	scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]

foldl			:: (a -> b -> a) -> a -> [b] -> a
foldl f z xs            = foldr (\ b g a -> g (f a b)) id xs z
--foldl f z []		=  z
--foldl f z (x:xs)	=  foldl f (f z x) xs
{-# foldl  :: Inline #-}

foldl1			:: (a -> a -> a) -> [a] -> a
foldl1 f (x:xs)		=  foldl f x xs
foldl1 _ []		=  error "foldl1{PreludeList}: empty list"
{-# foldl1  :: Inline #-}

scanl			:: (a -> b -> a) -> a -> [b] -> [a]
scanl f q xs		=  q : (case xs of
				[]   -> []
				x:xs -> scanl f (f q x) xs)
{-# scanl  :: Inline #-}

scanl1			:: (a -> a -> a) -> [a] -> [a]
scanl1 f (x:xs)		=  scanl f x xs
scanl1 _ []		=  error "scanl1{PreludeList}: empty list"
{-# scanl1 :: Inline #-}


-- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the
-- above functions.

--foldr			:: (a -> b -> b) -> b -> [a] -> b
--foldr f z []		=  z
--foldr f z (x:xs)	=  f x (foldr f z xs)


foldr1			:: (a -> a -> a) -> [a] -> a
foldr1 f [x]		=  x
foldr1 f (x:xs)		=  f x (foldr1 f xs)
foldr1 _ []		=  error "foldr1{PreludeList}: empty list"
{-# foldr1  :: Inline #-}


-- I'm not sure the build/foldr expansion wins.

scanr			:: (a -> b -> b) -> b -> [a] -> [b]
--scanr f q0 l = build (\ c n ->
--                        let g x qs@(q:_) = c (f x q) qs
--			in foldr g (c q0 n) l)
scanr f q0 []		=  [q0]
scanr f q0 (x:xs)	=  f x q : qs
			   where qs@(q:_) = scanr f q0 xs 
{-# scanr  :: Inline #-}

scanr1			:: (a -> a -> a) -> [a] -> [a]
scanr1 f  [x]		=  [x]
scanr1 f  (x:xs)	=  f x q : qs
			   where qs@(q:_) = scanr1 f xs 
scanr1 _ []		=  error "scanr1{PreludeList}: empty list"
{-# scanr1  :: Inline #-}


-- iterate f x returns an infinite list of repeated applications of f to x:
-- iterate f x == [x, f x, f (f x), ...]
iterate			:: (a -> a) -> a -> [a]
iterate f x	= build (\ c n ->
                          let iterate' x' = c x' (iterate' (f x'))
			  in iterate' x)
--iterate f x		=  x : iterate f (f x)
{-# iterate  :: Inline #-}


-- repeat x is an infinite list, with x the value of every element.
repeat			:: a -> [a]
repeat x		= build (\ c n -> let r = c x r in r)
--repeat x		=  xs where xs = x:xs
{-# repeat  :: Inline #-}

-- cycle ties a finite list into a circular one, or equivalently,
-- the infinite repetition of the original list.  It is the identity
-- on infinite lists.

cycle			:: [a] -> [a]
cycle xs		=  xs' where xs' = xs ++ xs'


-- take n, applied to a list xs, returns the prefix of xs of length n,
-- or xs itself if n > length xs.  drop n xs returns the suffix of xs
-- after the first n elements, or [] if n > length xs.  splitAt n xs
-- is equivalent to (take n xs, drop n xs).

take			:: (Integral a) => a -> [b] -> [b]
take n l		= takeInt (fromIntegral n) l
{-# take  :: Inline #-}

takeInt                 :: Int -> [b] -> [b]
takeInt m l = 
  build (\ c n ->
           let f x g i | i <= 0		= n
	               | otherwise      = c x (g (i - 1))
           in foldr f (\ _ -> n) l m)
--takeInt  0     _	=  []
--takeInt  _     []	=  []
--takeInt  n l | n > 0    = primTake n l
{-# takeInt  :: Inline #-}



-- Writing drop and friends in terms of build/foldr seems to lose
-- way big since they cause an extra traversal of the list tail
-- (except when the calls are being deforested).

drop			:: (Integral a) => a -> [b] -> [b]
drop n l		= dropInt (fromIntegral n) l
{-# drop  :: Inline #-}
{-# drop  :: Strictness("S,S") #-}


dropInt                 :: Int -> [b] -> [b]
dropInt  0     xs	=  xs
dropInt  _     []	=  []
dropInt (n+1) (_:xs)	=  dropInt n xs
{-# dropInt  :: Inline #-}

splitAt			:: (Integral a) => a -> [b] -> ([b],[b])
splitAt n l		= splitAtInt (fromIntegral n) l
{-# splitAt  :: Inline #-}

splitAtInt		:: Int -> [b] -> ([b],[b])
splitAtInt  0     xs	=  ([],xs)
splitAtInt  _     []	=  ([],[])
splitAtInt (n+1) (x:xs)	=  (x:xs',xs'') where (xs',xs'') = splitAtInt n xs
{-# splitAtInt  :: Inline #-}

-- takeWhile, applied to a predicate p and a list xs, returns the longest
-- prefix (possibly empty) of xs of elements that satisfy p.  dropWhile p xs
-- returns the remaining suffix.  Span p xs is equivalent to
-- (takeWhile p xs, dropWhile p xs), while break p uses the negation of p.

takeWhile		:: (a -> Bool) -> [a] -> [a]
takeWhile p l = build (\ c n -> foldr (\ a b -> if p a then c a b else n) n l)
--takeWhile p []		=  []
--takeWhile p (x:xs) 
--            | p x       =  x : takeWhile p xs
--            | otherwise =  []
{-# takeWhile  :: Inline #-}


dropWhile		:: (a -> Bool) -> [a] -> [a]
dropWhile p []		=  []
dropWhile p xs@(x:xs')
	    | p x       =  dropWhile p xs'
	    | otherwise =  xs
{-# dropWhile  :: Inline #-}

span, break		:: (a -> Bool) -> [a] -> ([a],[a])
span p []		=  ([],[])
span p xs@(x:xs')
	   | p x	=  let (ys,zs) = span p xs' in (x:ys,zs)
	   | otherwise	=  ([],xs)
break p			=  span (not . p)

{-# span  :: Inline #-}
{-# break  :: Inline #-}


-- lines breaks a string up into a list of strings at newline characters.
-- The resulting strings do not contain newlines.  Similary, words
-- breaks a string up into a list of words, which were delimited by
-- white space.  unlines and unwords are the inverse operations.
-- unlines joins lines with terminating newlines, and unwords joins
-- words with separating spaces.

lines			:: String -> [String]
lines ""		=  []
lines s			=  let (l, s') = break (== '\n') s
			   in  l : case s' of
					[]     	-> []
					(_:s'') -> lines s''

words			:: String -> [String]
words s			=  case dropWhile isSpace s of
				"" -> []
				s' -> w : words s''
				      where (w, s'') = break isSpace s'

unlines			:: [String] -> String
unlines			=  concat . map (++ "\n")
{-# unlines  :: Inline #-}


unwords			:: [String] -> String
unwords []		=  ""
unwords ws		=  foldr1 (\w s -> w ++ ' ':s) ws

-- nub (meaning "essence") removes duplicate elements from its list argument.
nub			:: (Eq a) => [a] -> [a]
nub l = build (\ c n ->
                 let f x g [] = c x (g [x])
		     f x g xs = if elem x xs
		                   then (g xs)
				   else c x (g (x:xs))
                 in foldr f (\ _ -> n) l [])
{-# nub  :: Inline #-}
--nub []			=  []
--nub (x:xs)		=  x : nub (filter (/= x) xs)

-- reverse xs returns the elements of xs in reverse order.  xs must be finite.
reverse			:: [a] -> [a]
reverse l = build (\ c n ->
                     let f x g tail = g (c x tail)
		     in foldr f id l n)
{-# reverse  :: Inline #-}
--reverse x               =  reverse1 x [] where
--  reverse1 [] a     = a
--  reverse1 (x:xs) a = reverse1 xs (x:a)

-- and returns the conjunction of a Boolean list.  For the result to be
-- True, the list must be finite; False, however, results from a False
-- value at a finite index of a finite or infinite list.  or is the
-- disjunctive dual of and.
and, or			:: [Bool] -> Bool
and			=  foldr (&&) True
or			=  foldr (||) False
{-# and :: Inline #-}
{-# or  :: Inline #-}

-- Applied to a predicate and a list, any determines if any element
-- of the list satisfies the predicate.  Similarly, for all.
any, all		:: (a -> Bool) -> [a] -> Bool
any p			=  or . map p
all p			=  and . map p
{-# any :: Inline #-}
{-# all :: Inline #-}

-- elem is the list membership predicate, usually written in infix form,
-- e.g., x `elem` xs.  notElem is the negation.
elem, notElem		:: (Eq a) => a -> [a] -> Bool

elem x ys = foldr (\ y t -> (x == y) || t) False ys
--x `elem` []		=  False
--x `elem` (y:ys)         =  x == y || x `elem` ys
{-# elem :: Inline #-}
notElem	x y		=  not (x `elem` y)

-- sum and product compute the sum or product of a finite list of numbers.
sum, product		:: (Num a) => [a] -> a
sum			=  foldl (+) 0	
product			=  foldl (*) 1
{-# sum :: Inline #-}
{-# product :: Inline #-}

-- sums and products give a list of running sums or products from
-- a list of numbers.  For example,  sums [1,2,3] == [0,1,3,6].
sums, products		:: (Num a) => [a] -> [a]
sums			=  scanl (+) 0
products		=  scanl (*) 1

-- maximum and minimum return the maximum or minimum value from a list,
-- which must be non-empty, finite, and of an ordered type.
maximum, minimum	:: (Ord a) => [a] -> a
maximum			=  foldl1 max
minimum			=  foldl1 min
{-# maximum :: Inline #-}
{-# minimum :: Inline #-}

-- concat, applied to a list of lists, returns their flattened concatenation.
concat			:: [[a]] -> [a]
concat xs	= build (\ c n -> foldr (\ x y -> foldr c y x) n xs)
--concat []               =  []
--concat (l:ls)           =  l ++ concat ls
{-# concat :: Inline #-}


-- transpose, applied to a list of lists, returns that list with the
-- "rows" and "columns" interchanged.  The input need not be rectangular
-- (a list of equal-length lists) to be completely transposable, but can
-- be "triangular":  Each successive component list must be not longer
-- than the previous one; any elements outside of the "triangular"
-- transposable region are lost.  The input can be infinite in either
-- dimension or both.
transpose		:: [[a]] -> [[a]]
transpose		=  foldr 
			     (\xs xss -> zipWith (:) xs (xss ++ repeat []))
			     []
{-# transpose :: Inline #-}

-- zip takes two lists and returns a list of corresponding pairs.  If one
-- input list is short, excess elements of the longer list are discarded.
-- zip3 takes three lists and returns a list of triples, etc.  Versions
-- of zip producing up to septuplets are defined here.

zip			:: [a] -> [b] -> [(a,b)]
zip			=  zipWith (\a b -> (a,b))
{-# zip :: Inline #-}

zip3			:: [a] -> [b] -> [c] -> [(a,b,c)]
zip3			=  zipWith3 (\a b c -> (a,b,c))
{-# zip3 :: Inline #-}

zip4			:: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]
zip4			=  zipWith4 (\a b c d -> (a,b,c,d))
{-# zip4 :: Inline #-}

zip5			:: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]
zip5			=  zipWith5 (\a b c d e -> (a,b,c,d,e))
{-# zip5 :: Inline #-}

zip6			:: [a] -> [b] -> [c] -> [d] -> [e] -> [f]
			   -> [(a,b,c,d,e,f)]
zip6			=  zipWith6 (\a b c d e f -> (a,b,c,d,e,f))
{-# zip6 :: Inline #-}

zip7			:: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g]
			   -> [(a,b,c,d,e,f,g)]
zip7			=  zipWith7 (\a b c d e f g -> (a,b,c,d,e,f,g))
{-# zip7 :: Inline #-}

-- The zipWith family generalises the zip family by zipping with the
-- function given as the first argument, instead of a tupling function.
-- For example, zipWith (+) is applied to two lists to produce the list
-- of corresponding sums.

zipWith			:: (a->b->c) -> [a]->[b]->[c]
zipWith z as bs =
  build (\ c' n' ->
           let f' a g' (b:bs) = c' (z a b) (g' bs)
	       f' a g' _ = n'
           in foldr f' (\ _ -> n') as bs)
--zipWith z (a:as) (b:bs)	=  z a b : zipWith z as bs
--zipWith _ _ _		=  []
{-# zipWith :: Inline #-}

zipWith3		:: (a->b->c->d) -> [a]->[b]->[c]->[d]
zipWith3 z as bs cs =
  build (\ c' n' ->
          let f' a g' (b:bs) (c:cs) = c' (z a b c) (g' bs cs)
              f' a g' _ _ = n'
          in foldr f' (\ _ _ -> n') as bs cs)
{-# zipWith3 :: Inline #-}
--zipWith3 z (a:as) (b:bs) (c:cs)
--			=  z a b c : zipWith3 z as bs cs
--zipWith3 _ _ _ _	=  []

zipWith4		:: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
zipWith4 z as bs cs ds =
  build (\ c' n' ->
          let f' a g' (b:bs) (c:cs) (d:ds) = c' (z a b c d) (g' bs cs ds)
              f' a g' _ _ _ = n'
          in foldr f' (\ _ _ _ -> n') as bs cs ds)
{-# zipWith4 :: Inline #-}
--zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)
--			=  z a b c d : zipWith4 z as bs cs ds
--zipWith4 _ _ _ _ _	=  []

zipWith5		:: (a->b->c->d->e->f)
			   -> [a]->[b]->[c]->[d]->[e]->[f]
zipWith5 z as bs cs ds es=
  build (\ c' n' ->
          let f' a g' (b:bs) (c:cs) (d:ds) (e:es) =
	        c' (z a b c d e) (g' bs cs ds es)
              f' a g' _ _ _ _ = n'
          in foldr f' (\ _ _ _ _ -> n') as bs cs ds es)
{-# zipWith5 :: Inline #-}
--zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es)
--			=  z a b c d e : zipWith5 z as bs cs ds es
--zipWith5 _ _ _ _ _ _	=  []

zipWith6		:: (a->b->c->d->e->f->g)
			   -> [a]->[b]->[c]->[d]->[e]->[f]->[g]
zipWith6 z as bs cs ds es fs =
  build (\ c' n' ->
          let f' a g' (b:bs) (c:cs) (d:ds) (e:es) (f:fs) =
	        c' (z a b c d e f) (g' bs cs ds es fs)
              f' a g' _ _ _ _ _ = n'
          in foldr f' (\ _ _ _ _ _ -> n') as bs cs ds es fs)
{-# zipWith6 :: Inline #-}
--zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs)
--			=  z a b c d e f : zipWith6 z as bs cs ds es fs
--zipWith6 _ _ _ _ _ _ _	=  []

zipWith7		:: (a->b->c->d->e->f->g->h)
			   -> [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h]
zipWith7 z as bs cs ds es fs gs =
  build (\ c' n' ->
          let f' a g' (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) =
	        c' (z a b c d e f g) (g' bs cs ds es fs gs)
              f' a g' _ _ _ _ _ _ = n'
          in foldr f' (\ _ _ _ _ _ _ -> n') as bs cs ds es fs gs)
{-# zipWith7 :: Inline #-}
--zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs)
--		   =  z a b c d e f g : zipWith7 z as bs cs ds es fs gs
--zipWith7 _ _ _ _ _ _ _ _ =  []


-- unzip transforms a list of pairs into a pair of lists.  As with zip,
-- a family of such functions up to septuplets is provided.

unzip			:: [(a,b)] -> ([a],[b])
unzip			=  foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[])
{-# unzip :: Inline #-}


unzip3			:: [(a,b,c)] -> ([a],[b],[c])
unzip3			=  foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
				 ([],[],[])
{-# unzip3 :: Inline #-}

unzip4			:: [(a,b,c,d)] -> ([a],[b],[c],[d])
unzip4			=  foldr (\(a,b,c,d) ~(as,bs,cs,ds) ->
					(a:as,b:bs,c:cs,d:ds))
				 ([],[],[],[])
{-# unzip4 :: Inline #-}

unzip5			:: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e])
unzip5			=  foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) ->
					(a:as,b:bs,c:cs,d:ds,e:es))
				 ([],[],[],[],[])
{-# unzip5 :: Inline #-}

unzip6			:: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f])
unzip6			=  foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) ->
					(a:as,b:bs,c:cs,d:ds,e:es,f:fs))
				 ([],[],[],[],[],[])
{-# unzip6 :: Inline #-}

unzip7			:: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g])
unzip7			=  foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) ->
					(a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs))
				 ([],[],[],[],[],[],[])
{-# unzip7 :: Inline #-}