{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

module Hedgehog.Internal.Report (
  -- * Report
    Summary(..)
  , Report(..)
  , Progress(..)
  , Result(..)
  , FailureReport(..)
  , FailedAnnotation(..)

  , Style(..)
  , Markup(..)

  , renderProgress
  , renderResult
  , renderSummary
  , renderDoc

  , ppProgress
  , ppResult
  , ppSummary

  , fromResult
  , mkFailure
  ) where

import           Control.Monad (zipWithM)
import           Control.Monad.IO.Class (MonadIO(..))
import           Control.Monad.Trans.Maybe (MaybeT(..))

import           Data.Bifunctor (bimap, first, second)
import qualified Data.Char as Char
import           Data.Either (partitionEithers)
import qualified Data.List as List
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Maybe (mapMaybe, catMaybes)
#if !MIN_VERSION_base(4,11,0)
import qualified Data.Semigroup as Semigroup
#endif
import           Data.Traversable (for)

import           Hedgehog.Internal.Config
import           Hedgehog.Internal.Discovery (Pos(..), Position(..))
import qualified Hedgehog.Internal.Discovery as Discovery
import           Hedgehog.Internal.Prelude
import           Hedgehog.Internal.Property (CoverCount(..), CoverPercentage(..))
import           Hedgehog.Internal.Property (Coverage(..), Label(..), LabelName(..))
import           Hedgehog.Internal.Property (PropertyName(..), Log(..), Diff(..))
import           Hedgehog.Internal.Property (ShrinkCount(..), PropertyCount(..))
import           Hedgehog.Internal.Property (TestCount(..), DiscardCount(..))
import           Hedgehog.Internal.Property (coverPercentage, coverageFailures)
import           Hedgehog.Internal.Property (labelCovered)
import           Hedgehog.Internal.Property (ShrinkPath(..), skipCompress)

import           Hedgehog.Internal.Show
import           Hedgehog.Internal.Source

import           System.Console.ANSI (ColorIntensity(..), Color(..))
import           System.Console.ANSI (ConsoleLayer(..), ConsoleIntensity(..))
import           System.Console.ANSI (SGR(..), setSGRCode)
import           System.Directory (makeRelativeToCurrentDirectory)

#if mingw32_HOST_OS
import           System.IO (hSetEncoding, stdout, stderr, utf8)
#endif

import           Text.PrettyPrint.Annotated.WL (Doc, (<#>), (<+>))
import qualified Text.PrettyPrint.Annotated.WL as WL
import           Text.Printf (printf)

------------------------------------------------------------------------
-- Data

data FailedAnnotation =
  FailedAnnotation {
      FailedAnnotation -> Maybe Span
failedSpan :: !(Maybe Span)
    , FailedAnnotation -> String
failedValue :: !String
    } deriving (FailedAnnotation -> FailedAnnotation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FailedAnnotation -> FailedAnnotation -> Bool
$c/= :: FailedAnnotation -> FailedAnnotation -> Bool
== :: FailedAnnotation -> FailedAnnotation -> Bool
$c== :: FailedAnnotation -> FailedAnnotation -> Bool
Eq, Int -> FailedAnnotation -> ShowS
[FailedAnnotation] -> ShowS
FailedAnnotation -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FailedAnnotation] -> ShowS
$cshowList :: [FailedAnnotation] -> ShowS
show :: FailedAnnotation -> String
$cshow :: FailedAnnotation -> String
showsPrec :: Int -> FailedAnnotation -> ShowS
$cshowsPrec :: Int -> FailedAnnotation -> ShowS
Show)

data FailureReport =
  FailureReport {
      FailureReport -> ShrinkCount
failureShrinks :: !ShrinkCount
    , FailureReport -> ShrinkPath
failureShrinkPath :: !ShrinkPath
    , FailureReport -> Maybe (Coverage CoverCount)
failureCoverage :: !(Maybe (Coverage CoverCount))
    , FailureReport -> [FailedAnnotation]
failureAnnotations :: ![FailedAnnotation]
    , FailureReport -> Maybe Span
failureLocation :: !(Maybe Span)
    , FailureReport -> String
failureMessage :: !String
    , FailureReport -> Maybe Diff
failureDiff :: !(Maybe Diff)
    , FailureReport -> [String]
failureFootnotes :: ![String]
    } deriving (FailureReport -> FailureReport -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FailureReport -> FailureReport -> Bool
$c/= :: FailureReport -> FailureReport -> Bool
== :: FailureReport -> FailureReport -> Bool
$c== :: FailureReport -> FailureReport -> Bool
Eq, Int -> FailureReport -> ShowS
[FailureReport] -> ShowS
FailureReport -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FailureReport] -> ShowS
$cshowList :: [FailureReport] -> ShowS
show :: FailureReport -> String
$cshow :: FailureReport -> String
showsPrec :: Int -> FailureReport -> ShowS
$cshowsPrec :: Int -> FailureReport -> ShowS
Show)

-- | The status of a running property test.
--
data Progress =
    Running
  | Shrinking !FailureReport
    deriving (Progress -> Progress -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Progress -> Progress -> Bool
$c/= :: Progress -> Progress -> Bool
== :: Progress -> Progress -> Bool
$c== :: Progress -> Progress -> Bool
Eq, Int -> Progress -> ShowS
[Progress] -> ShowS
Progress -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Progress] -> ShowS
$cshowList :: [Progress] -> ShowS
show :: Progress -> String
$cshow :: Progress -> String
showsPrec :: Int -> Progress -> ShowS
$cshowsPrec :: Int -> Progress -> ShowS
Show)

-- | The status of a completed property test.
--
--   In the case of a failure it provides the seed used for the test, the
--   number of shrinks, and the execution log.
--
data Result =
    Failed !FailureReport
  | GaveUp
  | OK
    deriving (Result -> Result -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result -> Result -> Bool
$c/= :: Result -> Result -> Bool
== :: Result -> Result -> Bool
$c== :: Result -> Result -> Bool
Eq, Int -> Result -> ShowS
[Result] -> ShowS
Result -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result] -> ShowS
$cshowList :: [Result] -> ShowS
show :: Result -> String
$cshow :: Result -> String
showsPrec :: Int -> Result -> ShowS
$cshowsPrec :: Int -> Result -> ShowS
Show)

-- | A report on a running or completed property test.
--
data Report a =
  Report {
      forall a. Report a -> TestCount
reportTests :: !TestCount
    , forall a. Report a -> DiscardCount
reportDiscards :: !DiscardCount
    , forall a. Report a -> Coverage CoverCount
reportCoverage :: !(Coverage CoverCount)
    , forall a. Report a -> Seed
reportSeed :: !Seed
    , forall a. Report a -> a
reportStatus :: !a
    } deriving (Int -> Report a -> ShowS
forall a. Show a => Int -> Report a -> ShowS
forall a. Show a => [Report a] -> ShowS
forall a. Show a => Report a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Report a] -> ShowS
$cshowList :: forall a. Show a => [Report a] -> ShowS
show :: Report a -> String
$cshow :: forall a. Show a => Report a -> String
showsPrec :: Int -> Report a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Report a -> ShowS
Show, forall a b. a -> Report b -> Report a
forall a b. (a -> b) -> Report a -> Report b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Report b -> Report a
$c<$ :: forall a b. a -> Report b -> Report a
fmap :: forall a b. (a -> b) -> Report a -> Report b
$cfmap :: forall a b. (a -> b) -> Report a -> Report b
Functor, forall a. Eq a => a -> Report a -> Bool
forall a. Num a => Report a -> a
forall a. Ord a => Report a -> a
forall m. Monoid m => Report m -> m
forall a. Report a -> Bool
forall a. Report a -> Int
forall a. Report a -> [a]
forall a. (a -> a -> a) -> Report a -> a
forall m a. Monoid m => (a -> m) -> Report a -> m
forall b a. (b -> a -> b) -> b -> Report a -> b
forall a b. (a -> b -> b) -> b -> Report a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Report a -> a
$cproduct :: forall a. Num a => Report a -> a
sum :: forall a. Num a => Report a -> a
$csum :: forall a. Num a => Report a -> a
minimum :: forall a. Ord a => Report a -> a
$cminimum :: forall a. Ord a => Report a -> a
maximum :: forall a. Ord a => Report a -> a
$cmaximum :: forall a. Ord a => Report a -> a
elem :: forall a. Eq a => a -> Report a -> Bool
$celem :: forall a. Eq a => a -> Report a -> Bool
length :: forall a. Report a -> Int
$clength :: forall a. Report a -> Int
null :: forall a. Report a -> Bool
$cnull :: forall a. Report a -> Bool
toList :: forall a. Report a -> [a]
$ctoList :: forall a. Report a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Report a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Report a -> a
foldr1 :: forall a. (a -> a -> a) -> Report a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Report a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Report a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Report a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Report a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Report a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Report a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Report a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Report a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Report a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Report a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Report a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Report a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Report a -> m
fold :: forall m. Monoid m => Report m -> m
$cfold :: forall m. Monoid m => Report m -> m
Foldable, Functor Report
Foldable Report
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Report (m a) -> m (Report a)
forall (f :: * -> *) a.
Applicative f =>
Report (f a) -> f (Report a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Report a -> m (Report b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Report a -> f (Report b)
sequence :: forall (m :: * -> *) a. Monad m => Report (m a) -> m (Report a)
$csequence :: forall (m :: * -> *) a. Monad m => Report (m a) -> m (Report a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Report a -> m (Report b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Report a -> m (Report b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Report (f a) -> f (Report a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Report (f a) -> f (Report a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Report a -> f (Report b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Report a -> f (Report b)
Traversable)

-- | A summary of all the properties executed.
--
data Summary =
  Summary {
      Summary -> PropertyCount
summaryWaiting :: !PropertyCount
    , Summary -> PropertyCount
summaryRunning :: !PropertyCount
    , Summary -> PropertyCount
summaryFailed :: !PropertyCount
    , Summary -> PropertyCount
summaryGaveUp :: !PropertyCount
    , Summary -> PropertyCount
summaryOK :: !PropertyCount
    } deriving (Int -> Summary -> ShowS
[Summary] -> ShowS
Summary -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Summary] -> ShowS
$cshowList :: [Summary] -> ShowS
show :: Summary -> String
$cshow :: Summary -> String
showsPrec :: Int -> Summary -> ShowS
$cshowsPrec :: Int -> Summary -> ShowS
Show)

instance Monoid Summary where
#if !MIN_VERSION_base(4,11,0)
  mappend = (Semigroup.<>)
#endif
  mempty :: Summary
mempty =
    PropertyCount
-> PropertyCount
-> PropertyCount
-> PropertyCount
-> PropertyCount
-> Summary
Summary PropertyCount
0 PropertyCount
0 PropertyCount
0 PropertyCount
0 PropertyCount
0

instance Semigroup Summary where
  Summary PropertyCount
x1 PropertyCount
x2 PropertyCount
x3 PropertyCount
x4 PropertyCount
x5 <> :: Summary -> Summary -> Summary
<> Summary PropertyCount
y1 PropertyCount
y2 PropertyCount
y3 PropertyCount
y4 PropertyCount
y5 =
    PropertyCount
-> PropertyCount
-> PropertyCount
-> PropertyCount
-> PropertyCount
-> Summary
Summary
      (PropertyCount
x1 forall a. Num a => a -> a -> a
+ PropertyCount
y1)
      (PropertyCount
x2 forall a. Num a => a -> a -> a
+ PropertyCount
y2)
      (PropertyCount
x3 forall a. Num a => a -> a -> a
+ PropertyCount
y3)
      (PropertyCount
x4 forall a. Num a => a -> a -> a
+ PropertyCount
y4)
      (PropertyCount
x5 forall a. Num a => a -> a -> a
+ PropertyCount
y5)

-- | Construct a summary from a single result.
--
fromResult :: Result -> Summary
fromResult :: Result -> Summary
fromResult = \case
  Failed FailureReport
_ ->
    forall a. Monoid a => a
mempty { summaryFailed :: PropertyCount
summaryFailed = PropertyCount
1 }
  Result
GaveUp ->
    forall a. Monoid a => a
mempty { summaryGaveUp :: PropertyCount
summaryGaveUp = PropertyCount
1 }
  Result
OK ->
    forall a. Monoid a => a
mempty { summaryOK :: PropertyCount
summaryOK = PropertyCount
1 }

summaryCompleted :: Summary -> PropertyCount
summaryCompleted :: Summary -> PropertyCount
summaryCompleted (Summary PropertyCount
_ PropertyCount
_ PropertyCount
x3 PropertyCount
x4 PropertyCount
x5) =
  PropertyCount
x3 forall a. Num a => a -> a -> a
+ PropertyCount
x4 forall a. Num a => a -> a -> a
+ PropertyCount
x5

summaryTotal :: Summary -> PropertyCount
summaryTotal :: Summary -> PropertyCount
summaryTotal (Summary PropertyCount
x1 PropertyCount
x2 PropertyCount
x3 PropertyCount
x4 PropertyCount
x5) =
  PropertyCount
x1 forall a. Num a => a -> a -> a
+ PropertyCount
x2 forall a. Num a => a -> a -> a
+ PropertyCount
x3 forall a. Num a => a -> a -> a
+ PropertyCount
x4 forall a. Num a => a -> a -> a
+ PropertyCount
x5

------------------------------------------------------------------------
-- Pretty Printing Helpers

data Line a =
  Line {
      forall a. Line a -> a
_lineAnnotation :: !a
    , forall a. Line a -> LineNo
lineNumber :: !LineNo
    , forall a. Line a -> String
_lineSource :: !String
    } deriving (Line a -> Line a -> Bool
forall a. Eq a => Line a -> Line a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Line a -> Line a -> Bool
$c/= :: forall a. Eq a => Line a -> Line a -> Bool
== :: Line a -> Line a -> Bool
$c== :: forall a. Eq a => Line a -> Line a -> Bool
Eq, Line a -> Line a -> Bool
Line a -> Line a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (Line a)
forall a. Ord a => Line a -> Line a -> Bool
forall a. Ord a => Line a -> Line a -> Ordering
forall a. Ord a => Line a -> Line a -> Line a
min :: Line a -> Line a -> Line a
$cmin :: forall a. Ord a => Line a -> Line a -> Line a
max :: Line a -> Line a -> Line a
$cmax :: forall a. Ord a => Line a -> Line a -> Line a
>= :: Line a -> Line a -> Bool
$c>= :: forall a. Ord a => Line a -> Line a -> Bool
> :: Line a -> Line a -> Bool
$c> :: forall a. Ord a => Line a -> Line a -> Bool
<= :: Line a -> Line a -> Bool
$c<= :: forall a. Ord a => Line a -> Line a -> Bool
< :: Line a -> Line a -> Bool
$c< :: forall a. Ord a => Line a -> Line a -> Bool
compare :: Line a -> Line a -> Ordering
$ccompare :: forall a. Ord a => Line a -> Line a -> Ordering
Ord, Int -> Line a -> ShowS
forall a. Show a => Int -> Line a -> ShowS
forall a. Show a => [Line a] -> ShowS
forall a. Show a => Line a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Line a] -> ShowS
$cshowList :: forall a. Show a => [Line a] -> ShowS
show :: Line a -> String
$cshow :: forall a. Show a => Line a -> String
showsPrec :: Int -> Line a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Line a -> ShowS
Show, forall a b. a -> Line b -> Line a
forall a b. (a -> b) -> Line a -> Line b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Line b -> Line a
$c<$ :: forall a b. a -> Line b -> Line a
fmap :: forall a b. (a -> b) -> Line a -> Line b
$cfmap :: forall a b. (a -> b) -> Line a -> Line b
Functor)

data Declaration a =
  Declaration {
      forall a. Declaration a -> String
declarationFile :: !FilePath
    , forall a. Declaration a -> LineNo
declarationLine :: !LineNo
    , forall a. Declaration a -> String
_declarationName :: !String
    , forall a. Declaration a -> Map LineNo (Line a)
declarationSource :: !(Map LineNo (Line a))
    } deriving (Declaration a -> Declaration a -> Bool
forall a. Eq a => Declaration a -> Declaration a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Declaration a -> Declaration a -> Bool
$c/= :: forall a. Eq a => Declaration a -> Declaration a -> Bool
== :: Declaration a -> Declaration a -> Bool
$c== :: forall a. Eq a => Declaration a -> Declaration a -> Bool
Eq, Declaration a -> Declaration a -> Bool
Declaration a -> Declaration a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (Declaration a)
forall a. Ord a => Declaration a -> Declaration a -> Bool
forall a. Ord a => Declaration a -> Declaration a -> Ordering
forall a. Ord a => Declaration a -> Declaration a -> Declaration a
min :: Declaration a -> Declaration a -> Declaration a
$cmin :: forall a. Ord a => Declaration a -> Declaration a -> Declaration a
max :: Declaration a -> Declaration a -> Declaration a
$cmax :: forall a. Ord a => Declaration a -> Declaration a -> Declaration a
>= :: Declaration a -> Declaration a -> Bool
$c>= :: forall a. Ord a => Declaration a -> Declaration a -> Bool
> :: Declaration a -> Declaration a -> Bool
$c> :: forall a. Ord a => Declaration a -> Declaration a -> Bool
<= :: Declaration a -> Declaration a -> Bool
$c<= :: forall a. Ord a => Declaration a -> Declaration a -> Bool
< :: Declaration a -> Declaration a -> Bool
$c< :: forall a. Ord a => Declaration a -> Declaration a -> Bool
compare :: Declaration a -> Declaration a -> Ordering
$ccompare :: forall a. Ord a => Declaration a -> Declaration a -> Ordering
Ord, Int -> Declaration a -> ShowS
forall a. Show a => Int -> Declaration a -> ShowS
forall a. Show a => [Declaration a] -> ShowS
forall a. Show a => Declaration a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Declaration a] -> ShowS
$cshowList :: forall a. Show a => [Declaration a] -> ShowS
show :: Declaration a -> String
$cshow :: forall a. Show a => Declaration a -> String
showsPrec :: Int -> Declaration a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Declaration a -> ShowS
Show, forall a b. a -> Declaration b -> Declaration a
forall a b. (a -> b) -> Declaration a -> Declaration b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Declaration b -> Declaration a
$c<$ :: forall a b. a -> Declaration b -> Declaration a
fmap :: forall a b. (a -> b) -> Declaration a -> Declaration b
$cfmap :: forall a b. (a -> b) -> Declaration a -> Declaration b
Functor)

data Style =
    StyleDefault
  | StyleAnnotation
  | StyleFailure
    deriving (Style -> Style -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Style -> Style -> Bool
$c/= :: Style -> Style -> Bool
== :: Style -> Style -> Bool
$c== :: Style -> Style -> Bool
Eq, Eq Style
Style -> Style -> Bool
Style -> Style -> Ordering
Style -> Style -> Style
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Style -> Style -> Style
$cmin :: Style -> Style -> Style
max :: Style -> Style -> Style
$cmax :: Style -> Style -> Style
>= :: Style -> Style -> Bool
$c>= :: Style -> Style -> Bool
> :: Style -> Style -> Bool
$c> :: Style -> Style -> Bool
<= :: Style -> Style -> Bool
$c<= :: Style -> Style -> Bool
< :: Style -> Style -> Bool
$c< :: Style -> Style -> Bool
compare :: Style -> Style -> Ordering
$ccompare :: Style -> Style -> Ordering
Ord, Int -> Style -> ShowS
[Style] -> ShowS
Style -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Style] -> ShowS
$cshowList :: [Style] -> ShowS
show :: Style -> String
$cshow :: Style -> String
showsPrec :: Int -> Style -> ShowS
$cshowsPrec :: Int -> Style -> ShowS
Show)

data Markup =
    WaitingIcon
  | WaitingHeader
  | RunningIcon
  | RunningHeader
  | ShrinkingIcon
  | ShrinkingHeader
  | FailedIcon
  | FailedText
  | GaveUpIcon
  | GaveUpText
  | SuccessIcon
  | SuccessText
  | CoverageIcon
  | CoverageText
  | CoverageFill
  | DeclarationLocation
  | StyledLineNo !Style
  | StyledBorder !Style
  | StyledSource !Style
  | AnnotationGutter
  | AnnotationValue
  | FailureArrows
  | FailureGutter
  | FailureMessage
  | DiffPrefix
  | DiffInfix
  | DiffSuffix
  | DiffSame
  | DiffRemoved
  | DiffAdded
  | ReproduceHeader
  | ReproduceGutter
  | ReproduceSource
    deriving (Markup -> Markup -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Markup -> Markup -> Bool
$c/= :: Markup -> Markup -> Bool
== :: Markup -> Markup -> Bool
$c== :: Markup -> Markup -> Bool
Eq, Eq Markup
Markup -> Markup -> Bool
Markup -> Markup -> Ordering
Markup -> Markup -> Markup
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Markup -> Markup -> Markup
$cmin :: Markup -> Markup -> Markup
max :: Markup -> Markup -> Markup
$cmax :: Markup -> Markup -> Markup
>= :: Markup -> Markup -> Bool
$c>= :: Markup -> Markup -> Bool
> :: Markup -> Markup -> Bool
$c> :: Markup -> Markup -> Bool
<= :: Markup -> Markup -> Bool
$c<= :: Markup -> Markup -> Bool
< :: Markup -> Markup -> Bool
$c< :: Markup -> Markup -> Bool
compare :: Markup -> Markup -> Ordering
$ccompare :: Markup -> Markup -> Ordering
Ord, Int -> Markup -> ShowS
[Markup] -> ShowS
Markup -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Markup] -> ShowS
$cshowList :: [Markup] -> ShowS
show :: Markup -> String
$cshow :: Markup -> String
showsPrec :: Int -> Markup -> ShowS
$cshowsPrec :: Int -> Markup -> ShowS
Show)

instance Semigroup Style where
  <> :: Style -> Style -> Style
(<>) Style
x Style
y =
    case (Style
x, Style
y) of
      (Style
StyleFailure, Style
_) ->
        Style
StyleFailure
      (Style
_, Style
StyleFailure) ->
        Style
StyleFailure
      (Style
StyleAnnotation, Style
_) ->
        Style
StyleAnnotation
      (Style
_, Style
StyleAnnotation) ->
        Style
StyleAnnotation
      (Style
StyleDefault, Style
_) ->
        Style
StyleDefault

------------------------------------------------------------------------

takeAnnotation :: Log -> Maybe FailedAnnotation
takeAnnotation :: Log -> Maybe FailedAnnotation
takeAnnotation = \case
  Annotation Maybe Span
loc String
val ->
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Maybe Span -> String -> FailedAnnotation
FailedAnnotation Maybe Span
loc String
val
  Log
_ ->
    forall a. Maybe a
Nothing

takeFootnote :: Log -> Maybe String
takeFootnote :: Log -> Maybe String
takeFootnote = \case
  Footnote String
x ->
    forall a. a -> Maybe a
Just String
x
  Log
_ ->
    forall a. Maybe a
Nothing

mkFailure ::
     ShrinkCount
  -> ShrinkPath
  -> Maybe (Coverage CoverCount)
  -> Maybe Span
  -> String
  -> Maybe Diff
  -> [Log]
  -> FailureReport
mkFailure :: ShrinkCount
-> ShrinkPath
-> Maybe (Coverage CoverCount)
-> Maybe Span
-> String
-> Maybe Diff
-> [Log]
-> FailureReport
mkFailure ShrinkCount
shrinks ShrinkPath
shrinkPath Maybe (Coverage CoverCount)
mcoverage Maybe Span
location String
message Maybe Diff
diff [Log]
logs =
  let
    inputs :: [FailedAnnotation]
inputs =
      forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Log -> Maybe FailedAnnotation
takeAnnotation [Log]
logs

    footnotes :: [String]
footnotes =
      forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Log -> Maybe String
takeFootnote [Log]
logs
  in
    ShrinkCount
-> ShrinkPath
-> Maybe (Coverage CoverCount)
-> [FailedAnnotation]
-> Maybe Span
-> String
-> Maybe Diff
-> [String]
-> FailureReport
FailureReport ShrinkCount
shrinks ShrinkPath
shrinkPath Maybe (Coverage CoverCount)
mcoverage [FailedAnnotation]
inputs Maybe Span
location String
message Maybe Diff
diff [String]
footnotes

------------------------------------------------------------------------
-- Pretty Printing

ppShow :: Show x => x -> Doc a
ppShow :: forall x a. Show x => x -> Doc a
ppShow = -- unfortunate naming clash
  forall a. String -> Doc a
WL.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

markup :: Markup -> Doc Markup -> Doc Markup
markup :: Markup -> Doc Markup -> Doc Markup
markup =
  forall a. a -> Doc a -> Doc a
WL.annotate

gutter :: Markup -> Doc Markup -> Doc Markup
gutter :: Markup -> Doc Markup -> Doc Markup
gutter Markup
m Doc Markup
x =
  Markup -> Doc Markup -> Doc Markup
markup Markup
m Doc Markup
">" forall a. Doc a -> Doc a -> Doc a
<+> Doc Markup
x

icon :: Markup -> Char -> Doc Markup -> Doc Markup
icon :: Markup -> Char -> Doc Markup -> Doc Markup
icon Markup
m Char
i Doc Markup
x =
  Markup -> Doc Markup -> Doc Markup
markup Markup
m (forall a. Char -> Doc a
WL.char Char
i) forall a. Doc a -> Doc a -> Doc a
<+> Doc Markup
x

ppTestCount :: TestCount -> Doc a
ppTestCount :: forall a. TestCount -> Doc a
ppTestCount = \case
  TestCount Int
1 ->
    Doc a
"1 test"
  TestCount Int
n ->
    forall x a. Show x => x -> Doc a
ppShow Int
n forall a. Doc a -> Doc a -> Doc a
<+> Doc a
"tests"

ppDiscardCount :: DiscardCount -> Doc a
ppDiscardCount :: forall a. DiscardCount -> Doc a
ppDiscardCount = \case
  DiscardCount Int
1 ->
    Doc a
"1 discard"
  DiscardCount Int
n ->
    forall x a. Show x => x -> Doc a
ppShow Int
n forall a. Doc a -> Doc a -> Doc a
<+> Doc a
"discards"

ppShrinkCount :: ShrinkCount -> Doc a
ppShrinkCount :: forall a. ShrinkCount -> Doc a
ppShrinkCount = \case
  ShrinkCount Int
1 ->
    Doc a
"1 shrink"
  ShrinkCount Int
n ->
    forall x a. Show x => x -> Doc a
ppShow Int
n forall a. Doc a -> Doc a -> Doc a
<+> Doc a
"shrinks"

-- | Render a compressed 'Skip'.
--
ppSkip :: Skip -> Doc a
ppSkip :: forall a. Skip -> Doc a
ppSkip =
  forall a. String -> Doc a
WL.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. Skip -> String
skipCompress

-- | Render a compressed 'Skip', such that it can be read back in.
--
ppSkipReadable :: Skip -> Doc a
ppSkipReadable :: forall a. Skip -> Doc a
ppSkipReadable =
  forall a. String -> Doc a
WL.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. Skip -> String
skipCompress

ppRawPropertyCount :: PropertyCount -> Doc a
ppRawPropertyCount :: forall a. PropertyCount -> Doc a
ppRawPropertyCount (PropertyCount Int
n) =
  forall x a. Show x => x -> Doc a
ppShow Int
n

ppWithDiscardCount :: DiscardCount -> Doc Markup
ppWithDiscardCount :: DiscardCount -> Doc Markup
ppWithDiscardCount = \case
  DiscardCount Int
0 ->
    forall a. Monoid a => a
mempty
  DiscardCount
n ->
    Doc Markup
" with" forall a. Doc a -> Doc a -> Doc a
<+> forall a. DiscardCount -> Doc a
ppDiscardCount DiscardCount
n

ppShrinkDiscard :: ShrinkCount -> DiscardCount -> Doc Markup
ppShrinkDiscard :: ShrinkCount -> DiscardCount -> Doc Markup
ppShrinkDiscard ShrinkCount
s DiscardCount
d =
  case (ShrinkCount
s, DiscardCount
d) of
    (ShrinkCount
0, DiscardCount
0) ->
      Doc Markup
""
    (ShrinkCount
0, DiscardCount
_) ->
      Doc Markup
" and" forall a. Doc a -> Doc a -> Doc a
<+> forall a. DiscardCount -> Doc a
ppDiscardCount DiscardCount
d
    (ShrinkCount
_, DiscardCount
0) ->
      Doc Markup
" and" forall a. Doc a -> Doc a -> Doc a
<+> forall a. ShrinkCount -> Doc a
ppShrinkCount ShrinkCount
s
    (ShrinkCount
_, DiscardCount
_) ->
      Doc Markup
"," forall a. Doc a -> Doc a -> Doc a
<+> forall a. ShrinkCount -> Doc a
ppShrinkCount ShrinkCount
s forall a. Doc a -> Doc a -> Doc a
<+> Doc Markup
"and" forall a. Doc a -> Doc a -> Doc a
<+> forall a. DiscardCount -> Doc a
ppDiscardCount DiscardCount
d

mapSource :: (Map LineNo (Line a) -> Map LineNo (Line a)) -> Declaration a -> Declaration a
mapSource :: forall a.
(Map LineNo (Line a) -> Map LineNo (Line a))
-> Declaration a -> Declaration a
mapSource Map LineNo (Line a) -> Map LineNo (Line a)
f Declaration a
decl =
  Declaration a
decl {
      declarationSource :: Map LineNo (Line a)
declarationSource =
        Map LineNo (Line a) -> Map LineNo (Line a)
f (forall a. Declaration a -> Map LineNo (Line a)
declarationSource Declaration a
decl)
    }

-- | The span of non-whitespace characters for the line.
--
--   The result is @[inclusive, exclusive)@.
--
lineSpan :: Line a -> (ColumnNo, ColumnNo)
lineSpan :: forall a. Line a -> (ColumnNo, ColumnNo)
lineSpan (Line a
_ LineNo
_ String
x0) =
  let
    (String
pre, String
x1) =
      forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
Char.isSpace String
x0

    (String
_, String
x2) =
      forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
Char.isSpace (forall a. [a] -> [a]
reverse String
x1)

    start :: Int
start =
      forall (t :: * -> *) a. Foldable t => t a -> Int
length String
pre

    end :: Int
end =
      Int
start forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length String
x2
  in
    (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
start, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
end)

takeLines :: Span -> Declaration a -> Map LineNo (Line a)
takeLines :: forall a. Span -> Declaration a -> Map LineNo (Line a)
takeLines Span
sloc =
  forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> (Map k a, Map k a)
Map.split (Span -> LineNo
spanEndLine Span
sloc forall a. Num a => a -> a -> a
+ LineNo
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> (Map k a, Map k a)
Map.split (Span -> LineNo
spanStartLine Span
sloc forall a. Num a => a -> a -> a
- LineNo
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall a. Declaration a -> Map LineNo (Line a)
declarationSource

readDeclaration :: MonadIO m => Span -> m (Maybe (Declaration ()))
readDeclaration :: forall (m :: * -> *).
MonadIO m =>
Span -> m (Maybe (Declaration ()))
readDeclaration Span
sloc =
  forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
    String
path <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO String
makeRelativeToCurrentDirectory forall a b. (a -> b) -> a -> b
$ Span -> String
spanFile Span
sloc

    (String
name, Pos (Position String
_ LineNo
line0 ColumnNo
_) String
src) <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *).
MonadIO m =>
String -> LineNo -> m (Maybe (String, Pos String))
Discovery.readDeclaration String
path (Span -> LineNo
spanEndLine Span
sloc)

    let
      line :: LineNo
line =
        forall a b. (Integral a, Num b) => a -> b
fromIntegral LineNo
line0

    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
String -> LineNo -> String -> Map LineNo (Line a) -> Declaration a
Declaration String
path LineNo
line String
name forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      forall a b. [a] -> [b] -> [(a, b)]
zip [LineNo
line..] forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall a. a -> LineNo -> String -> Line a
Line ()) [LineNo
line..] forall a b. (a -> b) -> a -> b
$
      String -> [String]
lines String
src


defaultStyle :: Declaration a -> Declaration (Style, [(Style, Doc Markup)])
defaultStyle :: forall a.
Declaration a -> Declaration (Style, [(Style, Doc Markup)])
defaultStyle =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (Style
StyleDefault, [])

lastLineSpan :: Monad m => Span -> Declaration a -> MaybeT m (ColumnNo, ColumnNo)
lastLineSpan :: forall (m :: * -> *) a.
Monad m =>
Span -> Declaration a -> MaybeT m (ColumnNo, ColumnNo)
lastLineSpan Span
sloc Declaration a
decl =
  case forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ forall a. Span -> Declaration a -> Map LineNo (Line a)
takeLines Span
sloc Declaration a
decl of
    [] ->
      forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Line a
x : [Line a]
_ ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        forall a. Line a -> (ColumnNo, ColumnNo)
lineSpan Line a
x

ppFailedInputTypedArgument :: Int -> FailedAnnotation -> Doc Markup
ppFailedInputTypedArgument :: Int -> FailedAnnotation -> Doc Markup
ppFailedInputTypedArgument Int
ix (FailedAnnotation Maybe Span
_ String
val) =
  forall (f :: * -> *) a. Foldable f => f (Doc a) -> Doc a
WL.vsep [
      forall a. String -> Doc a
WL.text String
"forAll" forall a. Semigroup a => a -> a -> a
<> forall x a. Show x => x -> Doc a
ppShow Int
ix forall a. Doc a -> Doc a -> Doc a
<+> Doc Markup
"="
    , forall a. Int -> Doc a -> Doc a
WL.indent Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => f (Doc a) -> Doc a
WL.vsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Markup -> Doc Markup -> Doc Markup
markup Markup
AnnotationValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> Doc a
WL.text) forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
val
    ]

ppFailedInputDeclaration ::
     MonadIO m
  => FailedAnnotation
  -> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
ppFailedInputDeclaration :: forall (m :: * -> *).
MonadIO m =>
FailedAnnotation
-> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
ppFailedInputDeclaration (FailedAnnotation Maybe Span
msloc String
val) =
  forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
    Span
sloc <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Span
msloc
    Declaration (Style, [(Style, Doc Markup)])
decl <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a.
Declaration a -> Declaration (Style, [(Style, Doc Markup)])
defaultStyle forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Span -> m (Maybe (Declaration ()))
readDeclaration Span
sloc
    Int
startCol <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
Monad m =>
Span -> Declaration a -> MaybeT m (ColumnNo, ColumnNo)
lastLineSpan Span
sloc Declaration (Style, [(Style, Doc Markup)])
decl

    let
      ppValLine :: String -> Doc Markup
ppValLine =
        forall a. Int -> Doc a -> Doc a
WL.indent Int
startCol forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          (Markup -> Doc Markup -> Doc Markup
markup Markup
AnnotationGutter (forall a. String -> Doc a
WL.text String
"│ ") forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          Markup -> Doc Markup -> Doc Markup
markup Markup
AnnotationValue forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          forall a. String -> Doc a
WL.text

      valDocs :: [(Style, Doc Markup)]
valDocs =
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Style
StyleAnnotation, ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc Markup
ppValLine) forall a b. (a -> b) -> a -> b
$
        String -> [String]
List.lines String
val

      startLine :: LineNo
startLine =
        forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Span -> LineNo
spanStartLine Span
sloc

      endLine :: LineNo
endLine =
        forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Span -> LineNo
spanEndLine Span
sloc

      styleInput :: Map LineNo (f (p Style c)) -> Map LineNo (f (p Style c))
styleInput Map LineNo (f (p Style c))
kvs =
        forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const Style
StyleAnnotation) Map LineNo (f (p Style c))
kvs [LineNo
startLine..LineNo
endLine]

      insertDoc :: Map LineNo (Line (a, [(Style, Doc Markup)]))
-> Map LineNo (Line (a, [(Style, Doc Markup)]))
insertDoc =
        forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const [(Style, Doc Markup)]
valDocs) LineNo
endLine

    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
      forall a.
(Map LineNo (Line a) -> Map LineNo (Line a))
-> Declaration a -> Declaration a
mapSource (forall {f :: * -> *} {p :: * -> * -> *} {c}.
(Functor f, Bifunctor p) =>
Map LineNo (f (p Style c)) -> Map LineNo (f (p Style c))
styleInput forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}.
Map LineNo (Line (a, [(Style, Doc Markup)]))
-> Map LineNo (Line (a, [(Style, Doc Markup)]))
insertDoc) Declaration (Style, [(Style, Doc Markup)])
decl

ppFailedInput ::
     MonadIO m
  => Int
  -> FailedAnnotation
  -> m (Either (Doc Markup) (Declaration (Style, [(Style, Doc Markup)])))
ppFailedInput :: forall (m :: * -> *).
MonadIO m =>
Int
-> FailedAnnotation
-> m (Either
        (Doc Markup) (Declaration (Style, [(Style, Doc Markup)])))
ppFailedInput Int
ix FailedAnnotation
input = do
  Maybe (Declaration (Style, [(Style, Doc Markup)]))
mdecl <- forall (m :: * -> *).
MonadIO m =>
FailedAnnotation
-> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
ppFailedInputDeclaration FailedAnnotation
input
  case Maybe (Declaration (Style, [(Style, Doc Markup)]))
mdecl of
    Maybe (Declaration (Style, [(Style, Doc Markup)]))
Nothing ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Int -> FailedAnnotation -> Doc Markup
ppFailedInputTypedArgument Int
ix FailedAnnotation
input
    Just Declaration (Style, [(Style, Doc Markup)])
decl ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Declaration (Style, [(Style, Doc Markup)])
decl

ppLineDiff :: LineDiff -> Doc Markup
ppLineDiff :: LineDiff -> Doc Markup
ppLineDiff = \case
  LineSame String
x ->
    Markup -> Doc Markup -> Doc Markup
markup Markup
DiffSame forall a b. (a -> b) -> a -> b
$
      Doc Markup
"  " forall a. Semigroup a => a -> a -> a
<> forall a. String -> Doc a
WL.text String
x

  LineRemoved String
x ->
    Markup -> Doc Markup -> Doc Markup
markup Markup
DiffRemoved forall a b. (a -> b) -> a -> b
$
      Doc Markup
"- " forall a. Semigroup a => a -> a -> a
<> forall a. String -> Doc a
WL.text String
x

  LineAdded String
x ->
    Markup -> Doc Markup -> Doc Markup
markup Markup
DiffAdded forall a b. (a -> b) -> a -> b
$
      Doc Markup
"+ " forall a. Semigroup a => a -> a -> a
<> forall a. String -> Doc a
WL.text String
x

ppDiff :: Diff -> [Doc Markup]
ppDiff :: Diff -> [Doc Markup]
ppDiff (Diff String
prefix String
removed String
infix_ String
added String
suffix ValueDiff
diff) = [
    Markup -> Doc Markup -> Doc Markup
markup Markup
DiffPrefix (forall a. String -> Doc a
WL.text String
prefix) forall a. Semigroup a => a -> a -> a
<>
    Markup -> Doc Markup -> Doc Markup
markup Markup
DiffRemoved (forall a. String -> Doc a
WL.text String
removed) forall a. Semigroup a => a -> a -> a
<>
    Markup -> Doc Markup -> Doc Markup
markup Markup
DiffInfix (forall a. String -> Doc a
WL.text String
infix_) forall a. Semigroup a => a -> a -> a
<>
    Markup -> Doc Markup -> Doc Markup
markup Markup
DiffAdded (forall a. String -> Doc a
WL.text String
added) forall a. Semigroup a => a -> a -> a
<>
    Markup -> Doc Markup -> Doc Markup
markup Markup
DiffSuffix (forall a. String -> Doc a
WL.text String
suffix)
  ] forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LineDiff -> Doc Markup
ppLineDiff (ValueDiff -> [LineDiff]
toLineDiff ValueDiff
diff)

ppFailureLocation ::
     MonadIO m
  => [Doc Markup]
  -> Maybe Diff
  -> Span
  -> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
ppFailureLocation :: forall (m :: * -> *).
MonadIO m =>
[Doc Markup]
-> Maybe Diff
-> Span
-> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
ppFailureLocation [Doc Markup]
msgs Maybe Diff
mdiff Span
sloc =
  forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
    Declaration (Style, [(Style, Doc Markup)])
decl <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a.
Declaration a -> Declaration (Style, [(Style, Doc Markup)])
defaultStyle forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Span -> m (Maybe (Declaration ()))
readDeclaration Span
sloc
    (Int
startCol, Int
endCol) <- forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
Monad m =>
Span -> Declaration a -> MaybeT m (ColumnNo, ColumnNo)
lastLineSpan Span
sloc Declaration (Style, [(Style, Doc Markup)])
decl

    let
      arrowDoc :: Doc Markup
arrowDoc =
        forall a. Int -> Doc a -> Doc a
WL.indent Int
startCol forall a b. (a -> b) -> a -> b
$
          Markup -> Doc Markup -> Doc Markup
markup Markup
FailureArrows (forall a. String -> Doc a
WL.text (forall a. Int -> a -> [a]
replicate (Int
endCol forall a. Num a => a -> a -> a
- Int
startCol) Char
'^'))

      ppFailure :: Doc Markup -> Doc Markup
ppFailure Doc Markup
x =
        forall a. Int -> Doc a -> Doc a
WL.indent Int
startCol forall a b. (a -> b) -> a -> b
$
          Markup -> Doc Markup -> Doc Markup
markup Markup
FailureGutter (forall a. String -> Doc a
WL.text String
"│ ") forall a. Semigroup a => a -> a -> a
<> Doc Markup
x

      msgDocs :: [(Style, Doc Markup)]
msgDocs =
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Style
StyleFailure, ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Markup -> Doc Markup
ppFailure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markup -> Doc Markup -> Doc Markup
markup Markup
FailureMessage) [Doc Markup]
msgs

      diffDocs :: [(Style, Doc Markup)]
diffDocs =
        case Maybe Diff
mdiff of
          Maybe Diff
Nothing ->
            []
          Just Diff
diff ->
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Style
StyleFailure, ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Markup -> Doc Markup
ppFailure) (Diff -> [Doc Markup]
ppDiff Diff
diff)

      docs :: [(Style, Doc Markup)]
docs =
        [(Style
StyleFailure, Doc Markup
arrowDoc)] forall a. [a] -> [a] -> [a]
++ [(Style, Doc Markup)]
msgDocs forall a. [a] -> [a] -> [a]
++ [(Style, Doc Markup)]
diffDocs

      startLine :: LineNo
startLine =
        Span -> LineNo
spanStartLine Span
sloc

      endLine :: LineNo
endLine =
        Span -> LineNo
spanEndLine Span
sloc

      styleFailure :: Map LineNo (f (p Style c)) -> Map LineNo (f (p Style c))
styleFailure Map LineNo (f (p Style c))
kvs =
        forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const Style
StyleFailure) Map LineNo (f (p Style c))
kvs [LineNo
startLine..LineNo
endLine]

      insertDoc :: Map LineNo (Line (a, [(Style, Doc Markup)]))
-> Map LineNo (Line (a, [(Style, Doc Markup)]))
insertDoc =
        forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const [(Style, Doc Markup)]
docs) LineNo
endLine

    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
      forall a.
(Map LineNo (Line a) -> Map LineNo (Line a))
-> Declaration a -> Declaration a
mapSource (forall {f :: * -> *} {p :: * -> * -> *} {c}.
(Functor f, Bifunctor p) =>
Map LineNo (f (p Style c)) -> Map LineNo (f (p Style c))
styleFailure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}.
Map LineNo (Line (a, [(Style, Doc Markup)]))
-> Map LineNo (Line (a, [(Style, Doc Markup)]))
insertDoc) Declaration (Style, [(Style, Doc Markup)])
decl

ppDeclaration :: Declaration (Style, [(Style, Doc Markup)]) -> Doc Markup
ppDeclaration :: Declaration (Style, [(Style, Doc Markup)]) -> Doc Markup
ppDeclaration Declaration (Style, [(Style, Doc Markup)])
decl =
  case forall k a. Map k a -> Maybe (a, Map k a)
Map.maxView forall a b. (a -> b) -> a -> b
$ forall a. Declaration a -> Map LineNo (Line a)
declarationSource Declaration (Style, [(Style, Doc Markup)])
decl of
    Maybe
  (Line (Style, [(Style, Doc Markup)]),
   Map LineNo (Line (Style, [(Style, Doc Markup)])))
Nothing ->
      forall a. Monoid a => a
mempty
    Just (Line (Style, [(Style, Doc Markup)])
lastLine, Map LineNo (Line (Style, [(Style, Doc Markup)]))
_) ->
      let
        ppLocation :: Doc Markup
ppLocation =
          forall a. Int -> Doc a -> Doc a
WL.indent (Int
digits forall a. Num a => a -> a -> a
+ Int
1) forall a b. (a -> b) -> a -> b
$
            Markup -> Doc Markup -> Doc Markup
markup (Style -> Markup
StyledBorder Style
StyleDefault) Doc Markup
"┏━━" forall a. Doc a -> Doc a -> Doc a
<+>
            Markup -> Doc Markup -> Doc Markup
markup Markup
DeclarationLocation (forall a. String -> Doc a
WL.text (forall a. Declaration a -> String
declarationFile Declaration (Style, [(Style, Doc Markup)])
decl)) forall a. Doc a -> Doc a -> Doc a
<+>
            Markup -> Doc Markup -> Doc Markup
markup (Style -> Markup
StyledBorder Style
StyleDefault) Doc Markup
"━━━"

        digits :: Int
digits =
          forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineNo -> Int
unLineNo forall a b. (a -> b) -> a -> b
$ forall a. Line a -> LineNo
lineNumber Line (Style, [(Style, Doc Markup)])
lastLine

        ppLineNo :: LineNo -> Doc a
ppLineNo =
          forall a. String -> Doc a
WL.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. PrintfType r => String -> r
printf (String
"%" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
digits forall a. Semigroup a => a -> a -> a
<> String
"d") forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineNo -> Int
unLineNo

        ppEmptyNo :: Doc a
ppEmptyNo =
          forall a. String -> Doc a
WL.text forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
digits Char
' '

        ppSource :: Style -> LineNo -> String -> Doc Markup
ppSource Style
style LineNo
n String
src =
          Markup -> Doc Markup -> Doc Markup
markup (Style -> Markup
StyledLineNo Style
style) (forall {a}. LineNo -> Doc a
ppLineNo LineNo
n) forall a. Doc a -> Doc a -> Doc a
<+>
          Markup -> Doc Markup -> Doc Markup
markup (Style -> Markup
StyledBorder Style
style) Doc Markup
"┃" forall a. Doc a -> Doc a -> Doc a
<+>
          Markup -> Doc Markup -> Doc Markup
markup (Style -> Markup
StyledSource Style
style) (forall a. String -> Doc a
WL.text String
src)

        ppAnnot :: (Style, Doc Markup) -> Doc Markup
ppAnnot (Style
style, Doc Markup
doc) =
          Markup -> Doc Markup -> Doc Markup
markup (Style -> Markup
StyledLineNo Style
style) forall {a}. Doc a
ppEmptyNo forall a. Doc a -> Doc a -> Doc a
<+>
          Markup -> Doc Markup -> Doc Markup
markup (Style -> Markup
StyledBorder Style
style) Doc Markup
"┃" forall a. Doc a -> Doc a -> Doc a
<+>
          Doc Markup
doc

        ppLines :: [Doc Markup]
ppLines = do
          Line (Style
style, [(Style, Doc Markup)]
xs) LineNo
n String
src <- forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ forall a. Declaration a -> Map LineNo (Line a)
declarationSource Declaration (Style, [(Style, Doc Markup)])
decl
          Style -> LineNo -> String -> Doc Markup
ppSource Style
style LineNo
n String
src forall a. a -> [a] -> [a]
: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Style, Doc Markup) -> Doc Markup
ppAnnot [(Style, Doc Markup)]
xs
      in
        forall (f :: * -> *) a. Foldable f => f (Doc a) -> Doc a
WL.vsep (Doc Markup
ppLocation forall a. a -> [a] -> [a]
: [Doc Markup]
ppLines)

ppReproduce :: Maybe PropertyName -> Seed -> Skip -> Doc Markup
ppReproduce :: Maybe PropertyName -> Seed -> Skip -> Doc Markup
ppReproduce Maybe PropertyName
name Seed
seed Skip
skip =
  forall (f :: * -> *) a. Foldable f => f (Doc a) -> Doc a
WL.vsep [
      Markup -> Doc Markup -> Doc Markup
markup Markup
ReproduceHeader
        Doc Markup
"This failure can be reproduced by running:"
    , Markup -> Doc Markup -> Doc Markup
gutter Markup
ReproduceGutter forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markup -> Doc Markup -> Doc Markup
markup Markup
ReproduceSource forall a b. (a -> b) -> a -> b
$
        Doc Markup
"recheckAt" forall a. Doc a -> Doc a -> Doc a
<+>
        forall a. String -> Doc a
WL.text (forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Seed
seed String
"") forall a. Doc a -> Doc a -> Doc a
<+>
        forall a. Skip -> Doc a
ppSkipReadable Skip
skip forall a. Doc a -> Doc a -> Doc a
<+>
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc Markup
"<property>" (forall a. String -> Doc a
WL.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropertyName -> String
unPropertyName) Maybe PropertyName
name
    ]

mergeLine :: Semigroup a => Line a -> Line a -> Line a
mergeLine :: forall a. Semigroup a => Line a -> Line a -> Line a
mergeLine (Line a
x LineNo
no String
src) (Line a
y LineNo
_ String
_) =
  forall a. a -> LineNo -> String -> Line a
Line (a
x forall a. Semigroup a => a -> a -> a
<> a
y) LineNo
no String
src

mergeDeclaration :: Semigroup a => Declaration a -> Declaration a -> Declaration a
mergeDeclaration :: forall a.
Semigroup a =>
Declaration a -> Declaration a -> Declaration a
mergeDeclaration (Declaration String
file LineNo
line String
name Map LineNo (Line a)
src0) (Declaration String
_ LineNo
_ String
_ Map LineNo (Line a)
src1) =
  forall a.
String -> LineNo -> String -> Map LineNo (Line a) -> Declaration a
Declaration String
file LineNo
line String
name forall a b. (a -> b) -> a -> b
$
  forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Semigroup a => Line a -> Line a -> Line a
mergeLine Map LineNo (Line a)
src0 Map LineNo (Line a)
src1

mergeDeclarations :: Semigroup a => [Declaration a] -> [Declaration a]
mergeDeclarations :: forall a. Semigroup a => [Declaration a] -> [Declaration a]
mergeDeclarations =
  forall k a. Map k a -> [a]
Map.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a.
Semigroup a =>
Declaration a -> Declaration a -> Declaration a
mergeDeclaration forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Declaration a
d -> ((forall a. Declaration a -> String
declarationFile Declaration a
d, forall a. Declaration a -> LineNo
declarationLine Declaration a
d), Declaration a
d))

ppTextLines :: String -> [Doc Markup]
ppTextLines :: String -> [Doc Markup]
ppTextLines =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. String -> Doc a
WL.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
List.lines

ppFailureReport :: MonadIO m => Maybe PropertyName -> TestCount -> Seed -> FailureReport -> m [Doc Markup]
ppFailureReport :: forall (m :: * -> *).
MonadIO m =>
Maybe PropertyName
-> TestCount -> Seed -> FailureReport -> m [Doc Markup]
ppFailureReport Maybe PropertyName
name TestCount
tests Seed
seed (FailureReport ShrinkCount
_ ShrinkPath
shrinkPath Maybe (Coverage CoverCount)
mcoverage [FailedAnnotation]
inputs0 Maybe Span
mlocation0 String
msg Maybe Diff
mdiff [String]
msgs0) = do
  let
    basic :: ([Doc Markup], Maybe a)
basic =
      -- Move the failure message to the end section if we have
      -- no source location or can't find the source file.
      let
        msgs1 :: [String]
msgs1 =
          [String]
msgs0 forall a. [a] -> [a] -> [a]
++
          (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
msg then [] else [String
msg])

        docs :: [Doc Markup]
docs =
          forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [Doc Markup]
ppTextLines [String]
msgs1 forall a. [a] -> [a] -> [a]
++
          forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Diff -> [Doc Markup]
ppDiff Maybe Diff
mdiff
      in
        ([Doc Markup]
docs, forall a. Maybe a
Nothing)

  ([Doc Markup]
msgs1, Maybe (Declaration (Style, [(Style, Doc Markup)]))
mlocation) <-
    case Maybe Span
mlocation0 of
      Maybe Span
Nothing ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall {a}. ([Doc Markup], Maybe a)
basic

      Just Span
location0 -> do
        Maybe (Declaration (Style, [(Style, Doc Markup)]))
mAdvanced <-
          forall (m :: * -> *).
MonadIO m =>
[Doc Markup]
-> Maybe Diff
-> Span
-> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
ppFailureLocation (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. String -> Doc a
WL.text forall a b. (a -> b) -> a -> b
$ String -> [String]
List.lines String
msg) Maybe Diff
mdiff Span
location0
        case Maybe (Declaration (Style, [(Style, Doc Markup)]))
mAdvanced of
          Just Declaration (Style, [(Style, Doc Markup)])
advanced ->
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [Doc Markup]
ppTextLines [String]
msgs0, forall a. a -> Maybe a
Just Declaration (Style, [(Style, Doc Markup)])
advanced)
          Maybe (Declaration (Style, [(Style, Doc Markup)]))
Nothing ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall {a}. ([Doc Markup], Maybe a)
basic

  [Maybe (Declaration (Style, [(Style, Doc Markup)]))]
coverageLocations <-
    case Maybe (Coverage CoverCount)
mcoverage of
      Maybe (Coverage CoverCount)
Nothing ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      Just Coverage CoverCount
coverage ->
        forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (TestCount -> Coverage CoverCount -> [Label CoverCount]
coverageFailures TestCount
tests Coverage CoverCount
coverage) forall a b. (a -> b) -> a -> b
$ \(MkLabel LabelName
_ Maybe Span
mclocation CoverPercentage
_ CoverCount
count) ->
          case Maybe Span
mclocation of
            Maybe Span
Nothing ->
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Just Span
clocation ->
              let
                coverageMsg :: Doc Markup
coverageMsg =
                  forall (f :: * -> *) a. Foldable f => f (Doc a) -> Doc a
WL.cat [
                      Doc Markup
"Failed ("
                    , forall a. a -> Doc a -> Doc a
WL.annotate Markup
CoverageText forall a b. (a -> b) -> a -> b
$
                        CoverPercentage -> Doc Markup
ppCoverPercentage (TestCount -> CoverCount -> CoverPercentage
coverPercentage TestCount
tests CoverCount
count) forall a. Semigroup a => a -> a -> a
<> Doc Markup
" coverage"
                    , Doc Markup
")"
                    ]
              in
                forall (m :: * -> *).
MonadIO m =>
[Doc Markup]
-> Maybe Diff
-> Span
-> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
ppFailureLocation [Doc Markup
coverageMsg] forall a. Maybe a
Nothing Span
clocation

  ([Doc Markup]
args, [Declaration (Style, [(Style, Doc Markup)])]
idecls) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM forall (m :: * -> *).
MonadIO m =>
Int
-> FailedAnnotation
-> m (Either
        (Doc Markup) (Declaration (Style, [(Style, Doc Markup)])))
ppFailedInput [Int
0..] [FailedAnnotation]
inputs0

  let
    decls :: [Declaration (Style, [(Style, Doc Markup)])]
decls =
      forall a. Semigroup a => [Declaration a] -> [Declaration a]
mergeDeclarations forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$
        Maybe (Declaration (Style, [(Style, Doc Markup)]))
mlocation forall a. a -> [a] -> [a]
: [Maybe (Declaration (Style, [(Style, Doc Markup)]))]
coverageLocations forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Applicative f => a -> f a
pure [Declaration (Style, [(Style, Doc Markup)])]
idecls

    with :: t a -> (t a -> a) -> [a]
with t a
xs t a -> a
f =
      if forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
xs then
        []
      else
        [t a -> a
f t a
xs]

    whenSome :: (t a -> t a) -> t a -> t a
whenSome t a -> t a
f t a
xs =
      if forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
xs then
        t a
xs
      else
        t a -> t a
f t a
xs

    bottom :: [Doc Markup]
bottom =
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        [Maybe PropertyName -> Seed -> Skip -> Doc Markup
ppReproduce Maybe PropertyName
name Seed
seed (TestCount -> ShrinkPath -> Skip
SkipToShrink TestCount
tests ShrinkPath
shrinkPath)]
        (forall a b. a -> b -> a
const [])
        Maybe (Coverage CoverCount)
mcoverage

  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall {t :: * -> *} {a}. Foldable t => (t a -> t a) -> t a -> t a
whenSome (forall a. Monoid a => a
mempty forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall {t :: * -> *} {a}. Foldable t => (t a -> t a) -> t a -> t a
whenSome (forall a. [a] -> [a] -> [a]
++ [forall a. Monoid a => a
mempty]) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall (f :: * -> *) a.
Traversable f =>
Doc a -> f (Doc a) -> f (Doc a)
WL.punctuate forall {a}. Doc a
WL.line forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a. Foldable f => f (Doc a) -> Doc a
WL.vsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Int -> Doc a -> Doc a
WL.indent Int
2)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> a
id :: [Doc Markup] -> [Doc Markup]) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall a. (a -> Bool) -> [a] -> [a]
List.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
      forall {t :: * -> *} {a} {a}.
Foldable t =>
t a -> (t a -> a) -> [a]
with [Doc Markup]
args forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *) a.
Traversable f =>
Doc a -> f (Doc a) -> f (Doc a)
WL.punctuate forall {a}. Doc a
WL.line
    , forall {t :: * -> *} {a} {a}.
Foldable t =>
t a -> (t a -> a) -> [a]
with [Declaration (Style, [(Style, Doc Markup)])]
decls forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *) a.
Traversable f =>
Doc a -> f (Doc a) -> f (Doc a)
WL.punctuate forall {a}. Doc a
WL.line forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Declaration (Style, [(Style, Doc Markup)]) -> Doc Markup
ppDeclaration
    , forall {t :: * -> *} {a} {a}.
Foldable t =>
t a -> (t a -> a) -> [a]
with [Doc Markup]
msgs1 forall a b. (a -> b) -> a -> b
$
        forall a. a -> a
id
    , forall {t :: * -> *} {a} {a}.
Foldable t =>
t a -> (t a -> a) -> [a]
with [Doc Markup]
bottom forall a b. (a -> b) -> a -> b
$
        forall a. a -> a
id
    ]

ppName :: Maybe PropertyName -> Doc a
ppName :: forall a. Maybe PropertyName -> Doc a
ppName = \case
  Maybe PropertyName
Nothing ->
    Doc a
"<interactive>"
  Just (PropertyName String
name) ->
    forall a. String -> Doc a
WL.text String
name

ppProgress :: MonadIO m => Maybe PropertyName -> Report Progress -> m (Doc Markup)
ppProgress :: forall (m :: * -> *).
MonadIO m =>
Maybe PropertyName -> Report Progress -> m (Doc Markup)
ppProgress Maybe PropertyName
name (Report TestCount
tests DiscardCount
discards Coverage CoverCount
coverage Seed
_ Progress
status) =
  case Progress
status of
    Progress
Running ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => f (Doc a) -> Doc a
WL.vsep forall a b. (a -> b) -> a -> b
$ [
          Markup -> Char -> Doc Markup -> Doc Markup
icon Markup
RunningIcon Char
'●' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Doc a -> Doc a
WL.annotate Markup
RunningHeader forall a b. (a -> b) -> a -> b
$
            forall a. Maybe PropertyName -> Doc a
ppName Maybe PropertyName
name forall a. Doc a -> Doc a -> Doc a
<+>
            Doc Markup
"passed" forall a. Doc a -> Doc a -> Doc a
<+>
            forall a. TestCount -> Doc a
ppTestCount TestCount
tests forall a. Semigroup a => a -> a -> a
<>
            DiscardCount -> Doc Markup
ppWithDiscardCount DiscardCount
discards forall a. Doc a -> Doc a -> Doc a
<+>
            Doc Markup
"(running)"
        ] forall a. [a] -> [a] -> [a]
++
        TestCount -> Coverage CoverCount -> [Doc Markup]
ppCoverage TestCount
tests Coverage CoverCount
coverage

    Shrinking FailureReport
failure ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markup -> Char -> Doc Markup -> Doc Markup
icon Markup
ShrinkingIcon Char
'↯' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Doc a -> Doc a
WL.annotate Markup
ShrinkingHeader forall a b. (a -> b) -> a -> b
$
        forall a. Maybe PropertyName -> Doc a
ppName Maybe PropertyName
name forall a. Doc a -> Doc a -> Doc a
<+>
        Doc Markup
"failed" forall a. Doc a -> Doc a -> Doc a
<+> Maybe Span -> Doc Markup
ppFailedAtLocation (FailureReport -> Maybe Span
failureLocation FailureReport
failure) forall a. Doc a -> Doc a -> Doc a
<#>
        Doc Markup
"after" forall a. Doc a -> Doc a -> Doc a
<+>
        forall a. TestCount -> Doc a
ppTestCount TestCount
tests forall a. Semigroup a => a -> a -> a
<>
        ShrinkCount -> DiscardCount -> Doc Markup
ppShrinkDiscard (FailureReport -> ShrinkCount
failureShrinks FailureReport
failure) DiscardCount
discards forall a. Doc a -> Doc a -> Doc a
<+>
        Doc Markup
"(shrinking)"

ppResult :: MonadIO m => Maybe PropertyName -> Report Result -> m (Doc Markup)
ppResult :: forall (m :: * -> *).
MonadIO m =>
Maybe PropertyName -> Report Result -> m (Doc Markup)
ppResult Maybe PropertyName
name (Report TestCount
tests DiscardCount
discards Coverage CoverCount
coverage Seed
seed Result
result) = do
  case Result
result of
    Failed FailureReport
failure -> do
      [Doc Markup]
pfailure <- forall (m :: * -> *).
MonadIO m =>
Maybe PropertyName
-> TestCount -> Seed -> FailureReport -> m [Doc Markup]
ppFailureReport Maybe PropertyName
name TestCount
tests Seed
seed FailureReport
failure
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => f (Doc a) -> Doc a
WL.vsep forall a b. (a -> b) -> a -> b
$ [
          Markup -> Char -> Doc Markup -> Doc Markup
icon Markup
FailedIcon Char
'✗' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Doc a -> Doc a
WL.align forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Doc a -> Doc a
WL.annotate Markup
FailedText forall a b. (a -> b) -> a -> b
$
            forall a. Maybe PropertyName -> Doc a
ppName Maybe PropertyName
name forall a. Doc a -> Doc a -> Doc a
<+>
            Doc Markup
"failed" forall a. Doc a -> Doc a -> Doc a
<+> Maybe Span -> Doc Markup
ppFailedAtLocation (FailureReport -> Maybe Span
failureLocation FailureReport
failure) forall a. Doc a -> Doc a -> Doc a
<#>
            Doc Markup
"after" forall a. Doc a -> Doc a -> Doc a
<+>
            forall a. TestCount -> Doc a
ppTestCount TestCount
tests forall a. Semigroup a => a -> a -> a
<>
            ShrinkCount -> DiscardCount -> Doc Markup
ppShrinkDiscard (FailureReport -> ShrinkCount
failureShrinks FailureReport
failure) DiscardCount
discards forall a. Semigroup a => a -> a -> a
<>
            Doc Markup
"." forall a. Doc a -> Doc a -> Doc a
<#>
            Doc Markup
"shrink path:" forall a. Doc a -> Doc a -> Doc a
<+>
            forall a. Skip -> Doc a
ppSkip (TestCount -> ShrinkPath -> Skip
SkipToShrink TestCount
tests forall a b. (a -> b) -> a -> b
$ FailureReport -> ShrinkPath
failureShrinkPath FailureReport
failure)
        ] forall a. [a] -> [a] -> [a]
++
        TestCount -> Coverage CoverCount -> [Doc Markup]
ppCoverage TestCount
tests Coverage CoverCount
coverage forall a. [a] -> [a] -> [a]
++
        [Doc Markup]
pfailure

    Result
GaveUp ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => f (Doc a) -> Doc a
WL.vsep forall a b. (a -> b) -> a -> b
$ [
          Markup -> Char -> Doc Markup -> Doc Markup
icon Markup
GaveUpIcon Char
'⚐' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Doc a -> Doc a
WL.annotate Markup
GaveUpText forall a b. (a -> b) -> a -> b
$
            forall a. Maybe PropertyName -> Doc a
ppName Maybe PropertyName
name forall a. Doc a -> Doc a -> Doc a
<+>
            Doc Markup
"gave up after" forall a. Doc a -> Doc a -> Doc a
<+>
            forall a. DiscardCount -> Doc a
ppDiscardCount DiscardCount
discards forall a. Semigroup a => a -> a -> a
<>
            Doc Markup
", passed" forall a. Doc a -> Doc a -> Doc a
<+>
            forall a. TestCount -> Doc a
ppTestCount TestCount
tests forall a. Semigroup a => a -> a -> a
<>
            Doc Markup
"."
        ] forall a. [a] -> [a] -> [a]
++
        TestCount -> Coverage CoverCount -> [Doc Markup]
ppCoverage TestCount
tests Coverage CoverCount
coverage

    Result
OK ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => f (Doc a) -> Doc a
WL.vsep forall a b. (a -> b) -> a -> b
$ [
          Markup -> Char -> Doc Markup -> Doc Markup
icon Markup
SuccessIcon Char
'✓' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Doc a -> Doc a
WL.annotate Markup
SuccessText forall a b. (a -> b) -> a -> b
$
            forall a. Maybe PropertyName -> Doc a
ppName Maybe PropertyName
name forall a. Doc a -> Doc a -> Doc a
<+>
            Doc Markup
"passed" forall a. Doc a -> Doc a -> Doc a
<+>
            forall a. TestCount -> Doc a
ppTestCount TestCount
tests forall a. Semigroup a => a -> a -> a
<>
            Doc Markup
"."
        ] forall a. [a] -> [a] -> [a]
++
        TestCount -> Coverage CoverCount -> [Doc Markup]
ppCoverage TestCount
tests Coverage CoverCount
coverage

ppFailedAtLocation :: Maybe Span -> Doc Markup
ppFailedAtLocation :: Maybe Span -> Doc Markup
ppFailedAtLocation = \case
  Just Span
x ->
    Doc Markup
"at" forall a. Doc a -> Doc a -> Doc a
<+>
    forall a. String -> Doc a
WL.text (Span -> String
spanFile Span
x) forall a. Semigroup a => a -> a -> a
<> Doc Markup
":" forall a. Semigroup a => a -> a -> a
<>
    forall a b. Pretty a => a -> Doc b
WL.pretty (LineNo -> Int
unLineNo (Span -> LineNo
spanStartLine Span
x)) forall a. Semigroup a => a -> a -> a
<> Doc Markup
":" forall a. Semigroup a => a -> a -> a
<>
    forall a b. Pretty a => a -> Doc b
WL.pretty (ColumnNo -> Int
unColumnNo (Span -> ColumnNo
spanStartColumn Span
x))
  Maybe Span
Nothing ->
    forall a. Monoid a => a
mempty

ppCoverage :: TestCount -> Coverage CoverCount -> [Doc Markup]
ppCoverage :: TestCount -> Coverage CoverCount -> [Doc Markup]
ppCoverage TestCount
tests Coverage CoverCount
x =
  if forall k a. Map k a -> Bool
Map.null (forall a. Coverage a -> Map LabelName (Label a)
coverageLabels Coverage CoverCount
x) then
    forall a. Monoid a => a
mempty
  else
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TestCount -> ColumnWidth -> Label CoverCount -> Doc Markup
ppLabel TestCount
tests (TestCount -> Coverage CoverCount -> ColumnWidth
coverageWidth TestCount
tests Coverage CoverCount
x)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn forall a. Label a -> Maybe Span
labelLocation forall a b. (a -> b) -> a -> b
$
    forall k a. Map k a -> [a]
Map.elems (forall a. Coverage a -> Map LabelName (Label a)
coverageLabels Coverage CoverCount
x)

data ColumnWidth =
  ColumnWidth {
      ColumnWidth -> Int
widthPercentage :: !Int
    , ColumnWidth -> Int
widthMinimum :: !Int
    , ColumnWidth -> Int
widthName :: !Int
    , ColumnWidth -> Int
_widthNameFail :: !Int
    }

instance Semigroup ColumnWidth where
  <> :: ColumnWidth -> ColumnWidth -> ColumnWidth
(<>) (ColumnWidth Int
p0 Int
m0 Int
n0 Int
f0) (ColumnWidth Int
p1 Int
m1 Int
n1 Int
f1) =
    Int -> Int -> Int -> Int -> ColumnWidth
ColumnWidth
      (forall a. Ord a => a -> a -> a
max Int
p0 Int
p1)
      (forall a. Ord a => a -> a -> a
max Int
m0 Int
m1)
      (forall a. Ord a => a -> a -> a
max Int
n0 Int
n1)
      (forall a. Ord a => a -> a -> a
max Int
f0 Int
f1)

instance Monoid ColumnWidth where
  mempty :: ColumnWidth
mempty =
    Int -> Int -> Int -> Int -> ColumnWidth
ColumnWidth Int
0 Int
0 Int
0 Int
0
  mappend :: ColumnWidth -> ColumnWidth -> ColumnWidth
mappend =
    forall a. Semigroup a => a -> a -> a
(<>)

coverageWidth :: TestCount -> Coverage CoverCount -> ColumnWidth
coverageWidth :: TestCount -> Coverage CoverCount -> ColumnWidth
coverageWidth TestCount
tests (Coverage Map LabelName (Label CoverCount)
labels) =
  forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (TestCount -> Label CoverCount -> ColumnWidth
labelWidth TestCount
tests) Map LabelName (Label CoverCount)
labels

labelWidth :: TestCount -> Label CoverCount -> ColumnWidth
labelWidth :: TestCount -> Label CoverCount -> ColumnWidth
labelWidth TestCount
tests Label CoverCount
x =
  let
    percentage :: Int
percentage =
      forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      CoverPercentage -> String
renderCoverPercentage forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      TestCount -> CoverCount -> CoverPercentage
coverPercentage TestCount
tests forall a b. (a -> b) -> a -> b
$
      forall a. Label a -> a
labelAnnotation Label CoverCount
x

    minimum_ :: Int
minimum_ =
      if forall a. Label a -> CoverPercentage
labelMinimum Label CoverCount
x forall a. Eq a => a -> a -> Bool
== CoverPercentage
0 then
        Int
0
      else
        forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        CoverPercentage -> String
renderCoverPercentage forall a b. (a -> b) -> a -> b
$
        forall a. Label a -> CoverPercentage
labelMinimum Label CoverCount
x

    name :: Int
name =
      forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      LabelName -> String
unLabelName forall a b. (a -> b) -> a -> b
$
      forall a. Label a -> LabelName
labelName Label CoverCount
x

    nameFail :: Int
nameFail =
      if TestCount -> Label CoverCount -> Bool
labelCovered TestCount
tests Label CoverCount
x then
        Int
0
      else
        Int
name
  in
    Int -> Int -> Int -> Int -> ColumnWidth
ColumnWidth Int
percentage Int
minimum_ Int
name Int
nameFail

ppLeftPad :: Int -> Doc a -> Doc a
ppLeftPad :: forall a. Int -> Doc a -> Doc a
ppLeftPad Int
n Doc a
doc =
  let
    ndoc :: Int
ndoc =
      forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Show a => a -> String
show Doc a
doc)

    pad :: Doc a
pad =
      forall a. String -> Doc a
WL.text forall a b. (a -> b) -> a -> b
$
        forall a. Int -> a -> [a]
List.replicate (Int
n forall a. Num a => a -> a -> a
- Int
ndoc) Char
' '
  in
    forall {a}. Doc a
pad forall a. Semigroup a => a -> a -> a
<> Doc a
doc

ppLabel :: TestCount -> ColumnWidth -> Label CoverCount -> Doc Markup
ppLabel :: TestCount -> ColumnWidth -> Label CoverCount -> Doc Markup
ppLabel TestCount
tests ColumnWidth
w x :: Label CoverCount
x@(MkLabel LabelName
name Maybe Span
_ CoverPercentage
minimum_ CoverCount
count) =
  let
    covered :: Bool
covered =
      TestCount -> Label CoverCount -> Bool
labelCovered TestCount
tests Label CoverCount
x

    ltext :: Doc Markup -> Doc Markup
ltext =
      if Bool -> Bool
not Bool
covered then
        forall a. a -> Doc a -> Doc a
WL.annotate Markup
CoverageText
      else
        forall a. a -> a
id

    lborder :: Doc Markup -> Doc Markup
lborder =
      forall a. a -> Doc a -> Doc a
WL.annotate (Style -> Markup
StyledBorder Style
StyleDefault)

    licon :: Doc Markup
licon =
      if Bool -> Bool
not Bool
covered then
        forall a. a -> Doc a -> Doc a
WL.annotate Markup
CoverageText Doc Markup
"⚠ "
      else
        Doc Markup
"  "

    lname :: Doc a
lname =
      forall a. Int -> Doc a -> Doc a
WL.fill (ColumnWidth -> Int
widthName ColumnWidth
w) (forall a. LabelName -> Doc a
ppLabelName LabelName
name)

    wminimum :: Doc Markup
wminimum =
      forall a. Int -> Doc a -> Doc a
ppLeftPad (ColumnWidth -> Int
widthMinimum ColumnWidth
w) forall a b. (a -> b) -> a -> b
$
        CoverPercentage -> Doc Markup
ppCoverPercentage CoverPercentage
minimum_

    wcover :: String -> Doc Markup
wcover String
i =
      forall a. Int -> Doc a -> Doc a
ppLeftPad (ColumnWidth -> Int
widthPercentage ColumnWidth
w forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length String
i) forall a b. (a -> b) -> a -> b
$
        forall a. String -> Doc a
WL.text String
i forall a. Semigroup a => a -> a -> a
<>
        CoverPercentage -> Doc Markup
ppCoverPercentage (TestCount -> CoverCount -> CoverPercentage
coverPercentage TestCount
tests CoverCount
count)

    lminimum :: Doc Markup
lminimum =
      if ColumnWidth -> Int
widthMinimum ColumnWidth
w forall a. Eq a => a -> a -> Bool
== Int
0 then
        forall a. Monoid a => a
mempty
      else if Bool -> Bool
not Bool
covered then
        Doc Markup
" ✗ " forall a. Semigroup a => a -> a -> a
<> Doc Markup
wminimum
      else if CoverPercentage
minimum_ forall a. Eq a => a -> a -> Bool
== CoverPercentage
0 then
        Doc Markup
"   " forall a. Semigroup a => a -> a -> a
<> forall a. Int -> Doc a -> Doc a
ppLeftPad (ColumnWidth -> Int
widthMinimum ColumnWidth
w) Doc Markup
""
      else
        Doc Markup
" ✓ " forall a. Semigroup a => a -> a -> a
<> Doc Markup
wminimum

    lcover :: Doc Markup
lcover =
      if ColumnWidth -> Int
widthMinimum ColumnWidth
w forall a. Eq a => a -> a -> Bool
== Int
0 then
        String -> Doc Markup
wcover String
""
      else if Bool -> Bool
not Bool
covered then
        String -> Doc Markup
wcover String
""
      else if CoverPercentage
minimum_ forall a. Eq a => a -> a -> Bool
== CoverPercentage
0 then
        String -> Doc Markup
wcover String
""
      else
        String -> Doc Markup
wcover String
""
  in
    forall (f :: * -> *) a. Foldable f => f (Doc a) -> Doc a
WL.hcat [
        Doc Markup
licon
      , Doc Markup -> Doc Markup
ltext forall {a}. Doc a
lname
      , Doc Markup -> Doc Markup
lborder Doc Markup
" "
      , Doc Markup -> Doc Markup
ltext Doc Markup
lcover
      , Doc Markup -> Doc Markup
lborder Doc Markup
" "
      , Doc Markup -> Doc Markup
ltext forall a b. (a -> b) -> a -> b
$ CoverPercentage -> CoverPercentage -> Doc Markup
ppCoverBar (TestCount -> CoverCount -> CoverPercentage
coverPercentage TestCount
tests CoverCount
count) CoverPercentage
minimum_
      , Doc Markup -> Doc Markup
lborder Doc Markup
"" -- "│"
      , Doc Markup -> Doc Markup
ltext Doc Markup
lminimum
      ]

ppLabelName :: LabelName -> Doc a
ppLabelName :: forall a. LabelName -> Doc a
ppLabelName (LabelName String
name) =
  forall a. String -> Doc a
WL.text String
name

ppCoverPercentage :: CoverPercentage -> Doc Markup
ppCoverPercentage :: CoverPercentage -> Doc Markup
ppCoverPercentage =
  forall a. String -> Doc a
WL.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoverPercentage -> String
renderCoverPercentage

ppCoverBar :: CoverPercentage -> CoverPercentage -> Doc Markup
ppCoverBar :: CoverPercentage -> CoverPercentage -> Doc Markup
ppCoverBar (CoverPercentage Double
percentage) (CoverPercentage Double
minimum_) =
  let
    barWidth :: Int
    barWidth :: Int
barWidth =
      Int
20

    coverageRatio :: Double
    coverageRatio :: Double
coverageRatio =
      Double
percentage forall a. Fractional a => a -> a -> a
/ Double
100.0

    coverageWidth_ :: Int
    coverageWidth_ :: Int
coverageWidth_ =
      forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$
        Double
coverageRatio forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
barWidth

    minimumRatio :: Double
    minimumRatio :: Double
minimumRatio =
      Double
minimum_ forall a. Fractional a => a -> a -> a
/ Double
100.0

    minimumWidth :: Int
    minimumWidth :: Int
minimumWidth =
      forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$
        Double
minimumRatio forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
barWidth

    index :: [a] -> Int
    index :: forall a. [a] -> Int
index [a]
xs =
      forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$
        ((Double
coverageRatio forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
barWidth) forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
coverageWidth_) forall a. Num a => a -> a -> a
*
        forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs)

    part :: [a] -> a
part [a]
xs =
      [a]
xs forall a. [a] -> Int -> a
!! forall a. [a] -> Int
index [a]
xs

    fillWidth :: Int
fillWidth =
      Int
barWidth forall a. Num a => a -> a -> a
- Int
coverageWidth_ forall a. Num a => a -> a -> a
- Int
1

    fillErrorWidth :: Int
fillErrorWidth =
      forall a. Ord a => a -> a -> a
max Int
0 (Int
minimumWidth forall a. Num a => a -> a -> a
- Int
coverageWidth_ forall a. Num a => a -> a -> a
- Int
1)

    fillSurplusWidth :: Int
fillSurplusWidth =
      Int
fillWidth forall a. Num a => a -> a -> a
- Int
fillErrorWidth

    bar :: (Char, [Char]) -> Doc Markup
    bar :: (Char, String) -> Doc Markup
bar (Char
full, String
parts) =
      forall (f :: * -> *) a. Foldable f => f (Doc a) -> Doc a
WL.hcat [
        forall a. String -> Doc a
WL.text forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
coverageWidth_ Char
full
      , if Int
fillWidth forall a. Ord a => a -> a -> Bool
>= Int
0 then
          if forall a. [a] -> Int
index String
parts forall a. Eq a => a -> a -> Bool
== Int
0 then
            if Int
fillErrorWidth forall a. Ord a => a -> a -> Bool
> Int
0 then
              forall a. a -> Doc a -> Doc a
WL.annotate Markup
FailedText forall a b. (a -> b) -> a -> b
$ forall a. String -> Doc a
WL.text [forall {a}. [a] -> a
part String
parts]
            else
              forall a. a -> Doc a -> Doc a
WL.annotate Markup
CoverageFill forall a b. (a -> b) -> a -> b
$ forall a. String -> Doc a
WL.text [forall {a}. [a] -> a
part String
parts]
          else
            forall a. String -> Doc a
WL.text [forall {a}. [a] -> a
part String
parts]
        else
          Doc Markup
""
      , forall a. a -> Doc a -> Doc a
WL.annotate Markup
FailedText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> Doc a
WL.text forall a b. (a -> b) -> a -> b
$
          forall a. Int -> a -> [a]
replicate Int
fillErrorWidth (forall {a}. [a] -> a
head String
parts)
      , forall a. a -> Doc a -> Doc a
WL.annotate Markup
CoverageFill forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> Doc a
WL.text forall a b. (a -> b) -> a -> b
$
          forall a. Int -> a -> [a]
replicate Int
fillSurplusWidth (forall {a}. [a] -> a
head String
parts)
      --
      -- Uncomment when debugging:
      --
      -- , WL.annotate CoverageFill . WL.text $
      --        " " ++ show barWidth
      --     ++ " " ++ show coverageWidth_
      --     ++ " " ++ show minimumWidth
      --     ++ " " ++ "/"
      --     ++ " " ++ show fillErrorWidth
      --     ++ " " ++ "+"
      --     ++ " " ++ show fillSurplusWidth
      --     ++ " " ++ "="
      --     ++ " " ++ show fillWidth
      ]
  in
    (Char, String) -> Doc Markup
bar (Char
'█', [Char
'·', Char
'▏', Char
'▎', Char
'▍', Char
'▌', Char
'▋', Char
'▊', Char
'▉'])

    -- FIXME Maybe this should be configurable?
    -- Alternative histogram bars:
    --bar ('⣿', ['·', '⡀', '⡄', '⡆', '⡇', '⣇', '⣧', '⣷'])
    --bar ('⣿', ['⢕', '⡀', '⣀', '⣄', '⣤', '⣦', '⣶', '⣷'])
    --bar ('⣿', ['⢕', '⡵', '⢗', '⣗', '⣟'])
    --bar ('⣿', [' ', '⡵', '⢗', '⣗', '⣟'])
    --bar ('█', ['░','▓'])
    --bar ('█', ['░'])

renderCoverPercentage :: CoverPercentage -> String
renderCoverPercentage :: CoverPercentage -> String
renderCoverPercentage (CoverPercentage Double
percentage) =
  forall r. PrintfType r => String -> r
printf String
"%.0f" Double
percentage forall a. Semigroup a => a -> a -> a
<> String
"%"

ppWhenNonZero :: Doc a -> PropertyCount -> Maybe (Doc a)
ppWhenNonZero :: forall a. Doc a -> PropertyCount -> Maybe (Doc a)
ppWhenNonZero Doc a
suffix PropertyCount
n =
  if PropertyCount
n forall a. Ord a => a -> a -> Bool
<= PropertyCount
0 then
    forall a. Maybe a
Nothing
  else
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. PropertyCount -> Doc a
ppRawPropertyCount PropertyCount
n forall a. Doc a -> Doc a -> Doc a
<+> Doc a
suffix

annotateSummary :: Summary -> Doc Markup -> Doc Markup
annotateSummary :: Summary -> Doc Markup -> Doc Markup
annotateSummary Summary
summary =
  if Summary -> PropertyCount
summaryFailed Summary
summary forall a. Ord a => a -> a -> Bool
> PropertyCount
0 then
    Markup -> Char -> Doc Markup -> Doc Markup
icon Markup
FailedIcon Char
'✗' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Doc a -> Doc a
WL.annotate Markup
FailedText
  else if Summary -> PropertyCount
summaryGaveUp Summary
summary forall a. Ord a => a -> a -> Bool
> PropertyCount
0 then
    Markup -> Char -> Doc Markup -> Doc Markup
icon Markup
GaveUpIcon Char
'⚐' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Doc a -> Doc a
WL.annotate Markup
GaveUpText
  else if Summary -> PropertyCount
summaryWaiting Summary
summary forall a. Ord a => a -> a -> Bool
> PropertyCount
0 Bool -> Bool -> Bool
|| Summary -> PropertyCount
summaryRunning Summary
summary forall a. Ord a => a -> a -> Bool
> PropertyCount
0 then
    Markup -> Char -> Doc Markup -> Doc Markup
icon Markup
WaitingIcon Char
'○' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Doc a -> Doc a
WL.annotate Markup
WaitingHeader
  else
    Markup -> Char -> Doc Markup -> Doc Markup
icon Markup
SuccessIcon Char
'✓' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Doc a -> Doc a
WL.annotate Markup
SuccessText

ppSummary :: MonadIO m => Summary -> m (Doc Markup)
ppSummary :: forall (m :: * -> *). MonadIO m => Summary -> m (Doc Markup)
ppSummary Summary
summary =
  let
    complete :: Bool
complete =
      Summary -> PropertyCount
summaryCompleted Summary
summary forall a. Eq a => a -> a -> Bool
== Summary -> PropertyCount
summaryTotal Summary
summary

    prefix :: Doc a -> Doc a
prefix Doc a
end =
      if Bool
complete then
        forall a. Monoid a => a
mempty
      else
        forall a. PropertyCount -> Doc a
ppRawPropertyCount (Summary -> PropertyCount
summaryCompleted Summary
summary) forall a. Semigroup a => a -> a -> a
<>
        Doc a
"/" forall a. Semigroup a => a -> a -> a
<>
        forall a. PropertyCount -> Doc a
ppRawPropertyCount (Summary -> PropertyCount
summaryTotal Summary
summary) forall a. Doc a -> Doc a -> Doc a
<+>
        Doc a
"complete" forall a. Semigroup a => a -> a -> a
<> Doc a
end

    addPrefix :: [Doc a] -> [Doc a]
addPrefix [Doc a]
xs =
      if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc a]
xs then
        forall a. Doc a -> Doc a
prefix forall a. Monoid a => a
mempty forall a. a -> [a] -> [a]
: []
      else
        forall a. Doc a -> Doc a
prefix Doc a
": " forall a. a -> [a] -> [a]
: [Doc a]
xs

    suffix :: Doc Markup
suffix =
      if Bool
complete then
        Doc Markup
"."
      else
        Doc Markup
" (running)"
  in
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Summary -> Doc Markup -> Doc Markup
annotateSummary Summary
summary forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      (forall a. Semigroup a => a -> a -> a
<> Doc Markup
suffix) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      forall (f :: * -> *) a. Foldable f => f (Doc a) -> Doc a
WL.hcat forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      forall {a}. [Doc a] -> [Doc a]
addPrefix forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      forall (f :: * -> *) a.
Traversable f =>
Doc a -> f (Doc a) -> f (Doc a)
WL.punctuate Doc Markup
", " forall a b. (a -> b) -> a -> b
$
      forall a. [Maybe a] -> [a]
catMaybes [
          forall a. Doc a -> PropertyCount -> Maybe (Doc a)
ppWhenNonZero Doc Markup
"failed" (Summary -> PropertyCount
summaryFailed Summary
summary)
        , forall a. Doc a -> PropertyCount -> Maybe (Doc a)
ppWhenNonZero Doc Markup
"gave up" (Summary -> PropertyCount
summaryGaveUp Summary
summary)
        , if Bool
complete then
            forall a. Doc a -> PropertyCount -> Maybe (Doc a)
ppWhenNonZero Doc Markup
"succeeded" (Summary -> PropertyCount
summaryOK Summary
summary)
          else
            forall a. Maybe a
Nothing
        ]

renderDoc :: MonadIO m => UseColor -> Doc Markup -> m String
renderDoc :: forall (m :: * -> *).
MonadIO m =>
UseColor -> Doc Markup -> m String
renderDoc UseColor
color Doc Markup
doc = do
  let
    dull :: Color -> SGR
dull =
      ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull

    vivid :: Color -> SGR
vivid =
      ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid

    bold :: SGR
bold =
      ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity

    start :: Markup -> String
start = \case
      Markup
WaitingIcon ->
        [SGR] -> String
setSGRCode []
      Markup
WaitingHeader ->
        [SGR] -> String
setSGRCode []
      Markup
RunningIcon ->
        [SGR] -> String
setSGRCode []
      Markup
RunningHeader ->
        [SGR] -> String
setSGRCode []
      Markup
ShrinkingIcon ->
        [SGR] -> String
setSGRCode [Color -> SGR
vivid Color
Red]
      Markup
ShrinkingHeader ->
        [SGR] -> String
setSGRCode [Color -> SGR
vivid Color
Red]
      Markup
FailedIcon ->
        [SGR] -> String
setSGRCode [Color -> SGR
vivid Color
Red]
      Markup
FailedText ->
        [SGR] -> String
setSGRCode [Color -> SGR
vivid Color
Red]
      Markup
GaveUpIcon ->
        [SGR] -> String
setSGRCode [Color -> SGR
dull Color
Yellow]
      Markup
GaveUpText ->
        [SGR] -> String
setSGRCode [Color -> SGR
dull Color
Yellow]
      Markup
SuccessIcon ->
        [SGR] -> String
setSGRCode [Color -> SGR
dull Color
Green]
      Markup
SuccessText ->
        [SGR] -> String
setSGRCode [Color -> SGR
dull Color
Green]
      Markup
CoverageIcon ->
        [SGR] -> String
setSGRCode [Color -> SGR
dull Color
Yellow]
      Markup
CoverageText ->
        [SGR] -> String
setSGRCode [Color -> SGR
dull Color
Yellow]
      Markup
CoverageFill ->
        [SGR] -> String
setSGRCode [Color -> SGR
vivid Color
Black]

      Markup
DeclarationLocation ->
        [SGR] -> String
setSGRCode []

      StyledLineNo Style
StyleDefault ->
        [SGR] -> String
setSGRCode []
      StyledSource Style
StyleDefault ->
        [SGR] -> String
setSGRCode []
      StyledBorder Style
StyleDefault ->
        [SGR] -> String
setSGRCode []

      StyledLineNo Style
StyleAnnotation ->
        [SGR] -> String
setSGRCode [Color -> SGR
dull Color
Magenta]
      StyledSource Style
StyleAnnotation ->
        [SGR] -> String
setSGRCode []
      StyledBorder Style
StyleAnnotation ->
        [SGR] -> String
setSGRCode []
      Markup
AnnotationGutter ->
        [SGR] -> String
setSGRCode [Color -> SGR
dull Color
Magenta]
      Markup
AnnotationValue ->
        [SGR] -> String
setSGRCode [Color -> SGR
dull Color
Magenta]

      StyledLineNo Style
StyleFailure ->
        [SGR] -> String
setSGRCode [Color -> SGR
vivid Color
Red]
      StyledSource Style
StyleFailure ->
        [SGR] -> String
setSGRCode [Color -> SGR
vivid Color
Red, SGR
bold]
      StyledBorder Style
StyleFailure ->
        [SGR] -> String
setSGRCode []
      Markup
FailureArrows ->
        [SGR] -> String
setSGRCode [Color -> SGR
vivid Color
Red]
      Markup
FailureMessage ->
        [SGR] -> String
setSGRCode []
      Markup
FailureGutter ->
        [SGR] -> String
setSGRCode []

      Markup
DiffPrefix ->
        [SGR] -> String
setSGRCode []
      Markup
DiffInfix ->
        [SGR] -> String
setSGRCode []
      Markup
DiffSuffix ->
        [SGR] -> String
setSGRCode []
      Markup
DiffSame ->
        [SGR] -> String
setSGRCode []
      Markup
DiffRemoved ->
        [SGR] -> String
setSGRCode [Color -> SGR
dull Color
Red]
      Markup
DiffAdded ->
        [SGR] -> String
setSGRCode [Color -> SGR
dull Color
Green]

      Markup
ReproduceHeader ->
        [SGR] -> String
setSGRCode []
      Markup
ReproduceGutter ->
        [SGR] -> String
setSGRCode []
      Markup
ReproduceSource ->
        [SGR] -> String
setSGRCode []

    end :: p -> String
end p
_ =
      [SGR] -> String
setSGRCode [SGR
Reset]

  let
    display :: SimpleDoc Markup -> String
display =
      case UseColor
color of
        UseColor
EnableColor ->
          forall o a.
Monoid o =>
(a -> o) -> (a -> o) -> (String -> o) -> SimpleDoc a -> o
WL.displayDecorated Markup -> String
start forall {p}. p -> String
end forall a. a -> a
id
        UseColor
DisableColor ->
          forall a. SimpleDoc a -> String
WL.display

#if mingw32_HOST_OS
  liftIO $ do
    hSetEncoding stdout utf8
    hSetEncoding stderr utf8
#endif

  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    SimpleDoc Markup -> String
display forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall a. Int -> Doc a -> SimpleDoc a
WL.renderSmart Int
100 forall a b. (a -> b) -> a -> b
$
    forall a. Int -> Doc a -> Doc a
WL.indent Int
2 Doc Markup
doc

renderProgress :: MonadIO m => UseColor -> Maybe PropertyName -> Report Progress -> m String
renderProgress :: forall (m :: * -> *).
MonadIO m =>
UseColor -> Maybe PropertyName -> Report Progress -> m String
renderProgress UseColor
color Maybe PropertyName
name Report Progress
x =
  forall (m :: * -> *).
MonadIO m =>
UseColor -> Doc Markup -> m String
renderDoc UseColor
color forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadIO m =>
Maybe PropertyName -> Report Progress -> m (Doc Markup)
ppProgress Maybe PropertyName
name Report Progress
x

renderResult :: MonadIO m => UseColor -> Maybe PropertyName -> Report Result -> m String
renderResult :: forall (m :: * -> *).
MonadIO m =>
UseColor -> Maybe PropertyName -> Report Result -> m String
renderResult UseColor
color Maybe PropertyName
name Report Result
x =
  forall (m :: * -> *).
MonadIO m =>
UseColor -> Doc Markup -> m String
renderDoc UseColor
color forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadIO m =>
Maybe PropertyName -> Report Result -> m (Doc Markup)
ppResult Maybe PropertyName
name Report Result
x

renderSummary :: MonadIO m => UseColor -> Summary -> m String
renderSummary :: forall (m :: * -> *). MonadIO m => UseColor -> Summary -> m String
renderSummary UseColor
color Summary
x =
  forall (m :: * -> *).
MonadIO m =>
UseColor -> Doc Markup -> m String
renderDoc UseColor
color forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). MonadIO m => Summary -> m (Doc Markup)
ppSummary Summary
x