quox/src/Quox/Pretty.idr

module Quox.Pretty

import Quox.Name

import public Text.PrettyPrint.Prettyprinter.Doc
import Text.PrettyPrint.Prettyprinter.Render.String
import Text.PrettyPrint.Prettyprinter.Render.Terminal
import public Data.String
import Data.DPair

import public Control.Monad.Identity
import public Control.Monad.Reader

%default total


public export
data HL
  = Delim
  | TVar
  | TVarErr
  | Dim
  | DVar
  | DVarErr
  | Qty
  | Free
  | Syntax

private 0 HLRepr : Type
HLRepr = Nat

private %inline hlRepr : HL -> Nat
hlRepr Delim   = 0
hlRepr TVar    = 1
hlRepr TVarErr = 2
hlRepr Dim     = 3
hlRepr DVar    = 4
hlRepr DVarErr = 5
hlRepr Qty     = 6
hlRepr Free    = 7
hlRepr Syntax  = 8

export Eq  HL where (==) = (==) `on` hlRepr
export Ord HL where compare = compare `on` hlRepr


public export
data PPrec
  = Outer
  | Ann  -- right of "::"
  | AnnL -- left  of "::"
  -- ...
  | App  -- term/dimension application
  | SApp -- substitution application
  | Arg

private 0 PrecRepr : Type
PrecRepr = Nat

private %inline precRepr : PPrec -> PrecRepr
precRepr Outer = 0
precRepr Ann   = 1
precRepr AnnL  = 2
-- ...
precRepr App   = 98
precRepr SApp  = 99
precRepr Arg   = 100

export Eq  PPrec where (==) = (==) `on` precRepr
export Ord PPrec where compare = compare `on` precRepr


export %inline
hl : HL -> Doc HL -> Doc HL
hl = annotate

export %inline
hl' : HL -> Doc HL -> Doc HL
hl' h = hl h . unAnnotate

export %inline
hlF : Functor f => HL -> f (Doc HL) -> f (Doc HL)
hlF = map . hl

export %inline
hlF' : Functor f => HL -> f (Doc HL) -> f (Doc HL)
hlF' = map . hl'


export
parens : Doc HL -> Doc HL
parens doc = hl Delim "(" <+> doc <+> hl Delim ")"

export
parensIf : Bool -> Doc HL -> Doc HL
parensIf True  = parens
parensIf False = id


public export
record PrettyEnv where
  constructor MakePrettyEnv
  ||| names of bound dimension variables
  dnames  : List Name
  ||| names of bound term variables
  tnames  : List Name
  ||| use non-ascii characters for syntax
  unicode : Bool
  ||| surrounding precedence level
  prec    : PPrec

public export
0 M : Type -> Type
M = Reader PrettyEnv

export
ifUnicode : (uni, asc : Lazy a) -> M a
ifUnicode uni asc = if unicode !ask then [|uni|] else [|asc|]

export
parensIfM : PPrec -> Doc HL -> M (Doc HL)
parensIfM d doc = pure $ parensIf (prec !ask > d) doc

export
withPrec : PPrec -> M a -> M a
withPrec d = local {prec := d}

public export data BinderSort = T | D

export
under : BinderSort -> Name -> M a -> M a
under s x = local $
  {prec := Outer} .
  (case s of T => {tnames $= (x ::)}; D => {dnames $= (x ::)})


public export
interface PrettyHL a where
  prettyM : a -> M (Doc HL)

public export %inline
pretty0M : PrettyHL a => a -> M (Doc HL)
pretty0M = local {prec := Outer} . prettyM

public export %inline
pretty0 : PrettyHL a => {default True unicode : Bool} -> a -> Doc HL
pretty0 x {unicode} =
  let env = MakePrettyEnv {dnames = [], tnames = [], unicode, prec = Outer} in
  runReader env $ prettyM x


export
(forall a. PrettyHL (f a)) => PrettyHL (Exists f) where
  prettyM x = prettyM x.snd

export
PrettyHL a => PrettyHL (Subset a b) where
  prettyM x = prettyM x.fst


export PrettyHL BaseName where prettyM = pure . pretty . baseStr
export PrettyHL Name     where prettyM = pure . pretty . toDots


export
prettyStr : PrettyHL a => {default True unicode : Bool} -> a -> String
prettyStr {unicode} =
  renderString .
  layoutSmart (MkLayoutOptions (AvailablePerLine 80 0.8)) .
  pretty0 {unicode}


export
termHL : HL -> AnsiStyle
termHL Delim   = color BrightBlack
termHL TVar    = color BrightYellow
termHL TVarErr = color BrightYellow  <+> underline
termHL Dim     = color BrightGreen   <+> bold
termHL DVar    = color BrightGreen
termHL DVarErr = color BrightGreen   <+> underline
termHL Qty     = color BrightMagenta <+> bold
termHL Free    = color BrightWhite
termHL Syntax  = color BrightBlue

export
prettyTerm : {default True color, unicode : Bool} -> PrettyHL a => a -> IO Unit
prettyTerm x {color, unicode} =
  let reann = if color then map termHL else unAnnotate in
  Terminal.putDoc $ reann $ pretty0 x {unicode}


infixr 6 <//>
export %inline
(<//>) : Doc a -> Doc a -> Doc a
a <//> b = sep [a, b]

infixr 6 </>
export %inline
(</>) : Doc a -> Doc a -> Doc a
a </> b = cat [a, b]