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