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