{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
--
-- Copyright (c) 2005-2022   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
[] </> :: [Char] -> [Char] -> [Char]
</> [Char]
b = [Char]
b
[Char]
a  </> [Char]
b = [Char]
a [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
b

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

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

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

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

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

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

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

-- > dropSpace "   abc  " ===> "abc"
dropSpace :: [Char] -> [Char]
dropSpace :: [Char] -> [Char]
dropSpace = let f :: [Char] -> [Char]
f = [Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace in [Char] -> [Char]
f ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
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
$c== :: DirectoryEntryType -> DirectoryEntryType -> Bool
== :: DirectoryEntryType -> DirectoryEntryType -> Bool
$c/= :: DirectoryEntryType -> DirectoryEntryType -> Bool
/= :: DirectoryEntryType -> DirectoryEntryType -> Bool
Eq, Int -> DirectoryEntryType -> [Char] -> [Char]
[DirectoryEntryType] -> [Char] -> [Char]
DirectoryEntryType -> [Char]
(Int -> DirectoryEntryType -> [Char] -> [Char])
-> (DirectoryEntryType -> [Char])
-> ([DirectoryEntryType] -> [Char] -> [Char])
-> Show DirectoryEntryType
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> DirectoryEntryType -> [Char] -> [Char]
showsPrec :: Int -> DirectoryEntryType -> [Char] -> [Char]
$cshow :: DirectoryEntryType -> [Char]
show :: DirectoryEntryType -> [Char]
$cshowList :: [DirectoryEntryType] -> [Char] -> [Char]
showList :: [DirectoryEntryType] -> [Char] -> [Char]
Show)

directoryEntryType :: FilePath -> IO DirectoryEntryType
directoryEntryType :: [Char] -> IO DirectoryEntryType
directoryEntryType [Char]
fp =
    do Bool
b <- [Char] -> IO Bool
doesFileExist [Char]
fp
       if Bool
b then DirectoryEntryType -> IO DirectoryEntryType
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return DirectoryEntryType
File else do Bool
b <- [Char] -> IO Bool
doesDirectoryExist [Char]
fp
                                     DirectoryEntryType -> IO DirectoryEntryType
forall a. a -> IO a
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 :: [Char] -> [Char] -> ([Char] -> [[Char]] -> IO Bool) -> IO [[Char]]
collectFiles [Char]
root [Char]
suf [Char] -> [[Char]] -> IO Bool
prune =
    do [[Char]]
entries <- [Char] -> IO [[Char]]
getDirectoryContents [Char]
root
       Bool
b <- [Char] -> [[Char]] -> IO Bool
prune [Char]
root [[Char]]
entries
       if Bool
b then [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
          else do [[[Char]]]
all <- ([Char] -> IO [[Char]]) -> [[Char]] -> IO [[[Char]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([Char] -> [Char] -> IO [[Char]]
collect [Char]
root) [[Char]]
entries
                  [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Char]] -> IO [[Char]]) -> [[Char]] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[Char]]]
all
    where collect :: [Char] -> [Char] -> IO [[Char]]
collect [Char]
root [Char]
f | [Char]
f [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"." Bool -> Bool -> Bool
|| [Char]
f [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
".." = [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
                         | Bool
otherwise =
              do DirectoryEntryType
t <- [Char] -> IO DirectoryEntryType
directoryEntryType ([Char]
root [Char] -> [Char] -> [Char]
</> [Char]
f)
                 case DirectoryEntryType
t of
                   DirectoryEntryType
Directory -> [Char] -> [Char] -> ([Char] -> [[Char]] -> IO Bool) -> IO [[Char]]
collectFiles ([Char]
root [Char] -> [Char] -> [Char]
</> [Char]
f) [Char]
suf [Char] -> [[Char]] -> IO Bool
prune
                   DirectoryEntryType
File | [Char]
f [Char] -> [Char] -> Bool
`endswith` [Char]
suf -> [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [[Char]
root [Char] -> [Char] -> [Char]
</> [Char]
f]
                   DirectoryEntryType
_ -> [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []

maybeFile :: FilePath -> IO (Maybe FilePath)
maybeFile :: [Char] -> IO (Maybe [Char])
maybeFile [Char]
f =
    do Bool
b <- [Char] -> IO Bool
doesFileExist [Char]
f
       Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> IO (Maybe [Char]))
-> Maybe [Char] -> IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ if Bool
b then [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
f else Maybe [Char]
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 :: forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM acc -> x -> m (acc, y)
_ acc
s []        = (acc, [y]) -> m (acc, [y])
forall a. a -> m a
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 a. a -> m a
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 :: forall (m :: * -> *) a. (MonadFail m, Read a) => [Char] -> m a
readM [Char]
s | [a
x] <- [a]
parse = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
        | Bool
otherwise    = [Char] -> m a
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> m a) -> [Char] -> m a
forall a b. (a -> b) -> a -> b
$ [Char]
"Failed parse: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
s
    where
      parse :: [a]
parse = [a
x | (a
x, []) <- ReadS a
forall a. Read a => ReadS a
reads [Char]
s]

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

strip :: String -> String
strip :: [Char] -> [Char]
strip = [Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
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 :: forall a. 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
forall a b. a -> b -> b
`seq` IO ClockTime
getClockTime
       let diffMicro :: Integer
diffMicro = ClockTime
t1 ClockTime -> ClockTime -> Integer
`diffClockTimes` ClockTime
t0
       (a, Int) -> IO (a, Int)
forall a. a -> IO a
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 :: forall a. [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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
vj
  where
    n :: Int
n = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
    newArray :: Int -> [a] -> IO (IOArray Int a)
    newArray :: forall a. 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