guile-website-example/app/templates/nav.scm

(library (templates nav)
  (export nav-template)
  (import
    (except (rnrs base) let-values error)
    (only (guile)
          lambda* λ
          simple-format
          current-output-port)
    ;; exception handling
    (ice-9 exceptions)
    (prefix (srfi srfi-1) srfi-1:)
    ;; for functional structs (not part of srfi-9 directly)
    (srfi srfi-9 gnu)
    ;; standard web library
    (web request)
    (web response)
    (web uri)
    ;; web location
    (lib web-location-handling)
    (lib utils request-utils)
    (lib utils url-utils)))


(define-immutable-record-type <nav-link>
  ;; define constructor
  (construct-nav-link label slugs)
  ;; define predicate
  nav-link?
  ;; define accessors and functional setters
  (label nav-link-label)
  (slugs nav-link-slugs))


(define make-nav-link
  (λ (label slugs)
    (cond
     [(not (string? label))
      (raise-exception
       (make-exception
        (make-non-continuable-error)
        (make-exception-with-message "nav link label not given as string")
        (make-exception-with-irritants (list label))
        (make-exception-with-origin 'make-nav-link)))]
     [(not (list? slugs))
      (raise-exception
       (make-exception
        (make-non-continuable-error)
        (make-exception-with-message "nav link slugs not given as list")
        (make-exception-with-irritants (list slugs))
        (make-exception-with-origin 'make-nav-link)))]
     [else (construct-nav-link label slugs)])))


(define nav-link-main-ref
  (λ (nav-link)
    (srfi-1:first (nav-link-slugs nav-link))))


(define nav-links
  (list (make-nav-link "Home" '("/" "/home"))
        (make-nav-link "Schedule" '("/schedule"))
        (make-nav-link "Resources" '("/resources"))
        (make-nav-link "About" '("/about"))))


(define nav-logo-template
  (λ (request body)
    `(div (@ (class "dd-nav-logo"))
          #;(img (@ (src ,(static-asset-location '("img" "logo" "dragon-descendants-logo.png"))))))))


(define nav-link-template
  (lambda* (label reference #:key (active #f))
    `(li (@ (class ,(if active "active" "inactive")))
         (a (@ (href ,reference))
            (span ,label)))))


(define nav-link-active?
  (λ (request nav-link)
    "Check whether the slug of the request matches any associated slug of the
navigation link, to determin, whether the navigation link is the active link."
    (let ([req-path-comps (request-path-components request)]
          [link-slugs (nav-link-slugs nav-link)])
      ;; fold over all associated slugs of the link to check if any one is
      ;; matching the currently requested route
      (srfi-1:fold
       ;; proc
       (λ (link-slug acc)
         (or (equal? req-path-comps (url-slug-components link-slug))
             acc))
       ;; init
       #f
       ;; list
       link-slugs))))


(define nav-links-template
  (λ (request body)
    ;; render single links
    (map (λ (nav-link)
           (nav-link-template (nav-link-label nav-link)
                              (nav-link-main-ref nav-link)
                              #:active (nav-link-active? request nav-link)))
         nav-links)))


(define nav-template
  (λ (request body)
    `((nav (@ (class "nav nav-outer-cluster"))
           ;; the outer cluster contains a list of the logo and the inner cluster
           (ul
            (li
             ,(nav-logo-template request body))
            (li
             (div (@ (class "nav-menu nav-inner-cluster"))
                  ;; the inner cluster contains the navigation menu items
                  (ul
                   ,@(nav-links-template request body)))))))))