%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+% (c) The University of Glasgow 1992-2002
%
\section[Util]{Highly random utility functions}
\begin{code}
--- IF_NOT_GHC is meant to make this module useful outside the context of GHC
-#define IF_NOT_GHC(a)
-
module Util (
-#if NOT_USED
- -- The Eager monad
- Eager, thenEager, returnEager, mapEager, appEager, runEager,
-#endif
-- general list processing
zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
zipLazy, stretchZipWith,
mapAndUnzip, mapAndUnzip3,
- nOfThem, lengthExceeds, isSingleton, only,
- snocView,
+ nOfThem,
+ lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength,
+ isSingleton, only,
+ notNull, snocView,
+
isIn, isn'tIn,
-- for-loop
nTimes,
- -- maybe-ish
- unJust,
-
-- sorting
- IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
- sortLt,
- IF_NOT_GHC(mergeSort COMMA) naturalMergeSortLe, -- from Carsten
- IF_NOT_GHC(naturalMergeSort COMMA mergeSortLe COMMA)
+ sortLt, naturalMergeSortLe,
-- transitive closures
transitiveClosure,
-- accumulating
mapAccumL, mapAccumR, mapAccumB,
foldl2, count,
+
+ takeList, dropList, splitAtList,
-- comparisons
- eqListBy, thenCmp, cmpList, prefixMatch, suffixMatch,
+ eqListBy, equalLength, compareLength,
+ thenCmp, cmpList, prefixMatch, suffixMatch,
-- strictness
foldl', seqList,
-- pairs
- IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
- IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
- unzipWith
-
- , global
+ unzipWith,
-#if __GLASGOW_HASKELL__ <= 408
- , catchJust
- , ioErrors
- , throwTo
-#endif
+ global,
+ -- module names
+ looksLikeModuleName,
+
+ toArgs
) where
#include "../includes/config.h"
#include "HsVersions.h"
-import List ( zipWith4 )
-import Maybe ( Maybe(..) )
-import Panic ( panic )
-import IOExts ( IORef, newIORef, unsafePerformIO )
+import Panic ( panic, trace )
import FastTypes
+
#if __GLASGOW_HASKELL__ <= 408
-import Exception ( catchIO, justIoErrors, raiseInThread )
+import EXCEPTION ( catchIO, justIoErrors, raiseInThread )
+#endif
+import DATA_IOREF ( IORef, newIORef )
+import UNSAFE_IO ( unsafePerformIO )
+
+import qualified List ( elem, notElem )
+
+#ifndef DEBUG
+import List ( zipWith4 )
#endif
+import Char ( isUpper, isAlphaNum, isSpace )
+
infixr 9 `thenCmp`
\end{code}
%************************************************************************
%* *
-\subsection{Maybe-ery}
-%* *
-%************************************************************************
-
-\begin{code}
-unJust :: String -> Maybe a -> a
-unJust who (Just x) = x
-unJust who Nothing = panic ("unJust of Nothing, called by " ++ who)
-\end{code}
-
-%************************************************************************
-%* *
\subsection[Utils-lists]{General list processing}
%* *
%************************************************************************
nOfThem :: Int -> a -> [a]
nOfThem n thing = replicate n thing
+-- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
+-- specification:
+--
+-- atLength atLenPred atEndPred ls n
+-- | n < 0 = atLenPred n
+-- | length ls < n = atEndPred (n - length ls)
+-- | otherwise = atLenPred (drop n ls)
+--
+atLength :: ([a] -> b)
+ -> (Int -> b)
+ -> [a]
+ -> Int
+ -> b
+atLength atLenPred atEndPred ls n
+ | n < 0 = atEndPred n
+ | otherwise = go n ls
+ where
+ go n [] = atEndPred n
+ go 0 ls = atLenPred ls
+ go n (_:xs) = go (n-1) xs
+
+-- special cases.
lengthExceeds :: [a] -> Int -> Bool
--- (lengthExceeds xs n) is True if length xs > n
-(x:xs) `lengthExceeds` n = n < 1 || xs `lengthExceeds` (n - 1)
-[] `lengthExceeds` n = n < 0
+-- (lengthExceeds xs n) = (length xs > n)
+lengthExceeds = atLength notNull (const False)
+
+lengthAtLeast :: [a] -> Int -> Bool
+lengthAtLeast = atLength notNull (== 0)
+
+lengthIs :: [a] -> Int -> Bool
+lengthIs = atLength null (==0)
+
+listLengthCmp :: [a] -> Int -> Ordering
+listLengthCmp = atLength atLen atEnd
+ where
+ atEnd 0 = EQ
+ atEnd x
+ | x > 0 = LT -- not yet seen 'n' elts, so list length is < n.
+ | otherwise = GT
+
+ atLen [] = EQ
+ atLen _ = GT
isSingleton :: [a] -> Bool
isSingleton [x] = True
isSingleton _ = False
+notNull :: [a] -> Bool
+notNull [] = False
+notNull _ = True
+
+snocView :: [a] -> Maybe ([a],a)
+ -- Split off the last element
+snocView [] = Nothing
+snocView xs = go [] xs
+ where
+ -- Invariant: second arg is non-empty
+ go acc [x] = Just (reverse acc, x)
+ go acc (x:xs) = go (x:acc) xs
+
only :: [a] -> a
#ifdef DEBUG
only [a] = a
#endif
\end{code}
-\begin{code}
-snocView :: [a] -> ([a], a) -- Split off the last element
-snocView xs = go xs []
- where
- go [x] acc = (reverse acc, x)
- go (x:xs) acc = go xs (x:acc)
-\end{code}
-
Debugging/specialising versions of \tr{elem} and \tr{notElem}
\begin{code}
where
elem i _ [] = False
elem i x (y:ys)
- | i ># _ILIT 100 = panic ("Over-long elem in: " ++ msg)
- | otherwise = x == y || elem (i +# _ILIT(1)) x ys
+ | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $
+ x `List.elem` (y:ys)
+ | otherwise = x == y || elem (i +# _ILIT(1)) x ys
isn'tIn msg x ys
= notElem (_ILIT 0) x ys
where
notElem i x [] = True
notElem i x (y:ys)
- | i ># _ILIT 100 = panic ("Over-long notElem in: " ++ msg)
- | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys
-
+ | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $
+ x `List.notElem` (y:ys)
+ | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys
# endif {- DEBUG -}
-
\end{code}
%************************************************************************
is a {\em stable} sort.
\begin{code}
-stableSortLt = sortLt -- synonym; when we want to highlight stable-ness
-
sortLt :: (a -> a -> Bool) -- Less-than predicate
-> [a] -- Input list
-> [a] -- Result list
generalNaturalMergeSort p [] = []
generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
+#if NOT_USED
mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
mergeSort = generalMergeSort (<=)
naturalMergeSort = generalNaturalMergeSort (<=)
mergeSortLe le = generalMergeSort le
+#endif
+
naturalMergeSortLe le = generalNaturalMergeSort le
\end{code}
| otherwise = count p xs
\end{code}
+@splitAt@, @take@, and @drop@ but with length of another
+list giving the break-off point:
+
+\begin{code}
+takeList :: [b] -> [a] -> [a]
+takeList [] _ = []
+takeList (_:xs) ls =
+ case ls of
+ [] -> []
+ (y:ys) -> y : takeList xs ys
+
+dropList :: [b] -> [a] -> [a]
+dropList [] xs = xs
+dropList _ xs@[] = xs
+dropList (_:xs) (_:ys) = dropList xs ys
+
+
+splitAtList :: [b] -> [a] -> ([a], [a])
+splitAtList [] xs = ([], xs)
+splitAtList _ xs@[] = (xs, xs)
+splitAtList (_:xs) (y:ys) = (y:ys', ys'')
+ where
+ (ys', ys'') = splitAtList xs ys
+
+\end{code}
+
%************************************************************************
%* *
eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
eqListBy eq xs ys = False
+equalLength :: [a] -> [b] -> Bool
+equalLength [] [] = True
+equalLength (_:xs) (_:ys) = equalLength xs ys
+equalLength xs ys = False
+
+compareLength :: [a] -> [b] -> Ordering
+compareLength [] [] = EQ
+compareLength (_:xs) (_:ys) = compareLength xs ys
+compareLength [] _ys = LT
+compareLength _xs [] = GT
+
thenCmp :: Ordering -> Ordering -> Ordering
{-# INLINE thenCmp #-}
thenCmp EQ any = any
The following are curried versions of @fst@ and @snd@.
\begin{code}
+#if NOT_USED
cfst :: a -> b -> a -- stranal-sem only (Note)
cfst x y = x
+#endif
\end{code}
The following provide us higher order functions that, when applied
to a function, operate on pairs.
\begin{code}
+#if NOT_USED
applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
applyToPair (f,g) (x,y) = (f x, g y)
applyToSnd :: (b -> d) -> (a,b) -> (a,d)
applyToSnd f (x,y) = (x,f y)
+#endif
foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b)
foldPair fg ab [] = ab
global a = unsafePerformIO (newIORef a)
\end{code}
-Compatibility stuff:
+Module names:
\begin{code}
-#if __GLASGOW_HASKELL__ <= 408
-catchJust = catchIO
-ioErrors = justIoErrors
-throwTo = raiseInThread
-#endif
+looksLikeModuleName [] = False
+looksLikeModuleName (c:cs) = isUpper c && go cs
+ where go [] = True
+ go ('.':cs) = looksLikeModuleName cs
+ go (c:cs) = (isAlphaNum c || c == '_') && go cs
+\end{code}
+
+Akin to @Prelude.words@, but sensitive to dquoted entities treating
+them as single words.
+
+\begin{code}
+toArgs :: String -> [String]
+toArgs "" = []
+toArgs s =
+ case break (\ ch -> isSpace ch || ch == '"') (dropWhile isSpace s) of -- "
+ (w,aft) ->
+ (\ ws -> if null w then ws else w : ws) $
+ case aft of
+ [] -> []
+ (x:xs)
+ | x /= '"' -> toArgs xs
+ | otherwise ->
+ case lex aft of
+ ((str,rs):_) -> stripQuotes str : toArgs rs
+ _ -> [aft]
+ where
+ -- strip away dquotes; assume first and last chars contain quotes.
+ stripQuotes :: String -> String
+ stripQuotes ('"':xs) = init xs
+ stripQuotes xs = xs
\end{code}