Merge pull request #374 from thoughtpolice/fix-terminal-use

Fix up terminal title usage and color output

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,8 +226,14 @@ setupREPL opts = do
       print (hang "Errors encountered on startup; exiting:"
                 4 (vcat (map pp smoke)))
       exitFailure
-  displayLogo True
-  setUpdateREPLTitle setREPLTitle
+
+  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"
   case mCryptolPath of

cryptol/REPL/Haskeline.hs

@@ -24,7 +24,8 @@ import           Control.Monad.Trans.Control
 import           Data.Char (isAlphaNum, isSpace)
 import           Data.Function (on)
 import           Data.List (isPrefixOf,nub,sortBy,sort)
-import           System.Console.ANSI (setTitle)
+import           System.IO (stdout)
+import           System.Console.ANSI (setTitle, hSupportsANSI)
 import           System.Console.Haskeline
 import           System.Directory ( doesFileExist
                                   , getHomeDirectory
@@ -151,6 +152,22 @@ setREPLTitle = do
   lm <- getLoadedMod
   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
+-- use ANSI color sequences in places like Emacs, but not terminal
+-- 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)))