git.iko.soy/vty
on simplify-attr help sign in
vty/tools/BuildWidthTable.hs
144 lines 5.1 kB history raw
1{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE CPP #-}
3module Main where
5import qualified Control.Exception as E
6import Control.Monad (when)
7import Data.Maybe (fromMaybe)
8#if !(MIN_VERSION_base(4,11,0))
9import Data.Semigroup ((<>))
10#endif
11import System.Directory (createDirectoryIfMissing)
12import System.Environment (getArgs, getProgName)
13import System.FilePath (takeDirectory)
14import System.Exit (exitFailure)
15import System.Console.GetOpt
16import Text.Read (readMaybe)
18import Graphics.Vty.Config ( terminalWidthTablePath, currentTerminalName
19 , vtyConfigPath, addConfigWidthMap
20 , ConfigUpdateResult(..)
21 )
22import Graphics.Vty.UnicodeWidthTable.IO
23import Graphics.Vty.UnicodeWidthTable.Query
25data Arg = Help
26 | OutputPath String
27 | TableUpperBound String
28 | UpdateConfig
29 | VtyConfigPath String
30 deriving (Eq, Show)
32options :: Config -> [OptDescr Arg]
33options config =
34 [ Option "h" ["help"] (NoArg Help)
35 "This help output"
36 , Option "b" ["bound"] (ReqArg TableUpperBound "MAX_CHAR")
37 ("The maximum Unicode code point to test when building the table " <>
38 "(default: " <> (show $ fromEnum $ configBound config) <> ")")
39 , Option "p" ["path"] (ReqArg OutputPath "PATH")
40 ("The output path to write to (default: " <>
41 fromMaybe "<none>" (configOutputPath config) <> ")")
42 , Option "u" ["update-config"] (NoArg UpdateConfig)
43 "Create or update the Vty configuration file to use the new table (default: no)"
44 , Option "c" ["config-path"] (ReqArg VtyConfigPath "PATH")
45 ("Update the specified Vty configuration file path when -u is set (default: " <>
46 configPath config <> ")")
47 ]
49data Config =
50 Config { configOutputPath :: Maybe FilePath
51 , configBound :: Char
52 , configUpdate :: Bool
53 , configPath :: FilePath
54 }
55 deriving (Show)
57mkDefaultConfig :: IO Config
58mkDefaultConfig = do
59 Config <$> terminalWidthTablePath
60 <*> pure defaultUnicodeTableUpperBound
61 <*> pure False
62 <*> vtyConfigPath
64usage :: IO ()
65usage = do
66 config <- mkDefaultConfig
67 pn <- getProgName
68 putStrLn $ "Usage: " <> pn <> " [options]"
69 putStrLn ""
70 putStrLn "This tool queries the terminal on stdout to determine the widths"
71 putStrLn "of Unicode characters rendered to the terminal. The resulting data"
72 putStrLn "is written to a table at the specified output path for later"
73 putStrLn "loading by Vty-based applications."
74 putStrLn ""
76 putStrLn $ usageInfo pn (options config)
78updateConfigFromArg :: Arg -> Config -> Config
79updateConfigFromArg Help c =
80 c
81updateConfigFromArg UpdateConfig c =
82 c { configUpdate = True }
83updateConfigFromArg (VtyConfigPath p) c =
84 c { configPath = p }
85updateConfigFromArg (TableUpperBound s) c =
86 case readMaybe s of
87 Nothing -> error $ "Invalid table upper bound: " <> show s
88 Just v -> c { configBound = toEnum v }
89updateConfigFromArg (OutputPath p) c =
90 c { configOutputPath = Just p }
92main :: IO ()
93main = do
94 defConfig <- mkDefaultConfig
95 strArgs <- getArgs
96 let (args, unused, errors) = getOpt Permute (options defConfig) strArgs
98 when (not $ null errors) $ do
99 mapM_ putStrLn errors
100 exitFailure
102 when ((not $ null unused) || (Help `elem` args)) $ do
103 usage
104 exitFailure
106 let config = foldr updateConfigFromArg defConfig args
108 outputPath <- case configOutputPath config of
109 Nothing -> do
110 putStrLn "Error: could not obtain terminal width table path"
111 exitFailure
112 Just path -> return path
114 putStrLn "Querying terminal:"
115 builtTable <- buildUnicodeWidthTable $ configBound config
117 let dir = takeDirectory outputPath
118 createDirectoryIfMissing True dir
119 writeUnicodeWidthTable outputPath builtTable
121 putStrLn $ "\nOutput table written to " <> outputPath
123 when (configUpdate config) $ do
124 let cPath = configPath config
125 Just tName <- currentTerminalName
127 result <- E.try $ addConfigWidthMap cPath tName outputPath
129 case result of
130 Left (e::E.SomeException) -> do
131 putStrLn $ "Error updating Vty configuration at " <> cPath <> ": " <>
132 show e
133 exitFailure
134 Right ConfigurationCreated -> do
135 putStrLn $ "Configuration file created: " <> cPath
136 Right ConfigurationModified -> do
137 putStrLn $ "Configuration file updated: " <> cPath
138 Right (ConfigurationConflict other) -> do
139 putStrLn $ "Configuration file not updated: uses a different table " <>
140 "for TERM=" <> tName <> ": " <> other
141 Right ConfigurationRedundant -> do
142 putStrLn $ "Configuration file not updated: configuration " <>
143 cPath <> " already uses table " <> outputPath <>
144 " for TERM=" <> tName