content: -- | @futhark profile@
  module Futhark.CLI.Profile (main) where
  
  import Control.Exception (catch)
  import Data.ByteString.Lazy.Char8 qualified as BS
  import Data.List qualified as L
  import Data.Map qualified as M
  import Data.Text qualified as T
  import Data.Text.IO qualified as T
  import Futhark.Bench
  import Futhark.Util (showText)
  import Futhark.Util.Options
  import System.Directory (createDirectoryIfMissing, removePathForcibly)
  import System.Exit
  import System.FilePath
  import System.IO
  import Text.Printf
  
  commonPrefix :: (Eq e) => [e] -> [e] -> [e]
  commonPrefix _ [] = []
  commonPrefix [] _ = []
  commonPrefix (x : xs) (y : ys)
    | x == y = x : commonPrefix xs ys
    | otherwise = []
  
  longestCommonPrefix :: [FilePath] -> FilePath
  longestCommonPrefix [] = ""
  longestCommonPrefix (x : xs) = foldr commonPrefix x xs
  
  memoryReport :: M.Map T.Text Integer -> T.Text
  memoryReport = T.unlines . ("Peak memory usage in bytes" :) . map f . M.toList
    where
      f (space, bytes) = space <> ": " <> showText bytes
  
  padRight :: Int -> T.Text -> T.Text
  padRight k s = s <> T.replicate (k - T.length s) " "
  
  padLeft :: Int -> T.Text -> T.Text
  padLeft k s = T.replicate (k - T.length s) " " <> s
  
  data EvSummary = EvSummary
    { evCount :: Integer,
      evSum :: Double,
      evMin :: Double,
      evMax :: Double
    }
  
  tabulateEvents :: [ProfilingEvent] -> T.Text
  tabulateEvents = mkRows . M.toList . M.fromListWith comb . map pair
    where
      pair (ProfilingEvent name dur _ _details) = (name, EvSummary 1 dur dur dur)
      comb (EvSummary xn xdur xmin xmax) (EvSummary yn ydur ymin ymax) =
        EvSummary (xn + yn) (xdur + ydur) (min xmin ymin) (max xmax ymax)
      numpad = 15
      mkRows rows =
        let longest = foldl max numpad $ map (T.length . fst) rows
            total = sum $ map (evSum . snd) rows
            header = headerRow longest
            splitter = T.map (const '-') header
            bottom =
              T.unwords
                [ showText (sum (map (evCount . snd) rows)),
                  "events with a total runtime of",
                  T.pack $ printf "%.2fμs" total
                ]
         in T.unlines $
              header
                : splitter
                : map (mkRow longest total) rows
                  <> [splitter, bottom]
      headerRow longest =
        T.unwords
          [ padLeft longest "Cost centre",
            padLeft numpad "count",
            padLeft numpad "sum",
            padLeft numpad "avg",
            padLeft numpad "min",
            padLeft numpad "max",
            padLeft numpad "fraction"
          ]
      mkRow longest total (name, ev) =
        T.unwords
          [ padRight longest name,
            padLeft numpad (showText (evCount ev)),
            padLeft numpad $ T.pack $ printf "%.2fμs" (evSum ev),
            padLeft numpad $ T.pack $ printf "%.2fμs" $ evSum ev / fromInteger (evCount ev),
            padLeft numpad $ T.pack $ printf "%.2fμs" (evMin ev),
            padLeft numpad $ T.pack $ printf "%.2fμs" (evMax ev),
            padLeft numpad $ T.pack $ printf "%.4f" (evSum ev / total)
          ]
  
  timeline :: [ProfilingEvent] -> T.Text
  timeline = T.unlines . L.intercalate [""] . map onEvent
    where
      onEvent (ProfilingEvent name duration provenance _details) =
        [ name,
          "Duration: " <> showText duration <> " μs",
          "At: " <> provenance
        ]
  
  data TargetFiles = TargetFiles
    { summaryFile :: FilePath,
      timelineFile :: FilePath
    }
  
  writeAnalysis :: TargetFiles -> ProfilingReport -> IO ()
  writeAnalysis tf r = do
    T.writeFile (summaryFile tf) $
      memoryReport (profilingMemory r)
        <> "\n\n"
        <> tabulateEvents (profilingEvents r)
    T.writeFile (timelineFile tf) $
      timeline (profilingEvents r)
  
  prepareDir :: FilePath -> IO FilePath
  prepareDir json_path = do
    let top_dir = takeFileName json_path -<.> "prof"
    T.hPutStrLn stderr $ "Writing results to " <> T.pack top_dir <> "/"
    removePathForcibly top_dir
    pure top_dir
  
  analyseProfilingReport :: FilePath -> ProfilingReport -> IO ()
  analyseProfilingReport json_path r = do
    top_dir <- prepareDir json_path
    createDirectoryIfMissing True top_dir
    let tf =
          TargetFiles
            { summaryFile = top_dir </> "summary",
              timelineFile = top_dir </> "timeline"
            }
    writeAnalysis tf r
  
  analyseBenchResults :: FilePath -> [BenchResult] -> IO ()
  analyseBenchResults json_path bench_results = do
    top_dir <- prepareDir json_path
    T.hPutStrLn stderr $ "Stripping '" <> T.pack prefix <> "' from program paths."
    mapM_ (onBenchResult top_dir) bench_results
    where
      prefix = longestCommonPrefix $ map benchResultProg bench_results
  
      -- Eliminate characters that are filesystem-meaningful.
      escape '/' = '_'
      escape c = c
  
      problem prog_name name what =
        T.hPutStrLn stderr $ prog_name <> " dataset " <> name <> ": " <> what
  
      onBenchResult top_dir (BenchResult prog_path data_results) = do
        let (prog_path', entry) = span (/= ':') prog_path
            prog_name = drop (length prefix) prog_path'
            prog_dir = top_dir </> dropExtension prog_name </> drop 1 entry
        createDirectoryIfMissing True prog_dir
        mapM_ (onDataResult prog_dir (T.pack prog_name)) data_results
  
      onDataResult _ prog_name (DataResult name (Left _)) =
        problem prog_name name "execution failed"
      onDataResult prog_dir prog_name (DataResult name (Right res)) = do
        let name' = prog_dir </> T.unpack (T.map escape name)
        case stdErr res of
          Nothing -> problem prog_name name "no log recorded"
          Just text -> T.writeFile (name' <.> ".log") text
        case report res of
          Nothing -> problem prog_name name "no profiling information"
          Just r ->
            let tf =
                  TargetFiles
                    { summaryFile = name' <> ".summary",
                      timelineFile = name' <> ".timeline"
                    }
             in writeAnalysis tf r
  
  readFileSafely :: FilePath -> IO (Either String BS.ByteString)
  readFileSafely filepath =
    (Right <$> BS.readFile filepath) `catch` couldNotRead
    where
      couldNotRead e = pure $ Left $ show (e :: IOError)
  
  onFile :: FilePath -> IO ()
  onFile json_path = do
    s <- readFileSafely json_path
    case s of
      Left a -> do
        hPutStrLn stderr a
        exitWith $ ExitFailure 2
      Right s' ->
        case decodeBenchResults s' of
          Left _ ->
            case decodeProfilingReport s' of
              Nothing -> do
                hPutStrLn stderr $
                  "Cannot recognise " <> json_path <> " as benchmark results or a profiling report."
              Just pr ->
                analyseProfilingReport json_path pr
          Right br -> analyseBenchResults json_path br
  
  -- | Run @futhark profile@.
  main :: String -> [String] -> IO ()
  main = mainWithOptions () [] "[files]" f
    where
      f files () = Just $ mapM_ onFile files
  