Util.hs 45.4 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
-- (c) The University of Glasgow 2006
2

Ben Gamari's avatar
Ben Gamari committed
3 4 5 6 7 8 9 10 11
{-# LANGUAGE CPP #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE BangPatterns #-}
#if __GLASGOW_HASKELL__ < 800
-- For CallStack business
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE FlexibleContexts #-}
#endif
Ian Lynagh's avatar
Ian Lynagh committed
12

batterseapower's avatar
batterseapower committed
13
-- | Highly random utility functions
dterei's avatar
dterei committed
14
--
15
module Util (
batterseapower's avatar
batterseapower committed
16
        -- * Flags dependent on the compiler build
17
        ghciSupported, debugIsOn, ncgDebugIsOn,
18
        ghciTablesNextToCode,
19
        isWindowsHost, isDarwinHost,
sof's avatar
sof committed
20

batterseapower's avatar
batterseapower committed
21
        -- * General list processing
Ian Lynagh's avatar
Ian Lynagh committed
22
        zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
23
        zipLazy, stretchZipWith, zipWithAndUnzip,
dterei's avatar
dterei committed
24

25 26
        zipWithLazy, zipWith3Lazy,

27
        filterByList, filterByLists, partitionByList,
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
28

batterseapower's avatar
batterseapower committed
29
        unzipWith,
dterei's avatar
dterei committed
30

31
        mapFst, mapSnd, chkAppend,
32
        mapAndUnzip, mapAndUnzip3, mapAccumL2,
Ian Lynagh's avatar
Ian Lynagh committed
33
        nOfThem, filterOut, partitionWith, splitEithers,
dterei's avatar
dterei committed
34

35
        dropWhileEndLE, spanEnd,
36

batterseapower's avatar
batterseapower committed
37
        foldl1', foldl2, count, all2,
38

Ian Lynagh's avatar
Ian Lynagh committed
39
        lengthExceeds, lengthIs, lengthAtLeast,
40 41
        listLengthCmp, atLength,
        equalLength, compareLength, leLength,
Ian Lynagh's avatar
Ian Lynagh committed
42 43 44 45 46

        isSingleton, only, singleton,
        notNull, snocView,

        isIn, isn'tIn,
47

48 49
        chunkList,

50 51
        changeLast,

52
        -- * Tuples
53
        fstOf3, sndOf3, thdOf3,
batterseapower's avatar
batterseapower committed
54
        firstM, first3M,
55
        fst3, snd3, third3,
56
        uncurry3,
57
        liftFst, liftSnd,
58

batterseapower's avatar
batterseapower committed
59 60
        -- * List operations controlled by another list
        takeList, dropList, splitAtList, split,
61
        dropTail, capitalise,
batterseapower's avatar
batterseapower committed
62 63

        -- * For loop
Ian Lynagh's avatar
Ian Lynagh committed
64
        nTimes,
sof's avatar
sof committed
65

batterseapower's avatar
batterseapower committed
66
        -- * Sorting
67
        sortWith, minWith, nubSort,
68

batterseapower's avatar
batterseapower committed
69
        -- * Comparisons
70
        isEqual, eqListBy, eqMaybeBy,
71
        thenCmp, cmpList,
Ian Lynagh's avatar
Ian Lynagh committed
72
        removeSpaces,
73
        (<&&>), (<||>),
dterei's avatar
dterei committed
74

75
        -- * Edit distance
76
        fuzzyMatch, fuzzyLookup,
77

batterseapower's avatar
batterseapower committed
78 79
        -- * Transitive closures
        transitiveClosure,
80

batterseapower's avatar
batterseapower committed
81 82
        -- * Strictness
        seqList,
83

batterseapower's avatar
batterseapower committed
84
        -- * Module names
Ian Lynagh's avatar
Ian Lynagh committed
85
        looksLikeModuleName,
86
        looksLikePackageName,
87

batterseapower's avatar
batterseapower committed
88
        -- * Argument processing
Ian Lynagh's avatar
Ian Lynagh committed
89
        getCmd, toCmdArgs, toArgs,
90

91 92 93
        -- * Integers
        exactLog2,

batterseapower's avatar
batterseapower committed
94
        -- * Floating point
Ian Lynagh's avatar
Ian Lynagh committed
95
        readRational,
96

97
        -- * read helpers
98
        maybeRead, maybeReadFuzzy,
99

batterseapower's avatar
batterseapower committed
100
        -- * IO-ish utilities
Ian Lynagh's avatar
Ian Lynagh committed
101
        doesDirNameExist,
102
        getModificationUTCTime,
Ian Lynagh's avatar
Ian Lynagh committed
103
        modificationTimeIfExists,
104
        hSetTranslit,
105

106
        global, consIORef, globalM,
Moritz Angermann's avatar
Moritz Angermann committed
107
        sharedGlobal, sharedGlobalM,
batterseapower's avatar
batterseapower committed
108 109

        -- * Filenames and paths
Ian Lynagh's avatar
Ian Lynagh committed
110 111 112
        Suffix,
        splitLongestPrefix,
        escapeSpaces,
113
        Direction(..), reslash,
114
        makeRelativeTo,
115 116

        -- * Utils for defining Data instances
117 118 119
        abstractConstr, abstractDataType, mkNoRepType,

        -- * Utils for printing C code
120 121 122 123
        charToC,

        -- * Hashing
        hashString,
Ben Gamari's avatar
Ben Gamari committed
124 125

        -- * Call stacks
Yuras's avatar
Yuras committed
126
#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
Ben Gamari's avatar
Ben Gamari committed
127
        GHC.Stack.CallStack,
Yuras's avatar
Yuras committed
128
#endif
Ben Gamari's avatar
Ben Gamari committed
129 130 131
        HasCallStack,
        HasDebugCallStack,
        prettyCurrentCallStack,
Rufflewind's avatar
Rufflewind committed
132 133 134 135

        -- * Utils for flags
        OverridingBool(..),
        overrideWith,
136 137
    ) where

138 139
#include "HsVersions.h"

140
import Exception
141
import Panic
142

143
import Data.Data
144
import Data.IORef       ( IORef, newIORef, atomicModifyIORef' )
Ian Lynagh's avatar
Ian Lynagh committed
145
import System.IO.Unsafe ( unsafePerformIO )
146
import Data.List        hiding (group)
147

148
import GHC.Exts
Ben Gamari's avatar
Ben Gamari committed
149
import qualified GHC.Stack
sof's avatar
sof committed
150

151
import Control.Applicative ( liftA2 )
152
import Control.Monad    ( liftM )
153
import GHC.IO.Encoding (mkTextEncoding, textEncodingName)
Moritz Angermann's avatar
Moritz Angermann committed
154
import GHC.Conc.Sync ( sharedCAF )
155
import System.IO (Handle, hGetEncoding, hSetEncoding)
156
import System.IO.Error as IO ( isDoesNotExistError )
157
import System.Directory ( doesDirectoryExist, getModificationTime )
158
import System.FilePath
159

160
import Data.Char        ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper)
161
import Data.Int
Ian Lynagh's avatar
Ian Lynagh committed
162
import Data.Ratio       ( (%) )
163 164 165 166
import Data.Ord         ( comparing )
import Data.Bits
import Data.Word
import qualified Data.IntMap as IM
167
import qualified Data.Set as Set
168

169 170
import Data.Time

Ben Gamari's avatar
Ben Gamari committed
171
#if defined(DEBUG)
172 173 174
import {-# SOURCE #-} Outputable ( warnPprTrace, text )
#endif

175
infixr 9 `thenCmp`
176

Austin Seipp's avatar
Austin Seipp committed
177 178 179
{-
************************************************************************
*                                                                      *
180
\subsection{Is DEBUG on, are we on Windows, etc?}
Austin Seipp's avatar
Austin Seipp committed
181 182
*                                                                      *
************************************************************************
183

184 185 186 187 188 189 190 191
These booleans are global constants, set by CPP flags.  They allow us to
recompile a single module (this one) to change whether or not debug output
appears. They sometimes let us avoid even running CPP elsewhere.

It's important that the flags are literal constants (True/False). Then,
with -0, tests of the flags in other modules will simplify to the correct
branch of the conditional, thereby dropping debug code altogether when
the flags are off.
Austin Seipp's avatar
Austin Seipp committed
192
-}
193

194
ghciSupported :: Bool
Ben Gamari's avatar
Ben Gamari committed
195
#if defined(GHCI)
196 197 198 199 200
ghciSupported = True
#else
ghciSupported = False
#endif

201
debugIsOn :: Bool
Ben Gamari's avatar
Ben Gamari committed
202
#if defined(DEBUG)
203 204 205 206
debugIsOn = True
#else
debugIsOn = False
#endif
207

208
ncgDebugIsOn :: Bool
Ben Gamari's avatar
Ben Gamari committed
209
#if defined(NCG_DEBUG)
210 211 212 213 214
ncgDebugIsOn = True
#else
ncgDebugIsOn = False
#endif

Ian Lynagh's avatar
Ian Lynagh committed
215
ghciTablesNextToCode :: Bool
Ben Gamari's avatar
Ben Gamari committed
216
#if defined(GHCI_TABLES_NEXT_TO_CODE)
Ian Lynagh's avatar
Ian Lynagh committed
217 218 219 220 221
ghciTablesNextToCode = True
#else
ghciTablesNextToCode = False
#endif

222
isWindowsHost :: Bool
Ben Gamari's avatar
Ben Gamari committed
223
#if defined(mingw32_HOST_OS)
224 225 226 227
isWindowsHost = True
#else
isWindowsHost = False
#endif
Ian Lynagh's avatar
Ian Lynagh committed
228

229
isDarwinHost :: Bool
Ben Gamari's avatar
Ben Gamari committed
230
#if defined(darwin_HOST_OS)
231
isDarwinHost = True
Ian Lynagh's avatar
Ian Lynagh committed
232
#else
233
isDarwinHost = False
Ian Lynagh's avatar
Ian Lynagh committed
234
#endif
235

Austin Seipp's avatar
Austin Seipp committed
236 237 238
{-
************************************************************************
*                                                                      *
239
\subsection{A for loop}
Austin Seipp's avatar
Austin Seipp committed
240 241 242
*                                                                      *
************************************************************************
-}
243

batterseapower's avatar
batterseapower committed
244
-- | Compose a function with itself n times.  (nth rather than twice)
245 246 247 248 249
nTimes :: Int -> (a -> a) -> (a -> a)
nTimes 0 _ = id
nTimes 1 f = f
nTimes n f = f . nTimes (n-1) f

dterei's avatar
dterei committed
250 251
fstOf3   :: (a,b,c) -> a
sndOf3   :: (a,b,c) -> b
252
thdOf3   :: (a,b,c) -> c
253 254
fstOf3      (a,_,_) =  a
sndOf3      (_,b,_) =  b
255 256 257 258 259 260 261
thdOf3      (_,_,c) =  c

fst3 :: (a -> d) -> (a, b, c) -> (d, b, c)
fst3 f (a, b, c) = (f a, b, c)

snd3 :: (b -> d) -> (a, b, c) -> (a, d, c)
snd3 f (a, b, c) = (a, f b, c)
262

263 264 265
third3 :: (c -> d) -> (a, b, c) -> (a, b, d)
third3 f (a, b, c) = (a, b, f c)

266 267
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 f (a, b, c) = f a b c
268

269 270 271 272 273 274
liftFst :: (a -> b) -> (a, c) -> (b, c)
liftFst f (a,c) = (f a, c)

liftSnd :: (a -> b) -> (c, a) -> (c, b)
liftSnd f (c,a) = (c, f a)

batterseapower's avatar
batterseapower committed
275 276 277 278 279 280
firstM :: Monad m => (a -> m c) -> (a, b) -> m (c, b)
firstM f (x, y) = liftM (\x' -> (x', y)) (f x)

first3M :: Monad m => (a -> m d) -> (a, b, c) -> m (d, b, c)
first3M f (x, y, z) = liftM (\x' -> (x', y, z)) (f x)

Austin Seipp's avatar
Austin Seipp committed
281 282 283
{-
************************************************************************
*                                                                      *
284
\subsection[Utils-lists]{General list processing}
Austin Seipp's avatar
Austin Seipp committed
285 286 287
*                                                                      *
************************************************************************
-}
288

289
filterOut :: (a->Bool) -> [a] -> [a]
batterseapower's avatar
batterseapower committed
290
-- ^ Like filter, only it reverses the sense of the test
Ian Lynagh's avatar
Ian Lynagh committed
291
filterOut _ [] = []
292
filterOut p (x:xs) | p x       = filterOut p xs
Ian Lynagh's avatar
Ian Lynagh committed
293
                   | otherwise = x : filterOut p xs
294 295

partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
batterseapower's avatar
batterseapower committed
296
-- ^ Uses a function to determine which of two output lists an input element should join
Ian Lynagh's avatar
Ian Lynagh committed
297
partitionWith _ [] = ([],[])
298
partitionWith f (x:xs) = case f x of
Ian Lynagh's avatar
Ian Lynagh committed
299 300 301
                         Left  b -> (b:bs, cs)
                         Right c -> (bs, c:cs)
    where (bs,cs) = partitionWith f xs
302

303
splitEithers :: [Either a b] -> ([a], [b])
batterseapower's avatar
batterseapower committed
304
-- ^ Teases a list of 'Either's apart into two lists
305 306
splitEithers [] = ([],[])
splitEithers (e : es) = case e of
Ian Lynagh's avatar
Ian Lynagh committed
307 308 309
                        Left x -> (x:xs, ys)
                        Right y -> (xs, y:ys)
    where (xs,ys) = splitEithers es
310 311

chkAppend :: [a] -> [a] -> [a]
Gabor Greif's avatar
Gabor Greif committed
312
-- Checks for the second argument being empty
313
-- Used in situations where that situation is common
314
chkAppend xs ys
315 316
  | null ys   = xs
  | otherwise = xs ++ ys
317

Austin Seipp's avatar
Austin Seipp committed
318
{-
319 320 321
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?
Austin Seipp's avatar
Austin Seipp committed
322
-}
323

Ian Lynagh's avatar
Ian Lynagh committed
324 325 326 327
zipEqual        :: String -> [a] -> [b] -> [(a,b)]
zipWithEqual    :: String -> (a->b->c) -> [a]->[b]->[c]
zipWith3Equal   :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
zipWith4Equal   :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
328

Ben Gamari's avatar
Ben Gamari committed
329
#if !defined(DEBUG)
330 331 332 333
zipEqual      _ = zip
zipWithEqual  _ = zipWith
zipWith3Equal _ = zipWith3
zipWith4Equal _ = zipWith4
334
#else
335
zipEqual _   []     []     = []
336
zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
337
zipEqual msg _      _      = panic ("zipEqual: unequal lists:"++msg)
338 339

zipWithEqual msg z (a:as) (b:bs)=  z a b : zipWithEqual msg z as bs
340
zipWithEqual _   _ [] []        =  []
Ian Lynagh's avatar
Ian Lynagh committed
341
zipWithEqual msg _ _ _          =  panic ("zipWithEqual: unequal lists:"++msg)
342 343

zipWith3Equal msg z (a:as) (b:bs) (c:cs)
Ian Lynagh's avatar
Ian Lynagh committed
344
                                =  z a b c : zipWith3Equal msg z as bs cs
345
zipWith3Equal _   _ [] []  []   =  []
Ian Lynagh's avatar
Ian Lynagh committed
346
zipWith3Equal msg _ _  _   _    =  panic ("zipWith3Equal: unequal lists:"++msg)
347 348

zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
Ian Lynagh's avatar
Ian Lynagh committed
349
                                =  z a b c d : zipWith4Equal msg z as bs cs ds
350
zipWith4Equal _   _ [] [] [] [] =  []
Ian Lynagh's avatar
Ian Lynagh committed
351
zipWith4Equal msg _ _  _  _  _  =  panic ("zipWith4Equal: unequal lists:"++msg)
352 353
#endif

batterseapower's avatar
batterseapower committed
354
-- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~)
355
zipLazy :: [a] -> [b] -> [(a,b)]
Ian Lynagh's avatar
Ian Lynagh committed
356
zipLazy []     _       = []
Ian Lynagh's avatar
Ian Lynagh committed
357
zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
358

359 360 361 362 363 364 365 366 367 368 369 370 371 372
-- | 'zipWithLazy' is like 'zipWith' but is lazy in the second list.
-- The length of the output is always the same as the length of the first
-- list.
zipWithLazy :: (a -> b -> c) -> [a] -> [b] -> [c]
zipWithLazy _ []     _       = []
zipWithLazy f (a:as) ~(b:bs) = f a b : zipWithLazy f as bs

-- | 'zipWith3Lazy' is like 'zipWith3' but is lazy in the second and third lists.
-- The length of the output is always the same as the length of the first
-- list.
zipWith3Lazy :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3Lazy _ []     _       _       = []
zipWith3Lazy f (a:as) ~(b:bs) ~(c:cs) = f a b c : zipWith3Lazy f as bs cs

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
373 374 375 376 377 378 379 380 381
-- | 'filterByList' takes a list of Bools and a list of some elements and
-- filters out these elements for which the corresponding value in the list of
-- Bools is False. This function does not check whether the lists have equal
-- length.
filterByList :: [Bool] -> [a] -> [a]
filterByList (True:bs)  (x:xs) = x : filterByList bs xs
filterByList (False:bs) (_:xs) =     filterByList bs xs
filterByList _          _      = []

382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398
-- | 'filterByLists' takes a list of Bools and two lists as input, and
-- outputs a new list consisting of elements from the last two input lists. For
-- each Bool in the list, if it is 'True', then it takes an element from the
-- former list. If it is 'False', it takes an element from the latter list.
-- The elements taken correspond to the index of the Bool in its list.
-- For example:
--
-- @
-- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\"
-- @
--
-- This function does not check whether the lists have equal length.
filterByLists :: [Bool] -> [a] -> [a] -> [a]
filterByLists (True:bs)  (x:xs) (_:ys) = x : filterByLists bs xs ys
filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys
filterByLists _          _      _      = []

399 400 401 402 403 404 405 406 407 408 409 410 411
-- | 'partitionByList' takes a list of Bools and a list of some elements and
-- partitions the list according to the list of Bools. Elements corresponding
-- to 'True' go to the left; elements corresponding to 'False' go to the right.
-- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@
-- This function does not check whether the lists have equal
-- length.
partitionByList :: [Bool] -> [a] -> ([a], [a])
partitionByList = go [] []
  where
    go trues falses (True  : bs) (x : xs) = go (x:trues) falses bs xs
    go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs
    go trues falses _ _ = (reverse trues, reverse falses)

412
stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
batterseapower's avatar
batterseapower committed
413 414
-- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in
-- the places where @p@ returns @True@
415

Ian Lynagh's avatar
Ian Lynagh committed
416
stretchZipWith _ _ _ []     _ = []
417 418 419
stretchZipWith p z f (x:xs) ys
  | p x       = f x z : stretchZipWith p z f xs ys
  | otherwise = case ys of
Ian Lynagh's avatar
Ian Lynagh committed
420 421
                []     -> []
                (y:ys) -> f x y : stretchZipWith p z f xs ys
422

423 424 425 426 427 428
mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]

mapFst f xys = [(f x, y) | (x,y) <- xys]
mapSnd f xys = [(x, f y) | (x,y) <- xys]

429 430
mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])

Ian Lynagh's avatar
Ian Lynagh committed
431
mapAndUnzip _ [] = ([], [])
432
mapAndUnzip f (x:xs)
Ian Lynagh's avatar
Ian Lynagh committed
433 434
  = let (r1,  r2)  = f x
        (rs1, rs2) = mapAndUnzip f xs
435 436
    in
    (r1:rs1, r2:rs2)
437 438 439

mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])

Ian Lynagh's avatar
Ian Lynagh committed
440
mapAndUnzip3 _ [] = ([], [], [])
441
mapAndUnzip3 f (x:xs)
Ian Lynagh's avatar
Ian Lynagh committed
442 443
  = let (r1,  r2,  r3)  = f x
        (rs1, rs2, rs3) = mapAndUnzip3 f xs
444 445
    in
    (r1:rs1, r2:rs2, r3:rs3)
446

447 448 449 450 451 452 453 454
zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d])
zipWithAndUnzip f (a:as) (b:bs)
  = let (r1,  r2)  = f a b
        (rs1, rs2) = zipWithAndUnzip f as bs
    in
    (r1:rs1, r2:rs2)
zipWithAndUnzip _ _ _ = ([],[])

455 456 457 458 459
mapAccumL2 :: (s1 -> s2 -> a -> (s1, s2, b)) -> s1 -> s2 -> [a] -> (s1, s2, [b])
mapAccumL2 f s1 s2 xs = (s1', s2', ys)
  where ((s1', s2'), ys) = mapAccumL (\(s1, s2) x -> case f s1 s2 x of
                                                       (s1', s2', y) -> ((s1', s2'), y))
                                     (s1, s2) xs
460

461
nOfThem :: Int -> a -> [a]
sof's avatar
sof committed
462
nOfThem n thing = replicate n thing
463

batterseapower's avatar
batterseapower committed
464
-- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely:
sof's avatar
sof committed
465
--
batterseapower's avatar
batterseapower committed
466
-- @
sof's avatar
sof committed
467
--  atLength atLenPred atEndPred ls n
468
--   | n < 0         = atLenPred ls
sof's avatar
sof committed
469 470
--   | length ls < n = atEndPred (n - length ls)
--   | otherwise     = atLenPred (drop n ls)
batterseapower's avatar
batterseapower committed
471
-- @
472 473 474
atLength :: ([a] -> b)   -- Called when length ls >= n, passed (drop n ls)
                         --    NB: arg passed to this function may be []
         -> b            -- Called when length ls <  n
sof's avatar
sof committed
475 476 477
         -> [a]
         -> Int
         -> b
478 479 480
atLength atLenPred atEnd ls0 n0
  | n0 < 0    = atLenPred ls0
  | otherwise = go n0 ls0
sof's avatar
sof committed
481
  where
482 483 484
    -- go's first arg n >= 0
    go 0 ls     = atLenPred ls
    go _ []     = atEnd           -- n > 0 here
sof's avatar
sof committed
485 486
    go n (_:xs) = go (n-1) xs

batterseapower's avatar
batterseapower committed
487 488
-- Some special cases of atLength:

489
-- | @(lengthExceeds xs n) = (length xs > n)@
490
lengthExceeds :: [a] -> Int -> Bool
491 492 493 494 495
lengthExceeds lst n
  | n < 0
  = True
  | otherwise
  = atLength notNull False lst n
sof's avatar
sof committed
496 497

lengthAtLeast :: [a] -> Int -> Bool
498
lengthAtLeast = atLength (const True) False
sof's avatar
sof committed
499

500
-- | @(lengthIs xs n) = (length xs == n)@
sof's avatar
sof committed
501
lengthIs :: [a] -> Int -> Bool
502 503 504 505 506
lengthIs lst n
  | n < 0
  = False
  | otherwise
  = atLength null False lst n
sof's avatar
sof committed
507

Ian Lynagh's avatar
Ian Lynagh committed
508 509
listLengthCmp :: [a] -> Int -> Ordering
listLengthCmp = atLength atLen atEnd
sof's avatar
sof committed
510
 where
511
  atEnd = LT    -- Not yet seen 'n' elts, so list length is < n.
sof's avatar
sof committed
512 513 514

  atLen []     = EQ
  atLen _      = GT
515

516
equalLength :: [a] -> [b] -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
517
equalLength []     []     = True
518
equalLength (_:xs) (_:ys) = equalLength xs ys
Ian Lynagh's avatar
Ian Lynagh committed
519
equalLength _      _      = False
520 521

compareLength :: [a] -> [b] -> Ordering
Ian Lynagh's avatar
Ian Lynagh committed
522
compareLength []     []     = EQ
523
compareLength (_:xs) (_:ys) = compareLength xs ys
Ian Lynagh's avatar
Ian Lynagh committed
524 525
compareLength []     _      = LT
compareLength _      []     = GT
526

527 528 529 530 531 532 533
leLength :: [a] -> [b] -> Bool
-- ^ True if length xs <= length ys
leLength xs ys = case compareLength xs ys of
                   LT -> True
                   EQ -> True
                   GT -> False

534
----------------------------
535 536 537
singleton :: a -> [a]
singleton x = [x]

538
isSingleton :: [a] -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
539 540
isSingleton [_] = True
isSingleton _   = False
541

sof's avatar
sof committed
542 543 544 545
notNull :: [a] -> Bool
notNull [] = False
notNull _  = True

546
only :: [a] -> a
Ben Gamari's avatar
Ben Gamari committed
547
#if defined(DEBUG)
548 549 550 551
only [a] = a
#else
only (a:_) = a
#endif
Ian Lynagh's avatar
Ian Lynagh committed
552
only _ = panic "Util: only"
553

Austin Seipp's avatar
Austin Seipp committed
554
-- Debugging/specialising versions of \tr{elem} and \tr{notElem}
555

Ian Lynagh's avatar
Ian Lynagh committed
556
isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool
557 558

# ifndef DEBUG
559 560
isIn    _msg x ys = x `elem` ys
isn'tIn _msg x ys = x `notElem` ys
561

ross's avatar
ross committed
562
# else /* DEBUG */
563
isIn msg x ys
564
  = elem100 0 x ys
565
  where
566 567
    elem100 :: Eq a => Int -> a -> [a] -> Bool
    elem100 _ _ [] = False
568
    elem100 i x (y:ys)
569
      | i > 100 = WARN(True, text ("Over-long elem in " ++ msg)) (x `elem` (y:ys))
570
      | otherwise = x == y || elem100 (i + 1) x ys
571 572

isn'tIn msg x ys
573
  = notElem100 0 x ys
574
  where
575
    notElem100 :: Eq a => Int -> a -> [a] -> Bool
576 577
    notElem100 _ _ [] =  True
    notElem100 i x (y:ys)
578
      | i > 100 = WARN(True, text ("Over-long notElem in " ++ msg)) (x `notElem` (y:ys))
579
      | otherwise = x /= y && notElem100 (i + 1) x ys
ross's avatar
ross committed
580
# endif /* DEBUG */
581

582 583 584 585 586 587

-- | Split a list into chunks of /n/ elements
chunkList :: Int -> [a] -> [[a]]
chunkList _ [] = []
chunkList n xs = as : chunkList n bs where (as,bs) = splitAt n xs

588 589 590 591 592 593
-- | Replace the last element of a list with another element.
changeLast :: [a] -> a -> [a]
changeLast []     _  = panic "changeLast"
changeLast [_]    x  = [x]
changeLast (x:xs) x' = x : changeLast xs x'

Austin Seipp's avatar
Austin Seipp committed
594 595 596
{-
************************************************************************
*                                                                      *
Ian Lynagh's avatar
Ian Lynagh committed
597
\subsubsection{Sort utils}
Austin Seipp's avatar
Austin Seipp committed
598 599 600
*                                                                      *
************************************************************************
-}
601

602 603 604
minWith :: Ord b => (a -> b) -> [a] -> a
minWith get_key xs = ASSERT( not (null xs) )
                     head (sortWith get_key xs)
605 606 607

nubSort :: Ord a => [a] -> [a]
nubSort = Set.toAscList . Set.fromList
608

Austin Seipp's avatar
Austin Seipp committed
609 610 611
{-
************************************************************************
*                                                                      *
612
\subsection[Utils-transitive-closure]{Transitive closure}
Austin Seipp's avatar
Austin Seipp committed
613 614
*                                                                      *
************************************************************************
615 616

This algorithm for transitive closure is straightforward, albeit quadratic.
Austin Seipp's avatar
Austin Seipp committed
617
-}
618

Ian Lynagh's avatar
Ian Lynagh committed
619 620 621 622
transitiveClosure :: (a -> [a])         -- Successor function
                  -> (a -> a -> Bool)   -- Equality predicate
                  -> [a]
                  -> [a]                -- The transitive closure
623 624

transitiveClosure succ eq xs
625
 = go [] xs
626
 where
Ian Lynagh's avatar
Ian Lynagh committed
627
   go done []                      = done
628
   go done (x:xs) | x `is_in` done = go done xs
Ian Lynagh's avatar
Ian Lynagh committed
629
                  | otherwise      = go (x:done) (succ x ++ xs)
630

Ian Lynagh's avatar
Ian Lynagh committed
631
   _ `is_in` []                 = False
632
   x `is_in` (y:ys) | eq x y    = True
Ian Lynagh's avatar
Ian Lynagh committed
633
                    | otherwise = x `is_in` ys
634

Austin Seipp's avatar
Austin Seipp committed
635 636 637
{-
************************************************************************
*                                                                      *
638
\subsection[Utils-accum]{Accumulating}
Austin Seipp's avatar
Austin Seipp committed
639 640
*                                                                      *
************************************************************************
641

642
A combination of foldl with zip.  It works with equal length lists.
Austin Seipp's avatar
Austin Seipp committed
643
-}
644 645

foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
Ian Lynagh's avatar
Ian Lynagh committed
646
foldl2 _ z [] [] = z
647
foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
Ian Lynagh's avatar
Ian Lynagh committed
648
foldl2 _ _ _      _      = panic "Util: foldl2"
649 650

all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
651
-- True if the lists are the same length, and
652
-- all corresponding elements satisfy the predicate
Ian Lynagh's avatar
Ian Lynagh committed
653
all2 _ []     []     = True
654
all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
Ian Lynagh's avatar
Ian Lynagh committed
655
all2 _ _      _      = False
656

Austin Seipp's avatar
Austin Seipp committed
657
-- Count the number of times a predicate is true
658 659

count :: (a -> Bool) -> [a] -> Int
660 661 662 663
count p = go 0
  where go !n [] = n
        go !n (x:xs) | p x       = go (n+1) xs
                     | otherwise = go n xs
664

Austin Seipp's avatar
Austin Seipp committed
665
{-
sof's avatar
sof committed
666 667
@splitAt@, @take@, and @drop@ but with length of another
list giving the break-off point:
Austin Seipp's avatar
Austin Seipp committed
668
-}
sof's avatar
sof committed
669 670

takeList :: [b] -> [a] -> [a]
671 672
-- (takeList as bs) trims bs to the be same length
-- as as, unless as is longer in which case it's a no-op
sof's avatar
sof committed
673
takeList [] _ = []
Ian Lynagh's avatar
Ian Lynagh committed
674
takeList (_:xs) ls =
sof's avatar
sof committed
675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691
   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

692 693
-- drop from the end of a list
dropTail :: Int -> [a] -> [a]
694 695 696 697 698 699
-- Specification: dropTail n = reverse . drop n . reverse
-- Better implemention due to Joachim Breitner
-- http://www.joachim-breitner.de/blog/archives/600-On-taking-the-last-n-elements-of-a-list.html
dropTail n xs
  = go (drop n xs) xs
  where
700
    go (_:ys) (x:xs) = x : go ys xs
701 702
    go _      _      = []  -- Stop when ys runs out
                           -- It'll always run out before xs does
703

704 705 706 707 708 709 710 711 712 713 714 715
-- dropWhile from the end of a list. This is similar to Data.List.dropWhileEnd,
-- but is lazy in the elements and strict in the spine. For reasonably short lists,
-- such as path names and typical lines of text, dropWhileEndLE is generally
-- faster than dropWhileEnd. Its advantage is magnified when the predicate is
-- expensive--using dropWhileEndLE isSpace to strip the space off a line of text
-- is generally much faster than using dropWhileEnd isSpace for that purpose.
-- Specification: dropWhileEndLE p = reverse . dropWhile p . reverse
-- Pay attention to the short-circuit (&&)! The order of its arguments is the only
-- difference between dropWhileEnd and dropWhileEndLE.
dropWhileEndLE :: (a -> Bool) -> [a] -> [a]
dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) []

716 717 718 719 720 721 722 723 724 725 726
-- | @spanEnd p l == reverse (span p (reverse l))@. The first list
-- returns actually comes after the second list (when you look at the
-- input list).
spanEnd :: (a -> Bool) -> [a] -> ([a], [a])
spanEnd p l = go l [] [] l
  where go yes _rev_yes rev_no [] = (yes, reverse rev_no)
        go yes rev_yes  rev_no (x:xs)
          | p x       = go yes (x : rev_yes) rev_no                  xs
          | otherwise = go xs  []            (x : rev_yes ++ rev_no) xs


727
snocView :: [a] -> Maybe ([a],a)
Ian Lynagh's avatar
Ian Lynagh committed
728
        -- Split off the last element
729 730
snocView [] = Nothing
snocView xs = go [] xs
Ian Lynagh's avatar
Ian Lynagh committed
731 732 733 734 735
            where
                -- Invariant: second arg is non-empty
              go acc [x]    = Just (reverse acc, x)
              go acc (x:xs) = go (x:acc) xs
              go _   []     = panic "Util: snocView"
736

737 738
split :: Char -> String -> [String]
split c s = case rest of
Ian Lynagh's avatar
Ian Lynagh committed
739 740
                []     -> [chunk]
                _:rest -> chunk : split c rest
741
  where (chunk, rest) = break (==c) s
sof's avatar
sof committed
742

743 744 745 746 747 748
-- | Convert a word to title case by capitalising the first letter
capitalise :: String -> String
capitalise [] = []
capitalise (c:cs) = toUpper c : cs


Austin Seipp's avatar
Austin Seipp committed
749 750 751
{-
************************************************************************
*                                                                      *
752
\subsection[Utils-comparison]{Comparisons}
Austin Seipp's avatar
Austin Seipp committed
753 754 755
*                                                                      *
************************************************************************
-}
756

757 758 759 760 761 762 763 764
isEqual :: Ordering -> Bool
-- Often used in (isEqual (a `compare` b))
isEqual GT = False
isEqual EQ = True
isEqual LT = False

thenCmp :: Ordering -> Ordering -> Ordering
{-# INLINE thenCmp #-}
Ian Lynagh's avatar
Ian Lynagh committed
765 766
thenCmp EQ       ordering = ordering
thenCmp ordering _        = ordering
767

768
eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
769
eqListBy _  []     []     = True
770
eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
Ian Lynagh's avatar
Ian Lynagh committed
771
eqListBy _  _      _      = False
772

773 774 775 776 777
eqMaybeBy :: (a ->a->Bool) -> Maybe a -> Maybe a -> Bool
eqMaybeBy _  Nothing  Nothing  = True
eqMaybeBy eq (Just x) (Just y) = eq x y
eqMaybeBy _  _        _        = False

778
cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
779 780
    -- `cmpList' uses a user-specified comparer

Ian Lynagh's avatar
Ian Lynagh committed
781 782 783
cmpList _   []     [] = EQ
cmpList _   []     _  = LT
cmpList _   _      [] = GT
784
cmpList cmp (a:as) (b:bs)
785
  = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
786

787
removeSpaces :: String -> String
788
removeSpaces = dropWhileEndLE isSpace . dropWhile isSpace
789

790 791 792 793 794
-- Boolean operators lifted to Applicative
(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool
(<&&>) = liftA2 (&&)
infixr 3 <&&> -- same as (&&)

795 796 797 798
(<||>) :: Applicative f => f Bool -> f Bool -> f Bool
(<||>) = liftA2 (||)
infixr 2 <||> -- same as (||)

Austin Seipp's avatar
Austin Seipp committed
799 800 801
{-
************************************************************************
*                                                                      *
802
\subsection{Edit distance}
Austin Seipp's avatar
Austin Seipp committed
803 804 805
*                                                                      *
************************************************************************
-}
806

807 808 809 810 811 812
-- | Find the "restricted" Damerau-Levenshtein edit distance between two strings.
-- See: <http://en.wikipedia.org/wiki/Damerau-Levenshtein_distance>.
-- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing
-- Levenshtein and Damerau Edit Distances" in PSC'02 (Heikki Hyyro).
-- See http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and
--     http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for an explanation
813
restrictedDamerauLevenshteinDistance :: String -> String -> Int
814 815
restrictedDamerauLevenshteinDistance str1 str2
  = restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2
816 817 818 819
  where
    m = length str1
    n = length str2

820 821
restrictedDamerauLevenshteinDistanceWithLengths
  :: Int -> Int -> String -> String -> Int
822
restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2
823 824 825 826 827 828 829 830 831 832 833
  | m <= n
  = if n <= 32 -- n must be larger so this check is sufficient
    then restrictedDamerauLevenshteinDistance' (undefined :: Word32) m n str1 str2
    else restrictedDamerauLevenshteinDistance' (undefined :: Integer) m n str1 str2

  | otherwise
  = if m <= 32 -- m must be larger so this check is sufficient
    then restrictedDamerauLevenshteinDistance' (undefined :: Word32) n m str2 str1
    else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1

restrictedDamerauLevenshteinDistance'