Language/Symantic/CLI/Test.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE TypeApplications #-}
   3 module Language.Symantic.CLI.Test where
   4
   5 -- import Data.Monoid (Monoid(..))
   6 -- import Data.Ord (Ord(..))
   7 -- import Text.Show (Show(..))
   8 import Control.Monad (Monad(..))
   9 import Data.Bool
  10 import Data.Either (Either(..))
  11 import Data.Function (($))
  12 import Data.Functor ((<$>))
  13 import Data.Maybe (Maybe(..))
  14 import Data.Semigroup (Semigroup(..))
  15 import Data.String (String)
  16 import Data.Void (Void)
  17 import Text.Show (Show(..))
  18 import qualified Data.Set as Set
  19 import qualified Data.Text.Lazy.IO as TL
  20 import qualified Language.Symantic.Document.Term as Doc
  21 import qualified Language.Symantic.Document.Term.IO as DocIO
  22 import qualified System.IO as IO
  23 import qualified Text.Megaparsec as P
  24
  25 import Language.Symantic.CLI.Sym
  26 import qualified Language.Symantic.CLI.Plain as Plain
  27 import qualified Language.Symantic.CLI.Help as Help
  28 import qualified Language.Symantic.CLI.Read as Read
  29
  30 data Command
  31  =   Command_Source
  32    { command_source_output   :: [String]
  33    , command_source_format   :: String
  34    , command_source_dump_tct :: Bool
  35    }
  36  |   Command_Compile
  37    { command_compile_output   :: [String]
  38    , command_compile_lang     :: String
  39    , command_compile_dump_tct :: Bool
  40    , command_compile_dump_dtc :: Bool
  41    }
  42  |   Command_Schema
  43    { command_schema_output :: [String]
  44    }
  45  deriving (Show)
  46
  47 -- * Type 'Exit'
  48 data Exit d
  49  =   Exit_Help d
  50  |   Exit_Version
  51  deriving Show
  52
  53 doc ::
  54  Plain.Doc d =>
  55  Plain.Plain d (Exit d) t a -> d
  56 doc = Plain.textPlain
  57
  58 {-
  59 help_usage :: Plain.Doc d => Help.Help d (Exit d) t a -> d
  60 help_usage = Help.help "USAGE" "COMMAND" "OPTION" Help.defReader
  61  { Help.reader_command_indent = 4 }
  62 -}
  63
  64 help_usage :: Plain.Doc d => Help.Help d (Exit d) t a -> d
  65 help_usage = Help.textHelp Help.defReader
  66
  67 -- * Class 'Hdoc'
  68 class
  69  ( Sym_Fun repr
  70  , Sym_App repr
  71  , Sym_Alt repr
  72  , Sym_Help d repr
  73  , Sym_Rule repr
  74  , Sym_Interleaved repr
  75  , Sym_Command repr
  76  , Sym_Option repr
  77  , Sym_Exit repr
  78  , Sym_AltApp repr
  79  , Plain.Doc d
  80  ) => Hdoc d repr where
  81         hdoc :: repr (Exit d) ArgCommand Command
  82         hdoc =
  83                 help_words "technical document compiler\n(disclaimer: expect hdoc's documentation to be quite… technical :)" $
  84                 main "hdoc" $ opts **> cmds
  85                 where
  86                 opts =
  87                         interleaved $
  88                         (\_ -> ())
  89                          <<$? option_help (help_usage hdoc)
  90                          <<|?>> ((), long "version" $ exit Exit_Version)
  91                 cmds =
  92                         command_source  <||>
  93                         command_compile <||>
  94                         command_schema
  95
  96         help_words :: String -> repr (Exit d) t a -> repr (Exit d) t a
  97         help_words d = help @d (Plain.words d)
  98
  99         option_help :: d -> ((), repr (Exit d) ArgOption ())
 100         option_help d = ((), opt (OptionName 'h' "help") $ exit $ Exit_Help d)
 101
 102         command_source :: repr (Exit d) ArgCommand Command
 103         command_source =
 104                 help_words "Format a TCT source file." $
 105                 command "source" $
 106                 interleaved $
 107                 Command_Source
 108                  <<$?   option_help (help_usage command_source)
 109                  <<|*>> rule_output
 110                  <<|>>  option_format
 111                  <<|?>> option_dump_tct
 112         command_compile :: repr (Exit d) ArgCommand Command
 113         command_compile =
 114                 help_words "Compile a TCT source file." $
 115                 command "compile" $
 116                 (\cmd os -> case cmd of
 117                  Command_Compile{..} -> Command_Compile{command_compile_output=command_compile_output<>os, ..}
 118                  _ -> cmd)
 119                  <$$> opts
 120                  <**  end_options
 121                  <**> inps
 122                 where
 123                 opts =
 124                         interleaved $
 125                         Command_Compile
 126                          <<$?   option_help (help_usage command_compile)
 127                          <<|*>> rule_output
 128                          <<|?>> option_lang
 129                          <<|?>> option_dump_tct
 130                          <<|?>> option_dump_dtc
 131                 inps = many $ var "file" string
 132         command_schema  :: repr (Exit d) ArgCommand Command
 133         command_schema =
 134                 help_words "Show the schema for DTC documents." $
 135                 command "schema" $
 136                 interleaved $
 137                 Command_Schema
 138                  <<$?   option_help (help_usage command_schema)
 139                  <<|*>> option_output
 140
 141         end_options :: repr (Exit d) ArgOption ()
 142         end_options =
 143                 help_words "Force the end of options.\nUseful if <file> has the same name as an option." $
 144                 endOpt
 145
 146         option_lang :: (String, repr (Exit d) ArgOption String)
 147         option_lang =
 148                 let def = "en_US" in
 149                 (def,) $
 150                 help_words ("Use language <lang>.\nDefault <lang> is: "<>def) $
 151                 long "lang" $
 152                 var "lang" string
 153         rule_output :: repr (Exit d) ArgOption String
 154         rule_output =
 155                 rule "output" $
 156                 option_output
 157         option_output :: repr (Exit d) ArgOption String
 158         option_output =
 159                 help_words "Output into <file>.\nDefault <file> is: input <file> whose extension is replaced by <format> here and then." $
 160                 opt (OptionName 'o' "output") $
 161                 var "file" string
 162         option_dump_tct :: (Bool, repr (Exit d) ArgOption Bool)
 163         option_dump_tct =
 164                 (False,) $
 165                 help_words "Dump TCT." $
 166                 long  "dump-tct" $
 167                 value True
 168         option_dump_dtc :: (Bool, repr (Exit d) ArgOption Bool)
 169         option_dump_dtc =
 170                 (False,) $
 171                 help_words "Dump DTC." $
 172                 long  "dump-dtc" $
 173                 value True
 174         option_format :: repr (Exit d) ArgOption String
 175         option_format =
 176                 help_words "Output format." $
 177                 opt (OptionName 'f' "format") $
 178                 "plain" <$$ tag "plain" <||>
 179                 "html5" <$$ tag "html5"
 180 instance Plain.Doc d => Hdoc d (Plain.Plain d)
 181 instance Plain.Doc d => Hdoc d Read.Parser
 182 -- instance Plain.Doc d => Hdoc d (Help.Help d)
 183 instance Plain.Doc d => Hdoc d (Help.Help d)
 184
 185 parse ::
 186  Plain.Doc d =>
 187  [String] -> IO.IO (Maybe (Either (Exit d) Command))
 188 parse as =
 189         case Read.readArgs hdoc $ Read.Args $ Read.Arg <$> as of
 190          Right a -> return $ Just $ Right a
 191          Left err ->
 192                 case err of
 193                  P.FancyError _pos es ->
 194                         case Set.toList es of
 195                          [P.ErrorCustom (Read.ErrorRead e)] ->
 196                                 return $ Just $ Left e
 197                          _ -> return Nothing
 198                  P.TrivialError pos e es -> do
 199                         IO.putStr $ P.parseErrorPretty @_ @Void $
 200                                 P.TrivialError pos e es
 201                         return Nothing
 202
 203 parseIO :: [String] -> IO.IO ()
 204 parseIO as = do
 205         ret <- parse as
 206         case ret of
 207          Nothing -> return ()
 208          Just (Right cmd) ->
 209                 IO.print $ show cmd
 210          Just (Left err) -> do
 211                 case err of
 212                  Exit_Help d ->
 213                         DocIO.runTermIO IO.stdout $
 214                         Doc.withBreakable (Just 80) d <>
 215                         Doc.newline
 216                  Exit_Version ->
 217                         TL.putStrLn "version"