Run.hs

{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TupleSections #-}
module Test.Run
( runEntries
) where

import           Control.Carrier.Reader
import           Control.Carrier.State.Church
import           Control.Exception (SomeException)
import           Control.Monad (guard, when)
import           Control.Monad.IO.Class
import           Data.Bool (bool)
import           Data.Foldable (for_, toList)
import qualified Data.IntMap as IntMap
import           Data.List (elemIndex, intercalate, intersperse, sortBy)
import qualified Data.Map as Map
import           Data.Maybe (fromMaybe)
import           Data.Monoid (Ap(..))
import           Data.Ord (comparing)
import           Fresnel.Tropical
import           GHC.Exception.Type (Exception(displayException))
import           Numeric (showFFloatAlt)
import           System.Console.ANSI
import           System.IO
import           Test.Group as Group
import           Test.Options
import           Test.Print
import           Test.QuickCheck (Args(..), isSuccess, quickCheckWithResult)
import qualified Test.QuickCheck as QC

runEntries :: [Entry] -> Options -> IO Bool
runEntries groups (Options es args) = runReader w . runReader args . runReader stdout . runState (const . pure . not . hasFailures) mempty $ do
  t <- getAp (foldMap Ap (intersperse (mempty <$ blank <* blank) (map runEntry (matching ((==) . entryName) es groups))))
  when (hasSuccesses t || hasFailures t) (blank *> topIndent end *> runTally t)
  where
  blank = topIndent vline <* nl
  w = fromMaybe zero (getTropical (maxWidths groups))
  matching _ [] = id
  matching f fs = filter (\ g -> foldr ((||) . f g) False fs)

runEntry :: (Has (Reader Args) sig m, Has (Reader Handle) sig m, Has (Reader Width) sig m, Has (State Tally) sig m, MonadIO m) => Entry -> m Tally
runEntry = \case
  Group name entries -> runGroup name entries
  Prop name loc prop -> runProp  name loc prop


runGroup :: (Has (Reader Args) sig m, Has (Reader Handle) sig m, Has (Reader Width) sig m, Has (State Tally) sig m, MonadIO m) => String -> [Entry] -> m Tally
runGroup groupName entries  = do
  topIndent vline
  withSGR [SetConsoleIntensity BoldIntensity] (putS (space ++ groupName) *> nl)
  w <- ask
  t <- local (<> Width 2) (section Nothing (getAp (foldMap Ap (intersperse (mempty <$ line <* nl) (map (local (const (w :: Width)) . runEntry) entries)))))
  when (hasSuccesses t || hasFailures t) $ do
    if hasFailures t then
      failure' (putS (headingN <> gtally))
    else
      topIndent vline *> putS space
    runTally t
  pure t

runProp :: (Has (Reader Args) sig m, Has (Reader Handle) sig m, Has (Reader Width) sig m, Has (State Tally) sig m, MonadIO m) => String -> Loc -> QC.Property -> m Tally
runProp name loc property = runPropWith (ask >>= \ args -> fromQC <$> liftIO (quickCheckWithResult args property)) name loc

runPropWith :: (Has (Reader Args) sig m, Has (Reader Handle) sig m, Has (Reader Width) sig m, Has (State Tally) sig m, MonadIO m) => m Result -> String -> Loc -> m Tally
runPropWith run name Loc{ path, lineNumber } = withHandle $ \ h ->  do
  isTerminal <- liftIO (hIsTerminalDevice h)

  when isTerminal (title Pass False)

  failedPreviously <- gets hasFailures
  Result{ stats, status, failed } <- run
  modify (<> unit status)

  when isTerminal $ do
    liftIO (hClearFromCursorToLineBeginning h)
    liftIO (hSetCursorColumn h 0)

  title status failedPreviously

  putS "   " *> stat (success (putS "Success")) (failure (putS "Failure")) status *> nl

  maxSuccess <- asks maxSuccess
  let details = numTests stats == maxSuccess && not (null (classes stats))
      labels = runLabels status stats
      ln b = line *> stat success failure status (putS vline) *> b *> nl
      output
        | details || status == Fail || not (null labels) = section (Just status)
        | otherwise                                      = id

  unit status <$ output (sepBy_ (ln (pure ())) (concat
    [ [ ln (sepBy_ (putS " ") (runStats maxSuccess stats ++ runClasses stats)) | details ]
    , do
      Failure{ seed, reason, exception, testCase } <- toList failed
      let len = length testCase
      concat
        [ [ do
            ln (putS (path ++ ':' : show lineNumber ++ ':' : ' ' : reason))
            for_ exception (ln . putS . displayException) ]
        , [ for_ (enumerate (init testCase)) (\ (i, s) -> ln (putS (i ++ s))) | len >= 2 ]
        , [ ln (failure (putS (last testCase))) | len >= 1 ]
        , [ ln (putS ("--replay '" ++ seed ++ "'")) ] ]
    , labels
    , runTables stats ]))
  where
  title s failedPreviously = do
    topIndent (stat vline (bool heading1 headingN failedPreviously) s)
    stat (putS vline) (failure' (putS (hline ++ arrow))) s
    w <- asks width
    withSGR (SetConsoleIntensity BoldIntensity:stat [] [ SetColor Foreground Vivid Red ] s) (putS (bullet ++ name ++ replicate (w - length name) ' '))
    withHandle (liftIO . hFlush)

data Result = Result
  { stats  :: Stats
  , status :: Status
  , failed :: Maybe Failure
  }

data Failure = Failure
  { seed      :: String
  , reason    :: String
  , exception :: Maybe SomeException
  , testCase  :: [String]
  }

data Stats = Stats
  { numTests     :: Int
  , numDiscarded :: Int
  , numShrinks   :: Int
  , labels       :: Map.Map [String] Int
  , classes      :: Map.Map String Int
  , tables       :: Map.Map String (Map.Map String Int)
  }

defaultStats :: Stats
defaultStats = Stats
  { numTests     = 0
  , numDiscarded = 0
  , numShrinks   = 0
  , labels       = Map.empty
  , classes      = Map.empty
  , tables       = Map.empty
  }

fromQC :: QC.Result -> Result
fromQC r = Result (resultStats r) (bool Fail Pass (isSuccess r)) $ case r of
  QC.Failure{ usedSeed, usedSize, reason, theException, failingTestCase } -> Just Failure{ seed = show (usedSeed, usedSize), reason, exception = theException, testCase = failingTestCase }
  _                                                                       -> Nothing

resultStats :: QC.Result -> Stats
resultStats = \case
  QC.Success{ numTests, numDiscarded, labels, classes, tables }                   -> defaultStats{ numTests, numDiscarded, labels, classes, tables }
  QC.GaveUp{ numTests, numDiscarded, labels, classes, tables }                    -> defaultStats{ numTests, numDiscarded, labels, classes, tables }
  QC.Failure{ numTests, numDiscarded, numShrinks, failingLabels, failingClasses } -> defaultStats{ numTests, numDiscarded, numShrinks, labels = Map.fromList (map ((, numTests) . pure) failingLabels), classes = Map.fromList (map (,numTests) (toList failingClasses)) }
  QC.NoExpectedFailure{ numTests, numDiscarded, labels, classes, tables }         -> defaultStats{ numTests, numDiscarded, labels, classes, tables }

runStats :: (Has (Reader Handle) sig m, MonadIO m) => Int -> Stats -> [m ()]
runStats maxSuccess Stats{ numTests, numDiscarded, numShrinks } = [ sepBy_ (putS ", ") entries *> putS "." | not (null entries) ]
  where
  entries = concat
    [ [ putS (show numTests     ++ " test"   ++ singular numTests)   | numTests     > 0, numTests /= maxSuccess ]
    , [ putS (show numDiscarded ++ " discarded")                     | numDiscarded > 0 ]
    , [ putS (show numShrinks   ++ " shrink" ++ singular numShrinks) | numShrinks   > 0 ]
    ]


runLabels :: (Has (Reader Handle) sig m, Has (State Tally) sig m, MonadIO m) => Status -> Stats -> [m ()]
runLabels s Stats{ numTests, labels }
  | null labels = []
  | otherwise   = IntMap.elems numberedLabels >>= \ m ->
    let sorted = sortBy (flip (comparing snd) <> flip (comparing fst)) (Map.toList m)
        scaled = map (fmap (\ v -> realToFrac v / n * 100)) sorted
        sparked = sparkify (Map.elems m)
        ln l = line *> stat success failure s (putS vline) *> putS l *> nl
    in
    [ for_ (enumerate scaled) $ \ (i, (key, v)) -> ln (i ++ (' ' <$ guard (v < 10)) ++ showFFloatAlt (Just 1) v "" ++ "% " ++ key)
    , do
      ln [ c | e <- sparked, c <- [e, e, e] ]
      ln [ c | k <- Map.keys m, i <- maybe [] (pure . succ) (elemIndex k (map fst sorted)), c <- ' ':show i ++ " " ] ]
  where
  numberedLabels = IntMap.fromListWith (Map.unionWith (+))
    [ (i, Map.singleton l n)
    | (labels, n) <- Map.toList labels
    , (i, l) <- zip [(0 :: Int)..] labels ]
  n = realToFrac numTests :: Double

enumerate :: [a] -> [(String, a)]
enumerate as = foldr (\ (i, a) as -> (show (i :: Int) ++ ". " ++ replicate (maxDigits - digits i) ' ', a):as) [] (zip [1 :: Int ..] as) where
  digits i = ceiling (logBase 10 (realToFrac (i + 1) :: Double))
  maxDigits = digits (length as)

runClasses :: (Has (Reader Handle) sig m, MonadIO m) => Stats -> [m ()]
runClasses Stats{ numTests = n, classes } = [ putS (intercalate ", " (map (uncurry (class_ n)) (Map.toList classes)) ++ ".") | not (null classes) ] where
  class_ n label n' = if n == n' then label else showFFloatAlt (Just 1) (fromIntegral n' / fromIntegral n * 100 :: Double) ('%':' ':label)

runTables :: Stats -> [m ()]
runTables _ = []


plural :: Int -> a -> a -> a
plural 1 s _ = s
plural _ _ p = p

singular :: Int -> String
singular 1 = "s"
singular _ = ""

runTally :: (Has (Reader Handle) sig m, MonadIO m) => Tally -> m ()
runTally t = sepBy_ (putS ", " ) (map success (tally "✓" "success" "successes" (successes t)) ++ map failure (tally "✗" "failure" "failures"  (failures t))) *> putS "." *> nl
  where
  tally prefix s p n = [ sepBy_ (putS " ") [ putS prefix, putS (show n), putS (plural n s p) ] | n /= 0 ]