-{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main where
-import Control.Monad (forM_, when)
+-- import Data.Reflection (reify, Reifies(..))
+-- import qualified Data.Text.IO as Text
+import Control.Applicative (pure)
+import Control.Monad (Monad(..), forM_, when)
import Data.Bool
import Data.Default.Class (Default(..))
import Data.Either (Either(..))
import Data.Eq (Eq(..))
+import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
-import Data.Map.Strict (Map)
-import Data.Maybe (Maybe(..), fromMaybe)
+import Data.Locale
+import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Monoid (Monoid(..))
+import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
-import Data.String (String)
+import Data.String (String, IsString(..))
+import Data.Void (Void)
import GHC.Exts (IsList(..))
-import Options.Applicative as Opt
import Prelude (error)
-import System.IO (IO, FilePath, hPrint, hPutStrLn, stderr, stdout)
+import System.FilePath as FilePath
+import System.IO (IO, FilePath)
+import Text.Show (Show(..))
import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BSL
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
import qualified Data.Text as Text
-import qualified Data.Text.IO as Text
import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Text.Lazy.IO as TL
+import qualified Data.TreeSeq.Strict as Tree
+import qualified Data.Version as Version
+import qualified Paths_hdoc as Hdoc
+import qualified System.Directory as IO
import qualified System.Environment as Env
+import qualified System.IO as IO
+import qualified System.IO.Error as IO
import qualified Text.Blaze.Renderer.Utf8 as Blaze
import qualified Text.Blaze.Utils as Blaze
+import qualified Text.Megaparsec as P
-import Data.Locale
+import qualified Language.TCT as TCT
+import qualified Language.TCT.Write.HTML5 as TCT
+import qualified Language.TCT.Write.Plain as TCT
+import qualified Language.TCT.Write.XML as TCT
+import qualified Language.DTC.Read.TCT as DTC
+import qualified Language.DTC.Sym as DTC
+import qualified Language.DTC.Write.HTML5 as DTC
+import qualified Language.DTC.Write.XML as DTC
+import qualified Language.RNC.Write as RNC
+import qualified Text.Blaze.DTC as Blaze.DTC
+import qualified Text.Blaze.HTML5 as Blaze.HTML5
-import qualified Data.TreeSeq.Strict as Tree
-{-
-import qualified Language.DTC.Read.TCT as DTC.Read.TCT
-import qualified Language.DTC.Sym as DTC
-import qualified Language.DTC.Write.HTML5 as DTC.Write.HTML5
-import qualified Language.DTC.Write.XML as DTC.Write.XML
-import qualified Text.Blaze.DTC as Blaze.DTC
-import qualified Text.Blaze.HTML5 as Blaze.HTML5
--}
--- import qualified Language.RNC.Write as RNC
-import qualified Language.TCT as TCT
-import qualified Language.TCT.Write.Plain as TCT.Write.Plain
-import qualified Language.TCT.Write.HTML5 as TCT.Write.HTML5
-import qualified Language.TCT.Write.XML as TCT.Write.XML
-import qualified Text.Megaparsec as P
-
-import Read
+import Language.Symantic.CLI hiding (main)
+import qualified Language.Symantic.CLI as CLI
+import qualified Language.Symantic.Document.Term.IO as Doc
-type Langs = '[FR, EN]
-type Lang = LocaleIn Langs
+import qualified Language.Symantic.CLI.Plain as Plain
+import qualified Language.Symantic.CLI.Help as Help
+import qualified Language.Symantic.CLI.Read as Read
+
+version :: TL.Text
+version = "hdoc-" <> TL.pack (Version.showVersion Hdoc.version)
main :: IO ()
main = do
- lang <-
- (\v -> Map.findWithDefault
- (LocaleIn @Langs en_US)
- (Text.pack $ List.takeWhile (\c -> Char.isAlphaNum c || c == '_') v)
- (locales @Langs)) .
- fromMaybe ""
- <$> Env.lookupEnv "LANG"
- cmd <- execParser $ pArgv lang
- mainWithCommand cmd
- where
- pArgv lang =
- info (pCommand lang <**> helper) $ mconcat
- [ fullDesc
- , progDesc "document tool"
- , header "hdoc - TCT and DTC command line tool"
- ]
+ lang <- getLang
+ args <- Env.getArgs
+ readArgs lang args >>= \case
+ Nothing -> return ()
+ Just (Left err) -> onExit err
+ Just (Right cmd) -> onCommand cmd
+
+readArgs ::
+ forall d.
+ Plain.Doc d =>
+ Lang -> [String] -> IO.IO (Maybe (Either (Exit (Doc d)) Command))
+readArgs lang args =
+ case
+ Read.readArgs (cli (loqualize lang) lang) $
+ Read.Args $ Read.Arg <$> ("hdoc":args) of
+ Right a -> return $ Just $ Right a
+ Left err ->
+ case err of
+ P.FancyError pos es ->
+ case Set.toList es of
+ [P.ErrorCustom (Read.ErrorRead e)] ->
+ case e of
+ Exit_Error ee -> do
+ IO.hPutStr IO.stderr $
+ P.parseErrorPretty @Read.Arg @(Read.ErrorRead Error) $
+ P.FancyError pos $ Set.singleton $ P.ErrorCustom $
+ Read.ErrorRead ee
+ return Nothing
+ _ -> return $ Just $ Left e
+ _ -> return Nothing
+ P.TrivialError pos e es -> do
+ IO.hPutStr IO.stderr $
+ P.parseErrorPretty @_ @Void $
+ P.TrivialError pos e es
+ return Nothing
+
+-- * Type 'Exit'
+data Exit d
+ = Exit_Help d
+ | Exit_Version
+ | Exit_License (Loq d)
+ | Exit_Error Error
+ deriving Show
+instance Show (Loqualization q) where
+ show _ = "Loqualization"
-mainWithCommand :: Command -> IO ()
-mainWithCommand (CommandTCT ArgsTCT{..}) =
- readFile input $ \_fp txt ->
- case TCT.readTrees input $ TL.fromStrict txt of
- Left err -> error $ P.parseErrorPretty err
- Right tct -> do
- when (trace_TCT trace) $ do
- hPutStrLn stderr "### TCT ###"
- hPrint stderr $ Tree.Pretty tct
- when (trace_XML trace) $ do
- hPutStrLn stderr "### XML ###"
- let xml = TCT.Write.XML.xmlDocument tct
- hPrint stderr $ Tree.Pretty xml
- case format of
- TctFormatPlain ->
- TL.putStrLn $
- TCT.Write.Plain.plainDocument tct
- TctFormatHTML5 ->
- Blaze.renderMarkupToByteStringIO BS.putStr $
- TCT.Write.HTML5.html5Document tct
-{-
-mainWithCommand (CommandDTC ArgsDTC{..}) =
- readFile input $ \_fp txt ->
- case TCT.readTCTs input txt of
- Left err -> error $ P.parseErrorPretty err
- Right tct -> do
- when (trace_TCT trace) $ do
- hPutStrLn stderr "### TCT ###"
- hPrint stderr $ Tree.Pretty tct
- let xml = TCT.Write.XML.xmlDocument tct
- when (trace_XML trace) $ do
- hPutStrLn stderr "### XML ###"
- hPrint stderr $ Tree.Pretty xml
- case DTC.Read.TCT.readDTC xml of
- Left err -> error $ P.parseErrorPretty err
- Right dtc -> do
- when (trace_DTC trace) $ do
- hPutStrLn stderr "### DTC ###"
- hPrint stderr dtc
- case format of
- DtcFormatXML ->
- Blaze.prettyMarkupIO Blaze.DTC.indentTag BS.putStr $
- DTC.Write.XML.xmlDocument locale dtc
- DtcFormatHTML5 ->
- Blaze.prettyMarkupIO Blaze.HTML5.indentTag BS.putStr $
- DTC.Write.HTML5.html5Document locale dtc
-mainWithCommand (CommandRNC ArgsRNC{}) =
- forM_ DTC.dtcRNC $ \w ->
- Text.hPutStrLn stdout $ RNC.renderWriter w
--}
-
--- * Options utils
-
-instance IsList (Opt.Mod f a) where
- type Item (Opt.Mod f a) = Opt.Mod f a
- fromList = mconcat
- toList = pure
-
-readMap :: Map String a -> ReadM a
-readMap m =
- eitherReader $ \s ->
- case Map.lookup s m of
- Nothing -> Left $ "cannot parse value \"" <> s
- <> "\"\nexpecting one of: "
- <> (List.intercalate ", " $ Map.keys m)
- Just a -> Right a
+onExit :: Exit (Doc Doc.TermIO) -> IO ()
+onExit (Exit_Help d) =
+ Doc.runTermIO IO.stdout $
+ Doc.withBreakable (Just 80) (runDoc d) <>
+ Doc.newline
+onExit Exit_Version =
+ TL.putStrLn version
+onExit (Exit_License (Loqualization l)) =
+ Doc.runTermIO IO.stdout $
+ runDoc $
+ l10n_license l
+onExit Exit_Error{} =
+ return ()
+
+-- ** Type 'Error'
+data Error
+ = Error_Locale String
+ deriving Show
-- * Type 'Command'
data Command
- = CommandTCT ArgsTCT
- {-
- | CommandDTC ArgsDTC
- | CommandRNC ArgsRNC
- -}
-
-pCommand :: Lang -> Parser Command
-pCommand lang =
- hsubparser
- [ metavar "tct"
- , command "tct" $
- info (CommandTCT <$> pArgsTCT) $
- progDesc "TCT (Texte Convivial Technique) rendition."
- ] {-<|>
- hsubparser
- [ metavar "dtc"
- , command "dtc" $
- info (CommandDTC <$> pArgsDTC lang) $
- progDesc "DTC (Document Technique Convivial) rendition."
- ] <|>
- hsubparser
- [ metavar "rnc"
- , command "rnc" $
- info (CommandRNC <$> pArgsRNC) $
- progDesc "RNC (RelaxNG Compact) schema."
- ]-}
-
--- * Type 'Trace'
-data Trace
- = Trace
- { trace_TCT :: Bool
- , trace_XML :: Bool
- , trace_DTC :: Bool
+ = Command_Source CommandSource
+ | Command_Compile CommandCompile
+ | Command_Schema CommandSchema
+ deriving (Show)
+
+onCommand :: Command -> IO ()
+onCommand cmd@(Command_Source CommandSource{..}) = do
+ IO.hPrint IO.stderr cmd
+ TCT.readTCT source_input >>= \case
+ Left err -> error $ show err
+ Right tct -> do
+ when source_dump_tct $
+ writeFile (source_output-<.>"tct.dump") $
+ TL.pack $ Tree.prettyTrees tct
+ case source_format of
+ CommandSourceFormat_Plain ->
+ writeFile source_output $
+ TCT.writePlain tct
+ CommandSourceFormat_HTML5 ->
+ withFile source_output IO.WriteMode $ \h ->
+ Blaze.renderMarkupToByteStringIO (BS.hPutStr h) $
+ TCT.writeHTML5 tct
+onCommand cmd@(Command_Compile CommandCompile{..}) = do
+ IO.hPrint IO.stderr cmd
+ TCT.readTCT compile_input >>= \case
+ Left err -> error $ show err
+ Right tct -> do
+ when compile_dump_tct $ do
+ writeFile (compile_output-<.>"tct.dump") $
+ TL.pack $ Tree.prettyTrees tct
+ let xml = TCT.writeXML tct
+ when compile_dump_xml $ do
+ writeFile (compile_output-<.>"xml.dump") $
+ TL.pack $ Tree.prettyTrees xml
+ case DTC.readDTC xml of
+ Left err -> do
+ removeFile $ compile_output-<.>"deps"
+ error $ P.parseErrorPretty err
+ Right dtc -> do
+ when compile_dump_deps $ do
+ writeFile (compile_output-<.>"deps") $
+ writeDependencies compile_input tct
+ when compile_dump_xml $ do
+ writeFile (compile_output-<.>"dtc.dump") $
+ TL.pack $ show dtc
+ case compile_format of
+ CommandCompileFormat_XML ->
+ withFile compile_output IO.WriteMode $ \h ->
+ Blaze.prettyMarkupIO Blaze.DTC.isInlinedElement (BS.hPutStr h) $
+ DTC.writeXML compile_locale dtc
+ CommandCompileFormat_HTML5{..} -> do
+ config_css <- do
+ src <- Hdoc.getDataFileName "style/dtc-html5.css"
+ case compile_html5_output_css of
+ Nothing -> Right <$> readFile src
+ Just "" -> return $ Left ""
+ Just dst -> do
+ IO.createDirectoryIfMissing True $ FilePath.takeDirectory dst
+ IO.copyFile src dst
+ return $ Left dst
+ let conf = DTC.Config
+ { DTC.config_css
+ , DTC.config_locale = compile_locale
+ , DTC.config_generator = version
+ }
+ withFile compile_output IO.WriteMode $ \h ->
+ Blaze.prettyMarkupIO Blaze.HTML5.isInlinedElement (BS.hPutStr h) $
+ DTC.writeHTML5 conf dtc
+onCommand Command_Schema{} =
+ forM_ DTC.schema $ \ru ->
+ TL.hPutStrLn IO.stdout $ RNC.renderWriter ru
+
+writeDependencies :: FilePath -> TCT.Roots -> TL.Text
+writeDependencies input tct =
+ let dir = FilePath.takeDirectory input in
+ TL.pack input <> ":" <>
+ foldMap
+ ( TL.pack
+ . ((" \\\n " <>)
+ . FilePath.normalise
+ . (dir </>)) )
+ (TCT.dependencies tct) <>
+ "\n"
+
+-- ** Type 'CommandSource'
+data CommandSource
+ = CommandSource
+ { source_output :: FilePath
+ , source_dump_tct :: Bool
+ , source_format :: CommandSourceFormat
+ , source_input :: FilePath
}
-instance Default Trace where
- def = Trace
- { trace_TCT = False
- , trace_XML = False
- , trace_DTC = False
- }
-instance Semigroup Trace where
- x <> y =
- Trace
- { trace_TCT = trace_TCT x || trace_TCT y
- , trace_XML = trace_XML x || trace_XML y
- , trace_DTC = trace_DTC x || trace_DTC y
- }
-instance Monoid Trace where
- mempty = def
- mappend = (<>)
+ deriving (Show)
+
+-- *** Type 'CommandSourceFormat'
+data CommandSourceFormat
+ = CommandSourceFormat_Plain
+ | CommandSourceFormat_HTML5
+ deriving (Show)
+instance Default CommandSourceFormat where
+ def = CommandSourceFormat_Plain
-pTrace :: Parser Trace
-pTrace =
- (mconcat <$>) $
- many $
- option
- (readMap m)
- [ long "trace"
- , help $ "Print trace. (choices: "
- <> (List.intercalate ", " $ Map.keys m) <> ")"
- ]
- where
- m = Map.fromList
- [ ("tct", def{trace_TCT=True})
- , ("xml", def{trace_XML=True})
- , ("dtc", def{trace_DTC=True})
- ]
-
--- ** Type 'ArgsTCT'
-data ArgsTCT
- = ArgsTCT
- { input :: FilePath
- , format :: TctFormat
- , trace :: Trace
+-- *** Type 'CommandSourceDump'
+data CommandSourceDump
+ = CommandSourceDump_TCT
+ | CommandSourceDump_XML
+ deriving (Eq, Ord, Show)
+
+-- ** Type 'CommandCompile'
+data CommandCompile
+ = CommandCompile
+ { compile_output :: FilePath
+ , compile_locale :: Lang
+ , compile_dump_tct :: Bool
+ , compile_dump_xml :: Bool
+ , compile_dump_deps :: Bool
+ , compile_format :: CommandCompileFormat
+ , compile_input :: FilePath
+ -- , compile_dump :: Set CommandCompileDump
}
+ deriving (Show)
+
+-- *** Type 'CommandCompileFormat'
+data CommandCompileFormat
+ = CommandCompileFormat_HTML5
+ { compile_html5_output_css :: Maybe FilePath
+ , compile_html5_dump_dtc :: Bool
+ }
+ | CommandCompileFormat_XML
+ {
+ }
+ deriving (Show)
+instance Default CommandCompileFormat where
+ def = CommandCompileFormat_HTML5
+ { compile_html5_output_css = def
+ , compile_html5_dump_dtc = False
+ }
+
+-- *** Type 'CommandCompileDump'
+data CommandCompileDump
+ = CommandCompileDump_TCT
+ | CommandCompileDump_XML
+ | CommandCompileDump_DTC
+ | CommandCompileDump_Deps
+ deriving (Eq, Ord, Show)
+
+-- ** Type 'CommandSchema'
+data CommandSchema
+ = CommandSchema
+ deriving (Show)
-pArgsTCT :: Parser ArgsTCT
-pArgsTCT =
- ArgsTCT
- <$> argument str (metavar "FILE")
- <*> pTctFormat
- <*> pTrace
-
--- *** Type 'TctFormat'
-data TctFormat
- = TctFormatPlain
- | TctFormatHTML5
-
-pTctFormat :: Parser TctFormat
-pTctFormat =
- flag TctFormatPlain TctFormatPlain
- [ long "plain"
- , help "Render as plain text."
- ] <|>
- flag TctFormatHTML5 TctFormatHTML5
- [ long "html5"
- , help "Render as HTML5."
- ]
-
--- ** Type 'ArgsDTC'
-data ArgsDTC
- = ArgsDTC
- { input :: FilePath
- , format :: DtcFormat
- , locale :: Lang
- , trace :: Trace
+-- * Class 'CLI'
+class
+ ( Sym_Fun repr
+ , Sym_App repr
+ , Sym_Alt repr
+ , Sym_AltApp repr
+ , Sym_Help d repr
+ , Sym_Rule repr
+ , Sym_Interleaved repr
+ , Sym_Command repr
+ , Sym_Option repr
+ , Sym_Exit repr
+ , Plain.Doc d
+ -- , Reifies lang
+ ) => CLI d repr where
+ cli :: Loq d -> Lang -> repr (Exit d) ArgCommand Command
+ cli loq@(Loqualization l) lang =
+ help @d (l10n_cli l) $
+ CLI.main "hdoc" $ opts **> cmds
+ where
+ opts =
+ interleaved $
+ (\_ _ -> ())
+ <<$? option_help loq (help_usage $ cli loq lang)
+ <<|?>> option_version loq
+ <<|?>> option_license loq
+ cmds =
+ Command_Source <$$> command_source loq <||>
+ Command_Compile <$$> command_compile loq lang <||>
+ Command_Schema <$$> command_schema loq
+
+ option_help :: Loq d -> d -> ((), repr (Exit d) ArgOption ())
+ option_help (Loqualization l) d =
+ ((),) $
+ help @d (l10n_help_opt_help l) $
+ opt (OptionName 'h' "help") $
+ exit $ Exit_Help d
+ option_version :: Loq d -> ((), repr (Exit d) ArgOption ())
+ option_version (Loqualization l) = ((),) $
+ help @d (l10n_help_version l) $
+ long "version" $ exit $ Exit_Version
+ option_license :: Loq d -> ((), repr (Exit d) ArgOption ())
+ option_license loq@(Loqualization l) = ((),) $
+ help @d (l10n_help_license l) $
+ long "license" $ exit $ Exit_License loq
+ option_input :: Loq d -> (FilePath, repr (Exit d) ArgOption FilePath)
+ option_input (Loqualization l) =
+ (mempty,) $
+ help @d (l10n_help_opt_input l) $
+ opt (OptionName 'i' "input") $
+ string $ l10n_var_file l
+ option_output :: Loq d -> (FilePath, repr (Exit d) ArgOption FilePath)
+ option_output (Loqualization l) =
+ (mempty,) $
+ help @d (l10n_help_opt_output l) $
+ opt (OptionName 'o' "output") $
+ string $ l10n_var_file l
+ option_lang :: Loq d -> Lang -> (Lang, repr (Exit d) ArgOption Lang)
+ option_lang (Loqualization l) lang =
+ (lang,) $
+ help @d (l10n_help_opt_lang l) $
+ long "lang" $
+ var (l10n_var_locale l) $ \s ->
+ maybe (Left $ Exit_Error $ Error_Locale s) Right $
+ Map.lookup (Text.pack s) $
+ locales @Langs
+ option_dump_tct :: Loq d -> (Bool, repr (Exit d) ArgOption Bool)
+ option_dump_tct (Loqualization l) =
+ help @d (l10n_help_opt_dump_tct l) <$>
+ flag (OptionNameLong "dump-tct")
+ option_dump_xml :: Loq d -> (Bool, repr (Exit d) ArgOption Bool)
+ option_dump_xml (Loqualization l) =
+ help @d (l10n_help_opt_dump_xml l) <$>
+ flag (OptionNameLong "dump-xml")
+ option_dump_deps :: Loq d -> (Bool, repr (Exit d) ArgOption Bool)
+ option_dump_deps (Loqualization l) =
+ help @d (l10n_help_opt_dump_deps l) <$>
+ flag (OptionNameLong "dump-deps")
+ option_dump_dtc :: Loq d -> (Bool, repr (Exit d) ArgOption Bool)
+ option_dump_dtc (Loqualization l) =
+ help @d (l10n_help_opt_dump_dtc l) <$>
+ flag (OptionNameLong "dump-dtc")
+
+ command_source :: Loq d -> repr (Exit d) ArgCommand CommandSource
+ command_source loq@(Loqualization l) =
+ help @d (l10n_help_command_source l) $
+ command "source" $
+ (interleaved $
+ CommandSource
+ <<$? option_help loq (help_usage $ command_source loq)
+ <<|?>> option_output loq
+ <<|?>> option_dump_tct loq)
+ <**> (command_source_plain loq
+ <||> command_source_html5 loq)
+ <**> string (l10n_var_file l)
+ command_source_plain :: Loq d -> repr (Exit d) ArgCommand CommandSourceFormat
+ command_source_plain loq@(Loqualization l) =
+ help @d (l10n_help_format_plain l) $
+ command "plain" $
+ interleaved $
+ CommandSourceFormat_Plain
+ <<$? option_help loq (help_usage $ command_source_plain loq)
+ command_source_html5 :: Loq d -> repr (Exit d) ArgCommand CommandSourceFormat
+ command_source_html5 loq@(Loqualization l) =
+ help @d (l10n_help_format_html5 l) $
+ command "html" $
+ interleaved $
+ CommandSourceFormat_HTML5
+ <<$? option_help loq (help_usage $ command_source_html5 loq)
+
+ command_compile :: Loq d -> Lang -> repr (Exit d) ArgCommand CommandCompile
+ command_compile loq@(Loqualization l) lang =
+ help @d (l10n_help_command_compile l) $
+ command "compile" $
+ (setDefault <$$>) $
+ (interleaved $
+ CommandCompile
+ <<$? option_help loq (help_usage $ command_compile loq lang)
+ <<|?>> option_output loq
+ <<|?>> option_lang loq lang
+ <<|?>> option_dump_tct loq
+ <<|?>> option_dump_xml loq
+ <<|?>> option_dump_deps loq)
+ <**> (command_compile_html5 loq
+ <||> command_compile_xml loq)
+ <**> string (l10n_var_file l)
+ where
+ setDefault a@CommandCompile{..}
+ | null compile_output = (a::CommandCompile){compile_output=compile_input-<.>fmt compile_format}
+ | otherwise = a
+ fmt = \case
+ CommandCompileFormat_XML{} -> "xml"
+ CommandCompileFormat_HTML5{} -> "html"
+ command_compile_html5 :: Loq d -> repr (Exit d) ArgCommand CommandCompileFormat
+ command_compile_html5 loq@(Loqualization l) =
+ help @d (l10n_help_format_html5 l) $
+ command "html" $
+ interleaved $
+ CommandCompileFormat_HTML5
+ <<$? option_help loq (help_usage $ command_compile_html5 loq)
+ <<|?>> option_html5_output_css
+ <<|?>> option_dump_dtc loq
+ where
+ option_html5_output_css =
+ (Nothing,) $
+ (Just <$$>) $
+ help @d (l10n_help_opt_output_css l) $
+ opt (OptionNameLong "output-css") $
+ string $ l10n_var_file l
+ command_compile_xml :: Loq d -> repr (Exit d) ArgCommand CommandCompileFormat
+ command_compile_xml loq@(Loqualization l) =
+ help @d (l10n_help_format_xml l) $
+ command "xml" $
+ interleaved $
+ CommandCompileFormat_XML
+ <<$? option_help loq (help_usage $ command_compile_xml loq)
+
+ command_schema :: Loq d -> repr (Exit d) ArgCommand CommandSchema
+ command_schema loq@(Loqualization l) =
+ help @d (l10n_help_command_schema l) $
+ command "schema" $
+ interleaved $
+ CommandSchema
+ <<$? option_help loq (help_usage $ command_schema loq)
+instance Plain.Doc d => CLI d (Plain.Plain d)
+instance Plain.Doc d => CLI d Read.Parser
+instance Plain.Doc d => CLI d (Help.Help d)
+
+help_usage :: Plain.Doc d => Help.Help d (Exit d) t a -> d
+help_usage = Help.textHelp Help.defReader
+ { Help.reader_command_indent = 2
+ , Help.reader_option_indent = 12
}
-pArgsDTC :: Lang -> Parser ArgsDTC
-pArgsDTC lang =
- ArgsDTC
- <$> argument str (metavar "FILE")
- <*> pDtcFormat
- <*> pLocale lang
- <*> pTrace
-
-pLocale :: Lang -> Parser (LocaleIn Langs)
-pLocale lang =
- option
- (maybeReader $ \s -> Map.lookup (Text.pack s) $ locales @Langs)
- [ long "lang"
- , help "Language."
- , showDefault
- , value lang
- , metavar "LOCALE"
- ]
-
--- *** Type 'DtcFormat'
-data DtcFormat
- = DtcFormatHTML5
- | DtcFormatXML
-
-pDtcFormat :: Parser DtcFormat
-pDtcFormat =
- flag DtcFormatHTML5 DtcFormatHTML5
- [ long "html5"
- , help "Render as HTML5."
- ] <|>
- flag DtcFormatHTML5 DtcFormatXML
- [ long "xml"
- , help "Render as XML."
- ]
-
--- ** Type 'ArgsRNC'
-data ArgsRNC
- = ArgsRNC
-
-pArgsRNC :: Parser ArgsRNC
-pArgsRNC = pure ArgsRNC
-
-
-{-
- Args
- <$> strOption ( long "hello"
- <> metavar "TARGET"
- <> help "Target for the greeting")
- <*> switch ( long "quiet"
- <> short 'q'
- <> help "Whether to be quiet")
- <*> option auto ( long "enthusiasm"
- <> help "How enthusiastically to greet"
- <> showDefault
- <> value 1
- <> metavar "INT")
--}
+
+-- * Type 'Lang'
+-- | Supported locales
+type Langs = '[FR, EN]
+type Lang = LocaleIn Langs
+
+getLang :: IO Lang
+getLang =
+ (\v -> Map.findWithDefault
+ (LocaleIn @Langs en_US)
+ (Text.pack $ List.takeWhile (\c -> Char.isAlphaNum c || c == '_') v)
+ (locales @Langs)) .
+ fromMaybe ""
+ <$> Env.lookupEnv "LANG"
+
+-- ** Class 'L10n'
+type Loq d = Loqualization (L10n d)
+-- | Localization
+class L10n_Var lang => L10n d lang where
+ l10n_cli :: FullLocale lang -> d
+ l10n_license :: FullLocale lang -> d
+ l10n_help_version :: FullLocale lang -> d
+ l10n_help_license :: FullLocale lang -> d
+ l10n_help_command_source :: FullLocale lang -> d
+ l10n_help_command_compile :: FullLocale lang -> d
+ l10n_help_command_schema :: FullLocale lang -> d
+ l10n_help_opt_lang :: FullLocale lang -> d
+ l10n_help_opt_output :: FullLocale lang -> d
+ l10n_help_opt_output_css :: FullLocale lang -> d
+ l10n_help_opt_dump_tct :: FullLocale lang -> d
+ l10n_help_opt_dump_xml :: FullLocale lang -> d
+ l10n_help_opt_dump_deps :: FullLocale lang -> d
+ l10n_help_opt_dump_dtc :: FullLocale lang -> d
+ l10n_help_format :: FullLocale lang -> d
+ l10n_help_format_plain :: FullLocale lang -> d
+ l10n_help_format_html5 :: FullLocale lang -> d
+ l10n_help_format_xml :: FullLocale lang -> d
+ l10n_help_opt_input :: FullLocale lang -> d
+ l10n_help_opt_help :: FullLocale lang -> d
+class L10n_Var lang where
+ l10n_var_file :: FullLocale lang -> Name
+ l10n_var_locale :: FullLocale lang -> Name
+
+-- * Type 'Doc'
+data Doc d
+ = Doc d
+ | Var Name
+ deriving Show
+instance (Semigroup d, IsString d) => Semigroup (Doc d) where
+ Doc x <> Doc y = Doc (x<>y)
+ x <> y = Doc $ runDoc x <> runDoc y
+instance (Semigroup d, Monoid d, IsString d) => Monoid (Doc d) where
+ mempty = Doc mempty
+ mappend = (<>)
+instance Doc.Breakable d => IsString (Doc d) where
+ fromString = Doc . Plain.words
+instance (IsString d, Semigroup d, Monoid d) => IsList (Doc d) where
+ type Item (Doc d) = Doc d
+ toList = pure
+ fromList = Doc . foldMap runDoc
+instance (IsString d, Semigroup d) => Doc.Trans (Doc d) where
+ type ReprOf (Doc d) = d
+ trans = Doc
+ unTrans = runDoc
+instance Doc.Breakable d => Doc.Textable (Doc d)
+instance (Doc.Breakable d, Doc.Indentable d) => Doc.Indentable (Doc d)
+instance Doc.Breakable d => Doc.Breakable (Doc d)
+instance (IsString d, Semigroup d, Doc.Decorable d) => Doc.Decorable (Doc d)
+instance (IsString d, Semigroup d, Doc.Colorable d) => Doc.Colorable (Doc d)
+instance Plain.Doc d => Plain.Doc (Doc d)
+
+runDoc :: (IsString d, Semigroup d) => Doc d -> d
+runDoc = \case
+ Doc d -> d
+ Var n -> "<"<>fromString n<>">"
+
+instance (IsString d, Semigroup d, Monoid d, Doc.Breakable d) => L10n (Doc d) EN where
+ l10n_cli _ = "Compiler of Convivial Technical Document (DTC)."
+ l10n_license _ =
+ fromString $
+ List.intercalate "\n"
+ [ "License: GNU GPLv3+"
+ , "Copyright: Julien Moutinho <julm+hdoc@autogeree.net>"
+ , ""
+ , "hdoc is free software: you can redistribute it and/or modify it"
+ , "under the terms of the GNU General Public License (GPL)"
+ , "as published by the Free Software Foundation;"
+ , "either in version 3, or (at your option) any later version."
+ , ""
+ , "hdoc is distributed in the hope that it will be useful,"
+ , "but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY"
+ , "or FITNESS FOR A PARTICULAR PURPOSE."
+ , ""
+ , "See the GNU GPL for more details."
+ , "You should have received a copy of the GNU GPL along with hdoc."
+ , "If not, see: http://www.gnu.org/licenses/"
+ ]
+ l10n_help_version _ = "Show the version of this program."
+ l10n_help_license _ = "Inform about the license of this program."
+ l10n_help_command_source _ = "Format the source code of a TCT document."
+ l10n_help_command_compile _ = "Compile a TCT document into a format optimized for reading."
+ l10n_help_command_schema _ = "Show in RNC (RelaxNG Compact) format the XML schema of the DTC format."
+ l10n_help_opt_lang l = ["Use the language given by ", Var $ l10n_var_locale l, "."]
+ l10n_help_opt_output l = ["Output document into ", Var $ l10n_var_file l]
+ l10n_help_opt_output_css l = [ "Output CSS stylesheet into "
+ , Var $ l10n_var_file l
+ , " (if any), instead of incorporating it into the HTML."
+ ]
+ l10n_help_opt_dump_tct _ = "Dump internal representation of TCT."
+ l10n_help_opt_dump_xml _ = "Dump internal representation of XML."
+ l10n_help_opt_dump_deps _ = "Dump dependencies, in Makefile format."
+ l10n_help_opt_dump_dtc _ = "Dump internal representation of DTC."
+ l10n_help_opt_help _ = "Show this help."
+ l10n_help_format _ = "Output format."
+ l10n_help_format_plain _ = "Output as plain text."
+ l10n_help_format_html5 _ = "Output as HTML5."
+ l10n_help_format_xml _ = "Output as XML."
+ l10n_help_opt_input l = ["Read input from ", Var $ l10n_var_file l, "."]
+instance (IsString d , Semigroup d, Monoid d, Doc.Breakable d) => L10n (Doc d) FR where
+ l10n_cli _ = "Compilateur de Document Technique Convivial (DTC)."
+ l10n_license _ =
+ fromString $
+ List.intercalate "\n"
+ [ "Licence : GPLv3+ GNU"
+ , "Droit d’auteur : Julien Moutinho <julm+hdoc@autogeree.net>"
+ , ""
+ , "hdoc est un logiciel libre : vous pouvez le redistribuer et/ou le modifier"
+ , "selon les termes de la Licence Publique Générale (GPL) GNU"
+ , "telle que publiée par la Free Software Foundation ;"
+ , "en version 3, ou (à votre choix) n’importe quelle version ultérieure."
+ , ""
+ , "hdoc est distribué dans l’espoir qu’il sera utile,"
+ , "mais SANS AUCUNE GARANTIE ; sans même la garantie implicite de COMMERCIALISATION"
+ , "ou de CONVENANCE À UN BUT PARTICULIER."
+ , ""
+ , "Voyez la GPL pour davantage de détails."
+ , "Vous devriez avoir reçu une copie de la GPL avec hdoc."
+ , "Si non, voyez : http://www.gnu.org/licenses/"
+ ]
+ l10n_help_version _ = "Affiche la version de ce logiciel."
+ l10n_help_license _ = "Informe sur la licence de ce logiciel."
+ l10n_help_command_source _ = "Lit un document TCT et écrit un rendu préservant sa syntaxe."
+ l10n_help_command_compile _ = "Compile un document TCT vers un format optimisé pour la lecture."
+ l10n_help_command_schema _ = "Affiche au format RNC (RelaxNG Compact) le schéma XML du format DTC."
+ l10n_help_opt_lang l = ["Utilise le langage indiqué par ", Var $ l10n_var_locale l, "."]
+ l10n_help_opt_output l = ["Écrit dans ", Var $ l10n_var_file l, "."]
+ l10n_help_opt_output_css l = [ "Écrit la feuille de style CSS dans "
+ , Var $ l10n_var_file l
+ , ", au lieu de l’incorporer dans le HTML."
+ ]
+ l10n_help_opt_dump_tct _ = "Écrit la représentation interne du TCT."
+ l10n_help_opt_dump_xml _ = "Écrit la représentation interne du XML."
+ l10n_help_opt_dump_deps _ = "Écrit les dépendences, au format Makefile."
+ l10n_help_opt_dump_dtc _ = "Écrit la représentation interne du DTC."
+ l10n_help_opt_help _ = "Affiche cette aide."
+ l10n_help_format _ = "Format de sortie."
+ l10n_help_format_plain _ = "Produit du texte brut."
+ l10n_help_format_html5 _ = "Produit du HTML5."
+ l10n_help_format_xml _ = "Produit du XML."
+ l10n_help_opt_input l = ["Lit depuis ", Var $ l10n_var_file l, "."]
+instance L10n_Var EN where
+ l10n_var_file _ = "file"
+ l10n_var_locale _ = "locale"
+instance L10n_Var FR where
+ l10n_var_file _ = "fichier"
+ l10n_var_locale _ = "locale"
+
+-- * Filesystem utilities
+readFile :: FilePath -> IO TL.Text
+readFile fp = TL.decodeUtf8 <$> BSL.readFile fp
+
+writeFile :: FilePath -> TL.Text -> IO ()
+writeFile fp s = BSL.writeFile fp $ TL.encodeUtf8 s
+
+withFile :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
+withFile = IO.withFile
+
+removeFile :: FilePath -> IO ()
+removeFile f =
+ IO.removeFile f `IO.catchIOError` \e ->
+ if IO.isDoesNotExistError e
+ then return ()
+ else IO.ioError e
sourcephile / git / doclang.git / blobdiff