Fortran · 34516 bytes Raw Blame History
1 module window_mod
2 use, intrinsic :: iso_c_binding
3 use types
4 use glfw_bindings
5 use gl_bindings
6 use pty_mod
7 use terminal_mod
8 use selection_mod
9 implicit none
10 private
11
12 public :: window_t, selection_t
13 public :: window_create, window_destroy
14 public :: window_should_close, window_swap_buffers, window_poll_events
15 public :: window_get_size, window_set_pty, window_set_terminal
16 public :: window_set_title, window_set_cell_size, window_set_blur
17 public :: window_get_selection, window_clipboard_set, window_clipboard_get
18 public :: window_get_font_delta, window_clear_font_delta, window_set_font_size
19 public :: window_set_render_callback, window_is_resizing
20 public :: window_get_tab_action, window_clear_tab_action
21 public :: window_get_pane_action, window_clear_pane_action
22 public :: window_is_focused
23 public :: window_set_tab_bar_info
24 public :: window_get_tab_hover
25
26 ! Tab action constants
27 integer, parameter, public :: TAB_ACTION_NONE = 0
28 integer, parameter, public :: TAB_ACTION_NEW = 1
29 integer, parameter, public :: TAB_ACTION_CLOSE = 2
30 integer, parameter, public :: TAB_ACTION_NEXT = 3
31 integer, parameter, public :: TAB_ACTION_PREV = 4
32 ! TAB_ACTION_GOTO_1 through TAB_ACTION_GOTO_9 are 10-18
33
34 ! Pane action constants
35 integer, parameter, public :: PANE_ACTION_NONE = 0
36 integer, parameter, public :: PANE_ACTION_SPLIT_V = 1
37 integer, parameter, public :: PANE_ACTION_SPLIT_H = 2
38 integer, parameter, public :: PANE_ACTION_NAV_LEFT = 3
39 integer, parameter, public :: PANE_ACTION_NAV_RIGHT = 4
40 integer, parameter, public :: PANE_ACTION_NAV_UP = 5
41 integer, parameter, public :: PANE_ACTION_NAV_DOWN = 6
42
43 type :: window_t
44 type(c_ptr) :: handle = c_null_ptr
45 integer :: width = 0
46 integer :: height = 0
47 integer :: fb_width = 0
48 integer :: fb_height = 0
49 end type window_t
50
51 ! Module-level window pointer for callbacks
52 type(c_ptr), save :: current_window = c_null_ptr
53
54 ! Module-level PTY pointer for keyboard input
55 type(pty_t), pointer, save :: active_pty => null()
56
57 ! Module-level terminal pointer for scrollback
58 type(terminal_t), pointer, save :: active_term => null()
59
60 ! Selection state for mouse-based text selection
61 type(selection_t), save :: active_selection
62
63 ! Cell dimensions for mouse coordinate conversion
64 integer, save :: cell_width = 10
65 integer, save :: cell_height = 18
66
67 ! Font size adjustment state
68 integer, save :: pending_font_delta = 0 ! +2, -2, or -999 for reset
69 integer, save :: current_font_size = 16 ! Track current size
70
71 ! Tab action state
72 integer, save :: pending_tab_action = 0 ! 0=none, 1=new, 2=close, 3=next, 4=prev, 10-18=goto
73
74 ! Pane action state
75 integer, save :: pending_pane_action = 0 ! 0=none, 1=split_v, 2=split_h, 3-6=nav
76
77 ! Tab bar geometry for click detection
78 integer, save :: tab_bar_height = 0 ! 0 when hidden (1 tab), else ~28
79 integer, save :: tab_count = 1 ! Number of tabs
80 integer, save :: tab_bar_win_width = 800 ! Window width for tab width calc
81
82 ! Tab bar hover state
83 integer, save :: hover_tab_index = 0 ! Which tab mouse is over (0 = none)
84 logical, save :: hover_on_close_btn = .false. ! Is mouse over close button?
85
86 ! Live resize rendering support
87 logical, save :: is_resizing = .false.
88 procedure(render_callback_interface), pointer, save :: render_callback => null()
89
90 ! Abstract interface for render callback
91 abstract interface
92 subroutine render_callback_interface()
93 end subroutine render_callback_interface
94 end interface
95
96 ! Interface to C helper for loading OpenGL
97 interface
98 integer(c_int) function fortty_load_gl() bind(C, name="fortty_load_gl")
99 import :: c_int
100 end function fortty_load_gl
101
102 ! macOS window blur (no-op on other platforms)
103 subroutine fortty_set_window_blur_c(window, enable) bind(C, name="fortty_set_window_blur")
104 import :: c_ptr, c_int
105 type(c_ptr), value :: window
106 integer(c_int), value :: enable
107 end subroutine fortty_set_window_blur_c
108 end interface
109
110 contains
111
112 function window_create(width, height, title, transparent) result(win)
113 integer, intent(in) :: width, height
114 character(len=*), intent(in) :: title
115 logical, intent(in), optional :: transparent
116 type(window_t) :: win
117 type(c_funptr) :: dummy
118 integer(c_int) :: gl_loaded
119 character(len=256) :: c_title
120
121 ! Initialize GLFW
122 if (glfwInit() == GLFW_FALSE) then
123 print *, "Error: Failed to initialize GLFW"
124 stop 1
125 end if
126
127 ! Set error callback
128 dummy = glfwSetErrorCallback(c_funloc(error_callback))
129
130 ! Request OpenGL 3.3 Core Profile
131 call glfwWindowHint(GLFW_CONTEXT_VERSION_MAJOR, 3)
132 call glfwWindowHint(GLFW_CONTEXT_VERSION_MINOR, 3)
133 call glfwWindowHint(GLFW_OPENGL_PROFILE, GLFW_OPENGL_CORE_PROFILE)
134 call glfwWindowHint(GLFW_OPENGL_FORWARD_COMPAT, GLFW_TRUE)
135
136 ! Enable transparent framebuffer if requested (for window opacity)
137 if (present(transparent)) then
138 if (transparent) then
139 call glfwWindowHint(GLFW_TRANSPARENT_FRAMEBUFFER, GLFW_TRUE)
140 end if
141 end if
142
143 ! Create window
144 c_title = trim(title) // c_null_char
145 win%handle = glfwCreateWindow(width, height, c_title, c_null_ptr, c_null_ptr)
146
147 if (.not. c_associated(win%handle)) then
148 print *, "Error: Failed to create GLFW window"
149 call glfwTerminate()
150 stop 1
151 end if
152
153 win%width = width
154 win%height = height
155 current_window = win%handle
156
157 ! Make context current
158 call glfwMakeContextCurrent(win%handle)
159
160 ! Load OpenGL functions via GLAD
161 gl_loaded = fortty_load_gl()
162 if (gl_loaded == 0) then
163 print *, "Error: Failed to load OpenGL functions"
164 call glfwDestroyWindow(win%handle)
165 call glfwTerminate()
166 stop 1
167 end if
168
169 ! Get actual framebuffer size (may differ on HiDPI)
170 call glfwGetFramebufferSize(win%handle, win%fb_width, win%fb_height)
171
172 ! Set initial viewport
173 call glViewport(0, 0, win%fb_width, win%fb_height)
174
175 ! Register callbacks
176 dummy = glfwSetFramebufferSizeCallback(win%handle, c_funloc(framebuffer_size_callback))
177 dummy = glfwSetWindowRefreshCallback(win%handle, c_funloc(window_refresh_callback))
178 dummy = glfwSetKeyCallback(win%handle, c_funloc(key_callback))
179 dummy = glfwSetCharCallback(win%handle, c_funloc(char_callback))
180 dummy = glfwSetScrollCallback(win%handle, c_funloc(scroll_callback))
181 dummy = glfwSetMouseButtonCallback(win%handle, c_funloc(mouse_button_callback))
182 dummy = glfwSetCursorPosCallback(win%handle, c_funloc(cursor_pos_callback))
183
184 end function window_create
185
186 subroutine window_destroy(win)
187 type(window_t), intent(inout) :: win
188
189 if (c_associated(win%handle)) then
190 call glfwDestroyWindow(win%handle)
191 win%handle = c_null_ptr
192 end if
193
194 call glfwTerminate()
195 end subroutine window_destroy
196
197 function window_should_close(win) result(should)
198 type(window_t), intent(in) :: win
199 logical :: should
200
201 should = glfwWindowShouldClose(win%handle) /= GLFW_FALSE
202 end function window_should_close
203
204 ! Check if window has focus - used to skip rendering on Wayland when
205 ! window is on inactive workspace (prevents compositor timeout)
206 function window_is_focused(win) result(focused)
207 type(window_t), intent(in) :: win
208 logical :: focused
209
210 focused = glfwGetWindowAttrib(win%handle, GLFW_FOCUSED) /= GLFW_FALSE
211 end function window_is_focused
212
213 subroutine window_swap_buffers(win)
214 type(window_t), intent(in) :: win
215
216 call glfwSwapBuffers(win%handle)
217 end subroutine window_swap_buffers
218
219 subroutine window_poll_events()
220 ! Use WaitEventsTimeout instead of PollEvents for Wayland compatibility
221 ! This allows the compositor to send ping-pong messages to verify the app
222 ! is responsive, even when on an inactive workspace. 10ms timeout provides
223 ! ~100Hz max update rate while allowing proper event processing.
224 call glfwWaitEventsTimeout(0.01d0)
225 end subroutine window_poll_events
226
227 ! Get current framebuffer size
228 subroutine window_get_size(win, width, height)
229 type(window_t), intent(in) :: win
230 integer, intent(out) :: width, height
231 integer(c_int) :: w, h
232
233 ! Use window size (points) not framebuffer size (pixels)
234 ! This ensures projection and cell math work correctly on HiDPI displays
235 call glfwGetWindowSize(win%handle, w, h)
236 width = int(w)
237 height = int(h)
238 end subroutine window_get_size
239
240 ! Callback: handle window resize
241 subroutine framebuffer_size_callback(window, width, height) bind(C)
242 type(c_ptr), value :: window
243 integer(c_int), value :: width, height
244
245 ! Suppress unused argument warning (required by GLFW callback signature)
246 if (.false. .and. c_associated(window)) continue
247
248 call glViewport(0, 0, width, height)
249
250 ! Mark that we're in a resize operation and trigger a redraw
251 ! This ensures smooth rendering during live resize on macOS
252 is_resizing = .true.
253 if (associated(render_callback)) then
254 call render_callback()
255 end if
256 end subroutine framebuffer_size_callback
257
258 ! Callback: handle window refresh (called when window needs redrawing)
259 subroutine window_refresh_callback(window) bind(C)
260 type(c_ptr), value :: window
261
262 ! Suppress unused argument warning (required by GLFW callback signature)
263 if (.false. .and. c_associated(window)) continue
264
265 ! Trigger a redraw via the render callback
266 if (associated(render_callback)) then
267 call render_callback()
268 end if
269 end subroutine window_refresh_callback
270
271 ! Set PTY for keyboard input
272 subroutine window_set_pty(p)
273 type(pty_t), target, intent(in) :: p
274
275 active_pty => p
276 end subroutine window_set_pty
277
278 ! Set terminal for scrollback control
279 subroutine window_set_terminal(t)
280 type(terminal_t), target, intent(in) :: t
281
282 active_term => t
283 end subroutine window_set_terminal
284
285 ! Callback: handle key presses (special keys and Ctrl combinations)
286 subroutine key_callback(window, key, scancode, action, mods) bind(C)
287 type(c_ptr), value :: window
288 integer(c_int), value :: key, scancode, action, mods
289 character(len=16) :: seq
290 integer :: seq_len
291
292 ! Unused argument (required by GLFW callback signature)
293 if (.false.) print *, scancode
294
295 ! Only process press and repeat events
296 if (action == GLFW_RELEASE) return
297
298 ! Check if PTY is active
299 if (.not. associated(active_pty)) return
300
301 ! Close window on Escape (keep this for development)
302 if (key == GLFW_KEY_ESCAPE .and. action == GLFW_PRESS) then
303 call glfwSetWindowShouldClose(window, GLFW_TRUE)
304 return
305 end if
306
307 ! Handle Shift+PageUp/Down for scrollback (before resetting scroll)
308 if (associated(active_term) .and. iand(mods, GLFW_MOD_SHIFT) /= 0) then
309 if (key == GLFW_KEY_PAGE_UP) then
310 call terminal_scroll_view(active_term, active_term%rows)
311 return
312 else if (key == GLFW_KEY_PAGE_DOWN) then
313 call terminal_scroll_view(active_term, -active_term%rows)
314 return
315 end if
316 end if
317
318 ! Reset scroll view on any other key input (return to live view)
319 if (associated(active_term)) then
320 call terminal_reset_scroll_view(active_term)
321 end if
322
323 ! Handle Ctrl+Shift+V for paste
324 if (iand(mods, GLFW_MOD_CONTROL) /= 0 .and. iand(mods, GLFW_MOD_SHIFT) /= 0) then
325 if (key == GLFW_KEY_V) then
326 call handle_paste(window)
327 return
328 end if
329 end if
330
331 ! Handle font size adjustment: Ctrl/Cmd + Plus/Minus/0
332 if (iand(mods, GLFW_MOD_CONTROL) /= 0 .or. iand(mods, GLFW_MOD_SUPER) /= 0) then
333 if (key == GLFW_KEY_EQUAL .or. key == GLFW_KEY_KP_ADD) then
334 ! Ctrl/Cmd + = or numpad + (increase font size)
335 pending_font_delta = 2
336 return
337 else if (key == GLFW_KEY_MINUS .or. key == GLFW_KEY_KP_SUBTRACT) then
338 ! Ctrl/Cmd + - (decrease font size)
339 pending_font_delta = -2
340 return
341 else if (key == GLFW_KEY_0) then
342 ! Ctrl/Cmd + 0 (reset font size)
343 pending_font_delta = -999
344 return
345 end if
346 end if
347
348 ! Handle tab management: Ctrl/Cmd + T/W/[/]/1-9
349 if (iand(mods, GLFW_MOD_CONTROL) /= 0 .or. iand(mods, GLFW_MOD_SUPER) /= 0) then
350 select case (key)
351 case (GLFW_KEY_T)
352 ! New tab
353 pending_tab_action = TAB_ACTION_NEW
354 return
355 case (GLFW_KEY_W)
356 ! Close tab
357 pending_tab_action = TAB_ACTION_CLOSE
358 return
359 case (GLFW_KEY_RIGHT_BRACKET)
360 ! Next tab (Cmd+])
361 pending_tab_action = TAB_ACTION_NEXT
362 return
363 case (GLFW_KEY_LEFT_BRACKET)
364 ! Previous tab (Cmd+[)
365 pending_tab_action = TAB_ACTION_PREV
366 return
367 case (GLFW_KEY_1)
368 pending_tab_action = 10
369 return
370 case (GLFW_KEY_2)
371 pending_tab_action = 11
372 return
373 case (GLFW_KEY_3)
374 pending_tab_action = 12
375 return
376 case (GLFW_KEY_4)
377 pending_tab_action = 13
378 return
379 case (GLFW_KEY_5)
380 pending_tab_action = 14
381 return
382 case (GLFW_KEY_6)
383 pending_tab_action = 15
384 return
385 case (GLFW_KEY_7)
386 pending_tab_action = 16
387 return
388 case (GLFW_KEY_8)
389 pending_tab_action = 17
390 return
391 case (GLFW_KEY_9)
392 pending_tab_action = 18
393 return
394
395 ! Pane splitting: Cmd/Ctrl + \ (vertical), Cmd/Ctrl + Shift + \ (horizontal)
396 case (GLFW_KEY_BACKSLASH)
397 if (iand(mods, GLFW_MOD_SHIFT) /= 0) then
398 pending_pane_action = PANE_ACTION_SPLIT_H
399 else
400 pending_pane_action = PANE_ACTION_SPLIT_V
401 end if
402 return
403
404 ! Pane navigation with arrow keys: Cmd/Ctrl + Arrow
405 case (GLFW_KEY_LEFT)
406 pending_pane_action = PANE_ACTION_NAV_LEFT
407 return
408 case (GLFW_KEY_RIGHT)
409 pending_pane_action = PANE_ACTION_NAV_RIGHT
410 return
411 case (GLFW_KEY_UP)
412 pending_pane_action = PANE_ACTION_NAV_UP
413 return
414 case (GLFW_KEY_DOWN)
415 pending_pane_action = PANE_ACTION_NAV_DOWN
416 return
417
418 end select
419 end if
420
421 ! Pane navigation with vim keys: Super/Cmd + hjkl only (not Ctrl)
422 ! This allows Ctrl+L (clear), Ctrl+H, etc. to pass through to the shell
423 if (iand(mods, GLFW_MOD_SUPER) /= 0 .and. iand(mods, GLFW_MOD_CONTROL) == 0) then
424 select case (key)
425 case (GLFW_KEY_H)
426 pending_pane_action = PANE_ACTION_NAV_LEFT
427 return
428 case (GLFW_KEY_L)
429 pending_pane_action = PANE_ACTION_NAV_RIGHT
430 return
431 case (GLFW_KEY_K)
432 pending_pane_action = PANE_ACTION_NAV_UP
433 return
434 case (GLFW_KEY_J)
435 pending_pane_action = PANE_ACTION_NAV_DOWN
436 return
437 end select
438 end if
439
440 ! Handle Ctrl combinations (these don't trigger char_callback)
441 if (iand(mods, GLFW_MOD_CONTROL) /= 0) then
442 if (key >= GLFW_KEY_A .and. key <= GLFW_KEY_Z) then
443 ! Ctrl+A through Ctrl+Z = 0x01-0x1A
444 seq(1:1) = char(key - GLFW_KEY_A + 1)
445 call pty_write(active_pty, seq, 1)
446 return
447 end if
448 end if
449
450 ! Handle special keys
451 seq_len = 0
452 select case (key)
453 case (GLFW_KEY_ENTER)
454 seq(1:1) = char(13) ! CR
455 seq_len = 1
456
457 case (GLFW_KEY_TAB)
458 if (iand(mods, GLFW_MOD_SHIFT) /= 0) then
459 ! Shift+Tab = CSI Z
460 seq = char(27) // '[Z'
461 seq_len = 3
462 else
463 seq(1:1) = char(9) ! Tab
464 seq_len = 1
465 end if
466
467 case (GLFW_KEY_BACKSPACE)
468 seq(1:1) = char(127) ! DEL (most terminals expect this)
469 seq_len = 1
470
471 case (GLFW_KEY_UP)
472 call build_arrow_seq(seq, seq_len, 'A', mods)
473
474 case (GLFW_KEY_DOWN)
475 call build_arrow_seq(seq, seq_len, 'B', mods)
476
477 case (GLFW_KEY_RIGHT)
478 call build_arrow_seq(seq, seq_len, 'C', mods)
479
480 case (GLFW_KEY_LEFT)
481 call build_arrow_seq(seq, seq_len, 'D', mods)
482
483 case (GLFW_KEY_HOME)
484 call build_tilde_seq(seq, seq_len, 1, mods)
485
486 case (GLFW_KEY_END)
487 call build_tilde_seq(seq, seq_len, 4, mods)
488
489 case (GLFW_KEY_INSERT)
490 call build_tilde_seq(seq, seq_len, 2, mods)
491
492 case (GLFW_KEY_DELETE)
493 call build_tilde_seq(seq, seq_len, 3, mods)
494
495 case (GLFW_KEY_PAGE_UP)
496 call build_tilde_seq(seq, seq_len, 5, mods)
497
498 case (GLFW_KEY_PAGE_DOWN)
499 call build_tilde_seq(seq, seq_len, 6, mods)
500
501 case (GLFW_KEY_F1)
502 call build_fkey_seq(seq, seq_len, 11, mods)
503 case (GLFW_KEY_F2)
504 call build_fkey_seq(seq, seq_len, 12, mods)
505 case (GLFW_KEY_F3)
506 call build_fkey_seq(seq, seq_len, 13, mods)
507 case (GLFW_KEY_F4)
508 call build_fkey_seq(seq, seq_len, 14, mods)
509 case (GLFW_KEY_F5)
510 call build_fkey_seq(seq, seq_len, 15, mods)
511 case (GLFW_KEY_F6)
512 call build_fkey_seq(seq, seq_len, 17, mods)
513 case (GLFW_KEY_F7)
514 call build_fkey_seq(seq, seq_len, 18, mods)
515 case (GLFW_KEY_F8)
516 call build_fkey_seq(seq, seq_len, 19, mods)
517 case (GLFW_KEY_F9)
518 call build_fkey_seq(seq, seq_len, 20, mods)
519 case (GLFW_KEY_F10)
520 call build_fkey_seq(seq, seq_len, 21, mods)
521 case (GLFW_KEY_F11)
522 call build_fkey_seq(seq, seq_len, 23, mods)
523 case (GLFW_KEY_F12)
524 call build_fkey_seq(seq, seq_len, 24, mods)
525 end select
526
527 if (seq_len > 0) then
528 call pty_write(active_pty, seq, seq_len)
529 end if
530 end subroutine key_callback
531
532 ! Callback: handle character input (regular text)
533 subroutine char_callback(window, codepoint) bind(C)
534 type(c_ptr), value :: window
535 integer(c_int), value :: codepoint
536 character(len=4) :: utf8
537 integer :: utf8_len
538
539 ! Suppress unused argument warning (required by GLFW callback signature)
540 if (.false. .and. c_associated(window)) continue
541
542 if (.not. associated(active_pty)) return
543
544 ! Convert Unicode codepoint to UTF-8
545 call codepoint_to_utf8(codepoint, utf8, utf8_len)
546
547 if (utf8_len > 0) then
548 call pty_write(active_pty, utf8, utf8_len)
549 end if
550 end subroutine char_callback
551
552 ! Build arrow key escape sequence
553 subroutine build_arrow_seq(seq, seq_len, letter, mods)
554 character(len=*), intent(out) :: seq
555 integer, intent(out) :: seq_len
556 character(len=1), intent(in) :: letter
557 integer(c_int), intent(in) :: mods
558 integer :: mod_num
559
560 mod_num = get_modifier_num(mods)
561
562 if (mod_num == 0) then
563 ! ESC [ <letter>
564 seq = char(27) // '[' // letter
565 seq_len = 3
566 else
567 ! ESC [ 1 ; <mod> <letter>
568 seq = char(27) // '[1;' // char(mod_num + ichar('0')) // letter
569 seq_len = 6
570 end if
571 end subroutine build_arrow_seq
572
573 ! Build tilde-terminated escape sequence (Home, End, Insert, Delete, PgUp, PgDn)
574 subroutine build_tilde_seq(seq, seq_len, code, mods)
575 character(len=*), intent(out) :: seq
576 integer, intent(out) :: seq_len
577 integer, intent(in) :: code
578 integer(c_int), intent(in) :: mods
579 integer :: mod_num
580 character(len=2) :: code_str
581
582 mod_num = get_modifier_num(mods)
583 write(code_str, '(I1)') code
584
585 if (mod_num == 0) then
586 ! ESC [ <code> ~
587 seq = char(27) // '[' // trim(code_str) // '~'
588 seq_len = 4
589 else
590 ! ESC [ <code> ; <mod> ~
591 seq = char(27) // '[' // trim(code_str) // ';' // char(mod_num + ichar('0')) // '~'
592 seq_len = 6
593 end if
594 end subroutine build_tilde_seq
595
596 ! Build function key escape sequence
597 subroutine build_fkey_seq(seq, seq_len, code, mods)
598 character(len=*), intent(out) :: seq
599 integer, intent(out) :: seq_len
600 integer, intent(in) :: code
601 integer(c_int), intent(in) :: mods
602 integer :: mod_num
603 character(len=2) :: code_str
604
605 mod_num = get_modifier_num(mods)
606 write(code_str, '(I2)') code
607
608 if (mod_num == 0) then
609 ! ESC [ <code> ~
610 seq = char(27) // '[' // trim(code_str) // '~'
611 seq_len = 5
612 else
613 ! ESC [ <code> ; <mod> ~
614 seq = char(27) // '[' // trim(code_str) // ';' // char(mod_num + ichar('0')) // '~'
615 seq_len = 7
616 end if
617 end subroutine build_fkey_seq
618
619 ! Convert GLFW modifier bits to xterm modifier number
620 function get_modifier_num(mods) result(mod_num)
621 integer(c_int), intent(in) :: mods
622 integer :: mod_num
623
624 mod_num = 0
625 if (iand(mods, GLFW_MOD_SHIFT) /= 0) mod_num = mod_num + 1
626 if (iand(mods, GLFW_MOD_ALT) /= 0) mod_num = mod_num + 2
627 if (iand(mods, GLFW_MOD_CONTROL) /= 0) mod_num = mod_num + 4
628
629 ! xterm encoding: modifier = 1 + shift + alt*2 + ctrl*4
630 if (mod_num > 0) mod_num = mod_num + 1
631 end function get_modifier_num
632
633 ! Convert Unicode codepoint to UTF-8 bytes
634 subroutine codepoint_to_utf8(cp, utf8, length)
635 integer(c_int), intent(in) :: cp
636 character(len=*), intent(out) :: utf8
637 integer, intent(out) :: length
638
639 if (cp < 128) then
640 ! ASCII
641 utf8(1:1) = char(cp)
642 length = 1
643 else if (cp < 2048) then
644 ! 2-byte UTF-8
645 utf8(1:1) = char(ior(192, ishft(cp, -6)))
646 utf8(2:2) = char(ior(128, iand(cp, 63)))
647 length = 2
648 else if (cp < 65536) then
649 ! 3-byte UTF-8
650 utf8(1:1) = char(ior(224, ishft(cp, -12)))
651 utf8(2:2) = char(ior(128, iand(ishft(cp, -6), 63)))
652 utf8(3:3) = char(ior(128, iand(cp, 63)))
653 length = 3
654 else if (cp < 1114112) then
655 ! 4-byte UTF-8
656 utf8(1:1) = char(ior(240, ishft(cp, -18)))
657 utf8(2:2) = char(ior(128, iand(ishft(cp, -12), 63)))
658 utf8(3:3) = char(ior(128, iand(ishft(cp, -6), 63)))
659 utf8(4:4) = char(ior(128, iand(cp, 63)))
660 length = 4
661 else
662 ! Invalid codepoint
663 length = 0
664 end if
665 end subroutine codepoint_to_utf8
666
667 ! Callback: handle GLFW errors
668 subroutine error_callback(error_code, description) bind(C)
669 integer(c_int), value :: error_code
670 type(c_ptr), value :: description
671
672 ! Suppress unused argument warning (required by GLFW callback signature)
673 if (.false. .and. c_associated(description)) continue
674
675 print *, "GLFW Error ", error_code
676 end subroutine error_callback
677
678 ! Callback: handle mouse scroll wheel
679 subroutine scroll_callback(window, xoffset, yoffset) bind(C)
680 type(c_ptr), value :: window
681 real(c_double), value :: xoffset, yoffset
682 integer :: scroll_lines
683
684 ! Suppress unused argument warnings (required by GLFW callback signature)
685 if (.false. .and. c_associated(window)) continue
686 if (.false. .and. xoffset > 0.0d0) continue
687
688 if (.not. associated(active_term)) return
689
690 ! Convert scroll amount to lines (typically 3 lines per notch)
691 scroll_lines = nint(yoffset * 3.0d0)
692
693 ! Positive yoffset = scroll up (back in history)
694 call terminal_scroll_view(active_term, scroll_lines)
695 end subroutine scroll_callback
696
697 ! Set window title
698 subroutine window_set_title(win, title)
699 type(window_t), intent(in) :: win
700 character(len=*), intent(in) :: title
701 character(len=257) :: c_title
702
703 if (.not. c_associated(win%handle)) return
704
705 c_title = trim(title) // c_null_char
706 call glfwSetWindowTitle(win%handle, c_title)
707 end subroutine window_set_title
708
709 ! Enable background blur (macOS only, no-op on other platforms)
710 subroutine window_set_blur(win, enable)
711 type(window_t), intent(in) :: win
712 logical, intent(in) :: enable
713
714 if (.not. c_associated(win%handle)) return
715
716 if (enable) then
717 call fortty_set_window_blur_c(win%handle, 1_c_int)
718 else
719 call fortty_set_window_blur_c(win%handle, 0_c_int)
720 end if
721 end subroutine window_set_blur
722
723 ! Set cell dimensions for mouse coordinate conversion
724 subroutine window_set_cell_size(w, h)
725 integer, intent(in) :: w, h
726
727 cell_width = w
728 cell_height = h
729 end subroutine window_set_cell_size
730
731 ! Get selection state (for rendering)
732 function window_get_selection() result(sel)
733 type(selection_t) :: sel
734
735 sel = active_selection
736 end function window_get_selection
737
738 ! Set clipboard content
739 subroutine window_clipboard_set(win, text)
740 type(window_t), intent(in) :: win
741 character(len=*), intent(in) :: text
742 character(len=4097) :: c_text
743
744 if (.not. c_associated(win%handle)) return
745 if (len_trim(text) == 0) return
746
747 c_text = trim(text) // c_null_char
748 call glfwSetClipboardString(win%handle, c_text)
749 end subroutine window_clipboard_set
750
751 ! Get clipboard content
752 function window_clipboard_get(win) result(text)
753 type(window_t), intent(in) :: win
754 character(len=4096) :: text
755 type(c_ptr) :: clip_ptr
756 character(len=1), pointer :: chars(:)
757 integer :: i, length
758
759 text = ''
760 if (.not. c_associated(win%handle)) return
761
762 clip_ptr = glfwGetClipboardString(win%handle)
763 if (.not. c_associated(clip_ptr)) return
764
765 ! Convert C string to Fortran string
766 call c_f_pointer(clip_ptr, chars, [4096])
767 length = 0
768 do i = 1, 4096
769 if (chars(i) == c_null_char) exit
770 length = i
771 end do
772
773 do i = 1, min(length, 4096)
774 text(i:i) = chars(i)
775 end do
776 end function window_clipboard_get
777
778 ! Callback: handle mouse button events
779 subroutine mouse_button_callback(window, button, action, mods) bind(C)
780 type(c_ptr), value :: window
781 integer(c_int), value :: button, action, mods
782 real(c_double) :: xpos, ypos
783 integer :: col, row
784 integer :: clicked_tab
785 real :: tab_width, btn_x, btn_y
786
787 ! Unused argument (required by GLFW callback signature)
788 if (.false.) print *, mods
789
790 ! Only handle left mouse button for selection
791 if (button /= GLFW_MOUSE_BUTTON_LEFT) return
792
793 call glfwGetCursorPos(window, xpos, ypos)
794
795 ! Check if click is in the tab bar area (only on press)
796 if (action == GLFW_PRESS .and. tab_bar_height > 0 .and. tab_count > 1) then
797 if (int(ypos) < tab_bar_height) then
798 ! Calculate which tab was clicked
799 ! Tab width calculation matches tab_bar.f90 logic
800 tab_width = real(tab_bar_win_width) / real(tab_count)
801 if (tab_width > 200.0) tab_width = 200.0
802 if (tab_width < 80.0) tab_width = 80.0
803
804 clicked_tab = int(xpos / tab_width) + 1
805 if (clicked_tab >= 1 .and. clicked_tab <= tab_count) then
806 ! Check if clicking the close button (14x14 button, 6px from right edge)
807 btn_x = real(clicked_tab - 1) * tab_width + tab_width - 6.0 - 14.0
808 btn_y = (real(tab_bar_height) - 14.0) / 2.0
809
810 if (real(xpos) >= btn_x .and. real(xpos) <= btn_x + 14.0 .and. &
811 real(ypos) >= btn_y .and. real(ypos) <= btn_y + 14.0) then
812 ! Clicked close button - set action: 20 = close tab 1, 21 = close tab 2, etc.
813 pending_tab_action = 19 + clicked_tab
814 else
815 ! Clicked tab body - switch to tab: 10 = tab 1, 11 = tab 2, etc.
816 pending_tab_action = 9 + clicked_tab
817 end if
818 end if
819 return ! Don't start text selection when clicking tabs
820 end if
821 end if
822
823 ! Convert pixel position to terminal cell coordinates (1-based)
824 ! Account for tab bar offset when converting y coordinate
825 col = int(xpos / cell_width) + 1
826 row = int((ypos - real(tab_bar_height)) / cell_height) + 1
827
828 ! Clamp to valid range
829 if (associated(active_term)) then
830 if (col < 1) col = 1
831 if (col > active_term%cols) col = active_term%cols
832 if (row < 1) row = 1
833 if (row > active_term%rows) row = active_term%rows
834 end if
835
836 if (action == GLFW_PRESS) then
837 call selection_start(active_selection, row, col)
838 else if (action == GLFW_RELEASE) then
839 call selection_end(active_selection)
840 ! Copy selection to clipboard if active
841 if (selection_is_active(active_selection)) then
842 call copy_selection_to_clipboard(window)
843 end if
844 end if
845 end subroutine mouse_button_callback
846
847 ! Callback: handle cursor position changes
848 subroutine cursor_pos_callback(window, xpos, ypos) bind(C)
849 type(c_ptr), value :: window
850 real(c_double), value :: xpos, ypos
851 integer :: col, row
852 real :: tab_width, btn_x, btn_y, btn_size
853
854 ! Suppress unused argument warning (required by GLFW callback signature)
855 if (.false. .and. c_associated(window)) continue
856
857 ! Track tab bar hover state for close button highlighting
858 if (tab_bar_height > 0 .and. tab_count > 1 .and. int(ypos) < tab_bar_height) then
859 ! Mouse is in tab bar - calculate which tab
860 tab_width = real(tab_bar_win_width) / real(tab_count)
861 if (tab_width > 200.0) tab_width = 200.0
862 if (tab_width < 80.0) tab_width = 80.0
863
864 hover_tab_index = int(xpos / tab_width) + 1
865 if (hover_tab_index > tab_count) hover_tab_index = tab_count
866
867 ! Check if over close button (14x14 button, 6px from right edge)
868 btn_size = 14.0
869 btn_x = real(hover_tab_index - 1) * tab_width + tab_width - 6.0 - btn_size
870 btn_y = (real(tab_bar_height) - btn_size) / 2.0
871
872 hover_on_close_btn = (real(xpos) >= btn_x .and. real(xpos) <= btn_x + btn_size .and. &
873 real(ypos) >= btn_y .and. real(ypos) <= btn_y + btn_size)
874 else
875 hover_tab_index = 0
876 hover_on_close_btn = .false.
877 end if
878
879 ! Only update selection if actively selecting
880 if (.not. active_selection%selecting) return
881
882 ! Convert pixel position to terminal cell coordinates (1-based)
883 col = int(xpos / cell_width) + 1
884 row = int((ypos - real(tab_bar_height)) / cell_height) + 1
885
886 ! Clamp to valid range
887 if (associated(active_term)) then
888 if (col < 1) col = 1
889 if (col > active_term%cols) col = active_term%cols
890 if (row < 1) row = 1
891 if (row > active_term%rows) row = active_term%rows
892 end if
893
894 call selection_update(active_selection, row, col)
895 end subroutine cursor_pos_callback
896
897 ! Copy selection to clipboard
898 subroutine copy_selection_to_clipboard(window)
899 use screen_mod
900 use cell_mod
901 type(c_ptr), intent(in) :: window
902 type(screen_t), pointer :: scr
903 type(cell_t) :: cell
904 character(len=4096) :: text
905 character(len=4) :: utf8
906 integer :: r1, c1, r2, c2, row, col, pos, utf8_len
907
908 if (.not. associated(active_term)) return
909 if (.not. selection_is_active(active_selection)) return
910
911 scr => terminal_active_screen(active_term)
912 call selection_get_bounds(active_selection, r1, c1, r2, c2)
913
914 text = ''
915 pos = 1
916
917 do row = r1, r2
918 do col = 1, scr%cols
919 ! Check if this cell is in selection
920 if (.not. selection_contains(active_selection, row, col)) cycle
921
922 cell = screen_get_cell(scr, row, col)
923
924 ! Convert codepoint to UTF-8
925 if (cell%codepoint >= 32 .and. cell%codepoint < 1114112) then
926 call codepoint_to_utf8(cell%codepoint, utf8, utf8_len)
927 if (pos + utf8_len - 1 <= 4096) then
928 text(pos:pos+utf8_len-1) = utf8(1:utf8_len)
929 pos = pos + utf8_len
930 end if
931 end if
932 end do
933
934 ! Add newline between rows (except last row)
935 if (row < r2 .and. pos < 4096) then
936 text(pos:pos) = char(10)
937 pos = pos + 1
938 end if
939 end do
940
941 ! Set clipboard
942 if (pos > 1) then
943 call glfwSetClipboardString(window, trim(text(1:pos-1)) // c_null_char)
944 end if
945 end subroutine copy_selection_to_clipboard
946
947 ! Handle paste from clipboard
948 subroutine handle_paste(window)
949 type(c_ptr), intent(in) :: window
950 type(c_ptr) :: clip_ptr
951 character(len=1), pointer :: chars(:)
952 integer :: i, length
953
954 if (.not. associated(active_pty)) return
955
956 clip_ptr = glfwGetClipboardString(window)
957 if (.not. c_associated(clip_ptr)) return
958
959 ! Find length of C string
960 call c_f_pointer(clip_ptr, chars, [4096])
961 length = 0
962 do i = 1, 4096
963 if (chars(i) == c_null_char) exit
964 length = i
965 end do
966
967 ! Write to PTY
968 if (length > 0) then
969 block
970 character(len=4096) :: paste_text
971 integer :: j
972 paste_text = ''
973 do j = 1, length
974 paste_text(j:j) = chars(j)
975 end do
976 call pty_write(active_pty, paste_text, length)
977 end block
978 end if
979 end subroutine handle_paste
980
981 ! Get pending font size delta (returns 0 if none)
982 function window_get_font_delta() result(delta)
983 integer :: delta
984 delta = pending_font_delta
985 end function window_get_font_delta
986
987 ! Clear pending font size delta
988 subroutine window_clear_font_delta()
989 pending_font_delta = 0
990 end subroutine window_clear_font_delta
991
992 ! Set current font size (for tracking)
993 subroutine window_set_font_size(size)
994 integer, intent(in) :: size
995 current_font_size = size
996 end subroutine window_set_font_size
997
998 ! Set the render callback for live resize support
999 subroutine window_set_render_callback(callback)
1000 procedure(render_callback_interface) :: callback
1001
1002 render_callback => callback
1003 end subroutine window_set_render_callback
1004
1005 ! Check if window is currently resizing (for main loop optimization)
1006 function window_is_resizing() result(resizing)
1007 logical :: resizing
1008 resizing = is_resizing
1009 is_resizing = .false. ! Clear the flag after reading
1010 end function window_is_resizing
1011
1012 ! Get pending tab action (returns 0 if none)
1013 function window_get_tab_action() result(action)
1014 integer :: action
1015 action = pending_tab_action
1016 end function window_get_tab_action
1017
1018 ! Clear pending tab action
1019 subroutine window_clear_tab_action()
1020 pending_tab_action = TAB_ACTION_NONE
1021 end subroutine window_clear_tab_action
1022
1023 ! Get pending pane action (returns 0 if none)
1024 function window_get_pane_action() result(action)
1025 integer :: action
1026 action = pending_pane_action
1027 end function window_get_pane_action
1028
1029 ! Clear pending pane action
1030 subroutine window_clear_pane_action()
1031 pending_pane_action = PANE_ACTION_NONE
1032 end subroutine window_clear_pane_action
1033
1034 ! Set tab bar info for click detection
1035 subroutine window_set_tab_bar_info(bar_height, count, win_width)
1036 integer, intent(in) :: bar_height, count, win_width
1037 tab_bar_height = bar_height
1038 tab_count = count
1039 tab_bar_win_width = win_width
1040 end subroutine window_set_tab_bar_info
1041
1042 ! Get tab hover state for rendering close button highlights
1043 subroutine window_get_tab_hover(tab_idx, on_close_btn)
1044 integer, intent(out) :: tab_idx
1045 logical, intent(out) :: on_close_btn
1046 tab_idx = hover_tab_index
1047 on_close_btn = hover_on_close_btn
1048 end subroutine window_get_tab_hover
1049
1050 end module window_mod
1051