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
|
;;; Haunt --- Static site generator for GNU Guile
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of Haunt.
;;;
;;; Haunt 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.
;;;
;;; Haunt 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 Haunt. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; Miscellaneous utility procedures.
;;
;;; Code:
(define-module (haunt utils)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:export (flatten
flat-map
string-split-at
file-name-components
join-file-name-components
absolute-file-name
delete-file-recursively
mkdir-p
string->date*
take-up-to
make-user-module))
(define* (flatten lst #:optional depth)
"Return a list that recursively concatenates the sub-lists of LST,
up to DEPTH levels deep. When DEPTH is #f, the entire tree is
flattened."
(if (and (number? depth) (zero? depth))
lst
(fold-right (match-lambda*
(((sub-list ...) memo)
(append (flatten sub-list (and depth (1- depth)))
memo))
((elem memo)
(cons elem memo)))
'()
lst)))
(define (flat-map proc . lsts)
"Apply PROC to each element of each list in LSTS and return a new
list in which nested lists are concatenated into the result.
For example, the list (1 2 (3)) would be flattened to (1 2 3)."
(flatten (apply map proc lsts) 1))
(define (string-split-at str char-pred)
"Split STR at the first character that matches CHAR-PRED and return
a list of one or two strings. Two strings are returned if the string
was able to be split, with the character matching CHAR-PRED removed.
A list containing only STR is returned if CHAR-PRED does not match any
charcter."
(let ((i (string-index str char-pred)))
(if i
(list (string-take str i)
(string-drop str (1+ i)))
(list str))))
(define (file-name-components file-name)
"Split FILE-NAME into the components delimited by '/'."
(match file-name
("" '())
("/" '(""))
(_ (remove string-null? (string-split file-name #\/)))))
(define (join-file-name-components components)
"Join COMPONENTS into a file name string."
(string-join components "/"))
(define (absolute-file-name file-name)
"Return a an absolute file name string relative to the current
working directory for FILE-NAME, a relative file name string. If
FILE-NAME happens to already be absolute, FILE-NAME is returned
as-is."
(if (absolute-file-name? file-name)
file-name
(string-append (getcwd) "/" file-name)))
;; Written by Ludovic Courtès for GNU Guix.
(define* (delete-file-recursively dir
#:key follow-mounts?)
"Delete DIR recursively, like `rm -rf', without following symlinks. Don't
follow mount points either, unless FOLLOW-MOUNTS? is true. Report but ignore
errors."
(let ((dev (stat:dev (lstat dir))))
(file-system-fold (lambda (dir stat result) ; enter?
(or follow-mounts?
(= dev (stat:dev stat))))
(lambda (file stat result) ; leaf
(delete-file file))
(const #t) ; down
(lambda (dir stat result) ; up
(rmdir dir))
(const #t) ; skip
(lambda (file stat errno result)
(format (current-error-port)
"warning: failed to delete ~a: ~a~%"
file (strerror errno)))
#t
dir
;; Don't follow symlinks.
lstat)))
;; Written by Ludovic Courtès for GNU Guix.
(define (mkdir-p dir)
"Create directory DIR and all its ancestors."
(define absolute?
(string-prefix? "/" dir))
(define not-slash
(char-set-complement (char-set #\/)))
(let loop ((components (string-tokenize dir not-slash))
(root (if absolute?
""
".")))
(match components
((head tail ...)
(let ((path (string-append root "/" head)))
(catch 'system-error
(lambda ()
(mkdir path)
(loop tail path))
(lambda args
(if (= EEXIST (system-error-errno args))
(loop tail path)
(apply throw args))))))
(() #t))))
(define (string->date* str)
"Convert STR, a string in '~Y~m~d ~H:~M' format, into a SRFI-19 date
object."
(string->date str "~Y~m~d ~H:~M"))
(define (take-up-to n lst)
"Return the first N elements of LST or an equivalent list if there
are fewer than N elements."
(if (zero? n)
'()
(match lst
(() '())
((head . tail)
(cons head (take-up-to (1- n) tail))))))
(define (make-user-module modules)
"Return a new user module with the additional MODULES loaded."
(let ((module (make-fresh-user-module)))
(for-each (lambda (iface)
(module-use! module (resolve-interface iface)))
modules)
module))
|
