Add Testing.Options

src/libraries/OS-Independent/Testing/Options.dcl

+definition module Testing.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]
+	, strategy :: !Strategy
+	}
+
+:: MessageType = MT_Started | MT_Passed | MT_Failed | MT_Skipped | MT_Lost
+:: OutputFormat = OF_JSON | OF_HumanReadable
+:: Strategy = S_FailedFirst | S_Default
+
+:: Run =
+	{ name       :: !String
+	, executable :: !FilePath
+	, options    :: ![String]
+	}
+
+instance == MessageType
+
+derive gDefault MessageType, Options, OutputFormat, Run, Strategy
+
+messageType :: TestEvent -> MessageType
+
+parseTestOpts :: Options [String] -> MaybeErrorString Options

src/libraries/OS-Independent/Testing/Options.icl

+implementation module Testing.Options
+
+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, Strategy
+
+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")
+	, ("-S", "--strategy")
+	]
+
+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 ["--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 ["--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 ["--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 ["--strategy":args] = case args of
+	["default":args]      -> parseTestOpts {opts & strategy=S_Default} args
+	["failed-first":args] -> parseTestOpts {opts & strategy=S_FailedFirst} args
+	[s:args]              -> Error $ "Unknown strategy '" +++ s +++ "'"
+	[]                    -> Error "--strategy requires a parameter"
+parseTestOpts opts [arg:args] = Error $ "Unknown option '" +++ arg +++ "'"

tests/linux64/test.icl

@@ -127,6 +127,8 @@ import qualified System._Platform
 import qualified System._Pointer
 import qualified System._Posix
 import qualified System._Unsafe
+import qualified Testing.Options
+import qualified Testing.TestEvents
 import qualified Text
 import qualified Text.CSV
 import qualified Text.Encodings.Base64
@@ -155,6 +157,5 @@ import qualified Text.Unicode.Encodings.UTF8
 import qualified Text.Unicode.UChar
 import qualified Text.URI
 import qualified Text.XML
-import qualified Testing.TestEvents
 
 Start = "Hello World!"