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