prototypes ensureDelegatedNamespace: #conditions.

conditions addSlot: #conditionStack valued: Stack newEmpty.
"The current active condition stack. This assumes that no concurrency is
present."

conditions addPrototype: #Condition derivedFrom: {Cloneable}.
"A situation which is not handled in normal program logic, and may require
investigative or other special handling."
Condition addSlot: #handlers valued: ExtensibleArray newEmpty.
"The ordered group of handlers for the condition."
Condition addSlot: #exitContinuation valued: [] Identity.
"A continuation which when invoked will exit from the handler."
Condition addSlot: #returnContinuation valued: [] Identity.
"A continuation which when invoked will return from the point where the condition was signaled."

c@(Condition traits) new
"Create and initialize a new condition."
[
  c clone
].

c@(Condition traits) defaultHandler
"Do nothing, and return nothing by default."
[Nil].

c@(Condition traits) isRestartAvailable
"Answer whether there is an available Restart for the Condition."
[
].

c@(Condition traits) signal
"Signalling a Condition."
[
  c tryHandlers
].

_@(Condition traits) describe
"The default description for a Condition."
[
  DebugConsole ; 'Undescribed condition\n'
].

block@(Method traits) on: c@(Condition traits) do: handler
"Establishes a handler to be executed when the Condition is signaled within the block."
[| context |
  context: c clone.
  context handlers: { handler }.
  context exitContinuation: [| :result | ^ result].
  conditionStack push: context.
  block ensure: [conditionStack pop]
].

block@(Method traits) handlingCases: handlers
"Establishes handlers to be executed when their associated Conditions are
signaled within the block."
[| context continuation lastIndex |
  continuation: [| :result | ^ result].
  lastIndex: conditionStack lastIndex.
  handlers
    reverseDo:
      [| :handler |
        context: handler key clone.
        context handlers: { handler value }.
        context exitContinuation: continuation.
        conditionStack push: context
      ].
  block ensure: [conditionStack lastIndex: lastIndex]
].

c@(Condition traits) tryHandlers
"Tries all of the active handlers, beginning with the most-
recently established."
[| lastIndex delegates |
   c returnContinuation: [| :result | ^ result].
   lastIndex: conditionStack lastIndex.
   delegates: c allDelegates.
   conditionStack
     reverseDoWithIndex:
       [| :context :index |
          (delegates includes: context traits)
            ifTrue:
              [
                [index: index - 1.
                  index >= 0 and:
                    [(conditionStack at: index) exitContinuation == context exitContinuation]]
                  whileTrue.
                conditionStack lastIndex: index.
                c exitContinuation: context exitContinuation.
                context handlers do: [| :handler | handler applyWith: c].
              ]
       ].
   conditionStack lastIndex: lastIndex.
   c defaultHandler 
].

c@(Condition traits) return: result
[
  c returnContinuation applyWith: result
].

c@(Condition traits) return
[
  c return: Nil
].

c@(Condition traits) exit: result
[
  c exitContinuation applyWith: result
].

c@(Condition traits) exit
[
  c exit: Nil
].

block breakOn: c@(Condition traits)
"Breaks execution in case the given Condition is signaled within the block."
[
  block on: c do: [| :inst | inst exit].
].

conditions addPrototype: #Restart derivedFrom: {Condition}.
"A Restart is a Condition which is signaled by another Condition for the
purpose of handling it."
Restart addSlot: #condition.
"The actual signaled condition that invoked this restart."

r@(Restart traits) newCondition: c
[| newR |
  newR: r new.
  newR condition: c.
  newR
].

r@(Restart traits) appliesTo: c@(Condition traits)
"Answers whether the Restart applies to the Condition. The default is to
return True."
[
  True
].

r@(Restart traits) describe
[
  DebugConsole ; 'Undescribed restart\n'
].

r@(Restart traits) query
[
].

block handleWith: r@(Restart traits)
[
  block on: r do: [| :_ |]
].

conditions addPrototype: #Abort derivedFrom: {Restart}.
"An Abort is a Restart which exits the computation, unwinding the stack."

_@lobby abort
[
  Abort signal
].

_@(Abort traits) describe
[
  DebugConsole ; 'Abort evaluation of expression\n'
].

conditions addPrototype: #Quit derivedFrom: {Restart}.
"Quit is a Restart which exits the Slate environment."

_@(Quit traits) describe
[
  DebugConsole ; 'Quit Slate\n'
].

_@(Quit traits) defaultHandler
[
  quit
].

conditions addPrototype: #DescriptiveConditionMixin derivedFrom: {Cloneable}.
"Conditions which bear a description."
DescriptiveConditionMixin addSlot: #description valued: 'Undescribed condition'.

c@(DescriptiveConditionMixin traits) newDescription: description
[| newC |
  newC: c new.
  newC description: description.
  newC
].

c@(DescriptiveConditionMixin traits) describe
[
  DebugConsole ; c description ; '\n' 
].

conditions addPrototype: #Warning derivedFrom: {DescriptiveConditionMixin. Condition}.
"Warnings are Conditions which should generate notifications, but do not need
to be raised for handling, i.e. no action needs to be taken."

_@lobby warn: message
[
  Warning newDescription: message
].

warn@(Warning traits) defaultHandler
[
  DebugConsole ; 'Warning: ' ; warn description ; '\n'
].

m@(Method traits) ignoringWarnings
[
  m on: Warning do: [| :_ | ]
].

conditions addPrototype: #SimpleWarning derivedFrom: {Warning}.
"A SimpleWarning is a Warning."

conditions addPrototype: #StyleWarning derivedFrom: {SimpleWarning}.
"A StyleWarning is a Warning that certain conventions set up by the library
author have not been followed, which could lead to problems."

_@lobby deprecated
[
  (StyleWarning newDescription: 'This method has been deprecated.') signal
].

conditions addPrototype: #BreakPoint derivedFrom: {Condition}.
"A BreakPoint is a Condition raised when instrumenting code for
debugging from a particular place in the code. It may restarted."

_@lobby break
[ 
  (BreakPoint new) signal
].

_@(BreakPoint traits) describe
[ 
  DebugConsole ; 'Break point\n'.
].

bp@(BreakPoint traits) defaultHandler
"Invoke the debugger after setting up a Restart for the BreakPoint."
[
  [bp invokeDebugger]
    on: (BreakPoint Restart newBreakPoint: bp)
    do: [| :bpr | ^ Nil]
].

BreakPoint addPrototype: #Restart derivedFrom: {Restart}.
"A BreakPoint Restart is a Restart used to restart from a BreakPoint."
BreakPoint Restart addSlot: #breakPoint.

bpr@(BreakPoint Restart traits) newBreakPoint: bp
[| newBpr |
  newBpr: bpr clone.
  newBpr breakPoint: bp.
  newBpr
].

bpr@(BreakPoint Restart traits) describe
[
  DebugConsole ; 'Restart break point\n'
].

bpr@(BreakPoint Restart traits) appliesTo: bp
[
  bpr breakPoint == bp
].

conditions addPrototype: #SeriousCondition derivedFrom: {Condition}.
"A SeriousCondition is a Condition that requires handling, but is not a
semantic Error of the program. Rather, it's due to some incidental or
pragmatic consideration."

c@(SeriousCondition traits) defaultHandler
"Just raise a debugger if no handler is provided."
[
  c invokeDebugger
].

conditions addPrototype: #Error derivedFrom: {SeriousCondition}.
"An Error is a SeriousCondition which involves some misstep in program logic,
and raises the need for handlers."

conditions addPrototype: #DescriptiveError derivedFrom: {DescriptiveConditionMixin. Error}.
"A DescriptiveError is an Error which carries a description.
It is usually not recoverable."

_@(DescriptiveError traits) describe
[
  DebugConsole ; 'Error: '.
  resend
].

_@lobby error: message
[
  (DescriptiveError newDescription: message) signal
].