module Plutus.Contract.Test.Coverage.ReportCoverage(writeCoverageReport) where

import Control.Exception
import Control.Lens (view)
import Data.Function
import Data.List
import Data.Map qualified as Map
import Data.Ord
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (pack, unpack)
import HTMLEntities.Text (text)

import PlutusTx.Coverage

-- Position (in a file), and status (of a character)

type Pos = (Int,Int)   -- line, column

predPos, succPos :: Pos -> Pos

predPos :: Pos -> Pos
predPos (Int
l,Int
1) = (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1,Int
forall a. Bounded a => a
maxBound)
predPos (Int
l,Int
c) = (Int
l,Int
cInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)

succPos :: Pos -> Pos
succPos (Int
l,Int
c) = (Int
l,Int
cInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

data CoverStatus = NotCovered | HasBeenHere | HasBeenFalse | HasBeenTrue | HasBeenBoth
  deriving (CoverStatus -> CoverStatus -> Bool
(CoverStatus -> CoverStatus -> Bool)
-> (CoverStatus -> CoverStatus -> Bool) -> Eq CoverStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CoverStatus -> CoverStatus -> Bool
$c/= :: CoverStatus -> CoverStatus -> Bool
== :: CoverStatus -> CoverStatus -> Bool
$c== :: CoverStatus -> CoverStatus -> Bool
Eq, Eq CoverStatus
Eq CoverStatus
-> (CoverStatus -> CoverStatus -> Ordering)
-> (CoverStatus -> CoverStatus -> Bool)
-> (CoverStatus -> CoverStatus -> Bool)
-> (CoverStatus -> CoverStatus -> Bool)
-> (CoverStatus -> CoverStatus -> Bool)
-> (CoverStatus -> CoverStatus -> CoverStatus)
-> (CoverStatus -> CoverStatus -> CoverStatus)
-> Ord CoverStatus
CoverStatus -> CoverStatus -> Bool
CoverStatus -> CoverStatus -> Ordering
CoverStatus -> CoverStatus -> CoverStatus
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CoverStatus -> CoverStatus -> CoverStatus
$cmin :: CoverStatus -> CoverStatus -> CoverStatus
max :: CoverStatus -> CoverStatus -> CoverStatus
$cmax :: CoverStatus -> CoverStatus -> CoverStatus
>= :: CoverStatus -> CoverStatus -> Bool
$c>= :: CoverStatus -> CoverStatus -> Bool
> :: CoverStatus -> CoverStatus -> Bool
$c> :: CoverStatus -> CoverStatus -> Bool
<= :: CoverStatus -> CoverStatus -> Bool
$c<= :: CoverStatus -> CoverStatus -> Bool
< :: CoverStatus -> CoverStatus -> Bool
$c< :: CoverStatus -> CoverStatus -> Bool
compare :: CoverStatus -> CoverStatus -> Ordering
$ccompare :: CoverStatus -> CoverStatus -> Ordering
$cp1Ord :: Eq CoverStatus
Ord, Int -> CoverStatus -> ShowS
[CoverStatus] -> ShowS
CoverStatus -> String
(Int -> CoverStatus -> ShowS)
-> (CoverStatus -> String)
-> ([CoverStatus] -> ShowS)
-> Show CoverStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CoverStatus] -> ShowS
$cshowList :: [CoverStatus] -> ShowS
show :: CoverStatus -> String
$cshow :: CoverStatus -> String
showsPrec :: Int -> CoverStatus -> ShowS
$cshowsPrec :: Int -> CoverStatus -> ShowS
Show)

data IgnoreStatus = NotIgnored | IgnoredIfFalse | IgnoredIfTrue | AlwaysIgnored
  deriving (IgnoreStatus -> IgnoreStatus -> Bool
(IgnoreStatus -> IgnoreStatus -> Bool)
-> (IgnoreStatus -> IgnoreStatus -> Bool) -> Eq IgnoreStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IgnoreStatus -> IgnoreStatus -> Bool
$c/= :: IgnoreStatus -> IgnoreStatus -> Bool
== :: IgnoreStatus -> IgnoreStatus -> Bool
$c== :: IgnoreStatus -> IgnoreStatus -> Bool
Eq, Eq IgnoreStatus
Eq IgnoreStatus
-> (IgnoreStatus -> IgnoreStatus -> Ordering)
-> (IgnoreStatus -> IgnoreStatus -> Bool)
-> (IgnoreStatus -> IgnoreStatus -> Bool)
-> (IgnoreStatus -> IgnoreStatus -> Bool)
-> (IgnoreStatus -> IgnoreStatus -> Bool)
-> (IgnoreStatus -> IgnoreStatus -> IgnoreStatus)
-> (IgnoreStatus -> IgnoreStatus -> IgnoreStatus)
-> Ord IgnoreStatus
IgnoreStatus -> IgnoreStatus -> Bool
IgnoreStatus -> IgnoreStatus -> Ordering
IgnoreStatus -> IgnoreStatus -> IgnoreStatus
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: IgnoreStatus -> IgnoreStatus -> IgnoreStatus
$cmin :: IgnoreStatus -> IgnoreStatus -> IgnoreStatus
max :: IgnoreStatus -> IgnoreStatus -> IgnoreStatus
$cmax :: IgnoreStatus -> IgnoreStatus -> IgnoreStatus
>= :: IgnoreStatus -> IgnoreStatus -> Bool
$c>= :: IgnoreStatus -> IgnoreStatus -> Bool
> :: IgnoreStatus -> IgnoreStatus -> Bool
$c> :: IgnoreStatus -> IgnoreStatus -> Bool
<= :: IgnoreStatus -> IgnoreStatus -> Bool
$c<= :: IgnoreStatus -> IgnoreStatus -> Bool
< :: IgnoreStatus -> IgnoreStatus -> Bool
$c< :: IgnoreStatus -> IgnoreStatus -> Bool
compare :: IgnoreStatus -> IgnoreStatus -> Ordering
$ccompare :: IgnoreStatus -> IgnoreStatus -> Ordering
$cp1Ord :: Eq IgnoreStatus
Ord, Int -> IgnoreStatus -> ShowS
[IgnoreStatus] -> ShowS
IgnoreStatus -> String
(Int -> IgnoreStatus -> ShowS)
-> (IgnoreStatus -> String)
-> ([IgnoreStatus] -> ShowS)
-> Show IgnoreStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IgnoreStatus] -> ShowS
$cshowList :: [IgnoreStatus] -> ShowS
show :: IgnoreStatus -> String
$cshow :: IgnoreStatus -> String
showsPrec :: Int -> IgnoreStatus -> ShowS
$cshowsPrec :: Int -> IgnoreStatus -> ShowS
Show)

data Status = OnChain CoverStatus IgnoreStatus
  deriving (Status -> Status -> Bool
(Status -> Status -> Bool)
-> (Status -> Status -> Bool) -> Eq Status
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Status -> Status -> Bool
$c/= :: Status -> Status -> Bool
== :: Status -> Status -> Bool
$c== :: Status -> Status -> Bool
Eq, Eq Status
Eq Status
-> (Status -> Status -> Ordering)
-> (Status -> Status -> Bool)
-> (Status -> Status -> Bool)
-> (Status -> Status -> Bool)
-> (Status -> Status -> Bool)
-> (Status -> Status -> Status)
-> (Status -> Status -> Status)
-> Ord Status
Status -> Status -> Bool
Status -> Status -> Ordering
Status -> Status -> Status
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Status -> Status -> Status
$cmin :: Status -> Status -> Status
max :: Status -> Status -> Status
$cmax :: Status -> Status -> Status
>= :: Status -> Status -> Bool
$c>= :: Status -> Status -> Bool
> :: Status -> Status -> Bool
$c> :: Status -> Status -> Bool
<= :: Status -> Status -> Bool
$c<= :: Status -> Status -> Bool
< :: Status -> Status -> Bool
$c< :: Status -> Status -> Bool
compare :: Status -> Status -> Ordering
$ccompare :: Status -> Status -> Ordering
$cp1Ord :: Eq Status
Ord, Int -> Status -> ShowS
[Status] -> ShowS
Status -> String
(Int -> Status -> ShowS)
-> (Status -> String) -> ([Status] -> ShowS) -> Show Status
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Status] -> ShowS
$cshowList :: [Status] -> ShowS
show :: Status -> String
$cshow :: Status -> String
showsPrec :: Int -> Status -> ShowS
$cshowsPrec :: Int -> Status -> ShowS
Show)

instance Semigroup CoverStatus where
  CoverStatus
HasBeenBoth  <> :: CoverStatus -> CoverStatus -> CoverStatus
<> CoverStatus
_            = CoverStatus
HasBeenBoth
  CoverStatus
_            <> CoverStatus
HasBeenBoth  = CoverStatus
HasBeenBoth
  CoverStatus
HasBeenFalse <> CoverStatus
HasBeenTrue  = CoverStatus
HasBeenBoth
  CoverStatus
HasBeenTrue  <> CoverStatus
HasBeenFalse = CoverStatus
HasBeenBoth
  CoverStatus
HasBeenFalse <> CoverStatus
_            = CoverStatus
HasBeenFalse
  CoverStatus
_            <> CoverStatus
HasBeenFalse = CoverStatus
HasBeenFalse
  CoverStatus
HasBeenTrue  <> CoverStatus
_            = CoverStatus
HasBeenTrue
  CoverStatus
_            <> CoverStatus
HasBeenTrue  = CoverStatus
HasBeenTrue
  CoverStatus
HasBeenHere  <> CoverStatus
_            = CoverStatus
HasBeenHere
  CoverStatus
_            <> CoverStatus
HasBeenHere  = CoverStatus
HasBeenHere
  CoverStatus
NotCovered   <> CoverStatus
NotCovered   = CoverStatus
NotCovered

instance Monoid CoverStatus where
  mempty :: CoverStatus
mempty = CoverStatus
NotCovered

instance Semigroup IgnoreStatus where
  IgnoreStatus
AlwaysIgnored  <> :: IgnoreStatus -> IgnoreStatus -> IgnoreStatus
<> IgnoreStatus
_              = IgnoreStatus
AlwaysIgnored
  IgnoreStatus
_              <> IgnoreStatus
AlwaysIgnored  = IgnoreStatus
AlwaysIgnored
  IgnoreStatus
IgnoredIfFalse <> IgnoreStatus
IgnoredIfTrue  = IgnoreStatus
AlwaysIgnored
  IgnoreStatus
IgnoredIfTrue  <> IgnoreStatus
IgnoredIfFalse = IgnoreStatus
AlwaysIgnored
  IgnoreStatus
IgnoredIfTrue  <> IgnoreStatus
_              = IgnoreStatus
IgnoredIfTrue
  IgnoreStatus
_              <> IgnoreStatus
IgnoredIfTrue  = IgnoreStatus
IgnoredIfTrue
  IgnoreStatus
IgnoredIfFalse <> IgnoreStatus
_              = IgnoreStatus
IgnoredIfFalse
  IgnoreStatus
_              <> IgnoreStatus
IgnoredIfFalse = IgnoreStatus
IgnoredIfFalse
  IgnoreStatus
NotIgnored     <> IgnoreStatus
NotIgnored     = IgnoreStatus
NotIgnored

instance Monoid IgnoreStatus where
  mempty :: IgnoreStatus
mempty = IgnoreStatus
NotIgnored

-- The Semigroup instance is used to combine swipes over identical ranges.
instance Semigroup Status where
  OnChain CoverStatus
c IgnoreStatus
i <> :: Status -> Status -> Status
<> OnChain CoverStatus
c' IgnoreStatus
i' = CoverStatus -> IgnoreStatus -> Status
OnChain (CoverStatus
c CoverStatus -> CoverStatus -> CoverStatus
forall a. Semigroup a => a -> a -> a
<> CoverStatus
c') (IgnoreStatus
i IgnoreStatus -> IgnoreStatus -> IgnoreStatus
forall a. Semigroup a => a -> a -> a
<> IgnoreStatus
i')

instance Monoid Status where
  mempty :: Status
mempty = CoverStatus -> IgnoreStatus -> Status
OnChain CoverStatus
forall a. Monoid a => a
mempty IgnoreStatus
forall a. Monoid a => a
mempty

statusStyle :: Status -> String
statusStyle :: Status -> String
statusStyle (OnChain CoverStatus
HasBeenHere IgnoreStatus
_)             = String
"background-color:white;color:black"
statusStyle (OnChain CoverStatus
HasBeenBoth IgnoreStatus
_)             = String
"background-color:white;color:black"
statusStyle (OnChain CoverStatus
HasBeenTrue IgnoreStatus
i)
  | IgnoreStatus -> [IgnoreStatus] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem IgnoreStatus
i [IgnoreStatus
IgnoredIfFalse, IgnoreStatus
AlwaysIgnored]      = String
"background-color:white;color:lightgreen"
  | Bool
otherwise                                   = String
"background-color:lightgreen;color:black"
statusStyle (OnChain CoverStatus
HasBeenFalse IgnoreStatus
i)
  | IgnoreStatus -> [IgnoreStatus] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem IgnoreStatus
i [IgnoreStatus
IgnoredIfTrue, IgnoreStatus
AlwaysIgnored]       = String
"background-color:white;color:lightpink"
  | Bool
otherwise                                   = String
"background-color:lightpink;color:black"
statusStyle (OnChain CoverStatus
NotCovered IgnoreStatus
NotIgnored)     = String
"background-color:black;color:orangered"
statusStyle (OnChain CoverStatus
NotCovered IgnoreStatus
IgnoredIfFalse) = String
"background-color:lightpink;color:black"
statusStyle (OnChain CoverStatus
NotCovered IgnoreStatus
IgnoredIfTrue)  = String
"background-color:lightgreen;color:black"
statusStyle (OnChain CoverStatus
NotCovered IgnoreStatus
AlwaysIgnored)  = String
"background-color:white;color:orangered"

offChainStyle :: String
offChainStyle :: String
offChainStyle = String
"background-color:lightgray;color:gray"

-- A "swipe" represents colouring a region of a file with a
-- status. Our overall approach is to convert coverage information
-- into a collection of non-overlapping, but possibly nested swipes,
-- and then converting this into an orderedlist of disjoint swipes
-- which can be used for generating colours.

data Swipe = Swipe { Swipe -> Pos
swipeStart  :: Pos,
                     Swipe -> Pos
swipeEnd    :: Pos,
                     Swipe -> Status
swipeStatus :: Status }
  deriving (Swipe -> Swipe -> Bool
(Swipe -> Swipe -> Bool) -> (Swipe -> Swipe -> Bool) -> Eq Swipe
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Swipe -> Swipe -> Bool
$c/= :: Swipe -> Swipe -> Bool
== :: Swipe -> Swipe -> Bool
$c== :: Swipe -> Swipe -> Bool
Eq, Int -> Swipe -> ShowS
[Swipe] -> ShowS
Swipe -> String
(Int -> Swipe -> ShowS)
-> (Swipe -> String) -> ([Swipe] -> ShowS) -> Show Swipe
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Swipe] -> ShowS
$cshowList :: [Swipe] -> ShowS
show :: Swipe -> String
$cshow :: Swipe -> String
showsPrec :: Int -> Swipe -> ShowS
$cshowsPrec :: Int -> Swipe -> ShowS
Show)

-- This surprising ordering on swipes has the property that if s1 is
-- nested within s2, then s1 <= s2. Given that no two swipes overlap,
-- then s1 <= s2 precisely if s1 precedes s2 entirely, or s1 is nested
-- within s2. It follow that, in a sorted list of swipes, the first
-- one has no other swipes nested within it, and therefore its colour
-- takes priority over all other swipes. We make use of this in
-- converting a set of swipes to a set of disjoint swipes with the
-- same coloration.

instance Ord Swipe where
  <= :: Swipe -> Swipe -> Bool
(<=) = (Pos, Down Pos, Status) -> (Pos, Down Pos, Status) -> Bool
forall a. Ord a => a -> a -> Bool
(<=) ((Pos, Down Pos, Status) -> (Pos, Down Pos, Status) -> Bool)
-> (Swipe -> (Pos, Down Pos, Status)) -> Swipe -> Swipe -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` \(Swipe Pos
start Pos
end Status
status) -> (Pos
end, Pos -> Down Pos
forall a. a -> Down a
Down Pos
start, Status
status)

-- Is the first swipe nested within the second?

nested :: Swipe -> Swipe -> Bool
nested :: Swipe -> Swipe -> Bool
nested (Swipe Pos
from Pos
to Status
_) (Swipe Pos
from' Pos
to' Status
_) = Pos
from Pos -> Pos -> Bool
forall a. Ord a => a -> a -> Bool
>= Pos
from' Bool -> Bool -> Bool
&& Pos
to Pos -> Pos -> Bool
forall a. Ord a => a -> a -> Bool
<= Pos
to'

-- Let the first swipe "swipe over" part of the second. The resulting
-- swipes do not overlap.  The first swipe must be nested within the
-- second.

combineNestedSwipes :: Swipe -> Swipe -> [Swipe]
combineNestedSwipes :: Swipe -> Swipe -> [Swipe]
combineNestedSwipes (Swipe Pos
from Pos
to Status
s) (Swipe Pos
from' Pos
to' Status
s')
  | (Pos
from, Pos
to) (Pos, Pos) -> (Pos, Pos) -> Bool
forall a. Eq a => a -> a -> Bool
== (Pos
from', Pos
to') = [Pos -> Pos -> Status -> Swipe
Swipe Pos
from Pos
to (Status
s Status -> Status -> Status
forall a. Semigroup a => a -> a -> a
<> Status
s')]
  | Bool
otherwise =
    [Pos -> Pos -> Status -> Swipe
Swipe Pos
from' (Pos -> Pos
predPos Pos
from) Status
s' | Pos
from Pos -> Pos -> Bool
forall a. Eq a => a -> a -> Bool
/= Pos
from'] [Swipe] -> [Swipe] -> [Swipe]
forall a. [a] -> [a] -> [a]
++
    [Pos -> Pos -> Status -> Swipe
Swipe Pos
from Pos
to Status
s] [Swipe] -> [Swipe] -> [Swipe]
forall a. [a] -> [a] -> [a]
++
    [Pos -> Pos -> Status -> Swipe
Swipe (Pos -> Pos
succPos Pos
to) Pos
to' Status
s' | Pos
to Pos -> Pos -> Bool
forall a. Eq a => a -> a -> Bool
/= Pos
to']

-- Flatten an ordered list of swipes, to get a non-overlapping list.
-- Nested swipes "swipe over" the outer swipe. Because of the custom
-- ordering on swipes, the first swipe in the list cannot have any
-- other swipe in the listed nested within it, which means that its
-- colour "wins" over all others.

flattenSwipes :: [Swipe] -> [Swipe]
flattenSwipes :: [Swipe] -> [Swipe]
flattenSwipes []          = []
flattenSwipes (Swipe
sw:[Swipe]
swipes) = Swipe -> [Swipe] -> [Swipe]
swipeOver Swipe
sw ([Swipe] -> [Swipe]) -> ([Swipe] -> [Swipe]) -> [Swipe] -> [Swipe]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Swipe] -> [Swipe]
flattenSwipes ([Swipe] -> [Swipe]) -> [Swipe] -> [Swipe]
forall a b. (a -> b) -> a -> b
$ [Swipe]
swipes

swipeOver :: Swipe -> [Swipe] -> [Swipe]
swipeOver :: Swipe -> [Swipe] -> [Swipe]
swipeOver Swipe
sw [] = [Swipe
sw]
swipeOver Swipe
sw (Swipe
sw':[Swipe]
swipes)
  | Swipe -> Pos
swipeEnd Swipe
sw Pos -> Pos -> Bool
forall a. Ord a => a -> a -> Bool
< Swipe -> Pos
swipeStart Swipe
sw' = Swipe
swSwipe -> [Swipe] -> [Swipe]
forall a. a -> [a] -> [a]
:Swipe
sw'Swipe -> [Swipe] -> [Swipe]
forall a. a -> [a] -> [a]
:[Swipe]
swipes
  | Swipe -> Pos
swipeEnd Swipe
sw' Pos -> Pos -> Bool
forall a. Ord a => a -> a -> Bool
< Swipe -> Pos
swipeStart Swipe
sw = Swipe
sw'Swipe -> [Swipe] -> [Swipe]
forall a. a -> [a] -> [a]
:Swipe -> [Swipe] -> [Swipe]
swipeOver Swipe
sw [Swipe]
swipes
  | Swipe -> Swipe -> Bool
nested Swipe
sw Swipe
sw'                = Swipe -> Swipe -> [Swipe]
combineNestedSwipes Swipe
sw Swipe
sw' [Swipe] -> [Swipe] -> [Swipe]
forall a. [a] -> [a] -> [a]
++ [Swipe]
swipes
  | Bool
otherwise                    = String -> [Swipe]
forall a. HasCallStack => String -> a
error (String -> [Swipe]) -> ([String] -> String) -> [String] -> [Swipe]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> [Swipe]) -> [String] -> [Swipe]
forall a b. (a -> b) -> a -> b
$
                                     String
"swipeOver: precondition violated; swipes are not nested or disjoint."String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
                                     (Swipe -> String) -> [Swipe] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Swipe -> String
forall a. Show a => a -> String
show (Swipe
swSwipe -> [Swipe] -> [Swipe]
forall a. a -> [a] -> [a]
:Swipe
sw'Swipe -> [Swipe] -> [Swipe]
forall a. a -> [a] -> [a]
:Int -> [Swipe] -> [Swipe]
forall a. Int -> [a] -> [a]
take Int
8 [Swipe]
swipes)

-- Convert an ordered list of non-intersecting swipes that may swipe
-- any region in a file, into a list of swipes applied to each line.

type SwipesPerLine = [(Int,[Swipe])]

swipesByLine :: [Swipe] -> SwipesPerLine
swipesByLine :: [Swipe] -> SwipesPerLine
swipesByLine = ([Swipe] -> (Int, [Swipe])) -> [[Swipe]] -> SwipesPerLine
forall a b. (a -> b) -> [a] -> [b]
map [Swipe] -> (Int, [Swipe])
addLine ([[Swipe]] -> SwipesPerLine)
-> ([Swipe] -> [[Swipe]]) -> [Swipe] -> SwipesPerLine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Swipe -> Swipe -> Bool) -> [Swipe] -> [[Swipe]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Int -> Int -> Bool) -> (Swipe -> Int) -> Swipe -> Swipe -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Pos -> Int
forall a b. (a, b) -> a
fst(Pos -> Int) -> (Swipe -> Pos) -> Swipe -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Swipe -> Pos
swipeStart)) ([Swipe] -> [[Swipe]])
-> ([Swipe] -> [Swipe]) -> [Swipe] -> [[Swipe]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Swipe -> [Swipe]) -> [Swipe] -> [Swipe]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Swipe -> [Swipe]
splitSwipe
  where splitSwipe :: Swipe -> [Swipe]
splitSwipe s :: Swipe
s@(Swipe (Int
fromLine,Int
_) (Int
toLine,Int
_) Status
_)
          | Int
fromLine Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
toLine = [Swipe
s]
          | Bool
otherwise          = Swipe
s{swipeEnd :: Pos
swipeEnd = (Int
fromLine,Int
forall a. Bounded a => a
maxBound)}Swipe -> [Swipe] -> [Swipe]
forall a. a -> [a] -> [a]
:
                                 Swipe -> [Swipe]
splitSwipe Swipe
s{swipeStart :: Pos
swipeStart = (Int
fromLineInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,Int
1)}
        addLine :: [Swipe] -> (Int, [Swipe])
addLine [Swipe]
swipes = (Pos -> Int
forall a b. (a, b) -> a
fst (Pos -> Int) -> ([Swipe] -> Pos) -> [Swipe] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Swipe -> Pos
swipeStart (Swipe -> Pos) -> ([Swipe] -> Swipe) -> [Swipe] -> Pos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Swipe] -> Swipe
forall a. [a] -> a
head ([Swipe] -> Int) -> [Swipe] -> Int
forall a b. (a -> b) -> a -> b
$ [Swipe]
swipes, [Swipe]
swipes)

-- Extend a list of swipes-per-line by including non-swiped lines that
-- are within windowLines of a swiped line.

windowLines :: Int
windowLines :: Int
windowLines = Int
5

includeNearby ::  SwipesPerLine ->  SwipesPerLine
includeNearby :: SwipesPerLine -> SwipesPerLine
includeNearby SwipesPerLine
swipes = Int -> SwipesPerLine -> SwipesPerLine
forall a. Show a => Int -> [(Int, [a])] -> [(Int, [a])]
excluding Int
1 SwipesPerLine
swipes
  where excluding :: Int -> [(Int, [a])] -> [(Int, [a])]
excluding Int
_ [] = []
        excluding Int
n [(Int, [a])]
nSwipes
          | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
nextSwiped             = String -> [(Int, [a])]
forall a. HasCallStack => String -> a
error (String -> [(Int, [a])])
-> ([String] -> String) -> [String] -> [(Int, [a])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> [(Int, [a])]) -> [String] -> [(Int, [a])]
forall a b. (a -> b) -> a -> b
$ (String
"Bad excluding: "String -> ShowS
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
n)String -> [String] -> [String]
forall a. a -> [a] -> [a]
:((Int, [a]) -> String) -> [(Int, [a])] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int, [a]) -> String
forall a. Show a => a -> String
show (Int -> [(Int, [a])] -> [(Int, [a])]
forall a. Int -> [a] -> [a]
take Int
10 [(Int, [a])]
nSwipes)
          | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
nextSwiped            = Int -> [(Int, [a])] -> [(Int, [a])]
including Int
n [(Int, [a])]
nSwipes
          | Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
windowLines Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
nextSwiped = Int -> [(Int, [a])] -> [(Int, [a])]
excluding (Int
nextSwipedInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
windowLines) [(Int, [a])]
nSwipes
          | Bool
otherwise                  = (Int
n,[])(Int, [a]) -> [(Int, [a])] -> [(Int, [a])]
forall a. a -> [a] -> [a]
:Int -> [(Int, [a])] -> [(Int, [a])]
excluding (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [(Int, [a])]
nSwipes
          where nextSwiped :: Int
nextSwiped = (Int, [a]) -> Int
forall a b. (a, b) -> a
fst ([(Int, [a])] -> (Int, [a])
forall a. [a] -> a
head [(Int, [a])]
nSwipes)
        including :: Int -> [(Int, [a])] -> [(Int, [a])]
including Int
_ [] = []
        including Int
n ((Int
next,[a]
swipe):[(Int, [a])]
nSwipes)
          | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
next = String -> [(Int, [a])]
forall a. HasCallStack => String -> a
error (String -> [(Int, [a])])
-> ([String] -> String) -> [String] -> [(Int, [a])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> [(Int, [a])]) -> [String] -> [(Int, [a])]
forall a b. (a -> b) -> a -> b
$ (String
"Bad including: "String -> ShowS
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
n)String -> [String] -> [String]
forall a. a -> [a] -> [a]
:((Int, [a]) -> String) -> [(Int, [a])] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int, [a]) -> String
forall a. Show a => a -> String
show (Int -> [(Int, [a])] -> [(Int, [a])]
forall a. Int -> [a] -> [a]
take Int
10 ((Int
next,[a]
swipe)(Int, [a]) -> [(Int, [a])] -> [(Int, [a])]
forall a. a -> [a] -> [a]
:[(Int, [a])]
nSwipes))
          | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
next =
              (Int
next,[a]
swipe)(Int, [a]) -> [(Int, [a])] -> [(Int, [a])]
forall a. a -> [a] -> [a]
:Int -> [(Int, [a])] -> [(Int, [a])]
including (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [(Int, [a])]
nSwipes
          | Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
windowLines Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
next =
              (Int
n,[])(Int, [a]) -> [(Int, [a])] -> [(Int, [a])]
forall a. a -> [a] -> [a]
:Int -> [(Int, [a])] -> [(Int, [a])]
including (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ((Int
next,[a]
swipe)(Int, [a]) -> [(Int, [a])] -> [(Int, [a])]
forall a. a -> [a] -> [a]
:[(Int, [a])]
nSwipes)
          | Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
windowLines Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
next =
              [(Int
i,[]) | Int
i <- [Int
n..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
windowLines]] [(Int, [a])] -> [(Int, [a])] -> [(Int, [a])]
forall a. [a] -> [a] -> [a]
++ Int -> [(Int, [a])] -> [(Int, [a])]
excluding (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
windowLines) ((Int
next,[a]
swipe)(Int, [a]) -> [(Int, [a])] -> [(Int, [a])]
forall a. a -> [a] -> [a]
:[(Int, [a])]
nSwipes)
          | Bool
otherwise = String -> [(Int, [a])]
forall a. HasCallStack => String -> a
error String
"impossible"

-- Extend a list of swipes-per-line to include non-swiped lines that
-- form a small gap between swiped blocks. Gaps are replaced by three
-- vertical dots; there is no sense in replacing a gap of three or
-- fewer lines this way.

fillSmallGaps :: SwipesPerLine ->  SwipesPerLine
fillSmallGaps :: SwipesPerLine -> SwipesPerLine
fillSmallGaps ((Int
n,[Swipe]
swipes):(Int
n',[Swipe]
swipes'):SwipesPerLine
nSwipes)
  | Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
4 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n' = (Int
n,[Swipe]
swipes)(Int, [Swipe]) -> SwipesPerLine -> SwipesPerLine
forall a. a -> [a] -> [a]
:[(Int
i,[]) | Int
i <- [Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1..Int
n'Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]] SwipesPerLine -> SwipesPerLine -> SwipesPerLine
forall a. [a] -> [a] -> [a]
++ SwipesPerLine -> SwipesPerLine
fillSmallGaps ((Int
n',[Swipe]
swipes')(Int, [Swipe]) -> SwipesPerLine -> SwipesPerLine
forall a. a -> [a] -> [a]
:SwipesPerLine
nSwipes)
  | Bool
otherwise = (Int
n,[Swipe]
swipes)(Int, [Swipe]) -> SwipesPerLine -> SwipesPerLine
forall a. a -> [a] -> [a]
:SwipesPerLine -> SwipesPerLine
fillSmallGaps ((Int
n',[Swipe]
swipes')(Int, [Swipe]) -> SwipesPerLine -> SwipesPerLine
forall a. a -> [a] -> [a]
:SwipesPerLine
nSwipes)
fillSmallGaps SwipesPerLine
swipes = SwipesPerLine
swipes

-- Generate HTML elements

element :: String -> [(String,String)] -> String -> String
element :: String -> [(String, String)] -> ShowS
element String
name [(String, String)]
attrs String
body =
  String
"<"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
nameString -> ShowS
forall a. [a] -> [a] -> [a]
++String
" "String -> ShowS
forall a. [a] -> [a] -> [a]
++
  [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
aString -> ShowS
forall a. [a] -> [a] -> [a]
++String
"="String -> ShowS
forall a. [a] -> [a] -> [a]
++String
bString -> ShowS
forall a. [a] -> [a] -> [a]
++String
" " | (String
a,String
b) <- [(String, String)]
attrs]String -> ShowS
forall a. [a] -> [a] -> [a]
++
  String
">"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
bodyString -> ShowS
forall a. [a] -> [a] -> [a]
++String
"</"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
nameString -> ShowS
forall a. [a] -> [a] -> [a]
++String
">"

quote :: String -> String
quote :: ShowS
quote String
s = String
qString -> ShowS
forall a. [a] -> [a] -> [a]
++String
sString -> ShowS
forall a. [a] -> [a] -> [a]
++String
q
  where q :: String
q = String
"\""

encode :: String -> String
encode :: ShowS
encode = Text -> String
unpack (Text -> String) -> (String -> Text) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
text (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack

-- Read source files and extract coverage information.

data FileInfo = FileInfo
  { FileInfo -> String
fiName    :: String
  , FileInfo -> [String]
fiLines   :: [String]
  , FileInfo -> Set CoverageAnnotation
fiAllAnns :: Set CoverageAnnotation
  , FileInfo -> Set CoverageAnnotation
fiCovered :: Set CoverageAnnotation
  , FileInfo -> Set CoverageAnnotation
fiIgnored :: Set CoverageAnnotation }

files :: CoverageReport -> IO [FileInfo]
files :: CoverageReport -> IO [FileInfo]
files (CoverageReport ci :: CoverageIndex
ci@(CoverageIndex Map CoverageAnnotation CoverageMetadata
metadataMap) (CoverageData Set CoverageAnnotation
annots)) = [IO FileInfo] -> IO [FileInfo]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [String -> IO FileInfo
file String
n | String
n <- CoverageIndex -> [String]
fileNames CoverageIndex
ci]
  where file :: String -> IO FileInfo
file String
name = do
          String
body <- (IOException -> String)
-> ShowS -> Either IOException String -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IOException -> String
forall a b. a -> b -> a
const String
"" :: IOException -> String) ShowS
forall a. a -> a
id (Either IOException String -> String)
-> IO (Either IOException String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    IO String -> IO (Either IOException String)
forall e a. Exception e => IO a -> IO (Either e a)
try (String -> IO String
readFile String
name)
          FileInfo -> IO FileInfo
forall (m :: * -> *) a. Monad m => a -> m a
return FileInfo :: String
-> [String]
-> Set CoverageAnnotation
-> Set CoverageAnnotation
-> Set CoverageAnnotation
-> FileInfo
FileInfo{ fiName :: String
fiName    = String
name
                         , fiLines :: [String]
fiLines   = String -> [String]
lines String
body
                         , fiAllAnns :: Set CoverageAnnotation
fiAllAnns = String -> Set CoverageAnnotation
covx String
name
                         , fiCovered :: Set CoverageAnnotation
fiCovered = String -> Set CoverageAnnotation
covs String
name
                         , fiIgnored :: Set CoverageAnnotation
fiIgnored = String -> Set CoverageAnnotation
covi String
name }
        ignoredMap :: Map CoverageAnnotation CoverageMetadata
ignoredMap = (CoverageMetadata -> Bool)
-> Map CoverageAnnotation CoverageMetadata
-> Map CoverageAnnotation CoverageMetadata
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Metadata -> Set Metadata -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Metadata
IgnoredAnnotation (Set Metadata -> Bool)
-> (CoverageMetadata -> Set Metadata) -> CoverageMetadata -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Set Metadata) CoverageMetadata (Set Metadata)
-> CoverageMetadata -> Set Metadata
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Set Metadata) CoverageMetadata (Set Metadata)
Iso' CoverageMetadata (Set Metadata)
metadataSet) Map CoverageAnnotation CoverageMetadata
metadataMap
        covx :: String -> Set CoverageAnnotation
covx String
name = (CoverageAnnotation -> Bool)
-> Set CoverageAnnotation -> Set CoverageAnnotation
forall a. (a -> Bool) -> Set a -> Set a
Set.filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
name) (String -> Bool)
-> (CoverageAnnotation -> String) -> CoverageAnnotation -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CovLoc -> String
_covLocFile (CovLoc -> String)
-> (CoverageAnnotation -> CovLoc) -> CoverageAnnotation -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoverageAnnotation -> CovLoc
getCovLoc) (Set CoverageAnnotation -> Set CoverageAnnotation)
-> (Map CoverageAnnotation CoverageMetadata
    -> Set CoverageAnnotation)
-> Map CoverageAnnotation CoverageMetadata
-> Set CoverageAnnotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map CoverageAnnotation CoverageMetadata -> Set CoverageAnnotation
forall k a. Map k a -> Set k
Map.keysSet (Map CoverageAnnotation CoverageMetadata -> Set CoverageAnnotation)
-> Map CoverageAnnotation CoverageMetadata
-> Set CoverageAnnotation
forall a b. (a -> b) -> a -> b
$ Map CoverageAnnotation CoverageMetadata
metadataMap
        covs :: String -> Set CoverageAnnotation
covs String
name = (CoverageAnnotation -> Bool)
-> Set CoverageAnnotation -> Set CoverageAnnotation
forall a. (a -> Bool) -> Set a -> Set a
Set.filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
name) (String -> Bool)
-> (CoverageAnnotation -> String) -> CoverageAnnotation -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CovLoc -> String
_covLocFile (CovLoc -> String)
-> (CoverageAnnotation -> CovLoc) -> CoverageAnnotation -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoverageAnnotation -> CovLoc
getCovLoc) Set CoverageAnnotation
annots
        covi :: String -> Set CoverageAnnotation
covi String
name = (CoverageAnnotation -> Bool)
-> Set CoverageAnnotation -> Set CoverageAnnotation
forall a. (a -> Bool) -> Set a -> Set a
Set.filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
name) (String -> Bool)
-> (CoverageAnnotation -> String) -> CoverageAnnotation -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CovLoc -> String
_covLocFile (CovLoc -> String)
-> (CoverageAnnotation -> CovLoc) -> CoverageAnnotation -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoverageAnnotation -> CovLoc
getCovLoc) (Set CoverageAnnotation -> Set CoverageAnnotation)
-> (Map CoverageAnnotation CoverageMetadata
    -> Set CoverageAnnotation)
-> Map CoverageAnnotation CoverageMetadata
-> Set CoverageAnnotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map CoverageAnnotation CoverageMetadata -> Set CoverageAnnotation
forall k a. Map k a -> Set k
Map.keysSet (Map CoverageAnnotation CoverageMetadata -> Set CoverageAnnotation)
-> Map CoverageAnnotation CoverageMetadata
-> Set CoverageAnnotation
forall a b. (a -> b) -> a -> b
$ Map CoverageAnnotation CoverageMetadata
ignoredMap

fileNames :: CoverageIndex -> [String]
fileNames :: CoverageIndex -> [String]
fileNames (CoverageIndex Map CoverageAnnotation CoverageMetadata
metadataMap) =
  Set String -> [String]
forall a. Set a -> [a]
Set.toList (Set String -> [String])
-> (Map CoverageAnnotation CoverageMetadata -> Set String)
-> Map CoverageAnnotation CoverageMetadata
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoverageAnnotation -> String)
-> Set CoverageAnnotation -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (CovLoc -> String
_covLocFile (CovLoc -> String)
-> (CoverageAnnotation -> CovLoc) -> CoverageAnnotation -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoverageAnnotation -> CovLoc
getCovLoc) (Set CoverageAnnotation -> Set String)
-> (Map CoverageAnnotation CoverageMetadata
    -> Set CoverageAnnotation)
-> Map CoverageAnnotation CoverageMetadata
-> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map CoverageAnnotation CoverageMetadata -> Set CoverageAnnotation
forall k a. Map k a -> Set k
Map.keysSet (Map CoverageAnnotation CoverageMetadata -> [String])
-> Map CoverageAnnotation CoverageMetadata -> [String]
forall a b. (a -> b) -> a -> b
$ Map CoverageAnnotation CoverageMetadata
metadataMap

getCovLoc :: CoverageAnnotation -> CovLoc
getCovLoc :: CoverageAnnotation -> CovLoc
getCovLoc (CoverLocation CovLoc
c) = CovLoc
c
getCovLoc (CoverBool CovLoc
c Bool
_)   = CovLoc
c

-- Generate the coverage report and write to an HTML file.

writeCoverageReport :: String -> CoverageReport -> IO ()
writeCoverageReport :: String -> CoverageReport -> IO ()
writeCoverageReport String
name CoverageReport
cr = do
  [FileInfo]
fs <- CoverageReport -> IO [FileInfo]
files CoverageReport
cr
  String -> String -> IO ()
writeFile (String
nameString -> ShowS
forall a. [a] -> [a] -> [a]
++String
".html") (String -> IO ()) -> ([FileInfo] -> String) -> [FileInfo] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FileInfo] -> String
coverageReportHtml ([FileInfo] -> IO ()) -> [FileInfo] -> IO ()
forall a b. (a -> b) -> a -> b
$ [FileInfo]
fs

coverageReportHtml :: [FileInfo] -> String
coverageReportHtml :: [FileInfo] -> String
coverageReportHtml [FileInfo]
fs = String -> [(String, String)] -> ShowS
element String
"body" [] ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
report
  where
    report :: String
report = String
header String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"<hr>"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
-> [String]
-> Set CoverageAnnotation
-> Set CoverageAnnotation
-> Set CoverageAnnotation
-> String
file String
name [String]
body Set CoverageAnnotation
covx Set CoverageAnnotation
annots Set CoverageAnnotation
covi | FileInfo String
name [String]
body Set CoverageAnnotation
covx Set CoverageAnnotation
annots Set CoverageAnnotation
covi <- [FileInfo]
fs]
    header :: String
header =
      String -> [(String, String)] -> ShowS
element String
"h1" [] String
"Files" String -> ShowS
forall a. [a] -> [a] -> [a]
++
      String -> [(String, String)] -> ShowS
element String
"ul" []
        ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String -> [(String, String)] -> ShowS
element String
"li" [] ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(String, String)] -> ShowS
element String
"a" [(String
"href",ShowS
quote (String
"#"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
name))] ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
name
                | FileInfo{fiName :: FileInfo -> String
fiName = String
name} <- [FileInfo]
fs])
    file :: String
-> [String]
-> Set CoverageAnnotation
-> Set CoverageAnnotation
-> Set CoverageAnnotation
-> String
file String
name [String]
body Set CoverageAnnotation
covx Set CoverageAnnotation
annots Set CoverageAnnotation
covi =
      let uncovered :: Set CoverageAnnotation
uncovered  = Set CoverageAnnotation
covx Set CoverageAnnotation
-> Set CoverageAnnotation -> Set CoverageAnnotation
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set CoverageAnnotation
annots
          status :: CoverageAnnotation -> Status
status CoverageAnnotation
ann = CoverStatus -> IgnoreStatus -> Status
OnChain (Bool -> CoverStatus -> CoverStatus
forall p. Monoid p => Bool -> p -> p
ifM Bool
c CoverStatus
covS) (Bool -> IgnoreStatus -> IgnoreStatus
forall p. Monoid p => Bool -> p -> p
ifM Bool
i IgnoreStatus
ignS)
            where
              i :: Bool
i = CoverageAnnotation -> Set CoverageAnnotation -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member CoverageAnnotation
ann Set CoverageAnnotation
covi
              c :: Bool
c = CoverageAnnotation -> Set CoverageAnnotation -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember CoverageAnnotation
ann Set CoverageAnnotation
uncovered
              ifM :: Bool -> p -> p
ifM Bool
False p
_ = p
forall a. Monoid a => a
mempty
              ifM Bool
True  p
m = p
m
              covS :: CoverStatus
covS = case CoverageAnnotation
ann of
                CoverBool _ True  -> CoverStatus
HasBeenTrue
                CoverBool _ False -> CoverStatus
HasBeenFalse
                CoverLocation{}   -> CoverStatus
HasBeenHere
              ignS :: IgnoreStatus
ignS = case CoverageAnnotation
ann of
                CoverBool _ True  -> IgnoreStatus
IgnoredIfTrue
                CoverBool _ False -> IgnoreStatus
IgnoredIfFalse
                CoverLocation{}   -> IgnoreStatus
AlwaysIgnored
          swipe :: CovLoc -> Status -> Swipe
swipe CovLoc
loc Status
s = Pos -> Pos -> Status -> Swipe
Swipe (CovLoc -> Int
_covLocStartLine CovLoc
loc, CovLoc -> Int
_covLocStartCol CovLoc
loc)
                              (CovLoc -> Int
_covLocEndLine   CovLoc
loc, CovLoc -> Int
_covLocEndCol   CovLoc
loc) Status
s
          swipes :: [Swipe]
swipes = [Swipe] -> [Swipe]
flattenSwipes ([Swipe] -> [Swipe]) -> ([Swipe] -> [Swipe]) -> [Swipe] -> [Swipe]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Swipe] -> [Swipe]
forall a. Ord a => [a] -> [a]
sort ([Swipe] -> [Swipe]) -> [Swipe] -> [Swipe]
forall a b. (a -> b) -> a -> b
$
                   [ CovLoc -> Status -> Swipe
swipe (CoverageAnnotation -> CovLoc
getCovLoc CoverageAnnotation
ann) (Status -> Swipe) -> Status -> Swipe
forall a b. (a -> b) -> a -> b
$ CoverageAnnotation -> Status
status CoverageAnnotation
ann | CoverageAnnotation
ann <- Set CoverageAnnotation -> [CoverageAnnotation]
forall a. Set a -> [a]
Set.toList Set CoverageAnnotation
covx ]
      in
      String -> [(String, String)] -> ShowS
element String
"h2" [(String
"id",ShowS
quote String
name)] String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++
      String -> [(String, String)] -> ShowS
element String
"pre" [] ([String] -> String
unlines
        ([(Int, String)] -> SwipesPerLine -> [String]
annotateLines
          ([Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [String]
body)
          (SwipesPerLine -> SwipesPerLine
fillSmallGaps (SwipesPerLine -> SwipesPerLine)
-> ([Swipe] -> SwipesPerLine) -> [Swipe] -> SwipesPerLine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SwipesPerLine -> SwipesPerLine
includeNearby (SwipesPerLine -> SwipesPerLine)
-> ([Swipe] -> SwipesPerLine) -> [Swipe] -> SwipesPerLine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Swipe] -> SwipesPerLine
swipesByLine ([Swipe] -> SwipesPerLine) -> [Swipe] -> SwipesPerLine
forall a b. (a -> b) -> a -> b
$ [Swipe]
swipes)))

-- Apply swipes to the selected contents of a file

annotateLines :: [(Int,String)] -> SwipesPerLine -> [String]
annotateLines :: [(Int, String)] -> SwipesPerLine -> [String]
annotateLines [(Int, String)]
_ [] = []
annotateLines [] SwipesPerLine
_ = [String -> [(String, String)] -> ShowS
element String
"div" [(String
"style",String
"color:red")] String
"Source code not available"]
annotateLines ((Int
n,String
line):[(Int, String)]
nLines) ((Int
n',[Swipe]
swipes):SwipesPerLine
nSwipes)
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n'  = Int -> String -> [String]
forall a. Int -> a -> [a]
replicate Int
3 String
"." [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
              [(Int, String)] -> SwipesPerLine -> [String]
annotateLines (((Int, String) -> Bool) -> [(Int, String)] -> [(Int, String)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
n')(Int -> Bool) -> ((Int, String) -> Int) -> (Int, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int, String) -> Int
forall a b. (a, b) -> a
fst) [(Int, String)]
nLines) ((Int
n',[Swipe]
swipes)(Int, [Swipe]) -> SwipesPerLine -> SwipesPerLine
forall a. a -> [a] -> [a]
:SwipesPerLine
nSwipes)
  | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n' = Int -> String -> [Swipe] -> String
annotateLine Int
n String
line [Swipe]
swipesString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[(Int, String)] -> SwipesPerLine -> [String]
annotateLines [(Int, String)]
nLines SwipesPerLine
nSwipes
annotateLines [(Int, String)]
xs SwipesPerLine
ys =
  String -> [String]
forall a. HasCallStack => String -> a
error (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String
"Non-exhaustive patterns in function annotateLines\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++
  [String] -> String
unlines (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
10 (((Int, String) -> String) -> [(Int, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int, String) -> String
forall a. Show a => a -> String
show [(Int, String)]
xs) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"----------"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
10 (((Int, [Swipe]) -> String) -> SwipesPerLine -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int, [Swipe]) -> String
forall a. Show a => a -> String
show SwipesPerLine
ys))

-- Annotate a line with a list of swipes

annotateLine :: Int -> String -> [Swipe] -> String
annotateLine :: Int -> String -> [Swipe] -> String
annotateLine Int
n String
line [Swipe]
swipes =
  Int -> String
showLineNo Int
nString -> ShowS
forall a. [a] -> [a] -> [a]
++String
"    "String -> ShowS
forall a. [a] -> [a] -> [a]
++Int -> String -> [Swipe] -> String
swipeLine Int
1 String
line [Swipe]
swipes

swipeLine :: Int -> String -> [Swipe] -> String
swipeLine :: Int -> String -> [Swipe] -> String
swipeLine Int
_ String
line [] = String -> [(String, String)] -> ShowS
element String
"span" [(String
"style",String
offChainStyle)] ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
encode String
line
swipeLine Int
c String
line s :: [Swipe]
s@(Swipe (Int
_,Int
from) (Int
_,Int
to) Status
stat:[Swipe]
swipes)
  | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
from  = String -> [(String, String)] -> ShowS
element String
"span" [(String
"style",String
offChainStyle)] (ShowS
encode ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
take (Int
fromInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
c) String
line) String -> ShowS
forall a. [a] -> [a] -> [a]
++
                Int -> String -> [Swipe] -> String
swipeLine Int
from (Int -> ShowS
forall a. Int -> [a] -> [a]
drop (Int
fromInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
c) String
line) [Swipe]
s
  | Bool
otherwise = String -> [(String, String)] -> ShowS
element String
"span" [(String
"style",Status -> String
statusStyle Status
stat)] (ShowS
encode ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
take (Int
toInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
from) String
line) String -> ShowS
forall a. [a] -> [a] -> [a]
++
                Int -> String -> [Swipe] -> String
swipeLine (Int
toInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int -> ShowS
forall a. Int -> [a] -> [a]
drop (Int
toInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
from) String
line) [Swipe]
swipes

showLineNo :: Int -> String
showLineNo :: Int -> String
showLineNo Int
n = ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
6 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
6 Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n