Coverage report: /home/ellis/comp/core/lib/cli/linedit.lisp

Kind	Covered	All	%
expression	12	2628	0.5
branch	0	238	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; linedit.lisp --- Sharplispers Line Editor

2

3

;; See https://github.com/sharplispers/linedit

4

5

;;; Code:

6

(in-package :linedit)

7

8

;;; Utils

9

(declaim (type simple-string *word-delimiters*))

10

(defparameter *word-delimiters* "()[]{}',` \"")

11

12

(defmacro ensure (symbol expr)

13

`(or ,symbol (setf ,symbol ,expr)))

14

15

(defun word-delimiter-p (char)

16

(declare (simple-string *word-delimiters*)

17

(character char))

18

(find char *word-delimiters*))

19

20

(defun whitespacep (char)

21

(member char '(#\space #\newline #\tab #\return #\page)))

22

23

(defun at-delimiter-p (string index)

24

(and (< index (length string))

25

(word-delimiter-p (char string index))))

26

27

;;;; QUOTES

28

29

;; FIXME: should checking for #\", "\"", et cetera.

30

(defun quoted-p (string index)

31

(let ((quoted-p nil))

32

(dotimes (n (min index (length string)) quoted-p)

33

(when (eql (schar string n) #\")

34

(setf quoted-p (not quoted-p))))))

35

36

(defun find-open-quote (string index)

37

(when (quoted-p string index)

38

(loop for n from (1- index) downto 0

39

when (eql (schar string n) #\") return n)))

40

41

(defun find-close-quote (string index)

42

(when (quoted-p string index)

43

(loop for n from (1+ index) below (length string)

44

when (eql (schar string n) #\") return n)))

45

46

(defun yes-or-no (control &rest args)

47

"Like Y-OR-N-P, but using linedit functionality."

48

;; Don't save the query response.

49

(let ((*history* nil)

50

(*killring* nil))

51

(loop

52

(let ((result (linedit :prompt (format nil "~? (y or n) " control args))))

53

(cond

54

((zerop (length result)))

55

((char-equal (elt result 0) #\y)

56

(return-from yes-or-no t))

57

((char-equal (elt result 0) #\n)

58

(return-from yes-or-no nil)))

59

(format *terminal-io* "Please type \"y\" for yes or \"n\" for no.~%")

60

(finish-output *terminal-io*)))))

61

62

(defun eof-handler (lisp-name quit-fn)

63

(handler-case

64

(cond ((yes-or-no "Really quit ~A?" lisp-name)

65

(fresh-line)

66

(funcall quit-fn))

67

(t

68

(return-from eof-handler "#.''end-of-file")))

69

(end-of-file ()

70

(fresh-line)

71

(funcall quit-fn))))

72

73

;;;; PARENS

74

75

;; FIXME: This is not the Right Way to do paren matching.

76

;; * use stack, not counting

77

;; * don't count #$ #$ &co

78

(defun after-close-p (string index)

79

(and (array-in-bounds-p string (1- index))

80

(find (schar string (1- index)) ")]}")))

81

82

(defun at-open-p (string index)

83

(and (array-in-bounds-p string index)

84

(find (schar string index) "([{")))

85

86

(defun paren-count-delta (char)

87

(case char

88

((#\( #\[ #\{) -1)

89

((#\) #\] #\}) 1)

90

(t 0)))

91

92

(defun find-open-paren (string index)

93

(loop with count = 1

94

for n from (1- index) downto 0

95

do (incf count (paren-count-delta (schar string n)))

96

when (zerop count) return n))

97

98

(defun find-close-paren (string index)

99

(loop with count = -1

100

for n from (1+ index) below (length string)

101

do (incf count (paren-count-delta (schar string n)))

102

when (zerop count) return n))

103

104

(defun dwim-match-parens (string index)

105

(cond ((after-close-p string index)

106

(values (find-open-paren string (1- index)) (1- index)))

107

((at-open-p string index)

108

(values index (find-close-paren string index)))

109

(t

110

(values nil nil))))

111

112

(defun dwim-mark-parens (string index &key pre-mark post-mark)

113

(multiple-value-bind (open close) (dwim-match-parens string index)

114

(values

115

(if (and open close)

116

(concatenate 'simple-string

117

(subseq string 0 open)

118

pre-mark

119

(string (schar string open))

120

post-mark

121

(subseq string (1+ open) close)

122

pre-mark

123

(string (schar string close))

124

post-mark

125

(if (> (length string) (1+ close))

126

(subseq string (1+ close))

127

""))

128

string)

129

open)))

130

131

(defparameter *default-columns* 80)

132

(defparameter *default-lines* 24)

133

(defparameter *highlight-color* :magenta

134

"Color to use for highlighting parentheses. NIL is the current foreground

135

color bolded, other options are terminal colors :BLACK, :RED, :GREEN, :YELLOW,

136

:BLUE, :MAGENTA, :CYAN, and :WHITE.")

137

138

(defclass backend ()

139

((ready-p :accessor backend-ready-p :initform nil)

140

(translations :reader backend-translations)

141

(start :initform 0 :accessor get-start)))

142

143

(defmacro with-backend (backend &body forms)

144

(with-gensyms (an-error)

145

`(let ((,an-error nil))

146

(unwind-protect

147

(handler-case (progn

148

(backend-init ,backend)

149

,@forms)

150

(error (e)

151

(setf ,an-error e)))

152

(backend-close ,backend)

153

(std:awhen ,an-error

154

(error std:it))))))

155

156

(defmacro without-backend (backend &body forms)

157

`(unwind-protect

158

(progn

159

(backend-close ,backend)

160

,@forms)

161

(backend-init ,backend)))

162

163

(defgeneric display (backend &key prompt line point &allow-other-keys))

164

165

;;; Terminal Glue

166

(defvar +linedit-ok+ 0)

167

(defvar +linedit-not-atty+ 1)

168

(defvar +linedit-memory-error+ 2)

169

(defvar +linedit-tcgetattr-error+ 3)

170

(defvar +linedit-tcsetattr-error+ 4)

171

(defvar +linedit-attr-error+ 5)

172

(defvar +linedit-no-attr-error+ 6)

173

174

(let (attr)

175

(defun c-terminal-init ()

176

(if (zerop (isatty 0))

177

(return-from c-terminal-init +linedit-not-atty+))

178

;; Save current terminal state in attr

179

(when attr

180

(warn "bad linedit attr: ~A" attr)

181

(return-from c-terminal-init +linedit-attr-error+))

182

(setf attr (std::foreign-alloc 'sb-posix::alien-termios))

183

(when (minusp (std::tcgetattr* 0 attr))

184

(return-from c-terminal-init +linedit-tcgetattr-error+))

185

;; Enter keyboard input mode

186

(sb-alien:with-alien ((tmp sb-posix::alien-termios))

187

(when (minusp (tcgetattr* 0 (sb-alien:addr tmp)))

188

(return-from c-terminal-init +linedit-tcgetattr-error+))

189

(cfmakeraw (sb-alien:addr tmp))

190

(with-alien-slots (sb-posix::oflag) tmp

191

(setf sb-posix::oflag (logior sb-posix::oflag sb-posix::opost)))

192

(if (minusp (tcsetattr* 0 sb-posix::tcsaflush (sb-alien:addr tmp)))

193

+linedit-tcsetattr-error+))

194

+linedit-ok+)

195

(defun c-terminal-close ()

196

;; Restore saved terminal state from attr

197

(when (null attr)

198

(warn "missing linedit attr on close")

199

(return-from c-terminal-close +linedit-no-attr-error+))

200

(when (zerop (isatty 0))

201

(return-from c-terminal-close +linedit-not-atty+))

202

(when (minusp (tcsetattr* 0 sb-posix::tcsanow attr))

203

(return-from c-terminal-close +linedit-tcsetattr-error+))

204

(std:foreign-free attr)

205

(setf attr nil)

206

+linedit-ok+))

207

208

(defun c-terminal-winsize (def side side-env)

209

(if (boundp 'std::+tiocgwinsz+)

210

(sb-alien:with-alien ((size winsize))

211

(and (zerop (ioctl 0 std::+tiocgwinsz+ (sb-alien:cast size (* t))))

212

(sb-alien:slot size side)))

213

(aif (getenv side-env)

214

(parse-integer it)

215

def)))

216

217

(defun c-terminal-lines (def)

218

(c-terminal-winsize def 'std/os::row "LINES"))

219

220

(defun c-terminal-columns (def)

221

(c-terminal-winsize def 'std/os::col "COLUMNS"))

222

223

;;; Terminal Translations

224

(defvar *terminal-translations* (make-hash-table :test #'equalp))

225

226

(defmacro deftrans (name &rest chords)

227

`(dolist (chord ',chords)

228

(let ((old (gethash chord *terminal-translations*)))

229

(when (and old (not (equal old ,name)))

230

(warn "Overriding old translation ~S for ~S with ~S." old chord ,name)))

231

(setf (gethash chord *terminal-translations*) ,name)))

232

233

(deftrans "C-Space" 0)

234

(deftrans "C-A" 1)

235

(deftrans "C-B" 2)

236

(deftrans "C-C" 3)

237

(deftrans "C-D" 4)

238

(deftrans "C-E" 5)

239

(deftrans "C-F" 6)

240

(deftrans "C-G" 7)

241

(deftrans "C-Backspace" 8)

242

(deftrans "Tab" 9)

243

(deftrans "C-K" 11)

244

(deftrans "C-L" 12)

245

(deftrans "Return" 10 13) ;; Newline and return

246

(deftrans "C-N" 14)

247

(deftrans "C-O" 15)

248

(deftrans "C-P" 16)

249

(deftrans "C-Q" 17)

250

(deftrans "C-R" 18)

251

(deftrans "C-S" 19)

252

(deftrans "C-T" 20)

253

(deftrans "C-U" 21)

254

(deftrans "C-V" 22)

255

(deftrans "C-W" 23)

256

(deftrans "C-X" 24)

257

(deftrans "C-Y" 25)

258

(deftrans "C-Z" 26)

259

(deftrans "C--" 31)

260

(deftrans "Backspace" 127)

261

262

(deftrans "M-A" (#\Esc #\A) 225)

263

(deftrans "M-B" (#\Esc #\B) 226)

264

(deftrans "M-C" (#\Esc #\C) 227)

265

(deftrans "M-D" (#\Esc #\D) 228)

266

(deftrans "M-E" (#\Esc #\E) 229)

267

(deftrans "M-F" (#\Esc #\F) 230)

268

(deftrans "M-G" (#\Esc #\G) 231)

269

(deftrans "M-H" (#\Esc #\H) 232)

270

(deftrans "M-I" (#\Esc #\I) 233)

271

(deftrans "M-J" (#\Esc #\J) 234)

272

(deftrans "M-K" (#\Esc #\K) 235)

273

(deftrans "M-L" (#\Esc #\L) 236)

274

(deftrans "M-M" (#\Esc #\M) 237)

275

(deftrans "M-N" (#\Esc #\N) 238)

276

(deftrans "M-O" (#\Esc #\O) 239)

277

(deftrans "M-P" (#\Esc #\P) 240)

278

(deftrans "M-Q" (#\Esc #\Q) 241)

279

(deftrans "M-R" (#\Esc #\R) 242)

280

(deftrans "M-S" (#\Esc #\S) 243)

281

(deftrans "M-T" (#\Esc #\T) 244)

282

(deftrans "M-U" (#\Esc #\U) 245)

283

(deftrans "M-V" (#\Esc #\V) 246)

284

(deftrans "M-W" (#\Esc #\W) 247)

285

(deftrans "M-X" (#\Esc #\X) 248)

286

(deftrans "M-Y" (#\Esc #\Y) 249)

287

(deftrans "M-Z" (#\Esc #\Z) 250)

288

(deftrans "M-0" (#\Esc #\0) 176)

289

(deftrans "M-1" (#\Esc #\1) 177)

290

(deftrans "M-2" (#\Esc #\2) 178)

291

(deftrans "M-3" (#\Esc #\3) 179)

292

(deftrans "M-4" (#\Esc #\4) 180)

293

(deftrans "M-5" (#\Esc #\5) 181)

294

(deftrans "M-6" (#\Esc #\6) 182)

295

(deftrans "M-7" (#\Esc #\7) 183)

296

(deftrans "M-8" (#\Esc #\8) 184)

297

(deftrans "M-9" (#\Esc #\9) 185)

298

(deftrans "M-Backspace" (#\Esc #\Rubout))

299

300

(deftrans "C-M-f" (#\Esc #\^F) 134)

301

(deftrans "C-M-b" (#\Esc #\^B) 130)

302

(deftrans "C-M-k" (#\Esc #\^K) 139)

303

304

(deftrans "Up-arrow" (#\Esc #\[ #\A))

305

(deftrans "Down-arrow" (#\Esc #\[ #\B))

306

(deftrans "Right-arrow" (#\Esc #\[ #\C))

307

(deftrans "Left-arrow" (#\Esc #\[ #\D))

308

(deftrans "Insert" (#\Esc #\[ #\2 #\~))

309

(deftrans "Delete" (#\Esc #\[ #\3 #\~))

310

(deftrans "C-Delete" (#\Esc #\[ #\3 #\^))

311

(deftrans "Page-up" (#\Esc #\[ #\5 #\~))

312

(deftrans "Page-down" (#\Esc #\[ #\6 #\~))

313

(deftrans "Home" (#\Esc #\[ #\7 #\~) (#\Esc #\[ #\1 #\~) (#\Esc #\[ #\H))

314

(deftrans "End" (#\Esc #\[ #\8 #\~) (#\Esc #\[ #\4 #\~) (#\Esc #\[ #\F))

315

316

(defclass terminal (backend)

317

((translations :initform *terminal-translations*)

318

(dirty-p :initform t :accessor dirty-p)))

319

320

(defmethod backend-columns ((backend terminal))

321

(let ((cols (c-terminal-columns *default-columns*)))

322

(if (> cols 0)

323

cols

324

*default-columns*)))

325

326

(defmethod backend-lines ((backend terminal))

327

(c-terminal-lines *default-lines*))

328

329

(defmacro invariant (condition)

330

(with-unique-names (value)

331

`(let ((,value ,condition))

332

(unless ,value

333

(let ((*print-pretty* nil))

334

(error "Invariant ~S violated."

335

',condition))))))

336

337

(defmethod backend-init ((backend terminal))

338

(invariant (not (backend-ready-p backend)))

339

(invariant (zerop (c-terminal-init)))

340

(setf (backend-ready-p backend) t))

341

342

(defmethod backend-close ((backend terminal))

343

(invariant (backend-ready-p backend))

344

(invariant (zerop (c-terminal-close)))

345

(setf (backend-ready-p backend) nil))

346

347

;;; FIXME: Use read-char-no-hang to detect pastes, and set an

348

;;; apropriate flag, or something.

349

(defmethod read-chord ((backend terminal))

350

(assert (backend-ready-p backend))

351

(flet ((read-open-chord ()

352

(do ((chars nil)

353

(c #1=(read-char) #1#))

354

((member c '(#\- #\~ #\$)) (nconc (nreverse chars) (list c)))

355

(push c chars))))

356

(let ((chord

357

(acase (read-char)

358

(#\Esc

359

(cons it (acase (read-char)

360

(#\[ (cons

361

it

362

(let ((char (read-char)))

363

(if (digit-char-p char)

364

(cons char

365

(read-open-chord))

366

(list char)))))

367

(t (list it)))))

368

(t (if (graphic-char-p it)

369

it

370

(char-code it))))))

371

(gethash chord

372

(backend-translations backend)

373

(if (characterp chord)

374

chord

375

(list 'untranslated chord))))))

376

377

;;; ASCII 7 should ring the terminal bell. This is hopefully marginally more

378

;;; robust than #\Bel -- some implementations might eg. call it #\Bell, which

379

;;; is unicode character in eg. SBCL.

380

(defconstant +terminal-bell+ (code-char 7))

381

382

(defmethod beep ((b terminal))

383

(declare (ignore b))

384

(and (write-char +terminal-bell+ *error-output*)

385

(force-output *error-output*)))

386

387

(defmethod page ((backend terminal))

388

(write-string "--more--")

389

(force-output)

390

(let ((q (read-chord backend)))

391

(write-char #\Return)

392

(not (equal #\q q))))

393

394

;;; FIXME: Explicit line-wrap needed

395

(defmethod print-in-columns ((backend terminal) list &key width)

396

(let ((max-col (truncate (backend-columns backend) width))

397

(col 0)

398

(line 0)

399

(pad nil))

400

(newline backend)

401

(dolist (item list)

402

(incf col)

403

;; Padding

404

(when pad

405

(write-string pad)

406

(setf pad nil))

407

;; Item

408

(write-string item)

409

;; Maybe newline

410

(cond ((= col max-col)

411

(newline backend)

412

(setf col 0)

413

(when (= (1+ (incf line)) (backend-lines backend))

414

(setf line 0)

415

(unless (page backend)

416

(return-from print-in-columns nil))))

417

(t

418

(setf pad (make-string (- width (length item))

419

:initial-element #\space)))))

420

;; Optional newline

421

(when pad

422

(newline backend))))

423

424

(defmethod print-in-lines ((backend terminal) string)

425

(newline backend)

426

(do ((i 0 (1+ i))

427

(lines 0))

428

((= i (length string)))

429

(let ((c (schar string i)))

430

(when (= lines (backend-lines backend))

431

(setf lines 0)

432

(unless (page backend)

433

(return-from print-in-lines nil)))

434

(when (eql #\newline c)

435

(incf lines))

436

(write-char c)))

437

(newline backend))

438

439

(defmethod newline ((backend terminal))

440

(setf (dirty-p backend) t)

441

(write-char #\newline)

442

(write-char #\return)

443

(force-output))

444

445

;;; Smart Terminal

446

(defclass smart-terminal (terminal)

447

((old-point :initform 0 :accessor old-point)

448

(old-string :initform "" :accessor old-string)

449

(old-markup :initform 0 :accessor old-markup)))

450

451

(defun set-column-address (n current)

452

;; (if nil

453

;; (ti:tputs ti:column-address n)

454

(cond ((< n current)

455

(loop repeat (- current n)

456

do (tputs ti:cursor-left)))

457

((> n current)

458

(loop repeat (- n current)

459

do (tputs ti:cursor-right)))))

460

461

(defun smart-terminal-p ()

462

(and ti:cursor-up ti:cursor-down ti:clr-eos

463

(or ti:column-address (and ti:cursor-left ti:cursor-right))

464

(or ti:auto-right-margin ti:enter-am-mode)))

465

466

(defmethod backend-init ((backend smart-terminal))

467

(call-next-method)

468

(when ti:enter-am-mode

469

(ti:tputs ti:enter-am-mode)))

470

471

(defun find-row (n columns)

472

;; 1+ includes point in row calculations

473

(ceiling (1+ n) columns))

474

475

(defun find-col (n columns)

476

(rem n columns))

477

478

(defun move-in-column (&key col vertical clear-to-eos current-col)

479

(set-column-address col current-col)

480

(if (plusp vertical)

481

(loop repeat vertical do (ti:tputs ti:cursor-up))

482

(loop repeat (abs vertical) do (ti:tputs ti:cursor-down)))

483

(when clear-to-eos

484

(ti:tputs ti:clr-eos)))

485

486

(defun fix-wraparound (start end columns)

487

;; If final character ended in the last column the point

488

;; will wrap around to the first column on the same line:

489

;; hence move down if so.

490

(when (and (< start end) (zerop (find-col end columns)))

491

(ti:tputs ti:cursor-down)))

492

493

(defun place-point (&key up col)

494

(loop repeat up do (ti:tputs ti:cursor-up))

495

(tputs ti:column-address col))

496

497

(definline paren-style ()

498

(concatenate

499

'simple-string

500

(when *highlight-color*

501

(tparm

502

ti:set-a-foreground

503

(or (position *highlight-color* '(:black :red :green :yellow :blue :magenta :cyan :white))

504

(error "Unknown color: ~S" *highlight-color*))))

505

ti:enter-bold-mode))

506

507

(defmethod display ((backend smart-terminal) &key prompt line point markup)

508

(let* (;; SBCL and CMUCL traditionally point *terminal-io* to /dev/tty,

509

;; and we do output on it assuming it goes to STDOUT. Binding

510

;; *terminal-io* is unportable, so do it only when needed.

511

(*terminal-io* *standard-output*)

512

(columns (backend-columns backend))

513

(old-markup (old-markup backend))

514

(old-point (old-point backend))

515

(old-col (find-col old-point columns))

516

(old-row (find-row old-point columns))

517

(old (old-string backend))

518

(new (concatenate 'simple-string prompt line))

519

(end (length new))

520

(rows (find-row end columns)))

521

(when (dirty-p backend)

522

(setf old-markup 0

523

old-point 0

524

old-col 0

525

old-row 1))

526

(multiple-value-bind (marked-line markup)

527

(if markup

528

(dwim-mark-parens line point

529

:pre-mark (paren-style)

530

:post-mark ti:exit-attribute-mode)

531

(values line point))

532

(let* ((full (concatenate 'simple-string prompt marked-line))

533

(point (+ point (length prompt)))

534

(point-row (find-row point columns))

535

(point-col (find-col point columns))

536

(diff (mismatch new old))

537

              (start (apply 'min (remove-if 'null (list old-point point markup old-markup diff end))))

538

(start-row (find-row start columns))

539

(start-col (find-col start columns)))

540

;; (dbg "---~%")

541

;; (dbg-values (subseq new start))

542

;; (dbg-values rows point point-row point-col start start-row start-col

543

;; old-point old-row old-col end diff)

544

(move-in-column

545

:col start-col

546

:vertical (- old-row start-row)

547

:clear-to-eos t

548

:current-col old-col)

549

(write-string (subseq full start))

550

(fix-wraparound start end columns)

551

(move-in-column

552

:col point-col

553

:vertical (- rows point-row)

554

:current-col (find-col end columns))

555

;; Save state

556

(setf (old-string backend) new

557

(old-markup backend) markup

558

(old-point backend) point

559

(dirty-p backend) nil)))

560

(force-output *terminal-io*)))

561

562

;;; Dumb Terminal

563

(defclass dumb-terminal (terminal) ())

564

565

(defmethod display ((backend dumb-terminal) &key prompt line point &allow-other-keys)

566

(let* ((string (concatenate 'simple-string prompt line))

567

(length (length string))

568

(point (+ point (length prompt)))

569

(columns (backend-columns backend)))

570

(write-char #\return)

571

(cond ((< (1+ point) columns)

572

(write-string (subseq string 0 (min length columns)))

573

(when (< length columns)

574

(write-string (make-string (- columns length) :initial-element #\space)))

575

(write-char #\return)

576

(write-string (subseq string 0 point)))

577

(t

578

(write-string (subseq string (- (1+ point) columns) point))

579

(write-char #\return)

580

(write-string (subseq string (- (1+ point) columns) point)))))

581

(force-output))

582

583

;;; Mixin that implements undo

584

(with-compilation-unit

585

(:policy '(optimize (debug 3) (safety 3)))

586

(defclass rewindable ()

587

((rewind-store :reader %rewind-store

588

:initform (make-array 12 :fill-pointer 0 :adjustable t))

589

;; Index is the number of rewinds we've done.

590

(rewind-index :accessor %rewind-index

591

:initform 0)))

592

593

(defun %rewind-count (rewindable)

594

(fill-pointer (%rewind-store rewindable)))

595

596

(defun last-state (rewindable)

597

(let ((size (%rewind-count rewindable)))

598

(if (zerop size)

599

(values nil nil)

600

(values (aref (%rewind-store rewindable) (1- size)) t))))

601

602

(defun save-rewindable-state (rewindable object)

603

(let ((index (%rewind-index rewindable))

604

(store (%rewind-store rewindable)))

605

(unless (zerop index)

606

;; Reverse the tail of pool, since we've

607

;; gotten to the middle by rewinding.

608

(setf (subseq store index) (nreverse (subseq store index))))

609

(vector-push-extend object store)))

610

611

(defmethod rewind-state ((rewindable rewindable))

612

(assert (not (zerop (%rewind-count rewindable))))

613

(setf (%rewind-index rewindable)

614

(mod (1+ (%rewind-index rewindable)) (%rewind-count rewindable)))

615

(aref (%rewind-store rewindable)

616

(- (%rewind-count rewindable) (%rewind-index rewindable) 1))))

617

618

(defclass line ()

619

((string :accessor get-string :initform "" :initarg :string)

620

(point :accessor get-point :initform 0 :initarg :point)))

621

622

(defmethod (setf get-string) :around (string line)

623

(prog1 (call-next-method)

624

(when (>= (get-point line) (length string))

625

(setf (get-point line) (length string)))))

626

627

(defmethod (setf get-point) :around (point line)

628

(when (<= 0 point (length (get-string line)))

629

(call-next-method)))

630

631

;;; BUFFER offers a simple browsable from of storage. It is used to

632

;;; implement both the kill-ring and history.

633

(defclass buffer ()

634

((prev :initarg :prev :accessor %buffer-prev :initform nil)

635

(next :initarg :next :accessor %buffer-next :initform nil)

636

(list :initarg :list :accessor %buffer-list :initform nil)

637

;; For file-backed buffers.

638

(pathname :initarg :pathname :initform nil :accessor %buffer-pathname)))

639

640

(defun copy-buffer (buffer)

641

(make-instance 'buffer

642

:prev (%buffer-prev buffer)

643

:next (%buffer-next buffer)

644

:list (%buffer-list buffer)

645

:pathname (%buffer-pathname buffer)))

646

647

(defun ensure-buffer (datum)

648

"DATUM may be a buffer, a list, or a pathname designator."

649

(etypecase datum

650

(buffer datum)

651

((or pathname string null)

652

(let ((buffer (make-instance 'buffer :pathname datum)))

653

(when datum

654

(with-open-file (f datum

655

:direction :input

656

:if-does-not-exist nil

657

:external-format :utf-8)

658

(when f

659

(loop for line = (read-line f nil)

660

while line

661

do (push line (%buffer-list buffer)))

662

(setf (%buffer-prev buffer) (%buffer-list buffer)))))

663

buffer))

664

(list (let ((buffer (make-instance 'buffer :list datum)))

665

(setf (%buffer-prev buffer) (%buffer-list buffer))

666

buffer))))

667

668

(defun buffer-push (string buffer)

669

(unless (equal string (car (%buffer-list buffer)))

670

(push string (%buffer-list buffer))

671

(let ((pathname (%buffer-pathname buffer)))

672

(when pathname

673

(with-open-file (f pathname

674

:direction :output

675

:if-does-not-exist :create

676

:if-exists :append

677

:external-format :utf-8)

678

(write-line string f))))

679

(setf (%buffer-next buffer) nil

680

(%buffer-prev buffer) (%buffer-list buffer))))

681

682

(defun buffer-find-previous-if (test buffer)

683

(std:awhen (position-if test (%buffer-prev buffer))

684

(loop repeat (1+ std:it)

685

do (push (pop (%buffer-prev buffer))

686

(%buffer-next buffer)))

687

(car (%buffer-next buffer))))

688

689

(defun buffer-previous (string buffer)

690

(when (%buffer-prev buffer)

691

(push string (%buffer-next buffer))

692

(pop (%buffer-prev buffer))))

693

694

(defun buffer-peek (buffer)

695

(std:aif (%buffer-prev buffer)

696

(car std:it)))

697

698

(defun buffer-find-next-if (test buffer)

699

(std:awhen (position-if test (%buffer-next buffer))

700

(loop repeat (1+ std:it)

701

do (push (pop (%buffer-next buffer)) (%buffer-prev buffer)))

702

(car (%buffer-prev buffer))))

703

704

(defun buffer-next (string buffer)

705

(when (%buffer-next buffer)

706

(push string (%buffer-prev buffer))

707

(pop (%buffer-next buffer))))

708

709

(defun buffer-cycle (buffer)

710

(flet ((wrap-buffer ()

711

(unless (%buffer-prev buffer)

712

(setf (%buffer-prev buffer) (reverse (%buffer-next buffer))

713

(%buffer-next buffer) nil))))

714

(wrap-buffer)

715

(push (pop (%buffer-prev buffer)) (%buffer-next buffer))

716

(wrap-buffer)

717

t))

718

719

;;; Command Keys

720

(defvar *commands* (make-hash-table :test #'equalp))

721

722

(defmacro defcommand (command &optional action)

723

(when action

724

`(setf (gethash ,command *commands*) ,action)))

725

726

(defmacro defcommand-prefix (cmd &rest cmds)

727

"Define a prefix command on CMD which interprets the next sequence read with

728

READ-CHORD according to CMDS."

729

(let ((tbl (make-hash-table :test 'equalp :size (length cmds))))

730

(dolist (c cmds tbl)

731

(destructuring-bind (key act) c

732

(when act (setf (gethash key tbl) act))))

733

`(setf (gethash ,cmd *commands*) ,tbl)))

734

735

(defcommand-prefix "C-X" ("C-X" move-to-bol))

736

(defcommand "C-A" 'move-to-bol)

737

(defcommand "C-B" 'move-char-left)

738

(defcommand "C-C" 'interrupt-lisp)

739

(defcommand "C-D" 'delete-char-forwards-or-eof)

740

(defcommand "C-E" 'move-to-eol)

741

(defcommand "C-F" 'move-char-right)

742

(defcommand "C-G")

743

(defcommand "C-J")

744

(defcommand "C-K" 'kill-to-eol)

745

(defcommand "C-L")

746

(defcommand "C-N" 'history-next)

747

(defcommand "C-O" 'close-all-sexp)

748

(defcommand "C-P" 'history-previous)

749

(defcommand "C-Q")

750

(defcommand "C-R" 'search-history-backwards)

751

(defcommand "C-S" 'search-history-forwards)

752

(defcommand "C-T")

753

(defcommand "C-U" 'kill-to-bol)

754

(defcommand "C-V")

755

(defcommand "C-W" 'cut-region)

756

;; (defcommand "C-X")

757

(defcommand "C-Y" 'yank)

758

(defcommand "C-Z" 'stop-lisp)

759

(defcommand "C--" 'undo)

760

761

(defcommand "M-A" 'apropos-word)

762

(defcommand "M-B" 'move-word-backwards)

763

(defcommand "M-C")

764

(defcommand "M-D" 'delete-word-forwards)

765

(defcommand "M-E")

766

(defcommand "M-F" 'move-word-forwards)

767

(defcommand "M-G")

768

(defcommand "M-H" 'help)

769

(defcommand "M-I" 'describe-word)

770

(defcommand "M-J" 'inspect-word)

771

(defcommand "M-K")

772

(defcommand "M-L" 'downcase-word)

773

(defcommand "M-M")

774

(defcommand "M-N")

775

(defcommand "M-O")

776

(defcommand "M-P")

777

(defcommand "M-Q")

778

(defcommand "M-R")

779

(defcommand "M-S")

780

(defcommand "M-T")

781

(defcommand "M-U" 'upcase-word)

782

(defcommand "M-V")

783

(defcommand "M-W" 'copy-region)

784

(defcommand "M-X")

785

(defcommand "M-Y" 'yank-cycle)

786

(defcommand "M-Z")

787

(defcommand "M-1")

788

(defcommand "M-2")

789

(defcommand "M-3")

790

(defcommand "M-4")

791

(defcommand "M-5")

792

(defcommand "M-6")

793

(defcommand "M-7")

794

(defcommand "M-8")

795

(defcommand "M-9")

796

(defcommand "M-0")

797

798

(defcommand "C-M-b" 'backward-sexp)

799

(defcommand "C-M-f" 'forward-sexp)

800

(defcommand "C-M-k" 'kill-sexp)

801

802

(defcommand "M-Backspace" 'delete-word-backwards)

803

804

(defcommand "C-Space" 'set-mark)

805

(defcommand "C-Backspace" 'delete-word-backwards)

806

807

(defcommand "Tab" 'complete)

808

(defcommand "Backspace" 'delete-char-backwards)

809

(defcommand "Return" 'finish-input)

810

811

(defcommand "Up-arrow" 'history-previous)

812

(defcommand "Down-arrow" 'history-next)

813

(defcommand "Right-arrow" 'move-char-right)

814

(defcommand "Left-arrow" 'move-char-left)

815

(defcommand "Insert" 'toggle-insert)

816

(defcommand "Delete" 'delete-char-forwards)

817

(defcommand "C-Delete")

818

(defcommand "Page-up")

819

(defcommand "Page-down")

820

(defcommand "Home" 'move-to-bol)

821

(defcommand "End" 'move-to-eol)

822

823

;;; Editor

824

(defvar *history* nil)

825

(defvar *killring* nil)

826

827

(defclass editor (line rewindable)

828

((commands :reader editor-commands

829

:initform *commands*

830

:initarg :commands)

831

(completer :accessor editor-completer

832

:initform 'lisp-complete

833

:initarg :complete)

834

(history :accessor editor-history)

835

(killring :accessor editor-killring)

836

(insert :accessor editor-insert-mode

837

:initform t

838

:initarg :insert-mode)

839

(mark :accessor editor-mark

840

:initform nil)

841

(yank :accessor editor-yank

842

:initform nil)

843

(last-yank :accessor editor-last-yank

844

:initform nil)

845

(prompt :accessor editor-prompt

846

:initform ""

847

:initarg :prompt)))

848

849

(defmethod initialize-instance :after ((editor editor) &rest initargs &key history killring completions)

850

(declare (ignorable initargs))

851

(let ((history (ensure-buffer (or history *history*))))

852

(unless *history*

853

(setf *history* history))

854

(setf (editor-history editor) history))

855

(let ((killring (ensure-buffer (or killring *killring*))))

856

(unless *killring*

857

(setf *killring* killring))

858

(setf (editor-killring editor) killring))

859

(when completions (setf (editor-completer editor) (make-list-completer completions)))

860

(save-state editor))

861

862

(defclass smart-editor (editor smart-terminal) ())

863

(defclass dumb-editor (editor dumb-terminal) ())

864

865

(defvar *announce* nil)

866

(defvar *linedit-spec* nil)

867

(defvar *version* "0.1.1-cc")

868

869

(defun make-editor (&rest args)

870

(ti:set-terminal)

871

(let* ((type (if (smart-terminal-p)

872

'smart-editor

873

'dumb-editor))

874

(spec (list *version* type)))

875

(when *announce*

876

(unless (equal *linedit-spec* spec)

877

(format t "~&Linedit version ~A, ~A mode, ESC-h for help.~%"

878

*version*

879

(if (eq 'smart-editor type)

880

"smart"

881

"dumb"))))

882

(setf *linedit-spec* spec)

883

(apply 'make-instance type args)))

884

885

;;; undo

886

(defun save-state (editor)

887

(let ((string (get-string editor))

888

(last (last-state editor)))

889

(unless (and last (equal string (get-string last)))

890

;; Save only if different than last saved state

891

(save-rewindable-state editor

892

(make-instance 'line

893

:string (copy-seq string)

894

:point (get-point editor))))))

895

896

(defmethod rewind-state ((editor editor))

897

(let ((line (call-next-method)))

898

(setf (get-string editor) (copy-seq (get-string line))

899

(get-point editor) (get-point line))))

900

901

(defvar *aux-prompt* nil)

902

903

(defun redraw-line (editor &key markup)

904

(display editor

905

:prompt (concatenate 'simple-string (editor-prompt editor) *aux-prompt*)

906

:line (get-string editor)

907

:point (get-point editor)

908

:markup markup))

909

910

(defvar *last-command* nil)

911

912

(defun next-chord (editor)

913

(redraw-line editor :markup t)

914

(forget-yank editor)

915

(let* ((chord (read-chord editor))

916

(command (gethash chord (editor-commands editor)

917

(if (characterp chord)

918

'add-char

919

'unknown-command))))

920

(if (hash-table-p command)

921

;; prefix command

922

(let* ((ch (read-chord editor))

923

(com

924

(gethash chord command

925

(if (characterp chord)

926

'add-char

927

'unknown-command))))

928

(setf *last-command* (cons chord com))

929

(funcall com ch editor))

930

;; command

931

(progn

932

(funcall command chord editor)

933

(setf *last-command* command))))

934

(save-state editor))

935

936

(defun get-finished-string (editor)

937

(buffer-push (get-string editor) (editor-history editor))

938

(newline editor)

939

(get-string editor))

940

941

(eval-always

942

(defmacro with-editor-point-and-string (((point string) editor) &body forms)

943

`(let ((,point (get-point ,editor))

944

(,string (get-string ,editor)))

945

,@forms)))

946

947

(defun editor-interrupt (editor)

948

(without-backend editor

949

(sb-posix:kill 0 sb-posix:sigint)))

950

951

(defun editor-stop (editor)

952

(without-backend editor (sb-posix:kill 0 sb-posix:sigtstp)))

953

954

(defun editor-word-start (editor)

955

"Returns the index of the first letter of current or previous word,

956

if the point is just after a word, or the point."

957

(with-editor-point-and-string ((point string) editor)

958

(if (or (not (at-delimiter-p string point))

959

(not (and (plusp point) (at-delimiter-p string (1- point)))))

960

(1+ (or (position-if 'word-delimiter-p string :end point :from-end t)

961

-1)) ; start of string

962

point)))

963

964

(defun editor-previous-word-start (editor)

965

"Returns the index of the first letter of current or previous word,

966

if the point was at the start of a word or between words."

967

(with-editor-point-and-string ((point string) editor)

968

(let ((tmp (cond ((at-delimiter-p string point)

969

(position-if-not 'word-delimiter-p string

970

:end point :from-end t))

971

((and (plusp point) (at-delimiter-p string (1- point)))

972

(position-if-not 'word-delimiter-p string

973

:end (1- point) :from-end t))

974

(t point))))

975

;; tmp is always in the word whose start we want (or NIL)

976

(1+ (or (position-if 'word-delimiter-p string

977

:end (or tmp 0) :from-end t)

978

-1)))))

979

980

(defun editor-word-end (editor)

981

"Returns the index just beyond the current word or the point if

982

point is not inside a word."

983

(with-editor-point-and-string ((point string) editor)

984

(if (at-delimiter-p string point)

985

point

986

(or (position-if 'word-delimiter-p string :start point)

987

(length string)))))

988

989

(defun editor-next-word-end (editor)

990

"Returns the index just beyond the last letter of current or next

991

word, if the point was between words."

992

(with-editor-point-and-string ((point string) editor)

993

(let ((tmp (if (at-delimiter-p string point)

994

(or (position-if-not 'word-delimiter-p string

995

:start point)

996

(length string))

997

point)))

998

;; tmp is always in the word whose end we want (or already at the end)

999

(or (position-if 'word-delimiter-p string :start tmp)

1000

(length string)))))

1001

1002

(defun editor-word (editor)

1003

"Returns the current word the point is in or right after, or an

1004

empty string."

1005

(let ((start (editor-word-start editor))

1006

(end (editor-word-end editor)))

1007

(subseq (get-string editor) start end)))

1008

1009

(defun editor-sexp-start (editor)

1010

(with-editor-point-and-string ((point string) editor)

1011

(setf point (loop for n from (min point (1- (length string))) downto 0

1012

when (not (whitespacep (schar string n)))

1013

return n))

1014

(case (and point (schar string point))

1015

((#\) #\] #\}) (or (find-open-paren string point) 0))

1016

((#\( #\[ #\{) (max (1- point) 0))

1017

(#\" (or (find-open-quote string point)

1018

(max (1- point) 0)))

1019

(t (editor-previous-word-start editor)))))

1020

1021

(defun editor-sexp-end (editor)

1022

(with-editor-point-and-string ((point string) editor)

1023

(setf point (loop for n from point below (length string)

1024

when (not (whitespacep (schar string n)))

1025

return n))

1026

(case (and point (schar string point))

1027

((#\( #\[ #\{) (or (find-close-paren string point)

1028

(length string)))

1029

((#\) #\] #\}) (min (1+ point) (length string)))

1030

(#\" (or (find-close-quote string (1+ point))

1031

(min (1+ point) (length string))))

1032

(t (editor-next-word-end editor)))))

1033

1034

(defun editor-complete (editor)

1035

(funcall (editor-completer editor) (editor-word editor) editor))

1036

1037

(defun remember-yank (editor)

1038

(setf (editor-yank editor) (get-point editor)))

1039

1040

(defun forget-yank (editor)

1041

(shiftf (editor-last-yank editor) (editor-yank editor) nil))

1042

1043

(defun try-yank (editor)

1044

(setf (editor-yank editor) (editor-last-yank editor))

1045

(editor-yank editor))

1046

1047

(defun editor-replace-word (editor word)

1048

(with-editor-point-and-string ((point string) editor)

1049

(declare (ignore point))

1050

(let ((start (editor-word-start editor))

1051

(end (editor-word-end editor)))

1052

(setf (get-string editor)

1053

(concatenate 'simple-string (subseq string 0 start) word (subseq string end))

1054

(get-point editor) (+ start (length word))))))

1055

1056

(defun in-quoted-string-p (editor)

1057

(quoted-p (get-string editor) (get-point editor)))

1058

1059

;;; Completion

1060

(defun pathname-directory-pathname (pathname)

1061

(make-pathname :name nil :type nil

1062

:defaults pathname))

1063

1064

(defun underlying-directory-p (pathname)

1065

(case (file-kind pathname)

1066

(:directory t)

1067

(:symbolic-link

1068

(file-kind (merge-pathnames (sb-posix:readlink pathname) pathname)))))

1069

1070

(defun logical-pathname-p (pathname)

1071

(typep (pathname pathname) 'logical-pathname))

1072

1073

(defun check-logical-pathname (string)

1074

(acond

1075

((find (trim string :char-bag ":") (logical-host-names) :test 'string-equal)

1076

(list (replace string it)))

1077

((ignore-errors

1078

(namestring

1079

(translate-logical-pathname

1080

(unless (find #\; string)

1081

(concatenate 'string string ";")))))

1082

(list it))

1083

(t nil)))

1084

1085

;; simplified LPN completion (just shows the expansion if available)

1086

(defun logical-pathname-complete (string)

1087

(when-let ((path (check-logical-pathname string)))

1088

(values path (length string))))

1089

1090

;;; We can't easily do zsh-style tab-completion of ~us into ~user, but

1091

;;; at least we can expand ~ and ~user. The other bug here at the

1092

;;; moment is that ~nonexistant will complete to the same as ~.

1093

(defun tilde-expand-string (string)

1094

"Returns the supplied string, with a prefix of ~ or ~user expanded

1095

to the appropriate home directory."

1096

(if (and (> (length string) 0)

1097

(eql (schar string 0) #\~))

1098

(flet ((chop (s)

1099

(subseq s 0 (1- (length s)))))

1100

(let* ((slash-index (loop for i below (length string)

1101

when (eql (schar string i) #\/)

1102

return i))

1103

(suffix (and slash-index (subseq string slash-index)))

1104

(uname (subseq string 1 slash-index))

1105

(homedir (or (cdr (assoc :home (std::user-info uname)))

1106

(chop (namestring

1107

(or (probe-file (user-homedir-pathname))

1108

(return-from tilde-expand-string

1109

string)))))))

1110

(concatenate 'string homedir (or suffix ""))))

1111

string))

1112

1113

(defun directory-complete (string)

1114

(declare (simple-string string))

1115

(let* ((common nil)

1116

(all nil)

1117

(max 0)

1118

(string (tilde-expand-string string))

1119

(dir (pathname-directory-pathname string))

1120

(namefun (if (relative-pathname-p string)

1121

#'namestring

1122

(lambda (x) (namestring (merge-pathnames x))))))

1123

(unless (and (underlying-directory-p dir)

1124

(not (wild-pathname-p dir)))

1125

(return-from directory-complete (values nil 0)))

1126

(with-directory-iterator (next dir)

1127

(loop for entry = (next)

1128

while entry

1129

do (let* ((full (funcall namefun entry))

1130

(diff (mismatch string full)))

1131

(log:trace! "~& completed: ~A, diff: ~A~%" full diff)

1132

(unless (and diff (< diff (length string)))

1133

(log:trace! "~& common ~A mismatch ~A~&" common

1134

(mismatch common full))

1135

(setf common (if common

1136

(subseq common 0 (mismatch common full))

1137

full)

1138

max (max max (length full))

1139

all (cons full all))))))

1140

(log:trace! "~&common: ~A~%" common)

1141

(if (or (null common)

1142

(<= (length common) (length string)))

1143

(values all max)

1144

(values (list common) (length common)))))

1145

1146

(defun make-list-completer (completions)

1147

(lambda (str ed)

1148

(declare (ignore ed))

1149

(if (zerop (length str))

1150

(values completions (reduce 'max (mapcar 'length completions)))

1151

         (when-let ((matches (flatten (mapcar (lambda (x) (when (uiop:string-prefix-p str x) x)) completions))))

1152

(values matches (reduce 'max (mapcar 'length matches)))))))

1153

1154

(defun lisp-complete (string editor)

1155

(declare (simple-string string))

1156

(when (plusp (length string))

1157

(if (in-quoted-string-p editor)

1158

(if (logical-pathname-p string)

1159

(logical-pathname-complete string)

1160

(directory-complete string))

1161

(let* ((length (length string))

1162

(first-colon (position #\: string))

1163

(last-colon (position #\: string :from-end t))

1164

(state (and first-colon

1165

(if (< first-colon last-colon)

1166

:internal

1167

:external)))

1168

(package (and first-colon

1169

(find-package (if (plusp first-colon)

1170

(string-upcase

1171

                                                 (subseq string 0 first-colon))

1172

:keyword))))

1173

(hash (make-hash-table :test #'equal))

1174

(common nil)

1175

(max-len 0))

1176

(labels ((stringify (symbol)

1177

(if (upper-case-p (schar string 0))

1178

(string symbol)

1179

(string-downcase (string symbol))))

1180

(push-name (name)

1181

(setf common (if common

1182

                                       (subseq name 0 (mismatch common name))

1183

name)

1184

max-len (max max-len (length name))

1185

(gethash name hash) name))

1186

(select-symbol (symbol match)

1187

(let ((name (stringify symbol))

1188

(end (length match)))

1189

(when (and (> (length name) end) ; Skip indetical

1190

(equal match (subseq name 0 end)))

1191

                          (push-name (concatenate 'simple-string string (subseq name end)))))))

1192

;; Skip empty strings

1193

(when (plusp length)

1194

(if package

1195

;; Symbols with explicit package prefixes.

1196

(let* ((start (1+ last-colon))

1197

(match (subseq string start)))

1198

(ecase state

1199

(:internal (std::do-internal-symbols (sym package)

1200

(select-symbol sym match)))

1201

(:external (do-external-symbols (sym package)

1202

(select-symbol sym match)))))

1203

;; Symbols without explicit package prefix + packges

1204

(dolist (package (list-all-packages))

1205

(if (eq *package* package)

1206

(do-symbols (sym)

1207

(select-symbol sym string))

1208

;; Package names

1209

(dolist (name (cons (package-name package)

1210

(package-nicknames package)))

1211

(select-symbol name string))))))

1212

;; Return list of matches to caller

1213

(if (> (length common) (length string))

1214

(values (list common) (length common))

1215

(let (list)

1216

(maphash (lambda (key val)

1217

(declare (ignore val))

1218

(push key list))

1219

hash)

1220

(values list max-len))))))))

1221

1222

;;; Main

1223

(defvar *editor* nil)

1224

1225

(defun linedit (&rest keyword-args &key prompt history killring completions &allow-other-keys)

1226

"Reads a single line of input with line-editing from standard input

1227

of the process and returns it as a string.

1228

1229

Results are unspecified if *STANDARD-INPUT* has been bound or altered.

1230

1231

PROMPT specifies the string to print to *STANDARD-OUTPUT* before

1232

starting the accept input.

1233

1234

HISTORY and KILLRING can be pathname designators, in which case

1235

they indicate the file to use for history and killring persistence,

1236

respectively.

1237

1238

Further keyword arguments to LINEDIT are an advanced and undocumented

1239

topic, but if you're willing to dive into sources you can eg. use

1240

multiple kill-rings not shared between different invocations of

1241

LINEDIT, or change the function responsible for providing input

1242

completion."

1243

(declare (ignore prompt history killring))

1244

(flet ((edit ()

1245

(catch 'linedit-done

1246

(loop

1247

(catch 'linedit-loop

1248

(next-chord *editor*))))

1249

(redraw-line *editor*)

1250

(get-finished-string *editor*)))

1251

(if (and *editor* (backend-ready-p *editor*))

1252

;; FIXME: This is a bit kludgy. It would be nicer to have a new

1253

;; editor object that shares the same backend, kill-ring, etc.

1254

(let* ((new (getf keyword-args :prompt))

1255

(old (editor-prompt *editor*))

1256

(completer (editor-completer *editor*))

1257

(history (copy-buffer (editor-history *editor*)))

1258

(string (get-string *editor*))

1259

(point (get-point *editor*)))

1260

(unwind-protect

1261

(progn

1262

(when new

1263

(setf (editor-prompt *editor*) new))

1264

(when completions

1265

(setf (editor-completer *editor*) (make-list-completer completions)))

1266

(edit))

1267

(when new

1268

(setf (editor-prompt *editor*) old))

1269

(when completions

1270

(setf (editor-completer *editor*) completer))

1271

(setf (get-string *editor*) string

1272

(get-point *editor*) point

1273

(editor-history *editor*) history)))

1274

(let ((*editor* (apply 'make-editor keyword-args)))

1275

(with-backend *editor*

1276

(edit))))))

1277

1278

(defvar *level* 0)

1279

1280

(defun formedit (&rest args &key (prompt1 "") (prompt2 "") history killring completions

1281

&allow-other-keys)

1282

"Reads a single form (s-expession) of input with line-editing from

1283

standard input of the process and returns it as a string.

1284

1285

Results are unspecified if *STANDARD-INPUT* has been bound or altered,

1286

or if *READTABLE* is not the standard readtable.

1287

1288

PROMPT1 specifies the string to print to *STANDARD-OUTPUT* before

1289

starting the accept input.

1290

1291

PROMPT2 specifies the string to print to *STANDARD-OUTPUT* when input

1292

spans multiple lines (ie. prefixing every but first line of input.)

1293

1294

HISTORY and KILLRING can be pathname designators, in which case

1295

they indicate the file to use for history and killring persistence,

1296

respectively.

1297

1298

Further keyword arguments to FORMEDIT are an advanced and undocumented

1299

topic, but if you're willing to dive into sources you can eg. use

1300

multiple kill-rings not shared between different invocations of

1301

FORMEDIT, or change the function responsible for providing input

1302

completion."

1303

(declare (ignore history killring completions))

1304

(let ((args (copy-list args)))

1305

(dolist (key '(:prompt1 :prompt2))

1306

(remf args key))

1307

(catch 'form-done

1308

(let ((eof-marker (gensym "EOF"))

1309

(table (copy-readtable)))

1310

;; FIXME: It would be nice to provide an interace of some sort that

1311

;; the user could use to alter the crucial reader macros in custom readtables.

1312

(set-macro-character #\: #'colon-reader nil table)

1313

(set-macro-character #\, (constantly (values)) nil table)

1314

(set-macro-character #\; #'semicolon-reader nil table)

1315

(set-dispatch-macro-character #\# #\. (constantly (values)) table)

1316

(do ((str (apply #'linedit :prompt prompt1 args)

1317

(concatenate 'simple-string str

1318

(string #\newline)

1319

(apply #'linedit :prompt prompt2 args))))

1320

((let ((form (handler-case (let ((*readtable* table)

1321

(*level* (1+ *level*))

1322

(*package* (make-package

1323

                                                          ;; If we manage to get into a nested read,

1324

                                                          ;; make sure we don't try to use the same package.

1325

                                                          (format nil "LINEDIT-SCRATCH#~A" *level*))))

1326

                                          (unwind-protect (read-from-string str)

1327

(delete-package *package*)))

1328

(end-of-file ()

1329

eof-marker))))

1330

(unless (eq eof-marker form)

1331

(throw 'form-done str)))))))))

1332

1333

(defun semicolon-reader (stream char)

1334

(declare (ignore char))

1335

(loop for char = (read-char stream)

1336

until (eql char #\newline))

1337

(values))

1338

1339

(defun colon-reader (stream char)

1340

(declare (ignore char))

1341

(read stream t nil t))

1342

1343

;;; Command Functions

1344

;; These functions are meant to be call throught the command table

1345

;; of an editor. These functions should not explicitly call refresh, etc:

1346

;; that is the responsibility of the editor -- but beeping is ok.

1347

1348

;; The arguments passed are: CHORD EDITOR

1349

1350

;;; BASIC EDITING

1351

(defun add-char (char editor)

1352

(with-editor-point-and-string ((point string) editor)

1353

(setf (get-string editor)

1354

(concatenate 'simple-string (subseq string 0 point)

1355

(string char)

1356

(if (editor-insert-mode editor)

1357

(subseq string point)

1358

(when (> (length string) (1+ point))

1359

(subseq string (1+ point))))))

1360

(incf (get-point editor))))

1361

1362

(defun delete-char-backwards (chord editor)

1363

(declare (ignore chord))

1364

(with-editor-point-and-string ((point string) editor)

1365

;; Can't delegate to editor because of the SUBSEQ index calc.

1366

(unless (zerop point)

1367

(setf (get-string editor) (concatenate 'simple-string (subseq string 0 (1- point))

1368

(subseq string point))

1369

(get-point editor) (1- point)))))

1370

1371

(defun delete-char-forwards (chord editor)

1372

(declare (ignore chord))

1373

(with-editor-point-and-string ((point string) editor)

1374

(setf (get-string editor) (concatenate 'simple-string (subseq string 0 point)

1375

                                            (subseq string (min (1+ point) (length string)))))))

1376

1377

(defun delete-char-forwards-or-eof (chord editor)

1378

(if (equal "" (get-string editor))

1379

(error 'end-of-file :stream *standard-input*)

1380

(delete-char-forwards chord editor)))

1381

1382

(defun delete-word-forwards (chord editor)

1383

(declare (ignore chord))

1384

(with-editor-point-and-string ((point string) editor)

1385

(declare (ignore point))

1386

(let ((i (get-point editor))

1387

(j (editor-next-word-end editor)))

1388

(setf (get-string editor)

1389

(concatenate 'simple-string (subseq string 0 i) (subseq string j))))))

1390

1391

(defun delete-word-backwards (chord editor)

1392

(declare (ignore chord))

1393

(with-editor-point-and-string ((point string) editor)

1394

(let ((i (editor-previous-word-start editor)))

1395

(setf (get-string editor) (concatenate 'simple-string (subseq string 0 i)

1396

(subseq string point))

1397

(get-point editor) i))))

1398

1399

(defun finish-input (chord editor)

1400

(declare (ignore chord editor))

1401

(throw 'linedit-done t))

1402

1403

;;; CASE CHANGES

1404

(flet ((frob-case (frob editor)

1405

(with-editor-point-and-string ((point string) editor)

1406

(let ((end (editor-next-word-end editor)))

1407

(setf (get-string editor) (concatenate 'simple-string

1408

                                                     (subseq string 0 point)

1409

(funcall frob

1410

                                                              (subseq string point end))

1411

                                                     (subseq string end))

1412

(get-point editor) end)))))

1413

1414

(defun upcase-word (chord editor)

1415

(declare (ignore chord))

1416

(funcall #'frob-case #'string-upcase editor))

1417

1418

(defun downcase-word (chord editor)

1419

(declare (ignore chord))

1420

(funcall #'frob-case #'string-downcase editor)))

1421

1422

;;; MOVEMENT

1423

(defun move-to-bol (chord editor)

1424

(declare (ignore chord))

1425

(setf (get-point editor) 0))

1426

1427

(defun move-to-eol (chord editor)

1428

(declare (ignore chord))

1429

(setf (get-point editor) (length (get-string editor))))

1430

1431

(defun move-char-right (chord editor)

1432

(declare (ignore chord))

1433

(incf (get-point editor)))

1434

1435

(defun move-char-left (chord editor)

1436

(declare (ignore chord))

1437

(decf (get-point editor)))

1438

1439

(defun move-word-backwards (chord editor)

1440

(declare (ignore chord))

1441

(setf (get-point editor) (editor-previous-word-start editor)))

1442

1443

(defun move-word-forwards (chord editor)

1444

(declare (ignore chord))

1445

(setf (get-point editor) (editor-next-word-end editor)))

1446

1447

;;; UNDO

1448

(defun undo (chord editor)

1449

(declare (ignore chord))

1450

(rewind-state editor)

1451

(throw 'linedit-loop t))

1452

1453

;;; HISTORY

1454

(defun history-previous (chord editor)

1455

(declare (ignore chord))

1456

(std:aif (buffer-previous (get-string editor) (editor-history editor))

1457

(setf (get-string editor) std:it)

1458

(beep editor)))

1459

1460

(defun history-next (chord editor)

1461

(declare (ignore chord))

1462

(std:aif (buffer-next (get-string editor) (editor-history editor))

1463

(setf (get-string editor) std:it)

1464

(beep editor)))

1465

1466

(defvar *history-search* nil)

1467

(defvar *history-needle* nil)

1468

1469

(defun history-search-needle (editor &key direction)

1470

(declare (ignore direction))

1471

(let ((text (if *history-search*

1472

(cond ((and *history-needle*

1473

(member *last-command* '(search-history-backwards

1474

                                                        search-history-forwards)))

1475

*history-needle*)

1476

(t

1477

(setf *history-needle* (get-string editor))))

1478

(let* ((*history-search* t)

1479

(*aux-prompt* nil))

1480

(linedit :prompt "Search History: ")))))

1481

(when *history-search*

1482

(setf *aux-prompt* (concatenate 'simple-string "[" text "] ")))

1483

text))

1484

1485

(defun history-search (editor direction)

1486

(let* ((text (history-search-needle editor))

1487

(history (editor-history editor))

1488

(test (lambda (old) (search text old)))

1489

(match (unless (equal "" text)

1490

(ecase direction

1491

(:backwards

1492

(buffer-find-previous-if test history))

1493

(:forwards

1494

(buffer-find-next-if test history))))))

1495

(unless match

1496

(beep editor)

1497

(setf match text))

1498

(setf (get-string editor) match

1499

(get-point editor) (length match))))

1500

1501

(defun search-history-backwards (chord editor)

1502

(declare (ignore chord))

1503

(history-search editor :backwards))

1504

1505

(defun search-history-forwards (chord editor)

1506

(declare (ignore chord))

1507

(history-search editor :forwards))

1508

1509

;;; KILLING & YANKING

1510

(defun %yank (editor)

1511

(std:aif (buffer-peek (editor-killring editor))

1512

(with-editor-point-and-string ((point string) editor)

1513

(setf (get-string editor)

1514

(concatenate 'simple-string (subseq string 0 (editor-yank editor))

1515

std:it

1516

(subseq string point))

1517

(get-point editor) (+ (editor-yank editor) (length std:it))))

1518

(beep editor)))

1519

1520

(defun yank (chord editor)

1521

(declare (ignore chord))

1522

(remember-yank editor)

1523

(%yank editor))

1524

1525

(defun yank-cycle (chord editor)

1526

(declare (ignore chord))

1527

(if (try-yank editor)

1528

(progn

1529

(buffer-cycle (editor-killring editor))

1530

(%yank editor))

1531

(beep editor)))

1532

1533

(defun kill-to-eol (chord editor)

1534

(declare (ignore chord))

1535

(with-editor-point-and-string ((point string) editor)

1536

(buffer-push (subseq string point) (editor-killring editor))

1537

(setf (get-string editor) (subseq string 0 point))))

1538

1539

(defun kill-to-bol (chord editor)

1540

;; Thanks to Andreas Fuchs

1541

(declare (ignore chord))

1542

(with-editor-point-and-string ((point string) editor)

1543

(buffer-push (subseq string 0 point) (editor-killring editor))

1544

(setf (get-string editor) (subseq string point)

1545

(get-point editor) 0)))

1546

1547

(defun copy-region (chord editor)

1548

(declare (ignore chord))

1549

(std:awhen (editor-mark editor)

1550

(with-editor-point-and-string ((point string) editor)

1551

(let ((start (min std:it point))

1552

(end (max std:it point)))

1553

(buffer-push (subseq string start end) (editor-killring editor))

1554

(setf (editor-mark editor) nil)))))

1555

1556

(defun cut-region (chord editor)

1557

(declare (ignore chord))

1558

(std:awhen (editor-mark editor)

1559

(with-editor-point-and-string ((point string) editor)

1560

(let ((start (min std:it point))

1561

(end (max std:it point)))

1562

(copy-region t editor)

1563

(setf (get-string editor) (concatenate 'simple-string (subseq string 0 start)

1564

(subseq string end))

1565

(get-point editor) start)))))

1566

1567

(defun set-mark (chord editor)

1568

(declare (ignore chord))

1569

;; FIXME: this was (setf mark (unless mark point)) -- modulo correct

1570

;; accessors. Why? Was I not thinking, or am I not thinking now?

1571

(setf (editor-mark editor) (get-point editor)))

1572

1573

;;; SEXP MOTION

1574

(defun forward-sexp (chord editor)

1575

(declare (ignore chord))

1576

(setf (get-point editor) (editor-sexp-end editor)))

1577

1578

(defun backward-sexp (chord editor)

1579

(declare (ignore chord))

1580

(setf (get-point editor) (editor-sexp-start editor)))

1581

1582

;; FIXME: KILL-SEXP is fairly broken, but works for enough of my

1583

;; common use cases. Most of its flaws lie in how the EDITOR-SEXP-

1584

;; functions deal with objects other than lists and strings.

1585

(defun kill-sexp (chord editor)

1586

(declare (ignore chord))

1587

(with-editor-point-and-string ((point string) editor)

1588

(declare (ignore point))

1589

(let ((start (editor-sexp-start editor))

1590

(end (min (1+ (editor-sexp-end editor)) (length string))))

1591

(buffer-push (subseq string start end) (editor-killring editor))

1592

(setf (get-string editor) (concatenate 'simple-string (subseq string 0 start)

1593

(subseq string end))

1594

(get-point editor) start))))

1595

1596

(defun close-all-sexp (chord editor)

1597

(move-to-eol chord editor)

1598

(do ((string (get-string editor) (get-string editor)))

1599

((not (find-open-paren string (length string))))

1600

(add-char (case (schar string (find-open-paren string (length string)))

1601

(#$ #$)

1602

(#\[ #\])

1603

(#\{ #\}))

1604

editor)))

1605

1606

;;; SIGNALS

1607

(defun interrupt-lisp (chord editor)

1608

(declare (ignore chord))

1609

(editor-interrupt editor))

1610

1611

(defun stop-lisp (chord editor)

1612

(declare (ignore chord))

1613

(editor-stop editor))

1614

1615

;;; MISCELLANY

1616

(defun help (chord editor)

1617

(declare (ignore chord))

1618

(let ((pairs nil)

1619

(max-id 0)

1620

(max-f 0))

1621

(maphash (lambda (id function)

1622

(let ((f (string-downcase (symbol-name function))))

1623

(push (list id f) pairs)

1624

(setf max-id (max max-id (length id))

1625

max-f (max max-f (length f)))))

1626

(editor-commands editor))

1627

(print-in-columns editor

1628

(mapcar (lambda (pair)

1629

(destructuring-bind (id f) pair

1630

(with-output-to-string (s)

1631

(write-string id s)

1632

(loop repeat (- (1+ max-id) (length id))

1633

do (write-char #\Space s))

1634

(write-string f s))))

1635

(nreverse pairs))

1636

:width (+ max-id max-f 2))))

1637

1638

(defun unknown-command (chord editor)

1639

(newline editor)

1640

(format *standard-output* "Unknown command ~S." chord)

1641

(newline editor))

1642

1643

(defun complete (chord editor)

1644

(declare (ignore chord))

1645

(multiple-value-bind (completions max-len) (editor-complete editor)

1646

(if completions

1647

(if (not (cdr completions))

1648

(editor-replace-word editor (car completions))

1649

(print-in-columns editor completions :width (+ max-len 2)))

1650

(beep editor))))

1651

1652

(defun apropos-word (chord editor)

1653

(declare (ignore chord))

1654

(let* ((word (editor-word editor))

1655

(apropi (apropos-list word)))

1656

(if (null apropi)

1657

(beep editor)

1658

(let* ((longest 0)

1659

(strings (mapcar (lambda (symbol)

1660

(declare (symbol symbol))

1661

(let ((str (prin1-to-string symbol)))

1662

(setf longest (max longest (length str)))

1663

(string-downcase str)))

1664

apropi)))

1665

(print-in-columns editor strings :width (+ longest 2))))))

1666

1667

(defun describe-word (chord editor)

1668

(declare (ignore chord))

1669

(print-in-lines editor

1670

(with-output-to-string (s)

1671

(describe (read-from-string (editor-word editor)) s))))

1672

1673

(defun inspect-word (chord editor)

1674

(declare (ignore chord))

1675

(without-backend editor

1676

(inspect (read-from-string (editor-word editor)))))

1677

1678

(defun toggle-insert (chord editor)

1679

(declare (ignore chord))

1680

(setf (editor-insert-mode editor) (not (editor-insert-mode editor))))

1681

1682

(let (prompt-fun read-form-fun)

1683

(declare (type (or null function) prompt-fun read-form-fun))

1684

1685

(macrolet ((enforce-consistent-state ()

1686

`(assert (or (and prompt-fun read-form-fun)

1687

(not (or prompt-fun read-form-fun))))))

1688

1689

(defun uninstall-repl ()

1690

(enforce-consistent-state)

1691

(if prompt-fun

1692

(setf sb-int:*repl-prompt-fun* prompt-fun

1693

sb-int:*repl-read-form-fun* read-form-fun

1694

prompt-fun nil

1695

read-form-fun nil)

1696

(warn "UNINSTALL-REPL failed: No Linedit REPL present."))

1697

nil)

1698

1699

(defun install-repl (&rest args &key wrap-current eof-quits history killring &allow-other-keys)

1700

(enforce-consistent-state)

1701

(let ((args (copy-list args)))

1702

(dolist (key '(:wrap-current :eof-quits

1703

:history :killring))

1704

(remf args key))

1705

(when prompt-fun

1706

(warn "INSTALL-REPL failed: Linedit REPL already installed.")

1707

(return-from install-repl nil))

1708

(setf prompt-fun sb-int:*repl-prompt-fun*

1709

read-form-fun sb-int:*repl-read-form-fun*)

1710

(flet ((repl-reader (in out)

1711

(declare (type stream out)

1712

(ignore in))

1713

(fresh-line out)

1714

(let ((prompt (with-output-to-string (s)

1715

(funcall prompt-fun s))))

1716

(handler-case

1717

(apply #'formedit

1718

:prompt1 prompt

1719

:prompt2 (make-string (length prompt)

1720

                                                     :initial-element #\Space)

1721

:history history

1722

:killring killring

1723

args)

1724

(end-of-file (e)

1725

(declare (ignore e))

1726

(if eof-quits

1727

(and (fresh-line) (eof-handler "SBCL" #'sb-ext:quit))

1728

;; Hackins, I know.

1729

"#.''end-of-file"))))))

1730

(setf sb-int:*repl-prompt-fun* (constantly ""))

1731

(setf sb-int:*repl-read-form-fun*

1732

(if wrap-current

1733

(lambda (in out)

1734

(declare (type stream out in))

1735

;; FIXME: Yich.

1736

(terpri)

1737

(with-input-from-string (in (repl-reader in out))

1738

(funcall read-form-fun in out)))

1739

(lambda (in out)

1740

(declare (type stream out in))

1741

(handler-case (read-from-string (repl-reader in out))

1742

(end-of-file ()

1743

;; We never get here if eof-quits is true, so...

1744

(fresh-line)

1745

(write-line "#<end-of-file>")

1746

(values)))))))

1747

t))))