exe/cli/Main.hs

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