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
|
;;; 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)
(flatten (apply map proc lsts) 1))
(define (string-split-at str char-pred)
(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 '/'."
(if (string-null? file-name)
'()
(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)
(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))
|
