rose-ash/lib/guest/layout.sx

;; lib/guest/layout.sx — configurable off-side / layout-sensitive lexer.
;;
;; Inserts virtual open / close / separator tokens based on indentation.
;; Configurable enough to encode either the Haskell 98 layout rule (let /
;; where / do / of opens a virtual brace at the next token's column) or
;; a Python-ish indent / dedent rule (a colon at the end of a line opens
;; a block at the next non-blank line's column).
;;
;; Token shape (input + output)
;; ----------------------------
;; Each token is a dict {:type :value :line :col …}. The kit reads
;; only :type / :value / :line / :col and passes everything else
;; through. The input stream MUST be free of newline filler tokens
;; (preprocess them away with your tokenizer) — line breaks are detected
;; by comparing :line of consecutive tokens.
;;
;; Config
;; ------
;;   :open-keywords    list of strings; a token whose :value matches
;;                     opens a new layout block at the next token's
;;                     column (Haskell: let/where/do/of).
;;   :open-trailing-fn (fn (tok) -> bool) — alternative trigger that
;;                     fires AFTER the token is emitted. Use for
;;                     Python-style trailing `:`.
;;   :open-token / :close-token / :sep-token
;;                     templates {:type :value} merged with :line and
;;                     :col when virtual tokens are emitted.
;;   :explicit-open?   (fn (tok) -> bool) — if the next token after a
;;                     trigger satisfies this, suppress virtual layout
;;                     for that block (Haskell: `{`).
;;   :module-prelude?  if true, wrap whole input in an implicit block
;;                     at the first token's column (Haskell yes,
;;                     Python no).
;;
;; Public entry
;; ------------
;;   (layout-pass cfg tokens) -> tokens with virtual layout inserted.

(define
  layout-mk-virtual
  (fn (template line col)
    (assoc (assoc template :line line) :col col)))

(define
  layout-is-open-kw?
  (fn (tok open-kws)
    (and (= (get tok :type) "reserved")
         (some (fn (k) (= k (get tok :value))) open-kws))))

(define
  layout-pass
  (fn (cfg tokens)
    (let ((open-kws (get cfg :open-keywords))
          (trailing-fn (get cfg :open-trailing-fn))
          (open-tmpl (get cfg :open-token))
          (close-tmpl (get cfg :close-token))
          (sep-tmpl (get cfg :sep-token))
          (mod-prelude? (get cfg :module-prelude?))
          (expl?-fn (get cfg :explicit-open?))
          (out (list))
          (stack (list))
          (n (len tokens))
          (i 0)
          (prev-line -1)
          (pending-open false)
          (just-opened false))
      (define
        emit-closes-while-greater
        (fn (col line)
          (when (and (not (empty? stack)) (> (first stack) col))
            (do
              (append! out (layout-mk-virtual close-tmpl line col))
              (set! stack (rest stack))
              (emit-closes-while-greater col line)))))
      (define
        emit-pending-open
        (fn (line col)
          (do
            (append! out (layout-mk-virtual open-tmpl line col))
            (set! stack (cons col stack))
            (set! pending-open false)
            (set! just-opened true))))
      (define
        layout-step
        (fn ()
          (when (< i n)
            (let ((tok (nth tokens i)))
              (let ((line (get tok :line)) (col (get tok :col)))
                (cond
                  (pending-open
                    (cond
                      ((and (not (= expl?-fn nil)) (expl?-fn tok))
                        (do
                          (set! pending-open false)
                          (append! out tok)
                          (set! prev-line line)
                          (set! i (+ i 1))
                          (layout-step)))
                      (:else
                        (do
                          (emit-pending-open line col)
                          (layout-step)))))
                  (:else
                    (let ((on-fresh-line? (and (> prev-line 0) (> line prev-line))))
                      (do
                        (when on-fresh-line?
                          (let ((stack-before stack))
                            (begin
                              (emit-closes-while-greater col line)
                              (when (and (not (empty? stack))
                                         (= (first stack) col)
                                         (not just-opened)
                                         ;; suppress separator if a dedent fired
                                         ;; — the dedent is itself the separator
                                         (= (len stack) (len stack-before)))
                                (append! out (layout-mk-virtual sep-tmpl line col))))))
                        (set! just-opened false)
                        (append! out tok)
                        (set! prev-line line)
                        (set! i (+ i 1))
                        (cond
                          ((layout-is-open-kw? tok open-kws)
                            (set! pending-open true))
                          ((and (not (= trailing-fn nil)) (trailing-fn tok))
                            (set! pending-open true)))
                        (layout-step))))))))))
      (begin
        ;; Module prelude: implicit layout block at the first token's column.
        (when (and mod-prelude? (> n 0))
          (let ((tok (nth tokens 0)))
            (do
              (append! out (layout-mk-virtual open-tmpl (get tok :line) (get tok :col)))
              (set! stack (cons (get tok :col) stack))
              (set! just-opened true))))
        (layout-step)
        ;; EOF: close every remaining block.
        (define close-rest
          (fn ()
            (when (not (empty? stack))
              (do
                (append! out (layout-mk-virtual close-tmpl 0 0))
                (set! stack (rest stack))
                (close-rest)))))
        (close-rest)
        out))))