atomo-0.2.1: prelude/condition.atomo

{ 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
  }

  for-macro Handler = Object clone do: { handle: _ := @ok }
  for-macro Restart = Object 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 do: { delegates-to: v; value = v }

  Simple-Warning new: v :=
    Simple-Warning clone do: { delegates-to: v; 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: @(handle: 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: Handler) do: (action: Block) :=
    modify: *handlers* as: { hs | h . hs } do: action

  macro a bind: (bs: Block) :=
    { h = Handler clone

      (h) in: c :=
        { h context = c
          h
        } call

      -- yield a hygienic expr to define on the handler
      expr-for: e :=
        condition: {
          e type == @block && e arguments empty? not ->
            ``(~'~e call: [~s]) -- wow

          e type == @block ->
            `'(~e call)

          otherwise -> `'~e
        }

      signals = bs contents map:
        { `(~pat -> ~expr) |
          Lobby
            define: @handle:
              on: `(h: ~h) (as: Pattern)
              with: [`(s: ~pat) as: Pattern]
              as: `(
                { match: ~(pat as: Pattern) on: s
                  (with-delegates: [h context])
                    evaluate: ~(expr-for: expr)
                } call
              )
        }

      `(with-handler: (~h in: this) do: ~a)
    } call
} call