test/constraints.sgl

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: 515 request-deadline: 1000))

4(define output-id #f)

5(define windows '())

6(define accept? #f)

7(define allow-hints? #t)

8(define locked? #f)

9(define active 0)

10(define states 0)

11(define hints '())

12(define errors '())

13(define (eligible? record)

14 (let ((window (dict-ref record window:)))

15 (and accept? (not locked?) (dict-ref record seat?:)

16 (dict-ref record visible?:) (dict-ref record pointer-focused?:)

17 (dict-ref record inside?:) (> window 0)

18 (= window (dict-ref record keyboard-window:))

19 (= window (dict-ref (host-snapshot host) focus:)))))

20(define (choose-constraint!)

21 (let* ((records (filter eligible? (dict-ref (host-snapshot host) constraints:)))

22 (selected (or (find (lambda (record) (= (dict-ref record id:) active)) records)

23 (and (pair? records) (car records))))

24 (desired (if selected (dict-ref selected id:) 0)))

25 (unless (= desired active)

26 (set! active desired)

27 (set-active-pointer-constraint! host desired (if selected (dict-ref selected generation:) 0)))))

28(define (redraw!)

29 (submit-plan! host

30 (make-scene-plan

31 (map (lambda (id index)

32 (placement window: id

33 box: (rect x: (+ 20 (* index 380)) y: 20 width: 300 height: 300)))

34 windows (iota (length windows)))

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

36(on-event! host

37 (lambda (event)

38 (guard (exception

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

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

41 (case (event-type event)

42 ((ready)

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

44 (set-seat-capabilities! host 3)

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

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

47 (delegate-relative-pointer! host #t))

48 ((output-added)

49 (set! output-id id)

50 (configure-output! host id

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

52 ((output-configured)

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

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

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

56 ((window-unmapped window-destroyed)

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

58 ((constraint-state) (set! states (+ states 1)) (choose-constraint!))

59 ((constraint-activation)

60 (when (and (= active id) (not (event-ref event active?:))) (set! active 0)))

61 ((constraint-result) (unless (event-ref event accepted?:) (set! active 0)))

62 ((constraint-destroyed) (when (= active id) (set! active 0)) (choose-constraint!))

63 ((pointer-hint-request)

64 (reply-pointer-hint! host id

65 (and allow-hints? (not locked?) (= (event-ref event window:) (dict-ref (host-snapshot host) focus:)))))

66 ((pointer-hint-result) (set! hints (cons event hints)))

67 ((virtual-device-request) (reply-request! host id (not locked?)))

68 ((lock-state)

69 (set! locked? (not (= id 0)))

70 (choose-constraint!)

71 (unless locked? (redraw!)))

72 ((transaction-applied) (choose-constraint!))

73 ((command-rejected) (error "constraint command was rejected" (event-raw event))))))))

74(with-async

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

76 (run-host! host)

77 (stop-repl! repl)))

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

79 (= (host-statistic host 3) 0) (= (host-statistic host 4) 0))

80 (error "constraint lifetime or dispatch failed" errors))

81(display "CONSTRAINT_HOST=PASS\n")