From db456b0e51bdec24f7ada0170ee08679de91020c Mon Sep 17 00:00:00 2001
From: Pepe Iborra <pepeiborra@gmail.com>
Date: Mon, 6 Jan 2020 18:56:40 +0000
Subject: [PATCH] Add a new flag --shake-profiling DIR (#307)

The flag provides a way to enable Shake profiling reports without recompiling.
Debug output prints links to the Shake reports for convenience
---
 exe/Arguments.hs                  |  2 ++
 exe/Main.hs                       |  4 +++-
 src/Development/IDE/Core/Shake.hs | 26 +++++++++++++++++---------
 3 files changed, 22 insertions(+), 10 deletions(-)

diff --git a/exe/Arguments.hs b/exe/Arguments.hs
index 8821c417..527fa882 100644
--- a/exe/Arguments.hs
+++ b/exe/Arguments.hs
@@ -11,6 +11,7 @@ data Arguments = Arguments
     ,argsCwd :: Maybe FilePath
     ,argFiles :: [FilePath]
     ,argsVersion :: Bool
+    ,argsShakeProfiling :: Maybe FilePath
     }
 
 getArguments :: IO Arguments
@@ -27,3 +28,4 @@ arguments = Arguments
       <*> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory")
       <*> many (argument str (metavar "FILES/DIRS..."))
       <*> switch (long "version" <> help "Show ghcide and GHC versions")
+      <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory")
diff --git a/exe/Main.hs b/exe/Main.hs
index 5e4fcd8b..afcd09c2 100644
--- a/exe/Main.hs
+++ b/exe/Main.hs
@@ -93,7 +93,9 @@ main = do
             -- very important we only call loadSession once, and it's fast, so just do it before starting
             session <- loadSession dir
             let options = (defaultIdeOptions $ return session)
-                    { optReportProgress = clientSupportsProgress caps }
+                    { optReportProgress = clientSupportsProgress caps 
+                    , optShakeProfiling = argsShakeProfiling
+                    }
             initialise (mainRule >> action kick) getLspId event (logger minBound) options vfs
     else do
         putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs
index 706d50d4..a2d5377b 100644
--- a/src/Development/IDE/Core/Shake.hs
+++ b/src/Development/IDE/Core/Shake.hs
@@ -53,9 +53,10 @@ import qualified Data.ByteString.Internal as BS
 import           Data.Dynamic
 import           Data.Maybe
 import Data.Map.Strict (Map)
-import           Data.List.Extra
+import           Data.List.Extra (foldl', partition, takeEnd)
 import qualified Data.Set as Set
 import qualified Data.Text as T
+import Data.Traversable (for)
 import Data.Tuple.Extra
 import Data.Unique
 import Development.IDE.Core.Debouncer
@@ -227,14 +228,15 @@ data IdeState = IdeState
 
 
 -- This is debugging code that generates a series of profiles, if the Boolean is true
-shakeRunDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> [Action a] -> IO [a]
+shakeRunDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> [Action a] -> IO ([a], Maybe FilePath)
 shakeRunDatabaseProfile mbProfileDir shakeDb acts = do
         (time, (res,_)) <- duration $ shakeRunDatabase shakeDb acts
-        whenJust mbProfileDir $ \dir -> do
-            count <- modifyVar profileCounter $ \x -> let !y = x+1 in return (y,y)
-            let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) ++ "-" ++ showDP 2 time <.> "html"
-            shakeProfileDatabase shakeDb $ dir </> file
-        return res
+        proFile <- for mbProfileDir $ \dir -> do
+                count <- modifyVar profileCounter $ \x -> let !y = x+1 in return (y,y)
+                let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) ++ "-" ++ showDP 2 time <.> "html"
+                shakeProfileDatabase shakeDb $ dir </> file
+                return (dir </> file)
+        return (res, proFile)
     where
 
 {-# NOINLINE profileStartTime #-}
@@ -392,9 +394,15 @@ shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts =
                   let res' = case res of
                           Left e -> "exception: " <> displayException e
                           Right _ -> "completed"
+                      profile = case res of
+                          Right (_, Just fp) -> 
+                              let link = case filePathToUri' $ toNormalizedFilePath fp of
+                                            NormalizedUri x -> x
+                              in ", profile saved at " <> T.unpack link
+                          _ -> ""
                   logDebug logger $ T.pack $
-                      "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ ")"
-                  signalBarrier bar res
+                      "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ profile ++ ")"
+                  signalBarrier bar (fst <$> res)
               -- important: we send an async exception to the thread, then wait for it to die, before continuing
               pure (killThread thread >> void (waitBarrier bar), either throwIO return =<< waitBarrier bar))