Add a --color command line option

This command has three options: 'auto', 'none', and 'always'. They're
fairly self explanatory. 'auto' is the default, and detects that the
terminal output is not equal to `dumb`, and that `stdout` is a
terminal handle.

The choice of option has no impact on whether the title sequence is
sent to the ANSI terminal. That is always detected automatically and
independently of this option.

Signed-off-by: Austin Seipp <aseipp@pobox.com>

cryptol/Main.hs

@@ -41,12 +41,16 @@ import System.IO (hClose, hPutStr, openTempFile)
 import Prelude ()
 import Prelude.Compat
 
+data ColorMode = AutoColor | NoColor | AlwaysColor
+  deriving (Show, Eq)
+
 data Options = Options
   { optLoad            :: [FilePath]
   , optVersion         :: Bool
   , optHelp            :: Bool
   , optBatch           :: Maybe FilePath
   , optCommands        :: [String]
+  , optColorMode       :: ColorMode
   , optCryptolrc       :: Cryptolrc
   , optCryptolPathOnly :: Bool
   } deriving (Show)
@@ -58,6 +62,7 @@ defaultOptions  = Options
   , optHelp            = False
   , optBatch           = Nothing
   , optCommands        = []
+  , optColorMode       = AutoColor
   , optCryptolrc       = CryrcDefault
   , optCryptolPathOnly = False
   }
@@ -73,6 +78,11 @@ options  =
             , "on the command line (overrides --batch)"
             ])
 
+  , Option "" ["color"] (ReqArg setColorMode "MODE")
+    (concat [ "control the color output for the terminal, which may be "
+            , "'auto', 'none' or 'always' (default: 'auto')"
+            ])
+
   , Option "v" ["version"] (NoArg setVersion)
     "display version number"
 
@@ -103,6 +113,13 @@ addCommand cmd =
 setBatchScript :: String -> OptParser Options
 setBatchScript path = modify $ \ opts -> opts { optBatch = Just path }
 
+-- | Set the color mode of the terminal output.
+setColorMode :: String -> OptParser Options
+setColorMode "auto"   = modify $ \ opts -> opts { optColorMode = AutoColor }
+setColorMode "none"   = modify $ \ opts -> opts { optColorMode = NoColor }
+setColorMode "always" = modify $ \ opts -> opts { optColorMode = AlwaysColor }
+setColorMode x        = OptFailure ["invalid color mode: " ++ x ++ "\n"]
+
 -- | Signal that version should be displayed.
 setVersion :: OptParser Options
 setVersion  = modify $ \ opts -> opts { optVersion = True }
@@ -209,7 +226,13 @@ setupREPL opts = do
       print (hang "Errors encountered on startup; exiting:"
                 4 (vcat (map pp smoke)))
       exitFailure
-  displayLogo True
+
+  color <- case optColorMode opts of
+    AlwaysColor -> return True
+    NoColor     -> return False
+    AutoColor   -> canDisplayColor
+  displayLogo color
+
   setUpdateREPLTitle (shouldSetREPLTitle >>= \b -> when b setREPLTitle)
   updateREPLTitle
   mCryptolPath <- io $ lookupEnv "CRYPTOLPATH"

cryptol/REPL/Haskeline.hs

@@ -153,13 +153,21 @@ setREPLTitle = do
   io (setTitle (mkTitle lm))
 
 -- | In certain environments like Emacs, we shouldn't set the terminal
--- title.  Note: this does not imply we can't use color output. We can
+-- title. Note: this does not imply we can't use color output. We can
 -- use ANSI color sequences in places like Emacs, but not terminal
--- codes. Rather, the lack of color output would imply this option, not the
--- other way around.
+-- codes.
+--
+-- This checks that @'stdout'@ is a proper terminal handle, and that the
+-- terminal mode is not @dumb@, which is set by Emacs and others.
 shouldSetREPLTitle :: REPL Bool
 shouldSetREPLTitle = io (hSupportsANSI stdout)
 
+-- | Whether we can display color titles. This checks that @'stdout'@
+-- is a proper terminal handle, and that the terminal mode is not
+-- @dumb@, which is set by Emacs and others.
+canDisplayColor :: REPL Bool
+canDisplayColor = io (hSupportsANSI stdout)
+
 -- Completion ------------------------------------------------------------------
 
 -- | Completion for cryptol commands.

cryptol/REPL/Logo.hs

@@ -49,4 +49,4 @@ logo useColor =
   lineLen   = length (head ls)
 
 displayLogo :: Bool -> REPL ()
-displayLogo useColor =unlessBatch (io (mapM_ putStrLn (logo useColor)))
+displayLogo useColor = unlessBatch (io (mapM_ putStrLn (logo useColor)))