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

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

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

  , renderProgress
  , renderResult
  , renderSummary
  , renderDoc

  , ppProgress
  , ppResult
  , ppSummary

  , fromResult
  , mkFailure
  ) where

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

import           Data.Bifunctor (bimap, first, second)
import qualified Data.Char as Char
import           Data.Either (partitionEithers)
import qualified Data.List as List
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Maybe (mapMaybe, catMaybes)
import           Data.Traversable (for)

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

import           Hedgehog.Internal.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 PropertyCount
0 PropertyCount
0 PropertyCount
0 PropertyCount
0 PropertyCount
0
  mappend :: Summary -> Summary -> Summary
mappend (Summary PropertyCount
x1 PropertyCount
x2 PropertyCount
x3 PropertyCount
x4 PropertyCount
x5) (Summary PropertyCount
y1 PropertyCount
y2 PropertyCount
y3 PropertyCount
y4 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 FailureReport
_ ->
    Summary
forall a. Monoid a => a
mempty { summaryFailed :: PropertyCount
summaryFailed = PropertyCount
1 }
  Result
GaveUp ->
    Summary
forall a. Monoid a => a
mempty { summaryGaveUp :: PropertyCount
summaryGaveUp = PropertyCount
1 }
  Result
OK ->
    Summary
forall a. Monoid a => a
mempty { summaryOK :: PropertyCount
summaryOK = PropertyCount
1 }

summaryCompleted :: Summary -> PropertyCount
summaryCompleted :: Summary -> PropertyCount
summaryCompleted (Summary PropertyCount
_ PropertyCount
_ PropertyCount
x3 PropertyCount
x4 PropertyCount
x5) =
  PropertyCount
x3 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 PropertyCount
x1 PropertyCount
x2 PropertyCount
x3 PropertyCount
x4 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
(<>) Style
x Style
y =
    case (Style
x, Style
y) of
      (Style
StyleFailure, Style
_) ->
        Style
StyleFailure
      (Style
_, Style
StyleFailure) ->
        Style
StyleFailure
      (Style
StyleAnnotation, Style
_) ->
        Style
StyleAnnotation
      (Style
_, Style
StyleAnnotation) ->
        Style
StyleAnnotation
      (Style
StyleDefault, Style
_) ->
        Style
StyleDefault

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

takeAnnotation :: Log -> Maybe FailedAnnotation
takeAnnotation :: Log -> Maybe FailedAnnotation
takeAnnotation = \case
  Annotation Maybe Span
loc String
val ->
    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
  Log
_ ->
    Maybe FailedAnnotation
forall a. Maybe a
Nothing

takeFootnote :: Log -> Maybe String
takeFootnote :: Log -> Maybe String
takeFootnote = \case
  Footnote String
x ->
    String -> Maybe String
forall a. a -> Maybe a
Just String
x
  Log
_ ->
    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 Seed
seed ShrinkCount
shrinks Maybe (Coverage CoverCount)
mcoverage Maybe Span
location String
message Maybe Diff
diff [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 Markup
m Doc Markup
x =
  Markup -> Doc Markup -> Doc Markup
markup Markup
m Doc Markup
">" 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 Markup
m Char
i 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 Int
1 ->
    Doc a
"1 test"
  TestCount 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
<+> Doc a
"tests"

ppDiscardCount :: DiscardCount -> Doc a
ppDiscardCount :: DiscardCount -> Doc a
ppDiscardCount = \case
  DiscardCount Int
1 ->
    Doc a
"1 discard"
  DiscardCount 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
<+> Doc a
"discards"

ppShrinkCount :: ShrinkCount -> Doc a
ppShrinkCount :: ShrinkCount -> Doc a
ppShrinkCount = \case
  ShrinkCount Int
1 ->
    Doc a
"1 shrink"
  ShrinkCount 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
<+> Doc a
"shrinks"

ppRawPropertyCount :: PropertyCount -> Doc a
ppRawPropertyCount :: PropertyCount -> Doc a
ppRawPropertyCount (PropertyCount 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 Int
0 ->
    Doc Markup
forall a. Monoid a => a
mempty
  DiscardCount
n ->
    Doc Markup
" 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 ShrinkCount
s DiscardCount
d =
  case (ShrinkCount
s, DiscardCount
d) of
    (ShrinkCount
0, DiscardCount
0) ->
      Doc Markup
""
    (ShrinkCount
0, DiscardCount
_) ->
      Doc Markup
" 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
    (ShrinkCount
_, DiscardCount
0) ->
      Doc Markup
" 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
    (ShrinkCount
_, DiscardCount
_) ->
      Doc Markup
"," 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
<+> Doc Markup
"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 Map LineNo (Line a) -> Map LineNo (Line a)
f Declaration a
decl =
  Declaration a
decl {
      declarationSource :: Map LineNo (Line a)
declarationSource =
        Map LineNo (Line a) -> Map LineNo (Line a)
f (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 a
_ LineNo
_ String
x0) =
  let
    (String
pre, String
x1) =
      (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
Char.isSpace String
x0

    (String
_, 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 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
+ LineNo
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
- LineNo
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 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

    (String
name, Pos (Position String
_ LineNo
line0 ColumnNo
_) 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 Span
sloc 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
    Line a
x : [Line a]
_ ->
      (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 Int
ix (FailedAnnotation Maybe Span
_ 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 String
"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
<+> Doc Markup
"="
    , Int -> Doc Markup -> Doc Markup
forall a. Int -> Doc a -> Doc a
WL.indent Int
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 Maybe Span
msloc 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 String
"│ ") 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 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 Int
ix 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
    Maybe (Declaration (Style, [(Style, Doc Markup)]))
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 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 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 -> Doc Markup
forall a. Semigroup a => a -> a -> a
<> String -> Doc Markup
forall a. String -> Doc a
WL.text String
x

  LineRemoved 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 -> Doc Markup
forall a. Semigroup a => a -> a -> a
<> String -> Doc Markup
forall a. String -> Doc a
WL.text String
x

  LineAdded 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 -> 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 String
prefix String
removed String
infix_ String
added String
suffix 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 [Doc Markup]
msgs Maybe Diff
mdiff 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
    (Int
startCol, 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) Char
'^'))

      ppFailure :: Doc Markup -> Doc Markup
ppFailure 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 String
"│ ") 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
          Maybe Diff
Nothing ->
            []
          Just 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 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 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
    Maybe
  (Line (Style, [(Style, Doc Markup)]),
   Map LineNo (Line (Style, [(Style, Doc Markup)])))
Nothing ->
      Doc Markup
forall a. Monoid a => a
mempty
    Just (Line (Style, [(Style, Doc Markup)])
lastLine, Map LineNo (Line (Style, [(Style, Doc Markup)]))
_) ->
      let
        ppLocation :: Doc Markup
ppLocation =
          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
+ Int
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 -> 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) Doc Markup
"━━━"

        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
"%" 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
<> String
"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 Char
' '

        ppSource :: Style -> LineNo -> String -> Doc Markup
ppSource Style
style LineNo
n String
src =
          Markup -> Doc Markup -> Doc Markup
markup (Style -> Markup
StyledLineNo Style
style) (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 -> 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, 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 -> Doc Markup
forall a. Doc a -> Doc a -> Doc a
<+>
          Doc Markup
doc

        ppLines :: [Doc Markup]
ppLines = do
          Line (Style
style, [(Style, Doc Markup)]
xs) LineNo
n String
src <- 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 Maybe PropertyName
name Size
size 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
        Doc Markup
"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
$
        Doc Markup
"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 Int
11 Size
size String
"") 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 Int
11 Seed
seed String
"") 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 Doc Markup
"<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 a
x LineNo
no String
src) (Line a
y LineNo
_ String
_) =
  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 String
file LineNo
line String
name Map LineNo (Line a)
src0) (Declaration String
_ LineNo
_ String
_ 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 (\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 Maybe PropertyName
name TestCount
tests (FailureReport Size
size Seed
seed ShrinkCount
_ Maybe (Coverage CoverCount)
mcoverage [FailedAnnotation]
inputs0 Maybe Span
mlocation0 String
msg Maybe Diff
mdiff [String]
msgs0) = do
  let
    basic :: ([Doc Markup], Maybe a)
basic =
      -- Move the failure message to the end section if we have
      -- no source location or can't find the source file.
      let
        msgs1 :: [String]
msgs1 =
          [String]
msgs0 [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]
docs, Maybe a
forall a. Maybe a
Nothing)

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

      Just Span
location0 -> do
        Maybe (Declaration (Style, [(Style, Doc Markup)]))
mAdvanced <-
          [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
        case Maybe (Declaration (Style, [(Style, Doc Markup)]))
mAdvanced of
          Just Declaration (Style, [(Style, Doc Markup)])
advanced ->
            ([Doc Markup], Maybe (Declaration (Style, [(Style, Doc Markup)])))
-> m ([Doc Markup],
      Maybe (Declaration (Style, [(Style, Doc Markup)])))
forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> [Doc Markup]) -> [String] -> [Doc Markup]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [Doc Markup]
ppTextLines [String]
msgs0, Declaration (Style, [(Style, Doc Markup)])
-> Maybe (Declaration (Style, [(Style, Doc Markup)]))
forall a. a -> Maybe a
Just Declaration (Style, [(Style, Doc Markup)])
advanced)
          Maybe (Declaration (Style, [(Style, Doc Markup)]))
Nothing ->
            ([Doc Markup], Maybe (Declaration (Style, [(Style, Doc Markup)])))
-> m ([Doc Markup],
      Maybe (Declaration (Style, [(Style, Doc Markup)])))
forall (m :: * -> *) a. Monad m => a -> m a
return ([Doc Markup], Maybe (Declaration (Style, [(Style, Doc Markup)])))
forall a. ([Doc Markup], Maybe a)
basic

  [Maybe (Declaration (Style, [(Style, Doc Markup)]))]
coverageLocations <-
    case Maybe (Coverage CoverCount)
mcoverage of
      Maybe (Coverage CoverCount)
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 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 LabelName
_ Maybe Span
mclocation CoverPercentage
_ CoverCount
count) ->
          case Maybe Span
mclocation of
            Maybe Span
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 Span
clocation ->
              let
                coverageMsg :: Doc Markup
coverageMsg =
                  [Doc Markup] -> Doc Markup
forall (f :: * -> *) a. Foldable f => f (Doc a) -> Doc a
WL.cat [
                      Doc Markup
"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
<> Doc Markup
" coverage"
                    , Doc Markup
")"
                    ]
              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

  ([Doc Markup]
args, [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 [Int
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 t a
xs 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 t a -> t a
f 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 Int
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]
List.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
  Maybe PropertyName
Nothing ->
    Doc a
"<interactive>"
  Just (PropertyName 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 Maybe PropertyName
name (Report TestCount
tests DiscardCount
discards Coverage CoverCount
coverage Progress
status) =
  case Progress
status of
    Progress
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 Char
'●' (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
<+>
            Doc Markup
"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
<+>
            Doc Markup
"(running)"
        ] [Doc Markup] -> [Doc Markup] -> [Doc Markup]
forall a. [a] -> [a] -> [a]
++
        TestCount -> Coverage CoverCount -> [Doc Markup]
ppCoverage TestCount
tests Coverage CoverCount
coverage

    Shrinking 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 Char
'↯' (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
<+>
        Doc Markup
"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
<#>
        Doc Markup
"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
<+>
        Doc Markup
"(shrinking)"

ppResult :: MonadIO m => Maybe PropertyName -> Report Result -> m (Doc Markup)
ppResult :: Maybe PropertyName -> Report Result -> m (Doc Markup)
ppResult Maybe PropertyName
name (Report TestCount
tests DiscardCount
discards Coverage CoverCount
coverage Result
result) = do
  case Result
result of
    Failed 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 Char
'✗' (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
<+>
            Doc Markup
"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
<#>
            Doc Markup
"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] -> [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

    Result
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 Char
'⚐' (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
<+>
            Doc Markup
"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
<>
            Doc Markup
", 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] -> [Doc Markup]
forall a. [a] -> [a] -> [a]
++
        TestCount -> Coverage CoverCount -> [Doc Markup]
ppCoverage TestCount
tests Coverage CoverCount
coverage

    Result
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 Char
'✓' (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
<+>
            Doc Markup
"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] -> [Doc Markup]
forall a. [a] -> [a] -> [a]
++
        TestCount -> Coverage CoverCount -> [Doc Markup]
ppCoverage TestCount
tests Coverage CoverCount
coverage

ppFailedAtLocation :: Maybe Span -> Doc Markup
ppFailedAtLocation :: Maybe Span -> Doc Markup
ppFailedAtLocation = \case
  Just Span
x ->
    Doc Markup
"at" 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 -> 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 -> 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))
  Maybe Span
Nothing ->
    Doc Markup
forall a. Monoid a => a
mempty

ppCoverage :: TestCount -> Coverage CoverCount -> [Doc Markup]
ppCoverage :: TestCount -> Coverage CoverCount -> [Doc Markup]
ppCoverage TestCount
tests Coverage CoverCount
x =
  if 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 Int
p0 Int
m0 Int
n0 Int
f0) (ColumnWidth Int
p1 Int
m1 Int
n1 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 Int
0 Int
0 Int
0 Int
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 TestCount
tests (Coverage 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 TestCount
tests 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
== CoverPercentage
0 then
        Int
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
        Int
0
      else
        Int
name
  in
    Int -> Int -> Int -> Int -> ColumnWidth
ColumnWidth Int
percentage Int
minimum_ Int
name Int
nameFail

ppLeftPad :: Int -> Doc a -> Doc a
ppLeftPad :: Int -> Doc a -> Doc a
ppLeftPad Int
n 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) Char
' '
  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 TestCount
tests ColumnWidth
w x :: Label CoverCount
x@(MkLabel LabelName
name Maybe Span
_ CoverPercentage
minimum_ CoverCount
count) =
  let
    covered :: Bool
covered =
      TestCount -> Label CoverCount -> Bool
labelCovered TestCount
tests Label CoverCount
x

    ltext :: Doc Markup -> Doc Markup
ltext =
      if Bool -> Bool
not Bool
covered then
        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 Doc Markup
"⚠ "
      else
        Doc Markup
"  "

    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 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
== Int
0 then
        Doc Markup
forall a. Monoid a => a
mempty
      else if Bool -> Bool
not Bool
covered then
        Doc Markup
" ✗ " 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
== CoverPercentage
0 then
        Doc Markup
"   " 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) Doc Markup
""
      else
        Doc Markup
" ✓ " 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
== Int
0 then
        String -> Doc Markup
wcover String
""
      else if Bool -> Bool
not Bool
covered then
        String -> Doc Markup
wcover String
""
      else if CoverPercentage
minimum_ CoverPercentage -> CoverPercentage -> Bool
forall a. Eq a => a -> a -> Bool
== CoverPercentage
0 then
        String -> Doc Markup
wcover String
""
      else
        String -> Doc Markup
wcover String
""
  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 -> Doc Markup
ltext Doc Markup
lcover
      , Doc Markup -> Doc Markup
lborder Doc Markup
" "
      , 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 -> Doc Markup
ltext Doc Markup
lminimum
      ]

ppLabelName :: LabelName -> Doc a
ppLabelName :: LabelName -> Doc a
ppLabelName (LabelName 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 Double
percentage) (CoverPercentage Double
minimum_) =
  let
    barWidth :: Int
    barWidth :: Int
barWidth =
      Int
20

    coverageRatio :: Double
    coverageRatio :: Double
coverageRatio =
      Double
percentage Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
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
/ Double
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 [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 [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
- Int
1

    fillErrorWidth :: Int
fillErrorWidth =
      Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
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
- Int
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 (Char
full, 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
>= Int
0 then
          if String -> Int
forall a. [a] -> Int
index String
parts Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then
            if Int
fillErrorWidth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
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
          Doc Markup
""
      , 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 (Char
'█', [Char
'·', Char
'▏', Char
'▎', Char
'▍', Char
'▌', Char
'▋', Char
'▊', Char
'▉'])

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

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

ppWhenNonZero :: Doc a -> PropertyCount -> Maybe (Doc a)
ppWhenNonZero :: Doc a -> PropertyCount -> Maybe (Doc a)
ppWhenNonZero Doc a
suffix PropertyCount
n =
  if PropertyCount
n PropertyCount -> PropertyCount -> Bool
forall a. Ord a => a -> a -> Bool
<= PropertyCount
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 =
  if Summary -> PropertyCount
summaryFailed Summary
summary PropertyCount -> PropertyCount -> Bool
forall a. Ord a => a -> a -> Bool
> PropertyCount
0 then
    Markup -> Char -> Doc Markup -> Doc Markup
icon Markup
FailedIcon Char
'✗' (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
> PropertyCount
0 then
    Markup -> Char -> Doc Markup -> Doc Markup
icon Markup
GaveUpIcon Char
'⚐' (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
> PropertyCount
0 Bool -> Bool -> Bool
|| Summary -> PropertyCount
summaryRunning Summary
summary PropertyCount -> PropertyCount -> Bool
forall a. Ord a => a -> a -> Bool
> PropertyCount
0 then
    Markup -> Char -> Doc Markup -> Doc Markup
icon Markup
WaitingIcon Char
'○' (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 Char
'✓' (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 =
  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 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 -> 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
<+>
        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 [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] -> [Doc a]
forall a. a -> [a] -> [a]
: [Doc a]
xs

    suffix :: Doc Markup
suffix =
      if Bool
complete then
        Doc Markup
"."
      else
        Doc Markup
" (running)"
  in
    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
", " ([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 Doc Markup
"failed" (Summary -> PropertyCount
summaryFailed Summary
summary)
        , Doc Markup -> PropertyCount -> Maybe (Doc Markup)
forall a. Doc a -> PropertyCount -> Maybe (Doc a)
ppWhenNonZero Doc Markup
"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 Doc Markup
"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 UseColor
color Doc Markup
doc = do
  let
    dull :: Color -> SGR
dull =
      ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull

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

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

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

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

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

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

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

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

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

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

  let
    display :: SimpleDoc Markup -> String
display =
      case UseColor
color of
        UseColor
EnableColor ->
          (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
        UseColor
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 Int
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 Int
2 Doc Markup
doc

renderProgress :: MonadIO m => UseColor -> Maybe PropertyName -> Report Progress -> m String
renderProgress :: UseColor -> Maybe PropertyName -> Report Progress -> m String
renderProgress UseColor
color Maybe PropertyName
name 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 UseColor
color Maybe PropertyName
name 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 UseColor
color 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