library/platform/jvm/listener.factor

   1 ! :folding=indent:collapseFolds=1:
   2
   3 ! $Id$
   4 !
   5 ! Copyright (C) 2003, 2004 Slava Pestov.
   6 !
   7 ! Redistribution and use in source and binary forms, with or without
   8 ! modification, are permitted provided that the following conditions are met:
   9 !
  10 ! 1. Redistributions of source code must retain the above copyright notice,
  11 !    this list of conditions and the following disclaimer.
  12 !
  13 ! 2. Redistributions in binary form must reproduce the above copyright notice,
  14 !    this list of conditions and the following disclaimer in the documentation
  15 !    and/or other materials provided with the distribution.
  16 !
  17 ! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
  18 ! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
  19 ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  20 ! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  21 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
  22 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
  23 ! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  24 ! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  25 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
  26 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  27
  28 IN: listener
  29 USE: combinators
  30 USE: continuations
  31 USE: interpreter
  32 USE: kernel
  33 USE: lists
  34 USE: namespaces
  35 USE: stack
  36 USE: stdio
  37 USE: styles
  38 USE: streams
  39 USE: strings
  40 USE: unparser
  41
  42 : <attribute-set> ( -- attribute-set )
  43     [ ] "javax.swing.text.SimpleAttributeSet" jnew ;
  44
  45 : attribute+ ( attribute-set value key -- )
  46     transp
  47     [ "java.lang.Object" "java.lang.Object" ]
  48     "javax.swing.text.SimpleAttributeSet"
  49     "addAttribute" jinvoke ;
  50
  51 : style-constant ( name -- key )
  52     #! javax.swing.text.StyleConstants contains static variables
  53     #! which key in an AttributeSet.
  54     "javax.swing.text.StyleConstants" swap jvar-static-get
  55     ; inline
  56
  57 : swing-attribute+ ( attribute-set value key -- )
  58     style-constant attribute+ ;
  59
  60 : >color ( triplet -- hex )
  61     uncons uncons uncons drop
  62     [ "int" "int" "int" ]
  63     "java.awt.Color"
  64     jnew ;
  65
  66 : link-key ( -- attr )
  67     "factor.listener.FactorListener" "Link" jvar-static-get
  68     ; inline
  69
  70 : obj>listener-link ( obj -- link )
  71     #! Listener links are quotations.
  72     dup string? [
  73         ! Inspector link.
  74         unparse " describe-object-path" cat2
  75     ] when ;
  76
  77 : link-attribute ( attribute-set target -- )
  78     [ dup t "Underline" swing-attribute+ ] dip
  79     obj>listener-link link-key attribute+ ;
  80
  81 : style>attribute-set ( -- attribute-set )
  82     <attribute-set>
  83     "link" get [ dupd link-attribute ] when*
  84     "bold" get [ dup t "Bold" swing-attribute+ ] when
  85     "italics" get [ dup t "Italic" swing-attribute+ ] when
  86     "underline" get [ dup t "Underline" swing-attribute+ ] when
  87     "fg" get [ dupd >color "Foreground" swing-attribute+ ] when*
  88     "bg" get [ dupd >color "Background" swing-attribute+ ] when*
  89     "font" get [ dupd "FontFamily" swing-attribute+ ] when*
  90     "size" get [ dupd "FontSize" swing-attribute+ ] when* ;
  91
  92 : reset-attrs ( -- )
  93     default-style [ style>attribute-set ] bind t
  94     "listener" get
  95     [ "javax.swing.text.AttributeSet" "boolean" ]
  96     "javax.swing.JTextPane"
  97     "setCharacterAttributes"
  98     jinvoke ;
  99
 100 : listener-readln* ( continuation -- )
 101     "listener" get
 102         [ "factor.Cons" ]
 103         "factor.listener.FactorListener"
 104         "readLine" jinvoke ;
 105
 106 : listener-readln ( -- line )
 107     reset-attrs [ listener-readln* suspend ] callcc1 ;
 108
 109 : listener-write-attr ( string -- )
 110     style>attribute-set "listener" get
 111     [ "java.lang.String" "javax.swing.text.AttributeSet" ]
 112     "factor.listener.FactorListener"
 113     "insertWithAttrs"
 114     jinvoke ;
 115
 116 : listener-write ( string -- )
 117     default-style [ listener-write-attr ] bind ;
 118
 119 !: listener-edit ( string -- )
 120 !    "listener" get
 121 !    [ "java.lang.String" ]
 122 !    "factor.listener.FactorListener"
 123 !    "editLine" jinvoke ;
 124
 125 : <listener-stream> ( listener -- stream )
 126     #! Creates a stream for reading/writing to the given
 127     #! listener instance.
 128     <stream> [
 129         "listener" set
 130         ( -- string )
 131         [ listener-readln ] "freadln" set
 132         ( string -- )
 133         [ listener-write ] "fwrite" set
 134         ( string -- )
 135         [ listener-write-attr ] "fwrite-attr" set
 136         ( string -- )
 137         ![ listener-edit ] "fedit" set
 138         ( -- )
 139         [ ] "fflush" set
 140         ( -- )
 141         [ ] "fclose" set
 142         ( string -- )
 143         [ this fwrite "\n" this fwrite ] "fprint" set
 144     ] extend ;
 145
 146 : new-listener-hook ( listener -- )
 147     #! Called when user opens a new listener
 148     <namespace> [
 149         dup "listener" set
 150         <listener-stream> "stdio" set
 151         print-banner
 152         room.
 153         interpreter-loop
 154     ] bind ;