{-# 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
(Arg -> Arg -> Bool) -> (Arg -> Arg -> Bool) -> Eq Arg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Arg -> Arg -> Bool
== :: Arg -> Arg -> Bool
$c/= :: Arg -> Arg -> Bool
/= :: Arg -> Arg -> Bool
Eq, Int -> Arg -> ShowS
[Arg] -> ShowS
Arg -> [Char]
(Int -> Arg -> ShowS)
-> (Arg -> [Char]) -> ([Arg] -> ShowS) -> Show Arg
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Arg -> ShowS
showsPrec :: Int -> Arg -> ShowS
$cshow :: Arg -> [Char]
show :: Arg -> [Char]
$cshowList :: [Arg] -> ShowS
showList :: [Arg] -> ShowS
Show)

options :: Config -> [OptDescr Arg]
options :: Config -> [OptDescr Arg]
options Config
config =
    [ [Char] -> [[Char]] -> ArgDescr Arg -> [Char] -> OptDescr Arg
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [Char]
"h" [[Char]
"help"] (Arg -> ArgDescr Arg
forall a. a -> ArgDescr a
NoArg Arg
Help)
      [Char]
"This help output"
    , [Char] -> [[Char]] -> ArgDescr Arg -> [Char] -> OptDescr Arg
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [Char]
"b" [[Char]
"bound"] (([Char] -> Arg) -> [Char] -> ArgDescr Arg
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 " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>
       [Char]
"(default: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ Char -> Int
forall a. Enum a => a -> Int
fromEnum (Char -> Int) -> Char -> Int
forall a b. (a -> b) -> a -> b
$ Config -> Char
configBound Config
config) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
")")
    , [Char] -> [[Char]] -> ArgDescr Arg -> [Char] -> OptDescr Arg
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [Char]
"p" [[Char]
"path"] (([Char] -> Arg) -> [Char] -> ArgDescr Arg
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg [Char] -> Arg
OutputPath [Char]
"PATH")
      ([Char]
"The output path to write to (default: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>
       [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"<none>" (Config -> Maybe [Char]
configOutputPath Config
config) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
")")
    , [Char] -> [[Char]] -> ArgDescr Arg -> [Char] -> OptDescr Arg
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [Char]
"u" [[Char]
"update-config"] (Arg -> ArgDescr Arg
forall a. a -> ArgDescr a
NoArg Arg
UpdateConfig)
      [Char]
"Create or update the Vty configuration file to use the new table (default: no)"
    , [Char] -> [[Char]] -> ArgDescr Arg -> [Char] -> OptDescr Arg
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [Char]
"c" [[Char]
"config-path"] (([Char] -> Arg) -> [Char] -> ArgDescr Arg
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: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>
       Config -> [Char]
configPath Config
config [Char] -> ShowS
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]
(Int -> Config -> ShowS)
-> (Config -> [Char]) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Config -> ShowS
showsPrec :: Int -> Config -> ShowS
$cshow :: Config -> [Char]
show :: Config -> [Char]
$cshowList :: [Config] -> ShowS
showList :: [Config] -> ShowS
Show)

mkDefaultConfig :: IO Config
mkDefaultConfig :: IO Config
mkDefaultConfig = do
    Maybe [Char] -> Char -> Bool -> [Char] -> Config
Config (Maybe [Char] -> Char -> Bool -> [Char] -> Config)
-> IO (Maybe [Char]) -> IO (Char -> Bool -> [Char] -> Config)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe [Char])
terminalWidthTablePath
           IO (Char -> Bool -> [Char] -> Config)
-> IO Char -> IO (Bool -> [Char] -> Config)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> IO Char
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
defaultUnicodeTableUpperBound
           IO (Bool -> [Char] -> Config) -> IO Bool -> IO ([Char] -> Config)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
           IO ([Char] -> Config) -> IO [Char] -> IO Config
forall a b. IO (a -> b) -> IO a -> IO b
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 ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Usage: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
pn [Char] -> ShowS
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 ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [OptDescr Arg] -> [Char]
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 = True }
updateConfigFromArg (VtyConfigPath [Char]
p) Config
c =
    Config
c { configPath = p }
updateConfigFromArg (TableUpperBound [Char]
s) Config
c =
    case [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
s of
        Maybe Int
Nothing -> [Char] -> Config
forall a. HasCallStack => [Char] -> a
error ([Char] -> Config) -> [Char] -> Config
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid table upper bound: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. Show a => a -> [Char]
show [Char]
s
        Just Int
v  -> Config
c { configBound = toEnum v }
updateConfigFromArg (OutputPath [Char]
p) Config
c =
    Config
c { configOutputPath = Just 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) = ArgOrder Arg
-> [OptDescr Arg] -> [[Char]] -> ([Arg], [[Char]], [[Char]])
forall a.
ArgOrder a -> [OptDescr a] -> [[Char]] -> ([a], [[Char]], [[Char]])
getOpt ArgOrder Arg
forall a. ArgOrder a
Permute (Config -> [OptDescr Arg]
options Config
defConfig) [[Char]]
strArgs

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

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

    let config :: Config
config = (Arg -> Config -> Config) -> Config -> [Arg] -> Config
forall a b. (a -> b -> b) -> b -> [a] -> b
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"
            IO [Char]
forall a. IO a
exitFailure
        Just [Char]
path -> [Char] -> IO [Char]
forall a. a -> IO a
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 (Char -> IO UnicodeWidthTable) -> Char -> IO UnicodeWidthTable
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 ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"\nOutput table written to " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
outputPath

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
configUpdate Config
config) (IO () -> IO ()) -> IO () -> IO ()
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 <- IO ConfigUpdateResult
-> IO (Either SomeException ConfigUpdateResult)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO ConfigUpdateResult
 -> IO (Either SomeException ConfigUpdateResult))
-> IO ConfigUpdateResult
-> IO (Either SomeException ConfigUpdateResult)
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 ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Error updating Vty configuration at " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
cPath [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>
                           SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
e
                IO ()
forall a. IO a
exitFailure
            Right ConfigUpdateResult
ConfigurationCreated -> do
                [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Configuration file created: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
cPath
            Right ConfigUpdateResult
ConfigurationModified -> do
                [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Configuration file updated: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
cPath
            Right (ConfigurationConflict [Char]
other) -> do
                [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Configuration file not updated: uses a different table " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>
                           [Char]
"for TERM=" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
tName [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
other
            Right ConfigUpdateResult
ConfigurationRedundant -> do
                [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Configuration file not updated: configuration " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>
                           [Char]
cPath [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" already uses table " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
outputPath [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>
                           [Char]
" for TERM=" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
tName