-
Notifications
You must be signed in to change notification settings - Fork 2
/
utils.scm
116 lines (97 loc) · 2.79 KB
/
utils.scm
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
;; This file is part of mowedline.
;; Copyright (C) 2015 John J. Foerch
;;
;; mowedline is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; mowedline is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with mowedline. If not, see <http://www.gnu.org/licenses/>.
(import chicken scheme)
(use (srfi 1)
coops
matchable
pathname-expand)
;;;
;;; Language
;;;
(define L list)
(define rest cdr)
(define-syntax bind
(syntax-rules ()
((bind pattern exp . body)
(match exp (pattern . body)))))
(define-syntax bind-lambda
(syntax-rules ()
((bind-lambda pattern . body)
(match-lambda (pattern . body)))))
(define-syntax bind-lambda*
(syntax-rules ()
((bind-lambda* pattern . body)
(match-lambda* (pattern . body)))))
;;;
;;; Utils
;;;
(define (ensure-list x)
(if (list? x)
x
(list x)))
(define-inline (*subclass? c1 c2)
(or (eq? c1 c2) (subclass? c1 c2)))
(define (instance-of? x class)
(*subclass? (class-of x) class))
(define (split-properties lst)
(bind (_ props . tail)
(fold
(bind-lambda*
(x (expect-value? props . tail))
(cond
(expect-value?
(cons* #f (cons x props) tail))
((symbol? x)
(cons* #t (cons x props) tail))
(else
(cons* #f props x tail))))
(cons* #f '() '())
lst)
(values (reverse! props) (reverse! tail))))
;; text-maybe-pad-left prepends a space on a string or mowedline markup
;; structure iff the text is non-null.
;;
(define (text-maybe-pad-left text)
(cond
((and (string? text)
(not (string-null? text)))
(string-append " " text))
((and (pair? text)
(not (null? text)))
(cons " " text))
(else text)))
;; widget-update-at-interval calls widget-update on the given widget every
;; interval seconds, with the value returned by (thunk).
;;
(define (widget-update-at-interval widget interval thunk)
(define (poll-thread widget)
(lambda ()
(let loop ()
(gochan-send
*internal-events*
(lambda () (update widget (thunk))))
(thread-sleep! interval)
(loop))))
(thread-start!
(make-thread (poll-thread widget))))
;;;
;;; Environment
;;;
(define (xdg-config-home)
(let ((path (get-environment-variable "XDG_CONFIG_HOME")))
(if (and path (not (string-null? path)))
path
(pathname-expand "~/.config"))))