{-# 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 (
Summary(..)
, Report(..)
, Progress(..)
, Result(..)
, FailureReport(..)
, FailedAnnotation(..)
, Style(..)
, Markup(..)
, Config(..)
, defaultConfig
, Context(..)
, Lines
, PrintPrefixIcons(..)
, renderProgress
, renderResult
, renderResultWith
, renderSummary
, renderDoc
, ppProgress
, ppResult
, ppResultWith
, ppSummary
, fromResult
, mkFailure
) where
import Control.Monad (zipWithM)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.Bifunctor (bimap, first, second)
import qualified Data.Char as Char
import Data.Either (partitionEithers)
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (mapMaybe, catMaybes)
#if !MIN_VERSION_base(4,11,0)
import qualified Data.Semigroup as Semigroup
#endif
import Data.Traversable (for)
import Hedgehog.Internal.Config
import Hedgehog.Internal.Discovery (Pos(..), Position(..))
import qualified Hedgehog.Internal.Discovery as Discovery
import Hedgehog.Internal.Prelude
import Hedgehog.Internal.Property (CoverCount(..), CoverPercentage(..))
import Hedgehog.Internal.Property (Coverage(..), Label(..), LabelName(..))
import Hedgehog.Internal.Property (PropertyName(..), Log(..), Diff(..))
import Hedgehog.Internal.Property (ShrinkCount(..), PropertyCount(..))
import Hedgehog.Internal.Property (TestCount(..), DiscardCount(..))
import Hedgehog.Internal.Property (coverPercentage, coverageFailures)
import Hedgehog.Internal.Property (labelCovered)
import Hedgehog.Internal.Property (ShrinkPath(..), skipCompress)
import Hedgehog.Internal.Show
import Hedgehog.Internal.Source
import System.Console.ANSI (ColorIntensity(..), Color(..))
import System.Console.ANSI (ConsoleLayer(..), ConsoleIntensity(..))
import System.Console.ANSI (SGR(..), setSGRCode)
import System.Directory (makeRelativeToCurrentDirectory)
#if mingw32_HOST_OS
import System.IO (hSetEncoding, stdout, stderr, utf8)
#endif
import Text.PrettyPrint.Annotated.WL (Doc, (<#>), (<+>))
import qualified Text.PrettyPrint.Annotated.WL as WL
import Text.Printf (printf)
data 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
$c== :: FailedAnnotation -> FailedAnnotation -> Bool
== :: FailedAnnotation -> FailedAnnotation -> Bool
$c/= :: FailedAnnotation -> FailedAnnotation -> Bool
/= :: 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
$cshowsPrec :: Int -> FailedAnnotation -> ShowS
showsPrec :: Int -> FailedAnnotation -> ShowS
$cshow :: FailedAnnotation -> String
show :: FailedAnnotation -> String
$cshowList :: [FailedAnnotation] -> ShowS
showList :: [FailedAnnotation] -> ShowS
Show)
data FailureReport =
FailureReport {
FailureReport -> ShrinkCount
failureShrinks :: !ShrinkCount
, FailureReport -> ShrinkPath
failureShrinkPath :: !ShrinkPath
, FailureReport -> Maybe (Coverage CoverCount)
failureCoverage :: !(Maybe (Coverage CoverCount))
, FailureReport -> [FailedAnnotation]
failureAnnotations :: ![FailedAnnotation]
, FailureReport -> Maybe Span
failureLocation :: !(Maybe Span)
, FailureReport -> String
failureMessage :: !String
, FailureReport -> Maybe Diff
failureDiff :: !(Maybe Diff)
, :: ![String]
} deriving (FailureReport -> FailureReport -> Bool
(FailureReport -> FailureReport -> Bool)
-> (FailureReport -> FailureReport -> Bool) -> Eq FailureReport
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FailureReport -> FailureReport -> Bool
== :: FailureReport -> FailureReport -> Bool
$c/= :: FailureReport -> FailureReport -> Bool
/= :: 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
$cshowsPrec :: Int -> FailureReport -> ShowS
showsPrec :: Int -> FailureReport -> ShowS
$cshow :: FailureReport -> String
show :: FailureReport -> String
$cshowList :: [FailureReport] -> ShowS
showList :: [FailureReport] -> ShowS
Show)
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
$c== :: Progress -> Progress -> Bool
== :: Progress -> Progress -> Bool
$c/= :: Progress -> Progress -> Bool
/= :: 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
$cshowsPrec :: Int -> Progress -> ShowS
showsPrec :: Int -> Progress -> ShowS
$cshow :: Progress -> String
show :: Progress -> String
$cshowList :: [Progress] -> ShowS
showList :: [Progress] -> ShowS
Show)
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
$c== :: Result -> Result -> Bool
== :: Result -> Result -> Bool
$c/= :: Result -> Result -> Bool
/= :: 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
$cshowsPrec :: Int -> Result -> ShowS
showsPrec :: Int -> Result -> ShowS
$cshow :: Result -> String
show :: Result -> String
$cshowList :: [Result] -> ShowS
showList :: [Result] -> ShowS
Show)
data Report a =
Report {
forall a. Report a -> TestCount
reportTests :: !TestCount
, forall a. Report a -> DiscardCount
reportDiscards :: !DiscardCount
, forall a. Report a -> Coverage CoverCount
reportCoverage :: !(Coverage CoverCount)
, forall a. Report a -> Seed
reportSeed :: !Seed
, forall a. Report a -> a
reportStatus :: !a
} deriving (Int -> Report a -> ShowS
[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
$cshowsPrec :: forall a. Show a => Int -> Report a -> ShowS
showsPrec :: Int -> Report a -> ShowS
$cshow :: forall a. Show a => Report a -> String
show :: Report a -> String
$cshowList :: forall a. Show a => [Report a] -> ShowS
showList :: [Report a] -> ShowS
Show, (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
$cfmap :: forall a b. (a -> b) -> Report a -> Report b
fmap :: forall a b. (a -> b) -> Report a -> Report b
$c<$ :: forall a b. a -> Report b -> Report a
<$ :: forall a b. a -> Report b -> Report a
Functor, (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
$cfold :: forall m. Monoid m => Report m -> m
fold :: forall m. Monoid m => Report m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Report a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Report a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Report a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Report a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Report a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Report a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Report a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Report a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Report a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Report a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Report a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Report a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Report a -> a
foldr1 :: forall a. (a -> a -> a) -> Report a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Report a -> a
foldl1 :: forall a. (a -> a -> a) -> Report a -> a
$ctoList :: forall a. Report a -> [a]
toList :: forall a. Report a -> [a]
$cnull :: forall a. Report a -> Bool
null :: forall a. Report a -> Bool
$clength :: forall a. Report a -> Int
length :: forall a. Report a -> Int
$celem :: forall a. Eq a => a -> Report a -> Bool
elem :: forall a. Eq a => a -> Report a -> Bool
$cmaximum :: forall a. Ord a => Report a -> a
maximum :: forall a. Ord a => Report a -> a
$cminimum :: forall a. Ord a => Report a -> a
minimum :: forall a. Ord a => Report a -> a
$csum :: forall a. Num a => Report a -> a
sum :: forall a. Num a => Report a -> a
$cproduct :: forall a. Num a => Report a -> a
product :: forall a. Num a => Report a -> a
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
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)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Report a -> f (Report b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Report a -> f (Report b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Report (f a) -> f (Report a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Report (f a) -> f (Report a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Report a -> m (Report b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Report a -> m (Report b)
$csequence :: forall (m :: * -> *) a. Monad m => Report (m a) -> m (Report a)
sequence :: forall (m :: * -> *) a. Monad m => Report (m a) -> m (Report a)
Traversable)
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
$cshowsPrec :: Int -> Summary -> ShowS
showsPrec :: Int -> Summary -> ShowS
$cshow :: Summary -> String
show :: Summary -> String
$cshowList :: [Summary] -> ShowS
showList :: [Summary] -> ShowS
Show)
instance Monoid Summary where
#if !MIN_VERSION_base(4,11,0)
mappend = (Semigroup.<>)
#endif
mempty :: Summary
mempty =
PropertyCount
-> PropertyCount
-> PropertyCount
-> PropertyCount
-> PropertyCount
-> Summary
Summary PropertyCount
0 PropertyCount
0 PropertyCount
0 PropertyCount
0 PropertyCount
0
instance Semigroup Summary where
Summary PropertyCount
x1 PropertyCount
x2 PropertyCount
x3 PropertyCount
x4 PropertyCount
x5 <> :: Summary -> Summary -> Summary
<> Summary PropertyCount
y1 PropertyCount
y2 PropertyCount
y3 PropertyCount
y4 PropertyCount
y5 =
PropertyCount
-> PropertyCount
-> PropertyCount
-> PropertyCount
-> PropertyCount
-> Summary
Summary
(PropertyCount
x1 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)
fromResult :: Result -> Summary
fromResult :: Result -> Summary
fromResult = \case
Failed FailureReport
_ ->
Summary
forall a. Monoid a => a
mempty { summaryFailed = 1 }
Result
GaveUp ->
Summary
forall a. Monoid a => a
mempty { summaryGaveUp = 1 }
Result
OK ->
Summary
forall a. Monoid a => a
mempty { summaryOK = 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
data Line a =
Line {
forall a. Line a -> a
lineAnnotation :: !a
, forall a. Line a -> LineNo
lineNumber :: !LineNo
, forall a. Line a -> String
_lineSource :: !String
} deriving (Line a -> Line a -> Bool
(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
$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
/= :: 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
$ccompare :: forall a. Ord a => Line a -> Line a -> Ordering
compare :: Line a -> Line a -> Ordering
$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
>= :: Line a -> Line a -> Bool
$cmax :: forall a. Ord a => Line a -> Line a -> Line a
max :: Line a -> Line a -> Line a
$cmin :: forall a. Ord a => Line a -> Line a -> Line a
min :: Line a -> Line a -> 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
$cshowsPrec :: forall a. Show a => Int -> Line a -> ShowS
showsPrec :: Int -> Line a -> ShowS
$cshow :: forall a. Show a => Line a -> String
show :: Line a -> String
$cshowList :: forall a. Show a => [Line a] -> ShowS
showList :: [Line a] -> ShowS
Show, (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
$cfmap :: forall a b. (a -> b) -> Line a -> Line b
fmap :: forall a b. (a -> b) -> Line a -> Line b
$c<$ :: forall a b. a -> Line b -> Line a
<$ :: forall a b. a -> Line b -> Line a
Functor)
data Declaration a =
Declaration {
forall a. Declaration a -> String
declarationFile :: !FilePath
, forall a. Declaration a -> LineNo
declarationLine :: !LineNo
, forall a. Declaration a -> String
_declarationName :: !String
, forall a. Declaration a -> Map LineNo (Line a)
declarationSource :: !(Map LineNo (Line a))
} deriving (Declaration a -> Declaration a -> Bool
(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
$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
/= :: 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
$ccompare :: forall a. Ord a => Declaration a -> Declaration a -> Ordering
compare :: Declaration a -> Declaration a -> Ordering
$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
>= :: Declaration a -> Declaration a -> Bool
$cmax :: forall a. Ord a => Declaration a -> Declaration a -> Declaration a
max :: Declaration a -> Declaration a -> Declaration a
$cmin :: forall a. Ord a => Declaration a -> Declaration a -> Declaration a
min :: Declaration a -> Declaration a -> 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
$cshowsPrec :: forall a. Show a => Int -> Declaration a -> ShowS
showsPrec :: Int -> Declaration a -> ShowS
$cshow :: forall a. Show a => Declaration a -> String
show :: Declaration a -> String
$cshowList :: forall a. Show a => [Declaration a] -> ShowS
showList :: [Declaration a] -> ShowS
Show, (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
$cfmap :: forall a b. (a -> b) -> Declaration a -> Declaration b
fmap :: forall a b. (a -> b) -> Declaration a -> Declaration b
$c<$ :: forall a b. a -> Declaration b -> Declaration a
<$ :: forall a b. a -> Declaration b -> Declaration a
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
$c== :: Style -> Style -> Bool
== :: Style -> Style -> Bool
$c/= :: Style -> Style -> Bool
/= :: 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
$ccompare :: Style -> Style -> Ordering
compare :: Style -> Style -> Ordering
$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
>= :: Style -> Style -> Bool
$cmax :: Style -> Style -> Style
max :: Style -> Style -> Style
$cmin :: Style -> Style -> Style
min :: Style -> Style -> 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
$cshowsPrec :: Int -> Style -> ShowS
showsPrec :: Int -> Style -> ShowS
$cshow :: Style -> String
show :: Style -> String
$cshowList :: [Style] -> ShowS
showList :: [Style] -> ShowS
Show)
data Markup =
WaitingIcon
|
| RunningIcon
|
| ShrinkingIcon
|
| 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
|
| ReproduceGutter
| ReproduceSource
deriving (Markup -> Markup -> Bool
(Markup -> Markup -> Bool)
-> (Markup -> Markup -> Bool) -> Eq Markup
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Markup -> Markup -> Bool
== :: Markup -> Markup -> Bool
$c/= :: Markup -> Markup -> Bool
/= :: 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
$ccompare :: Markup -> Markup -> Ordering
compare :: Markup -> Markup -> Ordering
$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
>= :: Markup -> Markup -> Bool
$cmax :: Markup -> Markup -> Markup
max :: Markup -> Markup -> Markup
$cmin :: Markup -> Markup -> Markup
min :: Markup -> Markup -> 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
$cshowsPrec :: Int -> Markup -> ShowS
showsPrec :: Int -> Markup -> ShowS
$cshow :: Markup -> String
show :: Markup -> String
$cshowList :: [Markup] -> ShowS
showList :: [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
= \case
Footnote String
x ->
String -> Maybe String
forall a. a -> Maybe a
Just String
x
Log
_ ->
Maybe String
forall a. Maybe a
Nothing
mkFailure ::
ShrinkCount
-> ShrinkPath
-> Maybe (Coverage CoverCount)
-> Maybe Span
-> String
-> Maybe Diff
-> [Log]
-> FailureReport
mkFailure :: ShrinkCount
-> ShrinkPath
-> Maybe (Coverage CoverCount)
-> Maybe Span
-> String
-> Maybe Diff
-> [Log]
-> FailureReport
mkFailure ShrinkCount
shrinks ShrinkPath
shrinkPath Maybe (Coverage CoverCount)
mcoverage Maybe Span
location String
message Maybe Diff
diff [Log]
logs =
let
inputs :: [FailedAnnotation]
inputs =
(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
ShrinkCount
-> ShrinkPath
-> Maybe (Coverage CoverCount)
-> [FailedAnnotation]
-> Maybe Span
-> String
-> Maybe Diff
-> [String]
-> FailureReport
FailureReport ShrinkCount
shrinks ShrinkPath
shrinkPath Maybe (Coverage CoverCount)
mcoverage [FailedAnnotation]
inputs Maybe Span
location String
message Maybe Diff
diff [String]
footnotes
ppShow :: Show x => x -> Doc a
ppShow :: forall x a. Show x => x -> Doc a
ppShow =
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 :: PrintPrefixIcons -> Markup -> Char -> Doc Markup -> Doc Markup
icon :: PrintPrefixIcons -> Markup -> Char -> Doc Markup -> Doc Markup
icon PrintPrefixIcons
p Markup
m Char
i Doc Markup
x = case PrintPrefixIcons
p of
PrintPrefixIcons
DisablePrefixIcons -> Doc Markup
x
PrintPrefixIcons
EnablePrefixIcons -> 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 :: forall a. 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 :: forall a. 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 :: forall a. 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"
ppSkip :: Skip -> Doc a
ppSkip :: forall a. Skip -> Doc a
ppSkip =
String -> Doc a
forall a. String -> Doc a
WL.text (String -> Doc a) -> (Skip -> String) -> Skip -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Skip -> String
skipCompress
ppSkipReadable :: Skip -> Doc a
ppSkipReadable :: forall a. Skip -> Doc a
ppSkipReadable =
String -> Doc a
forall a. String -> Doc a
WL.text (String -> Doc a) -> (Skip -> String) -> Skip -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. Show a => a -> String
show ShowS -> (Skip -> String) -> Skip -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Skip -> String
skipCompress
ppRawPropertyCount :: PropertyCount -> Doc a
ppRawPropertyCount :: forall a. PropertyCount -> Doc a
ppRawPropertyCount (PropertyCount Int
n) =
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 :: forall a.
(Map LineNo (Line a) -> Map LineNo (Line a))
-> Declaration a -> Declaration a
mapSource Map LineNo (Line a) -> Map LineNo (Line a)
f Declaration a
decl =
Declaration a
decl {
declarationSource =
f (declarationSource decl)
}
lineSpan :: Line a -> (ColumnNo, ColumnNo)
lineSpan :: forall a. 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 a. [a] -> 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 a. [a] -> 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 :: forall a. 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 :: forall (m :: * -> *).
MonadIO m =>
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 a. IO a -> MaybeT m a
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 a. a -> MaybeT m a
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 :: forall a.
Declaration a -> Declaration (Style, [(Style, Doc Markup)])
defaultStyle =
(a -> (Style, [(Style, Doc Markup)]))
-> Declaration a -> Declaration (Style, [(Style, Doc Markup)])
forall a b. (a -> b) -> Declaration a -> Declaration b
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 :: forall (m :: * -> *) a.
Monad m =>
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 a. a -> m a
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 a. a -> MaybeT m a
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 a b. (a -> b) -> [a] -> [b]
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 :: forall (m :: * -> *).
MonadIO m =>
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 a. a -> m a
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 a b. (a -> b) -> MaybeT m a -> MaybeT m b
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 a b. (a -> b) -> [a] -> [b]
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 a b. (a -> b -> b) -> b -> [a] -> b
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 a b. (a -> b) -> f a -> f b
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 a b c. (a -> b) -> p a c -> p b 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 a b. (a -> b) -> Line a -> Line b
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 b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (([(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 a. a -> MaybeT m a
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 :: forall (m :: * -> *).
MonadIO m =>
Int
-> FailedAnnotation
-> m (Either
(Doc Markup) (Declaration (Style, [(Style, Doc Markup)])))
ppFailedInput Int
ix FailedAnnotation
input = do
Maybe (Declaration (Style, [(Style, Doc Markup)]))
mdecl <- 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 a. a -> m a
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 a. a -> m a
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 a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LineDiff -> Doc Markup
ppLineDiff (ValueDiff -> [LineDiff]
toLineDiff ValueDiff
diff)
ppFailureLocation ::
MonadIO m
=> [Doc Markup]
-> Maybe Diff
-> Span
-> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
ppFailureLocation :: forall (m :: * -> *).
MonadIO m =>
[Doc Markup]
-> Maybe Diff
-> Span
-> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
ppFailureLocation [Doc Markup]
msgs Maybe Diff
mdiff Span
sloc =
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 a b. (a -> b) -> MaybeT m a -> MaybeT m b
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 a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
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 a b. (a -> b) -> [a] -> [b]
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 a b. (a -> b) -> [a] -> [b]
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 a b. (a -> b -> b) -> b -> [a] -> b
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 a b. (a -> b) -> f a -> f b
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 a b c. (a -> b) -> p a c -> p b 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 a b. (a -> b) -> Line a -> Line b
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 b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (([(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 a. a -> MaybeT m a
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
type Annotation = (Style, [(Style, Doc Markup)])
newtype Lines = Lines Int
deriving (Lines -> Lines -> Bool
(Lines -> Lines -> Bool) -> (Lines -> Lines -> Bool) -> Eq Lines
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Lines -> Lines -> Bool
== :: Lines -> Lines -> Bool
$c/= :: Lines -> Lines -> Bool
/= :: Lines -> Lines -> Bool
Eq, Integer -> Lines
Lines -> Lines
Lines -> Lines -> Lines
(Lines -> Lines -> Lines)
-> (Lines -> Lines -> Lines)
-> (Lines -> Lines -> Lines)
-> (Lines -> Lines)
-> (Lines -> Lines)
-> (Lines -> Lines)
-> (Integer -> Lines)
-> Num Lines
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: Lines -> Lines -> Lines
+ :: Lines -> Lines -> Lines
$c- :: Lines -> Lines -> Lines
- :: Lines -> Lines -> Lines
$c* :: Lines -> Lines -> Lines
* :: Lines -> Lines -> Lines
$cnegate :: Lines -> Lines
negate :: Lines -> Lines
$cabs :: Lines -> Lines
abs :: Lines -> Lines
$csignum :: Lines -> Lines
signum :: Lines -> Lines
$cfromInteger :: Integer -> Lines
fromInteger :: Integer -> Lines
Num)
instance Show Lines where
showsPrec :: Int -> Lines -> ShowS
showsPrec Int
p (Lines Int
n) = Int -> Int -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p Int
n
data Context = FullContext | Context Lines
deriving (Context -> Context -> Bool
(Context -> Context -> Bool)
-> (Context -> Context -> Bool) -> Eq Context
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Context -> Context -> Bool
== :: Context -> Context -> Bool
$c/= :: Context -> Context -> Bool
/= :: Context -> Context -> Bool
Eq, Int -> Context -> ShowS
[Context] -> ShowS
Context -> String
(Int -> Context -> ShowS)
-> (Context -> String) -> ([Context] -> ShowS) -> Show Context
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Context -> ShowS
showsPrec :: Int -> Context -> ShowS
$cshow :: Context -> String
show :: Context -> String
$cshowList :: [Context] -> ShowS
showList :: [Context] -> ShowS
Show)
applyContext :: Context -> Declaration Annotation -> Declaration Annotation
applyContext :: Context
-> Declaration (Style, [(Style, Doc Markup)])
-> Declaration (Style, [(Style, Doc Markup)])
applyContext Context
context Declaration (Style, [(Style, Doc Markup)])
decl = case Context
context of
Context
FullContext -> Declaration (Style, [(Style, Doc Markup)])
decl
Context Lines
n -> Declaration (Style, [(Style, Doc Markup)])
decl { declarationSource = limitContextTo n (declarationSource decl) }
limitContextTo :: Lines -> Map LineNo (Line Annotation) -> Map LineNo (Line Annotation)
limitContextTo :: Lines
-> Map LineNo (Line (Style, [(Style, Doc Markup)]))
-> Map LineNo (Line (Style, [(Style, Doc Markup)]))
limitContextTo (Lines Int
context) =
let
skipBoring :: [(a, Line (Style, [(Style, Doc Markup)]))]
-> [(a, Line (Style, [(Style, Doc Markup)]))]
skipBoring [(a, Line (Style, [(Style, Doc Markup)]))]
xs = case ((a, Line (Style, [(Style, Doc Markup)])) -> Bool)
-> [(a, Line (Style, [(Style, Doc Markup)]))]
-> ([(a, Line (Style, [(Style, Doc Markup)]))],
[(a, Line (Style, [(Style, Doc Markup)]))])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (a, Line (Style, [(Style, Doc Markup)])) -> Bool
forall {a}. (a, Line (Style, [(Style, Doc Markup)])) -> Bool
isBoring [(a, Line (Style, [(Style, Doc Markup)]))]
xs of
([(a, Line (Style, [(Style, Doc Markup)]))]
boring, []) -> Int
-> [(a, Line (Style, [(Style, Doc Markup)]))]
-> [(a, Line (Style, [(Style, Doc Markup)]))]
forall a. Int -> [a] -> [a]
take Int
context [(a, Line (Style, [(Style, Doc Markup)]))]
boring
([(a, Line (Style, [(Style, Doc Markup)]))]
boring, [(a, Line (Style, [(Style, Doc Markup)]))]
rest) -> Int
-> [(a, Line (Style, [(Style, Doc Markup)]))]
-> [(a, Line (Style, [(Style, Doc Markup)]))]
forall a. Int -> [a] -> [a]
takeEnd Int
context [(a, Line (Style, [(Style, Doc Markup)]))]
boring [(a, Line (Style, [(Style, Doc Markup)]))]
-> [(a, Line (Style, [(Style, Doc Markup)]))]
-> [(a, Line (Style, [(Style, Doc Markup)]))]
forall a. Semigroup a => a -> a -> a
<> [(a, Line (Style, [(Style, Doc Markup)]))]
-> [(a, Line (Style, [(Style, Doc Markup)]))]
keepInteresting [(a, Line (Style, [(Style, Doc Markup)]))]
rest
keepInteresting :: [(a, Line (Style, [(Style, Doc Markup)]))]
-> [(a, Line (Style, [(Style, Doc Markup)]))]
keepInteresting [(a, Line (Style, [(Style, Doc Markup)]))]
xs = case ((a, Line (Style, [(Style, Doc Markup)])) -> Bool)
-> [(a, Line (Style, [(Style, Doc Markup)]))]
-> ([(a, Line (Style, [(Style, Doc Markup)]))],
[(a, Line (Style, [(Style, Doc Markup)]))])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (a, Line (Style, [(Style, Doc Markup)])) -> Bool
forall {a}. (a, Line (Style, [(Style, Doc Markup)])) -> Bool
isBoring [(a, Line (Style, [(Style, Doc Markup)]))]
xs of
([(a, Line (Style, [(Style, Doc Markup)]))]
interesting, [(a, Line (Style, [(Style, Doc Markup)]))]
rest) -> [(a, Line (Style, [(Style, Doc Markup)]))]
interesting [(a, Line (Style, [(Style, Doc Markup)]))]
-> [(a, Line (Style, [(Style, Doc Markup)]))]
-> [(a, Line (Style, [(Style, Doc Markup)]))]
forall a. Semigroup a => a -> a -> a
<> Int
-> [(a, Line (Style, [(Style, Doc Markup)]))]
-> [(a, Line (Style, [(Style, Doc Markup)]))]
forall a. Int -> [a] -> [a]
take Int
context [(a, Line (Style, [(Style, Doc Markup)]))]
rest [(a, Line (Style, [(Style, Doc Markup)]))]
-> [(a, Line (Style, [(Style, Doc Markup)]))]
-> [(a, Line (Style, [(Style, Doc Markup)]))]
forall a. Semigroup a => a -> a -> a
<> [(a, Line (Style, [(Style, Doc Markup)]))]
-> [(a, Line (Style, [(Style, Doc Markup)]))]
skipBoring [(a, Line (Style, [(Style, Doc Markup)]))]
rest
isBoring :: (a, Line (Style, [(Style, Doc Markup)])) -> Bool
isBoring = (Style, [(Style, Doc Markup)]) -> Bool
isBoringAnnotation ((Style, [(Style, Doc Markup)]) -> Bool)
-> ((a, Line (Style, [(Style, Doc Markup)]))
-> (Style, [(Style, Doc Markup)]))
-> (a, Line (Style, [(Style, Doc Markup)]))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line (Style, [(Style, Doc Markup)])
-> (Style, [(Style, Doc Markup)])
forall a. Line a -> a
lineAnnotation (Line (Style, [(Style, Doc Markup)])
-> (Style, [(Style, Doc Markup)]))
-> ((a, Line (Style, [(Style, Doc Markup)]))
-> Line (Style, [(Style, Doc Markup)]))
-> (a, Line (Style, [(Style, Doc Markup)]))
-> (Style, [(Style, Doc Markup)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Line (Style, [(Style, Doc Markup)]))
-> Line (Style, [(Style, Doc Markup)])
forall a b. (a, b) -> b
snd
in
[(LineNo, Line (Style, [(Style, Doc Markup)]))]
-> Map LineNo (Line (Style, [(Style, Doc Markup)]))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(LineNo, Line (Style, [(Style, Doc Markup)]))]
-> Map LineNo (Line (Style, [(Style, Doc Markup)])))
-> (Map LineNo (Line (Style, [(Style, Doc Markup)]))
-> [(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
. [(LineNo, Line (Style, [(Style, Doc Markup)]))]
-> [(LineNo, Line (Style, [(Style, Doc Markup)]))]
forall {a}.
[(a, Line (Style, [(Style, Doc Markup)]))]
-> [(a, Line (Style, [(Style, Doc Markup)]))]
skipBoring ([(LineNo, Line (Style, [(Style, Doc Markup)]))]
-> [(LineNo, Line (Style, [(Style, Doc Markup)]))])
-> (Map LineNo (Line (Style, [(Style, Doc Markup)]))
-> [(LineNo, Line (Style, [(Style, Doc Markup)]))])
-> Map LineNo (Line (Style, [(Style, Doc Markup)]))
-> [(LineNo, Line (Style, [(Style, Doc Markup)]))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map LineNo (Line (Style, [(Style, Doc Markup)]))
-> [(LineNo, Line (Style, [(Style, Doc Markup)]))]
forall k a. Map k a -> [(k, a)]
Map.toList
takeEnd :: Int -> [a] -> [a]
takeEnd :: forall a. Int -> [a] -> [a]
takeEnd Int
n = [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
n ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. [a] -> [a]
reverse
isBoringAnnotation :: Annotation -> Bool
isBoringAnnotation :: (Style, [(Style, Doc Markup)]) -> Bool
isBoringAnnotation = \ case
(Style
StyleDefault, []) -> Bool
True
(Style, [(Style, Doc Markup)])
_ -> Bool
False
ppDeclaration :: Declaration (Style, [(Style, Doc Markup)]) -> Doc Markup
ppDeclaration :: Declaration (Style, [(Style, Doc Markup)]) -> Doc Markup
ppDeclaration Declaration (Style, [(Style, Doc Markup)])
decl = let source :: Map LineNo (Line (Style, [(Style, Doc Markup)]))
source = 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 in
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)]))
source 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 a. [a] -> 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 :: forall a. 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 -> LineNo -> String -> Doc Markup
ppSource Style
style LineNo
n String
src =
(if LineNo -> Bool
isOmittedLine (LineNo -> LineNo
forall a. Enum a => a -> a
pred LineNo
n) then Doc Markup -> Doc Markup
addVerticalEllipsis else Doc Markup -> Doc Markup
forall a. a -> a
id) (Doc Markup -> Doc Markup) -> Doc Markup -> Doc Markup
forall a b. (a -> b) -> a -> b
$
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)
addVerticalEllipsis :: Doc Markup -> Doc Markup
addVerticalEllipsis =
(Doc Markup
verticalEllipsis Doc Markup -> Doc Markup -> Doc Markup
forall a. Doc a -> Doc a -> Doc a
<#>)
verticalEllipsis :: Doc Markup
verticalEllipsis =
Doc Markup
"\x22ee"
isOmittedLine :: LineNo -> Bool
isOmittedLine LineNo
n =
LineNo
n LineNo -> LineNo -> Bool
forall a. Ord a => a -> a -> Bool
>= LineNo
firstLine Bool -> Bool -> Bool
&& LineNo -> Map LineNo (Line (Style, [(Style, Doc Markup)])) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember LineNo
n Map LineNo (Line (Style, [(Style, Doc Markup)]))
source
firstLine :: LineNo
firstLine =
(LineNo, Line (Style, [(Style, Doc Markup)])) -> LineNo
forall a b. (a, b) -> a
fst ((LineNo, Line (Style, [(Style, Doc Markup)])) -> LineNo)
-> (LineNo, Line (Style, [(Style, Doc Markup)])) -> LineNo
forall a b. (a -> b) -> a -> b
$ Map LineNo (Line (Style, [(Style, Doc Markup)]))
-> (LineNo, Line (Style, [(Style, Doc Markup)]))
forall k a. Map k a -> (k, a)
Map.findMin Map LineNo (Line (Style, [(Style, Doc Markup)]))
source
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)]))
source
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 a b. (a -> b) -> [a] -> [b]
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 -> Seed -> Skip -> Doc Markup
ppReproduce :: Maybe PropertyName -> Seed -> Skip -> Doc Markup
ppReproduce Maybe PropertyName
name Seed
seed Skip
skip =
[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
"recheckAt" 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
<+>
Skip -> Doc Markup
forall a. Skip -> Doc a
ppSkipReadable Skip
skip 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 :: forall a. Semigroup a => 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 :: forall a.
Semigroup a =>
Declaration a -> Declaration a -> Declaration a
mergeDeclaration (Declaration String
file LineNo
line String
name Map LineNo (Line a)
src0) (Declaration String
_ LineNo
_ String
_ Map LineNo (Line a)
src1) =
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 :: forall a. Semigroup a => [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 a b. (a -> b) -> [a] -> [b]
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 a b. (a -> b) -> [a] -> [b]
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 => Config -> Maybe PropertyName -> TestCount -> DiscardCount -> Seed -> FailureReport -> m [Doc Markup]
ppFailureReport :: forall (m :: * -> *).
MonadIO m =>
Config
-> Maybe PropertyName
-> TestCount
-> DiscardCount
-> Seed
-> FailureReport
-> m [Doc Markup]
ppFailureReport Config
config Maybe PropertyName
name TestCount
tests DiscardCount
discards Seed
seed (FailureReport ShrinkCount
_ ShrinkPath
shrinkPath Maybe (Coverage CoverCount)
mcoverage [FailedAnnotation]
inputs0 Maybe Span
mlocation0 String
msg Maybe Diff
mdiff [String]
msgs0) = do
let
basic :: ([Doc Markup], Maybe a)
basic =
let
msgs1 :: [String]
msgs1 =
[String]
msgs0 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
(if String -> Bool
forall a. [a] -> 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 a. a -> m a
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 a b. (a -> b) -> [a] -> [b]
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 a. a -> m a
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 a. a -> m a
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 a. a -> m a
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 a. a -> m a
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 a b. (a -> b) -> m a -> m b
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)])]
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)])])
-> [Declaration (Style, [(Style, Doc Markup)])]
-> [Declaration (Style, [(Style, Doc Markup)])]
forall a b. (a -> b) -> a -> b
$
[Maybe (Declaration (Style, [(Style, Doc Markup)]))]
-> [Declaration (Style, [(Style, Doc Markup)])]
forall a. [Maybe a] -> [a]
catMaybes (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) [Declaration (Style, [(Style, Doc Markup)])]
-> [Declaration (Style, [(Style, Doc Markup)])]
-> [Declaration (Style, [(Style, Doc Markup)])]
forall a. Semigroup a => a -> a -> a
<> [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 a. 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 a. 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 = case Maybe (Coverage CoverCount)
mcoverage of
Maybe (Coverage CoverCount)
Nothing | Config -> Bool
configPrintReproduceMessage Config
config ->
[Maybe PropertyName -> Seed -> Skip -> Doc Markup
ppReproduce Maybe PropertyName
name Seed
seed (TestCount -> DiscardCount -> ShrinkPath -> Skip
SkipToShrink TestCount
tests DiscardCount
discards ShrinkPath
shrinkPath)]
Maybe (Coverage CoverCount)
_ ->
[]
[Doc Markup] -> m [Doc Markup]
forall a. a -> m a
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 a b. (a -> b) -> [a] -> [b]
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 a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PrintPrefixIcons -> Doc Markup -> Doc Markup
forall a. PrintPrefixIcons -> Doc a -> Doc a
indentBy (PrintPrefixIcons -> Doc Markup -> Doc Markup)
-> PrintPrefixIcons -> Doc Markup -> Doc Markup
forall a b. (a -> b) -> a -> b
$ Config -> PrintPrefixIcons
configPrintPrefixIcons Config
config)) ([[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 a b. (a -> b) -> [a] -> [b]
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 a. [a] -> 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 a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Declaration (Style, [(Style, Doc Markup)]) -> Doc Markup
ppDeclaration (Declaration (Style, [(Style, Doc Markup)]) -> Doc Markup)
-> (Declaration (Style, [(Style, Doc Markup)])
-> Declaration (Style, [(Style, Doc Markup)]))
-> Declaration (Style, [(Style, Doc Markup)])
-> Doc Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context
-> Declaration (Style, [(Style, Doc Markup)])
-> Declaration (Style, [(Style, Doc Markup)])
applyContext (Config -> Context
configContext Config
config))
, [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
]
indentBy :: PrintPrefixIcons -> Doc a -> Doc a
indentBy :: forall a. PrintPrefixIcons -> Doc a -> Doc a
indentBy = \case
PrintPrefixIcons
DisablePrefixIcons ->
Doc a -> Doc a
forall a. a -> a
id
PrintPrefixIcons
EnablePrefixIcons ->
Int -> Doc a -> Doc a
forall a. Int -> Doc a -> Doc a
WL.indent Int
2
ppName :: Maybe PropertyName -> Doc a
ppName :: forall a. Maybe PropertyName -> Doc a
ppName = \case
Maybe PropertyName
Nothing ->
Doc a
"<interactive>" Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
forall a. Doc a
WL.space
Just PropertyName
"" ->
Doc a
forall a. Monoid a => a
mempty
Just (PropertyName String
name) ->
String -> Doc a
forall a. String -> Doc a
WL.text String
name Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
forall a. Doc a
WL.space
ppProgress :: MonadIO m => Maybe PropertyName -> Report Progress -> m (Doc Markup)
ppProgress :: forall (m :: * -> *).
MonadIO m =>
Maybe PropertyName -> Report Progress -> m (Doc Markup)
ppProgress Maybe PropertyName
name (Report TestCount
tests DiscardCount
discards Coverage CoverCount
coverage Seed
_ Progress
status) =
case Progress
status of
Progress
Running ->
Doc Markup -> m (Doc Markup)
forall a. a -> m a
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
$ [
PrintPrefixIcons -> Markup -> Char -> Doc Markup -> Doc Markup
icon PrintPrefixIcons
EnablePrefixIcons 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. 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
<>
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]
++
PrintPrefixIcons
-> TestCount -> Coverage CoverCount -> [Doc Markup]
ppCoverage PrintPrefixIcons
EnablePrefixIcons TestCount
tests Coverage CoverCount
coverage
Shrinking FailureReport
failure ->
Doc Markup -> m (Doc Markup)
forall a. a -> m a
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
. PrintPrefixIcons -> Markup -> Char -> Doc Markup -> Doc Markup
icon PrintPrefixIcons
EnablePrefixIcons 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. Semigroup a => a -> a -> 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 :: forall (m :: * -> *).
MonadIO m =>
Maybe PropertyName -> Report Result -> m (Doc Markup)
ppResult = Config -> Maybe PropertyName -> Report Result -> m (Doc Markup)
forall (m :: * -> *).
MonadIO m =>
Config -> Maybe PropertyName -> Report Result -> m (Doc Markup)
ppResultWith Config
defaultConfig
ppResultWith :: MonadIO m => Config -> Maybe PropertyName -> Report Result -> m (Doc Markup)
ppResultWith :: forall (m :: * -> *).
MonadIO m =>
Config -> Maybe PropertyName -> Report Result -> m (Doc Markup)
ppResultWith Config
config Maybe PropertyName
name (Report TestCount
tests DiscardCount
discards Coverage CoverCount
coverage Seed
seed Result
result) = do
case Result
result of
Failed FailureReport
failure -> do
[Doc Markup]
pfailure <- Config
-> Maybe PropertyName
-> TestCount
-> DiscardCount
-> Seed
-> FailureReport
-> m [Doc Markup]
forall (m :: * -> *).
MonadIO m =>
Config
-> Maybe PropertyName
-> TestCount
-> DiscardCount
-> Seed
-> FailureReport
-> m [Doc Markup]
ppFailureReport Config
config Maybe PropertyName
name TestCount
tests DiscardCount
discards Seed
seed FailureReport
failure
Doc Markup -> m (Doc Markup)
forall a. a -> m a
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
$ [
PrintPrefixIcons -> Markup -> Char -> Doc Markup -> Doc Markup
icon (Config -> PrintPrefixIcons
configPrintPrefixIcons Config
config) 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. Semigroup a => a -> a -> a
<>
(
if Config -> Bool
configPrintFailedAtLocation Config
config then
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"
else
Doc Markup
"failed 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. Semigroup a => a -> a -> a
<>
(
if Config -> Bool
configPrintShrinkPath Config
config then
Doc Markup
forall a. Doc a
WL.line Doc Markup -> Doc Markup -> Doc Markup
forall a. Semigroup a => a -> a -> a
<>
Doc Markup
"shrink path:" Doc Markup -> Doc Markup -> Doc Markup
forall a. Doc a -> Doc a -> Doc a
<+>
Skip -> Doc Markup
forall a. Skip -> Doc a
ppSkip (TestCount -> DiscardCount -> ShrinkPath -> Skip
SkipToShrink TestCount
tests DiscardCount
discards (ShrinkPath -> Skip) -> ShrinkPath -> Skip
forall a b. (a -> b) -> a -> b
$ FailureReport -> ShrinkPath
failureShrinkPath FailureReport
failure)
else
Doc Markup
forall a. Monoid a => a
mempty
)
] [Doc Markup] -> [Doc Markup] -> [Doc Markup]
forall a. [a] -> [a] -> [a]
++
PrintPrefixIcons
-> TestCount -> Coverage CoverCount -> [Doc Markup]
ppCoverage (Config -> PrintPrefixIcons
configPrintPrefixIcons Config
config) 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 a. a -> m a
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
$ [
PrintPrefixIcons -> Markup -> Char -> Doc Markup -> Doc Markup
icon (Config -> PrintPrefixIcons
configPrintPrefixIcons Config
config) 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. Semigroup a => a -> a -> 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]
++
PrintPrefixIcons
-> TestCount -> Coverage CoverCount -> [Doc Markup]
ppCoverage (Config -> PrintPrefixIcons
configPrintPrefixIcons Config
config) TestCount
tests Coverage CoverCount
coverage
Result
OK ->
Doc Markup -> m (Doc Markup)
forall a. a -> m a
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
$ [
PrintPrefixIcons -> Markup -> Char -> Doc Markup -> Doc Markup
icon (Config -> PrintPrefixIcons
configPrintPrefixIcons Config
config) 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. 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]
++
PrintPrefixIcons
-> TestCount -> Coverage CoverCount -> [Doc Markup]
ppCoverage (Config -> PrintPrefixIcons
configPrintPrefixIcons Config
config) 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 b. Int -> Doc b
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 b. Int -> Doc b
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 :: PrintPrefixIcons -> TestCount -> Coverage CoverCount -> [Doc Markup]
ppCoverage :: PrintPrefixIcons
-> TestCount -> Coverage CoverCount -> [Doc Markup]
ppCoverage PrintPrefixIcons
icons 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 a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PrintPrefixIcons
-> TestCount -> ColumnWidth -> Label CoverCount -> Doc Markup
ppLabel PrintPrefixIcons
icons 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 m a. Monoid m => (a -> m) -> Map LabelName a -> m
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 a. [a] -> 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 a. [a] -> 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 a. [a] -> 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 :: forall a. Int -> Doc a -> Doc a
ppLeftPad Int
n Doc a
doc =
let
ndoc :: Int
ndoc =
String -> Int
forall a. [a] -> 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 :: PrintPrefixIcons -> TestCount -> ColumnWidth -> Label CoverCount -> Doc Markup
ppLabel :: PrintPrefixIcons
-> TestCount -> ColumnWidth -> Label CoverCount -> Doc Markup
ppLabel PrintPrefixIcons
icons 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 = case PrintPrefixIcons
icons of
PrintPrefixIcons
DisablePrefixIcons ->
Doc Markup
forall a. Monoid a => a
mempty
PrintPrefixIcons
EnablePrefixIcons ->
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 a. [a] -> 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 :: forall a. 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 b. Integral b => Double -> b
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 b. Integral b => Double -> b
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 :: forall a. [a] -> Int
index [a]
xs =
Double -> Int
forall b. Integral b => Double -> b
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 a. [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. HasCallStack => [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. HasCallStack => [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. HasCallStack => [a] -> a
head String
parts)
]
in
(Char, String) -> Doc Markup
bar (Char
'█', [Char
'·', Char
'▏', Char
'▎', Char
'▍', Char
'▌', Char
'▋', Char
'▊', Char
'▉'])
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 :: forall a. 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
PrintPrefixIcons -> Markup -> Char -> Doc Markup -> Doc Markup
icon PrintPrefixIcons
EnablePrefixIcons 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
PrintPrefixIcons -> Markup -> Char -> Doc Markup -> Doc Markup
icon PrintPrefixIcons
EnablePrefixIcons 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
PrintPrefixIcons -> Markup -> Char -> Doc Markup -> Doc Markup
icon PrintPrefixIcons
EnablePrefixIcons 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
PrintPrefixIcons -> Markup -> Char -> Doc Markup -> Doc Markup
icon PrintPrefixIcons
EnablePrefixIcons 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 :: forall (m :: * -> *). MonadIO m => 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 a. [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 a. a -> m a
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 :: forall (m :: * -> *).
MonadIO m =>
UseColor -> Doc Markup -> m String
renderDoc UseColor
color Doc Markup
doc = do
let
dull :: Color -> SGR
dull =
ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull
vivid :: Color -> SGR
vivid =
ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid
bold :: SGR
bold =
ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity
start :: Markup -> String
start = \case
Markup
WaitingIcon ->
[SGR] -> String
setSGRCode []
Markup
WaitingHeader ->
[SGR] -> String
setSGRCode []
Markup
RunningIcon ->
[SGR] -> String
setSGRCode []
Markup
RunningHeader ->
[SGR] -> String
setSGRCode []
Markup
ShrinkingIcon ->
[SGR] -> String
setSGRCode [Color -> SGR
vivid Color
Red]
Markup
ShrinkingHeader ->
[SGR] -> String
setSGRCode [Color -> SGR
vivid Color
Red]
Markup
FailedIcon ->
[SGR] -> String
setSGRCode [Color -> SGR
vivid Color
Red]
Markup
FailedText ->
[SGR] -> String
setSGRCode [Color -> SGR
vivid Color
Red]
Markup
GaveUpIcon ->
[SGR] -> String
setSGRCode [Color -> SGR
dull Color
Yellow]
Markup
GaveUpText ->
[SGR] -> String
setSGRCode [Color -> SGR
dull Color
Yellow]
Markup
SuccessIcon ->
[SGR] -> String
setSGRCode [Color -> SGR
dull Color
Green]
Markup
SuccessText ->
[SGR] -> String
setSGRCode [Color -> SGR
dull Color
Green]
Markup
CoverageIcon ->
[SGR] -> String
setSGRCode [Color -> SGR
dull Color
Yellow]
Markup
CoverageText ->
[SGR] -> String
setSGRCode [Color -> SGR
dull Color
Yellow]
Markup
CoverageFill ->
[SGR] -> String
setSGRCode [Color -> SGR
vivid Color
Black]
Markup
DeclarationLocation ->
[SGR] -> String
setSGRCode []
StyledLineNo Style
StyleDefault ->
[SGR] -> String
setSGRCode []
StyledSource Style
StyleDefault ->
[SGR] -> String
setSGRCode []
StyledBorder Style
StyleDefault ->
[SGR] -> String
setSGRCode []
StyledLineNo Style
StyleAnnotation ->
[SGR] -> String
setSGRCode [Color -> SGR
dull Color
Magenta]
StyledSource Style
StyleAnnotation ->
[SGR] -> String
setSGRCode []
StyledBorder Style
StyleAnnotation ->
[SGR] -> String
setSGRCode []
Markup
AnnotationGutter ->
[SGR] -> String
setSGRCode [Color -> SGR
dull Color
Magenta]
Markup
AnnotationValue ->
[SGR] -> String
setSGRCode [Color -> SGR
dull Color
Magenta]
StyledLineNo Style
StyleFailure ->
[SGR] -> String
setSGRCode [Color -> SGR
vivid Color
Red]
StyledSource Style
StyleFailure ->
[SGR] -> String
setSGRCode [Color -> SGR
vivid Color
Red, SGR
bold]
StyledBorder Style
StyleFailure ->
[SGR] -> String
setSGRCode []
Markup
FailureArrows ->
[SGR] -> String
setSGRCode [Color -> SGR
vivid Color
Red]
Markup
FailureMessage ->
[SGR] -> String
setSGRCode []
Markup
FailureGutter ->
[SGR] -> String
setSGRCode []
Markup
DiffPrefix ->
[SGR] -> String
setSGRCode []
Markup
DiffInfix ->
[SGR] -> String
setSGRCode []
Markup
DiffSuffix ->
[SGR] -> String
setSGRCode []
Markup
DiffSame ->
[SGR] -> String
setSGRCode []
Markup
DiffRemoved ->
[SGR] -> String
setSGRCode [Color -> SGR
dull Color
Red]
Markup
DiffAdded ->
[SGR] -> String
setSGRCode [Color -> SGR
dull Color
Green]
Markup
ReproduceHeader ->
[SGR] -> String
setSGRCode []
Markup
ReproduceGutter ->
[SGR] -> String
setSGRCode []
Markup
ReproduceSource ->
[SGR] -> String
setSGRCode []
end :: p -> String
end p
_ =
[SGR] -> String
setSGRCode [SGR
Reset]
let
display :: SimpleDoc Markup -> String
display =
case UseColor
color of
UseColor
EnableColor ->
(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 a. a -> m a
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 :: forall (m :: * -> *).
MonadIO m =>
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 :: forall (m :: * -> *).
MonadIO m =>
UseColor -> Maybe PropertyName -> Report Result -> m String
renderResult = Config
-> UseColor -> Maybe PropertyName -> Report Result -> m String
forall (m :: * -> *).
MonadIO m =>
Config
-> UseColor -> Maybe PropertyName -> Report Result -> m String
renderResultWith Config
defaultConfig
data Config =
Config {
Config -> Context
configContext :: Context
, Config -> Bool
configPrintFailedAtLocation :: Bool
, Config -> Bool
configPrintShrinkPath :: Bool
, Config -> Bool
configPrintReproduceMessage :: Bool
, Config -> PrintPrefixIcons
configPrintPrefixIcons :: PrintPrefixIcons
} deriving (Config -> Config -> Bool
(Config -> Config -> Bool)
-> (Config -> Config -> Bool) -> Eq Config
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
/= :: Config -> Config -> Bool
Eq, Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Config -> ShowS
showsPrec :: Int -> Config -> ShowS
$cshow :: Config -> String
show :: Config -> String
$cshowList :: [Config] -> ShowS
showList :: [Config] -> ShowS
Show)
data PrintPrefixIcons =
DisablePrefixIcons
| EnablePrefixIcons
deriving (PrintPrefixIcons -> PrintPrefixIcons -> Bool
(PrintPrefixIcons -> PrintPrefixIcons -> Bool)
-> (PrintPrefixIcons -> PrintPrefixIcons -> Bool)
-> Eq PrintPrefixIcons
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PrintPrefixIcons -> PrintPrefixIcons -> Bool
== :: PrintPrefixIcons -> PrintPrefixIcons -> Bool
$c/= :: PrintPrefixIcons -> PrintPrefixIcons -> Bool
/= :: PrintPrefixIcons -> PrintPrefixIcons -> Bool
Eq, Int -> PrintPrefixIcons -> ShowS
[PrintPrefixIcons] -> ShowS
PrintPrefixIcons -> String
(Int -> PrintPrefixIcons -> ShowS)
-> (PrintPrefixIcons -> String)
-> ([PrintPrefixIcons] -> ShowS)
-> Show PrintPrefixIcons
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PrintPrefixIcons -> ShowS
showsPrec :: Int -> PrintPrefixIcons -> ShowS
$cshow :: PrintPrefixIcons -> String
show :: PrintPrefixIcons -> String
$cshowList :: [PrintPrefixIcons] -> ShowS
showList :: [PrintPrefixIcons] -> ShowS
Show)
defaultConfig :: Config
defaultConfig :: Config
defaultConfig = Context -> Bool -> Bool -> Bool -> PrintPrefixIcons -> Config
Config Context
FullContext Bool
True Bool
True Bool
True PrintPrefixIcons
EnablePrefixIcons
renderResultWith :: MonadIO m => Config -> UseColor -> Maybe PropertyName -> Report Result -> m String
renderResultWith :: forall (m :: * -> *).
MonadIO m =>
Config
-> UseColor -> Maybe PropertyName -> Report Result -> m String
renderResultWith Config
config 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
=<< Config -> Maybe PropertyName -> Report Result -> m (Doc Markup)
forall (m :: * -> *).
MonadIO m =>
Config -> Maybe PropertyName -> Report Result -> m (Doc Markup)
ppResultWith Config
config Maybe PropertyName
name Report Result
x
renderSummary :: MonadIO m => UseColor -> Summary -> m String
renderSummary :: forall (m :: * -> *). MonadIO m => UseColor -> Summary -> m String
renderSummary UseColor
color Summary
x =
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