Resolve #3; options for hiding messages

Tools/CleanTest.icl

@@ -6,9 +6,12 @@ import StdList
 import StdString
 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,8 +24,20 @@ import Text.Language
 :: Options =
 	{ runs :: ![Run]
 	, help :: !Bool
+	, hide :: ![MessageType]
 	}
 
+:: MessageType = MT_Started | MT_Passed | MT_Failed | MT_Skipped | MT_Lost
+
+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
@@ -30,7 +45,22 @@ import Text.Language
 	}
 
 gDefault{|Bool|} = False
-derive gDefault Options, Run
+derive gDefault MessageType, Options, Run
+
+:: ProcessOutput =
+	{ lines :: ![String]
+	, rest  :: !String
+	}
+
+append :: !String !(String .e -> .e) !ProcessOutput .e -> .(ProcessOutput, .e)
+append s f out env
+# out & rest = out.rest +++ s
+# lines = split "\n" out.rest
+| length lines == 1 = (out, env)
+# env = seqSt f (init lines) env
+# out & lines = out.lines ++ init lines
+# out & rest  = last lines
+= (out, env)
 
 Start w
 # ([prog:args],w) = getCommandLine w
@@ -38,27 +68,46 @@ Start w
 | isError opts = exit True (Just $ fromError opts) prog w
 # opts = fromOk opts
 | opts.help = exit True Nothing prog w
-# w = seqSt run opts.runs w
+# w = seqSt (run opts.hide) opts.runs w
 = w
 where
 	parseOpts :: Options [String] -> MaybeErrorString Options
 	parseOpts opts [] = Ok {opts & runs=reverse opts.runs}
-	parseOpts opts ["--run":args] = parseOpts opts ["-r":args]
-	parseOpts opts ["-r":exe:args] = parseOpts {opts & runs=[new:opts.runs]} args
-		with new = {gDefault{|*|} & executable=exe, name=exe}
-	parseOpts opts ["-r"] = Error "-r requires a parameter"
-	parseOpts opts ["--help":args] = parseOpts opts ["-h":args]
-	parseOpts opts ["-h":args] = parseOpts {opts & help=True} args
-	parseOpts opts ["--option":args] = parseOpts opts ["-O":args]
-	parseOpts opts ["-O":opt:args] = case opts.runs of
-		[]     -> Error "-O used before -r"
-		[r:rs] -> parseOpts {opts & runs=[{r & options=r.options ++ [opt]}:rs]} args
-	parseOpts opts ["-O"] = Error "-O requires a parameter"
-	parseOpts opts ["--name":args] = parseOpts opts ["-n":args]
-	parseOpts opts ["-n":name:args] = case opts.runs of
-		[]     -> Error "-n used before -r"
-		[r:rs] -> parseOpts {opts & runs=[{Run | r & name=name}:rs]} args
-	parseOpts opts ["-n"] = Error "-n requires a parameter"
+	parseOpts opts [arg:args] | isJust ('M'.get arg long_options)
+		= parseOpts opts [fromJust ('M'.get arg long_options):args]
+	where
+		long_options = 'M'.fromList
+			[ ("-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 ["--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
@@ -75,59 +124,61 @@ where
 		help :: String
 		help = prog +++ ": run Clean tests\nOptions:\n" +++
 			"  --help/-h        Show this help\n" +++
+			"  --hide/-H TYPE   Comma-separated list of types of messages to hide (start,pass,fail,skip,lost)\n" +++
 			"  --run/-r EXE     Execute tests from executable EXE\n" +++
 			"  --option/-O OPT  Add OPT to the command line of the previously added run\n" +++
 			"  --name/-n NAME   Give the previously added run the name NAME\n"
 
-run :: !Run !*World -> *World
-run r w
+run :: ![MessageType] !Run !*World -> *World
+run hide r w
 # (io,w) = stdio w
-# io = io <<< toJSON {StartEvent | name=r.Run.name} <<< "\n"
+# io = emit hide (StartEvent {StartEvent | name=r.Run.name}) io
 # (h,w) = runProcessIO r.executable r.options Nothing w
 | isError h
 	# (err,msg) = fromError h
-	# io = io <<< toJSON
+	# io = emit hide (EndEvent
 		{ name    = r.Run.name
 		, event   = Failed
 		, message = "Failed to execute " <+ r.executable <+ " (" <+ err <+ "; " <+ msg <+ ")"
-		} <<< "\n"
+		}) io
 	= snd $ fclose io w
 # (h,pio) = fromOk h
 # w = snd $ fclose io w
-# w = redirect "" h pio w
+# w = redirect {lines=[], rest=""} h pio w
 = w
 where
-	redirect :: String ProcessHandle ProcessIO *World -> *World
+	redirect :: ProcessOutput ProcessHandle ProcessIO *World -> *World
 	redirect output h pio w
 	# (io,w) = stdio w
 	// Check child output
 	# (ss,w) = readPipeBlockingMulti [pio.stdOut, pio.stdErr] w
 	| isError ss
 		# (err,msg) = fromError ss
-		# io = io <<< toJSON
+		# io = emit hide (EndEvent
 			{ name    = r.Run.name
 			, event   = Failed
 			, message = "Failed to read child process IO (" <+ err <+ "; " <+ msg <+ ")"
-			} <<< "\n"
+			}) io
 		= snd $ fclose io w
 	# [out,err:_] = fromOk ss
-	# io = io <<< out
+	# (output,io) = append out (\s io -> case fromJSON $ fromString s of
+		Nothing -> io
+		Just ev -> emit hide ev io) output io
 	# w = snd $ fclose (stderr <<< err) w
-	# output = output +++ out
 	// Check if child has terminated
 	# (t,w) = checkProcess h w
 	| isError t
 		# (err,msg) = fromError t
-		# io = io <<< toJSON
+		# io = emit hide (EndEvent
 			{ name    = r.Run.name
 			, event   = Failed
 			, message = "Failed to check on child process (" <+ err <+ "; " <+ msg <+ ")"
-			} <<< "\n"
+			}) io
 		= snd $ fclose io w
 	# rcode = fromOk t
 	// Check return code
 	| rcode == Just 0
-		# results = map (fromJSON o fromString) $ filter ((<>) "") $ split "\n" output
+		# results = map (fromJSON o fromString) $ filter ((<>) "") output.lines
 		| any isNothing results
 			# io = io <<< toJSON
 				{ name    = r.Run.name
@@ -135,14 +186,14 @@ where
 				, message = "Failed to read child messages"
 				} <<< "\n"
 			= snd $ fclose io w
-		# io = io <<< toJSON (mergeResults $ map fromJust results) <<< "\n"
+		# io = emit hide (EndEvent $ mergeResults $ map fromJust results) io
 		= snd $ fclose io w
 	| isJust rcode
-		# io = io <<< toJSON
+		# io = emit hide (EndEvent
 			{ name    = r.Run.name
 			, event   = Failed
 			, message = "Child process exited with " <+ fromJust rcode
-			} <<< "\n"
+			}) io
 		= snd $ fclose io w
 	# w = snd $ fclose io w
 	= redirect output h pio w
@@ -163,3 +214,8 @@ where
 			skipped = length $ filter (\te -> te=:(EndEvent {event=Skipped})) tes
 			lost = length (filter (\te -> te=:(StartEvent _)) tes) -
 				length (filter (\te -> te=:(EndEvent _)) tes)
+
+	emit :: [MessageType] TestEvent *File -> *File
+	emit hide ev io
+	| isMember (messageType ev) hide = io
+	| otherwise = io <<< toJSON ev <<< "\n"