Commit 6824e091 authored by Camil Staps's avatar Camil Staps 🙂

Export Options type and parser (#4)

parent 9305beb3
Clean System Files/
Tools/CleanTest
Tools/ctest
......@@ -9,9 +9,6 @@ import StdTuple
import Control.Monad
import Data.Error
from Data.Func import $, seqSt
import Data.Generics.GenDefault
import Data.Generics.GenEq
import qualified Data.Map as M
import Data.Maybe
import System.CommandLine
import System.FilePath
......@@ -21,33 +18,7 @@ from Text import <+, class Text(split), instance Text String
import Text.JSON
import Text.Language
:: Options =
{ runs :: ![Run]
, help :: !Bool
, output :: !OutputFormat
, hide :: ![MessageType]
}
:: MessageType = MT_Started | MT_Passed | MT_Failed | MT_Skipped | MT_Lost
:: OutputFormat = OF_JSON | OF_HumanReadable
messageType :: TestEvent -> MessageType
messageType (StartEvent _) = MT_Started
messageType (EndEvent ee) = case ee.event of
Passed -> MT_Passed
Failed -> MT_Failed
Skipped -> MT_Skipped
derive gEq MessageType; instance == MessageType where == a b = a === b
:: Run =
{ name :: !String
, executable :: !FilePath
, options :: ![String]
}
gDefault{|Bool|} = False
derive gDefault MessageType, Options, OutputFormat, Run
import CleanTest.Options
:: ProcessOutput =
{ lines :: ![String]
......@@ -66,58 +37,13 @@ append s f out env
Start w
# ([prog:args],w) = getCommandLine w
# opts = parseOpts gDefault{|*|} args
# opts = parseTestOpts gDefault{|*|} args
| isError opts = exit True (Just $ fromError opts) prog w
# opts = fromOk opts
| opts.help = exit True Nothing prog w
# w = seqSt (run opts) opts.runs w
= w
where
parseOpts :: Options [String] -> MaybeErrorString Options
parseOpts opts [] = Ok {opts & runs=reverse opts.runs}
parseOpts opts [arg:args] | isJust ('M'.get arg long_options)
= parseOpts opts [fromJust ('M'.get arg long_options):args]
where
long_options = 'M'.fromList
[ ("-f", "--output-format")
, ("-h", "--help")
, ("-H", "--hide")
, ("-n", "--name")
, ("-O", "--option")
, ("-r", "--run")
]
parseOpts opts ["--help":args] = parseOpts {opts & help=True} args
parseOpts opts ["--hide":args] = case args of
[arg:args] -> mapM parseMT (split "," arg) >>= \h -> parseOpts {opts & hide=h} args
[] -> Error "--hide requires a parameter"
where
parseMT :: String -> MaybeErrorString MessageType
parseMT "start" = Ok MT_Started
parseMT "pass" = Ok MT_Passed
parseMT "fail" = Ok MT_Failed
parseMT "skip" = Ok MT_Skipped
parseMT "lost" = Ok MT_Lost
parseMT s = Error $ "Unknown message type '" +++ s +++ "'"
parseOpts opts ["--run":args] = case args of
[exe:args] -> parseOpts {opts & runs=[{gDefault{|*|} & executable=exe, name=exe}:opts.runs]} args
[] -> Error "--run requires a parameter"
parseOpts opts ["--option":args] = case args of
[opt:args] -> case opts.runs of
[] -> Error "--option used before --run"
[r:rs] -> parseOpts {opts & runs=[{r & options=r.options ++ [opt]}:rs]} args
[] -> Error "--option requires a parameter"
parseOpts opts ["--output-format":args] = case args of
["json":args] -> parseOpts {opts & output=OF_JSON} args
["human":args] -> parseOpts {opts & output=OF_HumanReadable} args
[fmt:args] -> Error $ "Unknown output format '" +++ fmt +++ "'"
[] -> Error "--output-format requires a parameter"
parseOpts opts ["--name":args] = case args of
[name:args] -> case opts.runs of
[] -> Error "-n used before -r"
[r:rs] -> parseOpts {opts & runs=[{Run | r & name=name}:rs]} args
[] -> Error "-n requires a parameter"
parseOpts opts [arg:args] = Error $ "Unknown option '" +++ arg +++ "'"
exit :: Bool (Maybe String) String *World -> *World
exit show_help error prog w
# io = stderr
......
definition module CleanTest.Options
from StdOverloaded import class ==
from Data.Error import :: MaybeError, :: MaybeErrorString
from Data.Generics.GenDefault import generic gDefault
from System.FilePath import :: FilePath
from Testing.TestEvents import :: TestEvent
:: Options =
{ runs :: ![Run]
, help :: !Bool
, output :: !OutputFormat
, hide :: ![MessageType]
}
:: MessageType = MT_Started | MT_Passed | MT_Failed | MT_Skipped | MT_Lost
:: OutputFormat = OF_JSON | OF_HumanReadable
:: Run =
{ name :: !String
, executable :: !FilePath
, options :: ![String]
}
instance == MessageType
derive gDefault MessageType, Options, OutputFormat, Run
messageType :: TestEvent -> MessageType
parseTestOpts :: Options [String] -> MaybeErrorString Options
implementation module CleanTest.Options
import StdList
import StdOverloaded
import StdString
import Control.Monad
import Data.Error
from Data.Func import $
import Data.Generics.GenDefault
import Data.Generics.GenEq
import Data.List
import Data.Maybe
import System.FilePath
import Testing.TestEvents
from Text import class Text(split), instance Text String
derive gEq MessageType; instance == MessageType where == a b = a === b
gDefault{|Bool|} = False
derive gDefault MessageType, Options, OutputFormat, Run
messageType :: TestEvent -> MessageType
messageType (StartEvent _) = MT_Started
messageType (EndEvent ee) = case ee.event of
Passed -> MT_Passed
Failed -> MT_Failed
Skipped -> MT_Skipped
LONG_OPTIONS =:
[ ("-f", "--output-format")
, ("-h", "--help")
, ("-H", "--hide")
, ("-n", "--name")
, ("-O", "--option")
, ("-r", "--run")
]
parseTestOpts :: Options [String] -> MaybeErrorString Options
parseTestOpts opts [] = Ok {opts & runs=reverse opts.runs}
parseTestOpts opts [arg:args] | isJust opt = parseTestOpts opts [fromJust opt:args]
where opt = lookup arg LONG_OPTIONS
parseTestOpts opts ["--help":args] = parseTestOpts {opts & help=True} args
parseTestOpts opts ["--hide":args] = case args of
[arg:args] -> mapM parseMT (split "," arg) >>= \h -> parseTestOpts {opts & hide=h} args
[] -> Error "--hide requires a parameter"
where
parseMT :: String -> MaybeErrorString MessageType
parseMT "start" = Ok MT_Started
parseMT "pass" = Ok MT_Passed
parseMT "fail" = Ok MT_Failed
parseMT "skip" = Ok MT_Skipped
parseMT "lost" = Ok MT_Lost
parseMT s = Error $ "Unknown message type '" +++ s +++ "'"
parseTestOpts opts ["--run":args] = case args of
[exe:args] -> parseTestOpts {opts & runs=[{gDefault{|*|} & executable=exe, name=exe}:opts.runs]} args
[] -> Error "--run requires a parameter"
parseTestOpts opts ["--option":args] = case args of
[opt:args] -> case opts.runs of
[] -> Error "--option used before --run"
[r:rs] -> parseTestOpts {opts & runs=[{r & options=r.options ++ [opt]}:rs]} args
[] -> Error "--option requires a parameter"
parseTestOpts opts ["--output-format":args] = case args of
["json":args] -> parseTestOpts {opts & output=OF_JSON} args
["human":args] -> parseTestOpts {opts & output=OF_HumanReadable} args
[fmt:args] -> Error $ "Unknown output format '" +++ fmt +++ "'"
[] -> Error "--output-format requires a parameter"
parseTestOpts opts ["--name":args] = case args of
[name:args] -> case opts.runs of
[] -> Error "-n used before -r"
[r:rs] -> parseTestOpts {opts & runs=[{Run | r & name=name}:rs]} args
[] -> Error "-n requires a parameter"
parseTestOpts opts [arg:args] = Error $ "Unknown option '" +++ arg +++ "'"
BIN:=CleanTest
BIN:=ctest
SRC:=CleanTest
CLM:=clm
CLMFLAGS:=-nr -nt -nortsopts\
-I $$CLEAN_HOME/lib/Platform
......@@ -8,7 +9,7 @@ CLMFLAGS:=-nr -nt -nortsopts\
all: $(BIN)
$(BIN): .FORCE
$(CLM) $(CLMFLAGS) $@ -o $@
$(CLM) $(CLMFLAGS) $(SRC) -o $@
clean:
$(RM) -r **/Clean\ System\ Files $(BIN)
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment