clj-load-prof.hs

clj-load-prof.hs

#!/usr/bin/env stack
-- stack script --resolver lts-14.25 --install-ghc --compile

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

-- --package typed-process
-- --package unordered-containers
-- --package clock
-- --package text

import Control.Monad
import Data.Function
import Data.Int
import Data.List
import Data.Maybe
import qualified Data.Text as T
import System.Clock
import System.Environment
import System.IO
import System.Process.Typed

main :: IO ()
main = do
  args <- getArgs
  case args of
    [ns] -> do
      profile ns
    _ -> do
      putStrLn "Usage:"
      putStrLn "  clj-load-prof my-megaproject.core"

profile :: String -> IO ()
profile ns = do
  let loadExpr = "(binding [clojure.core/*loading-verbosely* true] (require '" <> ns <> "))"
      procConfig =
        proc "clj" ["-e", loadExpr]
          & setStdout createPipe
  withProcessTerm_ procConfig $ \p -> do
    let loop acc =
          hIsEOF (getStdout p) >>= \case
            True -> pure $ reverse acc
            False -> do
              TimeSpec s n <- getTime Monotonic
              l <- hGetLine (getStdout p)
              loop ((s, n, l) : acc)
    ls <- loop []
    let es = map (\(s, n, l) -> (s, n, parseEvent l)) ls
    let leaderboard = mkLeaderboard es
    mapM_ print leaderboard

data Event = LoadNS T.Text | Other
  deriving (Show, Eq, Ord)

parseEvent :: String -> Event
parseEvent (T.pack -> s) =
  case T.stripPrefix "(clojure.core/load \"/" s of
    Just (T.stripSuffix "\")" -> Just t) ->
      t
        & T.replace "_" "-"
        & T.replace "/" "."
        & LoadNS
    _ -> Other

mkLeaderboard :: [(Int64, Int64, Event)] -> [(Int64, Event)]
mkLeaderboard es =
  zipWith (\(s1, n1, e) (s2, n2, _) -> ((n2 - n1 + (s2 - s1) * 1_000_000_000) `div` 1_000_000, e)) es (drop 1 es)
    & sort