-- (c) The University of Glasgow 2006

{-# LANGUAGE CPP #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MagicHash #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-- | Highly random utility functions
--
module GHC.Utils.Misc (
        -- * Flags dependent on the compiler build
        ghciSupported, debugIsOn,
        isWindowsHost, isDarwinHost,

        -- * Miscellaneous higher-order functions
        applyWhen, nTimes,

        -- * General list processing
        zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
        zipLazy, stretchZipWith, zipWithAndUnzip, zipAndUnzip,

        zipWithLazy, zipWith3Lazy,

        filterByList, filterByLists, partitionByList,

        unzipWith,

        mapFst, mapSnd, chkAppend,
        mapAndUnzip, mapAndUnzip3,
        filterOut, partitionWith,

        dropWhileEndLE, spanEnd, last2, lastMaybe,

        List.foldl1', foldl2, count, countWhile, all2,

        lengthExceeds, lengthIs, lengthIsNot,
        lengthAtLeast, lengthAtMost, lengthLessThan,
        listLengthCmp, atLength,
        equalLength, compareLength, leLength, ltLength,

        isSingleton, only, expectOnly, GHC.Utils.Misc.singleton,
        notNull, snocView,

        isIn, isn'tIn,

        chunkList,

        changeLast,
        mapLastM,

        whenNonEmpty,

        mergeListsBy,
        isSortedBy,

        -- * Tuples
        fstOf3, sndOf3, thdOf3,
        firstM, first3M, secondM,
        fst3, snd3, third3,
        uncurry3,
        liftFst, liftSnd,

        -- * List operations controlled by another list
        takeList, dropList, splitAtList, split,
        dropTail, capitalise,

        -- * Sorting
        sortWith, minWith, nubSort, ordNub,

        -- * Comparisons
        isEqual, eqListBy, eqMaybeBy,
        thenCmp, cmpList,
        removeSpaces,
        (<&&>), (<||>),

        -- * Edit distance
        fuzzyMatch, fuzzyLookup,

        -- * Transitive closures
        transitiveClosure,

        -- * Strictness
        seqList, strictMap, strictZipWith,

        -- * Module names
        looksLikeModuleName,
        looksLikePackageName,

        -- * Argument processing
        getCmd, toCmdArgs, toArgs,

        -- * Integers
        exactLog2,

        -- * Floating point
        readRational,
        readSignificandExponentPair,
        readHexRational,
        readHexSignificandExponentPair,

        -- * IO-ish utilities
        doesDirNameExist,
        getModificationUTCTime,
        modificationTimeIfExists,
        withAtomicRename,

        -- * Filenames and paths
        Suffix,
        splitLongestPrefix,
        escapeSpaces,
        Direction(..), reslash,
        makeRelativeTo,

        -- * Utils for defining Data instances
        abstractConstr, abstractDataType, mkNoRepType,

        -- * Utils for printing C code
        charToC,

        -- * Hashing
        hashString,

        -- * Call stacks
        HasCallStack,
        HasDebugCallStack,

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

#include "HsVersions.h"

import GHC.Prelude

import GHC.Utils.Exception
import GHC.Utils.Panic.Plain

import Data.Data
import qualified Data.List as List
import Data.List.NonEmpty  ( NonEmpty(..) )

import GHC.Exts
import GHC.Stack (HasCallStack)

import Control.Applicative ( liftA2 )
import Control.Monad    ( liftM, guard )
import Control.Monad.IO.Class ( MonadIO, liftIO )
import System.IO.Error as IO ( isDoesNotExistError )
import System.Directory ( doesDirectoryExist, getModificationTime, renameFile )
import System.FilePath

import Data.Char        ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper
                        , isHexDigit, digitToInt )
import Data.Int
import Data.Ratio       ( (%) )
import Data.Ord         ( comparing )
import Data.Word
import qualified Data.IntMap as IM
import qualified Data.Set as Set

import Data.Time

#if defined(DEBUG)
import {-# SOURCE #-} GHC.Utils.Outputable ( text )
import {-# SOURCE #-} GHC.Driver.Ppr ( warnPprTrace )
#endif

infixr 9 `thenCmp`

{-
************************************************************************
*                                                                      *
\subsection{Is DEBUG on, are we on Windows, etc?}
*                                                                      *
************************************************************************

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.
-}

ghciSupported :: Bool
#if defined(HAVE_INTERNAL_INTERPRETER)
ghciSupported :: Bool
ghciSupported = Bool
True
#else
ghciSupported = False
#endif

debugIsOn :: Bool
#if defined(DEBUG)
debugIsOn = True
#else
debugIsOn :: Bool
debugIsOn = Bool
False
#endif

isWindowsHost :: Bool
#if defined(mingw32_HOST_OS)
isWindowsHost = True
#else
isWindowsHost :: Bool
isWindowsHost = Bool
False
#endif

isDarwinHost :: Bool
#if defined(darwin_HOST_OS)
isDarwinHost = True
#else
isDarwinHost :: Bool
isDarwinHost = Bool
False
#endif

{-
************************************************************************
*                                                                      *
\subsection{Miscellaneous higher-order functions}
*                                                                      *
************************************************************************
-}

-- | Apply a function iff some condition is met.
applyWhen :: Bool -> (a -> a) -> a -> a
applyWhen :: forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
True a -> a
f a
x = a -> a
f a
x
applyWhen Bool
_    a -> a
_ a
x = a
x

-- | Apply a function @n@ times to a given value.
nTimes :: Int -> (a -> a) -> (a -> a)
nTimes :: forall a. Int -> (a -> a) -> a -> a
nTimes Int
0 a -> a
_ = forall a. a -> a
id
nTimes Int
1 a -> a
f = a -> a
f
nTimes Int
n a -> a
f = a -> a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> (a -> a) -> a -> a
nTimes (Int
nforall a. Num a => a -> a -> a
-Int
1) a -> a
f

fstOf3   :: (a,b,c) -> a
sndOf3   :: (a,b,c) -> b
thdOf3   :: (a,b,c) -> c
fstOf3 :: forall a b c. (a, b, c) -> a
fstOf3      (a
a,b
_,c
_) =  a
a
sndOf3 :: forall a b c. (a, b, c) -> b
sndOf3      (a
_,b
b,c
_) =  b
b
thdOf3 :: forall a b c. (a, b, c) -> c
thdOf3      (a
_,b
_,c
c) =  c
c

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

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

third3 :: (c -> d) -> (a, b, c) -> (a, b, d)
third3 :: forall c d a b. (c -> d) -> (a, b, c) -> (a, b, d)
third3 c -> d
f (a
a, b
b, c
c) = (a
a, b
b, c -> d
f c
c)

uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 :: forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 a -> b -> c -> d
f (a
a, b
b, c
c) = a -> b -> c -> d
f a
a b
b c
c

liftFst :: (a -> b) -> (a, c) -> (b, c)
liftFst :: forall a b c. (a -> b) -> (a, c) -> (b, c)
liftFst a -> b
f (a
a,c
c) = (a -> b
f a
a, c
c)

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

firstM :: Monad m => (a -> m c) -> (a, b) -> m (c, b)
firstM :: forall (m :: * -> *) a c b.
Monad m =>
(a -> m c) -> (a, b) -> m (c, b)
firstM a -> m c
f (a
x, b
y) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\c
x' -> (c
x', b
y)) (a -> m c
f a
x)

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

secondM :: Monad m => (b -> m c) -> (a, b) -> m (a, c)
secondM :: forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a, b) -> m (a, c)
secondM b -> m c
f (a
x, b
y) = (a
x,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> m c
f b
y

{-
************************************************************************
*                                                                      *
\subsection[Utils-lists]{General list processing}
*                                                                      *
************************************************************************
-}

filterOut :: (a->Bool) -> [a] -> [a]
-- ^ Like filter, only it reverses the sense of the test
filterOut :: forall a. (a -> Bool) -> [a] -> [a]
filterOut a -> Bool
_ [] = []
filterOut a -> Bool
p (a
x:[a]
xs) | a -> Bool
p a
x       = forall a. (a -> Bool) -> [a] -> [a]
filterOut a -> Bool
p [a]
xs
                   | Bool
otherwise = a
x forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
filterOut a -> Bool
p [a]
xs

partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
-- ^ Uses a function to determine which of two output lists an input element should join
partitionWith :: forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith a -> Either b c
_ [] = ([],[])
partitionWith a -> Either b c
f (a
x:[a]
xs) = case a -> Either b c
f a
x of
                         Left  b
b -> (b
bforall a. a -> [a] -> [a]
:[b]
bs, [c]
cs)
                         Right c
c -> ([b]
bs, c
cforall a. a -> [a] -> [a]
:[c]
cs)
    where ([b]
bs,[c]
cs) = forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith a -> Either b c
f [a]
xs

chkAppend :: [a] -> [a] -> [a]
-- Checks for the second argument being empty
-- Used in situations where that situation is common
chkAppend :: forall a. [a] -> [a] -> [a]
chkAppend [a]
xs [a]
ys
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
ys   = [a]
xs
  | Bool
otherwise = [a]
xs forall a. [a] -> [a] -> [a]
++ [a]
ys

{-
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?
-}

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]

#if !defined(DEBUG)
zipEqual :: forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual      String
_ = forall a b. [a] -> [b] -> [(a, b)]
zip
zipWithEqual :: forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual  String
_ = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
zipWith3Equal :: forall a b c d.
String -> (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3Equal String
_ = forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3
zipWith4Equal :: forall a b c d e.
String
-> (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
zipWith4Equal String
_ = forall a b c d e.
(a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
List.zipWith4
#else
zipEqual _   []     []     = []
zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
zipEqual msg _      _      = panic ("zipEqual: unequal lists: "++msg)

zipWithEqual msg z (a:as) (b:bs)=  z a b : zipWithEqual msg z as bs
zipWithEqual _   _ [] []        =  []
zipWithEqual msg _ _ _          =  panic ("zipWithEqual: unequal lists: "++msg)

zipWith3Equal msg z (a:as) (b:bs) (c:cs)
                                =  z a b c : zipWith3Equal msg z as bs cs
zipWith3Equal _   _ [] []  []   =  []
zipWith3Equal msg _ _  _   _    =  panic ("zipWith3Equal: unequal lists: "++msg)

zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
                                =  z a b c d : zipWith4Equal msg z as bs cs ds
zipWith4Equal _   _ [] [] [] [] =  []
zipWith4Equal msg _ _  _  _  _  =  panic ("zipWith4Equal: unequal lists: "++msg)
#endif

-- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~)
zipLazy :: [a] -> [b] -> [(a,b)]
zipLazy :: forall a b. [a] -> [b] -> [(a, b)]
zipLazy []     [b]
_       = []
zipLazy (a
x:[a]
xs) ~(b
y:[b]
ys) = (a
x,b
y) forall a. a -> [a] -> [a]
: forall a b. [a] -> [b] -> [(a, b)]
zipLazy [a]
xs [b]
ys

-- | '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 :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWithLazy a -> b -> c
_ []     [b]
_       = []
zipWithLazy a -> b -> c
f (a
a:[a]
as) ~(b
b:[b]
bs) = a -> b -> c
f a
a b
b forall a. a -> [a] -> [a]
: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWithLazy a -> b -> c
f [a]
as [b]
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 :: forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3Lazy a -> b -> c -> d
_ []     [b]
_       [c]
_       = []
zipWith3Lazy a -> b -> c -> d
f (a
a:[a]
as) ~(b
b:[b]
bs) ~(c
c:[c]
cs) = a -> b -> c -> d
f a
a b
b c
c forall a. a -> [a] -> [a]
: forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3Lazy a -> b -> c -> d
f [a]
as [b]
bs [c]
cs

-- | '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 :: forall a. [Bool] -> [a] -> [a]
filterByList (Bool
True:[Bool]
bs)  (a
x:[a]
xs) = a
x forall a. a -> [a] -> [a]
: forall a. [Bool] -> [a] -> [a]
filterByList [Bool]
bs [a]
xs
filterByList (Bool
False:[Bool]
bs) (a
_:[a]
xs) =     forall a. [Bool] -> [a] -> [a]
filterByList [Bool]
bs [a]
xs
filterByList [Bool]
_          [a]
_      = []

-- | '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 :: forall a. [Bool] -> [a] -> [a] -> [a]
filterByLists (Bool
True:[Bool]
bs)  (a
x:[a]
xs) (a
_:[a]
ys) = a
x forall a. a -> [a] -> [a]
: forall a. [Bool] -> [a] -> [a] -> [a]
filterByLists [Bool]
bs [a]
xs [a]
ys
filterByLists (Bool
False:[Bool]
bs) (a
_:[a]
xs) (a
y:[a]
ys) = a
y forall a. a -> [a] -> [a]
: forall a. [Bool] -> [a] -> [a] -> [a]
filterByLists [Bool]
bs [a]
xs [a]
ys
filterByLists [Bool]
_          [a]
_      [a]
_      = []

-- | '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; when one list runs out, the function stops.
partitionByList :: [Bool] -> [a] -> ([a], [a])
partitionByList :: forall a. [Bool] -> [a] -> ([a], [a])
partitionByList = forall {a}. [a] -> [a] -> [Bool] -> [a] -> ([a], [a])
go [] []
  where
    go :: [a] -> [a] -> [Bool] -> [a] -> ([a], [a])
go [a]
trues [a]
falses (Bool
True  : [Bool]
bs) (a
x : [a]
xs) = [a] -> [a] -> [Bool] -> [a] -> ([a], [a])
go (a
xforall a. a -> [a] -> [a]
:[a]
trues) [a]
falses [Bool]
bs [a]
xs
    go [a]
trues [a]
falses (Bool
False : [Bool]
bs) (a
x : [a]
xs) = [a] -> [a] -> [Bool] -> [a] -> ([a], [a])
go [a]
trues (a
xforall a. a -> [a] -> [a]
:[a]
falses) [Bool]
bs [a]
xs
    go [a]
trues [a]
falses [Bool]
_ [a]
_ = (forall a. [a] -> [a]
reverse [a]
trues, forall a. [a] -> [a]
reverse [a]
falses)

stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
-- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in
-- the places where @p@ returns @True@

stretchZipWith :: forall a b c.
(a -> Bool) -> b -> (a -> b -> c) -> [a] -> [b] -> [c]
stretchZipWith a -> Bool
_ b
_ a -> b -> c
_ []     [b]
_ = []
stretchZipWith a -> Bool
p b
z a -> b -> c
f (a
x:[a]
xs) [b]
ys
  | a -> Bool
p a
x       = a -> b -> c
f a
x b
z forall a. a -> [a] -> [a]
: forall a b c.
(a -> Bool) -> b -> (a -> b -> c) -> [a] -> [b] -> [c]
stretchZipWith a -> Bool
p b
z a -> b -> c
f [a]
xs [b]
ys
  | Bool
otherwise = case [b]
ys of
                []     -> []
                (b
y:[b]
ys) -> a -> b -> c
f a
x b
y forall a. a -> [a] -> [a]
: forall a b c.
(a -> Bool) -> b -> (a -> b -> c) -> [a] -> [b] -> [c]
stretchZipWith a -> Bool
p b
z a -> b -> c
f [a]
xs [b]
ys

mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]

mapFst :: forall a c b. (a -> c) -> [(a, b)] -> [(c, b)]
mapFst a -> c
f [(a, b)]
xys = [(a -> c
f a
x, b
y) | (a
x,b
y) <- [(a, b)]
xys]
mapSnd :: forall b c a. (b -> c) -> [(a, b)] -> [(a, c)]
mapSnd b -> c
f [(a, b)]
xys = [(a
x, b -> c
f b
y) | (a
x,b
y) <- [(a, b)]
xys]

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

mapAndUnzip :: forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip a -> (b, c)
_ [] = ([], [])
mapAndUnzip a -> (b, c)
f (a
x:[a]
xs)
  = let (b
r1,  c
r2)  = a -> (b, c)
f a
x
        ([b]
rs1, [c]
rs2) = forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip a -> (b, c)
f [a]
xs
    in
    (b
r1forall a. a -> [a] -> [a]
:[b]
rs1, c
r2forall a. a -> [a] -> [a]
:[c]
rs2)

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

mapAndUnzip3 :: forall a b c d. (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
mapAndUnzip3 a -> (b, c, d)
_ [] = ([], [], [])
mapAndUnzip3 a -> (b, c, d)
f (a
x:[a]
xs)
  = let (b
r1,  c
r2,  d
r3)  = a -> (b, c, d)
f a
x
        ([b]
rs1, [c]
rs2, [d]
rs3) = forall a b c d. (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
mapAndUnzip3 a -> (b, c, d)
f [a]
xs
    in
    (b
r1forall a. a -> [a] -> [a]
:[b]
rs1, c
r2forall a. a -> [a] -> [a]
:[c]
rs2, d
r3forall a. a -> [a] -> [a]
:[d]
rs3)

zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d])
zipWithAndUnzip :: forall a b c d. (a -> b -> (c, d)) -> [a] -> [b] -> ([c], [d])
zipWithAndUnzip a -> b -> (c, d)
f (a
a:[a]
as) (b
b:[b]
bs)
  = let (c
r1,  d
r2)  = a -> b -> (c, d)
f a
a b
b
        ([c]
rs1, [d]
rs2) = forall a b c d. (a -> b -> (c, d)) -> [a] -> [b] -> ([c], [d])
zipWithAndUnzip a -> b -> (c, d)
f [a]
as [b]
bs
    in
    (c
r1forall a. a -> [a] -> [a]
:[c]
rs1, d
r2forall a. a -> [a] -> [a]
:[d]
rs2)
zipWithAndUnzip a -> b -> (c, d)
_ [a]
_ [b]
_ = ([],[])

-- | This has the effect of making the two lists have equal length by dropping
-- the tail of the longer one.
zipAndUnzip :: [a] -> [b] -> ([a],[b])
zipAndUnzip :: forall a b. [a] -> [b] -> ([a], [b])
zipAndUnzip (a
a:[a]
as) (b
b:[b]
bs)
  = let ([a]
rs1, [b]
rs2) = forall a b. [a] -> [b] -> ([a], [b])
zipAndUnzip [a]
as [b]
bs
    in
    (a
aforall a. a -> [a] -> [a]
:[a]
rs1, b
bforall a. a -> [a] -> [a]
:[b]
rs2)
zipAndUnzip [a]
_ [b]
_ = ([],[])

-- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely:
--
-- @
--  atLength atLenPred atEndPred ls n
--   | n < 0         = atLenPred ls
--   | length ls < n = atEndPred (n - length ls)
--   | otherwise     = atLenPred (drop n ls)
-- @
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
         -> [a]
         -> Int
         -> b
atLength :: forall a b. ([a] -> b) -> b -> [a] -> Int -> b
atLength [a] -> b
atLenPred b
atEnd [a]
ls0 Int
n0
  | Int
n0 forall a. Ord a => a -> a -> Bool
< Int
0    = [a] -> b
atLenPred [a]
ls0
  | Bool
otherwise = Int -> [a] -> b
go Int
n0 [a]
ls0
  where
    -- go's first arg n >= 0
    go :: Int -> [a] -> b
go Int
0 [a]
ls     = [a] -> b
atLenPred [a]
ls
    go Int
_ []     = b
atEnd           -- n > 0 here
    go Int
n (a
_:[a]
xs) = Int -> [a] -> b
go (Int
nforall a. Num a => a -> a -> a
-Int
1) [a]
xs

-- Some special cases of atLength:

-- | @(lengthExceeds xs n) = (length xs > n)@
lengthExceeds :: [a] -> Int -> Bool
lengthExceeds :: forall a. [a] -> Int -> Bool
lengthExceeds [a]
lst Int
n
  | Int
n forall a. Ord a => a -> a -> Bool
< Int
0
  = Bool
True
  | Bool
otherwise
  = forall a b. ([a] -> b) -> b -> [a] -> Int -> b
atLength forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull Bool
False [a]
lst Int
n

-- | @(lengthAtLeast xs n) = (length xs >= n)@
lengthAtLeast :: [a] -> Int -> Bool
lengthAtLeast :: forall a. [a] -> Int -> Bool
lengthAtLeast = forall a b. ([a] -> b) -> b -> [a] -> Int -> b
atLength (forall a b. a -> b -> a
const Bool
True) Bool
False

-- | @(lengthIs xs n) = (length xs == n)@
lengthIs :: [a] -> Int -> Bool
lengthIs :: forall a. [a] -> Int -> Bool
lengthIs [a]
lst Int
n
  | Int
n forall a. Ord a => a -> a -> Bool
< Int
0
  = Bool
False
  | Bool
otherwise
  = forall a b. ([a] -> b) -> b -> [a] -> Int -> b
atLength forall (t :: * -> *) a. Foldable t => t a -> Bool
null Bool
False [a]
lst Int
n

-- | @(lengthIsNot xs n) = (length xs /= n)@
lengthIsNot :: [a] -> Int -> Bool
lengthIsNot :: forall a. [a] -> Int -> Bool
lengthIsNot [a]
lst Int
n
  | Int
n forall a. Ord a => a -> a -> Bool
< Int
0 = Bool
True
  | Bool
otherwise = forall a b. ([a] -> b) -> b -> [a] -> Int -> b
atLength forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull Bool
True [a]
lst Int
n

-- | @(lengthAtMost xs n) = (length xs <= n)@
lengthAtMost :: [a] -> Int -> Bool
lengthAtMost :: forall a. [a] -> Int -> Bool
lengthAtMost [a]
lst Int
n
  | Int
n forall a. Ord a => a -> a -> Bool
< Int
0
  = Bool
False
  | Bool
otherwise
  = forall a b. ([a] -> b) -> b -> [a] -> Int -> b
atLength forall (t :: * -> *) a. Foldable t => t a -> Bool
null Bool
True [a]
lst Int
n

-- | @(lengthLessThan xs n) == (length xs < n)@
lengthLessThan :: [a] -> Int -> Bool
lengthLessThan :: forall a. [a] -> Int -> Bool
lengthLessThan = forall a b. ([a] -> b) -> b -> [a] -> Int -> b
atLength (forall a b. a -> b -> a
const Bool
False) Bool
True

listLengthCmp :: [a] -> Int -> Ordering
listLengthCmp :: forall a. [a] -> Int -> Ordering
listLengthCmp = forall a b. ([a] -> b) -> b -> [a] -> Int -> b
atLength forall {a}. [a] -> Ordering
atLen Ordering
atEnd
 where
  atEnd :: Ordering
atEnd = Ordering
LT    -- Not yet seen 'n' elts, so list length is < n.

  atLen :: [a] -> Ordering
atLen []     = Ordering
EQ
  atLen [a]
_      = Ordering
GT

equalLength :: [a] -> [b] -> Bool
-- ^ True if length xs == length ys
equalLength :: forall a b. [a] -> [b] -> Bool
equalLength []     []     = Bool
True
equalLength (a
_:[a]
xs) (b
_:[b]
ys) = forall a b. [a] -> [b] -> Bool
equalLength [a]
xs [b]
ys
equalLength [a]
_      [b]
_      = Bool
False

compareLength :: [a] -> [b] -> Ordering
compareLength :: forall a b. [a] -> [b] -> Ordering
compareLength []     []     = Ordering
EQ
compareLength (a
_:[a]
xs) (b
_:[b]
ys) = forall a b. [a] -> [b] -> Ordering
compareLength [a]
xs [b]
ys
compareLength []     [b]
_      = Ordering
LT
compareLength [a]
_      []     = Ordering
GT

leLength :: [a] -> [b] -> Bool
-- ^ True if length xs <= length ys
leLength :: forall a b. [a] -> [b] -> Bool
leLength [a]
xs [b]
ys = case forall a b. [a] -> [b] -> Ordering
compareLength [a]
xs [b]
ys of
                   Ordering
LT -> Bool
True
                   Ordering
EQ -> Bool
True
                   Ordering
GT -> Bool
False

ltLength :: [a] -> [b] -> Bool
-- ^ True if length xs < length ys
ltLength :: forall a b. [a] -> [b] -> Bool
ltLength [a]
xs [b]
ys = case forall a b. [a] -> [b] -> Ordering
compareLength [a]
xs [b]
ys of
                   Ordering
LT -> Bool
True
                   Ordering
EQ -> Bool
False
                   Ordering
GT -> Bool
False

----------------------------
singleton :: a -> [a]
singleton :: forall a. a -> [a]
singleton a
x = [a
x]

isSingleton :: [a] -> Bool
isSingleton :: forall a. [a] -> Bool
isSingleton [a
_] = Bool
True
isSingleton [a]
_   = Bool
False

notNull :: Foldable f => f a -> Bool
notNull :: forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null

only :: [a] -> a
#if defined(DEBUG)
only [a] = a
#else
only :: forall a. [a] -> a
only (a
a:[a]
_) = a
a
#endif
only [a]
_ = forall a. String -> a
panic String
"Util: only"

-- | Extract the single element of a list and panic with the given message if
-- there are more elements or the list was empty.
-- Like 'expectJust', but for lists.
expectOnly :: HasCallStack => String -> [a] -> a
{-# INLINE expectOnly #-}
#if defined(DEBUG)
expectOnly _   [a]   = a
#else
expectOnly :: forall a. HasCallStack => String -> [a] -> a
expectOnly String
_   (a
a:[a]
_) = a
a
#endif
expectOnly String
msg [a]
_     = forall a. String -> a
panic (String
"expectOnly: " forall a. [a] -> [a] -> [a]
++ String
msg)

-- Debugging/specialising versions of \tr{elem} and \tr{notElem}

# if !defined(DEBUG)
isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool
isIn :: forall a. Eq a => String -> a -> [a] -> Bool
isIn    String
_msg a
x [a]
ys = a
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
ys
isn'tIn :: forall a. Eq a => String -> a -> [a] -> Bool
isn'tIn String
_msg a
x [a]
ys = a
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [a]
ys

# else /* DEBUG */
isIn, isn'tIn :: (HasDebugCallStack, Eq a) => String -> a -> [a] -> Bool
isIn msg x ys
  = elem100 0 x ys
  where
    elem100 :: Eq a => Int -> a -> [a] -> Bool
    elem100 _ _ [] = False
    elem100 i x (y:ys)
      | i > 100 = WARN(True, text ("Over-long elem in " ++ msg)) (x `elem` (y:ys))
      | otherwise = x == y || elem100 (i + 1) x ys

isn'tIn msg x ys
  = notElem100 0 x ys
  where
    notElem100 :: Eq a => Int -> a -> [a] -> Bool
    notElem100 _ _ [] =  True
    notElem100 i x (y:ys)
      | i > 100 = WARN(True, text ("Over-long notElem in " ++ msg)) (x `notElem` (y:ys))
      | otherwise = x /= y && notElem100 (i + 1) x ys
# endif /* DEBUG */


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

-- | Replace the last element of a list with another element.
changeLast :: [a] -> a -> [a]
changeLast :: forall a. [a] -> a -> [a]
changeLast []     a
_  = forall a. String -> a
panic String
"changeLast"
changeLast [a
_]    a
x  = [a
x]
changeLast (a
x:[a]
xs) a
x' = a
x forall a. a -> [a] -> [a]
: forall a. [a] -> a -> [a]
changeLast [a]
xs a
x'

-- | Apply an effectful function to the last list element.
-- Assumes a non-empty list (panics otherwise).
mapLastM :: Functor f => (a -> f a) -> [a] -> f [a]
mapLastM :: forall (f :: * -> *) a. Functor f => (a -> f a) -> [a] -> f [a]
mapLastM a -> f a
_ [] = forall a. String -> a
panic String
"mapLastM: empty list"
mapLastM a -> f a
f [a
x] = (\a
x' -> [a
x']) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f a
f a
x
mapLastM a -> f a
f (a
x:[a]
xs) = (a
xforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Functor f => (a -> f a) -> [a] -> f [a]
mapLastM a -> f a
f [a]
xs

whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m ()
whenNonEmpty :: forall (m :: * -> *) a.
Applicative m =>
[a] -> (NonEmpty a -> m ()) -> m ()
whenNonEmpty []     NonEmpty a -> m ()
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
whenNonEmpty (a
x:[a]
xs) NonEmpty a -> m ()
f = NonEmpty a -> m ()
f (a
x forall a. a -> [a] -> NonEmpty a
:| [a]
xs)

-- | Merge an unsorted list of sorted lists, for example:
--
--  > mergeListsBy compare [ [2,5,15], [1,10,100] ] = [1,2,5,10,15,100]
--
--  \( O(n \log{} k) \)
mergeListsBy :: forall a. (a -> a -> Ordering) -> [[a]] -> [a]
mergeListsBy :: forall a. (a -> a -> Ordering) -> [[a]] -> [a]
mergeListsBy a -> a -> Ordering
cmp [[a]]
lists | Bool
debugIsOn, Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all [a] -> Bool
sorted [[a]]
lists) =
  -- When debugging is on, we check that the input lists are sorted.
  forall a. String -> a
panic String
"mergeListsBy: input lists must be sorted"
  where sorted :: [a] -> Bool
sorted = forall a. (a -> a -> Ordering) -> [a] -> Bool
isSortedBy a -> a -> Ordering
cmp
mergeListsBy a -> a -> Ordering
cmp [[a]]
all_lists = [[a]] -> [a]
merge_lists [[a]]
all_lists
  where
    -- Implements "Iterative 2-Way merge" described at
    -- https://en.wikipedia.org/wiki/K-way_merge_algorithm

    -- Merge two sorted lists into one in O(n).
    merge2 :: [a] -> [a] -> [a]
    merge2 :: [a] -> [a] -> [a]
merge2 [] [a]
ys = [a]
ys
    merge2 [a]
xs [] = [a]
xs
    merge2 (a
x:[a]
xs) (a
y:[a]
ys) =
      case a -> a -> Ordering
cmp a
x a
y of
        Ordering
GT -> a
y forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
merge2 (a
xforall a. a -> [a] -> [a]
:[a]
xs) [a]
ys
        Ordering
_  -> a
x forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
merge2 [a]
xs (a
yforall a. a -> [a] -> [a]
:[a]
ys)

    -- Merge the first list with the second, the third with the fourth, and so
    -- on. The output has half as much lists as the input.
    merge_neighbours :: [[a]] -> [[a]]
    merge_neighbours :: [[a]] -> [[a]]
merge_neighbours []   = []
    merge_neighbours [[a]
xs] = [[a]
xs]
    merge_neighbours ([a]
xs : [a]
ys : [[a]]
lists) =
      [a] -> [a] -> [a]
merge2 [a]
xs [a]
ys forall a. a -> [a] -> [a]
: [[a]] -> [[a]]
merge_neighbours [[a]]
lists

    -- Since 'merge_neighbours' halves the amount of lists in each iteration,
    -- we perform O(log k) iteration. Each iteration is O(n). The total running
    -- time is therefore O(n log k).
    merge_lists :: [[a]] -> [a]
    merge_lists :: [[a]] -> [a]
merge_lists [[a]]
lists =
      case [[a]] -> [[a]]
merge_neighbours [[a]]
lists of
        []     -> []
        [[a]
xs]   -> [a]
xs
        [[a]]
lists' -> [[a]] -> [a]
merge_lists [[a]]
lists'

isSortedBy :: (a -> a -> Ordering) -> [a] -> Bool
isSortedBy :: forall a. (a -> a -> Ordering) -> [a] -> Bool
isSortedBy a -> a -> Ordering
cmp = [a] -> Bool
sorted
  where
    sorted :: [a] -> Bool
sorted [] = Bool
True
    sorted [a
_] = Bool
True
    sorted (a
x:a
y:[a]
xs) = a -> a -> Ordering
cmp a
x a
y forall a. Eq a => a -> a -> Bool
/= Ordering
GT Bool -> Bool -> Bool
&& [a] -> Bool
sorted (a
yforall a. a -> [a] -> [a]
:[a]
xs)
{-
************************************************************************
*                                                                      *
\subsubsection{Sort utils}
*                                                                      *
************************************************************************
-}

minWith :: Ord b => (a -> b) -> [a] -> a
minWith :: forall b a. Ord b => (a -> b) -> [a] -> a
minWith a -> b
get_key [a]
xs = ASSERT( not (null xs) )
                     forall a. [a] -> a
head (forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith a -> b
get_key [a]
xs)

nubSort :: Ord a => [a] -> [a]
nubSort :: forall a. Ord a => [a] -> [a]
nubSort = forall a. Set a -> [a]
Set.toAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
Set.fromList

-- | Remove duplicates but keep elements in order.
--   O(n * log n)
ordNub :: Ord a => [a] -> [a]
ordNub :: forall a. Ord a => [a] -> [a]
ordNub [a]
xs
  = forall {a}. Ord a => Set a -> [a] -> [a]
go forall a. Set a
Set.empty [a]
xs
  where
    go :: Set a -> [a] -> [a]
go Set a
_ [] = []
    go Set a
s (a
x:[a]
xs)
      | forall a. Ord a => a -> Set a -> Bool
Set.member a
x Set a
s = Set a -> [a] -> [a]
go Set a
s [a]
xs
      | Bool
otherwise = a
x forall a. a -> [a] -> [a]
: Set a -> [a] -> [a]
go (forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
s) [a]
xs


{-
************************************************************************
*                                                                      *
\subsection[Utils-transitive-closure]{Transitive closure}
*                                                                      *
************************************************************************

This algorithm for transitive closure is straightforward, albeit quadratic.
-}

transitiveClosure :: (a -> [a])         -- Successor function
                  -> (a -> a -> Bool)   -- Equality predicate
                  -> [a]
                  -> [a]                -- The transitive closure

transitiveClosure :: forall a. (a -> [a]) -> (a -> a -> Bool) -> [a] -> [a]
transitiveClosure a -> [a]
succ a -> a -> Bool
eq [a]
xs
 = [a] -> [a] -> [a]
go [] [a]
xs
 where
   go :: [a] -> [a] -> [a]
go [a]
done []                      = [a]
done
   go [a]
done (a
x:[a]
xs) | a
x a -> [a] -> Bool
`is_in` [a]
done = [a] -> [a] -> [a]
go [a]
done [a]
xs
                  | Bool
otherwise      = [a] -> [a] -> [a]
go (a
xforall a. a -> [a] -> [a]
:[a]
done) (a -> [a]
succ a
x forall a. [a] -> [a] -> [a]
++ [a]
xs)

   a
_ is_in :: a -> [a] -> Bool
`is_in` []                 = Bool
False
   a
x `is_in` (a
y:[a]
ys) | a -> a -> Bool
eq a
x a
y    = Bool
True
                    | Bool
otherwise = a
x a -> [a] -> Bool
`is_in` [a]
ys

{-
************************************************************************
*                                                                      *
\subsection[Utils-accum]{Accumulating}
*                                                                      *
************************************************************************

A combination of foldl with zip.  It works with equal length lists.
-}

foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
foldl2 :: forall acc a b. (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
foldl2 acc -> a -> b -> acc
_ acc
z [] [] = acc
z
foldl2 acc -> a -> b -> acc
k acc
z (a
a:[a]
as) (b
b:[b]
bs) = forall acc a b. (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
foldl2 acc -> a -> b -> acc
k (acc -> a -> b -> acc
k acc
z a
a b
b) [a]
as [b]
bs
foldl2 acc -> a -> b -> acc
_ acc
_ [a]
_      [b]
_      = forall a. String -> a
panic String
"Util: foldl2"

all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
-- True if the lists are the same length, and
-- all corresponding elements satisfy the predicate
all2 :: forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
all2 a -> b -> Bool
_ []     []     = Bool
True
all2 a -> b -> Bool
p (a
x:[a]
xs) (b
y:[b]
ys) = a -> b -> Bool
p a
x b
y Bool -> Bool -> Bool
&& forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
all2 a -> b -> Bool
p [a]
xs [b]
ys
all2 a -> b -> Bool
_ [a]
_      [b]
_      = Bool
False

-- Count the number of times a predicate is true

count :: (a -> Bool) -> [a] -> Int
count :: forall a. (a -> Bool) -> [a] -> Int
count a -> Bool
p = Int -> [a] -> Int
go Int
0
  where go :: Int -> [a] -> Int
go !Int
n [] = Int
n
        go !Int
n (a
x:[a]
xs) | a -> Bool
p a
x       = Int -> [a] -> Int
go (Int
nforall a. Num a => a -> a -> a
+Int
1) [a]
xs
                     | Bool
otherwise = Int -> [a] -> Int
go Int
n [a]
xs

countWhile :: (a -> Bool) -> [a] -> Int
-- Length of an /initial prefix/ of the list satisfying p
countWhile :: forall a. (a -> Bool) -> [a] -> Int
countWhile a -> Bool
p = Int -> [a] -> Int
go Int
0
  where go :: Int -> [a] -> Int
go !Int
n (a
x:[a]
xs) | a -> Bool
p a
x = Int -> [a] -> Int
go (Int
nforall a. Num a => a -> a -> a
+Int
1) [a]
xs
        go !Int
n [a]
_            = Int
n

{-
@splitAt@, @take@, and @drop@ but with length of another
list giving the break-off point:
-}

takeList :: [b] -> [a] -> [a]
-- (takeList as bs) trims bs to the be same length
-- as as, unless as is longer in which case it's a no-op
takeList :: forall b a. [b] -> [a] -> [a]
takeList [] [a]
_ = []
takeList (b
_:[b]
xs) [a]
ls =
   case [a]
ls of
     [] -> []
     (a
y:[a]
ys) -> a
y forall a. a -> [a] -> [a]
: forall b a. [b] -> [a] -> [a]
takeList [b]
xs [a]
ys

dropList :: [b] -> [a] -> [a]
dropList :: forall b a. [b] -> [a] -> [a]
dropList [] [a]
xs    = [a]
xs
dropList [b]
_  xs :: [a]
xs@[] = [a]
xs
dropList (b
_:[b]
xs) (a
_:[a]
ys) = forall b a. [b] -> [a] -> [a]
dropList [b]
xs [a]
ys


-- | Given two lists xs and ys, return `splitAt (length xs) ys`.
splitAtList :: [b] -> [a] -> ([a], [a])
splitAtList :: forall b a. [b] -> [a] -> ([a], [a])
splitAtList [b]
xs [a]
ys = Int# -> [b] -> [a] -> ([a], [a])
go Int#
0# [b]
xs [a]
ys
   where
      -- we are careful to avoid allocating when there are no leftover
      -- arguments: in this case we can return "ys" directly (cf #18535)
      --
      -- We make `xs` strict because in the general case `ys` isn't `[]` so we
      -- will have to evaluate `xs` anyway.
      go :: Int# -> [b] -> [a] -> ([a], [a])
go Int#
_  ![b]
_     []     = ([a]
ys, [])             -- length ys <= length xs
      go Int#
n  []     [a]
bs     = (forall a. Int -> [a] -> [a]
take (Int# -> Int
I# Int#
n) [a]
ys, [a]
bs) -- = splitAt n ys
      go Int#
n  (b
_:[b]
as) (a
_:[a]
bs) = Int# -> [b] -> [a] -> ([a], [a])
go (Int#
n Int# -> Int# -> Int#
+# Int#
1#) [b]
as [a]
bs

-- drop from the end of a list
dropTail :: Int -> [a] -> [a]
-- Specification: dropTail n = reverse . drop n . reverse
-- Better implementation due to Joachim Breitner
-- http://www.joachim-breitner.de/blog/archives/600-On-taking-the-last-n-elements-of-a-list.html
dropTail :: forall a. Int -> [a] -> [a]
dropTail Int
n [a]
xs
  = forall b a. [b] -> [a] -> [a]
go (forall a. Int -> [a] -> [a]
drop Int
n [a]
xs) [a]
xs
  where
    go :: [a] -> [a] -> [a]
go (a
_:[a]
ys) (a
x:[a]
xs) = a
x forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
go [a]
ys [a]
xs
    go [a]
_      [a]
_      = []  -- Stop when ys runs out
                           -- It'll always run out before xs does

-- 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 :: forall a. (a -> Bool) -> [a] -> [a]
dropWhileEndLE a -> Bool
p = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x [a]
r -> if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
r Bool -> Bool -> Bool
&& a -> Bool
p a
x then [] else a
xforall a. a -> [a] -> [a]
:[a]
r) []

-- | @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 :: forall a. (a -> Bool) -> [a] -> ([a], [a])
spanEnd a -> Bool
p [a]
l = [a] -> [a] -> [a] -> [a] -> ([a], [a])
go [a]
l [] [] [a]
l
  where go :: [a] -> [a] -> [a] -> [a] -> ([a], [a])
go [a]
yes [a]
_rev_yes [a]
rev_no [] = ([a]
yes, forall a. [a] -> [a]
reverse [a]
rev_no)
        go [a]
yes [a]
rev_yes  [a]
rev_no (a
x:[a]
xs)
          | a -> Bool
p a
x       = [a] -> [a] -> [a] -> [a] -> ([a], [a])
go [a]
yes (a
x forall a. a -> [a] -> [a]
: [a]
rev_yes) [a]
rev_no                  [a]
xs
          | Bool
otherwise = [a] -> [a] -> [a] -> [a] -> ([a], [a])
go [a]
xs  []            (a
x forall a. a -> [a] -> [a]
: [a]
rev_yes forall a. [a] -> [a] -> [a]
++ [a]
rev_no) [a]
xs

-- | Get the last two elements in a list. Partial!
{-# INLINE last2 #-}
last2 :: [a] -> (a,a)
last2 :: forall a. [a] -> (a, a)
last2 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\(a
_,a
x2) a
x -> (a
x2,a
x)) (forall {a}. a
partialError,forall {a}. a
partialError)
  where
    partialError :: a
partialError = forall a. String -> a
panic String
"last2 - list length less than two"

lastMaybe :: [a] -> Maybe a
lastMaybe :: forall a. [a] -> Maybe a
lastMaybe [] = forall a. Maybe a
Nothing
lastMaybe [a]
xs = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [a]
xs

-- | Split a list into its last element and the initial part of the list.
-- @snocView xs = Just (init xs, last xs)@ for non-empty lists.
-- @snocView xs = Nothing@ otherwise.
-- Unless both parts of the result are guaranteed to be used
-- prefer separate calls to @last@ + @init@.
-- If you are guaranteed to use both, this will
-- be more efficient.
snocView :: [a] -> Maybe ([a],a)
snocView :: forall a. [a] -> Maybe ([a], a)
snocView [] = forall a. Maybe a
Nothing
snocView [a]
xs
    | ([a]
xs,a
x) <- forall a. [a] -> ([a], a)
go [a]
xs
    = forall a. a -> Maybe a
Just ([a]
xs,a
x)
  where
    go :: [a] -> ([a],a)
    go :: forall a. [a] -> ([a], a)
go [a
x] = ([],a
x)
    go (a
x:[a]
xs)
        | !([a]
xs',a
x') <- forall a. [a] -> ([a], a)
go [a]
xs
        = (a
xforall a. a -> [a] -> [a]
:[a]
xs', a
x')
    go [] = forall a. HasCallStack => String -> a
error String
"impossible"

split :: Char -> String -> [String]
split :: Char -> String -> [String]
split Char
c String
s = case String
rest of
                []     -> [String
chunk]
                Char
_:String
rest -> String
chunk forall a. a -> [a] -> [a]
: Char -> String -> [String]
split Char
c String
rest
  where (String
chunk, String
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
==Char
c) String
s

-- | Convert a word to title case by capitalising the first letter
capitalise :: String -> String
capitalise :: String -> String
capitalise [] = []
capitalise (Char
c:String
cs) = Char -> Char
toUpper Char
c forall a. a -> [a] -> [a]
: String
cs


{-
************************************************************************
*                                                                      *
\subsection[Utils-comparison]{Comparisons}
*                                                                      *
************************************************************************
-}

isEqual :: Ordering -> Bool
-- Often used in (isEqual (a `compare` b))
isEqual :: Ordering -> Bool
isEqual Ordering
GT = Bool
False
isEqual Ordering
EQ = Bool
True
isEqual Ordering
LT = Bool
False

thenCmp :: Ordering -> Ordering -> Ordering
{-# INLINE thenCmp #-}
thenCmp :: Ordering -> Ordering -> Ordering
thenCmp Ordering
EQ       Ordering
ordering = Ordering
ordering
thenCmp Ordering
ordering Ordering
_        = Ordering
ordering

eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
eqListBy :: forall a. (a -> a -> Bool) -> [a] -> [a] -> Bool
eqListBy a -> a -> Bool
_  []     []     = Bool
True
eqListBy a -> a -> Bool
eq (a
x:[a]
xs) (a
y:[a]
ys) = a -> a -> Bool
eq a
x a
y Bool -> Bool -> Bool
&& forall a. (a -> a -> Bool) -> [a] -> [a] -> Bool
eqListBy a -> a -> Bool
eq [a]
xs [a]
ys
eqListBy a -> a -> Bool
_  [a]
_      [a]
_      = Bool
False

eqMaybeBy :: (a ->a->Bool) -> Maybe a -> Maybe a -> Bool
eqMaybeBy :: forall a. (a -> a -> Bool) -> Maybe a -> Maybe a -> Bool
eqMaybeBy a -> a -> Bool
_  Maybe a
Nothing  Maybe a
Nothing  = Bool
True
eqMaybeBy a -> a -> Bool
eq (Just a
x) (Just a
y) = a -> a -> Bool
eq a
x a
y
eqMaybeBy a -> a -> Bool
_  Maybe a
_        Maybe a
_        = Bool
False

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

cmpList :: forall a. (a -> a -> Ordering) -> [a] -> [a] -> Ordering
cmpList a -> a -> Ordering
_   []     [] = Ordering
EQ
cmpList a -> a -> Ordering
_   []     [a]
_  = Ordering
LT
cmpList a -> a -> Ordering
_   [a]
_      [] = Ordering
GT
cmpList a -> a -> Ordering
cmp (a
a:[a]
as) (a
b:[a]
bs)
  = case a -> a -> Ordering
cmp a
a a
b of { Ordering
EQ -> forall a. (a -> a -> Ordering) -> [a] -> [a] -> Ordering
cmpList a -> a -> Ordering
cmp [a]
as [a]
bs; Ordering
xxx -> Ordering
xxx }

removeSpaces :: String -> String
removeSpaces :: String -> String
removeSpaces = forall a. (a -> Bool) -> [a] -> [a]
dropWhileEndLE Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace

-- Boolean operators lifted to Applicative
(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool
<&&> :: forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
(<&&>) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(&&)
infixr 3 <&&> -- same as (&&)

(<||>) :: Applicative f => f Bool -> f Bool -> f Bool
<||> :: forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
(<||>) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(||)
infixr 2 <||> -- same as (||)

{-
************************************************************************
*                                                                      *
\subsection{Edit distance}
*                                                                      *
************************************************************************
-}

-- | 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
restrictedDamerauLevenshteinDistance :: String -> String -> Int
restrictedDamerauLevenshteinDistance :: String -> String -> Int
restrictedDamerauLevenshteinDistance String
str1 String
str2
  = Int -> Int -> String -> String -> Int
restrictedDamerauLevenshteinDistanceWithLengths Int
m Int
n String
str1 String
str2
  where
    m :: Int
m = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str1
    n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str2

restrictedDamerauLevenshteinDistanceWithLengths
  :: Int -> Int -> String -> String -> Int
restrictedDamerauLevenshteinDistanceWithLengths :: Int -> Int -> String -> String -> Int
restrictedDamerauLevenshteinDistanceWithLengths Int
m Int
n String
str1 String
str2
  | Int
m forall a. Ord a => a -> a -> Bool
<= Int
n
  = if Int
n forall a. Ord a => a -> a -> Bool
<= Int
32 -- n must be larger so this check is sufficient
    then forall bv.
(Bits bv, Num bv) =>
bv -> Int -> Int -> String -> String -> Int
restrictedDamerauLevenshteinDistance' (forall a. HasCallStack => a
undefined :: Word32) Int
m Int
n String
str1 String
str2
    else forall bv.
(Bits bv, Num bv) =>
bv -> Int -> Int -> String -> String -> Int
restrictedDamerauLevenshteinDistance' (forall a. HasCallStack => a
undefined :: Integer) Int
m Int
n String
str1 String
str2

  | Bool
otherwise
  = if Int
m forall a. Ord a => a -> a -> Bool
<= Int
32 -- m must be larger so this check is sufficient
    then forall bv.
(Bits bv, Num bv) =>
bv -> Int -> Int -> String -> String -> Int
restrictedDamerauLevenshteinDistance' (forall a. HasCallStack => a
undefined :: Word32) Int
n Int
m String
str2 String
str1
    else forall bv.
(Bits bv, Num bv) =>
bv -> Int -> Int -> String -> String -> Int
restrictedDamerauLevenshteinDistance' (forall a. HasCallStack => a
undefined :: Integer) Int
n Int
m String
str2 String
str1

restrictedDamerauLevenshteinDistance'
  :: (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int
restrictedDamerauLevenshteinDistance' :: forall bv.
(Bits bv, Num bv) =>
bv -> Int -> Int -> String -> String -> Int
restrictedDamerauLevenshteinDistance' bv
_bv_dummy Int
m Int
n String
str1 String
str2
  | [] <- String
str1 = Int
n
  | Bool
otherwise  = forall {a} {b} {c} {d} {e}. (a, b, c, d, e) -> e
extractAnswer forall a b. (a -> b) -> a -> b
$
                 forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (forall bv.
(Bits bv, Num bv) =>
IntMap bv
-> bv
-> bv
-> (bv, bv, bv, bv, Int)
-> Char
-> (bv, bv, bv, bv, Int)
restrictedDamerauLevenshteinDistanceWorker
                             (forall bv. (Bits bv, Num bv) => String -> IntMap bv
matchVectors String
str1) bv
top_bit_mask bv
vector_mask)
                        (bv
0, bv
0, bv
m_ones, bv
0, Int
m) String
str2
  where
    m_ones :: bv
m_ones@bv
vector_mask = (bv
2 forall a b. (Num a, Integral b) => a -> b -> a
^ Int
m) forall a. Num a => a -> a -> a
- bv
1
    top_bit_mask :: bv
top_bit_mask = (bv
1 forall a. Bits a => a -> Int -> a
`shiftL` (Int
m forall a. Num a => a -> a -> a
- Int
1)) forall a. a -> a -> a
`asTypeOf` bv
_bv_dummy
    extractAnswer :: (a, b, c, d, e) -> e
extractAnswer (a
_, b
_, c
_, d
_, e
distance) = e
distance

restrictedDamerauLevenshteinDistanceWorker
      :: (Bits bv, Num bv) => IM.IntMap bv -> bv -> bv
      -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int)
restrictedDamerauLevenshteinDistanceWorker :: forall bv.
(Bits bv, Num bv) =>
IntMap bv
-> bv
-> bv
-> (bv, bv, bv, bv, Int)
-> Char
-> (bv, bv, bv, bv, Int)
restrictedDamerauLevenshteinDistanceWorker IntMap bv
str1_mvs bv
top_bit_mask bv
vector_mask
                                           (bv
pm, bv
d0, bv
vp, bv
vn, Int
distance) Char
char2
  = seq :: forall a b. a -> b -> b
seq IntMap bv
str1_mvs forall a b. (a -> b) -> a -> b
$ seq :: forall a b. a -> b -> b
seq bv
top_bit_mask forall a b. (a -> b) -> a -> b
$ seq :: forall a b. a -> b -> b
seq bv
vector_mask forall a b. (a -> b) -> a -> b
$
    seq :: forall a b. a -> b -> b
seq bv
pm' forall a b. (a -> b) -> a -> b
$ seq :: forall a b. a -> b -> b
seq bv
d0' forall a b. (a -> b) -> a -> b
$ seq :: forall a b. a -> b -> b
seq bv
vp' forall a b. (a -> b) -> a -> b
$ seq :: forall a b. a -> b -> b
seq bv
vn' forall a b. (a -> b) -> a -> b
$
    seq :: forall a b. a -> b -> b
seq Int
distance'' forall a b. (a -> b) -> a -> b
$ seq :: forall a b. a -> b -> b
seq Char
char2 forall a b. (a -> b) -> a -> b
$
    (bv
pm', bv
d0', bv
vp', bv
vn', Int
distance'')
  where
    pm' :: bv
pm' = forall a. a -> Int -> IntMap a -> a
IM.findWithDefault bv
0 (Char -> Int
ord Char
char2) IntMap bv
str1_mvs

    d0' :: bv
d0' = ((((forall bv. Bits bv => bv -> bv -> bv
sizedComplement bv
vector_mask bv
d0) forall bv. Bits bv => bv -> bv -> bv
.&. bv
pm') forall a. Bits a => a -> Int -> a
`shiftL` Int
1) forall bv. Bits bv => bv -> bv -> bv
.&. bv
pm)
      forall bv. Bits bv => bv -> bv -> bv
.|. ((((bv
pm' forall bv. Bits bv => bv -> bv -> bv
.&. bv
vp) forall a. Num a => a -> a -> a
+ bv
vp) forall bv. Bits bv => bv -> bv -> bv
.&. bv
vector_mask) forall bv. Bits bv => bv -> bv -> bv
`xor` bv
vp) forall bv. Bits bv => bv -> bv -> bv
.|. bv
pm' forall bv. Bits bv => bv -> bv -> bv
.|. bv
vn
          -- No need to mask the shiftL because of the restricted range of pm

    hp' :: bv
hp' = bv
vn forall bv. Bits bv => bv -> bv -> bv
.|. forall bv. Bits bv => bv -> bv -> bv
sizedComplement bv
vector_mask (bv
d0' forall bv. Bits bv => bv -> bv -> bv
.|. bv
vp)
    hn' :: bv
hn' = bv
d0' forall bv. Bits bv => bv -> bv -> bv
.&. bv
vp

    hp'_shift :: bv
hp'_shift = ((bv
hp' forall a. Bits a => a -> Int -> a
`shiftL` Int
1) forall bv. Bits bv => bv -> bv -> bv
.|. bv
1) forall bv. Bits bv => bv -> bv -> bv
.&. bv
vector_mask
    hn'_shift :: bv
hn'_shift = (bv
hn' forall a. Bits a => a -> Int -> a
`shiftL` Int
1) forall bv. Bits bv => bv -> bv -> bv
.&. bv
vector_mask
    vp' :: bv
vp' = bv
hn'_shift forall bv. Bits bv => bv -> bv -> bv
.|. forall bv. Bits bv => bv -> bv -> bv
sizedComplement bv
vector_mask (bv
d0' forall bv. Bits bv => bv -> bv -> bv
.|. bv
hp'_shift)
    vn' :: bv
vn' = bv
d0' forall bv. Bits bv => bv -> bv -> bv
.&. bv
hp'_shift

    distance' :: Int
distance' = if bv
hp' forall bv. Bits bv => bv -> bv -> bv
.&. bv
top_bit_mask forall a. Eq a => a -> a -> Bool
/= bv
0 then Int
distance forall a. Num a => a -> a -> a
+ Int
1 else Int
distance
    distance'' :: Int
distance'' = if bv
hn' forall bv. Bits bv => bv -> bv -> bv
.&. bv
top_bit_mask forall a. Eq a => a -> a -> Bool
/= bv
0 then Int
distance' forall a. Num a => a -> a -> a
- Int
1 else Int
distance'

sizedComplement :: Bits bv => bv -> bv -> bv
sizedComplement :: forall bv. Bits bv => bv -> bv -> bv
sizedComplement bv
vector_mask bv
vect = bv
vector_mask forall bv. Bits bv => bv -> bv -> bv
`xor` bv
vect

matchVectors :: (Bits bv, Num bv) => String -> IM.IntMap bv
matchVectors :: forall bv. (Bits bv, Num bv) => String -> IntMap bv
matchVectors = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' forall {a} {a}.
(Bits a, Integral a, Num a) =>
(a, IntMap a) -> Char -> (a, IntMap a)
go (Int
0 :: Int, forall a. IntMap a
IM.empty)
  where
    go :: (a, IntMap a) -> Char -> (a, IntMap a)
go (a
ix, IntMap a
im) Char
char = let ix' :: a
ix' = a
ix forall a. Num a => a -> a -> a
+ a
1
                           im' :: IntMap a
im' = forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith forall bv. Bits bv => bv -> bv -> bv
(.|.) (Char -> Int
ord Char
char) (a
2 forall a b. (Num a, Integral b) => a -> b -> a
^ a
ix) IntMap a
im
                       in seq :: forall a b. a -> b -> b
seq a
ix' forall a b. (a -> b) -> a -> b
$ seq :: forall a b. a -> b -> b
seq IntMap a
im' forall a b. (a -> b) -> a -> b
$ (a
ix', IntMap a
im')

{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance'
                      :: Word32 -> Int -> Int -> String -> String -> Int #-}
{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance'
                      :: Integer -> Int -> Int -> String -> String -> Int #-}

{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker
               :: IM.IntMap Word32 -> Word32 -> Word32
               -> (Word32, Word32, Word32, Word32, Int)
               -> Char -> (Word32, Word32, Word32, Word32, Int) #-}
{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker
               :: IM.IntMap Integer -> Integer -> Integer
               -> (Integer, Integer, Integer, Integer, Int)
               -> Char -> (Integer, Integer, Integer, Integer, Int) #-}

{-# SPECIALIZE INLINE sizedComplement :: Word32 -> Word32 -> Word32 #-}
{-# SPECIALIZE INLINE sizedComplement :: Integer -> Integer -> Integer #-}

{-# SPECIALIZE matchVectors :: String -> IM.IntMap Word32 #-}
{-# SPECIALIZE matchVectors :: String -> IM.IntMap Integer #-}

fuzzyMatch :: String -> [String] -> [String]
fuzzyMatch :: String -> [String] -> [String]
fuzzyMatch String
key [String]
vals = forall a. String -> [(String, a)] -> [a]
fuzzyLookup String
key [(String
v,String
v) | String
v <- [String]
vals]

-- | Search for possible matches to the users input in the given list,
-- returning a small number of ranked results
fuzzyLookup :: String -> [(String,a)] -> [a]
fuzzyLookup :: forall a. String -> [(String, a)] -> [a]
fuzzyLookup String
user_entered [(String, a)]
possibilites
  = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
mAX_RESULTS forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> b
snd)
    [ (a
poss_val, Int
distance) | (String
poss_str, a
poss_val) <- [(String, a)]
possibilites
                       , let distance :: Int
distance = String -> String -> Int
restrictedDamerauLevenshteinDistance
                                            String
poss_str String
user_entered
                       , Int
distance forall a. Ord a => a -> a -> Bool
<= Int
fuzzy_threshold ]
  where
    -- Work out an appropriate match threshold:
    -- We report a candidate if its edit distance is <= the threshold,
    -- The threshold is set to about a quarter of the # of characters the user entered
    --   Length    Threshold
    --     1         0          -- Don't suggest *any* candidates
    --     2         1          -- for single-char identifiers
    --     3         1
    --     4         1
    --     5         1
    --     6         2
    --
    fuzzy_threshold :: Int
fuzzy_threshold = forall a b. (RealFrac a, Integral b) => a -> b
truncate forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
user_entered forall a. Num a => a -> a -> a
+ Int
2) forall a. Fractional a => a -> a -> a
/ (Rational
4 :: Rational)
    mAX_RESULTS :: Int
mAX_RESULTS = Int
3

{-
************************************************************************
*                                                                      *
\subsection[Utils-pairs]{Pairs}
*                                                                      *
************************************************************************
-}

unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
unzipWith :: forall a b c. (a -> b -> c) -> [(a, b)] -> [c]
unzipWith a -> b -> c
f [(a, b)]
pairs = forall a b. (a -> b) -> [a] -> [b]
map ( \ (a
a, b
b) -> a -> b -> c
f a
a b
b ) [(a, b)]
pairs

seqList :: [a] -> b -> b
seqList :: forall a b. [a] -> b -> b
seqList [] b
b = b
b
seqList (a
x:[a]
xs) b
b = a
x seq :: forall a b. a -> b -> b
`seq` forall a b. [a] -> b -> b
seqList [a]
xs b
b

strictMap :: (a -> b) -> [a] -> [b]
strictMap :: forall a b. (a -> b) -> [a] -> [b]
strictMap a -> b
_ [] = []
strictMap a -> b
f (a
x : [a]
xs) =
  let
    !x' :: b
x' = a -> b
f a
x
    !xs' :: [b]
xs' = forall a b. (a -> b) -> [a] -> [b]
strictMap a -> b
f [a]
xs
  in
    b
x' forall a. a -> [a] -> [a]
: [b]
xs'

strictZipWith :: (a -> b -> c) -> [a] -> [b] -> [c]
strictZipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
strictZipWith a -> b -> c
_ [] [b]
_ = []
strictZipWith a -> b -> c
_ [a]
_ [] = []
strictZipWith a -> b -> c
f (a
x : [a]
xs) (b
y: [b]
ys) =
  let
    !x' :: c
x' = a -> b -> c
f a
x b
y
    !xs' :: [c]
xs' = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
strictZipWith a -> b -> c
f [a]
xs [b]
ys
  in
    c
x' forall a. a -> [a] -> [a]
: [c]
xs'


-- Module names:

looksLikeModuleName :: String -> Bool
looksLikeModuleName :: String -> Bool
looksLikeModuleName [] = Bool
False
looksLikeModuleName (Char
c:String
cs) = Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
&& String -> Bool
go String
cs
  where go :: String -> Bool
go [] = Bool
True
        go (Char
'.':String
cs) = String -> Bool
looksLikeModuleName String
cs
        go (Char
c:String
cs)   = (Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\'') Bool -> Bool -> Bool
&& String -> Bool
go String
cs

-- Similar to 'parse' for Distribution.Package.PackageName,
-- but we don't want to depend on Cabal.
looksLikePackageName :: String -> Bool
looksLikePackageName :: String -> Bool
looksLikePackageName = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isAlphaNum forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<&&> Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> [String]
split Char
'-'

{-
Akin to @Prelude.words@, but acts like the Bourne shell, treating
quoted strings as Haskell Strings, and also parses Haskell [String]
syntax.
-}

getCmd :: String -> Either String             -- Error
                           (String, String) -- (Cmd, Rest)
getCmd :: String -> Either String (String, String)
getCmd String
s = case forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
s of
           ([], String
_) -> forall a b. a -> Either a b
Left (String
"Couldn't find command in " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
s)
           (String, String)
res -> forall a b. b -> Either a b
Right (String, String)
res

toCmdArgs :: String -> Either String             -- Error
                              (String, [String]) -- (Cmd, Args)
toCmdArgs :: String -> Either String (String, [String])
toCmdArgs String
s = case String -> Either String (String, String)
getCmd String
s of
              Left String
err -> forall a b. a -> Either a b
Left String
err
              Right (String
cmd, String
s') -> case String -> Either String [String]
toArgs String
s' of
                                 Left String
err -> forall a b. a -> Either a b
Left String
err
                                 Right [String]
args -> forall a b. b -> Either a b
Right (String
cmd, [String]
args)

toArgs :: String -> Either String   -- Error
                           [String] -- Args
toArgs :: String -> Either String [String]
toArgs String
str
    = case forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
str of
      s :: String
s@(Char
'[':String
_) -> case forall a. Read a => ReadS a
reads String
s of
                   [([String]
args, String
spaces)]
                    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
spaces ->
                       forall a b. b -> Either a b
Right [String]
args
                   [([String], String)]
_ ->
                       forall a b. a -> Either a b
Left (String
"Couldn't read " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
str forall a. [a] -> [a] -> [a]
++ String
" as [String]")
      String
s -> String -> Either String [String]
toArgs' String
s
 where
  toArgs' :: String -> Either String [String]
  -- Remove outer quotes:
  -- > toArgs' "\"foo\" \"bar baz\""
  -- Right ["foo", "bar baz"]
  --
  -- Keep inner quotes:
  -- > toArgs' "-DFOO=\"bar baz\""
  -- Right ["-DFOO=\"bar baz\""]
  toArgs' :: String -> Either String [String]
toArgs' String
s = case forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
s of
              [] -> forall a b. b -> Either a b
Right []
              (Char
'"' : String
_) -> do
                    -- readAsString removes outer quotes
                    (String
arg, String
rest) <- String -> Either String (String, String)
readAsString String
s
                    (String
argforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> Either String [String]
toArgs' String
rest
              String
s' -> case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Bool
isSpace forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<||> (forall a. Eq a => a -> a -> Bool
== Char
'"')) String
s' of
                    (String
argPart1, s'' :: String
s''@(Char
'"':String
_)) -> do
                        (String
argPart2, String
rest) <- String -> Either String (String, String)
readAsString String
s''
                        -- show argPart2 to keep inner quotes
                        ((String
argPart1 forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
argPart2)forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> Either String [String]
toArgs' String
rest
                    (String
arg, String
s'') -> (String
argforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> Either String [String]
toArgs' String
s''

  readAsString :: String -> Either String (String, String)
  readAsString :: String -> Either String (String, String)
readAsString String
s = case forall a. Read a => ReadS a
reads String
s of
                [(String
arg, String
rest)]
                    -- rest must either be [] or start with a space
                    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace (forall a. Int -> [a] -> [a]
take Int
1 String
rest) ->
                    forall a b. b -> Either a b
Right (String
arg, String
rest)
                [(String, String)]
_ ->
                    forall a b. a -> Either a b
Left (String
"Couldn't read " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
s forall a. [a] -> [a] -> [a]
++ String
" as String")
-----------------------------------------------------------------------------
-- Integers

-- | Determine the $\log_2$ of exact powers of 2
exactLog2 :: Integer -> Maybe Integer
exactLog2 :: Integer -> Maybe Integer
exactLog2 Integer
x
   | Integer
x forall a. Ord a => a -> a -> Bool
<= Integer
0                               = forall a. Maybe a
Nothing
   | Integer
x forall a. Ord a => a -> a -> Bool
> forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Int32) = forall a. Maybe a
Nothing
   | Int32
x' forall bv. Bits bv => bv -> bv -> bv
.&. (-Int32
x') forall a. Eq a => a -> a -> Bool
/= Int32
x'                   = forall a. Maybe a
Nothing
   | Bool
otherwise                            = forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
c)
      where
         x' :: Int32
x' = forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x :: Int32
         c :: Int
c = forall b. FiniteBits b => b -> Int
countTrailingZeros Int32
x'

{-
-- -----------------------------------------------------------------------------
-- Floats
-}

readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
readRational__ :: ReadS Rational
readRational__ String
r = do
      ((Integer
i, Integer
e), String
t) <- ReadS (Integer, Integer)
readSignificandExponentPair__ String
r
      forall (m :: * -> *) a. Monad m => a -> m a
return ((Integer
iforall a. Integral a => a -> a -> Ratio a
%Integer
1)forall a. Num a => a -> a -> a
*Rational
10forall a b. (Fractional a, Integral b) => a -> b -> a
^^Integer
e, String
t)

readRational :: String -> Rational -- NB: *does* handle a leading "-"
readRational :: String -> Rational
readRational String
top_s
  = case String
top_s of
      Char
'-' : String
xs -> - (String -> Rational
read_me String
xs)
      String
xs       -> String -> Rational
read_me String
xs
  where
    read_me :: String -> Rational
read_me String
s
      = case (do { (Rational
x,String
"") <- ReadS Rational
readRational__ String
s ; forall (m :: * -> *) a. Monad m => a -> m a
return Rational
x }) of
          [Rational
x] -> Rational
x
          []  -> forall a. HasCallStack => String -> a
error (String
"readRational: no parse:"        forall a. [a] -> [a] -> [a]
++ String
top_s)
          [Rational]
_   -> forall a. HasCallStack => String -> a
error (String
"readRational: ambiguous parse:" forall a. [a] -> [a] -> [a]
++ String
top_s)


readSignificandExponentPair__ :: ReadS (Integer, Integer) -- NB: doesn't handle leading "-"
readSignificandExponentPair__ :: ReadS (Integer, Integer)
readSignificandExponentPair__ String
r = do
     (Integer
n,Int
d,String
s) <- String -> [(Integer, Int, String)]
readFix String
r
     (Int
k,String
t)   <- forall {m :: * -> *}. MonadFail m => String -> m (Int, String)
readExp String
s
     let pair :: (Integer, Integer)
pair = (Integer
n, forall a. Integral a => a -> Integer
toInteger (Int
k forall a. Num a => a -> a -> a
- Int
d))
     forall (m :: * -> *) a. Monad m => a -> m a
return ((Integer, Integer)
pair, String
t)
 where
     readFix :: String -> [(Integer, Int, String)]
readFix String
r = do
        (String
ds,String
s)  <- String -> [(String, String)]
lexDecDigits String
r
        (String
ds',String
t) <- forall {m :: * -> *}. Monad m => String -> m (String, String)
lexDotDigits String
s
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Read a => String -> a
read (String
dsforall a. [a] -> [a] -> [a]
++String
ds'), forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ds', String
t)

     readExp :: String -> m (Int, String)
readExp (Char
e:String
s) | Char
e forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"eE" = forall {m :: * -> *}. MonadFail m => String -> m (Int, String)
readExp' String
s
     readExp String
s                     = forall (m :: * -> *) a. Monad m => a -> m a
return (Int
0,String
s)

     readExp' :: String -> m (Int, String)
readExp' (Char
'+':String
s) = forall {m :: * -> *}. MonadFail m => String -> m (Int, String)
readDec String
s
     readExp' (Char
'-':String
s) = do (Int
k,String
t) <- forall {m :: * -> *}. MonadFail m => String -> m (Int, String)
readDec String
s
                           forall (m :: * -> *) a. Monad m => a -> m a
return (-Int
k,String
t)
     readExp' String
s       = forall {m :: * -> *}. MonadFail m => String -> m (Int, String)
readDec String
s

     readDec :: String -> m (Int, String)
readDec String
s = do
        (String
ds,String
r) <- forall {m :: * -> *}.
MonadFail m =>
(Char -> Bool) -> String -> m (String, String)
nonnull Char -> Bool
isDigit String
s
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\Int
n Int
d -> Int
n forall a. Num a => a -> a -> a
* Int
10 forall a. Num a => a -> a -> a
+ Int
d) [ Char -> Int
ord Char
d forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'0' | Char
d <- String
ds ],
                String
r)

     lexDecDigits :: String -> [(String, String)]
lexDecDigits = forall {m :: * -> *}.
MonadFail m =>
(Char -> Bool) -> String -> m (String, String)
nonnull Char -> Bool
isDigit

     lexDotDigits :: String -> m (String, String)
lexDotDigits (Char
'.':String
s) = forall (m :: * -> *) a. Monad m => a -> m a
return ((Char -> Bool) -> String -> (String, String)
span' Char -> Bool
isDigit String
s)
     lexDotDigits String
s       = forall (m :: * -> *) a. Monad m => a -> m a
return (String
"",String
s)

     nonnull :: (Char -> Bool) -> String -> m (String, String)
nonnull Char -> Bool
p String
s = do (cs :: String
cs@(Char
_:String
_),String
t) <- forall (m :: * -> *) a. Monad m => a -> m a
return ((Char -> Bool) -> String -> (String, String)
span' Char -> Bool
p String
s)
                      forall (m :: * -> *) a. Monad m => a -> m a
return (String
cs,String
t)

     span' :: (Char -> Bool) -> String -> (String, String)
span' Char -> Bool
_ xs :: String
xs@[]         =  (String
xs, String
xs)
     span' Char -> Bool
p xs :: String
xs@(Char
x:String
xs')
               | Char
x forall a. Eq a => a -> a -> Bool
== Char
'_'  = (Char -> Bool) -> String -> (String, String)
span' Char -> Bool
p String
xs'   -- skip "_" (#14473)
               | Char -> Bool
p Char
x       =  let (String
ys,String
zs) = (Char -> Bool) -> String -> (String, String)
span' Char -> Bool
p String
xs' in (Char
xforall a. a -> [a] -> [a]
:String
ys,String
zs)
               | Bool
otherwise =  ([],String
xs)

-- | Parse a string into a significand and exponent.
-- A trivial example might be:
--   ghci> readSignificandExponentPair "1E2"
--   (1,2)
-- In a more complex case we might return a exponent different than that
-- which the user wrote. This is needed in order to use a Integer significand.
--   ghci> readSignificandExponentPair "-1.11E5"
--   (-111,3)
readSignificandExponentPair :: String -> (Integer, Integer) -- NB: *does* handle a leading "-"
readSignificandExponentPair :: String -> (Integer, Integer)
readSignificandExponentPair String
top_s
  = case String
top_s of
      Char
'-' : String
xs -> let (Integer
i, Integer
e) = String -> (Integer, Integer)
read_me String
xs in (-Integer
i, Integer
e)
      String
xs       -> String -> (Integer, Integer)
read_me String
xs
  where
    read_me :: String -> (Integer, Integer)
read_me String
s
      = case (do { ((Integer, Integer)
x,String
"") <- ReadS (Integer, Integer)
readSignificandExponentPair__ String
s ; forall (m :: * -> *) a. Monad m => a -> m a
return (Integer, Integer)
x }) of
          [(Integer, Integer)
x] -> (Integer, Integer)
x
          []  -> forall a. HasCallStack => String -> a
error (String
"readSignificandExponentPair: no parse:"        forall a. [a] -> [a] -> [a]
++ String
top_s)
          [(Integer, Integer)]
_   -> forall a. HasCallStack => String -> a
error (String
"readSignificandExponentPair: ambiguous parse:" forall a. [a] -> [a] -> [a]
++ String
top_s)


readHexRational :: String -> Rational
readHexRational :: String -> Rational
readHexRational String
str =
  case String
str of
    Char
'-' : String
xs -> - (String -> Rational
readMe String
xs)
    String
xs       -> String -> Rational
readMe String
xs
  where
  readMe :: String -> Rational
readMe String
as =
    case String -> Maybe Rational
readHexRational__ String
as of
      Just Rational
n -> Rational
n
      Maybe Rational
_      -> forall a. HasCallStack => String -> a
error (String
"readHexRational: no parse:" forall a. [a] -> [a] -> [a]
++ String
str)


readHexRational__ :: String -> Maybe Rational
readHexRational__ :: String -> Maybe Rational
readHexRational__ (Char
'0' : Char
x : String
rest)
  | Char
x forall a. Eq a => a -> a -> Bool
== Char
'X' Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'x' =
  do let (String
front,String
rest2) = (Char -> Bool) -> String -> (String, String)
span' Char -> Bool
isHexDigit String
rest
     forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
front))
     let frontNum :: Integer
frontNum = forall {t :: * -> *} {b}.
(Foldable t, Num b) =>
b -> b -> t Char -> b
steps Integer
16 Integer
0 String
front
     case String
rest2 of
       Char
'.' : String
rest3 ->
          do let (String
back,String
rest4) = (Char -> Bool) -> String -> (String, String)
span' Char -> Bool
isHexDigit String
rest3
             forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
back))
             let backNum :: Integer
backNum = forall {t :: * -> *} {b}.
(Foldable t, Num b) =>
b -> b -> t Char -> b
steps Integer
16 Integer
frontNum String
back
                 exp1 :: Int
exp1    = -Int
4 forall a. Num a => a -> a -> a
* forall (t :: * -> *) a. Foldable t => t a -> Int
length String
back
             case String
rest4 of
               Char
p : String
ps | Char -> Bool
isExp Char
p -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> Int -> Rational
mk Integer
backNum forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+ Int
exp1)) (forall {a}. Num a => String -> Maybe a
getExp String
ps)
               String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Int -> Rational
mk Integer
backNum Int
exp1)
       Char
p : String
ps | Char -> Bool
isExp Char
p -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> Int -> Rational
mk Integer
frontNum) (forall {a}. Num a => String -> Maybe a
getExp String
ps)
       String
_ -> forall a. Maybe a
Nothing

  where
  isExp :: Char -> Bool
isExp Char
p = Char
p forall a. Eq a => a -> a -> Bool
== Char
'p' Bool -> Bool -> Bool
|| Char
p forall a. Eq a => a -> a -> Bool
== Char
'P'

  getExp :: String -> Maybe a
getExp (Char
'+' : String
ds) = forall {a}. Num a => String -> Maybe a
dec String
ds
  getExp (Char
'-' : String
ds) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Num a => a -> a
negate (forall {a}. Num a => String -> Maybe a
dec String
ds)
  getExp String
ds         = forall {a}. Num a => String -> Maybe a
dec String
ds

  mk :: Integer -> Int -> Rational
  mk :: Integer -> Int -> Rational
mk Integer
n Int
e = forall a. Num a => Integer -> a
fromInteger Integer
n forall a. Num a => a -> a -> a
* Rational
2forall a b. (Fractional a, Integral b) => a -> b -> a
^^Int
e

  dec :: String -> Maybe a
dec String
cs = case (Char -> Bool) -> String -> (String, String)
span' Char -> Bool
isDigit String
cs of
             (String
ds,String
"") | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ds) -> forall a. a -> Maybe a
Just (forall {t :: * -> *} {b}.
(Foldable t, Num b) =>
b -> b -> t Char -> b
steps a
10 a
0 String
ds)
             (String, String)
_ -> forall a. Maybe a
Nothing

  steps :: b -> b -> t Char -> b
steps b
base b
n t Char
ds = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (forall {a}. Num a => a -> a -> Char -> a
step b
base) b
n t Char
ds
  step :: a -> a -> Char -> a
step  a
base a
n Char
d  = a
base forall a. Num a => a -> a -> a
* a
n forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
digitToInt Char
d)

  span' :: (Char -> Bool) -> String -> (String, String)
span' Char -> Bool
_ xs :: String
xs@[]         =  (String
xs, String
xs)
  span' Char -> Bool
p xs :: String
xs@(Char
x:String
xs')
            | Char
x forall a. Eq a => a -> a -> Bool
== Char
'_'  = (Char -> Bool) -> String -> (String, String)
span' Char -> Bool
p String
xs'   -- skip "_"  (#14473)
            | Char -> Bool
p Char
x       =  let (String
ys,String
zs) = (Char -> Bool) -> String -> (String, String)
span' Char -> Bool
p String
xs' in (Char
xforall a. a -> [a] -> [a]
:String
ys,String
zs)
            | Bool
otherwise =  ([],String
xs)

readHexRational__ String
_ = forall a. Maybe a
Nothing

-- | Parse a string into a significand and exponent according to
-- the "Hexadecimal Floats in Haskell" proposal.
-- A trivial example might be:
--   ghci> readHexSignificandExponentPair "0x1p+1"
--   (1,1)
-- Behaves similar to readSignificandExponentPair but the base is 16
-- and numbers are given in hexadecimal:
--   ghci> readHexSignificandExponentPair "0xAp-4"
--   (10,-4)
--   ghci> readHexSignificandExponentPair "0x1.2p3"
--   (18,-1)
readHexSignificandExponentPair :: String -> (Integer, Integer)
readHexSignificandExponentPair :: String -> (Integer, Integer)
readHexSignificandExponentPair String
str =
  case String
str of
    Char
'-' : String
xs -> let (Integer
i, Integer
e) = String -> (Integer, Integer)
readMe String
xs in (-Integer
i, Integer
e)
    String
xs       -> String -> (Integer, Integer)
readMe String
xs
  where
  readMe :: String -> (Integer, Integer)
readMe String
as =
    case String -> Maybe (Integer, Integer)
readHexSignificandExponentPair__ String
as of
      Just (Integer, Integer)
n -> (Integer, Integer)
n
      Maybe (Integer, Integer)
_      -> forall a. HasCallStack => String -> a
error (String
"readHexSignificandExponentPair: no parse:" forall a. [a] -> [a] -> [a]
++ String
str)


readHexSignificandExponentPair__ :: String -> Maybe (Integer, Integer)
readHexSignificandExponentPair__ :: String -> Maybe (Integer, Integer)
readHexSignificandExponentPair__ (Char
'0' : Char
x : String
rest)
  | Char
x forall a. Eq a => a -> a -> Bool
== Char
'X' Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'x' =
  do let (String
front,String
rest2) = (Char -> Bool) -> String -> (String, String)
span' Char -> Bool
isHexDigit String
rest
     forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
front))
     let frontNum :: Integer
frontNum = forall {t :: * -> *} {b}.
(Foldable t, Num b) =>
b -> b -> t Char -> b
steps Integer
16 Integer
0 String
front
     case String
rest2 of
       Char
'.' : String
rest3 ->
          do let (String
back,String
rest4) = (Char -> Bool) -> String -> (String, String)
span' Char -> Bool
isHexDigit String
rest3
             forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
back))
             let backNum :: Integer
backNum = forall {t :: * -> *} {b}.
(Foldable t, Num b) =>
b -> b -> t Char -> b
steps Integer
16 Integer
frontNum String
back
                 exp1 :: Int
exp1    = -Int
4 forall a. Num a => a -> a -> a
* forall (t :: * -> *) a. Foldable t => t a -> Int
length String
back
             case String
rest4 of
               Char
p : String
ps | Char -> Bool
isExp Char
p -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> Int -> (Integer, Integer)
mk Integer
backNum forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+ Int
exp1)) (forall {a}. Num a => String -> Maybe a
getExp String
ps)
               String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Int -> (Integer, Integer)
mk Integer
backNum Int
exp1)
       Char
p : String
ps | Char -> Bool
isExp Char
p -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> Int -> (Integer, Integer)
mk Integer
frontNum) (forall {a}. Num a => String -> Maybe a
getExp String
ps)
       String
_ -> forall a. Maybe a
Nothing

  where
  isExp :: Char -> Bool
isExp Char
p = Char
p forall a. Eq a => a -> a -> Bool
== Char
'p' Bool -> Bool -> Bool
|| Char
p forall a. Eq a => a -> a -> Bool
== Char
'P'

  getExp :: String -> Maybe a
getExp (Char
'+' : String
ds) = forall {a}. Num a => String -> Maybe a
dec String
ds
  getExp (Char
'-' : String
ds) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Num a => a -> a
negate (forall {a}. Num a => String -> Maybe a
dec String
ds)
  getExp String
ds         = forall {a}. Num a => String -> Maybe a
dec String
ds

  mk :: Integer -> Int -> (Integer, Integer)
  mk :: Integer -> Int -> (Integer, Integer)
mk Integer
n Int
e = (Integer
n, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
e)

  dec :: String -> Maybe a
dec String
cs = case (Char -> Bool) -> String -> (String, String)
span' Char -> Bool
isDigit String
cs of
             (String
ds,String
"") | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ds) -> forall a. a -> Maybe a
Just (forall {t :: * -> *} {b}.
(Foldable t, Num b) =>
b -> b -> t Char -> b
steps a
10 a
0 String
ds)
             (String, String)
_ -> forall a. Maybe a
Nothing

  steps :: b -> b -> t Char -> b
steps b
base b
n t Char
ds = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall {a}. Num a => a -> a -> Char -> a
step b
base) b
n t Char
ds
  step :: a -> a -> Char -> a
step  a
base a
n Char
d  = a
base forall a. Num a => a -> a -> a
* a
n forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
digitToInt Char
d)

  span' :: (Char -> Bool) -> String -> (String, String)
span' Char -> Bool
_ xs :: String
xs@[]         =  (String
xs, String
xs)
  span' Char -> Bool
p xs :: String
xs@(Char
x:String
xs')
            | Char
x forall a. Eq a => a -> a -> Bool
== Char
'_'  = (Char -> Bool) -> String -> (String, String)
span' Char -> Bool
p String
xs'   -- skip "_"  (#14473)
            | Char -> Bool
p Char
x       =  let (String
ys,String
zs) = (Char -> Bool) -> String -> (String, String)
span' Char -> Bool
p String
xs' in (Char
xforall a. a -> [a] -> [a]
:String
ys,String
zs)
            | Bool
otherwise =  ([],String
xs)

readHexSignificandExponentPair__ String
_ = forall a. Maybe a
Nothing


-----------------------------------------------------------------------------
-- Verify that the 'dirname' portion of a FilePath exists.
--
doesDirNameExist :: FilePath -> IO Bool
doesDirNameExist :: String -> IO Bool
doesDirNameExist String
fpath = String -> IO Bool
doesDirectoryExist (String -> String
takeDirectory String
fpath)

-----------------------------------------------------------------------------
-- Backwards compatibility definition of getModificationTime

getModificationUTCTime :: FilePath -> IO UTCTime
getModificationUTCTime :: String -> IO UTCTime
getModificationUTCTime = String -> IO UTCTime
getModificationTime

-- --------------------------------------------------------------
-- check existence & modification time at the same time

modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists :: String -> IO (Maybe UTCTime)
modificationTimeIfExists String
f =
  (do UTCTime
t <- String -> IO UTCTime
getModificationUTCTime String
f; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just UTCTime
t))
        forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
e -> if IOException -> Bool
isDoesNotExistError IOException
e
                        then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                        else forall a. IOException -> IO a
ioError IOException
e

-- --------------------------------------------------------------
-- atomic file writing by writing to a temporary file first (see #14533)
--
-- This should be used in all cases where GHC writes files to disk
-- and uses their modification time to skip work later,
-- as otherwise a partially written file (e.g. due to crash or Ctrl+C)
-- also results in a skip.

withAtomicRename :: (MonadIO m) => FilePath -> (FilePath -> m a) -> m a
withAtomicRename :: forall (m :: * -> *) a.
MonadIO m =>
String -> (String -> m a) -> m a
withAtomicRename String
targetFile String -> m a
f = do
  -- The temp file must be on the same file system (mount) as the target file
  -- to result in an atomic move on most platforms.
  -- The standard way to ensure that is to place it into the same directory.
  -- This can still be fooled when somebody mounts a different file system
  -- at just the right time, but that is not a case we aim to cover here.
  let temp :: String
temp = String
targetFile String -> String -> String
<.> String
"tmp"
  a
res <- String -> m a
f String
temp
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
renameFile String
temp String
targetFile
  forall (m :: * -> *) a. Monad m => a -> m a
return a
res

-- --------------------------------------------------------------
-- split a string at the last character where 'pred' is True,
-- returning a pair of strings. The first component holds the string
-- up (but not including) the last character for which 'pred' returned
-- True, the second whatever comes after (but also not including the
-- last character).
--
-- If 'pred' returns False for all characters in the string, the original
-- string is returned in the first component (and the second one is just
-- empty).
splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
splitLongestPrefix :: String -> (Char -> Bool) -> (String, String)
splitLongestPrefix String
str Char -> Bool
pred
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
r_pre = (String
str,           [])
  | Bool
otherwise  = (forall a. [a] -> [a]
reverse (forall a. [a] -> [a]
tail String
r_pre), forall a. [a] -> [a]
reverse String
r_suf)
                           -- 'tail' drops the char satisfying 'pred'
  where (String
r_suf, String
r_pre) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
pred (forall a. [a] -> [a]
reverse String
str)

escapeSpaces :: String -> String
escapeSpaces :: String -> String
escapeSpaces = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Char
c String
s -> if Char -> Bool
isSpace Char
c then Char
'\\'forall a. a -> [a] -> [a]
:Char
cforall a. a -> [a] -> [a]
:String
s else Char
cforall a. a -> [a] -> [a]
:String
s) String
""

type Suffix = String

--------------------------------------------------------------
-- * Search path
--------------------------------------------------------------

data Direction = Forwards | Backwards

reslash :: Direction -> FilePath -> FilePath
reslash :: Direction -> String -> String
reslash Direction
d = String -> String
f
    where f :: String -> String
f (Char
'/'  : String
xs) = Char
slash forall a. a -> [a] -> [a]
: String -> String
f String
xs
          f (Char
'\\' : String
xs) = Char
slash forall a. a -> [a] -> [a]
: String -> String
f String
xs
          f (Char
x    : String
xs) = Char
x     forall a. a -> [a] -> [a]
: String -> String
f String
xs
          f String
""          = String
""
          slash :: Char
slash = case Direction
d of
                  Direction
Forwards -> Char
'/'
                  Direction
Backwards -> Char
'\\'

makeRelativeTo :: FilePath -> FilePath -> FilePath
String
this makeRelativeTo :: String -> String -> String
`makeRelativeTo` String
that = String
directory String -> String -> String
</> String
thisFilename
    where (String
thisDirectory, String
thisFilename) = String -> (String, String)
splitFileName String
this
          thatDirectory :: String
thatDirectory = String -> String
dropFileName String
that
          directory :: String
directory = [String] -> String
joinPath forall a b. (a -> b) -> a -> b
$ [String] -> [String] -> [String]
f (String -> [String]
splitPath String
thisDirectory)
                                   (String -> [String]
splitPath String
thatDirectory)

          f :: [String] -> [String] -> [String]
f (String
x : [String]
xs) (String
y : [String]
ys)
           | String
x forall a. Eq a => a -> a -> Bool
== String
y = [String] -> [String] -> [String]
f [String]
xs [String]
ys
          f [String]
xs [String]
ys = forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ys) String
".." forall a. [a] -> [a] -> [a]
++ [String]
xs

{-
************************************************************************
*                                                                      *
\subsection[Utils-Data]{Utils for defining Data instances}
*                                                                      *
************************************************************************

These functions helps us to define Data instances for abstract types.
-}

abstractConstr :: String -> Constr
abstractConstr :: String -> Constr
abstractConstr String
n = DataType -> String -> [String] -> Fixity -> Constr
mkConstr (String -> DataType
abstractDataType String
n) (String
"{abstract:"forall a. [a] -> [a] -> [a]
++String
nforall a. [a] -> [a] -> [a]
++String
"}") [] Fixity
Prefix

abstractDataType :: String -> DataType
abstractDataType :: String -> DataType
abstractDataType String
n = String -> [Constr] -> DataType
mkDataType String
n [String -> Constr
abstractConstr String
n]

{-
************************************************************************
*                                                                      *
\subsection[Utils-C]{Utils for printing C code}
*                                                                      *
************************************************************************
-}

charToC :: Word8 -> String
charToC :: Word8 -> String
charToC Word8
w =
  case Int -> Char
chr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w) of
        Char
'\"' -> String
"\\\""
        Char
'\'' -> String
"\\\'"
        Char
'\\' -> String
"\\\\"
        Char
c | Char
c forall a. Ord a => a -> a -> Bool
>= Char
' ' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'~' -> [Char
c]
          | Bool
otherwise -> [Char
'\\',
                         Int -> Char
chr (Char -> Int
ord Char
'0' forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
c forall a. Integral a => a -> a -> a
`div` Int
64),
                         Int -> Char
chr (Char -> Int
ord Char
'0' forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
c forall a. Integral a => a -> a -> a
`div` Int
8 forall a. Integral a => a -> a -> a
`mod` Int
8),
                         Int -> Char
chr (Char -> Int
ord Char
'0' forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
c         forall a. Integral a => a -> a -> a
`mod` Int
8)]

{-
************************************************************************
*                                                                      *
\subsection[Utils-Hashing]{Utils for hashing}
*                                                                      *
************************************************************************
-}

-- | A sample hash function for Strings.  We keep multiplying by the
-- golden ratio and adding.  The implementation is:
--
-- > hashString = foldl' f golden
-- >   where f m c = fromIntegral (ord c) * magic + hashInt32 m
-- >         magic = 0xdeadbeef
--
-- Where hashInt32 works just as hashInt shown above.
--
-- Knuth argues that repeated multiplication by the golden ratio
-- will minimize gaps in the hash space, and thus it's a good choice
-- for combining together multiple keys to form one.
--
-- Here we know that individual characters c are often small, and this
-- produces frequent collisions if we use ord c alone.  A
-- particular problem are the shorter low ASCII and ISO-8859-1
-- character strings.  We pre-multiply by a magic twiddle factor to
-- obtain a good distribution.  In fact, given the following test:
--
-- > testp :: Int32 -> Int
-- > testp k = (n - ) . length . group . sort . map hs . take n $ ls
-- >   where ls = [] : [c : l | l <- ls, c <- ['\0'..'\xff']]
-- >         hs = foldl' f golden
-- >         f m c = fromIntegral (ord c) * k + hashInt32 m
-- >         n = 100000
--
-- We discover that testp magic = 0.
hashString :: String -> Int32
hashString :: String -> Int32
hashString = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int32 -> Char -> Int32
f Int32
golden
   where f :: Int32 -> Char -> Int32
f Int32
m Char
c = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c) forall a. Num a => a -> a -> a
* Int32
magic forall a. Num a => a -> a -> a
+ Int32 -> Int32
hashInt32 Int32
m
         magic :: Int32
magic = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
0xdeadbeef :: Word32)

golden :: Int32
golden :: Int32
golden = Int32
1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32
-- was -1640531527 = round ((sqrt 5 - 1) * 2^31) :: Int32
-- but that has bad mulHi properties (even adding 2^32 to get its inverse)
-- Whereas the above works well and contains no hash duplications for
-- [-32767..65536]

-- | A sample (and useful) hash function for Int32,
-- implemented by extracting the uppermost 32 bits of the 64-bit
-- result of multiplying by a 33-bit constant.  The constant is from
-- Knuth, derived from the golden ratio:
--
-- > golden = round ((sqrt 5 - 1) * 2^32)
--
-- We get good key uniqueness on small inputs
-- (a problem with previous versions):
--  (length $ group $ sort $ map hashInt32 [-32767..65536]) == 65536 + 32768
--
hashInt32 :: Int32 -> Int32
hashInt32 :: Int32 -> Int32
hashInt32 Int32
x = Int32 -> Int32 -> Int32
mulHi Int32
x Int32
golden forall a. Num a => a -> a -> a
+ Int32
x

-- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply
mulHi :: Int32 -> Int32 -> Int32
mulHi :: Int32 -> Int32 -> Int32
mulHi Int32
a Int32
b = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
r forall a. Bits a => a -> Int -> a
`shiftR` Int
32)
   where r :: Int64
         r :: Int64
r = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
a forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
b

-- | A call stack constraint, but only when 'isDebugOn'.
#if defined(DEBUG)
type HasDebugCallStack = HasCallStack
#else
type HasDebugCallStack = (() :: Constraint)
#endif

data OverridingBool
  = Auto
  | Always
  | Never
  deriving Int -> OverridingBool -> String -> String
[OverridingBool] -> String -> String
OverridingBool -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [OverridingBool] -> String -> String
$cshowList :: [OverridingBool] -> String -> String
show :: OverridingBool -> String
$cshow :: OverridingBool -> String
showsPrec :: Int -> OverridingBool -> String -> String
$cshowsPrec :: Int -> OverridingBool -> String -> String
Show

overrideWith :: Bool -> OverridingBool -> Bool
overrideWith :: Bool -> OverridingBool -> Bool
overrideWith Bool
b OverridingBool
Auto   = Bool
b
overrideWith Bool
_ OverridingBool
Always = Bool
True
overrideWith Bool
_ OverridingBool
Never  = Bool
False