src/plugins/old/curses.slate

   1 terminals define: #CursesConsole &parents: {StructuredConsole}.
   2
   3 CursesConsole traits `>> [
   4   define: #Lib &builder:
   5     [ExternalInterface newForLibrary: 'ncurses-console' primitives:
   6      q{(Boolean isAvailable          ())
   7         (Boolean enterStructuredMode  ())
   8         (Boolean leaveStructuredMode  ())
   9         (CString keySequenceOf        (CString))
  10         (Int     columns              ())
  11         (Int     rows                 ())
  12         (Boolean write                (Bytes Int Int))
  13         (Boolean clear                ())
  14         (Boolean clearToEOS           ())
  15         (Boolean clearToEOL           ())
  16         (Boolean scroll               (Int))
  17         (Boolean moveToXY             (Int Int))
  18         (Int     cursorX              ())
  19         (Int     cursorY              ())
  20         (Int     nextEvent            (Int))
  21         (Boolean hasEvent             ())
  22         (Boolean flush                ())
  23         (Boolean deleteChar           ())
  24         (Boolean deleteLines          (Int))
  25         (Boolean insertLines          (Int))
  26         (Int     hideCursor           ())
  27         (Int     showCursor           ())
  28         (Void    setAttributes        (Int Int))
  29         (Int     maxColorPairs        ())
  30         (Boolean initColorPair        (Int Int Int))
  31        } &leader: 'sc_'].
  32   addSlot: #maxColorPairs.
  33   addSlot: #currentColorPair.
  34   addSlot: #colorToPairs valued: Dictionary new.
  35
  36   "Create new prorotypes for the streams for methods we install on them"
  37   define: #EventStream &parents: {CursesConsole EventStream}.
  38   "define: #ReadStream &parents: {CursesConsole ReadStream}. we don't override anything for now"
  39   define: #WriteStream &parents: {CursesConsole WriteStream}.
  40   define: #ReadWriteStream &parents: {CursesConsole ReadStream. CursesConsole WriteStream}.
  41 ].
  42
  43 w@(CursesConsole WriteStream traits) next: n putAll: seq startingAt: start
  44 "Override the generic cursor tracking mechanism with reading the cursor position
  45 after the output"
  46 [| result c |
  47   result := resend.
  48   c := w resource.
  49   c moveCursorTo: {c actualCursorColumn. c actualCursorRow}.
  50   result
  51 ].
  52
  53 c@(CursesConsole traits) updateCursorPositionFrom: col@(Collection traits)
  54 [
  55   "Hide implementation, we will read the curses cursor position after the write"
  56 ].
  57
  58 _@(CursesConsole traits) elementType
  59 [Character].
  60
  61 _@(CursesConsole traits) collectionType
  62 [String].
  63
  64 c@(CursesConsole traits) isAvailable
  65 [
  66   c Lib enable.
  67   c Lib primitives isAvailable do
  68 ].
  69
  70 c@(CursesConsole traits) enterStructuredMode
  71 [
  72   (c Lib primitives enterStructuredMode do)
  73     ifTrue:
  74       [c maxColorPairs := c Lib primitives maxColorPairs do.
  75        c currentColorPair := 0.
  76        c colorToPairs := c colorToPairs new.
  77        c Lib primitives clear do.
  78        True]
  79     ifFalse:
  80       [error: 'Curses console plugin failed to switch to structured mode'.
  81        False]
  82 ].
  83
  84 c@(CursesConsole traits) leaveStructuredMode
  85 [| result |
  86   result := c Lib primitives leaveStructuredMode do.
  87   c Lib primitives slotNamesAndValuesDo: [| :name :value |
  88     (value is: ExternalMethod) ifTrue:
  89       [value close. c Lib primitives removeSlot: name]].
  90   c Lib disable.
  91   result
  92 ].
  93
  94 c@(CursesConsole traits) initKeyMappings
  95 [
  96   c keyCodeToKeyName clear.
  97   c sequenceToKeyName clear.
  98
  99   q{(UpArrow    'kcuu1')
 100     (DownArrow  'kcud1')
 101     (RightArrow 'kcuf1')
 102     (LeftArrow  'kcub1')
 103     (Home       'khome')
 104     (Insert     'kich1')
 105     (Delete     'kdch1')
 106     (End        'kend')
 107     (PageUp     'kpp')
 108     (PageDown   'knp')
 109
 110     (Enter      'kind' $\n)
 111     (Backspace  'kbs')
 112     (Tab        'ktab' $\t)
 113   } do: [| :entry keyName cursesName |
 114     keyName := entry first.
 115     cursesName := entry second.
 116
 117     (c Lib primitives keySequenceOf applyTo: {cursesName as: String})
 118       ifNil: [
 119         c ; 'Warning: Can\'t find TerminInfo entry for "' ; cursesName ; '" which is key "' ; keyName ; '"\n'.
 120         ]
 121       ifNotNilDo: [| :sequence char |
 122         entry size >= 3 ifTrue: [char := entry third].
 123         sequence size = 1
 124           ifTrue: [c keyCodeToKeyName at: (sequence first as: Integer) put: {keyName. char}]
 125           ifFalse: [
 126             sequence size = 2 /\ [sequence first = $^]
 127               ifTrue: [
 128                 c keyCodeToKeyName
 129                   at: ((sequence second as: Integer) bitOr: 2r01000000)
 130                   put: {keyName. char}]
 131               ifFalse: [| keyCode |
 132                 sequence size = 4 /\ [sequence first = $\\]
 133                   /\ [(keyCode := ((sequence copyFrom: 1) as: Integer &radix: 8)) ~= 0]
 134                     ifTrue: [c keyCodeToKeyName at: keyCode put: {keyName. Nil}]
 135                     ifFalse: [c sequenceToKeyName at: sequence put: keyName]]]].
 136   ].
 137
 138   "Add function keys"
 139   0 to: 63 do: [| :index indexStr |
 140     indexStr := (index as: String).
 141     (c Lib primitives keySequenceOf applyTo: {'kf' ; indexStr})
 142       ifNotNilDo: [| :sequence |
 143         c sequenceToKeyName at: sequence put: ('Function' ; indexStr as: Symbol)].
 144   ].
 145
 146   "Fill the holes with defaults"
 147   resend
 148 ].
 149
 150 "The exported primitives as methods"
 151
 152 c@(CursesConsole traits) actualColumns
 153 [
 154   c assumeStructuredMode.
 155   c Lib primitives columns do
 156 ].
 157
 158 c@(CursesConsole traits) actualRows
 159 [
 160   c assumeStructuredMode.
 161   c Lib primitives rows do
 162 ].
 163
 164 c@(CursesConsole traits) clear
 165 [
 166   c assumeStructuredMode.
 167   c Lib primitives clear do
 168 ].
 169
 170 c@(CursesConsole traits) clearToEOS
 171 [
 172   c assumeStructuredMode.
 173   c Lib primitives clearToEOS do
 174 ].
 175
 176 c@(CursesConsole traits) clearToEOL
 177 [
 178   c assumeStructuredMode.
 179   c Lib primitives clearToEOL do
 180 ].
 181
 182 c@(CursesConsole traits) moveCursorTo: pos
 183 [
 184   c assumeStructuredMode.
 185   c Lib primitives moveToXY applyTo: {pos first. pos second}.
 186   resend
 187 ].
 188
 189 c@(CursesConsole traits) actualCursorColumn
 190 [
 191   c assumeStructuredMode.
 192   c Lib primitives cursorX do
 193 ].
 194
 195 c@(CursesConsole traits) actualCursorRow
 196 [
 197   c assumeStructuredMode.
 198   c Lib primitives cursorY do
 199 ].
 200
 201 c@(CursesConsole traits) scroll &lines: lines
 202 [
 203   c assumeStructuredMode.
 204   lines `defaultsTo: 1.
 205   c Lib primitives scroll applyTo: {lines}
 206 ].
 207
 208 c@(CursesConsole traits) readEscapedKeyInto: event
 209 [| keyCode seq count |
 210   seq := '' writer.
 211   count := 0.
 212   "Read up to 4 key codes without blocking"
 213   [(keyCode := (c Lib primitives nextEvent applyTo: {0})) > 0 /\
 214     [count <= 4]]
 215       whileTrue: [| result |
 216         count += 1.
 217         "Reenter for double escaped keys like alt+right arrow"
 218         count = 1 /\ [keyCode = 27]
 219           ifTrue: [
 220             event leftAltState := True.
 221             ^ (c readEscapedKeyInto: event)].
 222         seq nextPut: (keyCode as: ASCIICharacter).
 223         (c translateEscapedSequence: seq contents into: event)
 224           ifTrue: [^ Nil]].
 225   "If nothing was read unblockingly then it's a simple Escape"
 226   count isZero ifTrue: [event keyName := #Escape].
 227 ].
 228
 229 c@(CursesConsole traits) write: n to: handle from: array startingAt: start
 230 [
 231   c assumeStructuredMode.
 232   c Lib primitives write applyTo: {array. n. start}.
 233   n
 234 ].
 235
 236 c@(CursesConsole traits) flush
 237 [
 238   c assumeStructuredMode.
 239   c Lib primitives flush do
 240 ].
 241
 242 c@(CursesConsole traits) deleteChar
 243 [
 244   c assumeStructuredMode.
 245   c Lib primitives deleteChar do
 246 ].
 247
 248 c@(CursesConsole traits) deleteLines: n
 249 [
 250   c assumeStructuredMode.
 251   c Lib primitives deleteLines applyTo: {n}
 252 ].
 253
 254 c@(CursesConsole traits) insertLines: n
 255 [
 256   c assumeStructuredMode.
 257   c Lib primitives insertLines applyTo: {n}
 258 ].
 259
 260 c@(CursesConsole traits) hideCursor
 261 [
 262   c assumeStructuredMode.
 263   c Lib primitives hideCursor do
 264 ].
 265
 266 c@(CursesConsole traits) showCursor
 267 [
 268   c assumeStructuredMode.
 269   c Lib primitives showCursor do
 270 ].
 271
 272 c@(CursesConsole traits) ensurePairForFg: fg forBg: bg
 273 [
 274   c colorToPairs at: fg <> bg ifAbsentPut:
 275     [| oldPair |
 276      (oldPair := c currentColorPair) >= c maxColorPairs ifTrue:
 277        [error: 'Ran out of terminal color pairs (this is how lame ncurses is with its color pairs)'].
 278     c currentColorPair := oldPair + 1.
 279     c Lib primitives initColorPair applyTo: {oldPair. fg. bg}.
 280     oldPair]
 281 ].
 282
 283 c@(CursesConsole traits) attributeMode: mode
 284 [
 285   c setAttributeMode: mode withFg: c currentFgColor withBg: c currentBgColor.
 286   resend
 287 ].
 288
 289 c@(CursesConsole traits) foregroundColor: fg
 290 [
 291   c setAttributeMode: c currentMode withFg: fg withBg: c currentBgColor.
 292   resend
 293 ].
 294
 295 c@(CursesConsole traits) backgroundColor: bg
 296 [
 297   c setAttributeMode: c currentMode withFg: c currentFgColor withBg: bg.
 298   resend
 299 ].
 300
 301 c@(CursesConsole traits) setAttributeMode: mode withFg: fg withBg: bg
 302 "This is the primitive"
 303 [
 304   c assumeStructuredMode.
 305   c Lib primitives setAttributes applyTo: {mode. c ensurePairForFg: fg forBg: bg}.
 306 ].
 307
 308 "Event stream stuff"
 309
 310 s@(CursesConsole EventStream traits) hasNext
 311 [| c |
 312   (c := s console) assumeStructuredMode.
 313   c Lib primitives hasEvent do
 314 ].
 315
 316 s@(CursesConsole EventStream traits) next
 317 [| c keyCode |
 318   (c := s console) assumeStructuredMode.
 319   (keyCode := c Lib primitives nextEvent apply*, -1) caseOf: {
 320     410 -> [c resized.
 321             c ResizeEvent new].
 322     127 -> [(c KeyDownEvent newForKeyCode: 8) `>>
 323               [keyName := #BackSpace.
 324                leftControlState := True. ]].
 325     27 -> [| event |
 326            event := c KeyDownEvent newForKeyCode: keyCode.
 327            c readEscapedKeyInto: event.
 328            "event keyName ifNil: [error: 'unknown key sequence']."
 329            event]
 330   } otherwise: [c resolveEvent: (c KeyDownEvent newForKeyCode: keyCode)]
 331 ].