@@ -4,16 +4,18 @@
44{-# LANGUAGE OverloadedStrings #-}
55{-# LANGUAGE ScopedTypeVariables #-}
66{-# LANGUAGE TupleSections #-}
7+{-# LANGUAGE QuasiQuotes #-}
78module Obelisk.Command.Run where
89
910import Control.Arrow ((&&&))
1011import Control.Exception (Exception, bracket)
11−import Control.Lens (ifor)
12−import Control.Monad (filterM, unless)
12+import Control.Lens (ifor, (.~), (&))
13+import Control.Monad (filterM, unless, void)
1314import Control.Monad.Except (runExceptT, throwError)
1415import Control.Monad.IO.Class (liftIO)
1516import Control.Monad.Reader (MonadIO)
1617import Data.Coerce (coerce)
18+import Data.Default (def)
1719import Data.Either
1820import Data.Foldable (for_, toList)
1921import qualified Data.List.NonEmpty as NE
@@ -23,6 +25,8 @@ import Data.Maybe
2325import qualified Data.Set as Set
2426import Data.Text (Text)
2527import qualified Data.Text as T
28+import Data.Time.Clock (getCurrentTime)
29+import Data.Time.Format (formatTime, defaultTimeLocale)
2630import Data.Traversable (for)
2731import Debug.Trace (trace)
2832import Distribution.Compiler (CompilerFlavor(..))
@@ -47,10 +51,23 @@ import qualified System.Info
4751import System.IO.Temp (withSystemTempDirectory)
4852
4953import Obelisk.App (MonadObelisk)
50−import Obelisk.CliApp (Severity (..) , failWith, putLog, proc, readCreateProcessWithExitCode, readProcessAndLogStderr, setCwd)
51−import Obelisk.Command.Project (nixShellWithPkgs, toImplDir, withProjectRoot)
54+import Obelisk.CliApp (
55+ Severity (..),
56+ createProcess_,
57+ failWith,
58+ proc,
59+ putLog,
60+ readCreateProcessWithExitCode,
61+ readProcessAndLogStderr,
62+ setCwd,
63+ setDelegateCtlc,
64+ waitForProcess,
65+ withSpinner,
66+ )
67+import Obelisk.Command.Nix
68+import Obelisk.Command.Project (nixShellWithPkgs, toImplDir, withProjectRoot, findProjectAssets)
5269import Obelisk.Command.Thunk (attrCacheFileName)
53−import Obelisk.Command.Utils (findExePath, ghcidExePath, nixBuildExePath, nixExePath)
70+import Obelisk.Command.Utils (findExePath, ghcidExePath)
5471
5572data CabalPackageInfo = CabalPackageInfo
5673 { _cabalPackageInfo_packageFile :: FilePath
@@ -71,30 +88,49 @@ data CabalPackageInfo = CabalPackageInfo
7188preprocessorIdentifier :: String
7289preprocessorIdentifier = "__preprocessor-apply-packages"
7390
74−run :: MonadObelisk m => m ()
91+profile
92+ :: MonadObelisk m
93+ => String
94+ -> [String]
95+ -> m ()
96+profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
97+ putLog Debug "Using profiled build of project."
98+
99+ outPath <- withSpinner "Building profiled executable" $
100+ fmap (T.unpack . T.strip) $ readProcessAndLogStderr Debug $ setCwd (Just root) $ nixCmdProc $
101+ NixCmd_Build $ def
102+ & nixBuildConfig_outLink .~ OutLink_None
103+ & nixCmdConfig_target .~ Target
104+ { _target_path = Just "."
105+ , _target_attr = Just "__unstable__.profiledObRun"
106+ , _target_expr = Nothing
107+ }
108+ assets <- findProjectAssets root
109+ putLog Debug $ "Assets impurely loaded from: " <> assets
110+ time <- liftIO getCurrentTime
111+ let profileBaseName = formatTime defaultTimeLocale profileBasePattern time
112+ liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName
113+ putLog Debug $ "Storing profiled data under base name of " <> T.pack (root </> profileBaseName)
114+ freePort <- getFreePort
115+ (_, _, _, ph) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $
116+ [ show freePort
117+ , T.unpack assets
118+ , profileBaseName
119+ , "+RTS"
120+ , "-po" <> profileBaseName
121+ ] <> rtsFlags
122+ <> [ "-RTS" ]
123+ void $ waitForProcess ph
124+
125+run
126+ :: MonadObelisk m
127+ => m ()
75128run = withProjectRoot "." $ \root -> do
76129 pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
77130 withGhciScript pkgs root $ \dotGhciPath -> do
78− assets <- do
79− isDerivation <- readProcessAndLogStderr Debug $ setCwd (Just root) $
80− proc nixExePath
81− [ "eval"
82− , "(let a = import ./. {}; in toString (a.reflex.nixpkgs.lib.isDerivation a.passthru.staticFilesImpure))"
83− , "--raw"
84− -- `--raw` is not available with old nix-instantiate. It drops quotation
85− -- marks and trailing newline, so is very convenient for shelling out.
86− ]
87− -- Check whether the impure static files are a derivation (and so must be built)
88− if isDerivation == "1"
89− then fmap T.strip $ readProcessAndLogStderr Debug $ setCwd (Just root) $ -- Strip whitespace here because nix-build has no --raw option
90− proc nixBuildExePath
91− [ "--no-out-link"
92− , "-E", "(import ./. {}).passthru.staticFilesImpure"
93− ]
94− else readProcessAndLogStderr Debug $ setCwd (Just root) $
95− proc nixExePath ["eval", "-f", ".", "passthru.staticFilesImpure", "--raw"]
96− putLog Debug $ "Assets impurely loaded from: " <> assets
97131 freePort <- getFreePort
132+ assets <- findProjectAssets root
133+ putLog Debug $ "Assets impurely loaded from: " <> assets
98134 runGhcid root True dotGhciPath pkgs $ Just $ unwords
99135 [ "Obelisk.Run.run"
100136 , show freePort
@@ -289,8 +325,7 @@ withGhciScript packageInfos pathBase f = do
289325 , if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
290326 , "import qualified Obelisk.Run"
291327 , "import qualified Frontend"
292− , "import qualified Backend"
293− ]
328+ , "import qualified Backend" ]
294329 withSystemTempDirectory "ob-ghci" $ \fp -> do
295330 let dotGhciPath = fp </> ".ghci"
296331 liftIO $ writeFile dotGhciPath dotGhci