{-# LANGUAGE CPP #-}
module Test.FitSpec.Utils
( (...)
, uncurry3
, count
, compositions
, subsets
, contained
, contains
, filterU
, sortAndGroupOn
, sortAndGroupFstBySnd
, sortGroupAndCollapse
, takeWhileIncreasing
, takeWhileIncreasingOn
, lastTimeout
, sortOn
, (***)
)
where
#if __GLASGOW_HASKELL__ <= 704
import Prelude hiding (catch)
#endif
import System.IO.Unsafe (unsafePerformIO)
import Control.Exception ( Exception
, SomeException
, ArithException
, ArrayException
, ErrorCall
, PatternMatchFail
, catch
, catches
, Handler (Handler)
, evaluate
)
import Data.Function (on)
import Data.Ord (comparing)
import Data.List (groupBy,sortBy)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Control.Concurrent (forkIO, threadDelay, killThread)
import Control.Monad (liftM)
(...) :: (c->d) -> (a->b->c) -> a -> b -> d
... :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(...) = ((b -> c) -> b -> d) -> (a -> b -> c) -> a -> b -> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (((b -> c) -> b -> d) -> (a -> b -> c) -> a -> b -> d)
-> ((c -> d) -> (b -> c) -> b -> d)
-> (c -> d)
-> (a -> b -> c)
-> a
-> b
-> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c -> d) -> (b -> c) -> b -> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)
uncurry3 :: (a->b->c->d) -> (a,b,c) -> d
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 a -> b -> c -> d
f (a
x,b
y,c
z) = a -> b -> c -> d
f a
x b
y c
z
count :: (a -> Bool) -> [a] -> Int
count :: (a -> Bool) -> [a] -> Int
count a -> Bool
p = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> Int) -> ([a] -> [a]) -> [a] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter a -> Bool
p
compositions :: [Bool] -> [Bool]
compositions :: [Bool] -> [Bool]
compositions = ([Bool] -> Bool) -> [[Bool]] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([[Bool]] -> [Bool]) -> ([Bool] -> [[Bool]]) -> [Bool] -> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> [[Bool]]
forall a. [a] -> [[a]]
subsets
subsets :: [a] -> [[a]]
subsets :: [a] -> [[a]]
subsets [] = [[]]
subsets (a
x:[a]
xs) = ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [[a]]
forall a. [a] -> [[a]]
subsets [a]
xs) [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ [a] -> [[a]]
forall a. [a] -> [[a]]
subsets [a]
xs
contained :: Eq a => [a] -> [a] -> Bool
[a]
xs contained :: [a] -> [a] -> Bool
`contained` [a]
ys = (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
ys) [a]
xs
contains :: Eq a => [a] -> [a] -> Bool
contains :: [a] -> [a] -> Bool
contains = ([a] -> [a] -> Bool) -> [a] -> [a] -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
contained
filterU :: (a -> a -> Bool) -> [a] -> [a]
filterU :: (a -> a -> Bool) -> [a] -> [a]
filterU a -> a -> Bool
f [] = []
filterU a -> a -> Bool
f (a
x:[a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> a -> Bool
f a
x) ((a -> a -> Bool) -> [a] -> [a]
forall a. (a -> a -> Bool) -> [a] -> [a]
filterU a -> a -> Bool
f [a]
xs)
sortOn :: Ord b => (a -> b) -> [a] -> [a]
sortOn :: (a -> b) -> [a] -> [a]
sortOn a -> b
f = (a -> a -> Ordering) -> [a] -> [a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (b -> b -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (b -> b -> Ordering) -> (a -> b) -> a -> a -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` a -> b
f)
sortAndGroupOn :: Ord b => (a -> b) -> [a] -> [[a]]
sortAndGroupOn :: (a -> b) -> [a] -> [[a]]
sortAndGroupOn a -> b
f = (a -> a -> Bool) -> [a] -> [[a]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (b -> b -> Bool
forall a. Eq a => a -> a -> Bool
(==) (b -> b -> Bool) -> (a -> b) -> a -> a -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` a -> b
f)
([a] -> [[a]]) -> ([a] -> [a]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> [a] -> [a]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn a -> b
f
sortGroupAndCollapse :: Ord b
=> (a -> b) -> (a -> c) -> (b -> [c] -> d)
-> [a] -> [d]
sortGroupAndCollapse :: (a -> b) -> (a -> c) -> (b -> [c] -> d) -> [a] -> [d]
sortGroupAndCollapse a -> b
f a -> c
g b -> [c] -> d
h = ([a] -> d) -> [[a]] -> [d]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> d
collapse
([[a]] -> [d]) -> ([a] -> [[a]]) -> [a] -> [d]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> [a] -> [[a]]
forall b a. Ord b => (a -> b) -> [a] -> [[a]]
sortAndGroupOn a -> b
f
where collapse :: [a] -> d
collapse (a
x:[a]
xs) = a -> b
f a
x b -> [c] -> d
`h` (a -> c) -> [a] -> [c]
forall a b. (a -> b) -> [a] -> [b]
map a -> c
g (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)
sortAndGroupFstBySnd :: Ord b => [(a,b)] -> [([a],b)]
sortAndGroupFstBySnd :: [(a, b)] -> [([a], b)]
sortAndGroupFstBySnd = ((a, b) -> b)
-> ((a, b) -> a)
-> (b -> [a] -> ([a], b))
-> [(a, b)]
-> [([a], b)]
forall b a c d.
Ord b =>
(a -> b) -> (a -> c) -> (b -> [c] -> d) -> [a] -> [d]
sortGroupAndCollapse (a, b) -> b
forall a b. (a, b) -> b
snd (a, b) -> a
forall a b. (a, b) -> a
fst (([a] -> b -> ([a], b)) -> b -> [a] -> ([a], b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,))
takeWhileIncreasing :: (a -> a -> Ordering) -> [a] -> [a]
takeWhileIncreasing :: (a -> a -> Ordering) -> [a] -> [a]
takeWhileIncreasing a -> a -> Ordering
_ [] = []
takeWhileIncreasing a -> a -> Ordering
_ [a
x] = [a
x]
takeWhileIncreasing a -> a -> Ordering
cmp (a
x:a
y:[a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: case a
x a -> a -> Ordering
`cmp` a
y of
Ordering
LT -> (a -> a -> Ordering) -> [a] -> [a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
takeWhileIncreasing a -> a -> Ordering
cmp (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)
Ordering
_ -> []
takeWhileIncreasingOn :: Ord b => (a -> b) -> [a] -> [a]
takeWhileIncreasingOn :: (a -> b) -> [a] -> [a]
takeWhileIncreasingOn a -> b
f = (a -> a -> Ordering) -> [a] -> [a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
takeWhileIncreasing (b -> b -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (b -> b -> Ordering) -> (a -> b) -> a -> a -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` a -> b
f)
readIORefUntil :: (a -> Bool) -> IORef a -> IO a
readIORefUntil :: (a -> Bool) -> IORef a -> IO a
readIORefUntil a -> Bool
p IORef a
r = do
a
x <- IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
r
if a -> Bool
p a
x
then a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
else Int -> IO ()
threadDelay Int
100000
IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (a -> Bool) -> IORef a -> IO a
forall a. (a -> Bool) -> IORef a -> IO a
readIORefUntil a -> Bool
p IORef a
r
lastTimeout :: Int -> [a] -> IO a
lastTimeout :: Int -> [a] -> IO a
lastTimeout Int
_ [] = [Char] -> IO a
forall a. HasCallStack => [Char] -> a
error [Char]
"lastTimeout: empty list"
lastTimeout Int
0 (a
x:[a]
_) = a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
lastTimeout Int
s [a]
xs = do
IORef (a, Bool)
r <- (a, Bool) -> IO (IORef (a, Bool))
forall a. a -> IO (IORef a)
newIORef (a
forall a. HasCallStack => a
undefined,Bool
False)
ThreadId
tid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IORef (a, Bool) -> [a] -> IO ()
forall a. IORef (a, Bool) -> [a] -> IO ()
keepImproving IORef (a, Bool)
r [a]
xs
Int -> IO ()
threadDelay (Int
sInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1000000)
(a
x,Bool
_) <- ((a, Bool) -> Bool) -> IORef (a, Bool) -> IO (a, Bool)
forall a. (a -> Bool) -> IORef a -> IO a
readIORefUntil (a, Bool) -> Bool
forall a b. (a, b) -> b
snd IORef (a, Bool)
r
ThreadId -> IO ()
killThread ThreadId
tid
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
where keepImproving :: IORef (a, Bool) -> [a] -> IO ()
keepImproving IORef (a, Bool)
_ [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
keepImproving IORef (a, Bool)
r (a
x:[a]
xs) = do
a -> IO a
forall a. a -> IO a
evaluate a
x
IORef (a, Bool) -> (a, Bool) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (a, Bool)
r (a
x,Bool
True)
IORef (a, Bool) -> [a] -> IO ()
keepImproving IORef (a, Bool)
r [a]
xs
(***) :: (a -> b) -> (c -> d) -> (a,c) -> (b,d)
a -> b
f *** :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
*** c -> d
g = \(a
x,c
y) -> (a -> b
f a
x, c -> d
g c
y)