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