@@ -12,9 +12,11 @@ import Control.Monad
1212import Control.Monad.IO.Class (liftIO)
1313import Control.Monad.Reader (ask)
1414import qualified Data.Binary as Binary
15+import Data.Bool (bool)
1516import qualified Data.ByteString.Base16 as Base16
1617import qualified Data.ByteString.Lazy as LBS
1718import Data.List
19+import Data.Maybe (catMaybes)
1820import Data.Monoid
1921import qualified Data.Text as T
2022import Data.Text.Encoding
@@ -39,11 +41,13 @@ data Args = Args
3941 -- ^ This flag is actually handled outside of the optparse-applicative parser, but we detect whether
4042 -- it has gotten through in order to notify the user that it should only be passed once and as the very
4143 -- first argument
44+ , _args_verbose :: Bool
4245 , _args_command :: ObCommand
4346 }
47+ deriving Show
4448
4549args :: Parser Args
46−args = Args <$> noHandoff <*> obCommand
50+args = Args <$> noHandoff <*> verbose <*> obCommand
4751
4852noHandoff :: Parser Bool
4953noHandoff = flag False True $ mconcat
@@ -52,6 +56,12 @@ noHandoff = flag False True $ mconcat
5256 , hidden
5357 ]
5458
59+verbose :: Parser Bool
60+verbose = flag False True $ mconcat
61+ [ long "verbose"
62+ , help "Be more verbose"
63+ ]
64+
5565argsInfo :: ParserInfo Args
5666argsInfo = info (args <**> helper) $ mconcat
5767 [ fullDesc
@@ -73,21 +83,28 @@ data ObCommand
7383 | ObCommand_Repl FilePath
7484 | ObCommand_Watch FilePath
7585 | ObCommand_Internal ObInternal
86+ deriving Show
7687
7788data ObInternal
7889 = ObInternal_RunStaticIO StaticKey
7990 | ObInternal_CLIDemo
91+ deriving Show
8092
8193inNixShell' :: MonadObelisk m => StaticPtr (IO ()) -> m ()
8294inNixShell' p = withProjectRoot "." $ \root -> do
83− progName <- liftIO getExecutablePath
84− projectShell root False "ghc" $ unwords --TODO: shell escape
85− [ progName
86− , "--no-handoff"
87− , "internal"
88− , "run-static-io"
89− , encodeStaticKey $ staticKey p
90− ]
95+ cmd <- liftIO $ unwords <$> mkCmd -- TODO: shell escape instead of unwords
96+ projectShell root False "ghc" cmd
97+ where
98+ mkCmd = do
99+ obArgs <- getObArgs
100+ progName <- getExecutablePath
101+ return $ progName : catMaybes
102+ [ Just "--no-handoff"
103+ , bool Nothing (Just "--verbose") $ _args_verbose obArgs
104+ , Just "internal"
105+ , Just "run-static-io"
106+ , Just $ encodeStaticKey $ staticKey p
107+ ]
91108
92109obCommand :: Parser ObCommand
93110obCommand = hsubparser
@@ -96,8 +113,8 @@ obCommand = hsubparser
96113 , command "deploy" $ info (ObCommand_Deploy <$> deployCommand) $ progDesc "Prepare a deployment for an Obelisk project"
97114 , command "run" $ info (pure ObCommand_Run) $ progDesc "Run current project in development mode"
98115 , command "thunk" $ info (ObCommand_Thunk <$> thunkCommand) $ progDesc "Manipulate thunk directories"
99− , command "repl" $ info (ObCommand_Repl <$> (strArgument (action "directory"))) $ progDesc "Open an interactive interpreter"
100− , command "watch" $ info (ObCommand_Watch <$> (strArgument (action "directory")))$ progDesc "Watch directory for changes and update interactive interpreter"
116+ , command "repl" $ info (ObCommand_Repl <$> strArgument (action "directory")) $ progDesc "Open an interactive interpreter"
117+ , command "watch" $ info (ObCommand_Watch <$> strArgument (action "directory"))$ progDesc "Watch directory for changes and update interactive interpreter"
101118 ])
102119 <|> subparser
103120 (mconcat
@@ -123,6 +140,7 @@ data DeployCommand
123140 = DeployCommand_Init DeployInitOpts
124141 | DeployCommand_Push
125142 | DeployCommand_Update
143+ deriving Show
126144
127145data DeployInitOpts = DeployInitOpts
128146 { _deployInitOpts_ouputDir :: FilePath
@@ -130,6 +148,7 @@ data DeployInitOpts = DeployInitOpts
130148 , _deployInitOpts_hostname :: [String]
131149 , _deployInitOpts_remote :: String
132150 }
151+ deriving Show
133152
134153internalCommand :: Parser ObInternal
135154internalCommand = subparser $ mconcat
@@ -149,11 +168,13 @@ data ThunkPackOpts = ThunkPackOpts
149168 { _thunkPackOpts_directory :: FilePath
150169 , _thunkPackOpts_upstream :: String
151170 }
171+ deriving Show
152172
153173data ThunkCommand
154174 = ThunkCommand_Update [FilePath]
155175 | ThunkCommand_Unpack [FilePath]
156176 | ThunkCommand_Pack [ThunkPackOpts]
177+ deriving Show
157178
158179thunkPackOpts :: Parser ThunkPackOpts
159180thunkPackOpts = (ThunkPackOpts <$> thunkDirectoryParser <*>) . strOption $ mconcat
@@ -184,31 +205,38 @@ isInteractiveTerm = do
184205 inShellCompletion <- liftIO $ isInfixOf "completion" . unwords <$> getArgs
185206 return $ isTerm && not inShellCompletion
186207
187−main :: IO ()
188−main = do
189− -- We are not passing `logLevel` as cli argument (--verbose) because run-static-io does not
190− -- pass along the cli arguments to recursive obelisks.
191− logLevel <- maybe Notice read <$> lookupEnv "LOGLEVEL"
208+mkObeliskConfig :: IO Obelisk
209+mkObeliskConfig = do
210+ logLevel <- getLogLevel <$> getObArgs
192211 notInteractive <- not <$> isInteractiveTerm
193212 loggingConfig <- LoggingConfig logLevel notInteractive <$> newMVar False
194− let obeliskConfig = Obelisk notInteractive loggingConfig
195− runObelisk obeliskConfig $ ObeliskT main'
213+ return $ Obelisk notInteractive loggingConfig
214+ where
215+ getLogLevel = bool Notice Debug . _args_verbose
216+
217+getObArgs :: IO Args
218+getObArgs = getArgs >>= handleParseResult . execParserPure parserPrefs argsInfo
219+
220+main :: IO ()
221+main = mkObeliskConfig >>= (`runObelisk` ObeliskT main')
196222
197223main' :: MonadObelisk m => m ()
198224main' = do
199225 c <- ask
200− myPath <- liftIO $ fmap T.pack getExecutablePath
201− putLog Debug $ T.unwords
202− [ "Starting Obelisk <" <> myPath <> ">"
203− , "noSpinner=" <> T.pack (show $ _obelisk_noSpinner c)
204− , "logging-level=" <> T.pack (show $ _loggingConfig_level $ _obelisk_logging c)
226+ obPath <- liftIO getExecutablePath
227+ obArgs <- liftIO getObArgs
228+ putLog Debug $ T.pack $ unwords
229+ [ "Starting Obelisk <" <> obPath <> ">"
230+ , "args=" <> show obArgs
231+ , "noSpinner=" <> show (_obelisk_noSpinner c)
232+ , "logging-level=" <> show (_loggingConfig_level $ _obelisk_logging c)
205233 ]
206234
207− myArgs <- liftIO getArgs
208235 --TODO: We'd like to actually use the parser to determine whether to hand off,
209236 --but in the case where this implementation of 'ob' doesn't support all
210237 --arguments being passed along, this could fail. For now, we don't bother
211238 --with optparse-applicative until we've done the handoff.
239+ myArgs <- liftIO getArgs
212240 let go as = do
213241 args' <- liftIO $ handleParseResult (execParserPure parserPrefs argsInfo as)
214242 case _args_noHandOffPassed args' of