exe/cli/Main.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE DuplicateRecordFields #-}
   3 {-# LANGUAGE TypeApplications #-}
   4 {-# LANGUAGE UndecidableInstances #-}
   5 {-# OPTIONS_GHC -fno-warn-orphans #-}
   6 module Main where
   7
   8 import Control.Monad (forM_)
   9 import Data.Bool
  10 import Data.Eq (Eq(..))
  11 import Data.Either (Either(..))
  12 import Data.Function (($), (.))
  13 import Data.Functor ((<$>))
  14 import Data.Maybe (fromMaybe)
  15 import Data.Monoid (Monoid(..))
  16 import Data.Semigroup (Semigroup(..))
  17 import Options.Applicative as Opt
  18 import Prelude (error)
  19 import System.IO (IO, FilePath, hPrint, hPutStrLn, stderr, stdout)
  20 import qualified Data.ByteString as BS
  21 import qualified Data.Char as Char
  22 import qualified Data.Text.IO as Text
  23 import qualified Data.Text as Text
  24 import qualified Data.List as List
  25 import qualified Text.Blaze.Renderer.Utf8 as Blaze
  26 import qualified Text.Blaze.Utils as Blaze
  27 import qualified Data.Map.Strict as Map
  28 import qualified System.Environment as Env
  29
  30 import Data.Locale
  31
  32 import qualified Data.TreeSeq.Strict as Tree
  33 import qualified Language.DTC.Read.TCT as DTC.Read.TCT
  34 import qualified Language.DTC.Sym as DTC
  35 import qualified Language.DTC.Write.HTML5 as DTC.Write.HTML5
  36 import qualified Language.DTC.Write.XML   as DTC.Write.XML
  37 import qualified Language.RNC.Write as RNC
  38 import qualified Language.TCT as TCT
  39 import qualified Language.TCT.Write.HTML5 as TCT.Write.HTML5
  40 import qualified Language.TCT.Write.XML   as TCT.Write.XML
  41 import qualified Text.Blaze.DTC   as Blaze.DTC
  42 import qualified Text.Blaze.HTML5 as Blaze.HTML5
  43 import qualified Text.Megaparsec  as P
  44
  45 import Read
  46
  47 type Langs = '[FR, EN]
  48 type Lang = LocaleIn Langs
  49
  50 main :: IO ()
  51 main = do
  52         lang <-
  53                 (\v -> Map.findWithDefault
  54                  (LocaleIn @Langs en_US)
  55                  (Text.pack $ List.takeWhile (\c -> Char.isAlphaNum c || c == '_') v)
  56                  (locales @Langs)) .
  57                 fromMaybe ""
  58                  <$> Env.lookupEnv "LANG"
  59         cmd <- execParser $ p_Argv lang
  60         mainWithCommand cmd
  61         where
  62         p_Argv lang =
  63                 info (p_Command lang <**> helper) $ mconcat $
  64                  [ fullDesc
  65                  , progDesc "document tool"
  66                  , header "hdoc - TCT and DTC command line tool"
  67                  ]
  68
  69 mainWithCommand :: Command -> IO ()
  70 mainWithCommand (CommandTCT ArgsTCT{..}) =
  71         readFile input $ \_fp txt ->
  72                 case TCT.readTCTs input txt of
  73                  Left err -> error $ P.parseErrorPretty err
  74                  Right tct -> do
  75                         hPrint stderr $ Tree.Pretty tct
  76                         case format of
  77                          TctFormatHTML5 ->
  78                                 Blaze.renderMarkupToByteStringIO BS.putStr $
  79                                 TCT.Write.HTML5.html5Document tct
  80 mainWithCommand (CommandDTC ArgsDTC{..}) =
  81         readFile input $ \_fp txt ->
  82                 case TCT.readTCTs input txt of
  83                  Left err -> error $ P.parseErrorPretty err
  84                  Right tct -> do
  85                         hPutStrLn stderr "### TCT ###"
  86                         hPrint stderr $ Tree.Pretty tct
  87                         let xml = TCT.Write.XML.xmlDocument tct
  88                         hPutStrLn stderr "### XML ###"
  89                         hPrint stderr $ Tree.Pretty xml
  90                         case DTC.Read.TCT.readDTC xml of
  91                          Left err -> error $ P.parseErrorPretty err
  92                          Right dtc -> do
  93                                 hPutStrLn stderr "### DTC ###"
  94                                 hPrint stderr dtc
  95                                 case format of
  96                                  DtcFormatXML ->
  97                                         Blaze.prettyMarkupIO Blaze.DTC.indentTag BS.putStr $
  98                                         DTC.Write.XML.xmlDocument locale dtc
  99                                  DtcFormatHTML5 ->
 100                                         Blaze.prettyMarkupIO Blaze.HTML5.indentTag BS.putStr $
 101                                         DTC.Write.HTML5.html5Document locale dtc
 102 mainWithCommand (CommandRNC ArgsRNC{}) =
 103         forM_ DTC.dtcRNC $ \w ->
 104                 Text.hPutStrLn stdout $ RNC.renderWriter w
 105
 106 -- * Type 'Command'
 107 data Command
 108  =   CommandTCT ArgsTCT
 109  |   CommandDTC ArgsDTC
 110  |   CommandRNC ArgsRNC
 111
 112 p_Command :: Lang -> Parser Command
 113 p_Command lang =
 114         subparser (
 115                 command "tct" $
 116                         info (CommandTCT <$> p_ArgsTCT <**> helper) $
 117                                 progDesc "TCT (Texte Convivial Technique) rendition.") <|>
 118         subparser (
 119                 command "dtc" $
 120                         info (CommandDTC <$> p_ArgsDTC lang <**> helper) $
 121                                 progDesc "DTC (Document Technique Convivial) rendition.") <|>
 122         subparser (
 123                 command "rnc" $
 124                         info (CommandRNC <$> p_ArgsRNC <**> helper) $
 125                                 progDesc "RNC (RelaxNG Compact) schema.")
 126
 127 -- ** Type 'ArgsTCT'
 128 data ArgsTCT
 129  =   ArgsTCT
 130  {   input  :: FilePath
 131  ,   format :: TctFormat
 132  }
 133
 134 p_ArgsTCT :: Parser ArgsTCT
 135 p_ArgsTCT =
 136         ArgsTCT
 137          <$> argument str (metavar "FILE")
 138          <*> p_TctFormat
 139
 140 -- *** Type 'TctFormat'
 141 data TctFormat
 142  =   TctFormatHTML5
 143
 144 p_TctFormat :: Parser TctFormat
 145 p_TctFormat =
 146         flag TctFormatHTML5 TctFormatHTML5
 147          (long "html5" <> help "Render as HTML5.")
 148
 149 -- ** Type 'ArgsDTC'
 150 data ArgsDTC
 151  =   ArgsDTC
 152  {   input  :: FilePath
 153  ,   format :: DtcFormat
 154  ,   locale :: Lang
 155  -- ,   argsDTC_locale :: LocaleIn Langs
 156  }
 157 p_ArgsDTC :: Lang -> Parser ArgsDTC
 158 p_ArgsDTC lang =
 159         ArgsDTC
 160          <$> argument str (metavar "FILE")
 161          <*> p_DtcFormat
 162          <*> p_Locale lang
 163
 164 p_Locale :: Lang -> Parser (LocaleIn Langs)
 165 p_Locale lang =
 166         option
 167          (maybeReader $ \s -> Map.lookup (Text.pack s) $ locales @Langs)
 168          ( long "lang"
 169          <> help "Language."
 170          <> showDefault
 171          <> value lang
 172          <> metavar "LOCALE")
 173
 174 -- *** Type 'DtcFormat'
 175 data DtcFormat
 176  =   DtcFormatHTML5
 177  |   DtcFormatXML
 178
 179 p_DtcFormat :: Parser DtcFormat
 180 p_DtcFormat =
 181         flag DtcFormatHTML5 DtcFormatHTML5
 182          (long "html5" <> help "Render as HTML5.") <|>
 183         flag DtcFormatHTML5 DtcFormatXML
 184          (long "xml"   <> help "Render as XML.")
 185
 186 -- ** Type 'ArgsRNC'
 187 data ArgsRNC
 188  =   ArgsRNC
 189
 190 p_ArgsRNC :: Parser ArgsRNC
 191 p_ArgsRNC = pure ArgsRNC
 192
 193
 194 {-
 195         Args
 196          <$> strOption (  long "hello"
 197                        <> metavar "TARGET"
 198                        <> help "Target for the greeting")
 199          <*> switch (  long "quiet"
 200                     <> short 'q'
 201                     <> help "Whether to be quiet")
 202          <*> option auto ( long "enthusiasm"
 203                          <> help "How enthusiastically to greet"
 204                          <> showDefault
 205                          <> value 1
 206                          <> metavar "INT")
 207 -}