test/desktop.sgl — sigil-wm

1(import (sigil async) (sigil io) (sigil process)

2 (sigil wm host) (sigil wm input) (sigil wm model) (sigil wm scene) (sigil wm repl))

3(define host (start-host! protocols: 64 request-deadline: 500))

4(define output-id #f)

5(define windows '())

6(define accept? #t)

7(define hold? #f)

8(define requests '())

9(define results '())

10(define retired '())

11(define drags '())

12(define drops '())

13(define ended '())

14(define errors '())

15(define retired-submissions 0)

16(define (record id)

17 (find (lambda (entry) (= (dict-ref entry id:) id)) (dict-ref (host-snapshot host) windows:)))

18(define (redraw!)

19 (submit-plan! host

20 (make-scene-plan

21 (map (lambda (id)

22 (placement window: id

23 box: (rect x: (if (string=? (dict-ref (record id) title:) "target") 340 20)

24 y: 20 width: 300 height: 200)

25 activated?: (eqv? id (and (pair? windows) (car (reverse windows))))))

26 windows)

27 (and (pair? windows) (car (reverse windows))) 200)))

28(on-event! host

29 (lambda (event)

30 (guard (exception (#t (set! errors (cons exception errors)) (write exception) (newline) (flush-output-port)))

31 (let ((id (event-ref event id:)))

32 (case (event-type event)

33 ((ready)

34 (configure-keyboard! host 1 "us" 25 600)

35 (set-seat-capabilities! host 3)

36 (delegate-client-cursor! host #t)

37 (set-pointer-route! host #t))

38 ((output-added)

39 (set! output-id id)

40 (configure-output! host id

41 (dict enabled: #t x: 0 y: 0 scale: 1 transform: 0 mode: -1 width: 960 height: 640 refresh: 60000)))

42 ((output-configured)

43 (display "WAYLAND_SOCKET=") (display (host-socket host)) (newline) (flush-output-port))

44 ((window-initial) (configure-window! host id 300 200))

45 ((window-mapped) (set! windows (append windows (list id))) (redraw!))

46 ((window-unmapped window-destroyed)

47 (set! windows (filter (lambda (window) (not (= window id))) windows)) (redraw!))

48 ((selection-request drag-request)

49 (set! requests (append requests (list event)))

50 (unless hold? (reply-data-request! host id accept? follow-icon?: #t)))

51 ((data-request-result) (set! results (append results (list event))))

52 ((request-retired) (set! retired (cons id retired)))

53 ((drag-started) (set! drags (cons event drags)))

54 ((drag-dropped) (set! drops (cons id drops)))

55 ((drag-ended) (set! ended (cons id ended)))

56 ((transaction-rejected)

57 (case (event-ref event reason:)

58 ((3) #t)

59 ((2)

60 (when (record (event-ref event object:)) (error "live resource reported retired"))

61 (when (event-ref event submitted?:) (set! retired-submissions (+ retired-submissions 1))))

62 (else (error "invalid desktop scene")))))))))

63(with-async

64 (let ((repl (start-repl! host (getenv "SIGIL_WM_REPL") (interaction-environment))))

65 (run-host! host)

66 (stop-repl! repl)))

67(display "DESKTOP_STATS=")

68(write (list (map (lambda (index) (host-statistic host index)) '(1 2 3 4)) retired-submissions errors))

69(newline)

70(unless (and (null? errors) (= (host-statistic host 1) 0)

71 (= (host-statistic host 2) 0) (= (host-statistic host 3) retired-submissions)

72 (= (host-statistic host 4) 0))

73 (error "desktop request ownership or handler failed" errors))

74(display "DESKTOP_HOST=PASS\n")