-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns, DisambiguateRecordFields #-}
-- | Basic testing utilities.
module Util.Test.Testing (
    Test, Profile
    , Config(..), modify_test_config, with_test_name
    -- * metadata
    , ModuleMeta(..), moduleMeta, Tag(..)
    -- * assertions
    , check, check_val
    , equal, equal_fmt, equal_on, right_equal, not_equal, equalf, strings_like
    , left_like, match
    , Pattern
    -- ** exception assertions
    , throws

    -- ** io assertions
    , io_equal, io_human, pause

    -- ** low level
    , success, failure

    -- * extracting
    , expect_right

    -- * hedgehog
    , hedgehog
    , property
    , (===), (/==)

    -- * QuickCheck
    , quickcheck
    , q_equal

    -- * pretty printing
    , pretty_compare
    , prettyp, pprint

    -- * filesystem
    , tmp_dir, in_tmp_dir, tmp_base_dir

    -- * util
    , force
) where
import qualified Control.DeepSeq as DeepSeq
import qualified Control.Exception as Exception
import           Control.Monad (unless)

import qualified Data.Algorithm.Diff as Diff
import qualified Data.IORef as IORef
import qualified Data.IntMap as IntMap
import qualified Data.Set as Set
import qualified Data.Text as Text
import           Data.Text (Text)
import qualified Data.Text.IO as Text.IO

import qualified GHC.Stack as Stack
import           GHC.Stack (HasCallStack)
import qualified Hedgehog
import           Hedgehog (property, (/==), (===))
import qualified Hedgehog.Internal.Config as Internal.Config
import qualified Hedgehog.Internal.Property as Internal.Property
import qualified Hedgehog.Internal.Report as Report
import qualified Hedgehog.Internal.Runner as Internal.Runner
import qualified Hedgehog.Internal.Seed as Internal.Seed

import qualified System.Directory as Directory
import           System.FilePath ((</>))
import qualified System.IO as IO
import qualified System.IO.Unsafe as Unsafe
import qualified System.Posix.IO as IO
import qualified System.Posix.Temp as Temp
import qualified System.Posix.Terminal as Terminal

import qualified Test.QuickCheck as QuickCheck

import qualified Util.Diffs as Diffs
import qualified Util.Lists as Lists
import qualified Util.PPrint as PPrint
import qualified Util.Pretty as Pretty
import qualified Util.Regex as Regex
import qualified Util.Strings as Strings
import qualified Util.Test.ApproxEq as ApproxEq


-- | The type of toplevel tests, which is the same as the type of individual
-- test functions.  It's just IO () for now, but some day I may be able to move
-- to something more specialized, so if tests have declared types it might as
-- well be one I can change in one place.
type Test = IO ()

-- | Profiles are just like tests, but I'll use a different type just for
-- documentation at least.  The real determination is that profiles start with
-- "profile_" instead of "test_".
type Profile = IO ()

{-# NOINLINE test_config #-}
test_config :: IORef.IORef Config
test_config :: IORef Config
test_config = forall a. IO a -> a
Unsafe.unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
IORef.newIORef forall a b. (a -> b) -> a -> b
$ Config
    { config_test_name :: Text
config_test_name = Text
"no-test"
    , config_human_agreeable :: Bool
config_human_agreeable = Bool
True
    }

modify_test_config :: (Config -> Config) -> IO ()
modify_test_config :: (Config -> Config) -> IO ()
modify_test_config = forall a. IORef a -> (a -> a) -> IO ()
IORef.modifyIORef IORef Config
test_config

-- | Set 'config_test_name'.  This is a grody hack, but I need it because GHC
-- call stack is off by one, so you get the caller line number, but the
-- callee's function name: https://ghc.haskell.org/trac/ghc/ticket/11686
with_test_name :: Text -> IO a -> IO a
with_test_name :: forall a. Text -> IO a -> IO a
with_test_name Text
name IO a
action = do
    (Config -> Config) -> IO ()
modify_test_config (\Config
config -> Config
config { config_test_name :: Text
config_test_name = Text
name })
    IO a
action

data Config = Config {
    -- | Keep the test name so I can report it in 'success' in 'failure'.
    Config -> Text
config_test_name :: !Text
    -- | If True, 'io_human' will always return True.  That way I can at least
    -- get the coverage and check for crashes, even if I can't verify the
    -- results.
    , Config -> Bool
config_human_agreeable :: !Bool
    } deriving (Int -> Config -> ShowS
[Config] -> ShowS
Config -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> [Char]
$cshow :: Config -> [Char]
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show)

check :: HasCallStack => Text -> Bool -> Test
check :: HasCallStack => Text -> Bool -> IO ()
check Text
msg Bool
False = HasCallStack => Text -> IO ()
failure (Text
"failed: " forall a. Semigroup a => a -> a -> a
<> Text
msg)
check Text
msg Bool
True = HasCallStack => Text -> IO ()
success Text
msg

-- | Check against a function.  Use like:
--
-- > check_val (f x) $ \case -> ...
check_val :: (Show a, HasCallStack) => a -> (a -> Bool) -> Test
check_val :: forall a. (Show a, HasCallStack) => a -> (a -> Bool) -> IO ()
check_val a
val a -> Bool
f
    | a -> Bool
f a
val = HasCallStack => Text -> IO ()
success forall a b. (a -> b) -> a -> b
$ Text
"ok: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
pshowt a
val
    | Bool
otherwise = HasCallStack => Text -> IO ()
failure forall a b. (a -> b) -> a -> b
$ Text
"failed: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
pshowt a
val

-- * metadata

data ModuleMeta = ModuleMeta {
    -- | Wrap each test with IO level setup and teardown.  Sync exceptions are
    -- caught from the test function, so this should only see async exceptions.
    ModuleMeta -> IO () -> IO ()
initialize :: IO () -> IO ()
    , ModuleMeta -> [Tag]
tags :: [Tag]
    }

moduleMeta :: ModuleMeta
moduleMeta :: ModuleMeta
moduleMeta = ModuleMeta
    { initialize :: IO () -> IO ()
initialize = forall a. a -> a
id
    , tags :: [Tag]
tags = []
    }

data Tag =
    -- | Especially expensive to run.
    Large
    -- | Wants to have a conversation.  This implies the tests must be
    -- serialized, since who wants to have a conversation in parallel.
    -- 'io_human' is one way to do this.
    | Interactive
    deriving (Tag -> Tag -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tag -> Tag -> Bool
$c/= :: Tag -> Tag -> Bool
== :: Tag -> Tag -> Bool
$c== :: Tag -> Tag -> Bool
Eq, Int -> Tag -> ShowS
[Tag] -> ShowS
Tag -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Tag] -> ShowS
$cshowList :: [Tag] -> ShowS
show :: Tag -> [Char]
$cshow :: Tag -> [Char]
showsPrec :: Int -> Tag -> ShowS
$cshowsPrec :: Int -> Tag -> ShowS
Show)

-- * equal and diff

equal :: (HasCallStack, Show a, Eq a) => a -> a -> Test
equal :: forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
equal a
a a
b = forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO Bool
equal_ a
a a
b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()

equal_ :: (HasCallStack, Show a, Eq a) => a -> a -> IO Bool
equal_ :: forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO Bool
equal_ a
a a
b
    | a
a forall a. Eq a => a -> a -> Bool
== a
b = HasCallStack => Text -> IO ()
success (Bool -> Text
cmp Bool
True) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    | Bool
otherwise = HasCallStack => Text -> IO ()
failure (Bool -> Text
cmp Bool
False) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    where cmp :: Bool -> Text
cmp = forall a. Show a => Text -> Text -> Bool -> a -> a -> Bool -> Text
pretty_compare Text
"==" Text
"/=" Bool
True a
a a
b

not_equal :: (HasCallStack, Show a, Eq a) => a -> a -> Test
not_equal :: forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
not_equal a
a a
b
    | a
a forall a. Eq a => a -> a -> Bool
== a
b = HasCallStack => Text -> IO ()
failure forall a b. (a -> b) -> a -> b
$ Bool -> Text
cmp Bool
True
    | Bool
otherwise = HasCallStack => Text -> IO ()
success forall a b. (a -> b) -> a -> b
$ Bool -> Text
cmp Bool
False
    where cmp :: Bool -> Text
cmp = forall a. Show a => Text -> Text -> Bool -> a -> a -> Bool -> Text
pretty_compare Text
"==" Text
"/=" Bool
False a
a a
b

equal_fmt :: (HasCallStack, Eq a, Show a) => (a -> Text) -> a -> a -> Test
equal_fmt :: forall a.
(HasCallStack, Eq a, Show a) =>
(a -> Text) -> a -> a -> IO ()
equal_fmt a -> Text
fmt a
a a
b = do
    Bool
ok <- forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO Bool
equal_ a
a a
b
    let (Text
pa, Text
pb) = (a -> Text
fmt a
a, a -> Text
fmt a
b)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
ok Bool -> Bool -> Bool
|| Text -> Bool
Text.null Text
pa Bool -> Bool -> Bool
&& Text -> Bool
Text.null Text
pb) forall a b. (a -> b) -> a -> b
$
        Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
show_diff Text
pa Text
pb
    where
    show_diff :: Text -> Text -> Text
show_diff Text
pretty_a Text
pretty_b = Text -> [Text] -> [Text] -> Text
fmt_lines Text
"/="
        (ColorCode -> IntMap [CharRange] -> [Text] -> [Text]
highlight_lines ColorCode
color IntMap [CharRange]
diff_a forall a b. (a -> b) -> a -> b
$ Text -> [Text]
Text.lines Text
pretty_a)
        (ColorCode -> IntMap [CharRange] -> [Text] -> [Text]
highlight_lines ColorCode
color IntMap [CharRange]
diff_b forall a b. (a -> b) -> a -> b
$ Text -> [Text]
Text.lines Text
pretty_b)
        where
        color :: ColorCode
color = ColorCode
failure_color
        (IntMap [CharRange]
diff_a, IntMap [CharRange]
diff_b) = Text -> Text -> (IntMap [CharRange], IntMap [CharRange])
Diffs.ranges Text
pretty_a Text
pretty_b

-- | Assert these things are equal after applying a function.  Print without
-- the function if they're not equal.  This is for cases when the extract
-- function loses information it would be nice to see if the test fails.
equal_on :: (HasCallStack, Eq b, Show a, Show b) => (a -> b) -> a -> b -> Test
equal_on :: forall b a.
(HasCallStack, Eq b, Show a, Show b) =>
(a -> b) -> a -> b -> IO ()
equal_on a -> b
f a
a b
b = do
    Bool
ok <- forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO Bool
equal_ (a -> b
f a
a) b
b
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Text.IO.putStrLn (forall a. Show a => a -> Text
pshowt a
a)

right_equal :: (HasCallStack, Show err, Show a, Eq a) => Either err a -> a
    -> Test
right_equal :: forall err a.
(HasCallStack, Show err, Show a, Eq a) =>
Either err a -> a -> IO ()
right_equal (Right a
a) a
b = forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
equal a
a a
b
right_equal (Left err
err) a
_ = HasCallStack => Text -> IO ()
failure forall a b. (a -> b) -> a -> b
$ Text
"Left: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
pshowt err
err

-- | Show the values nicely, whether they are equal or not.
pretty_compare :: Show a =>
    Text -- ^ equal operator
    -> Text -- ^ inequal operator
    -> Bool -- ^ If True then equal is expected so inequal will be highlighted
    -- red.  Otherwise, inequal is expected and highlighted green.
    -> a -> a -> Bool -- ^ True if as are equal
    -> Text
pretty_compare :: forall a. Show a => Text -> Text -> Bool -> a -> a -> Bool -> Text
pretty_compare Text
equal Text
inequal Bool
expect_equal a
a a
b Bool
is_equal
    | Bool
is_equal Bool -> Bool -> Bool
&& Bool
expect_equal = Text
equal forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text -> Text
ellipse (forall a. Show a => a -> Text
showt a
a)
    | Bool
otherwise = Text -> [Text] -> [Text] -> Text
fmt_lines Text
inequal
        (ColorCode -> IntMap [CharRange] -> [Text] -> [Text]
highlight_lines ColorCode
color IntMap [CharRange]
diff_a forall a b. (a -> b) -> a -> b
$ Text -> [Text]
Text.lines Text
pretty_a)
        (ColorCode -> IntMap [CharRange] -> [Text] -> [Text]
highlight_lines ColorCode
color IntMap [CharRange]
diff_b forall a b. (a -> b) -> a -> b
$ Text -> [Text]
Text.lines Text
pretty_b)
    where
    color :: ColorCode
color = if Bool
expect_equal then ColorCode
failure_color else ColorCode
success_color
    (IntMap [CharRange]
diff_a, IntMap [CharRange]
diff_b) = Text -> Text -> (IntMap [CharRange], IntMap [CharRange])
Diffs.ranges Text
pretty_a Text
pretty_b
    pretty_a :: Text
pretty_a = forall a. Show a => a -> Text
pshowt a
a
    pretty_b :: Text
pretty_b = forall a. Show a => a -> Text
pshowt a
b
    -- Expected results are usually not interesting, so abbreviate if they're
    -- too long.
    ellipse :: Text -> Text
ellipse Text
s
        | Int
len forall a. Ord a => a -> a -> Bool
> Int
maxlen = Int -> Text -> Text
Text.take Int
maxlen Text
s forall a. Semigroup a => a -> a -> a
<> Text
"... {" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
len forall a. Semigroup a => a -> a -> a
<> Text
"}"
        | Bool
otherwise = Text
s
        where len :: Int
len = Text -> Int
Text.length Text
s
    maxlen :: Int
maxlen = Int
400

highlight_lines :: ColorCode -> IntMap.IntMap [Diffs.CharRange] -> [Text]
    -> [Text]
highlight_lines :: ColorCode -> IntMap [CharRange] -> [Text] -> [Text]
highlight_lines (ColorCode Text
color) =
    ColorCode -> IntMap [CharRange] -> [Text] -> [Text]
Diffs.highlightLines (Text -> ColorCode
Diffs.ColorCode Text
color)

-- * approximately equal

equalf :: (HasCallStack, Show a, ApproxEq.ApproxEq a) => Double -> a -> a
    -> Test
equalf :: forall a.
(HasCallStack, Show a, ApproxEq a) =>
Double -> a -> a -> IO ()
equalf Double
eta a
a a
b
    | forall a. ApproxEq a => Double -> a -> a -> Bool
ApproxEq.eq Double
eta a
a a
b = HasCallStack => Text -> IO ()
success forall a b. (a -> b) -> a -> b
$ Bool -> Text
pretty Bool
True
    | Bool
otherwise = HasCallStack => Text -> IO ()
failure forall a b. (a -> b) -> a -> b
$ Bool -> Text
pretty Bool
False
    where pretty :: Bool -> Text
pretty = forall a. Show a => Text -> Text -> Bool -> a -> a -> Bool -> Text
pretty_compare Text
"~~" Text
"/~" Bool
True a
a a
b

-- * other assertions

class Show a => TextLike a where to_text :: a -> Text
instance TextLike String where to_text :: [Char] -> Text
to_text = [Char] -> Text
Text.pack
instance TextLike Text where to_text :: Text -> Text
to_text = forall a. a -> a
id

-- | Strings in the first list match patterns in the second list, using
-- 'pattern_matches'.
strings_like :: forall txt. (HasCallStack, TextLike txt) => [txt] -> [Pattern]
    -> Test
strings_like :: forall txt.
(HasCallStack, TextLike txt) =>
[txt] -> [Text] -> IO ()
strings_like [txt]
gotten_ [Text]
expected
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall {a} {b}. PolyDiff a b -> Bool
is_both [Diff (Numbered Text)]
diffs = HasCallStack => Text -> IO ()
success forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> [Text] -> Text
fmt_lines Text
"=~" [Text]
gotten [Text]
expected
    | Bool
otherwise = HasCallStack => Text -> IO ()
failure forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> [Text] -> Text
fmt_lines Text
"/~"
        (forall a b. (a -> b) -> [a] -> [b]
map (forall {a}. Ord a => Set a -> (a, Text) -> Text
fmt_line
                (forall a. Ord a => [a] -> Set a
Set.fromList [forall a. Numbered a -> Int
Diffs.numbered Numbered Text
a | Diff.Second Numbered Text
a <- [Diff (Numbered Text)]
diffs]))
            (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Text]
gotten))
        (forall a b. (a -> b) -> [a] -> [b]
map (forall {a}. Ord a => Set a -> (a, Text) -> Text
fmt_line
                (forall a. Ord a => [a] -> Set a
Set.fromList [forall a. Numbered a -> Int
Diffs.numbered Numbered Text
a | Diff.First Numbered Text
a <- [Diff (Numbered Text)]
diffs]))
            (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Text]
expected))
    where
    fmt_line :: Set a -> (a, Text) -> Text
fmt_line Set a
failures (a
n, Text
line)
        | forall a. Ord a => a -> Set a -> Bool
Set.member a
n Set a
failures = ColorCode -> Text -> Text
highlight ColorCode
failure_color Text
line
        | Bool
otherwise = Text
line
    gotten :: [Text]
gotten = forall a b. (a -> b) -> [a] -> [b]
map forall a. TextLike a => a -> Text
to_text [txt]
gotten_
    diffs :: [Diff (Numbered Text)]
diffs = forall a. (a -> a -> Bool) -> [a] -> [a] -> [Diff (Numbered a)]
Diffs.numberedDiff forall txt. TextLike txt => Text -> txt -> Bool
pattern_matches [Text]
expected [Text]
gotten
    is_both :: PolyDiff a b -> Bool
is_both (Diff.Both {}) = Bool
True
    is_both PolyDiff a b
_ = Bool
False

-- | Format multiple lines with an operator between them, on a single line if
-- they fit.
fmt_lines :: Text -> [Text] -> [Text] -> Text
fmt_lines :: Text -> [Text] -> [Text] -> Text
fmt_lines Text
operator [Text
x] [Text
y] | Text -> Int
Text.length Text
x forall a. Num a => a -> a -> a
+ Text -> Int
Text.length Text
y forall a. Ord a => a -> a -> Bool
<= Int
70 =
    Text
x forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
operator forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
y
fmt_lines Text
operator [] [Text
y] = Text
"<empty> " forall a. Semigroup a => a -> a -> a
<> Text
operator forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
y
fmt_lines Text
operator [Text
x] [] = Text
x forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
operator forall a. Semigroup a => a -> a -> a
<> Text
" <empty>"
fmt_lines Text
operator [Text]
xs [Text]
ys = (Text
"\n"<>) forall a b. (a -> b) -> a -> b
$ Text -> Text
Text.stripEnd forall a b. (a -> b) -> a -> b
$
    [Text] -> Text
Text.unlines forall a b. (a -> b) -> a -> b
$ [Text]
xs forall a. Semigroup a => a -> a -> a
<> [Text
"    " forall a. Semigroup a => a -> a -> a
<> Text
operator] forall a. Semigroup a => a -> a -> a
<> [Text]
ys

-- | It's common for Left to be an error msg, or be something that can be
-- converted to one.
left_like :: (HasCallStack, Show a, TextLike txt) => Either txt a -> Pattern
    -> Test
left_like :: forall a txt.
(HasCallStack, Show a, TextLike txt) =>
Either txt a -> Text -> IO ()
left_like Either txt a
gotten Text
expected = case Either txt a
gotten of
    Left txt
msg
        | forall txt. TextLike txt => Text -> txt -> Bool
pattern_matches Text
expected txt
msg -> HasCallStack => Text -> IO ()
success forall a b. (a -> b) -> a -> b
$
            Text
"Left " forall a. Semigroup a => a -> a -> a
<> forall a. TextLike a => a -> Text
to_text txt
msg forall a. Semigroup a => a -> a -> a
<> Text
" =~ Left " forall a. Semigroup a => a -> a -> a
<> forall a. TextLike a => a -> Text
to_text Text
expected
        | Bool
otherwise ->
            HasCallStack => Text -> IO ()
failure forall a b. (a -> b) -> a -> b
$ Text
"Left " forall a. Semigroup a => a -> a -> a
<> forall a. TextLike a => a -> Text
to_text txt
msg forall a. Semigroup a => a -> a -> a
<> Text
" !~ Left " forall a. Semigroup a => a -> a -> a
<> forall a. TextLike a => a -> Text
to_text Text
expected
    Right a
a ->
        HasCallStack => Text -> IO ()
failure forall a b. (a -> b) -> a -> b
$ Text
"Right (" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt a
a forall a. Semigroup a => a -> a -> a
<> Text
") !~ Left " forall a. Semigroup a => a -> a -> a
<> forall a. TextLike a => a -> Text
to_text Text
expected

match :: (HasCallStack, TextLike txt) => txt -> Pattern -> Test
match :: forall txt. (HasCallStack, TextLike txt) => txt -> Text -> IO ()
match txt
gotten Text
pattern =
    (if Bool
matches then HasCallStack => Text -> IO ()
success else HasCallStack => Text -> IO ()
failure) forall a b. (a -> b) -> a -> b
$
        Text -> [Text] -> [Text] -> Text
fmt_lines (if Bool
matches then Text
"=~" else Text
"!~")
            (Text -> [Text]
Text.lines (forall a. TextLike a => a -> Text
to_text txt
gotten)) (Text -> [Text]
Text.lines Text
pattern)
    where
    matches :: Bool
matches = forall txt. TextLike txt => Text -> txt -> Bool
pattern_matches Text
pattern txt
gotten

-- | Pattern as matched by 'pattern_matches'.
type Pattern = Text

-- | This is a simplified pattern that only has the @*@ operator, which is
-- equivalent to regex's @.*?@.  This reduces the amount of quoting you have
-- to write.  You can escape @*@ with a backslash.
pattern_matches :: TextLike txt => Pattern -> txt -> Bool
pattern_matches :: forall txt. TextLike txt => Text -> txt -> Bool
pattern_matches Text
pattern = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Regex -> Text -> [(Text, [Text])]
Regex.groups (HasCallStack => Text -> Regex
pattern_to_regex Text
pattern)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TextLike a => a -> Text
to_text

pattern_to_regex :: HasCallStack => Text -> Regex.Regex
pattern_to_regex :: HasCallStack => Text -> Regex
pattern_to_regex =
    HasCallStack => [Option] -> [Char] -> Regex
Regex.compileOptionsUnsafe [Option
Regex.DotAll] forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
mkstar forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
Regex.escape
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
Text.unpack
    where
    mkstar :: ShowS
mkstar [Char]
"" = [Char]
""
    mkstar (Char
'\\' : Char
'\\' : Char
'\\' : Char
'*' : [Char]
cs) = Char
'\\' forall a. a -> [a] -> [a]
: Char
'*' forall a. a -> [a] -> [a]
: ShowS
mkstar [Char]
cs
    mkstar (Char
'\\' : Char
'*' : [Char]
cs) = Char
'.' forall a. a -> [a] -> [a]
: Char
'*' forall a. a -> [a] -> [a]
: Char
'?' forall a. a -> [a] -> [a]
: ShowS
mkstar [Char]
cs
    mkstar (Char
c : [Char]
cs) = Char
c forall a. a -> [a] -> [a]
: ShowS
mkstar [Char]
cs

-- | The given pure value should throw an exception that matches the predicate.
throws :: (HasCallStack, Show a) => a -> Pattern -> Test
throws :: forall a. (HasCallStack, Show a) => a -> Text -> IO ()
throws a
val Text
exc_pattern =
    (forall a. a -> IO a
Exception.evaluate a
val forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HasCallStack => Text -> IO ()
failure (Text
"didn't throw: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt a
val))
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch` \(SomeException
exc :: Exception.SomeException) ->
        if forall txt. TextLike txt => Text -> txt -> Bool
pattern_matches Text
exc_pattern (forall a. Show a => a -> Text
showt SomeException
exc)
            then HasCallStack => Text -> IO ()
success (Text
"caught exc: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt SomeException
exc)
            else HasCallStack => Text -> IO ()
failure forall a b. (a -> b) -> a -> b
$ Text
"exception <" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt SomeException
exc forall a. Semigroup a => a -> a -> a
<> Text
"> didn't match "
                forall a. Semigroup a => a -> a -> a
<> Text
exc_pattern

io_equal :: (HasCallStack, Eq a, Show a) => IO a -> a -> Test
io_equal :: forall a. (HasCallStack, Eq a, Show a) => IO a -> a -> IO ()
io_equal IO a
io_val a
expected = do
    a
val <- IO a
io_val
    forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
equal a
val a
expected

-- | Only a human can check these things.
io_human :: HasCallStack => String -> IO a -> IO a
io_human :: forall a. HasCallStack => [Char] -> IO a -> IO a
io_human [Char]
expected_msg IO a
op = do
    [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"should see: " forall a. [a] -> [a] -> [a]
++ [Char]
expected_msg
    IO Char
human_get_char
    a
result <- IO a
op
    [Char] -> IO ()
putStr [Char]
"  ... ok (y/n/q)? "
    Char
c <- IO Char
human_get_char
    Char -> IO ()
putChar Char
'\n'
    case Char
c of
        Char
'y' -> HasCallStack => Text -> IO ()
success forall a b. (a -> b) -> a -> b
$ Text
"saw " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Char]
expected_msg
        Char
'q' -> forall a. HasCallStack => [Char] -> a
error [Char]
"quit test"
        Char
_ -> HasCallStack => Text -> IO ()
failure forall a b. (a -> b) -> a -> b
$ Text
"didn't see " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Char]
expected_msg
    forall (m :: * -> *) a. Monad m => a -> m a
return a
result

pause :: String -> IO ()
pause :: [Char] -> IO ()
pause [Char]
msg = do
    [Char] -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ [Char]
"pausing, hit almost any key... "
        forall a. [a] -> [a] -> [a]
++ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
msg then [Char]
"" else [Char]
" -- " forall a. [a] -> [a] -> [a]
++ [Char]
msg
    IO Char
human_get_char
    [Char] -> IO ()
putStr [Char]
"\n"

expect_right :: (HasCallStack, Show a) => Either a b -> b
expect_right :: forall a b. (HasCallStack, Show a) => Either a b -> b
expect_right (Left a
v) = forall a. HasCallStack => [Char] -> a
error (forall a. Show a => a -> [Char]
show a
v)
expect_right (Right b
v) = b
v

-- * hedgehog

hedgehog :: Hedgehog.Property -> Test
hedgehog :: Property -> IO ()
hedgehog Property
prop = do
    Seed
seed <- forall (m :: * -> *). MonadIO m => m Seed
Internal.Seed.random
    Report Result
report <- forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
PropertyConfig
-> Size
-> Seed
-> PropertyT m ()
-> (Report Progress -> m ())
-> m (Report Result)
Internal.Runner.checkReport PropertyConfig
config Size
size Seed
seed
        (Property -> PropertyT IO ()
Internal.Property.propertyTest Property
prop) forall {m :: * -> *} {p}. Monad m => p -> m ()
updateUI
    (Bool
ok, Text
msg) <- Report Result -> IO (Bool, Text)
format_hedgehog_report Report Result
report
    (if Bool
ok then HasCallStack => Text -> IO ()
success else HasCallStack => Text -> IO ()
failure) Text
msg
    where
    -- TODO if it's interactive, give a progress report?
    updateUI :: p -> m ()
updateUI p
_progress = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    config :: PropertyConfig
config = Property -> PropertyConfig
Internal.Property.propertyConfig Property
prop
    size :: Size
size = Size
0

format_hedgehog_report :: Report.Report Report.Result -> IO (Bool, Text)
format_hedgehog_report :: Report Result -> IO (Bool, Text)
format_hedgehog_report Report Result
report = do
    [Char]
name <- Text -> [Char]
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Text
config_test_name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
IORef.readIORef IORef Config
test_config
    [Char]
str <- forall (m :: * -> *).
MonadIO m =>
UseColor -> Maybe PropertyName -> Report Result -> m [Char]
Report.renderResult UseColor
Internal.Config.EnableColor
        (forall a. a -> Maybe a
Just ([Char] -> PropertyName
Internal.Property.PropertyName [Char]
name)) Report Result
report
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (, [Char] -> Text
Text.pack [Char]
str) forall a b. (a -> b) -> a -> b
$ case forall a. Report a -> a
Report.reportStatus Report Result
report of
        Result
Report.OK -> Bool
True
        Result
Report.GaveUp -> Bool
False
        Report.Failed {} -> Bool
False

-- * QuickCheck

-- | Run a quickcheck property.
quickcheck :: (HasCallStack, QuickCheck.Testable prop) => prop -> Test
quickcheck :: forall prop. (HasCallStack, Testable prop) => prop -> IO ()
quickcheck prop
prop = do
    (Bool
ok, Text
msg) <- Result -> (Bool, Text)
format_quickcheck_result forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall prop. Testable prop => Args -> prop -> IO Result
QuickCheck.quickCheckWithResult Args
args prop
prop
    (if Bool
ok then HasCallStack => Text -> IO ()
success else HasCallStack => Text -> IO ()
failure) Text
msg
    where
    args :: Args
args = Args
QuickCheck.stdArgs { chatty :: Bool
QuickCheck.chatty = Bool
False }

format_quickcheck_result :: QuickCheck.Result -> (Bool, Text)
format_quickcheck_result :: Result -> (Bool, Text)
format_quickcheck_result Result
result = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
Text.strip forall a b. (a -> b) -> a -> b
$ case Result
result of
    QuickCheck.Success { [Char]
output :: Result -> [Char]
output :: [Char]
output } -> (Bool
True, [Char] -> Text
Text.pack [Char]
output)
    QuickCheck.GaveUp { [Char]
output :: [Char]
output :: Result -> [Char]
output } -> (Bool
False, [Char] -> Text
Text.pack [Char]
output)
    QuickCheck.Failure { [Char]
output :: [Char]
output :: Result -> [Char]
output } -> (Bool
False, [Char] -> Text
Text.pack [Char]
output)
    QuickCheck.NoExpectedFailure { [Char]
output :: [Char]
output :: Result -> [Char]
output } -> (Bool
False, [Char] -> Text
Text.pack [Char]
output)

-- | 'equal' for quickcheck.
q_equal :: (Show a, Eq a) => a -> a -> QuickCheck.Property
q_equal :: forall a. (Show a, Eq a) => a -> a -> Property
q_equal a
a a
b = forall prop. Testable prop => [Char] -> prop -> Property
QuickCheck.counterexample
    (Text -> [Char]
Text.unpack forall a b. (a -> b) -> a -> b
$ forall a. Show a => Text -> Text -> Bool -> a -> a -> Bool -> Text
pretty_compare Text
"==" Text
"/=" Bool
True a
a a
b Bool
False)
    (a
a forall a. Eq a => a -> a -> Bool
== a
b)

-- * util

-- These used to write to stderr, but the rest of the diagnostic output goes to
-- stdout, and it's best these appear in context.

-- | Print a msg with a special tag indicating a passing test.
success :: HasCallStack => Text -> Test
success :: HasCallStack => Text -> IO ()
success Text
msg = CallStack -> ColorCode -> Text -> Text -> IO ()
print_test_line HasCallStack => CallStack
Stack.callStack ColorCode
success_color Text
"++-> " Text
msg

-- | Print a msg with a special tag indicating a failing test.
failure :: HasCallStack => Text -> Test
failure :: HasCallStack => Text -> IO ()
failure Text
msg = CallStack -> ColorCode -> Text -> Text -> IO ()
print_test_line HasCallStack => CallStack
Stack.callStack ColorCode
failure_color Text
"__-> " Text
msg

print_test_line :: Stack.CallStack -> ColorCode -> Text -> Text -> IO ()
print_test_line :: CallStack -> ColorCode -> Text -> Text -> IO ()
print_test_line CallStack
stack ColorCode
color Text
prefix Text
msg = do
    -- Make sure the output doesn't get mixed with trace debug msgs.
    forall a. NFData a => a -> IO ()
force Text
msg
    Bool
isatty <- Fd -> IO Bool
Terminal.queryTerminal Fd
IO.stdOutput
    Text
test_name <- Config -> Text
config_test_name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
IORef.readIORef IORef Config
test_config
    -- If there is highlighting in the msg, then it's probably a diff so
    -- most of it may be unhighlighted.  So highlight the prefix to make
    -- the line visible.
    let full_prefix :: Text
full_prefix = (if Text -> Bool
is_highlighted Text
msg then ColorCode -> Text -> Text
highlight ColorCode
color else forall a. a -> a
id)
            (Text
prefix forall a. Semigroup a => a -> a -> a
<> Text -> CallStack -> Text
show_stack Text
test_name CallStack
stack)
    let full_msg :: Text
full_msg = Text
full_prefix forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
msg
        highlighted :: Text
highlighted
            -- I only want colors in tty output.
            | Bool -> Bool
not Bool
isatty = Text -> Text
strip_colors Text
full_msg
            -- Don't put on a color if it already has some.
            | Text -> Bool
is_highlighted Text
full_msg = Text
full_msg
            | Bool
otherwise = ColorCode -> Text -> Text
highlight ColorCode
color Text
full_msg
    Text -> IO ()
Text.IO.putStrLn Text
highlighted
    where
    is_highlighted :: Text -> Bool
is_highlighted = (Text
vt100_prefix `Text.isInfixOf`)

show_stack :: Text -> Stack.CallStack -> Text
show_stack :: Text -> CallStack -> Text
show_stack Text
test_name =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"<empty-stack>" forall {a}. (a, SrcLoc) -> Text
show_frame forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
Lists.last forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> [([Char], SrcLoc)]
Stack.getCallStack
    where
    show_frame :: (a, SrcLoc) -> Text
show_frame (a
_, SrcLoc
srcloc) =
        [Char] -> Text
Text.pack (SrcLoc -> [Char]
Stack.srcLocFile SrcLoc
srcloc) forall a. Semigroup a => a -> a -> a
<> Text
":"
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (SrcLoc -> Int
Stack.srcLocStartLine SrcLoc
srcloc)
        forall a. Semigroup a => a -> a -> a
<> if Text -> Bool
Text.null Text
test_name then Text
"" else Text
" [" forall a. Semigroup a => a -> a -> a
<> Text
test_name forall a. Semigroup a => a -> a -> a
<> Text
"]"

highlight :: ColorCode -> Text -> Text
highlight :: ColorCode -> Text -> Text
highlight (ColorCode Text
code) Text
text
    | Text -> Bool
Text.null Text
text = Text
text
    | Bool
otherwise = Text
code forall a. Semigroup a => a -> a -> a
<> Text
text forall a. Semigroup a => a -> a -> a
<> Text
vt100_normal

-- | Remove vt100 color codes.
strip_colors :: Text -> Text
strip_colors :: Text -> Text
strip_colors = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a) -> [a] -> [a]
Lists.mapTail (Int -> Text -> Text
Text.drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
Text.dropWhile (forall a. Eq a => a -> a -> Bool
/=Char
'm'))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text.splitOn Text
vt100_prefix

newtype ColorCode = ColorCode Text deriving (Int -> ColorCode -> ShowS
[ColorCode] -> ShowS
ColorCode -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ColorCode] -> ShowS
$cshowList :: [ColorCode] -> ShowS
show :: ColorCode -> [Char]
$cshow :: ColorCode -> [Char]
showsPrec :: Int -> ColorCode -> ShowS
$cshowsPrec :: Int -> ColorCode -> ShowS
Show)

vt100_prefix :: Text
vt100_prefix :: Text
vt100_prefix = Text
"\ESC["

vt100_normal :: Text
vt100_normal :: Text
vt100_normal = Text
"\ESC[m\ESC[m"

-- | These codes should probably come from termcap, but I can't be bothered.
failure_color :: ColorCode
failure_color :: ColorCode
failure_color = Text -> ColorCode
ColorCode Text
"\ESC[31m" -- red

success_color :: ColorCode
success_color :: ColorCode
success_color = Text -> ColorCode
ColorCode Text
"\ESC[32m" -- green

-- | getChar with no buffering.
human_get_char :: IO Char
human_get_char :: IO Char
human_get_char = do
    Bool
agreeable <- Config -> Bool
config_human_agreeable forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
IORef.readIORef IORef Config
test_config
    if Bool
agreeable
        then forall (m :: * -> *) a. Monad m => a -> m a
return Char
'y'
        else do
            Handle -> IO ()
IO.hFlush Handle
IO.stdout
            BufferMode
mode <- Handle -> IO BufferMode
IO.hGetBuffering Handle
IO.stdin
            Handle -> BufferMode -> IO ()
IO.hSetBuffering Handle
IO.stdin BufferMode
IO.NoBuffering
            do { Char
c <- IO Char
getChar; Char -> IO ()
putChar Char
' '; forall (m :: * -> *) a. Monad m => a -> m a
return Char
c }
                forall a b. IO a -> IO b -> IO a
`Exception.finally` Handle -> BufferMode -> IO ()
IO.hSetBuffering Handle
IO.stdin BufferMode
mode

-- * pretty

prettyp :: Pretty.Pretty a => a -> IO ()
prettyp :: forall a. Pretty a => a -> IO ()
prettyp a
val = Text
s forall a b. NFData a => a -> b -> b
`DeepSeq.deepseq` Text -> IO ()
Text.IO.putStr Text
s
    -- deepseq to ensure log tracing happens first
    where s :: Text
s = forall a. Pretty a => a -> Text
Pretty.formatted a
val

pprint :: Show a => a -> IO ()
pprint :: forall a. Show a => a -> IO ()
pprint = [Char] -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
pshow

showt :: Show a => a -> Text
showt :: forall a. Show a => a -> Text
showt = [Char] -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show

pshowt :: Show a => a -> Text
pshowt :: forall a. Show a => a -> Text
pshowt = Text -> Text
Text.strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
pshow

-- | Strict pshow, so I don't get debug traces interleaved with printing.
pshow :: Show a => a -> String
pshow :: forall a. Show a => a -> [Char]
pshow a
val = [Char]
s forall a b. NFData a => a -> b -> b
`DeepSeq.deepseq` [Char]
s
    where s :: [Char]
s = ShowS
Strings.rstrip forall a b. (a -> b) -> a -> b
$ ShowS
PPrint.format_str (forall a. Show a => a -> [Char]
show a
val)

-- * filesystem

-- | Get a tmp dir, which will be unique for each test run.
tmp_dir :: String -> IO FilePath
tmp_dir :: [Char] -> IO [Char]
tmp_dir [Char]
prefix = do
    Bool -> [Char] -> IO ()
Directory.createDirectoryIfMissing Bool
True [Char]
tmp_base_dir
    [Char]
dir <- [Char] -> IO [Char]
Temp.mkdtemp forall a b. (a -> b) -> a -> b
$ [Char]
tmp_base_dir [Char] -> ShowS
</> [Char]
prefix forall a. [a] -> [a] -> [a]
++ [Char]
"-"
    [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"** tmp dir: " forall a. [a] -> [a] -> [a]
++ [Char]
dir
    forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
dir

-- | Run the computation with cwd in a new tmp dir.
in_tmp_dir :: String -> IO a -> IO a
in_tmp_dir :: forall a. [Char] -> IO a -> IO a
in_tmp_dir [Char]
prefix IO a
action = do
    [Char]
dir <- [Char] -> IO [Char]
tmp_dir [Char]
prefix
    forall a. [Char] -> IO a -> IO a
Directory.withCurrentDirectory [Char]
dir IO a
action

-- | All tmp files used by tests should go in this directory.
-- TODO instead of being hardcoded this should be configured per-project.
tmp_base_dir :: FilePath
tmp_base_dir :: [Char]
tmp_base_dir = [Char]
"build/test/tmp"

-- * util

force :: DeepSeq.NFData a => a -> IO ()
force :: forall a. NFData a => a -> IO ()
force a
x = forall a. a -> IO a
Exception.evaluate (forall a. NFData a => a -> ()
DeepSeq.rnf a
x)