test/x11.sgl — sigil-wm

1(import (sigil async)

2 (sigil io)

3 (sigil process)

4 (sigil wm host)

5 (sigil wm model)

6 (sigil wm scene)

7 (sigil wm input)

8 (sigil wm repl))

10(define host (start-host! protocols: 4))

11(define managed #f)

12(define menu #f)

13(define windows '())

14(define output-id #f)

15(define saw-client-move? #f)

16(define saw-client-resize? #f)

18(define (record id)

19 (find (lambda (window) (= (dict-ref window id:) id)) (dict-ref (host-snapshot host) windows:)))

21(define (redraw!)

22 (when (pair? windows)

23 (submit-plan! host

24 (make-scene-plan

25 (map

26 (lambda (id)

27 (let ((override? (dict-ref (record id) override-redirect?:)))

28 (placement window: id

29 box: (if override?

30 (rect x: 700 y: 300 width: 160 height: 100)

31 (rect x: 48 y: 64 width: 480 height: 320))

32 activated?: (not override?))))

33 windows)

34 managed 200))))

36(on-event! host

37 (lambda (event)

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

39 (case (event-type event)

40 ((ready)

41 (configure-device! host 1 "us" 25 600)

42 (set-seat-capabilities! host 3)

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

44 ((output-added)

45 (set! output-id id)

46 (configure-output! host id

47 (dict enabled: #t x: 0 y: 0 scale: 1 transform: 0 mode: -1

48 width: 960 height: 640 refresh: 60000)))

49 ((output-configured)

50 (display "X_DISPLAY=")

51 (display (host-x-display host))

52 (newline)

53 (flush-output-port))

54 ((window-request)

55 (case (event-ref event request:)

56 ((1) (set! saw-client-move? #t))

57 ((2)

58 (unless (= (event-ref event edges:) 5) (error "client resize edges lost"))

59 (set! saw-client-resize? #t)))

60 (when (= (event-ref event request:) 5)

61 (configure-x11! host id (rect x: 48 y: 64 width: 480 height: 320))))

62 ((window-mapped)

63 (unless (eq? (dict-ref (record id) role:) 'x11)

64 (error "X11 role not copied"))

65 (if (dict-ref (record id) override-redirect?:)

66 (set! menu id)

67 (set! managed id))

68 (set! windows (append windows (list id)))

69 (redraw!))

70 ((window-unmapped window-destroyed)

71 (set! windows (filter (lambda (window) (not (= window id))) windows))

72 (when (eqv? managed id) (set! managed #f))

73 (when (eqv? menu id) (set! menu #f))

74 (redraw!))

75 ((transaction-applied)

76 (display "X11_SCENE=PASS\n")

77 (flush-output-port))))))

79(with-async

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

81 (run-host! host)

82 (stop-repl! repl)))

83(unless (and (= (host-statistic host 1) 0) (= (host-statistic host 2) 0))

84 (error "X11 native objects survived teardown"))

85(display "X11_HOST=PASS\n")