exe/cli/Main.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE DuplicateRecordFields #-}
   3 {-# LANGUAGE OverloadedLists #-}
   4 {-# LANGUAGE TypeApplications #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 {-# LANGUAGE UndecidableInstances #-}
   7 {-# OPTIONS_GHC -fno-warn-orphans #-}
   8 module Main where
   9
  10 import Control.Monad (Monad(..), forM_, when)
  11 import Data.Bool
  12 import Data.Either (Either(..))
  13 import Data.Eq (Eq(..))
  14 import Data.Foldable (Foldable(..))
  15 import Data.Function (($), (.))
  16 import Data.Functor ((<$>))
  17 import Data.Locale
  18 import Data.Maybe (Maybe(..), fromMaybe)
  19 import Data.Monoid (Monoid(..))
  20 import Data.Ord (Ord(..))
  21 import Data.Semigroup (Semigroup(..))
  22 import Data.Set (Set)
  23 import Data.String (String)
  24 import Data.Tuple (fst)
  25 import GHC.Exts (IsList(..))
  26 import Options.Applicative as Opt
  27 import Prelude (error)
  28 import System.FilePath as FilePath
  29 import System.IO (IO, FilePath)
  30 import Text.Show (Show(..))
  31 import qualified Data.ByteString as BS
  32 import qualified Data.ByteString.Lazy as BSL
  33 import qualified Data.Char as Char
  34 import qualified Data.List as List
  35 import qualified Data.Map.Strict as Map
  36 import qualified Data.Set as Set
  37 import qualified Data.Text as Text
  38 import qualified Data.Text.IO as Text
  39 import qualified Data.Text.Lazy as TL
  40 import qualified Data.Text.Lazy.Encoding as TL
  41 import qualified Data.TreeSeq.Strict as Tree
  42 import qualified System.Environment as Env
  43 import qualified System.IO as IO
  44 import qualified Text.Blaze.Renderer.Utf8 as Blaze
  45 import qualified Text.Blaze.Utils as Blaze
  46 import qualified Text.Megaparsec as P
  47
  48 -- TCT imports
  49 import qualified Language.TCT             as TCT
  50 import qualified Language.TCT.Write.HTML5 as TCT.Write.HTML5
  51 import qualified Language.TCT.Write.Plain as TCT.Write.Plain
  52 import qualified Language.TCT.Write.XML   as TCT.Write.XML
  53
  54 -- DTC imports
  55 import qualified Language.DTC.Read.TCT    as DTC.Read.TCT
  56 import qualified Language.DTC.Sym         as DTC
  57 import qualified Language.DTC.Write.HTML5 as DTC.Write.HTML5
  58 import qualified Language.DTC.Write.XML   as DTC.Write.XML
  59 import qualified Language.RNC.Write       as RNC
  60 import qualified Text.Blaze.DTC           as Blaze.DTC
  61 import qualified Text.Blaze.HTML5         as Blaze.HTML5
  62
  63 type Langs = '[FR, EN]
  64 type Lang  = LocaleIn Langs
  65
  66 main :: IO ()
  67 main = do
  68         lang <-
  69                 (\v -> Map.findWithDefault
  70                  (LocaleIn @Langs en_US)
  71                  (Text.pack $ List.takeWhile (\c -> Char.isAlphaNum c || c == '_') v)
  72                  (locales @Langs)) .
  73                 fromMaybe ""
  74                  <$> Env.lookupEnv "LANG"
  75         cmd <- execParser $ pArgv lang
  76         mainWithCommand cmd
  77         where
  78         pArgv lang =
  79                 info (pCommand lang <**> helper) $ mconcat
  80                  [ fullDesc
  81                  , progDesc "document tool"
  82                  , header "hdoc - command line tool for TCT and DTC technical documents"
  83                  ]
  84
  85 mainWithCommand :: Command -> IO ()
  86 mainWithCommand (CommandTCT ArgsTCT{..}) = do
  87         TCT.readTCT input >>= \case
  88          Left err -> error $ show err
  89          Right tct -> do
  90                 when (DumpTCT_TCT`elem`dump) $
  91                         writeFile (output`FilePath.replaceExtension`".tct.dump") $
  92                                 TL.pack $ Tree.prettyTrees tct
  93                 when (DumpTCT_XML`elem`dump) $
  94                         let xml = TCT.Write.XML.document tct in
  95                         writeFile (output`FilePath.replaceExtension`".xml.dump") $
  96                                 TL.pack $ Tree.prettyTrees xml
  97                 case format of
  98                  FormatTCT_Plain ->
  99                         writeFile output $
 100                         TCT.Write.Plain.document tct
 101                  FormatTCT_HTML5 ->
 102                         withFile output IO.WriteMode $ \h ->
 103                                 Blaze.renderMarkupToByteStringIO (BS.hPutStr h) $
 104                                 TCT.Write.HTML5.document tct
 105 mainWithCommand (CommandDTC ArgsDTC{..}) =
 106         TCT.readTCT input >>= \case
 107          Left err -> error $ show err
 108          Right tct -> do
 109                 when (DumpDTC_TCT`elem`dump) $ do
 110                         writeFile (input`FilePath.replaceExtension`".tct.dump") $
 111                                 TL.pack $ Tree.prettyTrees tct
 112                 let xml = TCT.Write.XML.document tct
 113                 when (DumpDTC_XML`elem`dump) $ do
 114                         writeFile (input`FilePath.replaceExtension`".xml.dump") $
 115                                 TL.pack $ Tree.prettyTrees xml
 116                 case DTC.Read.TCT.readDTC xml of
 117                  Left err -> error $ P.parseErrorPretty err
 118                  Right dtc -> do
 119                         when (DumpDTC_DTC`elem`dump) $ do
 120                                 writeFile (input`FilePath.replaceExtension`".dtc.dump") $
 121                                         TL.pack $ show dtc
 122                         case format of
 123                          FormatDTC_XML ->
 124                                 withFile output IO.WriteMode $ \h ->
 125                                         Blaze.prettyMarkupIO Blaze.DTC.isInlinedElement (BS.hPutStr h) $
 126                                         DTC.Write.XML.document locale dtc
 127                          FormatDTC_HTML5 ->
 128                                 withFile output IO.WriteMode $ \h ->
 129                                         Blaze.prettyMarkupIO Blaze.HTML5.isInlinedElement (BS.hPutStr h) $
 130                                         DTC.Write.HTML5.document locale dtc
 131 mainWithCommand (CommandRNC ArgsRNC{}) =
 132         forM_ DTC.schema $ \rule ->
 133                 Text.hPutStrLn IO.stdout $ RNC.renderWriter rule
 134
 135 -- * Filesystem utilities
 136 writeFile :: FilePath -> TL.Text -> IO ()
 137 writeFile fp s = BSL.writeFile fp $ TL.encodeUtf8 s
 138
 139 withFile :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
 140 withFile = IO.withFile
 141
 142 -- * Options utilities
 143 instance IsList (Opt.Mod f a) where
 144         type Item (Opt.Mod f a) = Opt.Mod f a
 145         fromList = mconcat
 146         toList   = pure
 147
 148 readList :: [(String, a)] -> ReadM a
 149 readList m =
 150         eitherReader $ \s ->
 151                 case s`List.lookup`m of
 152                  Just a -> Right a
 153                  Nothing -> Left $
 154                         "cannot parse value \"" <> s
 155                          <> "\"\nexpecting one of: "
 156                          <> List.intercalate ", " (fst <$> m)
 157
 158 -- * Type 'Command'
 159 data Command
 160  =   CommandTCT ArgsTCT
 161  |   CommandDTC ArgsDTC
 162  |   CommandRNC ArgsRNC
 163
 164 pCommand :: Lang -> Parser Command
 165 pCommand lang =
 166         hsubparser
 167          [ metavar "tct"
 168          , command "tct" $
 169                 info (CommandTCT <$> pArgsTCT) $
 170                         progDesc "TCT (Texte Convivial Technique) rendition."
 171          ] <|>
 172         hsubparser
 173          [ metavar "dtc"
 174          , command "dtc" $
 175                 info (CommandDTC <$> pArgsDTC lang) $
 176                         progDesc "DTC (Document Technique Convivial) rendition."
 177          ] <|>
 178         hsubparser
 179          [ metavar "rnc"
 180          , command "rnc" $
 181                 info (CommandRNC <$> pArgsRNC) $
 182                         progDesc "RNC (RelaxNG Compact) schema."
 183          ]
 184
 185 pDump :: Ord a => [(String, a)] -> Parser (Set a)
 186 pDump formats =
 187         (mconcat <$>) $
 188         many $
 189         option
 190          (Set.singleton <$> readList formats)
 191          [ long "dump"
 192          , help $ "Dump an intermediate format. (choices: "
 193                  <> List.intercalate ", " (fst <$> formats) <> ")"
 194          ]
 195
 196 -- ** Type 'ArgsTCT'
 197 data ArgsTCT
 198  =   ArgsTCT
 199  {   input  :: FilePath
 200  ,   output :: FilePath
 201  ,   format :: FormatTCT
 202  ,   dump   :: Set DumpTCT
 203  }
 204
 205 pArgsTCT :: Parser ArgsTCT
 206 pArgsTCT =
 207         (setDefault <$>) $
 208         ArgsTCT
 209          <$> argument str (metavar "FILE")
 210          <*> strOption [ long "output"
 211                        , metavar "FILE"
 212                        , value ""
 213                        , help "write output to FILE"
 214                        ]
 215          <*> pFormatTCT
 216          <*> pDump [ ("tct", DumpTCT_TCT)
 217                    , ("xml", DumpTCT_XML) ]
 218         where
 219         setDefault a@ArgsTCT{..}
 220          | null output = (a::ArgsTCT){output=input`FilePath.replaceExtension`ext format}
 221          | otherwise   = a
 222         ext = \case
 223          FormatTCT_Plain -> ".txt"
 224          FormatTCT_HTML5 -> ".html"
 225
 226 -- *** Type 'FormatTCT'
 227 data FormatTCT
 228  =   FormatTCT_Plain
 229  |   FormatTCT_HTML5
 230
 231 pFormatTCT :: Parser FormatTCT
 232 pFormatTCT =
 233         flag FormatTCT_Plain FormatTCT_Plain
 234          [ long "plain"
 235          , help "Render as plain text."
 236          ] <|>
 237         flag FormatTCT_HTML5 FormatTCT_HTML5
 238          [ long "html5"
 239          , help "Render as HTML5."
 240          ]
 241
 242 -- *** Type 'DumpTCT'
 243 data DumpTCT
 244  =   DumpTCT_TCT
 245  |   DumpTCT_XML
 246  deriving (Eq, Ord, Show)
 247
 248 -- ** Type 'ArgsDTC'
 249 data ArgsDTC
 250  =   ArgsDTC
 251  {   input  :: FilePath
 252  ,   output :: FilePath
 253  ,   format :: FormatDTC
 254  ,   locale :: Lang
 255  ,   dump   :: Set DumpDTC
 256  }
 257 pArgsDTC :: Lang -> Parser ArgsDTC
 258 pArgsDTC lang =
 259         (setDefault <$>) $
 260         ArgsDTC
 261          <$> argument str (metavar "FILE")
 262          <*> strOption [ long "output"
 263                        , metavar "FILE"
 264                        , value ""
 265                        , help "write output to FILE"
 266                        ]
 267          <*> pFormatDTC
 268          <*> pLocale lang
 269          <*> pDump [ ("tct", DumpDTC_TCT)
 270                    , ("xml", DumpDTC_XML)
 271                    , ("dtc", DumpDTC_DTC) ]
 272         where
 273         setDefault a@ArgsDTC{..}
 274          | null output = (a::ArgsDTC){output=input`FilePath.replaceExtension`fmt format}
 275          | otherwise   = a
 276         fmt = \case
 277          FormatDTC_XML   -> ".xml"
 278          FormatDTC_HTML5 -> ".html"
 279
 280 pLocale :: Lang -> Parser (LocaleIn Langs)
 281 pLocale lang =
 282         option
 283          (maybeReader $ \s -> Map.lookup (Text.pack s) $ locales @Langs)
 284          [ long "lang"
 285          , help "Language."
 286          , showDefault
 287          , value lang
 288          , metavar "LOCALE"
 289          ]
 290
 291 -- *** Type 'FormatDTC'
 292 data FormatDTC
 293  =   FormatDTC_HTML5
 294  |   FormatDTC_XML
 295
 296 pFormatDTC :: Parser FormatDTC
 297 pFormatDTC =
 298         flag FormatDTC_HTML5 FormatDTC_HTML5
 299          [ long "html5"
 300          , help "Render as HTML5."
 301          ] <|>
 302         flag FormatDTC_HTML5 FormatDTC_XML
 303          [ long "xml"
 304          , help "Render as XML."
 305          ]
 306
 307 -- *** Type 'DumpDTC'
 308 data DumpDTC
 309  =   DumpDTC_TCT
 310  |   DumpDTC_XML
 311  |   DumpDTC_DTC
 312  deriving (Eq, Ord, Show)
 313
 314 -- ** Type 'ArgsRNC'
 315 data ArgsRNC
 316  =   ArgsRNC
 317
 318 pArgsRNC :: Parser ArgsRNC
 319 pArgsRNC = pure ArgsRNC