{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# 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)
import           Data.Semigroup (Semigroup(..))
import           Data.Traversable (for)

import           Hedgehog.Internal.Config
import           Hedgehog.Internal.Discovery (Pos(..), Position(..))
import qualified Hedgehog.Internal.Discovery as Discovery
import           Hedgehog.Internal.Property (Coverage(..), Label(..), LabelName(..))
import           Hedgehog.Internal.Property (CoverCount(..), CoverPercentage(..))
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.Seed (Seed)
import           Hedgehog.Internal.Show
import           Hedgehog.Internal.Source
import           Hedgehog.Range (Size)

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
(FailedAnnotation -> FailedAnnotation -> Bool)
-> (FailedAnnotation -> FailedAnnotation -> Bool)
-> Eq FailedAnnotation
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
(Int -> FailedAnnotation -> ShowS)
-> (FailedAnnotation -> String)
-> ([FailedAnnotation] -> ShowS)
-> Show FailedAnnotation
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 -> Size
failureSize :: !Size
    , FailureReport -> Seed
failureSeed :: !Seed
    , FailureReport -> ShrinkCount
failureShrinks :: !ShrinkCount
    , 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
(FailureReport -> FailureReport -> Bool)
-> (FailureReport -> FailureReport -> Bool) -> Eq FailureReport
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
(Int -> FailureReport -> ShowS)
-> (FailureReport -> String)
-> ([FailureReport] -> ShowS)
-> Show FailureReport
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
(Progress -> Progress -> Bool)
-> (Progress -> Progress -> Bool) -> Eq Progress
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
(Int -> Progress -> ShowS)
-> (Progress -> String) -> ([Progress] -> ShowS) -> Show Progress
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
(Result -> Result -> Bool)
-> (Result -> Result -> Bool) -> Eq Result
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
(Int -> Result -> ShowS)
-> (Result -> String) -> ([Result] -> ShowS) -> Show Result
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 {
      Report a -> TestCount
reportTests :: !TestCount
    , Report a -> DiscardCount
reportDiscards :: !DiscardCount
    , Report a -> Coverage CoverCount
reportCoverage :: !(Coverage CoverCount)
    , Report a -> a
reportStatus :: !a
    } deriving (Int -> Report a -> ShowS
[Report a] -> ShowS
Report a -> String
(Int -> Report a -> ShowS)
-> (Report a -> String) -> ([Report a] -> ShowS) -> Show (Report a)
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, a -> Report b -> Report a
(a -> b) -> Report a -> Report b
(forall a b. (a -> b) -> Report a -> Report b)
-> (forall a b. a -> Report b -> Report a) -> Functor Report
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
<$ :: a -> Report b -> Report a
$c<$ :: forall a b. a -> Report b -> Report a
fmap :: (a -> b) -> Report a -> Report b
$cfmap :: forall a b. (a -> b) -> Report a -> Report b
Functor, Report a -> Bool
(a -> m) -> Report a -> m
(a -> b -> b) -> b -> Report a -> b
(forall m. Monoid m => Report m -> m)
-> (forall m a. Monoid m => (a -> m) -> Report a -> m)
-> (forall m a. Monoid m => (a -> m) -> Report a -> m)
-> (forall a b. (a -> b -> b) -> b -> Report a -> b)
-> (forall a b. (a -> b -> b) -> b -> Report a -> b)
-> (forall b a. (b -> a -> b) -> b -> Report a -> b)
-> (forall b a. (b -> a -> b) -> b -> Report a -> b)
-> (forall a. (a -> a -> a) -> Report a -> a)
-> (forall a. (a -> a -> a) -> Report a -> a)
-> (forall a. Report a -> [a])
-> (forall a. Report a -> Bool)
-> (forall a. Report a -> Int)
-> (forall a. Eq a => a -> Report a -> Bool)
-> (forall a. Ord a => Report a -> a)
-> (forall a. Ord a => Report a -> a)
-> (forall a. Num a => Report a -> a)
-> (forall a. Num a => Report a -> a)
-> Foldable Report
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 :: Report a -> a
$cproduct :: forall a. Num a => Report a -> a
sum :: Report a -> a
$csum :: forall a. Num a => Report a -> a
minimum :: Report a -> a
$cminimum :: forall a. Ord a => Report a -> a
maximum :: Report a -> a
$cmaximum :: forall a. Ord a => Report a -> a
elem :: a -> Report a -> Bool
$celem :: forall a. Eq a => a -> Report a -> Bool
length :: Report a -> Int
$clength :: forall a. Report a -> Int
null :: Report a -> Bool
$cnull :: forall a. Report a -> Bool
toList :: Report a -> [a]
$ctoList :: forall a. Report a -> [a]
foldl1 :: (a -> a -> a) -> Report a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Report a -> a
foldr1 :: (a -> a -> a) -> Report a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Report a -> a
foldl' :: (b -> a -> b) -> b -> Report a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Report a -> b
foldl :: (b -> a -> b) -> b -> Report a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Report a -> b
foldr' :: (a -> b -> b) -> b -> Report a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Report a -> b
foldr :: (a -> b -> b) -> b -> Report a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Report a -> b
foldMap' :: (a -> m) -> Report a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Report a -> m
foldMap :: (a -> m) -> Report a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Report a -> m
fold :: Report m -> m
$cfold :: forall m. Monoid m => Report m -> m
Foldable, Functor Report
Foldable Report
(Functor Report, Foldable Report) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Report a -> f (Report b))
-> (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 (m :: * -> *) a.
    Monad m =>
    Report (m a) -> m (Report a))
-> Traversable Report
(a -> f b) -> Report a -> f (Report b)
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 :: Report (m a) -> m (Report a)
$csequence :: forall (m :: * -> *) a. Monad m => Report (m a) -> m (Report a)
mapM :: (a -> m b) -> Report a -> m (Report b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Report a -> m (Report b)
sequenceA :: Report (f a) -> f (Report a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Report (f a) -> f (Report a)
traverse :: (a -> f b) -> Report a -> f (Report b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Report a -> f (Report b)
$cp2Traversable :: Foldable Report
$cp1Traversable :: Functor Report
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
(Int -> Summary -> ShowS)
-> (Summary -> String) -> ([Summary] -> ShowS) -> Show Summary
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
  mempty :: Summary
mempty =
    PropertyCount
-> PropertyCount
-> PropertyCount
-> PropertyCount
-> PropertyCount
-> Summary
Summary 0 0 0 0 0
  mappend :: Summary -> Summary -> Summary
mappend (Summary x1 :: PropertyCount
x1 x2 :: PropertyCount
x2 x3 :: PropertyCount
x3 x4 :: PropertyCount
x4 x5 :: PropertyCount
x5) (Summary y1 :: PropertyCount
y1 y2 :: PropertyCount
y2 y3 :: PropertyCount
y3 y4 :: PropertyCount
y4 y5 :: PropertyCount
y5) =
    PropertyCount
-> PropertyCount
-> PropertyCount
-> PropertyCount
-> PropertyCount
-> Summary
Summary
      (PropertyCount
x1 PropertyCount -> PropertyCount -> PropertyCount
forall a. Num a => a -> a -> a
+ PropertyCount
y1)
      (PropertyCount
x2 PropertyCount -> PropertyCount -> PropertyCount
forall a. Num a => a -> a -> a
+ PropertyCount
y2)
      (PropertyCount
x3 PropertyCount -> PropertyCount -> PropertyCount
forall a. Num a => a -> a -> a
+ PropertyCount
y3)
      (PropertyCount
x4 PropertyCount -> PropertyCount -> PropertyCount
forall a. Num a => a -> a -> a
+ PropertyCount
y4)
      (PropertyCount
x5 PropertyCount -> PropertyCount -> PropertyCount
forall a. Num a => a -> a -> a
+ PropertyCount
y5)

instance Semigroup Summary where
  <> :: Summary -> Summary -> Summary
(<>) = Summary -> Summary -> Summary
forall a. Monoid a => a -> a -> a
mappend

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

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

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

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

data Line a =
  Line {
      Line a -> a
_lineAnnotation :: !a
    , Line a -> LineNo
lineNumber :: !LineNo
    , Line a -> String
_lineSource :: !String
    } deriving (Line a -> Line a -> Bool
(Line a -> Line a -> Bool)
-> (Line a -> Line a -> Bool) -> Eq (Line a)
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, Eq (Line a)
Eq (Line a) =>
(Line a -> Line a -> Ordering)
-> (Line a -> Line a -> Bool)
-> (Line a -> Line a -> Bool)
-> (Line a -> Line a -> Bool)
-> (Line a -> Line a -> Bool)
-> (Line a -> Line a -> Line a)
-> (Line a -> Line a -> Line a)
-> Ord (Line a)
Line a -> Line a -> Bool
Line a -> Line a -> Ordering
Line a -> Line a -> Line a
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
$cp1Ord :: forall a. Ord a => Eq (Line a)
Ord, Int -> Line a -> ShowS
[Line a] -> ShowS
Line a -> String
(Int -> Line a -> ShowS)
-> (Line a -> String) -> ([Line a] -> ShowS) -> Show (Line a)
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, a -> Line b -> Line a
(a -> b) -> Line a -> Line b
(forall a b. (a -> b) -> Line a -> Line b)
-> (forall a b. a -> Line b -> Line a) -> Functor Line
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
<$ :: a -> Line b -> Line a
$c<$ :: forall a b. a -> Line b -> Line a
fmap :: (a -> b) -> Line a -> Line b
$cfmap :: forall a b. (a -> b) -> Line a -> Line b
Functor)

data Declaration a =
  Declaration {
      Declaration a -> String
declarationFile :: !FilePath
    , Declaration a -> LineNo
declarationLine :: !LineNo
    , Declaration a -> String
_declarationName :: !String
    , Declaration a -> Map LineNo (Line a)
declarationSource :: !(Map LineNo (Line a))
    } deriving (Declaration a -> Declaration a -> Bool
(Declaration a -> Declaration a -> Bool)
-> (Declaration a -> Declaration a -> Bool) -> Eq (Declaration a)
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, Eq (Declaration a)
Eq (Declaration a) =>
(Declaration a -> Declaration a -> Ordering)
-> (Declaration a -> Declaration a -> Bool)
-> (Declaration a -> Declaration a -> Bool)
-> (Declaration a -> Declaration a -> Bool)
-> (Declaration a -> Declaration a -> Bool)
-> (Declaration a -> Declaration a -> Declaration a)
-> (Declaration a -> Declaration a -> Declaration a)
-> Ord (Declaration a)
Declaration a -> Declaration a -> Bool
Declaration a -> Declaration a -> Ordering
Declaration a -> Declaration a -> Declaration a
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
$cp1Ord :: forall a. Ord a => Eq (Declaration a)
Ord, Int -> Declaration a -> ShowS
[Declaration a] -> ShowS
Declaration a -> String
(Int -> Declaration a -> ShowS)
-> (Declaration a -> String)
-> ([Declaration a] -> ShowS)
-> Show (Declaration a)
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, a -> Declaration b -> Declaration a
(a -> b) -> Declaration a -> Declaration b
(forall a b. (a -> b) -> Declaration a -> Declaration b)
-> (forall a b. a -> Declaration b -> Declaration a)
-> Functor Declaration
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
<$ :: a -> Declaration b -> Declaration a
$c<$ :: forall a b. a -> Declaration b -> Declaration a
fmap :: (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
(Style -> Style -> Bool) -> (Style -> Style -> Bool) -> Eq Style
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
Eq Style =>
(Style -> Style -> Ordering)
-> (Style -> Style -> Bool)
-> (Style -> Style -> Bool)
-> (Style -> Style -> Bool)
-> (Style -> Style -> Bool)
-> (Style -> Style -> Style)
-> (Style -> Style -> Style)
-> Ord 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
$cp1Ord :: Eq Style
Ord, Int -> Style -> ShowS
[Style] -> ShowS
Style -> String
(Int -> Style -> ShowS)
-> (Style -> String) -> ([Style] -> ShowS) -> Show Style
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
(Markup -> Markup -> Bool)
-> (Markup -> Markup -> Bool) -> Eq Markup
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
Eq Markup =>
(Markup -> Markup -> Ordering)
-> (Markup -> Markup -> Bool)
-> (Markup -> Markup -> Bool)
-> (Markup -> Markup -> Bool)
-> (Markup -> Markup -> Bool)
-> (Markup -> Markup -> Markup)
-> (Markup -> Markup -> Markup)
-> Ord 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
$cp1Ord :: Eq Markup
Ord, Int -> Markup -> ShowS
[Markup] -> ShowS
Markup -> String
(Int -> Markup -> ShowS)
-> (Markup -> String) -> ([Markup] -> ShowS) -> Show Markup
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
(<>) x :: Style
x y :: Style
y =
    case (Style
x, Style
y) of
      (StyleFailure, _) ->
        Style
StyleFailure
      (_, StyleFailure) ->
        Style
StyleFailure
      (StyleAnnotation, _) ->
        Style
StyleAnnotation
      (_, StyleAnnotation) ->
        Style
StyleAnnotation
      (StyleDefault, _) ->
        Style
StyleDefault

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

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

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

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

    footnotes :: [String]
footnotes =
      (Log -> Maybe String) -> [Log] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Log -> Maybe String
takeFootnote [Log]
logs
  in
    Size
-> Seed
-> ShrinkCount
-> Maybe (Coverage CoverCount)
-> [FailedAnnotation]
-> Maybe Span
-> String
-> Maybe Diff
-> [String]
-> FailureReport
FailureReport Size
size Seed
seed ShrinkCount
shrinks 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 :: x -> Doc a
ppShow = -- unfortunate naming clash
  String -> Doc a
forall a. String -> Doc a
WL.text (String -> Doc a) -> (x -> String) -> x -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> String
forall a. Show a => a -> String
show

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

gutter :: Markup -> Doc Markup -> Doc Markup
gutter :: Markup -> Doc Markup -> Doc Markup
gutter m :: Markup
m x :: Doc Markup
x =
  Markup -> Doc Markup -> Doc Markup
markup Markup
m ">" Doc Markup -> Doc Markup -> 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 m :: Markup
m i :: Char
i x :: Doc Markup
x =
  Markup -> Doc Markup -> Doc Markup
markup Markup
m (Char -> Doc Markup
forall a. Char -> Doc a
WL.char Char
i) Doc Markup -> Doc Markup -> Doc Markup
forall a. Doc a -> Doc a -> Doc a
<+> Doc Markup
x

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

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

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

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

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

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

mapSource :: (Map LineNo (Line a) -> Map LineNo (Line a)) -> Declaration a -> Declaration a
mapSource :: (Map LineNo (Line a) -> Map LineNo (Line a))
-> Declaration a -> Declaration a
mapSource f :: Map LineNo (Line a) -> Map LineNo (Line a)
f decl :: Declaration a
decl =
  Declaration a
decl {
      declarationSource :: Map LineNo (Line a)
declarationSource =
        Map LineNo (Line a) -> Map LineNo (Line a)
f (Declaration a -> Map LineNo (Line a)
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 :: Line a -> (ColumnNo, ColumnNo)
lineSpan (Line _ _ x0 :: String
x0) =
  let
    (pre :: String
pre, x1 :: String
x1) =
      (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
Char.isSpace String
x0

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

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

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

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

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

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

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

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


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

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

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

ppFailedInputDeclaration ::
     MonadIO m
  => FailedAnnotation
  -> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
ppFailedInputDeclaration :: FailedAnnotation
-> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
ppFailedInputDeclaration (FailedAnnotation msloc :: Maybe Span
msloc val :: String
val) =
  MaybeT m (Declaration (Style, [(Style, Doc Markup)]))
-> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m (Declaration (Style, [(Style, Doc Markup)]))
 -> m (Maybe (Declaration (Style, [(Style, Doc Markup)]))))
-> MaybeT m (Declaration (Style, [(Style, Doc Markup)]))
-> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
forall a b. (a -> b) -> a -> b
$ do
    Span
sloc <- m (Maybe Span) -> MaybeT m Span
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe Span) -> MaybeT m Span)
-> m (Maybe Span) -> MaybeT m Span
forall a b. (a -> b) -> a -> b
$ Maybe Span -> m (Maybe Span)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Span
msloc
    Declaration (Style, [(Style, Doc Markup)])
decl <- (Declaration () -> Declaration (Style, [(Style, Doc Markup)]))
-> MaybeT m (Declaration ())
-> MaybeT m (Declaration (Style, [(Style, Doc Markup)]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Declaration () -> Declaration (Style, [(Style, Doc Markup)])
forall a.
Declaration a -> Declaration (Style, [(Style, Doc Markup)])
defaultStyle (MaybeT m (Declaration ())
 -> MaybeT m (Declaration (Style, [(Style, Doc Markup)])))
-> (m (Maybe (Declaration ())) -> MaybeT m (Declaration ()))
-> m (Maybe (Declaration ()))
-> MaybeT m (Declaration (Style, [(Style, Doc Markup)]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Maybe (Declaration ())) -> MaybeT m (Declaration ())
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe (Declaration ()))
 -> MaybeT m (Declaration (Style, [(Style, Doc Markup)])))
-> m (Maybe (Declaration ()))
-> MaybeT m (Declaration (Style, [(Style, Doc Markup)]))
forall a b. (a -> b) -> a -> b
$ Span -> m (Maybe (Declaration ()))
forall (m :: * -> *).
MonadIO m =>
Span -> m (Maybe (Declaration ()))
readDeclaration Span
sloc
    Int
startCol <- ColumnNo -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ColumnNo -> Int)
-> ((ColumnNo, ColumnNo) -> ColumnNo)
-> (ColumnNo, ColumnNo)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ColumnNo, ColumnNo) -> ColumnNo
forall a b. (a, b) -> a
fst ((ColumnNo, ColumnNo) -> Int)
-> MaybeT m (ColumnNo, ColumnNo) -> MaybeT m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Span
-> Declaration (Style, [(Style, Doc Markup)])
-> MaybeT m (ColumnNo, ColumnNo)
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 =
        Int -> Doc Markup -> Doc Markup
forall a. Int -> Doc a -> Doc a
WL.indent Int
startCol (Doc Markup -> Doc Markup)
-> (String -> Doc Markup) -> String -> Doc Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          (Markup -> Doc Markup -> Doc Markup
markup Markup
AnnotationGutter (String -> Doc Markup
forall a. String -> Doc a
WL.text "│ ") Doc Markup -> Doc Markup -> Doc Markup
forall a. Semigroup a => a -> a -> a
<>) (Doc Markup -> Doc Markup)
-> (String -> Doc Markup) -> String -> Doc Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          Markup -> Doc Markup -> Doc Markup
markup Markup
AnnotationValue (Doc Markup -> Doc Markup)
-> (String -> Doc Markup) -> String -> Doc Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          String -> Doc Markup
forall a. String -> Doc a
WL.text

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

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

      endLine :: LineNo
endLine =
        LineNo -> LineNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral (LineNo -> LineNo) -> LineNo -> LineNo
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 kvs :: Map LineNo (f (p Style c))
kvs =
        (LineNo
 -> Map LineNo (f (p Style c)) -> Map LineNo (f (p Style c)))
-> Map LineNo (f (p Style c))
-> [LineNo]
-> Map LineNo (f (p Style c))
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((f (p Style c) -> f (p Style c))
-> LineNo
-> Map LineNo (f (p Style c))
-> Map LineNo (f (p Style c))
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust ((f (p Style c) -> f (p Style c))
 -> LineNo
 -> Map LineNo (f (p Style c))
 -> Map LineNo (f (p Style c)))
-> ((Style -> Style) -> f (p Style c) -> f (p Style c))
-> (Style -> Style)
-> LineNo
-> Map LineNo (f (p Style c))
-> Map LineNo (f (p Style c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (p Style c -> p Style c) -> f (p Style c) -> f (p Style c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((p Style c -> p Style c) -> f (p Style c) -> f (p Style c))
-> ((Style -> Style) -> p Style c -> p Style c)
-> (Style -> Style)
-> f (p Style c)
-> f (p Style c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Style -> Style) -> p Style c -> p Style c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Style -> Style)
 -> LineNo
 -> Map LineNo (f (p Style c))
 -> Map LineNo (f (p Style c)))
-> (Style -> Style)
-> LineNo
-> Map LineNo (f (p Style c))
-> Map LineNo (f (p Style c))
forall a b. (a -> b) -> a -> b
$ Style -> Style -> Style
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 =
        (Line (a, [(Style, Doc Markup)])
 -> Line (a, [(Style, Doc Markup)]))
-> LineNo
-> Map LineNo (Line (a, [(Style, Doc Markup)]))
-> Map LineNo (Line (a, [(Style, Doc Markup)]))
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (((a, [(Style, Doc Markup)]) -> (a, [(Style, Doc Markup)]))
-> Line (a, [(Style, Doc Markup)])
-> Line (a, [(Style, Doc Markup)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, [(Style, Doc Markup)]) -> (a, [(Style, Doc Markup)]))
 -> Line (a, [(Style, Doc Markup)])
 -> Line (a, [(Style, Doc Markup)]))
-> (([(Style, Doc Markup)] -> [(Style, Doc Markup)])
    -> (a, [(Style, Doc Markup)]) -> (a, [(Style, Doc Markup)]))
-> ([(Style, Doc Markup)] -> [(Style, Doc Markup)])
-> Line (a, [(Style, Doc Markup)])
-> Line (a, [(Style, Doc Markup)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Style, Doc Markup)] -> [(Style, Doc Markup)])
-> (a, [(Style, Doc Markup)]) -> (a, [(Style, Doc Markup)])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (([(Style, Doc Markup)] -> [(Style, Doc Markup)])
 -> Line (a, [(Style, Doc Markup)])
 -> Line (a, [(Style, Doc Markup)]))
-> ([(Style, Doc Markup)] -> [(Style, Doc Markup)])
-> Line (a, [(Style, Doc Markup)])
-> Line (a, [(Style, Doc Markup)])
forall a b. (a -> b) -> a -> b
$ [(Style, Doc Markup)]
-> [(Style, Doc Markup)] -> [(Style, Doc Markup)]
forall a b. a -> b -> a
const [(Style, Doc Markup)]
valDocs) LineNo
endLine

    Declaration (Style, [(Style, Doc Markup)])
-> MaybeT m (Declaration (Style, [(Style, Doc Markup)]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Declaration (Style, [(Style, Doc Markup)])
 -> MaybeT m (Declaration (Style, [(Style, Doc Markup)])))
-> Declaration (Style, [(Style, Doc Markup)])
-> MaybeT m (Declaration (Style, [(Style, Doc Markup)]))
forall a b. (a -> b) -> a -> b
$
      (Map LineNo (Line (Style, [(Style, Doc Markup)]))
 -> Map LineNo (Line (Style, [(Style, Doc Markup)])))
-> Declaration (Style, [(Style, Doc Markup)])
-> Declaration (Style, [(Style, Doc Markup)])
forall a.
(Map LineNo (Line a) -> Map LineNo (Line a))
-> Declaration a -> Declaration a
mapSource (Map LineNo (Line (Style, [(Style, Doc Markup)]))
-> Map LineNo (Line (Style, [(Style, Doc Markup)]))
forall (f :: * -> *) (p :: * -> * -> *) c.
(Functor f, Bifunctor p) =>
Map LineNo (f (p Style c)) -> Map LineNo (f (p Style c))
styleInput (Map LineNo (Line (Style, [(Style, Doc Markup)]))
 -> Map LineNo (Line (Style, [(Style, Doc Markup)])))
-> (Map LineNo (Line (Style, [(Style, Doc Markup)]))
    -> Map LineNo (Line (Style, [(Style, Doc Markup)])))
-> Map LineNo (Line (Style, [(Style, Doc Markup)]))
-> Map LineNo (Line (Style, [(Style, Doc Markup)]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map LineNo (Line (Style, [(Style, Doc Markup)]))
-> Map LineNo (Line (Style, [(Style, Doc Markup)]))
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 :: Int
-> FailedAnnotation
-> m (Either
        (Doc Markup) (Declaration (Style, [(Style, Doc Markup)])))
ppFailedInput ix :: Int
ix input :: FailedAnnotation
input = do
  Maybe (Declaration (Style, [(Style, Doc Markup)]))
mdecl <- FailedAnnotation
-> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
forall (m :: * -> *).
MonadIO m =>
FailedAnnotation
-> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
ppFailedInputDeclaration FailedAnnotation
input
  case Maybe (Declaration (Style, [(Style, Doc Markup)]))
mdecl of
    Nothing ->
      Either (Doc Markup) (Declaration (Style, [(Style, Doc Markup)]))
-> m (Either
        (Doc Markup) (Declaration (Style, [(Style, Doc Markup)])))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Doc Markup) (Declaration (Style, [(Style, Doc Markup)]))
 -> m (Either
         (Doc Markup) (Declaration (Style, [(Style, Doc Markup)]))))
-> (Doc Markup
    -> Either
         (Doc Markup) (Declaration (Style, [(Style, Doc Markup)])))
-> Doc Markup
-> m (Either
        (Doc Markup) (Declaration (Style, [(Style, Doc Markup)])))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Markup
-> Either (Doc Markup) (Declaration (Style, [(Style, Doc Markup)]))
forall a b. a -> Either a b
Left (Doc Markup
 -> m (Either
         (Doc Markup) (Declaration (Style, [(Style, Doc Markup)]))))
-> Doc Markup
-> m (Either
        (Doc Markup) (Declaration (Style, [(Style, Doc Markup)])))
forall a b. (a -> b) -> a -> b
$ Int -> FailedAnnotation -> Doc Markup
ppFailedInputTypedArgument Int
ix FailedAnnotation
input
    Just decl :: Declaration (Style, [(Style, Doc Markup)])
decl ->
      Either (Doc Markup) (Declaration (Style, [(Style, Doc Markup)]))
-> m (Either
        (Doc Markup) (Declaration (Style, [(Style, Doc Markup)])))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Doc Markup) (Declaration (Style, [(Style, Doc Markup)]))
 -> m (Either
         (Doc Markup) (Declaration (Style, [(Style, Doc Markup)]))))
-> Either (Doc Markup) (Declaration (Style, [(Style, Doc Markup)]))
-> m (Either
        (Doc Markup) (Declaration (Style, [(Style, Doc Markup)])))
forall a b. (a -> b) -> a -> b
$ Declaration (Style, [(Style, Doc Markup)])
-> Either (Doc Markup) (Declaration (Style, [(Style, Doc Markup)]))
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 x :: String
x ->
    Markup -> Doc Markup -> Doc Markup
markup Markup
DiffSame (Doc Markup -> Doc Markup) -> Doc Markup -> Doc Markup
forall a b. (a -> b) -> a -> b
$
      "  " Doc Markup -> Doc Markup -> Doc Markup
forall a. Semigroup a => a -> a -> a
<> String -> Doc Markup
forall a. String -> Doc a
WL.text String
x

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

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

ppDiff :: Diff -> [Doc Markup]
ppDiff :: Diff -> [Doc Markup]
ppDiff (Diff prefix :: String
prefix removed :: String
removed infix_ :: String
infix_ added :: String
added suffix :: String
suffix diff :: ValueDiff
diff) = [
    Markup -> Doc Markup -> Doc Markup
markup Markup
DiffPrefix (String -> Doc Markup
forall a. String -> Doc a
WL.text String
prefix) Doc Markup -> Doc Markup -> Doc Markup
forall a. Semigroup a => a -> a -> a
<>
    Markup -> Doc Markup -> Doc Markup
markup Markup
DiffRemoved (String -> Doc Markup
forall a. String -> Doc a
WL.text String
removed) Doc Markup -> Doc Markup -> Doc Markup
forall a. Semigroup a => a -> a -> a
<>
    Markup -> Doc Markup -> Doc Markup
markup Markup
DiffInfix (String -> Doc Markup
forall a. String -> Doc a
WL.text String
infix_) Doc Markup -> Doc Markup -> Doc Markup
forall a. Semigroup a => a -> a -> a
<>
    Markup -> Doc Markup -> Doc Markup
markup Markup
DiffAdded (String -> Doc Markup
forall a. String -> Doc a
WL.text String
added) Doc Markup -> Doc Markup -> Doc Markup
forall a. Semigroup a => a -> a -> a
<>
    Markup -> Doc Markup -> Doc Markup
markup Markup
DiffSuffix (String -> Doc Markup
forall a. String -> Doc a
WL.text String
suffix)
  ] [Doc Markup] -> [Doc Markup] -> [Doc Markup]
forall a. [a] -> [a] -> [a]
++ (LineDiff -> Doc Markup) -> [LineDiff] -> [Doc Markup]
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 :: [Doc Markup]
-> Maybe Diff
-> Span
-> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
ppFailureLocation msgs :: [Doc Markup]
msgs mdiff :: Maybe Diff
mdiff sloc :: Span
sloc =
  MaybeT m (Declaration (Style, [(Style, Doc Markup)]))
-> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m (Declaration (Style, [(Style, Doc Markup)]))
 -> m (Maybe (Declaration (Style, [(Style, Doc Markup)]))))
-> MaybeT m (Declaration (Style, [(Style, Doc Markup)]))
-> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
forall a b. (a -> b) -> a -> b
$ do
    Declaration (Style, [(Style, Doc Markup)])
decl <- (Declaration () -> Declaration (Style, [(Style, Doc Markup)]))
-> MaybeT m (Declaration ())
-> MaybeT m (Declaration (Style, [(Style, Doc Markup)]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Declaration () -> Declaration (Style, [(Style, Doc Markup)])
forall a.
Declaration a -> Declaration (Style, [(Style, Doc Markup)])
defaultStyle (MaybeT m (Declaration ())
 -> MaybeT m (Declaration (Style, [(Style, Doc Markup)])))
-> (m (Maybe (Declaration ())) -> MaybeT m (Declaration ()))
-> m (Maybe (Declaration ()))
-> MaybeT m (Declaration (Style, [(Style, Doc Markup)]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Maybe (Declaration ())) -> MaybeT m (Declaration ())
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe (Declaration ()))
 -> MaybeT m (Declaration (Style, [(Style, Doc Markup)])))
-> m (Maybe (Declaration ()))
-> MaybeT m (Declaration (Style, [(Style, Doc Markup)]))
forall a b. (a -> b) -> a -> b
$ Span -> m (Maybe (Declaration ()))
forall (m :: * -> *).
MonadIO m =>
Span -> m (Maybe (Declaration ()))
readDeclaration Span
sloc
    (startCol :: Int
startCol, endCol :: Int
endCol) <- (ColumnNo -> Int)
-> (ColumnNo -> Int) -> (ColumnNo, ColumnNo) -> (Int, Int)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ColumnNo -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ColumnNo -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((ColumnNo, ColumnNo) -> (Int, Int))
-> MaybeT m (ColumnNo, ColumnNo) -> MaybeT m (Int, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Span
-> Declaration (Style, [(Style, Doc Markup)])
-> MaybeT m (ColumnNo, ColumnNo)
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 =
        Int -> Doc Markup -> Doc Markup
forall a. Int -> Doc a -> Doc a
WL.indent Int
startCol (Doc Markup -> Doc Markup) -> Doc Markup -> Doc Markup
forall a b. (a -> b) -> a -> b
$
          Markup -> Doc Markup -> Doc Markup
markup Markup
FailureArrows (String -> Doc Markup
forall a. String -> Doc a
WL.text (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
endCol Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
startCol) '^'))

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

      msgDocs :: [(Style, Doc Markup)]
msgDocs =
        (Doc Markup -> (Style, Doc Markup))
-> [Doc Markup] -> [(Style, Doc Markup)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Style
StyleFailure, ) (Doc Markup -> (Style, Doc Markup))
-> (Doc Markup -> Doc Markup) -> Doc Markup -> (Style, Doc Markup)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Markup -> Doc Markup
ppFailure (Doc Markup -> Doc Markup)
-> (Doc Markup -> Doc Markup) -> Doc Markup -> Doc Markup
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
          Nothing ->
            []
          Just diff :: Diff
diff ->
            (Doc Markup -> (Style, Doc Markup))
-> [Doc Markup] -> [(Style, Doc Markup)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Style
StyleFailure, ) (Doc Markup -> (Style, Doc Markup))
-> (Doc Markup -> Doc Markup) -> Doc Markup -> (Style, Doc Markup)
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)] [(Style, Doc Markup)]
-> [(Style, Doc Markup)] -> [(Style, Doc Markup)]
forall a. [a] -> [a] -> [a]
++ [(Style, Doc Markup)]
msgDocs [(Style, Doc Markup)]
-> [(Style, Doc Markup)] -> [(Style, Doc Markup)]
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 kvs :: Map LineNo (f (p Style c))
kvs =
        (LineNo
 -> Map LineNo (f (p Style c)) -> Map LineNo (f (p Style c)))
-> Map LineNo (f (p Style c))
-> [LineNo]
-> Map LineNo (f (p Style c))
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((f (p Style c) -> f (p Style c))
-> LineNo
-> Map LineNo (f (p Style c))
-> Map LineNo (f (p Style c))
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust ((f (p Style c) -> f (p Style c))
 -> LineNo
 -> Map LineNo (f (p Style c))
 -> Map LineNo (f (p Style c)))
-> ((Style -> Style) -> f (p Style c) -> f (p Style c))
-> (Style -> Style)
-> LineNo
-> Map LineNo (f (p Style c))
-> Map LineNo (f (p Style c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (p Style c -> p Style c) -> f (p Style c) -> f (p Style c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((p Style c -> p Style c) -> f (p Style c) -> f (p Style c))
-> ((Style -> Style) -> p Style c -> p Style c)
-> (Style -> Style)
-> f (p Style c)
-> f (p Style c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Style -> Style) -> p Style c -> p Style c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Style -> Style)
 -> LineNo
 -> Map LineNo (f (p Style c))
 -> Map LineNo (f (p Style c)))
-> (Style -> Style)
-> LineNo
-> Map LineNo (f (p Style c))
-> Map LineNo (f (p Style c))
forall a b. (a -> b) -> a -> b
$ Style -> Style -> Style
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 =
        (Line (a, [(Style, Doc Markup)])
 -> Line (a, [(Style, Doc Markup)]))
-> LineNo
-> Map LineNo (Line (a, [(Style, Doc Markup)]))
-> Map LineNo (Line (a, [(Style, Doc Markup)]))
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (((a, [(Style, Doc Markup)]) -> (a, [(Style, Doc Markup)]))
-> Line (a, [(Style, Doc Markup)])
-> Line (a, [(Style, Doc Markup)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, [(Style, Doc Markup)]) -> (a, [(Style, Doc Markup)]))
 -> Line (a, [(Style, Doc Markup)])
 -> Line (a, [(Style, Doc Markup)]))
-> (([(Style, Doc Markup)] -> [(Style, Doc Markup)])
    -> (a, [(Style, Doc Markup)]) -> (a, [(Style, Doc Markup)]))
-> ([(Style, Doc Markup)] -> [(Style, Doc Markup)])
-> Line (a, [(Style, Doc Markup)])
-> Line (a, [(Style, Doc Markup)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Style, Doc Markup)] -> [(Style, Doc Markup)])
-> (a, [(Style, Doc Markup)]) -> (a, [(Style, Doc Markup)])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (([(Style, Doc Markup)] -> [(Style, Doc Markup)])
 -> Line (a, [(Style, Doc Markup)])
 -> Line (a, [(Style, Doc Markup)]))
-> ([(Style, Doc Markup)] -> [(Style, Doc Markup)])
-> Line (a, [(Style, Doc Markup)])
-> Line (a, [(Style, Doc Markup)])
forall a b. (a -> b) -> a -> b
$ [(Style, Doc Markup)]
-> [(Style, Doc Markup)] -> [(Style, Doc Markup)]
forall a b. a -> b -> a
const [(Style, Doc Markup)]
docs) LineNo
endLine

    Declaration (Style, [(Style, Doc Markup)])
-> MaybeT m (Declaration (Style, [(Style, Doc Markup)]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Declaration (Style, [(Style, Doc Markup)])
 -> MaybeT m (Declaration (Style, [(Style, Doc Markup)])))
-> Declaration (Style, [(Style, Doc Markup)])
-> MaybeT m (Declaration (Style, [(Style, Doc Markup)]))
forall a b. (a -> b) -> a -> b
$
      (Map LineNo (Line (Style, [(Style, Doc Markup)]))
 -> Map LineNo (Line (Style, [(Style, Doc Markup)])))
-> Declaration (Style, [(Style, Doc Markup)])
-> Declaration (Style, [(Style, Doc Markup)])
forall a.
(Map LineNo (Line a) -> Map LineNo (Line a))
-> Declaration a -> Declaration a
mapSource (Map LineNo (Line (Style, [(Style, Doc Markup)]))
-> Map LineNo (Line (Style, [(Style, Doc Markup)]))
forall (f :: * -> *) (p :: * -> * -> *) c.
(Functor f, Bifunctor p) =>
Map LineNo (f (p Style c)) -> Map LineNo (f (p Style c))
styleFailure (Map LineNo (Line (Style, [(Style, Doc Markup)]))
 -> Map LineNo (Line (Style, [(Style, Doc Markup)])))
-> (Map LineNo (Line (Style, [(Style, Doc Markup)]))
    -> Map LineNo (Line (Style, [(Style, Doc Markup)])))
-> Map LineNo (Line (Style, [(Style, Doc Markup)]))
-> Map LineNo (Line (Style, [(Style, Doc Markup)]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map LineNo (Line (Style, [(Style, Doc Markup)]))
-> Map LineNo (Line (Style, [(Style, Doc Markup)]))
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 decl :: Declaration (Style, [(Style, Doc Markup)])
decl =
  case Map LineNo (Line (Style, [(Style, Doc Markup)]))
-> Maybe
     (Line (Style, [(Style, Doc Markup)]),
      Map LineNo (Line (Style, [(Style, Doc Markup)])))
forall k a. Map k a -> Maybe (a, Map k a)
Map.maxView (Map LineNo (Line (Style, [(Style, Doc Markup)]))
 -> Maybe
      (Line (Style, [(Style, Doc Markup)]),
       Map LineNo (Line (Style, [(Style, Doc Markup)]))))
-> Map LineNo (Line (Style, [(Style, Doc Markup)]))
-> Maybe
     (Line (Style, [(Style, Doc Markup)]),
      Map LineNo (Line (Style, [(Style, Doc Markup)])))
forall a b. (a -> b) -> a -> b
$ Declaration (Style, [(Style, Doc Markup)])
-> Map LineNo (Line (Style, [(Style, Doc Markup)]))
forall a. Declaration a -> Map LineNo (Line a)
declarationSource Declaration (Style, [(Style, Doc Markup)])
decl of
    Nothing ->
      Doc Markup
forall a. Monoid a => a
mempty
    Just (lastLine :: Line (Style, [(Style, Doc Markup)])
lastLine, _) ->
      let
        ppLocation :: Doc Markup
ppLocation =
          Int -> Doc Markup -> Doc Markup
forall a. Int -> Doc a -> Doc a
WL.indent (Int
digits Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Doc Markup -> Doc Markup) -> Doc Markup -> Doc Markup
forall a b. (a -> b) -> a -> b
$
            Markup -> Doc Markup -> Doc Markup
markup (Style -> Markup
StyledBorder Style
StyleDefault) "┏━━" Doc Markup -> Doc Markup -> Doc Markup
forall a. Doc a -> Doc a -> Doc a
<+>
            Markup -> Doc Markup -> Doc Markup
markup Markup
DeclarationLocation (String -> Doc Markup
forall a. String -> Doc a
WL.text (Declaration (Style, [(Style, Doc Markup)]) -> String
forall a. Declaration a -> String
declarationFile Declaration (Style, [(Style, Doc Markup)])
decl)) Doc Markup -> Doc Markup -> Doc Markup
forall a. Doc a -> Doc a -> Doc a
<+>
            Markup -> Doc Markup -> Doc Markup
markup (Style -> Markup
StyledBorder Style
StyleDefault) "━━━"

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

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

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

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

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

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

ppReproduce :: Maybe PropertyName -> Size -> Seed -> Doc Markup
ppReproduce :: Maybe PropertyName -> Size -> Seed -> Doc Markup
ppReproduce name :: Maybe PropertyName
name size :: Size
size seed :: Seed
seed =
  [Doc Markup] -> Doc Markup
forall (f :: * -> *) a. Foldable f => f (Doc a) -> Doc a
WL.vsep [
      Markup -> Doc Markup -> Doc Markup
markup Markup
ReproduceHeader
        "This failure can be reproduced by running:"
    , Markup -> Doc Markup -> Doc Markup
gutter Markup
ReproduceGutter (Doc Markup -> Doc Markup)
-> (Doc Markup -> Doc Markup) -> Doc Markup -> Doc Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markup -> Doc Markup -> Doc Markup
markup Markup
ReproduceSource (Doc Markup -> Doc Markup) -> Doc Markup -> Doc Markup
forall a b. (a -> b) -> a -> b
$
        "recheck" Doc Markup -> Doc Markup -> Doc Markup
forall a. Doc a -> Doc a -> Doc a
<+>
        String -> Doc Markup
forall a. String -> Doc a
WL.text (Int -> Size -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec 11 Size
size "") Doc Markup -> Doc Markup -> Doc Markup
forall a. Doc a -> Doc a -> Doc a
<+>
        String -> Doc Markup
forall a. String -> Doc a
WL.text (Int -> Seed -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec 11 Seed
seed "") Doc Markup -> Doc Markup -> Doc Markup
forall a. Doc a -> Doc a -> Doc a
<+>
        Doc Markup
-> (PropertyName -> Doc Markup) -> Maybe PropertyName -> Doc Markup
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "<property>" (String -> Doc Markup
forall a. String -> Doc a
WL.text (String -> Doc Markup)
-> (PropertyName -> String) -> PropertyName -> Doc Markup
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 :: Line a -> Line a -> Line a
mergeLine (Line x :: a
x no :: LineNo
no src :: String
src) (Line y :: a
y _ _) =
  a -> LineNo -> String -> Line a
forall a. a -> LineNo -> String -> Line a
Line (a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
y) LineNo
no String
src

mergeDeclaration :: Semigroup a => Declaration a -> Declaration a -> Declaration a
mergeDeclaration :: Declaration a -> Declaration a -> Declaration a
mergeDeclaration (Declaration file :: String
file line :: LineNo
line name :: String
name src0 :: Map LineNo (Line a)
src0) (Declaration _ _ _ src1 :: Map LineNo (Line a)
src1) =
  String -> LineNo -> String -> Map LineNo (Line a) -> Declaration a
forall a.
String -> LineNo -> String -> Map LineNo (Line a) -> Declaration a
Declaration String
file LineNo
line String
name (Map LineNo (Line a) -> Declaration a)
-> Map LineNo (Line a) -> Declaration a
forall a b. (a -> b) -> a -> b
$
  (Line a -> Line a -> Line a)
-> Map LineNo (Line a)
-> Map LineNo (Line a)
-> Map LineNo (Line a)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Line a -> Line a -> Line a
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 :: [Declaration a] -> [Declaration a]
mergeDeclarations =
  Map (String, LineNo) (Declaration a) -> [Declaration a]
forall k a. Map k a -> [a]
Map.elems (Map (String, LineNo) (Declaration a) -> [Declaration a])
-> ([Declaration a] -> Map (String, LineNo) (Declaration a))
-> [Declaration a]
-> [Declaration a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (Declaration a -> Declaration a -> Declaration a)
-> [((String, LineNo), Declaration a)]
-> Map (String, LineNo) (Declaration a)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Declaration a -> Declaration a -> Declaration a
forall a.
Semigroup a =>
Declaration a -> Declaration a -> Declaration a
mergeDeclaration ([((String, LineNo), Declaration a)]
 -> Map (String, LineNo) (Declaration a))
-> ([Declaration a] -> [((String, LineNo), Declaration a)])
-> [Declaration a]
-> Map (String, LineNo) (Declaration a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (Declaration a -> ((String, LineNo), Declaration a))
-> [Declaration a] -> [((String, LineNo), Declaration a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\d :: Declaration a
d -> ((Declaration a -> String
forall a. Declaration a -> String
declarationFile Declaration a
d, Declaration a -> LineNo
forall a. Declaration a -> LineNo
declarationLine Declaration a
d), Declaration a
d))

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

ppFailureReport :: MonadIO m => Maybe PropertyName -> TestCount -> FailureReport -> m [Doc Markup]
ppFailureReport :: Maybe PropertyName -> TestCount -> FailureReport -> m [Doc Markup]
ppFailureReport name :: Maybe PropertyName
name tests :: TestCount
tests (FailureReport size :: Size
size seed :: Seed
seed _ mcoverage :: Maybe (Coverage CoverCount)
mcoverage inputs0 :: [FailedAnnotation]
inputs0 mlocation0 :: Maybe Span
mlocation0 msg :: String
msg mdiff :: Maybe Diff
mdiff msgs0 :: [String]
msgs0) = do
  (msgs1 :: [Doc Markup]
msgs1, mlocation :: Maybe (Declaration (Style, [(Style, Doc Markup)]))
mlocation) <-
    case Maybe Span
mlocation0 of
      Nothing ->
        -- Move the failure message to the end section if we have
        -- no source location.
        let
          msgs1 :: [String]
msgs1 =
            [String]
msgs0 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
            (if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
msg then [] else [String
msg])

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

      Just location0 :: Span
location0 ->
        (Maybe (Declaration (Style, [(Style, Doc Markup)]))
 -> ([Doc Markup],
     Maybe (Declaration (Style, [(Style, Doc Markup)]))))
-> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
-> m ([Doc Markup],
      Maybe (Declaration (Style, [(Style, Doc Markup)])))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> [Doc Markup]) -> [String] -> [Doc Markup]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [Doc Markup]
ppTextLines [String]
msgs0,) (m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
 -> m ([Doc Markup],
       Maybe (Declaration (Style, [(Style, Doc Markup)]))))
-> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
-> m ([Doc Markup],
      Maybe (Declaration (Style, [(Style, Doc Markup)])))
forall a b. (a -> b) -> a -> b
$
          [Doc Markup]
-> Maybe Diff
-> Span
-> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
forall (m :: * -> *).
MonadIO m =>
[Doc Markup]
-> Maybe Diff
-> Span
-> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
ppFailureLocation ((String -> Doc Markup) -> [String] -> [Doc Markup]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Doc Markup
forall a. String -> Doc a
WL.text ([String] -> [Doc Markup]) -> [String] -> [Doc Markup]
forall a b. (a -> b) -> a -> b
$ String -> [String]
List.lines String
msg) Maybe Diff
mdiff Span
location0

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

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

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

    with :: t a -> (t a -> a) -> [a]
with xs :: t a
xs f :: t a -> a
f =
      if t a -> Bool
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 f :: t a -> t a
f xs :: t a
xs =
      if t a -> Bool
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 =
      [Doc Markup]
-> (Coverage CoverCount -> [Doc Markup])
-> Maybe (Coverage CoverCount)
-> [Doc Markup]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Maybe PropertyName -> Size -> Seed -> Doc Markup
ppReproduce Maybe PropertyName
name Size
size Seed
seed] ([Doc Markup] -> Coverage CoverCount -> [Doc Markup]
forall a b. a -> b -> a
const []) Maybe (Coverage CoverCount)
mcoverage

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

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

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

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

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

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

    OK ->
      Doc Markup -> m (Doc Markup)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc Markup -> m (Doc Markup))
-> ([Doc Markup] -> Doc Markup) -> [Doc Markup] -> m (Doc Markup)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc Markup] -> Doc Markup
forall (f :: * -> *) a. Foldable f => f (Doc a) -> Doc a
WL.vsep ([Doc Markup] -> m (Doc Markup)) -> [Doc Markup] -> m (Doc Markup)
forall a b. (a -> b) -> a -> b
$ [
          Markup -> Char -> Doc Markup -> Doc Markup
icon Markup
SuccessIcon '✓' (Doc Markup -> Doc Markup)
-> (Doc Markup -> Doc Markup) -> Doc Markup -> Doc Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markup -> Doc Markup -> Doc Markup
forall a. a -> Doc a -> Doc a
WL.annotate Markup
SuccessText (Doc Markup -> Doc Markup) -> Doc Markup -> Doc Markup
forall a b. (a -> b) -> a -> b
$
            Maybe PropertyName -> Doc Markup
forall a. Maybe PropertyName -> Doc a
ppName Maybe PropertyName
name Doc Markup -> Doc Markup -> Doc Markup
forall a. Doc a -> Doc a -> Doc a
<+>
            "passed" Doc Markup -> Doc Markup -> Doc Markup
forall a. Doc a -> Doc a -> Doc a
<+>
            TestCount -> Doc Markup
forall a. TestCount -> Doc a
ppTestCount TestCount
tests Doc Markup -> Doc Markup -> Doc Markup
forall a. Semigroup a => a -> a -> a
<>
            "."
        ] [Doc Markup] -> [Doc Markup] -> [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 x :: Span
x ->
    "at" Doc Markup -> Doc Markup -> Doc Markup
forall a. Doc a -> Doc a -> Doc a
<+>
    String -> Doc Markup
forall a. String -> Doc a
WL.text (Span -> String
spanFile Span
x) Doc Markup -> Doc Markup -> Doc Markup
forall a. Semigroup a => a -> a -> a
<> ":" Doc Markup -> Doc Markup -> Doc Markup
forall a. Semigroup a => a -> a -> a
<>
    Int -> Doc Markup
forall a b. Pretty a => a -> Doc b
WL.pretty (LineNo -> Int
unLineNo (Span -> LineNo
spanStartLine Span
x)) Doc Markup -> Doc Markup -> Doc Markup
forall a. Semigroup a => a -> a -> a
<> ":" Doc Markup -> Doc Markup -> Doc Markup
forall a. Semigroup a => a -> a -> a
<>
    Int -> Doc Markup
forall a b. Pretty a => a -> Doc b
WL.pretty (ColumnNo -> Int
unColumnNo (Span -> ColumnNo
spanStartColumn Span
x))
  Nothing ->
    Doc Markup
forall a. Monoid a => a
mempty

ppCoverage :: TestCount -> Coverage CoverCount -> [Doc Markup]
ppCoverage :: TestCount -> Coverage CoverCount -> [Doc Markup]
ppCoverage tests :: TestCount
tests x :: Coverage CoverCount
x =
  if Map LabelName (Label CoverCount) -> Bool
forall k a. Map k a -> Bool
Map.null (Coverage CoverCount -> Map LabelName (Label CoverCount)
forall a. Coverage a -> Map LabelName (Label a)
coverageLabels Coverage CoverCount
x) then
    [Doc Markup]
forall a. Monoid a => a
mempty
  else
    (Label CoverCount -> Doc Markup)
-> [Label CoverCount] -> [Doc Markup]
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)) ([Label CoverCount] -> [Doc Markup])
-> ([Label CoverCount] -> [Label CoverCount])
-> [Label CoverCount]
-> [Doc Markup]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (Label CoverCount -> Maybe Span)
-> [Label CoverCount] -> [Label CoverCount]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn Label CoverCount -> Maybe Span
forall a. Label a -> Maybe Span
labelLocation ([Label CoverCount] -> [Doc Markup])
-> [Label CoverCount] -> [Doc Markup]
forall a b. (a -> b) -> a -> b
$
    Map LabelName (Label CoverCount) -> [Label CoverCount]
forall k a. Map k a -> [a]
Map.elems (Coverage CoverCount -> Map LabelName (Label CoverCount)
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 p0 :: Int
p0 m0 :: Int
m0 n0 :: Int
n0 f0 :: Int
f0) (ColumnWidth p1 :: Int
p1 m1 :: Int
m1 n1 :: Int
n1 f1 :: Int
f1) =
    Int -> Int -> Int -> Int -> ColumnWidth
ColumnWidth
      (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
p0 Int
p1)
      (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
m0 Int
m1)
      (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
n0 Int
n1)
      (Int -> Int -> Int
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 0 0 0 0
  mappend :: ColumnWidth -> ColumnWidth -> ColumnWidth
mappend =
    ColumnWidth -> ColumnWidth -> ColumnWidth
forall a. Semigroup a => a -> a -> a
(<>)

coverageWidth :: TestCount -> Coverage CoverCount -> ColumnWidth
coverageWidth :: TestCount -> Coverage CoverCount -> ColumnWidth
coverageWidth tests :: TestCount
tests (Coverage labels :: Map LabelName (Label CoverCount)
labels) =
  (Label CoverCount -> ColumnWidth)
-> Map LabelName (Label CoverCount) -> ColumnWidth
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 tests :: TestCount
tests x :: Label CoverCount
x =
  let
    percentage :: Int
percentage =
      String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> (CoverCount -> String) -> CoverCount -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      CoverPercentage -> String
renderCoverPercentage (CoverPercentage -> String)
-> (CoverCount -> CoverPercentage) -> CoverCount -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      TestCount -> CoverCount -> CoverPercentage
coverPercentage TestCount
tests (CoverCount -> Int) -> CoverCount -> Int
forall a b. (a -> b) -> a -> b
$
      Label CoverCount -> CoverCount
forall a. Label a -> a
labelAnnotation Label CoverCount
x

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

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

    nameFail :: Int
nameFail =
      if TestCount -> Label CoverCount -> Bool
labelCovered TestCount
tests Label CoverCount
x then
        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 :: Int -> Doc a -> Doc a
ppLeftPad n :: Int
n doc :: Doc a
doc =
  let
    ndoc :: Int
ndoc =
      String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Doc a -> String
forall a. Show a => a -> String
show Doc a
doc)

    pad :: Doc a
pad =
      String -> Doc a
forall a. String -> Doc a
WL.text (String -> Doc a) -> String -> Doc a
forall a b. (a -> b) -> a -> b
$
        Int -> Char -> String
forall a. Int -> a -> [a]
List.replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ndoc) ' '
  in
    Doc a
forall a. Doc a
pad Doc a -> Doc a -> Doc a
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 tests :: TestCount
tests w :: ColumnWidth
w x :: Label CoverCount
x@(MkLabel name :: LabelName
name _ minimum_ :: CoverPercentage
minimum_ count :: 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
        Markup -> Doc Markup -> Doc Markup
forall a. a -> Doc a -> Doc a
WL.annotate Markup
CoverageText
      else
        Doc Markup -> Doc Markup
forall a. a -> a
id

    lborder :: Doc Markup -> Doc Markup
lborder =
      Markup -> Doc Markup -> Doc Markup
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
        Markup -> Doc Markup -> Doc Markup
forall a. a -> Doc a -> Doc a
WL.annotate Markup
CoverageText "⚠ "
      else
        "  "

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

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

    wcover :: String -> Doc Markup
wcover i :: String
i =
      Int -> Doc Markup -> Doc Markup
forall a. Int -> Doc a -> Doc a
ppLeftPad (ColumnWidth -> Int
widthPercentage ColumnWidth
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
i) (Doc Markup -> Doc Markup) -> Doc Markup -> Doc Markup
forall a b. (a -> b) -> a -> b
$
        String -> Doc Markup
forall a. String -> Doc a
WL.text String
i Doc Markup -> Doc Markup -> Doc Markup
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then
        Doc Markup
forall a. Monoid a => a
mempty
      else if Bool -> Bool
not Bool
covered then
        " ✗ " Doc Markup -> Doc Markup -> Doc Markup
forall a. Semigroup a => a -> a -> a
<> Doc Markup
wminimum
      else if CoverPercentage
minimum_ CoverPercentage -> CoverPercentage -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then
        "   " Doc Markup -> Doc Markup -> Doc Markup
forall a. Semigroup a => a -> a -> a
<> Int -> Doc Markup -> Doc Markup
forall a. Int -> Doc a -> Doc a
ppLeftPad (ColumnWidth -> Int
widthMinimum ColumnWidth
w) ""
      else
        " ✓ " Doc Markup -> Doc Markup -> Doc Markup
forall a. Semigroup a => a -> a -> a
<> Doc Markup
wminimum

    lcover :: Doc Markup
lcover =
      if ColumnWidth -> Int
widthMinimum ColumnWidth
w Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then
        String -> Doc Markup
wcover ""
      else if Bool -> Bool
not Bool
covered then
        String -> Doc Markup
wcover ""
      else if CoverPercentage
minimum_ CoverPercentage -> CoverPercentage -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then
        String -> Doc Markup
wcover ""
      else
        String -> Doc Markup
wcover ""
  in
    [Doc Markup] -> Doc Markup
forall (f :: * -> *) a. Foldable f => f (Doc a) -> Doc a
WL.hcat [
        Doc Markup
licon
      , Doc Markup -> Doc Markup
ltext Doc Markup
forall a. Doc a
lname
      , Doc Markup -> Doc Markup
lborder " "
      , Doc Markup -> Doc Markup
ltext Doc Markup
lcover
      , Doc Markup -> Doc Markup
lborder " "
      , Doc Markup -> Doc Markup
ltext (Doc Markup -> Doc Markup) -> Doc Markup -> Doc Markup
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
ltext Doc Markup
lminimum
      ]

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

ppCoverPercentage :: CoverPercentage -> Doc Markup
ppCoverPercentage :: CoverPercentage -> Doc Markup
ppCoverPercentage =
  String -> Doc Markup
forall a. String -> Doc a
WL.text (String -> Doc Markup)
-> (CoverPercentage -> String) -> CoverPercentage -> Doc Markup
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 percentage :: Double
percentage) (CoverPercentage minimum_ :: Double
minimum_) =
  let
    barWidth :: Int
    barWidth :: Int
barWidth =
      20

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

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

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

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

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

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

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

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

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

    bar :: (Char, [Char]) -> Doc Markup
    bar :: (Char, String) -> Doc Markup
bar (full :: Char
full, parts :: String
parts) =
      [Doc Markup] -> Doc Markup
forall (f :: * -> *) a. Foldable f => f (Doc a) -> Doc a
WL.hcat [
        String -> Doc Markup
forall a. String -> Doc a
WL.text (String -> Doc Markup) -> String -> Doc Markup
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
coverageWidth_ Char
full
      , if Int
fillWidth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 then
          if String -> Int
forall a. [a] -> Int
index String
parts Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then
            if Int
fillErrorWidth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 then
              Markup -> Doc Markup -> Doc Markup
forall a. a -> Doc a -> Doc a
WL.annotate Markup
FailedText (Doc Markup -> Doc Markup) -> Doc Markup -> Doc Markup
forall a b. (a -> b) -> a -> b
$ String -> Doc Markup
forall a. String -> Doc a
WL.text [String -> Char
forall a. [a] -> a
part String
parts]
            else
              Markup -> Doc Markup -> Doc Markup
forall a. a -> Doc a -> Doc a
WL.annotate Markup
CoverageFill (Doc Markup -> Doc Markup) -> Doc Markup -> Doc Markup
forall a b. (a -> b) -> a -> b
$ String -> Doc Markup
forall a. String -> Doc a
WL.text [String -> Char
forall a. [a] -> a
part String
parts]
          else
            String -> Doc Markup
forall a. String -> Doc a
WL.text [String -> Char
forall a. [a] -> a
part String
parts]
        else
          ""
      , Markup -> Doc Markup -> Doc Markup
forall a. a -> Doc a -> Doc a
WL.annotate Markup
FailedText (Doc Markup -> Doc Markup)
-> (String -> Doc Markup) -> String -> Doc Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc Markup
forall a. String -> Doc a
WL.text (String -> Doc Markup) -> String -> Doc Markup
forall a b. (a -> b) -> a -> b
$
          Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
fillErrorWidth (String -> Char
forall a. [a] -> a
head String
parts)
      , Markup -> Doc Markup -> Doc Markup
forall a. a -> Doc a -> Doc a
WL.annotate Markup
CoverageFill (Doc Markup -> Doc Markup)
-> (String -> Doc Markup) -> String -> Doc Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc Markup
forall a. String -> Doc a
WL.text (String -> Doc Markup) -> String -> Doc Markup
forall a b. (a -> b) -> a -> b
$
          Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
fillSurplusWidth (String -> Char
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 ('█', ['·', '▏', '▎', '▍', '▌', '▋', '▊', '▉'])

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

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

ppWhenNonZero :: Doc a -> PropertyCount -> Maybe (Doc a)
ppWhenNonZero :: Doc a -> PropertyCount -> Maybe (Doc a)
ppWhenNonZero suffix :: Doc a
suffix n :: PropertyCount
n =
  if PropertyCount
n PropertyCount -> PropertyCount -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 then
    Maybe (Doc a)
forall a. Maybe a
Nothing
  else
    Doc a -> Maybe (Doc a)
forall a. a -> Maybe a
Just (Doc a -> Maybe (Doc a)) -> Doc a -> Maybe (Doc a)
forall a b. (a -> b) -> a -> b
$ PropertyCount -> Doc a
forall a. PropertyCount -> Doc a
ppRawPropertyCount PropertyCount
n Doc a -> Doc a -> Doc a
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
summary =
  if Summary -> PropertyCount
summaryFailed Summary
summary PropertyCount -> PropertyCount -> Bool
forall a. Ord a => a -> a -> Bool
> 0 then
    Markup -> Char -> Doc Markup -> Doc Markup
icon Markup
FailedIcon '✗' (Doc Markup -> Doc Markup)
-> (Doc Markup -> Doc Markup) -> Doc Markup -> Doc Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markup -> Doc Markup -> Doc Markup
forall a. a -> Doc a -> Doc a
WL.annotate Markup
FailedText
  else if Summary -> PropertyCount
summaryGaveUp Summary
summary PropertyCount -> PropertyCount -> Bool
forall a. Ord a => a -> a -> Bool
> 0 then
    Markup -> Char -> Doc Markup -> Doc Markup
icon Markup
GaveUpIcon '⚐' (Doc Markup -> Doc Markup)
-> (Doc Markup -> Doc Markup) -> Doc Markup -> Doc Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markup -> Doc Markup -> Doc Markup
forall a. a -> Doc a -> Doc a
WL.annotate Markup
GaveUpText
  else if Summary -> PropertyCount
summaryWaiting Summary
summary PropertyCount -> PropertyCount -> Bool
forall a. Ord a => a -> a -> Bool
> 0 Bool -> Bool -> Bool
|| Summary -> PropertyCount
summaryRunning Summary
summary PropertyCount -> PropertyCount -> Bool
forall a. Ord a => a -> a -> Bool
> 0 then
    Markup -> Char -> Doc Markup -> Doc Markup
icon Markup
WaitingIcon '○' (Doc Markup -> Doc Markup)
-> (Doc Markup -> Doc Markup) -> Doc Markup -> Doc Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markup -> Doc Markup -> Doc Markup
forall a. a -> Doc a -> Doc a
WL.annotate Markup
WaitingHeader
  else
    Markup -> Char -> Doc Markup -> Doc Markup
icon Markup
SuccessIcon '✓' (Doc Markup -> Doc Markup)
-> (Doc Markup -> Doc Markup) -> Doc Markup -> Doc Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markup -> Doc Markup -> Doc Markup
forall a. a -> Doc a -> Doc a
WL.annotate Markup
SuccessText

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

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

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

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

renderDoc :: MonadIO m => UseColor -> Doc Markup -> m String
renderDoc :: UseColor -> Doc Markup -> m String
renderDoc color :: UseColor
color doc :: 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
      WaitingIcon ->
        [SGR] -> String
setSGRCode []
      WaitingHeader ->
        [SGR] -> String
setSGRCode []
      RunningIcon ->
        [SGR] -> String
setSGRCode []
      RunningHeader ->
        [SGR] -> String
setSGRCode []
      ShrinkingIcon ->
        [SGR] -> String
setSGRCode [Color -> SGR
vivid Color
Red]
      ShrinkingHeader ->
        [SGR] -> String
setSGRCode [Color -> SGR
vivid Color
Red]
      FailedIcon ->
        [SGR] -> String
setSGRCode [Color -> SGR
vivid Color
Red]
      FailedText ->
        [SGR] -> String
setSGRCode [Color -> SGR
vivid Color
Red]
      GaveUpIcon ->
        [SGR] -> String
setSGRCode [Color -> SGR
dull Color
Yellow]
      GaveUpText ->
        [SGR] -> String
setSGRCode [Color -> SGR
dull Color
Yellow]
      SuccessIcon ->
        [SGR] -> String
setSGRCode [Color -> SGR
dull Color
Green]
      SuccessText ->
        [SGR] -> String
setSGRCode [Color -> SGR
dull Color
Green]
      CoverageIcon ->
        [SGR] -> String
setSGRCode [Color -> SGR
dull Color
Yellow]
      CoverageText ->
        [SGR] -> String
setSGRCode [Color -> SGR
dull Color
Yellow]
      CoverageFill ->
        [SGR] -> String
setSGRCode [Color -> SGR
vivid Color
Black]

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

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

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

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

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

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

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

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

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

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

renderProgress :: MonadIO m => UseColor -> Maybe PropertyName -> Report Progress -> m String
renderProgress :: UseColor -> Maybe PropertyName -> Report Progress -> m String
renderProgress color :: UseColor
color name :: Maybe PropertyName
name x :: Report Progress
x =
  UseColor -> Doc Markup -> m String
forall (m :: * -> *).
MonadIO m =>
UseColor -> Doc Markup -> m String
renderDoc UseColor
color (Doc Markup -> m String) -> m (Doc Markup) -> m String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe PropertyName -> Report Progress -> m (Doc Markup)
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 :: UseColor -> Maybe PropertyName -> Report Result -> m String
renderResult color :: UseColor
color name :: Maybe PropertyName
name x :: Report Result
x =
  UseColor -> Doc Markup -> m String
forall (m :: * -> *).
MonadIO m =>
UseColor -> Doc Markup -> m String
renderDoc UseColor
color (Doc Markup -> m String) -> m (Doc Markup) -> m String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe PropertyName -> Report Result -> m (Doc Markup)
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 :: UseColor -> Summary -> m String
renderSummary color :: UseColor
color x :: Summary
x =
  UseColor -> Doc Markup -> m String
forall (m :: * -> *).
MonadIO m =>
UseColor -> Doc Markup -> m String
renderDoc UseColor
color (Doc Markup -> m String) -> m (Doc Markup) -> m String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Summary -> m (Doc Markup)
forall (m :: * -> *). MonadIO m => Summary -> m (Doc Markup)
ppSummary Summary
x