Use optparse-applicative for all argument parsing

parser-typechecker/package.yaml

@@ -32,7 +32,6 @@ library:
   dependencies:
     - aeson
     - ansi-terminal
-    - ansi-wl-pprint
     - async
     - base
     - base16 >= 0.2.1.0
@@ -73,8 +72,8 @@ library:
     - network
     - network-simple
     - nonempty-containers
+    - optparse-applicative >= 0.16.1.0
     - openapi3
-    - optparse-applicative
     - pem
     - process
     - primitive
@@ -132,6 +131,7 @@ executables:
       - lens
       - megaparsec
       - mtl
+      - optparse-applicative >= 0.16.1.0
       - safe
       - shellmet
       - template-haskell

parser-typechecker/src/Unison/CommandLine/ArgParse.hs

@@ -1,117 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
--- |
--- The Options module defines the command line options available when invoking unison
---
--- It is built using https://hackage.haskell.org/package/optparse-applicative
--- which has a pretty good guide that should explain everything in this module
-module Unison.CommandLine.ArgParse where
-
-import Control.Applicative ((<**>), (<|>), some)
-import Options.Applicative
-import Text.PrettyPrint.ANSI.Leijen ((<$$>), (<+>), (</>), Doc, bold, hardline)
-import Data.Foldable
-
--- Unfortunately we can't use a global --codebase option so we have
--- to add it to all Commands that needs it
--- see https://github.com/pcapriotti/optparse-applicative/issues/294
-type Codebase = Maybe FilePath
-
-data Command
-  = Launch Codebase
-  | Version
-  | Init Codebase
-  | Run Codebase (Maybe FilePath) Stdin String
-  | Transcript Codebase Fork SaveCodebase [FilePath]
-  deriving (Show)
-
-newtype Stdin = Stdin Bool
-  deriving (Show)
-
-newtype Fork = Fork Bool
-  deriving (Show)
-
-newtype SaveCodebase = SaveCodebase Bool
-  deriving (Show)
-
-options :: ParserInfo Command
-options = info (options' <**> helper) (progDescDoc unisonHelp)
-
-unisonHelp :: Maybe Doc
-unisonHelp =
-  Just $
-    "Usage instructions for the Unison Codebase Manager"
-      <> hardline
-      <> hardline
-      <> "To get started just run " <+> bold "unison" <+> "to enter interactive mode"
-      <$$> mempty
-      </> "Unison has various sub-commands (see Available commands) but by default will run in interactive mode"
-      </> "Use" <+> bold "unison command --help" <+> "to show help for a command"
-      <> hardline
-      <> hardline
-      <> "Most commands take the option" <+> bold "--codebase" <+> "which expects a path to a unison codebase"
-      </> "If none is provided then the home directory is used"
-
-codebaseHelp :: Maybe Doc
-codebaseHelp = Just "The path to the codebase, defaults to the home directory"
-
-options' :: Parser Command
-options' =
-  hsubparser commands <|> launchCommand
-  where
-    commands = 
-      fold [ versionCommand
-           , initCommand
-           , runCommand
-           , transcriptCommand
-           ]
-
-versionCommand :: Mod CommandFields Command
-versionCommand = command "version" (info (pure Version) (progDesc "print the version of unison"))
-
-initCommand :: Mod CommandFields Command
-initCommand = command "init" (info (Init <$> optional (strOption (long "codebase" <> helpDoc codebaseHelp))) (progDesc initHelp))
-  where
-    initHelp = "Initialise a unison codebase"
-
-runCommand :: Mod CommandFields Command
-runCommand = command "run" (info run (progDescDoc runHelp))
-  where
-    runHelp = Just "Execute a definition from a file, stdin or the codebase"
-
-transcriptCommand :: Mod CommandFields Command
-transcriptCommand = command "transcript" (info transcript (progDesc transcriptHelp <> footerDoc transcriptFooter))
-  where
-    transcriptHelp = "Execute transcript markdown files"
-    transcriptFooter =
-      Just $
-        "For each transcript file provided this executes the transcript and creates"
-          <+> bold "mytranscript.output.md"
-          <+> "if successful."
-          </> "Exits after completion, and deletes the temporary directory created."
-          </> "Multiple transcript files may be provided; they are processed in sequence"
-          <+> "starting from the same codebase."
-
-launchCommand :: Parser Command
-launchCommand = (Launch <$> optional (strOption (long "codebase" <> helpDoc codebaseHelp)))
-
-run :: Parser Command
-run =
-  Run <$> optional (strOption (long "codebase" <> helpDoc codebaseHelp))
-    <*> optional (strOption (long "file" <> helpDoc fileHelp))
-    <*> (Stdin <$> switch (long "stdin" <> helpDoc pipeHelp))
-    <*> strArgument (help mainHelp <> metavar ".mylib.mymain")
-  where
-    fileHelp = Just $ "the file containing" <+> bold ".mylib.mymain" <+> "- if not provided then the codebase will be used"
-    pipeHelp = Just $ "read the definition from stdin, usefull for piping to unison"
-    mainHelp = "the main method"
-
-transcript :: Parser Command
-transcript =
-  Transcript <$> optional (strOption (long "codebase" <> helpDoc codebaseHelp))
-    <*> (Fork <$> switch (long "fork" <> helpDoc forkHelp))
-    <*> (SaveCodebase <$> switch (long "save-codebase" <> helpDoc saveHelp))
-    <*> some (strArgument (metavar "transcriptfiles..."))
-  where
-    forkHelp = Just "if set the transcript is executed in a copy of the current codebase"
-    saveHelp = Just "if set the resulting codebase will be saved to a new directory, otherwise it will be deleted"

parser-typechecker/unison-parser-typechecker.cabal

@@ -80,7 +80,6 @@ library
       Unison.Codebase.TypeEdit
       Unison.Codebase.Watch
       Unison.CommandLine
-      Unison.CommandLine.ArgParse
       Unison.CommandLine.DisplayValues
       Unison.CommandLine.InputPattern
       Unison.CommandLine.InputPatterns
@@ -181,7 +180,6 @@ library
       ListLike
     , aeson
     , ansi-terminal
-    , ansi-wl-pprint
     , async
     , base
     , base16 >=0.2.1.0
@@ -222,7 +220,7 @@ library
     , network-simple
     , nonempty-containers
     , openapi3
-    , optparse-applicative
+    , optparse-applicative >=0.16.1.0
     , pem
     , primitive
     , process
@@ -420,6 +418,8 @@ executable transcripts
 executable unison
   main-is: Main.hs
   other-modules:
+      ArgParse
+      Compat
       System.Path
       Version
       Paths_unison_parser_typechecker
@@ -450,6 +450,7 @@ executable unison
     , lens
     , megaparsec
     , mtl
+    , optparse-applicative >=0.16.1.0
     , safe
     , shellmet
     , template-haskell

parser-typechecker/unison/ArgParse.hs

@@ -0,0 +1,263 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+
+-- | This module handles parsing CLI arguments into 'Command's.
+-- See the excellent documentation at https://hackage.haskell.org/package/optparse-applicative
+module ArgParse where
+
+import Options.Applicative
+    ( optional,
+      (<**>),
+      action,
+      columns,
+      command,
+      flag,
+      flag',
+      footerDoc,
+      help,
+      info,
+      long,
+      metavar,
+      prefs,
+      progDesc,
+      showHelpOnError,
+      strArgument,
+      strOption,
+      customExecParser,
+      helper,
+      hsubparser,
+      parserFailure,
+      renderFailure,
+      Alternative(some, (<|>)),
+      CommandFields,
+      Mod,
+      ParseError(ShowHelpText),
+      Parser,
+      ParserInfo,
+      ParserPrefs, fullDesc, headerDoc )
+import Options.Applicative.Help ( (<+>), bold )
+import Data.Foldable ( Foldable(fold) )
+import qualified Options.Applicative.Help.Pretty as P
+import qualified Unison.PrettyTerminal as PT
+import qualified Data.List as List
+import Unison.Util.Pretty (Width(..))
+
+-- The name of a symbol to execute.
+type SymbolName = String
+
+-- | Valid ways to provide source code to the run command
+data RunSource =
+    RunFromPipe SymbolName
+  | RunFromSymbol SymbolName
+  | RunFromFile FilePath SymbolName
+  deriving (Show)
+
+data ShouldForkCodebase
+    = UseFork
+    | DontFork
+    deriving (Show, Eq)
+
+data ShouldSaveCodebase
+    = SaveCodebase
+    | DontSaveCodebase
+    deriving (Show, Eq)
+
+data IsHeadless = Headless | WithCLI
+  deriving (Show, Eq)
+
+data Command
+  = Launch IsHeadless
+  | PrintVersion
+  | Init
+  | Run RunSource
+  | Transcript ShouldForkCodebase ShouldSaveCodebase [FilePath]
+  | UpgradeCodebase
+  deriving (Show)
+
+data CodebaseFormat
+    = V1
+    | V2
+    deriving (Show, Eq)
+
+data GlobalOptions = GlobalOptions
+  { codebasePath :: Maybe FilePath
+  , codebaseFormat :: CodebaseFormat
+  } deriving (Show)
+
+rootParserInfo :: String -> String -> ParserInfo (GlobalOptions, Command)
+rootParserInfo progName version =
+    info ((,) <$> globalOptionsParser <*> commandParser <**> helper)
+         (  fullDesc
+         <> headerDoc (Just $ unisonHelp progName version))
+
+type UsageRenderer =
+    Maybe String -- ^ Optional sub-command to render help for
+    -> String
+
+parseCLIArgs :: String -> String -> IO (UsageRenderer, GlobalOptions, Command)
+parseCLIArgs progName version = do
+  (Width cols) <- PT.getAvailableWidth
+  let parserInfo = rootParserInfo progName version
+  let preferences = prefs $ showHelpOnError <> columns cols
+  (globalOptions, command) <- customExecParser preferences parserInfo
+  let usage = renderUsage progName parserInfo preferences
+  pure $ (usage, globalOptions, command)
+
+renderUsage :: String -> ParserInfo a -> ParserPrefs -> Maybe String -> String
+renderUsage programName pInfo preferences subCommand =
+    let showHelpFailure = parserFailure preferences pInfo (ShowHelpText subCommand) mempty
+        (helpText, _exitCode) = renderFailure showHelpFailure programName
+     in helpText
+
+commandParser :: Parser Command
+commandParser =
+  hsubparser commands <|> launchParser
+  where
+    commands =
+      fold [ versionCommand
+           , initCommand
+           , runSymbolCommand
+           , runFileCommand
+           , runPipeCommand
+           , transcriptCommand
+           , transcriptForkCommand
+           , upgradeCodebaseCommand
+           , launchHeadlessCommand
+           ]
+
+globalOptionsParser :: Parser GlobalOptions
+globalOptionsParser = do -- ApplicativeDo
+    codebasePath <- codebasePathParser
+    codebaseFormat <- codebaseFormatParser
+    pure GlobalOptions{..}
+
+codebasePathParser :: Parser (Maybe FilePath)
+codebasePathParser =
+    optional . strOption $
+         long "codebase"
+      <> metavar "path/to/codebase"
+      <> help "The path to the codebase, defaults to the home directory"
+
+codebaseFormatParser :: Parser CodebaseFormat
+codebaseFormatParser =
+        flag' V1 (long "old-codebase" <> help "Use a v1 codebase on startup.")
+    <|> flag' V2 (long "new-codebase" <> help "Use a v2 codebase on startup.")
+    <|> pure V2
+
+launchHeadlessCommand :: Mod CommandFields Command
+launchHeadlessCommand =
+    command "headless" (info launchHeadlessParser (progDesc headlessHelp))
+  where
+    headlessHelp = "Runs the codebase server without the command-line interface."
+
+versionCommand :: Mod CommandFields Command
+versionCommand = command "version" (info versionParser (fullDesc <> progDesc "Print the version of unison you're running"))
+
+initCommand :: Mod CommandFields Command
+initCommand = command "init" (info initParser (progDesc initHelp))
+  where
+    initHelp = "Initialise a unison codebase"
+
+runSymbolCommand :: Mod CommandFields Command
+runSymbolCommand =
+    command "run" (info runSymbolParser (fullDesc <> progDesc "Execute a definition from the codebase"))
+
+runFileCommand :: Mod CommandFields Command
+runFileCommand =
+    command "run.file" (info runFileParser (fullDesc <> progDesc "Execute a definition from a file"))
+
+runPipeCommand :: Mod CommandFields Command
+runPipeCommand =
+    command "run.pipe" (info runPipeParser (fullDesc <> progDesc "Execute code from stdin"))
+
+transcriptCommand :: Mod CommandFields Command
+transcriptCommand =
+    command "transcript" (info transcriptParser (fullDesc <> progDesc transcriptHelp <> footerDoc transcriptFooter))
+  where
+    transcriptHelp = "Execute transcript markdown files"
+    transcriptFooter =
+      Just . fold . List.intersperse P.line $
+        [ "For each <transcript>.md file provided this executes the transcript and creates" <+> bold "<transcript>.output.md" <+> "if successful."
+        , "Exits after completion, and deletes the temporary directory created, unless --save-codebase is provided"
+        , "Multiple transcript files may be provided; they are processed in sequence" <+> "starting from the same codebase."
+        ]
+
+transcriptForkCommand :: Mod CommandFields Command
+transcriptForkCommand =
+    command "transcript.fork" (info transcriptForkParser (fullDesc <> progDesc transcriptHelp <> footerDoc transcriptFooter))
+  where
+    transcriptHelp = "Execute transcript markdown files in a sandboxed codebase"
+    transcriptFooter =
+      Just . fold . List.intersperse P.line $
+        [ "For each <transcript>.md file provided this executes the transcript in a sandbox codebase and creates" <+> bold "<transcript>.output.md" <+> "if successful."
+        , "Exits after completion, and deletes the temporary directory created, unless --save-codebase is provided"
+        , "Multiple transcript files may be provided; they are processed in sequence" <+> "starting from the same codebase."
+        ]
+
+upgradeCodebaseCommand :: Mod CommandFields Command
+upgradeCodebaseCommand =
+    command "upgrade-codebase" (info (pure UpgradeCodebase) (fullDesc <> progDesc "Upgrades a v1 codebase to a v2 codebase"))
+
+launchParser :: Parser Command
+launchParser = pure (Launch WithCLI)
+
+launchHeadlessParser :: Parser Command
+launchHeadlessParser = pure (Launch Headless)
+
+initParser :: Parser Command
+initParser = pure Init
+
+versionParser :: Parser Command
+versionParser = pure PrintVersion
+
+runSymbolParser :: Parser Command
+runSymbolParser =
+  Run . RunFromSymbol <$> strArgument (metavar "SYMBOL")
+
+runFileParser :: Parser Command
+runFileParser = do -- ApplicativeDo
+  pathTofile <- strArgument (metavar "path/to/file")
+  symbolName <- strArgument (metavar "SYMBOL")
+  pure $ Run (RunFromFile pathTofile symbolName)
+
+runPipeParser :: Parser Command
+runPipeParser =
+  Run . RunFromPipe <$> strArgument (metavar "SYMBOL")
+
+saveCodebaseFlag :: Parser ShouldSaveCodebase
+saveCodebaseFlag = flag DontSaveCodebase SaveCodebase (long "save-codebase" <> help saveHelp)
+  where
+    saveHelp = "if set the resulting codebase will be saved to a new directory, otherwise it will be deleted"
+
+filesArgument :: Parser [FilePath]
+filesArgument = some (strArgument (  metavar "FILES..."
+                                  <> action "file" -- Autocomplete file names
+                                  ))
+
+transcriptParser :: Parser Command
+transcriptParser = do -- ApplicativeDo
+  shouldSaveCodebase <- saveCodebaseFlag
+  files <- filesArgument
+  pure (Transcript DontFork shouldSaveCodebase files)
+
+transcriptForkParser :: Parser Command
+transcriptForkParser = do -- ApplicativeDo
+  shouldSaveCodebase <- saveCodebaseFlag
+  files <- filesArgument
+  pure (Transcript UseFork shouldSaveCodebase files)
+
+unisonHelp :: String -> String -> P.Doc
+unisonHelp (P.text -> executable) (P.text -> version) =
+  fold . List.intersperse P.line $
+    [ P.empty
+    , "🌻"
+    , P.empty
+    , P.bold "Usage instructions for the Unison Codebase Manager"
+    , "You are running version:" <+> version
+    , P.empty
+    , "To get started just run" <+> P.bold executable
+    , P.empty
+    , "Use" <+> P.bold (executable <+> "[command] --help") <+> "to show help for a command."
+    ]

parser-typechecker/unison/Compat.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE CPP #-}
+module Compat where
+
+import Control.Concurrent (mkWeakThreadId, myThreadId)
+import Control.Exception (AsyncException (UserInterrupt), throwTo)
+import System.Mem.Weak (deRefWeak)
+
+#if defined(mingw32_HOST_OS)
+import qualified GHC.ConsoleHandler as WinSig
+#else
+import qualified System.Posix.Signals as Sig
+#endif
+
+installSignalHandlers :: IO ()
+installSignalHandlers = do
+  main_thread <- myThreadId
+  wtid <- mkWeakThreadId main_thread
+  let interrupt = do
+        r <- deRefWeak wtid
+        case r of
+          Nothing -> return ()
+          Just t  -> throwTo t UserInterrupt
+
+#if defined(mingw32_HOST_OS)
+  let sig_handler WinSig.ControlC = interrupt
+      sig_handler WinSig.Break    = interrupt
+      sig_handler _               = return ()
+  _ <- WinSig.installHandler (WinSig.Catch sig_handler)
+#else
+  _ <- Sig.installHandler Sig.sigQUIT  (Sig.Catch interrupt) Nothing
+  _ <- Sig.installHandler Sig.sigINT   (Sig.Catch interrupt) Nothing
+#endif
+  return ()

parser-typechecker/unison/Main.hs

@@ -1,34 +1,26 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ApplicativeDo #-}
 {-# OPTIONS_GHC -Wno-partial-type-signatures #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 module Main where
 
-#if defined(mingw32_HOST_OS)
-import qualified GHC.ConsoleHandler as WinSig
-#else
-import qualified System.Posix.Signals as Sig
-#endif
-
-import Control.Concurrent (mkWeakThreadId, myThreadId, newEmptyMVar, takeMVar)
+import Control.Concurrent (newEmptyMVar, takeMVar)
 import Control.Error.Safe (rightMay)
-import Control.Exception (AsyncException (UserInterrupt), throwTo)
 import Data.ByteString.Char8 (unpack)
 import Data.Configurator.Types (Config)
 import qualified Data.Text as Text
 import qualified GHC.Conc
 import qualified Network.URI.Encode as URI
 import System.Directory (canonicalizePath, getCurrentDirectory, removeDirectoryRecursive)
-import System.Environment (getArgs, getProgName)
+import System.Environment (getProgName)
 import qualified System.Exit as Exit
 import qualified System.FilePath as FP
 import System.IO.Error (catchIOError)
 import qualified System.IO.Temp as Temp
-import System.Mem.Weak (deRefWeak)
 import qualified System.Path as Path
 import Text.Megaparsec (runParser)
 import qualified Unison.Codebase as Codebase
@@ -53,80 +45,49 @@ import Unison.Symbol (Symbol)
 import qualified Unison.Util.Pretty as P
 import qualified Version
 import qualified Unison.Codebase.Conversion.Upgrade12 as Upgrade12
-
-installSignalHandlers :: IO ()
-installSignalHandlers = do
-  main_thread <- myThreadId
-  wtid <- mkWeakThreadId main_thread
-  let interrupt = do
-        r <- deRefWeak wtid
-        case r of
-          Nothing -> return ()
-          Just t  -> throwTo t UserInterrupt
-
-#if defined(mingw32_HOST_OS)
-  let sig_handler WinSig.ControlC = interrupt
-      sig_handler WinSig.Break    = interrupt
-      sig_handler _               = return ()
-  _ <- WinSig.installHandler (WinSig.Catch sig_handler)
-#else
-  _ <- Sig.installHandler Sig.sigQUIT  (Sig.Catch interrupt) Nothing
-  _ <- Sig.installHandler Sig.sigINT   (Sig.Catch interrupt) Nothing
-#endif
-  return ()
-
-
-data CodebaseFormat = V1 | V2 deriving (Eq)
+import Compat
+import ArgParse
 
 cbInitFor :: CodebaseFormat -> Codebase.Init IO Symbol Ann
 cbInitFor = \case V1 -> FC.init; V2 -> SC.init
 
 main :: IO ()
 main = do
-  args <- getArgs
   progName <- getProgName
   -- hSetBuffering stdout NoBuffering -- cool
 
   void installSignalHandlers
-  option <- customExecParser (prefs showHelpOnError) Options.options
-  -- We need to know whether the program was invoked with -codebase for
-  -- certain messages. Therefore we keep a Maybe FilePath - mcodepath
-  -- rather than just deciding on whether to use the supplied path or
-  -- the home directory here and throwing away that bit of information
-  let (mcodepath, restargs0) = case args of
-           "-codebase" : codepath : restargs -> (Just codepath, restargs)
-           _                                 -> (Nothing, args)
-      (fromMaybe V2 -> cbFormat, restargs) = case restargs0 of
-           "--new-codebase" : rest -> (Just V2, rest)
-           "--old-codebase" : rest -> (Just V1, rest)
-           _ -> (Nothing, restargs0)
-      cbInit = case cbFormat of V1 -> FC.init; V2 -> SC.init
+  (renderUsageInfo, globalOptions, command) <- parseCLIArgs progName Version.gitDescribe
+  let GlobalOptions{codebasePath=mcodepath, codebaseFormat=cbFormat} = globalOptions
+  let cbInit = cbInitFor cbFormat
   currentDir <- getCurrentDirectory
   configFilePath <- getConfigFilePath mcodepath
   config <-
     catchIOError (watchConfig configFilePath) $ \_ ->
       Exit.die "Your .unisonConfig could not be loaded. Check that it's correct!"
-  case restargs of
-    [version] | isFlag "version" version ->
-      putStrLn $ progName ++ " version: " ++ Version.gitDescribe
-    [help] | isFlag "help" help -> PT.putPrettyLn (usage progName)
-    ["init"] -> Codebase.initCodebaseAndExit cbInit "main.init" mcodepath
-    "run" : [mainName] -> do
+  case command of
+     PrintVersion ->
+       putStrLn $ progName ++ " version: " ++ Version.gitDescribe
+     Init ->
+       Codebase.initCodebaseAndExit cbInit "main.init" mcodepath
+     Run (RunFromSymbol mainName) -> do
       (closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath
       runtime <- RTI.startRuntime
       execute theCodebase runtime mainName
       closeCodebase
-    "run.file" : file : [mainName] | isDotU file -> do
-      e <- safeReadUtf8 file
-      case e of
-        Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I couldn't find that file or it is for some reason unreadable."
-        Right contents -> do
-          (closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath
-          rt <- RTI.startRuntime
-          let fileEvent = Input.UnisonFileChanged (Text.pack file) contents
-          launch currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName, Right Input.QuitI]
-          closeCodebase
-    "run.pipe" : [mainName] -> do
+     Run (RunFromFile file mainName)
+       | not (isDotU file) -> PT.putPrettyLn $ P.callout "⚠️" "I couldn't find that file or it is for some reason unreadable."
+       | otherwise -> do
+            e <- safeReadUtf8 file
+            case e of
+              Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I couldn't find that file or it is for some reason unreadable."
+              Right contents -> do
+                (closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath
+                rt <- RTI.startRuntime
+                let fileEvent = Input.UnisonFileChanged (Text.pack file) contents
+                launch currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName, Right Input.QuitI]
+                closeCodebase
+     Run (RunFromPipe mainName) -> do
       e <- safeReadUtf8StdIn
       case e of
         Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I had trouble reading this input."
@@ -138,39 +99,32 @@ main = do
             currentDir config rt theCodebase
             [Left fileEvent, Right $ Input.ExecuteI mainName, Right Input.QuitI]
           closeCodebase
-    "transcript" : args' ->
-      case args' of
-      "-save-codebase" : transcripts -> runTranscripts cbFormat False True mcodepath transcripts
-      _                              -> runTranscripts cbFormat False False mcodepath args'
-    "transcript.fork" : args' ->
-      case args' of
-      "-save-codebase" : transcripts -> runTranscripts cbFormat True True mcodepath transcripts
-      _                              -> runTranscripts cbFormat True False mcodepath args'
-    ["upgrade-codebase"] -> upgradeCodebase mcodepath
-    args -> do
-      let headless = listToMaybe args == Just "headless"
-      (closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath
-      runtime <- RTI.startRuntime
-      Server.start runtime theCodebase $ \token port -> do
-        let url =
-             "http://127.0.0.1:" <> show port <> "/" <> URI.encode (unpack token)
-        when headless $
-          PT.putPrettyLn $ P.lines
-            ["I've started the codebase API server at" , P.string $ url <> "/api"]
-        PT.putPrettyLn $ P.lines
-          ["The Unison Codebase UI is running at", P.string $ url <> "/ui"]
-        if headless then do
-          PT.putPrettyLn $ P.string "Running the codebase manager headless with "
-            <> P.shown GHC.Conc.numCapabilities
-            <> " "
-            <> plural' GHC.Conc.numCapabilities "cpu" "cpus"
-            <> "."
-          mvar <- newEmptyMVar
-          takeMVar mvar
-        else do
-          PT.putPrettyLn $ P.string "Now starting the Unison Codebase Manager..."
-          launch currentDir config runtime theCodebase []
-          closeCodebase
+     Transcript shouldFork shouldSaveCodebase transcriptFiles ->
+       runTranscripts renderUsageInfo cbFormat shouldFork shouldSaveCodebase mcodepath transcriptFiles
+     UpgradeCodebase -> upgradeCodebase mcodepath
+     Launch isHeadless -> do
+       (closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath
+       runtime <- RTI.startRuntime
+       Server.start runtime theCodebase $ \token port -> do
+         let url =
+              "http://127.0.0.1:" <> show port <> "/" <> URI.encode (unpack token)
+         PT.putPrettyLn $ P.lines
+           ["The Unison Codebase UI is running at", P.string $ url <> "/ui"]
+         case isHeadless of
+             Headless -> do
+                 PT.putPrettyLn $ P.lines
+                    ["I've started the codebase API server at" , P.string $ url <> "/api"]
+                 PT.putPrettyLn $ P.string "Running the codebase manager headless with "
+                     <> P.shown GHC.Conc.numCapabilities
+                     <> " "
+                     <> plural' GHC.Conc.numCapabilities "cpu" "cpus"
+                     <> "."
+                 mvar <- newEmptyMVar
+                 takeMVar mvar
+             WithCLI -> do
+                 PT.putPrettyLn $ P.string "Now starting the Unison Codebase Manager..."
+                 launch currentDir config runtime theCodebase []
+                 closeCodebase
 
 upgradeCodebase :: Maybe Codebase.CodebasePath -> IO ()
 upgradeCodebase mcodepath =
@@ -189,21 +143,22 @@ upgradeCodebase mcodepath =
       <> "but there's no rush.  You can access the old codebase again by passing the"
       <> P.backticked "--old-codebase" <> "flag at startup."
 
-prepareTranscriptDir :: CodebaseFormat -> Bool -> Maybe FilePath -> IO FilePath
-prepareTranscriptDir cbFormat inFork mcodepath = do
+prepareTranscriptDir :: CodebaseFormat -> ShouldForkCodebase -> Maybe FilePath -> IO FilePath
+prepareTranscriptDir cbFormat shouldFork mcodepath = do
   tmp <- Temp.getCanonicalTemporaryDirectory >>= (`Temp.createTempDirectory` "transcript")
   let cbInit = cbInitFor cbFormat
-  if inFork then
-    getCodebaseOrExit cbFormat mcodepath >> do
-    path <- Codebase.getCodebaseDir mcodepath
-    PT.putPrettyLn $ P.lines [
-      P.wrap "Transcript will be run on a copy of the codebase at: ", "",
-      P.indentN 2 (P.string path)
-      ]
-    Path.copyDir (Codebase.codebasePath cbInit path) (Codebase.codebasePath cbInit tmp)
-  else do
-    PT.putPrettyLn . P.wrap $ "Transcript will be run on a new, empty codebase."
-    void $ Codebase.openNewUcmCodebaseOrExit cbInit "main.transcript" tmp
+  case shouldFork of
+    UseFork -> do
+      getCodebaseOrExit cbFormat mcodepath
+      path <- Codebase.getCodebaseDir mcodepath
+      PT.putPrettyLn $ P.lines [
+        P.wrap "Transcript will be run on a copy of the codebase at: ", "",
+        P.indentN 2 (P.string path)
+        ]
+      Path.copyDir (Codebase.codebasePath cbInit path) (Codebase.codebasePath cbInit tmp)
+    DontFork -> do
+      PT.putPrettyLn . P.wrap $ "Transcript will be run on a new, empty codebase."
+      void $ Codebase.openNewUcmCodebaseOrExit cbInit "main.transcript" tmp
   pure tmp
 
 runTranscripts'
@@ -245,32 +200,34 @@ runTranscripts' codebaseFormat mcodepath transcriptDir args = do
       pure False
 
 runTranscripts
-  :: CodebaseFormat
-  -> Bool
-  -> Bool
+  :: UsageRenderer
+  -> CodebaseFormat
+  -> ShouldForkCodebase
+  -> ShouldSaveCodebase
   -> Maybe FilePath
   -> [String]
   -> IO ()
-runTranscripts cbFormat inFork keepTemp mcodepath args = do
+runTranscripts renderUsageInfo cbFormat shouldFork shouldSaveTempCodebase mcodepath args = do
   progName <- getProgName
-  transcriptDir <- prepareTranscriptDir cbFormat inFork mcodepath
+  transcriptDir <- prepareTranscriptDir cbFormat shouldFork mcodepath
   completed <-
     runTranscripts' cbFormat (Just transcriptDir) transcriptDir args
-  when completed $ do
-    unless keepTemp $ removeDirectoryRecursive transcriptDir
-    when keepTemp $ PT.putPrettyLn $
-        P.callout "🌸" (
-          P.lines [
-            "I've finished running the transcript(s) in this codebase:", "",
-            P.indentN 2 (P.string transcriptDir), "",
-            P.wrap $ "You can run"
-                  <> P.backticked (P.string progName <> " -codebase " <> P.string transcriptDir)
-                  <> "to do more work with it."])
-
-  unless completed $ do
-      unless keepTemp $ removeDirectoryRecursive transcriptDir
-      PT.putPrettyLn (usage progName)
-      Exit.exitWith (Exit.ExitFailure 1)
+  case shouldSaveTempCodebase of
+    DontSaveCodebase -> removeDirectoryRecursive transcriptDir
+    SaveCodebase ->
+      if completed
+        then
+          PT.putPrettyLn $
+            P.callout "🌸" (
+              P.lines [
+                "I've finished running the transcript(s) in this codebase:", "",
+                P.indentN 2 (P.string transcriptDir), "",
+                P.wrap $ "You can run"
+                      <> P.backticked (P.string progName <> " -codebase " <> P.string transcriptDir)
+                      <> "to do more work with it."])
+        else do
+          putStrLn (renderUsageInfo $ Just "transcript")
+          Exit.exitWith (Exit.ExitFailure 1)
 
 initialPath :: Path.Absolute
 initialPath = Path.absoluteEmpty

stack.yaml

@@ -46,6 +46,7 @@ extra-deps:
 - Cabal-3.2.1.0
 - fuzzyfind-3.0.0
 - monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505
+- optparse-applicative-0.16.1.0 # We need some features from the most recent revision
 
 ghc-options:
  # All packages