factor/extra/mason/report/report.factor

! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs combinators.smart debugger fry io.encodings.utf8
io.files io.streams.string kernel literals locals mason.common
mason.config mason.disk math namespaces sequences xml.syntax
xml.writer ;
IN: mason.report

: git-link ( id -- link )
    [ "http://github.com/slavapestov/factor/commit/" "" prepend-as ] keep
    [XML <a href=<->><-></a> XML] ;

: common-report ( -- xml )
    target-os get
    target-cpu get
    short-host-name
    disk-usage
    build-dir
    current-git-id get git-link
    [XML
    <h1>Build report for <->/<-></h1>
    <table>
    <tr><td>Build machine:</td><td><-></td></tr>
    <tr><td>Disk usage:</td><td><-></td></tr>
    <tr><td>Build directory:</td><td><-></td></tr>
    <tr><td>GIT ID:</td><td><-></td></tr>
    </table>
    XML] ;

: with-report ( quot -- )
    [ "report" utf8 ] dip
    '[
        common-report
        _ call( -- xml )
        [XML <html><body><-><-></body></html> XML]
        write-xml
    ] with-file-writer ; inline

: file-tail ( file encoding lines -- seq )
    [ file-lines ] dip short tail* "\n" join ;

:: failed-report ( error file what -- status )
    [
        error [ error. ] with-string-writer :> error
        file utf8 400 file-tail :> output

        [XML
        <h2><-what-></h2>
        Build output:
        <pre><-output-></pre>
        Launcher error:
        <pre><-error-></pre>
        XML]
    ] with-report
    status-error ;

: compile-failed ( error -- status )
    "compile-log" "VM compilation failed" failed-report ;

: boot-failed ( error -- status )
    "boot-log" "Bootstrap failed" failed-report ;

: test-failed ( error -- status )
    "test-log" "Tests failed" failed-report ;

: timings-table ( -- xml )
    ${
        boot-time-file
        load-time-file
        test-time-file
        help-lint-time-file
        benchmark-time-file
        html-help-time-file
    } [
        dup eval-file nanos>time
        [XML <tr><td><-></td><td><-></td></tr> XML]
    ] map [XML <h2>Timings</h2> <table><-></table> XML] ;

: error-dump ( heading vocabs-file messages-file -- xml )
    [ eval-file ] dip over empty? [ 3drop f ] [
        [ ]
        [ [ [XML <li><-></li> XML] ] map [XML <ul><-></ul> XML] ]
        [ utf8 file-contents ]
        tri*
        [XML <h1><-></h1> <-> Details: <pre><-></pre> XML]
    ] if ;

: benchmarks-table ( assoc -- xml )
    [
        1,000,000,000 /f
        [XML <tr><td><-></td><td><-></td></tr> XML]
    ] { } assoc>map
    [XML
        <h2>Benchmarks</h2>
        <table>
            <tr><th>Benchmark</th><th>Time (seconds)</th></tr>
            <->
        </table>
    XML] ;

: successful-report ( -- )
    [
        [
            timings-table

            "Load failures"
            load-all-vocabs-file
            load-all-errors-file
            error-dump

            "Compiler errors"
            compiler-errors-file
            compiler-error-messages-file
            error-dump

            "Unit test failures"
            test-all-vocabs-file
            test-all-errors-file
            error-dump

            "Help lint failures"
            help-lint-vocabs-file
            help-lint-errors-file
            error-dump

            "Benchmark errors"
            benchmark-error-vocabs-file
            benchmark-error-messages-file
            error-dump

            benchmarks-file eval-file benchmarks-table
        ] output>array
    ] with-report ;

: build-clean? ( -- ? )
    ${
        load-all-vocabs-file
        test-all-vocabs-file
        help-lint-vocabs-file
        compiler-errors-file
        benchmark-error-vocabs-file
    } [ eval-file empty? ] all? ;

: success ( -- status )
    successful-report build-clean? status-clean status-dirty ? ;
mason: various assorted improvements - put disk usage in build report - bump minimum disk space required before starting a build from 300mb to 1gb - check repository consistency before pulling; if there are untracked files, or if the pull fails, blow away the repo and clone it again 2010-09-05 18:22:02 -04:00			`! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.`
Mason: another type of builder 2008-09-16 00:20:33 -04:00			`! See http://factorcode.org/license.txt for BSD license.`
mason: cleanup usings and misc stuff. 2014-11-15 19:20:49 -05:00			`USING: assocs combinators.smart debugger fry io.encodings.utf8`
			`io.files io.streams.string kernel literals locals mason.common`
			`mason.config mason.disk math namespaces sequences xml.syntax`
			`xml.writer ;`
Mason: another type of builder 2008-09-16 00:20:33 -04:00			`IN: mason.report`

mason.report: put github link in build reports 2009-11-20 01:12:28 -05:00			`: git-link ( id -- link )`
fix some tests broken by the prepend change. 2012-05-29 19:58:58 -04:00			`[ "http://github.com/slavapestov/factor/commit/" "" prepend-as ] keep`
mason.report: put github link in build reports 2009-11-20 01:12:28 -05:00			`[XML <a href=<->><-></a> XML] ;`

mason: send HTML e-mails; if benchmarks fail build fails 2009-04-17 18:55:33 -04:00			`: common-report ( -- xml )`
			`target-os get`
			`target-cpu get`
webapps.mason: Now renders a download grid with links to build machine status and download pages 2009-05-21 20:15:04 -04:00			`short-host-name`
mason: various assorted improvements - put disk usage in build report - bump minimum disk space required before starting a build from 300mb to 1gb - check repository consistency before pulling; if there are untracked files, or if the pull fails, blow away the repo and clone it again 2010-09-05 18:22:02 -04:00			`disk-usage`
mason: send HTML e-mails; if benchmarks fail build fails 2009-04-17 18:55:33 -04:00			`build-dir`
mason.report: put github link in build reports 2009-11-20 01:12:28 -05:00			`current-git-id get git-link`
mason: send HTML e-mails; if benchmarks fail build fails 2009-04-17 18:55:33 -04:00			`[XML`
			`<h1>Build report for <->/<-></h1>`
			`<table>`
			`<tr><td>Build machine:</td><td><-></td></tr>`
mason: various assorted improvements - put disk usage in build report - bump minimum disk space required before starting a build from 300mb to 1gb - check repository consistency before pulling; if there are untracked files, or if the pull fails, blow away the repo and clone it again 2010-09-05 18:22:02 -04:00			`<tr><td>Disk usage:</td><td><-></td></tr>`
mason: send HTML e-mails; if benchmarks fail build fails 2009-04-17 18:55:33 -04:00			`<tr><td>Build directory:</td><td><-></td></tr>`
			`<tr><td>GIT ID:</td><td><-></td></tr>`
			`</table>`
			`XML] ;`
Mason: another type of builder 2008-09-16 00:20:33 -04:00
			`: with-report ( quot -- )`
mason: send HTML e-mails; if benchmarks fail build fails 2009-04-17 18:55:33 -04:00			`[ "report" utf8 ] dip`
			`'[`
Revert "Try without-limits in mason.report. Fixes #275." This reverts commit 1771f18998b20e0f8769b094f46329267799c7e7. 2011-10-21 16:34:08 -04:00			`common-report`
			`_ call( -- xml )`
			`[XML <html><body><-><-></body></html> XML]`
			`write-xml`
mason: send HTML e-mails; if benchmarks fail build fails 2009-04-17 18:55:33 -04:00			`] with-file-writer ; inline`
Mason: another type of builder 2008-09-16 00:20:33 -04:00
mason.report: join lines with \n 2009-05-18 17:50:11 -04:00			`: file-tail ( file encoding lines -- seq )`
			`[ file-lines ] dip short tail* "\n" join ;`

mason: working on a big overhaul of mason. Status updates sent to a web service, binary upload notification via Twitter 2009-04-17 21:59:59 -04:00			`:: failed-report ( error file what -- status )`
Mason: another type of builder 2008-09-16 00:20:33 -04:00			`[`
mason: send HTML e-mails; if benchmarks fail build fails 2009-04-17 18:55:33 -04:00			`error [ error. ] with-string-writer :> error`
mason.report: join lines with \n 2009-05-18 17:50:11 -04:00			`file utf8 400 file-tail :> output`
fix some tests broken by the prepend change. 2012-05-29 19:58:58 -04:00
mason: send HTML e-mails; if benchmarks fail build fails 2009-04-17 18:55:33 -04:00			`[XML`
			`<h2><-what-></h2>`
			`Build output:`
			`<pre><-output-></pre>`
			`Launcher error:`
			`<pre><-error-></pre>`
			`XML]`
mason: working on a big overhaul of mason. Status updates sent to a web service, binary upload notification via Twitter 2009-04-17 21:59:59 -04:00			`] with-report`
			`status-error ;`
Mason: another type of builder 2008-09-16 00:20:33 -04:00
mason: working on a big overhaul of mason. Status updates sent to a web service, binary upload notification via Twitter 2009-04-17 21:59:59 -04:00			`: compile-failed ( error -- status )`
mason: send HTML e-mails; if benchmarks fail build fails 2009-04-17 18:55:33 -04:00			`"compile-log" "VM compilation failed" failed-report ;`

mason: working on a big overhaul of mason. Status updates sent to a web service, binary upload notification via Twitter 2009-04-17 21:59:59 -04:00			`: boot-failed ( error -- status )`
mason: send HTML e-mails; if benchmarks fail build fails 2009-04-17 18:55:33 -04:00			`"boot-log" "Bootstrap failed" failed-report ;`
Mason: another type of builder 2008-09-16 00:20:33 -04:00
mason: working on a big overhaul of mason. Status updates sent to a web service, binary upload notification via Twitter 2009-04-17 21:59:59 -04:00			`: test-failed ( error -- status )`
mason: send HTML e-mails; if benchmarks fail build fails 2009-04-17 18:55:33 -04:00			`"test-log" "Tests failed" failed-report ;`

			`: timings-table ( -- xml )`
Working on webapps.mason 2009-05-21 01:08:43 -04:00			`${`
			`boot-time-file`
			`load-time-file`
			`test-time-file`
			`help-lint-time-file`
			`benchmark-time-file`
			`html-help-time-file`
mason: send HTML e-mails; if benchmarks fail build fails 2009-04-17 18:55:33 -04:00			`} [`
Bootstrap and mason now record times in nanoseconds 2009-11-20 00:50:30 -05:00			`dup eval-file nanos>time`
mason: send HTML e-mails; if benchmarks fail build fails 2009-04-17 18:55:33 -04:00			`[XML <tr><td><-></td><td><-></td></tr> XML]`
			`] map [XML <h2>Timings</h2> <table><-></table> XML] ;`

mason: working on a big overhaul of mason. Status updates sent to a web service, binary upload notification via Twitter 2009-04-17 21:59:59 -04:00			`: error-dump ( heading vocabs-file messages-file -- xml )`
mason: send HTML e-mails; if benchmarks fail build fails 2009-04-17 18:55:33 -04:00			`[ eval-file ] dip over empty? [ 3drop f ] [`
			`[ ]`
			`[ [ [XML <li><-></li> XML] ] map [XML <ul><-></ul> XML] ]`
			`[ utf8 file-contents ]`
			`tri*`
			`[XML <h1><-></h1> <-> Details: <pre><-></pre> XML]`
			`] if ;`

			`: benchmarks-table ( assoc -- xml )`
Mason: another type of builder 2008-09-16 00:20:33 -04:00			`[`
mason.report: better benchmark timings 2009-11-20 19:20:45 -05:00			`1,000,000,000 /f`
mason: send HTML e-mails; if benchmarks fail build fails 2009-04-17 18:55:33 -04:00			`[XML <tr><td><-></td><td><-></td></tr> XML]`
mason.report: better benchmark timings 2009-11-20 19:20:45 -05:00			`] { } assoc>map`
			`[XML`
			`<h2>Benchmarks</h2>`
			`<table>`
			`<tr><th>Benchmark</th><th>Time (seconds)</th></tr>`
			`<->`
			`</table>`
			`XML] ;`
Mason: another type of builder 2008-09-16 00:20:33 -04:00
			`: successful-report ( -- )`
			`[`
mason: send HTML e-mails; if benchmarks fail build fails 2009-04-17 18:55:33 -04:00			`[`
			`timings-table`
Mason: another type of builder 2008-09-16 00:20:33 -04:00
mason: send HTML e-mails; if benchmarks fail build fails 2009-04-17 18:55:33 -04:00			`"Load failures"`
Split up tools.vocabs. Note that load-everything is now named load-all 2009-05-04 07:44:17 -04:00			`load-all-vocabs-file`
			`load-all-errors-file`
mason: working on a big overhaul of mason. Status updates sent to a web service, binary upload notification via Twitter 2009-04-17 21:59:59 -04:00			`error-dump`
Mason: another type of builder 2008-09-16 00:20:33 -04:00
Compiler warnings are no more 2009-04-23 23:17:25 -04:00			`"Compiler errors"`
mason: send HTML e-mails; if benchmarks fail build fails 2009-04-17 18:55:33 -04:00			`compiler-errors-file`
			`compiler-error-messages-file`
mason: working on a big overhaul of mason. Status updates sent to a web service, binary upload notification via Twitter 2009-04-17 21:59:59 -04:00			`error-dump`
Mason: another type of builder 2008-09-16 00:20:33 -04:00
mason: send HTML e-mails; if benchmarks fail build fails 2009-04-17 18:55:33 -04:00			`"Unit test failures"`
			`test-all-vocabs-file`
			`test-all-errors-file`
mason: working on a big overhaul of mason. Status updates sent to a web service, binary upload notification via Twitter 2009-04-17 21:59:59 -04:00			`error-dump`
fix some tests broken by the prepend change. 2012-05-29 19:58:58 -04:00
mason: send HTML e-mails; if benchmarks fail build fails 2009-04-17 18:55:33 -04:00			`"Help lint failures"`
			`help-lint-vocabs-file`
			`help-lint-errors-file`
mason: working on a big overhaul of mason. Status updates sent to a web service, binary upload notification via Twitter 2009-04-17 21:59:59 -04:00			`error-dump`
Put compiler errors in build report 2008-11-16 14:46:45 -05:00
mason: send HTML e-mails; if benchmarks fail build fails 2009-04-17 18:55:33 -04:00			`"Benchmark errors"`
			`benchmark-error-vocabs-file`
			`benchmark-error-messages-file`
mason: working on a big overhaul of mason. Status updates sent to a web service, binary upload notification via Twitter 2009-04-17 21:59:59 -04:00			`error-dump`
mason.report: Remove superfluous text 2009-05-08 22:33:49 -04:00
mason: send HTML e-mails; if benchmarks fail build fails 2009-04-17 18:55:33 -04:00			`benchmarks-file eval-file benchmarks-table`
			`] output>array`
mason: working on a big overhaul of mason. Status updates sent to a web service, binary upload notification via Twitter 2009-04-17 21:59:59 -04:00			`] with-report ;`

			`: build-clean? ( -- ? )`
Working on webapps.mason 2009-05-21 01:08:43 -04:00			`${`
			`load-all-vocabs-file`
			`test-all-vocabs-file`
			`help-lint-vocabs-file`
			`compiler-errors-file`
			`benchmark-error-vocabs-file`
			`} [ eval-file empty? ] all? ;`
mason: working on a big overhaul of mason. Status updates sent to a web service, binary upload notification via Twitter 2009-04-17 21:59:59 -04:00
			`: success ( -- status )`
fix some tests broken by the prepend change. 2012-05-29 19:58:58 -04:00			`successful-report build-clean? status-clean status-dirty ? ;`