{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
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 <- IO Config
mkDefaultConfig
pn <- getProgName
putStrLn $ "Usage: " <> pn <> " [options]"
putStrLn ""
putStrLn "This tool queries the terminal on stdout to determine the widths"
putStrLn "of Unicode characters rendered to the terminal. The resulting data"
putStrLn "is written to a table at the specified output path for later"
putStrLn "loading by Vty-based applications."
putStrLn ""
putStrLn $ usageInfo pn (options 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 }
defaultMain :: (Char -> IO Int) -> IO ()
defaultMain :: (Char -> IO Int) -> IO ()
defaultMain Char -> IO Int
charWidth = do
defConfig <- IO Config
mkDefaultConfig
strArgs <- getArgs
let (args, unused, errors) = getOpt Permute (options defConfig) strArgs
when (not $ null errors) $ do
mapM_ putStrLn errors
exitFailure
when ((not $ null unused) || (Help `elem` args)) $ do
usage
exitFailure
let 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
outputPath <- case configOutputPath 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
putStrLn "Querying terminal:"
builtTable <- buildUnicodeWidthTable charWidth $ configBound config
let dir = ShowS
takeDirectory [Char]
outputPath
createDirectoryIfMissing True dir
writeUnicodeWidthTable outputPath builtTable
putStrLn $ "\nOutput table written to " <> outputPath
when (configUpdate config) $ do
let cPath = Config -> [Char]
configPath Config
config
Just tName <- currentTerminalName
result <- E.try $ addConfigWidthMap cPath tName outputPath
case 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