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

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

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

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

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

    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [OptDescr Arg] -> String
forall a. String -> [OptDescr a] -> String
usageInfo String
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 String
p) Config
c =
    Config
c { configPath :: String
configPath = String
p }
updateConfigFromArg (TableUpperBound String
s) Config
c =
    case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
s of
        Maybe Int
Nothing -> String -> Config
forall a. HasCallStack => String -> a
error (String -> Config) -> String -> Config
forall a b. (a -> b) -> a -> b
$ String
"Invalid table upper bound: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. Show a => a -> String
show String
s
        Just Int
v  -> Config
c { configBound :: Char
configBound = Int -> Char
forall a. Enum a => Int -> a
toEnum Int
v }
updateConfigFromArg (OutputPath String
p) Config
c =
    Config
c { configOutputPath :: Maybe String
configOutputPath = String -> Maybe String
forall a. a -> Maybe a
Just String
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
    [String]
strArgs <- IO [String]
getArgs
    let ([Arg]
args, [String]
unused, [String]
errors) = ArgOrder Arg
-> [OptDescr Arg] -> [String] -> ([Arg], [String], [String])
forall a.
ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])
getOpt ArgOrder Arg
forall a. ArgOrder a
Permute (Config -> [OptDescr Arg]
options Config
defConfig) [String]
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
$ [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
errors) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn [String]
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
$ [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
unused) Bool -> Bool -> Bool
|| (Arg
Help Arg -> [Arg] -> 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 (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Arg -> Config -> Config
updateConfigFromArg Config
defConfig [Arg]
args

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

    String -> IO ()
putStrLn String
"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 :: String
dir = ShowS
takeDirectory String
outputPath
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
dir
    String -> UnicodeWidthTable -> IO ()
writeUnicodeWidthTable String
outputPath UnicodeWidthTable
builtTable

    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\nOutput table written to " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
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 :: String
cPath = Config -> String
configPath Config
config
        Just String
tName <- IO (Maybe String)
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
$ String -> String -> String -> IO ConfigUpdateResult
addConfigWidthMap String
cPath String
tName String
outputPath

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