This commit is contained in:
rhiannon morris 2021-09-09 23:51:29 +02:00
parent b29fd538e4
commit b47ef502f3

View file

@ -87,11 +87,11 @@ hlF' : Functor f => HL -> f (Doc HL) -> f (Doc HL)
hlF' = map . hl' hlF' = map . hl'
export export %inline
parens : Doc HL -> Doc HL parens : Doc HL -> Doc HL
parens doc = hl Delim "(" <+> doc <+> hl Delim ")" parens doc = hl Delim "(" <+> doc <+> hl Delim ")"
export export %inline
parensIf : Bool -> Doc HL -> Doc HL parensIf : Bool -> Doc HL -> Doc HL
parensIf True = parens parensIf True = parens
parensIf False = id parensIf False = id
@ -112,21 +112,21 @@ record PrettyEnv where
public export %inline HasEnv : (Type -> Type) -> Type public export %inline HasEnv : (Type -> Type) -> Type
HasEnv = MonadReader PrettyEnv HasEnv = MonadReader PrettyEnv
export export %inline
ifUnicode : HasEnv m => (uni, asc : Lazy a) -> m a ifUnicode : HasEnv m => (uni, asc : Lazy a) -> m a
ifUnicode uni asc = if (!ask).unicode then [|uni|] else [|asc|] ifUnicode uni asc = if (!ask).unicode then [|uni|] else [|asc|]
export export %inline
parensIfM : HasEnv m => PPrec -> Doc HL -> m (Doc HL) parensIfM : HasEnv m => PPrec -> Doc HL -> m (Doc HL)
parensIfM d doc = pure $ parensIf ((!ask).prec > d) doc parensIfM d doc = pure $ parensIf ((!ask).prec > d) doc
export export %inline
withPrec : HasEnv m => PPrec -> m a -> m a withPrec : HasEnv m => PPrec -> m a -> m a
withPrec d = local {prec := d} withPrec d = local {prec := d}
public export data BinderSort = T | D public export data BinderSort = T | D
export export %inline
under : HasEnv m => BinderSort -> Name -> m a -> m a under : HasEnv m => BinderSort -> Name -> m a -> m a
under s x = local $ under s x = local $
{prec := Outer} . {prec := Outer} .
@ -161,7 +161,7 @@ export PrettyHL BaseName where prettyM = pure . pretty . baseStr
export PrettyHL Name where prettyM = pure . pretty . toDots export PrettyHL Name where prettyM = pure . pretty . toDots
export export %inline
prettyStr : PrettyHL a => {default True unicode : Bool} -> a -> String prettyStr : PrettyHL a => {default True unicode : Bool} -> a -> String
prettyStr {unicode} = prettyStr {unicode} =
let layout = layoutSmart (MkLayoutOptions (AvailablePerLine 80 0.8)) in let layout = layoutSmart (MkLayoutOptions (AvailablePerLine 80 0.8)) in
@ -180,7 +180,7 @@ termHL Qty = color BrightMagenta <+> bold
termHL Free = color BrightWhite termHL Free = color BrightWhite
termHL Syntax = color BrightBlue termHL Syntax = color BrightBlue
export export %inline
prettyTerm : {default True color, unicode : Bool} -> PrettyHL a => a -> IO Unit prettyTerm : {default True color, unicode : Bool} -> PrettyHL a => a -> IO Unit
prettyTerm x {color, unicode} = prettyTerm x {color, unicode} =
let reann = if color then map termHL else unAnnotate in let reann = if color then map termHL else unAnnotate in