Options.hs

{-# Language CPP, TemplateHaskell, MultiWayIf #-}

#ifndef TOOL_VERSION_alex
#define TOOL_VERSION_alex "none"
#endif

#ifndef TOOL_VERSION_happy
#define TOOL_VERSION_happy "none"
#endif

{-|
Module      : Client.Options
Description : Processing of command-line options
Copyright   : (c) Eric Mertens, 2016
License     : ISC
Maintainer  : emertens@gmail.com

This module process command-line options provided when launching the client.

-}
module Client.Options
  (
  -- * Command-line options
    Options(..)

  -- * Lenses
  , optConfigFile
  , optInitialNetworks
  , optNoConnect

  -- * Options loader
  , getOptions
  ) where

import Build_glirc (deps)
import Client.Configuration (configurationSpec, getConfigPath)
import Config.Schema.Docs (generateDocs)
import Control.Lens (view, (<>~), set, makeLenses)
import Data.Foldable (Foldable(foldl'), traverse_)
import Data.List (intercalate, sort)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Version (showVersion)
import GitHash (giHash, giDirty, tGitInfoCwdTry)
import Paths_glirc (version)
import System.Console.GetOpt
import System.Environment (getArgs)
import System.Exit (exitFailure, exitSuccess)
import System.Info (arch, compilerName, compilerVersion, os)
import System.IO (hPutStr, hPutStrLn, stderr)

-- | Command-line options
data Options = Options
  { _optConfigFile      :: Maybe FilePath -- ^ configuration file path
  , _optInitialNetworks :: [Text]         -- ^ initial networks
  , _optNoConnect       :: Bool           -- ^ disable autoconnect
  , _optShowHelp        :: Bool           -- ^ show help message
  , _optShowVersion     :: Bool           -- ^ show version message
  , _optShowFullVersion :: Bool           -- ^ show version of ALL transitive dependencies
  , _optShowConfigFormat:: Bool           -- ^ show configuration file format
  }

makeLenses ''Options

-- | Default values for 'Options'
defaultOptions :: Options
defaultOptions = Options
  { _optConfigFile      = Nothing
  , _optInitialNetworks = []
  , _optShowHelp        = False
  , _optShowVersion     = False
  , _optShowFullVersion = False
  , _optNoConnect       = False
  , _optShowConfigFormat= False
  }

-- | Option descriptions
options :: [OptDescr (Options -> Options)]
options =
  [ Option "c" ["config"]  (ReqArg (set optConfigFile . Just) "PATH")
    "Configuration file path"
  , Option "!" ["noconnect"] (NoArg (set optNoConnect True))
    "Disable autoconnecting"
  , Option "h" ["help"]    (NoArg (set optShowHelp True))
    "Show help"
  , Option "" ["config-format"] (NoArg (set optShowConfigFormat True))
    "Show configuration file format"
  , Option "v" ["version"] (NoArg (set optShowVersion True))
    "Show version"
  , Option "" ["full-version"] (NoArg (set optShowFullVersion True))
    "Show version and versions of all linked Haskell libraries"
  ]

optOrder :: ArgOrder (Options -> Options)
optOrder = ReturnInOrder (\x -> optInitialNetworks <>~ [Text.pack x])

-- | Load command line options. This action will terminate early
-- in the case of the version flag, help flag, or an error.
getOptions :: IO Options
getOptions =
  do (flags, _, errors) <- getOpt optOrder options <$> getArgs

     let opts = foldl' (\acc f -> f acc) defaultOptions flags

         bullet x = "• " ++ x

         reportErrors =
           do hPutStrLn stderr "Errors processing command-line options:"
              traverse_ (hPutStr stderr) (map bullet errors)
              hPutStrLn stderr tryHelpTxt

     if | view optShowHelp         opts -> putStr helpTxt        >> exitSuccess
        | view optShowFullVersion  opts -> putStr fullVersionTxt >> exitSuccess
        | view optShowVersion      opts -> putStr versionTxt     >> exitSuccess
        | view optShowConfigFormat opts -> printConfigFormat     >> exitSuccess
        | null errors                   -> return opts
        | otherwise                     -> reportErrors          >> exitFailure

printConfigFormat :: IO ()
printConfigFormat =
  do path <- getConfigPath
     putStrLn ""
     putStrLn ("Default configuration file path: " ++ path)
     putStrLn ""
     print (generateDocs configurationSpec)

helpTxt :: String
helpTxt = usageInfo "glirc [FLAGS] INITIAL_NETWORKS..." options

tryHelpTxt :: String
tryHelpTxt =
  "Run 'glirc --help' to see a list of available command line options."

-- version information ---------------------------------------------

versionTxt :: String
versionTxt = unlines
  [ "glirc-" ++ showVersion version ++ gitHashTxt
  , "Copyright 2016-2020 Eric Mertens"
  ]
  where
    gitHashTxt =
      case $$tGitInfoCwdTry of
        Left{}   -> ""
        Right gi -> giHash gi ++ if giDirty gi then "-dirty" else ""

fullVersionTxt :: String
fullVersionTxt =
  versionTxt ++
  unlines
  (""
  :("OS          : " ++ os)
  :("Architecture: " ++ arch)
  :("Compiler    : " ++ compilerName ++ "-" ++ showVersion compilerVersion)
  :""
  :("ghc         : " ++ TOOL_VERSION_ghc)
  :("ghc-pkg     : " ++ TOOL_VERSION_ghc_pkg)
  :("alex        : " ++ TOOL_VERSION_alex)
  :("happy       : " ++ TOOL_VERSION_happy)
  :("hsc2hs      : " ++ TOOL_VERSION_hsc2hs)
  :""
  :"Transitive dependencies:"
  : [ name ++ "-" ++ intercalate "." (map show ver) | (name,ver) <- sort deps ]
  )