plt/gui/rml.ss
(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)
   
#|
RML ::= ('div (Style ...) RML ...)
      | ('wide-box RML ...)
      | ('collapse-box RML ...)
      | ('box RML ...)
      | ('hrule)
      | Inline

Inline ::= ('span (Style ...) Inline ...)
         | ('link CallbackProcedure (Style ...) Inline)
         | ('pretty value)
         | String | Symbol | Number
         | Snip
|#

  ;; insert-text : text% string style-delta% -> void
  (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)
      
      ;; text-insert : string (list-of style-delta%) -> void
      ;; A list of styles to be applied. The first style is the last applied.
      (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)))))
      
      ;; text-insert/click : string (?? -> void) (list-of style-delta%) -> void
      (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))
      
      ;; Change defaults.
      (set-styles-sticky #f)
      (set-autowrap-bitmap #f)

      ;; Import get-style from style-map
      (class:open style-map (get-style))
      
      ;; render : RML boolean -> void
      (define/public (render rml tail?)
        (render-top-level 
         rml 
         tail? 
         (list (get-style 'normal))))
      
      ;; render-top-level : RML boolean (list-of style-delta%) -> void
      (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))]
;          [('hrule)
;           (insert (instantiate hrule-snip% ()))]
;          [('collapse-box collapsed expanded)
;           (let [(s (instantiate collapse-box-snip% ()
;                      (renderer this)
;                      (collapsed-rml collapsed)
;                      (expanded-rml expanded)))]
;             (send text insert s))]
          [_
           (render-inline rml styleset)]))
      
      ;; render-inline : RML (list-of style-delta%) -> void
      (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)]))

      ;; render-newline : -> void
      (define/private (render-newline)
        (text-insert "\n" (list (get-style 'normal))))

      ;; for-each/tail : ('a -> void) ('a -> void) (list-of 'a) -> void
      (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))]))

      ;; ->style : (union symbol style-delta%) -> style-delta%
      (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-display/canvas%
;    (class* rml-display% (rml-display<%>)
;      (init parent
;            (renderer base-editor-renderer))
;      (inherit-field -text)
;      (super-instantiate ()
;        (renderer renderer)
;        (text (send renderer build-editor)))
;      (define canvas
;        (instantiate canvas:wide-snip% ()
;          (editor -text) (parent parent)))
;      ))
; 
;  (define rml-display/snip%
;    (class* rml-display% (rml-display<%>)
;      (public get-snip)
;      (init (renderer base-editor-renderer))
;      (inherit-field -text)
;      (super-instantiate ()
;        (renderer renderer) (text (send renderer build-editor)))
;      (define snip
;        (instantiate editor-snip% () (editor -text)))
;      (define (get-snip) snip)))
  
  (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%) ;;text:hide-caret/selection%
  (define base-box-editor% rml:text%) ;; % base-editor%
  (define base-box-snip% editor-snip%)
  )

;(require (lib "class.ss")
;           (lib "framework.ss" "framework")
;           (lib "mred.ss" "mred")
;           rml)
;(begin (define ed% (rml:text:display-mixin (rml:text-mixin (ext:text-mixin text%))))
;       (define ed (instantiate ed% () (box-editor% ed%)))
;       (define frame (instantiate frame% () (label "Testing")))
;       (define view (instantiate editor-canvas% () (parent frame) (editor ed)))
;       (send frame show #t))
;
;(send ed append
;      '(div () "foo bwah ha"))
;(send ed append
;      '(div (blue) "I'm in blue!"))
;(send ed append
;      '(div ()
;            (wide-box (span (red) "whee!"))))