Skip to content
Snippets Groups Projects
Commit 9d6f0747 authored by Georgy Lukyanov's avatar Georgy Lukyanov
Browse files

Delete MarkupLucid

parent 448cadf9
No related branches found
No related tags found
No related merge requests found
Pipeline #96240 passed
Stage: test
Hide whitespace changes
Inline Side-by-side
src/Trace/Hpc/MarkupLucid.hs deleted 100644 → 0
+ 0
− 297
View file @ 448cadf9
{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules #-}
-- |
-- Module : Trace.Hpc.MarkupLucid
-- Description : The subcommand @hpc markup@
-- Copyright : Andy Gill and Colin Runciman, 2006
-- License : BSD-3-Clause
module Trace.Hpc.MarkupLucid (markupLucidPlugin) where
import qualified Lucid as L
import Control.Monad
import Data.Array
import Data.List (find, sortBy)
import Data.Maybe
import Data.Semigroup as Semi
import qualified Data.Set as Set
import qualified Data.Text as T
import System.FilePath
import Trace.Hpc.Flags
import Trace.Hpc.Mix
import Trace.Hpc.Plugin
import Trace.Hpc.Tix
import Trace.Hpc.Util
import Trace.Hpc.Utils
------------------------------------------------------------------------------
markupOptions :: FlagOptSeq
markupOptions =
excludeOpt
. includeOpt
. srcDirOpt
. hpcDirOpt
. resetHpcDirsOpt
. funTotalsOpt
. altHighlightOpt
. destDirOpt
. verbosityOpt
markupLucidPlugin :: Plugin
markupLucidPlugin =
Plugin
{ name = "markupLucid",
usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]",
options = markupOptions,
summary = "Markup Haskell source with program coverage",
implementation = markupMain
}
------------------------------------------------------------------------------
-- Templates for the summary HTML page
------------------------------------------------------------------------------
-- | The <head>...</head> component of the summary html page
summaryHtmlHead :: L.Html ()
summaryHtmlHead = L.head_ (meta <> style)
where
-- | <meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
meta :: L.Html ()
meta = L.meta_ [L.httpEquiv_ "Content-Type", L.content_ "text/html; charset=UTF-8"]
style :: L.Html ()
style = L.style_ [L.type_ "text/css"] stylecontent
stylecontent :: T.Text
stylecontent = "table.bar { background-color: #f25913; }\n"
<> "td.bar { background-color: #60de51; }\n"
<> "td.invbar { background-color: #f25913; }\n"
<> "table.dashboard { border-collapse: collapse ; border: solid 1px black }\n"
<> ".dashboard td { border: solid 1px black }\n"
<> ".dashboard th { border: solid 1px black }\n"
-- | The <body>..</body> component of the summary html page
summaryHtmlBody :: [(String, String, ModuleSummary)] -> L.Html ()
summaryHtmlBody mods = L.body_ (L.table_ [L.class_ "dashboard", L.width_ "100%" {-, L.border_ "1"-}] tableBody)
where
tableBody :: L.Html ()
tableBody = hyperlinks <> heading <> modSummary <> (L.tr_ "") <> totalSummary
heading :: L.Html ()
heading = L.tr_ (percent <> coveredTotal <> percent <> coveredTotal <> percent <> coveredTotal)
where
percent = L.th_ "%"
coveredTotal = L.th_ [L.colspan_ "2"] "covered / total"
modSummary :: L.Html ()
modSummary = mconcat (showModuleSummary <$> mods)
totalSummary :: L.Html ()
totalSummary = showTotalSummary (mconcat [modSummary | (_, _, modSummary) <- mods])
hyperlinks :: L.Html ()
hyperlinks = L.tr_ (
(L.th_ [L.rowspan_ "2"] (L.a_ [L.href_ "hpc_index.html"] "module")) <>
(L.th_ [L.colspan_ "3"] (L.a_ [L.href_ "hpc_index_fun.html"] "Top Level Definitions")) <>
(L.th_ [L.colspan_ "3"] (L.a_ [L.href_ "hpc_index_alt.html"] "Alternatives")) <>
(L.th_ [L.colspan_ "3"] (L.a_ [L.href_ "hpc_index_exp.html"] "Expressions")))
showModuleSummary :: (String, String, ModuleSummary) -> L.Html ()
showModuleSummary (modName, fileName, modSummary) = L.tr_ (link <> top <> alt <> exp)
where
link = L.td_ ("&nbsp;&nbsp;" <> L.code_ ("module" <> L.a_ [L.href_ (T.pack fileName)] (L.toHtml modName)))
top = showSummary (topFunTicked modSummary) (topFunTotal modSummary)
alt = showSummary (altTicked modSummary) (altTotal modSummary)
exp = showSummary (expTicked modSummary) (expTotal modSummary)
showTotalSummary :: ModuleSummary -> L.Html ()
showTotalSummary modSummary = L.tr_ [L.style_ "background: #e0e0e0"] content
where
content = header <> top <> alt <> exp
header = L.th_ [L.style_ "text-align: left"] "&nbsp;&nbsp;Program Coverage Total"
top = showSummary (topFunTicked modSummary) (topFunTotal modSummary)
alt = showSummary (altTicked modSummary) (altTotal modSummary)
exp = showSummary (expTicked modSummary) (expTotal modSummary)
showSummary :: Int -> Int -> L.Html ()
showSummary ticked total = percentHtml <> tickedTotal <> last
where
percentHtml :: L.Html ()
percentHtml = L.td_ [L.style_ "text-align: right"] (showP (percent ticked total))
showP :: Maybe Int -> L.Html ()
showP Nothing = "-&nbsp;"
showP (Just x) = L.toHtml (show x) <> "%"
tickedTotal :: L.Html ()
tickedTotal = L.td_ [] (L.toHtml (show ticked <> "/" <> show total))
last :: L.Html ()
last = L.td_ [L.width_ "100"] (case percent ticked total of { Nothing -> "&nbsp;"; Just w -> bar w "bar"})
bar :: Int -> String -> L.Html ()
bar 0 _ = bar 100 "invbar"
bar w inner = L.table_ [ {- L.cellpadding_ "0", L.cellspacing_ "0",-} L.width_ "100", L.class_ "bar"] (L.tr_ (L.td_ innerTable))
where
innerTable :: L.Html ()
innerTable = L.table_ [{- L.cellpadding_ "0", L.cellspacing_ "0",-} L.width_ (T.pack (show w))] tableContent
tableContent :: L.Html ()
tableContent = L.tr_ (L.td_ [L.height_ "12", L.class_ (T.pack inner)] "")
percent :: Int -> Int -> Maybe Int
percent ticked total = if total == 0 then Nothing else Just (ticked * 100 `div` total)
-- | The <html>..</html> component of the summary html page
summaryHtml :: [(String, String, ModuleSummary)] -> L.Html ()
summaryHtml mods = L.html_ (summaryHtmlHead <> (summaryHtmlBody mods))
------------------------------------------------------------------------------
-- Templates for the per-module HTML page
------------------------------------------------------------------------------
-- | The <html>..</html> component of the per module html page
perModuleHtml :: Bool
-- ^ Whether we want to highlight covered code or gaps in code coverage.
-> Int
-- ^ tabStop
-> [(HpcPos, Markup)]
-- ^ random list of tick location pairs
-> String
-- ^ text to mark up
-> L.Html ()
perModuleHtml invertOutput tabstop mix str = (perModuleHtmlHead invertOutput) <> (perModuleHtmlBody tabstop mix str)
-- | The <head>..</head> component of the per module html page
perModuleHtmlHead :: Bool
-- ^ Whether we want to highlight covered code or gaps in code coverage.
-> L.Html ()
perModuleHtmlHead invertOutput = L.head_ (meta <> style)
where
meta :: L.Html ()
meta = L.meta_ [L.httpEquiv_ "Content-Type", L.content_ "text/html; charset=UTF-8"]
style :: L.Html ()
style = L.style_ [L.type_ "text/css"] stylecontent
stylecontent :: T.Text
stylecontent = T.unlines [
"span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }",
if invertOutput
then "span.nottickedoff { color: #404040; background: white; font-style: oblique }"
else "span.nottickedoff { background: " <> yellow <> "}",
if invertOutput
then "span.istickedoff { color: black; background: #d0c0ff; font-style: normal; }"
else "span.istickedoff { background: white }",
"span.tickonlyfalse { margin: -1px; border: 1px solid " <> red <> "; background: " <> red <> " }",
"span.tickonlytrue { margin: -1px; border: 1px solid " <> green <> "; background: " <> green <> " }",
"span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 }",
if invertOutput
then "span.decl { font-weight: bold; background: #d0c0ff }"
else "span.decl { font-weight: bold }",
"span.spaces { background: white }"]
red :: T.Text
red = "#f20913"
green :: T.Text
green = "#60de51"
yellow :: T.Text
yellow = "yellow"
-- | The <body>..</body> component of the per module html page
perModuleHtmlBody :: Int
-- ^ tabStop
-> [(HpcPos, Markup)]
-- ^ random list of tick location pairs
-> String
-- ^ text to mark up
-> L.Html ()
perModuleHtmlBody tabstop mix str = L.body_ (header <> (L.pre_ (addLines (markup tabstop mix str))))
where
header :: L.Html ()
header = L.pre_ (L.span_ [L.class_ "decl"] (neverExecuted <> alwaysTrue <> alwaysFalse))
neverExecuted :: L.Html ()
neverExecuted = L.span_ [L.class_ "nottickedoff"] "never executed"
alwaysTrue :: L.Html ()
alwaysTrue = L.span_ [L.class_ "tickonlytrue"] "always true"
alwaysFalse :: L.Html ()
alwaysFalse = L.span_ [L.class_ "tickonlyfalse"] "always false"
addLine :: Int -> L.Html () -> L.Html ()
addLine n xs = (L.span_ [L.class_ "lineno"] (L.toHtml (padLeft 5 ' ' (show n)))) <> xs
addLines :: [L.Html ()] -> L.Html ()
addLines xs = mconcat (zipWith addLine [1 :: Int ..] xs)
markup :: Int
-- ^ tabStop
-> [(HpcPos, Markup)]
-- ^ random list of tick location pairs
-> String
-- ^ text to mark up
-> [L.Html ()]
markup tabstop mix str = undefined
------------------------------------------------------------------------------
-- Other
------------------------------------------------------------------------------
-- Add characters to the left of a string until it is at least as
-- large as requested.
padLeft :: Int -> Char -> String -> String
padLeft n c str = go n str
where
-- If the string is already long enough, stop traversing it.
go 0 _ = str
go k [] = replicate k c ++ str
go k (_ : xs) = go (k - 1) xs
markupMain :: Flags -> [String] -> IO ()
markupMain = undefined
data Loc = Loc !Int !Int
deriving (Eq, Ord, Show)
data Markup
= NotTicked
| TickedOnlyTrue
| TickedOnlyFalse
| IsTicked
| TopLevelDecl
Bool -- display entry totals
Integer
deriving (Eq, Show)
data ModuleSummary = ModuleSummary
{ expTicked :: !Int,
expTotal :: !Int,
topFunTicked :: !Int,
topFunTotal :: !Int,
altTicked :: !Int,
altTotal :: !Int
}
deriving (Show)
instance Semi.Semigroup ModuleSummary where
(ModuleSummary eTik1 eTot1 tTik1 tTot1 aTik1 aTot1) <> (ModuleSummary eTik2 eTot2 tTik2 tTot2 aTik2 aTot2) =
ModuleSummary (eTik1 + eTik2) (eTot1 + eTot2) (tTik1 + tTik2) (tTot1 + tTot2) (aTik1 + aTik2) (aTot1 + aTot2)
instance Monoid ModuleSummary where
mempty =
ModuleSummary
{ expTicked = 0,
expTotal = 0,
topFunTicked = 0,
topFunTotal = 0,
altTicked = 0,
altTotal = 0
}
mappend = (<>)
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment