------------------------------------------------------------------------------
-- |
-- Module: Xmobar.App.Opts
-- Copyright: (c) 2018, 2019, 2020 Jose Antonio Ortega Ruiz
-- License: BSD3-style (see LICENSE)
--
-- Maintainer: jao@gnu.org
-- Stability: unstable
-- Portability: portable
-- Created: Fri Nov 30, 2018 01:19
--
--
-- Command line option parsing
--
------------------------------------------------------------------------------

module Xmobar.App.Opts (recompileFlag, verboseFlag, getOpts, doOpts) where

import Control.Monad (when)
import System.Console.GetOpt
import System.Exit (exitSuccess, exitWith, ExitCode(..))
import Data.Version (showVersion)
import Text.Read (readMaybe)

import Paths_xmobar (version)

import Xmobar.Config.Types

data Opts = Help
          | Verbose
          | Recompile
          | Version
          | Font       String
          | BgColor    String
          | FgColor    String
          | Alpha      String
          | T
          | B
          | D
          | AlignSep   String
          | Commands   String
          | AddCommand String
          | SepChar    String
          | Template   String
          | OnScr      String
          | IconRoot   String
          | Position   String
          | WmClass    String
          | WmName     String
       deriving (Int -> Opts -> ShowS
[Opts] -> ShowS
Opts -> String
(Int -> Opts -> ShowS)
-> (Opts -> String) -> ([Opts] -> ShowS) -> Show Opts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Opts] -> ShowS
$cshowList :: [Opts] -> ShowS
show :: Opts -> String
$cshow :: Opts -> String
showsPrec :: Int -> Opts -> ShowS
$cshowsPrec :: Int -> Opts -> ShowS
Show, Opts -> Opts -> Bool
(Opts -> Opts -> Bool) -> (Opts -> Opts -> Bool) -> Eq Opts
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Opts -> Opts -> Bool
$c/= :: Opts -> Opts -> Bool
== :: Opts -> Opts -> Bool
$c== :: Opts -> Opts -> Bool
Eq)

options :: [OptDescr Opts]
options :: [OptDescr Opts]
options =
    [ String -> [String] -> ArgDescr Opts -> String -> OptDescr Opts
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option "h?" ["help"] (Opts -> ArgDescr Opts
forall a. a -> ArgDescr a
NoArg Opts
Help) "This help"
    , String -> [String] -> ArgDescr Opts -> String -> OptDescr Opts
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option "v" ["verbose"] (Opts -> ArgDescr Opts
forall a. a -> ArgDescr a
NoArg Opts
Verbose) "Emit verbose debugging messages"
    , String -> [String] -> ArgDescr Opts -> String -> OptDescr Opts
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option "r" ["recompile"] (Opts -> ArgDescr Opts
forall a. a -> ArgDescr a
NoArg Opts
Recompile) "Force recompilation"
    , String -> [String] -> ArgDescr Opts -> String -> OptDescr Opts
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option "V" ["version"] (Opts -> ArgDescr Opts
forall a. a -> ArgDescr a
NoArg Opts
Version) "Show version information"
    , String -> [String] -> ArgDescr Opts -> String -> OptDescr Opts
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option "f" ["font"] ((String -> Opts) -> String -> ArgDescr Opts
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Opts
Font "font name") "Font name"
    , String -> [String] -> ArgDescr Opts -> String -> OptDescr Opts
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option "w" ["wmclass"] ((String -> Opts) -> String -> ArgDescr Opts
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Opts
WmClass "class") "X11 WM_CLASS property"
    , String -> [String] -> ArgDescr Opts -> String -> OptDescr Opts
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option "n" ["wmname"] ((String -> Opts) -> String -> ArgDescr Opts
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Opts
WmName "name") "X11 WM_NAME property"
    , String -> [String] -> ArgDescr Opts -> String -> OptDescr Opts
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option "B" ["bgcolor"] ((String -> Opts) -> String -> ArgDescr Opts
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Opts
BgColor "bg color" )
      "The background color. Default black"
    , String -> [String] -> ArgDescr Opts -> String -> OptDescr Opts
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option "F" ["fgcolor"] ((String -> Opts) -> String -> ArgDescr Opts
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Opts
FgColor "fg color")
      "The foreground color. Default grey"
    , String -> [String] -> ArgDescr Opts -> String -> OptDescr Opts
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option "i" ["iconroot"] ((String -> Opts) -> String -> ArgDescr Opts
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Opts
IconRoot "path")
      "Root directory for icon pattern paths. Default '.'"
    , String -> [String] -> ArgDescr Opts -> String -> OptDescr Opts
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option "A" ["alpha"] ((String -> Opts) -> String -> ArgDescr Opts
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Opts
Alpha "alpha")
      "Transparency: 0 is transparent, 255 is opaque. Default: 255"
    , String -> [String] -> ArgDescr Opts -> String -> OptDescr Opts
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option "o" ["top"] (Opts -> ArgDescr Opts
forall a. a -> ArgDescr a
NoArg Opts
T) "Place xmobar at the top of the screen"
    , String -> [String] -> ArgDescr Opts -> String -> OptDescr Opts
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option "b" ["bottom"] (Opts -> ArgDescr Opts
forall a. a -> ArgDescr a
NoArg Opts
B)
      "Place xmobar at the bottom of the screen"
    , String -> [String] -> ArgDescr Opts -> String -> OptDescr Opts
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option "d" ["dock"] (Opts -> ArgDescr Opts
forall a. a -> ArgDescr a
NoArg Opts
D)
      "Don't override redirect from WM and function as a dock"
    , String -> [String] -> ArgDescr Opts -> String -> OptDescr Opts
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option "a" ["alignsep"] ((String -> Opts) -> String -> ArgDescr Opts
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Opts
AlignSep "alignsep")
      "Separators for left, center and right text\nalignment. Default: '}{'"
    , String -> [String] -> ArgDescr Opts -> String -> OptDescr Opts
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option "s" ["sepchar"] ((String -> Opts) -> String -> ArgDescr Opts
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Opts
SepChar "char")
      ("Character used to separate commands in" String -> ShowS
forall a. [a] -> [a] -> [a]
++
       "\nthe output template. Default '%'")
    , String -> [String] -> ArgDescr Opts -> String -> OptDescr Opts
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option "t" ["template"] ((String -> Opts) -> String -> ArgDescr Opts
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Opts
Template "template")
      "Output template"
    , String -> [String] -> ArgDescr Opts -> String -> OptDescr Opts
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option "c" ["commands"] ((String -> Opts) -> String -> ArgDescr Opts
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Opts
Commands "commands")
      "List of commands to be executed"
    , String -> [String] -> ArgDescr Opts -> String -> OptDescr Opts
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option "C" ["add-command"] ((String -> Opts) -> String -> ArgDescr Opts
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Opts
AddCommand "command")
      "Add to the list of commands to be executed"
    , String -> [String] -> ArgDescr Opts -> String -> OptDescr Opts
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option "x" ["screen"] ((String -> Opts) -> String -> ArgDescr Opts
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Opts
OnScr "screen")
      "On which X screen number to start"
    , String -> [String] -> ArgDescr Opts -> String -> OptDescr Opts
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option "p" ["position"] ((String -> Opts) -> String -> ArgDescr Opts
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Opts
Position "position")
      "Specify position of xmobar. Same syntax as in config file"
    ]

getOpts :: [String] -> IO ([Opts], [String])
getOpts :: [String] -> IO ([Opts], [String])
getOpts argv :: [String]
argv = do
   (o :: [Opts]
o,n :: [String]
n) <-  case ArgOrder Opts
-> [OptDescr Opts] -> [String] -> ([Opts], [String], [String])
forall a.
ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])
getOpt ArgOrder Opts
forall a. ArgOrder a
Permute [OptDescr Opts]
options [String]
argv of
               (o :: [Opts]
o,n :: [String]
n,[])   -> ([Opts], [String]) -> IO ([Opts], [String])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Opts]
o,[String]
n)
               (_,_,errs :: [String]
errs) -> String -> IO ([Opts], [String])
forall a. HasCallStack => String -> a
error ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
errs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
usage)
   Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Opts
Help Opts -> [Opts] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Opts]
o) (String -> IO ()
putStr String
usage IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitSuccess)
   Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Opts
Version Opts -> [Opts] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Opts]
o) (String -> IO ()
putStr String
info IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitSuccess)
   ([Opts], [String]) -> IO ([Opts], [String])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Opts]
o, [String]
n)

usage :: String
usage :: String
usage = String -> [OptDescr Opts] -> String
forall a. String -> [OptDescr a] -> String
usageInfo String
header [OptDescr Opts]
options String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
footer
    where header :: String
header = "Usage: xmobar [OPTION...] [FILE]\nOptions:"
          footer :: String
footer = "\nMail bug reports and suggestions to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
mail String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n"

info :: String
info :: String
info = "xmobar " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> String
showVersion Version
version
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n (C) 2010 - 2020 Jose A Ortega Ruiz"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n (C) 2007 - 2010 Andrea Rossato\n "
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
mail String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
license String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n"

mail :: String
mail :: String
mail = "<mail@jao.io>"

license :: String
license :: String
license = "\nThis program is distributed in the hope that it will be useful," String -> ShowS
forall a. [a] -> [a] -> [a]
++
          "\nbut WITHOUT ANY WARRANTY; without even the implied warranty of" String -> ShowS
forall a. [a] -> [a] -> [a]
++
          "\nMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." String -> ShowS
forall a. [a] -> [a] -> [a]
++
          "\nSee the License for more details."

doOpts :: Config -> [Opts] -> IO Config
doOpts :: Config -> [Opts] -> IO Config
doOpts conf :: Config
conf [] =
  Config -> IO Config
forall (m :: * -> *) a. Monad m => a -> m a
return (Config
conf {lowerOnStart :: Bool
lowerOnStart = Config -> Bool
lowerOnStart Config
conf Bool -> Bool -> Bool
&& Config -> Bool
overrideRedirect Config
conf})
doOpts conf :: Config
conf (o :: Opts
o:oo :: [Opts]
oo) =
  case Opts
o of
    Help -> Config -> IO Config
doOpts' Config
conf
    Version -> Config -> IO Config
doOpts' Config
conf
    Recompile -> Config -> IO Config
doOpts' Config
conf
    Verbose -> Config -> IO Config
doOpts' (Config
conf {verbose :: Bool
verbose = Bool
True})
    Font s :: String
s -> Config -> IO Config
doOpts' (Config
conf {font :: String
font = String
s})
    WmClass s :: String
s -> Config -> IO Config
doOpts' (Config
conf {wmClass :: String
wmClass = String
s})
    WmName s :: String
s -> Config -> IO Config
doOpts' (Config
conf {wmName :: String
wmName = String
s})
    BgColor s :: String
s -> Config -> IO Config
doOpts' (Config
conf {bgColor :: String
bgColor = String
s})
    FgColor s :: String
s -> Config -> IO Config
doOpts' (Config
conf {fgColor :: String
fgColor = String
s})
    Alpha n :: String
n -> Config -> IO Config
doOpts' (Config
conf {alpha :: Int
alpha = String -> Int
forall a. Read a => String -> a
read String
n})
    T -> Config -> IO Config
doOpts' (Config
conf {position :: XPosition
position = XPosition
Top})
    B -> Config -> IO Config
doOpts' (Config
conf {position :: XPosition
position = XPosition
Bottom})
    D -> Config -> IO Config
doOpts' (Config
conf {overrideRedirect :: Bool
overrideRedirect = Bool
False})
    AlignSep s :: String
s -> Config -> IO Config
doOpts' (Config
conf {alignSep :: String
alignSep = String
s})
    SepChar s :: String
s -> Config -> IO Config
doOpts' (Config
conf {sepChar :: String
sepChar = String
s})
    Template s :: String
s -> Config -> IO Config
doOpts' (Config
conf {template :: String
template = String
s})
    IconRoot s :: String
s -> Config -> IO Config
doOpts' (Config
conf {iconRoot :: String
iconRoot = String
s})
    OnScr n :: String
n -> Config -> IO Config
doOpts' (Config
conf {position :: XPosition
position = Int -> XPosition -> XPosition
OnScreen (String -> Int
forall a. Read a => String -> a
read String
n) (XPosition -> XPosition) -> XPosition -> XPosition
forall a b. (a -> b) -> a -> b
$ Config -> XPosition
position Config
conf})
    Commands s :: String
s -> case Char -> String -> Either String [Runnable]
forall b. Read b => Char -> String -> Either String b
readCom 'c' String
s of
                    Right x :: [Runnable]
x -> Config -> IO Config
doOpts' (Config
conf {commands :: [Runnable]
commands = [Runnable]
x})
                    Left e :: String
e -> String -> IO ()
putStr (String
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
usage) IO () -> IO Config -> IO Config
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExitCode -> IO Config
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure 1)
    AddCommand s :: String
s -> case Char -> String -> Either String [Runnable]
forall b. Read b => Char -> String -> Either String b
readCom 'C' String
s of
                      Right x :: [Runnable]
x -> Config -> IO Config
doOpts' (Config
conf {commands :: [Runnable]
commands = Config -> [Runnable]
commands Config
conf [Runnable] -> [Runnable] -> [Runnable]
forall a. [a] -> [a] -> [a]
++ [Runnable]
x})
                      Left e :: String
e -> String -> IO ()
putStr (String
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
usage) IO () -> IO Config -> IO Config
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExitCode -> IO Config
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure 1)
    Position s :: String
s -> String -> IO Config
readPosition String
s
  where readCom :: Char -> String -> Either String b
readCom c :: Char
c str :: String
str =
          case String -> [b]
forall a. Read a => String -> [a]
readStr String
str of
            [x :: b
x] -> b -> Either String b
forall a b. b -> Either a b
Right b
x
            _  -> String -> Either String b
forall a b. a -> Either a b
Left ("xmobar: cannot read list of commands " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                        "specified with the -" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:" option\n")
        readStr :: String -> [a]
readStr str :: String
str = [a
x | (x :: a
x,t :: String
t) <- ReadS a
forall a. Read a => ReadS a
reads String
str, ("","") <- ReadS String
lex String
t]
        doOpts' :: Config -> IO Config
doOpts' c :: Config
c = Config -> [Opts] -> IO Config
doOpts Config
c [Opts]
oo
        readPosition :: String -> IO Config
readPosition string :: String
string =
            case String -> Maybe XPosition
forall a. Read a => String -> Maybe a
readMaybe String
string of
                Just x :: XPosition
x  -> Config -> IO Config
doOpts' (Config
conf { position :: XPosition
position = XPosition
x })
                Nothing -> do
                    String -> IO ()
putStrLn "Can't parse position option, ignoring"
                    Config -> IO Config
doOpts' Config
conf

recompileFlag :: [Opts] -> Bool
recompileFlag :: [Opts] -> Bool
recompileFlag = Opts -> [Opts] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Opts
Recompile

verboseFlag :: [Opts] -> Bool
verboseFlag :: [Opts] -> Bool
verboseFlag = Opts -> [Opts] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Opts
Verbose