1 {-# LANGUAGE DataKinds #-}
2 {-# LANGUAGE DuplicateRecordFields #-}
3 {-# LANGUAGE OverloadedLists #-}
4 {-# LANGUAGE TypeApplications #-}
5 {-# LANGUAGE TypeFamilies #-}
6 {-# LANGUAGE UndecidableInstances #-}
7 {-# OPTIONS_GHC -fno-warn-orphans #-}
10 import Control.Monad (forM_, when)
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
40 import qualified Data.TreeSeq.Strict as Tree
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
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
58 type Langs = '[FR, EN]
59 type Lang = LocaleIn Langs
64 (\v -> Map.findWithDefault
65 (LocaleIn @Langs en_US)
66 (Text.pack $ List.takeWhile (\c -> Char.isAlphaNum c || c == '_') v)
69 <$> Env.lookupEnv "LANG"
70 cmd <- execParser $ pArgv lang
74 info (pCommand lang <**> helper) $ mconcat
76 , progDesc "document tool"
77 , header "hdoc - TCT and DTC command line tool"
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
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.document tct
92 hPrint stderr $ Tree.Pretty xml
96 TCT.Write.Plain.document tct
98 Blaze.renderMarkupToByteStringIO BS.putStr $
99 TCT.Write.HTML5.document tct
101 mainWithCommand (CommandDTC ArgsDTC{..}) =
102 readFile input $ \_fp txt ->
103 case TCT.readTCTs input txt of
104 Left err -> error $ P.parseErrorPretty err
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
116 when (trace_DTC trace) $ do
117 hPutStrLn stderr "### DTC ###"
121 Blaze.prettyMarkupIO Blaze.DTC.indentTag BS.putStr $
122 DTC.Write.XML.xmlDocument locale dtc
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
133 instance IsList (Opt.Mod f a) where
134 type Item (Opt.Mod f a) = Opt.Mod f a
138 readMap :: Map String a -> ReadM a
141 case Map.lookup s m of
142 Nothing -> Left $ "cannot parse value \"" <> s
143 <> "\"\nexpecting one of: "
144 <> (List.intercalate ", " $ Map.keys m)
155 pCommand :: Lang -> Parser Command
160 info (CommandTCT <$> pArgsTCT) $
161 progDesc "TCT (Texte Convivial Technique) rendition."
166 info (CommandDTC <$> pArgsDTC lang) $
167 progDesc "DTC (Document Technique Convivial) rendition."
172 info (CommandRNC <$> pArgsRNC) $
173 progDesc "RNC (RelaxNG Compact) schema."
183 instance Default Trace where
189 instance Semigroup Trace where
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
196 instance Monoid Trace where
200 pTrace :: Parser Trace
207 , help $ "Print trace. (choices: "
208 <> (List.intercalate ", " $ Map.keys m) <> ")"
212 [ ("tct", def{trace_TCT=True})
213 , ("xml", def{trace_XML=True})
214 , ("dtc", def{trace_DTC=True})
221 , format :: TctFormat
225 pArgsTCT :: Parser ArgsTCT
228 <$> argument str (metavar "FILE")
232 -- *** Type 'TctFormat'
237 pTctFormat :: Parser TctFormat
239 flag TctFormatPlain TctFormatPlain
241 , help "Render as plain text."
243 flag TctFormatHTML5 TctFormatHTML5
245 , help "Render as HTML5."
252 , format :: DtcFormat
256 pArgsDTC :: Lang -> Parser ArgsDTC
259 <$> argument str (metavar "FILE")
264 pLocale :: Lang -> Parser (LocaleIn Langs)
267 (maybeReader $ \s -> Map.lookup (Text.pack s) $ locales @Langs)
275 -- *** Type 'DtcFormat'
280 pDtcFormat :: Parser DtcFormat
282 flag DtcFormatHTML5 DtcFormatHTML5
284 , help "Render as HTML5."
286 flag DtcFormatHTML5 DtcFormatXML
288 , help "Render as XML."
295 pArgsRNC :: Parser ArgsRNC
296 pArgsRNC = pure ArgsRNC
301 <$> strOption ( long "hello"
303 <> help "Target for the greeting")
304 <*> switch ( long "quiet"
306 <> help "Whether to be quiet")
307 <*> option auto ( long "enthusiasm"
308 <> help "How enthusiastically to greet"