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         txt <- TCT.readFile input
  85         case TCT.readTCTWithoutIncludes input txt of
  86          Left err -> error $ show err
  87          Right tct -> do
  88                 when (trace_TCT trace) $ do
  89                         hPutStrLn stderr "### TCT ###"
  90                         hPutStrLn stderr $ Tree.prettyTrees tct
  91                 when (trace_XML trace) $ do
  92                         hPutStrLn stderr "### XML ###"
  93                         let xml = TCT.Write.XML.document tct
  94                         hPutStrLn stderr $ Tree.prettyTrees xml
  95                 case format of
  96                  TctFormatPlain ->
  97                         TL.putStrLn $
  98                         TCT.Write.Plain.document tct
  99                  TctFormatHTML5 ->
 100                         Blaze.renderMarkupToByteStringIO BS.putStr $
 101                         TCT.Write.HTML5.document tct
 102 mainWithCommand (CommandDTC ArgsDTC{..}) =
 103         TCT.readTCT input >>= \case
 104          Left err -> error $ show 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.isInlinedElement BS.putStr $
 122                                 DTC.Write.XML.document locale dtc
 123                          DtcFormatHTML5 ->
 124                                 Blaze.prettyMarkupIO Blaze.HTML5.isInlinedElement 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