{-# 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
/= :: 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 }
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