/usr/share/gnotime/ghtml/C/gtt.scm is in gnotime 2.4.1-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 | ;
; FILE:
; gtt.scm
;
; FUNCTION:
; Miscellaneous definitions for generating reports
;
; HISTORY:
; Copyright (c) 2002,2003 Linas Vepstas <linas@linas.org>
;
; This file is covered by the GPL. Please refer to the
; GPL license for details.
; -- debugging support XXX using these crashes guile, don't know why.
; (use-modules (ice-9 debug))
; (use-modules (ice-9 stack-catch))
; (debug-enable 'backtrace)
; (debug-enable 'debug)
; (read-enable 'positions)
; Various bits of syntactic sugar for showing the current (linked)
; project title and other stuff of that sort.
;
(debug-set! stack 0)
(define (gtt-show-project-title)
(gtt-show (gtt-project-title (gtt-linked-project))))
(define (gtt-show-project-desc)
(gtt-show (gtt-project-desc (gtt-linked-project))))
(define (gtt-show-project-notes)
(gtt-show (gtt-project-notes (gtt-linked-project))))
(define (gtt-show-basic-journal)
(gtt-show-journal (gtt-linked-project)))
;; ---------------------------------------------------------
;; If a report query was run, use results from that;
;; show selected project & subprojects
;
(define (gtt-linked-or-query-results)
(if (gtt-did-query)
(gtt-query-results)
(gtt-project-subprojects (gtt-linked-project))
)
)
;; ---------------------------------------------------------
; Define primitives as per generic scheme
; surely these are defined in somewhere else (slib ??)
(define (xtagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
#f))
(define (xquoted? exp)
(xtagged-list? exp 'quote))
; Hmm, basic guile is missing a 'string-tail' function, so add it here.
; given a string and an integer offset, return copy of string
; from the offset to the very end.
(define (string-tail str off)
(substring str off (string-length str) ))
;; ---------------------------------------------------------
;; prototype infrastructure for new, "type-safe" types...
(define (gtt-is-task-list-type? x) (equal? (cdr x) "gtt-task-list") )
(define (gtt-is-interval-list-type? x) (equal? (cdr x) "gtt-interval-list") )
;; ---------------------------------------------------------
; The gtt-apply-func-list-to-obj routine is a simple utility
; to apply a list of functions to a single gtt object,
; where a gtt object is a task, interval, or project.
; The 'function list' should be either:
; -- a function that takes a single gtt object as an argument
; -- a double-quoted string
; It returns a list of the result of applying each function
; to the object, omitting null results from the list
;
; XXX FIXME the vars first_func, next_func, parent_obj,
; next_obj, result, appres, is-bill, is-hold, is-paid
; are scoped globally to the functions being applied. This
; introducees potential symbol conflist. This needds to be fixed!
;
(define (gtt-apply-func-list-to-obj func_list obj)
(let ( (first_func (car func_list))
(next_func (cdr func_list))
)
(let (
; result is the result of the evaluation.
; We compute it here to make sure we apply only once;
; we can use the result for tests.
(result (if (xquoted? first_func)
(cdr first_func) ;; just something quoted
(first_func obj)))
)
(if (null? next_func)
(if (null? result)
'()
(list result))
; if result was null, do not put it into list!
(if (null? result)
(gtt-apply-func-list-to-obj next_func obj)
(list result (gtt-apply-func-list-to-obj next_func obj)))
)
)))
; The gtt-apply-func-list-to-obj-list routine is a simple
; utility to apply a list of functions to a list of gtt objects.
; The 'function list' should be either:
; -- a function that takes a single object as an argument
; -- a double-quoted string
; It returns a list of the result of applying each function
; to the object, omitting null results from the list
;
(define (gtt-apply-func-list-to-obj-list func_list obj_list)
(if (null? obj_list) '()
(let ( (parent_obj (car obj_list))
(next_obj (cdr obj_list))
)
(let (
; appres is the result of the evaluation.
; We compute it here to make sure we apply only once;
; we can use the result for tests.
(appres (if (list? parent_obj)
(gtt-apply-func-list-to-obj-list func_list parent_obj)
(gtt-apply-func-list-to-obj func_list parent_obj))
)
)
(if (null? next_obj)
(if (null? appres)
'()
(list appres))
(if (null? appres)
(gtt-apply-func-list-to-obj-list func_list next_obj)
(list appres
(gtt-apply-func-list-to-obj-list func_list next_obj))
)
)
))))
;; ---------------------------------------------------------
; The gtt-show-projects is syntatic sugar for displaying a
; project info with embedded html markup
;
(define (gtt-show-projects prj_list func_list)
(gtt-show (gtt-apply-func-list-to-obj-list func_list prj_list))
)
; The gtt-show-tasks proceedure is syntatic sugar for displaying a
; task info with embedded html markup
;
(define (gtt-show-tasks task_list func_list)
(gtt-show (gtt-apply-func-list-to-obj-list func_list task_list))
)
; Syntactic sugar for organizing intervals.
(define (gtt-ivls task func_list)
(gtt-apply-func-list-to-obj-list func_list (gtt-intervals task))
)
; Utility to compute elapsed time
(define (gtt-interval-elapsed interval)
(- (gtt-interval-stop interval) (gtt-interval-start interval))
)
;; ---------------------------------------------------------
; The gtt-task-billable-value-str routine will display the value of
; a task, but only if its been marked as 'billable'.
(define (gtt-task-billable-value-str task)
(gtt-task-value-str task)
)
;; ---------------------------------------------------------
;; Define some filters to prune down task lists.
;;
;; The gtt-billable-tasks takes a list of tasks, and returns
;; a list of only those that are billable.
(define (gtt-filter-bill-tasks tasks)
(define (is-bill task)
(if (equal? (gtt-task-billstatus task) (gettext '"Bill"))
task '())
)
(gtt-apply-func-list-to-obj-list (list is-bill) tasks)
)
(define (gtt-filter-paid-tasks tasks)
(define (is-paid task)
(if (equal? (gtt-task-billstatus task) (gettext '"Paid"))
task '())
)
(gtt-apply-func-list-to-obj-list (list is-paid) tasks)
)
(define (gtt-filter-hold-tasks tasks)
(define (is-hold task)
(if (equal? (gtt-task-billstatus task) (gettext '"Hold"))
task '())
)
(gtt-apply-func-list-to-obj-list (list is-hold) tasks)
)
;; ---------------------------------------------------------
; The below identifies a 'daily-obj' type, with getters for its two members.
; The first member is the date,
; The second member is the amount of time spent on the project on that date.
; At this point, both members are strings; this may change someday.
(define (gtt-is-daily-type? daily-obj) (equal? (cdr daily-obj) "gtt-daily") )
;; XXX should really be using srfi-19 to handle the date printing
(define (gtt-daily-day-str daily-obj)
(if (gtt-is-daily-type? daily-obj)
(caar daily-obj) ))
(define (gtt-daily-time-str daily-obj)
(if (gtt-is-daily-type? daily-obj)
(cadar daily-obj) ))
(define (gtt-show-daily dly_list func_list)
(gtt-show (gtt-apply-func-list-to-obj-list func_list dly_list)))
;; ---------------------------------------------------------
;; Return the task list part of the daily report.
;; Currently, it assumes that the object is in a fixed position
;; in the list. A better implementation would perform a search
;; in the list for the right type.
(define (gtt-daily-task-list daily-obj)
(if (gtt-is-daily-type? daily-obj)
(caddar daily-obj) ))
(define (gtt-daily-interval-list daily-obj)
(if (gtt-is-daily-type? daily-obj)
(cadr (cddar daily-obj) )))
;; ---------------------------------------------------------
; Syntactic sugar that allows various task attributes to
; be extracted next to each other ... see daily report for usage
(define (gtt-show-daily-tasks dailyobj tasklist)
(gtt-apply-func-list-to-obj-list
tasklist
(car (gtt-daily-task-list dailyobj) )
))
;; ---------------------------------------------------------
; plain-text to HTML beautification. These filters can take
; plain-text input strings, and mark them up so that the
; formatting is preserved in html.
; Convert newlines to <br>\n and return the result.
; this routine is implemented tail-recursively
(define (gtt-html-escape-newline str)
(define (tail-escape-newline accum str)
(let ((noff (string-index str #\newline))
)
(if (equal? #f noff)
(string-append accum str)
(tail-escape-newline
(string-append accum (substring str 0 noff) "<br>\n")
(string-tail str (+ noff 1))
)
)
))
(tail-escape-newline "" str)
)
; For right now, all that this does is the newline thing.
; Hopefully it will do the URL markup too soon.
(define (gtt-html-markup str)
(gtt-html-escape-newline str)
)
;; ---------------------------------------------------------
;; --------------------- end of file -----------------------
|