module HpcDraft (draft_plugin) where

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

import HpcFlags

import qualified Data.Set as Set
import qualified Data.Map as Map
import HpcUtils
import Data.Tree

------------------------------------------------------------------------------
draft_options :: FlagOptSeq
draft_options
        = excludeOpt
        . includeOpt
        . srcDirOpt
        . hpcDirOpt
        . resetHpcDirsOpt
        . outputOpt
        . verbosityOpt

draft_plugin :: Plugin
draft_plugin = Plugin { name = "draft"
                       , usage = "[OPTION] .. <TIX_FILE>"
                       , options = draft_options
                       , summary = "Generate draft overlay that provides 100% coverage"
                       , implementation = draft_main
                       , init_flags = default_flags
                       , final_flags = default_final_flags
                       }

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

draft_main :: Flags -> [String] -> IO ()
draft_main _        []              = error "draft_main: unhandled case: []"
draft_main hpcflags (progName:mods) = do
  let hpcflags1 = hpcflags
                { includeMods = Set.fromList mods
                                   `Set.union`
                                includeMods hpcflags }
  let prog = getTixFileName $ progName
  tix <- readTix prog
  case tix of
    Just (Tix tickCounts) -> do
        outs <- sequence
                      [ makeDraft hpcflags1 tixModule
                      | tixModule@(TixModule m _ _ _) <- tickCounts
                      , allowModule hpcflags1 m
                      ]
        case outputFile hpcflags1 of
         "-" -> putStrLn (unlines outs)
         out -> writeFile out (unlines outs)
    Nothing -> hpcError draft_plugin $ "unable to find tix file for:" ++ progName

makeDraft :: Flags -> TixModule -> IO String
makeDraft hpcflags tix = do
  let modu = tixModuleName tix
      tixs = tixModuleTixs tix

  (Mix filepath _ _ _ entries) <- readMixWithFlags hpcflags (Right tix)

  let forest = createMixEntryDom
              [ (srcspan,(box,v > 0))
              | ((srcspan,box),v) <- zip entries tixs
              ]

--  let show' (span,stuff) = show (span,stuff,grabHpcPos hsMap span)
--  putStrLn $ drawForest $ map (fmap show) $ forest

  let non_ticked = findNotTickedFromList forest

  hs  <- readFileFromPath (hpcError draft_plugin) filepath (srcDirs hpcflags)

  let hsMap :: Map.Map Int String
      hsMap = Map.fromList (zip [1..] $ lines hs)

  let quoteString = show

  let firstLine pos = case fromHpcPos pos of
                        (ln,_,_,_) -> ln

  let showPleaseTick :: Int -> PleaseTick -> String
      showPleaseTick d (TickFun str pos) =
                     spaces d ++ "tick function \"" ++ last str ++ "\" "
                              ++ "on line " ++ show (firstLine pos) ++ ";"
      showPleaseTick d (TickExp pos) =
                     spaces d ++ "tick "
                              ++ if '\n' `elem` txt
                                 then "at position " ++ show pos ++ ";"
                                 else quoteString txt ++ " "  ++ "on line " ++ show (firstLine pos) ++ ";"

          where
                  txt = grabHpcPos hsMap pos

      showPleaseTick d (TickInside [str] _ pleases) =
                     spaces d ++ "inside \"" ++ str ++ "\" {\n" ++
                     showPleaseTicks (d + 2) pleases ++
                     spaces d ++ "}"

      showPleaseTick _ (TickInside _ _ _)
          = error "showPleaseTick: Unhandled case TickInside"

      showPleaseTicks d pleases = unlines (map (showPleaseTick d) pleases)

      spaces d = take d (repeat ' ')

  return $ "module " ++ show (fixPackageSuffix modu) ++ " {\n" ++
         showPleaseTicks 2 non_ticked ++ "}"

fixPackageSuffix :: String -> String
fixPackageSuffix modu = case span (/= '/') modu of
                        (before,'/':after) -> before ++ ":" ++ after
                        _                  -> modu

data PleaseTick
   = TickFun [String] HpcPos
   | TickExp HpcPos
   | TickInside [String] HpcPos [PleaseTick]
    deriving Show

mkTickInside :: [String] -> HpcPos -> [PleaseTick]
             -> [PleaseTick] -> [PleaseTick]
mkTickInside _ _ []        = id
mkTickInside nm pos inside = (TickInside nm pos inside :)

findNotTickedFromTree :: MixEntryDom [(BoxLabel,Bool)] -> [PleaseTick]
findNotTickedFromTree (Node (pos,(ExpBox {},False):_) _) = [TickExp pos]
findNotTickedFromTree (Node (pos,(TopLevelBox nm,False):_) _)
  = [ TickFun nm pos ]
findNotTickedFromTree (Node (pos,(LocalBox nm,False):_) _)
  = [ TickFun nm pos ]
findNotTickedFromTree (Node (pos,(TopLevelBox nm,True):_) children)
  = mkTickInside nm pos (findNotTickedFromList children) []
findNotTickedFromTree (Node (pos,_:others) children) =
                      findNotTickedFromTree (Node (pos,others) children)
findNotTickedFromTree (Node (_, []) children) = findNotTickedFromList children

findNotTickedFromList :: [MixEntryDom [(BoxLabel,Bool)]] -> [PleaseTick]
findNotTickedFromList = concatMap findNotTickedFromTree


-- (c) 2007 Andy Gill

module HpcFlags where

import System.Console.GetOpt
import qualified Data.Set as Set
import Data.Char
import Trace.Hpc.Tix
import Trace.Hpc.Mix
import System.Exit
import System.FilePath

data Flags = Flags
  { outputFile          :: String
  , includeMods         :: Set.Set String
  , excludeMods         :: Set.Set String
  , hpcDirs             :: [String]
  , srcDirs             :: [String]
  , destDir             :: String

  , perModule           :: Bool
  , decList             :: Bool
  , xmlOutput           :: Bool

  , funTotals           :: Bool
  , altHighlight        :: Bool

  , combineFun          :: CombineFun   -- tick-wise combine
  , postFun             :: PostFun      --
  , mergeModule         :: MergeFun     -- module-wise merge

  , verbosity           :: Verbosity
  }

default_flags :: Flags
default_flags = Flags
  { outputFile          = "-"
  , includeMods         = Set.empty
  , excludeMods         = Set.empty
  , hpcDirs             = [".hpc"]
  , srcDirs             = []
  , destDir             = "."

  , perModule           = False
  , decList             = False
  , xmlOutput           = False

  , funTotals           = False
  , altHighlight        = False

  , combineFun          = ADD
  , postFun             = ID
  , mergeModule         = INTERSECTION

  , verbosity           = Normal
  }

data Verbosity = Silent | Normal | Verbose
  deriving (Eq, Ord)

verbosityFromString :: String -> Verbosity
verbosityFromString "0" = Silent
verbosityFromString "1" = Normal
verbosityFromString "2" = Verbose
verbosityFromString v   = error $ "unknown verbosity: " ++ v

-- We do this after reading flags, because the defaults
-- depends on if specific flags we used.

default_final_flags :: Flags -> Flags
default_final_flags flags = flags
  { srcDirs = if null (srcDirs flags)
              then ["."]
              else srcDirs flags
  }

type FlagOptSeq = [OptDescr (Flags -> Flags)] -> [OptDescr (Flags -> Flags)]

noArg :: String -> String -> (Flags -> Flags) -> FlagOptSeq
noArg flag detail fn = (:) $ Option [] [flag] (NoArg $ fn) detail

anArg :: String -> String -> String -> (String -> Flags -> Flags) -> FlagOptSeq
anArg flag detail argtype fn = (:) $ Option [] [flag] (ReqArg fn argtype) detail

infoArg :: String -> FlagOptSeq
infoArg info = (:) $ Option [] [] (NoArg $ id) info

excludeOpt, includeOpt, hpcDirOpt, resetHpcDirsOpt, srcDirOpt,
    destDirOpt, outputOpt, verbosityOpt,
    perModuleOpt, decListOpt, xmlOutputOpt, funTotalsOpt,
    altHighlightOpt, combineFunOpt, combineFunOptInfo, mapFunOpt,
    mapFunOptInfo, unionModuleOpt :: FlagOptSeq
excludeOpt      = anArg "exclude"    "exclude MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"
                $ \ a f -> f { excludeMods = a `Set.insert` excludeMods f }

includeOpt      = anArg "include"    "include MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"
                $ \ a f -> f { includeMods = a `Set.insert` includeMods f }

hpcDirOpt       = anArg "hpcdir"     "append sub-directory that contains .mix files" "DIR"
                   (\ a f -> f { hpcDirs = hpcDirs f ++ [a] })
                .  infoArg "default .hpc [rarely used]"

resetHpcDirsOpt = noArg "reset-hpcdirs" "empty the list of hpcdir's"
                   (\ f -> f { hpcDirs = [] })
                .  infoArg "[rarely used]"

srcDirOpt       = anArg "srcdir"     "path to source directory of .hs files" "DIR"
                  (\ a f -> f { srcDirs = srcDirs f ++ [a] })
                . infoArg "multi-use of srcdir possible"

destDirOpt      = anArg "destdir"   "path to write output to" "DIR"
                $ \ a f -> f { destDir = a }

outputOpt     = anArg "output"    "output FILE" "FILE"        $ \ a f -> f { outputFile = a }

verbosityOpt  = anArg "verbosity" "verbosity level, 0-2" "[0-2]"
                (\ a f -> f { verbosity  = verbosityFromString a })
              . infoArg "default 1"

-- markup

perModuleOpt  = noArg "per-module" "show module level detail" $ \ f -> f { perModule = True }
decListOpt    = noArg "decl-list"  "show unused decls"        $ \ f -> f { decList = True }
xmlOutputOpt  = noArg "xml-output" "show output in XML"       $ \ f -> f { xmlOutput = True }
funTotalsOpt  = noArg "fun-entry-count" "show top-level function entry counts"
                                                              $ \ f -> f { funTotals = True }
altHighlightOpt
              = noArg "highlight-covered" "highlight covered code, rather that code gaps"
                                                              $ \ f -> f { altHighlight = True }

combineFunOpt = anArg "function"
                      "combine .tix files with join function, default = ADD" "FUNCTION"
              $ \ a f -> case reads (map toUpper a) of
                          [(c,"")] -> f { combineFun = c }
                          _ -> error $ "no such combine function : " ++ a
combineFunOptInfo = infoArg
                  $ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst foldFuns)

mapFunOpt = anArg "function"
                      "apply function to .tix files, default = ID" "FUNCTION"
              $ \ a f -> case reads (map toUpper a) of
                          [(c,"")] -> f { postFun = c }
                          _ -> error $ "no such combine function : " ++ a
mapFunOptInfo = infoArg
                  $ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst postFuns)

unionModuleOpt = noArg "union"
                      "use the union of the module namespace (default is intersection)"
              $ \ f -> f { mergeModule = UNION }

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

readMixWithFlags :: Flags -> Either String TixModule -> IO Mix
readMixWithFlags flags modu = readMix [ dir </> hpcDir
                                      | dir <- srcDirs flags
                                      , hpcDir <- hpcDirs flags
                                      ] modu

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

command_usage :: Plugin -> IO ()
command_usage plugin =
  putStrLn $
                                       "Usage: hpc " ++ (name plugin) ++ " " ++
                                        (usage plugin) ++
                                        "\n" ++ summary plugin ++ "\n" ++
                                        if null (options plugin [])
                                        then ""
                                        else usageInfo "\n\nOptions:\n" (options plugin [])

hpcError :: Plugin -> String -> IO a
hpcError plugin msg = do
   putStrLn $ "Error: " ++ msg
   command_usage plugin
   exitFailure

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

data Plugin = Plugin { name           :: String
                     , usage          :: String
                     , options        :: FlagOptSeq
                     , summary        :: String
                     , implementation :: Flags -> [String] -> IO ()
                     , init_flags     :: Flags
                     , final_flags    :: Flags -> Flags
                     }

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

-- filterModules takes a list of candidate modules,
-- and
--  * excludes the excluded modules
--  * includes the rest if there are no explicitly included modules
--  * otherwise, accepts just the included modules.

allowModule :: Flags -> String -> Bool
allowModule flags full_mod
      | full_mod' `Set.member` excludeMods flags = False
      | pkg_name  `Set.member` excludeMods flags = False
      | mod_name  `Set.member` excludeMods flags = False
      | Set.null (includeMods flags)             = True
      | full_mod' `Set.member` includeMods flags = True
      | pkg_name  `Set.member` includeMods flags = True
      | mod_name  `Set.member` includeMods flags = True
      | otherwise                                = False
  where
          full_mod' = pkg_name ++ mod_name
      -- pkg name always ends with '/', main
          (pkg_name,mod_name) =
                        case span (/= '/') full_mod of
                     (p,'/':m) -> (p ++ ":",m)
                     (m,[])    -> (":",m)
                     _         -> error "impossible case in allowModule"

filterTix :: Flags -> Tix -> Tix
filterTix flags (Tix tixs) =
     Tix $ filter (allowModule flags . tixModuleName) tixs

------------------------------------------------------------------------------
-- HpcCombine specifics

data CombineFun = ADD | DIFF | SUB
     deriving (Eq,Show, Read, Enum)

theCombineFun :: CombineFun -> Integer -> Integer -> Integer
theCombineFun fn = case fn of
            ADD  -> \ l r -> l + r
            SUB  -> \ l r -> max 0 (l - r)
            DIFF -> \ g b -> if g > 0 then 0 else min 1 b

foldFuns :: [ (String,CombineFun) ]
foldFuns = [ (show comb,comb)
           | comb <- [ADD .. SUB]
           ]

data PostFun = ID | INV | ZERO
     deriving (Eq,Show, Read, Enum)

thePostFun :: PostFun -> Integer -> Integer
thePostFun ID   x = x
thePostFun INV  0 = 1
thePostFun INV  _ = 0
thePostFun ZERO _ = 0

postFuns :: [(String, PostFun)]
postFuns = [ (show pos,pos)
             | pos <- [ID .. ZERO]
           ]

data MergeFun = INTERSECTION | UNION
     deriving (Eq,Show, Read, Enum)

theMergeFun :: (Ord a) => MergeFun -> Set.Set a -> Set.Set a -> Set.Set a
theMergeFun INTERSECTION = Set.intersection
theMergeFun UNION        = Set.union

mergeFuns :: [(String, MergeFun)]
mergeFuns = [ (show pos,pos)
             | pos <- [INTERSECTION,UNION]
           ]


module HpcLexer where

import Data.Char

data Token
        = ID String
        | SYM Char
        | INT Int
        | STR String
        | CAT String
        deriving (Eq,Show)

initLexer :: String -> [Token]
initLexer str = [ t | (_,_,t) <- lexer str 1 1 ]

lexer :: String -> Int -> Int ->  [(Int,Int,Token)]
lexer (c:cs) line column
  | c == '\n' = lexer cs (succ line) 1
  | c == '\"' = lexerSTR cs line (succ column)
  | c == '[' = lexerCAT cs "" line (succ column)
  | c `elem` "{};-:"
              = (line,column,SYM c) : lexer cs line (succ column)
  | isSpace c = lexer cs        line (succ column)
  | isAlpha c = lexerKW  cs [c] line (succ column)
  | isDigit c = lexerINT cs [c] line (succ column)
  | otherwise = error "lexer failure"
lexer [] _ _ = []

lexerKW :: String -> String -> Int -> Int -> [(Int,Int,Token)]
lexerKW  (c:cs) s line column
  | isAlpha c = lexerKW cs (s ++ [c]) line (succ column)
lexerKW  other s line column = (line,column,ID s) : lexer other line column

lexerINT :: String -> String -> Int -> Int -> [(Int,Int,Token)]
lexerINT  (c:cs) s line column
  | isDigit c = lexerINT cs (s ++ [c]) line (succ column)
lexerINT  other s line column = (line,column,INT (read s)) : lexer other line column

-- not technically correct for the new column count, but a good approximation.
lexerSTR :: String -> Int -> Int -> [(Int,Int,Token)]
lexerSTR cs line column
  = case lex ('"' : cs) of
      [(str,rest)] -> (line,succ column,STR (read str))
                   : lexer rest line (length (show str) + column + 1)
      _ -> error "bad string"

lexerCAT :: String -> String -> Int -> Int -> [(Int,Int,Token)]
lexerCAT (c:cs) s line column
  | c == ']'  =  (line,column,CAT s) : lexer cs line (succ column)
  | otherwise = lexerCAT cs (s ++ [c]) line (succ column)
lexerCAT  [] _ _ _ = error "lexer failure in CAT"

test :: IO ()
test = do
          t <- readFile "EXAMPLE.tc"
          print (initLexer t)


---------------------------------------------------------
-- The main program for the hpc-markup tool, part of HPC.
-- Andy Gill and Colin Runciman, 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.FilePath
import System.IO (localeEncoding)
import Data.List
import Data.Maybe(fromJust)
import Data.Semigroup as Semi
import Data.Array
import Control.Monad
import qualified Data.Set as Set

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

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

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

        unless (verbosity flags < Normal) $
            putStrLn $ "Writing: " ++ (filename <.> "html")

        writeFileUsing (dest_dir </> filename <.> "html") $
            "" ++
            "" ++
            charEncodingTag ++
            "\n" ++
            "" ++
            "" ++
            "
\n" ++
            "
" ++
            "module	" ++
            "Top Level Definitions	" ++
            "Alternatives	" ++
            "Expressions	" ++
            "
" ++
            "
" ++
            "%	" ++
            "covered / total	" ++
            "%	" ++
            "covered / total	" ++
            "%	" ++
            "covered / total	" ++
            "
" ++
            concat [ showModuleSummary (modName,fileName,modSummary)
                   | (modName,fileName,modSummary) <- mods'
                   ] ++
            "

" ++
            showTotalSummary (mconcat
                                 [ modSummary
                                 | (_,_,modSummary) <- mods'
                                 ])
                   ++ "
\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 ++ "\">"

-- 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

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 addLine n xs = "" ++ padLeft 5 ' ' (show n) ++ " " ++ xs
  let addLines = unlines . map (uncurry addLine) . zip [1 :: Int ..] . lines
  let fileName = modName0 <.> "hs" <.> "html"
  unless (verbosity flags < Normal) $
            putStrLn $ "Writing: " ++ fileName
  writeFileUsing (dest_dir </> fileName) $
            unlines ["",
                     "",
                     charEncodingTag,
                     "",
                     "",
                     "",
                     "
",
                     concat [
                         "",
                         "never executed ",
                         "always true ",
                         "always false"],
                     "
",
                     "
"] ++ addLines content' ++ "\n
\n\n\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
     deriving (Eq,Show)

markup    :: Int                -- ^tabStop
          -> [(HpcPos,Markup)]  -- random list of tick location pairs
          -> String             -- text to mark up
          -> String
markup tabStop mix str = addMarkup tabStop str (Loc 1 1) [] sortedTickLocs
  where
    tickLocs = [ (Loc ln1 c1,Loc ln2 c2,mark)
               | (pos,mark) <- mix
               , let (ln1,c1,ln2,c2) = fromHpcPos pos
               ]
    sortedTickLocs = sortBy (\(locA1,locZ1,_) (locA2,locZ2,_) ->
                              (locA1,locZ2) `compare` (locA2,locZ1)) tickLocs

addMarkup :: Int                -- tabStop
          -> String             -- text to mark up
          -> Loc                -- current location
          -> [(Loc,Markup)]     -- stack of open ticks, with closing location
          -> [(Loc,Loc,Markup)] -- sorted list of tick location pairs
          -> String

-- check the pre-condition.
--addMarkup tabStop cs loc os ticks
--   | not (isSorted (map fst os)) = error $ "addMarkup: bad closing ordering: " ++ show os

--addMarkup tabStop cs loc os@(_:_) ticks
--   | trace (show (loc,os,take 10 ticks)) False = undefined

-- close all open ticks, if we have reached the end
addMarkup _ [] _loc os [] =
  concatMap (const closeTick) os
addMarkup tabStop cs loc ((o,_):os) ticks | loc > o =
  closeTick ++ addMarkup tabStop cs loc os ticks

--addMarkup tabStop cs loc os ((t1,t2,tik@(TopLevelDecl {})):ticks) | loc == t1 =
--   openTick tik ++ closeTick ++ addMarkup tabStop cs loc os ticks

addMarkup tabStop cs loc os ((t1,t2,tik0):ticks) | loc == t1 =
  case os of
  ((_,tik'):_)
    | not (allowNesting tik0 tik')
    -> addMarkup tabStop cs loc os ticks -- already marked or bool within marked bool
  _ -> openTick tik0 ++ addMarkup tabStop cs loc (addTo (t2,tik0) os) ticks
 where

  addTo (t,tik) []             = [(t,tik)]
  addTo (t,tik) ((t',tik'):xs) | t <= t'   = (t,tik):(t',tik'):xs
                               | otherwise = (t',tik):(t',tik'):xs

addMarkup tabStop0 cs loc os ((t1,_t2,_tik):ticks) | loc > t1 =
          -- throw away this tick, because it is from a previous place ??
          addMarkup tabStop0 cs loc os ticks

addMarkup tabStop0 ('\n':cs) loc@(Loc ln col) os@((Loc ln2 col2,_):_) ticks
          | ln == ln2 && col < col2
          = addMarkup tabStop0 (' ':'\n':cs) loc os ticks
addMarkup tabStop0 (c0:cs) loc@(Loc _ p) os ticks =
  if c0=='\n' && os/=[] then
    concatMap (const closeTick) (downToTopLevel os) ++
    c0 : "" ++ expand 1 w ++ "" ++
    concatMap (openTick.snd) (reverse (downToTopLevel os)) ++
    addMarkup tabStop0 cs' loc' os ticks
  else if c0=='\t' then
    expand p "\t" ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks
  else
    escape c0 ++ addMarkup tabStop0 cs (incBy c0 loc) os ticks
  where
  (w,cs') = span (`elem` " \t") cs
  loc' = foldl (flip incBy) loc (c0:w)
  escape '>' = ">"
  escape '<' = "<"
  escape '"' = """
  escape '&' = "&"
  escape c  = [c]

  expand :: Int -> String -> String
  expand _ ""       = ""
  expand c ('\t':s) = replicate (c' - c) ' ' ++ expand c' s
    where
    c' = tabStopAfter 8 c
  expand c (' ':s)  = ' ' : expand (c+1) s
  expand _ _        = error "bad character in string for expansion"

  incBy :: Char -> Loc -> Loc
  incBy '\n' (Loc ln _c) = Loc (succ ln) 1
  incBy '\t' (Loc ln c) = Loc ln (tabStopAfter tabStop0 c)
  incBy _    (Loc ln c) = Loc ln (succ c)

  tabStopAfter :: Int -> Int -> Int
  tabStopAfter tabStop c = fromJust (find (>c) [1,(tabStop + 1)..])

addMarkup tabStop cs loc os ticks = "ERROR: " ++ show (take 10 cs,tabStop,loc,take 10 os,take 10 ticks)

openTick :: Markup -> String
openTick NotTicked       = ""
openTick IsTicked        = ""
openTick TickedOnlyTrue  = ""
openTick TickedOnlyFalse = ""
openTick (TopLevelDecl False _) = openTopDecl
openTick (TopLevelDecl True 0)
         = "-- never entered" ++
           openTopDecl
openTick (TopLevelDecl True 1)
         = "-- entered once" ++
           openTopDecl
openTick (TopLevelDecl True n0)
         = "-- entered " ++ showBigNum n0 ++ " times" ++ openTopDecl
  where showBigNum n | n <= 9999 = show n
                     | otherwise = case n `quotRem` 1000 of
                                     (q, r) -> showBigNum' q ++ "," ++ showWith r
        showBigNum' n | n <= 999 = show n
                      | otherwise = case n `quotRem` 1000 of
                                      (q, r) -> showBigNum' q ++ "," ++ showWith r
        showWith n = padLeft 3 '0' $ show n

closeTick :: String
closeTick = ""

openTopDecl :: String
openTopDecl = ""

downToTopLevel :: [(Loc,Markup)] -> [(Loc,Markup)]
downToTopLevel ((_,TopLevelDecl {}):_) = []
downToTopLevel (o : os)               = o : downToTopLevel os
downToTopLevel []                     = []

-- build in logic for nesting bin boxes

allowNesting :: Markup  -- innermost
            -> Markup   -- outermost
            -> Bool
allowNesting n m               | n == m = False -- no need to double nest
allowNesting IsTicked TickedOnlyFalse   = False
allowNesting IsTicked TickedOnlyTrue    = False
allowNesting _ _                        = True

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

data ModuleSummary = ModuleSummary
     { expTicked :: !Int
     , expTotal  :: !Int
     , topFunTicked :: !Int
     , topFunTotal  :: !Int
     , altTicked :: !Int
     , altTotal  :: !Int
     }
     deriving (Show)

showModuleSummary :: (String, String, ModuleSummary) -> String
showModuleSummary (modName,fileName,modSummary) =
  "
\n" ++
  "  <tt>module "
                              ++ modName ++ "</tt>	\n" ++
   showSummary (topFunTicked modSummary) (topFunTotal modSummary) ++
   showSummary (altTicked modSummary) (altTotal modSummary) ++
   showSummary (expTicked modSummary) (expTotal modSummary) ++
  "
\n"

showTotalSummary :: ModuleSummary -> String
showTotalSummary modSummary =
  "
\n" ++
  "  Program Coverage Total</tt>	\n" ++
   showSummary (topFunTicked modSummary) (topFunTotal modSummary) ++
   showSummary (altTicked modSummary) (altTotal modSummary) ++
   showSummary (expTicked modSummary) (expTotal modSummary) ++
  "
\n"

showSummary :: (Integral t, Show t) => t -> t -> String
showSummary ticked total =
                "" ++ showP (percent ticked total) ++ "	" ++
                "" ++ show ticked ++ "/" ++ show total ++ "	" ++
                "" ++
                    (case percent ticked total of
                       Nothing -> " "
                       Just w -> bar w "bar"
                     )  ++ "	"
     where
        showP Nothing = "- "
        showP (Just x) = show x ++ "%"
        bar 0 _     = bar 100 "invbar"
        bar w inner = "
" ++
                         "

" ++
                              "

" ++
                              "

"

percent :: (Integral a) => a -> a -> Maybe a
percent ticked total = if total == 0 then Nothing else Just (ticked * 100 `div` total)

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 = (<>)

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

writeFileUsing :: String -> String -> IO ()
writeFileUsing filename text = do
-- We need to check for the dest_dir each time, because we use sub-dirs for
-- packages, and a single .tix file might contain information about
-- many package.

  -- create the dest_dir if needed
  createDirectoryIfMissing True (takeDirectory filename)

  writeFile filename text

------------------------------------------------------------------------------
-- global color pallete

red,green,yellow :: String
red    = "#f20913"
green  = "#60de51"
yellow = "yellow"


module HpcOverlay where

import HpcFlags
import HpcParser
import HpcUtils
import Trace.Hpc.Tix
import Trace.Hpc.Mix
import Trace.Hpc.Util
import qualified Data.Map as Map
import Data.Tree

overlay_options :: FlagOptSeq
overlay_options
        = srcDirOpt
        . hpcDirOpt
        . resetHpcDirsOpt
        . outputOpt
        . verbosityOpt

overlay_plugin :: Plugin
overlay_plugin = Plugin { name = "overlay"
                       , usage = "[OPTION] .. <OVERLAY_FILE> [<OVERLAY_FILE> [...]]"
                       , options = overlay_options
                       , summary = "Generate a .tix file from an overlay file"
                       , implementation = overlay_main
                       , init_flags = default_flags
                       , final_flags = default_final_flags
                       }

overlay_main :: Flags -> [String] -> IO ()
overlay_main _     [] = hpcError overlay_plugin $ "no overlay file specified"
overlay_main flags files = do
  specs <- mapM hpcParser files
  let (Spec globals modules) = concatSpec specs

  let modules1 = Map.fromListWith (++) [ (m,info) | (m,info) <- modules ]

  mod_info <-
     sequence [ do mix@(Mix origFile _ _ _ _) <- readMixWithFlags flags (Left modu)
                   content <- readFileFromPath (hpcError overlay_plugin) origFile (srcDirs flags)
                   processModule modu content mix mod_spec globals
              | (modu, mod_spec) <- Map.toList modules1
              ]

  let tix = Tix $ mod_info

  case outputFile flags of
    "-" -> putStrLn (show tix)
    out -> writeFile out (show tix)

processModule :: String         -- ^ module name
              -> String         -- ^ module contents
              -> Mix            -- ^ mix entry for this module
              -> [Tick]         -- ^ local ticks
              -> [ExprTick]     -- ^ global ticks
              -> IO TixModule
processModule modName modContents (Mix _ _ hash _ entries) locals globals = do

   let hsMap :: Map.Map Int String
       hsMap = Map.fromList (zip [1..] $ lines modContents)

   let topLevelFunctions =
        Map.fromListWith (++)
                     [ (nm,[pos])
                     | (pos,TopLevelBox [nm]) <- entries
                     ]

   let inside :: HpcPos -> String -> Bool
       inside pos nm =
                       case Map.lookup nm topLevelFunctions of
                         Nothing -> False
                         Just poss -> any (pos `insideHpcPos`) poss

   -- TODO: rename plzTick => plzExprTick, plzTopPick => plzTick
   let plzTick :: HpcPos -> BoxLabel -> ExprTick -> Bool
       plzTick pos (ExpBox _) (TickExpression _ match q _)  =
                     qualifier pos q
                  && case match of
                        Nothing -> True
                        Just str -> str == grabHpcPos hsMap pos
       plzTick _   _       _ = False

       plzTopTick :: HpcPos -> BoxLabel -> Tick -> Bool
       plzTopTick pos label  (ExprTick ignore)           = plzTick pos label ignore
       plzTopTick pos _      (TickFunction fn q _)   =
                    qualifier pos q && pos `inside` fn
       plzTopTick pos label  (InsideFunction fn igs)   =
         pos `inside` fn && any (plzTopTick pos label) igs

   let tixs = Map.fromList
              [ (ix,
                   any (plzTick pos label) globals
                || any (plzTopTick pos label) locals)
              | (ix,(pos,label)) <- zip [0..] entries
              ]

   -- let show' (srcspan,stuff) = show (srcspan,stuff,grabHpcPos hsMap span)

   let forest = createMixEntryDom
              [ (srcspan,ix)
              | ((srcspan,_),ix) <- zip entries [0..]
              ]

   --
   let forest2 = addParentToList [] $ forest
--   putStrLn $ drawForest $ map (fmap show') $ forest2

   let isDomList = Map.fromList
              [ (ix,filter (/= ix) rng ++ dom)
              | (_,(rng,dom)) <- concatMap flatten forest2
              , ix <- rng
              ]

   -- We do not use laziness here, because the dominator lists
   -- point to their equivent peers, creating loops.

   let isTicked n =
           case Map.lookup n tixs of
             Just v -> v
             Nothing -> error $ "can not find ix # " ++ show n

   let tixs' = [ case Map.lookup n isDomList of
                   Just vs -> if any isTicked (n : vs) then 1 else 0
                   Nothing -> error $ "can not find ix in dom list # " ++ show n
               | n <- [0..(length entries - 1)]
               ]

   return $ TixModule modName hash (length tixs') tixs'

qualifier :: HpcPos -> Maybe Qualifier -> Bool
qualifier _   Nothing = True
qualifier pos (Just (OnLine n)) = n == l1 && n == l2
  where (l1,_,l2,_) = fromHpcPos pos
qualifier pos (Just (AtPosition l1' c1' l2' c2'))
          = (l1', c1', l2', c2') == fromHpcPos pos

concatSpec :: [Spec] -> Spec
concatSpec = foldr
               (\ (Spec pre1 body1) (Spec pre2 body2)
                     -> Spec (pre1 ++ pre2) (body1 ++ body2))
                (Spec [] [])

addParentToTree :: [a] -> MixEntryDom [a] -> MixEntryDom ([a],[a])
addParentToTree path (Node (pos,a) children) =
                Node (pos,(a,path)) (addParentToList (a ++ path) children)

addParentToList :: [a] -> [MixEntryDom [a]] -> [MixEntryDom ([a],[a])]
addParentToList path nodes = map (addParentToTree path) nodes


---------------------------------------------------------
-- The main program for the hpc-report tool, part of HPC.
-- Colin Runciman and Andy Gill, June 2006
---------------------------------------------------------

module HpcReport (report_plugin) where

import Prelude hiding (exp)
import Data.List(sort,intersperse,sortBy)
import HpcFlags
import Trace.Hpc.Mix
import Trace.Hpc.Tix
import Control.Monad hiding (guard)
import qualified Data.Set as Set

notExpecting :: String -> a
notExpecting s = error ("not expecting "++s)

data BoxTixCounts = BT {boxCount, tixCount :: !Int}

btZero :: BoxTixCounts
btZero = BT {boxCount=0, tixCount=0}

btPlus :: BoxTixCounts -> BoxTixCounts -> BoxTixCounts
btPlus (BT b1 t1) (BT b2 t2) = BT (b1+b2) (t1+t2)

btPercentage :: String -> BoxTixCounts -> String
btPercentage s (BT b t) = showPercentage s t b

showPercentage :: String -> Int -> Int -> String
showPercentage s 0 0 = "100% "++s++" (0/0)"
showPercentage s n d = showWidth 3 p++"% "++
                       s++
                       " ("++show n++"/"++show d++")"
  where
  p = (n*100) `div` d
  showWidth w x0 = replicate (shortOf w (length sx)) ' ' ++ sx
                  where
                  sx = show x0
                  shortOf x y = if y < x then x-y else 0

data BinBoxTixCounts = BBT { binBoxCount
                           , onlyTrueTixCount
                           , onlyFalseTixCount
                           , bothTixCount :: !Int}

bbtzero :: BinBoxTixCounts
bbtzero = BBT { binBoxCount=0
              , onlyTrueTixCount=0
              , onlyFalseTixCount=0
              , bothTixCount=0}

bbtPlus :: BinBoxTixCounts -> BinBoxTixCounts -> BinBoxTixCounts
bbtPlus (BBT b1 tt1 ft1 bt1) (BBT b2 tt2 ft2 bt2) =
  BBT (b1+b2) (tt1+tt2) (ft1+ft2) (bt1+bt2)

bbtPercentage :: String -> Bool -> BinBoxTixCounts -> String
bbtPercentage s withdetail (BBT b tt ft bt) =
  showPercentage s bt b ++
  if withdetail && bt/=b then
    detailFor tt "always True"++
    detailFor ft "always False"++
    detailFor (b-(tt+ft+bt)) "unevaluated"
  else ""
  where
  detailFor n txt = if n>0 then ", "++show n++" "++txt
                    else ""

data ModInfo = MI { exp,alt,top,loc :: !BoxTixCounts
                  , guard,cond,qual :: !BinBoxTixCounts
                  , decPaths :: [[String]]}

miZero :: ModInfo
miZero = MI { exp=btZero
            , alt=btZero
            , top=btZero
            , loc=btZero
            , guard=bbtzero
            , cond=bbtzero
            , qual=bbtzero
            , decPaths = []}

miPlus :: ModInfo -> ModInfo -> ModInfo
miPlus mi1 mi2 =
  MI { exp = exp mi1 `btPlus` exp mi2
     , alt = alt mi1 `btPlus` alt mi2
     , top = top mi1 `btPlus` top mi2
     , loc = loc mi1 `btPlus` loc mi2
     , guard = guard mi1 `bbtPlus` guard mi2
     , cond  = cond  mi1 `bbtPlus` cond  mi2
     , qual  = qual  mi1 `bbtPlus` qual  mi2
     , decPaths = decPaths mi1 ++ decPaths mi2 }

allBinCounts :: ModInfo -> BinBoxTixCounts
allBinCounts mi =
  BBT { binBoxCount = sumAll binBoxCount
      , onlyTrueTixCount = sumAll onlyTrueTixCount
      , onlyFalseTixCount = sumAll onlyFalseTixCount
      , bothTixCount = sumAll bothTixCount }
  where
  sumAll f = f (guard mi) + f (cond mi) + f (qual mi)

accumCounts :: [(BoxLabel,Integer)] -> ModInfo -> ModInfo
accumCounts [] mi = mi
accumCounts ((bl,btc):etc) mi
 | single bl = accumCounts etc mi'
  where
  mi' = case bl of
        ExpBox False ->   mi{exp = inc (exp mi)}
        ExpBox True  ->   mi{exp = inc (exp mi), alt = inc (alt mi)}
        TopLevelBox dp -> mi{top = inc (top mi)
                            ,decPaths = upd dp (decPaths mi)}
        LocalBox dp ->    mi{loc = inc (loc mi)
                            ,decPaths = upd dp (decPaths mi)}
        _other ->          notExpecting "BoxLabel in accumcounts"
  inc (BT {boxCount=bc,tixCount=tc}) =
    BT { boxCount = bc+1
       , tixCount = tc + bit (btc>0) }
  upd dp dps =
    if btc>0 then dps else dp:dps
accumCounts [_] _ = error "accumCounts: Unhandled case: [_] _"
accumCounts ((bl0,btc0):(bl1,btc1):etc) mi =
  accumCounts etc mi'
  where
  mi' = case (bl0,bl1) of
        (BinBox GuardBinBox True, BinBox GuardBinBox False) ->
          mi{guard = inc (guard mi)}
        (BinBox CondBinBox True, BinBox CondBinBox False) ->
          mi{cond = inc (cond mi)}
        (BinBox QualBinBox True, BinBox QualBinBox False) ->
          mi{qual = inc (qual mi)}
        _other -> notExpecting "BoxLabel pair in accumcounts"
  inc (BBT { binBoxCount=bbc
           , onlyTrueTixCount=ttc
           , onlyFalseTixCount=ftc
           , bothTixCount=btc}) =
    BBT { binBoxCount       = bbc+1
        , onlyTrueTixCount  = ttc + bit (btc0 >0 && btc1==0)
        , onlyFalseTixCount = ftc + bit (btc0==0 && btc1 >0)
        , bothTixCount      = btc + bit (btc0 >0 && btc1 >0) }

bit :: Bool -> Int
bit True = 1
bit False = 0

single :: BoxLabel -> Bool
single (ExpBox {}) = True
single (TopLevelBox _) = True
single (LocalBox _) = True
single (BinBox {}) = False

modInfo :: Flags -> Bool -> TixModule -> IO ModInfo
modInfo hpcflags qualDecList tix@(TixModule moduleName _ _ tickCounts) = do
  Mix _ _ _ _ mes <- readMixWithFlags hpcflags (Right tix)
  return (q (accumCounts (zip (map snd mes) tickCounts) miZero))
  where
  q mi = if qualDecList then mi{decPaths = map (moduleName:) (decPaths mi)}
         else mi

modReport :: Flags -> TixModule -> IO ()
modReport hpcflags tix@(TixModule moduleName _ _ _) = do
  mi <- modInfo hpcflags False tix
  if xmlOutput hpcflags
    then putStrLn $ "  <module name = " ++ show moduleName  ++ ">"
    else putStrLn ("-----<module "++moduleName++">-----")
  printModInfo hpcflags mi
  if xmlOutput hpcflags
    then putStrLn $ "  </module>"
    else return ()

printModInfo :: Flags -> ModInfo -> IO ()
printModInfo hpcflags mi | xmlOutput hpcflags = do
  element "exprs" (xmlBT $ exp mi)
  element "booleans" (xmlBBT $ allBinCounts mi)
  element "guards" (xmlBBT $ guard mi)
  element "conditionals" (xmlBBT $ cond mi)
  element "qualifiers" (xmlBBT $ qual mi)
  element "alts" (xmlBT $ alt mi)
  element "local" (xmlBT $ loc mi)
  element "toplevel" (xmlBT $ top mi)
printModInfo hpcflags mi = do
  putStrLn (btPercentage "expressions used" (exp mi))
  putStrLn (bbtPercentage "boolean coverage" False (allBinCounts mi))
  putStrLn ("     "++bbtPercentage "guards" True (guard mi))
  putStrLn ("     "++bbtPercentage "'if' conditions" True (cond mi))
  putStrLn ("     "++bbtPercentage "qualifiers" True (qual mi))
  putStrLn (btPercentage "alternatives used" (alt mi))
  putStrLn (btPercentage "local declarations used" (loc mi))
  putStrLn (btPercentage "top-level declarations used" (top mi))
  modDecList hpcflags mi

modDecList :: Flags -> ModInfo -> IO ()
modDecList hpcflags mi0 =
  when (decList hpcflags && someDecsUnused mi0) $ do
    putStrLn "unused declarations:"
    mapM_ showDecPath (sort (decPaths mi0))
  where
  someDecsUnused mi = tixCount (top mi) < boxCount (top mi) ||
                      tixCount (loc mi) < boxCount (loc mi)
  showDecPath dp = putStrLn ("     "++
                             concat (intersperse "." dp))

report_plugin :: Plugin
report_plugin = Plugin { name = "report"
                       , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
                       , options = report_options
                       , summary = "Output textual report about program coverage"
                       , implementation = report_main
                       , init_flags = default_flags
                       , final_flags = default_final_flags
                       }

report_main :: Flags -> [String] -> IO ()
report_main hpcflags (progName:mods) = do
  let hpcflags1 = hpcflags
                { includeMods = Set.fromList mods
                                   `Set.union`
                                includeMods hpcflags }
  let prog = getTixFileName $ progName
  tix <- readTix prog
  case tix of
    Just (Tix tickCounts) ->
           makeReport hpcflags1 progName
                    $ sortBy (\ mod1 mod2 -> tixModuleName mod1 `compare` tixModuleName mod2)
                    $ [ tix'
                      | tix'@(TixModule m _ _ _) <- tickCounts
                      , allowModule hpcflags1 m
                      ]
    Nothing -> hpcError report_plugin  $ "unable to find tix file for:" ++ progName
report_main _ [] =
        hpcError report_plugin $ "no .tix file or executable name specified"

makeReport :: Flags -> String -> [TixModule] -> IO ()
makeReport hpcflags progName modTcs | xmlOutput hpcflags = do
  putStrLn $ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
  putStrLn $ "<coverage name=" ++ show progName ++ ">"
  if perModule hpcflags
    then mapM_ (modReport hpcflags) modTcs
    else return ()
  mis <- mapM (modInfo hpcflags True) modTcs
  putStrLn $ "  <summary>"
  printModInfo hpcflags (foldr miPlus miZero mis)
  putStrLn $ "  </summary>"
  putStrLn $ "</coverage>"
makeReport hpcflags _ modTcs =
  if perModule hpcflags then
    mapM_ (modReport hpcflags) modTcs
  else do
    mis <- mapM (modInfo hpcflags True) modTcs
    printModInfo hpcflags (foldr miPlus miZero mis)

element :: String -> [(String,String)] -> IO ()
element tag attrs = putStrLn $
                    "    <" ++ tag ++ " "
                        ++ unwords [ x ++ "=" ++ show y
                                   | (x,y) <- attrs
                                   ] ++ "/>"

xmlBT :: BoxTixCounts -> [(String, String)]
xmlBT (BT b t) = [("boxes",show b),("count",show t)]

xmlBBT :: BinBoxTixCounts -> [(String, String)]
xmlBBT (BBT b tt tf bt) = [("boxes",show b),("true",show tt),("false",show tf),("count",show (tt + tf + bt))]

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

report_options :: FlagOptSeq
report_options
        = perModuleOpt
        . decListOpt
        . excludeOpt
        . includeOpt
        . srcDirOpt
        . hpcDirOpt
        . resetHpcDirsOpt
        . xmlOutputOpt
        . verbosityOpt


module HpcShowTix (showtix_plugin) where

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

import HpcFlags

import qualified Data.Set as Set

showtix_options :: FlagOptSeq
showtix_options
        = excludeOpt
        . includeOpt
        . srcDirOpt
        . hpcDirOpt
        . resetHpcDirsOpt
        . outputOpt
        . verbosityOpt

showtix_plugin :: Plugin
showtix_plugin = Plugin { name = "show"
                       , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
                       , options = showtix_options
                       , summary = "Show .tix file in readable, verbose format"
                       , implementation = showtix_main
                       , init_flags = default_flags
                       , final_flags = default_final_flags
                       }

showtix_main :: Flags -> [String] -> IO ()
showtix_main _     [] = hpcError showtix_plugin $ "no .tix file or executable name specified"
showtix_main flags (prog:modNames) = do
  let hpcflags1 = flags
                { includeMods = Set.fromList modNames
                                   `Set.union`
                                includeMods flags }

  optTixs <- readTix (getTixFileName prog)
  case optTixs of
    Nothing -> hpcError showtix_plugin $ "could not read .tix file : "  ++ prog
    Just (Tix tixs) -> do
       tixs_mixs <- sequence
               [ do mix <- readMixWithFlags hpcflags1 (Right tix)
                    return $ (tix,mix)
               | tix <- tixs
               , allowModule hpcflags1 (tixModuleName tix)
               ]

       let rjust n str = take (n - length str) (repeat ' ') ++ str
       let ljust n str = str ++ take (n - length str) (repeat ' ')

       sequence_ [ sequence_ [ putStrLn (rjust 5 (show ix) ++ " " ++
                                         rjust 10 (show count) ++ " " ++
                                         ljust 20  modName ++ " " ++ rjust 20 (show pos) ++ " " ++ show lab)
                             | (count,ix,(pos,lab)) <- zip3 tixs' [(0::Int)..] entries
                             ]
                 | ( TixModule modName _hash1 _ tixs'
                   , Mix _file _timestamp _hash2 _tab entries
                   ) <- tixs_mixs
                 ]

       return ()


module HpcUtils where

import Trace.Hpc.Util
import qualified Data.Map as Map
import System.FilePath

dropWhileEndLE :: (a -> Bool) -> [a] -> [a]
-- Spec: dropWhileEndLE p = reverse . dropWhile p . reverse
dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) []

-- turns \n into ' '
-- | grab's the text behind a HpcPos;
grabHpcPos :: Map.Map Int String -> HpcPos -> String
grabHpcPos hsMap srcspan =
         case lns of
           [ln] -> (take ((c2 - c1) + 1) $ drop (c1 - 1) ln)
           _ -> let lns1 = drop (c1 -1) (head lns) : tail lns
                    lns2 = init lns1 ++ [take (c2 + 1) (last lns1) ]
                 in foldl1 (\ xs ys -> xs ++ "\n" ++ ys) lns2
  where (l1,c1,l2,c2) = fromHpcPos srcspan
        lns = map (\ n -> case Map.lookup n hsMap of
                           Just ln -> ln
                           Nothing -> error $ "bad line number : " ++ show n
                  ) [l1..l2]

readFileFromPath :: (String -> IO String) -> String -> [String] -> IO String
readFileFromPath _ filename@('/':_) _ = readFile filename
readFileFromPath err filename path0 = readTheFile path0
  where
        readTheFile [] = err $ "could not find " ++ show filename
                                 ++ " in path " ++ show path0
        readTheFile (dir:dirs) =
                catchIO (do str <- readFile (dir </> filename)
                            return str)
                        (\ _ -> readTheFile dirs)


-- (c) 2007 Andy Gill

-- Main driver for Hpc
import Data.Version
import System.Environment
import System.Exit
import System.Console.GetOpt

import HpcFlags
import HpcReport
import HpcMarkup
import HpcCombine
import HpcShowTix
import HpcDraft
import HpcOverlay
import Paths_hpc_bin

helpList :: IO ()
helpList =
     putStrLn $
           "Usage: hpc COMMAND ...\n\n" ++
           section "Commands" help ++
           section "Reporting Coverage" reporting ++
           section "Processing Coverage files" processing ++
           section "Coverage Overlays" overlays ++
           section "Others" other ++
           ""
  where
    help       = ["help"]
    reporting  = ["report","markup"]
    overlays   = ["overlay","draft"]
    processing = ["sum","combine","map"]
    other     = [ name hook
                | hook <- hooks
                , name hook `notElem`
                     (concat [help,reporting,processing,overlays])
                ]

section :: String -> [String] -> String
section _   []   = ""
section msg cmds = msg ++ ":\n"
        ++ unlines [ take 14 ("  " ++ cmd ++ repeat ' ') ++ summary hook
                   | cmd <- cmds
                   , hook <- hooks
                   , name hook == cmd
                   ]

dispatch :: [String] -> IO ()
dispatch [] = do
             helpList
             exitWith ExitSuccess
dispatch (txt:args0) = do
     case lookup txt hooks' of
       Just plugin -> parse plugin args0
       _ -> parse help_plugin (txt:args0)
  where
     parse plugin args =
              case getOpt Permute (options plugin []) args of
                (_,_,errs) | not (null errs)
                     -> do putStrLn "hpc failed:"
                           sequence_ [ putStr ("  " ++ err)
                                    | err <- errs
                                    ]
                           putStrLn $ "\n"
                           command_usage plugin
                           exitFailure
                (o,ns,_) -> do
                         let flags = final_flags plugin
                                   $ foldr (.) id o
                                   $ init_flags plugin
                         implementation plugin flags ns

main :: IO ()
main = do
 args <- getArgs
 dispatch args

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

hooks :: [Plugin]
hooks = [ help_plugin
        , report_plugin
        , markup_plugin
        , sum_plugin
        , combine_plugin
        , map_plugin
        , showtix_plugin
        , overlay_plugin
        , draft_plugin
        , version_plugin
        ]

hooks' :: [(String, Plugin)]
hooks' = [ (name hook,hook) | hook <- hooks ]

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

help_plugin :: Plugin
help_plugin = Plugin { name = "help"
                     , usage = "[<HPC_COMMAND>]"
                     , summary = "Display help for hpc or a single command"
                     , options = help_options
                     , implementation = help_main
                     , init_flags = default_flags
                     , final_flags = default_final_flags
                     }

help_main :: Flags -> [String] -> IO ()
help_main _ [] = do
            helpList
            exitWith ExitSuccess
help_main _ (sub_txt:_) = do
    case lookup sub_txt hooks' of
      Nothing -> do
          putStrLn $ "no such hpc command : " ++ sub_txt
          exitFailure
      Just plugin' -> do
          command_usage plugin'
          exitWith ExitSuccess

help_options :: FlagOptSeq
help_options   = id

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

version_plugin :: Plugin
version_plugin = Plugin { name = "version"
                        , usage = ""
                        , summary = "Display version for hpc"
                        , options = id
                        , implementation = version_main
                        , init_flags = default_flags
                        , final_flags = default_final_flags
                        }

version_main :: Flags -> [String] -> IO ()
version_main _ _ = putStrLn ("hpc tools, version " ++ showVersion version)

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


{-# LANGUAGE CPP, GADTs #-}

-- |
-- The Remote GHCi server.
--
-- For details on Remote GHCi, see Note [Remote GHCi] in
-- compiler/ghci/GHCi.hs.
--
module Main (main) where

import Lib (serv)

import GHCi.Message
import GHCi.Signals
import GHCi.Utils

import Control.Exception
import Control.Monad
import Data.IORef
import System.Environment
import System.Exit
import Text.Printf

dieWithUsage :: IO a
dieWithUsage = do
    prog <- getProgName
    die $ prog ++ ": " ++ msg
  where
#ifdef WINDOWS
    msg = "usage: iserv <write-handle> <read-handle> [-v]"
#else
    msg = "usage: iserv <write-fd> <read-fd> [-v]"
#endif

main :: IO ()
main = do
  args <- getArgs
  (wfd1, rfd2, rest) <-
      case args of
        arg0:arg1:rest -> do
            let wfd1 = read arg0
                rfd2 = read arg1
            return (wfd1, rfd2, rest)
        _ -> dieWithUsage

  verbose <- case rest of
    ["-v"] -> return True
    []     -> return False
    _      -> dieWithUsage
  when verbose $
    printf "GHC iserv starting (in: %d; out: %d)\n"
      (fromIntegral rfd2 :: Int) (fromIntegral wfd1 :: Int)
  inh  <- getGhcHandle rfd2
  outh <- getGhcHandle wfd1
  installSignalHandlers
  lo_ref <- newIORef Nothing
  let pipe = Pipe{pipeRead = inh, pipeWrite = outh, pipeLeftovers = lo_ref}
  uninterruptibleMask $ serv verbose hook pipe

  where hook = return -- empty hook
    -- we cannot allow any async exceptions while communicating, because
    -- we will lose sync in the protocol, hence uninterruptibleMask.


{-# LANGUAGE CPP, GADTs, OverloadedStrings, LambdaCase #-}

{-
This is the proxy portion of iserv.

It acts as local bridge for GHC to call
a remote slave. This all might sound
confusing, so let's try to get some
naming down.

GHC is the actual Haskell compiler, that
acts as frontend to the code to be compiled.

iserv is the slave, that GHC delegates compilation
of TH to. As such it needs to be compiled for
and run on the Target. In the special case
where the Host and the Target are the same,
no proxy is needed. GHC and iserv communicate
via pipes.

iserv-proxy is the proxy instance to iserv.
The following illustration should make this
somewhat clear:

 .----- Host -----.     .- Target -.
 | GHC <--> proxy<+-----+>  iserv  |
 '----------------'  ^  '----------'
        ^            |
        |            '-- communication via sockets
        '--- communication via pipes

For now, we won't support multiple concurrent
invocations of the proxy instance, and that
behavior will be undefined, as this largely
depends on the capability of the iserv on the
target to spawn multiple process.  Spawning
multiple threads won't be sufficient, as the
GHC runtime has global state.

Also the GHC runtime needs to be able to
use the linker on the Target to link archives
and object files.

-}

module Main (main) where

import System.IO
import GHCi.Message
import GHCi.Utils
import GHCi.Signals

import Remote.Message

import Network.Socket
import Data.IORef
import Control.Monad
import System.Environment
import System.Exit
import Text.Printf
import GHC.Fingerprint (getFileHash)
import System.Directory
import System.FilePath (isAbsolute)

import Data.Binary
import qualified Data.ByteString as BS

import Control.Concurrent (threadDelay)
import qualified Control.Exception as E

trace :: String -> IO ()
trace s = getProgName >>= \name -> printf "[%20s] %s\n" name s

dieWithUsage :: IO a
dieWithUsage = do
    prog <- getProgName
    die $ prog ++ ": " ++ msg
  where
#if defined(WINDOWS)
    msg = "usage: iserv <write-handle> <read-handle> <slave ip> [-v]"
#else
    msg = "usage: iserv <write-fd> <read-fd> <slave ip> [-v]"
#endif

main :: IO ()
main = do
  hSetBuffering stdin LineBuffering
  hSetBuffering stdout LineBuffering

  args <- getArgs
  (wfd1, rfd2, host_ip, port, rest) <-
      case args of
        arg0:arg1:arg2:arg3:rest -> do
            let wfd1 = read arg0
                rfd2 = read arg1
                ip   = arg2
                port = read arg3
            return (wfd1, rfd2, ip, port, rest)
        _ -> dieWithUsage

  verbose <- case rest of
    ["-v"] -> return True
    []     -> return False
    _      -> dieWithUsage

  when verbose $
    printf "GHC iserv starting (in: %d; out: %d)\n"
      (fromIntegral rfd2 :: Int) (fromIntegral wfd1 :: Int)
  inh  <- getGhcHandle rfd2
  outh <- getGhcHandle wfd1
  installSignalHandlers
  lo_ref <- newIORef Nothing
  let in_pipe = Pipe{pipeRead = inh, pipeWrite = outh, pipeLeftovers = lo_ref}

  when verbose $
    trace ("Trying to connect to " ++ host_ip ++ ":" ++ (show port))

  out_pipe <- do
    let go n = E.try (connectTo verbose host_ip port >>= socketToPipe) >>= \case
          Left e | n == 0 -> E.throw (e :: E.SomeException)
                 | n >  0 -> threadDelay 500000 >> go (n - 1)
          Right a -> return a
      in go 120 -- wait for up to 60seconds (polling every 0.5s).

  when verbose $
    trace "Starting proxy"
  proxy verbose in_pipe out_pipe

-- | A hook, to transform outgoing (proxy -> slave)
-- messages prior to sending them to the slave.
hook :: Msg -> IO Msg
hook = return

-- | Forward a single @THMessage@ from the slave
-- to ghc, and read back the result from GHC.
--
--  @Message@s go from ghc to the slave.
--    ghc --- proxy --> slave               (@Message@)
--  @THMessage@s go from the slave to ghc
--    ghc <-- proxy --- slave               (@THMessage@)
--
fwdTHMsg :: (Binary a) => Pipe -> THMessage a -> IO a
fwdTHMsg local msg = do
  writePipe local (putTHMessage msg)
  readPipe local get

-- | Fowarard a @Message@ call and handle @THMessages@.
fwdTHCall :: (Binary a) => Bool -> Pipe -> Pipe -> Message a -> IO a
fwdTHCall verbose local remote msg = do
  when verbose $ trace ("fwdTHCall: " ++ show msg)
  writePipe remote (putMessage msg)
  -- wait for control instructions
  when verbose $ trace "waiting for control instructions..."
  loopTH
  when verbose $ trace "reading remote pipe result"
  readPipe remote get
    where
      loopTH :: IO ()
      loopTH = do
        when verbose $
          trace "fwdTHCall/loopTH: reading remote pipe..."
        THMsg msg' <- readPipe remote getTHMessage
        when verbose $
          trace ("| TH Msg: ghc <- proxy -- slave: " ++ show msg')
        res <- fwdTHMsg local msg'
        when verbose $
          trace ("| Resp.:  ghc -- proxy -> slave: " ++ show res)
        writePipe remote (put res)
        case msg' of
          RunTHDone -> return ()
          _         -> loopTH

-- | Forwards a @Message@ call, and handle @SlaveMessage@.
-- Similar to @THMessages@, but @SlaveMessage@ are between
-- the slave and the proxy, and are not forwarded to ghc.
-- These message allow the Slave to query the proxy for
-- files.
--
--  ghc --- proxy --> slave  (@Message@)
--
--          proxy <-- slave  (@SlaveMessage@)
--
fwdLoadCall :: (Binary a, Show a) => Bool -> Pipe -> Pipe -> Message a -> IO a
fwdLoadCall verbose _ remote msg = do
  when verbose $ trace "fwdLoadCall: writing remote pipe"
  writePipe remote (putMessage msg)
  loopLoad
  when verbose $ trace "fwdLoadCall: reading local pipe"
  readPipe remote get
  where
    truncateMsg :: Int -> String -> String
    truncateMsg n s | length s > n = take n s ++ "..."
                    | otherwise    = s
    reply :: (Binary a, Show a) => a -> IO ()
    reply m = do
      when verbose $
        trace ("| Resp.:         proxy -> slave: "
                  ++ truncateMsg 80 (show m))
      writePipe remote (put m)
    loopLoad :: IO ()
    loopLoad = do
      when verbose $ trace "fwdLoadCall: reading remote pipe"
      SlaveMsg msg' <- readPipe remote getSlaveMessage
      when verbose $
        trace ("| Sl Msg:        proxy <- slave: " ++ show msg')
      case msg' of
        Done -> return ()
        Missing path -> do
          when verbose $
            trace $ "fwdLoadCall: missing path: " ++ path
          reply =<< BS.readFile path
          loopLoad
        Have path remoteHash -> do
          localHash <- getFileHash path
          reply =<< if localHash == remoteHash
                    then return Nothing
                    else Just <$> BS.readFile path
          loopLoad

-- | The actual proxy. Conntect local and remote pipe,
-- and does some message handling.
proxy :: Bool -> Pipe -> Pipe -> IO ()
proxy verbose local remote = loop
  where
    fwdCall :: (Binary a, Show a) => Message a -> IO a
    fwdCall msg = do
      when verbose $ trace "proxy/fwdCall: writing remote pipe"
      writePipe remote (putMessage msg)
      when verbose $ trace "proxy/fwdCall: reading remote pipe"
      readPipe remote get

    -- reply to ghc.
    reply :: (Show a, Binary a) => a -> IO ()
    reply msg = do
      when verbose $
        trace ("Resp.:    ghc <- proxy -- slave: " ++ show msg)
      writePipe local (put msg)

    loop = do
      (Msg msg) <- readPipe local getMessage
      when verbose $
        trace ("Msg:      ghc -- proxy -> slave: " ++ show msg)
      (Msg msg') <- hook (Msg msg)
      -- Note [proxy-communication]
      --
      -- The fwdTHCall/fwdLoadCall/fwdCall's have to match up
      -- with their endpoints in libiserv:Remote.Slave otherwise
      -- you will end up with hung connections.
      --
      -- We are intercepting some calls between ghc and iserv
      -- and augment the protocol here.  Thus these two sides
      -- need to line up and know what request/reply to expect.
      --
      case msg' of
        -- TH might send some message back to ghc.
        RunTH{} -> do
          resp <- fwdTHCall verbose local remote msg'
          reply resp
          loop
        RunModFinalizers{} -> do
          resp <- fwdTHCall verbose local remote msg'
          reply resp
          loop
        -- Load messages might send some messages back to the proxy, to
        -- requrest files that are not present on the device.
        LoadArchive{} -> do
          resp <- fwdLoadCall verbose local remote msg'
          reply resp
          loop
        LoadObj{} -> do
          resp <- fwdLoadCall verbose local remote msg'
          reply resp
          loop
        -- On windows we assume that we don't want to copy libraries
        -- that are referenced in C:\ these are usually system libraries.
        LoadDLL path@('C':':':_) -> do
          fwdCall msg' >>= reply >> loop
        LoadDLL path | isAbsolute path -> do
          resp <- fwdLoadCall verbose local remote msg'
          reply resp
          loop
        Shutdown{}    -> fwdCall msg' >> return ()
        _other        -> fwdCall msg' >>= reply >> loop

connectTo :: Bool -> String -> PortNumber -> IO Socket
connectTo verbose host port = do
  addr <- resolve host (show port)
  open addr
  where
    resolve host port = do
        let hints = defaultHints { addrSocketType = Stream }
        addr:_ <- getAddrInfo (Just hints) (Just host) (Just port)
        return addr
    open addr = do
        sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
        when verbose $
          trace $ "Created socket for " ++ host ++ ":" ++ show port
        connect sock $ addrAddress addr
        when verbose $
          trace "connected"
        return sock

-- | Turn a socket into an unbuffered pipe.
socketToPipe :: Socket -> IO Pipe
socketToPipe sock = do
  hdl <- socketToHandle sock ReadWriteMode
  hSetBuffering hdl NoBuffering

  lo_ref <- newIORef Nothing
  pure Pipe{ pipeRead = hdl, pipeWrite = hdl, pipeLeftovers = lo_ref }


import           Distribution.Simple
main = defaultMain


module Main where

import           Remote.Slave (startSlave')
import           System.Environment (getArgs, getProgName)
import           System.Exit (die)

main :: IO ()
main = getArgs >>= startSlave

dieWithUsage :: IO a
dieWithUsage = do
  prog <- getProgName
  die $ msg prog
 where
  msg name = "usage: " ++ name ++ " /path/to/storage PORT [-v]"

startSlave :: [String] -> IO ()
startSlave args0
  | "--help" `elem` args0 = dieWithUsage
  | otherwise = do
      (path, port, rest) <- case args0 of
        arg0:arg1:rest -> return (arg0, read arg1, rest)
        _              -> dieWithUsage

      verbose <- case rest of
        ["-v"] -> return True
        []     -> return False
        _      -> dieWithUsage

      startSlave' verbose path port


{-# LANGUAGE CPP #-}
#include "ghcconfig.h"
-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow, 2004
--
-- runghc program, for invoking from a #! line in a script.  For example:
--
--   script.lhs:
--      #!/usr/bin/env runghc
--      > main = putStrLn "hello!"
--
-- runghc accepts one flag:
--
--      -f <path>    specify the path
--
-- -----------------------------------------------------------------------------

module Main (main) where

import Control.Exception
import Data.Semigroup as Semi
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.IO

#if defined(mingw32_HOST_OS)
import System.Process (rawSystem)
import Foreign
import Foreign.C.String
#else
import System.Posix.Process (executeFile)
#endif

#if defined(mingw32_HOST_OS)
# if defined(i386_HOST_ARCH)
#  define WINDOWS_CCONV stdcall
# elif defined(x86_64_HOST_ARCH)
#  define WINDOWS_CCONV ccall
# else
#  error Unknown mingw32 arch
# endif
#endif

main :: IO ()
main = do
    args <- getArgs
    case parseRunGhcFlags args of
        (Help, _) -> printUsage
        (ShowVersion, _) -> printVersion
        (RunGhcFlags (Just ghc), args') -> uncurry (doIt ghc) $ getGhcArgs args'
        (RunGhcFlags Nothing, args') -> do
            mbPath <- getExecPath
            case mbPath of
                Nothing  -> dieProg ("cannot find ghc")
                Just path -> do
                    ghc <- findGhc path
                    uncurry (doIt ghc) $ getGhcArgs args'

-- In some cases, runghc isn't given a path to ghc explicitly. This can occur
-- if $1_$2_SHELL_WRAPPER = NO (which is always the case on Windows). In such
-- a scenario, we must guess where ghc lives. Given a path where ghc might
-- live, we check for the existence of ghc. If we can't find it, we assume that
-- we're building ghc from source, in which case we fall back on ghc-stage2.
-- (See Trac #1185.)
findGhc :: FilePath -> IO FilePath
findGhc path = do
    let ghcDir = takeDirectory (normalise path)
        ghc    = ghcDir </> "ghc" <.> exeExtension
    ghcExists <- doesFileExist ghc
    return $ if ghcExists
             then ghc
             else ghcDir </> "ghc-stage2" <.> exeExtension

data RunGhcFlags = RunGhcFlags (Maybe FilePath) -- GHC location
                 | Help -- Print help text
                 | ShowVersion -- Print version info

instance Semi.Semigroup RunGhcFlags where
    Help <> _ = Help
    _ <> Help = Help
    ShowVersion <> _ = ShowVersion
    _ <> ShowVersion = ShowVersion
    RunGhcFlags _ <> right@(RunGhcFlags (Just _)) = right
    left@(RunGhcFlags _) <> RunGhcFlags Nothing = left

instance Monoid RunGhcFlags where
    mempty = RunGhcFlags Nothing
    mappend = (<>)

parseRunGhcFlags :: [String] -> (RunGhcFlags, [String])
parseRunGhcFlags = f mempty
    where f flags ("-f" : ghc : args)
              = f (flags `mappend` RunGhcFlags (Just ghc)) args
          f flags (('-' : 'f' : ghc) : args)
              = f (flags `mappend` RunGhcFlags (Just ghc)) args
          f flags ("--help" : args) = f (flags `mappend` Help) args
          f flags ("--version" : args) = f (flags `mappend` ShowVersion) args
          -- If you need the first GHC flag to be a -f flag then
          -- you can pass -- first
          f flags ("--" : args) = (flags, args)
          f flags         args  = (flags, args)

printVersion :: IO ()
printVersion = do
    putStrLn ("runghc " ++ VERSION)

printUsage :: IO ()
printUsage = do
    putStrLn "Usage: runghc [runghc flags] [GHC flags] module [program args]"
    putStrLn ""
    putStrLn "The runghc flags are"
    putStrLn "    -f /path/to/ghc       Tell runghc where GHC is"
    putStrLn "    --ghc-arg=<arg>       Pass an option or argument to GHC"
    putStrLn "    --help                Print this usage information"
    putStrLn "    --version             Print version number"

doIt :: String -- ^ path to GHC
     -> [String] -- ^ GHC args
     -> [String] -- ^ rest of the args
     -> IO ()
doIt ghc ghc_args rest = do
    case rest of
        [] -> do
           -- behave like typical perl, python, ruby interpreters:
           -- read from stdin
           tmpdir <- getTemporaryDirectory
           bracket
             (openTempFile tmpdir "runghcXXXX.hs")
             (\(filename,h) -> do hClose h; removeFile filename)
             $ \(filename,h) -> do
                 getContents >>= hPutStr h
                 hClose h
                 doIt ghc ghc_args [filename]
        filename : prog_args -> do
            -- If the file exists, and is not a .lhs file, then we
            -- want to treat it as a .hs file.
            --
            -- If the file doesn't exist then GHC is going to look for
            -- filename.hs and filename.lhs, and use the appropriate
            -- type.
            exists <- doesFileExist filename
            let xflag = if exists && (takeExtension filename /= ".lhs")
                        then ["-x", "hs"]
                        else []
                c1 = ":set prog " ++ show filename
                c2 = ":main " ++ show prog_args

            let cmd = ghc
                args = ["-ignore-dot-ghci"] ++
                       xflag ++
                       ghc_args ++
                       [ "-e", c1, "-e", c2, filename]

#if defined(mingw32_HOST_OS)
            rawSystem cmd args >>= exitWith
#else
            -- Passing False to avoid searching the PATH, since the cmd should
            -- always be an absolute path to the ghc executable.
            executeFile cmd False args Nothing
#endif

getGhcArgs :: [String] -> ([String], [String])
getGhcArgs args
 = let (ghcArgs, otherArgs) = case break pastArgs args of
                              (xs, "--":ys) -> (xs, ys)
                              (xs, ys)      -> (xs, ys)
   in (map unescape ghcArgs, otherArgs)
    where unescape ('-':'-':'g':'h':'c':'-':'a':'r':'g':'=':arg) =
                case arg of
                    -- Bug #8601: allow --ghc-arg=--ghc-arg= as a prefix as well for backwards compatibility
                    ('-':'-':'g':'h':'c':'-':'a':'r':'g':'=':arg') -> arg'
                    _ -> arg
          unescape arg = arg

pastArgs :: String -> Bool
-- You can use -- to mark the end of the flags, in case you need to use
-- a file called -foo.hs for some reason. You almost certainly shouldn't,
-- though.
pastArgs "--" = True
pastArgs ('-':_) = False
pastArgs _       = True

dieProg :: String -> IO a
dieProg msg = do
    p <- getProgName
    hPutStrLn stderr (p ++ ": " ++ msg)
    exitWith (ExitFailure 1)

-- usage :: String
-- usage = "syntax: runghc [-f GHC-PATH | --] [GHC-ARGS] [--] FILE ARG..."

getExecPath :: IO (Maybe String)
#if defined(mingw32_HOST_OS)
getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
  where
    try_size size = allocaArray (fromIntegral size) $ \buf -> do
        ret <- c_GetModuleFileName nullPtr buf size
        case ret of
          0 -> return Nothing
          _ | ret < size -> fmap Just $ peekCWString buf
            | otherwise  -> try_size (size * 2)

foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
  c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
#else
getExecPath = return Nothing
#endif


module Main (main) where

import Control.Monad
import qualified Data.ByteString.Char8 as BSC
import Data.Function
import Data.List
import qualified Data.Map as Map
import Data.Map (Map)
import System.Environment
import System.FilePath

data CleanWhat = CleanFile FilePath
               | CleanRec  FilePath
    deriving (Read, Show)

newtype FilePathFragment = FilePathFragment BSC.ByteString
    deriving (Show, Eq, Ord)

toFilePathFragments :: FilePath -> [FilePathFragment]
toFilePathFragments
    = map (FilePathFragment . BSC.pack) . splitDirectories . normalise

fromFilePathFragments :: [FilePathFragment] -> FilePath
fromFilePathFragments xs = joinPath $ map f $ reverse xs
    where f (FilePathFragment frag) = BSC.unpack frag

data Tree = Node !FileInfo !(Map FilePathFragment Tree)
data FileInfo = FileInfo {
                    fiBefore :: !Bool,
                    fiAfter :: !Bool,
                    fiDeleted :: !Bool
                }

beforeFileInfo :: FileInfo
beforeFileInfo = noFileInfo { fiBefore  = True }

afterFileInfo :: FileInfo
afterFileInfo = noFileInfo { fiAfter   = True }

noFileInfo :: FileInfo
noFileInfo = FileInfo {
                 fiBefore  = False,
                 fiAfter   = False,
                 fiDeleted = False
             }

readTree :: FileInfo -> FilePath -> IO (Tree)
readTree fi fp = do xs <- readFile fp
                    return $ mkTree fi $ lines xs

mkTree :: FileInfo -> [FilePath] -> Tree
mkTree fi fps = f (sort fragss)
    where fragss = map toFilePathFragments fps
          f xs = let xs' = g $ groupBy ((==) `on` head)
                             $ filter (not . null) xs
                 in Node fi xs'
          g xss = mapFromList' [ (head (head xs), f (map tail xs))
                               | xs <- xss ]

mapFromList' :: Ord a => [(a, b)] -> Map a b
mapFromList' xs = seqAll xs `seq` Map.fromList xs
    where seqAll [] = ()
          seqAll ((x, y) : xys) = x `seq` y `seq` seqAll xys

{-
... = OK: will happen if a file in a non-existent directory is rm'd [1]
..D = OK: will happen if a non-existent file is rm'd [1]
.A. = suspicious: Why wasn't this file cleaned?
.AD = OK: This is what object files look like
B.. = suspicious: Where did the file go?
B.D = suspicious: Why are we removing a file that existed before?
BA. = OK: This is what source files look like
BAD = suspicious: Why are we removing a file that existed before?

[1] some files may only be created on certain platforms, or in certain
    build-system configurations, but the cleaning code is deliberately
    simple so it will always clean them regardless
-}
pprSuspicious :: Tree -> [String]
pprSuspicious t = f [] t
    where f ps (Node fi m) = suspicious (fromFilePathFragments ps) fi
                          ++ concat [ f (p : ps) m' | (p, m') <- Map.toList m ]
          suspicious fp (FileInfo False True  False) = ["File not deleted:    " ++ show fp]
          suspicious fp (FileInfo True  False False) = ["File disappeared:    " ++ show fp]
          suspicious fp (FileInfo True  False True)  = ["Deleted before file: " ++ show fp]
          suspicious fp (FileInfo True  True  True)  = ["Deleted before file: " ++ show fp]
          suspicious _  _                            = []

pprTree :: Tree -> [String]
pprTree t = f [] t
    where f ps (Node fi m) = (pprInfo fi ++ " " ++ fromFilePathFragments ps)
                           : concat [ f (p : ps) m' | (p, m') <- Map.toList m ]

pprInfo :: FileInfo -> String
pprInfo (FileInfo before after deleted) = [if before  then 'B' else '.',
                                           if after   then 'A' else '.',
                                           if deleted then 'D' else '.']

mergeTree :: Tree -> Tree -> Tree
mergeTree (Node fi1 m1) (Node fi2 m2)
    = Node (mergeFileInfo fi1 fi2)
           (Map.unionWith mergeTree m1 m2)

mergeFileInfo :: FileInfo -> FileInfo -> FileInfo
mergeFileInfo (FileInfo before1 after1 deleted1)
              (FileInfo before2 after2 deleted2)
    = FileInfo (before1 || before2) (after1 || after2) (deleted1 || deleted2)

main :: IO ()
main = do args <- getArgs
          case args of
              [contentsBeforeFile, contentsAfterFile, wouldBeCleanedFile] ->
                  doit contentsBeforeFile contentsAfterFile wouldBeCleanedFile
              _ ->
                  error "Bad args"

doit :: FilePath -> FilePath -> FilePath -> IO ()
doit contentsBeforeFile contentsAfterFile wouldBeCleanedFile
 = do contentsBefore <- readTree beforeFileInfo contentsBeforeFile
      contentsAfter  <- readTree afterFileInfo  contentsAfterFile
      let contentsMerged = mergeTree contentsBefore contentsAfter
      wouldBeCleaned <- liftM (map read . lines) $ readFile wouldBeCleanedFile
      let contentsCleaned = simulateCleans contentsMerged wouldBeCleaned
      mapM_ putStrLn $ pprSuspicious contentsCleaned

simulateCleans :: Tree -> [CleanWhat] -> Tree
simulateCleans = foldl' simulateClean

simulateClean :: Tree -> CleanWhat -> Tree
simulateClean t (CleanFile fp) = at t fp markDeleted
simulateClean t (CleanRec  fp) = at t fp markSubtreeDeleted

markDeleted :: Tree -> Tree
markDeleted (Node fi m) = Node (fi { fiDeleted = True }) m

markSubtreeDeleted :: Tree -> Tree
markSubtreeDeleted (Node fi m) = Node fi' (Map.map markSubtreeDeleted m)
    where fi' = -- "rm -r" will only delete things that are there afterwards
                if fiAfter fi then fi { fiDeleted = True } else fi

at :: Tree -> FilePath -> (Tree -> Tree) -> Tree
at t fp f = at' t (toFilePathFragments fp) f

at' :: Tree -> [FilePathFragment] -> (Tree -> Tree) -> Tree
at' t           []       f = f t
at' (Node fi m) (p : ps) f = Node fi m'
    where m' = Map.insert p (at' t ps f) m
          t = Map.findWithDefault (Node noFileInfo Map.empty) p m


module Main (main) where

import System.Environment

data CleanWhat = CleanFile FilePath
               | CleanRec  FilePath
    deriving (Read, Show)

main :: IO ()
main = do args <- getArgs
          ls <- case args of
                "CLEAN_FILES" : files -> return $ map CleanFile files
                "CLEAN_REC"   : dirs  -> return $ map CleanRec dirs
                _ -> error "Bad args"
          appendFile "would-be-cleaned" $ unlines $ map show ls


#!/usr/bin/env runhaskell
> import Distribution.Simple
> main = defaultMain


module Main where

import Documentation.Haddock (haddock)
import ResponseFile (expandResponse)
import System.Environment (getArgs)

main :: IO ()
main = getArgs >>= expandResponse >>= haddock


{-# LANGUAGE ScopedTypeVariables #-}
module ResponseFile (
    unescapeArgs,
    escapeArgs,
    expandResponse
  ) where

import Control.Exception
import Data.Char (isSpace)
import Data.Foldable (foldl')
import System.Exit (exitFailure)
import System.IO

-- | Given a string of concatenated strings, separate each by removing
-- a layer of /quoting/ and\/or /escaping/ of certain characters.
--
-- These characters are: any whitespace, single quote, double quote,
-- and the backslash character.  The backslash character always
-- escapes (i.e., passes through without further consideration) the
-- character which follows.  Characters can also be escaped in blocks
-- by quoting (i.e., surrounding the blocks with matching pairs of
-- either single- or double-quotes which are not themselves escaped).
--
-- Any whitespace which appears outside of either of the quoting and
-- escaping mechanisms, is interpreted as having been added by this
-- special concatenation process to designate where the boundaries
-- are between the original, un-concatenated list of strings.  These
-- added whitespace characters are removed from the output.
--
-- > unescapeArgs "hello\\ \\\"world\\\"\n" == escapeArgs "hello \"world\""
unescapeArgs :: String -> [String]
unescapeArgs = filter (not . null) . unescape

-- | Given a list of strings, concatenate them into a single string
-- with escaping of certain characters, and the addition of a newline
-- between each string.  The escaping is done by adding a single
-- backslash character before any whitespace, single quote, double
-- quote, or backslash character, so this escaping character must be
-- removed.  Unescaped whitespace (in this case, newline) is part
-- of this "transport" format to indicate the end of the previous
-- string and the start of a new string.
--
-- While 'unescapeArgs' allows using quoting (i.e., convenient
-- escaping of many characters) by having matching sets of single- or
-- double-quotes,'escapeArgs' does not use the quoting mechasnism,
-- and thus will always escape any whitespace, quotes, and
-- backslashes.
--
-- > unescapeArgs "hello\\ \\\"world\\\"\\n" == escapeArgs "hello \"world\""
escapeArgs :: [String] -> String
escapeArgs = unlines . map escapeArg

-- | Arguments which look like '@foo' will be replaced with the
-- contents of file @foo@. A gcc-like syntax for response files arguments
-- is expected.  This must re-constitute the argument list by doing an
-- inverse of the escaping mechanism done by the calling-program side.
--
-- We quit if the file is not found or reading somehow fails.
-- (A convenience routine for haddock or possibly other clients)
expandResponse :: [String] -> IO [String]
expandResponse = fmap concat . mapM expand
  where
    expand :: String -> IO [String]
    expand ('@':f) = readFileExc f >>= return . unescapeArgs
    expand x = return [x]

    readFileExc f =
      readFile f `catch` \(e :: IOException) -> do
        hPutStrLn stderr $ "Error while expanding response file: " ++ show e
        exitFailure

data Quoting = NoneQ | SngQ | DblQ

unescape :: String -> [String]
unescape args = reverse . map reverse $ go args NoneQ False [] []
    where
      -- n.b., the order of these cases matters; these are cribbed from gcc
      -- case 1: end of input
      go []     _q    _bs   a as = a:as
      -- case 2: back-slash escape in progress
      go (c:cs) q     True  a as = go cs q     False (c:a) as
      -- case 3: no back-slash escape in progress, but got a back-slash
      go (c:cs) q     False a as
        | '\\' == c              = go cs q     True  a     as
      -- case 4: single-quote escaping in progress
      go (c:cs) SngQ  False a as
        | '\'' == c              = go cs NoneQ False a     as
        | otherwise              = go cs SngQ  False (c:a) as
      -- case 5: double-quote escaping in progress
      go (c:cs) DblQ  False a as
        | '"' == c               = go cs NoneQ False a     as
        | otherwise              = go cs DblQ  False (c:a) as
      -- case 6: no escaping is in progress
      go (c:cs) NoneQ False a as
        | isSpace c              = go cs NoneQ False []    (a:as)
        | '\'' == c              = go cs SngQ  False a     as
        | '"'  == c              = go cs DblQ  False a     as
        | otherwise              = go cs NoneQ False (c:a) as

escapeArg :: String -> String
escapeArg = reverse . foldl' escape []

escape :: String -> Char -> String
escape cs c
  |    isSpace c
    || '\\' == c
    || '\'' == c
    || '"'  == c = c:'\\':cs -- n.b., our caller must reverse the result
  | otherwise    = c:cs


module Main where

import Test.Hspec (describe, hspec, Spec)
import qualified ResponseFileSpec (spec)

main :: IO ()
main = hspec spec

spec :: Spec
spec = do
    describe "ResponseFile" ResponseFileSpec.spec


module ResponseFileSpec where

import Test.Hspec (context, describe, it, shouldBe, Spec)
import ResponseFile (escapeArgs, unescapeArgs)

-- The first two elements are
--   1) a list of 'args' to encode and
--   2) a single string of the encoded args
-- The 3rd element is just a description for the tests.
testStrs :: [(([String], String), String)]
testStrs =
  [ ((["a simple command line"],
      "a\\ simple\\ command\\ line\n"),
     "the white-space, end with newline")

  , ((["arg 'foo' is single quoted"],
      "arg\\ \\'foo\\'\\ is\\ single\\ quoted\n"),
     "the single quotes as well")

  , ((["arg \"bar\" is double quoted"],
      "arg\\ \\\"bar\\\"\\ is\\ double\\ quoted\n"),
     "the double quotes as well" )

  , ((["arg \"foo bar\" has embedded whitespace"],
      "arg\\ \\\"foo\\ bar\\\"\\ has\\ embedded\\ whitespace\n"),
     "the quote-embedded whitespace")

  , ((["arg 'Jack said \\'hi\\'' has single quotes"],
      "arg\\ \\'Jack\\ said\\ \\\\\\'hi\\\\\\'\\'\\ has\\ single\\ quotes\n"),
     "the escaped single quotes")

  , ((["arg 'Jack said \\\"hi\\\"' has double quotes"],
      "arg\\ \\'Jack\\ said\\ \\\\\\\"hi\\\\\\\"\\'\\ has\\ double\\ quotes\n"),
     "the escaped double quotes")

  , ((["arg 'Jack said\\r\\n\\t \\\"hi\\\"' has other whitespace"],
      "arg\\ \\'Jack\\ said\\\\r\\\\n\\\\t\\ \\\\\\\"hi\\\\\\\"\\'\\ has\\ \
           \other\\ whitespace\n"),
     "the other whitespace")

  , (([ "--prologue=.\\dist\\.\\haddock-prologue3239114604.txt"
      , "--title=HaddockNewline-0.1.0.0: This has a\n\
        \newline yo."
      , "-BC:\\Program Files\\Haskell Platform\\lib"],
      "--prologue=.\\\\dist\\\\.\\\\haddock-prologue3239114604.txt\n\
      \--title=HaddockNewline-0.1.0.0:\\ This\\ has\\ a\\\n\
      \newline\\ yo.\n\
      \-BC:\\\\Program\\ Files\\\\Haskell\\ Platform\\\\lib\n"),
     "an actual haddock response file snippet with embedded newlines")
  ]

spec :: Spec
spec = do
  describe "escapeArgs" $ do
      mapM_ (\((ss1,s2),des) -> do
                  context ("given " ++ (show ss1)) $ do
                      it ("should escape " ++ des) $ do
                          escapeArgs ss1 `shouldBe` s2
            ) testStrs
  describe "unescapeArgs" $ do
      mapM_ (\((ss1,s2),des) -> do
                  context ("given " ++ (show s2)) $ do
                      it ("should unescape " ++ des) $ do
                          unescapeArgs s2 `shouldBe` ss1
            ) testStrs
  describe "unescapeArgs" $ do
      context "given unescaped single quotes" $ do
          it "should pass-through, without escaping, everything inside" $ do
              -- backslash *always* is escaped anywhere it appears
              (filter (not . null) $
                unescapeArgs "this\\ is\\ 'not escape\\d \"inside\"'\\ yo\n")
              `shouldBe`
              ["this is not escaped \"inside\" yo"]
      context "given unescaped double quotes" $ do
          it "should pass-through, without escaping, everything inside" $ do
              -- backslash *always* is escaped anywhere it appears
              (filter (not . null) $
                unescapeArgs "this\\ is\\ \"not escape\\d 'inside'\"\\ yo\n")
              `shouldBe`
              ["this is not escaped 'inside' yo"]