blob: 11b76d5b18969ca855aec764345109785327f389 (
plain)
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
|
;; -*- geiser-scheme-implementation: guile -*-
(when (current-filename)
(add-to-load-path (dirname (current-filename))))
(set! (@ (global) basedir) (car %load-path))
(use-modules (srfi srfi-1)
(srfi srfi-41)
(srfi srfi-41 util)
(srfi srfi-88) ; keyword syntax
(util)
(util io)
(util time)
(util app)
(util config)
((entry-points html) :prefix html-)
((entry-points terminal) :prefix terminal-)
((entry-points import) :prefix import-)
((entry-points text) :prefix text-)
((entry-points info) :prefix info-)
((entry-points ical) :prefix ical-)
((entry-points benchmark) :prefix benchmark-)
((entry-points server) :prefix server-)
(ice-9 getopt-long)
(statprof)
(repl)
)
(define options
'((statprof (value optional))
(repl (value optional))
(help (single-char #\h))))
(define (ornull a b)
(if (null? a)
b a))
(define (wrapped-main args)
(define opts (getopt-long args options #:stop-at-first-non-option #t))
(define stprof (option-ref opts 'statprof #f))
(define repl (option-ref opts 'repl #f))
(when stprof (statprof-start))
(cond [(eqv? #t repl) (repl-start (format #f "~a/calp-~a" (runtime-dir) (getpid)))]
[repl => repl-start])
(let ((config-file (format #f "~a/.config/calp/config.scm"
(getenv "HOME"))))
(when (file-exists? config-file)
(primitive-load config-file)))
;; (current-app (make-app))
((@ (vcomponent) init-app) (get-config 'calendar-files))
((@ (datetime app) init-app))
(let ((ropt (ornull (option-ref opts '() '())
'("term"))))
((case (string->symbol (car ropt))
((html) html-main)
((term) terminal-main)
((import) import-main)
((text) text-main)
((info) info-main)
((ical) ical-main)
((server) server-main)
((benchmark) benchmark-main)
(else => (lambda (s)
(format (current-error-port)
"Unsupported mode of operation: ~a~%"
s)
(exit 1))))
ropt))
(when stprof
(statprof-stop)
(statprof-display (current-error-port)
style: (if (boolean? stprof)
'flat
(string->symbol stprof)))))
(use-modules (system vm frame))
(define (main args)
(report-time! "Program start")
;; ((@ (util config) print-configuration-documentation))
(with-throw-handler #t
(lambda () (wrapped-main args))
(lambda (err . args)
(define stack (make-stack #t))
(format
(current-error-port)
"bindings = (~a)~%"
(with-output-to-string
(lambda ()
(let loop ((frame (stack-ref stack 0)))
(when frame
(format #t "~{~a~^ ~}" (map binding-name (frame-bindings frame)))
(let ((event (and=> (frame-lookup-binding frame 'event)
binding-ref)))
(when event
(format (current-error-port) "event = ~a~%" event)
((@ (vcomponent output) serialize-vcomponent)
event (current-error-port))))
(loop (frame-previous frame))))))))))
|
