-- (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, ncgDebugIsOn,
        ghciTablesNextToCode,
        isWindowsHost, isDarwinHost,

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

        zipWithLazy, zipWith3Lazy,

        filterByList, filterByLists, partitionByList,

        unzipWith,

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

        dropWhileEndLE, spanEnd, last2,

        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,

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

        -- * For loop
        nTimes,

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

        -- * read helpers
        maybeRead, maybeReadFuzzy,

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

        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 GHC.Exts
import GHC.Stack (HasCallStack)

import Control.Applicative ( liftA2 )
import Control.Monad    ( liftM, guard )
import GHC.Conc.Sync ( sharedCAF )
import System.IO.Error as IO ( isDoesNotExistError )
import System.Directory ( doesDirectoryExist, getModificationTime )
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(GHCI)
ghciSupported = True
#else
ghciSupported :: Bool
ghciSupported = Bool
False
#endif

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

ncgDebugIsOn :: Bool
#if defined(NCG_DEBUG)
ncgDebugIsOn = True
#else
ncgDebugIsOn :: Bool
ncgDebugIsOn = 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{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 0 _ = a -> a
forall a. a -> a
id
nTimes 1 f :: a -> a
f = a -> a
f
nTimes n :: Int
n f :: 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
-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
a,_,_) =  a
a
sndOf3 :: (a, b, c) -> b
sndOf3      (_,b :: b
b,_) =  b
b
thdOf3 :: (a, b, c) -> c
thdOf3      (_,_,c :: c
c) =  c
c

fst3 :: (a -> d) -> (a, b, c) -> (d, b, c)
fst3 :: (a -> d) -> (a, b, c) -> (d, b, c)
fst3 f :: a -> d
f (a :: a
a, b :: b
b, c :: 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 f :: b -> d
f (a :: a
a, b :: b
b, c :: 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 f :: c -> d
f (a :: a
a, b :: b
b, c :: 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 f :: a -> b -> c -> d
f (a :: a
a, b :: b
b, c :: 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 f :: a -> b
f (a :: a
a,c :: c
c) = (a -> b
f a
a, c
c)

liftSnd :: (a -> b) -> (c, a) -> (c, b)
liftSnd :: (a -> b) -> (c, a) -> (c, b)
liftSnd f :: a -> b
f (c :: c
c,a :: 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 f :: a -> m c
f (x :: a
x, y :: b
y) = (c -> (c, b)) -> m c -> m (c, b)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\x' :: 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 f :: a -> m d
f (x :: a
x, y :: b
y, z :: 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 (\x' :: 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 f :: b -> m c
f (x :: a
x, y :: 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 _ [] = []
filterOut p :: a -> Bool
p (x :: a
x:xs :: [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 _ [] = ([],[])
partitionWith f :: a -> Either b c
f (x :: a
x:xs :: [a]
xs) = case a -> Either b c
f a
x of
                         Left  b :: b
b -> (b
bb -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
bs, [c]
cs)
                         Right c :: c
c -> ([b]
bs, c
cc -> [c] -> [c]
forall a. a -> [a] -> [a]
:[c]
cs)
    where (bs :: [b]
bs,cs :: [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 xs :: [a]
xs ys :: [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      _ = [a] -> [b] -> [(a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip
zipWithEqual :: String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual  _ = (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 _ = (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 _ = (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 []     _       = []
zipLazy (x :: a
x:xs :: [a]
xs) ~(y :: b
y:ys :: [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 _ []     _       = []
zipWithLazy f :: a -> b -> c
f (a :: a
a:as :: [a]
as) ~(b :: b
b:bs :: [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 _ []     _       _       = []
zipWith3Lazy f :: a -> b -> c -> d
f (a :: a
a:as :: [a]
as) ~(b :: b
b:bs :: [b]
bs) ~(c :: c
c:cs :: [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 (True:bs :: [Bool]
bs)  (x :: a
x:xs :: [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 (False:bs :: [Bool]
bs) (_:xs :: [a]
xs) =     [Bool] -> [a] -> [a]
forall a. [Bool] -> [a] -> [a]
filterByList [Bool]
bs [a]
xs
filterByList _          _      = []

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

-- | 'partitionByList' takes a list of Bools and a list of some elements and
-- partitions the list according to the list of Bools. Elements corresponding
-- to 'True' go to the left; elements corresponding to 'False' go to the right.
-- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@
-- This function does not check whether the lists have equal
-- length.
partitionByList :: [Bool] -> [a] -> ([a], [a])
partitionByList :: [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 trues :: [a]
trues falses :: [a]
falses (True  : bs :: [Bool]
bs) (x :: a
x : xs :: [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 trues :: [a]
trues falses :: [a]
falses (False : bs :: [Bool]
bs) (x :: a
x : xs :: [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 trues :: [a]
trues falses :: [a]
falses _ _ = ([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 _ _ _ []     _ = []
stretchZipWith p :: a -> Bool
p z :: b
z f :: a -> b -> c
f (x :: a
x:xs :: [a]
xs) ys :: [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
                []     -> []
                (y :: b
y:ys :: [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 f :: a -> c
f xys :: [(a, b)]
xys = [(a -> c
f a
x, b
y) | (x :: a
x,y :: b
y) <- [(a, b)]
xys]
mapSnd :: (b -> c) -> [(a, b)] -> [(a, c)]
mapSnd f :: b -> c
f xys :: [(a, b)]
xys = [(a
x, b -> c
f b
y) | (x :: a
x,y :: b
y) <- [(a, b)]
xys]

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

mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip _ [] = ([], [])
mapAndUnzip f :: a -> (b, c)
f (x :: a
x:xs :: [a]
xs)
  = let (r1 :: b
r1,  r2 :: c
r2)  = a -> (b, c)
f a
x
        (rs1 :: [b]
rs1, rs2 :: [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 _ [] = ([], [], [])
mapAndUnzip3 f :: a -> (b, c, d)
f (x :: a
x:xs :: [a]
xs)
  = let (r1 :: b
r1,  r2 :: c
r2,  r3 :: d
r3)  = a -> (b, c, d)
f a
x
        (rs1 :: [b]
rs1, rs2 :: [c]
rs2, rs3 :: [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 f :: a -> b -> (c, d)
f (a :: a
a:as :: [a]
as) (b :: b
b:bs :: [b]
bs)
  = let (r1 :: c
r1,  r2 :: d
r2)  = a -> b -> (c, d)
f a
a b
b
        (rs1 :: [c]
rs1, rs2 :: [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 _ _ _ = ([],[])

-- | 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 :: [a]
as) (b :: b
b:bs :: [b]
bs)
  = let (rs1 :: [a]
rs1, rs2 :: [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 _ _ = ([],[])

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 f :: s1 -> s2 -> a -> (s1, s2, b)
f s1 :: s1
s1 s2 :: s2
s2 xs :: [a]
xs = (s1
s1', s2
s2', [b]
ys)
  where ((s1' :: s1
s1', s2' :: s2
s2'), ys :: [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
s1, s2 :: s2
s2) x :: a
x -> case s1 -> s2 -> a -> (s1, s2, b)
f s1
s1 s2
s2 a
x of
                                                       (s1' :: s1
s1', s2' :: s2
s2', y :: b
y) -> ((s1
s1', s2
s2'), b
y))
                                     (s1
s1, s2
s2) [a]
xs

nOfThem :: Int -> a -> [a]
nOfThem :: Int -> a -> [a]
nOfThem n :: Int
n thing :: a
thing = Int -> a -> [a]
forall a. Int -> a -> [a]
replicate Int
n a
thing

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

-- Some special cases of atLength:

-- | @(lengthExceeds xs n) = (length xs > n)@
lengthExceeds :: [a] -> Int -> Bool
lengthExceeds :: [a] -> Int -> Bool
lengthExceeds lst :: [a]
lst n :: Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 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 lst :: [a]
lst n :: Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 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 lst :: [a]
lst n :: Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 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 lst :: [a]
lst n :: Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 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 _      = Ordering
GT

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

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

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

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

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

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

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

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

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

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

# ifndef DEBUG
isIn :: String -> a -> [a] -> Bool
isIn    _msg :: String
_msg x :: a
x ys :: [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 _msg :: String
_msg x :: a
x ys :: [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 _ [] = []
chunkList n :: Int
n xs :: [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 (as :: [a]
as,bs :: [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 []     _  = String -> [a]
forall a. String -> a
panic "changeLast"
changeLast [_]    x :: a
x  = [a
x]
changeLast (x :: a
x:xs :: [a]
xs) x' :: 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'

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

minWith :: Ord b => (a -> b) -> [a] -> a
minWith :: (a -> b) -> [a] -> a
minWith get_key :: a -> b
get_key xs :: [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 xs :: [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 _ [] = []
    go s :: Set a
s (x :: a
x:xs :: [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 succ :: a -> [a]
succ eq :: a -> a -> Bool
eq xs :: [a]
xs
 = [a] -> [a] -> [a]
go [] [a]
xs
 where
   go :: [a] -> [a] -> [a]
go done :: [a]
done []                      = [a]
done
   go done :: [a]
done (x :: a
x:xs :: [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)

   _ is_in :: a -> [a] -> Bool
`is_in` []                 = Bool
False
   x :: a
x `is_in` (y :: a
y:ys :: [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 _ z :: acc
z [] [] = acc
z
foldl2 k :: acc -> a -> b -> acc
k z :: acc
z (a :: a
a:as :: [a]
as) (b :: b
b:bs :: [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 _ _ _      _      = String -> acc
forall a. String -> a
panic "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 _ []     []     = Bool
True
all2 p :: a -> b -> Bool
p (x :: a
x:xs :: [a]
xs) (y :: b
y:ys :: [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 _ _      _      = Bool
False

-- Count the number of times a predicate is true

count :: (a -> Bool) -> [a] -> Int
count :: (a -> Bool) -> [a] -> Int
count p :: a -> Bool
p = Int -> [a] -> Int
forall t. Num t => t -> [a] -> t
go 0
  where go :: t -> [a] -> t
go !t
n [] = t
n
        go !t
n (x :: a
x:xs :: [a]
xs) | a -> Bool
p a
x       = t -> [a] -> t
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
+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 p :: a -> Bool
p = Int -> [a] -> Int
forall p. Num p => p -> [a] -> p
go 0
  where go :: p -> [a] -> p
go !p
n (x :: a
x:xs :: [a]
xs) | a -> Bool
p a
x = p -> [a] -> p
go (p
np -> p -> p
forall a. Num a => a -> a -> a
+1) [a]
xs
        go !p
n _            = 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 [] _ = []
takeList (_:xs :: [b]
xs) ls :: [a]
ls =
   case [a]
ls of
     [] -> []
     (y :: a
y:ys :: [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 [] xs :: [a]
xs    = [a]
xs
dropList _  xs :: [a]
xs@[] = [a]
xs
dropList (_:xs :: [b]
xs) (_:ys :: [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 [] xs :: [a]
xs     = ([], [a]
xs)
splitAtList _ xs :: [a]
xs@[]   = ([a]
xs, [a]
xs)
splitAtList (_:xs :: [b]
xs) (y :: a
y:ys :: [a]
ys) = (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys', [a]
ys'')
    where
      (ys' :: [a]
ys', 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 n :: Int
n xs :: [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 (_:ys :: [a]
ys) (x :: a
x:xs :: [a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
go [a]
ys [a]
xs
    go _      _      = []  -- 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 p :: a -> Bool
p = (a -> [a] -> [a]) -> [a] -> [a] -> [a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\x :: a
x r :: [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 p :: a -> Bool
p l :: [a]
l = [a] -> [a] -> [a] -> [a] -> ([a], [a])
go [a]
l [] [] [a]
l
  where go :: [a] -> [a] -> [a] -> [a] -> ([a], [a])
go yes :: [a]
yes _rev_yes :: [a]
_rev_yes rev_no :: [a]
rev_no [] = ([a]
yes, [a] -> [a]
forall a. [a] -> [a]
reverse [a]
rev_no)
        go yes :: [a]
yes rev_yes :: [a]
rev_yes  rev_no :: [a]
rev_no (x :: a
x:xs :: [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' (\(_,x2 :: a
x2) x :: 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 "last2 - list length less than two"

snocView :: [a] -> Maybe ([a],a)
        -- Split off the last element
snocView :: [a] -> Maybe ([a], a)
snocView [] = Maybe ([a], a)
forall a. Maybe a
Nothing
snocView xs :: [a]
xs = [a] -> [a] -> Maybe ([a], a)
forall a. [a] -> [a] -> Maybe ([a], a)
go [] [a]
xs
            where
                -- Invariant: second arg is non-empty
              go :: [a] -> [a] -> Maybe ([a], a)
go acc :: [a]
acc [x :: a
x]    = ([a], a) -> Maybe ([a], a)
forall a. a -> Maybe a
Just ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
acc, a
x)
              go acc :: [a]
acc (x :: a
x:xs :: [a]
xs) = [a] -> [a] -> Maybe ([a], a)
go (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
acc) [a]
xs
              go _   []     = String -> Maybe ([a], a)
forall a. String -> a
panic "Util: snocView"

split :: Char -> String -> [String]
split :: Char -> String -> [String]
split c :: Char
c s :: String
s = case String
rest of
                []     -> [String
chunk]
                _:rest :: String
rest -> String
chunk String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Char -> String -> [String]
split Char
c String
rest
  where (chunk :: String
chunk, rest :: 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 (c :: Char
c:cs :: 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 GT = Bool
False
isEqual EQ = Bool
True
isEqual LT = Bool
False

thenCmp :: Ordering -> Ordering -> Ordering
{-# INLINE thenCmp #-}
thenCmp :: Ordering -> Ordering -> Ordering
thenCmp EQ       ordering :: 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 _  []     []     = Bool
True
eqListBy eq :: a -> a -> Bool
eq (x :: a
x:xs :: [a]
xs) (y :: a
y:ys :: [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 _  _      _      = Bool
False

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

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

cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
cmpList _   []     [] = Ordering
EQ
cmpList _   []     _  = Ordering
LT
cmpList _   _      [] = Ordering
GT
cmpList cmp :: a -> a -> Ordering
cmp (a :: a
a:as :: [a]
as) (b :: a
b:bs :: [a]
bs)
  = case a -> a -> Ordering
cmp a
a a
b of { EQ -> (a -> a -> Ordering) -> [a] -> [a] -> Ordering
forall a. (a -> a -> Ordering) -> [a] -> [a] -> Ordering
cmpList a -> a -> Ordering
cmp [a]
as [a]
bs; xxx :: 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 str1 :: String
str1 str2 :: 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 m :: Int
m n :: Int
n str1 :: String
str1 str2 :: 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
<= 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
<= 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_dummy :: bv
_bv_dummy m :: Int
m n :: Int
n str1 :: String
str1 str2 :: 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)
                        (0, 0, bv
m_ones, 0, Int
m) String
str2
  where
    m_ones :: bv
m_ones@bv
vector_mask = (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
- 1
    top_bit_mask :: bv
top_bit_mask = (1 bv -> Int -> bv
forall a. Bits a => a -> Int -> a
`shiftL` (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)) bv -> bv -> bv
forall a. a -> a -> a
`asTypeOf` bv
_bv_dummy
    extractAnswer :: (a, b, c, d, e) -> e
extractAnswer (_, _, _, _, distance :: 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 str1_mvs :: IntMap bv
str1_mvs top_bit_mask :: bv
top_bit_mask vector_mask :: bv
vector_mask
                                           (pm :: bv
pm, d0 :: bv
d0, vp :: bv
vp, vn :: bv
vn, distance :: Int
distance) char2 :: Char
char2
  = IntMap bv -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)
forall a b. a -> b -> b
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)
forall a b. a -> b -> b
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)
forall a b. a -> b -> b
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)
forall a b. a -> b -> b
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)
forall a b. a -> b -> b
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)
forall a b. a -> b -> b
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)
forall a b. a -> b -> b
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)
forall a b. a -> b -> b
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)
forall a b. a -> b -> b
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 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` 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` 1) bv -> bv -> bv
forall bv. Bits 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` 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
/= 0 then Int
distance Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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
/= 0 then Int
distance' Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1 else Int
distance'

sizedComplement :: Bits bv => bv -> bv -> bv
sizedComplement :: bv -> bv -> bv
sizedComplement vector_mask :: bv
vector_mask vect :: 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 (0 :: Int, IntMap bv
forall a. IntMap a
IM.empty)
  where
    go :: (a, IntMap a) -> Char -> (a, IntMap a)
go (ix :: a
ix, im :: IntMap a
im) char :: Char
char = let ix' :: a
ix' = a
ix a -> a -> a
forall a. Num 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) (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)
forall a b. a -> b -> b
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)
forall a b. a -> b -> b
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 key :: String
key vals :: [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 user_entered :: String
user_entered possibilites :: [(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) | (poss_str :: String
poss_str, poss_val :: 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
+ 2) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ (4 :: Rational)
    mAX_RESULTS :: Int
mAX_RESULTS = 3

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

unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
unzipWith f :: a -> b -> c
f pairs :: [(a, b)]
pairs = ((a, b) -> c) -> [(a, b)] -> [c]
forall a b. (a -> b) -> [a] -> [b]
map ( \ (a :: a
a, b :: 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
b
seqList (x :: a
x:xs :: [a]
xs) b :: b
b = a
x a -> b -> b
forall a b. 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
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 var :: IORef [a]
var x :: a
x = do
  IORef [a] -> ([a] -> ([a], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [a]
var (\xs :: [a]
xs -> (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs,()))

globalM :: IO a -> IORef a
globalM :: IO a -> IORef a
globalM ma :: 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
a get_or_set :: 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 ma :: IO a
ma get_or_set :: 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 (c :: Char
c:cs :: String
cs) = Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
&& String -> Bool
go String
cs
  where go :: String -> Bool
go [] = Bool
True
        go ('.':cs :: String
cs) = String -> Bool
looksLikeModuleName String
cs
        go (c :: Char
c:cs :: String
cs)   = (Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\'') 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 '-'

{-
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 s :: 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 -> Either String (String, String)
forall a b. a -> Either a b
Left ("Couldn't find command in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s)
           res :: (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 s :: String
s = case String -> Either String (String, String)
getCmd String
s of
              Left err :: String
err -> String -> Either String (String, [String])
forall a b. a -> Either a b
Left String
err
              Right (cmd :: String
cmd, s' :: String
s') -> case String -> Either String [String]
toArgs String
s' of
                                 Left err :: String
err -> String -> Either String (String, [String])
forall a b. a -> Either a b
Left String
err
                                 Right args :: [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 str :: String
str
    = case (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
str of
      s :: String
s@('[':_) -> case ReadS [String]
forall a. Read a => ReadS a
reads String
s of
                   [(args :: [String]
args, spaces :: 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 -> Either String [String]
forall a b. a -> Either a b
Left ("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]
++ " as [String]")
      s :: 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' s :: 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 []
              ('"' : _) -> do
                    -- readAsString removes outer quotes
                    (arg :: String
arg, rest :: 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
              s' :: 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
== '"')) String
s' of
                    (argPart1 :: String
argPart1, s'' :: String
s''@('"':_)) -> do
                        (argPart2 :: String
argPart2, rest :: 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
                    (arg :: String
arg, s'' :: 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 s :: String
s = case ReadS String
forall a. Read a => ReadS a
reads String
s of
                [(arg :: String
arg, rest :: 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 1 String
rest) ->
                    (String, String) -> Either String (String, String)
forall a b. b -> Either a b
Right (String
arg, String
rest)
                _ ->
                    String -> Either String (String, String)
forall a b. a -> Either a b
Left ("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]
++ " as String")
-----------------------------------------------------------------------------
-- Integers

-- This algorithm for determining the $\log_2$ of exact powers of 2 comes
-- from GCC.  It requires bit manipulation primitives, and we use GHC
-- extensions.  Tough.

exactLog2 :: Integer -> Maybe Integer
exactLog2 :: Integer -> Maybe Integer
exactLog2 x :: Integer
x
  = if (Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 Bool -> Bool -> Bool
|| Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= 2147483648) then
       Maybe Integer
forall a. Maybe a
Nothing
    else
       if (Integer
x Integer -> Integer -> Integer
forall bv. Bits bv => bv -> bv -> bv
.&. (-Integer
x)) Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
x then
          Maybe Integer
forall a. Maybe a
Nothing
       else
          Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Integer
forall t p. (Num t, Num p, Bits t) => t -> p
pow2 Integer
x)
  where
    pow2 :: t -> p
pow2 x :: t
x | t
x t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== 1 = 0
           | Bool
otherwise = 1 p -> p -> p
forall a. Num a => a -> a -> a
+ t -> p
pow2 (t
x t -> Int -> t
forall a. Bits a => a -> Int -> a
`shiftR` 1)


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

readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
readRational__ :: ReadS Rational
readRational__ r :: String
r = do
     (n :: Integer
n,d :: Int
d,s :: String
s) <- String -> [(Integer, Int, String)]
forall a. Read a => String -> [(a, Int, String)]
readFix String
r
     (k :: Int
k,t :: 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
%1)Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*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 r :: String
r = do
        (ds :: String
ds,s :: String
s)  <- ReadS String
lexDecDigits String
r
        (ds' :: String
ds',t :: 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 (e :: Char
e:s :: String
s) | Char
e Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` "eE" = String -> m (Int, String)
forall (m :: * -> *). MonadFail m => String -> m (Int, String)
readExp' String
s
     readExp s :: String
s                     = (Int, String) -> m (Int, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (0,String
s)

     readExp' :: String -> m (Int, String)
readExp' ('+':s :: String
s) = String -> m (Int, String)
forall (m :: * -> *). MonadFail m => String -> m (Int, String)
readDec String
s
     readExp' ('-':s :: String
s) = do (k :: Int
k,t :: 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' s :: String
s       = String -> m (Int, String)
forall (m :: * -> *). MonadFail m => String -> m (Int, String)
readDec String
s

     readDec :: String -> m (Int, String)
readDec s :: String
s = do
        (ds :: String
ds,r :: 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 (\n :: Int
n d :: Int
d -> Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* 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 '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 ('.':s :: 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 s :: String
s       = (String, String) -> m (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ("",String
s)

     nonnull :: (Char -> Bool) -> String -> m (String, String)
nonnull p :: Char -> Bool
p s :: String
s = do (cs :: String
cs@(_:_),t :: 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' _ xs :: String
xs@[]         =  (String
xs, String
xs)
     span' p :: Char -> Bool
p xs :: String
xs@(x :: Char
x:xs' :: String
xs')
               | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_'  = (Char -> Bool) -> String -> (String, String)
span' Char -> Bool
p String
xs'   -- skip "_" (#14473)
               | Char -> Bool
p Char
x       =  let (ys :: String
ys,zs :: 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 top_s :: String
top_s
  = case String
top_s of
      '-' : xs :: String
xs -> - (String -> Rational
read_me String
xs)
      xs :: String
xs       -> String -> Rational
read_me String
xs
  where
    read_me :: String -> Rational
read_me s :: String
s
      = case (do { (x :: Rational
x,"") <- ReadS Rational
readRational__ String
s ; Rational -> [Rational]
forall (m :: * -> *) a. Monad m => a -> m a
return Rational
x }) of
          [x :: Rational
x] -> Rational
x
          []  -> String -> Rational
forall a. HasCallStack => String -> a
error ("readRational: no parse:"        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
top_s)
          _   -> String -> Rational
forall a. HasCallStack => String -> a
error ("readRational: ambiguous parse:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
top_s)


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


readHexRational__ :: String -> Maybe Rational
readHexRational__ :: String -> Maybe Rational
readHexRational__ ('0' : x :: Char
x : rest :: String
rest)
  | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'X' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'x' =
  do let (front :: String
front,rest2 :: 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 16 0 String
front
     case String
rest2 of
       '.' : rest3 :: String
rest3 ->
          do let (back :: String
back,rest4 :: 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 16 Integer
frontNum String
back
                 exp1 :: Int
exp1    = -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
               p :: Char
p : ps :: 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)
               _ -> Rational -> Maybe Rational
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Int -> Rational
mk Integer
backNum Int
exp1)
       p :: Char
p : ps :: 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)
       _ -> Maybe Rational
forall a. Maybe a
Nothing

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

  getExp :: String -> Maybe a
getExp ('+' : ds :: String
ds) = String -> Maybe a
forall a. Num a => String -> Maybe a
dec String
ds
  getExp ('-' : ds :: 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 ds :: String
ds         = String -> Maybe a
forall a. Num a => String -> Maybe a
dec String
ds

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

  dec :: String -> Maybe a
dec cs :: String
cs = case (Char -> Bool) -> String -> (String, String)
span' Char -> Bool
isDigit String
cs of
             (ds :: String
ds,"") | 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 10 0 String
ds)
             _ -> Maybe a
forall a. Maybe a
Nothing

  steps :: b -> b -> t Char -> b
steps base :: b
base n :: b
n ds :: 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  base :: a
base n :: a
n d :: 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' _ xs :: String
xs@[]         =  (String
xs, String
xs)
  span' p :: Char -> Bool
p xs :: String
xs@(x :: Char
x:xs' :: String
xs')
            | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_'  = (Char -> Bool) -> String -> (String, String)
span' Char -> Bool
p String
xs'   -- skip "_"  (#14473)
            | Char -> Bool
p Char
x       =  let (ys :: String
ys,zs :: 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__ _ = Maybe Rational
forall a. Maybe a
Nothing




-----------------------------------------------------------------------------
-- read helpers

maybeRead :: Read a => String -> Maybe a
maybeRead :: String -> Maybe a
maybeRead str :: String
str = case ReadS a
forall a. Read a => ReadS a
reads String
str of
                [(x :: a
x, "")] -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
                _         -> Maybe a
forall a. Maybe a
Nothing

maybeReadFuzzy :: Read a => String -> Maybe a
maybeReadFuzzy :: String -> Maybe a
maybeReadFuzzy str :: String
str = case ReadS a
forall a. Read a => ReadS a
reads String
str of
                     [(x :: a
x, s :: String
s)]
                      | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
s ->
                         a -> Maybe a
forall a. a -> Maybe a
Just a
x
                     _ ->
                         Maybe a
forall a. Maybe a
Nothing

-----------------------------------------------------------------------------
-- Verify that the 'dirname' portion of a FilePath exists.
--
doesDirNameExist :: FilePath -> IO Bool
doesDirNameExist :: String -> IO Bool
doesDirNameExist fpath :: 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 f :: 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` \e :: 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

-- --------------------------------------------------------------
-- 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 str :: String
str pred :: 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 (r_suf :: String
r_suf, r_pre :: 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 (\c :: Char
c s :: String
s -> if Char -> Bool
isSpace Char
c then '\\'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) ""

type Suffix = String

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

data Direction = Forwards | Backwards

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

makeRelativeTo :: FilePath -> FilePath -> FilePath
this :: String
this makeRelativeTo :: String -> String -> String
`makeRelativeTo` that :: String
that = String
directory String -> String -> String
</> String
thisFilename
    where (thisDirectory :: String
thisDirectory, thisFilename :: 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 (x :: String
x : xs :: [String]
xs) (y :: String
y : ys :: [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 xs :: [String]
xs ys :: [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]
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 n :: String
n = DataType -> String -> [String] -> Fixity -> Constr
mkConstr (String -> DataType
abstractDataType String
n) ("{abstract:"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nString -> String -> String
forall a. [a] -> [a] -> [a]
++"}") [] Fixity
Prefix

abstractDataType :: String -> DataType
abstractDataType :: String -> DataType
abstractDataType n :: 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 w :: Word8
w =
  case Int -> Char
chr (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w) of
        '\"' -> "\\\""
        '\'' -> "\\\'"
        '\\' -> "\\\\"
        c :: Char
c | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= ' ' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '~' -> [Char
c]
          | Bool
otherwise -> ['\\',
                         Int -> Char
chr (Char -> Int
ord '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` 64),
                         Int -> Char
chr (Char -> Int
ord '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` 8 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` 8),
                         Int -> Char
chr (Char -> Int
ord '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` 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 m :: Int32
m c :: 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 (0xdeadbeef :: Word32)

golden :: Int32
golden :: Int32
golden = 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 x :: 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 a :: Int32
a b :: 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` 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 b :: Bool
b Auto   = Bool
b
overrideWith _ Always = Bool
True
overrideWith _ Never  = Bool
False