quox/lib/Quox/Pretty.idr

305 lines
8 KiB
Idris
Raw Normal View History

2021-07-20 16:05:19 -04:00
module Quox.Pretty
2023-05-01 21:06:25 -04:00
import Quox.Loc
2021-07-20 16:05:19 -04:00
import Quox.Name
2023-05-14 13:58:46 -04:00
import public Text.PrettyPrint.Bernardy
import public Text.PrettyPrint.Bernardy.Core.Decorate
import public Quox.EffExtra
2021-07-20 16:05:19 -04:00
import public Data.String
2023-05-14 13:58:46 -04:00
import Control.ANSI.SGR
2021-07-20 16:05:19 -04:00
import Data.DPair
import Data.SnocList
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
2023-05-14 13:58:46 -04:00
data PPrec
= Outer
| Times -- "_ × _"
| InTimes -- arguments of ×
| AnnL -- left of "∷"
| Eq -- "_ ≡ _ : _"
| InEq -- arguments of ≡
-- ...
| App -- term/dimension application
| Arg -- argument to nonfix function
%runElab derive "PPrec" [Eq, Ord, Show]
2022-04-11 15:58:33 -04:00
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
2023-05-21 14:09:34 -04:00
| Qty | Universe
2022-05-13 01:05:55 -04:00
| Syntax
| Tag
2023-03-02 13:52:32 -05:00
%runElab derive "HL" [Eq, Ord, Show]
2021-07-20 16:05:19 -04:00
2023-05-14 13:58:46 -04:00
public export
data Flavor = Unicode | Ascii
%runElab derive "Flavor" [Eq, Ord, Show]
2021-07-20 16:05:19 -04:00
export %inline
2023-05-14 13:58:46 -04:00
noHighlight : HL -> Highlight
noHighlight _ = MkHighlight "" ""
2021-07-20 16:05:19 -04:00
2023-05-14 13:58:46 -04:00
public export
data EffTag = PREC | FLAVOR | HIGHLIGHT | INDENT
2021-07-20 16:05:19 -04:00
2023-05-14 13:58:46 -04:00
public export
Pretty : List (Type -> Type)
Pretty = [StateL PREC PPrec, ReaderL FLAVOR Flavor,
ReaderL HIGHLIGHT (HL -> Highlight), ReaderL INDENT Nat]
2021-07-20 16:05:19 -04:00
2023-01-20 20:34:28 -05:00
export %inline
2023-05-14 13:58:46 -04:00
runPrettyWith : PPrec -> Flavor -> (HL -> Highlight) -> Nat ->
Eff Pretty a -> a
runPrettyWith prec flavor highlight indent act =
extract $
evalStateAt PREC prec $
runReaderAt FLAVOR flavor $
runReaderAt HIGHLIGHT highlight $
runReaderAt INDENT indent act
2023-01-20 20:34:28 -05:00
export %inline
2023-05-14 13:58:46 -04:00
toSGR : HL -> List SGR
2023-05-21 14:09:34 -04:00
toSGR Delim = []
toSGR Free = [SetForeground BrightBlue]
toSGR TVar = [SetForeground BrightYellow]
toSGR TVarErr = [SetForeground BrightYellow, SetStyle SingleUnderline]
toSGR Dim = [SetForeground BrightGreen]
toSGR DVar = [SetForeground BrightGreen]
toSGR DVarErr = [SetForeground BrightGreen, SetStyle SingleUnderline]
toSGR Qty = [SetForeground BrightMagenta]
toSGR Universe = [SetForeground BrightRed]
toSGR Syntax = [SetForeground BrightCyan]
toSGR Tag = [SetForeground BrightRed]
2021-07-20 16:05:19 -04:00
2023-01-26 13:54:46 -05:00
export %inline
2023-05-14 13:58:46 -04:00
highlightSGR : HL -> Highlight
highlightSGR h = MkHighlight (escapeSGR $ toSGR h) (escapeSGR [Reset])
2023-01-26 13:54:46 -05:00
2021-09-09 17:51:29 -04:00
export %inline
2023-05-14 13:58:46 -04:00
runPretty : Eff Pretty a -> a
runPretty = runPrettyWith Outer Unicode noHighlight 2
2021-07-20 16:05:19 -04:00
export %inline
2023-05-14 13:58:46 -04:00
runPrettyColor : Eff Pretty a -> a
runPrettyColor = runPrettyWith Outer Unicode highlightSGR 2
export %inline
2023-05-14 13:58:46 -04:00
hl : {opts : _} -> HL -> Doc opts -> Eff Pretty (Doc opts)
hl h doc = asksAt HIGHLIGHT $ \f => decorate (f h) doc
2021-07-20 16:05:19 -04:00
2021-09-09 17:56:10 -04:00
export %inline
2023-05-14 13:58:46 -04:00
indentD : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
indentD doc = pure $ indent !(askAt INDENT) doc
2021-09-09 17:56:10 -04:00
export %inline
2023-05-14 13:58:46 -04:00
hangD : {opts : _} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts)
hangD d1 d2 = pure $ hangSep !(askAt INDENT) d1 d2
2021-09-09 17:56:10 -04:00
export %inline
2023-05-14 13:58:46 -04:00
hangDSingle : {opts : _} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts)
hangDSingle d1 d2 =
pure $ ifMultiline (d1 <++> d2) (vappend d1 !(indentD d2))
2021-09-09 17:56:10 -04:00
2023-05-14 13:58:46 -04:00
export
tightDelims : {opts : _} -> (l, r : String) -> (inner : Doc opts) ->
Eff Pretty (Doc opts)
tightDelims l r inner = do
l <- hl Delim $ text l
r <- hl Delim $ text r
pure $ hcat [l, inner, r]
2021-09-09 17:56:10 -04:00
2023-05-14 13:58:46 -04:00
export
looseDelims : {opts : _} -> (l, r : String) -> (inner : Doc opts) ->
Eff Pretty (Doc opts)
looseDelims l r inner = do
l <- hl Delim $ text l
r <- hl Delim $ text r
let short = hsep [l, inner, r]
long = vsep [l, !(indentD inner), r]
pure $ ifMultiline short long
2021-07-20 16:05:19 -04:00
2023-05-14 13:58:46 -04:00
export %inline
parens : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
parens = tightDelims "(" ")"
2021-07-20 16:05:19 -04:00
2021-09-09 17:51:29 -04:00
export %inline
2023-05-14 13:58:46 -04:00
bracks : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
bracks = tightDelims "[" "]"
2021-07-20 16:05:19 -04:00
2021-09-09 17:51:29 -04:00
export %inline
2023-05-14 13:58:46 -04:00
braces : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
braces = looseDelims "{" "}"
2021-07-20 16:05:19 -04:00
export %inline
tightBraces : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
tightBraces = tightDelims "{" "}"
2021-09-09 17:51:29 -04:00
export %inline
2023-05-14 13:58:46 -04:00
parensIf : {opts : _} -> Bool -> Doc opts -> Eff Pretty (Doc opts)
parensIf True = parens
parensIf False = pure
2021-07-20 16:05:19 -04:00
2023-05-14 13:58:46 -04:00
||| uses hsep only if the whole list fits on one line
export
sepSingle : {opts : _} -> List (Doc opts) -> Doc opts
sepSingle xs = ifMultiline (hsep xs) (vsep xs)
2023-01-20 20:34:28 -05:00
2023-05-14 13:58:46 -04:00
export
fillSep : {opts : _} -> List (Doc opts) -> Doc opts
fillSep [] = empty
fillSep (x :: xs) = foldl (\x, y => sep [x, y]) x xs
2021-07-20 16:05:19 -04:00
2023-05-14 13:58:46 -04:00
export
exceptLast : {opts : _} -> (Doc opts -> Doc opts) ->
List (Doc opts) -> List (Doc opts)
exceptLast f [] = []
exceptLast f [x] = [x]
exceptLast f (x :: xs) = f x :: exceptLast f xs
2021-07-20 16:05:19 -04:00
2023-05-14 13:58:46 -04:00
parameters {opts : LayoutOpts} {auto _ : Foldable t}
export
separateLoose : Doc opts -> t (Doc opts) -> Doc opts
separateLoose d = sep . exceptLast (<++> d) . toList
2021-07-20 16:05:19 -04:00
2023-05-14 13:58:46 -04:00
export
separateTight : Doc opts -> t (Doc opts) -> Doc opts
separateTight d = sep . exceptLast (<+> d) . toList
2021-07-20 16:05:19 -04:00
2023-05-14 13:58:46 -04:00
export
fillSeparateTight : Doc opts -> t (Doc opts) -> Doc opts
fillSeparateTight d = fillSep . exceptLast (<+> d) . toList
2023-03-15 10:54:51 -04:00
2023-03-25 15:48:26 -04:00
export %inline
2023-05-14 13:58:46 -04:00
ifUnicode : (uni, asc : Lazy a) -> Eff Pretty a
ifUnicode uni asc =
asksAt FLAVOR $ \case
Unicode => uni
Ascii => asc
2023-03-25 15:48:26 -04:00
export %inline
2023-05-14 13:58:46 -04:00
parensIfM : {opts : _} -> PPrec -> Doc opts -> Eff Pretty (Doc opts)
parensIfM d doc = parensIf (!(getAt PREC) > d) doc
2021-07-20 16:05:19 -04:00
2023-05-14 13:58:46 -04:00
export %inline
withPrec : PPrec -> Eff Pretty a -> Eff Pretty a
withPrec = localAt_ PREC
2021-07-20 16:05:19 -04:00
2023-05-21 14:09:34 -04:00
export
prettyName : Name -> Doc opts
prettyName = text . toDots
export
2023-05-14 13:58:46 -04:00
prettyFree : {opts : _} -> Name -> Eff Pretty (Doc opts)
2023-05-21 14:09:34 -04:00
prettyFree = hl Free . prettyName
2021-07-20 16:05:19 -04:00
export
2023-05-14 13:58:46 -04:00
prettyBind' : BindName -> Doc opts
prettyBind' = text . baseStr . name
2021-07-20 16:05:19 -04:00
2023-05-14 13:58:46 -04:00
export
prettyTBind : {opts : _} -> BindName -> Eff Pretty (Doc opts)
prettyTBind = hl TVar . prettyBind'
2022-04-11 15:58:33 -04:00
2023-05-14 13:58:46 -04:00
export
prettyDBind : {opts : _} -> BindName -> Eff Pretty (Doc opts)
prettyDBind = hl DVar . prettyBind'
2021-07-20 16:05:19 -04:00
export %inline
2023-05-14 13:58:46 -04:00
typeD, arrowD, darrowD, timesD, lamD, eqndD, dlamD, annD, natD,
eqD, colonD, commaD, semiD, caseD, typecaseD, returnD,
ofD, dotD, zeroD, succD, coeD, compD, undD, cstD, pipeD :
{opts : _} -> Eff Pretty (Doc opts)
typeD = hl Syntax . text =<< ifUnicode "" "Type"
arrowD = hl Delim . text =<< ifUnicode "" "->"
darrowD = hl Delim . text =<< ifUnicode "" "=>"
timesD = hl Delim . text =<< ifUnicode "×" "**"
lamD = hl Syntax . text =<< ifUnicode "λ" "fun"
eqndD = hl Delim . text =<< ifUnicode "" "=="
dlamD = hl Syntax . text =<< ifUnicode "δ" "dfun"
annD = hl Delim . text =<< ifUnicode "" "::"
natD = hl Syntax . text =<< ifUnicode "" "Nat"
eqD = hl Syntax $ text "Eq"
colonD = hl Delim $ text ":"
commaD = hl Delim $ text ","
semiD = hl Delim $ text ";"
caseD = hl Syntax $ text "case"
typecaseD = hl Syntax $ text "type-case"
ofD = hl Syntax $ text "of"
returnD = hl Syntax $ text "return"
dotD = hl Delim $ text "."
zeroD = hl Syntax $ text "zero"
succD = hl Syntax $ text "succ"
coeD = hl Syntax $ text "coe"
compD = hl Syntax $ text "comp"
undD = hl Syntax $ text "_"
cstD = hl Syntax $ text "="
pipeD = hl Syntax $ text "|"
2023-04-02 09:50:56 -04:00
export
2023-05-14 13:58:46 -04:00
prettyApp : {opts : _} -> Nat -> Doc opts -> List (Doc opts) -> Doc opts
prettyApp ind f args =
hsep (f :: args)
<|> hsep [f, vsep args]
<|> vsep (f :: map (indent ind) args)
2023-04-02 09:50:56 -04:00
export
2023-05-14 13:58:46 -04:00
prettyAppD : {opts : _} -> Doc opts -> List (Doc opts) -> Eff Pretty (Doc opts)
prettyAppD f args = pure $ prettyApp !(askAt INDENT) f args
2023-04-02 09:50:56 -04:00
2023-05-14 13:58:46 -04:00
export
escapeString : String -> String
escapeString = concatMap esc1 . unpack where
esc1 : Char -> String
esc1 '"' = #"\""#
esc1 '\\' = #"\\"#
esc1 '\n' = #"\n"#
esc1 c = singleton c
2023-04-02 09:50:56 -04:00
2023-05-14 13:58:46 -04:00
export
quoteTag : String -> String
quoteTag tag =
if isName tag then tag else
"\"" ++ escapeString tag ++ "\""
2023-05-01 21:06:25 -04:00
2023-05-14 13:58:46 -04:00
export
prettyBounds : {opts : _} -> Bounds -> Eff Pretty (Doc opts)
prettyBounds (MkBounds l1 c1 l2 c2) =
hcat <$> sequence
[hl TVar $ text $ show l1, colonD,
hl DVar $ text $ show c1, hl Delim "-",
hl TVar $ text $ show l2, colonD,
hl DVar $ text $ show c2, colonD]
2023-05-01 21:06:25 -04:00
export
2023-05-14 13:58:46 -04:00
prettyLoc : {opts : _} -> Loc -> Eff Pretty (Doc opts)
prettyLoc (L NoLoc) =
hcat <$> sequence [hl TVarErr "no location", colonD]
prettyLoc (L (YesLoc file b)) =
hcat <$> sequence [hl Free $ text file, colonD, prettyBounds b]