{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
-- | This module provides a command-line tool implementation for
-- building Vty character width tables and updating the user's local Vty
-- configuration to load them.
--
-- The API is parameterized on a platform-specific function to obtain
-- character widths. For example, on Unix platforms, this could be done
-- with a routine that communicates with the terminal to query it for
-- character widths. On other platforms, such a routine might interact
-- with a system library.
--
-- This tool is provided as a library implementation so that the tool
-- has a consistent interface across platforms and so that it implements
-- the Vty configuration update the same way everywhere.
module Graphics.Vty.UnicodeWidthTable.Main
  ( defaultMain
  )
where

import qualified Control.Exception as E
import Control.Monad (when)
import Data.Maybe (fromMaybe)
#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup ((<>))
#endif
import System.Directory (createDirectoryIfMissing)
import System.Environment (getArgs, getProgName)
import System.FilePath (takeDirectory)
import System.Exit (exitFailure)
import System.Console.GetOpt
import Text.Read (readMaybe)

import Graphics.Vty.Config ( terminalWidthTablePath, currentTerminalName
                           , vtyConfigPath, addConfigWidthMap
                           , ConfigUpdateResult(..)
                           )
import Graphics.Vty.UnicodeWidthTable.IO
import Graphics.Vty.UnicodeWidthTable.Query

data Arg = Help
         | OutputPath String
         | TableUpperBound String
         | UpdateConfig
         | VtyConfigPath String
         deriving (Arg -> Arg -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Arg -> Arg -> Bool
$c/= :: Arg -> Arg -> Bool
== :: Arg -> Arg -> Bool
$c== :: Arg -> Arg -> Bool
Eq, Int -> Arg -> ShowS
[Arg] -> ShowS
Arg -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Arg] -> ShowS
$cshowList :: [Arg] -> ShowS
show :: Arg -> [Char]
$cshow :: Arg -> [Char]
showsPrec :: Int -> Arg -> ShowS
$cshowsPrec :: Int -> Arg -> ShowS
Show)

options :: Config -> [OptDescr Arg]
options :: Config -> [OptDescr Arg]
options Config
config =
    [ forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [Char]
"h" [[Char]
"help"] (forall a. a -> ArgDescr a
NoArg Arg
Help)
      [Char]
"This help output"
    , forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [Char]
"b" [[Char]
"bound"] (forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg [Char] -> Arg
TableUpperBound [Char]
"MAX_CHAR")
      ([Char]
"The maximum Unicode code point to test when building the table " forall a. Semigroup a => a -> a -> a
<>
       [Char]
"(default: " forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum forall a b. (a -> b) -> a -> b
$ Config -> Char
configBound Config
config) forall a. Semigroup a => a -> a -> a
<> [Char]
")")
    , forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [Char]
"p" [[Char]
"path"] (forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg [Char] -> Arg
OutputPath [Char]
"PATH")
      ([Char]
"The output path to write to (default: " forall a. Semigroup a => a -> a -> a
<>
       forall a. a -> Maybe a -> a
fromMaybe [Char]
"<none>" (Config -> Maybe [Char]
configOutputPath Config
config) forall a. Semigroup a => a -> a -> a
<> [Char]
")")
    , forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [Char]
"u" [[Char]
"update-config"] (forall a. a -> ArgDescr a
NoArg Arg
UpdateConfig)
      [Char]
"Create or update the Vty configuration file to use the new table (default: no)"
    , forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [Char]
"c" [[Char]
"config-path"] (forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg [Char] -> Arg
VtyConfigPath [Char]
"PATH")
      ([Char]
"Update the specified Vty configuration file path when -u is set (default: " forall a. Semigroup a => a -> a -> a
<>
       Config -> [Char]
configPath Config
config forall a. Semigroup a => a -> a -> a
<> [Char]
")")
    ]

data Config =
    Config { Config -> Maybe [Char]
configOutputPath :: Maybe FilePath
           , Config -> Char
configBound :: Char
           , Config -> Bool
configUpdate :: Bool
           , Config -> [Char]
configPath :: FilePath
           }
           deriving (Int -> Config -> ShowS
[Config] -> ShowS
Config -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> [Char]
$cshow :: Config -> [Char]
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show)

mkDefaultConfig :: IO Config
mkDefaultConfig :: IO Config
mkDefaultConfig = do
    Maybe [Char] -> Char -> Bool -> [Char] -> Config
Config forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe [Char])
terminalWidthTablePath
           forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
defaultUnicodeTableUpperBound
           forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
           forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO [Char]
vtyConfigPath

usage :: IO ()
usage :: IO ()
usage = do
    Config
config <- IO Config
mkDefaultConfig
    [Char]
pn <- IO [Char]
getProgName
    [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"Usage: " forall a. Semigroup a => a -> a -> a
<> [Char]
pn forall a. Semigroup a => a -> a -> a
<> [Char]
" [options]"
    [Char] -> IO ()
putStrLn [Char]
""
    [Char] -> IO ()
putStrLn [Char]
"This tool queries the terminal on stdout to determine the widths"
    [Char] -> IO ()
putStrLn [Char]
"of Unicode characters rendered to the terminal. The resulting data"
    [Char] -> IO ()
putStrLn [Char]
"is written to a table at the specified output path for later"
    [Char] -> IO ()
putStrLn [Char]
"loading by Vty-based applications."
    [Char] -> IO ()
putStrLn [Char]
""

    [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> [OptDescr a] -> [Char]
usageInfo [Char]
pn (Config -> [OptDescr Arg]
options Config
config)

updateConfigFromArg :: Arg -> Config -> Config
updateConfigFromArg :: Arg -> Config -> Config
updateConfigFromArg Arg
Help Config
c =
    Config
c
updateConfigFromArg Arg
UpdateConfig Config
c =
    Config
c { configUpdate :: Bool
configUpdate = Bool
True }
updateConfigFromArg (VtyConfigPath [Char]
p) Config
c =
    Config
c { configPath :: [Char]
configPath = [Char]
p }
updateConfigFromArg (TableUpperBound [Char]
s) Config
c =
    case forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
s of
        Maybe Int
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid table upper bound: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [Char]
s
        Just Int
v  -> Config
c { configBound :: Char
configBound = forall a. Enum a => Int -> a
toEnum Int
v }
updateConfigFromArg (OutputPath [Char]
p) Config
c =
    Config
c { configOutputPath :: Maybe [Char]
configOutputPath = forall a. a -> Maybe a
Just [Char]
p }

-- | Run the character width table builder tool using the specified
-- function to obtain character widths. This is intended to be a 'main'
-- implementation, e.g. @main = defaultMain getCharWidth@.
--
-- The tool queries the local terminal in some way (as determined by
-- the provided function) over a wide range of Unicode code points and
-- generates a table of character widths that can subsequently be loaded
-- by Vty-based applications.
--
-- The tool respects the following command-line flags, all of which are
-- optional and have sensible defaults:
--
-- * @-h@/@--help@: help output
-- * @-b@/@--bound@: Unicode code point upper bound to use when building
--   the table.
-- * @-p@/@--path@: the output path where the generated table should be
--   written.
-- * @-u@/@--update-config@: If given, create or update the user's Vty
--   configuration file to use the new table.
-- * @-c@/@--config-path@: the path to the user's Vty configuration.
defaultMain :: (Char -> IO Int) -> IO ()
defaultMain :: (Char -> IO Int) -> IO ()
defaultMain Char -> IO Int
charWidth = do
    Config
defConfig <- IO Config
mkDefaultConfig
    [[Char]]
strArgs <- IO [[Char]]
getArgs
    let ([Arg]
args, [[Char]]
unused, [[Char]]
errors) = forall a.
ArgOrder a -> [OptDescr a] -> [[Char]] -> ([a], [[Char]], [[Char]])
getOpt forall a. ArgOrder a
Permute (Config -> [OptDescr Arg]
options Config
defConfig) [[Char]]
strArgs

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
errors) forall a b. (a -> b) -> a -> b
$ do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Char] -> IO ()
putStrLn [[Char]]
errors
        forall a. IO a
exitFailure

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
unused) Bool -> Bool -> Bool
|| (Arg
Help forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Arg]
args)) forall a b. (a -> b) -> a -> b
$ do
        IO ()
usage
        forall a. IO a
exitFailure

    let config :: Config
config = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Arg -> Config -> Config
updateConfigFromArg Config
defConfig [Arg]
args

    [Char]
outputPath <- case Config -> Maybe [Char]
configOutputPath Config
config of
        Maybe [Char]
Nothing -> do
            [Char] -> IO ()
putStrLn [Char]
"Error: could not obtain terminal width table path"
            forall a. IO a
exitFailure
        Just [Char]
path -> forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
path

    [Char] -> IO ()
putStrLn [Char]
"Querying terminal:"
    UnicodeWidthTable
builtTable <- (Char -> IO Int) -> Char -> IO UnicodeWidthTable
buildUnicodeWidthTable Char -> IO Int
charWidth forall a b. (a -> b) -> a -> b
$ Config -> Char
configBound Config
config

    let dir :: [Char]
dir = ShowS
takeDirectory [Char]
outputPath
    Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
dir
    [Char] -> UnicodeWidthTable -> IO ()
writeUnicodeWidthTable [Char]
outputPath UnicodeWidthTable
builtTable

    [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"\nOutput table written to " forall a. Semigroup a => a -> a -> a
<> [Char]
outputPath

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
configUpdate Config
config) forall a b. (a -> b) -> a -> b
$ do
        let cPath :: [Char]
cPath = Config -> [Char]
configPath Config
config
        Just [Char]
tName <- IO (Maybe [Char])
currentTerminalName

        Either SomeException ConfigUpdateResult
result <- forall e a. Exception e => IO a -> IO (Either e a)
E.try forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char] -> IO ConfigUpdateResult
addConfigWidthMap [Char]
cPath [Char]
tName [Char]
outputPath

        case Either SomeException ConfigUpdateResult
result of
            Left (SomeException
e::E.SomeException) -> do
                [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"Error updating Vty configuration at " forall a. Semigroup a => a -> a -> a
<> [Char]
cPath forall a. Semigroup a => a -> a -> a
<> [Char]
": " forall a. Semigroup a => a -> a -> a
<>
                           forall a. Show a => a -> [Char]
show SomeException
e
                forall a. IO a
exitFailure
            Right ConfigUpdateResult
ConfigurationCreated -> do
                [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"Configuration file created: " forall a. Semigroup a => a -> a -> a
<> [Char]
cPath
            Right ConfigUpdateResult
ConfigurationModified -> do
                [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"Configuration file updated: " forall a. Semigroup a => a -> a -> a
<> [Char]
cPath
            Right (ConfigurationConflict [Char]
other) -> do
                [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"Configuration file not updated: uses a different table " forall a. Semigroup a => a -> a -> a
<>
                           [Char]
"for TERM=" forall a. Semigroup a => a -> a -> a
<> [Char]
tName forall a. Semigroup a => a -> a -> a
<> [Char]
": " forall a. Semigroup a => a -> a -> a
<> [Char]
other
            Right ConfigUpdateResult
ConfigurationRedundant -> do
                [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"Configuration file not updated: configuration " forall a. Semigroup a => a -> a -> a
<>
                           [Char]
cPath forall a. Semigroup a => a -> a -> a
<> [Char]
" already uses table " forall a. Semigroup a => a -> a -> a
<> [Char]
outputPath forall a. Semigroup a => a -> a -> a
<>
                           [Char]
" for TERM=" forall a. Semigroup a => a -> a -> a
<> [Char]
tName