cli/Textphile/CLI/Lang.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 module Textphile.CLI.Lang where
   5
   6 import Control.Applicative (Applicative(..), (<*), liftA2, liftA3)
   7 import Control.Monad.Trans.Reader (Reader, runReader, ReaderT, runReaderT, ask)
   8 import Data.Bool
   9 import Data.Eq (Eq(..))
  10 import Data.Function (($), (.))
  11 import Data.Functor (Functor(..), (<$>))
  12 import Data.Locale
  13 import Data.Maybe (Maybe(..), fromMaybe, maybe)
  14 import Data.Monoid (Monoid(..))
  15 import Data.Semigroup (Semigroup(..))
  16 import Data.String (String, IsString(..))
  17 import Data.Text (Text)
  18 import Symantic.CLI (Outputable(..), OnHandle(..), IOType)
  19 import System.IO (IO, FilePath)
  20 import qualified Data.Char as Char
  21 import qualified Data.List as List
  22 import qualified Data.Map.Strict as Map
  23 import qualified Data.Text as Text
  24 import qualified Data.Text.Lazy.Builder as TLB
  25 import qualified Symantic.CLI as CLI
  26 import qualified Symantic.Document as Doc
  27 import qualified System.Environment as Env
  28
  29 type Doc = Reader Loq (Doc.Plain TLB.Builder)
  30
  31 instance (Semigroup d, Applicative m) => Semigroup (ReaderT r m (Doc.Plain d)) where
  32         (<>) = liftA2 (<>)
  33 instance (Monoid d, Applicative m) => Monoid (ReaderT r m (Doc.Plain d)) where
  34         mempty = pure mempty
  35         mappend = liftA2 mappend
  36 instance
  37  ( Doc.From (Doc.Word String) d
  38  , Applicative m
  39  , Doc.Spaceable d
  40  ) => IsString (ReaderT r m (Doc.Plain d)) where
  41         fromString = pure . fromString
  42 instance
  43  ( Applicative m
  44  , Doc.Spaceable d
  45  ) => Doc.Spaceable (ReaderT r m (Doc.Plain d)) where
  46         newline = pure Doc.newline
  47         space = pure Doc.space
  48 instance
  49  ( Functor m
  50  , Semigroup d
  51  , Doc.From [Doc.SGR] d
  52  ) => Doc.Colorable16 (ReaderT r m (Doc.Plain d)) where
  53         reverse     = fmap Doc.reverse
  54         black       = fmap Doc.black
  55         red         = fmap Doc.red
  56         green       = fmap Doc.green
  57         yellow      = fmap Doc.yellow
  58         blue        = fmap Doc.blue
  59         magenta     = fmap Doc.magenta
  60         cyan        = fmap Doc.cyan
  61         white       = fmap Doc.white
  62         blacker     = fmap Doc.blacker
  63         redder      = fmap Doc.redder
  64         greener     = fmap Doc.greener
  65         yellower    = fmap Doc.yellower
  66         bluer       = fmap Doc.bluer
  67         magentaer   = fmap Doc.magentaer
  68         cyaner      = fmap Doc.cyaner
  69         whiter      = fmap Doc.whiter
  70         onBlack     = fmap Doc.onBlack
  71         onRed       = fmap Doc.onRed
  72         onGreen     = fmap Doc.onGreen
  73         onYellow    = fmap Doc.onYellow
  74         onBlue      = fmap Doc.onBlue
  75         onMagenta   = fmap Doc.onMagenta
  76         onCyan      = fmap Doc.onCyan
  77         onWhite     = fmap Doc.onWhite
  78         onBlacker   = fmap Doc.onBlacker
  79         onRedder    = fmap Doc.onRedder
  80         onGreener   = fmap Doc.onGreener
  81         onYellower  = fmap Doc.onYellower
  82         onBluer     = fmap Doc.onBluer
  83         onMagentaer = fmap Doc.onMagentaer
  84         onCyaner    = fmap Doc.onCyaner
  85         onWhiter    = fmap Doc.onWhiter
  86 instance
  87  ( Applicative m
  88  , Semigroup d
  89  , Doc.From [Doc.SGR] d
  90  ) => Doc.Decorable (ReaderT r m (Doc.Plain d)) where
  91         bold      = fmap Doc.bold
  92         underline = fmap Doc.underline
  93         italic    = fmap Doc.italic
  94 instance
  95  ( Applicative m
  96  , Semigroup d
  97  , Doc.Spaceable d
  98  ) => Doc.Wrappable (ReaderT r m (Doc.Plain d)) where
  99         setWidth w = fmap (Doc.setWidth w)
 100         breakpoint = pure Doc.breakpoint
 101         breakspace = pure Doc.breakspace
 102         breakalt   = liftA2 Doc.breakalt
 103         endline    = pure Doc.endline
 104 instance
 105  ( Applicative m
 106  , Semigroup d
 107  , Doc.Spaceable d
 108  ) => Doc.Justifiable (ReaderT r m (Doc.Plain d)) where
 109         justify = fmap Doc.justify
 110 instance
 111  ( Applicative m
 112  , Semigroup d
 113  , Doc.Spaceable d
 114  ) => Doc.Indentable (ReaderT r m (Doc.Plain d)) where
 115         align = fmap Doc.align
 116         setIndent d i x = Doc.setIndent <$> d <*> pure i <*> x
 117         incrIndent d i x = Doc.incrIndent <$> d <*> pure i <*> x
 118         fill i = fmap (Doc.fill i)
 119         fillOrBreak i = fmap (Doc.fillOrBreak i)
 120 instance
 121  ( Applicative m
 122  , Semigroup d
 123  , Doc.Lengthable s
 124  , Doc.From (Doc.Word s) d
 125  ) => Doc.From (Doc.Word s) (ReaderT r m (Doc.Plain d)) where
 126         from = pure . Doc.from
 127 instance Doc.From String Doc where
 128         from = pure . Doc.from
 129 instance Doc.From Text Doc where
 130         from = pure . Doc.from
 131
 132 instance IOType Doc
 133 instance Outputable Doc where
 134         output d = do
 135                 lang <- getLang
 136                 output $ runReader d $ loqualize lang
 137 instance Outputable (OnHandle Doc) where
 138         output (OnHandle h d) = do
 139                 lang <- getLang
 140                 output $ OnHandle h $ runReader d $ loqualize lang
 141
 142 getLang :: IO Lang
 143 getLang =
 144         (\v -> Map.findWithDefault
 145          (LocaleIn @Langs en_US)
 146          (Text.pack $ List.takeWhile (\c -> Char.isAlphaNum c || c == '_') v)
 147          (locales @Langs)) .
 148         fromMaybe ""
 149          <$> Env.lookupEnv "LANG"
 150
 151 type Name = Text
 152
 153 -- * Type 'Lang'
 154 -- | Supported locales
 155 type Langs = '[FR, EN]
 156 type Lang  = LocaleIn Langs
 157
 158 l10n_var v = "<"<>Doc.from v<>">"
 159 ref = Doc.underline
 160 con = Doc.between "\"" "\""
 161 fileRef = ref
 162
 163 -- ** Class 'L10n'
 164 type Loq = Loqualization L10n
 165
 166 helps ::
 167  CLI.CLI_Help repr =>
 168  CLI.HelpConstraint repr Doc =>
 169  (forall lang. L10n lang => FullLocale lang -> Doc.Plain TLB.Builder) ->
 170  repr f k -> repr f k
 171 helps f = CLI.help @_ @Doc (Doc.justify ((\(Loqualization fl) -> f fl) <$> ask))
 172 infixr 0 `helps`
 173
 174 -- | Localization
 175 class L10n_Var lang => L10n lang where
 176         l10n_cli                   :: FullLocale lang -> Doc.Plain TLB.Builder
 177         l10n_license               :: FullLocale lang -> Doc.Plain TLB.Builder
 178         l10n_help_version          :: FullLocale lang -> Doc.Plain TLB.Builder
 179         l10n_help_license          :: FullLocale lang -> Doc.Plain TLB.Builder
 180         l10n_help_command_source   :: FullLocale lang -> Doc.Plain TLB.Builder
 181         l10n_help_command_compile  :: FullLocale lang -> Doc.Plain TLB.Builder
 182         l10n_help_command_schema   :: FullLocale lang -> Doc.Plain TLB.Builder
 183         l10n_help_opt_lang         :: FullLocale lang -> Doc.Plain TLB.Builder
 184         l10n_help_opt_output       :: FullLocale lang -> Doc.Plain TLB.Builder
 185         l10n_help_opt_output_css   :: FullLocale lang -> Doc.Plain TLB.Builder
 186         l10n_help_opt_output_js    :: FullLocale lang -> Doc.Plain TLB.Builder
 187         l10n_help_opt_dump_tct     :: FullLocale lang -> Doc.Plain TLB.Builder
 188         l10n_help_opt_dump_xml     :: FullLocale lang -> Doc.Plain TLB.Builder
 189         l10n_help_opt_dump_deps    :: FullLocale lang -> Doc.Plain TLB.Builder
 190         l10n_help_opt_dump_dtc     :: FullLocale lang -> Doc.Plain TLB.Builder
 191         l10n_help_format           :: FullLocale lang -> Doc.Plain TLB.Builder
 192         l10n_help_format_plain     :: FullLocale lang -> Doc.Plain TLB.Builder
 193         l10n_help_format_html5     :: FullLocale lang -> Doc.Plain TLB.Builder
 194         l10n_help_format_xml       :: FullLocale lang -> Doc.Plain TLB.Builder
 195         l10n_help_opt_input        :: FullLocale lang -> Doc.Plain TLB.Builder
 196         l10n_help_opt_help_full    :: FullLocale lang -> Doc.Plain TLB.Builder
 197         l10n_help_opt_help_compact :: FullLocale lang -> Doc.Plain TLB.Builder
 198         l10n_help_opt_verbosity    :: FullLocale lang -> Doc.Plain TLB.Builder
 199
 200 instance L10n EN where
 201         l10n_cli _ = "Compiler of Convivial Technical Document (DTC)."
 202         l10n_license _ =
 203                 fromString $
 204                 List.intercalate "\n"
 205                  [ "License: GNU GPLv3+"
 206                  , "Copyright: Julien Moutinho <julm+textphile@sourcephile.fr>"
 207                  , ""
 208                  , "hdoc is free software: you can redistribute it and/or modify it"
 209                  , "under the terms of the GNU General Public License (GPL)"
 210                  , "as published by the Free Software Foundation;"
 211                  , "either in version 3, or (at your option) any later version."
 212                  , ""
 213                  , "hdoc is distributed in the hope that it will be useful,"
 214                  , "but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY"
 215                  , "or FITNESS FOR A PARTICULAR PURPOSE."
 216                  , ""
 217                  , "See the GNU GPL for more details."
 218                  , "You should have received a copy of the GNU GPL along with hdoc."
 219                  , "If not, see: http://www.gnu.org/licenses/"
 220                  ]
 221         l10n_help_version         _ = "Show the version of this program."
 222         l10n_help_license         _ = "Inform about the license of this program."
 223         l10n_help_command_source  _ = "Format the source code of a TCT document."
 224         l10n_help_command_compile _ = "Compile a TCT document into a format optimized for reading."
 225         l10n_help_command_schema  _ = "Show in RNC (RelaxNG Compact) format the XML schema of the DTC format."
 226         l10n_help_opt_lang l = mconcat
 227          [ "Use the language given by "
 228          , l10n_var $ l10n_var_locale l
 229          , "."
 230          ]
 231         l10n_help_opt_output l = mconcat
 232          [ "Output document into "
 233          , l10n_var $ l10n_var_file l
 234          ]
 235         l10n_help_opt_output_css  l = mconcat
 236          [ "Output CSS stylesheet into "
 237          , l10n_var $ l10n_var_file l
 238          , " (if any), instead of incorporating it into the HTML."
 239          ]
 240         l10n_help_opt_output_js l = mconcat
 241          [ "Output JavaScript script into "
 242          , l10n_var $ l10n_var_file l
 243          , " (if any), instead of incorporating it into the HTML."
 244          ]
 245         l10n_help_opt_dump_tct l = mconcat
 246          [ "Dump internal TCT representation of "
 247          , l10n_var $ l10n_var_file l,".tct file,"
 248          , " in a"
 249          , l10n_var $ l10n_var_file l,".tct.dump file."
 250          ]
 251         l10n_help_opt_dump_xml l = mconcat
 252          [ "Dump internal XML representation of "
 253          , l10n_var $ l10n_var_file l,".tct file,"
 254          , " in a"
 255          , l10n_var $ l10n_var_file l,".xml.dump file."
 256          ]
 257         l10n_help_opt_dump_deps l = mconcat
 258          [ "Dump dependencies of ", l10n_var $ l10n_var_file l,".tct file"
 259          , " in ", l10n_var $ l10n_var_file l,".deps file,"
 260          , " separated by newlines."
 261          ]
 262         l10n_help_opt_dump_dtc      _ = "Dump internal representation of DTC."
 263         l10n_help_opt_help_full     _ = "Print a commented grammar tree to help using this program."
 264         l10n_help_opt_help_compact  _ = "Print an uncommented grammar tree to help using this program."
 265         l10n_help_format            _ = "Output format."
 266         l10n_help_format_plain      _ = "Output as plain text."
 267         l10n_help_format_html5      _ = "Output as HTML5."
 268         l10n_help_format_xml        _ = "Output as XML."
 269         l10n_help_opt_input l = mconcat
 270          [ "Read input from ", l10n_var $ l10n_var_file l, "." ]
 271         l10n_help_opt_verbosity _ =
 272                 "Verbosity level.\
 273                 \\n(default: "<>con "info"<>")"
 274 instance L10n FR where
 275         l10n_cli _ = "Compilateur de Document Technique Convivial (DTC)."
 276         l10n_license _ =
 277                 fromString $
 278                 List.intercalate "\n"
 279                  [ "Licence : GPLv3+ GNU"
 280                  , "Auteur : Julien Moutinho <julm+textphile@sourcephile.fr>"
 281                  , ""
 282                  , "textphile est un logiciel libre : vous pouvez le redistribuer et/ou le modifier"
 283                  , "selon les termes de la Licence Publique Générale (GPL) GNU"
 284                  , "telle que publiée par la Free Software Foundation ;"
 285                  , "en version 3, ou (à votre choix) n’importe quelle version ultérieure."
 286                  , ""
 287                  , "textphile est distribué dans l’espoir qu’il sera utile,"
 288                  , "mais SANS AUCUNE GARANTIE ; sans même la garantie implicite de COMMERCIALISATION"
 289                  , "ou de CONVENANCE À UN BUT PARTICULIER."
 290                  , ""
 291                  , "Voyez la GPL pour davantage de détails."
 292                  , "Vous devriez avoir reçu une copie de la GPL avec textphile."
 293                  , "Si non, voyez : http://www.gnu.org/licenses/"
 294                  ]
 295         l10n_help_version         _ = "Affiche la version de ce logiciel."
 296         l10n_help_license         _ = "Informe sur la licence de ce logiciel."
 297         l10n_help_command_source  _ = "Lit un document TCT et écrit un rendu préservant sa syntaxe."
 298         l10n_help_command_compile _ = "Compile un document TCT vers un format optimisé pour la lecture."
 299         l10n_help_command_schema  _ = "Affiche au format RNC (RelaxNG Compact) le schéma XML du format DTC."
 300         l10n_help_opt_lang l = mconcat
 301          [ "Utilise le langage indiqué par "
 302          , l10n_var $ l10n_var_locale l, "." ]
 303         l10n_help_opt_output l = mconcat
 304          [ "Écrit dans ", l10n_var $ l10n_var_file l, "." ]
 305         l10n_help_opt_output_css l = mconcat
 306          [ "Écrit la feuille de style CSS dans "
 307          , l10n_var $ l10n_var_file l
 308          , ", au lieu de l’incorporer dans le HTML."
 309          ]
 310         l10n_help_opt_output_js l = mconcat
 311          [ "Écrit le script JavaScript dans "
 312          , l10n_var $ l10n_var_file l
 313          , ", au lieu de l’incorporer dans le HTML."
 314          ]
 315         l10n_help_opt_dump_tct l = mconcat
 316          [ "Écrit la représentation TCT interne de "
 317          , l10n_var $ l10n_var_file l,".tct,"
 318          , " dans "
 319          , l10n_var $ l10n_var_file l,".tct.dump."
 320          ]
 321         l10n_help_opt_dump_xml l = mconcat
 322          [ "Écrit la représentation XML interne de "
 323          , l10n_var $ l10n_var_file l,".tct,"
 324          , " dans "
 325          , l10n_var $ l10n_var_file l,".xml.dump."
 326          ]
 327         l10n_help_opt_dump_deps l = mconcat
 328          [ "Écrit les dépendences de ", l10n_var $ l10n_var_file l,".tct"
 329          , " dans ", l10n_var $ l10n_var_file l,".deps,"
 330          , " séparées par des retours à la ligne."
 331          ]
 332         l10n_help_opt_dump_dtc     _ = "Écrit la représentation interne du DTC."
 333         l10n_help_opt_help_full    _ = "Affiche un arbre grammatical avec commentaires pour aider à utiliser ce programme."
 334         l10n_help_opt_help_compact _ = "Affiche un arbre grammatical sans commentaires pour aider à utiliser ce programme."
 335         l10n_help_format           _ = "Format de sortie."
 336         l10n_help_format_plain     _ = "Produit du texte brut."
 337         l10n_help_format_html5     _ = "Produit du HTML5."
 338         l10n_help_format_xml       _ = "Produit du XML."
 339         l10n_help_opt_input l = mconcat
 340          [ "Lit depuis ", l10n_var $ l10n_var_file l, "." ]
 341         l10n_help_opt_verbosity _ =
 342                 "Niveau de verbosité.\
 343                 \\n(défault : "<>con "info"<>")"
 344
 345 -- ** Class 'L10n_Var'
 346 class L10n_Var lang where
 347         l10n_var_file   :: FullLocale lang -> Name
 348         l10n_var_locale :: FullLocale lang -> Name
 349 instance L10n_Var EN where
 350         l10n_var_file   _ = "file"
 351         l10n_var_locale _ = "locale"
 352 instance L10n_Var FR where
 353         l10n_var_file   _ = "fichier"
 354         l10n_var_locale _ = "locale"