quox/src/Quox/Pretty.idr

201 lines
4.2 KiB
Idris
Raw Normal View History

2021-07-20 16:05:19 -04:00
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]