Automatically highlight default options of a CommandUI when converting it to a list of GetOpts

I shamelessly stole some code from GHCi for the highlighting.

Distribution/Simple/Command.hs

@@ -78,8 +78,9 @@ module Distribution.Simple.Command (
   ) where
 
 import Control.Monad
+import qualified Control.Exception as Exception
 import Data.Char (isAlpha, toLower)
-import Data.List (sortBy)
+import Data.List (sortBy, isPrefixOf)
 import Data.Maybe
 import Data.Monoid
 import qualified Distribution.GetOpt as GetOpt
@@ -88,6 +89,8 @@ import Distribution.Text
 import Distribution.ParseUtils
 import Distribution.ReadE
 import Text.PrettyPrint.HughesPJ    ( punctuate, cat, comma, text, empty)
+import System.IO.Unsafe (unsafePerformIO)
+import System.Environment (getEnv)
 
 data CommandUI flags = CommandUI {
     -- | The name of the command as it would be entered on the command line.
@@ -220,10 +223,14 @@ choiceOptFromEnum _sf _lf d get = choiceOpt [ (x, (sf, [map toLower $ show x]),
                                                        , toLower sf `notElem` prevflags]
           firstOne = minBound `asTypeOf` get undefined
 
-viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a->a)]
-viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa
+commandGetOpts :: ShowOrParseArgs -> CommandUI flags -> [GetOpt.OptDescr (flags -> flags)]
+commandGetOpts showOrParse command =
+    concatMap (viewAsGetOpt (commandDefaultFlags command))
+              (commandOptions command showOrParse)
+
+viewAsGetOpt :: a -> OptionField a -> [GetOpt.OptDescr (a->a)]
+viewAsGetOpt v (OptionField _n aa) = concatMap optDescrToGetOpt aa
   where
-    optDescrToGetOpt :: OptDescr t -> [GetOpt.OptDescr (t -> t)]
     optDescrToGetOpt (ReqArg d (cs,ss) arg_desc set _) =
          [GetOpt.Option cs ss (GetOpt.ReqArg set' arg_desc) d]
              where set' = readEOrFail set
@@ -232,10 +239,32 @@ viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa
              where set' Nothing    = def
                    set' (Just txt) = readEOrFail set txt
     optDescrToGetOpt (ChoiceOpt alts) =
-         [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d,(sf,lf),set,_) <- alts]
-    optDescrToGetOpt (BoolOpt d (sfT,lfT) (sfF, lfF) set _get) =
-         [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True))  ("Enable " ++ d)
-         , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ]
+         [GetOpt.Option sf lf (GetOpt.NoArg set) (highlight (isSet v) d)
+              | (d,(sf,lf),set,isSet) <- alts ]
+    optDescrToGetOpt (BoolOpt d (sfT,lfT) (sfF, lfF) set isSet) =
+         [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True))
+                             (highlight (isSet v) $ "Enable " ++ d)
+         , GetOpt.Option sfF lfF (GetOpt.NoArg (set False))
+                             (highlight (not$ isSet v) $ "Disable " ++ d) ]
+    highlight False            = id
+    highlight True | do_bold   = highlight_bold
+                   | otherwise = highlight_textually
+    highlight_bold = (start_bold ++) . (++ end_bold)
+    highlight_textually = (++ " (default)")
+
+-- For now, use ANSI bold on terminals that we know support it.
+-- Otherwise, we add a line of carets under the active expression instead.
+-- In particular, on Windows and when running the testsuite (which sets
+-- TERM to vt100 for other reasons) we get carets.
+-- We really ought to use a proper termcap/terminfo library.
+do_bold :: Bool
+do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
+    where mTerm = getEnv "TERM" `Exception.catch` \_ -> return "TERM not set"
+start_bold :: String
+start_bold = "\ESC[1m"
+end_bold :: String
+end_bold   = "\ESC[0m"
+
 
 -- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool > Choice > Opt) and consider only the first one.
 viewAsFieldDescr :: OptionField a -> FieldDescr a
@@ -341,7 +370,7 @@ commandListOptions command =
     addCommonFlags ShowArgs $ -- This is a slight hack, we don't want
                               -- "--list-options" showing up in the
                               -- list options output, so use ShowArgs
-      concatMap viewAsGetOpt (commandOptions command ParseArgs)
+      commandGetOpts ShowArgs command
   where
     listOption (GetOpt.Option shortNames longNames _ _) =
          [ "-"  ++ [name] | name <- shortNames ]
@@ -352,8 +381,7 @@ commandHelp :: CommandUI flags -> String
 commandHelp command =
     GetOpt.usageInfo ""
   . addCommonFlags ShowArgs
-  . concatMap viewAsGetOpt
-  $ commandOptions command ShowArgs
+  $ commandGetOpts ShowArgs command
 
 -- | Make a Command from standard 'GetOpt' options.
 makeCommand :: String                         -- ^ name
@@ -407,8 +435,7 @@ commandParseArgs :: CommandUI flags -> Bool -> [String]
                  -> CommandParse (flags -> flags, [String])
 commandParseArgs command ordered args =
   let options = addCommonFlags ParseArgs
-              . concatMap viewAsGetOpt
-              $ commandOptions command ParseArgs
+              $ commandGetOpts ParseArgs command
       order | ordered   = GetOpt.RequireOrder
             | otherwise = GetOpt.Permute
   in case GetOpt.getOpt order options args of