ginsu-0.8.0: GenUtil.hs

{-# LANGUAGE ParallelListComp #-}
-- Copyright (c) 2002 John Meacham (john@foo.net)
--
-- Permission is hereby granted, free of charge, to any person obtaining a
-- copy of this software and associated documentation files (the
-- "Software"), to deal in the Software without restriction, including
-- without limitation the rights to use, copy, modify, merge, publish,
-- distribute, sublicense, and/or sell copies of the Software, and to
-- permit persons to whom the Software is furnished to do so, subject to
-- the following conditions:
--
-- The above copyright notice and this permission notice shall be included
-- in all copies or substantial portions of the Software.
--
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
-- IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
-- CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
-- TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
-- SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

----------------------------------------
-- | This is a collection of random useful utility functions written in pure
-- Haskell 98. In general, it trys to conform to the naming scheme put forth
-- the haskell prelude and fill in the obvious omissions, as well as provide
-- useful routines in general. To ensure maximum portability, no instances are
-- exported so it may be added to any project without conflicts.
----------------------------------------

module GenUtil(
    -- * Functions
    -- ** Error reporting
    putErr,putErrLn,putErrDie,
    -- ** Simple deconstruction
    fromLeft,fromRight,fsts,snds,splitEither,rights,lefts,
    isLeft,isRight,
    -- ** System routines
    exitSuccess, System.exitFailure, epoch, lookupEnv,endOfTime,
    -- ** Random routines
    repMaybe,
    liftT2, liftT3, liftT4,
    snub, snubFst, snubUnder, smerge, sortFst, groupFst, foldl',
    fmapLeft,fmapRight,isDisjoint,isConjoint,
    groupUnder,
    sortUnder,
    minimumUnder,
    maximumUnder,
    sortGroupUnder,
    sortGroupUnderF,
    sortGroupUnderFG,
    sameLength,
    naturals,

    -- ** Monad routines
    perhapsM,
    repeatM, repeatM_, replicateM, replicateM_, maybeToMonad,
    toMonadM, ioM, ioMp, foldlM, foldlM_, foldl1M, foldl1M_,
    -- ** Text Routines
    -- *** Quoting
    shellQuote, simpleQuote, simpleUnquote,
    -- *** Layout
    indentLines,
    buildTableLL,
    buildTableRL,
    buildTable,
    trimBlankLines,
    paragraph,
    paragraphBreak,
    expandTabs,
    chunkText,
    -- *** Scrambling
    rot13,
    -- ** Random
    concatInter,
    powerSet,
    randomPermute,
    randomPermuteIO,
    chunk,
    rtup,
    triple,
    fromEither,
    mapFst,
    mapSnd,
    mapFsts,
    mapSnds,
    tr,
    readHex,
    overlaps,
    showDuration,
    readM,
    readsM,
    split,
    tokens,
    count,
    hasRepeatUnder,
    -- ** Option handling
    getArgContents,
    parseOpt,
    getOptContents,
    doTime,
    getPrefix,
    rspan,
    rbreak,
    rdropWhile,
    rtakeWhile,
    rbdropWhile,
    concatMapM,
    on,
    mapMsnd,
    mapMfst,


    -- * Classes
    UniqueProducer(..)
    ) where

import Char(isAlphaNum, isSpace, toLower, ord, chr)
import List
import Monad
import qualified IO
import qualified System
import Random(StdGen, newStdGen, Random(randomR))
import Time
import CPUTime

{-# SPECIALIZE snub :: [String] -> [String] #-}
{-# SPECIALIZE snub :: [Int] -> [Int] #-}

{-# RULES "snub/snub" forall x . snub (snub x) = snub x #-}
{-# RULES "snub/nub" forall x . snub (nub x) = snub x #-}
{-# RULES "nub/snub" forall x . nub (snub x) = snub x #-}
{-# RULES "snub/sort" forall x . snub (sort x) = snub x #-}
{-# RULES "sort/snub" forall x . sort (snub x) = snub x #-}
{-# RULES "snub/[]" snub [] = [] #-}
{-# RULES "snub/[x]" forall x . snub [x] = [x] #-}

-- | sorted nub of list, much more efficient than nub, but doesnt preserve ordering.
snub :: Ord a => [a] -> [a]
snub = map head . group . sort

-- | sorted nub of list of tuples, based solely on the first element of each tuple.
snubFst :: Ord a => [(a,b)] -> [(a,b)]
snubFst = map head . groupBy (\(x,_) (y,_) -> x == y) . sortBy (\(x,_) (y,_) -> compare x y)

-- | sorted nub of list based on function of values
snubUnder :: Ord b => (a -> b) -> [a] -> [a]
snubUnder f = map head . groupUnder f . sortUnder f

-- | sort list of tuples, based on first element of each tuple.
sortFst :: Ord a => [(a,b)] -> [(a,b)]
sortFst = sortBy (\(x,_) (y,_) -> compare x y)

-- | group list of tuples, based only on equality of the first element of each tuple.
groupFst :: Eq a => [(a,b)] -> [[(a,b)]]
groupFst = groupBy (\(x,_) (y,_) -> x == y)

concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM f xs = do
    res <- mapM f xs
    return $ concat res

on :: (a -> a -> b) -> (c -> a) -> c -> c -> b
(*) `on` f = \x y -> f x * f y

mapMsnd :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)]
mapMsnd f xs = do
    let g (a,b) = do
            c <- f b
            return (a,c)
    mapM g xs

mapMfst :: Monad m => (b -> m c) -> [(b,a)] -> m [(c,a)]
mapMfst f xs = do
    let g (a,b) = do
            c <- f a
            return (c,b)
    mapM g xs

rspan :: (a -> Bool) -> [a] -> ([a], [a])
rspan fn xs = f xs [] where
    f [] rs = ([],reverse rs)
    f (x:xs) rs
        | fn x = f xs (x:rs)
        | otherwise = (reverse rs ++ x:za,zb) where
            (za,zb) = f xs []

rbreak :: (a -> Bool) -> [a] -> ([a], [a])
rbreak fn xs = rspan (not . fn) xs

rdropWhile :: (a -> Bool) -> [a] -> [a]
rdropWhile fn xs = f xs [] where
    f [] _ = []
    f (x:xs) rs
        | fn x = f xs (x:rs)
        | otherwise = reverse rs ++ x:(f xs [])

rtakeWhile :: (a -> Bool) -> [a] -> [a]
rtakeWhile fn xs = f xs [] where
    f [] rs = reverse rs
    f (x:xs) rs
        | fn x = f xs (x:rs)
        | otherwise = f xs []

rbdropWhile :: (a -> Bool) -> [a] -> [a]
rbdropWhile fn xs = rdropWhile fn (dropWhile fn xs)

-- | group a list based on a function of the values.
groupUnder :: Eq b => (a -> b) -> [a] -> [[a]]
groupUnder f = groupBy (\x y -> f x == f y)
-- | sort a list based on a function of the values.
sortUnder :: Ord b => (a -> b) -> [a] -> [a]
sortUnder f = sortBy (\x y -> f x `compare` f y)

-- | merge sorted lists in linear time
smerge :: Ord a => [a] -> [a] -> [a]
smerge (x:xs) (y:ys)
    | x == y = x:smerge xs ys
    | x < y = x:smerge xs (y:ys)
    | otherwise = y:smerge (x:xs) ys
smerge [] ys = ys
smerge xs [] = xs

sortGroupUnder :: Ord a => (b -> a) -> [b] -> [[b]]
sortGroupUnder f = groupUnder f . sortUnder f
sortGroupUnderF :: Ord a => (b -> a) -> [b] -> [(a,[b])]
sortGroupUnderF f xs = [ (f x, xs) |  xs@(x:_) <- sortGroupUnder f xs]

sortGroupUnderFG :: Ord b => (a -> b) -> (a -> c) -> [a] -> [(b,[c])]
sortGroupUnderFG f g xs = [ (f x, map g xs) |  xs@(x:_) <- sortGroupUnder f xs]

minimumUnder :: Ord b => (a -> b) -> [a] -> a
minimumUnder _ [] = error "minimumUnder: empty list"
minimumUnder _ [x] = x
minimumUnder f (x:xs) = g (f x) x xs where
    g _ x [] = x
    g fb b (x:xs)
        | fx < fb = g fx x xs
        | otherwise = g fb b xs where
            fx = f x

maximumUnder :: Ord b => (a -> b) -> [a] -> a
maximumUnder _ [] = error "maximumUnder: empty list"
maximumUnder _ [x] = x
maximumUnder f (x:xs) = g (f x) x xs where
    g _ x [] = x
    g fb b (x:xs)
        | fx > fb = g fx x xs
        | otherwise = g fb b xs where
            fx = f x

-- | Flushes stdout and writes string to standard error
putErr :: String -> IO ()
putErr s = IO.hFlush IO.stdout >> IO.hPutStr IO.stderr s

-- | Flush stdout and write string and newline to standard error
putErrLn :: String -> IO ()
putErrLn s = IO.hFlush IO.stdout >> IO.hPutStrLn IO.stderr s


-- | Flush stdout, write string and newline to standard error,
-- then exit program with failure.
putErrDie :: String -> IO a
putErrDie s = putErrLn s >> System.exitFailure


-- | exit program successfully. 'exitFailure' is
-- also exported from System.
exitSuccess :: IO a
exitSuccess = System.exitWith System.ExitSuccess


{-# INLINE fromRight #-}
fromRight :: Either a b -> b
fromRight (Right x) = x
fromRight _ = error "fromRight"

{-# INLINE fromLeft #-}
fromLeft :: Either a b -> a
fromLeft (Left x) = x
fromLeft _ = error "fromLeft"

-- | recursivly apply function to value until it returns Nothing
repMaybe :: (a -> Maybe a) -> a -> a
repMaybe f e = case f e of
    Just e' -> repMaybe f e'
    Nothing -> e

{-# INLINE liftT2 #-}
{-# INLINE liftT3 #-}
{-# INLINE liftT4 #-}

liftT4 (f1,f2,f3,f4) (v1,v2,v3,v4) = (f1 v1, f2 v2, f3 v3, f4 v4)
liftT3 (f,g,h) (x,y,z) = (f x, g y, h z)
-- | apply functions to values inside a tupele. 'liftT3' and 'liftT4' also exist.
liftT2 :: (a -> b, c -> d) -> (a,c) -> (b,d)
liftT2 (f,g) (x,y) = (f x, g y)


-- | class for monads which can generate
-- unique values.
class Monad m => UniqueProducer m where
    -- | produce a new unique value
    newUniq :: m Int

--    peekUniq :: m Int
--    modifyUniq :: (Int -> Int) -> m ()
--    newUniq = do
--	v <- peekUniq
--	modifyUniq (+1)
--	return v

rtup a b = (b,a)
triple a b c = (a,b,c)

-- | the standard unix epoch
epoch :: ClockTime
epoch = toClockTime $ CalendarTime { ctYear = 1970, ctMonth = January, ctDay = 0, ctHour = 0, ctMin = 0, ctSec = 0, ctTZ = 0, ctPicosec = 0, ctWDay = undefined, ctYDay = undefined, ctTZName = undefined, ctIsDST = undefined}

-- | an arbitrary time in the future
endOfTime :: ClockTime
endOfTime = toClockTime $ CalendarTime { ctYear = 2020, ctMonth = January, ctDay = 0, ctHour = 0, ctMin = 0, ctSec = 0, ctTZ = 0, ctPicosec = 0, ctWDay = undefined, ctYDay = undefined, ctTZName = undefined, ctIsDST = undefined}

{-# INLINE fsts #-}
-- | take the fst of every element of a list
fsts :: [(a,b)] -> [a]
fsts = map fst

{-# INLINE snds #-}
-- | take the snd of every element of a list
snds :: [(a,b)] -> [b]
snds = map snd

{-# INLINE repeatM #-}
{-# SPECIALIZE repeatM :: IO a -> IO [a] #-}
repeatM :: Monad m => m a -> m [a]
repeatM x = sequence $ repeat x

{-# INLINE repeatM_ #-}
{-# SPECIALIZE repeatM_ :: IO a -> IO () #-}
repeatM_ :: Monad m => m a -> m ()
repeatM_ x = sequence_ $ repeat x

{-# RULES "replicateM/0" replicateM 0 = const (return []) #-}
{-# RULES "replicateM_/0" replicateM_ 0 = const (return ()) #-}

{-# INLINE replicateM #-}
{-# SPECIALIZE replicateM :: Int -> IO a -> IO [a] #-}
replicateM :: Monad m => Int -> m a -> m [a]
replicateM n x = sequence $ replicate n x

{-# INLINE replicateM_ #-}
{-# SPECIALIZE replicateM_ :: Int -> IO a -> IO () #-}
replicateM_ :: Monad m => Int -> m a -> m ()
replicateM_ n x = sequence_ $ replicate n x

{-# SPECIALIZE maybeToMonad :: Maybe a -> IO a #-}
-- | convert a maybe to an arbitrary failable monad
maybeToMonad :: Monad m => Maybe a -> m a
maybeToMonad (Just x) = return x
maybeToMonad Nothing = fail "Nothing"

toMonadM :: Monad m => m (Maybe a) -> m a
toMonadM action = join $ liftM maybeToMonad action

foldlM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a
foldlM f v (x:xs) = (f v x) >>= \a -> foldlM f a xs
foldlM _ v [] = return v

foldl1M :: Monad m => (a -> a -> m a) ->  [a] -> m a
foldl1M f (x:xs) = foldlM f x xs
foldl1M _ _ = error "foldl1M"


foldlM_ :: Monad m => (a -> b -> m a) -> a -> [b] -> m ()
foldlM_ f v xs = foldlM f v xs >> return ()

foldl1M_ ::Monad m => (a -> a -> m a)  -> [a] -> m ()
foldl1M_ f xs = foldl1M f xs >> return ()

-- | partition a list of eithers.
splitEither :: [Either a b] -> ([a],[b])
splitEither  (r:rs) = case splitEither rs of
    (xs,ys) -> case r of
        Left x -> (x:xs,ys)
        Right y -> (xs,y:ys)
splitEither          [] = ([],[])

isLeft Left {} = True
isLeft _ = False

isRight Right {} = True
isRight _ = False

perhapsM :: Monad m => Bool -> a -> m a
perhapsM True a = return a
perhapsM False _ = fail "perhapsM"

sameLength (_:xs) (_:ys) = sameLength xs ys
sameLength [] [] = True
sameLength _ _ = False

fromEither :: Either a a -> a
fromEither (Left x) = x
fromEither (Right x) = x

{-# INLINE mapFst #-}
{-# INLINE mapSnd #-}
mapFst :: (a -> b) -> (a,c) -> (b,c)
mapFst  f   (x,y) = (f x,  y)
mapSnd :: (a -> b) -> (c,a) -> (c,b)
mapSnd    g (x,y) = (  x,g y)

{-# INLINE mapFsts #-}
{-# INLINE mapSnds #-}
mapFsts :: (a -> b) -> [(a,c)] -> [(b,c)]
mapFsts f xs = [(f x, y) | (x,y) <- xs]
mapSnds :: (a -> b) -> [(c,a)] -> [(c,b)]
mapSnds g xs = [(x, g y) | (x,y) <- xs]

{-# INLINE rights #-}
-- | take just the rights
rights :: [Either a b] -> [b]
rights xs = [x | Right x <- xs]

{-# INLINE lefts #-}
-- | take just the lefts
lefts :: [Either a b] -> [a]
lefts xs = [x | Left x <- xs]

-- | Trasform IO errors into the failing of an arbitrary monad.
ioM :: Monad m => IO a -> IO (m a)
ioM action = catch (fmap return action) (\e -> return (fail (show e)))

-- | Trasform IO errors into the mzero of an arbitrary member of MonadPlus.
ioMp :: MonadPlus m => IO a -> IO (m a)
ioMp action = catch (fmap return action) (\_ -> return mzero)

-- | reformat a string to not be wider than a given width, breaking it up
-- between words.

paragraph :: Int -> String -> String
paragraph maxn xs = drop 1 (f maxn (words xs)) where
    f n (x:xs) | lx < n = (' ':x) ++ f (n - lx) xs where
        lx = length x + 1
    f _ (x:xs) = '\n': (x ++ f (maxn - length x) xs)
    f _ [] = "\n"

chunk :: Int -> [a] -> [[a]]
chunk 0 _  = repeat []
chunk _ [] = []
chunk mw s = case splitAt mw s of
    (a,[]) -> [a]
    (a,b) -> a : chunk mw b

chunkText :: Int -> String -> String
chunkText mw s = concatMap (unlines . chunk mw) $ lines s

rot13Char :: Char -> Char
rot13Char c
    | c >= 'a' && c <= 'm' || c >= 'A' && c <= 'M' = chr $ ord c + 13
    | c >= 'n' && c <= 'z' || c >= 'N' && c <= 'Z' = chr $ ord c - 13
    | otherwise                                    = c

rot13 :: String -> String
rot13 = map rot13Char

{-
paragraphBreak :: Int -> String -> String
paragraphBreak  maxn xs = unlines (map ( unlines . map (unlines . chunk maxn) . lines . f maxn ) $ lines xs) where
    f _ "" = ""
    f n xs | length ss > 0 = if length ss + r rs > n then '\n':f maxn rs else ss where
        (ss,rs) = span isSpace xs
    f n xs = ns ++ f (n - length ns) rs where
        (ns,rs) = span (not . isSpace) xs
    r xs = length $ fst $ span (not . isSpace) xs
-}

paragraphBreak :: Int -> String -> String
paragraphBreak  maxn xs = unlines $ (map f) $ lines xs where
    f s | length s <= maxn = s
    f s | isSpace (head b) = a ++ "\n" ++ f (dropWhile isSpace b)
        | all (not . isSpace) a = a ++ "\n" ++ f b
        | otherwise  = reverse (dropWhile isSpace sa) ++ "\n" ++ f (reverse ea ++ b) where
            (ea, sa) = span (not . isSpace) $ reverse a
            (a,b) = splitAt maxn s

expandTabs' :: Int -> Int -> String -> String
expandTabs' 0 _ s = filter (/= '\t') s
expandTabs' sz off ('\t':s) = replicate len ' ' ++ expandTabs' sz (off + len) s where
    len = (sz - (off `mod` sz))
expandTabs' sz _ ('\n':s) = '\n': expandTabs' sz 0 s
expandTabs' sz off (c:cs) = c: expandTabs' sz (off + 1) cs
expandTabs' _ _ "" = ""


-- | expand tabs into spaces in a string assuming tabs are every 8 spaces and we are starting at column 0.
expandTabs :: String -> String
expandTabs s = expandTabs' 8 0 s



-- | Translate characters to other characters in a string, if the second argument is empty,
-- delete the characters in the first argument, else map each character to the
-- cooresponding one in the second argument, cycling the second argument if
-- necessary.

tr :: String -> String -> String -> String
tr as "" s = filter (`notElem` as) s
tr as bs s = map (f as bs) s where
    f (a:_) (b:_) c | a == c = b
    f (_:as) (_:bs) c = f as bs c
    f [] _ c = c
    f as' [] c = f as' bs c
    --f _ _ _ = error "invalid tr"


-- | quote strings rc style. single quotes protect any characters between
-- them, to get an actual single quote double it up. Inverse of 'simpleUnquote'
simpleQuote :: [String] -> String
simpleQuote ss = unwords (map f ss) where
    f s | any isBad s || null s = "'" ++ dquote s ++ "'"
    f s = s
    dquote s = concatMap (\c -> if c == '\'' then "''" else [c]) s
    isBad c = isSpace c || c == '\''

-- | inverse of 'simpleQuote'
simpleUnquote :: String -> [String]
simpleUnquote s = f (dropWhile isSpace s)  where
    f [] = []
    f ('\'':xs) = case quote' "" xs of (x,y) ->  x:f (dropWhile isSpace y)
    f xs = case span (not . isSpace) xs of (x,y) ->  x:f (dropWhile isSpace y)
    quote' a ('\'':'\'':xs) = quote' ('\'':a) xs
    quote' a ('\'':xs) = (reverse a, xs)
    quote' a (x:xs) = quote' (x:a) xs
    quote' a [] = (reverse a, "")

-- | quote a set of strings as would be appropriate to pass them as
-- arguments to a sh style shell
shellQuote :: [String] -> String
shellQuote ss = unwords (map f ss) where
    f s | any (not . isGood) s || null s  = "'" ++ dquote s ++ "'"
    f s = s
    dquote s = concatMap (\c -> if c == '\'' then "'\\''" else [c]) s
    isGood c = isAlphaNum c || c `elem` "@/.-_"


-- | looks up an enviornment variable and returns it in an arbitrary Monad rather
-- than raising an exception if the variable is not set.
lookupEnv :: Monad m => String -> IO (m String)
lookupEnv s = catch (fmap return $ System.getEnv s) (\e -> if IO.isDoesNotExistError e then return (fail (show e)) else ioError e)

{-# SPECIALIZE fmapLeft :: (a -> c) -> [(Either a b)] -> [(Either c b)] #-}
fmapLeft :: Functor f => (a -> c) -> f (Either a b) -> f (Either c b)
fmapLeft fn = fmap f where
    f (Left x) = Left (fn x)
    f (Right x)  = Right x

{-# SPECIALIZE fmapRight :: (b -> c) -> [(Either a b)] -> [(Either a c)] #-}
fmapRight :: Functor f => (b -> c) -> f (Either a b) -> f (Either a c)
fmapRight fn = fmap f where
    f (Left x) = Left x
    f (Right x)  = Right (fn x)

{-# SPECIALIZE isDisjoint :: [String] -> [String] -> Bool #-}
{-# SPECIALIZE isConjoint :: [String] -> [String] -> Bool #-}
{-# SPECIALIZE isDisjoint :: [Int] -> [Int] -> Bool #-}
{-# SPECIALIZE isConjoint :: [Int] -> [Int] -> Bool #-}
-- | set operations on lists. (slow!)
isDisjoint, isConjoint :: Eq a => [a] -> [a] -> Bool
isConjoint xs ys = or [x == y | x <- xs, y <- ys]
isDisjoint xs ys = not (isConjoint xs ys)

-- | 'concat' composed with 'List.intersperse'. Can be used similarly to join in perl.
concatInter :: String -> [String] -> String
concatInter x = concat . (intersperse x)

-- | place spaces before each line in string.
indentLines :: Int -> String -> String
indentLines n s = unlines $ map (replicate n ' ' ++)$ lines s

-- | trim blank lines at beginning and end of string
trimBlankLines :: String -> String
trimBlankLines cs = unlines $ rbdropWhile (all isSpace) (lines cs)

buildTableRL :: [(String,String)] -> [String]
buildTableRL ps = map f ps where
    f (x,"") = x
    f (x,y) = replicate (bs - length x) ' ' ++ x ++ replicate 4 ' ' ++ y
    bs = maximum (map (length . fst) [ p | p@(_,_:_) <- ps ])

buildTableLL :: [(String,String)] -> [String]
buildTableLL ps = map f ps where
    f (x,y) = x ++ replicate (bs - length x) ' ' ++ replicate 4 ' ' ++ y
    bs = maximum (map (length . fst) ps)

{-# INLINE foldl' #-}
-- | strict version of 'foldl'
foldl' :: (a -> b -> a) -> a -> [b] -> a
foldl' _ a []     = a
foldl' f a (x:xs) = (foldl' f $! f a x) xs

-- | count elements of list that have a given property
count :: (a -> Bool) -> [a] -> Int
count f xs = g 0 xs where
    g n [] = n
    g n (x:xs)
        | f x = let x = n + 1 in x `seq` g x xs
        | otherwise = g n xs

-- | randomly permute a list, using the standard random number generator.
randomPermuteIO :: [a] -> IO [a]
randomPermuteIO xs = newStdGen >>= \g -> return (randomPermute g xs)

-- | randomly permute a list given a RNG
randomPermute :: StdGen -> [a] -> [a]
randomPermute _   []  = []
randomPermute gen xs  = (head tl) : randomPermute gen' (hd ++ tail tl)
   where (idx, gen') = randomR (0,length xs - 1) gen
         (hd,  tl)   = splitAt idx xs

hasRepeatUnder f xs = any (not . null . tail) $ sortGroupUnder f xs

-- | compute the power set of a list

powerSet       :: [a] -> [[a]]
powerSet []     = [[]]
powerSet (x:xs) = xss /\/ map (x:) xss
                where xss = powerSet xs

-- | interleave two lists lazily, alternating elements from them. This can also be
-- used instead of concatination to avoid space leaks in certain situations.

(/\/)        :: [a] -> [a] -> [a]
[]     /\/ ys = ys
(x:xs) /\/ ys = x : (ys /\/ xs)



readHexChar a | a >= '0' && a <= '9' = return $ ord a - ord '0'
readHexChar a | z >= 'a' && z <= 'f' = return $ 10 + ord z - ord 'a' where z = toLower a
readHexChar x = fail $ "not hex char: " ++ [x]

readHex :: Monad m => String -> m Int
readHex [] = fail "empty string"
readHex cs = mapM readHexChar cs >>= \cs' -> return (rh $ reverse cs') where
    rh (c:cs) =  c + 16 * (rh cs)
    rh [] =  0


{-# SPECIALIZE overlaps :: (Int,Int) -> (Int,Int) -> Bool #-}

-- | determine if two closed intervals overlap at all.

overlaps :: Ord a => (a,a) -> (a,a) -> Bool
(a,_) `overlaps` (_,y) | y < a = False
(_,b) `overlaps` (x,_) | b < x = False
_ `overlaps` _ = True

-- | translate a number of seconds to a string representing the duration expressed.
showDuration :: Integral a => a -> String
showDuration x = st "d" dayI ++ st "h" hourI ++ st "m" minI ++ show secI ++ "s" where
        (dayI, hourI) = divMod hourI' 24
        (hourI', minI) = divMod minI' 60
        (minI',secI) = divMod x 60
        st _ 0 = ""
        st c n = show n ++ c

-- | behave like while(<>) in perl, go through the argument list, reading the
-- concation of each file name mentioned or stdin if '-' is on it. If no
-- arguments are given, read stdin.

getArgContents :: IO String
getArgContents = do
    as <- System.getArgs
    let f "-" = getContents
        f fn = readFile fn
    cs <- mapM f as
    if null as then getContents else return $ concat cs

-- | Combination of parseOpt and getArgContents.
getOptContents :: String -> IO (String,[Char],[(Char,String)])
getOptContents args = do
    as <- System.getArgs
    (as,o1,o2) <- parseOpt args as
    let f "-" = getContents
        f fn = readFile fn
    cs <- mapM f as
    s <- if null as then getContents else return $ concat cs
    return (s,o1,o2)


-- | Process options with an option string like the standard C getopt function call.
parseOpt :: Monad m =>
    String -- ^ Argument string, list of valid options with : after ones which accept an argument
    -> [String]  -- ^ Arguments
    -> m ([String],[Char],[(Char,String)])  -- ^ (non-options,flags,options with arguments)
parseOpt ps as = f ([],[],[]) as where
    (args,oargs) = g ps [] [] where
        g (':':_) _ _ = error "getOpt: Invalid option string"
        g (c:':':ps) x y = g ps x (c:y)
        g (c:ps) x y = g ps (c:x) y
        g [] x y = (x,y)
    f cs [] = return cs
    f (xs,ys,zs) ("--":rs) = return (xs ++ rs, ys, zs)
    f cs (('-':as@(_:_)):rs) = z cs as where
        z (xs,ys,zs) (c:cs)
            | c `elem` args = z (xs,c:ys,zs) cs
            | c `elem` oargs = case cs of
                [] -> case rs of
                    (x:rs) -> f (xs,ys,(c,x):zs) rs
                    [] -> fail $ "Option requires argument: " ++ [c]
                x -> f (xs,ys,(c,x):zs) rs
            | otherwise = fail $ "Invalid option: " ++ [c]
        z cs [] = f cs rs
    f (xs,ys,zs) (r:rs) = f (xs ++ [r], ys, zs) rs

readM :: (Monad m, Read a) => String -> m a
readM cs = case [x | (x,t) <-  reads cs, ("","") <- lex t] of
    [x] -> return x
    [] -> fail "readM: no parse"
    _ -> fail "readM: ambiguous parse"

readsM :: (Monad m, Read a) => String -> m (a,String)
readsM cs = case readsPrec 0 cs of
    [(x,s)] -> return (x,s)
    _ -> fail "cannot readsM"

-- | Splits a list into components delimited by separators, where the
-- predicate returns True for a separator element.  The resulting
-- components do not contain the separators.  Two adjacent separators
-- result in an empty component in the output.  eg.
--
-- > split (=='a') "aabbaca"
-- > ["", "", "bb", "c", ""]
--
split :: (a -> Bool) -> [a] -> [[a]]
split p s = case rest of
                []     -> [chunk]
                _:rest -> chunk : split p rest
  where (chunk, rest) = break p s

-- | Like 'split', except that sequences of adjacent separators are
-- treated as a single separator. eg.
--
--   > tokens (=='a') "aabbaca"
--   > ["bb","c"]
tokens :: (a -> Bool) -> [a] -> [[a]]
tokens p = filter (not.null) . split p


buildTable ::  [String] -> [(String,[String])] -> String
buildTable ts rs = bt [ x:xs | (x,xs) <- ("",ts):rs ] where
    bt ts = unlines (map f ts) where
        f xs = concatInter " " [  es n s | s <- xs | n <- cw ]
        cw = [ maximum (map length xs) | xs <- transpose ts]
    es n s = replicate (n - length s) ' ' ++ s

-- | time task
doTime :: String -> IO a -> IO a
doTime str action = do
    start <- getCPUTime
    x <- action
    end <- getCPUTime
    putStrLn $ "Timing: " ++ str ++ " " ++ show ((end - start) `div` cpuTimePrecision)
    return x

getPrefix :: Monad m => String -> String -> m String
getPrefix a b = f a b where
    f [] ss = return ss
    f _  [] = fail "getPrefix: value too short"
    f (p:ps) (s:ss)
        | p == s = f ps ss
        | otherwise = fail $ "getPrefix: " ++ a ++ " " ++ b


{-# INLINE naturals #-}
naturals :: [Int]
naturals = [0..]