@@ -42,12 +42,15 @@ import Language.Haskell.Extension
4242import Network.Socket hiding (Debug)
4343import System.Directory
4444import System.Environment (getExecutablePath)
45+import System.Exit (ExitCode (ExitSuccess, ExitFailure))
4546import System.FilePath
4647import qualified System.Info
47−import System.IO.Temp (withSystemTempDirectory)
48+import System.IO (hPutStr, hFlush, hClose)
49+import System.IO.Temp (withSystemTempDirectory, withSystemTempFile)
50+import System.Process (waitForProcess)
4851
4952import Obelisk.App (MonadObelisk)
50−import Obelisk.CliApp (Severity (..) , failWith, putLog, proc, readCreateProcessWithExitCode)
53+import Obelisk.CliApp (Severity (..) , failWith, putLog, proc, readCreateProcessWithExitCode, setCwd, setDelegateCtlc, createProcess_)
5154import Obelisk.Command.Project (obeliskDirName, toObeliskDir, withProjectRoot, nixShellWithPkgs, findProjectAssets)
5255import Obelisk.Command.Thunk (attrCacheFileName)
5356import Obelisk.Command.Utils (findExePath, ghcidExePath)
@@ -71,20 +74,67 @@ data CabalPackageInfo = CabalPackageInfo
7174preprocessorIdentifier :: String
7275preprocessorIdentifier = "__preprocessor-apply-packages"
7376
74−run :: MonadObelisk m => m ()
75−run = withProjectRoot "." $ \root -> do
77+-- | Imports needed to use Obelisk.Run
78+obRunImports :: [String]
79+obRunImports = [ "import qualified Obelisk.Run"
80+ , "import qualified Frontend"
81+ , "import qualified Backend" ]
82+
83+run
84+ :: MonadObelisk m
85+ => Bool
86+ -- ^ Whether to enable profiling in the current project
87+ -> m ()
88+run profiled = withProjectRoot "." $ \root -> do
7689 pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
77− withGhciScript pkgs root $ \dotGhciPath -> do
78− freePort <- getFreePort
79− assets <- findProjectAssets root
80− putLog Debug $ "Assets impurely loaded from: " <> assets
81− runGhcid root True dotGhciPath pkgs $ Just $ unwords
82− [ "Obelisk.Run.run"
83− , show freePort
84− , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
85− , "Backend.backend"
86− , "Frontend.frontend"
87− ]
90+ freePort <- getFreePort
91+ assets <- findProjectAssets root
92+ putLog Debug $ "Assets impurely loaded from: " <> assets
93+ let obRunExpr = unwords
94+ [ "Obelisk.Run.run"
95+ , show freePort
96+ , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
97+ , "Backend.backend"
98+ , "Frontend.frontend"
99+ ]
100+ case profiled of
101+ True -> do
102+ putLog Debug "Using profiled build of project."
103+ let exeSource =
104+ unlines $
105+ [ "module Main where"
106+ , "import Control.Concurrent"
107+ , "import Control.Monad.Fix"
108+ , "import Reflex.Profiled" ]
109+ <> obRunImports <>
110+ [ "main :: IO ()"
111+ , "main = do"
112+ , " forkIO $ fix $ \\rec -> do"
113+ -- TODO: make this filename customizable
114+ , " writeProfilingData \"ob-run.rfprof\""
115+ -- write every .1 seconds.
116+ -- TODO: perhaps it should only write once at the end of ecah run
117+ , " threadDelay 10000"
118+ , " rec"
119+ , " " <> obRunExpr]
120+ -- sane flags to enable by default, enable time profiling + closure heap profiling
121+ rtsFlags = [ "+RTS", "-p", "-hc", "-RTS" ]
122+ withSystemTempFile "ob-run-profiled.hs" $ \hsFname hsHandle -> withSystemTempFile "ob-run" $ \exeFname exeHandle -> do
123+ liftIO $ hPutStr hsHandle exeSource
124+ liftIO $ hFlush hsHandle
125+ (_, _, _, ph1) <- createProcess_ "nixGhcWithProfiling" $ setCwd (Just root) $ proc "nix-shell" [ "-p", "((import ./. {}).profiled.ghc.ghcWithPackages (p: [ p.backend p.frontend]))", "--run", unwords [ "ghc", "-x", "hs", "-prof", "-fprof-auto", hsFname, "-o", exeFname ] ]
126+ code <- liftIO $ waitForProcess ph1
127+ case code of
128+ ExitSuccess -> do
129+ liftIO $ hClose exeHandle
130+ (_, _, _, ph2) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc exeFname rtsFlags
131+ _ <- liftIO $ waitForProcess ph2
132+ pure ()
133+ ExitFailure _ -> do
134+ pure ()
135+ False ->
136+ withGhciScript pkgs root $ \dotGhciPath -> do
137+ runGhcid root True dotGhciPath pkgs $ Just obRunExpr
88138
89139runRepl :: MonadObelisk m => m ()
90140runRepl = withProjectRoot "." $ \root -> do
@@ -256,15 +306,12 @@ withGhciScript packageInfos pathBase f = do
256306 , [ "Backend" | "backend" `Set.member` packageNames ]
257307 , [ "Frontend" | "frontend" `Set.member` packageNames ]
258308 ]
259− dotGhci = unlines
309+ dotGhci = unlines $
260310 -- TODO: Shell escape
261311 [ ":set -F -pgmF " <> selfExe <> " -optF " <> preprocessorIdentifier <> " " <> unwords (map (("-optF " <>) . makeRelative pathBase . _cabalPackageInfo_packageFile) packageInfos)
262312 , ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)
263313 , if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
264− , "import qualified Obelisk.Run"
265− , "import qualified Frontend"
266− , "import qualified Backend"
267− ]
314+ ] <> obRunImports
268315 withSystemTempDirectory "ob-ghci" $ \fp -> do
269316 let dotGhciPath = fp </> ".ghci"
270317 liftIO $ writeFile dotGhciPath dotGhci