(module rml mzscheme
(require (lib "framework.ss" "framework")
(lib "mred.ss" "mred")
(lib "class.ss")
(lib "match.ss")
(lib "pretty.ss")
"interfaces.ss"
"rml-styles.ss")
(provide insert-text
rml:text%
ext:text-mixin
rml:text-mixin
rml:text:display-mixin)
(define (insert-text e text style)
(let ([a (send e last-position)])
(send e insert text)
(let ([b (send e last-position)])
(send e change-style style a b))))
(define text<%> (class->interface text%))
(define ext:text-mixin
(mixin (text<%>) (ext:text<%>)
(super-new)
(inherit last-position
change-style
set-clickback
insert)
(define/public (text-insert text styles)
(let ([a (last-position)])
(insert text)
(let ([b (last-position)])
(for-each (lambda (style) (change-style style a b))
(reverse styles)))))
(define/public (text-insert/click text clickback styles)
(let ([a (last-position)])
(insert text)
(let ([b (last-position)])
(for-each (lambda (style) (change-style style a b))
(reverse styles))
(set-clickback a b clickback))))
))
(define-syntax (class:open stx)
(syntax-case stx ()
[(class:open var (method ...))
(with-syntax ([begin (datum->syntax-object stx 'begin)]
[define (datum->syntax-object stx 'define)])
#'(begin (define (method . args)
(send var method . args))
...))]))
(define rml:text-mixin
(mixin (text<%> ext:text<%>) (rml:text<%>)
(init-field (style-map basic-style-map)
(editor% base-editor%)
(box-editor% base-box-editor%)
(box-snip% base-box-snip%))
(inherit insert
text-insert
text-insert/click
get-canvas
set-styles-sticky
set-autowrap-bitmap)
(super-instantiate () (auto-wrap #t))
(set-styles-sticky #f)
(set-autowrap-bitmap #f)
(class:open style-map (get-style))
(define/public (render rml tail?)
(render-top-level
rml
tail?
(list (get-style 'normal))))
(define/public (render-top-level rml tail? styleset)
(match rml
[('div (styles ...) bodies ...)
(let ([new-styleset (append (map ->style styles) styleset)])
(for-each/tail
(lambda (b) (render-top-level b #f new-styleset))
(lambda (b) (render-top-level b tail? new-styleset))
bodies)
(unless tail? (render-newline)))]
[('wide-box bodies ...)
(let* [(seditor (instantiate rml:text% () (style-map style-map)))
(snip (instantiate editor-snip% () (editor seditor)))]
(send seditor set-autowrap-bitmap #f)
(for-each/tail
(lambda (body) (send seditor render-top-level body #f styleset))
(lambda (body) (send seditor render-top-level body #t styleset))
bodies)
(let [(canvas (get-canvas))]
(when (is-a? canvas canvas:wide-snip<%>)
(send canvas add-wide-snip snip)))
(insert snip)
(send seditor lock #t))]
[('box bodies ...)
(let* [(seditor (instantiate rml:text% ()
(auto-wrap #t) (style-map style-map)))
(snip (instantiate box-snip% () (editor seditor)))]
(send seditor set-autowrap-bitmap #f)
(for-each/tail
(lambda (body) (send seditor render-inline body #f styleset))
(lambda (body) (send seditor render-inline body #t styleset))
bodies)
(insert snip)
(send seditor lock #t))]
[_
(render-inline rml styleset)]))
(define/public (render-inline rml styleset)
(match rml
[('span (styles ...) bodies ...)
(let ([new-styleset (append (map ->style styles) styleset)])
(for-each (lambda (b) (render-inline b new-styleset))
bodies))]
[('link callback (styles ...) item0)
(let ([new-styleset (append (map ->style styles) styleset)])
(text-insert/click item0 callback new-styleset))]
[('pretty value)
(let ([oport (open-output-string)])
(pretty-print value oport)
(text-insert (get-output-string oport) styleset))]
[(? string? string)
(text-insert string styleset)]
[(? number? v)
(text-insert (number->string v) styleset)]
[(? symbol? v)
(text-insert (symbol->string v) styleset)]
[(? (lambda (p) (is-a? p snip%)) snip)
(text-insert snip styleset)]))
(define/private (render-newline)
(text-insert "\n" (list (get-style 'normal))))
(define/private (for-each/tail p-rep p-ult items)
(cond [(null? items) (void)]
[(and (pair? items) (null? (cdr items)))
(p-ult (car items))]
[else
(p-rep (car items))
(for-each/tail p-rep p-ult (cdr items))]))
(define (->style value)
(cond [(symbol? value)
(get-style value)]
[else value]))
))
(define rml:text:display-mixin
(mixin (text<%> text:wide-snip<%> rml:text<%>) (rml:text:display<%>)
(super-instantiate ())
(inherit begin-edit-sequence
end-edit-sequence
get-start-position
erase
find-snip
scroll-to
scroll-to-position
render)
(define/public (display rml)
(display* rml #f))
(define/public (display/tail rml)
(display* rml #t))
(define/private (display* rml tail?)
(let [(saved-position (get-start-position))]
(begin-edit-sequence #f)
(erase)
(render rml tail?)
(end-edit-sequence)
(scroll-to-position 0)))
(define/public (append rml)
(append* rml #f))
(define/public (append/tail rml)
(append* rml #t))
(define/private (append* rml tail?)
(render rml tail?))))
(define rml:text%
(rml:text:display-mixin
(rml:text-mixin
(text:wide-snip-mixin
(ext:text-mixin
text:hide-caret/selection%)))))
(define base-editor% rml:text%) (define base-box-editor% rml:text%) (define base-box-snip% editor-snip%)
)