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