atomo-0.3: prelude/condition.atomo

for-macro super Restart = Object clone

{ define: *handlers* as: []
  define: *restarts* as: []

  super do: {
    Default-Debugger = Object clone do:
      { run: e :=
          { Restart show-options-for: e

            "!> " display

            Restart (get: read) jump: []
          } call
      }

    define: *debugger* as: Default-Debugger
    define: *error-output* as: Port standard-error

    Condition = Object clone

    Error = Condition clone
    Simple-Error = Error clone

    Warning = Condition clone
    Simple-Warning = Warning clone
  }

  (e: Simple-Error) describe-error := e value describe-error
  (w: Simple-Warning) describe-error := w value describe-error

  Simple-Error new: v :=
    Simple-Error clone (delegating-to: v) do: { value = v }

  Simple-Warning new: v :=
    Simple-Warning clone (delegating-to: v) do: { value = v }

  (e: Simple-Error) show := "<error " .. e value show .. ">"
  (e: Simple-Warning) show := "<warning " .. e value show .. ">"

  Restart show-options-for: e :=
    { $- (repeat: 78) print
      e describe-error
        (word-wrap: 74)
        lines
        (map: { l | "*** " .. l })
        unlines
        print

      halt when: *restarts* _? empty?

      "restarts:" print

      *restarts* _? (zip: (0 .. *restarts* _? length)) map:
        { choice |
          [index, name] = [choice to, choice from from]
          ("  :" .. index show .. " -> " .. name name) print
        }
    } call

  Restart get: (n: Integer) :=
    *restarts* _? (at: n) to

  Restart new: (a: Block) in: (c: Continuation) :=
    { res = *restarts* _?
      Restart clone do:
        { jump: as := with: *restarts* as: res do: { c yield: (a call: as) }
          action = a
          context = c
        }
    } call

  (r: -> Restart) show := "<restart " .. r action show .. ">"

  macro (action with-restarts: (restarts: Block))
    { rs = restarts contents map:
        { `(~n -> ~e) |
          e type match: {
            @block -> `('~n -> ~e)
            _ -> `('~n -> { ~e })
          }
        }

      `(
        { cc action pairs |
          restarts = pairs map:
            { a | a from -> (~Restart new: a to in: cc) }
          action with-restarts: restarts
        } call/cc: [~action, ~(`List new: rs)]
      )
    } call

  (action: Block) with-restarts: (restarts: List) :=
    modify: *restarts* as: { rs | restarts .. rs } do: action

  (super) signal: v :=
    { *handlers* _? map: { h | h (call: [v]) (call: [v]) }
      @ok
    } call

  (super) error: v := error: (Simple-Error new: v)
  (super) error: (e: Error) :=
    { signal: e

      with-output-to: *error-output* _? do: {
        *debugger* _? run: e
      }
    } call

  (super) warning: v := warning: (Simple-Warning new: v)
  (super) warning: (w: Warning) :=
    { signal: w

      with-output-to: *error-output* _? do: {
        ("WARNING: " .. w describe-error) print
      }

      @ok
    } with-restarts: {
      muffle-warning -> @ok
    }

  (super) restart: name := restart: name with: []

  (super) restart: name with: (params: List) :=
    *restarts* _? (lookup: name) match: {
      @(ok: r) ->
        r jump: params

      @none ->
        error: @(unknown-restart: name)
    }

  (super) find-restart: name :=
    *restarts* _? lookup: name

  (super) with-handler: (h: Block) do: (action: Block) :=
    modify: *handlers* as: { hs | h . hs } do: action

  macro (a bind: (bs: Block))
    { branches = bs contents map:
        { `(~p -> ~e) |
          if: (e type == @block)
            then: { `(~p -> ~e) }
            else: { `(~p -> { ~e }) }
        }

      handler = `Block new: (branches .. ['(_ -> { @ok })])

      `({ h a |
          with-handler: h do: a
        } call: [{ #c | super = super; #c match: ~handler }, ~a])
    } call
} call