{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
--
-- Copyright (c) 2005, 2012   Stefan Wehr - http://www.stefanwehr.de
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
--

module Test.Framework.Utils where

import System.Directory
import Data.Char
import System.Time hiding (diffClockTimes)
import System.Random
import Data.Array.IO
import Control.Monad

infixr 6 </>

(</>) :: FilePath -> FilePath -> FilePath
[] </> :: FilePath -> FilePath -> FilePath
</> FilePath
b = FilePath
b
FilePath
a  </> FilePath
b = FilePath
a FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
b

basename :: FilePath -> FilePath
basename :: FilePath -> FilePath
basename FilePath
p = FilePath -> FilePath
forall a. [a] -> [a]
reverse (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
p

dirname :: FilePath -> FilePath
dirname :: FilePath -> FilePath
dirname FilePath
p  =
    case FilePath -> FilePath
forall a. [a] -> [a]
reverse (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
p of
        [] -> FilePath
"."
        FilePath
p' -> FilePath
p'

startswith :: String -> String -> Bool
startswith :: FilePath -> FilePath -> Bool
startswith FilePath
s FilePath
pref =
    let n :: Int
n = FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
pref
        in Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take Int
n FilePath
s FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
pref

endswith :: String -> String -> Bool
endswith :: FilePath -> FilePath -> Bool
endswith FilePath
s FilePath
suf =
    let n :: Int
n = FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
suf
        in Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
n FilePath
s FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
suf

dropPrefix :: String -> String -> String
dropPrefix :: FilePath -> FilePath -> FilePath
dropPrefix FilePath
s FilePath
pref =
    if FilePath -> FilePath -> Bool
startswith FilePath
s FilePath
pref
       then Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
pref) FilePath
s
       else FilePath
s

dropSuffix :: FilePath -> FilePath
dropSuffix :: FilePath -> FilePath
dropSuffix FilePath
f = FilePath -> FilePath
forall a. [a] -> [a]
reverse (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
forall a. [a] -> [a]
tail (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
f

replaceSuffix :: FilePath -> String -> FilePath
replaceSuffix :: FilePath -> FilePath -> FilePath
replaceSuffix FilePath
f FilePath
suf = FilePath -> FilePath
dropSuffix FilePath
f FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
suf

-- > dropSpace "   abc  " ===> "abc"
dropSpace :: [Char] -> [Char]
dropSpace :: FilePath -> FilePath
dropSpace = let f :: FilePath -> FilePath
f = FilePath -> FilePath
forall a. [a] -> [a]
reverse (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace in FilePath -> FilePath
f (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
f

data DirectoryEntryType = File | Directory | Other
                        deriving (DirectoryEntryType -> DirectoryEntryType -> Bool
(DirectoryEntryType -> DirectoryEntryType -> Bool)
-> (DirectoryEntryType -> DirectoryEntryType -> Bool)
-> Eq DirectoryEntryType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DirectoryEntryType -> DirectoryEntryType -> Bool
$c/= :: DirectoryEntryType -> DirectoryEntryType -> Bool
== :: DirectoryEntryType -> DirectoryEntryType -> Bool
$c== :: DirectoryEntryType -> DirectoryEntryType -> Bool
Eq, Int -> DirectoryEntryType -> FilePath -> FilePath
[DirectoryEntryType] -> FilePath -> FilePath
DirectoryEntryType -> FilePath
(Int -> DirectoryEntryType -> FilePath -> FilePath)
-> (DirectoryEntryType -> FilePath)
-> ([DirectoryEntryType] -> FilePath -> FilePath)
-> Show DirectoryEntryType
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [DirectoryEntryType] -> FilePath -> FilePath
$cshowList :: [DirectoryEntryType] -> FilePath -> FilePath
show :: DirectoryEntryType -> FilePath
$cshow :: DirectoryEntryType -> FilePath
showsPrec :: Int -> DirectoryEntryType -> FilePath -> FilePath
$cshowsPrec :: Int -> DirectoryEntryType -> FilePath -> FilePath
Show)

directoryEntryType :: FilePath -> IO DirectoryEntryType
directoryEntryType :: FilePath -> IO DirectoryEntryType
directoryEntryType FilePath
fp =
    do Bool
b <- FilePath -> IO Bool
doesFileExist FilePath
fp
       if Bool
b then DirectoryEntryType -> IO DirectoryEntryType
forall (m :: * -> *) a. Monad m => a -> m a
return DirectoryEntryType
File else do Bool
b <- FilePath -> IO Bool
doesDirectoryExist FilePath
fp
                                     DirectoryEntryType -> IO DirectoryEntryType
forall (m :: * -> *) a. Monad m => a -> m a
return (DirectoryEntryType -> IO DirectoryEntryType)
-> DirectoryEntryType -> IO DirectoryEntryType
forall a b. (a -> b) -> a -> b
$ if Bool
b then DirectoryEntryType
Directory else DirectoryEntryType
Other

collectFiles :: FilePath                -- the directory to start from
             -> String                  -- suffix of the file names to collect
             -> (FilePath -> [FilePath] -> IO Bool)
               -- predicate that determines
               -- whether files below a certain
               -- directory should be pruned.
               -- The first argument is the
               -- name of the directory, the
               -- second the entries of the
               -- directory
             -> IO [FilePath]
collectFiles :: FilePath
-> FilePath -> (FilePath -> [FilePath] -> IO Bool) -> IO [FilePath]
collectFiles FilePath
root FilePath
suf FilePath -> [FilePath] -> IO Bool
prune =
    do [FilePath]
entries <- FilePath -> IO [FilePath]
getDirectoryContents FilePath
root
       Bool
b <- FilePath -> [FilePath] -> IO Bool
prune FilePath
root [FilePath]
entries
       if Bool
b then [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []
          else do [[FilePath]]
all <- (FilePath -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath -> FilePath -> IO [FilePath]
collect FilePath
root) [FilePath]
entries
                  [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FilePath]]
all
    where collect :: FilePath -> FilePath -> IO [FilePath]
collect FilePath
root FilePath
f | FilePath
f FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"." Bool -> Bool -> Bool
|| FilePath
f FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".." = [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                         | Bool
otherwise =
              do DirectoryEntryType
t <- FilePath -> IO DirectoryEntryType
directoryEntryType (FilePath
root FilePath -> FilePath -> FilePath
</> FilePath
f)
                 case DirectoryEntryType
t of
                   DirectoryEntryType
Directory -> FilePath
-> FilePath -> (FilePath -> [FilePath] -> IO Bool) -> IO [FilePath]
collectFiles (FilePath
root FilePath -> FilePath -> FilePath
</> FilePath
f) FilePath
suf FilePath -> [FilePath] -> IO Bool
prune
                   DirectoryEntryType
File | FilePath
f FilePath -> FilePath -> Bool
`endswith` FilePath
suf -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath
root FilePath -> FilePath -> FilePath
</> FilePath
f]
                   DirectoryEntryType
_ -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []

maybeFile :: FilePath -> IO (Maybe FilePath)
maybeFile :: FilePath -> IO (Maybe FilePath)
maybeFile FilePath
f =
    do Bool
b <- FilePath -> IO Bool
doesFileExist FilePath
f
       Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ if Bool
b then FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
f else Maybe FilePath
forall a. Maybe a
Nothing

-- monadic version of mapAccumL
mapAccumLM :: Monad m
           => (acc -> x -> m (acc, y)) -- Function of elt of input list
                                       -- and accumulator, returning new
                                       -- accumulator and elt of result list
          -> acc            -- Initial accumulator
          -> [x]            -- Input list
          -> m (acc, [y])   -- Final accumulator and result list
mapAccumLM :: (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM acc -> x -> m (acc, y)
_ acc
s []        = (acc, [y]) -> m (acc, [y])
forall (m :: * -> *) a. Monad m => a -> m a
return (acc
s, [])
mapAccumLM acc -> x -> m (acc, y)
f acc
s (x
x:[x]
xs)    = do (acc
s', y
y ) <- acc -> x -> m (acc, y)
f acc
s x
x
                              (acc
s'',[y]
ys) <- (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM acc -> x -> m (acc, y)
f acc
s' [x]
xs
                              (acc, [y]) -> m (acc, [y])
forall (m :: * -> *) a. Monad m => a -> m a
return (acc
s'',y
yy -> [y] -> [y]
forall a. a -> [a] -> [a]
:[y]
ys)

#if !(MIN_VERSION_base(4,13,0))
readM :: (Monad m, Read a) => String -> m a
#else
readM :: (MonadFail m, Read a) => String -> m a
#endif
readM :: FilePath -> m a
readM FilePath
s | [a
x] <- [a]
parse = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
        | Bool
otherwise    = FilePath -> m a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> m a) -> FilePath -> m a
forall a b. (a -> b) -> a -> b
$ FilePath
"Failed parse: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
s
    where
      parse :: [a]
parse = [a
x | (a
x, []) <- ReadS a
forall a. Read a => ReadS a
reads FilePath
s]

ensureNewline :: String -> String
ensureNewline :: FilePath -> FilePath
ensureNewline FilePath
s =
    FilePath
s FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ case (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') (FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
s) of
           Char
'\n':FilePath
_ -> FilePath
""
           FilePath
_ | FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
s -> FilePath
""
             | Bool
otherwise -> FilePath
"\n"

strip :: String -> String
strip :: FilePath -> FilePath
strip = FilePath -> FilePath
forall a. [a] -> [a]
reverse (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
forall a. [a] -> [a]
reverse (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace

-- Measures execution time of the given IO action in milliseconds
measure :: IO a -> IO (a, Int)
measure :: IO a -> IO (a, Int)
measure IO a
ma =
    do ClockTime
t0 <- IO ClockTime
getClockTime
       a
a <- IO a
ma
       ClockTime
t1 <- a
a a -> IO ClockTime -> IO ClockTime
`seq` IO ClockTime
getClockTime
       let diffMicro :: Integer
diffMicro = ClockTime
t1 ClockTime -> ClockTime -> Integer
`diffClockTimes` ClockTime
t0
       (a, Int) -> IO (a, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer
diffMicro Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
1000))

diffClockTimes :: ClockTime -> ClockTime -> Integer
diffClockTimes :: ClockTime -> ClockTime -> Integer
diffClockTimes (TOD Integer
s1 Integer
p1) (TOD Integer
s0 Integer
p0) =
    (Integer -> Integer
forall a. Integral a => a -> a
picoseconds Integer
p1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Integer
forall a. Num a => a -> a
seconds Integer
s1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-
    (Integer -> Integer
forall a. Integral a => a -> a
picoseconds Integer
p0 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Integer
forall a. Num a => a -> a
seconds Integer
s0)
    where
      -- bring all into microseconds
      picoseconds :: a -> a
picoseconds a
i = a
i a -> a -> a
forall a. Integral a => a -> a -> a
`div` (a
1000 a -> a -> a
forall a. Num a => a -> a -> a
* a
1000)
      seconds :: a -> a
seconds a
i = a
i a -> a -> a
forall a. Num a => a -> a -> a
* a
1000000

-- | Randomly shuffle a list
--   /O(N)/
shuffleIO :: [a] -> IO [a]
shuffleIO :: [a] -> IO [a]
shuffleIO [a]
xs = do
        IOArray Int a
ar <- Int -> [a] -> IO (IOArray Int a)
forall a. Int -> [a] -> IO (IOArray Int a)
newArray Int
n [a]
xs
        [Int] -> (Int -> IO a) -> IO [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
1..Int
n] ((Int -> IO a) -> IO [a]) -> (Int -> IO a) -> IO [a]
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
            Int
j <- (Int, Int) -> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
i,Int
n)
            a
vi <- IOArray Int a -> Int -> IO a
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOArray Int a
ar Int
i
            a
vj <- IOArray Int a -> Int -> IO a
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOArray Int a
ar Int
j
            IOArray Int a -> Int -> a -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOArray Int a
ar Int
j a
vi
            a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
vj
  where
    n :: Int
n = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
    newArray :: Int -> [a] -> IO (IOArray Int a)
    newArray :: Int -> [a] -> IO (IOArray Int a)
newArray Int
n [a]
xs =  (Int, Int) -> [a] -> IO (IOArray Int a)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> [e] -> m (a i e)
newListArray (Int
1,Int
n) [a]
xs