src/core/condition.slate

   1 prototypes ensureNamespace: #conditions &delegate: True.
   2
   3 conditions addSlot: #conditionStack valued: Stack new.
   4 "The current active condition stack. This assumes that no concurrency is
   5 present."
   6
   7 conditions define: #Condition &parents: {Cloneable} &slots: {
   8 "A situation in the call context which is not handled in normal program logic,
   9 and may require investigative or other special handling."
  10 #handlers -> {}.
  11 "The ordered group of handlers for the condition."
  12 #exitContinuation -> [| :result |].
  13 "A continuation which when invoked will exit from the handler."
  14 #returnContinuation -> [| :result |].
  15 "A continuation which when invoked will return from the point where the condition was signaled."
  16 }.
  17
  18 c@(Condition traits) new
  19 "Create and initialize a new condition."
  20 [c clone].
  21
  22 c@(Condition traits) defaultHandler
  23 "Do nothing, and return nothing by default."
  24 [Nil].
  25
  26 c@(Condition traits) isRestartAvailable
  27 "Answer whether there is an available Restart for the Condition."
  28 [
  29 ].
  30
  31 c@(Condition traits) signal
  32 "Signalling a Condition."
  33 [
  34   c tryHandlers
  35 ].
  36
  37 _@(Condition traits) describeOn: console
  38 "The default description for a Condition."
  39 [
  40   console ; 'Undescribed condition\n'
  41 ].
  42
  43 block@(Method traits) on: c@(Condition traits) do: handler
  44 "Establishes a handler to be executed when the Condition is signaled within the block."
  45 [| context |
  46   context := c clone `>>
  47     [handlers := {handler}.
  48      exitContinuation := [| :result | ^ result]. ].
  49   conditionStack push: context.
  50   block ensure: [conditionStack pop]
  51 ].
  52
  53 block@(Method traits) on: col@(Collection traits) do: handler
  54 "Establishes the handlers to be executed when the Condition is signaled within the block."
  55 [
  56   col do:
  57     [| :c context |
  58      context := c clone `>>
  59        [handlers := {handler}.
  60         exitContinuation := [| :result | ^ result]. ].
  61      conditionStack push: context].
  62   block ensure: [conditionStack pop: col size]
  63 ].
  64
  65 block@(Method traits) handlingCases: handlers
  66 "Establishes handlers to be executed when their associated Conditions are
  67 signaled within the block."
  68 [| context pos |
  69   pos := conditionStack position.
  70   handlers
  71     reverseDo:
  72       [| :handler |
  73        context := handler key clone `>>
  74          [handlers := {handler value}.
  75           exitContinuation := [| :result | ^ result]. ].
  76        conditionStack push: context].
  77   block ensure: [conditionStack position := pos]
  78 ].
  79
  80 c@(Condition traits) tryHandlers
  81 [| delegates |
  82    c returnContinuation := [| :result | ^ result].
  83    delegates := c allDelegates.
  84    conditionStack
  85      reverseDoWithIndex:
  86        [| :context :index |
  87         (delegates includes: context traits)
  88           ifTrue:
  89             [[(index -= 1) >= 0
  90                 /\ [(conditionStack at: index) exitContinuation == context exitContinuation]]
  91                whileTrue.
  92              c exitContinuation := context exitContinuation.
  93              context handlers do: #(applyWith: c) `er]].
  94    c defaultHandler
  95 ].
  96
  97 "
  98 c@(Condition traits) tryHandlers
  99 [
 100    c returnContinuation := [| :result | ^ result].
 101    conditionStack
 102      reverseDo:
 103        [| :context |
 104         c == context
 105           ifTrue:
 106             [c exitContinuation := context exitContinuation.
 107              context handlers do: #(applyWith: c) `er]].
 108    c defaultHandler
 109 ].
 110 "
 111
 112 c@(Condition traits) return: result
 113 [
 114   c returnContinuation applyWith: result
 115 ].
 116
 117 c@(Condition traits) return
 118 [
 119   c return: Nil
 120 ].
 121
 122 c@(Condition traits) exit: result
 123 [
 124   c exitContinuation applyWith: result
 125 ].
 126
 127 c@(Condition traits) exit
 128 [
 129   c exit: Nil
 130 ].
 131
 132 block@(Method traits) breakOn: c
 133 "Breaks execution in case the given Condition is signaled within the block."
 134 [
 135   block on: c do: #exit `er.
 136 ].
 137
 138 block@(Method traits) ignoring: c
 139 [
 140   block on: c do: #return `er
 141 ].
 142
 143 conditions define: #Restart &parents: {Condition} &slots: {#condition}.
 144 "A Restart is a Condition which is signaled by another Condition for the
 145 purpose of handling it."
 146 "The actual signaled condition that invoked this restart."
 147
 148 r@(Restart traits) newCondition: c
 149 [r new `>> [condition := c. ]].
 150
 151 r@(Restart traits) appliesTo: c@(Condition traits)
 152 "Answers whether the Restart applies to the Condition. The default is to
 153 return True."
 154 [True].
 155
 156 r@(Restart traits) describeOn: console
 157 [
 158   console ; 'Undescribed restart\n'
 159 ].
 160
 161 r@(Restart traits) queryFrom: d
 162 [
 163 ].
 164
 165 block handleWith: r@(Restart traits)
 166 [
 167   block on: r do: [| :_ |]
 168 ].
 169
 170 conditions define: #Abort &parents: {Restart}.
 171 "An Abort is a Restart which exits the computation, unwinding the stack."
 172
 173 _@(Root traits) abort
 174 [
 175   Abort signal
 176 ].
 177
 178 _@(Abort traits) describeOn: console
 179 [
 180   console ; 'Abort evaluation of expression\n'
 181 ].
 182
 183 conditions define: #Retry &parents: {Restart}.
 184 "A retry is where you try doing it again."
 185
 186 _@(Retry traits) describeOn: console
 187 [
 188   console ; 'Retry evaluation of expression\n'
 189 ].
 190
 191 conditions define: #Quit &parents: {Restart}.
 192 "Quit is a Restart which exits the Slate environment, noting an error."
 193
 194 _@(Quit traits) describeOn: console
 195 [
 196   console ; 'Quit Slate\n'
 197 ].
 198
 199 _@(Quit traits) defaultHandler
 200 "Cause Slate to exit with an error code to the underlying system."
 201 [lobby exit: 1].
 202
 203 conditions define: #DescriptiveConditionMixin &parents: {Cloneable} &slots: {#description -> 'Undescribed condition'}.
 204 "Conditions which bear a description."
 205
 206 c@(DescriptiveConditionMixin traits) newDescription: description
 207 [c new `>> [description := description. ]].
 208
 209 c@(DescriptiveConditionMixin traits) signalSaying: description
 210 [
 211   (c newDescription: description) signal
 212 ].
 213
 214 c@(DescriptiveConditionMixin traits) describeOn: console
 215 [
 216   (c description is: String)
 217     ifTrue: [console ; c description ; '\n']
 218     ifFalse: [console ; c description printString ; '\n']
 219 ].
 220
 221 conditions define: #Warning &parents: {DescriptiveConditionMixin. Condition}.
 222 "Warnings are Conditions which should generate notifications, but do not need
 223 to be raised for handling, i.e. no action needs to be taken."
 224
 225 _@(Root traits) warn: message
 226 [
 227   Warning signalSaying: message
 228 ].
 229
 230 warn@(Warning traits) describeOn: console
 231 [
 232   console ; 'Warning: ' ; warn description ; '\n'
 233 ].
 234
 235 warn@(Warning traits) defaultHandler
 236 [
 237   warn describeOn: DebugConsole
 238 ].
 239
 240 m@(Method traits) ignoringWarnings
 241 [
 242   m ignoring: Warning
 243 ].
 244
 245 conditions define: #SimpleWarning &parents: {Warning}.
 246 "A SimpleWarning is a Warning."
 247
 248 conditions define: #StyleWarning &parents: {SimpleWarning}.
 249 "A StyleWarning is a Warning that certain conventions set up by the library
 250 author have not been followed, which could lead to problems."
 251
 252 _@(Root traits) deprecated
 253 [
 254   StyleWarning signalSaying: 'This method has been deprecated.'
 255 ].
 256
 257 conditions define: #BreakPoint &parents: {Condition}.
 258 "A BreakPoint is a Condition raised when instrumenting code for
 259 debugging from a particular place in the code. It may restarted."
 260
 261 _@(Root traits) break
 262 [
 263   (BreakPoint new) signal
 264 ].
 265
 266 _@(BreakPoint traits) describeOn: console
 267 [
 268   console ; 'Break point\n'.
 269 ].
 270
 271 bp@(BreakPoint traits) defaultHandler
 272 "Invoke the debugger after setting up a Restart for the BreakPoint."
 273 [
 274   [bp invokeDebugger]
 275     on: (BreakPoint Restart newCondition: bp)
 276     do: [| :bpr | ^ Nil]
 277 ].
 278
 279 BreakPoint traits define: #Restart &parents: {Restart}.
 280 "A BreakPoint Restart is a Restart used to restart from a BreakPoint."
 281
 282 bpr@(BreakPoint Restart traits) describeOn: console
 283 [
 284   console ; 'Restart break point\n'
 285 ].
 286
 287 bpr@(BreakPoint Restart traits) appliesTo: bp
 288 [
 289   bpr condition == bp
 290 ].
 291
 292 conditions define: #SeriousCondition &parents: {Condition}.
 293 "A SeriousCondition is a Condition that requires handling, but is not a
 294 semantic Error of the program. Rather, it's due to some incidental or
 295 pragmatic consideration."
 296
 297 c@(SeriousCondition traits) defaultHandler
 298 "Just raise a debugger if no handler is provided."
 299 [
 300   c invokeDebugger
 301 ].
 302
 303 conditions define: #Error &parents: {SeriousCondition}.
 304 "An Error is a SeriousCondition which involves some misstep in program logic,
 305 and raises the need for handlers."
 306
 307 m@(Method traits) ignoringErrors
 308 [m ignoring: Error].
 309
 310 conditions define: #DescriptiveError &parents: {DescriptiveConditionMixin. Error}.
 311 "A DescriptiveError is an Error which carries a description.
 312 It is usually not recoverable."
 313
 314 _@(DescriptiveError traits) describeOn: console
 315 [
 316   console ; 'Error: '.
 317   resend
 318 ].
 319
 320 _@(Root traits) error: message
 321 [
 322   DescriptiveError signalSaying: message
 323 ].