quox/lib/Quox/Pretty.idr

363 lines
9.9 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-09-18 18:41:47 -04:00
import Control.Monad.ST.Extra
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
2023-11-05 08:30:40 -05:00
| Constant
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 =
2023-08-25 12:09:06 -04:00
runST $ do
runEff act $ with Union.(::)
2023-09-18 18:41:47 -04:00
[handleStateSTRef !(newSTRef prec),
2023-08-25 12:09:06 -04:00
handleReaderConst flavor,
handleReaderConst highlight,
handleReaderConst indent]
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]
2023-11-05 08:30:40 -05:00
toSGR Constant = [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-11-05 09:47:52 -05:00
export %inline
toClass : HL -> String
toClass Delim = "dl"
toClass Free = "fr"
toClass TVar = "tv"
toClass TVarErr = "tv err"
toClass Dim = "dc"
toClass DVar = "dv"
toClass DVarErr = "dv err"
toClass Qty = "qt"
toClass Universe = "un"
toClass Syntax = "sy"
toClass Constant = "co"
2023-01-26 13:54:46 -05:00
2021-09-09 17:51:29 -04:00
export %inline
2023-11-05 09:47:52 -05:00
highlightHtml : HL -> Highlight
highlightHtml h = MkHighlight #"<span class="\#{toClass h}">"# "</span>"
2021-07-20 16:05:19 -04:00
export %inline
2023-11-05 09:47:52 -05:00
runPrettyHL : (HL -> Highlight) -> Eff Pretty a -> a
runPrettyHL f = runPrettyWith Outer Unicode f 2
export %inline
runPretty : Eff Pretty a -> a
runPretty = runPrettyHL noHighlight
export %inline
2023-08-25 12:09:06 -04:00
hl : {opts : LayoutOpts} -> HL -> Doc opts -> Eff Pretty (Doc opts)
2023-05-14 13:58:46 -04:00
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-08-25 12:09:06 -04:00
indentD : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
2023-05-14 13:58:46 -04:00
indentD doc = pure $ indent !(askAt INDENT) doc
2021-09-09 17:56:10 -04:00
export %inline
2023-08-25 12:09:06 -04:00
hangD : {opts : LayoutOpts} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts)
2023-05-14 13:58:46 -04:00
hangD d1 d2 = pure $ hangSep !(askAt INDENT) d1 d2
2021-09-09 17:56:10 -04:00
2023-10-20 11:42:01 -04:00
export %inline
hangSingle : {opts : LayoutOpts} -> Nat -> Doc opts -> Doc opts -> Doc opts
hangSingle n d1 d2 = ifMultiline (d1 <++> d2) (vappend d1 (indent n d2))
2021-09-09 17:56:10 -04:00
export %inline
2023-08-25 12:09:06 -04:00
hangDSingle : {opts : LayoutOpts} -> Doc opts -> Doc opts ->
Eff Pretty (Doc opts)
2023-10-20 11:42:01 -04:00
hangDSingle d1 d2 = pure $ hangSingle !(askAt INDENT) d1 d2
2021-09-09 17:56:10 -04:00
2023-05-14 13:58:46 -04:00
export
2023-08-25 12:09:06 -04:00
tightDelims : {opts : LayoutOpts} -> (l, r : String) -> (inner : Doc opts) ->
2023-05-14 13:58:46 -04:00
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
2023-08-25 12:09:06 -04:00
looseDelims : {opts : LayoutOpts} -> (l, r : String) -> (inner : Doc opts) ->
2023-05-14 13:58:46 -04:00
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
2023-08-25 12:09:06 -04:00
parens : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
2023-05-14 13:58:46 -04:00
parens = tightDelims "(" ")"
2021-07-20 16:05:19 -04:00
2021-09-09 17:51:29 -04:00
export %inline
2023-08-25 12:09:06 -04:00
bracks : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
2023-05-14 13:58:46 -04:00
bracks = tightDelims "[" "]"
2021-07-20 16:05:19 -04:00
2021-09-09 17:51:29 -04:00
export %inline
2023-08-25 12:09:06 -04:00
braces : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
2023-05-14 13:58:46 -04:00
braces = looseDelims "{" "}"
2021-07-20 16:05:19 -04:00
export %inline
2023-08-25 12:09:06 -04:00
tightBraces : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
tightBraces = tightDelims "{" "}"
2021-09-09 17:51:29 -04:00
export %inline
2023-08-25 12:09:06 -04:00
parensIf : {opts : LayoutOpts} -> Bool -> Doc opts -> Eff Pretty (Doc opts)
2023-05-14 13:58:46 -04:00
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
2023-08-25 12:09:06 -04:00
sepSingle : {opts : LayoutOpts} -> List (Doc opts) -> Doc opts
2023-05-14 13:58:46 -04:00
sepSingle xs = ifMultiline (hsep xs) (vsep xs)
2023-01-20 20:34:28 -05:00
2023-05-14 13:58:46 -04:00
export
2023-08-25 12:09:06 -04:00
fillSep : {opts : LayoutOpts} -> List (Doc opts) -> Doc opts
2023-05-14 13:58:46 -04:00
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
2023-08-25 12:09:06 -04:00
exceptLast : {opts : LayoutOpts} -> (Doc opts -> Doc opts) ->
2023-05-14 13:58:46 -04:00
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-11-03 12:47:01 -04:00
export
hseparateTight : Doc opts -> t (Doc opts) -> Doc opts
hseparateTight d = hsep . exceptLast (<+> d) . toList
export
vseparateTight : Doc opts -> t (Doc opts) -> Doc opts
vseparateTight d = vsep . exceptLast (<+> d) . toList
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
2023-10-20 11:42:01 -04:00
export %inline
pshow : {opts : LayoutOpts} -> Show a => a -> Doc opts
pshow = text . show
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-08-25 12:09:06 -04:00
parensIfM : {opts : LayoutOpts} -> PPrec -> Doc opts -> Eff Pretty (Doc opts)
2023-05-14 13:58:46 -04:00
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-08-25 12:09:06 -04:00
prettyFree : {opts : LayoutOpts} -> 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
2023-09-20 15:58:27 -04:00
prettyBind' = text . baseStr . val
2021-07-20 16:05:19 -04:00
2023-05-14 13:58:46 -04:00
export
2023-08-25 12:09:06 -04:00
prettyTBind : {opts : LayoutOpts} -> BindName -> Eff Pretty (Doc opts)
2023-05-14 13:58:46 -04:00
prettyTBind = hl TVar . prettyBind'
2022-04-11 15:58:33 -04:00
2023-05-14 13:58:46 -04:00
export
2023-08-25 12:09:06 -04:00
prettyDBind : {opts : LayoutOpts} -> BindName -> Eff Pretty (Doc opts)
2023-05-14 13:58:46 -04:00
prettyDBind = hl DVar . prettyBind'
2021-07-20 16:05:19 -04:00
export %inline
typeD, ioStateD, arrowD, darrowD, timesD, lamD, eqndD, dlamD, annD, natD,
2023-11-05 09:44:44 -05:00
stringD, eqD, colonD, commaD, semiD, atD, caseD, typecaseD, returnD,
2023-09-18 15:52:51 -04:00
ofD, dotD, zeroD, succD, coeD, compD, undD, cstD, pipeD, fstD, sndD :
2023-08-25 12:09:06 -04:00
{opts : LayoutOpts} -> Eff Pretty (Doc opts)
2023-05-14 13:58:46 -04:00
typeD = hl Syntax . text =<< ifUnicode "" "Type"
ioStateD = hl Syntax $ text "IOState"
arrowD = hl Syntax . text =<< ifUnicode "" "->"
darrowD = hl Syntax . text =<< ifUnicode "" "=>"
timesD = hl Syntax . text =<< ifUnicode "×" "**"
2023-05-14 13:58:46 -04:00
lamD = hl Syntax . text =<< ifUnicode "λ" "fun"
eqndD = hl Syntax . text =<< ifUnicode "" "=="
2023-05-14 13:58:46 -04:00
dlamD = hl Syntax . text =<< ifUnicode "δ" "dfun"
annD = hl Syntax . text =<< ifUnicode "" "::"
2023-05-14 13:58:46 -04:00
natD = hl Syntax . text =<< ifUnicode "" "Nat"
2023-11-05 08:30:40 -05:00
stringD = hl Syntax $ text "String"
eqD = hl Syntax $ text "Eq"
colonD = hl Syntax $ text ":"
commaD = hl Syntax $ text ","
2023-11-05 08:30:40 -05:00
semiD = hl Delim $ text ";"
2023-11-05 09:44:44 -05:00
atD = hl Delim $ text "@"
2023-11-05 08:30:40 -05:00
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 Constant $ text "zero"
succD = hl Constant $ text "succ"
coeD = hl Syntax $ text "coe"
compD = hl Syntax $ text "comp"
undD = hl Syntax $ text "_"
cstD = hl Syntax $ text "="
pipeD = hl Delim $ text "|"
2023-11-05 08:30:40 -05:00
fstD = hl Syntax $ text "fst"
sndD = hl Syntax $ text "snd"
2023-04-02 09:50:56 -04:00
export
2023-08-25 12:09:06 -04:00
prettyApp : {opts : LayoutOpts} -> Nat -> Doc opts ->
List (Doc opts) -> Doc opts
2023-05-14 13:58:46 -04:00
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-08-25 12:09:06 -04:00
prettyAppD : {opts : LayoutOpts} -> Doc opts -> List (Doc opts) ->
Eff Pretty (Doc opts)
2023-05-14 13:58:46 -04:00
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
2023-08-25 12:09:06 -04:00
prettyBounds : {opts : LayoutOpts} -> Bounds -> Eff Pretty (Doc opts)
2023-05-14 13:58:46 -04:00
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-08-25 12:09:06 -04:00
prettyLoc : {opts : LayoutOpts} -> Loc -> Eff Pretty (Doc opts)
2023-05-14 13:58:46 -04:00
prettyLoc (L NoLoc) =
hcat <$> sequence [hl TVarErr "no location", colonD]
prettyLoc (L (YesLoc file b)) =
hcat <$> sequence [hl Free $ text file, colonD, prettyBounds b]
2023-09-20 15:58:42 -04:00
export
prettyTag : {opts : _} -> String -> Eff Pretty (Doc opts)
2023-11-05 08:30:40 -05:00
prettyTag tag = hl Constant $ text $ "'" ++ quoteTag tag
export
prettyStrLit : {opts : _} -> String -> Eff Pretty (Doc opts)
prettyStrLit s =
let s = concatMap esc1 $ unpack s in
2023-11-05 08:30:40 -05:00
hl Constant $ hcat ["\"", text s, "\""]
where
esc1 : Char -> String
esc1 '"' = "\""; esc1 '\\' = "\\"
esc1 c = singleton c