%
-% (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,
+ nOfThem, filterOut,
lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength,
isSingleton, only,
- notNull,
+ notNull, snocView,
- 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)
+ sortLe,
-- transitive closures
transitiveClosure,
-- comparisons
eqListBy, equalLength, compareLength,
- thenCmp, cmpList, prefixMatch, suffixMatch,
+ thenCmp, cmpList, prefixMatch, suffixMatch, maybePrefixMatch,
-- strictness
foldl', seqList,
-- pairs
- IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
- IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
- unzipWith
+ unzipWith,
- , global
+ global,
-#if __GLASGOW_HASKELL__ <= 408
- , catchJust
- , ioErrors
- , throwTo
-#endif
+ -- module names
+ looksLikeModuleName,
+
+ toArgs,
+ -- Floating point stuff
+ readRational,
) where
-#include "../includes/config.h"
+#include "../includes/ghcconfig.h"
#include "HsVersions.h"
-import qualified List ( elem, notElem )
-import List ( zipWith4 )
-import Maybe ( Maybe(..) )
import Panic ( panic, trace )
-import IOExts ( IORef, newIORef, unsafePerformIO )
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, ord, isDigit )
+import Ratio ( (%) )
infixr 9 `thenCmp`
\end{code}
%************************************************************************
%* *
-\subsection{Maybe-ery}
+\subsection[Utils-lists]{General list processing}
%* *
%************************************************************************
\begin{code}
-unJust :: String -> Maybe a -> a
-unJust who (Just x) = x
-unJust who Nothing = panic ("unJust of Nothing, called by " ++ who)
+filterOut :: (a->Bool) -> [a] -> [a]
+-- Like filter, only reverses the sense of the test
+filterOut p [] = []
+filterOut p (x:xs) | p x = filterOut p xs
+ | otherwise = x : filterOut p xs
\end{code}
-%************************************************************************
-%* *
-\subsection[Utils-lists]{General list processing}
-%* *
-%************************************************************************
-
A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
are of equal length. Alastair Reid thinks this should only happen if
DEBUGging on; hey, why not?
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}
notElem__ x [] = True
notElem__ x (y:ys) = x /= y && notElem__ x ys
-# else {- DEBUG -}
+# else /* DEBUG */
isIn msg x ys
= elem (_ILIT 0) x ys
where
| 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}
-
-%************************************************************************
-%* *
-\subsection[Utils-sorting]{Sorting}
-%* *
-%************************************************************************
-
-%************************************************************************
-%* *
-\subsubsection[Utils-quicksorting]{Quicksorts}
-%* *
-%************************************************************************
-
-\begin{code}
-#if NOT_USED
-
--- tail-recursive, etc., "quicker sort" [as per Meira thesis]
-quicksort :: (a -> a -> Bool) -- Less-than predicate
- -> [a] -- Input list
- -> [a] -- Result list in increasing order
-
-quicksort lt [] = []
-quicksort lt [x] = [x]
-quicksort lt (x:xs) = split x [] [] xs
- where
- split x lo hi [] = quicksort lt lo ++ (x : quicksort lt hi)
- split x lo hi (y:ys) | y `lt` x = split x (y:lo) hi ys
- | True = split x lo (y:hi) ys
-#endif
-\end{code}
-
-Quicksort variant from Lennart's Haskell-library contribution. This
-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
-
-sortLt lt l = qsort lt l []
-
--- qsort is stable and does not concatenate.
-qsort :: (a -> a -> Bool) -- Less-than predicate
- -> [a] -- xs, Input list
- -> [a] -- r, Concatenate this list to the sorted input list
- -> [a] -- Result = sort xs ++ r
-
-qsort lt [] r = r
-qsort lt [x] r = x:r
-qsort lt (x:xs) r = qpart lt x xs [] [] r
-
--- qpart partitions and sorts the sublists
--- rlt contains things less than x,
--- rge contains the ones greater than or equal to x.
--- Both have equal elements reversed with respect to the original list.
-
-qpart lt x [] rlt rge r =
- -- rlt and rge are in reverse order and must be sorted with an
- -- anti-stable sorting
- rqsort lt rlt (x : rqsort lt rge r)
-
-qpart lt x (y:ys) rlt rge r =
- if lt y x then
- -- y < x
- qpart lt x ys (y:rlt) rge r
- else
- -- y >= x
- qpart lt x ys rlt (y:rge) r
-
--- rqsort is as qsort but anti-stable, i.e. reverses equal elements
-rqsort lt [] r = r
-rqsort lt [x] r = x:r
-rqsort lt (x:xs) r = rqpart lt x xs [] [] r
-
-rqpart lt x [] rle rgt r =
- qsort lt rle (x : qsort lt rgt r)
-
-rqpart lt x (y:ys) rle rgt r =
- if lt x y then
- -- y > x
- rqpart lt x ys rle (y:rgt) r
- else
- -- y <= x
- rqpart lt x ys (y:rle) rgt r
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[Utils-dull-mergesort]{A rather dull mergesort}
-%* *
-%************************************************************************
-
-\begin{code}
-#if NOT_USED
-mergesort :: (a -> a -> Ordering) -> [a] -> [a]
-
-mergesort cmp xs = merge_lists (split_into_runs [] xs)
- where
- a `le` b = case cmp a b of { LT -> True; EQ -> True; GT -> False }
- a `ge` b = case cmp a b of { LT -> False; EQ -> True; GT -> True }
-
- split_into_runs [] [] = []
- split_into_runs run [] = [run]
- split_into_runs [] (x:xs) = split_into_runs [x] xs
- split_into_runs [r] (x:xs) | x `ge` r = split_into_runs [r,x] xs
- split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs
- | True = rl : (split_into_runs [x] xs)
-
- merge_lists [] = []
- merge_lists (x:xs) = merge x (merge_lists xs)
-
- merge [] ys = ys
- merge xs [] = xs
- merge xl@(x:xs) yl@(y:ys)
- = case cmp x y of
- EQ -> x : y : (merge xs ys)
- LT -> x : (merge xs yl)
- GT -> y : (merge xl ys)
-#endif
+# endif /* DEBUG */
\end{code}
%************************************************************************
balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
balancedFold' f xs = xs
-generalMergeSort p [] = []
-generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
-
generalNaturalMergeSort p [] = []
generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
+#if NOT_USED
+generalMergeSort p [] = []
+generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
+
mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
mergeSort = generalMergeSort (<=)
naturalMergeSort = generalNaturalMergeSort (<=)
mergeSortLe le = generalMergeSort le
-naturalMergeSortLe le = generalNaturalMergeSort le
+#endif
+
+sortLe :: (a->a->Bool) -> [a] -> [a]
+sortLe le = generalNaturalMergeSort le
\end{code}
%************************************************************************
prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss
| otherwise = False
+maybePrefixMatch :: String -> String -> Maybe String
+maybePrefixMatch [] rest = Just rest
+maybePrefixMatch (_:_) [] = Nothing
+maybePrefixMatch (p:pat) (r:rest)
+ | p == r = maybePrefixMatch pat rest
+ | otherwise = Nothing
+
suffixMatch :: Eq a => [a] -> [a] -> Bool
suffixMatch pat str = prefixMatch (reverse pat) (reverse str)
\end{code}
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)
-
-foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b)
-foldPair fg ab [] = ab
-foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v)
- where (u,v) = foldPair fg ab abs
+#endif
\end{code}
\begin{code}
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}
+
+-- -----------------------------------------------------------------------------
+-- Floats
+
+\begin{code}
+readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
+readRational__ r = do
+ (n,d,s) <- readFix r
+ (k,t) <- readExp s
+ return ((n%1)*10^^(k-d), t)
+ where
+ readFix r = do
+ (ds,s) <- lexDecDigits r
+ (ds',t) <- lexDotDigits s
+ return (read (ds++ds'), length ds', t)
+
+ readExp (e:s) | e `elem` "eE" = readExp' s
+ readExp s = return (0,s)
+
+ readExp' ('+':s) = readDec s
+ readExp' ('-':s) = do
+ (k,t) <- readDec s
+ return (-k,t)
+ readExp' s = readDec s
+
+ readDec s = do
+ (ds,r) <- nonnull isDigit s
+ return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
+ r)
+
+ lexDecDigits = nonnull isDigit
+
+ lexDotDigits ('.':s) = return (span isDigit s)
+ lexDotDigits s = return ("",s)
+
+ nonnull p s = do (cs@(_:_),t) <- return (span p s)
+ return (cs,t)
+
+readRational :: String -> Rational -- NB: *does* handle a leading "-"
+readRational top_s
+ = case top_s of
+ '-' : xs -> - (read_me xs)
+ xs -> read_me xs
+ where
+ read_me s
+ = case (do { (x,"") <- readRational__ s ; return x }) of
+ [x] -> x
+ [] -> error ("readRational: no parse:" ++ top_s)
+ _ -> error ("readRational: ambiguous parse:" ++ top_s)
\end{code}