]> Git — Sourcephile - doclang.git/blob - cli/Textphile/CLI/Utils.hs
Fix megaparsec-8 update
[doclang.git] / 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