{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns, DisambiguateRecordFields #-}
module EL.Test.Testing (
Config(..), modifyTestConfig, withTestName
, ModuleMeta(..), moduleMeta, Tag(..)
, check, checkVal
, equal, equalFmt, rightEqual, notEqual, equalf, stringsLike
, leftLike, match
, Pattern
, throws
, ioEqual
, success, failure
, expectRight
, quickcheck
, qcEqual
, pprint
, uniqueTmpDir, inTmpDir, tmpBaseDir
, 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.Map as Map
import Data.Monoid ((<>))
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 System.Directory as Directory
import System.FilePath ((</>))
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 EL.Private.Map as EL.Map
import qualified EL.Private.PPrint as PPrint
import qualified EL.Private.Ranges as Ranges
import qualified EL.Private.Regex as Regex
import qualified EL.Private.Seq as Seq
import qualified EL.Test.ApproxEq as ApproxEq
{-# NOINLINE testConfig #-}
testConfig :: IORef.IORef Config
testConfig = Unsafe.unsafePerformIO $ IORef.newIORef $ Config
{ configTestName = "no-test"
}
modifyTestConfig :: (Config -> Config) -> IO ()
modifyTestConfig = IORef.modifyIORef testConfig
withTestName :: Text -> IO a -> IO a
withTestName name action = do
modifyTestConfig (\config -> config { configTestName = name })
action
data Config = Config {
configTestName :: !Text
} deriving (Show)
check :: HasCallStack => Text -> Bool -> IO Bool
check msg False = failure ("failed: " <> msg)
check msg True = success msg
checkVal :: Show a => HasCallStack => a -> (a -> Bool) -> IO Bool
checkVal val f
| f val = success $ "ok: " <> pshowt val
| otherwise = failure $ "failed: " <> pshowt val
data ModuleMeta = ModuleMeta {
initialize :: IO () -> IO ()
, tags :: [Tag]
}
moduleMeta :: ModuleMeta
moduleMeta = ModuleMeta
{ initialize = id
, tags = []
}
data Tag = Large
deriving (Eq, Show)
equal :: (HasCallStack, Show a, Eq a) => a -> a -> IO Bool
equal a b
| a == b = success $ cmp True
| otherwise = failure $ cmp False
where cmp = prettyCompare "==" "/=" True a b
equalFmt :: (HasCallStack, Eq a, Show a) => (a -> Text) -> a -> a -> IO Bool
equalFmt fmt a b = do
ok <- equal a b
let (pa, pb) = (fmt a, fmt b)
unless (ok || Text.null pa && Text.null pb) $
Text.IO.putStrLn $ showDiff pa pb
return ok
where
showDiff prettyA prettyB = fmtLines "/="
(Text.lines $ highlightLines color diffA prettyA)
(Text.lines $ highlightLines color diffB prettyB)
where
color = failureColor
(diffA, diffB) = diffRanges prettyA prettyB
notEqual :: (HasCallStack, Show a, Eq a) => a -> a -> IO Bool
notEqual a b
| a == b = failure $ cmp True
| otherwise = success $ cmp False
where cmp = prettyCompare "==" "/=" False a b
rightEqual :: (HasCallStack, Show err, Show a, Eq a) => Either err a -> a
-> IO Bool
rightEqual (Right a) b = equal a b
rightEqual (Left err) _ = failure $ "Left: " <> pshowt err
prettyCompare :: Show a =>
Text
-> Text
-> Bool
-> a -> a -> Bool
-> Text
prettyCompare equal inequal expectEqual a b isEqual
| isEqual = equal <> " " <> ellipse (showt a)
| otherwise = fmtLines inequal
(Text.lines $ highlightLines color diffA prettyA)
(Text.lines $ highlightLines color diffB prettyB)
where
color = if expectEqual then failureColor else successColor
(diffA, diffB) = diffRanges prettyA prettyB
prettyA = Text.strip $ pshowt a
prettyB = Text.strip $ pshowt b
ellipse s
| len > maxlen = Text.take maxlen s <> "... {" <> showt len <> "}"
| otherwise = s
where len = Text.length s
maxlen = 200
highlightLines :: ColorCode -> IntMap.IntMap [CharRange] -> Text -> Text
highlightLines color nums = Text.unlines . zipWith hi [0..] . Text.lines
where
hi i line = case IntMap.lookup i nums of
Just ranges -> highlightRanges color ranges line
Nothing -> line
highlightRanges :: ColorCode -> [CharRange] -> Text -> Text
highlightRanges color ranges = mconcat . map hi . splitRanges ranges
where hi (outside, inside) = outside <> highlight color inside
splitRanges :: [(Int, Int)] -> Text -> [(Text, Text)]
splitRanges ranges = go 0 ranges
where
go _ [] text
| Text.null text = []
| otherwise = [(text, mempty)]
go prev ((s, e) : ranges) text = (pre, within) : go e ranges post
where
(pre, rest) = Text.splitAt (s-prev) text
(within, post) = Text.splitAt (e - s) rest
type CharRange = (Int, Int)
diffRanges :: Text -> Text
-> (IntMap.IntMap [CharRange], IntMap.IntMap [CharRange])
diffRanges first second =
toMap $ Seq.partition_paired $ map diffLine $
EL.Map.pairs firstByLine secondByLine
where
toMap (as, bs) = (IntMap.fromList as, IntMap.fromList bs)
diffLine (num, d) = case d of
Seq.Both line1 line2 -> Seq.Both (num, d1) (num, d2)
where (d1, d2) = charDiff line1 line2
Seq.First line1 -> Seq.First (num, [(0, Text.length line1)])
Seq.Second line2 -> Seq.Second (num, [(0, Text.length line2)])
firstByLine = Map.fromList
[(n, text) | Diff.First (Numbered n text) <- diffs]
secondByLine = Map.fromList
[(n, text) | Diff.Second (Numbered n text) <- diffs]
diffs = numberedDiff (==) (Text.lines first) (Text.lines second)
charDiff :: Text -> Text -> ([CharRange], [CharRange])
charDiff first second
| tooDifferent firstCs || tooDifferent secondCs =
([(0, Text.length first)], [(0, Text.length second)])
| otherwise = (firstCs, secondCs)
where
firstCs = toRanges [n | Diff.First (Numbered n _) <- diffs]
secondCs = toRanges [n | Diff.Second (Numbered n _) <- diffs]
diffs = numberedDiff (==) (Text.unpack first) (Text.unpack second)
tooDifferent ranges = length ranges > 2
toRanges :: [Int] -> [(Int, Int)]
toRanges xs = Ranges.merge_sorted [(n, n+1) | n <- xs]
numberedDiff :: (a -> a -> Bool) -> [a] -> [a] -> [Diff.Diff (Numbered a)]
numberedDiff equal a b =
Diff.getDiffBy (\a b -> _numberedVal a `equal` _numberedVal b)
(number a) (number b)
where number = zipWith Numbered [0..]
data Numbered a = Numbered {
_numbered :: !Int
, _numberedVal :: !a
} deriving (Show)
equalf :: (HasCallStack, Show a, ApproxEq.ApproxEq a) => Double -> a -> a
-> IO Bool
equalf eta a b
| ApproxEq.eq eta a b = success $ pretty True
| otherwise = failure $ pretty False
where pretty = prettyCompare "~~" "/~" True a b
class Show a => TextLike a where toText :: a -> Text
instance TextLike String where toText = Text.pack
instance TextLike Text where toText = id
stringsLike :: forall txt. (HasCallStack, TextLike txt) => [txt] -> [Pattern]
-> IO Bool
stringsLike gotten_ expected
| all isBoth diffs = success $ fmtLines "=~" gotten expected
| otherwise = failure $ fmtLines "/~"
(map (fmtLine (Set.fromList [_numbered a | Diff.Second a <- diffs]))
(zip [0..] gotten))
(map (fmtLine (Set.fromList [_numbered a | Diff.First a <- diffs]))
(zip [0..] expected))
where
fmtLine failures (n, line)
| Set.member n failures = highlight failureColor line
| otherwise = line
gotten = map toText gotten_
diffs = numberedDiff patternMatches expected gotten
isBoth (Diff.Both {}) = True
isBoth _ = False
fmtLines :: Text -> [Text] -> [Text] -> Text
fmtLines operator [x] [y] | Text.length x + Text.length y <= 70 =
x <> " " <> operator <> " " <> y
fmtLines operator [] [y] = "<empty> " <> operator <> " " <> y
fmtLines operator [x] [] = x <> " " <> operator <> " <empty>"
fmtLines operator xs ys = ("\n"<>) $ Text.stripEnd $
Text.unlines $ xs <> [" " <> operator] <> ys
leftLike :: (HasCallStack, Show a, TextLike txt) => Either txt a -> Pattern
-> IO Bool
leftLike gotten expected = case gotten of
Left msg
| patternMatches expected msg -> success $
"Left " <> toText msg <> " =~ Left " <> toText expected
| otherwise ->
failure $ "Left " <> toText msg <> " !~ Left " <> toText expected
Right a ->
failure $ "Right (" <> showt a <> ") !~ Left " <> toText expected
match :: (HasCallStack, TextLike txt) => txt -> Pattern -> IO Bool
match gotten pattern =
(if matches then success else failure) $
fmtLines (if matches then "=~" else "!~")
(Text.lines (toText gotten)) (Text.lines pattern)
where
matches = patternMatches pattern gotten
type Pattern = Text
patternMatches :: TextLike txt => Pattern -> txt -> Bool
patternMatches pattern = not . null . Regex.groups (patternToRegex pattern)
. toText
patternToRegex :: HasCallStack => Text -> Regex.Regex
patternToRegex =
Regex.compileOptionsUnsafe [Regex.DotAll] . mkstar . Regex.escape
. Text.unpack
where
mkstar "" = ""
mkstar ('\\' : '\\' : '\\' : '*' : cs) = '\\' : '*' : mkstar cs
mkstar ('\\' : '*' : cs) = '.' : '*' : '?' : mkstar cs
mkstar (c : cs) = c : mkstar cs
throws :: (HasCallStack, Show a) => a -> Pattern -> IO Bool
throws val excPattern =
(Exception.evaluate val >> failure ("didn't throw: " <> showt val))
`Exception.catch` \(exc :: Exception.SomeException) ->
if patternMatches excPattern (showt exc)
then success ("caught exc: " <> showt exc)
else failure $ "exception <" <> showt exc <> "> didn't match "
<> excPattern
ioEqual :: (HasCallStack, Eq a, Show a) => IO a -> a -> IO Bool
ioEqual ioVal expected = do
val <- ioVal
equal val expected
expectRight :: (HasCallStack, Show a) => Either a b -> b
expectRight (Left v) = error (pshow v)
expectRight (Right v) = v
quickcheck :: (HasCallStack, QuickCheck.Testable prop) => prop -> IO Bool
quickcheck prop = do
(ok, msg) <- fmtQuickCheckResult <$>
QuickCheck.quickCheckWithResult args prop
(if ok then success else failure) msg
where
args = QuickCheck.stdArgs { QuickCheck.chatty = False }
fmtQuickCheckResult :: QuickCheck.Result -> (Bool, Text)
fmtQuickCheckResult result = fmap Text.strip $ case result of
QuickCheck.Success { output } -> (True, Text.pack output)
QuickCheck.GaveUp { output } -> (False, Text.pack output)
QuickCheck.Failure { output } -> (False, Text.pack output)
QuickCheck.NoExpectedFailure { output } -> (False, Text.pack output)
#if ! MIN_VERSION_QuickCheck(2, 12, 0)
QuickCheck.InsufficientCoverage { output } -> (False, Text.pack output)
#endif
qcEqual :: (Show a, Eq a) => a -> a -> QuickCheck.Property
qcEqual a b = QuickCheck.counterexample
(Text.unpack $ prettyCompare "==" "/=" True a b False)
(a == b)
success :: HasCallStack => Text -> IO Bool
success msg = do
printTestLine Stack.callStack successColor "++-> " msg
return True
failure :: HasCallStack => Text -> IO Bool
failure msg = do
printTestLine Stack.callStack failureColor "__-> " msg
return False
printTestLine :: Stack.CallStack -> ColorCode -> Text -> Text -> IO ()
printTestLine stack color prefix msg = do
force msg
isatty <- Terminal.queryTerminal IO.stdOutput
testName <- configTestName <$> IORef.readIORef testConfig
let fullPrefix = (if isHighlighted msg then highlight color else id)
(prefix <> showStack testName stack)
let fullMsg = fullPrefix <> " " <> msg
highlighted
| not isatty = stripColors fullMsg
| isHighlighted fullMsg = fullMsg
| otherwise = highlight color fullMsg
Text.IO.putStrLn highlighted
where
isHighlighted = (vt100Prefix `Text.isInfixOf`)
showStack :: Text -> Stack.CallStack -> Text
showStack testName =
maybe "<empty-stack>" showFrame . Seq.last . Stack.getCallStack
where
showFrame (_, srcloc) =
Text.pack (Stack.srcLocFile srcloc) <> ":"
<> showt (Stack.srcLocStartLine srcloc)
<> if Text.null testName then "" else " [" <> testName <> "]"
highlight :: ColorCode -> Text -> Text
highlight (ColorCode code) text
| Text.null text = text
| otherwise = code <> text <> vt100Normal
stripColors :: Text -> Text
stripColors = mconcat . Seq.map_tail (Text.drop 1 . Text.dropWhile (/='m'))
. Text.splitOn vt100Prefix
newtype ColorCode = ColorCode Text deriving (Show)
vt100Prefix :: Text
vt100Prefix = "\ESC["
vt100Normal :: Text
vt100Normal = "\ESC[m\ESC[m"
failureColor :: ColorCode
failureColor = ColorCode "\ESC[31m"
successColor :: ColorCode
successColor = ColorCode "\ESC[32m"
pprint :: Show a => a -> IO ()
pprint = putStr . pshow
showt :: Show a => a -> Text
showt = Text.pack . show
pshowt :: Show a => a -> Text
pshowt = Text.pack . pshow
pshow :: Show a => a -> String
pshow val = s `DeepSeq.deepseq` s
where s = PPrint.pshow val
uniqueTmpDir :: String -> IO FilePath
uniqueTmpDir prefix = do
Directory.createDirectoryIfMissing True tmpBaseDir
Temp.mkdtemp $ tmpBaseDir </> prefix ++ "-"
inTmpDir :: String -> IO a -> IO a
inTmpDir prefix action = do
dir <- uniqueTmpDir prefix
Directory.withCurrentDirectory dir action
tmpBaseDir :: FilePath
tmpBaseDir = "dist/test-tmp"
force :: DeepSeq.NFData a => a -> IO ()
force x = Exception.evaluate (DeepSeq.rnf x)