cli/Textphile/CLI/Utils.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE Rank2Types #-}
   4 {-# LANGUAGE StrictData #-}
   5 {-# OPTIONS_GHC -Wno-missing-signatures #-}
   6 {-# OPTIONS_GHC -Wno-orphans #-}
   7 module Textphile.CLI.Utils where
   8
   9 import Control.Applicative (Applicative(..), Alternative(..))
  10 import Control.Arrow (left)
  11 import Control.Monad (Monad(..), forM_, when)
  12 import Control.Monad.Trans.Maybe (MaybeT(..))
  13 import Control.Monad.Trans.Except (runExceptT)
  14 import Control.Monad.Trans.Reader (Reader, runReader)
  15 import Data.Bool
  16 import Data.Either (Either(..))
  17 import Data.Eq (Eq(..))
  18 import Data.Foldable (Foldable)
  19 import Data.Function (($), (.), id)
  20 import Data.Functor ((<$>))
  21 import Data.Maybe (Maybe(..), maybe)
  22 import Data.Monoid (Monoid(..))
  23 import Data.Ord (Ord(..))
  24 import Data.Semigroup (Semigroup(..))
  25 import Data.Text (Text)
  26 import Data.Typeable (Typeable)
  27 import Prelude (min, max, (-))
  28 import Symantic.CLI as CLI
  29 import System.IO (IO)
  30 import Text.Show (Show(..))
  31 import qualified Control.Monad.Classes as MC
  32 import qualified Data.ByteString.Char8 as BS8
  33 import qualified Data.ByteString.Lazy.Char8 as BSL8
  34 import qualified Data.Char as Char
  35 import qualified Data.List as List
  36 import qualified Data.Map.Strict as Map
  37 import qualified Data.Text as Text
  38 import qualified Data.Text.Encoding as T
  39 import qualified Symantic.Document as Doc
  40 import qualified System.Console.Terminal.Size as Console
  41 import qualified System.Directory as IO
  42 import qualified System.FilePath as FP
  43 import qualified System.IO as IO
  44 import qualified System.Posix as Posix
  45 import qualified Data.Version as Version
  46 import qualified Paths_textphile as Textphile
  47
  48 import Data.Locale
  49 import Textphile.CLI.Lang
  50
  51 progname :: Text
  52 progname = "textphile"
  53
  54 version :: Text
  55 version =
  56         progname <> "-" <>
  57         Text.pack (Version.showVersion Textphile.version)
  58
  59 api_help full =
  60         if full
  61         then
  62                 api_compact <.> response @Doc <!>
  63                 api_full    <.> response @Doc
  64         else
  65                 (api_compact <!> api_full) <.> response @Doc
  66         where
  67         api_compact =
  68                 (if full then helps l10n_help_opt_help_compact else id) $
  69                 tag "h" (just False)
  70         api_full =
  71                 (if full then helps l10n_help_opt_help_full else id) $
  72                 tag "help" (just True)
  73
  74 run_help lay = route :!: route
  75         where
  76         route helpInh_full = do
  77                 width <- Just . maybe 80 (min 80 . max 0 . (\x -> x - 2) . Console.width)
  78                  <$> Console.size
  79                 return $
  80                         Doc.setWidth width $
  81                                 runLayout helpInh_full lay
  82
  83 -- * Type 'Cfg_Global'
  84 data Cfg_Global
  85  =   Cfg_Global
  86  {   cfg_global_stderr_prepend_newline  :: Bool
  87  ,   cfg_global_stderr_prepend_carriage :: Bool
  88  ,   cfg_global_stderr_append_newline   :: Bool
  89  ,   cfg_global_verbosity :: Verbosity
  90  ,   cfg_global_lang      :: Lang
  91  }
  92
  93 api_options =
  94         rule "OPTIONS" $
  95                 Cfg_Global False False True
  96                  <$> api_param_verbosity
  97                  <*> api_param_lang
  98 api_param_lang =
  99         (\v -> Map.findWithDefault
 100          (LocaleIn @Langs en_US)
 101          (Text.pack $ List.takeWhile (\c -> Char.isAlphaNum c || c == '_') v)
 102          (locales @Langs)) <$>
 103         toPermDefault "en_US" (env "LANG")
 104
 105 -- * Type 'Verbosity'
 106 data Verbosity
 107  =   Verbosity_Error
 108  |   Verbosity_Warning
 109  |   Verbosity_Info
 110  |   Verbosity_Debug
 111  deriving (Eq,Ord)
 112
 113 instance IOType Verbosity
 114 instance FromSegment Verbosity where
 115         fromSegment = \case
 116          "error"   -> return $ Right Verbosity_Error
 117          "warning" -> return $ Right Verbosity_Warning
 118          "info"    -> return $ Right Verbosity_Info
 119          "debug"   -> return $ Right Verbosity_Debug
 120          _ -> return $ Left "invalid verbosity"
 121
 122 api_param_verbosity =
 123         helps l10n_help_opt_verbosity $
 124         toPermDefault Verbosity_Info $
 125                 tag "verbosity" (
 126                         constant "error"   Verbosity_Error   `alt`
 127                         constant "warning" Verbosity_Warning `alt`
 128                         constant "info"    Verbosity_Info    `alt`
 129                         constant "debug"   Verbosity_Debug
 130                  ) `alt`
 131                 env "TEXTPHILE_VERBOSITY"
 132
 133 outputMessage :: MC.MonadExec IO m => Cfg_Global -> Doc -> Doc -> m ()
 134 outputMessage Cfg_Global{..} hdr msg =
 135         MC.exec @IO $ output $ OnHandle IO.stderr $ (`runReader` loqualize cfg_global_lang) $
 136                 (if cfg_global_stderr_prepend_newline then Doc.newline else mempty) <>
 137                 (if cfg_global_stderr_prepend_carriage then "\r" else mempty) <>
 138                 hdr<>": "<>msg<>
 139                 (if cfg_global_stderr_append_newline then Doc.newline else mempty)
 140
 141 outputError :: MC.MonadExec IO m => Cfg_Global -> Doc -> MaybeT m a
 142 outputError cfg_global@Cfg_Global{..} msg = do
 143         when (Verbosity_Error <= cfg_global_verbosity) $ do
 144                 outputMessage cfg_global (Doc.redder "ERROR") msg
 145         empty
 146
 147 outputWarning :: MC.MonadExec IO m => Cfg_Global -> Doc -> m ()
 148 outputWarning cfg_global@Cfg_Global{..} msg = do
 149         when (Verbosity_Warning <= cfg_global_verbosity) $ do
 150                 outputMessage cfg_global (Doc.yellower "WARNING") msg
 151
 152 outputInfo :: MC.MonadExec IO m => Cfg_Global -> Doc -> m ()
 153 outputInfo cfg_global@Cfg_Global{..} msg = do
 154         when (Verbosity_Info <= cfg_global_verbosity) $ do
 155                 outputMessage cfg_global (Doc.greener "info") msg
 156
 157 outputDebug :: MC.MonadExec IO m => Cfg_Global -> Doc -> m ()
 158 outputDebug cfg_global@Cfg_Global{..} msg = do
 159         when (Verbosity_Debug <= cfg_global_verbosity) $ do
 160                 outputMessage cfg_global (Doc.magentaer "debug") msg