requires: {#ExtensibleArray. #Condition. #Restart. #Abort. #Quit}.
provides: {#Debugger}.

conditions addSlot: #DebugConsole valued: Console.
"The interaction to which Error messages are sent and handler input is
received. This should be StdErr and overridable."

conditions addPrototype: #Debugger derivedFrom: {Cloneable}.
conditions Debugger addSlot: #condition.
"The Condition that raised the debugging context."
conditions Debugger addSlot: #restarts valued: ExtensibleArray newEmpty.
"The available Restart objects, in linear precedence order."

c@(Condition traits) invokeDebugger
"The hook for any Condition to start the debugger and enter its loop."
[| debug |
  debug: Debugger clone.
  debug condition: c.
  debug restarts: debug restarts newEmpty.
  debug loop
].

d@(Debugger traits) printBacktrace
"Shows the sequence of method calls, with source location or primitive-ness
information per line, up until the actual Condition-signalling."
[| bt omitted |
  debugMode
    ifFalse: [DebugConsole ; 'Backtrace not enabled.\n\n'. ^ False].
  bt: backtrace.
  omitted:
    (bt indexOfFirstSatisfying:
      [| :frame | frame selector = #signal]) + 1.
  (bt allButFirst: omitted)
    reverseDo:
      [| :frame |
        frame method fileName = ''
          ifTrue: [DebugConsole ; 'Primitive ']
          ifFalse:
            [DebugConsole ; '\'' ; frame method fileName ; '\':' ;
	       frame method lineNumber print ; ' '].
        DebugConsole ; frame selector print ; '\n'
      ].
  DebugConsole ; '\n'.
  True
].

d@(Debugger traits) findRestarts
"Rebuilds the list of applicable restarts."
[
  d restarts clear.
  conditionStack
    reverseDo:
      [| :context |
        ((context is: Restart) and: [context appliesTo: d condition])
          ifTrue: [d restarts addLast: context]].
  d restarts
].

d@(Debugger traits) describeRestarts
"Describes the restarts available in the context, if any."
[
  DebugConsole ; 'The following condition was signaled:\n'.
  d condition describe.
  DebugConsole ; '\n'.
  DebugConsole ; (d restarts isEmpty
    ifTrue: ['No restarts are available.\n']
    ifFalse: ['The following restarts are available:\n']).
  d restarts
    doWithIndex:
      [| :restart :index |
        DebugConsole ; index print ; ')\t'.
        restart describe]
].

d@(Debugger traits) queryRestart
"Prints out the restarting options with a prompt and numeric labels, and reads
in the selected option number, returning it if valid."
[| line restart |
  DebugConsole ; 'Debug'.
  d restarts isEmpty
    ifFalse: [DebugConsole ; ' [0..' ; (d restarts size - 1) print ; ']'].
  DebugConsole ; ': '.
  line: (DebugConsole reader upTo: $\n).
  (line size > 0 and: [line allSatisfy: [| :c | c isDigit]])
    ifFalse: [^ Nil].
  restart: ((line as: String) as: Integer).
  (d restarts acceptsKey: restart)
    ifTrue: [restart]
    ifFalse: [Nil]
].

d@(Debugger traits) signalRestartAt: index
"Takes the restart option number from the queryRestart and invokes it."
[| restart |
  restart: ((d restarts at: index) newCondition: (d condition)).
  restart query.
  restart signal
].

d@(Debugger traits) loop
"The main interactive debugger loop."
[
  [
    d printBacktrace.
    d findRestarts.
    d describeRestarts.
    d queryRestart
      ifNotNilDo: [| :index | d signalRestartAt: index]
  ] loop
].

_@lobby initHook
"This is called when the image is started, which conceptually is intended to
start a new thread. This is an approximation."
[
  conditionStack clear
].

_@lobby interpretHook: block
"The default set of restarts for any errors in a block of code."
[
  block
    handlingCases:
      {
        Abort -> [| :_ | ^ Nil].
        Quit -> [| :_ |]
      }
].