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.readFile input >>= \case
  88          Left err -> IO.hPrint IO.stderr err
  89          Right txt ->
  90                 case TCT.readTCTWithoutIncludes input txt of
  91                  Left err -> error $ show err
  92                  Right tct -> do
  93                         when (DumpTCT_TCT`elem`dump) $
  94                                 writeFile (output`FilePath.replaceExtension`".tct.dump") $
  95                                         TL.pack $ Tree.prettyTrees tct
  96                         when (DumpTCT_XML`elem`dump) $
  97                                 let xml = TCT.Write.XML.document tct in
  98                                 writeFile (output`FilePath.replaceExtension`".xml.dump") $
  99                                         TL.pack $ Tree.prettyTrees xml
 100                         case format of
 101                          FormatTCT_Plain ->
 102                                 writeFile output $
 103                                 TCT.Write.Plain.document tct
 104                          FormatTCT_HTML5 ->
 105                                 withFile output IO.WriteMode $ \h ->
 106                                         Blaze.renderMarkupToByteStringIO (BS.hPutStr h) $
 107                                         TCT.Write.HTML5.document tct
 108 mainWithCommand (CommandDTC ArgsDTC{..}) =
 109         TCT.readTCT input >>= \case
 110          Left err -> error $ show err
 111          Right tct -> do
 112                 when (DumpDTC_TCT`elem`dump) $ do
 113                         writeFile (input`FilePath.replaceExtension`".tct.dump") $
 114                                 TL.pack $ Tree.prettyTrees tct
 115                 let xml = TCT.Write.XML.document tct
 116                 when (DumpDTC_XML`elem`dump) $ do
 117                         writeFile (input`FilePath.replaceExtension`".xml.dump") $
 118                                 TL.pack $ Tree.prettyTrees xml
 119                 case DTC.Read.TCT.readDTC xml of
 120                  Left err -> error $ P.parseErrorPretty err
 121                  Right dtc -> do
 122                         when (DumpDTC_DTC`elem`dump) $ do
 123                                 writeFile (input`FilePath.replaceExtension`".dtc.dump") $
 124                                         TL.pack $ show dtc
 125                         case format of
 126                          FormatDTC_XML ->
 127                                 withFile output IO.WriteMode $ \h ->
 128                                         Blaze.prettyMarkupIO Blaze.DTC.isInlinedElement (BS.hPutStr h) $
 129                                         DTC.Write.XML.document locale dtc
 130                          FormatDTC_HTML5 ->
 131                                 withFile output IO.WriteMode $ \h ->
 132                                         Blaze.prettyMarkupIO Blaze.HTML5.isInlinedElement (BS.hPutStr h) $
 133                                         DTC.Write.HTML5.document locale dtc
 134 mainWithCommand (CommandRNC ArgsRNC{}) =
 135         forM_ DTC.schema $ \rule ->
 136                 Text.hPutStrLn IO.stdout $ RNC.renderWriter rule
 137
 138 -- * Filesystem utilities
 139 writeFile :: FilePath -> TL.Text -> IO ()
 140 writeFile fp s = BSL.writeFile fp $ TL.encodeUtf8 s
 141
 142 withFile :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
 143 withFile = IO.withFile
 144
 145 -- * Options utilities
 146 instance IsList (Opt.Mod f a) where
 147         type Item (Opt.Mod f a) = Opt.Mod f a
 148         fromList = mconcat
 149         toList   = pure
 150
 151 readList :: [(String, a)] -> ReadM a
 152 readList m =
 153         eitherReader $ \s ->
 154                 case s`List.lookup`m of
 155                  Just a -> Right a
 156                  Nothing -> Left $
 157                         "cannot parse value \"" <> s
 158                          <> "\"\nexpecting one of: "
 159                          <> List.intercalate ", " (fst <$> m)
 160
 161 -- * Type 'Command'
 162 data Command
 163  =   CommandTCT ArgsTCT
 164  |   CommandDTC ArgsDTC
 165  |   CommandRNC ArgsRNC
 166
 167 pCommand :: Lang -> Parser Command
 168 pCommand lang =
 169         hsubparser
 170          [ metavar "tct"
 171          , command "tct" $
 172                 info (CommandTCT <$> pArgsTCT) $
 173                         progDesc "TCT (Texte Convivial Technique) rendition."
 174          ] <|>
 175         hsubparser
 176          [ metavar "dtc"
 177          , command "dtc" $
 178                 info (CommandDTC <$> pArgsDTC lang) $
 179                         progDesc "DTC (Document Technique Convivial) rendition."
 180          ] <|>
 181         hsubparser
 182          [ metavar "rnc"
 183          , command "rnc" $
 184                 info (CommandRNC <$> pArgsRNC) $
 185                         progDesc "RNC (RelaxNG Compact) schema."
 186          ]
 187
 188 pDump :: Ord a => [(String, a)] -> Parser (Set a)
 189 pDump formats =
 190         (mconcat <$>) $
 191         many $
 192         option
 193          (Set.singleton <$> readList formats)
 194          [ long "dump"
 195          , help $ "Dump an intermediate format. (choices: "
 196                  <> List.intercalate ", " (fst <$> formats) <> ")"
 197          ]
 198
 199 -- ** Type 'ArgsTCT'
 200 data ArgsTCT
 201  =   ArgsTCT
 202  {   input  :: FilePath
 203  ,   output :: FilePath
 204  ,   format :: FormatTCT
 205  ,   dump   :: Set DumpTCT
 206  }
 207
 208 pArgsTCT :: Parser ArgsTCT
 209 pArgsTCT =
 210         (setDefault <$>) $
 211         ArgsTCT
 212          <$> argument str (metavar "FILE")
 213          <*> strOption [ long "output"
 214                        , metavar "FILE"
 215                        , value ""
 216                        , help "write output to FILE"
 217                        ]
 218          <*> pFormatTCT
 219          <*> pDump [ ("tct", DumpTCT_TCT)
 220                    , ("xml", DumpTCT_XML) ]
 221         where
 222         setDefault a@ArgsTCT{..}
 223          | null output = (a::ArgsTCT){output=input`FilePath.replaceExtension`ext format}
 224          | otherwise   = a
 225         ext = \case
 226          FormatTCT_Plain -> ".txt"
 227          FormatTCT_HTML5 -> ".html"
 228
 229 -- *** Type 'FormatTCT'
 230 data FormatTCT
 231  =   FormatTCT_Plain
 232  |   FormatTCT_HTML5
 233
 234 pFormatTCT :: Parser FormatTCT
 235 pFormatTCT =
 236         flag FormatTCT_Plain FormatTCT_Plain
 237          [ long "plain"
 238          , help "Render as plain text."
 239          ] <|>
 240         flag FormatTCT_HTML5 FormatTCT_HTML5
 241          [ long "html5"
 242          , help "Render as HTML5."
 243          ]
 244
 245 -- *** Type 'DumpTCT'
 246 data DumpTCT
 247  =   DumpTCT_TCT
 248  |   DumpTCT_XML
 249  deriving (Eq, Ord, Show)
 250
 251 -- ** Type 'ArgsDTC'
 252 data ArgsDTC
 253  =   ArgsDTC
 254  {   input  :: FilePath
 255  ,   output :: FilePath
 256  ,   format :: FormatDTC
 257  ,   locale :: Lang
 258  ,   dump   :: Set DumpDTC
 259  }
 260 pArgsDTC :: Lang -> Parser ArgsDTC
 261 pArgsDTC lang =
 262         (setDefault <$>) $
 263         ArgsDTC
 264          <$> argument str (metavar "FILE")
 265          <*> strOption [ long "output"
 266                        , metavar "FILE"
 267                        , value ""
 268                        , help "write output to FILE"
 269                        ]
 270          <*> pFormatDTC
 271          <*> pLocale lang
 272          <*> pDump [ ("tct", DumpDTC_TCT)
 273                    , ("xml", DumpDTC_XML)
 274                    , ("dtc", DumpDTC_DTC) ]
 275         where
 276         setDefault a@ArgsDTC{..}
 277          | null output = (a::ArgsDTC){output=input`FilePath.replaceExtension`fmt format}
 278          | otherwise   = a
 279         fmt = \case
 280          FormatDTC_XML   -> ".xml"
 281          FormatDTC_HTML5 -> ".html"
 282
 283 pLocale :: Lang -> Parser (LocaleIn Langs)
 284 pLocale lang =
 285         option
 286          (maybeReader $ \s -> Map.lookup (Text.pack s) $ locales @Langs)
 287          [ long "lang"
 288          , help "Language."
 289          , showDefault
 290          , value lang
 291          , metavar "LOCALE"
 292          ]
 293
 294 -- *** Type 'FormatDTC'
 295 data FormatDTC
 296  =   FormatDTC_HTML5
 297  |   FormatDTC_XML
 298
 299 pFormatDTC :: Parser FormatDTC
 300 pFormatDTC =
 301         flag FormatDTC_HTML5 FormatDTC_HTML5
 302          [ long "html5"
 303          , help "Render as HTML5."
 304          ] <|>
 305         flag FormatDTC_HTML5 FormatDTC_XML
 306          [ long "xml"
 307          , help "Render as XML."
 308          ]
 309
 310 -- *** Type 'DumpDTC'
 311 data DumpDTC
 312  =   DumpDTC_TCT
 313  |   DumpDTC_XML
 314  |   DumpDTC_DTC
 315  deriving (Eq, Ord, Show)
 316
 317 -- ** Type 'ArgsRNC'
 318 data ArgsRNC
 319  =   ArgsRNC
 320
 321 pArgsRNC :: Parser ArgsRNC
 322 pArgsRNC = pure ArgsRNC