-- (c) The University of Glasgow 2006

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

-- | Highly random utility functions
--
module Util (
        -- * Flags dependent on the compiler build
        ghciSupported, debugIsOn,
        ghciTablesNextToCode,
        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, mapAccumL2,
        filterOut, partitionWith,

        dropWhileEndLE, spanEnd, last2, lastMaybe,

        foldl1', foldl2, count, countWhile, all2,

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

        isSingleton, only, singleton,
        notNull, snocView,

        isIn, isn'tIn,

        chunkList,

        changeLast,

        whenNonEmpty,

        -- * 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,

        -- * Module names
        looksLikeModuleName,
        looksLikePackageName,

        -- * Argument processing
        getCmd, toCmdArgs, toArgs,

        -- * Integers
        exactLog2,

        -- * Floating point
        readRational,
        readHexRational,

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

        global, consIORef, globalM,
        sharedGlobal, sharedGlobalM,

        -- * 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 GhcPrelude

import Exception
import PlainPanic

import Data.Data
import Data.IORef       ( IORef, newIORef, atomicModifyIORef' )
import System.IO.Unsafe ( unsafePerformIO )
import Data.List        hiding (group)
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 GHC.Conc.Sync ( sharedCAF )
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.Bits
import Data.Word
import qualified Data.IntMap as IM
import qualified Data.Set as Set

import Data.Time

#if defined(DEBUG)
import {-# SOURCE #-} Outputable ( warnPprTrace, text )
#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 = True
#else
ghciSupported :: Bool
ghciSupported = Bool
False
#endif

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

ghciTablesNextToCode :: Bool
#if defined(GHCI_TABLES_NEXT_TO_CODE)
ghciTablesNextToCode = True
#else
ghciTablesNextToCode :: Bool
ghciTablesNextToCode = 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 :: 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

-- | A for loop: Compose a function with itself n times.  (nth rather than twice)
nTimes :: Int -> (a -> a) -> (a -> a)
nTimes :: Int -> (a -> a) -> a -> a
nTimes Int
0 a -> a
_ = 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 (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (a -> a) -> a -> a
forall a. Int -> (a -> a) -> a -> a
nTimes (Int
nInt -> Int -> Int
forall 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 :: (a, b, c) -> a
fstOf3      (a
a,b
_,c
_) =  a
a
sndOf3 :: (a, b, c) -> b
sndOf3      (a
_,b
b,c
_) =  b
b
thdOf3 :: (a, b, c) -> c
thdOf3      (a
_,b
_,c
c) =  c
c

fst3 :: (a -> d) -> (a, b, c) -> (d, b, c)
fst3 :: (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 :: (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 :: (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 :: (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 :: (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 :: (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 :: (a -> m c) -> (a, b) -> m (c, b)
firstM a -> m c
f (a
x, b
y) = (c -> (c, b)) -> m c -> m (c, b)
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 :: (a -> m d) -> (a, b, c) -> m (d, b, c)
first3M a -> m d
f (a
x, b
y, c
z) = (d -> (d, b, c)) -> m d -> m (d, b, c)
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 :: (b -> m c) -> (a, b) -> m (a, c)
secondM b -> m c
f (a
x, b
y) = (a
x,) (c -> (a, c)) -> m c -> m (a, c)
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 :: (a -> Bool) -> [a] -> [a]
filterOut a -> Bool
_ [] = []
filterOut a -> Bool
p (a
x:[a]
xs) | a -> Bool
p a
x       = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filterOut a -> Bool
p [a]
xs
                   | Bool
otherwise = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> Bool) -> [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 :: (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
bb -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
bs, [c]
cs)
                         Right c
c -> ([b]
bs, c
cc -> [c] -> [c]
forall a. a -> [a] -> [a]
:[c]
cs)
    where ([b]
bs,[c]
cs) = (a -> Either b c) -> [a] -> ([b], [c])
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 :: [a] -> [a] -> [a]
chkAppend [a]
xs [a]
ys
  | [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
ys   = [a]
xs
  | Bool
otherwise = [a]
xs [a] -> [a] -> [a]
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 :: String -> [a] -> [b] -> [(a, b)]
zipEqual      String
_ = [a] -> [b] -> [(a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip
zipWithEqual :: String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual  String
_ = (a -> b -> c) -> [a] -> [b] -> [c]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
zipWith3Equal :: String -> (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3Equal String
_ = (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3
zipWith4Equal :: String
-> (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
zipWith4Equal String
_ = (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
forall a b c d e.
(a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
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 :: [a] -> [b] -> [(a, b)]
zipLazy []     [b]
_       = []
zipLazy (a
x:[a]
xs) ~(b
y:[b]
ys) = (a
x,b
y) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [a] -> [b] -> [(a, b)]
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 :: (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 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: (a -> b -> c) -> [a] -> [b] -> [c]
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 :: (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 d -> [d] -> [d]
forall a. a -> [a] -> [a]
: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
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 :: [Bool] -> [a] -> [a]
filterByList (Bool
True:[Bool]
bs)  (a
x:[a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [Bool] -> [a] -> [a]
forall a. [Bool] -> [a] -> [a]
filterByList [Bool]
bs [a]
xs
filterByList (Bool
False:[Bool]
bs) (a
_:[a]
xs) =     [Bool] -> [a] -> [a]
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 :: [Bool] -> [a] -> [a] -> [a]
filterByLists (Bool
True:[Bool]
bs)  (a
x:[a]
xs) (a
_:[a]
ys) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [Bool] -> [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 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [Bool] -> [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 :: [Bool] -> [a] -> ([a], [a])
partitionByList = [a] -> [a] -> [Bool] -> [a] -> ([a], [a])
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
xa -> [a] -> [a]
forall 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
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
falses) [Bool]
bs [a]
xs
    go [a]
trues [a]
falses [Bool]
_ [a]
_ = ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
trues, [a] -> [a]
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 :: (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 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: (a -> Bool) -> b -> (a -> b -> c) -> [a] -> [b] -> [c]
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 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: (a -> Bool) -> b -> (a -> b -> c) -> [a] -> [b] -> [c]
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 :: (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 :: (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 :: (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) = (a -> (b, c)) -> [a] -> ([b], [c])
forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip a -> (b, c)
f [a]
xs
    in
    (b
r1b -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
rs1, c
r2c -> [c] -> [c]
forall a. a -> [a] -> [a]
:[c]
rs2)

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

mapAndUnzip3 :: (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) = (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
forall a b c d. (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
mapAndUnzip3 a -> (b, c, d)
f [a]
xs
    in
    (b
r1b -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
rs1, c
r2c -> [c] -> [c]
forall a. a -> [a] -> [a]
:[c]
rs2, d
r3d -> [d] -> [d]
forall a. a -> [a] -> [a]
:[d]
rs3)

zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d])
zipWithAndUnzip :: (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) = (a -> b -> (c, d)) -> [a] -> [b] -> ([c], [d])
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
r1c -> [c] -> [c]
forall a. a -> [a] -> [a]
:[c]
rs1, d
r2d -> [d] -> [d]
forall 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 :: [a] -> [b] -> ([a], [b])
zipAndUnzip (a
a:[a]
as) (b
b:[b]
bs)
  = let ([a]
rs1, [b]
rs2) = [a] -> [b] -> ([a], [b])
forall a b. [a] -> [b] -> ([a], [b])
zipAndUnzip [a]
as [b]
bs
    in
    (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
rs1, b
bb -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
rs2)
zipAndUnzip [a]
_ [b]
_ = ([],[])

mapAccumL2 :: (s1 -> s2 -> a -> (s1, s2, b)) -> s1 -> s2 -> [a] -> (s1, s2, [b])
mapAccumL2 :: (s1 -> s2 -> a -> (s1, s2, b)) -> s1 -> s2 -> [a] -> (s1, s2, [b])
mapAccumL2 s1 -> s2 -> a -> (s1, s2, b)
f s1
s1 s2
s2 [a]
xs = (s1
s1', s2
s2', [b]
ys)
  where ((s1
s1', s2
s2'), [b]
ys) = ((s1, s2) -> a -> ((s1, s2), b))
-> (s1, s2) -> [a] -> ((s1, s2), [b])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (\(s1
s1, s2
s2) a
x -> case s1 -> s2 -> a -> (s1, s2, b)
f s1
s1 s2
s2 a
x of
                                                       (s1
s1', s2
s2', b
y) -> ((s1
s1', s2
s2'), b
y))
                                     (s1
s1, s2
s2) [a]
xs

-- | @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 :: ([a] -> b) -> b -> [a] -> Int -> b
atLength [a] -> b
atLenPred b
atEnd [a]
ls0 Int
n0
  | Int
n0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0    = [a] -> b
atLenPred [a]
ls0
  | Bool
otherwise = Int -> [a] -> b
forall t. (Eq t, Num t) => t -> [a] -> b
go Int
n0 [a]
ls0
  where
    -- go's first arg n >= 0
    go :: t -> [a] -> b
go t
0 [a]
ls     = [a] -> b
atLenPred [a]
ls
    go t
_ []     = b
atEnd           -- n > 0 here
    go t
n (a
_:[a]
xs) = t -> [a] -> b
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) [a]
xs

-- Some special cases of atLength:

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

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

-- | @(lengthIs xs n) = (length xs == n)@
lengthIs :: [a] -> Int -> Bool
lengthIs :: [a] -> Int -> Bool
lengthIs [a]
lst Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
  = Bool
False
  | Bool
otherwise
  = ([a] -> Bool) -> Bool -> [a] -> Int -> Bool
forall a b. ([a] -> b) -> b -> [a] -> Int -> b
atLength [a] -> Bool
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 :: [a] -> Int -> Bool
lengthIsNot [a]
lst Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Bool
True
  | Bool
otherwise = ([a] -> Bool) -> Bool -> [a] -> Int -> Bool
forall a b. ([a] -> b) -> b -> [a] -> Int -> b
atLength [a] -> Bool
forall a. [a] -> Bool
notNull Bool
True [a]
lst Int
n

-- | @(lengthAtMost xs n) = (length xs <= n)@
lengthAtMost :: [a] -> Int -> Bool
lengthAtMost :: [a] -> Int -> Bool
lengthAtMost [a]
lst Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
  = Bool
False
  | Bool
otherwise
  = ([a] -> Bool) -> Bool -> [a] -> Int -> Bool
forall a b. ([a] -> b) -> b -> [a] -> Int -> b
atLength [a] -> Bool
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 :: [a] -> Int -> Bool
lengthLessThan = ([a] -> Bool) -> Bool -> [a] -> Int -> Bool
forall a b. ([a] -> b) -> b -> [a] -> Int -> b
atLength (Bool -> [a] -> Bool
forall a b. a -> b -> a
const Bool
False) Bool
True

listLengthCmp :: [a] -> Int -> Ordering
listLengthCmp :: [a] -> Int -> Ordering
listLengthCmp = ([a] -> Ordering) -> Ordering -> [a] -> Int -> Ordering
forall a b. ([a] -> b) -> b -> [a] -> Int -> b
atLength [a] -> Ordering
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 :: [a] -> [b] -> Bool
equalLength []     []     = Bool
True
equalLength (a
_:[a]
xs) (b
_:[b]
ys) = [a] -> [b] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [a]
xs [b]
ys
equalLength [a]
_      [b]
_      = Bool
False

compareLength :: [a] -> [b] -> Ordering
compareLength :: [a] -> [b] -> Ordering
compareLength []     []     = Ordering
EQ
compareLength (a
_:[a]
xs) (b
_:[b]
ys) = [a] -> [b] -> Ordering
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 :: [a] -> [b] -> Bool
leLength [a]
xs [b]
ys = case [a] -> [b] -> Ordering
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 :: [a] -> [b] -> Bool
ltLength [a]
xs [b]
ys = case [a] -> [b] -> Ordering
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 :: a -> [a]
singleton a
x = [a
x]

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

notNull :: [a] -> Bool
notNull :: [a] -> Bool
notNull [] = Bool
False
notNull [a]
_  = Bool
True

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

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

isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool

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

# else /* DEBUG */
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 :: Int -> [a] -> [[a]]
chunkList Int
_ [] = []
chunkList Int
n [a]
xs = [a]
as [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
chunkList Int
n [a]
bs where ([a]
as,[a]
bs) = Int -> [a] -> ([a], [a])
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 :: [a] -> a -> [a]
changeLast []     a
_  = String -> [a]
forall a. String -> a
panic String
"changeLast"
changeLast [a
_]    a
x  = [a
x]
changeLast (a
x:[a]
xs) a
x' = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> a -> [a]
forall a. [a] -> a -> [a]
changeLast [a]
xs a
x'

whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m ()
whenNonEmpty :: [a] -> (NonEmpty a -> m ()) -> m ()
whenNonEmpty []     NonEmpty a -> m ()
_ = () -> 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 a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs)

{-
************************************************************************
*                                                                      *
\subsubsection{Sort utils}
*                                                                      *
************************************************************************
-}

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

nubSort :: Ord a => [a] -> [a]
nubSort :: [a] -> [a]
nubSort = Set a -> [a]
forall a. Set a -> [a]
Set.toAscList (Set a -> [a]) -> ([a] -> Set a) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Set a
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 :: [a] -> [a]
ordNub [a]
xs
  = Set a -> [a] -> [a]
forall a. Ord a => Set a -> [a] -> [a]
go Set a
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)
      | a -> Set a -> Bool
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 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Set a -> [a] -> [a]
go (a -> Set a -> Set a
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 :: (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
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
done) (a -> [a]
succ a
x [a] -> [a] -> [a]
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 :: (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) = (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
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]
_      = String -> acc
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 :: (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
&& (a -> b -> Bool) -> [a] -> [b] -> 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 :: (a -> Bool) -> [a] -> Int
count a -> Bool
p = Int -> [a] -> Int
forall t. Num t => t -> [a] -> t
go Int
0
  where go :: t -> [a] -> t
go !t
n [] = t
n
        go !t
n (a
x:[a]
xs) | a -> Bool
p a
x       = t -> [a] -> t
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
1) [a]
xs
                     | Bool
otherwise = t -> [a] -> t
go t
n [a]
xs

countWhile :: (a -> Bool) -> [a] -> Int
-- Length of an /initial prefix/ of the list satsifying p
countWhile :: (a -> Bool) -> [a] -> Int
countWhile a -> Bool
p = Int -> [a] -> Int
forall p. Num p => p -> [a] -> p
go Int
0
  where go :: p -> [a] -> p
go !p
n (a
x:[a]
xs) | a -> Bool
p a
x = p -> [a] -> p
go (p
np -> p -> p
forall a. Num a => a -> a -> a
+p
1) [a]
xs
        go !p
n [a]
_            = p
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 :: [b] -> [a] -> [a]
takeList [] [a]
_ = []
takeList (b
_:[b]
xs) [a]
ls =
   case [a]
ls of
     [] -> []
     (a
y:[a]
ys) -> a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [b] -> [a] -> [a]
forall b a. [b] -> [a] -> [a]
takeList [b]
xs [a]
ys

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


splitAtList :: [b] -> [a] -> ([a], [a])
splitAtList :: [b] -> [a] -> ([a], [a])
splitAtList [] [a]
xs     = ([], [a]
xs)
splitAtList [b]
_ xs :: [a]
xs@[]   = ([a]
xs, [a]
xs)
splitAtList (b
_:[b]
xs) (a
y:[a]
ys) = (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys', [a]
ys'')
    where
      ([a]
ys', [a]
ys'') = [b] -> [a] -> ([a], [a])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList [b]
xs [a]
ys

-- drop from the end of a list
dropTail :: Int -> [a] -> [a]
-- Specification: dropTail n = reverse . drop n . reverse
-- Better implemention due to Joachim Breitner
-- http://www.joachim-breitner.de/blog/archives/600-On-taking-the-last-n-elements-of-a-list.html
dropTail :: Int -> [a] -> [a]
dropTail Int
n [a]
xs
  = [a] -> [a] -> [a]
forall b a. [b] -> [a] -> [a]
go (Int -> [a] -> [a]
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 a -> [a] -> [a]
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 :: (a -> Bool) -> [a] -> [a]
dropWhileEndLE a -> Bool
p = (a -> [a] -> [a]) -> [a] -> [a] -> [a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x [a]
r -> if [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
r Bool -> Bool -> Bool
&& a -> Bool
p a
x then [] else a
xa -> [a] -> [a]
forall 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 :: (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, [a] -> [a]
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 a -> [a] -> [a]
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 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
rev_yes [a] -> [a] -> [a]
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 :: [a] -> (a, a)
last2 = ((a, a) -> a -> (a, a)) -> (a, a) -> [a] -> (a, a)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\(a
_,a
x2) a
x -> (a
x2,a
x)) (a
forall a. a
partialError,a
forall a. a
partialError)
  where
    partialError :: a
partialError = String -> a
forall a. String -> a
panic String
"last2 - list length less than two"

lastMaybe :: [a] -> Maybe a
lastMaybe :: [a] -> Maybe a
lastMaybe [] = Maybe a
forall a. Maybe a
Nothing
lastMaybe [a]
xs = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ [a] -> a
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 :: [a] -> Maybe ([a], a)
snocView [] = Maybe ([a], a)
forall a. Maybe a
Nothing
snocView [a]
xs
    | ([a]
xs,a
x) <- [a] -> ([a], a)
forall a. [a] -> ([a], a)
go [a]
xs
    = ([a], a) -> Maybe ([a], a)
forall a. a -> Maybe a
Just ([a]
xs,a
x)
  where
    go :: [a] -> ([a],a)
    go :: [a] -> ([a], a)
go [a
x] = ([],a
x)
    go (a
x:[a]
xs)
        | !([a]
xs',a
x') <- [a] -> ([a], a)
forall a. [a] -> ([a], a)
go [a]
xs
        = (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs', a
x')
    go [] = String -> ([a], a)
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 String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Char -> String -> [String]
split Char
c String
rest
  where (String
chunk, String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
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 Char -> String -> String
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 :: (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
&& (a -> a -> Bool) -> [a] -> [a] -> 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 :: (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 :: (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 -> (a -> a -> Ordering) -> [a] -> [a] -> Ordering
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 = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEndLE Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace

-- Boolean operators lifted to Applicative
(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool
<&&> :: f Bool -> f Bool -> f Bool
(<&&>) = (Bool -> Bool -> Bool) -> 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
<||> :: f Bool -> f Bool -> f Bool
(<||>) = (Bool -> Bool -> Bool) -> 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 = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str1
    n :: Int
n = String -> Int
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n
  = if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
32 -- n must be larger so this check is sufficient
    then Word32 -> Int -> Int -> String -> String -> Int
forall bv.
(Bits bv, Num bv) =>
bv -> Int -> Int -> String -> String -> Int
restrictedDamerauLevenshteinDistance' (Word32
forall a. HasCallStack => a
undefined :: Word32) Int
m Int
n String
str1 String
str2
    else Integer -> Int -> Int -> String -> String -> Int
forall bv.
(Bits bv, Num bv) =>
bv -> Int -> Int -> String -> String -> Int
restrictedDamerauLevenshteinDistance' (Integer
forall a. HasCallStack => a
undefined :: Integer) Int
m Int
n String
str1 String
str2

  | Bool
otherwise
  = if Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
32 -- m must be larger so this check is sufficient
    then Word32 -> Int -> Int -> String -> String -> Int
forall bv.
(Bits bv, Num bv) =>
bv -> Int -> Int -> String -> String -> Int
restrictedDamerauLevenshteinDistance' (Word32
forall a. HasCallStack => a
undefined :: Word32) Int
n Int
m String
str2 String
str1
    else Integer -> Int -> Int -> String -> String -> Int
forall bv.
(Bits bv, Num bv) =>
bv -> Int -> Int -> String -> String -> Int
restrictedDamerauLevenshteinDistance' (Integer
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' :: bv -> Int -> Int -> String -> String -> Int
restrictedDamerauLevenshteinDistance' bv
_bv_dummy Int
m Int
n String
str1 String
str2
  | [] <- String
str1 = Int
n
  | Bool
otherwise  = (bv, bv, bv, bv, Int) -> Int
forall a b c d e. (a, b, c, d, e) -> e
extractAnswer ((bv, bv, bv, bv, Int) -> Int) -> (bv, bv, bv, bv, Int) -> Int
forall a b. (a -> b) -> a -> b
$
                 ((bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int))
-> (bv, bv, bv, bv, Int) -> String -> (bv, bv, bv, bv, Int)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (IntMap bv
-> bv
-> bv
-> (bv, bv, bv, bv, Int)
-> Char
-> (bv, bv, bv, bv, Int)
forall bv.
(Bits bv, Num bv) =>
IntMap bv
-> bv
-> bv
-> (bv, bv, bv, bv, Int)
-> Char
-> (bv, bv, bv, bv, Int)
restrictedDamerauLevenshteinDistanceWorker
                             (String -> IntMap bv
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 bv -> Int -> bv
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
m) bv -> bv -> bv
forall a. Num a => a -> a -> a
- bv
1
    top_bit_mask :: bv
top_bit_mask = (bv
1 bv -> Int -> bv
forall a. Bits a => a -> Int -> a
`shiftL` (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) bv -> bv -> bv
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 :: 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
  = IntMap bv -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)
seq IntMap bv
str1_mvs ((bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int))
-> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)
forall a b. (a -> b) -> a -> b
$ bv -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)
seq bv
top_bit_mask ((bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int))
-> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)
forall a b. (a -> b) -> a -> b
$ bv -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)
seq bv
vector_mask ((bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int))
-> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)
forall a b. (a -> b) -> a -> b
$
    bv -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)
seq bv
pm' ((bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int))
-> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)
forall a b. (a -> b) -> a -> b
$ bv -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)
seq bv
d0' ((bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int))
-> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)
forall a b. (a -> b) -> a -> b
$ bv -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)
seq bv
vp' ((bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int))
-> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)
forall a b. (a -> b) -> a -> b
$ bv -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)
seq bv
vn' ((bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int))
-> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)
forall a b. (a -> b) -> a -> b
$
    Int -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)
seq Int
distance'' ((bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int))
-> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)
forall a b. (a -> b) -> a -> b
$ Char -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)
seq Char
char2 ((bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int))
-> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)
forall a b. (a -> b) -> a -> b
$
    (bv
pm', bv
d0', bv
vp', bv
vn', Int
distance'')
  where
    pm' :: bv
pm' = bv -> Int -> IntMap bv -> bv
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault bv
0 (Char -> Int
ord Char
char2) IntMap bv
str1_mvs

    d0' :: bv
d0' = ((((bv -> bv -> bv
forall bv. Bits bv => bv -> bv -> bv
sizedComplement bv
vector_mask bv
d0) bv -> bv -> bv
forall bv. Bits bv => bv -> bv -> bv
.&. bv
pm') bv -> Int -> bv
forall a. Bits a => a -> Int -> a
`shiftL` Int
1) bv -> bv -> bv
forall bv. Bits bv => bv -> bv -> bv
.&. bv
pm)
      bv -> bv -> bv
forall bv. Bits bv => bv -> bv -> bv
.|. ((((bv
pm' bv -> bv -> bv
forall bv. Bits bv => bv -> bv -> bv
.&. bv
vp) bv -> bv -> bv
forall a. Num a => a -> a -> a
+ bv
vp) bv -> bv -> bv
forall bv. Bits bv => bv -> bv -> bv
.&. bv
vector_mask) bv -> bv -> bv
forall bv. Bits bv => bv -> bv -> bv
`xor` bv
vp) bv -> bv -> bv
forall bv. Bits bv => bv -> bv -> bv
.|. bv
pm' bv -> bv -> bv
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 bv -> bv -> bv
forall bv. Bits bv => bv -> bv -> bv
.|. bv -> bv -> bv
forall bv. Bits bv => bv -> bv -> bv
sizedComplement bv
vector_mask (bv
d0' bv -> bv -> bv
forall bv. Bits bv => bv -> bv -> bv
.|. bv
vp)
    hn' :: bv
hn' = bv
d0' bv -> bv -> bv
forall bv. Bits bv => bv -> bv -> bv
.&. bv
vp

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

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

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

matchVectors :: (Bits bv, Num bv) => String -> IM.IntMap bv
matchVectors :: String -> IntMap bv
matchVectors = (Int, IntMap bv) -> IntMap bv
forall a b. (a, b) -> b
snd ((Int, IntMap bv) -> IntMap bv)
-> (String -> (Int, IntMap bv)) -> String -> IntMap bv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, IntMap bv) -> Char -> (Int, IntMap bv))
-> (Int, IntMap bv) -> String -> (Int, IntMap bv)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int, IntMap bv) -> Char -> (Int, IntMap bv)
forall a a.
(Bits a, Integral a, Num a) =>
(a, IntMap a) -> Char -> (a, IntMap a)
go (Int
0 :: Int, IntMap bv
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 a -> a -> a
forall a. Num a => a -> a -> a
+ a
1
                           im' :: IntMap a
im' = (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith a -> a -> a
forall bv. Bits bv => bv -> bv -> bv
(.|.) (Char -> Int
ord Char
char) (a
2 a -> a -> a
forall a b. (Num a, Integral b) => a -> b -> a
^ a
ix) IntMap a
im
                       in a -> (a, IntMap a) -> (a, IntMap a)
seq a
ix' ((a, IntMap a) -> (a, IntMap a)) -> (a, IntMap a) -> (a, IntMap a)
forall a b. (a -> b) -> a -> b
$ IntMap a -> (a, IntMap a) -> (a, IntMap a)
seq IntMap a
im' ((a, IntMap a) -> (a, IntMap a)) -> (a, IntMap a) -> (a, IntMap a)
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 = String -> [(String, String)] -> [String]
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 :: String -> [(String, a)] -> [a]
fuzzyLookup String
user_entered [(String, a)]
possibilites
  = ((a, Int) -> a) -> [(a, Int)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, Int) -> a
forall a b. (a, b) -> a
fst ([(a, Int)] -> [a]) -> [(a, Int)] -> [a]
forall a b. (a -> b) -> a -> b
$ Int -> [(a, Int)] -> [(a, Int)]
forall a. Int -> [a] -> [a]
take Int
mAX_RESULTS ([(a, Int)] -> [(a, Int)]) -> [(a, Int)] -> [(a, Int)]
forall a b. (a -> b) -> a -> b
$ ((a, Int) -> (a, Int) -> Ordering) -> [(a, Int)] -> [(a, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((a, Int) -> Int) -> (a, Int) -> (a, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (a, Int) -> Int
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
fuzzy_threshold ]
  where
    -- Work out an approriate 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 = Rational -> Int
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Rational -> Int) -> Rational -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
user_entered Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Rational -> Rational -> Rational
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 :: (a -> b -> c) -> [(a, b)] -> [c]
unzipWith a -> b -> c
f [(a, b)]
pairs = ((a, b) -> c) -> [(a, b)] -> [c]
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 :: [a] -> b -> b
seqList [] b
b = b
b
seqList (a
x:[a]
xs) b
b = a
x a -> b -> b
`seq` [a] -> b -> b
forall a b. [a] -> b -> b
seqList [a]
xs b
b


{-
************************************************************************
*                                                                      *
                        Globals and the RTS
*                                                                      *
************************************************************************

When a plugin is loaded, it currently gets linked against a *newly
loaded* copy of the GHC package. This would not be a problem, except
that the new copy has its own mutable state that is not shared with
that state that has already been initialized by the original GHC
package.

(Note that if the GHC executable was dynamically linked this
wouldn't be a problem, because we could share the GHC library it
links to; this is only a problem if DYNAMIC_GHC_PROGRAMS=NO.)

The solution is to make use of @sharedCAF@ through @sharedGlobal@
for globals that are shared between multiple copies of ghc packages.
-}

-- Global variables:

global :: a -> IORef a
global :: a -> IORef a
global a
a = IO (IORef a) -> IORef a
forall a. IO a -> a
unsafePerformIO (a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef a
a)

consIORef :: IORef [a] -> a -> IO ()
consIORef :: IORef [a] -> a -> IO ()
consIORef IORef [a]
var a
x = do
  IORef [a] -> ([a] -> ([a], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [a]
var (\[a]
xs -> (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs,()))

globalM :: IO a -> IORef a
globalM :: IO a -> IORef a
globalM IO a
ma = IO (IORef a) -> IORef a
forall a. IO a -> a
unsafePerformIO (IO a
ma IO a -> (a -> IO (IORef a)) -> IO (IORef a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef)

-- Shared global variables:

sharedGlobal :: a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a
sharedGlobal :: a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a
sharedGlobal a
a Ptr (IORef a) -> IO (Ptr (IORef a))
get_or_set = IO (IORef a) -> IORef a
forall a. IO a -> a
unsafePerformIO (IO (IORef a) -> IORef a) -> IO (IORef a) -> IORef a
forall a b. (a -> b) -> a -> b
$
  a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef a
a IO (IORef a) -> (IORef a -> IO (IORef a)) -> IO (IORef a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (IORef a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IO (IORef a))
-> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a -> IO (IORef a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip IORef a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IO (IORef a)
forall a. a -> (Ptr a -> IO (Ptr a)) -> IO a
sharedCAF Ptr (IORef a) -> IO (Ptr (IORef a))
get_or_set

sharedGlobalM :: IO a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a
sharedGlobalM :: IO a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a
sharedGlobalM IO a
ma Ptr (IORef a) -> IO (Ptr (IORef a))
get_or_set = IO (IORef a) -> IORef a
forall a. IO a -> a
unsafePerformIO (IO (IORef a) -> IORef a) -> IO (IORef a) -> IORef a
forall a b. (a -> b) -> a -> b
$
  IO a
ma IO a -> (a -> IO (IORef a)) -> IO (IORef a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef IO (IORef a) -> (IORef a -> IO (IORef a)) -> IO (IORef a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (IORef a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IO (IORef a))
-> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a -> IO (IORef a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip IORef a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IO (IORef a)
forall a. a -> (Ptr a -> IO (Ptr a)) -> IO a
sharedCAF Ptr (IORef a) -> IO (Ptr (IORef a))
get_or_set

-- 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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
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 = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isAlphaNum (String -> Bool) -> (String -> Bool) -> String -> Bool
forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<&&> Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit)) ([String] -> Bool) -> (String -> [String]) -> String -> Bool
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 (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
s of
           ([], String
_) -> String -> Either String (String, String)
forall a b. a -> Either a b
Left (String
"Couldn't find command in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s)
           (String, String)
res -> (String, String) -> Either String (String, String)
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 -> String -> Either String (String, [String])
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 -> String -> Either String (String, [String])
forall a b. a -> Either a b
Left String
err
                                 Right [String]
args -> (String, [String]) -> Either String (String, [String])
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 (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
str of
      s :: String
s@(Char
'[':String
_) -> case ReadS [String]
forall a. Read a => ReadS a
reads String
s of
                   [([String]
args, String
spaces)]
                    | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
spaces ->
                       [String] -> Either String [String]
forall a b. b -> Either a b
Right [String]
args
                   [([String], String)]
_ ->
                       String -> Either String [String]
forall a b. a -> Either a b
Left (String
"Couldn't read " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
str String -> String -> String
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 (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
s of
              [] -> [String] -> Either String [String]
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
argString -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ([String] -> [String])
-> Either String [String] -> Either String [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> Either String [String]
toArgs' String
rest
              String
s' -> case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Bool
isSpace (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<||> (Char -> Char -> 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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
argPart2)String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ([String] -> [String])
-> Either String [String] -> Either String [String]
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
argString -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ([String] -> [String])
-> Either String [String] -> Either String [String]
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 ReadS String
forall a. Read a => ReadS a
reads String
s of
                [(String
arg, String
rest)]
                    -- rest must either be [] or start with a space
                    | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
1 String
rest) ->
                    (String, String) -> Either String (String, String)
forall a b. b -> Either a b
Right (String
arg, String
rest)
                [(String, String)]
_ ->
                    String -> Either String (String, String)
forall a b. a -> Either a b
Left (String
"Couldn't read " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s String -> String -> String
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 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0                               = Maybe Integer
forall a. Maybe a
Nothing
   | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32
forall a. Bounded a => a
maxBound :: Int32) = Maybe Integer
forall a. Maybe a
Nothing
   | Int32
x' Int32 -> Int32 -> Int32
forall bv. Bits bv => bv -> bv -> bv
.&. (-Int32
x') Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int32
x'                   = Maybe Integer
forall a. Maybe a
Nothing
   | Bool
otherwise                            = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
c)
      where
         x' :: Int32
x' = Integer -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x :: Int32
         c :: Int
c = Int32 -> Int
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
n,Int
d,String
s) <- String -> [(Integer, Int, String)]
forall a. Read a => String -> [(a, Int, String)]
readFix String
r
     (Int
k,String
t)   <- String -> [(Int, String)]
forall (m :: * -> *). MonadFail m => String -> m (Int, String)
readExp String
s
     (Rational, String) -> [(Rational, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Integer
nInteger -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
1)Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
10Rational -> Int -> Rational
forall a b. (Fractional a, Integral b) => a -> b -> a
^^(Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
d), String
t)
 where
     readFix :: String -> [(a, Int, String)]
readFix String
r = do
        (String
ds,String
s)  <- ReadS String
lexDecDigits String
r
        (String
ds',String
t) <- ReadS String
forall (m :: * -> *). Monad m => String -> m (String, String)
lexDotDigits String
s
        (a, Int, String) -> [(a, Int, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> a
forall a. Read a => String -> a
read (String
dsString -> String -> String
forall a. [a] -> [a] -> [a]
++String
ds'), String -> Int
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 Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"eE" = String -> m (Int, String)
forall (m :: * -> *). MonadFail m => String -> m (Int, String)
readExp' String
s
     readExp String
s                     = (Int, String) -> m (Int, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
0,String
s)

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

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

     lexDecDigits :: ReadS String
lexDecDigits = (Char -> Bool) -> ReadS String
forall (m :: * -> *).
MonadFail m =>
(Char -> Bool) -> String -> m (String, String)
nonnull Char -> Bool
isDigit

     lexDotDigits :: String -> m (String, String)
lexDotDigits (Char
'.':String
s) = (String, String) -> m (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Char -> Bool) -> String -> (String, String)
span' Char -> Bool
isDigit String
s)
     lexDotDigits String
s       = (String, String) -> m (String, String)
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) <- (String, String) -> m (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Char -> Bool) -> String -> (String, String)
span' Char -> Bool
p String
s)
                      (String, String) -> m (String, String)
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 Char -> Char -> Bool
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
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
ys,String
zs)
               | Bool
otherwise =  ([],String
xs)

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 ; Rational -> [Rational]
forall (m :: * -> *) a. Monad m => a -> m a
return Rational
x }) of
          [Rational
x] -> Rational
x
          []  -> String -> Rational
forall a. HasCallStack => String -> a
error (String
"readRational: no parse:"        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
top_s)
          [Rational]
_   -> String -> Rational
forall a. HasCallStack => String -> a
error (String
"readRational: ambiguous parse:" String -> String -> String
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
_      -> String -> Rational
forall a. HasCallStack => String -> a
error (String
"readHexRational: no parse:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str)


readHexRational__ :: String -> Maybe Rational
readHexRational__ :: String -> Maybe Rational
readHexRational__ (Char
'0' : Char
x : String
rest)
  | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'X' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
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
     Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
front))
     let frontNum :: Integer
frontNum = Integer -> Integer -> String -> Integer
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
             Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
back))
             let backNum :: Integer
backNum = Integer -> Integer -> String -> Integer
forall (t :: * -> *) b.
(Foldable t, Num b) =>
b -> b -> t Char -> b
steps Integer
16 Integer
frontNum String
back
                 exp1 :: Int
exp1    = -Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
back
             case String
rest4 of
               Char
p : String
ps | Char -> Bool
isExp Char
p -> (Int -> Rational) -> Maybe Int -> Maybe Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> Int -> Rational
mk Integer
backNum (Int -> Rational) -> (Int -> Int) -> Int -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
exp1)) (String -> Maybe Int
forall a. Num a => String -> Maybe a
getExp String
ps)
               String
_ -> Rational -> Maybe Rational
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 -> (Int -> Rational) -> Maybe Int -> Maybe Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> Int -> Rational
mk Integer
frontNum) (String -> Maybe Int
forall a. Num a => String -> Maybe a
getExp String
ps)
       String
_ -> Maybe Rational
forall a. Maybe a
Nothing

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

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

  mk :: Integer -> Int -> Rational
  mk :: Integer -> Int -> Rational
mk Integer
n Int
e = Integer -> Rational
forall a. Num a => Integer -> a
fromInteger Integer
n Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
2Rational -> Int -> Rational
forall 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 (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ds) -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> a -> String -> a
forall (t :: * -> *) b.
(Foldable t, Num b) =>
b -> b -> t Char -> b
steps a
10 a
0 String
ds)
             (String, String)
_ -> Maybe a
forall a. Maybe a
Nothing

  steps :: b -> b -> t Char -> b
steps b
base b
n t Char
ds = (b -> Char -> b) -> b -> t Char -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (b -> b -> Char -> b
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 a -> a -> a
forall a. Num a => a -> a -> a
* a
n a -> a -> a
forall a. Num a => a -> a -> a
+ Int -> 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 Char -> Char -> Bool
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
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
ys,String
zs)
            | Bool
otherwise =  ([],String
xs)

readHexRational__ String
_ = Maybe Rational
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
  (do UTCTime
t <- String -> IO UTCTime
getModificationUTCTime String
f; Maybe UTCTime -> IO (Maybe UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
t))
        IO (Maybe UTCTime)
-> (IOException -> IO (Maybe UTCTime)) -> IO (Maybe UTCTime)
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
e -> if IOException -> Bool
isDoesNotExistError IOException
e
                        then Maybe UTCTime -> IO (Maybe UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCTime
forall a. Maybe a
Nothing
                        else IOException -> IO (Maybe UTCTime)
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 :: String -> (String -> m a) -> m a
withAtomicRename String
targetFile String -> m a
f
  | Bool
enableAtomicRename = 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
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
renameFile String
temp String
targetFile
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

  | Bool
otherwise = String -> m a
f String
targetFile
  where
    -- As described in #16450, enabling this causes spurious build failures due
    -- to apparently missing files.
    enableAtomicRename :: Bool
#if defined(mingw32_BUILD_OS)
    enableAtomicRename = False
#else
    enableAtomicRename :: Bool
enableAtomicRename = Bool
True
#endif

-- --------------------------------------------------------------
-- 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
  | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
r_pre = (String
str,           [])
  | Bool
otherwise  = (String -> String
forall a. [a] -> [a]
reverse (String -> String
forall a. [a] -> [a]
tail String
r_pre), String -> String
forall a. [a] -> [a]
reverse String
r_suf)
                           -- 'tail' drops the char satisfying 'pred'
  where (String
r_suf, String
r_pre) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
pred (String -> String
forall a. [a] -> [a]
reverse String
str)

escapeSpaces :: String -> String
escapeSpaces :: String -> String
escapeSpaces = (Char -> String -> String) -> String -> String -> String
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
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s else Char
cChar -> String -> String
forall 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 Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
f String
xs
          f (Char
'\\' : String
xs) = Char
slash Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
f String
xs
          f (Char
x    : String
xs) = Char
x     Char -> String -> String
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 ([String] -> String) -> [String] -> String
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
y = [String] -> [String] -> [String]
f [String]
xs [String]
ys
          f [String]
xs [String]
ys = Int -> String -> [String]
forall a. Int -> a -> [a]
replicate ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ys) String
".." [String] -> [String] -> [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:"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nString -> String -> String
forall 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 (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w) of
        Char
'\"' -> String
"\\\""
        Char
'\'' -> String
"\\\'"
        Char
'\\' -> String
"\\\\"
        Char
c | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
' ' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'~' -> [Char
c]
          | Bool
otherwise -> [Char
'\\',
                         Int -> Char
chr (Char -> Int
ord Char
'0' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
c Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
64),
                         Int -> Char
chr (Char -> Int
ord Char
'0' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
c Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8),
                         Int -> Char
chr (Char -> Int
ord Char
'0' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
c         Int -> Int -> Int
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 = (Int32 -> Char -> Int32) -> Int32 -> String -> Int32
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 = Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c) Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
magic Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32 -> Int32
hashInt32 Int32
m
         magic :: Int32
magic = Word32 -> Int32
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 Int32 -> Int32 -> Int32
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 = Int64 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
r Int64 -> Int -> Int64
forall a. Bits a => a -> Int -> a
`shiftR` Int
32)
   where r :: Int64
         r :: Int64
r = Int32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
a Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int32 -> Int64
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
(Int -> OverridingBool -> String -> String)
-> (OverridingBool -> String)
-> ([OverridingBool] -> String -> String)
-> Show OverridingBool
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