test/focus-click.sgl

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

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

3(define host (start-host!))

4(define windows '())

5(define last-plan #f)

6(define applied-plan #f)

7(define cookie? #f)

8(define samples '())

9(define owner (make-dispatcher))

10(define stopped? #f)

11(define hover? #f)

12(define pointer-token 0)

13(define focus-results '())

14(define errors '())

15(define (report exception)

16 (set! errors (cons exception errors))

17 (write exception) (newline) (stop-host! host))

18(define (redraw!)

19 (set! last-plan (submit-plan! host

20 (make-scene-plan

21 (map (lambda (id index)

22 (placement window: id box: (rect x: (* index 480) y: 0 width: 480 height: 640)))

23 windows (iota (length windows)))

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

25(set-button-hook! host

26 (lambda (event)

27 (dispatcher-call! owner

28 (lambda ()

29 (set! samples

30 (append samples (list (list (input-event-target event) (input-event-state event)))))

31 (sleep 0.05)

32 (when (and cookie? (= (input-event-state event) 1))

33 (focus-window! host (input-event-target event) input-token: (input-event-token event)))

34 (forward event)))))

35(define (handle-event! event)

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

37 (case (event-type event)

38 ((stopped) (set! stopped? #t) (dispatcher-close! owner))

39 ((transaction-applied) (set! applied-plan id))

40 ((command-rejected) (write (event-raw event)) (newline))

41 ((focus-request-result) (set! focus-results (cons event focus-results)))

42 ((pointer-target-changed)

43 (set! pointer-token (event-ref event pointer-token:))

44 (when (and hover? (> id 0) (event-ref event moved?:))

45 (sleep 0.05)

46 (focus-window! host id pointer-token: pointer-token)))

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

48 (set-seat-capabilities! host 3) (set-pointer-route! host #t))

49 ((output-added)

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 480 640))

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

56 ((window-unmapped window-destroyed)

57 (when (memv id windows)

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

59 (redraw!))))))

60(on-event! host

61 (lambda (event)

62 (dispatcher-enqueue! owner handle-event! event report)))

63(with-async

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

65 (go (run-host! host))

66 (go

67 (let loop ()

68 (dispatcher-wait! owner)

69 (dispatcher-drain! owner)

70 (unless stopped? (loop)))

71 (stop-repl! repl))))

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

73 (begin

74 (write (map (lambda (index) (host-statistic host index)) (list 1 2 3 4))) (newline)

75 (error "focus/click fixture retained native resources" errors)))

76(display "FOCUS_CLICK_HOST=PASS\n")