Draft: New Tool 'FaultLoc'

This adds a new tool named 'faultLoc' that uses Spectrum-Based Fault Localization (SBFL) to show suspicious and possibly faulty code parts. To use this tool you need per-test tix files (this can be achieved with this). The tool has options to show the ranking of suspicious code in the standard output and/or generate a JSON file with all the SBFL data in it.

Example usage:

hpc faultLoc ./path/to/folderWithTixFiles/

src/Trace/Hpc/FaultLoc.hs

+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE InstanceSigs #-}
+
+module Trace.Hpc.FaultLoc (faultLocPlugin) where
+
+import Control.DeepSeq (NFData, force)
+import Control.Monad (when)
+import Data.List (intercalate, sortBy)
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import GHC.Generics (Generic)
+import System.Directory (listDirectory)
+import System.FilePath (dropExtension, takeFileName, (</>))
+import Trace.Hpc.Flags
+import Trace.Hpc.Mix (BoxLabel (ExpBox), Mix (..), MixEntry)
+import Trace.Hpc.Plugin
+import Trace.Hpc.Tix (Tix (..), TixModule (..), readTix)
+import Trace.Hpc.Util (HpcPos, insideHpcPos, toHpcPos)
+import Trace.Hpc.Utils (JsonDoc (..), ToJson (..), writeJSON)
+
+faultLocOptions :: FlagOptSeq
+faultLocOptions =
+  excludeOpt
+    . includeOpt
+    . srcDirOpt
+    . hpcDirOpt
+    . destDirOpt
+    . verbosityOpt
+    . showNOpt
+    . includeTixFileOpt
+    . excludeTixFileOpt
+    . useMetricOpt
+    . sortByMetricOpt
+    . roundToNOpt
+    . resultPassedOpt
+    . resultFailedOpt
+    . resultSeperatorOpt
+    . showParametersOpt
+    . jsonOutputOpt
+    . outputGroupedOpt
+    . outputOpt
+
+faultLocPlugin :: Plugin
+faultLocPlugin =
+  Plugin
+    { name = "faultLoc",
+      usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]",
+      options = faultLocOptions,
+      summary = "SBFL Analysis of code",
+      implementation = faultLocMain
+    }
+
+faultLocMain :: Flags -> [String] -> IO ()
+faultLocMain _ [] = hpcError faultLocPlugin "no .tix folder specified"
+faultLocMain flags [tixDir] =
+  do
+    when (verbosity flags > Silent) $ do
+      putStrLn "Getting Coverage"
+
+    pcov@(ProgramCoverage !mm) <-
+      getProgramCoverage
+        tixDir
+        flags
+
+    when (verbosity flags > Normal) $ do
+      putStrLn $
+        (show . length) (Map.keys mm)
+          ++ " Modules covered"
+
+    when (verbosity flags > Silent) $ do
+      putStrLn "Grouping Locations"
+
+    let !gpcov = groupProgramCoverage pcov
+
+    when (verbosity flags > Silent) $ do
+      putStrLn "Getting Code"
+
+    (ProgramCode !cm) <-
+      getProgramCode
+        ((head . srcDirs) flags)
+        pcov
+
+    when (verbosity flags > Normal) $ do
+      putStrLn $
+        (show . length) (Map.keys cm)
+          ++ " src-Files read"
+
+    when (showN flags > 0) $ do
+      printRankedLocationTable pcov flags
+
+    when (jsonOutput flags) $ do
+      let filename =
+            if outputFile flags == "-"
+              then "sbfl.json"
+              else outputFile flags
+          filepath = destDir flags </> filename
+      writeJSON
+        filepath
+        (if outputGrouped flags then json gpcov else json pcov)
+faultLocMain _ _ = hpcError faultLocPlugin "too many arguments provided"
+
+----------------------------------------------------------------------------------
+
+data SBFLParameter = SBFLParameter
+  { -- | number of evaluations in failing tests
+    c_ef :: {-# UNPACK #-} !Int,
+    -- | number of non evaluations in failing tests
+    c_nf :: {-# UNPACK #-} !Int,
+    -- | number of evaluations in passing tests
+    c_ep :: {-# UNPACK #-} !Int,
+    -- | number of non evaluations in passing tests
+    c_np :: {-# UNPACK #-} !Int
+  }
+
+instance Semigroup SBFLParameter where
+  (<>) :: SBFLParameter -> SBFLParameter -> SBFLParameter
+  (<>)
+    SBFLParameter {c_ef = c_ef1, c_nf = c_nf1, c_ep = c_ep1, c_np = c_np1}
+    SBFLParameter {c_ef = c_ef2, c_nf = c_nf2, c_ep = c_ep2, c_np = c_np2} =
+      SBFLParameter
+        { c_ef = c_ef1 + c_ef2,
+          c_nf = c_nf1 + c_nf2,
+          c_ep = c_ep1 + c_ep2,
+          c_np = c_np1 + c_np2
+        }
+
+instance Monoid SBFLParameter where
+  mempty :: SBFLParameter
+  mempty = SBFLParameter {c_ef = 0, c_nf = 0, c_ep = 0, c_np = 0}
+
+-------
+
+data TestRun = TestRun
+  { test_passed :: !Bool,
+    covered_module :: !TixModule
+  }
+  deriving (Generic, Show)
+
+instance NFData TestRun
+
+toParameterMap ::
+  TestRun ->
+  Mix ->
+  Map.Map Trace.Hpc.Util.HpcPos SBFLParameter
+toParameterMap
+  TestRun
+    { test_passed = passed,
+      covered_module = (TixModule _ _ _ ticks)
+    }
+  (Mix _ _ _ _ entries') =
+    go Map.empty entries' 0
+    where
+      go ::
+        Map.Map Trace.Hpc.Util.HpcPos SBFLParameter ->
+        [MixEntry] ->
+        Int ->
+        Map.Map Trace.Hpc.Util.HpcPos SBFLParameter
+      go lis [] _ = lis
+      go lis ((loc, ExpBox _) : entries) i -- we are only interessted in ExpBoxes
+        =
+        let !li = getParameter i
+         in go (Map.insertWith merge loc li lis) entries (i + 1)
+      go lis (_ : entries) i = go lis entries (i + 1) -- other boxes
+      merge :: SBFLParameter -> SBFLParameter -> SBFLParameter
+      merge p1 p2 = p1 <> p2 -- TODO: WHY?
+      getParameter :: Int -> SBFLParameter
+      getParameter i = case (passed, ticks !! i > 0) of
+        (False, False) -> SBFLParameter {c_ef = 0, c_nf = 1, c_ep = 0, c_np = 0}
+        (False, True) -> SBFLParameter {c_ef = 1, c_nf = 0, c_ep = 0, c_np = 0}
+        (True, False) -> SBFLParameter {c_ef = 0, c_nf = 0, c_ep = 0, c_np = 1}
+        (True, True) -> SBFLParameter {c_ef = 0, c_nf = 0, c_ep = 1, c_np = 0}
+
+-------
+
+newtype ModuleCoverage = ModuleCoverage (Map.Map Trace.Hpc.Util.HpcPos SBFLParameter)
+
+instance Semigroup ModuleCoverage where
+  (<>) :: ModuleCoverage -> ModuleCoverage -> ModuleCoverage
+  (<>) (ModuleCoverage m1) (ModuleCoverage m2) =
+    ModuleCoverage (Map.unionWith (<>) m1 m2)
+
+-------
+
+newtype ProgramCoverage = ProgramCoverage (Map.Map FilePath ModuleCoverage)
+
+instance Semigroup ProgramCoverage where
+  (<>) :: ProgramCoverage -> ProgramCoverage -> ProgramCoverage
+  (<>) (ProgramCoverage m1) (ProgramCoverage m2) =
+    ProgramCoverage (Map.unionWith (<>) m1 m2)
+
+instance ToJson ProgramCoverage where
+  json :: ProgramCoverage -> JsonDoc
+  json (ProgramCoverage mcovs) =
+    JSArray $ map (uncurry jsonGroupedMCov) (Map.assocs mcovs)
+    where
+      jsonGroupedMCov :: FilePath -> ModuleCoverage -> JsonDoc
+      jsonGroupedMCov path (ModuleCoverage locs) =
+        JSObject
+          [ ("module_src_path", JSString path),
+            ("locations", JSArray $ map json (Map.assocs locs))
+          ]
+
+toModuleCoverage ::
+  TestRun ->
+  Mix ->
+  ModuleCoverage
+toModuleCoverage tr m =
+  ModuleCoverage $ toParameterMap tr m
+
+fromTixFile ::
+  -- | Path to tix-file
+  FilePath ->
+  -- | module-names that should be included
+  [String] ->
+  Flags ->
+  IO [TestRun]
+fromTixFile fp mods flags =
+  do
+    let filename = dropExtension $ takeFileName fp
+        (_, result) = splitOnLast (resultSeperator flags) filename
+
+    !tix <- readTix fp
+    let !(Tix tixms) = case tix of
+          Just tix' -> tix'
+          Nothing -> error $ "Could not read " ++ fp
+
+        !testruns =
+          [ TestRun
+              { test_passed =
+                  (result == resultPassed flags) -- check if indicator is correct
+                    || ( (result /= resultFailed flags)
+                           && error
+                             ( "'"
+                                 ++ filename
+                                 ++ "' does not contain the correct indicator "
+                                 ++ "if the test passed or not"
+                             )
+                       ),
+                covered_module = covered_mod
+              }
+            | covered_mod@(TixModule n _ _ _) <- tixms,
+              n `elem` mods
+          ]
+
+    pure $ force testruns
+
+splitOnLast :: Char -> String -> (String, String)
+splitOnLast c s =
+  if length parts == 1
+    then (s, [])
+    else (intercalate [c] $ init parts, last parts)
+  where
+    parts = go [] s
+
+    go :: String -> String -> [String]
+    go acc [] = [acc]
+    go acc (x : xs) =
+      if c == x
+        then acc : go [] xs
+        else go (acc ++ [x]) xs
+
+-------
+
+getProgramCoverage ::
+  -- | Path to tix-files
+  FilePath ->
+  -- | Flags
+  Flags ->
+  IO ProgramCoverage
+getProgramCoverage
+  tixpath
+  flags@Flags
+    { includeMods = inclMods,
+      excludeMods = exclMods,
+      includeTixFiles = inclTixs,
+      excludeTixFiles = exclTixs,
+      verbosity = verb
+    } =
+    do
+      tixNames <- listDirectory tixpath
+
+      let !tixPaths =
+            [ tixpath </> t | t <- tixNames, (null inclTixs && not (Set.member t exclTixs))
+                                               || Set.member t (inclTixs Set.\\ exclTixs)
+            ]
+
+      when (verb > Silent) $
+        putStrLn $
+          (show . length) tixPaths
+            ++ " Tix-files found"
+
+      when (null tixPaths) $ error "No Tix-files to process!"
+
+      go1 (1, length tixPaths) tixPaths
+    where
+      modsFromTixPath :: FilePath -> IO [String]
+      modsFromTixPath path =
+        do
+          mtix <- readTix path
+          let (Tix tms) = case mtix of
+                Just t -> t
+                Nothing -> error $ "Can't read tix from " ++ path
+          pure
+            [ n | n <- map (\(TixModule n' _ _ _) -> n') tms, (null inclMods && not (Set.member n exclMods))
+                                                                || Set.member n (inclMods Set.\\ exclMods)
+            ]
+
+      mixsFromTestRuns :: [TestRun] -> IO [Mix]
+      mixsFromTestRuns [] = pure []
+      mixsFromTestRuns (TestRun {covered_module = tixm} : trs) =
+        do
+          mix <- readMixWithFlags flags (Right tixm)
+          mixs <- mixsFromTestRuns trs
+          pure (mix : mixs)
+
+      go1 ::
+        (Int, Int) ->
+        [FilePath] ->
+        -- \^ filepaths to tix-files
+        IO ProgramCoverage
+      go1 _ [] = error "No tix-files found!"
+      go1 (i, n) (tix_path : tix_paths) =
+        do
+          when (verb > Normal) $
+            putStrLn $
+              "Reading tix-file "
+                ++ show i
+                ++ "/"
+                ++ show n
+          mods <- modsFromTixPath tix_path
+
+          when (null mods) $ error "No modules could be loaded!"
+
+          !testruns <- fromTixFile tix_path mods flags
+
+          mixs <- mixsFromTestRuns testruns
+
+          let !moduleMap =
+                Map.fromListWith
+                  (const $ error "Multiple modules with same Filepath")
+                  [ (path, toModuleCoverage tr m)
+                    | (tr, m@(Mix path _ _ _ _)) <- zip testruns mixs
+                  ] -- this is only possible because of the generation of mixs
+          go (i + 1, n) tix_paths mixs mods (ProgramCoverage moduleMap)
+
+      go ::
+        (Int, Int) ->
+        [FilePath] ->
+        -- \^ filepaths to tix-files
+        [Mix] ->
+        -- \^ corresponding mixs to tix-files
+        [String] ->
+        -- \^ module-names that should be included
+        ProgramCoverage ->
+        -- \^ coverage to accumulate over
+        IO ProgramCoverage
+      go _ [] _ _ !pcov = pure pcov
+      go (i, n) (tix_path : tix_paths) !mixs mods (ProgramCoverage moduleMap') =
+        do
+          when (verb > Normal) $
+            putStrLn $
+              "Reading tix-file "
+                ++ show i
+                ++ "/"
+                ++ show n
+          !testruns <- fromTixFile tix_path mods flags
+
+          let !moduleMap =
+                Map.fromListWith
+                  (const $ error "Multiple modules with same Filepath")
+                  [ (path, toModuleCoverage tr m)
+                    | (tr, m@(Mix path _ _ _ _)) <- zip testruns mixs
+                  ] -- this is only possible because of the generation of mixs
+          go (i + 1, n) tix_paths mixs mods $!
+            ProgramCoverage
+              ( Map.unionWith
+                  (<>)
+                  moduleMap'
+                  moduleMap
+              )
+
+-------
+
+instance ToJson (Trace.Hpc.Util.HpcPos, SBFLParameter) where
+  json :: (Trace.Hpc.Util.HpcPos, SBFLParameter) -> JsonDoc
+  json (loc, param) =
+    JSObject
+      [ ("location", JSString $ show loc),
+        ("c_ef", (JSInt . fromIntegral) (c_ef param)),
+        ("c_nf", (JSInt . fromIntegral) (c_nf param)),
+        ("c_ep", (JSInt . fromIntegral) (c_ep param)),
+        ("c_np", (JSInt . fromIntegral) (c_np param)),
+        ("scores", scores)
+      ]
+    where
+      scores :: JsonDoc
+      scores =
+        JSObject $
+          map
+            (\m -> (show m, (JSString . show) $ theMetricFun m param))
+            allMetrics
+
+data LocationTree
+  = LocationTree
+      (Trace.Hpc.Util.HpcPos, SBFLParameter) -- Main-Location
+      [(Trace.Hpc.Util.HpcPos, SBFLParameter)] -- Locations in Main-Location
+
+instance ToJson LocationTree where
+  json :: LocationTree -> JsonDoc
+  json (LocationTree ml cs) =
+    JSObject
+      [ ("main_location", json ml),
+        ("child_locations", JSArray $ map json cs)
+      ]
+
+newtype GroupedModuleCoverage = GroupedModuleCoverage [LocationTree]
+
+newtype GroupedProgramCoverage
+  = GroupedProgramCoverage
+      (Map.Map FilePath GroupedModuleCoverage)
+
+instance ToJson GroupedProgramCoverage where
+  json :: GroupedProgramCoverage -> JsonDoc
+  json (GroupedProgramCoverage gmcovs) =
+    JSArray $ map (uncurry jsonGroupedMCov) (Map.assocs gmcovs)
+    where
+      jsonGroupedMCov :: FilePath -> GroupedModuleCoverage -> JsonDoc
+      jsonGroupedMCov path (GroupedModuleCoverage locs) =
+        JSObject
+          [ ("module_src_path", JSString path),
+            ("locations", JSArray $ map json locs)
+          ]
+
+groupProgramCoverage :: ProgramCoverage -> GroupedProgramCoverage
+groupProgramCoverage (ProgramCoverage mcovs) =
+  GroupedProgramCoverage $ Map.map groupModule mcovs
+  where
+    groupModule :: ModuleCoverage -> GroupedModuleCoverage
+    groupModule (ModuleCoverage locs) =
+      GroupedModuleCoverage $ Map.foldlWithKey' insert [] locs
+
+    insert :: [LocationTree] -> Trace.Hpc.Util.HpcPos -> SBFLParameter -> [LocationTree]
+    insert [] loc param = [LocationTree (loc, param) []]
+    insert
+      (lt@(LocationTree ml@(loc2, _) cs) : lts)
+      loc1
+      param1 =
+        case (Trace.Hpc.Util.insideHpcPos loc1 loc2, Trace.Hpc.Util.insideHpcPos loc2 loc1) of
+          (False, False) -> lt : insert lts loc1 param1
+          (False, True) -> LocationTree (loc1, param1) (ml : cs) : lts -- swapping mainlocation
+          (True, False) -> LocationTree ml ((loc1, param1) : cs) : lts
+          (True, True) -> error "Multiple location with same position"
+
+----------------------------------------------------------------------------------
+
+type CodeLine = String
+
+newtype ModuleCode = ModuleCode (Map.Map Trace.Hpc.Util.HpcPos CodeLine)
+
+getModuleCode ::
+  FilePath -> -- Path to Module
+  IO ModuleCode
+getModuleCode path =
+  do
+    c <- readFile path
+    let code_lines = splitAtLineEndings c
+        locLines =
+          [ (loc, l) | (i, l) <- zip [1 ..] code_lines, let n = length l
+                                                            loc = Trace.Hpc.Util.toHpcPos (i, 1, i, n)
+          ]
+
+    pure $ ModuleCode (Map.fromList locLines)
+  where
+    splitAtLineEndings :: String -> [String]
+    splitAtLineEndings = go []
+      where
+        go :: String -> String -> [String]
+        go acc [] = [acc]
+        go acc (s : ss) =
+          if s == '\n'
+            then acc : go [] ss
+            else go (acc ++ [s]) ss
+
+newtype ProgramCode = ProgramCode (Map.Map FilePath ModuleCode)
+
+instance ToJson ProgramCode where
+  json :: ProgramCode -> JsonDoc
+  json (ProgramCode mcovs) =
+    JSArray $
+      map
+        (uncurry jsonModuleCode)
+        (Map.assocs mcovs)
+    where
+      jsonModuleCode :: FilePath -> ModuleCode -> JsonDoc
+      jsonModuleCode path (ModuleCode m) =
+        JSObject
+          [ ("module_src_path", JSString path),
+            ( "codes",
+              JSArray $
+                map
+                  (uncurry jsonCodeLine)
+                  (Map.assocs m)
+            )
+          ]
+
+      jsonCodeLine :: Trace.Hpc.Util.HpcPos -> CodeLine -> JsonDoc
+      jsonCodeLine loc l =
+        JSObject
+          [ ("location", JSString $ show loc),
+            ("code", JSString l)
+          ]
+
+getProgramCode ::
+  -- | Filepath to base directory
+  FilePath ->
+  ProgramCoverage ->
+  IO ProgramCode
+getProgramCode basepath (ProgramCoverage mcovs) =
+  let paths = Map.keys mcovs
+   in do
+        mcodes <- sequence [getModuleCode (basepath </> path) | path <- paths]
+        pure $
+          ProgramCode $
+            Map.fromListWith
+              (const $ error "Multiple modules with same Filepath")
+              (zip (Map.keys mcovs) mcodes)
+
+----------------------------------------------------------------------------------
+
+type SBFLMetric = SBFLParameter -> Float
+
+allMetrics :: [MetricFun]
+allMetrics =
+  [ OCHIAI,
+    TARANTULA,
+    JACCARD,
+    ZOLTAR,
+    OP,
+    O,
+    KULCZYNSKI2,
+    MCCON,
+    DSTAR,
+    MINUS
+  ]
+
+theMetricFun :: MetricFun -> SBFLMetric
+theMetricFun fn = case fn of
+  OCHIAI -> ochiaiMetric
+  TARANTULA -> tarantulaMetric
+  JACCARD -> jaccardMetric
+  ZOLTAR -> zoltarMetric
+  OP -> oPMetric
+  O -> oMetric
+  KULCZYNSKI2 -> kulczynski2Metric
+  MCCON -> mcConMetric
+  DSTAR -> dStarMetric
+  MINUS -> minusMetric
+
+ochiaiMetric :: SBFLMetric
+ochiaiMetric param =
+  case (c_ef param, c_nf param, c_ep param, c_np param) of
+    (0, _, 0, _) -> 0
+    (c_ef', c_nf', c_ep', _) ->
+      fromIntegral c_ef'
+        / sqrt (fromIntegral $ (c_ef' + c_nf') * (c_ef' + c_ep'))
+
+tarantulaMetric :: SBFLMetric
+tarantulaMetric param =
+  case (c_ef param, c_nf param, c_ep param, c_np param) of
+    (0, 0, 0, 0) -> undefined -- No coverage
+    (0, 0, _, _) -> 0 -- No failing tests
+    (0, _, 0, 0) -> 0
+    (_, 0, 0, 0) -> 1
+    (c_ef', c_nf', 0, 0) -> fromIntegral c_ef' / fromIntegral (c_ef' + c_nf') -- TODO: Fix
+    (c_ef', c_nf', c_ep', c_np') ->
+      (fromIntegral c_ef' / fromIntegral (c_ef' + c_nf'))
+        / ( (fromIntegral c_ef' / fromIntegral (c_ef' + c_nf'))
+              + (fromIntegral c_ep' / fromIntegral (c_ep' + c_np'))
+          )
+
+jaccardMetric :: SBFLMetric
+jaccardMetric param =
+  case (c_ef param, c_nf param, c_ep param, c_np param) of
+    (0, _, 0, _) -> 0
+    (c_ef', c_nf', c_ep', _) -> fromIntegral c_ef' / fromIntegral (c_ef' + c_nf' + c_ep')
+
+zoltarMetric :: SBFLMetric
+zoltarMetric param =
+  case (c_ef param, c_nf param, c_ep param, c_np param) of
+    (0, _, _, _) -> 0
+    (c_ef', c_nf', c_ep', _) ->
+      fromIntegral c_ef'
+        / ( fromIntegral (c_ef' + c_nf' + c_ep')
+              + fromIntegral (10000 * c_nf' * c_ef')
+                / fromIntegral c_ef'
+          )
+
+oPMetric :: SBFLMetric
+oPMetric param =
+  fromIntegral (c_ef param)
+    - (fromIntegral (c_ep param) / fromIntegral (c_ep param + c_np param + 1))
+
+oMetric :: SBFLMetric
+oMetric param =
+  if c_nf param > 0 then -1 else fromIntegral (c_np param)
+
+kulczynski2Metric :: SBFLMetric
+kulczynski2Metric param =
+  case (c_ef param, c_nf param, c_ep param, c_np param) of
+    (0, _, 0, _) -> 0
+    (c_ef', c_nf', c_ep', _) ->
+      ( (fromIntegral c_ef' / fromIntegral (c_ef' + c_nf'))
+          + (fromIntegral c_ef' / fromIntegral (c_ef' + c_ep'))
+      )
+        / 2
+
+mcConMetric :: SBFLMetric
+mcConMetric param =
+  case (c_ef param, c_nf param, c_ep param, c_np param) of
+    (0, _, 0, _) -> 0
+    (c_ef', c_nf', c_ep', _) ->
+      ((fromIntegral c_ef' ** 2) - fromIntegral (c_nf' * c_ep'))
+        / fromIntegral ((c_ef' + c_nf') * (c_ef' + c_ep'))
+
+dStarMetric :: SBFLMetric
+dStarMetric param =
+  case (c_ef param, c_nf param, c_ep param, c_np param) of
+    (_, 0, 0, _) -> 1
+    (c_ef', c_nf', c_ep', _) ->
+      fromIntegral c_ef' ** 2
+        / fromIntegral (c_nf' + c_ep') -- TODO: Make exponent variable
+
+minusMetric :: SBFLMetric
+minusMetric param =
+  case (c_ef param, c_nf param, c_ep param, c_np param) of
+    (0, 0, 0, 0) -> undefined -- No coverage
+    (0, 0, _, _) -> 0 -- No failing tests
+    (0, _, 0, 0) -> 0
+    (_, 0, 0, 0) -> 1
+    (c_ef', c_nf', 0, 0) -> fromIntegral c_ef' / fromIntegral (c_ef' + c_nf') -- TODO: Fix
+    (c_ef', c_nf', c_ep', c_np') ->
+      ( (fromIntegral c_ef' / fromIntegral (c_ef' + c_nf'))
+          / ( (fromIntegral c_ef' / fromIntegral (c_ef' + c_nf'))
+                + (fromIntegral c_ep' / fromIntegral (c_ep' + c_np'))
+            )
+      )
+        - ( (1 - (fromIntegral c_ef' / fromIntegral (c_ef' + c_nf')))
+              / ( 1
+                    - (fromIntegral c_ef' / fromIntegral (c_ef' + c_nf'))
+                    + (1 - (fromIntegral c_ep' / fromIntegral (c_ep' + c_np')))
+                )
+          )
+
+orderProgramCoverage ::
+  ProgramCoverage ->
+  SBFLMetric ->
+  [(FilePath, HpcPos, SBFLParameter)]
+orderProgramCoverage (ProgramCoverage mcovs) f =
+  let lst =
+        [ (fp, pos, param)
+          | (fp, ModuleCoverage locs) <- Map.assocs mcovs,
+            (pos, param) <- Map.assocs locs
+        ]
+   in sortBy
+        ( flip
+            ( \(_, l1, p1) (_, l2, p2) ->
+                case compare (f p1) (f p2) of
+                  EQ -> case (insideHpcPos l1 l2, insideHpcPos l2 l1) of
+                    (False, True) -> LT
+                    (True, False) -> GT
+                    _ -> EQ
+                  c -> c
+            )
+        )
+        lst
+
+printRankedLocationTable :: ProgramCoverage -> Flags -> IO ()
+printRankedLocationTable pcov flags =
+  do
+    let sortMetric = theMetricFun $ sortByMetric flags
+
+        metrics =
+          map
+            (\m -> (show m, theMetricFun m))
+            ( if Set.null (useMetrics flags)
+                then allMetrics
+                else Set.toList $ useMetrics flags
+            )
+
+        parameters =
+          if showParameters flags
+            then [("c_ef", c_ef), ("c_nf", c_nf), ("c_ep", c_ep), ("c_np", c_np)]
+            else ([] :: [(String, SBFLParameter -> Int)])
+
+        sorted = orderProgramCoverage pcov sortMetric
+        n = min (showN flags) (length sorted)
+        selected = take n sorted
+
+        n_dec = roundToN flags
+
+        label_rank = "Rank"
+        label_fp = "Module Path"
+        label_loc = "Location in Module"
+        label_params = map fst parameters
+        labels_metrics = map fst metrics
+
+        max_pos_len = max ((length . show) n) (length label_rank)
+        max_fp_len = max (maximum [length fp | (fp, _, _) <- selected]) (length label_fp)
+        max_loc_len = max (maximum [(length . show) loc | (_, loc, _) <- selected]) (length label_loc)
+        max_param_lens =
+          [ max
+              ( maximum $
+                  [ (length . show . pf) param
+                    | (_, _, param) <- selected
+                  ]
+              )
+              (length pl)
+            | (pl, pf) <- parameters
+          ]
+        max_score_lens =
+          [ max
+              ( maximum $
+                  [ (length . show . roundTo n_dec . mf) param
+                    | (_, _, param) <- selected
+                  ]
+              )
+              (length ml)
+            | (ml, mf) <- metrics
+          ]
+
+        head_rank = label_rank ++ replicate (max_pos_len - length label_rank) ' '
+        head_fp = label_fp ++ replicate (max_fp_len - length label_fp) ' '
+        head_loc = label_loc ++ replicate (max_loc_len - length label_loc) ' '
+        head_params =
+          [ pl ++ replicate (max_param_len - length pl) ' '
+            | (pl, max_param_len) <- zip label_params max_param_lens
+          ]
+        head_metrics =
+          [ ml ++ replicate (max_score_len - length ml) ' '
+            | (ml, max_score_len) <- zip labels_metrics max_score_lens
+          ]
+
+        header =
+          head_rank
+            ++ " | "
+            ++ head_fp
+            ++ " | "
+            ++ head_loc
+            ++ " || "
+            ++ intercalate " | " head_params
+            ++ (if showParameters flags then " || " else [])
+            ++ intercalate " | " head_metrics
+        hline =
+          replicate (length head_rank) '-'
+            ++ " | "
+            ++ replicate (length head_fp) '-'
+            ++ " | "
+            ++ replicate (length head_loc) '-'
+            ++ " || "
+            ++ intercalate " | " [replicate l '-' | l <- map length head_params]
+            ++ (if showParameters flags then " || " else [])
+            ++ intercalate " | " [replicate l '-' | l <- map length head_metrics]
+
+    putStrLn $ "Top " ++ show n ++ " expressions:"
+    putStrLn header
+    putStrLn hline
+    mapM_
+      putStrLn
+      [ show i
+          ++ padding_pos
+          ++ " | "
+          ++ fp
+          ++ padding_fp
+          ++ " | "
+          ++ show loc
+          ++ padding_loc
+          ++ " || "
+          ++ intercalate
+            " | "
+            [ pad_value max_param_len (pf param)
+              | ((_, pf), max_param_len) <- zip parameters max_param_lens
+            ]
+          ++ (if showParameters flags then " || " else [])
+          ++ intercalate
+            " | "
+            [ pad_value max_score_len ((roundTo n_dec . mf) param)
+              | ((_, mf), max_score_len) <- zip metrics max_score_lens
+            ]
+        | (i, (fp, loc, param)) <- zip [1 .. n] selected,
+          let padding_pos = replicate (max_pos_len - (length . show) i) ' '
+              padding_fp = replicate (max_fp_len - length fp) ' '
+              padding_loc = replicate (max_loc_len - (length . show) loc) ' '
+      ]
+  where
+    pad_value :: (Num a, Show a) => Int -> a -> String
+    pad_value n v = show v ++ replicate (n - (length . show) v) ' '
+
+    roundTo :: Int -> Float -> Float
+    roundTo n =
+      let f = 10.0 ^^ n
+       in (/ f) . fromInteger . round . (* f)