<commit_before>---------------------------------------------------------
-- The main program for the hpc-markup tool, part of HPC.
-- <NAME> and <NAME>, June 2006
---------------------------------------------------------

module HpcMarkup (markup_plugin) where

import Trace.Hpc.Mix
import Trace.Hpc.Tix
import Trace.Hpc.Util

import HpcFlags
import HpcUtils

import System.Directory
import Data.List
import Data.Maybe(fromJust)
import Data.Array
import Data.Monoid
import Control.Monad
import qualified Data.Set as Set

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

markup_options :: FlagOptSeq
markup_options
        = excludeOpt
        . includeOpt
        . srcDirOpt
        . hpcDirOpt
        . funTotalsOpt
        . altHighlightOpt
        . destDirOpt

markup_plugin :: Plugin
markup_plugin = Plugin { name = "markup"
                       , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
                       , options = markup_options
                       , summary = "Markup Haskell source with program coverage"
                       , implementation = markup_main
                       , init_flags = default_flags
                       , final_flags = default_final_flags
                       }

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

markup_main :: Flags -> [String] -> IO ()
markup_main flags (prog:modNames) = do
  let hpcflags1 = flags
                { includeMods = Set.fromList modNames
                                   `Set.union`
                                includeMods flags }
  let Flags
       { funTotals = theFunTotals
       , altHighlight = invertOutput
       , destDir = dest_dir
       }  = hpcflags1

  mtix <- readTix (getTixFileName prog)
  Tix tixs <- case mtix of
    Nothing -> hpcError markup_plugin $ "unable to find tix file for: " ++ prog
    Just a -> return a

  mods <-
     sequence [ genHtmlFromMod dest_dir hpcflags1 tix theFunTotals invertOutput
              | tix <- tixs
              , allowModule hpcflags1 (tixModuleName tix)
              ]

  let index_name = "hpc_index"
      index_fun  = "hpc_index_fun"
      index_alt  = "hpc_index_alt"
      index_exp  = "hpc_index_exp"

  let writeSummary filename cmp = do
        let mods' = sortBy cmp mods

        putStrLn $ "Writing: " ++ (filename ++ ".html")

        writeFileUsing (dest_dir ++ "/" ++ filename ++ ".html") $
            "<html>" ++
            "<style type=\"text/css\">" ++
            "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" ++
            "</style>\n" ++
            "<table class=\"dashboard\" width=\"100%\" border=1>\n" ++
            "<tr>" ++
            "<th rowspan=2><a href=\"" ++ index_name ++ ".html\">module</a></th>" ++
            "<th colspan=3><a href=\"" ++ index_fun ++ ".html\">Top Level Definitions</a></th>" ++
            "<th colspan=3><a href=\"" ++ index_alt ++ ".html\">Alternatives</a></th>" ++
            "<th colspan=3><a href=\"" ++ index_exp ++ ".html\">Expressions</a></th>" ++
            "</tr>" ++
            "<tr>" ++
            "<th>%</th>" ++
            "<th colspan=2>covered / total</th>" ++
            "<th>%</th>" ++
            "<th colspan=2>covered / total</th>" ++
            "<th>%</th>" ++
            "<th colspan=2>covered / total</th>" ++
            "</tr>" ++
            concat [ showModuleSummary (modName,fileName,modSummary)
                   | (modName,fileName,modSummary) <- mods'
                   ] ++
            "<tr></tr>" ++
            showTotalSummary (mconcat
                                 [ modSummary
                                 | (_,_,modSummary) <- mods'
                                 ])
                   ++ "</table></html>\n"

  writeSummary index_name  $ \ (n1,_,_) (n2,_,_) -> compare n1 n2

  writeSummary index_fun $ \ (_,_,s1) (_,_,s2) ->
        compare (percent (topFunTicked s2) (topFunTotal s2))
                (percent (topFunTicked s1) (topFunTotal s1))

  writeSummary index_alt $ \ (_,_,s1) (_,_,s2) ->
        compare (percent (altTicked s2) (altTotal s2))
                (percent (altTicked s1) (altTotal s1))

  writeSummary index_exp $ \ (_,_,s1) (_,_,s2) ->
        compare (percent (expTicked s2) (expTotal s2))
                (percent (expTicked s1) (expTotal s1))


markup_main _ []
    = hpcError markup_plugin $ "no .tix file or executable name specified"

genHtmlFromMod
  :: String
  -> Flags
  -> TixModule
  -> Bool
  -> Bool
  -> IO (String, [Char], ModuleSummary)
genHtmlFromMod dest_dir flags tix theFunTotals invertOutput = do
  let theHsPath = srcDirs flags
  let modName0 = tixModuleName tix

  (Mix origFile _ _ tabStop mix') <- readMixWithFlags flags (Right tix)

  let arr_tix :: Array Int Integer
      arr_tix = listArray (0,length (tixModuleTixs tix) - 1)
              $ tixModuleTixs tix

  let tickedWith :: Int -> Integer
      tickedWith n = arr_tix ! n

      isTicked n = tickedWith n /= 0

  let info = [ (pos,theMarkup)
             | (gid,(pos,boxLabel)) <- zip [0 ..] mix'
             , let binBox = case (isTicked gid,isTicked (gid+1)) of
                               (False,False) -> []
                               (True,False)  -> [TickedOnlyTrue]
                               (False,True)  -> [TickedOnlyFalse]
                               (True,True)   -> []
             , let tickBox = if isTicked gid
                             then [IsTicked]
                             else [NotTicked]
             , theMarkup <- case boxLabel of
                                  ExpBox {} -> tickBox
                                  TopLevelBox {}
                                            -> TopLevelDecl theFunTotals (tickedWith gid) : tickBox
                                  LocalBox {}   -> tickBox
                                  BinBox _ True -> binBox
                                  _             -> []
             ]


  let modSummary = foldr (.) id
             [ \ st ->
               case boxLabel of
                 ExpBox False
                        -> st { expTicked = ticked (expTicked st)
                              , expTotal = succ (expTotal st)
                              }
                 ExpBox True
                        -> st { expTicked = ticked (expTicked st)
                              , expTotal = succ (expTotal st)
                              , altTicked = ticked (altTicked st)
                              , altTotal = succ (altTotal st)
                              }
                 TopLevelBox _ ->
                           st { topFunTicked = ticked (topFunTicked st)
                              , topFunTotal = succ (topFunTotal st)
                              }
                 _ -> st
             | (gid,(_pos,boxLabel)) <- zip [0 ..] mix'
             , let ticked = if isTicked gid
                            then succ
                            else id
             ] $ mempty

  -- add prefix to modName argument
  content <- readFileFromPath (hpcError markup_plugin) origFile theHsPath

  let content' = markup tabStop info content
  let show' = reverse . take 5 . (++ "       ") . reverse . show
  let addLine n xs = "<span class=\"lineno\">" ++ show' n ++ " </span>" ++ xs
  let addLines = unlines . map (uncurry addLine) . zip [1 :: Int ..] . lines
  let fileName = modName0 ++ ".hs.html"
  putStrLn $ "Writing: " ++ fileName
  writeFileUsing (dest_dir ++ "/" ++ fileName) $
            unlines [ "<html><style type=\"text/css\">",
                     "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 }",
                     "</style>",
                     "<pre>"] ++ addLines content' ++ "\n</pre>\n</html>\n";

  modSummary `seq` return (modName0,fileName,modSummary)

data Loc = Loc !Int !Int
         deriving (Eq,Ord,Show)

data Markup
     = NotTicked
     | TickedOnlyTrue
     | TickedOnlyFalse
     | IsTicked
     | TopLevelDecl
           Bool     -- display entry totals
           Integer<commit_msg>Write locale character encoding to hpc html report (#5006)<commit_after>---------------------------------------------------------
-- The main program for the hpc-markup tool, part of HPC.
-- <NAME> and <NAME>, June 2006
---------------------------------------------------------

module HpcMarkup (markup_plugin) where

import Trace.Hpc.Mix
import Trace.Hpc.Tix
import Trace.Hpc.Util

import HpcFlags
import HpcUtils

import System.Directory
import System.IO (localeEncoding)
import Data.List
import Data.Maybe(fromJust)
import Data.Array
import Data.Monoid
import Control.Monad
import qualified Data.Set as Set

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

markup_options :: FlagOptSeq
markup_options
        = excludeOpt
        . includeOpt
        . srcDirOpt
        . hpcDirOpt
        . funTotalsOpt
        . altHighlightOpt
        . destDirOpt

markup_plugin :: Plugin
markup_plugin = Plugin { name = "markup"
                       , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
                       , options = markup_options
                       , summary = "Markup Haskell source with program coverage"
                       , implementation = markup_main
                       , init_flags = default_flags
                       , final_flags = default_final_flags
                       }

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

markup_main :: Flags -> [String] -> IO ()
markup_main flags (prog:modNames) = do
  let hpcflags1 = flags
                { includeMods = Set.fromList modNames
                                   `Set.union`
                                includeMods flags }
  let Flags
       { funTotals = theFunTotals
       , altHighlight = invertOutput
       , destDir = dest_dir
       }  = hpcflags1

  mtix <- readTix (getTixFileName prog)
  Tix tixs <- case mtix of
    Nothing -> hpcError markup_plugin $ "unable to find tix file for: " ++ prog
    Just a -> return a

  mods <-
     sequence [ genHtmlFromMod dest_dir hpcflags1 tix theFunTotals invertOutput
              | tix <- tixs
              , allowModule hpcflags1 (tixModuleName tix)
              ]

  let index_name = "hpc_index"
      index_fun  = "hpc_index_fun"
      index_alt  = "hpc_index_alt"
      index_exp  = "hpc_index_exp"

  let writeSummary filename cmp = do
        let mods' = sortBy cmp mods

        putStrLn $ "Writing: " ++ (filename ++ ".html")

        writeFileUsing (dest_dir ++ "/" ++ filename ++ ".html") $
            "<html>" ++
            "<head>" ++
            charEncodingTag ++
            "<style type=\"text/css\">" ++
            "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" ++
            "</style>\n" ++
            "</head>" ++
            "<body>" ++
            "<table class=\"dashboard\" width=\"100%\" border=1>\n" ++
            "<tr>" ++
            "<th rowspan=2><a href=\"" ++ index_name ++ ".html\">module</a></th>" ++
            "<th colspan=3><a href=\"" ++ index_fun ++ ".html\">Top Level Definitions</a></th>" ++
            "<th colspan=3><a href=\"" ++ index_alt ++ ".html\">Alternatives</a></th>" ++
            "<th colspan=3><a href=\"" ++ index_exp ++ ".html\">Expressions</a></th>" ++
            "</tr>" ++
            "<tr>" ++
            "<th>%</th>" ++
            "<th colspan=2>covered / total</th>" ++
            "<th>%</th>" ++
            "<th colspan=2>covered / total</th>" ++
            "<th>%</th>" ++
            "<th colspan=2>covered / total</th>" ++
            "</tr>" ++
            concat [ showModuleSummary (modName,fileName,modSummary)
                   | (modName,fileName,modSummary) <- mods'
                   ] ++
            "<tr></tr>" ++
            showTotalSummary (mconcat
                                 [ modSummary
                                 | (_,_,modSummary) <- mods'
                                 ])
                   ++ "</table></body></html>\n"

  writeSummary index_name  $ \ (n1,_,_) (n2,_,_) -> compare n1 n2

  writeSummary index_fun $ \ (_,_,s1) (_,_,s2) ->
        compare (percent (topFunTicked s2) (topFunTotal s2))
                (percent (topFunTicked s1) (topFunTotal s1))

  writeSummary index_alt $ \ (_,_,s1) (_,_,s2) ->
        compare (percent (altTicked s2) (altTotal s2))
                (percent (altTicked s1) (altTotal s1))

  writeSummary index_exp $ \ (_,_,s1) (_,_,s2) ->
        compare (percent (expTicked s2) (expTotal s2))
                (percent (expTicked s1) (expTotal s1))


markup_main _ []
    = hpcError markup_plugin $ "no .tix file or executable name specified"

charEncodingTag :: String
charEncodingTag =
    "<meta http-equiv=\"Content-Type\" " ++
          "content=\"text/html; " ++ "charset=" ++ show localeEncoding ++ "\">"

genHtmlFromMod
  :: String
  -> Flags
  -> TixModule
  -> Bool
  -> Bool
  -> IO (String, [Char], ModuleSummary)
genHtmlFromMod dest_dir flags tix theFunTotals invertOutput = do
  let theHsPath = srcDirs flags
  let modName0 = tixModuleName tix

  (Mix origFile _ _ tabStop mix') <- readMixWithFlags flags (Right tix)

  let arr_tix :: Array Int Integer
      arr_tix = listArray (0,length (tixModuleTixs tix) - 1)
              $ tixModuleTixs tix

  let tickedWith :: Int -> Integer
      tickedWith n = arr_tix ! n

      isTicked n = tickedWith n /= 0

  let info = [ (pos,theMarkup)
             | (gid,(pos,boxLabel)) <- zip [0 ..] mix'
             , let binBox = case (isTicked gid,isTicked (gid+1)) of
                               (False,False) -> []
                               (True,False)  -> [TickedOnlyTrue]
                               (False,True)  -> [TickedOnlyFalse]
                               (True,True)   -> []
             , let tickBox = if isTicked gid
                             then [IsTicked]
                             else [NotTicked]
             , theMarkup <- case boxLabel of
                                  ExpBox {} -> tickBox
                                  TopLevelBox {}
                                            -> TopLevelDecl theFunTotals (tickedWith gid) : tickBox
                                  LocalBox {}   -> tickBox
                                  BinBox _ True -> binBox
                                  _             -> []
             ]


  let modSummary = foldr (.) id
             [ \ st ->
               case boxLabel of
                 ExpBox False
                        -> st { expTicked = ticked (expTicked st)
                              , expTotal = succ (expTotal st)
                              }
                 ExpBox True
                        -> st { expTicked = ticked (expTicked st)
                              , expTotal = succ (expTotal st)
                              , altTicked = ticked (altTicked st)
                              , altTotal = succ (altTotal st)
                              }
                 TopLevelBox _ ->
                           st { topFunTicked = ticked (topFunTicked st)
                              , topFunTotal = succ (topFunTotal st)
                              }
                 _ -> st
             | (gid,(_pos,boxLabel)) <- zip [0 ..] mix'
             , let ticked = if isTicked gid
                            then succ
                            else id
             ] $ mempty

  -- add prefix to modName argument
  content <- readFileFromPath (hpcError markup_plugin) origFile theHsPath

  let content' = markup tabStop info content
  let show' = reverse . take 5 . (++ "       ") . reverse . show
  let addLine n xs = "<span class=\"lineno\">" ++ show' n ++ " </span>" ++ xs
  let addLines = unlines . map (uncurry addLine) . zip [1 :: Int ..] . lines
  let fileName = modName0 ++ ".hs.html"
  putStrLn $ "Writing: " ++ fileName
  writeFileUsing (dest_dir ++ "/" ++ fileName) $
            unlines ["<html>",
                     "<head>",
                     charEncodingTag,
                     "<style type=\"text/css\">",
                     "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 }",
                     "</style>",
                     "</head>",
                     "<body>",
                     "<pre>"] ++ addLines content' ++ "\n</pre>\n</body>\n</html>\n";


  modSummary `seq` return (modName0,fileName,modSummary)

data Loc = Loc !Int !Int
         deriving (Eq,Ord,Show)

data Markup
     = NotTicked
     | TickedOnlyTrue
     | TickedOnlyFalse
     | IsTicked
     | TopLevelDecl
           Bool     -- display entry totals
           Integer
{'fraction_non_alphanumeric': 0.14812897883132342, 'fraction_numerical': 0.009316287976812795, 'mean_word_length': 1.3678921568627451, 'pattern_counts': {'":': 0, '<': 140, '<?xml version=': 0, '>': 174, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 22, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4403593', 'n_tokens_mistral': 5554, 'n_tokens_neox': 5311, 'n_words': 1350}