quox/lib/Quox/Pretty.idr

281 lines
6.5 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 Data.SnocList
2021-07-20 16:05:19 -04:00
import public Control.Monad.Identity
import public Control.Monad.Reader
2023-03-02 13:52:32 -05:00
import Derive.Prelude
2021-07-20 16:05:19 -04:00
%default total
2022-05-13 01:05:55 -04:00
%language ElabReflection
%hide TT.Name
2021-07-20 16:05:19 -04:00
2022-04-11 15:58:33 -04:00
public export
record PrettyOpts where
constructor MakePrettyOpts
unicode, color : Bool
public export
defPrettyOpts : PrettyOpts
defPrettyOpts = MakePrettyOpts {unicode = True, color = True}
2021-07-20 16:05:19 -04:00
public export
data HL
2022-05-13 01:05:55 -04:00
= Delim
| Free | TVar | TVarErr
| Dim | DVar | DVarErr
| Qty
| Syntax
| Tag
2023-03-02 13:52:32 -05:00
%runElab derive "HL" [Eq, Ord, Show]
2021-07-20 16:05:19 -04:00
public export
data PPrec
2022-05-13 01:05:55 -04:00
= Outer
| AnnR -- right of "∷"
| AnnL -- left of "∷"
| Eq -- "_ ≡ _ : _"
| InEq -- arguments of ≡
| Times -- "_ × _"
| InTimes -- arguments of ×
2021-07-20 16:05:19 -04:00
-- ...
2022-05-13 01:05:55 -04:00
| App -- term/dimension application
| SApp -- substitution application
| Arg -- argument to nonfix function
2023-03-02 13:52:32 -05:00
%runElab derive "PPrec" [Eq, Ord, Show]
2021-07-20 16:05:19 -04:00
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'
2023-01-20 20:34:28 -05:00
export %inline
delims : Doc HL -> Doc HL -> Doc HL -> Doc HL
delims l r doc = hl Delim l <+> doc <+> hl Delim r
2021-09-09 17:51:29 -04:00
export %inline
2021-07-20 16:05:19 -04:00
parens : Doc HL -> Doc HL
2023-01-20 20:34:28 -05:00
parens = delims "(" ")"
export %inline
bracks : Doc HL -> Doc HL
bracks = delims "[" "]"
2021-07-20 16:05:19 -04:00
2023-01-26 13:54:46 -05:00
||| includes spaces inside the braces
export %inline
braces : Doc HL -> Doc HL
braces doc = hl Delim "{" <++> doc <++> hl Delim "}"
2021-09-09 17:51:29 -04:00
export %inline
2021-07-20 16:05:19 -04:00
parensIf : Bool -> Doc HL -> Doc HL
parensIf True = parens
parensIf False = id
export %inline
comma : Doc HL
comma = hl Delim ","
export %inline
asep : List (Doc a) -> Doc a
asep = align . sep
2021-07-20 16:05:19 -04:00
2021-09-09 17:56:10 -04:00
export
separate' : Doc a -> List (Doc a) -> List (Doc a)
separate' s [] = []
separate' s [x] = [x]
separate' s (x :: xs) = x <+> s :: separate' s xs
export %inline
separate : Doc a -> List (Doc a) -> Doc a
separate s = sep . separate' s
export %inline
hseparate : Doc a -> List (Doc a) -> Doc a
hseparate s = hsep . separate' s
export %inline
vseparate : Doc a -> List (Doc a) -> Doc a
vseparate s = vsep . separate' s
export %inline
aseparate : Doc a -> List (Doc a) -> Doc a
aseparate s = align . separate s
2021-09-09 17:56:10 -04:00
2021-07-20 16:05:19 -04:00
public export
record PrettyEnv where
constructor MakePrettyEnv
||| names of bound dimension variables
dnames : SnocList BaseName
2021-07-20 16:05:19 -04:00
||| names of bound term variables
tnames : SnocList BaseName
2021-07-20 16:05:19 -04:00
||| use non-ascii characters for syntax
unicode : Bool
||| surrounding precedence level
prec : PPrec
2022-05-13 01:05:55 -04:00
public export
HasEnv : (Type -> Type) -> Type
HasEnv = MonadReader PrettyEnv
2021-07-20 16:05:19 -04:00
2021-09-09 17:51:29 -04:00
export %inline
ifUnicode : HasEnv m => (uni, asc : Lazy a) -> m a
2021-09-03 10:31:53 -04:00
ifUnicode uni asc = if (!ask).unicode then [|uni|] else [|asc|]
2021-07-20 16:05:19 -04:00
2021-09-09 17:51:29 -04:00
export %inline
parensIfM : HasEnv m => PPrec -> Doc HL -> m (Doc HL)
2021-09-03 10:31:53 -04:00
parensIfM d doc = pure $ parensIf ((!ask).prec > d) doc
2021-07-20 16:05:19 -04:00
2021-09-09 17:51:29 -04:00
export %inline
withPrec : HasEnv m => PPrec -> m a -> m a
2021-07-20 16:05:19 -04:00
withPrec d = local {prec := d}
public export data BinderSort = T | D
2023-01-20 20:34:28 -05:00
export %inline
unders : HasEnv m => BinderSort -> SnocList BaseName -> m a -> m a
unders T xs = local {prec := Outer, tnames $= (++ xs)}
unders D xs = local {prec := Outer, dnames $= (++ xs)}
2023-01-20 20:34:28 -05:00
2021-09-09 17:51:29 -04:00
export %inline
2023-02-22 01:40:19 -05:00
under : HasEnv m => BinderSort -> BaseName -> m a -> m a
under t x = unders t [< x]
2021-07-20 16:05:19 -04:00
public export
interface PrettyHL a where
prettyM : HasEnv m => a -> m (Doc HL)
2021-07-20 16:05:19 -04:00
export %inline
pretty0M : (PrettyHL a, HasEnv m) => a -> m (Doc HL)
2021-07-20 16:05:19 -04:00
pretty0M = local {prec := Outer} . prettyM
2023-03-15 10:54:51 -04:00
export %inline
2023-03-25 15:48:26 -04:00
runPrettyWith : (unicode : Bool) -> (dnames, tnames : SnocList BaseName) ->
Reader PrettyEnv a -> a
runPrettyWith unicode dnames tnames act =
let env = MakePrettyEnv {dnames, tnames, unicode, prec = Outer} in
2023-03-15 10:54:51 -04:00
runReader env act
2023-03-25 15:48:26 -04:00
export %inline
runPretty : (unicode : Bool) -> Reader PrettyEnv a -> a
runPretty unicode = runPrettyWith unicode [<] [<]
export %inline
pretty0With : PrettyHL a => (unicode : Bool) ->
(dnames, tnames : SnocList BaseName) ->
a -> Doc HL
pretty0With {unicode, dnames, tnames} =
runPrettyWith {unicode, dnames, tnames} . prettyM
export %inline
2022-04-11 15:58:33 -04:00
pretty0 : PrettyHL a => (unicode : Bool) -> a -> Doc HL
2023-03-25 15:48:26 -04:00
pretty0 unicode = pretty0With unicode [<] [<]
2021-07-20 16:05:19 -04:00
export PrettyHL BaseName where prettyM = pure . pretty . baseStr
export PrettyHL Name where prettyM = pure . pretty . toDots
export
nameSeq : HL -> List Name -> Doc HL
nameSeq h = hl h . asep . map (pretty0 False)
2021-09-09 17:51:29 -04:00
export %inline
2022-04-11 15:58:33 -04:00
prettyStr : PrettyHL a => (unicode : Bool) -> a -> String
prettyStr unicode =
2021-09-03 10:31:53 -04:00
let layout = layoutSmart (MkLayoutOptions (AvailablePerLine 80 0.8)) in
2022-04-11 15:58:33 -04:00
renderString . layout . pretty0 unicode
2021-07-20 16:05:19 -04:00
export
termHL : HL -> AnsiStyle
2023-02-26 05:18:11 -05:00
termHL Delim = neutral
2021-07-20 16:05:19 -04:00
termHL TVar = color BrightYellow
termHL TVarErr = color BrightYellow <+> underline
2023-02-26 05:18:11 -05:00
termHL Dim = color BrightGreen
2021-07-20 16:05:19 -04:00
termHL DVar = color BrightGreen
termHL DVarErr = color BrightGreen <+> underline
2023-02-26 05:18:11 -05:00
termHL Qty = color BrightMagenta
termHL Free = color BrightBlue
2022-04-11 08:09:48 -04:00
termHL Syntax = color BrightCyan
2023-02-26 05:18:11 -05:00
termHL Tag = color BrightRed
2021-07-20 16:05:19 -04:00
2021-09-09 17:51:29 -04:00
export %inline
prettyIO : PrettyOpts -> PrettyHL a => a -> IO Unit
prettyIO opts x =
2022-04-11 15:58:33 -04:00
let reann = if opts.color then map termHL else unAnnotate in
Terminal.putDoc $ reann $ pretty0 opts.unicode x
export %inline
prettyIODef : PrettyHL a => a -> IO Unit
prettyIODef = prettyIO defPrettyOpts
2021-07-20 16:05:19 -04:00
infixr 6 <%%>, <%>
2021-07-20 16:05:19 -04:00
export %inline
(<%%>) : Doc a -> Doc a -> Doc a
a <%%> b = sep [a, b]
2021-07-20 16:05:19 -04:00
export %inline
(<%>) : Doc a -> Doc a -> Doc a
a <%> b = cat [a, b]
||| wrapper for names that pretty-prints highlighted as a `TVar`.
2023-02-22 01:40:19 -05:00
public export data TVarName = TV BaseName
export %inline PrettyHL TVarName where prettyM (TV x) = hlF TVar $ prettyM x
||| wrapper for names that pretty-prints highlighted as a `DVar`.
2023-02-22 01:40:19 -05:00
public export data DVarName = DV BaseName
export %inline PrettyHL DVarName where prettyM (DV x) = hlF DVar $ prettyM x
2023-04-02 09:50:56 -04:00
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
public export
WithPretty : Type -> Type
WithPretty a = (PrettyHL a, a)
export %inline PrettyHL (WithPretty a) where prettyM x = prettyM $ snd x
export %inline
epretty : PrettyHL a => a -> Exists WithPretty
epretty @{p} x = Evidence a (p, x)
public export data Lit = L (Doc HL)
export PrettyHL Lit where prettyM (L doc) = pure doc