-- (c) The University of Glasgow 2006 {-# LANGUAGE CPP #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MagicHash #-} -- | Highly random utility functions -- module GHC.Utils.Misc ( -- * Miscellaneous higher-order functions applyWhen, nTimes, const2, -- * General list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, stretchZipWith, zipWithAndUnzip, zipAndUnzip, filterByList, filterByLists, partitionByList, unzipWith, mapFst, mapSnd, chkAppend, mapAndUnzip, mapAndUnzip3, filterOut, partitionWith, dropWhileEndLE, spanEnd, last2, lastMaybe, onJust, List.foldl1', foldl2, count, countWhile, all2, lengthExceeds, lengthIs, lengthIsNot, lengthAtLeast, lengthAtMost, lengthLessThan, listLengthCmp, atLength, equalLength, compareLength, leLength, ltLength, isSingleton, only, expectOnly, GHC.Utils.Misc.singleton, notNull, snocView, chunkList, holes, changeLast, mapLastM, whenNonEmpty, mergeListsBy, isSortedBy, -- Foldable generalised functions, mapMaybe', -- * Tuples fstOf3, sndOf3, thdOf3, fst3, snd3, third3, uncurry3, -- * List operations controlled by another list takeList, dropList, splitAtList, split, dropTail, capitalise, -- * Sorting sortWith, minWith, nubSort, ordNub, ordNubOn, -- * Comparisons isEqual, removeSpaces, (<&&>), (<||>), -- * Edit distance fuzzyMatch, fuzzyLookup, -- * Transitive closures transitiveClosure, -- * Strictness seqList, strictMap, strictZipWith, strictZipWith3, -- * Module names looksLikeModuleName, looksLikePackageName, -- * Integers exactLog2, -- * Floating point readRational, readSignificandExponentPair, readHexRational, readHexSignificandExponentPair, -- * IO-ish utilities doesDirNameExist, getModificationUTCTime, modificationTimeIfExists, fileHashIfExists, withAtomicRename, -- * Filenames and paths Suffix, splitLongestPrefix, escapeSpaces, Direction(..), reslash, makeRelativeTo, -- * Utils for defining Data instances abstractConstr, abstractDataType, mkNoRepType, -- * Utils for printing C code charToC, -- * Hashing hashString, -- * Call stacks HasCallStack, HasDebugCallStack, ) where import GHC.Prelude.Basic hiding ( head, init, last, tail ) import GHC.Utils.Exception import GHC.Utils.Panic.Plain import GHC.Utils.Constants import GHC.Utils.Fingerprint import Data.Data import qualified Data.List as List import qualified Data.List as Partial ( head ) import Data.List.NonEmpty ( NonEmpty(..), last, nonEmpty ) import qualified Data.List.NonEmpty as NE import GHC.Exts import GHC.Stack (HasCallStack) import Control.Monad ( guard ) import Control.Monad.IO.Class ( MonadIO, liftIO ) import System.IO.Error as IO ( isDoesNotExistError ) import System.Directory ( doesDirectoryExist, getModificationTime, renameFile ) import System.FilePath import Data.Bifunctor ( first, second ) import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper , isHexDigit, digitToInt ) import Data.Int import Data.Ratio ( (%) ) import Data.Ord ( comparing ) import Data.Word import qualified Data.IntMap as IM import qualified Data.Set as Set import Data.Time {- ************************************************************************ * * \subsection{Miscellaneous higher-order functions} * * ************************************************************************ -} -- | Apply a function iff some condition is met. applyWhen :: Bool -> (a -> a) -> a -> a applyWhen :: forall a. Bool -> (a -> a) -> a -> a applyWhen Bool True a -> a f a x = a -> a f a x applyWhen Bool _ a -> a _ a x = a x -- | Apply a function @n@ times to a given value. nTimes :: Int -> (a -> a) -> (a -> a) nTimes :: forall a. Int -> (a -> a) -> a -> a nTimes Int 0 a -> a _ = a -> a forall a. a -> a id nTimes Int 1 a -> a f = a -> a f nTimes Int n a -> a f = a -> a f (a -> a) -> (a -> a) -> a -> a forall b c a. (b -> c) -> (a -> b) -> a -> c . Int -> (a -> a) -> a -> a forall a. Int -> (a -> a) -> a -> a nTimes (Int nInt -> Int -> Int forall a. Num a => a -> a -> a -Int 1) a -> a f const2 :: a -> b -> c -> a const2 :: forall a b c. a -> b -> c -> a const2 a x b _ c _ = a x fstOf3 :: (a,b,c) -> a sndOf3 :: (a,b,c) -> b thdOf3 :: (a,b,c) -> c fstOf3 :: forall a b c. (a, b, c) -> a fstOf3 (a a,b _,c _) = a a sndOf3 :: forall a b c. (a, b, c) -> b sndOf3 (a _,b b,c _) = b b thdOf3 :: forall a b c. (a, b, c) -> c thdOf3 (a _,b _,c c) = c c fst3 :: (a -> d) -> (a, b, c) -> (d, b, c) fst3 :: forall a d b c. (a -> d) -> (a, b, c) -> (d, b, c) fst3 a -> d f (a a, b b, c c) = (a -> d f a a, b b, c c) snd3 :: (b -> d) -> (a, b, c) -> (a, d, c) snd3 :: forall b d a c. (b -> d) -> (a, b, c) -> (a, d, c) snd3 b -> d f (a a, b b, c c) = (a a, b -> d f b b, c c) third3 :: (c -> d) -> (a, b, c) -> (a, b, d) third3 :: forall c d a b. (c -> d) -> (a, b, c) -> (a, b, d) third3 c -> d f (a a, b b, c c) = (a a, b b, c -> d f c c) uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d uncurry3 :: forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d uncurry3 a -> b -> c -> d f (a a, b b, c c) = a -> b -> c -> d f a a b b c c {- ************************************************************************ * * \subsection[Utils-lists]{General list processing} * * ************************************************************************ -} filterOut :: (a->Bool) -> [a] -> [a] -- ^ Like filter, only it reverses the sense of the test filterOut :: forall a. (a -> Bool) -> [a] -> [a] filterOut a -> Bool p = (a -> Bool) -> [a] -> [a] forall a. (a -> Bool) -> [a] -> [a] filter (Bool -> Bool not (Bool -> Bool) -> (a -> Bool) -> a -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> Bool p) partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) -- ^ Uses a function to determine which of two output lists an input element should join partitionWith :: forall a b c. (a -> Either b c) -> [a] -> ([b], [c]) partitionWith a -> Either b c _ [] = ([],[]) partitionWith a -> Either b c f (a x:[a] xs) = case a -> Either b c f a x of Left b b -> (b bb -> [b] -> [b] forall a. a -> [a] -> [a] :[b] bs, [c] cs) Right c c -> ([b] bs, c cc -> [c] -> [c] forall a. a -> [a] -> [a] :[c] cs) where ([b] bs,[c] cs) = (a -> Either b c) -> [a] -> ([b], [c]) forall a b c. (a -> Either b c) -> [a] -> ([b], [c]) partitionWith a -> Either b c f [a] xs chkAppend :: [a] -> [a] -> [a] -- Checks for the second argument being empty -- Used in situations where that situation is common chkAppend :: forall a. [a] -> [a] -> [a] chkAppend [a] xs [a] ys | [a] -> Bool forall a. [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 :: HasDebugCallStack => String -> [a] -> [b] -> [(a,b)] zipWithEqual :: HasDebugCallStack => String -> (a->b->c) -> [a]->[b]->[c] zipWith3Equal :: HasDebugCallStack => String -> (a->b->c->d) -> [a]->[b]->[c]->[d] zipWith4Equal :: HasDebugCallStack => String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] #if !defined(DEBUG) zipEqual :: forall a b. HasDebugCallStack => String -> [a] -> [b] -> [(a, b)] zipEqual String _ = [a] -> [b] -> [(a, b)] forall a b. [a] -> [b] -> [(a, b)] zip zipWithEqual :: forall a b c. HasDebugCallStack => String -> (a -> b -> c) -> [a] -> [b] -> [c] zipWithEqual String _ = (a -> b -> c) -> [a] -> [b] -> [c] forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith zipWith3Equal :: forall a b c d. HasDebugCallStack => String -> (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] zipWith3Equal String _ = (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] zipWith3 zipWith4Equal :: forall a b c d e. HasDebugCallStack => String -> (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e] zipWith4Equal String _ = (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e] forall a b c d e. (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e] List.zipWith4 #else zipEqual _ [] [] = [] zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs zipEqual msg _ _ = panic ("zipEqual: unequal lists: "++msg) zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs zipWithEqual _ _ [] [] = [] zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists: "++msg) zipWith3Equal msg z (a:as) (b:bs) (c:cs) = z a b c : zipWith3Equal msg z as bs cs zipWith3Equal _ _ [] [] [] = [] zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists: "++msg) zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds) = z a b c d : zipWith4Equal msg z as bs cs ds zipWith4Equal _ _ [] [] [] [] = [] zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists: "++msg) #endif -- | 'filterByList' takes a list of Bools and a list of some elements and -- filters out these elements for which the corresponding value in the list of -- Bools is False. This function does not check whether the lists have equal -- length. filterByList :: [Bool] -> [a] -> [a] filterByList :: forall a. [Bool] -> [a] -> [a] filterByList (Bool True:[Bool] bs) (a x:[a] xs) = a x a -> [a] -> [a] forall a. a -> [a] -> [a] : [Bool] -> [a] -> [a] forall a. [Bool] -> [a] -> [a] filterByList [Bool] bs [a] xs filterByList (Bool False:[Bool] bs) (a _:[a] xs) = [Bool] -> [a] -> [a] forall a. [Bool] -> [a] -> [a] filterByList [Bool] bs [a] xs filterByList [Bool] _ [a] _ = [] -- | 'filterByLists' takes a list of Bools and two lists as input, and -- outputs a new list consisting of elements from the last two input lists. For -- each Bool in the list, if it is 'True', then it takes an element from the -- former list. If it is 'False', it takes an element from the latter list. -- The elements taken correspond to the index of the Bool in its list. -- For example: -- -- @ -- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\" -- @ -- -- This function does not check whether the lists have equal length. filterByLists :: [Bool] -> [a] -> [a] -> [a] filterByLists :: forall a. [Bool] -> [a] -> [a] -> [a] filterByLists (Bool True:[Bool] bs) (a x:[a] xs) (a _:[a] ys) = a x a -> [a] -> [a] forall a. a -> [a] -> [a] : [Bool] -> [a] -> [a] -> [a] forall a. [Bool] -> [a] -> [a] -> [a] filterByLists [Bool] bs [a] xs [a] ys filterByLists (Bool False:[Bool] bs) (a _:[a] xs) (a y:[a] ys) = a y a -> [a] -> [a] forall a. a -> [a] -> [a] : [Bool] -> [a] -> [a] -> [a] forall a. [Bool] -> [a] -> [a] -> [a] filterByLists [Bool] bs [a] xs [a] ys filterByLists [Bool] _ [a] _ [a] _ = [] -- | 'partitionByList' takes a list of Bools and a list of some elements and -- partitions the list according to the list of Bools. Elements corresponding -- to 'True' go to the left; elements corresponding to 'False' go to the right. -- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@ -- This function does not check whether the lists have equal -- length; when one list runs out, the function stops. partitionByList :: [Bool] -> [a] -> ([a], [a]) partitionByList :: forall a. [Bool] -> [a] -> ([a], [a]) partitionByList = [a] -> [a] -> [Bool] -> [a] -> ([a], [a]) forall {a}. [a] -> [a] -> [Bool] -> [a] -> ([a], [a]) go [] [] where go :: [a] -> [a] -> [Bool] -> [a] -> ([a], [a]) go [a] trues [a] falses (Bool True : [Bool] bs) (a x : [a] xs) = [a] -> [a] -> [Bool] -> [a] -> ([a], [a]) go (a xa -> [a] -> [a] forall a. a -> [a] -> [a] :[a] trues) [a] falses [Bool] bs [a] xs go [a] trues [a] falses (Bool False : [Bool] bs) (a x : [a] xs) = [a] -> [a] -> [Bool] -> [a] -> ([a], [a]) go [a] trues (a xa -> [a] -> [a] forall a. a -> [a] -> [a] :[a] falses) [Bool] bs [a] xs go [a] trues [a] falses [Bool] _ [a] _ = ([a] -> [a] forall a. [a] -> [a] reverse [a] trues, [a] -> [a] forall a. [a] -> [a] reverse [a] falses) stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c] -- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in -- the places where @p@ returns @True@ stretchZipWith :: forall a b c. (a -> Bool) -> b -> (a -> b -> c) -> [a] -> [b] -> [c] stretchZipWith a -> Bool _ b _ a -> b -> c _ [] [b] _ = [] stretchZipWith a -> Bool p b z a -> b -> c f (a x:[a] xs) [b] ys | a -> Bool p a x = a -> b -> c f a x b z c -> [c] -> [c] forall a. a -> [a] -> [a] : (a -> Bool) -> b -> (a -> b -> c) -> [a] -> [b] -> [c] forall a b c. (a -> Bool) -> b -> (a -> b -> c) -> [a] -> [b] -> [c] stretchZipWith a -> Bool p b z a -> b -> c f [a] xs [b] ys | Bool otherwise = case [b] ys of [] -> [] (b y:[b] ys) -> a -> b -> c f a x b y c -> [c] -> [c] forall a. a -> [a] -> [a] : (a -> Bool) -> b -> (a -> b -> c) -> [a] -> [b] -> [c] forall a b c. (a -> Bool) -> b -> (a -> b -> c) -> [a] -> [b] -> [c] stretchZipWith a -> Bool p b z a -> b -> c f [a] xs [b] ys mapFst :: Functor f => (a->c) -> f(a,b) -> f(c,b) mapSnd :: Functor f => (b->c) -> f(a,b) -> f(a,c) mapFst :: forall (f :: * -> *) a c b. Functor f => (a -> c) -> f (a, b) -> f (c, b) mapFst = ((a, b) -> (c, b)) -> f (a, b) -> f (c, b) forall a b. (a -> b) -> f a -> f b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (((a, b) -> (c, b)) -> f (a, b) -> f (c, b)) -> ((a -> c) -> (a, b) -> (c, b)) -> (a -> c) -> f (a, b) -> f (c, b) forall b c a. (b -> c) -> (a -> b) -> a -> c . (a -> c) -> (a, b) -> (c, b) forall a b c. (a -> b) -> (a, c) -> (b, c) forall (p :: * -> * -> *) a b c. Bifunctor p => (a -> b) -> p a c -> p b c first mapSnd :: forall (f :: * -> *) b c a. Functor f => (b -> c) -> f (a, b) -> f (a, c) mapSnd = ((a, b) -> (a, c)) -> f (a, b) -> f (a, c) forall a b. (a -> b) -> f a -> f b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (((a, b) -> (a, c)) -> f (a, b) -> f (a, c)) -> ((b -> c) -> (a, b) -> (a, c)) -> (b -> c) -> f (a, b) -> f (a, c) forall b c a. (b -> c) -> (a -> b) -> a -> c . (b -> c) -> (a, b) -> (a, c) forall b c a. (b -> c) -> (a, b) -> (a, c) forall (p :: * -> * -> *) b c a. Bifunctor p => (b -> c) -> p a b -> p a c second mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) mapAndUnzip :: forall a b c. (a -> (b, c)) -> [a] -> ([b], [c]) mapAndUnzip a -> (b, c) _ [] = ([], []) mapAndUnzip a -> (b, c) f (a x:[a] xs) = let (b r1, c r2) = a -> (b, c) f a x ([b] rs1, [c] rs2) = (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 :: forall a b c d. (a -> (b, c, d)) -> [a] -> ([b], [c], [d]) mapAndUnzip3 a -> (b, c, d) _ [] = ([], [], []) mapAndUnzip3 a -> (b, c, d) f (a x:[a] xs) = let (b r1, c r2, d r3) = a -> (b, c, d) f a x ([b] rs1, [c] rs2, [d] rs3) = (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 :: forall a b c d. (a -> b -> (c, d)) -> [a] -> [b] -> ([c], [d]) zipWithAndUnzip a -> b -> (c, d) f (a a:[a] as) (b b:[b] bs) = let (c r1, d r2) = a -> b -> (c, d) f a a b b ([c] rs1, [d] rs2) = (a -> b -> (c, d)) -> [a] -> [b] -> ([c], [d]) forall a b c d. (a -> b -> (c, d)) -> [a] -> [b] -> ([c], [d]) zipWithAndUnzip a -> b -> (c, d) f [a] as [b] bs in (c r1c -> [c] -> [c] forall a. a -> [a] -> [a] :[c] rs1, d r2d -> [d] -> [d] forall a. a -> [a] -> [a] :[d] rs2) zipWithAndUnzip a -> b -> (c, d) _ [a] _ [b] _ = ([],[]) -- | This has the effect of making the two lists have equal length by dropping -- the tail of the longer one. zipAndUnzip :: [a] -> [b] -> ([a],[b]) zipAndUnzip :: forall a b. [a] -> [b] -> ([a], [b]) zipAndUnzip (a a:[a] as) (b b:[b] bs) = let ([a] rs1, [b] rs2) = [a] -> [b] -> ([a], [b]) forall a b. [a] -> [b] -> ([a], [b]) zipAndUnzip [a] as [b] bs in (a aa -> [a] -> [a] forall a. a -> [a] -> [a] :[a] rs1, b bb -> [b] -> [b] forall a. a -> [a] -> [a] :[b] rs2) zipAndUnzip [a] _ [b] _ = ([],[]) -- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely: -- -- @ -- atLength atLenPred atEndPred ls n -- | n < 0 = atLenPred ls -- | length ls < n = atEndPred (n - length ls) -- | otherwise = atLenPred (drop n ls) -- @ atLength :: ([a] -> b) -- Called when length ls >= n, passed (drop n ls) -- NB: arg passed to this function may be [] -> b -- Called when length ls < n -> [a] -> Int -> b atLength :: forall a b. ([a] -> b) -> b -> [a] -> Int -> b atLength [a] -> b atLenPred b atEnd [a] ls0 Int n0 | Int n0 Int -> Int -> Bool forall a. Ord a => a -> a -> Bool < Int 0 = [a] -> b atLenPred [a] ls0 | Bool otherwise = Int -> [a] -> b go Int n0 [a] ls0 where -- go's first arg n >= 0 go :: Int -> [a] -> b go Int 0 [a] ls = [a] -> b atLenPred [a] ls go Int _ [] = b atEnd -- n > 0 here go Int n (a _:[a] xs) = Int -> [a] -> b go (Int nInt -> Int -> Int forall a. Num a => a -> a -> a -Int 1) [a] xs -- Some special cases of atLength: -- | @(lengthExceeds xs n) = (length xs > n)@ lengthExceeds :: [a] -> Int -> Bool lengthExceeds :: forall a. [a] -> Int -> Bool lengthExceeds [a] lst Int n | Int n Int -> Int -> Bool forall a. Ord a => a -> a -> Bool < Int 0 = Bool True | Bool otherwise = ([a] -> Bool) -> Bool -> [a] -> Int -> Bool forall a b. ([a] -> b) -> b -> [a] -> Int -> b atLength [a] -> Bool forall (f :: * -> *) a. Foldable f => f a -> Bool notNull Bool False [a] lst Int n -- | @(lengthAtLeast xs n) = (length xs >= n)@ lengthAtLeast :: [a] -> Int -> Bool lengthAtLeast :: forall a. [a] -> Int -> Bool lengthAtLeast = ([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 :: forall a. [a] -> Int -> Bool lengthIs [a] lst Int n | Int n Int -> Int -> Bool forall a. Ord a => a -> a -> Bool < Int 0 = Bool False | Bool otherwise = ([a] -> Bool) -> Bool -> [a] -> Int -> Bool forall a b. ([a] -> b) -> b -> [a] -> Int -> b atLength [a] -> Bool forall a. [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 :: forall a. [a] -> Int -> Bool lengthIsNot [a] lst Int n | Int n Int -> Int -> Bool forall a. Ord a => a -> a -> Bool < Int 0 = Bool True | Bool otherwise = ([a] -> Bool) -> Bool -> [a] -> Int -> Bool forall a b. ([a] -> b) -> b -> [a] -> Int -> b atLength [a] -> Bool forall (f :: * -> *) a. Foldable f => f a -> Bool notNull Bool True [a] lst Int n -- | @(lengthAtMost xs n) = (length xs <= n)@ lengthAtMost :: [a] -> Int -> Bool lengthAtMost :: forall a. [a] -> Int -> Bool lengthAtMost [a] lst Int n | Int n Int -> Int -> Bool forall a. Ord a => a -> a -> Bool < Int 0 = Bool False | Bool otherwise = ([a] -> Bool) -> Bool -> [a] -> Int -> Bool forall a b. ([a] -> b) -> b -> [a] -> Int -> b atLength [a] -> Bool forall a. [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 :: forall a. [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 :: forall a. [a] -> Int -> Ordering listLengthCmp = ([a] -> Ordering) -> Ordering -> [a] -> Int -> Ordering forall a b. ([a] -> b) -> b -> [a] -> Int -> b atLength [a] -> Ordering forall {a}. [a] -> Ordering atLen Ordering atEnd where atEnd :: Ordering atEnd = Ordering LT -- Not yet seen 'n' elts, so list length is < n. atLen :: [a] -> Ordering atLen [] = Ordering EQ atLen [a] _ = Ordering GT equalLength :: [a] -> [b] -> Bool -- ^ True if length xs == length ys equalLength :: forall a b. [a] -> [b] -> Bool equalLength [] [] = Bool True equalLength (a _:[a] xs) (b _:[b] ys) = [a] -> [b] -> Bool forall a b. [a] -> [b] -> Bool equalLength [a] xs [b] ys equalLength [a] _ [b] _ = Bool False compareLength :: [a] -> [b] -> Ordering compareLength :: forall a b. [a] -> [b] -> Ordering compareLength [] [] = Ordering EQ compareLength (a _:[a] xs) (b _:[b] ys) = [a] -> [b] -> Ordering forall a b. [a] -> [b] -> Ordering compareLength [a] xs [b] ys compareLength [] [b] _ = Ordering LT compareLength [a] _ [] = Ordering GT leLength :: [a] -> [b] -> Bool -- ^ True if length xs <= length ys leLength :: forall a b. [a] -> [b] -> Bool leLength [a] xs [b] ys = case [a] -> [b] -> Ordering forall a b. [a] -> [b] -> Ordering compareLength [a] xs [b] ys of Ordering LT -> Bool True Ordering EQ -> Bool True Ordering GT -> Bool False ltLength :: [a] -> [b] -> Bool -- ^ True if length xs < length ys ltLength :: forall a b. [a] -> [b] -> Bool ltLength [a] xs [b] ys = case [a] -> [b] -> Ordering forall a b. [a] -> [b] -> Ordering compareLength [a] xs [b] ys of Ordering LT -> Bool True Ordering EQ -> Bool False Ordering GT -> Bool False ---------------------------- singleton :: a -> [a] singleton :: forall a. a -> [a] singleton a x = [a x] isSingleton :: [a] -> Bool isSingleton :: forall a. [a] -> Bool isSingleton [a _] = Bool True isSingleton [a] _ = Bool False notNull :: Foldable f => f a -> Bool notNull :: forall (f :: * -> *) a. Foldable f => f a -> Bool notNull = Bool -> Bool not (Bool -> Bool) -> (f a -> Bool) -> f a -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . f a -> Bool forall a. f a -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null -- | Utility function to go from a singleton list to it's element. -- -- Wether or not the argument is a singleton list is only checked -- in debug builds. only :: [a] -> a #if defined(DEBUG) only [a] = a #else only :: forall a. [a] -> a only (a a:[a] _) = a a #endif only [a] _ = String -> a forall a. HasCallStack => String -> a panic String "Util: only" -- | Extract the single element of a list and panic with the given message if -- there are more elements or the list was empty. -- Like 'expectJust', but for lists. expectOnly :: HasCallStack => String -> [a] -> a {-# INLINE expectOnly #-} #if defined(DEBUG) expectOnly _ [a] = a #else expectOnly :: forall a. HasCallStack => String -> [a] -> a expectOnly String _ (a a:[a] _) = a a #endif expectOnly String msg [a] _ = String -> a forall a. HasCallStack => String -> a panic (String "expectOnly: " String -> String -> String forall a. [a] -> [a] -> [a] ++ String msg) -- | Split a list into chunks of /n/ elements chunkList :: Int -> [a] -> [[a]] chunkList :: forall a. Int -> [a] -> [[a]] chunkList Int _ [] = [] chunkList Int n [a] xs = [a] as [a] -> [[a]] -> [[a]] forall a. a -> [a] -> [a] : Int -> [a] -> [[a]] forall a. Int -> [a] -> [[a]] chunkList Int n [a] bs where ([a] as,[a] bs) = Int -> [a] -> ([a], [a]) forall a. Int -> [a] -> ([a], [a]) splitAt Int n [a] xs -- | Compute all the ways of removing a single element from a list. -- -- > holes [1,2,3] = [(1, [2,3]), (2, [1,3]), (3, [1,2])] holes :: [a] -> [(a, [a])] holes :: forall a. [a] -> [(a, [a])] holes [] = [] holes (a x:[a] xs) = (a x, [a] xs) (a, [a]) -> [(a, [a])] -> [(a, [a])] forall a. a -> [a] -> [a] : ([a] -> [a]) -> [(a, [a])] -> [(a, [a])] forall (f :: * -> *) b c a. Functor f => (b -> c) -> f (a, b) -> f (a, c) mapSnd (a xa -> [a] -> [a] forall a. a -> [a] -> [a] :) ([a] -> [(a, [a])] forall a. [a] -> [(a, [a])] holes [a] xs) -- | Replace the last element of a list with another element. changeLast :: [a] -> a -> [a] changeLast :: forall a. [a] -> a -> [a] changeLast [] a _ = String -> [a] forall a. HasCallStack => String -> a panic String "changeLast" changeLast [a _] a x = [a x] changeLast (a x:[a] xs) a x' = a x a -> [a] -> [a] forall a. a -> [a] -> [a] : [a] -> a -> [a] forall a. [a] -> a -> [a] changeLast [a] xs a x' -- | Apply an effectful function to the last list element. mapLastM :: Functor f => (a -> f a) -> NonEmpty a -> f (NonEmpty a) mapLastM :: forall (f :: * -> *) a. Functor f => (a -> f a) -> NonEmpty a -> f (NonEmpty a) mapLastM a -> f a f (a x:|[]) = a -> NonEmpty a forall a. a -> NonEmpty a NE.singleton (a -> NonEmpty a) -> f a -> f (NonEmpty a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> a -> f a f a x mapLastM a -> f a f (a x0:|a x1:[a] xs) = (a x0 a -> NonEmpty a -> NonEmpty a forall a. a -> NonEmpty a -> NonEmpty a NE.<|) (NonEmpty a -> NonEmpty a) -> f (NonEmpty a) -> f (NonEmpty a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (a -> f a) -> NonEmpty a -> f (NonEmpty a) forall (f :: * -> *) a. Functor f => (a -> f a) -> NonEmpty a -> f (NonEmpty a) mapLastM a -> f a f (a x1a -> [a] -> NonEmpty a forall a. a -> [a] -> NonEmpty a :|[a] xs) whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m () whenNonEmpty :: forall (m :: * -> *) a. Applicative m => [a] -> (NonEmpty a -> m ()) -> m () whenNonEmpty [] NonEmpty a -> m () _ = () -> m () forall a. a -> m a forall (f :: * -> *) a. Applicative f => a -> f a pure () whenNonEmpty (a x:[a] xs) NonEmpty a -> m () f = NonEmpty a -> m () f (a x a -> [a] -> NonEmpty a forall a. a -> [a] -> NonEmpty a :| [a] xs) -- | Merge an unsorted list of sorted lists, for example: -- -- > mergeListsBy compare [ [2,5,15], [1,10,100] ] = [1,2,5,10,15,100] -- -- \( O(n \log{} k) \) mergeListsBy :: forall a. (a -> a -> Ordering) -> [[a]] -> [a] mergeListsBy :: forall a. (a -> a -> Ordering) -> [[a]] -> [a] mergeListsBy a -> a -> Ordering cmp [[a]] lists | Bool debugIsOn, Bool -> Bool not (([a] -> Bool) -> [[a]] -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all [a] -> Bool sorted [[a]] lists) = -- When debugging is on, we check that the input lists are sorted. String -> [a] forall a. HasCallStack => String -> a panic String "mergeListsBy: input lists must be sorted" where sorted :: [a] -> Bool sorted = (a -> a -> Ordering) -> [a] -> Bool forall a. (a -> a -> Ordering) -> [a] -> Bool isSortedBy a -> a -> Ordering cmp mergeListsBy a -> a -> Ordering cmp [[a]] all_lists = [[a]] -> [a] merge_lists [[a]] all_lists where -- Implements "Iterative 2-Way merge" described at -- https://en.wikipedia.org/wiki/K-way_merge_algorithm -- Merge two sorted lists into one in O(n). merge2 :: [a] -> [a] -> [a] merge2 :: [a] -> [a] -> [a] merge2 [] [a] ys = [a] ys merge2 [a] xs [] = [a] xs merge2 (a x:[a] xs) (a y:[a] ys) = case a -> a -> Ordering cmp a x a y of Ordering GT -> a y a -> [a] -> [a] forall a. a -> [a] -> [a] : [a] -> [a] -> [a] merge2 (a xa -> [a] -> [a] forall a. a -> [a] -> [a] :[a] xs) [a] ys Ordering _ -> a x a -> [a] -> [a] forall a. a -> [a] -> [a] : [a] -> [a] -> [a] merge2 [a] xs (a ya -> [a] -> [a] forall a. a -> [a] -> [a] :[a] ys) -- Merge the first list with the second, the third with the fourth, and so -- on. The output has half as much lists as the input. merge_neighbours :: [[a]] -> [[a]] merge_neighbours :: [[a]] -> [[a]] merge_neighbours [] = [] merge_neighbours [[a] xs] = [[a] xs] merge_neighbours ([a] xs : [a] ys : [[a]] lists) = [a] -> [a] -> [a] merge2 [a] xs [a] ys [a] -> [[a]] -> [[a]] forall a. a -> [a] -> [a] : [[a]] -> [[a]] merge_neighbours [[a]] lists -- Since 'merge_neighbours' halves the amount of lists in each iteration, -- we perform O(log k) iteration. Each iteration is O(n). The total running -- time is therefore O(n log k). merge_lists :: [[a]] -> [a] merge_lists :: [[a]] -> [a] merge_lists [[a]] lists = case [[a]] -> [[a]] merge_neighbours [[a]] lists of [] -> [] [[a] xs] -> [a] xs [[a]] lists' -> [[a]] -> [a] merge_lists [[a]] lists' isSortedBy :: (a -> a -> Ordering) -> [a] -> Bool isSortedBy :: forall a. (a -> a -> Ordering) -> [a] -> Bool isSortedBy a -> a -> Ordering cmp = [a] -> Bool sorted where sorted :: [a] -> Bool sorted [] = Bool True sorted [a _] = Bool True sorted (a x:a y:[a] xs) = a -> a -> Ordering cmp a x a y Ordering -> Ordering -> Bool forall a. Eq a => a -> a -> Bool /= Ordering GT Bool -> Bool -> Bool && [a] -> Bool sorted (a ya -> [a] -> [a] forall a. a -> [a] -> [a] :[a] xs) {- ************************************************************************ * * \subsubsection{Sort utils} * * ************************************************************************ -} minWith :: Ord b => (a -> b) -> [a] -> a minWith :: forall b a. Ord b => (a -> b) -> [a] -> a minWith a -> b get_key [a] xs = Bool -> ([a] -> a) -> [a] -> a forall a. HasCallStack => Bool -> a -> a assert (Bool -> Bool not ([a] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [a] xs) ) [a] -> a forall a. HasCallStack => [a] -> a Partial.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 :: forall a. Ord a => [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 :: forall a. Ord a => [a] -> [a] ordNub [a] xs = (a -> a) -> [a] -> [a] forall b a. Ord b => (a -> b) -> [a] -> [a] ordNubOn a -> a forall a. a -> a id [a] xs -- | Remove duplicates but keep elements in order. -- O(n * log n) ordNubOn :: Ord b => (a -> b) -> [a] -> [a] ordNubOn :: forall b a. Ord b => (a -> b) -> [a] -> [a] ordNubOn a -> b f [a] xs = Set b -> [a] -> [a] go Set b forall a. Set a Set.empty [a] xs where go :: Set b -> [a] -> [a] go Set b _ [] = [] go Set b s (a x:[a] xs) | b -> Set b -> Bool forall a. Ord a => a -> Set a -> Bool Set.member (a -> b f a x) Set b s = Set b -> [a] -> [a] go Set b s [a] xs | Bool otherwise = a x a -> [a] -> [a] forall a. a -> [a] -> [a] : Set b -> [a] -> [a] go (b -> Set b -> Set b forall a. Ord a => a -> Set a -> Set a Set.insert (a -> b f a x) Set b s) [a] xs {- ************************************************************************ * * \subsection[Utils-transitive-closure]{Transitive closure} * * ************************************************************************ This algorithm for transitive closure is straightforward, albeit quadratic. -} transitiveClosure :: (a -> [a]) -- Successor function -> (a -> a -> Bool) -- Equality predicate -> [a] -> [a] -- The transitive closure transitiveClosure :: forall a. (a -> [a]) -> (a -> a -> Bool) -> [a] -> [a] transitiveClosure a -> [a] succ a -> a -> Bool eq [a] xs = [a] -> [a] -> [a] go [] [a] xs where go :: [a] -> [a] -> [a] go [a] done [] = [a] done go [a] done (a x:[a] xs) | a x a -> [a] -> Bool `is_in` [a] done = [a] -> [a] -> [a] go [a] done [a] xs | Bool otherwise = [a] -> [a] -> [a] go (a xa -> [a] -> [a] forall a. a -> [a] -> [a] :[a] done) (a -> [a] succ a x [a] -> [a] -> [a] forall a. [a] -> [a] -> [a] ++ [a] xs) a _ is_in :: a -> [a] -> Bool `is_in` [] = Bool False a x `is_in` (a y:[a] ys) | a -> a -> Bool eq a x a y = Bool True | Bool otherwise = a x a -> [a] -> Bool `is_in` [a] ys {- ************************************************************************ * * \subsection[Utils-accum]{Accumulating} * * ************************************************************************ A combination of foldl with zip. It works with equal length lists. -} foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc foldl2 :: forall acc a b. (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc foldl2 acc -> a -> b -> acc _ acc z [] [] = acc z foldl2 acc -> a -> b -> acc k acc z (a a:[a] as) (b b:[b] bs) = (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc forall acc a b. (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc foldl2 acc -> a -> b -> acc k (acc -> a -> b -> acc k acc z a a b b) [a] as [b] bs foldl2 acc -> a -> b -> acc _ acc _ [a] _ [b] _ = String -> acc forall a. HasCallStack => String -> a panic String "Util: foldl2" all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool -- True if the lists are the same length, and -- all corresponding elements satisfy the predicate all2 :: forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool all2 a -> b -> Bool _ [] [] = Bool True all2 a -> b -> Bool p (a x:[a] xs) (b y:[b] ys) = a -> b -> Bool p a x b y Bool -> Bool -> Bool && (a -> b -> Bool) -> [a] -> [b] -> Bool forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool all2 a -> b -> Bool p [a] xs [b] ys all2 a -> b -> Bool _ [a] _ [b] _ = Bool False -- Count the number of times a predicate is true count :: (a -> Bool) -> [a] -> Int count :: forall a. (a -> Bool) -> [a] -> Int count a -> Bool p = Int -> [a] -> Int go Int 0 where go :: Int -> [a] -> Int go !Int n [] = Int n go !Int n (a x:[a] xs) | a -> Bool p a x = Int -> [a] -> Int go (Int nInt -> Int -> Int forall a. Num a => a -> a -> a +Int 1) [a] xs | Bool otherwise = Int -> [a] -> Int go Int n [a] xs countWhile :: (a -> Bool) -> [a] -> Int -- Length of an /initial prefix/ of the list satisfying p countWhile :: forall a. (a -> Bool) -> [a] -> Int countWhile a -> Bool p = Int -> [a] -> Int go Int 0 where go :: Int -> [a] -> Int go !Int n (a x:[a] xs) | a -> Bool p a x = Int -> [a] -> Int go (Int nInt -> Int -> Int forall a. Num a => a -> a -> a +Int 1) [a] xs go !Int n [a] _ = Int n {- @splitAt@, @take@, and @drop@ but with length of another list giving the break-off point: -} takeList :: [b] -> [a] -> [a] -- (takeList as bs) trims bs to the be same length -- as as, unless as is longer in which case it's a no-op takeList :: forall b a. [b] -> [a] -> [a] takeList [] [a] _ = [] takeList (b _:[b] xs) [a] ls = case [a] ls of [] -> [] (a y:[a] ys) -> a y 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 :: forall b a. [b] -> [a] -> [a] dropList [] [a] xs = [a] xs dropList [b] _ xs :: [a] xs@[] = [a] xs dropList (b _:[b] xs) (a _:[a] ys) = [b] -> [a] -> [a] forall b a. [b] -> [a] -> [a] dropList [b] xs [a] ys -- | Given two lists xs and ys, return `splitAt (length xs) ys`. splitAtList :: [b] -> [a] -> ([a], [a]) splitAtList :: forall b a. [b] -> [a] -> ([a], [a]) splitAtList [b] xs [a] ys = Int# -> [b] -> [a] -> ([a], [a]) go Int# 0# [b] xs [a] ys where -- we are careful to avoid allocating when there are no leftover -- arguments: in this case we can return "ys" directly (cf #18535) -- -- We make `xs` strict because in the general case `ys` isn't `[]` so we -- will have to evaluate `xs` anyway. go :: Int# -> [b] -> [a] -> ([a], [a]) go Int# _ ![b] _ [] = ([a] ys, []) -- length ys <= length xs go Int# n [] [a] bs = (Int -> [a] -> [a] forall a. Int -> [a] -> [a] take (Int# -> Int I# Int# n) [a] ys, [a] bs) -- = splitAt n ys go Int# n (b _:[b] as) (a _:[a] bs) = Int# -> [b] -> [a] -> ([a], [a]) go (Int# n Int# -> Int# -> Int# +# Int# 1#) [b] as [a] bs -- | drop from the end of a list dropTail :: Int -> [a] -> [a] -- Specification: dropTail n = reverse . drop n . reverse -- Better implementation due to Joachim Breitner -- http://www.joachim-breitner.de/blog/archives/600-On-taking-the-last-n-elements-of-a-list.html dropTail :: forall a. Int -> [a] -> [a] dropTail Int n [a] xs = [a] -> [a] -> [a] forall b a. [b] -> [a] -> [a] go (Int -> [a] -> [a] forall a. Int -> [a] -> [a] drop Int n [a] xs) [a] xs where go :: [a] -> [a] -> [a] go (a _:[a] ys) (a x:[a] xs) = a x a -> [a] -> [a] forall a. a -> [a] -> [a] : [a] -> [a] -> [a] go [a] ys [a] xs go [a] _ [a] _ = [] -- Stop when ys runs out -- It'll always run out before xs does -- dropWhile from the end of a list. This is similar to Data.List.dropWhileEnd, -- but is lazy in the elements and strict in the spine. For reasonably short lists, -- such as path names and typical lines of text, dropWhileEndLE is generally -- faster than dropWhileEnd. Its advantage is magnified when the predicate is -- expensive--using dropWhileEndLE isSpace to strip the space off a line of text -- is generally much faster than using dropWhileEnd isSpace for that purpose. -- Specification: dropWhileEndLE p = reverse . dropWhile p . reverse -- Pay attention to the short-circuit (&&)! The order of its arguments is the only -- difference between dropWhileEnd and dropWhileEndLE. dropWhileEndLE :: (a -> Bool) -> [a] -> [a] dropWhileEndLE :: forall a. (a -> Bool) -> [a] -> [a] dropWhileEndLE a -> Bool p = (a -> [a] -> [a]) -> [a] -> [a] -> [a] forall a b. (a -> b -> b) -> b -> [a] -> b forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr (\a x [a] r -> if [a] -> Bool forall a. [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 :: forall a. (a -> Bool) -> [a] -> ([a], [a]) spanEnd a -> Bool p [a] l = [a] -> [a] -> [a] -> [a] -> ([a], [a]) go [a] l [] [] [a] l where go :: [a] -> [a] -> [a] -> [a] -> ([a], [a]) go [a] yes [a] _rev_yes [a] rev_no [] = ([a] yes, [a] -> [a] forall a. [a] -> [a] reverse [a] rev_no) go [a] yes [a] rev_yes [a] rev_no (a x:[a] xs) | a -> Bool p a x = [a] -> [a] -> [a] -> [a] -> ([a], [a]) go [a] yes (a x a -> [a] -> [a] forall a. a -> [a] -> [a] : [a] rev_yes) [a] rev_no [a] xs | Bool otherwise = [a] -> [a] -> [a] -> [a] -> ([a], [a]) go [a] xs [] (a x a -> [a] -> [a] forall a. a -> [a] -> [a] : [a] rev_yes [a] -> [a] -> [a] forall a. [a] -> [a] -> [a] ++ [a] rev_no) [a] xs -- | Get the last two elements in a list. {-# INLINE last2 #-} last2 :: [a] -> Maybe (a,a) last2 :: forall a. [a] -> Maybe (a, a) last2 = (Maybe a -> Maybe a -> Maybe (a, a)) -> (Maybe a, Maybe a) -> Maybe (a, a) forall a b c. (a -> b -> c) -> (a, b) -> c uncurry ((a -> a -> (a, a)) -> Maybe a -> Maybe a -> Maybe (a, a) forall a b c. (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c forall (f :: * -> *) a b c. Applicative f => (a -> b -> c) -> f a -> f b -> f c liftA2 (,)) ((Maybe a, Maybe a) -> Maybe (a, a)) -> ([a] -> (Maybe a, Maybe a)) -> [a] -> Maybe (a, a) forall b c a. (b -> c) -> (a -> b) -> a -> c . ((Maybe a, Maybe a) -> a -> (Maybe a, Maybe a)) -> (Maybe a, Maybe a) -> [a] -> (Maybe a, Maybe a) forall b a. (b -> a -> b) -> b -> [a] -> b forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b List.foldl' (\(Maybe a _,Maybe a x2) a x -> (Maybe a x2, a -> Maybe a forall a. a -> Maybe a Just a x)) (Maybe a forall a. Maybe a Nothing, Maybe a forall a. Maybe a Nothing) lastMaybe :: [a] -> Maybe a lastMaybe :: forall a. [a] -> Maybe a lastMaybe [] = Maybe a forall a. Maybe a Nothing lastMaybe (a x:[a] xs) = a -> Maybe a forall a. a -> Maybe a Just (a -> Maybe a) -> a -> Maybe a forall a b. (a -> b) -> a -> b $ NonEmpty a -> a forall a. NonEmpty a -> a last (a xa -> [a] -> NonEmpty a forall a. a -> [a] -> NonEmpty a :|[a] xs) -- | @onJust x m f@ applies f to the value inside the Just or returns the default. onJust :: b -> Maybe a -> (a->b) -> b onJust :: forall b a. b -> Maybe a -> (a -> b) -> b onJust b dflt = ((a -> b) -> Maybe a -> b) -> Maybe a -> (a -> b) -> b forall a b c. (a -> b -> c) -> b -> a -> c flip (b -> (a -> b) -> Maybe a -> b forall b a. b -> (a -> b) -> Maybe a -> b maybe b dflt) -- | Split a list into its last element and the initial part of the list. -- @snocView xs = Just (init xs, last xs)@ for non-empty lists. -- @snocView xs = Nothing@ otherwise. -- Unless both parts of the result are guaranteed to be used -- prefer separate calls to @last@ + @init@. -- If you are guaranteed to use both, this will -- be more efficient. snocView :: [a] -> Maybe ([a],a) snocView :: forall a. [a] -> Maybe ([a], a) snocView = (NonEmpty a -> ([a], a)) -> Maybe (NonEmpty a) -> Maybe ([a], a) forall a b. (a -> b) -> Maybe a -> Maybe b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap NonEmpty a -> ([a], a) forall a. NonEmpty a -> ([a], a) go (Maybe (NonEmpty a) -> Maybe ([a], a)) -> ([a] -> Maybe (NonEmpty a)) -> [a] -> Maybe ([a], a) forall b c a. (b -> c) -> (a -> b) -> a -> c . [a] -> Maybe (NonEmpty a) forall a. [a] -> Maybe (NonEmpty a) nonEmpty where go :: NonEmpty a -> ([a],a) go :: forall a. NonEmpty a -> ([a], a) go (a x:|[a] xs) = case [a] -> Maybe (NonEmpty a) forall a. [a] -> Maybe (NonEmpty a) nonEmpty [a] xs of Maybe (NonEmpty a) Nothing -> ([],a x) Just NonEmpty a xs -> case NonEmpty a -> ([a], a) forall a. NonEmpty a -> ([a], a) go NonEmpty a xs of !([a] xs', a x') -> (a xa -> [a] -> [a] forall a. a -> [a] -> [a] :[a] xs', a x') split :: Char -> String -> [String] split :: Char -> String -> [String] split Char c String s = case String rest of [] -> [String chunk] Char _:String rest -> String chunk String -> [String] -> [String] forall a. a -> [a] -> [a] : Char -> String -> [String] split Char c String rest where (String chunk, String rest) = (Char -> Bool) -> String -> (String, String) forall a. (a -> Bool) -> [a] -> ([a], [a]) break (Char -> Char -> Bool forall a. Eq a => a -> a -> Bool ==Char c) String s -- | Convert a word to title case by capitalising the first letter capitalise :: String -> String capitalise :: String -> String capitalise [] = [] capitalise (Char c:String cs) = Char -> Char toUpper Char c Char -> String -> String forall a. a -> [a] -> [a] : String cs {- ************************************************************************ * * \subsection[Utils-comparison]{Comparisons} * * ************************************************************************ -} isEqual :: Ordering -> Bool -- Often used in (isEqual (a `compare` b)) isEqual :: Ordering -> Bool isEqual Ordering GT = Bool False isEqual Ordering EQ = Bool True isEqual Ordering LT = Bool False 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 <&&> :: forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool (<&&>) = (Bool -> Bool -> Bool) -> f Bool -> f Bool -> f Bool forall a b c. (a -> b -> c) -> f a -> f b -> f c forall (f :: * -> *) a b c. Applicative f => (a -> b -> c) -> f a -> f b -> f c liftA2 Bool -> Bool -> Bool (&&) infixr 3 <&&> -- same as (&&) (<||>) :: Applicative f => f Bool -> f Bool -> f Bool <||> :: forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool (<||>) = (Bool -> Bool -> Bool) -> f Bool -> f Bool -> f Bool forall a b c. (a -> b -> c) -> f a -> f b -> f c forall (f :: * -> *) a b c. Applicative f => (a -> b -> c) -> f a -> f b -> f c liftA2 Bool -> Bool -> Bool (||) infixr 2 <||> -- same as (||) {- ************************************************************************ * * \subsection{Edit distance} * * ************************************************************************ -} -- | Find the "restricted" Damerau-Levenshtein edit distance between two strings. -- See: <http://en.wikipedia.org/wiki/Damerau-Levenshtein_distance>. -- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing -- Levenshtein and Damerau Edit Distances" in PSC'02 (Heikki Hyyro). -- See http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and -- http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for an explanation restrictedDamerauLevenshteinDistance :: String -> String -> Int restrictedDamerauLevenshteinDistance :: String -> String -> Int restrictedDamerauLevenshteinDistance String str1 String str2 = Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistanceWithLengths Int m Int n String str1 String str2 where m :: Int m = String -> Int forall a. [a] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length String str1 n :: Int n = String -> Int forall a. [a] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length String str2 restrictedDamerauLevenshteinDistanceWithLengths :: Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistanceWithLengths :: Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistanceWithLengths Int m Int n String str1 String str2 | Int m Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int n = if Int n Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int 32 -- n must be larger so this check is sufficient then Word32 -> Int -> Int -> String -> String -> Int forall bv. (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistance' (Word32 forall a. HasCallStack => a undefined :: Word32) Int m Int n String str1 String str2 else Integer -> Int -> Int -> String -> String -> Int forall bv. (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistance' (Integer forall a. HasCallStack => a undefined :: Integer) Int m Int n String str1 String str2 | Bool otherwise = if Int m Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int 32 -- m must be larger so this check is sufficient then Word32 -> Int -> Int -> String -> String -> Int forall bv. (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistance' (Word32 forall a. HasCallStack => a undefined :: Word32) Int n Int m String str2 String str1 else Integer -> Int -> Int -> String -> String -> Int forall bv. (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistance' (Integer forall a. HasCallStack => a undefined :: Integer) Int n Int m String str2 String str1 restrictedDamerauLevenshteinDistance' :: (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistance' :: forall bv. (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistance' bv _bv_dummy Int m Int n String str1 String str2 | [] <- String str1 = Int n | Bool otherwise = (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 b a. (b -> a -> b) -> b -> [a] -> b forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b List.foldl' (IntMap bv -> bv -> bv -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int) forall bv. (Bits bv, Num bv) => IntMap bv -> bv -> bv -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int) restrictedDamerauLevenshteinDistanceWorker (String -> IntMap bv forall bv. (Bits bv, Num bv) => String -> IntMap bv matchVectors String str1) bv top_bit_mask bv vector_mask) (bv 0, bv 0, bv m_ones, bv 0, Int m) String str2 where m_ones :: bv m_ones@bv vector_mask = (bv 2 bv -> Int -> bv forall a b. (Num a, Integral b) => a -> b -> a ^ Int m) bv -> bv -> bv forall a. Num a => a -> a -> a - bv 1 top_bit_mask :: bv top_bit_mask = (bv 1 bv -> Int -> bv forall a. Bits a => a -> Int -> a `shiftL` (Int m Int -> Int -> Int forall a. Num a => a -> a -> a - Int 1)) bv -> bv -> bv forall a. a -> a -> a `asTypeOf` bv _bv_dummy extractAnswer :: (a, b, c, d, e) -> e extractAnswer (a _, b _, c _, d _, e distance) = e distance restrictedDamerauLevenshteinDistanceWorker :: (Bits bv, Num bv) => IM.IntMap bv -> bv -> bv -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int) restrictedDamerauLevenshteinDistanceWorker :: forall bv. (Bits bv, Num bv) => IntMap bv -> bv -> bv -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int) restrictedDamerauLevenshteinDistanceWorker IntMap bv str1_mvs bv top_bit_mask bv vector_mask (bv pm, bv d0, bv vp, bv vn, Int distance) Char char2 = 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 bv 0 (Char -> Int ord Char char2) IntMap bv str1_mvs d0' :: bv d0' = ((((bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv sizedComplement bv vector_mask bv d0) bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .&. bv pm') bv -> Int -> bv forall a. Bits a => a -> Int -> a `shiftL` Int 1) bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .&. bv pm) bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .|. ((((bv pm' bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .&. bv vp) bv -> bv -> bv forall a. Num a => a -> a -> a + bv vp) bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .&. bv vector_mask) bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv `xor` bv vp) bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .|. bv pm' bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .|. bv vn -- No need to mask the shiftL because of the restricted range of pm hp' :: bv hp' = bv vn bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .|. bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv sizedComplement bv vector_mask (bv d0' bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .|. bv vp) hn' :: bv hn' = bv d0' bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .&. bv vp hp'_shift :: bv hp'_shift = ((bv hp' bv -> Int -> bv forall a. Bits a => a -> Int -> a `shiftL` Int 1) bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .|. bv 1) bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .&. bv vector_mask hn'_shift :: bv hn'_shift = (bv hn' bv -> Int -> bv forall a. Bits a => a -> Int -> a `shiftL` Int 1) bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .&. bv vector_mask vp' :: bv vp' = bv hn'_shift bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .|. bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv sizedComplement bv vector_mask (bv d0' bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .|. bv hp'_shift) vn' :: bv vn' = bv d0' bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .&. bv hp'_shift distance' :: Int distance' = if bv hp' bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .&. bv top_bit_mask bv -> bv -> Bool forall a. Eq a => a -> a -> Bool /= bv 0 then Int distance Int -> Int -> Int forall a. Num a => a -> a -> a + Int 1 else Int distance distance'' :: Int distance'' = if bv hn' bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .&. bv top_bit_mask bv -> bv -> Bool forall a. Eq a => a -> a -> Bool /= bv 0 then Int distance' Int -> Int -> Int forall a. Num a => a -> a -> a - Int 1 else Int distance' sizedComplement :: Bits bv => bv -> bv -> bv sizedComplement :: forall bv. Bits bv => bv -> bv -> bv sizedComplement bv vector_mask bv vect = bv vector_mask bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv `xor` bv vect matchVectors :: (Bits bv, Num bv) => String -> IM.IntMap bv matchVectors :: forall bv. (Bits bv, Num bv) => 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 b a. (b -> a -> b) -> b -> [a] -> b forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b List.foldl' (Int, IntMap bv) -> Char -> (Int, IntMap bv) forall {a} {a}. (Bits a, Integral a, Num a) => (a, IntMap a) -> Char -> (a, IntMap a) go (Int 0 :: Int, IntMap bv forall a. IntMap a IM.empty) where go :: (a, IntMap a) -> Char -> (a, IntMap a) go (a ix, IntMap a im) Char char = let ix' :: a ix' = a ix a -> a -> a forall a. Num a => a -> a -> a + a 1 im' :: IntMap a im' = (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a IM.insertWith a -> a -> a forall bv. Bits bv => bv -> bv -> bv (.|.) (Char -> Int ord Char char) (a 2 a -> a -> a forall a b. (Num a, Integral b) => a -> b -> a ^ a ix) IntMap a im in a -> (a, IntMap a) -> (a, IntMap a) 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 String key [String] vals = String -> [(String, String)] -> [String] forall a. String -> [(String, a)] -> [a] fuzzyLookup String key [(String v,String v) | String v <- [String] vals] -- | Search for possible matches to the users input in the given list, -- returning a small number of ranked results fuzzyLookup :: String -> [(String,a)] -> [a] fuzzyLookup :: forall a. String -> [(String, a)] -> [a] fuzzyLookup String user_entered [(String, a)] possibilities = ((a, (Int, Int, String)) -> a) -> [(a, (Int, Int, String))] -> [a] forall a b. (a -> b) -> [a] -> [b] map (a, (Int, Int, String)) -> a forall a b. (a, b) -> a fst ([(a, (Int, Int, String))] -> [a]) -> [(a, (Int, Int, String))] -> [a] forall a b. (a -> b) -> a -> b $ Int -> [(a, (Int, Int, String))] -> [(a, (Int, Int, String))] forall a. Int -> [a] -> [a] take Int mAX_RESULTS ([(a, (Int, Int, String))] -> [(a, (Int, Int, String))]) -> [(a, (Int, Int, String))] -> [(a, (Int, Int, String))] forall a b. (a -> b) -> a -> b $ ((a, (Int, Int, String)) -> (a, (Int, Int, String)) -> Ordering) -> [(a, (Int, Int, String))] -> [(a, (Int, Int, String))] forall a. (a -> a -> Ordering) -> [a] -> [a] List.sortBy (((a, (Int, Int, String)) -> (Int, Int, String)) -> (a, (Int, Int, String)) -> (a, (Int, Int, String)) -> Ordering forall a b. Ord a => (b -> a) -> b -> b -> Ordering comparing (a, (Int, Int, String)) -> (Int, Int, String) forall a b. (a, b) -> b snd) [ (a poss_val, (Int, Int, String) sort_key) | (String poss_str, a poss_val) <- [(String, a)] possibilities , 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 , let sort_key :: (Int, Int, String) sort_key = (Int distance, String -> Int forall a. [a] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length String poss_str, String poss_str) ] where -- Work out an appropriate match threshold: -- We report a candidate if its edit distance is <= the threshold, -- The threshold is set to about a quarter of the # of characters the user entered -- Length Threshold -- 1 0 -- Don't suggest *any* candidates -- 2 1 -- for single-char identifiers -- 3 1 -- 4 1 -- 5 1 -- 6 2 -- -- Candidates with the same distance are sorted by their length. We also -- use the actual string as the third sorting criteria the sort key to get -- deterministic output, even if the input may have depended on the uniques -- in question fuzzy_threshold :: Int fuzzy_threshold = Rational -> Int forall b. Integral b => Rational -> b 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 a. [a] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length String user_entered Int -> Int -> Int forall a. Num a => a -> a -> a + Int 2) Rational -> Rational -> Rational forall a. Fractional a => a -> a -> a / (Rational 4 :: Rational) mAX_RESULTS :: Int mAX_RESULTS = Int 3 {- ************************************************************************ * * \subsection[Utils-pairs]{Pairs} * * ************************************************************************ -} unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] unzipWith :: forall a b c. (a -> b -> c) -> [(a, b)] -> [c] unzipWith = ((a, b) -> c) -> [(a, b)] -> [c] forall a b. (a -> b) -> [a] -> [b] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (((a, b) -> c) -> [(a, b)] -> [c]) -> ((a -> b -> c) -> (a, b) -> c) -> (a -> b -> c) -> [(a, b)] -> [c] forall b c a. (b -> c) -> (a -> b) -> a -> c . (a -> b -> c) -> (a, b) -> c forall a b c. (a -> b -> c) -> (a, b) -> c uncurry seqList :: [a] -> b -> b seqList :: forall a b. [a] -> b -> b seqList [] b b = b b seqList (a x:[a] xs) b b = a x a -> b -> b forall a b. a -> b -> b `seq` [a] -> b -> b forall a b. [a] -> b -> b seqList [a] xs b b strictMap :: (a -> b) -> [a] -> [b] strictMap :: forall a b. (a -> b) -> [a] -> [b] strictMap a -> b _ [] = [] strictMap a -> b f (a x:[a] xs) = let !x' :: b x' = a -> b f a x !xs' :: [b] xs' = (a -> b) -> [a] -> [b] forall a b. (a -> b) -> [a] -> [b] strictMap a -> b f [a] xs in b x' b -> [b] -> [b] forall a. a -> [a] -> [a] : [b] xs' strictZipWith :: (a -> b -> c) -> [a] -> [b] -> [c] strictZipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] strictZipWith a -> b -> c _ [] [b] _ = [] strictZipWith a -> b -> c _ [a] _ [] = [] strictZipWith a -> b -> c f (a x:[a] xs) (b y:[b] ys) = let !x' :: c x' = a -> b -> c f a x b y !xs' :: [c] xs' = (a -> b -> c) -> [a] -> [b] -> [c] forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] strictZipWith a -> b -> c f [a] xs [b] ys in c x' c -> [c] -> [c] forall a. a -> [a] -> [a] : [c] xs' strictZipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] strictZipWith3 :: forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] strictZipWith3 a -> b -> c -> d _ [] [b] _ [c] _ = [] strictZipWith3 a -> b -> c -> d _ [a] _ [] [c] _ = [] strictZipWith3 a -> b -> c -> d _ [a] _ [b] _ [] = [] strictZipWith3 a -> b -> c -> d f (a x:[a] xs) (b y:[b] ys) (c z:[c] zs) = let !x' :: d x' = a -> b -> c -> d f a x b y c z !xs' :: [d] xs' = (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] strictZipWith3 a -> b -> c -> d f [a] xs [b] ys [c] zs in d x' d -> [d] -> [d] forall a. a -> [a] -> [a] : [d] xs' -- Module names: looksLikeModuleName :: String -> Bool looksLikeModuleName :: String -> Bool looksLikeModuleName [] = Bool False looksLikeModuleName (Char c:String cs) = Char -> Bool isUpper Char c Bool -> Bool -> Bool && String -> Bool go String cs where go :: String -> Bool go [] = Bool True go (Char '.':String cs) = String -> Bool looksLikeModuleName String cs go (Char c:String cs) = (Char -> Bool isAlphaNum Char c Bool -> Bool -> Bool || Char c Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char '_' Bool -> Bool -> Bool || Char c Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char '\'') Bool -> Bool -> Bool && String -> Bool go String cs -- Similar to 'parse' for Distribution.Package.PackageName, -- but we don't want to depend on Cabal. looksLikePackageName :: String -> Bool looksLikePackageName :: String -> Bool looksLikePackageName = (String -> Bool) -> [String] -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all ((Char -> Bool) -> String -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all Char -> Bool isAlphaNum (String -> Bool) -> (String -> Bool) -> String -> Bool forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool <&&> Bool -> Bool not (Bool -> Bool) -> (String -> Bool) -> String -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . ((Char -> Bool) -> String -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all Char -> Bool isDigit)) ([String] -> Bool) -> (String -> [String]) -> String -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . Char -> String -> [String] split Char '-' ----------------------------------------------------------------------------- -- Integers -- | Determine the $\log_2$ of exact powers of 2 exactLog2 :: Integer -> Maybe Integer exactLog2 :: Integer -> Maybe Integer exactLog2 Integer x | Integer x Integer -> Integer -> Bool forall a. Ord a => a -> a -> Bool <= Integer 0 = Maybe Integer forall a. Maybe a Nothing | Integer x Integer -> Integer -> Bool forall a. Ord a => a -> a -> Bool > Int32 -> Integer forall a b. (Integral a, Num b) => a -> b fromIntegral (Int32 forall a. Bounded a => a maxBound :: Int32) = Maybe Integer forall a. Maybe a Nothing | Int32 x' Int32 -> Int32 -> Int32 forall bv. Bits bv => bv -> bv -> bv .&. (-Int32 x') Int32 -> Int32 -> Bool forall a. Eq a => a -> a -> Bool /= Int32 x' = Maybe Integer forall a. Maybe a Nothing | Bool otherwise = Integer -> Maybe Integer forall a. a -> Maybe a Just (Int -> Integer forall a b. (Integral a, Num b) => a -> b fromIntegral Int c) where x' :: Int32 x' = Integer -> Int32 forall a b. (Integral a, Num b) => a -> b fromIntegral Integer x :: Int32 c :: Int c = Int32 -> Int forall b. FiniteBits b => b -> Int countTrailingZeros Int32 x' {- -- ----------------------------------------------------------------------------- -- Floats -} readRational__ :: ReadS Rational -- NB: doesn't handle leading "-" readRational__ :: ReadS Rational readRational__ String r = do ((Integer i, Integer e), String t) <- ReadS (Integer, Integer) readSignificandExponentPair__ String r (Rational, String) -> [(Rational, String)] forall a. a -> [a] forall (m :: * -> *) a. Monad m => a -> m a return ((Integer iInteger -> Integer -> Rational forall a. Integral a => a -> a -> Ratio a %Integer 1)Rational -> Rational -> Rational forall a. Num a => a -> a -> a *Rational 10Rational -> Integer -> Rational forall a b. (Fractional a, Integral b) => a -> b -> a ^^Integer e, String t) readRational :: String -> Rational -- NB: *does* handle a leading "-" readRational :: String -> Rational readRational String top_s = case String top_s of Char '-' : String xs -> Rational -> Rational forall a. Num a => a -> a negate (String -> Rational read_me String xs) String xs -> String -> Rational read_me String xs where read_me :: String -> Rational read_me String s = case (do { (Rational x,String "") <- ReadS Rational readRational__ String s ; Rational -> [Rational] forall a. a -> [a] forall (m :: * -> *) a. Monad m => a -> m a return Rational x }) of [Rational x] -> Rational x [] -> String -> Rational forall a. HasCallStack => String -> a error (String "readRational: no parse:" String -> String -> String forall a. [a] -> [a] -> [a] ++ String top_s) [Rational] _ -> String -> Rational forall a. HasCallStack => String -> a error (String "readRational: ambiguous parse:" String -> String -> String forall a. [a] -> [a] -> [a] ++ String top_s) readSignificandExponentPair__ :: ReadS (Integer, Integer) -- NB: doesn't handle leading "-" readSignificandExponentPair__ :: ReadS (Integer, Integer) readSignificandExponentPair__ String r = do (Integer n,Int d,String s) <- String -> [(Integer, Int, String)] readFix String r (Int k,String t) <- String -> [(Int, String)] forall {m :: * -> *}. MonadFail m => String -> m (Int, String) readExp String s let pair :: (Integer, Integer) pair = (Integer n, Int -> Integer forall a. Integral a => a -> Integer toInteger (Int k Int -> Int -> Int forall a. Num a => a -> a -> a - Int d)) ((Integer, Integer), String) -> [((Integer, Integer), String)] forall a. a -> [a] forall (m :: * -> *) a. Monad m => a -> m a return ((Integer, Integer) pair, String t) where readFix :: String -> [(Integer, Int, String)] readFix String r = do (String ds,String s) <- String -> [(String, String)] lexDecDigits String r (String ds',String t) <- String -> [(String, String)] forall {m :: * -> *}. Monad m => String -> m (String, String) lexDotDigits String s (Integer, Int, String) -> [(Integer, Int, String)] forall a. a -> [a] forall (m :: * -> *) a. Monad m => a -> m a return (String -> Integer forall a. Read a => String -> a read (String dsString -> String -> String forall a. [a] -> [a] -> [a] ++String ds'), String -> Int forall a. [a] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length String ds', String t) readExp :: String -> m (Int, String) readExp (Char e:String s) | Char e Char -> String -> Bool forall a. Eq a => a -> [a] -> Bool forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` String "eE" = String -> m (Int, String) forall {m :: * -> *}. MonadFail m => String -> m (Int, String) readExp' String s readExp String s = (Int, String) -> m (Int, String) forall a. a -> m a forall (m :: * -> *) a. Monad m => a -> m a return (Int 0,String s) readExp' :: String -> m (Int, String) readExp' (Char '+':String s) = String -> m (Int, String) forall {m :: * -> *}. MonadFail m => String -> m (Int, String) readDec String s readExp' (Char '-':String s) = do (Int k,String t) <- String -> m (Int, String) forall {m :: * -> *}. MonadFail m => String -> m (Int, String) readDec String s (Int, String) -> m (Int, String) forall a. a -> m a forall (m :: * -> *) a. Monad m => a -> m a return (-Int k,String t) readExp' String s = String -> m (Int, String) forall {m :: * -> *}. MonadFail m => String -> m (Int, String) readDec String s readDec :: String -> m (Int, String) readDec String s = do (String ds,String r) <- (Char -> Bool) -> String -> m (String, String) forall {m :: * -> *}. MonadFail m => (Char -> Bool) -> String -> m (String, String) nonnull Char -> Bool isDigit String s (Int, String) -> m (Int, String) forall a. a -> m a forall (m :: * -> *) a. Monad m => a -> m a return ((Int -> Int -> Int) -> [Int] -> Int forall a. (a -> a -> a) -> [a] -> a forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a foldl1 (\Int n Int d -> Int n Int -> Int -> Int forall a. Num a => a -> a -> a * Int 10 Int -> Int -> Int forall a. Num a => a -> a -> a + Int d) [ Char -> Int ord Char d Int -> Int -> Int forall a. Num a => a -> a -> a - Char -> Int ord Char '0' | Char d <- String ds ], String r) lexDecDigits :: String -> [(String, String)] lexDecDigits = (Char -> Bool) -> String -> [(String, String)] forall {m :: * -> *}. MonadFail m => (Char -> Bool) -> String -> m (String, String) nonnull Char -> Bool isDigit lexDotDigits :: String -> m (String, String) lexDotDigits (Char '.':String s) = (String, String) -> m (String, String) forall a. a -> m a forall (m :: * -> *) a. Monad m => a -> m a return ((Char -> Bool) -> String -> (String, String) span' Char -> Bool isDigit String s) lexDotDigits String s = (String, String) -> m (String, String) forall a. a -> m a forall (m :: * -> *) a. Monad m => a -> m a return (String "",String s) nonnull :: (Char -> Bool) -> String -> m (String, String) nonnull Char -> Bool p String s = do (cs :: String cs@(Char _:String _),String t) <- (String, String) -> m (String, String) forall a. a -> m a 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 a. a -> m a forall (m :: * -> *) a. Monad m => a -> m a return (String cs,String t) span' :: (Char -> Bool) -> String -> (String, String) span' Char -> Bool _ xs :: String xs@[] = (String xs, String xs) span' Char -> Bool p xs :: String xs@(Char x:String xs') | Char x Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char '_' = (Char -> Bool) -> String -> (String, String) span' Char -> Bool p String xs' -- skip "_" (#14473) | Char -> Bool p Char x = let (String ys,String zs) = (Char -> Bool) -> String -> (String, String) span' Char -> Bool p String xs' in (Char xChar -> String -> String forall a. a -> [a] -> [a] :String ys,String zs) | Bool otherwise = ([],String xs) -- | Parse a string into a significand and exponent. -- A trivial example might be: -- ghci> readSignificandExponentPair "1E2" -- (1,2) -- In a more complex case we might return a exponent different than that -- which the user wrote. This is needed in order to use a Integer significand. -- ghci> readSignificandExponentPair "-1.11E5" -- (-111,3) readSignificandExponentPair :: String -> (Integer, Integer) -- NB: *does* handle a leading "-" readSignificandExponentPair :: String -> (Integer, Integer) readSignificandExponentPair String top_s = case String top_s of Char '-' : String xs -> let (Integer i, Integer e) = String -> (Integer, Integer) read_me String xs in (-Integer i, Integer e) String xs -> String -> (Integer, Integer) read_me String xs where read_me :: String -> (Integer, Integer) read_me String s = case (do { ((Integer, Integer) x,String "") <- ReadS (Integer, Integer) readSignificandExponentPair__ String s ; (Integer, Integer) -> [(Integer, Integer)] forall a. a -> [a] forall (m :: * -> *) a. Monad m => a -> m a return (Integer, Integer) x }) of [(Integer, Integer) x] -> (Integer, Integer) x [] -> String -> (Integer, Integer) forall a. HasCallStack => String -> a error (String "readSignificandExponentPair: no parse:" String -> String -> String forall a. [a] -> [a] -> [a] ++ String top_s) [(Integer, Integer)] _ -> String -> (Integer, Integer) forall a. HasCallStack => String -> a error (String "readSignificandExponentPair: ambiguous parse:" String -> String -> String forall a. [a] -> [a] -> [a] ++ String top_s) readHexRational :: String -> Rational readHexRational :: String -> Rational readHexRational String str = case String str of Char '-' : String xs -> Rational -> Rational forall a. Num a => a -> a negate (String -> Rational readMe String xs) String xs -> String -> Rational readMe String xs where readMe :: String -> Rational readMe String as = case String -> Maybe Rational readHexRational__ String as of Just Rational n -> Rational n Maybe Rational _ -> String -> Rational forall a. HasCallStack => String -> a error (String "readHexRational: no parse:" String -> String -> String forall a. [a] -> [a] -> [a] ++ String str) readHexRational__ :: String -> Maybe Rational readHexRational__ :: String -> Maybe Rational readHexRational__ (Char '0' : Char x : String rest) | Char x Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char 'X' Bool -> Bool -> Bool || Char x Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char 'x' = do let (String front,String rest2) = (Char -> Bool) -> String -> (String, String) span' Char -> Bool isHexDigit String rest Bool -> Maybe () forall (f :: * -> *). Alternative f => Bool -> f () guard (Bool -> Bool not (String -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null String front)) let frontNum :: Integer frontNum = Integer -> Integer -> String -> Integer forall {t :: * -> *} {b}. (Foldable t, Num b) => b -> b -> t Char -> b steps Integer 16 Integer 0 String front case String rest2 of Char '.' : String rest3 -> do let (String back,String rest4) = (Char -> Bool) -> String -> (String, String) span' Char -> Bool isHexDigit String rest3 Bool -> Maybe () forall (f :: * -> *). Alternative f => Bool -> f () guard (Bool -> Bool not (String -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null String back)) let backNum :: Integer backNum = Integer -> Integer -> String -> Integer forall {t :: * -> *} {b}. (Foldable t, Num b) => b -> b -> t Char -> b steps Integer 16 Integer frontNum String back exp1 :: Int exp1 = -Int 4 Int -> Int -> Int forall a. Num a => a -> a -> a * String -> Int forall a. [a] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length String back case String rest4 of Char p : String ps | Char -> Bool isExp Char p -> (Int -> Rational) -> Maybe Int -> Maybe Rational forall a b. (a -> b) -> Maybe a -> Maybe b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (Integer -> Int -> Rational mk Integer backNum (Int -> Rational) -> (Int -> Int) -> Int -> Rational forall b c a. (b -> c) -> (a -> b) -> a -> c . (Int -> Int -> Int forall a. Num a => a -> a -> a + Int exp1)) (String -> Maybe Int forall {a}. Num a => String -> Maybe a getExp String ps) String _ -> Rational -> Maybe Rational forall a. a -> Maybe a forall (m :: * -> *) a. Monad m => a -> m a return (Integer -> Int -> Rational mk Integer backNum Int exp1) Char p : String ps | Char -> Bool isExp Char p -> (Int -> Rational) -> Maybe Int -> Maybe Rational forall a b. (a -> b) -> Maybe a -> Maybe b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (Integer -> Int -> Rational mk Integer frontNum) (String -> Maybe Int forall {a}. Num a => String -> Maybe a getExp String ps) String _ -> Maybe Rational forall a. Maybe a Nothing where isExp :: Char -> Bool isExp Char p = Char p Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char 'p' Bool -> Bool -> Bool || Char p Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char 'P' getExp :: String -> Maybe a getExp (Char '+' : String ds) = String -> Maybe a forall {a}. Num a => String -> Maybe a dec String ds getExp (Char '-' : String ds) = (a -> a) -> Maybe a -> Maybe a forall a b. (a -> b) -> Maybe a -> Maybe b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap a -> a forall a. Num a => a -> a negate (String -> Maybe a forall {a}. Num a => String -> Maybe a dec String ds) getExp String ds = String -> Maybe a forall {a}. Num a => String -> Maybe a dec String ds mk :: Integer -> Int -> Rational mk :: Integer -> Int -> Rational mk Integer n Int e = Integer -> Rational forall a. Num a => Integer -> a fromInteger Integer n Rational -> Rational -> Rational forall a. Num a => a -> a -> a * Rational 2Rational -> Int -> Rational forall a b. (Fractional a, Integral b) => a -> b -> a ^^Int e dec :: String -> Maybe a dec String cs = case (Char -> Bool) -> String -> (String, String) span' Char -> Bool isDigit String cs of (String ds,String "") | Bool -> Bool not (String -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null String ds) -> a -> Maybe a forall a. a -> Maybe a Just (a -> a -> String -> a forall {t :: * -> *} {b}. (Foldable t, Num b) => b -> b -> t Char -> b steps a 10 a 0 String ds) (String, String) _ -> Maybe a forall a. Maybe a Nothing steps :: b -> b -> t Char -> b steps b base b n t Char ds = (b -> Char -> b) -> b -> t Char -> b forall b a. (b -> a -> b) -> b -> t a -> b forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b List.foldl' (b -> b -> Char -> b forall {a}. Num a => a -> a -> Char -> a step b base) b n t Char ds step :: a -> a -> Char -> a step a base a n Char d = a base a -> a -> a forall a. Num a => a -> a -> a * a n a -> a -> a forall a. Num a => a -> a -> a + Int -> a forall a b. (Integral a, Num b) => a -> b fromIntegral (Char -> Int digitToInt Char d) span' :: (Char -> Bool) -> String -> (String, String) span' Char -> Bool _ xs :: String xs@[] = (String xs, String xs) span' Char -> Bool p xs :: String xs@(Char x:String xs') | Char x Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char '_' = (Char -> Bool) -> String -> (String, String) span' Char -> Bool p String xs' -- skip "_" (#14473) | Char -> Bool p Char x = let (String ys,String zs) = (Char -> Bool) -> String -> (String, String) span' Char -> Bool p String xs' in (Char xChar -> String -> String forall a. a -> [a] -> [a] :String ys,String zs) | Bool otherwise = ([],String xs) readHexRational__ String _ = Maybe Rational forall a. Maybe a Nothing -- | Parse a string into a significand and exponent according to -- the "Hexadecimal Floats in Haskell" proposal. -- A trivial example might be: -- ghci> readHexSignificandExponentPair "0x1p+1" -- (1,1) -- Behaves similar to readSignificandExponentPair but the base is 16 -- and numbers are given in hexadecimal: -- ghci> readHexSignificandExponentPair "0xAp-4" -- (10,-4) -- ghci> readHexSignificandExponentPair "0x1.2p3" -- (18,-1) readHexSignificandExponentPair :: String -> (Integer, Integer) readHexSignificandExponentPair :: String -> (Integer, Integer) readHexSignificandExponentPair String str = case String str of Char '-' : String xs -> let (Integer i, Integer e) = String -> (Integer, Integer) readMe String xs in (-Integer i, Integer e) String xs -> String -> (Integer, Integer) readMe String xs where readMe :: String -> (Integer, Integer) readMe String as = case String -> Maybe (Integer, Integer) readHexSignificandExponentPair__ String as of Just (Integer, Integer) n -> (Integer, Integer) n Maybe (Integer, Integer) _ -> String -> (Integer, Integer) forall a. HasCallStack => String -> a error (String "readHexSignificandExponentPair: no parse:" String -> String -> String forall a. [a] -> [a] -> [a] ++ String str) readHexSignificandExponentPair__ :: String -> Maybe (Integer, Integer) readHexSignificandExponentPair__ :: String -> Maybe (Integer, Integer) readHexSignificandExponentPair__ (Char '0' : Char x : String rest) | Char x Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char 'X' Bool -> Bool -> Bool || Char x Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char 'x' = do let (String front,String rest2) = (Char -> Bool) -> String -> (String, String) span' Char -> Bool isHexDigit String rest Bool -> Maybe () forall (f :: * -> *). Alternative f => Bool -> f () guard (Bool -> Bool not (String -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null String front)) let frontNum :: Integer frontNum = Integer -> Integer -> String -> Integer forall {t :: * -> *} {b}. (Foldable t, Num b) => b -> b -> t Char -> b steps Integer 16 Integer 0 String front case String rest2 of Char '.' : String rest3 -> do let (String back,String rest4) = (Char -> Bool) -> String -> (String, String) span' Char -> Bool isHexDigit String rest3 Bool -> Maybe () forall (f :: * -> *). Alternative f => Bool -> f () guard (Bool -> Bool not (String -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null String back)) let backNum :: Integer backNum = Integer -> Integer -> String -> Integer forall {t :: * -> *} {b}. (Foldable t, Num b) => b -> b -> t Char -> b steps Integer 16 Integer frontNum String back exp1 :: Int exp1 = -Int 4 Int -> Int -> Int forall a. Num a => a -> a -> a * String -> Int forall a. [a] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length String back case String rest4 of Char p : String ps | Char -> Bool isExp Char p -> (Int -> (Integer, Integer)) -> Maybe Int -> Maybe (Integer, Integer) forall a b. (a -> b) -> Maybe a -> Maybe b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (Integer -> Int -> (Integer, Integer) mk Integer backNum (Int -> (Integer, Integer)) -> (Int -> Int) -> Int -> (Integer, Integer) forall b c a. (b -> c) -> (a -> b) -> a -> c . (Int -> Int -> Int forall a. Num a => a -> a -> a + Int exp1)) (String -> Maybe Int forall {a}. Num a => String -> Maybe a getExp String ps) String _ -> (Integer, Integer) -> Maybe (Integer, Integer) forall a. a -> Maybe a forall (m :: * -> *) a. Monad m => a -> m a return (Integer -> Int -> (Integer, Integer) mk Integer backNum Int exp1) Char p : String ps | Char -> Bool isExp Char p -> (Int -> (Integer, Integer)) -> Maybe Int -> Maybe (Integer, Integer) forall a b. (a -> b) -> Maybe a -> Maybe b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (Integer -> Int -> (Integer, Integer) mk Integer frontNum) (String -> Maybe Int forall {a}. Num a => String -> Maybe a getExp String ps) String _ -> Maybe (Integer, Integer) forall a. Maybe a Nothing where isExp :: Char -> Bool isExp Char p = Char p Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char 'p' Bool -> Bool -> Bool || Char p Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char 'P' getExp :: String -> Maybe a getExp (Char '+' : String ds) = String -> Maybe a forall {a}. Num a => String -> Maybe a dec String ds getExp (Char '-' : String ds) = (a -> a) -> Maybe a -> Maybe a forall a b. (a -> b) -> Maybe a -> Maybe b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap a -> a forall a. Num a => a -> a negate (String -> Maybe a forall {a}. Num a => String -> Maybe a dec String ds) getExp String ds = String -> Maybe a forall {a}. Num a => String -> Maybe a dec String ds mk :: Integer -> Int -> (Integer, Integer) mk :: Integer -> Int -> (Integer, Integer) mk Integer n Int e = (Integer n, Int -> Integer forall a b. (Integral a, Num b) => a -> b fromIntegral Int e) dec :: String -> Maybe a dec String cs = case (Char -> Bool) -> String -> (String, String) span' Char -> Bool isDigit String cs of (String ds,String "") | Bool -> Bool not (String -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null String ds) -> a -> Maybe a forall a. a -> Maybe a Just (a -> a -> String -> a forall {t :: * -> *} {b}. (Foldable t, Num b) => b -> b -> t Char -> b steps a 10 a 0 String ds) (String, String) _ -> Maybe a forall a. Maybe a Nothing steps :: b -> b -> t Char -> b steps b base b n t Char ds = (b -> Char -> b) -> b -> t Char -> b forall b a. (b -> a -> b) -> b -> t a -> b forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl' (b -> b -> Char -> b forall {a}. Num a => a -> a -> Char -> a step b base) b n t Char ds step :: a -> a -> Char -> a step a base a n Char d = a base a -> a -> a forall a. Num a => a -> a -> a * a n a -> a -> a forall a. Num a => a -> a -> a + Int -> a forall a b. (Integral a, Num b) => a -> b fromIntegral (Char -> Int digitToInt Char d) span' :: (Char -> Bool) -> String -> (String, String) span' Char -> Bool _ xs :: String xs@[] = (String xs, String xs) span' Char -> Bool p xs :: String xs@(Char x:String xs') | Char x Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char '_' = (Char -> Bool) -> String -> (String, String) span' Char -> Bool p String xs' -- skip "_" (#14473) | Char -> Bool p Char x = let (String ys,String zs) = (Char -> Bool) -> String -> (String, String) span' Char -> Bool p String xs' in (Char xChar -> String -> String forall a. a -> [a] -> [a] :String ys,String zs) | Bool otherwise = ([],String xs) readHexSignificandExponentPair__ String _ = Maybe (Integer, Integer) forall a. Maybe a Nothing ----------------------------------------------------------------------------- -- Verify that the 'dirname' portion of a FilePath exists. -- doesDirNameExist :: FilePath -> IO Bool doesDirNameExist :: String -> IO Bool doesDirNameExist String fpath = String -> IO Bool doesDirectoryExist (String -> String takeDirectory String fpath) ----------------------------------------------------------------------------- -- Backwards compatibility definition of getModificationTime getModificationUTCTime :: FilePath -> IO UTCTime getModificationUTCTime :: String -> IO UTCTime getModificationUTCTime = String -> IO UTCTime getModificationTime -- -------------------------------------------------------------- -- check existence & modification time at the same time modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime) modificationTimeIfExists :: String -> IO (Maybe UTCTime) modificationTimeIfExists String f = (do UTCTime t <- String -> IO UTCTime getModificationUTCTime String f; Maybe UTCTime -> IO (Maybe UTCTime) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return (UTCTime -> Maybe UTCTime forall a. a -> Maybe a Just UTCTime t)) IO (Maybe UTCTime) -> (IOException -> IO (Maybe UTCTime)) -> IO (Maybe UTCTime) forall a. IO a -> (IOException -> IO a) -> IO a `catchIO` \IOException e -> if IOException -> Bool isDoesNotExistError IOException e then Maybe UTCTime -> IO (Maybe UTCTime) forall a. a -> IO a 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 -- -------------------------------------------------------------- -- check existence & hash at the same time fileHashIfExists :: FilePath -> IO (Maybe Fingerprint) fileHashIfExists :: String -> IO (Maybe Fingerprint) fileHashIfExists String f = (do Fingerprint t <- String -> IO Fingerprint getFileHash String f; Maybe Fingerprint -> IO (Maybe Fingerprint) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return (Fingerprint -> Maybe Fingerprint forall a. a -> Maybe a Just Fingerprint t)) IO (Maybe Fingerprint) -> (IOException -> IO (Maybe Fingerprint)) -> IO (Maybe Fingerprint) forall a. IO a -> (IOException -> IO a) -> IO a `catchIO` \IOException e -> if IOException -> Bool isDoesNotExistError IOException e then Maybe Fingerprint -> IO (Maybe Fingerprint) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return Maybe Fingerprint forall a. Maybe a Nothing else IOException -> IO (Maybe Fingerprint) forall a. IOException -> IO a ioError IOException e -- -------------------------------------------------------------- -- atomic file writing by writing to a temporary file first (see #14533) -- -- This should be used in all cases where GHC writes files to disk -- and uses their modification time to skip work later, -- as otherwise a partially written file (e.g. due to crash or Ctrl+C) -- also results in a skip. withAtomicRename :: (MonadIO m) => FilePath -> (FilePath -> m a) -> m a withAtomicRename :: forall (m :: * -> *) a. MonadIO m => String -> (String -> m a) -> m a withAtomicRename String targetFile String -> m a f = do -- The temp file must be on the same file system (mount) as the target file -- to result in an atomic move on most platforms. -- The standard way to ensure that is to place it into the same directory. -- This can still be fooled when somebody mounts a different file system -- at just the right time, but that is not a case we aim to cover here. let temp :: String temp = String targetFile String -> String -> String <.> String "tmp" a res <- String -> m a f String temp IO () -> m () forall a. IO a -> m a forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> m ()) -> IO () -> m () forall a b. (a -> b) -> a -> b $ String -> String -> IO () renameFile String temp String targetFile a -> m a forall a. a -> m a forall (m :: * -> *) a. Monad m => a -> m a return a res -- -------------------------------------------------------------- -- split a string at the last character where 'pred' is True, -- returning a pair of strings. The first component holds the string -- up (but not including) the last character for which 'pred' returned -- True, the second whatever comes after (but also not including the -- last character). -- -- If 'pred' returns False for all characters in the string, the original -- string is returned in the first component (and the second one is just -- empty). splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) splitLongestPrefix :: String -> (Char -> Bool) -> (String, String) splitLongestPrefix String str Char -> Bool pred = case String r_pre of [] -> (String str, []) Char _:String r_pre' -> (String -> String forall a. [a] -> [a] reverse String r_pre', String -> String forall a. [a] -> [a] reverse String r_suf) -- 'tail' drops the char satisfying 'pred' where (String r_suf, String r_pre) = (Char -> Bool) -> String -> (String, String) forall a. (a -> Bool) -> [a] -> ([a], [a]) break Char -> Bool pred (String -> String forall a. [a] -> [a] reverse String str) escapeSpaces :: String -> String escapeSpaces :: String -> String escapeSpaces = (Char -> String -> String) -> String -> String -> String forall a b. (a -> b -> b) -> b -> [a] -> b forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr (\Char c String s -> if Char -> Bool isSpace Char c then Char '\\'Char -> String -> String forall a. a -> [a] -> [a] :Char cChar -> String -> String forall a. a -> [a] -> [a] :String s else Char cChar -> String -> String forall a. a -> [a] -> [a] :String s) String "" type Suffix = String -------------------------------------------------------------- -- * Search path -------------------------------------------------------------- data Direction = Forwards | Backwards reslash :: Direction -> FilePath -> FilePath reslash :: Direction -> String -> String reslash Direction d = String -> String f where f :: String -> String f (Char '/' : String xs) = Char slash Char -> String -> String forall a. a -> [a] -> [a] : String -> String f String xs f (Char '\\' : String xs) = Char slash Char -> String -> String forall a. a -> [a] -> [a] : String -> String f String xs f (Char x : String xs) = Char x Char -> String -> String forall a. a -> [a] -> [a] : String -> String f String xs f String "" = String "" slash :: Char slash = case Direction d of Direction Forwards -> Char '/' Direction Backwards -> Char '\\' makeRelativeTo :: FilePath -> FilePath -> FilePath String this makeRelativeTo :: String -> String -> String `makeRelativeTo` String that = String directory String -> String -> String </> String thisFilename where (String thisDirectory, String thisFilename) = String -> (String, String) splitFileName String this thatDirectory :: String thatDirectory = String -> String dropFileName String that directory :: String directory = [String] -> String joinPath ([String] -> String) -> [String] -> String forall a b. (a -> b) -> a -> b $ [String] -> [String] -> [String] f (String -> [String] splitPath String thisDirectory) (String -> [String] splitPath String thatDirectory) f :: [String] -> [String] -> [String] f (String x : [String] xs) (String y : [String] ys) | String x String -> String -> Bool forall a. Eq a => a -> a -> Bool == String y = [String] -> [String] -> [String] f [String] xs [String] ys f [String] xs [String] ys = Int -> String -> [String] forall a. Int -> a -> [a] replicate ([String] -> Int forall a. [a] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [String] ys) String ".." [String] -> [String] -> [String] forall a. [a] -> [a] -> [a] ++ [String] xs {- ************************************************************************ * * \subsection[Utils-Data]{Utils for defining Data instances} * * ************************************************************************ These functions helps us to define Data instances for abstract types. -} abstractConstr :: String -> Constr abstractConstr :: String -> Constr abstractConstr String n = DataType -> String -> [String] -> Fixity -> Constr mkConstr (String -> DataType abstractDataType String n) (String "{abstract:"String -> String -> String forall a. [a] -> [a] -> [a] ++String nString -> String -> String forall a. [a] -> [a] -> [a] ++String "}") [] Fixity Prefix abstractDataType :: String -> DataType abstractDataType :: String -> DataType abstractDataType String n = String -> [Constr] -> DataType mkDataType String n [String -> Constr abstractConstr String n] {- ************************************************************************ * * \subsection[Utils-C]{Utils for printing C code} * * ************************************************************************ -} charToC :: Word8 -> String charToC :: Word8 -> String charToC Word8 w = case Int -> Char chr (Word8 -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral Word8 w) of Char '\"' -> String "\\\"" Char '\'' -> String "\\\'" Char '\\' -> String "\\\\" Char c | Char c Char -> Char -> Bool forall a. Ord a => a -> a -> Bool >= Char ' ' Bool -> Bool -> Bool && Char c Char -> Char -> Bool forall a. Ord a => a -> a -> Bool <= Char '~' -> [Char c] | Bool otherwise -> [Char '\\', Int -> Char chr (Char -> Int ord Char '0' Int -> Int -> Int forall a. Num a => a -> a -> a + Char -> Int ord Char c Int -> Int -> Int forall a. Integral a => a -> a -> a `div` Int 64), Int -> Char chr (Char -> Int ord Char '0' Int -> Int -> Int forall a. Num a => a -> a -> a + Char -> Int ord Char c Int -> Int -> Int forall a. Integral a => a -> a -> a `div` Int 8 Int -> Int -> Int forall a. Integral a => a -> a -> a `mod` Int 8), Int -> Char chr (Char -> Int ord Char '0' Int -> Int -> Int forall a. Num a => a -> a -> a + Char -> Int ord Char c Int -> Int -> Int forall a. Integral a => a -> a -> a `mod` Int 8)] {- ************************************************************************ * * \subsection[Utils-Hashing]{Utils for hashing} * * ************************************************************************ -} -- | A sample hash function for Strings. We keep multiplying by the -- golden ratio and adding. The implementation is: -- -- > hashString = foldl' f golden -- > where f m c = fromIntegral (ord c) * magic + hashInt32 m -- > magic = 0xdeadbeef -- -- Where hashInt32 works just as hashInt shown above. -- -- Knuth argues that repeated multiplication by the golden ratio -- will minimize gaps in the hash space, and thus it's a good choice -- for combining together multiple keys to form one. -- -- Here we know that individual characters c are often small, and this -- produces frequent collisions if we use ord c alone. A -- particular problem are the shorter low ASCII and ISO-8859-1 -- character strings. We pre-multiply by a magic twiddle factor to -- obtain a good distribution. In fact, given the following test: -- -- > testp :: Int32 -> Int -- > testp k = (n - ) . length . group . sort . map hs . take n $ ls -- > where ls = [] : [c : l | l <- ls, c <- ['\0'..'\xff']] -- > hs = foldl' f golden -- > f m c = fromIntegral (ord c) * k + hashInt32 m -- > n = 100000 -- -- We discover that testp magic = 0. hashString :: String -> Int32 hashString :: String -> Int32 hashString = (Int32 -> Char -> Int32) -> Int32 -> String -> Int32 forall b a. (b -> a -> b) -> b -> [a] -> b forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl' Int32 -> Char -> Int32 f Int32 golden where f :: Int32 -> Char -> Int32 f Int32 m Char c = Int -> Int32 forall a b. (Integral a, Num b) => a -> b fromIntegral (Char -> Int ord Char c) Int32 -> Int32 -> Int32 forall a. Num a => a -> a -> a * Int32 magic Int32 -> Int32 -> Int32 forall a. Num a => a -> a -> a + Int32 -> Int32 hashInt32 Int32 m magic :: Int32 magic = Word32 -> Int32 forall a b. (Integral a, Num b) => a -> b fromIntegral (Word32 0xdeadbeef :: Word32) golden :: Int32 golden :: Int32 golden = Int32 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32 -- was -1640531527 = round ((sqrt 5 - 1) * 2^31) :: Int32 -- but that has bad mulHi properties (even adding 2^32 to get its inverse) -- Whereas the above works well and contains no hash duplications for -- [-32767..65536] -- | A sample (and useful) hash function for Int32, -- implemented by extracting the uppermost 32 bits of the 64-bit -- result of multiplying by a 33-bit constant. The constant is from -- Knuth, derived from the golden ratio: -- -- > golden = round ((sqrt 5 - 1) * 2^32) -- -- We get good key uniqueness on small inputs -- (a problem with previous versions): -- (length $ group $ sort $ map hashInt32 [-32767..65536]) == 65536 + 32768 -- hashInt32 :: Int32 -> Int32 hashInt32 :: Int32 -> Int32 hashInt32 Int32 x = Int32 -> Int32 -> Int32 mulHi Int32 x Int32 golden Int32 -> Int32 -> Int32 forall a. Num a => a -> a -> a + Int32 x -- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply mulHi :: Int32 -> Int32 -> Int32 mulHi :: Int32 -> Int32 -> Int32 mulHi Int32 a Int32 b = Int64 -> Int32 forall a b. (Integral a, Num b) => a -> b fromIntegral (Int64 r Int64 -> Int -> Int64 forall a. Bits a => a -> Int -> a `shiftR` Int 32) where r :: Int64 r :: Int64 r = Int32 -> Int64 forall a b. (Integral a, Num b) => a -> b fromIntegral Int32 a Int64 -> Int64 -> Int64 forall a. Num a => a -> a -> a * Int32 -> Int64 forall a b. (Integral a, Num b) => a -> b fromIntegral Int32 b -- | A call stack constraint, but only when 'isDebugOn'. #if defined(DEBUG) type HasDebugCallStack = HasCallStack #else type HasDebugCallStack = (() :: Constraint) #endif mapMaybe' :: Foldable f => (a -> Maybe b) -> f a -> [b] mapMaybe' :: forall (f :: * -> *) a b. Foldable f => (a -> Maybe b) -> f a -> [b] mapMaybe' a -> Maybe b f = (a -> [b] -> [b]) -> [b] -> f a -> [b] forall a b. (a -> b -> b) -> b -> f a -> b forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr a -> [b] -> [b] g [] where g :: a -> [b] -> [b] g a x [b] rest | Just b y <- a -> Maybe b f a x = b y b -> [b] -> [b] forall a. a -> [a] -> [a] : [b] rest | Bool otherwise = [b] rest