anatomy-0.3: lib/pretty.atomo

-- root URL for links
define: docs-root as: ""

-- current pretty-printer indentation level
define: indent-level as: 0

-- allow multiline pretty-printing
define: multiline-pretty? as: False

-- context for a pretty-print
define: context as: @top

-- output as values? (i.e. <expression 1 + 1> instead of 1 + 1)
define: value-output? as: False


-- indent s up to the current indentation level
indented: (s: String) :=
  ($  repeat: (indent-level * 2)) .. s

-- an empty line, followed by (indentation - 1) indentation
unindent :=
  "\n" .. ($  repeat: ((indent-level - 1) * 2))


-- default pretty-printer; just do @show
A pretty: o :=
  { s = o show

    if: (s starts-with?: "<")
      then: { s escape type: "internal" }
      else: { s escape }
  } call

-- primitive pretty-printers
A pretty: (c: Char) := c show escape type: "char"
A pretty: (b: Boolean) := b show escape type: "keyword boolean"
A pretty: (d: Double) := d show escape type: "number double"
A pretty: (i: Integer) := i show escape type: "number integer"
A pretty: (r: Rational) := r show escape type: "number rational"
A pretty: (c: String) := c show escape type: "string"

-- pattern pretty-printing; lop off "<pattern [...]>" normally
A pretty: (p: Pattern) :=
  if: value-output?
    then: { p show escape type: "internal" }
    else: {
      p show (drop: "<pattern " length) init escape
        type: "pattern"
    }

-- pretty-print both sides of an Association
(a: A) pretty: (as: Association) :=
  (a pretty: as from) .. " -> " escape .. (a pretty: as to)

(a: A) pretty: (p: Particle) :=
  p type match: {
    @single -> ("@" .. p name escape (type: "name")) type: "particle"
    @keyword -> a pretty-particle: p
  }

(a: A) pretty: (l: List) :=
  ("[" .. l (map: { l | a pretty: l }) (join: ", ") .. "]") type: "list"

(a: A) pretty: (b: Block) :=
  with: [
    context -> @top
    value-output? -> False
    indent-level -> indent-level + 1
  ] do: {
    arguments = b arguments (map: { p | a pretty: p }) (join: " ")

    pretty-contents = b contents (map: { e | a pretty: e })

    contents =
      if: multiline-pretty?
        then: {
          exprs = pretty-contents (map: { c | "\n" .. (indented: c) }) join strip-end
          exprs .. unindent
        }
        else: { " " .. pretty-contents (join: "; ") .. " " }

    condition: {
      contents strip empty? && b arguments empty? ->
        "{ }" type: "block"

      contents strip empty? ->
        ("{ " .. arguments .. " | }") type: "block"

      b arguments empty? ->
        ("{" .. contents .. "}") type: "block"

      otherwise ->
        ("{ " .. arguments .. " |" .. contents .. "}") type: "block"
    }
  }

(a: A) pretty: (e: Expression) :=
  { pretty = e type match: {
      @(dispatch: type) ->
        with: value-output? as: False do: {
          a pretty-dispatch: e type: type
        }

      @define ->
        with: [
          value-output? -> False
          context -> @define
        ] do: {
          pat = a pretty: e pattern

          if: multiline-pretty?
            then: {
              with: [
                indent-level -> indent-level + 1
                context -> @define
              ] do: {
                expr = a pretty: e expression
                pat .. " :=\n" .. (indented: expr) .. "\n"
              }
            }
            else: {
              with: context as: @define do: {
                expr = a pretty: e expression
                pat .. " := " .. expr
              }
            }
        }

      @set ->
        with: [
          value-output? -> False
          context -> @set
        ] do: {
          (a pretty: e pattern) .. " = " .. (a pretty: e expression)
        }

      @list ->
        with: [
          value-output? -> False
          context -> @list
        ] do: {
          "[" .. e contents (map: { l | a pretty: l }) (join: ", ") .. "]"
        }

      @(particle: @single) -> a pretty: (a evaluate: e)

      @(particle: @keyword) ->
        with: context as: @particle do: {
          a pretty-particle: e
        }

      @primitive ->
        with: value-output? as: True do: {
          a pretty: (a evaluate: e)
        }

      @block ->
        with: context as: @block do: {
          a pretty: (a evaluate: e)
        }

      @top -> "this" type: "keyword top"

      @macro ->
        [ "macro" type: "keyword macro"
          "(" .. (a pretty: e pattern) .. ")"
          a pretty: e expression
        ] unwords

      @operator ->
        [ "operator" type: "keyword operator"
          e associativity name
          a pretty: e precedence
          e operators
            (map: { o | a linked: `~o as: o names head })
            unwords
        ] unwords

      @for-macro ->
        [ "for-macro" type: "keyword for-macro"
          a pretty: e expression
        ] unwords

      @quote ->
        with: [
          value-output? -> False
          context -> @quote
        ] do: {
          "`" .. (a pretty-segment: e expression)
        }

      @unquote ->
        with: [
          value-output? -> False
          context -> @unquote
        ] do: {
          "~" .. (a pretty-segment: e expression)
        }

      x -> e show (drop: 2) init escape -- remove '( and )
    }

    condition: {
      value-output? not -> pretty

      e needs-parens? ->
        "'(" .. pretty .. ")"

      otherwise -> "'" .. pretty
    }
  } call

(e: Expression) needs-parens? :=
  e type match: {
    @(dispatch: @single) ->
      e target type /= @top

    x -> x in?: [@define, @set, @(dispatch: @keyword)]
  }

(a: A) pretty-segment: (e: Expression) :=
  if: e needs-parens?
    then: { "(" .. (a pretty: e) .. ")" }
    else: { a pretty: e }

(a: A) pretty-dispatch: e type: @single :=
  with: context as: @single do: {
    msg = (a linked: e as: e name) type: "dispatch single"

    if: (e target type == @top)
      then: { msg }
      else: { (a pretty: e target) .. " " .. msg }
  }

(a: A) pretty-dispatch: e type: @keyword :=
  condition: {
    e targets empty? ->
      (a linked: e as: e names (map: @keywordfy) join)
        type: "dispatch keyword"

    e names == [":="] ->
      with: context as: @define do: {
        pat = a pretty: e targets head
        exp = e targets (at: 1)
        key = a linked: e as: ":="

        if: multiline-pretty?
          then: {
            modify: indent-level as: @(+ 1) do: {
              expr = a pretty: exp
              pat .. " " .. key .. "\n" .. (indented: expr) .. "\n"
            }
          } else: {
            pat .. " " .. key .. " " .. (a pretty: exp)
          }
      }

    e names == ["="] ->
      with: context as: @set do: {
        pat = a pretty: e targets head
        exp = e targets (at: 1)
        key = a linked: e as: "="

        pat .. " " .. key .. " " .. (a pretty: exp)
      }

    otherwise ->
      { from = context

        with: context as: @keyword do: {
          initial =
            if: (e targets head type == @top)
              then: { "" }
              else: { (a pretty: e targets head) .. " " }

          rest =
            (0 ... e names length) (map: { n |
              name = e names (at: n)
              value = a pretty: e targets (at: (n + 1))

              (a linked: e as: name keywordfy) .. " " .. value
            }) join: " "

          (if: (from == @single || from == @keyword)
            then: { "(" .. initial .. rest .. ")" }
            else: { initial .. rest })
            type: "dispatch keyword"
        }
      } call
  }

(a: A) pretty-particle: p :=
  if: p values (all?: @(== @none))
    then: {
      ("@" ..
        p names
          (map: { n | n keywordfy escape (type: "names") })
          join
      ) type: "particle"
    }
    else: {
      initial =
        p values head match: {
          @none -> ""
          @(ok: v) -> a pretty: v
        }

      ks = (0 ... p names length) map:
        { n |
          name = p names (at: n)
          value =
            p values (at: (n + 1)) match: {
              @none -> "_"
              @(ok: v) -> a pretty: v
            }

          name keywordfy escape (type: "names") .. " " .. value
        }

      ("@(" .. initial .. ks (join: " ") .. ")") type: "particle"
    }


-- find a url for an expression, and link it with t as the text
(a: A) linked: (e: Expression) as: (t: String) :=
  a (url-for: e) match: {
    @none -> t escape
    @(ok: u) ->
      t escape in-tag: ("a href=\"" .. docs-root .. u .. "\"")
  }