zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
zipLazy, stretchZipWith,
mapAndUnzip, mapAndUnzip3,
- nOfThem, lengthExceeds, isSingleton, only,
+ 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,
transitiveClosure,
-- accumulating
- mapAccumL, mapAccumR, mapAccumB, foldl2, count,
+ mapAccumL, mapAccumR, mapAccumB,
+ foldl2, count,
+
+ takeList, dropList, splitAtList,
-- comparisons
- thenCmp, cmpList, prefixMatch, postfixMatch,
+ eqListBy, equalLength, compareLength,
+ thenCmp, cmpList, prefixMatch, suffixMatch,
-- strictness
- seqList, ($!),
+ foldl', seqList,
-- pairs
IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
unzipWith
- -- I/O
-#if __GLASGOW_HASKELL__ < 402
- , bracket
-#endif
-
, global
- , myGetProcessID
#if __GLASGOW_HASKELL__ <= 408
, catchJust
) where
+#include "../includes/config.h"
#include "HsVersions.h"
+import qualified List ( elem, notElem )
import List ( zipWith4 )
import Maybe ( Maybe(..) )
-import Panic ( panic )
+import Panic ( panic, trace )
import IOExts ( IORef, newIORef, unsafePerformIO )
import FastTypes
#if __GLASGOW_HASKELL__ <= 408
import Exception ( catchIO, justIoErrors, raiseInThread )
#endif
-#ifndef mingw32_TARGET_OS
-import Posix
-#endif
+
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
+
only :: [a] -> a
#ifdef DEBUG
only [a] = a
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}
%************************************************************************
(a'',b',ys) = mapAccumB f a' b xs
\end{code}
+A strict version of foldl.
+
+\begin{code}
+foldl' :: (a -> b -> a) -> a -> [b] -> a
+foldl' f z xs = lgo z xs
+ where
+ lgo z [] = z
+ lgo z (x:xs) = (lgo $! (f z x)) xs
+\end{code}
+
A combination of foldl with zip. It works with equal length lists.
\begin{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}
+
%************************************************************************
%* *
%************************************************************************
\begin{code}
+eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
+eqListBy eq [] [] = True
+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
prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss
| otherwise = False
-postfixMatch :: Eq a => [a] -> [a] -> Bool
-postfixMatch pat str = prefixMatch (reverse pat) (reverse str)
+suffixMatch :: Eq a => [a] -> [a] -> Bool
+suffixMatch pat str = prefixMatch (reverse pat) (reverse str)
\end{code}
%************************************************************************
\end{code}
\begin{code}
-#if __HASKELL1__ > 4
seqList :: [a] -> b -> b
-#else
-seqList :: (Eval a) => [a] -> b -> b
-#endif
seqList [] b = b
seqList (x:xs) b = x `seq` seqList xs b
-
-#if __HASKELL1__ <= 4
-($!) :: (Eval a) => (a -> b) -> a -> b
-f $! x = x `seq` f x
-#endif
-\end{code}
-
-\begin{code}
-#if __GLASGOW_HASKELL__ < 402
-bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
-bracket before after thing = do
- a <- before
- r <- (thing a) `catch` (\err -> after a >> fail err)
- after a
- return r
-#endif
\end{code}
Global variables:
ioErrors = justIoErrors
throwTo = raiseInThread
#endif
-
-#ifdef mingw32_TARGET_OS
-foreign import "_getpid" myGetProcessID :: IO Int
-#else
-myGetProcessID :: IO Int
-myGetProcessID = Posix.getProcessID
-#endif
\end{code}
projects / ghc-hetmet.git / blobdiff