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