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