quox/tests/PrettyExtra.idr

module PrettyExtra

import public Quox.Pretty
import public Quox.Name
import TAP

export
squash : String -> String
squash = pack . squash' . unpack . trim where
  squash' : List Char -> List Char
  squash' [] = []
  squash' (c :: cs) =
    if isSpace c then ' ' :: squash' (dropWhile isSpace cs)
    else c :: squash' cs

public export
Printer : Type -> Type
Printer a = {opts : _} -> a -> Eff Pretty (Doc opts)

export
renderSquash : ({opts : _} -> Doc opts) -> String
renderSquash doc = squash $ render (Opts 10000) doc

export
prettySquash : Printer a -> Flavor -> a -> String
prettySquash pr f x =
  renderSquash $ runPrettyWith Outer f noHighlight 0 (pr x)

export
testPretty : Printer a -> a -> (uni, asc : String) ->
             {default uni label : String} -> Test
testPretty pr t uni asc {label} = test {e = Info} label $ do
  let uni  = squash uni; asc = squash asc
      uni' = prettySquash pr Unicode t
      asc' = prettySquash pr Ascii t
  unless (uni == uni') $ Left [("exp", uni), ("got", uni')]
  unless (asc == asc') $ Left [("exp", asc), ("got", asc')]

export
runPrettyDef : Eff Pretty a -> a
runPrettyDef = runPrettyWith Outer Unicode noHighlight 0

export
prettyStr : ({opts : _} -> Eff Pretty (Doc opts)) -> String
prettyStr doc = render (Opts 60) $ runPrettyDef doc