test/decorations.sgl

1(import (sigil async) (sigil io) (sigil wm host) (sigil wm input)

2 (sigil wm scene) (sigil wm model) (sigil wm repl) (sigil process))

3(define host (start-host! protocols: 8 legacy-decoration: 'server))

4(define windows '())

5(define before-role #f)

6(define unselected? #f)

7(define states 0)

8(define errors '())

9(define (redraw!)

10 (submit-plan! host

11 (make-scene-plan

12 (map (lambda (id) (placement window: id box: (rect x: 100 y: 100 width: 300 height: 300))) windows)

13 (and (pair? windows) (car windows)) 200)))

14(on-event! host

15 (lambda (event)

16 (guard (exception

17 (#t (set! errors (cons exception errors)) (write exception) (newline) (stop-host! host)))

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

19 (case (event-type event)

20 ((ready)

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

22 (set-seat-capabilities! host 3)

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

24 ((output-added)

25 (configure-output! host id

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

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

28 ((output-configured)

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

30 ((window-initial) (configure-window! host id 300 300))

31 ((window-mapped) (set! windows (cons id windows)) (redraw!))

32 ((window-unmapped window-destroyed)

33 (when (memv id windows)

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

35 (redraw!)))

36 ((decoration-request)

37 (when (find (lambda (record)

38 (and (= (dict-ref record window:) id) (eq? (dict-ref record mode:) 'none)))

39 (dict-ref (host-snapshot host) decorations:))

40 (set! unselected? #t))

41 (set-decoration-mode! host id 'server))

42 ((decoration-state)

43 (set! states (+ states 1))

44 (when (and (= (event-ref event decoration-kind:) 1) (= (event-ref event window:) 0)

45 (not before-role))

46 (set! before-role (host-snapshot host))))

47 ((command-rejected) (error "decoration command was rejected" (event-raw event))))))))

48(with-async

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

50 (run-host! host)

51 (stop-repl! repl)))

52(unless (and (null? errors) (every (lambda (index) (= (host-statistic host index) 0)) '(1 2 3 4)))

53 (error "decoration host retained resources or rejected commands" errors))

54(display "DECORATION_HOST=PASS\n")