    {-# 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 <- 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 }

    -- | 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
        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