Kitten Debug Trait

debug.ktn

-_

trait debug<T> (T -> debug::Repr);

about debug<T>:
  kitten::docs:
    """
    Produce a debugging representation (`debug::Repr`) of a value.

    For uninspectable types such as functions, use `debug::opaque`.
    """
  kitten::laws:
    injectivity:
      -> x, y; (x <> y) --> x debug <> y debug

vocab debug {

type Tree<T>:
  case node:
    root_label as T
    subtrees as List<Tree<T>>

derive (_=_)<T> (Tree<T>, Tree<T> -> Bool +(_=_)<T>);
derive (_<=>_)<T> (Tree<T>, Tree<T> -> Ordering +(_<=>_)<T>);
derive map<A, B> (Tree<A>, (A -> B) -> Tree<B>);

vocab tree {

define is_leaf<T> (Tree<T> -> Bool):
  match case (_ [] node) { true } else { false }

define fold<A, B> (Tree<A>, (A, List<B> -> B) -> B):
  -> f
  define go:
    match case node:
      \go map  f call
  go

define prune<T> (Tree<T>, T, (T -> Bool), Int32 -> Tree<T>):
  1 max -> depth
  -> replacement, counts
  define go:
    -> d
    match
    case ((_ [] node) -> n) when (d = 0):
      n
    case _ when (d = 0):
      replacement [] node
    case (label children node)
      d if (label counts) { (_ - 1) } -> d
      label (children { d go } map) node
  depth go

} // vocab tree

type Repr:
  case repr (Tree<Label>)

type Label:
  case int (Int32)
  case float (Float64)
  case char (Char)
  case text (Text)
  case array ()
  case record ()
  case prop (Text)
  case app (Text)
  case opaque (Text)
  case literal (Text)
  case assoc (Text)
  case assoc_prop (Text)
  case omitted ()

derive (_=_) (Label, Label -> Bool);
derive (_<=>_) (Label, Label -> Ordering);

define int (Int32 -> Repr):
  Label::int leaf

// …

type Delta<T>:
  case context (T)
  case different ()
  case deletion ()
  case insertion ()
  case subtree (T)

derive (_=_)<T> (Delta<T>, Delta<T> -> Bool +(_=_)<T>);
derive (_<=>_)<T> (Delta<T>, Delta<T> -> Ordering +(_<=>_)<T>);

type DiffOptions:
  case diff_options:
    float_epsilon as Float64

/*
defaultDiffOptions :: DiffOptions
defaultDiffOptions =
  { maxRelativeError: 1e-12 }

diff' :: forall a.
  (a -> a -> Boolean) ->
  (a -> Boolean) ->
  Tree a ->
  Tree a ->
  Tree (Delta a)
diff' labelEq isUnimportantLabel = go
  where
  go left@(Node x xs) right@(Node y ys) =
    if labelEq x y
      then
        let
          children = goChildren xs ys
        in
          if isUnimportantLabel x && all differing children
            then
              Node Different [map Subtree left, map Subtree right]
            else
              Node (Same x) children
      else
        Node Different [map Subtree left, map Subtree right]

  goChildren :: Array (Tree a) -> Array (Tree a) -> Array (Tree (Delta a))
  goChildren xs ys =
    let
      xlen = Array.length xs
      ylen = Array.length ys
      begin = Array.zipWith go xs ys
    in
      case compare xlen ylen of
        LT ->
          begin <> map (extra Extra1) (Array.drop xlen ys)
        EQ ->
          begin
        GT ->
          begin <> map (extra Extra2) (Array.drop ylen xs)

  extra :: Delta a -> Tree a -> Tree (Delta a)
  extra ctor subtree = Node ctor [map Subtree subtree]

  differing :: Tree (Delta a) -> Boolean
  differing (Node root _) =
    case root of
      Same _ ->
        false
      _ ->
        true

-- | Compare two `Repr` values and record the results as a `ReprDelta`
-- | structure, using the specified options.
diffReprWith :: DiffOptions -> Repr -> Repr -> ReprDelta
diffReprWith opts (Repr a) (Repr b) =
  ReprDelta $
    diff'
      (labelApproxEq opts.maxRelativeError)
      labelIsUnimportant
      a
      b

-- | Compare two `Repr` values and record the results as a `ReprDelta`
-- | structure, using the default options.
diffRepr :: Repr -> Repr -> ReprDelta
diffRepr = diffReprWith defaultDiffOptions
*/

// TODO: <https://github.com/hdgarrood/purescript-debugged/blob/master/src/Data/Debug/Type.purs>

} // vocab debug