From 9ec5d2b6ba40033e1c63d61811f8362e63be862f Mon Sep 17 00:00:00 2001 From: Matthew Bauer Date: Tue, 11 Feb 2020 17:53:10 -0500 Subject: [PATCH] Avoid using maybe for filepath in ob profile --- lib/command/src/Obelisk/Command.hs | 28 ++++++++++++++++---------- lib/command/src/Obelisk/Command/Run.hs | 14 +++---------- 2 files changed, 20 insertions(+), 22 deletions(-) diff --git a/lib/command/src/Obelisk/Command.hs b/lib/command/src/Obelisk/Command.hs index 7cde61a8d..32759cfa2 100644 --- a/lib/command/src/Obelisk/Command.hs +++ b/lib/command/src/Obelisk/Command.hs @@ -13,9 +13,12 @@ import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Lazy as LBS import Data.Foldable (for_) import Data.List +import Data.Maybe import qualified Data.Text as T import Data.Text.Encoding import Data.Text.Encoding.Error (lenientDecode) +import Data.Time.Clock +import Data.Time.Format (formatTime, defaultTimeLocale) import GHC.StaticPtr import Options.Applicative import Options.Applicative.Help.Pretty (text, (<$$>)) @@ -50,8 +53,8 @@ newtype ArgsConfig = ArgsConfig { _argsConfig_enableVmBuilderByDefault :: Bool } -args :: ArgsConfig -> Parser Args -args cfg = Args <$> noHandoff <*> verbose <*> obCommand cfg +args :: ArgsConfig -> UTCTime -> Maybe FilePath -> Parser Args +args cfg time root = Args <$> noHandoff <*> verbose <*> obCommand cfg time root noHandoff :: Parser Bool noHandoff = flag False True $ mconcat @@ -67,8 +70,8 @@ verbose = flag False True $ mconcat , help "Be more verbose" ] -argsInfo :: ArgsConfig -> ParserInfo Args -argsInfo cfg = info (args cfg <**> helper) $ mconcat +argsInfo :: ArgsConfig -> UTCTime -> Maybe FilePath -> ParserInfo Args +argsInfo cfg time root = info (args cfg time root <**> helper) $ mconcat [ fullDesc , progDesc "Manage Obelisk projects" ] @@ -87,7 +90,7 @@ data ObCommand = ObCommand_Init InitSource Bool | ObCommand_Deploy DeployCommand | ObCommand_Run - | ObCommand_Profile (Maybe FilePath) + | ObCommand_Profile FilePath | ObCommand_Thunk ThunkCommand | ObCommand_Repl | ObCommand_Watch @@ -103,13 +106,13 @@ data ObInternal = ObInternal_ApplyPackages String String String [String] deriving Show -obCommand :: ArgsConfig -> Parser ObCommand -obCommand cfg = hsubparser +obCommand :: ArgsConfig -> UTCTime -> Maybe FilePath -> Parser ObCommand +obCommand cfg time root = hsubparser (mconcat [ command "init" $ info (ObCommand_Init <$> initSource <*> initForce) $ progDesc "Initialize an Obelisk project" , command "deploy" $ info (ObCommand_Deploy <$> deployCommand cfg) $ progDesc "Prepare a deployment for an Obelisk project" , command "run" $ info (pure ObCommand_Run) $ progDesc "Run current project in development mode" - , command "profile" $ info (ObCommand_Profile <$> optional (strOption ( long "output" <> short 'o' <> metavar "BASEPATH" ))) $ progDesc "Run current project with profiling enabled" + , command "profile" $ info (ObCommand_Profile <$> option auto (long "output" <> short 'o' <> help "Base output to use for profiling output. Suffixes are added to this based on the profiling type." <> showDefault <> value ((fromMaybe "" root) "profile" formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S" time) <> metavar "PATH")) $ progDesc "Run current project with profiling enabled" , command "thunk" $ info (ObCommand_Thunk <$> thunkCommand) $ progDesc "Manipulate thunk directories" , command "repl" $ info (pure ObCommand_Repl) $ progDesc "Open an interactive interpreter" , command "watch" $ info (pure ObCommand_Watch) $ progDesc "Watch current project for errors and warnings" @@ -250,8 +253,8 @@ parserPrefs = defaultPrefs { prefShowHelpOnEmpty = True } -parseCLIArgs :: ArgsConfig -> [String] -> IO Args -parseCLIArgs cfg = handleParseResult . execParserPure parserPrefs (argsInfo cfg) +parseCLIArgs :: ArgsConfig -> UTCTime -> Maybe FilePath -> [String] -> IO Args +parseCLIArgs cfg time root = handleParseResult . execParserPure parserPrefs (argsInfo cfg time root) -- | Create an Obelisk config for the current process. mkObeliskConfig :: IO Obelisk @@ -306,12 +309,15 @@ main' argsCfg = do , "logging-level=" <> show logLevel ] + time <- liftIO $ getCurrentTime + root <- findProjectRoot "." + --TODO: We'd like to actually use the parser to determine whether to hand off, --but in the case where this implementation of 'ob' doesn't support all --arguments being passed along, this could fail. For now, we don't bother --with optparse-applicative until we've done the handoff. let go as = do - args' <- liftIO $ handleParseResult (execParserPure parserPrefs (argsInfo argsCfg) as) + args' <- liftIO $ handleParseResult (execParserPure parserPrefs (argsInfo argsCfg time root) as) case _args_noHandOffPassed args' of False -> return () True -> putLog Warning "--no-handoff should only be passed once and as the first argument; ignoring" diff --git a/lib/command/src/Obelisk/Command/Run.hs b/lib/command/src/Obelisk/Command/Run.hs index a7a75745d..25d853dc9 100644 --- a/lib/command/src/Obelisk/Command/Run.hs +++ b/lib/command/src/Obelisk/Command/Run.hs @@ -24,8 +24,6 @@ import Data.Maybe import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T -import Data.Time (getCurrentTime) -import Data.Time.Format (formatTime, defaultTimeLocale) import Data.Traversable (for) import Debug.Trace (trace) import Distribution.Compiler (CompilerFlavor(..)) @@ -83,20 +81,14 @@ obRunImports = [ "import qualified Obelisk.Run" profile :: MonadObelisk m - => Maybe FilePath + => FilePath -> m () -profile mProfileBaseName = withProjectRoot "." $ \root -> do +profile profileBaseName = withProjectRoot "." $ \root -> do freePort <- getFreePort assets <- findProjectAssets root putLog Debug $ "Assets impurely loaded from: " <> assets putLog Debug "Using profiled build of project." - time <- liftIO $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S" <$> getCurrentTime - profileBaseName <- case mProfileBaseName of - Just baseName -> pure baseName - Nothing -> do - let profileDirectory = root "profile" - liftIO $ createDirectoryIfMissing False profileDirectory - pure $ profileDirectory time + liftIO $ createDirectoryIfMissing False $ takeDirectory profileBaseName let -- Sane flags to enable by default, enable time profiling + -- closure heap profiling. rtsFlags = [ "+RTS", "-p", "-po" <> profileBaseName, "-hc", "-RTS" ]