-- |
-- Module      : Test.FitSpec.Utils
-- Copyright   : (c) 2015-2017 Rudy Matela
-- License     : 3-Clause BSD  (see the file LICENSE)
-- Maintainer  : Rudy Matela <rudy@matela.com.br>
--
-- General purpose utility functions for FitSpec
{-# 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)

-- | Compose composed with compose operator.
--
-- > (f ... g) x y === f (g x y)
(...) :: (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
(.)
-- f ... g = \x y -> f (g x y)

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' @bs@ returns all compositions formed by taking values of @bs@
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' @xs@ returns the list of sublists formed by taking values of @xs@
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

-- TODO: rename contained and contains to subset and superset?

-- | Check if all elements of a list is contained in another list
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' filter greater-later elements in a list according to a partial
--   ordering relation.
--
-- > filterU (notContained) [[1],[2],[1,2,3],[3,4,5]] == [[1],[2],[3,4,5]]
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 (,))

-- | Takes values from a list while the values increase.  If the original list
--   is non-empty, the returning list will also be non-empty
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 -- 100ms
      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 s xs@ will take the last value of @xs@ it is able evaluate
--   before @s@ seconds elapse.
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  -- no time to lose
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) -- TODO: change to waitForThread!!!
  (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)