Commit 27694f98 authored by Bas Lijnse's avatar Bas Lijnse

Updated codequality monitor tool to compile and run clean-test based unit tests

parent fc49eb94
Pipeline #12658 failed with stage
in 1 minute and 27 seconds
......@@ -4,8 +4,9 @@ definition module iTasks.Extensions.Development.Testing
*/
import iTasks
from Testing.TestEvents import :: EndEventType
from Testing.TestEvents import :: EndEvent, :: EndEventType
from iTasks.Util.Testing import :: TestReport
from iTasks.Extensions.Development.Codebase import :: CleanModuleName, :: ModuleName
compileTestModule :: FilePath -> Task EndEventType
runTestModule :: FilePath -> Task EndEventType
compileTestModule :: CleanModuleName -> Task EndEvent
runTestModule :: CleanModuleName -> Task [EndEvent]
......@@ -4,78 +4,57 @@ import System.Time
import Testing.TestEvents
import iTasks.Util.Testing
import iTasks.Extensions.Files
import iTasks.Extensions.Development.Tools
import Text, Data.Tuple, Data.Error, System.FilePath, System.OS
import iTasks.Extensions.Development.Codebase
import Text, Data.Tuple, Data.Error, Data.Func, System.FilePath, System.OS
TESTS_PATH :== "../Tests/TestPrograms"
//:: CompileError = CompileError !Int
derive class iTask EndEventType
derive gEditor FailReason, FailedAssertion, CounterExample, Relation
derive gText FailReason, FailedAssertion, CounterExample, Relation
derive gDefault FailReason, FailedAssertion, CounterExample, Relation
derive gEq FailReason, FailedAssertion, CounterExample, Relation
compileTestModule :: FilePath -> Task EndEventType
compileTestModule path
= traceValue path >>| get cpmExecutable
>>- \cpm ->runWithOutput cpm ["project", base, "create"] (Just baseDir)
>>- \_ ->runWithOutput cpm ["project", prj, "target", "iTasks"] (Just baseDir)
>>- \_ ->runWithOutput cpm ["project", prj, "exec", base +++ ".exe"] (Just baseDir)
>>- \_ ->runWithOutput cpm ["project", prj, "set", "-h", "200M", "-s", "2M", "-dynamics"] (Just baseDir)
>>- \_ ->runWithOutput cpm [prj] (Just baseDir) //Build the test
@ \(c,o) -> if (passed c o) Passed (Failed Nothing)
derive gEditor EndEvent, FailReason, FailedAssertion, CounterExample, Relation
derive gText EndEvent, FailReason, FailedAssertion, CounterExample, Relation
derive gDefault EndEvent, FailReason, FailedAssertion, CounterExample, Relation
derive gEq EndEvent, FailReason, FailedAssertion, CounterExample, Relation
compileTestModule :: CleanModuleName -> Task EndEvent
compileTestModule (path,name)
= copyFile prjDefaultPath prjPath
>>- \_ -> get cpmExecutable
>>- \cpm -> runWithOutput cpm [prjPath] Nothing //Build the test
@ \(c,o) -> if (passed c o)
{name = testName, event = Passed, message = join "" o}
{name = testName, event = (Failed Nothing), message = join "" o}
where
testName = "Compile: " +++ name
iclPath = cleanFilePath (path,name,Icl)
prjDefaultPath = path </> name +++ ".prj.default"
prjPath = path </> name +++ ".prj"
//Cpm still returns exitcode 0 on failure, so we have to check the output
passed 0 o = let lines = split OS_NEWLINE (join "" o) in not (any isErrorLine lines)
passed _ _ = False
isErrorLine l = startsWith "Error" l || startsWith "Type error" l || startsWith "Parse error" l
baseDir = takeDirectory path
base = takeFileName (dropExtension path)
prj = takeFileName (addExtension base "prj")
//Copy-paste.. should be in library
runTestModule :: FilePath -> Task EndEventType
runTestModule path
= compileTestModule path
>>- \res -> case res of
Passed = runWithOutput exe [] Nothing @ (parseSuiteResult o appSnd (join "")) //Run the test
_ = return res
runTestModule :: CleanModuleName -> Task [EndEvent]
runTestModule (path,name)
= compileTestModule (path,name)
>>- \res=:{EndEvent|event} -> case event of
Passed = runWithOutput exe [] Nothing @ (parseTestResults o appSnd (join "")) //Run the test
_ = return [res]
where
exe = IF_WINDOWS (base </> addExtension name "exe") (path </> name)
baseDir = takeDirectory path
base = dropExtension path
exe = addExtension base "exe"
parseSuiteResult :: (Int,String) -> EndEventType //QUICK AND DIRTY PARSER
parseSuiteResult (ecode,output)
# lines = split "\n" output
parseTestResults (ecode,output)
# lines = split OS_NEWLINE output
| length lines < 2 = fallback ecode output
# suiteName = trim ((split ":" (lines !! 0)) !! 1)
# results = [parseRes resLines \\ resLines <- splitLines (drop 3 lines) | length resLines >= 2]
= Passed
//= {SuiteResult|suiteName=suiteName,testResults=results}
= [res \\ Just res <- map (fromJSON o fromString) lines]
where
splitLines lines = split` lines [[]]
where
split` ["":lines] acc = split` lines [[]:acc]
split` [l:lines] [h:acc] = split` lines [[l:h]:acc]
split` [] acc = reverse (map reverse acc)
parseRes [nameLine,resultLine:descLines]
# name = trim ((split ":" nameLine) !! 1)
# result = case resultLine of
"Result: Passed" = Passed
"Result: Skipped" = Skipped
//_ = Failed (if (descLines =: []) Nothing (Just (join "\n" descLines)))
_ = Failed (if (descLines =: []) Nothing (Just Crashed))
= (name,result)
parseRes _ = ("oops",Failed Nothing)
//If we can't parse the output, We'll treat it as a single simple test executable
fallback 0 _ = Passed //{SuiteResult|suiteName="Unknown",testResults=[("executable",Passed)]}
fallback _ output = Failed Nothing//{SuiteResult|suiteName="Unknown",testResults=[("executable",Failed (Just output))]}
fallback 0 _ = [{name=name,event=Passed,message="Execution returned 0"}]
fallback _ output = [{name=name,event=Failed Nothing,message=output}]
runWithOutput :: FilePath [String] (Maybe FilePath) -> Task (Int,[String])
runWithOutput prog args dir = withShared ([], []) \out->withShared [] \stdin->
......
......@@ -38,17 +38,17 @@ EXAMPLE_MODULES :== ["../Examples/BasicApiExamples.icl"
derive class iTask EndEventType
derive gEditor FailReason, FailedAssertion, CounterExample, Relation
derive gDefault FailReason, FailedAssertion, CounterExample, Relation
derive gEq FailReason, FailedAssertion, CounterExample, Relation
derive gText FailReason, FailedAssertion, CounterExample, Relation
derive gEditor EndEvent, FailReason, FailedAssertion, CounterExample, Relation
derive gDefault EndEvent, FailReason, FailedAssertion, CounterExample, Relation
derive gEq EndEvent, FailReason, FailedAssertion, CounterExample, Relation
derive gText EndEvent, FailReason, FailedAssertion, CounterExample, Relation
inspectCodeQuality :: Task ()
inspectCodeQuality
= application {WebImage|src="/testbench.png",alt="iTasks Testbench",width=200, height=50}
( allTasks [Title "Unit Tests" @>> runUnitTests
,Title "Interactive Tests" @>> runInteractiveTests
,Title "Example applications" @>> checkExampleApplications
//,Title "Example applications" @>> checkExampleApplications
,Title "Code" @>> exploreCode
,Title "Experiment" @>> inspectMainModule "test" "module test\nStart = \"Hello World\""
] <<@ ArrangeWithTabs False
......@@ -59,12 +59,12 @@ where
runInteractiveTests :: Task ()
runInteractiveTests
= ( editSelectionWithShared (Title "Select test") False (SelectInTree collectionToTree selectTest) tests (const []) @? tvHd
= ( editSelectionWithShared (Title "Select test") False (SelectInTree fileCollectionToTree selectTest) tests (const []) @? tvHd
>&> withSelection (viewInformation () [] "Select a test") testInteractive ) <<@ ArrangeWithSideBar 0 LeftSide 250 True @! ()
where
tests = sdsFocus INTERACTIVE_TESTS_PATH (fileCollection (\path isDirectory -> isDirectory || takeExtension path == "icl") False)
collectionToTree collection = itemsToTree [] collection
fileCollectionToTree collection = itemsToTree [] collection
where
itemsToTree prefix subCollection = map (itemToTree prefix) ('DM'.toList subCollection)
......@@ -88,38 +88,42 @@ where
runUnitTests :: Task ()
runUnitTests = withShared 'DM'.newMap
\results ->
(
(enterChoiceWithSharedAs () [ChooseFromGrid fst] (testsWithResults results) fst
>&> withSelection (viewInformation "Select a test" [] ())
(\path ->
(viewSharedInformation (Title "Code") [ViewUsing id aceTextArea] (sdsFocus (UNIT_TESTS_PATH </> path) (removeMaybe Nothing fileShare))
-&&-
viewSharedInformation (Title "Results") [ViewAs (toTestReport o maybeToList)] (mapRead ('DM'.get path) results) <<@ ArrangeHorizontal)
(( ((editSelectionWithShared (Title "Tests") False
(SelectInTree toModuleSelectTree selectByIndex)
(sdsFocus UNIT_TESTS_PATH moduleList) (const []) @? tvHd)
)
>&> withSelection (viewInformation "Select a test" [] ())
(viewTest results)
)
@! ()) <<@ ArrangeWithSideBar 0 LeftSide 250 True
where
selectByIndex nodes indices = [nodes !! i \\ i <- indices | i >= 0 && i < length nodes]
viewTest results (name,_)
= (viewSharedInformation (Title "Code") [ViewUsing (join "\n") aceTextArea] (sdsFocus (UNIT_TESTS_PATH,name) moduleImplementation)
-&&-
((viewSharedInformation (Title "Results") [ViewAs (toTestReport o maybeToList)] (mapRead ('DM'.get name) results) <<@ ArrangeHorizontal)
>^* [OnAction (Action "Run") (always
( runTestModule (UNIT_TESTS_PATH </> path) <<@ InWindow
>>- \res -> (upd ('DM'.put path res)) results
( runTestModule (UNIT_TESTS_PATH,name) <<@ InWindow
>>- \res -> (upd ('DM'.put name res)) results
)
)]
) @! ()) <<@ ArrangeWithSideBar 0 LeftSide 250 True
)
where
testsWithResults results = mapRead (\(res,tests) -> [(t,'DM'.get t res) \\t <- tests]) (results |*| tests)
where
tests = mapRead (filter ((==) "icl" o takeExtension)) (sdsFocus UNIT_TESTS_PATH directoryListing)
) @! ()) <<@ ArrangeWithSideBar 1 RightSide 400 True
toTestReport results
= DivTag [] [] //[suiteHtml res \\ res <- results | not (isEmpty results)]
= DivTag [] [setHtml res \\ res <- results | not (isEmpty results)]
where
suiteHtml testResults
setHtml testResults
= TableTag [StyleAttr "width: 100%"] [headerRow:map resultRow testResults]
headerRow = TrTag [] [ThTag [] [Text "Test"],ThTag [] [Text "Result"],ThTag [] [Text "Details"]]
resultRow Passed = TrTag [] [TdTag [] [Text "FIXME"],TdTag [] [SpanTag [StyleAttr "color: green"] [Text "Passed"]],TdTag [] []]
resultRow Skipped = TrTag [] [TdTag [] [Text "FIXME"],TdTag [] [SpanTag [StyleAttr "color: orange"] [Text "Skipped"]],TdTag [] []]
resultRow (Failed Nothing) = TrTag [] [TdTag [] [Text "FIXME"],TdTag [] [SpanTag [StyleAttr "color: red"] [Text "Failed"]],TdTag [] []]
resultRow (Failed (Just details)) = TrTag [] [TdTag [] [Text "FIXME"],TdTag [] [SpanTag [StyleAttr "color: red"] [Text "Failed"]],TdTag [] [TextareaTag [] [Text (toString (toJSON details))]]]
resultRow {name,event=Passed,message} = TrTag [] [TdTag [] [Text name],TdTag [] [SpanTag [StyleAttr "color: green"] [Text "Passed"]],TdTag [] [Text message]]
resultRow {name,event=Skipped,message} = TrTag [] [TdTag [] [Text name],TdTag [] [SpanTag [StyleAttr "color: orange"] [Text "Skipped"]],TdTag [] [Text message]]
resultRow {name,event=Failed Nothing,message} = TrTag [] [TdTag [] [Text name],TdTag [] [SpanTag [StyleAttr "color: red"] [Text "Failed"]],TdTag [] [Text message]]
resultRow {name,event=Failed (Just details),message} = TrTag [] [TdTag [] [Text name],TdTag [] [SpanTag [StyleAttr "color: red"] [Text "Failed"]],TdTag [] [TextareaTag [] [Text (toString (toJSON details))]]]
/*
checkExampleApplications = withShared 'DM'.newMap
\results ->
(
......@@ -140,6 +144,7 @@ where
examplesWithResults results = mapRead (\(res,examples) -> [(e,'DM'.get e res) \\e <- examples ]) (results |*| examples)
where
examples = constShare EXAMPLE_MODULES
*/
exploreCode :: Task ()
exploreCode
......@@ -293,7 +298,6 @@ where
]
Start world = startEngine inspectCodeQuality world
//Start world = startEngineWithOptions (\cli options -> (Just {options & autoLayout = False},[])) inspectCodeQuality world
//CREATE THIS WITH CPM LIBRARY
projectTemplate moduleName = join OS_NEWLINE
......
......@@ -8,7 +8,7 @@ Global
CheckIndexes: True
Application
HeapSize: 209715200
StackSize: 512000
StackSize: 5120000
ExtraMemory: 8192
IntialHeapSize: 204800
HeapSizeMultiplier: 4096
......
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