-- (c) The University of Glasgow 2006 {-# LANGUAGE CPP #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TupleSections #-} -- | Highly random utility functions -- module Util ( -- * Flags dependent on the compiler build ghciSupported, debugIsOn, ghciTablesNextToCode, isWindowsHost, isDarwinHost, -- * Miscellaneous higher-order functions applyWhen, nTimes, -- * General list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, zipLazy, stretchZipWith, zipWithAndUnzip, zipAndUnzip, zipWithLazy, zipWith3Lazy, filterByList, filterByLists, partitionByList, unzipWith, mapFst, mapSnd, chkAppend, mapAndUnzip, mapAndUnzip3, mapAccumL2, filterOut, partitionWith, dropWhileEndLE, spanEnd, last2, lastMaybe, foldl1', foldl2, count, countWhile, all2, lengthExceeds, lengthIs, lengthIsNot, lengthAtLeast, lengthAtMost, lengthLessThan, listLengthCmp, atLength, equalLength, compareLength, leLength, ltLength, isSingleton, only, singleton, notNull, snocView, isIn, isn'tIn, chunkList, changeLast, whenNonEmpty, -- * Tuples fstOf3, sndOf3, thdOf3, firstM, first3M, secondM, fst3, snd3, third3, uncurry3, liftFst, liftSnd, -- * List operations controlled by another list takeList, dropList, splitAtList, split, dropTail, capitalise, -- * Sorting sortWith, minWith, nubSort, ordNub, -- * Comparisons isEqual, eqListBy, eqMaybeBy, thenCmp, cmpList, removeSpaces, (<&&>), (<||>), -- * Edit distance fuzzyMatch, fuzzyLookup, -- * Transitive closures transitiveClosure, -- * Strictness seqList, -- * Module names looksLikeModuleName, looksLikePackageName, -- * Argument processing getCmd, toCmdArgs, toArgs, -- * Integers exactLog2, -- * Floating point readRational, readHexRational, -- * IO-ish utilities doesDirNameExist, getModificationUTCTime, modificationTimeIfExists, withAtomicRename, global, consIORef, globalM, sharedGlobal, sharedGlobalM, -- * Filenames and paths Suffix, splitLongestPrefix, escapeSpaces, Direction(..), reslash, makeRelativeTo, -- * Utils for defining Data instances abstractConstr, abstractDataType, mkNoRepType, -- * Utils for printing C code charToC, -- * Hashing hashString, -- * Call stacks HasCallStack, HasDebugCallStack, -- * Utils for flags OverridingBool(..), overrideWith, ) where #include "HsVersions.h" import GhcPrelude import Exception import PlainPanic import Data.Data import Data.IORef ( IORef, newIORef, atomicModifyIORef' ) import System.IO.Unsafe ( unsafePerformIO ) import Data.List hiding (group) import Data.List.NonEmpty ( NonEmpty(..) ) import GHC.Exts import GHC.Stack (HasCallStack) import Control.Applicative ( liftA2 ) import Control.Monad ( liftM, guard ) import Control.Monad.IO.Class ( MonadIO, liftIO ) import GHC.Conc.Sync ( sharedCAF ) import System.IO.Error as IO ( isDoesNotExistError ) import System.Directory ( doesDirectoryExist, getModificationTime, renameFile ) import System.FilePath import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper , isHexDigit, digitToInt ) import Data.Int import Data.Ratio ( (%) ) import Data.Ord ( comparing ) import Data.Bits import Data.Word import qualified Data.IntMap as IM import qualified Data.Set as Set import Data.Time #if defined(DEBUG) import {-# SOURCE #-} Outputable ( warnPprTrace, text ) #endif infixr 9 `thenCmp` {- ************************************************************************ * * \subsection{Is DEBUG on, are we on Windows, etc?} * * ************************************************************************ These booleans are global constants, set by CPP flags. They allow us to recompile a single module (this one) to change whether or not debug output appears. They sometimes let us avoid even running CPP elsewhere. It's important that the flags are literal constants (True/False). Then, with -0, tests of the flags in other modules will simplify to the correct branch of the conditional, thereby dropping debug code altogether when the flags are off. -} ghciSupported :: Bool #if defined(HAVE_INTERNAL_INTERPRETER) ghciSupported = True #else ghciSupported :: Bool ghciSupported = Bool False #endif debugIsOn :: Bool #if defined(DEBUG) debugIsOn = True #else debugIsOn :: Bool debugIsOn = Bool False #endif ghciTablesNextToCode :: Bool #if defined(GHCI_TABLES_NEXT_TO_CODE) ghciTablesNextToCode = True #else ghciTablesNextToCode :: Bool ghciTablesNextToCode = Bool False #endif isWindowsHost :: Bool #if defined(mingw32_HOST_OS) isWindowsHost = True #else isWindowsHost :: Bool isWindowsHost = Bool False #endif isDarwinHost :: Bool #if defined(darwin_HOST_OS) isDarwinHost = True #else isDarwinHost :: Bool isDarwinHost = Bool False #endif {- ************************************************************************ * * \subsection{Miscellaneous higher-order functions} * * ************************************************************************ -} -- | Apply a function iff some condition is met. applyWhen :: Bool -> (a -> a) -> a -> a applyWhen :: Bool -> (a -> a) -> a -> a applyWhen Bool True a -> a f a x = a -> a f a x applyWhen Bool _ a -> a _ a x = a x -- | A for loop: Compose a function with itself n times. (nth rather than twice) nTimes :: Int -> (a -> a) -> (a -> a) nTimes :: Int -> (a -> a) -> a -> a nTimes Int 0 a -> a _ = a -> a forall a. a -> a id nTimes Int 1 a -> a f = a -> a f nTimes Int n a -> a f = a -> a f (a -> a) -> (a -> a) -> a -> a forall b c a. (b -> c) -> (a -> b) -> a -> c . Int -> (a -> a) -> a -> a forall a. Int -> (a -> a) -> a -> a nTimes (Int nInt -> Int -> Int forall a. Num a => a -> a -> a -Int 1) a -> a f fstOf3 :: (a,b,c) -> a sndOf3 :: (a,b,c) -> b thdOf3 :: (a,b,c) -> c fstOf3 :: (a, b, c) -> a fstOf3 (a a,b _,c _) = a a sndOf3 :: (a, b, c) -> b sndOf3 (a _,b b,c _) = b b thdOf3 :: (a, b, c) -> c thdOf3 (a _,b _,c c) = c c fst3 :: (a -> d) -> (a, b, c) -> (d, b, c) fst3 :: (a -> d) -> (a, b, c) -> (d, b, c) fst3 a -> d f (a a, b b, c c) = (a -> d f a a, b b, c c) snd3 :: (b -> d) -> (a, b, c) -> (a, d, c) snd3 :: (b -> d) -> (a, b, c) -> (a, d, c) snd3 b -> d f (a a, b b, c c) = (a a, b -> d f b b, c c) third3 :: (c -> d) -> (a, b, c) -> (a, b, d) third3 :: (c -> d) -> (a, b, c) -> (a, b, d) third3 c -> d f (a a, b b, c c) = (a a, b b, c -> d f c c) uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d uncurry3 a -> b -> c -> d f (a a, b b, c c) = a -> b -> c -> d f a a b b c c liftFst :: (a -> b) -> (a, c) -> (b, c) liftFst :: (a -> b) -> (a, c) -> (b, c) liftFst a -> b f (a a,c c) = (a -> b f a a, c c) liftSnd :: (a -> b) -> (c, a) -> (c, b) liftSnd :: (a -> b) -> (c, a) -> (c, b) liftSnd a -> b f (c c,a a) = (c c, a -> b f a a) firstM :: Monad m => (a -> m c) -> (a, b) -> m (c, b) firstM :: (a -> m c) -> (a, b) -> m (c, b) firstM a -> m c f (a x, b y) = (c -> (c, b)) -> m c -> m (c, b) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r liftM (\c x' -> (c x', b y)) (a -> m c f a x) first3M :: Monad m => (a -> m d) -> (a, b, c) -> m (d, b, c) first3M :: (a -> m d) -> (a, b, c) -> m (d, b, c) first3M a -> m d f (a x, b y, c z) = (d -> (d, b, c)) -> m d -> m (d, b, c) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r liftM (\d x' -> (d x', b y, c z)) (a -> m d f a x) secondM :: Monad m => (b -> m c) -> (a, b) -> m (a, c) secondM :: (b -> m c) -> (a, b) -> m (a, c) secondM b -> m c f (a x, b y) = (a x,) (c -> (a, c)) -> m c -> m (a, c) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> b -> m c f b y {- ************************************************************************ * * \subsection[Utils-lists]{General list processing} * * ************************************************************************ -} filterOut :: (a->Bool) -> [a] -> [a] -- ^ Like filter, only it reverses the sense of the test filterOut :: (a -> Bool) -> [a] -> [a] filterOut a -> Bool _ [] = [] filterOut a -> Bool p (a x:[a] xs) | a -> Bool p a x = (a -> Bool) -> [a] -> [a] forall a. (a -> Bool) -> [a] -> [a] filterOut a -> Bool p [a] xs | Bool otherwise = a x a -> [a] -> [a] forall a. a -> [a] -> [a] : (a -> Bool) -> [a] -> [a] forall a. (a -> Bool) -> [a] -> [a] filterOut a -> Bool p [a] xs partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) -- ^ Uses a function to determine which of two output lists an input element should join partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) partitionWith a -> Either b c _ [] = ([],[]) partitionWith a -> Either b c f (a x:[a] xs) = case a -> Either b c f a x of Left b b -> (b bb -> [b] -> [b] forall a. a -> [a] -> [a] :[b] bs, [c] cs) Right c c -> ([b] bs, c cc -> [c] -> [c] forall a. a -> [a] -> [a] :[c] cs) where ([b] bs,[c] cs) = (a -> Either b c) -> [a] -> ([b], [c]) forall a b c. (a -> Either b c) -> [a] -> ([b], [c]) partitionWith a -> Either b c f [a] xs chkAppend :: [a] -> [a] -> [a] -- Checks for the second argument being empty -- Used in situations where that situation is common chkAppend :: [a] -> [a] -> [a] chkAppend [a] xs [a] ys | [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [a] ys = [a] xs | Bool otherwise = [a] xs [a] -> [a] -> [a] forall a. [a] -> [a] -> [a] ++ [a] ys {- A paranoid @zip@ (and some @zipWith@ friends) that checks the lists are of equal length. Alastair Reid thinks this should only happen if DEBUGging on; hey, why not? -} zipEqual :: String -> [a] -> [b] -> [(a,b)] zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c] zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d] zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] #if !defined(DEBUG) zipEqual :: String -> [a] -> [b] -> [(a, b)] zipEqual String _ = [a] -> [b] -> [(a, b)] forall a b. [a] -> [b] -> [(a, b)] zip zipWithEqual :: String -> (a -> b -> c) -> [a] -> [b] -> [c] zipWithEqual String _ = (a -> b -> c) -> [a] -> [b] -> [c] forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith zipWith3Equal :: String -> (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] zipWith3Equal String _ = (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] zipWith3 zipWith4Equal :: String -> (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e] zipWith4Equal String _ = (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e] forall a b c d e. (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e] zipWith4 #else zipEqual _ [] [] = [] zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs zipEqual msg _ _ = panic ("zipEqual: unequal lists:"++msg) zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs zipWithEqual _ _ [] [] = [] zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg) zipWith3Equal msg z (a:as) (b:bs) (c:cs) = z a b c : zipWith3Equal msg z as bs cs zipWith3Equal _ _ [] [] [] = [] zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg) zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds) = z a b c d : zipWith4Equal msg z as bs cs ds zipWith4Equal _ _ [] [] [] [] = [] zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg) #endif -- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~) zipLazy :: [a] -> [b] -> [(a,b)] zipLazy :: [a] -> [b] -> [(a, b)] zipLazy [] [b] _ = [] zipLazy (a x:[a] xs) ~(b y:[b] ys) = (a x,b y) (a, b) -> [(a, b)] -> [(a, b)] forall a. a -> [a] -> [a] : [a] -> [b] -> [(a, b)] forall a b. [a] -> [b] -> [(a, b)] zipLazy [a] xs [b] ys -- | 'zipWithLazy' is like 'zipWith' but is lazy in the second list. -- The length of the output is always the same as the length of the first -- list. zipWithLazy :: (a -> b -> c) -> [a] -> [b] -> [c] zipWithLazy :: (a -> b -> c) -> [a] -> [b] -> [c] zipWithLazy a -> b -> c _ [] [b] _ = [] zipWithLazy a -> b -> c f (a a:[a] as) ~(b b:[b] bs) = a -> b -> c f a a b b c -> [c] -> [c] forall a. a -> [a] -> [a] : (a -> b -> c) -> [a] -> [b] -> [c] forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWithLazy a -> b -> c f [a] as [b] bs -- | 'zipWith3Lazy' is like 'zipWith3' but is lazy in the second and third lists. -- The length of the output is always the same as the length of the first -- list. zipWith3Lazy :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] zipWith3Lazy :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] zipWith3Lazy a -> b -> c -> d _ [] [b] _ [c] _ = [] zipWith3Lazy a -> b -> c -> d f (a a:[a] as) ~(b b:[b] bs) ~(c c:[c] cs) = a -> b -> c -> d f a a b b c c d -> [d] -> [d] forall a. a -> [a] -> [a] : (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] zipWith3Lazy a -> b -> c -> d f [a] as [b] bs [c] cs -- | 'filterByList' takes a list of Bools and a list of some elements and -- filters out these elements for which the corresponding value in the list of -- Bools is False. This function does not check whether the lists have equal -- length. filterByList :: [Bool] -> [a] -> [a] filterByList :: [Bool] -> [a] -> [a] filterByList (Bool True:[Bool] bs) (a x:[a] xs) = a x a -> [a] -> [a] forall a. a -> [a] -> [a] : [Bool] -> [a] -> [a] forall a. [Bool] -> [a] -> [a] filterByList [Bool] bs [a] xs filterByList (Bool False:[Bool] bs) (a _:[a] xs) = [Bool] -> [a] -> [a] forall a. [Bool] -> [a] -> [a] filterByList [Bool] bs [a] xs filterByList [Bool] _ [a] _ = [] -- | 'filterByLists' takes a list of Bools and two lists as input, and -- outputs a new list consisting of elements from the last two input lists. For -- each Bool in the list, if it is 'True', then it takes an element from the -- former list. If it is 'False', it takes an element from the latter list. -- The elements taken correspond to the index of the Bool in its list. -- For example: -- -- @ -- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\" -- @ -- -- This function does not check whether the lists have equal length. filterByLists :: [Bool] -> [a] -> [a] -> [a] filterByLists :: [Bool] -> [a] -> [a] -> [a] filterByLists (Bool True:[Bool] bs) (a x:[a] xs) (a _:[a] ys) = a x a -> [a] -> [a] forall a. a -> [a] -> [a] : [Bool] -> [a] -> [a] -> [a] forall a. [Bool] -> [a] -> [a] -> [a] filterByLists [Bool] bs [a] xs [a] ys filterByLists (Bool False:[Bool] bs) (a _:[a] xs) (a y:[a] ys) = a y a -> [a] -> [a] forall a. a -> [a] -> [a] : [Bool] -> [a] -> [a] -> [a] forall a. [Bool] -> [a] -> [a] -> [a] filterByLists [Bool] bs [a] xs [a] ys filterByLists [Bool] _ [a] _ [a] _ = [] -- | 'partitionByList' takes a list of Bools and a list of some elements and -- partitions the list according to the list of Bools. Elements corresponding -- to 'True' go to the left; elements corresponding to 'False' go to the right. -- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@ -- This function does not check whether the lists have equal -- length; when one list runs out, the function stops. partitionByList :: [Bool] -> [a] -> ([a], [a]) partitionByList :: [Bool] -> [a] -> ([a], [a]) partitionByList = [a] -> [a] -> [Bool] -> [a] -> ([a], [a]) forall a. [a] -> [a] -> [Bool] -> [a] -> ([a], [a]) go [] [] where go :: [a] -> [a] -> [Bool] -> [a] -> ([a], [a]) go [a] trues [a] falses (Bool True : [Bool] bs) (a x : [a] xs) = [a] -> [a] -> [Bool] -> [a] -> ([a], [a]) go (a xa -> [a] -> [a] forall a. a -> [a] -> [a] :[a] trues) [a] falses [Bool] bs [a] xs go [a] trues [a] falses (Bool False : [Bool] bs) (a x : [a] xs) = [a] -> [a] -> [Bool] -> [a] -> ([a], [a]) go [a] trues (a xa -> [a] -> [a] forall a. a -> [a] -> [a] :[a] falses) [Bool] bs [a] xs go [a] trues [a] falses [Bool] _ [a] _ = ([a] -> [a] forall a. [a] -> [a] reverse [a] trues, [a] -> [a] forall a. [a] -> [a] reverse [a] falses) stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c] -- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in -- the places where @p@ returns @True@ stretchZipWith :: (a -> Bool) -> b -> (a -> b -> c) -> [a] -> [b] -> [c] stretchZipWith a -> Bool _ b _ a -> b -> c _ [] [b] _ = [] stretchZipWith a -> Bool p b z a -> b -> c f (a x:[a] xs) [b] ys | a -> Bool p a x = a -> b -> c f a x b z c -> [c] -> [c] forall a. a -> [a] -> [a] : (a -> Bool) -> b -> (a -> b -> c) -> [a] -> [b] -> [c] forall a b c. (a -> Bool) -> b -> (a -> b -> c) -> [a] -> [b] -> [c] stretchZipWith a -> Bool p b z a -> b -> c f [a] xs [b] ys | Bool otherwise = case [b] ys of [] -> [] (b y:[b] ys) -> a -> b -> c f a x b y c -> [c] -> [c] forall a. a -> [a] -> [a] : (a -> Bool) -> b -> (a -> b -> c) -> [a] -> [b] -> [c] forall a b c. (a -> Bool) -> b -> (a -> b -> c) -> [a] -> [b] -> [c] stretchZipWith a -> Bool p b z a -> b -> c f [a] xs [b] ys mapFst :: (a->c) -> [(a,b)] -> [(c,b)] mapSnd :: (b->c) -> [(a,b)] -> [(a,c)] mapFst :: (a -> c) -> [(a, b)] -> [(c, b)] mapFst a -> c f [(a, b)] xys = [(a -> c f a x, b y) | (a x,b y) <- [(a, b)] xys] mapSnd :: (b -> c) -> [(a, b)] -> [(a, c)] mapSnd b -> c f [(a, b)] xys = [(a x, b -> c f b y) | (a x,b y) <- [(a, b)] xys] mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) mapAndUnzip a -> (b, c) _ [] = ([], []) mapAndUnzip a -> (b, c) f (a x:[a] xs) = let (b r1, c r2) = a -> (b, c) f a x ([b] rs1, [c] rs2) = (a -> (b, c)) -> [a] -> ([b], [c]) forall a b c. (a -> (b, c)) -> [a] -> ([b], [c]) mapAndUnzip a -> (b, c) f [a] xs in (b r1b -> [b] -> [b] forall a. a -> [a] -> [a] :[b] rs1, c r2c -> [c] -> [c] forall a. a -> [a] -> [a] :[c] rs2) mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d]) mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d]) mapAndUnzip3 a -> (b, c, d) _ [] = ([], [], []) mapAndUnzip3 a -> (b, c, d) f (a x:[a] xs) = let (b r1, c r2, d r3) = a -> (b, c, d) f a x ([b] rs1, [c] rs2, [d] rs3) = (a -> (b, c, d)) -> [a] -> ([b], [c], [d]) forall a b c d. (a -> (b, c, d)) -> [a] -> ([b], [c], [d]) mapAndUnzip3 a -> (b, c, d) f [a] xs in (b r1b -> [b] -> [b] forall a. a -> [a] -> [a] :[b] rs1, c r2c -> [c] -> [c] forall a. a -> [a] -> [a] :[c] rs2, d r3d -> [d] -> [d] forall a. a -> [a] -> [a] :[d] rs3) zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d]) zipWithAndUnzip :: (a -> b -> (c, d)) -> [a] -> [b] -> ([c], [d]) zipWithAndUnzip a -> b -> (c, d) f (a a:[a] as) (b b:[b] bs) = let (c r1, d r2) = a -> b -> (c, d) f a a b b ([c] rs1, [d] rs2) = (a -> b -> (c, d)) -> [a] -> [b] -> ([c], [d]) forall a b c d. (a -> b -> (c, d)) -> [a] -> [b] -> ([c], [d]) zipWithAndUnzip a -> b -> (c, d) f [a] as [b] bs in (c r1c -> [c] -> [c] forall a. a -> [a] -> [a] :[c] rs1, d r2d -> [d] -> [d] forall a. a -> [a] -> [a] :[d] rs2) zipWithAndUnzip a -> b -> (c, d) _ [a] _ [b] _ = ([],[]) -- | This has the effect of making the two lists have equal length by dropping -- the tail of the longer one. zipAndUnzip :: [a] -> [b] -> ([a],[b]) zipAndUnzip :: [a] -> [b] -> ([a], [b]) zipAndUnzip (a a:[a] as) (b b:[b] bs) = let ([a] rs1, [b] rs2) = [a] -> [b] -> ([a], [b]) forall a b. [a] -> [b] -> ([a], [b]) zipAndUnzip [a] as [b] bs in (a aa -> [a] -> [a] forall a. a -> [a] -> [a] :[a] rs1, b bb -> [b] -> [b] forall a. a -> [a] -> [a] :[b] rs2) zipAndUnzip [a] _ [b] _ = ([],[]) mapAccumL2 :: (s1 -> s2 -> a -> (s1, s2, b)) -> s1 -> s2 -> [a] -> (s1, s2, [b]) mapAccumL2 :: (s1 -> s2 -> a -> (s1, s2, b)) -> s1 -> s2 -> [a] -> (s1, s2, [b]) mapAccumL2 s1 -> s2 -> a -> (s1, s2, b) f s1 s1 s2 s2 [a] xs = (s1 s1', s2 s2', [b] ys) where ((s1 s1', s2 s2'), [b] ys) = ((s1, s2) -> a -> ((s1, s2), b)) -> (s1, s2) -> [a] -> ((s1, s2), [b]) forall (t :: * -> *) a b c. Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c) mapAccumL (\(s1 s1, s2 s2) a x -> case s1 -> s2 -> a -> (s1, s2, b) f s1 s1 s2 s2 a x of (s1 s1', s2 s2', b y) -> ((s1 s1', s2 s2'), b y)) (s1 s1, s2 s2) [a] xs -- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely: -- -- @ -- atLength atLenPred atEndPred ls n -- | n < 0 = atLenPred ls -- | length ls < n = atEndPred (n - length ls) -- | otherwise = atLenPred (drop n ls) -- @ atLength :: ([a] -> b) -- Called when length ls >= n, passed (drop n ls) -- NB: arg passed to this function may be [] -> b -- Called when length ls < n -> [a] -> Int -> b atLength :: ([a] -> b) -> b -> [a] -> Int -> b atLength [a] -> b atLenPred b atEnd [a] ls0 Int n0 | Int n0 Int -> Int -> Bool forall a. Ord a => a -> a -> Bool < Int 0 = [a] -> b atLenPred [a] ls0 | Bool otherwise = Int -> [a] -> b forall t. (Eq t, Num t) => t -> [a] -> b go Int n0 [a] ls0 where -- go's first arg n >= 0 go :: t -> [a] -> b go t 0 [a] ls = [a] -> b atLenPred [a] ls go t _ [] = b atEnd -- n > 0 here go t n (a _:[a] xs) = t -> [a] -> b go (t nt -> t -> t forall a. Num a => a -> a -> a -t 1) [a] xs -- Some special cases of atLength: -- | @(lengthExceeds xs n) = (length xs > n)@ lengthExceeds :: [a] -> Int -> Bool lengthExceeds :: [a] -> Int -> Bool lengthExceeds [a] lst Int n | Int n Int -> Int -> Bool forall a. Ord a => a -> a -> Bool < Int 0 = Bool True | Bool otherwise = ([a] -> Bool) -> Bool -> [a] -> Int -> Bool forall a b. ([a] -> b) -> b -> [a] -> Int -> b atLength [a] -> Bool forall a. [a] -> Bool notNull Bool False [a] lst Int n -- | @(lengthAtLeast xs n) = (length xs >= n)@ lengthAtLeast :: [a] -> Int -> Bool lengthAtLeast :: [a] -> Int -> Bool lengthAtLeast = ([a] -> Bool) -> Bool -> [a] -> Int -> Bool forall a b. ([a] -> b) -> b -> [a] -> Int -> b atLength (Bool -> [a] -> Bool forall a b. a -> b -> a const Bool True) Bool False -- | @(lengthIs xs n) = (length xs == n)@ lengthIs :: [a] -> Int -> Bool lengthIs :: [a] -> Int -> Bool lengthIs [a] lst Int n | Int n Int -> Int -> Bool forall a. Ord a => a -> a -> Bool < Int 0 = Bool False | Bool otherwise = ([a] -> Bool) -> Bool -> [a] -> Int -> Bool forall a b. ([a] -> b) -> b -> [a] -> Int -> b atLength [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null Bool False [a] lst Int n -- | @(lengthIsNot xs n) = (length xs /= n)@ lengthIsNot :: [a] -> Int -> Bool lengthIsNot :: [a] -> Int -> Bool lengthIsNot [a] lst Int n | Int n Int -> Int -> Bool forall a. Ord a => a -> a -> Bool < Int 0 = Bool True | Bool otherwise = ([a] -> Bool) -> Bool -> [a] -> Int -> Bool forall a b. ([a] -> b) -> b -> [a] -> Int -> b atLength [a] -> Bool forall a. [a] -> Bool notNull Bool True [a] lst Int n -- | @(lengthAtMost xs n) = (length xs <= n)@ lengthAtMost :: [a] -> Int -> Bool lengthAtMost :: [a] -> Int -> Bool lengthAtMost [a] lst Int n | Int n Int -> Int -> Bool forall a. Ord a => a -> a -> Bool < Int 0 = Bool False | Bool otherwise = ([a] -> Bool) -> Bool -> [a] -> Int -> Bool forall a b. ([a] -> b) -> b -> [a] -> Int -> b atLength [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null Bool True [a] lst Int n -- | @(lengthLessThan xs n) == (length xs < n)@ lengthLessThan :: [a] -> Int -> Bool lengthLessThan :: [a] -> Int -> Bool lengthLessThan = ([a] -> Bool) -> Bool -> [a] -> Int -> Bool forall a b. ([a] -> b) -> b -> [a] -> Int -> b atLength (Bool -> [a] -> Bool forall a b. a -> b -> a const Bool False) Bool True listLengthCmp :: [a] -> Int -> Ordering listLengthCmp :: [a] -> Int -> Ordering listLengthCmp = ([a] -> Ordering) -> Ordering -> [a] -> Int -> Ordering forall a b. ([a] -> b) -> b -> [a] -> Int -> b atLength [a] -> Ordering forall a. [a] -> Ordering atLen Ordering atEnd where atEnd :: Ordering atEnd = Ordering LT -- Not yet seen 'n' elts, so list length is < n. atLen :: [a] -> Ordering atLen [] = Ordering EQ atLen [a] _ = Ordering GT equalLength :: [a] -> [b] -> Bool -- ^ True if length xs == length ys equalLength :: [a] -> [b] -> Bool equalLength [] [] = Bool True equalLength (a _:[a] xs) (b _:[b] ys) = [a] -> [b] -> Bool forall a b. [a] -> [b] -> Bool equalLength [a] xs [b] ys equalLength [a] _ [b] _ = Bool False compareLength :: [a] -> [b] -> Ordering compareLength :: [a] -> [b] -> Ordering compareLength [] [] = Ordering EQ compareLength (a _:[a] xs) (b _:[b] ys) = [a] -> [b] -> Ordering forall a b. [a] -> [b] -> Ordering compareLength [a] xs [b] ys compareLength [] [b] _ = Ordering LT compareLength [a] _ [] = Ordering GT leLength :: [a] -> [b] -> Bool -- ^ True if length xs <= length ys leLength :: [a] -> [b] -> Bool leLength [a] xs [b] ys = case [a] -> [b] -> Ordering forall a b. [a] -> [b] -> Ordering compareLength [a] xs [b] ys of Ordering LT -> Bool True Ordering EQ -> Bool True Ordering GT -> Bool False ltLength :: [a] -> [b] -> Bool -- ^ True if length xs < length ys ltLength :: [a] -> [b] -> Bool ltLength [a] xs [b] ys = case [a] -> [b] -> Ordering forall a b. [a] -> [b] -> Ordering compareLength [a] xs [b] ys of Ordering LT -> Bool True Ordering EQ -> Bool False Ordering GT -> Bool False ---------------------------- singleton :: a -> [a] singleton :: a -> [a] singleton a x = [a x] isSingleton :: [a] -> Bool isSingleton :: [a] -> Bool isSingleton [a _] = Bool True isSingleton [a] _ = Bool False notNull :: [a] -> Bool notNull :: [a] -> Bool notNull [] = Bool False notNull [a] _ = Bool True only :: [a] -> a #if defined(DEBUG) only [a] = a #else only :: [a] -> a only (a a:[a] _) = a a #endif only [a] _ = String -> a forall a. String -> a panic String "Util: only" -- Debugging/specialising versions of \tr{elem} and \tr{notElem} isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool # if !defined(DEBUG) isIn :: String -> a -> [a] -> Bool isIn String _msg a x [a] ys = a x a -> [a] -> Bool forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` [a] ys isn'tIn :: String -> a -> [a] -> Bool isn'tIn String _msg a x [a] ys = a x a -> [a] -> Bool forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `notElem` [a] ys # else /* DEBUG */ isIn msg x ys = elem100 0 x ys where elem100 :: Eq a => Int -> a -> [a] -> Bool elem100 _ _ [] = False elem100 i x (y:ys) | i > 100 = WARN(True, text ("Over-long elem in " ++ msg)) (x `elem` (y:ys)) | otherwise = x == y || elem100 (i + 1) x ys isn'tIn msg x ys = notElem100 0 x ys where notElem100 :: Eq a => Int -> a -> [a] -> Bool notElem100 _ _ [] = True notElem100 i x (y:ys) | i > 100 = WARN(True, text ("Over-long notElem in " ++ msg)) (x `notElem` (y:ys)) | otherwise = x /= y && notElem100 (i + 1) x ys # endif /* DEBUG */ -- | Split a list into chunks of /n/ elements chunkList :: Int -> [a] -> [[a]] chunkList :: Int -> [a] -> [[a]] chunkList Int _ [] = [] chunkList Int n [a] xs = [a] as [a] -> [[a]] -> [[a]] forall a. a -> [a] -> [a] : Int -> [a] -> [[a]] forall a. Int -> [a] -> [[a]] chunkList Int n [a] bs where ([a] as,[a] bs) = Int -> [a] -> ([a], [a]) forall a. Int -> [a] -> ([a], [a]) splitAt Int n [a] xs -- | Replace the last element of a list with another element. changeLast :: [a] -> a -> [a] changeLast :: [a] -> a -> [a] changeLast [] a _ = String -> [a] forall a. String -> a panic String "changeLast" changeLast [a _] a x = [a x] changeLast (a x:[a] xs) a x' = a x a -> [a] -> [a] forall a. a -> [a] -> [a] : [a] -> a -> [a] forall a. [a] -> a -> [a] changeLast [a] xs a x' whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m () whenNonEmpty :: [a] -> (NonEmpty a -> m ()) -> m () whenNonEmpty [] NonEmpty a -> m () _ = () -> m () forall (f :: * -> *) a. Applicative f => a -> f a pure () whenNonEmpty (a x:[a] xs) NonEmpty a -> m () f = NonEmpty a -> m () f (a x a -> [a] -> NonEmpty a forall a. a -> [a] -> NonEmpty a :| [a] xs) {- ************************************************************************ * * \subsubsection{Sort utils} * * ************************************************************************ -} minWith :: Ord b => (a -> b) -> [a] -> a minWith :: (a -> b) -> [a] -> a minWith a -> b get_key [a] xs = ASSERT( not (null xs) ) [a] -> a forall a. [a] -> a head ((a -> b) -> [a] -> [a] forall b a. Ord b => (a -> b) -> [a] -> [a] sortWith a -> b get_key [a] xs) nubSort :: Ord a => [a] -> [a] nubSort :: [a] -> [a] nubSort = Set a -> [a] forall a. Set a -> [a] Set.toAscList (Set a -> [a]) -> ([a] -> Set a) -> [a] -> [a] forall b c a. (b -> c) -> (a -> b) -> a -> c . [a] -> Set a forall a. Ord a => [a] -> Set a Set.fromList -- | Remove duplicates but keep elements in order. -- O(n * log n) ordNub :: Ord a => [a] -> [a] ordNub :: [a] -> [a] ordNub [a] xs = Set a -> [a] -> [a] forall a. Ord a => Set a -> [a] -> [a] go Set a forall a. Set a Set.empty [a] xs where go :: Set a -> [a] -> [a] go Set a _ [] = [] go Set a s (a x:[a] xs) | a -> Set a -> Bool forall a. Ord a => a -> Set a -> Bool Set.member a x Set a s = Set a -> [a] -> [a] go Set a s [a] xs | Bool otherwise = a x a -> [a] -> [a] forall a. a -> [a] -> [a] : Set a -> [a] -> [a] go (a -> Set a -> Set a forall a. Ord a => a -> Set a -> Set a Set.insert a x Set a s) [a] xs {- ************************************************************************ * * \subsection[Utils-transitive-closure]{Transitive closure} * * ************************************************************************ This algorithm for transitive closure is straightforward, albeit quadratic. -} transitiveClosure :: (a -> [a]) -- Successor function -> (a -> a -> Bool) -- Equality predicate -> [a] -> [a] -- The transitive closure transitiveClosure :: (a -> [a]) -> (a -> a -> Bool) -> [a] -> [a] transitiveClosure a -> [a] succ a -> a -> Bool eq [a] xs = [a] -> [a] -> [a] go [] [a] xs where go :: [a] -> [a] -> [a] go [a] done [] = [a] done go [a] done (a x:[a] xs) | a x a -> [a] -> Bool `is_in` [a] done = [a] -> [a] -> [a] go [a] done [a] xs | Bool otherwise = [a] -> [a] -> [a] go (a xa -> [a] -> [a] forall a. a -> [a] -> [a] :[a] done) (a -> [a] succ a x [a] -> [a] -> [a] forall a. [a] -> [a] -> [a] ++ [a] xs) a _ is_in :: a -> [a] -> Bool `is_in` [] = Bool False a x `is_in` (a y:[a] ys) | a -> a -> Bool eq a x a y = Bool True | Bool otherwise = a x a -> [a] -> Bool `is_in` [a] ys {- ************************************************************************ * * \subsection[Utils-accum]{Accumulating} * * ************************************************************************ A combination of foldl with zip. It works with equal length lists. -} foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc foldl2 acc -> a -> b -> acc _ acc z [] [] = acc z foldl2 acc -> a -> b -> acc k acc z (a a:[a] as) (b b:[b] bs) = (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc forall acc a b. (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc foldl2 acc -> a -> b -> acc k (acc -> a -> b -> acc k acc z a a b b) [a] as [b] bs foldl2 acc -> a -> b -> acc _ acc _ [a] _ [b] _ = String -> acc forall a. String -> a panic String "Util: foldl2" all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool -- True if the lists are the same length, and -- all corresponding elements satisfy the predicate all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool all2 a -> b -> Bool _ [] [] = Bool True all2 a -> b -> Bool p (a x:[a] xs) (b y:[b] ys) = a -> b -> Bool p a x b y Bool -> Bool -> Bool && (a -> b -> Bool) -> [a] -> [b] -> Bool forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool all2 a -> b -> Bool p [a] xs [b] ys all2 a -> b -> Bool _ [a] _ [b] _ = Bool False -- Count the number of times a predicate is true count :: (a -> Bool) -> [a] -> Int count :: (a -> Bool) -> [a] -> Int count a -> Bool p = Int -> [a] -> Int forall t. Num t => t -> [a] -> t go Int 0 where go :: t -> [a] -> t go !t n [] = t n go !t n (a x:[a] xs) | a -> Bool p a x = t -> [a] -> t go (t nt -> t -> t forall a. Num a => a -> a -> a +t 1) [a] xs | Bool otherwise = t -> [a] -> t go t n [a] xs countWhile :: (a -> Bool) -> [a] -> Int -- Length of an /initial prefix/ of the list satsifying p countWhile :: (a -> Bool) -> [a] -> Int countWhile a -> Bool p = Int -> [a] -> Int forall p. Num p => p -> [a] -> p go Int 0 where go :: p -> [a] -> p go !p n (a x:[a] xs) | a -> Bool p a x = p -> [a] -> p go (p np -> p -> p forall a. Num a => a -> a -> a +p 1) [a] xs go !p n [a] _ = p n {- @splitAt@, @take@, and @drop@ but with length of another list giving the break-off point: -} takeList :: [b] -> [a] -> [a] -- (takeList as bs) trims bs to the be same length -- as as, unless as is longer in which case it's a no-op takeList :: [b] -> [a] -> [a] takeList [] [a] _ = [] takeList (b _:[b] xs) [a] ls = case [a] ls of [] -> [] (a y:[a] ys) -> a y a -> [a] -> [a] forall a. a -> [a] -> [a] : [b] -> [a] -> [a] forall b a. [b] -> [a] -> [a] takeList [b] xs [a] ys dropList :: [b] -> [a] -> [a] dropList :: [b] -> [a] -> [a] dropList [] [a] xs = [a] xs dropList [b] _ xs :: [a] xs@[] = [a] xs dropList (b _:[b] xs) (a _:[a] ys) = [b] -> [a] -> [a] forall b a. [b] -> [a] -> [a] dropList [b] xs [a] ys splitAtList :: [b] -> [a] -> ([a], [a]) splitAtList :: [b] -> [a] -> ([a], [a]) splitAtList [] [a] xs = ([], [a] xs) splitAtList [b] _ xs :: [a] xs@[] = ([a] xs, [a] xs) splitAtList (b _:[b] xs) (a y:[a] ys) = (a ya -> [a] -> [a] forall a. a -> [a] -> [a] :[a] ys', [a] ys'') where ([a] ys', [a] ys'') = [b] -> [a] -> ([a], [a]) forall b a. [b] -> [a] -> ([a], [a]) splitAtList [b] xs [a] ys -- drop from the end of a list dropTail :: Int -> [a] -> [a] -- Specification: dropTail n = reverse . drop n . reverse -- Better implemention due to Joachim Breitner -- http://www.joachim-breitner.de/blog/archives/600-On-taking-the-last-n-elements-of-a-list.html dropTail :: Int -> [a] -> [a] dropTail Int n [a] xs = [a] -> [a] -> [a] forall b a. [b] -> [a] -> [a] go (Int -> [a] -> [a] forall a. Int -> [a] -> [a] drop Int n [a] xs) [a] xs where go :: [a] -> [a] -> [a] go (a _:[a] ys) (a x:[a] xs) = a x a -> [a] -> [a] forall a. a -> [a] -> [a] : [a] -> [a] -> [a] go [a] ys [a] xs go [a] _ [a] _ = [] -- Stop when ys runs out -- It'll always run out before xs does -- dropWhile from the end of a list. This is similar to Data.List.dropWhileEnd, -- but is lazy in the elements and strict in the spine. For reasonably short lists, -- such as path names and typical lines of text, dropWhileEndLE is generally -- faster than dropWhileEnd. Its advantage is magnified when the predicate is -- expensive--using dropWhileEndLE isSpace to strip the space off a line of text -- is generally much faster than using dropWhileEnd isSpace for that purpose. -- Specification: dropWhileEndLE p = reverse . dropWhile p . reverse -- Pay attention to the short-circuit (&&)! The order of its arguments is the only -- difference between dropWhileEnd and dropWhileEndLE. dropWhileEndLE :: (a -> Bool) -> [a] -> [a] dropWhileEndLE :: (a -> Bool) -> [a] -> [a] dropWhileEndLE a -> Bool p = (a -> [a] -> [a]) -> [a] -> [a] -> [a] forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr (\a x [a] r -> if [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [a] r Bool -> Bool -> Bool && a -> Bool p a x then [] else a xa -> [a] -> [a] forall a. a -> [a] -> [a] :[a] r) [] -- | @spanEnd p l == reverse (span p (reverse l))@. The first list -- returns actually comes after the second list (when you look at the -- input list). spanEnd :: (a -> Bool) -> [a] -> ([a], [a]) spanEnd :: (a -> Bool) -> [a] -> ([a], [a]) spanEnd a -> Bool p [a] l = [a] -> [a] -> [a] -> [a] -> ([a], [a]) go [a] l [] [] [a] l where go :: [a] -> [a] -> [a] -> [a] -> ([a], [a]) go [a] yes [a] _rev_yes [a] rev_no [] = ([a] yes, [a] -> [a] forall a. [a] -> [a] reverse [a] rev_no) go [a] yes [a] rev_yes [a] rev_no (a x:[a] xs) | a -> Bool p a x = [a] -> [a] -> [a] -> [a] -> ([a], [a]) go [a] yes (a x a -> [a] -> [a] forall a. a -> [a] -> [a] : [a] rev_yes) [a] rev_no [a] xs | Bool otherwise = [a] -> [a] -> [a] -> [a] -> ([a], [a]) go [a] xs [] (a x a -> [a] -> [a] forall a. a -> [a] -> [a] : [a] rev_yes [a] -> [a] -> [a] forall a. [a] -> [a] -> [a] ++ [a] rev_no) [a] xs -- | Get the last two elements in a list. Partial! {-# INLINE last2 #-} last2 :: [a] -> (a,a) last2 :: [a] -> (a, a) last2 = ((a, a) -> a -> (a, a)) -> (a, a) -> [a] -> (a, a) forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl' (\(a _,a x2) a x -> (a x2,a x)) (a forall a. a partialError,a forall a. a partialError) where partialError :: a partialError = String -> a forall a. String -> a panic String "last2 - list length less than two" lastMaybe :: [a] -> Maybe a lastMaybe :: [a] -> Maybe a lastMaybe [] = Maybe a forall a. Maybe a Nothing lastMaybe [a] xs = a -> Maybe a forall a. a -> Maybe a Just (a -> Maybe a) -> a -> Maybe a forall a b. (a -> b) -> a -> b $ [a] -> a forall a. [a] -> a last [a] xs -- | Split a list into its last element and the initial part of the list. -- @snocView xs = Just (init xs, last xs)@ for non-empty lists. -- @snocView xs = Nothing@ otherwise. -- Unless both parts of the result are guaranteed to be used -- prefer separate calls to @last@ + @init@. -- If you are guaranteed to use both, this will -- be more efficient. snocView :: [a] -> Maybe ([a],a) snocView :: [a] -> Maybe ([a], a) snocView [] = Maybe ([a], a) forall a. Maybe a Nothing snocView [a] xs | ([a] xs,a x) <- [a] -> ([a], a) forall a. [a] -> ([a], a) go [a] xs = ([a], a) -> Maybe ([a], a) forall a. a -> Maybe a Just ([a] xs,a x) where go :: [a] -> ([a],a) go :: [a] -> ([a], a) go [a x] = ([],a x) go (a x:[a] xs) | !([a] xs',a x') <- [a] -> ([a], a) forall a. [a] -> ([a], a) go [a] xs = (a xa -> [a] -> [a] forall a. a -> [a] -> [a] :[a] xs', a x') go [] = String -> ([a], a) forall a. HasCallStack => String -> a error String "impossible" split :: Char -> String -> [String] split :: Char -> String -> [String] split Char c String s = case String rest of [] -> [String chunk] Char _:String rest -> String chunk String -> [String] -> [String] forall a. a -> [a] -> [a] : Char -> String -> [String] split Char c String rest where (String chunk, String rest) = (Char -> Bool) -> String -> (String, String) forall a. (a -> Bool) -> [a] -> ([a], [a]) break (Char -> Char -> Bool forall a. Eq a => a -> a -> Bool ==Char c) String s -- | Convert a word to title case by capitalising the first letter capitalise :: String -> String capitalise :: String -> String capitalise [] = [] capitalise (Char c:String cs) = Char -> Char toUpper Char c Char -> String -> String forall a. a -> [a] -> [a] : String cs {- ************************************************************************ * * \subsection[Utils-comparison]{Comparisons} * * ************************************************************************ -} isEqual :: Ordering -> Bool -- Often used in (isEqual (a `compare` b)) isEqual :: Ordering -> Bool isEqual Ordering GT = Bool False isEqual Ordering EQ = Bool True isEqual Ordering LT = Bool False thenCmp :: Ordering -> Ordering -> Ordering {-# INLINE thenCmp #-} thenCmp :: Ordering -> Ordering -> Ordering thenCmp Ordering EQ Ordering ordering = Ordering ordering thenCmp Ordering ordering Ordering _ = Ordering ordering eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool eqListBy :: (a -> a -> Bool) -> [a] -> [a] -> Bool eqListBy a -> a -> Bool _ [] [] = Bool True eqListBy a -> a -> Bool eq (a x:[a] xs) (a y:[a] ys) = a -> a -> Bool eq a x a y Bool -> Bool -> Bool && (a -> a -> Bool) -> [a] -> [a] -> Bool forall a. (a -> a -> Bool) -> [a] -> [a] -> Bool eqListBy a -> a -> Bool eq [a] xs [a] ys eqListBy a -> a -> Bool _ [a] _ [a] _ = Bool False eqMaybeBy :: (a ->a->Bool) -> Maybe a -> Maybe a -> Bool eqMaybeBy :: (a -> a -> Bool) -> Maybe a -> Maybe a -> Bool eqMaybeBy a -> a -> Bool _ Maybe a Nothing Maybe a Nothing = Bool True eqMaybeBy a -> a -> Bool eq (Just a x) (Just a y) = a -> a -> Bool eq a x a y eqMaybeBy a -> a -> Bool _ Maybe a _ Maybe a _ = Bool False cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering -- `cmpList' uses a user-specified comparer cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering cmpList a -> a -> Ordering _ [] [] = Ordering EQ cmpList a -> a -> Ordering _ [] [a] _ = Ordering LT cmpList a -> a -> Ordering _ [a] _ [] = Ordering GT cmpList a -> a -> Ordering cmp (a a:[a] as) (a b:[a] bs) = case a -> a -> Ordering cmp a a a b of { Ordering EQ -> (a -> a -> Ordering) -> [a] -> [a] -> Ordering forall a. (a -> a -> Ordering) -> [a] -> [a] -> Ordering cmpList a -> a -> Ordering cmp [a] as [a] bs; Ordering xxx -> Ordering xxx } removeSpaces :: String -> String removeSpaces :: String -> String removeSpaces = (Char -> Bool) -> String -> String forall a. (a -> Bool) -> [a] -> [a] dropWhileEndLE Char -> Bool isSpace (String -> String) -> (String -> String) -> String -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . (Char -> Bool) -> String -> String forall a. (a -> Bool) -> [a] -> [a] dropWhile Char -> Bool isSpace -- Boolean operators lifted to Applicative (<&&>) :: Applicative f => f Bool -> f Bool -> f Bool <&&> :: f Bool -> f Bool -> f Bool (<&&>) = (Bool -> Bool -> Bool) -> f Bool -> f Bool -> f Bool forall (f :: * -> *) a b c. Applicative f => (a -> b -> c) -> f a -> f b -> f c liftA2 Bool -> Bool -> Bool (&&) infixr 3 <&&> -- same as (&&) (<||>) :: Applicative f => f Bool -> f Bool -> f Bool <||> :: f Bool -> f Bool -> f Bool (<||>) = (Bool -> Bool -> Bool) -> f Bool -> f Bool -> f Bool forall (f :: * -> *) a b c. Applicative f => (a -> b -> c) -> f a -> f b -> f c liftA2 Bool -> Bool -> Bool (||) infixr 2 <||> -- same as (||) {- ************************************************************************ * * \subsection{Edit distance} * * ************************************************************************ -} -- | Find the "restricted" Damerau-Levenshtein edit distance between two strings. -- See: <http://en.wikipedia.org/wiki/Damerau-Levenshtein_distance>. -- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing -- Levenshtein and Damerau Edit Distances" in PSC'02 (Heikki Hyyro). -- See http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and -- http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for an explanation restrictedDamerauLevenshteinDistance :: String -> String -> Int restrictedDamerauLevenshteinDistance :: String -> String -> Int restrictedDamerauLevenshteinDistance String str1 String str2 = Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistanceWithLengths Int m Int n String str1 String str2 where m :: Int m = String -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length String str1 n :: Int n = String -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length String str2 restrictedDamerauLevenshteinDistanceWithLengths :: Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistanceWithLengths :: Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistanceWithLengths Int m Int n String str1 String str2 | Int m Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int n = if Int n Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int 32 -- n must be larger so this check is sufficient then Word32 -> Int -> Int -> String -> String -> Int forall bv. (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistance' (Word32 forall a. HasCallStack => a undefined :: Word32) Int m Int n String str1 String str2 else Integer -> Int -> Int -> String -> String -> Int forall bv. (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistance' (Integer forall a. HasCallStack => a undefined :: Integer) Int m Int n String str1 String str2 | Bool otherwise = if Int m Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int 32 -- m must be larger so this check is sufficient then Word32 -> Int -> Int -> String -> String -> Int forall bv. (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistance' (Word32 forall a. HasCallStack => a undefined :: Word32) Int n Int m String str2 String str1 else Integer -> Int -> Int -> String -> String -> Int forall bv. (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistance' (Integer forall a. HasCallStack => a undefined :: Integer) Int n Int m String str2 String str1 restrictedDamerauLevenshteinDistance' :: (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistance' :: bv -> Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistance' bv _bv_dummy Int m Int n String str1 String str2 | [] <- String str1 = Int n | Bool otherwise = (bv, bv, bv, bv, Int) -> Int forall a b c d e. (a, b, c, d, e) -> e extractAnswer ((bv, bv, bv, bv, Int) -> Int) -> (bv, bv, bv, bv, Int) -> Int forall a b. (a -> b) -> a -> b $ ((bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int)) -> (bv, bv, bv, bv, Int) -> String -> (bv, bv, bv, bv, Int) forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl' (IntMap bv -> bv -> bv -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int) forall bv. (Bits bv, Num bv) => IntMap bv -> bv -> bv -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int) restrictedDamerauLevenshteinDistanceWorker (String -> IntMap bv forall bv. (Bits bv, Num bv) => String -> IntMap bv matchVectors String str1) bv top_bit_mask bv vector_mask) (bv 0, bv 0, bv m_ones, bv 0, Int m) String str2 where m_ones :: bv m_ones@bv vector_mask = (bv 2 bv -> Int -> bv forall a b. (Num a, Integral b) => a -> b -> a ^ Int m) bv -> bv -> bv forall a. Num a => a -> a -> a - bv 1 top_bit_mask :: bv top_bit_mask = (bv 1 bv -> Int -> bv forall a. Bits a => a -> Int -> a `shiftL` (Int m Int -> Int -> Int forall a. Num a => a -> a -> a - Int 1)) bv -> bv -> bv forall a. a -> a -> a `asTypeOf` bv _bv_dummy extractAnswer :: (a, b, c, d, e) -> e extractAnswer (a _, b _, c _, d _, e distance) = e distance restrictedDamerauLevenshteinDistanceWorker :: (Bits bv, Num bv) => IM.IntMap bv -> bv -> bv -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int) restrictedDamerauLevenshteinDistanceWorker :: IntMap bv -> bv -> bv -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int) restrictedDamerauLevenshteinDistanceWorker IntMap bv str1_mvs bv top_bit_mask bv vector_mask (bv pm, bv d0, bv vp, bv vn, Int distance) Char char2 = IntMap bv -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int) seq IntMap bv str1_mvs ((bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)) -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int) forall a b. (a -> b) -> a -> b $ bv -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int) seq bv top_bit_mask ((bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)) -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int) forall a b. (a -> b) -> a -> b $ bv -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int) seq bv vector_mask ((bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)) -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int) forall a b. (a -> b) -> a -> b $ bv -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int) seq bv pm' ((bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)) -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int) forall a b. (a -> b) -> a -> b $ bv -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int) seq bv d0' ((bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)) -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int) forall a b. (a -> b) -> a -> b $ bv -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int) seq bv vp' ((bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)) -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int) forall a b. (a -> b) -> a -> b $ bv -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int) seq bv vn' ((bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)) -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int) forall a b. (a -> b) -> a -> b $ Int -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int) seq Int distance'' ((bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)) -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int) forall a b. (a -> b) -> a -> b $ Char -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int) seq Char char2 ((bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int)) -> (bv, bv, bv, bv, Int) -> (bv, bv, bv, bv, Int) forall a b. (a -> b) -> a -> b $ (bv pm', bv d0', bv vp', bv vn', Int distance'') where pm' :: bv pm' = bv -> Int -> IntMap bv -> bv forall a. a -> Int -> IntMap a -> a IM.findWithDefault bv 0 (Char -> Int ord Char char2) IntMap bv str1_mvs d0' :: bv d0' = ((((bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv sizedComplement bv vector_mask bv d0) bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .&. bv pm') bv -> Int -> bv forall a. Bits a => a -> Int -> a `shiftL` Int 1) bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .&. bv pm) bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .|. ((((bv pm' bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .&. bv vp) bv -> bv -> bv forall a. Num a => a -> a -> a + bv vp) bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .&. bv vector_mask) bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv `xor` bv vp) bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .|. bv pm' bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .|. bv vn -- No need to mask the shiftL because of the restricted range of pm hp' :: bv hp' = bv vn bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .|. bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv sizedComplement bv vector_mask (bv d0' bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .|. bv vp) hn' :: bv hn' = bv d0' bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .&. bv vp hp'_shift :: bv hp'_shift = ((bv hp' bv -> Int -> bv forall a. Bits a => a -> Int -> a `shiftL` Int 1) bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .|. bv 1) bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .&. bv vector_mask hn'_shift :: bv hn'_shift = (bv hn' bv -> Int -> bv forall a. Bits a => a -> Int -> a `shiftL` Int 1) bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .&. bv vector_mask vp' :: bv vp' = bv hn'_shift bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .|. bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv sizedComplement bv vector_mask (bv d0' bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .|. bv hp'_shift) vn' :: bv vn' = bv d0' bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .&. bv hp'_shift distance' :: Int distance' = if bv hp' bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .&. bv top_bit_mask bv -> bv -> Bool forall a. Eq a => a -> a -> Bool /= bv 0 then Int distance Int -> Int -> Int forall a. Num a => a -> a -> a + Int 1 else Int distance distance'' :: Int distance'' = if bv hn' bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv .&. bv top_bit_mask bv -> bv -> Bool forall a. Eq a => a -> a -> Bool /= bv 0 then Int distance' Int -> Int -> Int forall a. Num a => a -> a -> a - Int 1 else Int distance' sizedComplement :: Bits bv => bv -> bv -> bv sizedComplement :: bv -> bv -> bv sizedComplement bv vector_mask bv vect = bv vector_mask bv -> bv -> bv forall bv. Bits bv => bv -> bv -> bv `xor` bv vect matchVectors :: (Bits bv, Num bv) => String -> IM.IntMap bv matchVectors :: String -> IntMap bv matchVectors = (Int, IntMap bv) -> IntMap bv forall a b. (a, b) -> b snd ((Int, IntMap bv) -> IntMap bv) -> (String -> (Int, IntMap bv)) -> String -> IntMap bv forall b c a. (b -> c) -> (a -> b) -> a -> c . ((Int, IntMap bv) -> Char -> (Int, IntMap bv)) -> (Int, IntMap bv) -> String -> (Int, IntMap bv) forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl' (Int, IntMap bv) -> Char -> (Int, IntMap bv) forall a a. (Bits a, Integral a, Num a) => (a, IntMap a) -> Char -> (a, IntMap a) go (Int 0 :: Int, IntMap bv forall a. IntMap a IM.empty) where go :: (a, IntMap a) -> Char -> (a, IntMap a) go (a ix, IntMap a im) Char char = let ix' :: a ix' = a ix a -> a -> a forall a. Num a => a -> a -> a + a 1 im' :: IntMap a im' = (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a IM.insertWith a -> a -> a forall bv. Bits bv => bv -> bv -> bv (.|.) (Char -> Int ord Char char) (a 2 a -> a -> a forall a b. (Num a, Integral b) => a -> b -> a ^ a ix) IntMap a im in a -> (a, IntMap a) -> (a, IntMap a) seq a ix' ((a, IntMap a) -> (a, IntMap a)) -> (a, IntMap a) -> (a, IntMap a) forall a b. (a -> b) -> a -> b $ IntMap a -> (a, IntMap a) -> (a, IntMap a) seq IntMap a im' ((a, IntMap a) -> (a, IntMap a)) -> (a, IntMap a) -> (a, IntMap a) forall a b. (a -> b) -> a -> b $ (a ix', IntMap a im') {-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' :: Word32 -> Int -> Int -> String -> String -> Int #-} {-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' :: Integer -> Int -> Int -> String -> String -> Int #-} {-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker :: IM.IntMap Word32 -> Word32 -> Word32 -> (Word32, Word32, Word32, Word32, Int) -> Char -> (Word32, Word32, Word32, Word32, Int) #-} {-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker :: IM.IntMap Integer -> Integer -> Integer -> (Integer, Integer, Integer, Integer, Int) -> Char -> (Integer, Integer, Integer, Integer, Int) #-} {-# SPECIALIZE INLINE sizedComplement :: Word32 -> Word32 -> Word32 #-} {-# SPECIALIZE INLINE sizedComplement :: Integer -> Integer -> Integer #-} {-# SPECIALIZE matchVectors :: String -> IM.IntMap Word32 #-} {-# SPECIALIZE matchVectors :: String -> IM.IntMap Integer #-} fuzzyMatch :: String -> [String] -> [String] fuzzyMatch :: String -> [String] -> [String] fuzzyMatch String key [String] vals = String -> [(String, String)] -> [String] forall a. String -> [(String, a)] -> [a] fuzzyLookup String key [(String v,String v) | String v <- [String] vals] -- | Search for possible matches to the users input in the given list, -- returning a small number of ranked results fuzzyLookup :: String -> [(String,a)] -> [a] fuzzyLookup :: String -> [(String, a)] -> [a] fuzzyLookup String user_entered [(String, a)] possibilites = ((a, Int) -> a) -> [(a, Int)] -> [a] forall a b. (a -> b) -> [a] -> [b] map (a, Int) -> a forall a b. (a, b) -> a fst ([(a, Int)] -> [a]) -> [(a, Int)] -> [a] forall a b. (a -> b) -> a -> b $ Int -> [(a, Int)] -> [(a, Int)] forall a. Int -> [a] -> [a] take Int mAX_RESULTS ([(a, Int)] -> [(a, Int)]) -> [(a, Int)] -> [(a, Int)] forall a b. (a -> b) -> a -> b $ ((a, Int) -> (a, Int) -> Ordering) -> [(a, Int)] -> [(a, Int)] forall a. (a -> a -> Ordering) -> [a] -> [a] sortBy (((a, Int) -> Int) -> (a, Int) -> (a, Int) -> Ordering forall a b. Ord a => (b -> a) -> b -> b -> Ordering comparing (a, Int) -> Int forall a b. (a, b) -> b snd) [ (a poss_val, Int distance) | (String poss_str, a poss_val) <- [(String, a)] possibilites , let distance :: Int distance = String -> String -> Int restrictedDamerauLevenshteinDistance String poss_str String user_entered , Int distance Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int fuzzy_threshold ] where -- Work out an approriate match threshold: -- We report a candidate if its edit distance is <= the threshold, -- The threshold is set to about a quarter of the # of characters the user entered -- Length Threshold -- 1 0 -- Don't suggest *any* candidates -- 2 1 -- for single-char identifiers -- 3 1 -- 4 1 -- 5 1 -- 6 2 -- fuzzy_threshold :: Int fuzzy_threshold = Rational -> Int forall a b. (RealFrac a, Integral b) => a -> b truncate (Rational -> Int) -> Rational -> Int forall a b. (a -> b) -> a -> b $ Int -> Rational forall a b. (Integral a, Num b) => a -> b fromIntegral (String -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length String user_entered Int -> Int -> Int forall a. Num a => a -> a -> a + Int 2) Rational -> Rational -> Rational forall a. Fractional a => a -> a -> a / (Rational 4 :: Rational) mAX_RESULTS :: Int mAX_RESULTS = Int 3 {- ************************************************************************ * * \subsection[Utils-pairs]{Pairs} * * ************************************************************************ -} unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] unzipWith a -> b -> c f [(a, b)] pairs = ((a, b) -> c) -> [(a, b)] -> [c] forall a b. (a -> b) -> [a] -> [b] map ( \ (a a, b b) -> a -> b -> c f a a b b ) [(a, b)] pairs seqList :: [a] -> b -> b seqList :: [a] -> b -> b seqList [] b b = b b seqList (a x:[a] xs) b b = a x a -> b -> b `seq` [a] -> b -> b forall a b. [a] -> b -> b seqList [a] xs b b {- ************************************************************************ * * Globals and the RTS * * ************************************************************************ When a plugin is loaded, it currently gets linked against a *newly loaded* copy of the GHC package. This would not be a problem, except that the new copy has its own mutable state that is not shared with that state that has already been initialized by the original GHC package. (Note that if the GHC executable was dynamically linked this wouldn't be a problem, because we could share the GHC library it links to; this is only a problem if DYNAMIC_GHC_PROGRAMS=NO.) The solution is to make use of @sharedCAF@ through @sharedGlobal@ for globals that are shared between multiple copies of ghc packages. -} -- Global variables: global :: a -> IORef a global :: a -> IORef a global a a = IO (IORef a) -> IORef a forall a. IO a -> a unsafePerformIO (a -> IO (IORef a) forall a. a -> IO (IORef a) newIORef a a) consIORef :: IORef [a] -> a -> IO () consIORef :: IORef [a] -> a -> IO () consIORef IORef [a] var a x = do IORef [a] -> ([a] -> ([a], ())) -> IO () forall a b. IORef a -> (a -> (a, b)) -> IO b atomicModifyIORef' IORef [a] var (\[a] xs -> (a xa -> [a] -> [a] forall a. a -> [a] -> [a] :[a] xs,())) globalM :: IO a -> IORef a globalM :: IO a -> IORef a globalM IO a ma = IO (IORef a) -> IORef a forall a. IO a -> a unsafePerformIO (IO a ma IO a -> (a -> IO (IORef a)) -> IO (IORef a) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= a -> IO (IORef a) forall a. a -> IO (IORef a) newIORef) -- Shared global variables: sharedGlobal :: a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a a a Ptr (IORef a) -> IO (Ptr (IORef a)) get_or_set = IO (IORef a) -> IORef a forall a. IO a -> a unsafePerformIO (IO (IORef a) -> IORef a) -> IO (IORef a) -> IORef a forall a b. (a -> b) -> a -> b $ a -> IO (IORef a) forall a. a -> IO (IORef a) newIORef a a IO (IORef a) -> (IORef a -> IO (IORef a)) -> IO (IORef a) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= (IORef a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IO (IORef a)) -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a -> IO (IORef a) forall a b c. (a -> b -> c) -> b -> a -> c flip IORef a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IO (IORef a) forall a. a -> (Ptr a -> IO (Ptr a)) -> IO a sharedCAF Ptr (IORef a) -> IO (Ptr (IORef a)) get_or_set sharedGlobalM :: IO a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a IO a ma Ptr (IORef a) -> IO (Ptr (IORef a)) get_or_set = IO (IORef a) -> IORef a forall a. IO a -> a unsafePerformIO (IO (IORef a) -> IORef a) -> IO (IORef a) -> IORef a forall a b. (a -> b) -> a -> b $ IO a ma IO a -> (a -> IO (IORef a)) -> IO (IORef a) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= a -> IO (IORef a) forall a. a -> IO (IORef a) newIORef IO (IORef a) -> (IORef a -> IO (IORef a)) -> IO (IORef a) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= (IORef a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IO (IORef a)) -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a -> IO (IORef a) forall a b c. (a -> b -> c) -> b -> a -> c flip IORef a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IO (IORef a) forall a. a -> (Ptr a -> IO (Ptr a)) -> IO a sharedCAF Ptr (IORef a) -> IO (Ptr (IORef a)) get_or_set -- Module names: looksLikeModuleName :: String -> Bool looksLikeModuleName :: String -> Bool looksLikeModuleName [] = Bool False looksLikeModuleName (Char c:String cs) = Char -> Bool isUpper Char c Bool -> Bool -> Bool && String -> Bool go String cs where go :: String -> Bool go [] = Bool True go (Char '.':String cs) = String -> Bool looksLikeModuleName String cs go (Char c:String cs) = (Char -> Bool isAlphaNum Char c Bool -> Bool -> Bool || Char c Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char '_' Bool -> Bool -> Bool || Char c Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char '\'') Bool -> Bool -> Bool && String -> Bool go String cs -- Similar to 'parse' for Distribution.Package.PackageName, -- but we don't want to depend on Cabal. looksLikePackageName :: String -> Bool looksLikePackageName :: String -> Bool looksLikePackageName = (String -> Bool) -> [String] -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all ((Char -> Bool) -> String -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all Char -> Bool isAlphaNum (String -> Bool) -> (String -> Bool) -> String -> Bool forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool <&&> Bool -> Bool not (Bool -> Bool) -> (String -> Bool) -> String -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . ((Char -> Bool) -> String -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all Char -> Bool isDigit)) ([String] -> Bool) -> (String -> [String]) -> String -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . Char -> String -> [String] split Char '-' {- Akin to @Prelude.words@, but acts like the Bourne shell, treating quoted strings as Haskell Strings, and also parses Haskell [String] syntax. -} getCmd :: String -> Either String -- Error (String, String) -- (Cmd, Rest) getCmd :: String -> Either String (String, String) getCmd String s = case (Char -> Bool) -> String -> (String, String) forall a. (a -> Bool) -> [a] -> ([a], [a]) break Char -> Bool isSpace (String -> (String, String)) -> String -> (String, String) forall a b. (a -> b) -> a -> b $ (Char -> Bool) -> String -> String forall a. (a -> Bool) -> [a] -> [a] dropWhile Char -> Bool isSpace String s of ([], String _) -> String -> Either String (String, String) forall a b. a -> Either a b Left (String "Couldn't find command in " String -> String -> String forall a. [a] -> [a] -> [a] ++ String -> String forall a. Show a => a -> String show String s) (String, String) res -> (String, String) -> Either String (String, String) forall a b. b -> Either a b Right (String, String) res toCmdArgs :: String -> Either String -- Error (String, [String]) -- (Cmd, Args) toCmdArgs :: String -> Either String (String, [String]) toCmdArgs String s = case String -> Either String (String, String) getCmd String s of Left String err -> String -> Either String (String, [String]) forall a b. a -> Either a b Left String err Right (String cmd, String s') -> case String -> Either String [String] toArgs String s' of Left String err -> String -> Either String (String, [String]) forall a b. a -> Either a b Left String err Right [String] args -> (String, [String]) -> Either String (String, [String]) forall a b. b -> Either a b Right (String cmd, [String] args) toArgs :: String -> Either String -- Error [String] -- Args toArgs :: String -> Either String [String] toArgs String str = case (Char -> Bool) -> String -> String forall a. (a -> Bool) -> [a] -> [a] dropWhile Char -> Bool isSpace String str of s :: String s@(Char '[':String _) -> case ReadS [String] forall a. Read a => ReadS a reads String s of [([String] args, String spaces)] | (Char -> Bool) -> String -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all Char -> Bool isSpace String spaces -> [String] -> Either String [String] forall a b. b -> Either a b Right [String] args [([String], String)] _ -> String -> Either String [String] forall a b. a -> Either a b Left (String "Couldn't read " String -> String -> String forall a. [a] -> [a] -> [a] ++ String -> String forall a. Show a => a -> String show String str String -> String -> String forall a. [a] -> [a] -> [a] ++ String " as [String]") String s -> String -> Either String [String] toArgs' String s where toArgs' :: String -> Either String [String] -- Remove outer quotes: -- > toArgs' "\"foo\" \"bar baz\"" -- Right ["foo", "bar baz"] -- -- Keep inner quotes: -- > toArgs' "-DFOO=\"bar baz\"" -- Right ["-DFOO=\"bar baz\""] toArgs' :: String -> Either String [String] toArgs' String s = case (Char -> Bool) -> String -> String forall a. (a -> Bool) -> [a] -> [a] dropWhile Char -> Bool isSpace String s of [] -> [String] -> Either String [String] forall a b. b -> Either a b Right [] (Char '"' : String _) -> do -- readAsString removes outer quotes (String arg, String rest) <- String -> Either String (String, String) readAsString String s (String argString -> [String] -> [String] forall a. a -> [a] -> [a] :) ([String] -> [String]) -> Either String [String] -> Either String [String] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b `fmap` String -> Either String [String] toArgs' String rest String s' -> case (Char -> Bool) -> String -> (String, String) forall a. (a -> Bool) -> [a] -> ([a], [a]) break (Char -> Bool isSpace (Char -> Bool) -> (Char -> Bool) -> Char -> Bool forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool <||> (Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char '"')) String s' of (String argPart1, s'' :: String s''@(Char '"':String _)) -> do (String argPart2, String rest) <- String -> Either String (String, String) readAsString String s'' -- show argPart2 to keep inner quotes ((String argPart1 String -> String -> String forall a. [a] -> [a] -> [a] ++ String -> String forall a. Show a => a -> String show String argPart2)String -> [String] -> [String] forall a. a -> [a] -> [a] :) ([String] -> [String]) -> Either String [String] -> Either String [String] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b `fmap` String -> Either String [String] toArgs' String rest (String arg, String s'') -> (String argString -> [String] -> [String] forall a. a -> [a] -> [a] :) ([String] -> [String]) -> Either String [String] -> Either String [String] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b `fmap` String -> Either String [String] toArgs' String s'' readAsString :: String -> Either String (String, String) readAsString :: String -> Either String (String, String) readAsString String s = case ReadS String forall a. Read a => ReadS a reads String s of [(String arg, String rest)] -- rest must either be [] or start with a space | (Char -> Bool) -> String -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all Char -> Bool isSpace (Int -> String -> String forall a. Int -> [a] -> [a] take Int 1 String rest) -> (String, String) -> Either String (String, String) forall a b. b -> Either a b Right (String arg, String rest) [(String, String)] _ -> String -> Either String (String, String) forall a b. a -> Either a b Left (String "Couldn't read " String -> String -> String forall a. [a] -> [a] -> [a] ++ String -> String forall a. Show a => a -> String show String s String -> String -> String forall a. [a] -> [a] -> [a] ++ String " as String") ----------------------------------------------------------------------------- -- Integers -- | Determine the $\log_2$ of exact powers of 2 exactLog2 :: Integer -> Maybe Integer exactLog2 :: Integer -> Maybe Integer exactLog2 Integer x | Integer x Integer -> Integer -> Bool forall a. Ord a => a -> a -> Bool <= Integer 0 = Maybe Integer forall a. Maybe a Nothing | Integer x Integer -> Integer -> Bool forall a. Ord a => a -> a -> Bool > Int32 -> Integer forall a b. (Integral a, Num b) => a -> b fromIntegral (Int32 forall a. Bounded a => a maxBound :: Int32) = Maybe Integer forall a. Maybe a Nothing | Int32 x' Int32 -> Int32 -> Int32 forall bv. Bits bv => bv -> bv -> bv .&. (-Int32 x') Int32 -> Int32 -> Bool forall a. Eq a => a -> a -> Bool /= Int32 x' = Maybe Integer forall a. Maybe a Nothing | Bool otherwise = Integer -> Maybe Integer forall a. a -> Maybe a Just (Int -> Integer forall a b. (Integral a, Num b) => a -> b fromIntegral Int c) where x' :: Int32 x' = Integer -> Int32 forall a b. (Integral a, Num b) => a -> b fromIntegral Integer x :: Int32 c :: Int c = Int32 -> Int forall b. FiniteBits b => b -> Int countTrailingZeros Int32 x' {- -- ----------------------------------------------------------------------------- -- Floats -} readRational__ :: ReadS Rational -- NB: doesn't handle leading "-" readRational__ :: ReadS Rational readRational__ String r = do (Integer n,Int d,String s) <- String -> [(Integer, Int, String)] forall a. Read a => String -> [(a, Int, String)] readFix String r (Int k,String t) <- String -> [(Int, String)] forall (m :: * -> *). MonadFail m => String -> m (Int, String) readExp String s (Rational, String) -> [(Rational, String)] forall (m :: * -> *) a. Monad m => a -> m a return ((Integer nInteger -> Integer -> Rational forall a. Integral a => a -> a -> Ratio a %Integer 1)Rational -> Rational -> Rational forall a. Num a => a -> a -> a *Rational 10Rational -> Int -> Rational forall a b. (Fractional a, Integral b) => a -> b -> a ^^(Int kInt -> Int -> Int forall a. Num a => a -> a -> a -Int d), String t) where readFix :: String -> [(a, Int, String)] readFix String r = do (String ds,String s) <- ReadS String lexDecDigits String r (String ds',String t) <- ReadS String forall (m :: * -> *). Monad m => String -> m (String, String) lexDotDigits String s (a, Int, String) -> [(a, Int, String)] forall (m :: * -> *) a. Monad m => a -> m a return (String -> a forall a. Read a => String -> a read (String dsString -> String -> String forall a. [a] -> [a] -> [a] ++String ds'), String -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length String ds', String t) readExp :: String -> m (Int, String) readExp (Char e:String s) | Char e Char -> String -> Bool forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` String "eE" = String -> m (Int, String) forall (m :: * -> *). MonadFail m => String -> m (Int, String) readExp' String s readExp String s = (Int, String) -> m (Int, String) forall (m :: * -> *) a. Monad m => a -> m a return (Int 0,String s) readExp' :: String -> m (Int, String) readExp' (Char '+':String s) = String -> m (Int, String) forall (m :: * -> *). MonadFail m => String -> m (Int, String) readDec String s readExp' (Char '-':String s) = do (Int k,String t) <- String -> m (Int, String) forall (m :: * -> *). MonadFail m => String -> m (Int, String) readDec String s (Int, String) -> m (Int, String) forall (m :: * -> *) a. Monad m => a -> m a return (-Int k,String t) readExp' String s = String -> m (Int, String) forall (m :: * -> *). MonadFail m => String -> m (Int, String) readDec String s readDec :: String -> m (Int, String) readDec String s = do (String ds,String r) <- (Char -> Bool) -> String -> m (String, String) forall (m :: * -> *). MonadFail m => (Char -> Bool) -> String -> m (String, String) nonnull Char -> Bool isDigit String s (Int, String) -> m (Int, String) forall (m :: * -> *) a. Monad m => a -> m a return ((Int -> Int -> Int) -> [Int] -> Int forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a foldl1 (\Int n Int d -> Int n Int -> Int -> Int forall a. Num a => a -> a -> a * Int 10 Int -> Int -> Int forall a. Num a => a -> a -> a + Int d) [ Char -> Int ord Char d Int -> Int -> Int forall a. Num a => a -> a -> a - Char -> Int ord Char '0' | Char d <- String ds ], String r) lexDecDigits :: ReadS String lexDecDigits = (Char -> Bool) -> ReadS String forall (m :: * -> *). MonadFail m => (Char -> Bool) -> String -> m (String, String) nonnull Char -> Bool isDigit lexDotDigits :: String -> m (String, String) lexDotDigits (Char '.':String s) = (String, String) -> m (String, String) forall (m :: * -> *) a. Monad m => a -> m a return ((Char -> Bool) -> String -> (String, String) span' Char -> Bool isDigit String s) lexDotDigits String s = (String, String) -> m (String, String) forall (m :: * -> *) a. Monad m => a -> m a return (String "",String s) nonnull :: (Char -> Bool) -> String -> m (String, String) nonnull Char -> Bool p String s = do (cs :: String cs@(Char _:String _),String t) <- (String, String) -> m (String, String) forall (m :: * -> *) a. Monad m => a -> m a return ((Char -> Bool) -> String -> (String, String) span' Char -> Bool p String s) (String, String) -> m (String, String) forall (m :: * -> *) a. Monad m => a -> m a return (String cs,String t) span' :: (Char -> Bool) -> String -> (String, String) span' Char -> Bool _ xs :: String xs@[] = (String xs, String xs) span' Char -> Bool p xs :: String xs@(Char x:String xs') | Char x Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char '_' = (Char -> Bool) -> String -> (String, String) span' Char -> Bool p String xs' -- skip "_" (#14473) | Char -> Bool p Char x = let (String ys,String zs) = (Char -> Bool) -> String -> (String, String) span' Char -> Bool p String xs' in (Char xChar -> String -> String forall a. a -> [a] -> [a] :String ys,String zs) | Bool otherwise = ([],String xs) readRational :: String -> Rational -- NB: *does* handle a leading "-" readRational :: String -> Rational readRational String top_s = case String top_s of Char '-' : String xs -> - (String -> Rational read_me String xs) String xs -> String -> Rational read_me String xs where read_me :: String -> Rational read_me String s = case (do { (Rational x,String "") <- ReadS Rational readRational__ String s ; Rational -> [Rational] forall (m :: * -> *) a. Monad m => a -> m a return Rational x }) of [Rational x] -> Rational x [] -> String -> Rational forall a. HasCallStack => String -> a error (String "readRational: no parse:" String -> String -> String forall a. [a] -> [a] -> [a] ++ String top_s) [Rational] _ -> String -> Rational forall a. HasCallStack => String -> a error (String "readRational: ambiguous parse:" String -> String -> String forall a. [a] -> [a] -> [a] ++ String top_s) readHexRational :: String -> Rational readHexRational :: String -> Rational readHexRational String str = case String str of Char '-' : String xs -> - (String -> Rational readMe String xs) String xs -> String -> Rational readMe String xs where readMe :: String -> Rational readMe String as = case String -> Maybe Rational readHexRational__ String as of Just Rational n -> Rational n Maybe Rational _ -> String -> Rational forall a. HasCallStack => String -> a error (String "readHexRational: no parse:" String -> String -> String forall a. [a] -> [a] -> [a] ++ String str) readHexRational__ :: String -> Maybe Rational readHexRational__ :: String -> Maybe Rational readHexRational__ (Char '0' : Char x : String rest) | Char x Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char 'X' Bool -> Bool -> Bool || Char x Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char 'x' = do let (String front,String rest2) = (Char -> Bool) -> String -> (String, String) span' Char -> Bool isHexDigit String rest Bool -> Maybe () forall (f :: * -> *). Alternative f => Bool -> f () guard (Bool -> Bool not (String -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null String front)) let frontNum :: Integer frontNum = Integer -> Integer -> String -> Integer forall (t :: * -> *) b. (Foldable t, Num b) => b -> b -> t Char -> b steps Integer 16 Integer 0 String front case String rest2 of Char '.' : String rest3 -> do let (String back,String rest4) = (Char -> Bool) -> String -> (String, String) span' Char -> Bool isHexDigit String rest3 Bool -> Maybe () forall (f :: * -> *). Alternative f => Bool -> f () guard (Bool -> Bool not (String -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null String back)) let backNum :: Integer backNum = Integer -> Integer -> String -> Integer forall (t :: * -> *) b. (Foldable t, Num b) => b -> b -> t Char -> b steps Integer 16 Integer frontNum String back exp1 :: Int exp1 = -Int 4 Int -> Int -> Int forall a. Num a => a -> a -> a * String -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length String back case String rest4 of Char p : String ps | Char -> Bool isExp Char p -> (Int -> Rational) -> Maybe Int -> Maybe Rational forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (Integer -> Int -> Rational mk Integer backNum (Int -> Rational) -> (Int -> Int) -> Int -> Rational forall b c a. (b -> c) -> (a -> b) -> a -> c . (Int -> Int -> Int forall a. Num a => a -> a -> a + Int exp1)) (String -> Maybe Int forall a. Num a => String -> Maybe a getExp String ps) String _ -> Rational -> Maybe Rational forall (m :: * -> *) a. Monad m => a -> m a return (Integer -> Int -> Rational mk Integer backNum Int exp1) Char p : String ps | Char -> Bool isExp Char p -> (Int -> Rational) -> Maybe Int -> Maybe Rational forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (Integer -> Int -> Rational mk Integer frontNum) (String -> Maybe Int forall a. Num a => String -> Maybe a getExp String ps) String _ -> Maybe Rational forall a. Maybe a Nothing where isExp :: Char -> Bool isExp Char p = Char p Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char 'p' Bool -> Bool -> Bool || Char p Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char 'P' getExp :: String -> Maybe a getExp (Char '+' : String ds) = String -> Maybe a forall a. Num a => String -> Maybe a dec String ds getExp (Char '-' : String ds) = (a -> a) -> Maybe a -> Maybe a forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap a -> a forall a. Num a => a -> a negate (String -> Maybe a forall a. Num a => String -> Maybe a dec String ds) getExp String ds = String -> Maybe a forall a. Num a => String -> Maybe a dec String ds mk :: Integer -> Int -> Rational mk :: Integer -> Int -> Rational mk Integer n Int e = Integer -> Rational forall a. Num a => Integer -> a fromInteger Integer n Rational -> Rational -> Rational forall a. Num a => a -> a -> a * Rational 2Rational -> Int -> Rational forall a b. (Fractional a, Integral b) => a -> b -> a ^^Int e dec :: String -> Maybe a dec String cs = case (Char -> Bool) -> String -> (String, String) span' Char -> Bool isDigit String cs of (String ds,String "") | Bool -> Bool not (String -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null String ds) -> a -> Maybe a forall a. a -> Maybe a Just (a -> a -> String -> a forall (t :: * -> *) b. (Foldable t, Num b) => b -> b -> t Char -> b steps a 10 a 0 String ds) (String, String) _ -> Maybe a forall a. Maybe a Nothing steps :: b -> b -> t Char -> b steps b base b n t Char ds = (b -> Char -> b) -> b -> t Char -> b forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl' (b -> b -> Char -> b forall a. Num a => a -> a -> Char -> a step b base) b n t Char ds step :: a -> a -> Char -> a step a base a n Char d = a base a -> a -> a forall a. Num a => a -> a -> a * a n a -> a -> a forall a. Num a => a -> a -> a + Int -> a forall a b. (Integral a, Num b) => a -> b fromIntegral (Char -> Int digitToInt Char d) span' :: (Char -> Bool) -> String -> (String, String) span' Char -> Bool _ xs :: String xs@[] = (String xs, String xs) span' Char -> Bool p xs :: String xs@(Char x:String xs') | Char x Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char '_' = (Char -> Bool) -> String -> (String, String) span' Char -> Bool p String xs' -- skip "_" (#14473) | Char -> Bool p Char x = let (String ys,String zs) = (Char -> Bool) -> String -> (String, String) span' Char -> Bool p String xs' in (Char xChar -> String -> String forall a. a -> [a] -> [a] :String ys,String zs) | Bool otherwise = ([],String xs) readHexRational__ String _ = Maybe Rational forall a. Maybe a Nothing ----------------------------------------------------------------------------- -- Verify that the 'dirname' portion of a FilePath exists. -- doesDirNameExist :: FilePath -> IO Bool doesDirNameExist :: String -> IO Bool doesDirNameExist String fpath = String -> IO Bool doesDirectoryExist (String -> String takeDirectory String fpath) ----------------------------------------------------------------------------- -- Backwards compatibility definition of getModificationTime getModificationUTCTime :: FilePath -> IO UTCTime getModificationUTCTime :: String -> IO UTCTime getModificationUTCTime = String -> IO UTCTime getModificationTime -- -------------------------------------------------------------- -- check existence & modification time at the same time modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime) modificationTimeIfExists :: String -> IO (Maybe UTCTime) modificationTimeIfExists String f = do (do UTCTime t <- String -> IO UTCTime getModificationUTCTime String f; Maybe UTCTime -> IO (Maybe UTCTime) forall (m :: * -> *) a. Monad m => a -> m a return (UTCTime -> Maybe UTCTime forall a. a -> Maybe a Just UTCTime t)) IO (Maybe UTCTime) -> (IOException -> IO (Maybe UTCTime)) -> IO (Maybe UTCTime) forall a. IO a -> (IOException -> IO a) -> IO a `catchIO` \IOException e -> if IOException -> Bool isDoesNotExistError IOException e then Maybe UTCTime -> IO (Maybe UTCTime) forall (m :: * -> *) a. Monad m => a -> m a return Maybe UTCTime forall a. Maybe a Nothing else IOException -> IO (Maybe UTCTime) forall a. IOException -> IO a ioError IOException e -- -------------------------------------------------------------- -- atomic file writing by writing to a temporary file first (see #14533) -- -- This should be used in all cases where GHC writes files to disk -- and uses their modification time to skip work later, -- as otherwise a partially written file (e.g. due to crash or Ctrl+C) -- also results in a skip. withAtomicRename :: (MonadIO m) => FilePath -> (FilePath -> m a) -> m a withAtomicRename :: String -> (String -> m a) -> m a withAtomicRename String targetFile String -> m a f | Bool enableAtomicRename = do -- The temp file must be on the same file system (mount) as the target file -- to result in an atomic move on most platforms. -- The standard way to ensure that is to place it into the same directory. -- This can still be fooled when somebody mounts a different file system -- at just the right time, but that is not a case we aim to cover here. let temp :: String temp = String targetFile String -> String -> String <.> String "tmp" a res <- String -> m a f String temp IO () -> m () forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> m ()) -> IO () -> m () forall a b. (a -> b) -> a -> b $ String -> String -> IO () renameFile String temp String targetFile a -> m a forall (m :: * -> *) a. Monad m => a -> m a return a res | Bool otherwise = String -> m a f String targetFile where -- As described in #16450, enabling this causes spurious build failures due -- to apparently missing files. enableAtomicRename :: Bool #if defined(mingw32_BUILD_OS) enableAtomicRename = False #else enableAtomicRename :: Bool enableAtomicRename = Bool True #endif -- -------------------------------------------------------------- -- split a string at the last character where 'pred' is True, -- returning a pair of strings. The first component holds the string -- up (but not including) the last character for which 'pred' returned -- True, the second whatever comes after (but also not including the -- last character). -- -- If 'pred' returns False for all characters in the string, the original -- string is returned in the first component (and the second one is just -- empty). splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) splitLongestPrefix :: String -> (Char -> Bool) -> (String, String) splitLongestPrefix String str Char -> Bool pred | String -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null String r_pre = (String str, []) | Bool otherwise = (String -> String forall a. [a] -> [a] reverse (String -> String forall a. [a] -> [a] tail String r_pre), String -> String forall a. [a] -> [a] reverse String r_suf) -- 'tail' drops the char satisfying 'pred' where (String r_suf, String r_pre) = (Char -> Bool) -> String -> (String, String) forall a. (a -> Bool) -> [a] -> ([a], [a]) break Char -> Bool pred (String -> String forall a. [a] -> [a] reverse String str) escapeSpaces :: String -> String escapeSpaces :: String -> String escapeSpaces = (Char -> String -> String) -> String -> String -> String forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr (\Char c String s -> if Char -> Bool isSpace Char c then Char '\\'Char -> String -> String forall a. a -> [a] -> [a] :Char cChar -> String -> String forall a. a -> [a] -> [a] :String s else Char cChar -> String -> String forall a. a -> [a] -> [a] :String s) String "" type Suffix = String -------------------------------------------------------------- -- * Search path -------------------------------------------------------------- data Direction = Forwards | Backwards reslash :: Direction -> FilePath -> FilePath reslash :: Direction -> String -> String reslash Direction d = String -> String f where f :: String -> String f (Char '/' : String xs) = Char slash Char -> String -> String forall a. a -> [a] -> [a] : String -> String f String xs f (Char '\\' : String xs) = Char slash Char -> String -> String forall a. a -> [a] -> [a] : String -> String f String xs f (Char x : String xs) = Char x Char -> String -> String forall a. a -> [a] -> [a] : String -> String f String xs f String "" = String "" slash :: Char slash = case Direction d of Direction Forwards -> Char '/' Direction Backwards -> Char '\\' makeRelativeTo :: FilePath -> FilePath -> FilePath String this makeRelativeTo :: String -> String -> String `makeRelativeTo` String that = String directory String -> String -> String </> String thisFilename where (String thisDirectory, String thisFilename) = String -> (String, String) splitFileName String this thatDirectory :: String thatDirectory = String -> String dropFileName String that directory :: String directory = [String] -> String joinPath ([String] -> String) -> [String] -> String forall a b. (a -> b) -> a -> b $ [String] -> [String] -> [String] f (String -> [String] splitPath String thisDirectory) (String -> [String] splitPath String thatDirectory) f :: [String] -> [String] -> [String] f (String x : [String] xs) (String y : [String] ys) | String x String -> String -> Bool forall a. Eq a => a -> a -> Bool == String y = [String] -> [String] -> [String] f [String] xs [String] ys f [String] xs [String] ys = Int -> String -> [String] forall a. Int -> a -> [a] replicate ([String] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [String] ys) String ".." [String] -> [String] -> [String] forall a. [a] -> [a] -> [a] ++ [String] xs {- ************************************************************************ * * \subsection[Utils-Data]{Utils for defining Data instances} * * ************************************************************************ These functions helps us to define Data instances for abstract types. -} abstractConstr :: String -> Constr abstractConstr :: String -> Constr abstractConstr String n = DataType -> String -> [String] -> Fixity -> Constr mkConstr (String -> DataType abstractDataType String n) (String "{abstract:"String -> String -> String forall a. [a] -> [a] -> [a] ++String nString -> String -> String forall a. [a] -> [a] -> [a] ++String "}") [] Fixity Prefix abstractDataType :: String -> DataType abstractDataType :: String -> DataType abstractDataType String n = String -> [Constr] -> DataType mkDataType String n [String -> Constr abstractConstr String n] {- ************************************************************************ * * \subsection[Utils-C]{Utils for printing C code} * * ************************************************************************ -} charToC :: Word8 -> String charToC :: Word8 -> String charToC Word8 w = case Int -> Char chr (Word8 -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral Word8 w) of Char '\"' -> String "\\\"" Char '\'' -> String "\\\'" Char '\\' -> String "\\\\" Char c | Char c Char -> Char -> Bool forall a. Ord a => a -> a -> Bool >= Char ' ' Bool -> Bool -> Bool && Char c Char -> Char -> Bool forall a. Ord a => a -> a -> Bool <= Char '~' -> [Char c] | Bool otherwise -> [Char '\\', Int -> Char chr (Char -> Int ord Char '0' Int -> Int -> Int forall a. Num a => a -> a -> a + Char -> Int ord Char c Int -> Int -> Int forall a. Integral a => a -> a -> a `div` Int 64), Int -> Char chr (Char -> Int ord Char '0' Int -> Int -> Int forall a. Num a => a -> a -> a + Char -> Int ord Char c Int -> Int -> Int forall a. Integral a => a -> a -> a `div` Int 8 Int -> Int -> Int forall a. Integral a => a -> a -> a `mod` Int 8), Int -> Char chr (Char -> Int ord Char '0' Int -> Int -> Int forall a. Num a => a -> a -> a + Char -> Int ord Char c Int -> Int -> Int forall a. Integral a => a -> a -> a `mod` Int 8)] {- ************************************************************************ * * \subsection[Utils-Hashing]{Utils for hashing} * * ************************************************************************ -} -- | A sample hash function for Strings. We keep multiplying by the -- golden ratio and adding. The implementation is: -- -- > hashString = foldl' f golden -- > where f m c = fromIntegral (ord c) * magic + hashInt32 m -- > magic = 0xdeadbeef -- -- Where hashInt32 works just as hashInt shown above. -- -- Knuth argues that repeated multiplication by the golden ratio -- will minimize gaps in the hash space, and thus it's a good choice -- for combining together multiple keys to form one. -- -- Here we know that individual characters c are often small, and this -- produces frequent collisions if we use ord c alone. A -- particular problem are the shorter low ASCII and ISO-8859-1 -- character strings. We pre-multiply by a magic twiddle factor to -- obtain a good distribution. In fact, given the following test: -- -- > testp :: Int32 -> Int -- > testp k = (n - ) . length . group . sort . map hs . take n $ ls -- > where ls = [] : [c : l | l <- ls, c <- ['\0'..'\xff']] -- > hs = foldl' f golden -- > f m c = fromIntegral (ord c) * k + hashInt32 m -- > n = 100000 -- -- We discover that testp magic = 0. hashString :: String -> Int32 hashString :: String -> Int32 hashString = (Int32 -> Char -> Int32) -> Int32 -> String -> Int32 forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl' Int32 -> Char -> Int32 f Int32 golden where f :: Int32 -> Char -> Int32 f Int32 m Char c = Int -> Int32 forall a b. (Integral a, Num b) => a -> b fromIntegral (Char -> Int ord Char c) Int32 -> Int32 -> Int32 forall a. Num a => a -> a -> a * Int32 magic Int32 -> Int32 -> Int32 forall a. Num a => a -> a -> a + Int32 -> Int32 hashInt32 Int32 m magic :: Int32 magic = Word32 -> Int32 forall a b. (Integral a, Num b) => a -> b fromIntegral (Word32 0xdeadbeef :: Word32) golden :: Int32 golden :: Int32 golden = Int32 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32 -- was -1640531527 = round ((sqrt 5 - 1) * 2^31) :: Int32 -- but that has bad mulHi properties (even adding 2^32 to get its inverse) -- Whereas the above works well and contains no hash duplications for -- [-32767..65536] -- | A sample (and useful) hash function for Int32, -- implemented by extracting the uppermost 32 bits of the 64-bit -- result of multiplying by a 33-bit constant. The constant is from -- Knuth, derived from the golden ratio: -- -- > golden = round ((sqrt 5 - 1) * 2^32) -- -- We get good key uniqueness on small inputs -- (a problem with previous versions): -- (length $ group $ sort $ map hashInt32 [-32767..65536]) == 65536 + 32768 -- hashInt32 :: Int32 -> Int32 hashInt32 :: Int32 -> Int32 hashInt32 Int32 x = Int32 -> Int32 -> Int32 mulHi Int32 x Int32 golden Int32 -> Int32 -> Int32 forall a. Num a => a -> a -> a + Int32 x -- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply mulHi :: Int32 -> Int32 -> Int32 mulHi :: Int32 -> Int32 -> Int32 mulHi Int32 a Int32 b = Int64 -> Int32 forall a b. (Integral a, Num b) => a -> b fromIntegral (Int64 r Int64 -> Int -> Int64 forall a. Bits a => a -> Int -> a `shiftR` Int 32) where r :: Int64 r :: Int64 r = Int32 -> Int64 forall a b. (Integral a, Num b) => a -> b fromIntegral Int32 a Int64 -> Int64 -> Int64 forall a. Num a => a -> a -> a * Int32 -> Int64 forall a b. (Integral a, Num b) => a -> b fromIntegral Int32 b -- | A call stack constraint, but only when 'isDebugOn'. #if defined(DEBUG) type HasDebugCallStack = HasCallStack #else type HasDebugCallStack = (() :: Constraint) #endif data OverridingBool = Auto | Always | Never deriving Int -> OverridingBool -> String -> String [OverridingBool] -> String -> String OverridingBool -> String (Int -> OverridingBool -> String -> String) -> (OverridingBool -> String) -> ([OverridingBool] -> String -> String) -> Show OverridingBool forall a. (Int -> a -> String -> String) -> (a -> String) -> ([a] -> String -> String) -> Show a showList :: [OverridingBool] -> String -> String $cshowList :: [OverridingBool] -> String -> String show :: OverridingBool -> String $cshow :: OverridingBool -> String showsPrec :: Int -> OverridingBool -> String -> String $cshowsPrec :: Int -> OverridingBool -> String -> String Show overrideWith :: Bool -> OverridingBool -> Bool overrideWith :: Bool -> OverridingBool -> Bool overrideWith Bool b OverridingBool Auto = Bool b overrideWith Bool _ OverridingBool Always = Bool True overrideWith Bool _ OverridingBool Never = Bool False