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