[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
129/197: installer: Emphasise that writing filesystems destroys existing
From: |
Danny Milosavljevic |
Subject: |
129/197: installer: Emphasise that writing filesystems destroys existing data. |
Date: |
Mon, 3 Jul 2017 20:37:12 -0400 (EDT) |
dannym pushed a commit to branch wip-installer-2
in repository guix.
commit b22e114f4d7a1a4d460bf62f98fbab031c76d52c
Author: John Darrington <address@hidden>
Date: Sun Jan 22 12:29:16 2017 +0100
installer: Emphasise that writing filesystems destroys existing data.
* gnu/system/installer/guixsd-installer.scm (guixsd-installer): Add new
colour pair.
* gnu/system/installer/misc.scm (installer-texinfo-markup): New variable.
* gurses/stexi.scm: New file.
* Makefile.am (MODULES): Add it.
* gnu/system/installer/format.scm (format-page-init): Mark as @strong the
warning about
destroying existing data.
---
Makefile.am | 4 +
gnu/system/installer/format.scm | 19 +--
gnu/system/installer/guixsd-installer.scm | 1 +
gnu/system/installer/misc.scm | 30 +++++
gurses/stexi.scm | 209 ++++++++++++++++++++++++++++++
5 files changed, 255 insertions(+), 8 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index f6059d9..9c1215e 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -38,6 +38,10 @@ include gnu/local.mk
MODULES = \
guix/base16.scm \
+ gurses/buttons.scm \
+ gurses/form.scm \
+ gurses/menu.scm \
+ gurses/stexi.scm \
guix/base32.scm \
guix/base64.scm \
guix/cpio.scm \
diff --git a/gnu/system/installer/format.scm b/gnu/system/installer/format.scm
index bc0ce81..e852d4e 100644
--- a/gnu/system/installer/format.scm
+++ b/gnu/system/installer/format.scm
@@ -26,6 +26,8 @@
#:use-module (gurses buttons)
#:use-module (ncurses curses)
#:use-module (srfi srfi-1)
+ #:use-module (texinfo)
+ #:use-module (gurses stexi)
#:export (filesystems-are-current?)
#:export (make-format-page))
@@ -184,14 +186,15 @@ match those uuids read from the respective partitions"
(getmaxy text-window)
0)))
- (addstr* text-window
- (gettext
- (format #f
- "The partitions ~s will be formatted. All data on
these partitions will be destroyed if you continue."
- (map (lambda (x)
- (car x))
- mount-points))))
-
+ (render-stexi
+ text-window
+ (texi-fragment->stexi
+ (gettext
+ (format #f
+ "The partitions ~s will be formatted. @strong{Any existing
data on these partitions will be destroyed if you continue!!}"
+ (map (lambda (x) (car x))
+ mount-points))))
+ #:markup-table installer-texinfo-markup)
(push-cursor (page-cursor-visibility p))
diff --git a/gnu/system/installer/guixsd-installer.scm
b/gnu/system/installer/guixsd-installer.scm
index 6db5477..c5394df 100644
--- a/gnu/system/installer/guixsd-installer.scm
+++ b/gnu/system/installer/guixsd-installer.scm
@@ -288,6 +288,7 @@ tail of the list."
(start-color!)
(init-pair! livery-title COLOR_RED COLOR_BLACK)
+ (init-pair! 2 COLOR_MAGENTA COLOR_BLACK)
(curs-set 0)
diff --git a/gnu/system/installer/misc.scm b/gnu/system/installer/misc.scm
index b245656..5c0ad3e 100644
--- a/gnu/system/installer/misc.scm
+++ b/gnu/system/installer/misc.scm
@@ -25,6 +25,7 @@
#:export (config-file)
#:export (key-map)
#:export (system-role)
+ #:export (installer-texinfo-markup)
#:export (mount-points))
(define livery-title 1)
@@ -39,3 +40,32 @@
(define config-file #f)
(define system-role #f)
+
+(define installer-texinfo-markup
+ `((bold . ,bold)
+ (samp . ,normal)
+ (code . ,normal)
+ (math . ,normal)
+ (kbd . ,normal)
+ (key . ,inverse)
+ (var . ,normal)
+ (env . ,normal)
+ (file . ,normal)
+ (command . ,normal)
+ (option . ,normal)
+ (dfn . ,standout)
+ (cite . ,normal)
+ (acro . ,normal)
+ (email . ,normal)
+ (emph . ,dim)
+ (strong . ,(lambda (x) (color 2 x)))
+ (sample . ,normal)
+ (sc . ,normal)
+ (titlefont . ,normal)
+ (asis . ,normal)
+ (b . ,bold)
+ (i . ,normal)
+ (r . ,normal)
+ (sansserif . ,normal)
+ (slanted . ,normal)
+ (t . ,normal)))
diff --git a/gurses/stexi.scm b/gurses/stexi.scm
new file mode 100644
index 0000000..67ffd4e
--- /dev/null
+++ b/gurses/stexi.scm
@@ -0,0 +1,209 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 John Darrington <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix 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.
+;;;
+;;; GNU Guix 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gurses stexi)
+
+ #:export (render-stexi)
+ #:use-module (ncurses curses)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1))
+
+(define default-markup-table
+ `((bold . ,bold)
+ (samp . ,normal)
+ (code . ,normal)
+ (math . ,normal)
+ (kbd . ,normal)
+ (key . ,inverse)
+ (var . ,normal)
+ (env . ,normal)
+ (file . ,normal)
+ (command . ,normal)
+ (option . ,normal)
+ (dfn . ,underline)
+ (cite . ,normal)
+ (acro . ,normal)
+ (email . ,normal)
+ (emph . ,dim)
+ (strong . ,blink)
+ (sample . ,normal)
+ (sc . ,normal)
+ (titlefont . ,normal)
+ (asis . ,normal)
+ (b . ,bold)
+ (i . ,normal)
+ (r . ,normal)
+ (sansserif . ,normal)
+ (slanted . ,normal)
+ (t . ,normal)))
+
+
+(define* (render-stexi win stexi #:key (y-start 0) (markup-table
default-markup-table))
+ "Render STEXI to WIN"
+ (let loop ((y y-start)
+ (lines (stexi->curses stexi (getmaxx win) markup-table)))
+ (when (not (null? lines))
+ (addchstr win
+ (car lines)
+ #:y y #:x 0)
+ (loop (1+ y) (cdr lines)))))
+
+(define (stexi->curses stxi line-length table)
+ "Return a list of `complex strings' justified to LINE-LENGTH comprising the
text
+described by the stexi STXI"
+ (define (parse-fragment frag out markup)
+ (match frag
+ (() out)
+ (('para . rest)
+ (let ((par (parse-fragment rest '() normal)))
+ (append out
+ (justify (append par (list (normal #\newline)))
line-length))))
+ ((first . second)
+ (parse-fragment
+ second
+ (match
+ first
+ ((? string? s)
+ (append out (markup s)))
+
+ (((? symbol? x) . rest)
+ (append out
+ (parse-fragment
+ rest '()
+ (assq-ref table x))))) markup))))
+
+ (map-in-order
+ (lambda (line)
+ (if (null? line)
+ line
+ (pad-complex-string line line-length)))
+ (match stxi
+ (('*fragment* . rest)
+ (let loop ((in rest)
+ (acc '()))
+ (if (null? in)
+ acc
+ (loop (cdr in)
+ (parse-fragment (car in) acc normal))))))))
+
+(define (offset-to-end-of-word ccs)
+ "Return the number of xchars until the end of the current word."
+
+ (define (offset-to-end-of-word' cs dist)
+ (cond
+ ((zero? (length cs))
+ dist)
+ ((char-set-contains? char-set:blank (car (xchar-chars (car cs))))
+ dist)
+ (else
+ (offset-to-end-of-word' (cdr cs) (1+ dist)))))
+
+ (offset-to-end-of-word' ccs 0))
+
+(define (remove-leading-whitespace cs)
+ (if (char-set-contains? char-set:blank (car (xchar-chars (car cs))))
+ (cdr cs)
+ cs))
+
+(define (line-split cs line-length)
+ "Return a pair whose car is the first LINE-LENGTH elements of cs and whose
+cdr is the rest"
+ (let loop ((in cs)
+ (count 0)
+ (line0 '())
+ (rest '()))
+ (if (null? in)
+ (let* ((trimmed-line (remove-leading-whitespace line0))
+ (len (length trimmed-line)))
+ (cons (reverse trimmed-line)
+ (reverse rest)))
+
+ (if (< (+ (offset-to-end-of-word in) count) line-length)
+ (loop (cdr in) (1+ count) (cons (car in) line0) rest)
+ (loop (cdr in) (1+ count) line0 (cons (car in) rest))))))
+
+(define (paragraph-format cs line-length)
+ (let loop ((pr (line-split cs line-length))
+ (acc '()))
+ (if (null? (cdr pr))
+ (cons (car pr) acc)
+ (loop (line-split (cdr pr) line-length) (cons (car pr) acc)))))
+
+(define (justify text line-length)
+ (reverse (paragraph-format text line-length )))
+
+
+(define (pad-complex-string str len)
+ "Return a complex string based on STR but with interword padding to make the
+string of length LEN"
+
+ (define (count-words str)
+ (let loop ((in str)
+ (x 0)
+ (n 0)
+ (prev-white #t))
+ (if (null? in)
+ n
+ (let ((white (char-set-contains? char-set:blank
+ (car (xchar-chars (car in))))))
+ (loop (cdr in) (1+ x) (if (and prev-white (not white))
+ (1+ n)
+ n) white)))))
+
+ (let* ((underflow (- len (length str)))
+ (word-count (count-words str))
+ (inter-word-space-count (1- word-count)))
+
+ (if (zero? inter-word-space-count)
+ str
+ (begin
+ (when (negative? underflow)
+ (error
+ (format
+ #f
+ "You asked to pad to ~a but the string is already ~a
characters long."
+ len (length str))))
+
+ (if (eqv? (car (xchar-chars (last str))) #\newline)
+ str ; Don't justify the last line of a paragraph
+ (let loop ((in str)
+ (out '())
+ (words 0)
+ (spaces 0)
+ (prev-white #t))
+ (if (null? in)
+ (reverse out)
+ (let* ((white (char-set-contains? char-set:blank
+ (car (xchar-chars (car
in)))))
+ (end-of-word (and white (not prev-white)))
+ (words-processed (if end-of-word (1+ words) words))
+ (spaces-inserted (if end-of-word
+ (truncate (- (*
+ (/ underflow
inter-word-space-count)
+ words-processed)
+ spaces))
+ 0)))
+ (loop (cdr in)
+ ;; FIXME: Use a more intelligent algorithm.
+ ;; (prefer spaces at sentence endings for example)
+ (append
+ (make-list spaces-inserted (normal #\space))
+ (cons (car in) out))
+ words-processed
+ (+ spaces spaces-inserted)
+ white)))))))))
- 106/197: installer: Properly handle swap partitions when generating the configuration., (continued)
- 106/197: installer: Properly handle swap partitions when generating the configuration., Danny Milosavljevic, 2017/07/03
- 114/197: installer: Check that swap spaces have not been assigned mount points, Danny Milosavljevic, 2017/07/03
- 112/197: gurses: form: Use match instead of car, cdr etc., Danny Milosavljevic, 2017/07/03
- 125/197: installer: Do not assume the root file system is of type "ext4"., Danny Milosavljevic, 2017/07/03
- 130/197: installer: Delete unused procedure "justify"., Danny Milosavljevic, 2017/07/03
- 134/197: installer: Tolerate an undefined system role in config generation., Danny Milosavljevic, 2017/07/03
- 137/197: installer: Prepare for new wireless network features., Danny Milosavljevic, 2017/07/03
- 140/197: installer: Fix the key map option., Danny Milosavljevic, 2017/07/03
- 132/197: installer: Add new procedure to check file system specifications., Danny Milosavljevic, 2017/07/03
- 145/197: gurses: Avoid yet another use of car and cdr., Danny Milosavljevic, 2017/07/03
- 129/197: installer: Emphasise that writing filesystems destroys existing data.,
Danny Milosavljevic <=
- 150/197: gurses: Reimplement pad-complex-string., Danny Milosavljevic, 2017/07/03
- 159/197: installer: Fix i18n in dialogs., Danny Milosavljevic, 2017/07/03
- 154/197: installer: Main page: Redisplay translatable strings upon refresh., Danny Milosavljevic, 2017/07/03
- 157/197: installer: Replace 'file-browser' with 'key-map'., Danny Milosavljevic, 2017/07/03
- 161/197: installer: Improve i18n in ping page., Danny Milosavljevic, 2017/07/03
- 162/197: gurses: Avoid one use of car/cdr., Danny Milosavljevic, 2017/07/03
- 166/197: installer: Provide verbose description of locale., Danny Milosavljevic, 2017/07/03
- 167/197: installer: Fix bug when changing languages., Danny Milosavljevic, 2017/07/03
- 156/197: installer: New page to select language., Danny Milosavljevic, 2017/07/03
- 168/197: installer: Fix the startup locale., Danny Milosavljevic, 2017/07/03