90 implicit none;
private
116 character(1),
parameter :: nl = new_line(
'a')
117 character(1),
parameter :: escape = achar(27)
118 character(2),
parameter :: code_start = escape//
'['
119 character(1),
parameter :: code_end =
'm'
120 character(4),
parameter :: code_clear = code_start//
'0'//code_end
122 character(17),
parameter :: styles(1:2, 1:16) = reshape([ &
124 'ITALICS_ON ',
'3 ', &
125 'UNDERLINE_ON ',
'4 ', &
126 'INVERSE_ON ',
'7 ', &
127 'STRIKETHROUGH_ON ',
'9 ', &
128 'BOLD_OFF ',
'22 ', &
129 'ITALICS_OFF ',
'23 ', &
130 'UNDERLINE_OFF ',
'24 ', &
131 'INVERSE_OFF ',
'27 ', &
132 'STRIKETHROUGH_OFF',
'29 ', &
133 'FRAMED_ON ',
'51 ', &
134 'ENCIRCLED_ON ',
'52 ', &
135 'OVERLINED_ON ',
'53 ', &
136 'FRAMED_OFF ',
'54 ', &
137 'ENCIRCLED_OFF ',
'54 ', &
138 'OVERLINED_OFF ',
'55 ' &
141 character(15),
parameter :: colors_fg(1:2, 1:17) = reshape([ &
151 'BLACK_INTENSE ',
'90 ', &
152 'RED_INTENSE ',
'91 ', &
153 'GREEN_INTENSE ',
'92 ', &
154 'YELLOW_INTENSE ',
'93 ', &
155 'BLUE_INTENSE ',
'94 ', &
156 'MAGENTA_INTENSE',
'95 ', &
157 'CYAN_INTENSE ',
'96 ', &
158 'WHITE_INTENSE ',
'97 ' &
161 character(15),
parameter :: colors_bg(1:2, 1:17) = reshape([ &
171 'BLACK_INTENSE ',
'100 ', &
172 'RED_INTENSE ',
'101 ', &
173 'GREEN_INTENSE ',
'102 ', &
174 'YELLOW_INTENSE ',
'103 ', &
175 'BLUE_INTENSE ',
'104 ', &
176 'MAGENTA_INTENSE',
'105 ', &
177 'CYAN_INTENSE ',
'106 ', &
178 'WHITE_INTENSE ',
'107 ' &
186 module procedure :: render_diagnostic
187 module procedure :: render_text
188 module procedure :: render_text_with_label
189 module procedure :: render_text_with_labels
193 enumerator :: LEVEL_ERROR = 0
194 enumerator :: LEVEL_WARNING = 1
195 enumerator :: LEVEL_HELP = 2
196 enumerator :: LEVEL_NOTE = 3
197 enumerator :: LEVEL_INFO = 4
248 integer,
allocatable :: level
258 character(:),
allocatable :: text
260 character(:),
allocatable :: source
264 module procedure :: label_new
265 module procedure :: label_new_with_line
273 character(:),
allocatable :: message
275 character(:),
allocatable :: source
283 module procedure diagnostic_new
288 integer :: first, last
298 pure function colorize(string, foreground, background, style)
result(res)
299 character(*),
intent(in) :: string
300 character(*),
intent(in),
optional :: foreground
301 character(*),
intent(in),
optional :: background
302 character(*),
intent(in),
optional :: style
303 character(:),
allocatable :: res
309 if (
present(foreground))
then
310 i = color_index(upper(foreground))
311 if (i > 0) res = code_start//trim(colors_fg(2, i))//code_end//res//code_clear
313 if (
present(background))
then
314 i = color_index(upper(background))
315 if (i > 0) res = code_start//trim(colors_bg(2, i))//code_end//res//code_clear
317 if (
present(style))
then
318 i = style_index(upper(style))
319 if (i > 0) res = code_start//trim(styles(2, i))//code_end//res//code_clear
327 elemental integer function color_index(color)
result(res)
328 character(*),
intent(in) :: color
333 do i = 1,
size(colors_fg, dim=2)
334 if (trim(colors_fg(1, i)) == trim(adjustl(color)))
then
342 elemental integer function style_index(style)
result(res)
343 character(*),
intent(in) :: style
348 do i = 1,
size(styles, dim = 2)
349 if (trim(styles(1, i)) == trim(adjustl(style)))
then
357 elemental function upper(string)
358 character(*),
intent(in) :: string
359 character(len(string)) :: upper
361 integer,
parameter :: a = iachar(
'a'), z = iachar(
'z'), case_diff = iachar(
'a')-iachar(
'A')
364 do i = 1, len(string)
365 ichar = iachar(string(i:i))
366 if (ichar >= a .and. ichar <= z) ichar = ichar - case_diff
367 upper(i:i) = achar(ichar)
371 type(
label_type)
pure function label_new(text, first, length, level) result(that)
372 character(*),
intent(in) :: text
373 integer,
intent(in) :: first
374 integer,
intent(in) :: length
375 integer,
intent(in) ,
optional :: level
379 that%first = max(1, first)
380 that%last = that%first + length
381 that%primary = .true.
382 if (
present(level)) that%level = level
385 type(
label_type)
pure function label_new_with_line(line, text, first, length, primary, level) result(that)
386 integer,
intent(in) :: line
387 character(*),
intent(in) :: text
388 integer,
intent(in) :: first
389 integer,
intent(in) :: length
390 logical,
intent(in),
optional :: primary
391 integer,
intent(in) ,
optional :: level
395 that%first = max(1, first)
396 that%last = that%first + length
397 if (
present(primary))
then
398 that%primary = primary
400 that%primary = .true.
402 if (
present(level)) that%level = level
411 type(
diagnostic_report) function diagnostic_new(level, message, source, label, diagnostic) result(that)
412 integer,
intent(in) :: level
413 character(*),
intent(in),
optional :: message
414 character(*),
intent(in),
optional :: source
415 type(
label_type),
intent(in),
optional :: label(..)
421 if (
present(message)) that%message = message
422 if (
present(source)) that%source = source
423 if (
present(label))
then
424 if (
allocated(that%label))
deallocate(that%label)
427 allocate(that%label(1))
428 that%label(1) = label
429 if (.not.
allocated(that%label(1)%level)) that%label(1)%level = level
431 allocate(that%label, source = label)
432 do i = 1,
size(label)
433 if (.not.
allocated(that%label(i)%level)) that%label(i)%level = level
437 if (
present(diagnostic)) that%sub = diagnostic
439 if (
allocated(that%label))
then
440 if (.not. any(that%label(:)%primary))
then
441 that%label(1)%primary = .true.
446 pure function line_tokens(input)
result(res)
447 character(*),
intent(in) :: input
450 integer :: first, last
455 do while (first <= len(input))
456 last = index(input(first + 1:), nl) + first - 1
457 if (last < first)
then
463 first = last + (1 + len(nl))
467 pure recursive function render_diagnostic(diag, input, linemum)
result(res)
469 character(*),
intent(in) :: input
470 integer,
intent(in),
optional :: linemum
471 character(:),
allocatable :: res
475 res = render_message(diag%level, diag%message)
477 if (
allocated(diag%label))
then
478 res = res // nl // render_text_with_labels(input, diag%label, source=diag%source, linemum=linemum)
480 res = res // nl // render_text_with_labels(input, [
label_type(
'', 1, len_trim(input))], source=diag%source, linemum=linemum)
483 if (
allocated(diag%sub))
then
484 do i = 1,
size(diag%sub)
485 res = res // nl // render_diagnostic(diag%sub(i), input, linemum)
490 pure function render_message(level, message)
result(res)
491 integer,
intent(in) :: level
492 character(*),
intent(in),
optional :: message
493 character(:),
allocatable :: res
495 if (
present(message))
then
496 res = level_name(level) // colorize(
': ' // message, style =
'bold_on')
498 res = level_name(level)
502 pure function level_name(level)
result(res)
503 integer,
intent(in) :: level
504 character(:),
allocatable :: res
508 res = colorize(
'error', foreground =
'red', style =
'bold_on')
510 res = colorize(
'warning', foreground =
'yellow', style =
'bold_on')
512 res = colorize(
'help', foreground =
'cyan', style =
'bold_on')
514 res = colorize(
'note', foreground =
'blue', style =
'bold_on')
516 res = colorize(
'info', foreground =
'magenta', style =
'bold_on')
518 res = colorize(
'unknown', foreground =
'blue', style =
'bold_on')
522 pure function render_source(source, offset)
result(res)
523 character(*),
intent(in) :: source
524 integer,
intent(in) :: offset
525 character(:),
allocatable :: res
527 res = repeat(
' ', offset) // colorize(
'-->', foreground =
'blue') //
' ' // source
530 pure function render_text(input, source, linenum)
result(res)
531 character(*),
intent(in) :: input
532 character(*),
intent(in),
optional :: source
533 integer,
intent(in),
optional :: linenum
534 character(:),
allocatable :: res
536 integer :: i, offset, iline
539 iline = 1;
if (
present(linenum)) iline = linenum
540 token = line_tokens(input)
541 offset = integer_width(iline)
543 if (
present(source))
then
544 res = render_source(source, offset) // nl // &
545 repeat(
' ', offset + 1) // colorize(
'|', foreground =
'blue')
547 res = repeat(
' ', offset + 1) // colorize(
'|', foreground =
'blue')
550 do i = 1,
size(token)
551 res = res // nl // render_line(input(token(i)%first:token(i)%last), to_string(iline + i - 1, offset))
553 res = res // nl // repeat(
' ', offset + 1) // colorize(
'|', foreground =
'blue')
556 pure function render_text_with_label(input, label, source, linenum)
result(res)
557 character(*),
intent(in) :: input
559 character(*),
intent(in),
optional :: source
560 integer,
intent(in),
optional :: linenum
561 character(:),
allocatable :: res
563 res = render_text_with_labels(input, [label], source, linenum)
566 pure function render_text_with_labels(input, labels, source, linemum)
result(res)
567 character(*),
intent(in) :: input
569 character(*),
intent(in),
optional :: source
570 integer,
intent(in),
optional :: linemum
571 character(:),
allocatable :: res
573 integer :: i, j, offset, first, last, iline
575 logical,
allocatable :: display(:)
577 token = line_tokens(input)
578 first = max(1, minval(labels%line) - 1)
579 last = min(
size(token), maxval(labels%line) + 1)
580 iline = 1;
if (
present(linemum)) iline = linemum
581 offset = integer_width(iline)
584 do j = 1,
size(labels)
585 if (labels(j)%primary)
then
591 if (
present(source))
then
592 res = render_source(source, offset) //
':' // &
593 to_string(labels(i)%line) //
':' // &
594 to_string(labels(i)%first) //
'-' // to_string(labels(i)%last) // nl // &
595 repeat(
' ', offset + 1) // colorize(
'|', foreground =
'blue')
597 res = repeat(
' ', offset + 1) // colorize(
'|', foreground =
'blue')
600 allocate(display(first:last), source=.false.)
601 do j = 1,
size(labels)
602 display(max(first, labels(j)%line - 1):min(last, labels(j)%line + 1)) = .true.
606 if (.not. display(i))
then
607 if (display(i - 1))
then
609 repeat(
' ', offset + 1) // colorize(
':', foreground =
'blue')
615 & render_line(input(token(i)%first:token(i)%last), &
616 & to_string(iline + i - 1, offset))
617 if (any(i == labels%line))
then
618 do j = 1,
size(labels)
619 if (labels(j)%line /= i) cycle
621 & repeat(
' ', offset + 1) // colorize(
'|', foreground =
'blue') // &
622 & render_label(labels(j))
626 res = res // nl // repeat(
' ', offset + 1) // colorize(
'|', foreground =
'blue')
629 pure function render_label(label)
result(res)
631 character(:),
allocatable :: res
634 character(1) :: marker
635 character(:),
allocatable :: this_color
637 marker = merge(
'^',
'-', label%primary)
638 width = label%last - label%first
640 if (
allocated(label%level))
then
641 select case (label%level)
643 res = repeat(
' ', label%first) // colorize(repeat(marker, width), foreground =
'red')
644 if (
allocated(label%text))
then
645 res = res //
' ' // colorize(label%text, foreground =
'red')
648 res = repeat(
' ', label%first) // colorize(repeat(marker, width), foreground =
'yellow')
649 if (
allocated(label%text))
then
650 res = res //
' ' // colorize(label%text, foreground =
'yellow')
653 res = repeat(
' ', label%first) // colorize(repeat(marker, width), foreground =
'cyan')
654 if (
allocated(label%text))
then
655 res = res //
' ' // colorize(label%text, foreground =
'cyan')
658 res = repeat(
' ', label%first) // colorize(repeat(marker, width), foreground =
'magenta')
659 if (
allocated(label%text))
then
660 res = res //
' ' // colorize(label%text, foreground =
'magenta')
663 res = repeat(
' ', label%first) // colorize(repeat(marker, width), foreground =
'blue')
664 if (
allocated(label%text))
then
665 res = res //
' ' // colorize(label%text, foreground =
'blue')
669 res = repeat(
' ', label%first) // repeat(marker, width)
670 if (
allocated(label%text))
then
671 res = res //
' ' // colorize(label%text, foreground =
'blue')
676 pure function render_line(input, line)
result(res)
677 character(*),
intent(in) :: input
678 character(*),
intent(in) :: line
679 character(:),
allocatable :: res
681 res = line //
' ' // colorize(
'|', foreground =
'blue') //
' ' // input
684 pure integer function integer_width(input)
result(res)
685 integer,
value :: input
688 do while (input /= 0)
696 pure function to_string(val, width)
result(res)
697 integer,
intent(in) :: val
698 integer,
intent(in),
optional :: width
699 character(:),
allocatable :: res
701 integer,
parameter :: buffer_len = range(val) + 2
702 character(buffer_len) :: buffer
704 character(1),
parameter :: numbers(0:9) = [
'0',
'1',
'2',
'3',
'4',
'5',
'6',
'7',
'8',
'9']
717 buffer(pos:pos) = numbers(mod(n, 10))
722 buffer(pos:pos) =
'-'
725 if (
present(width))
then
726 res = repeat(
' ', max(width - (buffer_len + 1 - pos), 0)) // buffer(pos:)
735 subroutine printf(str, fmt)
736 character(*),
intent(in) :: str
737 character(*),
intent(in),
optional :: fmt
740 if (
present(fmt))
then
logical, public nocolor
Switch for controling the ANSI color output Default value is .true. (color mode on)....
logical, public verbose
Master switch for verbose diagnostic output Default value is .false. (quiet mode)....
Interface to render diagnostic messages and labels.
Definition of diagnostic message.
Represents text as a sequence of ASCII code units. The derived type wraps an allocatable character ar...