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 Control.Monad.IO.Class (MonadIO(..))
  12 import Data.Bool
  13 import Data.Default.Class (Default(..))
  14 import Data.Either (Either(..))
  15 import Data.Eq (Eq(..))
  16 import Data.Function (($), (.))
  17 import Data.Functor ((<$>))
  18 import Data.Locale
  19 import Data.Map.Strict (Map)
  20 import Data.Maybe (Maybe(..), fromMaybe)
  21 import Data.Monoid (Monoid(..))
  22 import Data.Semigroup (Semigroup(..))
  23 import Data.String (String)
  24 import GHC.Exts (IsList(..))
  25 import Options.Applicative as Opt
  26 import Prelude (error)
  27 import System.IO (IO, FilePath, hPrint, hPutStrLn, stderr, stdout)
  28 import Text.Show (Show(..))
  29 import qualified Data.ByteString as BS
  30 import qualified Data.ByteString.Lazy as BSL
  31 import qualified Data.Char as Char
  32 import qualified Data.List as List
  33 import qualified Data.Map.Strict as Map
  34 import qualified Data.Text as Text
  35 import qualified Data.Text.IO as Text
  36 import qualified Data.Text.Lazy as TL
  37 import qualified Data.Text.Lazy.Encoding as TL
  38 import qualified Data.Text.Lazy.IO as TL
  39 import qualified Data.TreeSeq.Strict as Tree
  40 import qualified System.Environment as Env
  41 import qualified Text.Blaze.Renderer.Utf8 as Blaze
  42 import qualified Text.Blaze.Utils as Blaze
  43 import qualified Text.Megaparsec as P
  44
  45 -- TCT imports
  46 import qualified Language.TCT             as TCT
  47 import qualified Language.TCT.Write.HTML5 as TCT.Write.HTML5
  48 import qualified Language.TCT.Write.Plain as TCT.Write.Plain
  49 import qualified Language.TCT.Write.XML   as TCT.Write.XML
  50
  51 -- DTC imports
  52 import qualified Language.DTC.Read.TCT    as DTC.Read.TCT
  53 import qualified Language.DTC.Sym         as DTC
  54 import qualified Language.DTC.Write.HTML5 as DTC.Write.HTML5
  55 import qualified Language.DTC.Write.XML   as DTC.Write.XML
  56 import qualified Language.RNC.Write       as RNC
  57 import qualified Text.Blaze.DTC           as Blaze.DTC
  58 import qualified Text.Blaze.HTML5         as Blaze.HTML5
  59
  60 type Langs = '[FR, EN]
  61 type Lang  = LocaleIn Langs
  62
  63 main :: IO ()
  64 main = do
  65         lang <-
  66                 (\v -> Map.findWithDefault
  67                  (LocaleIn @Langs en_US)
  68                  (Text.pack $ List.takeWhile (\c -> Char.isAlphaNum c || c == '_') v)
  69                  (locales @Langs)) .
  70                 fromMaybe ""
  71                  <$> Env.lookupEnv "LANG"
  72         cmd <- execParser $ pArgv lang
  73         mainWithCommand cmd
  74         where
  75         pArgv lang =
  76                 info (pCommand lang <**> helper) $ mconcat
  77                  [ fullDesc
  78                  , progDesc "document tool"
  79                  , header "hdoc - command line tool for TCT and DTC technical documents"
  80                  ]
  81
  82 mainWithCommand :: Command -> IO ()
  83 mainWithCommand (CommandTCT ArgsTCT{..}) = do
  84         TCT.readFile input >>= \case
  85          Left err -> hPrint stderr err
  86          Right txt ->
  87                 case TCT.readTCTWithoutIncludes input txt of
  88                  Left err -> error $ show err
  89                  Right tct -> do
  90                         when (trace_TCT trace) $ do
  91                                 hPutStrLn stderr "### TCT ###"
  92                                 hPutStrLn stderr $ Tree.prettyTrees tct
  93                         when (trace_XML trace) $ do
  94                                 hPutStrLn stderr "### XML ###"
  95                                 let xml = TCT.Write.XML.document tct
  96                                 hPutStrLn stderr $ Tree.prettyTrees xml
  97                         case format of
  98                          TctFormatPlain ->
  99                                 TL.putStrLn $
 100                                 TCT.Write.Plain.document tct
 101                          TctFormatHTML5 ->
 102                                 Blaze.renderMarkupToByteStringIO BS.putStr $
 103                                 TCT.Write.HTML5.document tct
 104 mainWithCommand (CommandDTC ArgsDTC{..}) =
 105         TCT.readTCT input >>= \case
 106          Left err -> error $ show err
 107          Right tct -> do
 108                 when (trace_TCT trace) $ do
 109                         hPutStrLn stderr "### TCT ###"
 110                         hPutStrLn stderr $ Tree.prettyTrees tct
 111                 let xml = TCT.Write.XML.document tct
 112                 when (trace_XML trace) $ do
 113                         hPutStrLn stderr "### XML ###"
 114                         hPutStrLn stderr $ Tree.prettyTrees xml
 115                 case DTC.Read.TCT.readDTC xml of
 116                  Left err -> error $ P.parseErrorPretty err
 117                  Right dtc -> do
 118                         when (trace_DTC trace) $ do
 119                                 hPutStrLn stderr "### DTC ###"
 120                                 hPrint stderr dtc
 121                         case format of
 122                          DtcFormatXML ->
 123                                 Blaze.prettyMarkupIO Blaze.DTC.isInlinedElement BS.putStr $
 124                                 DTC.Write.XML.document locale dtc
 125                          DtcFormatHTML5 ->
 126                                 Blaze.prettyMarkupIO Blaze.HTML5.isInlinedElement BS.putStr $
 127                                 DTC.Write.HTML5.document locale dtc
 128 mainWithCommand (CommandRNC ArgsRNC{}) =
 129         forM_ DTC.schema $ \rule ->
 130                 Text.hPutStrLn stdout $ RNC.renderWriter rule
 131
 132 -- * Filesystem utilities
 133 readFile :: MonadIO m => FilePath -> (FilePath -> TL.Text -> m a) -> m a
 134 readFile fp f = do
 135         content <- liftIO $ BSL.readFile fp
 136         f fp $ TL.decodeUtf8 content
 137
 138 -- * Options utilities
 139
 140 instance IsList (Opt.Mod f a) where
 141         type Item (Opt.Mod f a) = Opt.Mod f a
 142         fromList = mconcat
 143         toList   = pure
 144
 145 readMap :: Map String a -> ReadM a
 146 readMap m =
 147         eitherReader $ \s ->
 148                 case Map.lookup s m of
 149                  Nothing -> Left $ "cannot parse value \"" <> s
 150                          <> "\"\nexpecting one of: "
 151                          <> (List.intercalate ", " $ Map.keys m)
 152                  Just a -> Right a
 153
 154 -- * Type 'Command'
 155 data Command
 156  =   CommandTCT ArgsTCT
 157  |   CommandDTC ArgsDTC
 158  |   CommandRNC ArgsRNC
 159
 160 pCommand :: Lang -> Parser Command
 161 pCommand lang =
 162         hsubparser
 163          [ metavar "tct"
 164          , command "tct" $
 165                 info (CommandTCT <$> pArgsTCT) $
 166                         progDesc "TCT (Texte Convivial Technique) rendition."
 167          ] <|>
 168         hsubparser
 169          [ metavar "dtc"
 170          , command "dtc" $
 171                 info (CommandDTC <$> pArgsDTC lang) $
 172                         progDesc "DTC (Document Technique Convivial) rendition."
 173          ] <|>
 174         hsubparser
 175          [ metavar "rnc"
 176          , command "rnc" $
 177                 info (CommandRNC <$> pArgsRNC) $
 178                         progDesc "RNC (RelaxNG Compact) schema."
 179          ]
 180
 181 -- * Type 'Trace'
 182 data Trace
 183  =   Trace
 184  {   trace_TCT :: Bool
 185  ,   trace_XML :: Bool
 186  ,   trace_DTC :: Bool
 187  }
 188 instance Default Trace where
 189         def = Trace
 190          { trace_TCT = False
 191          , trace_XML = False
 192          , trace_DTC = False
 193          }
 194 instance Semigroup Trace where
 195         x <> y =
 196                 Trace
 197                  { trace_TCT = trace_TCT x || trace_TCT y
 198                  , trace_XML = trace_XML x || trace_XML y
 199                  , trace_DTC = trace_DTC x || trace_DTC y
 200                  }
 201 instance Monoid Trace where
 202         mempty  = def
 203         mappend = (<>)
 204
 205 pTrace :: Parser Trace
 206 pTrace =
 207         (mconcat <$>) $
 208         many $
 209         option
 210          (readMap m)
 211          [ long "trace"
 212          , help $ "Print trace. (choices: "
 213                  <> (List.intercalate ", " $ Map.keys m) <> ")"
 214          ]
 215         where
 216         m = Map.fromList
 217          [ ("tct", def{trace_TCT=True})
 218          , ("xml", def{trace_XML=True})
 219          , ("dtc", def{trace_DTC=True})
 220          ]
 221
 222 -- ** Type 'ArgsTCT'
 223 data ArgsTCT
 224  =   ArgsTCT
 225  {   input  :: FilePath
 226  ,   format :: TctFormat
 227  ,   trace  :: Trace
 228  }
 229
 230 pArgsTCT :: Parser ArgsTCT
 231 pArgsTCT =
 232         ArgsTCT
 233          <$> argument str (metavar "FILE")
 234          <*> pTctFormat
 235          <*> pTrace
 236
 237 -- *** Type 'TctFormat'
 238 data TctFormat
 239  =   TctFormatPlain
 240  |   TctFormatHTML5
 241
 242 pTctFormat :: Parser TctFormat
 243 pTctFormat =
 244         flag TctFormatPlain TctFormatPlain
 245          [ long "plain"
 246          , help "Render as plain text."
 247          ] <|>
 248         flag TctFormatHTML5 TctFormatHTML5
 249          [ long "html5"
 250          , help "Render as HTML5."
 251          ]
 252
 253 -- ** Type 'ArgsDTC'
 254 data ArgsDTC
 255  =   ArgsDTC
 256  {   input  :: FilePath
 257  ,   format :: DtcFormat
 258  ,   locale :: Lang
 259  ,   trace  :: Trace
 260  }
 261 pArgsDTC :: Lang -> Parser ArgsDTC
 262 pArgsDTC lang =
 263         ArgsDTC
 264          <$> argument str (metavar "FILE")
 265          <*> pDtcFormat
 266          <*> pLocale lang
 267          <*> pTrace
 268
 269 pLocale :: Lang -> Parser (LocaleIn Langs)
 270 pLocale lang =
 271         option
 272          (maybeReader $ \s -> Map.lookup (Text.pack s) $ locales @Langs)
 273          [ long "lang"
 274          , help "Language."
 275          , showDefault
 276          , value lang
 277          , metavar "LOCALE"
 278          ]
 279
 280 -- *** Type 'DtcFormat'
 281 data DtcFormat
 282  =   DtcFormatHTML5
 283  |   DtcFormatXML
 284
 285 pDtcFormat :: Parser DtcFormat
 286 pDtcFormat =
 287         flag DtcFormatHTML5 DtcFormatHTML5
 288          [ long "html5"
 289          , help "Render as HTML5."
 290          ] <|>
 291         flag DtcFormatHTML5 DtcFormatXML
 292          [ long "xml"
 293          , help "Render as XML."
 294          ]
 295
 296 -- ** Type 'ArgsRNC'
 297 data ArgsRNC
 298  =   ArgsRNC
 299
 300 pArgsRNC :: Parser ArgsRNC
 301 pArgsRNC = pure ArgsRNC