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