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
90 when (trace_XML trace) $ do
91 hPutStrLn stderr "### XML ###"
92 let xml = TCT.Write.XML.xmlDocument tct
93 hPrint stderr $ Tree.Pretty xml
98 TCT.Write.Plain.plainDocument tct
100 Blaze.renderMarkupToByteStringIO BS.putStr $
101 TCT.Write.HTML5.html5Document tct
103 mainWithCommand (CommandDTC ArgsDTC{..}) =
104 readFile input $ \_fp txt ->
105 case TCT.readTCTs input txt of
106 Left err -> error $ P.parseErrorPretty err
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
118 when (trace_DTC trace) $ do
119 hPutStrLn stderr "### DTC ###"
123 Blaze.prettyMarkupIO Blaze.DTC.indentTag BS.putStr $
124 DTC.Write.XML.xmlDocument locale dtc
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
135 instance IsList (Opt.Mod f a) where
136 type Item (Opt.Mod f a) = Opt.Mod f a
140 readMap :: Map String a -> ReadM a
143 case Map.lookup s m of
144 Nothing -> Left $ "cannot parse value \"" <> s
145 <> "\"\nexpecting one of: "
146 <> (List.intercalate ", " $ Map.keys m)
157 pCommand :: Lang -> Parser Command
162 info (CommandTCT <$> pArgsTCT) $
163 progDesc "TCT (Texte Convivial Technique) rendition."
168 info (CommandDTC <$> pArgsDTC lang) $
169 progDesc "DTC (Document Technique Convivial) rendition."
174 info (CommandRNC <$> pArgsRNC) $
175 progDesc "RNC (RelaxNG Compact) schema."
185 instance Default Trace where
191 instance Semigroup Trace where
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
198 instance Monoid Trace where
202 pTrace :: Parser Trace
209 , help $ "Print trace. (choices: "
210 <> (List.intercalate ", " $ Map.keys m) <> ")"
214 [ ("tct", def{trace_TCT=True})
215 , ("xml", def{trace_XML=True})
216 , ("dtc", def{trace_DTC=True})
223 , format :: TctFormat
227 pArgsTCT :: Parser ArgsTCT
230 <$> argument str (metavar "FILE")
234 -- *** Type 'TctFormat'
239 pTctFormat :: Parser TctFormat
241 flag TctFormatPlain TctFormatPlain
243 , help "Render as plain text."
245 flag TctFormatHTML5 TctFormatHTML5
247 , help "Render as HTML5."
254 , format :: DtcFormat
258 pArgsDTC :: Lang -> Parser ArgsDTC
261 <$> argument str (metavar "FILE")
266 pLocale :: Lang -> Parser (LocaleIn Langs)
269 (maybeReader $ \s -> Map.lookup (Text.pack s) $ locales @Langs)
277 -- *** Type 'DtcFormat'
282 pDtcFormat :: Parser DtcFormat
284 flag DtcFormatHTML5 DtcFormatHTML5
286 , help "Render as HTML5."
288 flag DtcFormatHTML5 DtcFormatXML
290 , help "Render as XML."
297 pArgsRNC :: Parser ArgsRNC
298 pArgsRNC = pure ArgsRNC
303 <$> strOption ( long "hello"
305 <> help "Target for the greeting")
306 <*> switch ( long "quiet"
308 <> help "Whether to be quiet")
309 <*> option auto ( long "enthusiasm"
310 <> help "How enthusiastically to greet"