bricks-rendering-0.0.0.4: src/Bricks/Rendering.hs
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Bricks.Rendering
(
-- * @Render@
Render
, RenderContext (..)
, renderContext'default
, renderContext'terse
-- * Expressions
, render'expression
, render'expression'listContext
, render'expression'dotLeftContext
, render'expression'applyLeftContext
, render'expression'applyRightContext
, render'expression'inParens
, render'expression'dictKey
-- * Variables
, render'var
-- * Strings
, str'escape
-- ** Static strings
, render'strStatic'unquotedIfPossible
, render'strStatic'quoted
-- ** Dynamic strings
, render'strDynamic'unquotedIfPossible
, render'strDynamic'quoted
, render'str'1
-- ** Indented strings
, render'str'indented
, render'str'indented'1
-- * Lists
, render'list
-- * Dicts
, render'dict
, render'dictBinding
-- * Dict lookup
, render'dot
-- * Lambdas
, render'lambda
-- * Function parameters
, render'param
, render'dictPattern
, render'dictPattern'1
-- * Function application
, render'apply
-- * @let@
, render'let
, render'letBinding
) where
-- Bricks
import Bricks.Expression
import Bricks.Keyword
import Bricks.UnquotedString
-- Bricks internal
import Bricks.Internal.Prelude
import Bricks.Internal.Seq (Seq)
import qualified Bricks.Internal.Seq as Seq
import Bricks.Internal.Text (Text)
import qualified Bricks.Internal.Text as Text
-- base
import Prelude (Num (..), fromIntegral)
--------------------------------------------------------------------------------
-- $setup
--
-- >>> import Bricks.Expression.Construction
--------------------------------------------------------------------------------
type Render a = RenderContext -> a -> Text
data RenderContext =
RenderContext
{ renderContext'indentStart :: Natural
, renderContext'indentStep :: Natural
, renderContext'lineBreaks :: Bool
}
renderContext'default :: RenderContext
renderContext'default =
RenderContext
{ renderContext'indentStart = 0
, renderContext'indentStep = 2
, renderContext'lineBreaks = True
}
renderContext'terse :: RenderContext
renderContext'terse =
renderContext'default
{ renderContext'lineBreaks = False
}
indentMore :: RenderContext -> RenderContext
indentMore x =
x{ renderContext'indentStart = renderContext'indentStart x +
renderContext'indentStep x }
indentation :: Natural -> Text
indentation n = Text.replicate (fromIntegral n) " "
--------------------------------------------------------------------------------
{- | Insert escape sequences for rendering normal double-quoted (@"@) strings.
-}
str'escape :: Text -> Text
str'escape =
Text.replace "\"" "\\\"" .
Text.replace "${" "\\${" .
Text.replace "\n" "\\n" .
Text.replace "\r" "\\r" .
Text.replace "\t" "\\t" .
Text.replace "\\" "\\\\"
{- | Render an unquoted string in unquoted form. -}
render'var :: Render Var
render'var _cx v = var'text v
{- | Render a static string, in unquoted form if possible. -}
render'strStatic'unquotedIfPossible :: Render Str'Static
render'strStatic'unquotedIfPossible _cx s =
let
x = str'static'text s
in
if text'canBeUnquoted x
then x
else render'strStatic'quoted _cx s
{- | Render a static string, in quoted form. -}
render'strStatic'quoted :: Render Str'Static
render'strStatic'quoted _cx x =
"\"" <> (str'escape . str'static'text) x <> "\""
{- | Render a dynamic string, in unquoted form if possible. -}
render'strDynamic'unquotedIfPossible :: Render Str'Dynamic
render'strDynamic'unquotedIfPossible cx d =
case str'dynamic'to'static d of
Just s -> render'strStatic'unquotedIfPossible cx s
Nothing -> render'strDynamic'quoted cx d
{- | Render a dynamic string, in quoted form. -}
render'strDynamic'quoted :: Render Str'Dynamic
render'strDynamic'quoted cx xs =
"\"" <> foldMap (render'str'1 cx) (strDynamic'toSeq xs) <> "\""
render'str'1 :: Render Str'1
render'str'1 cx =
\case
Str'1'Literal x -> (str'escape . str'static'text) x
Str'1'Antiquote x ->
let cx' = cx{ renderContext'lineBreaks = False }
in "${" <> render'expression cx' x <> "}"
render'str'indented :: Render InStr
render'str'indented cx (inStr'dedent . inStr'trim -> (InStr xs _)) =
"''\n" <>
Text.concatMap (render'str'indented'1 (indentMore cx)) xs <>
indentation (renderContext'indentStart cx) <> "''"
render'str'indented'1 :: Render InStr'1
render'str'indented'1 cx x =
indentation (inStr'1'level x + renderContext'indentStart cx) <>
Text.concatMap (render'str'1 cx) (inStr'1'str x) <>
"\n"
{- | Render a lambda parameter: everything from the beginning of a lambda, up to
but not including the @:@ that separates the head from the body of the lambda.
-}
render'param :: Render Param
render'param cx =
\case
Param'Name a -> render'var cx a
Param'DictPattern b -> render'dictPattern cx b
Param'Both a b -> render'var cx a <> "@" <>
render'dictPattern cx b
{- | Render a dict pattern (@{ a, b ? c, ... }@). -}
render'dictPattern :: Render DictPattern
render'dictPattern cx (DictPattern bs e) =
if Seq.null xs
then "{ }"
else "{ " <> Text.intercalate ", " xs <> " }"
where
xs :: Seq Text
xs =
Seq.map (render'dictPattern'1 cx) bs <>
if e then Seq.singleton "..." else Seq.empty
{- | Render a single item in a 'DictPattern'. -}
render'dictPattern'1 :: Render DictPattern'1
render'dictPattern'1 cx =
\case
DictPattern'1 a Nothing -> render'var cx a
DictPattern'1 a (Just b) -> render'var cx a <> " ? " <>
render'expression cx b
{- | Render a lambda expression (@x: y@). -}
render'lambda :: Render Lambda
render'lambda cx x =
render'param cx (lambda'head x) <> ":" <> sp <>
render'expression cx' (lambda'body x)
where
sp = if lbr
then "\n" <> indentation (renderContext'indentStart cx)
else " "
lbr = renderContext'lineBreaks cx
cx' = indentMore cx
{- | Render a function application expression (@f x@). -}
render'apply :: Render Apply
render'apply cx x =
render'expression'applyLeftContext cx (apply'func x) <> " " <>
render'expression'applyRightContext cx (apply'arg x)
{- | Render a list literal (@[@ ... @]@). -}
render'list :: Render List
render'list cx x =
if Seq.null (list'expressions x)
then "[ ]"
else "[" <> sp <> r (list'expressions x) <> "]"
where
r = Text.concat . fmap
(\y ->
(if lbr then indentation (renderContext'indentStart cx') else "") <>
render'expression'listContext cx' y <> sp
)
sp = if lbr then "\n" else " "
cx' = indentMore cx
lbr = renderContext'lineBreaks cx
{- | Render a dict literal (@{@ ... @}@). -}
render'dict :: Render Dict
render'dict cx x =
(if dict'rec x then keywordText keyword'rec <> " " else "") <>
if Seq.null (dict'bindings x)
then "{ }"
else "{" <> sp <> r (dict'bindings x) <>
(if lbr then indentation (renderContext'indentStart cx) else "") <> "}"
where
r = Text.concat . fmap
(\b ->
(if lbr then indentation (renderContext'indentStart cx') else "") <>
render'dictBinding cx' b <> sp
)
sp = if lbr then "\n" else " "
cx' = indentMore cx
lbr = renderContext'lineBreaks cx
{- | Render a binding within a 'Dict', including the trailing semicolon. -}
render'dictBinding :: Render DictBinding
render'dictBinding cx =
\case
DictBinding'Eq a b ->
render'expression'dictKey cx a <> " = " <>
render'expression cx' b <> ";"
DictBinding'Inherit'Dict a b ->
"inherit " <> render'expression'inParens cx a <>
Text.concatMap
(\x ->
" " <> render'strStatic'unquotedIfPossible cx x
) b <>
";"
DictBinding'Inherit'Var a ->
"inherit" <> Text.concatMap (\x -> " " <> render'var cx x) a <> ";"
where
cx' = indentMore cx
{- | Render a dot expression (@a.b@). -}
render'dot :: Render Dot
render'dot cx x =
render'expression'dotLeftContext cx (dot'dict x) <> "." <>
render'expression'dictKey cx (dot'key x)
{- | Render a @let@-@in@ expression. -}
render'let :: Render Let
render'let cx x =
keywordText keyword'let <> sp <> r (let'bindings x) <>
(if lbr then indentation (renderContext'indentStart cx) else "") <>
keywordText keyword'in <> sp <>
(if lbr then indentation (renderContext'indentStart cx') else "") <>
render'expression cx' (let'value x)
where
r = Text.concat . fmap
(\b ->
(if lbr then indentation (renderContext'indentStart cx') else "") <>
render'letBinding cx' b <> sp
)
cx' = indentMore cx
sp = if lbr then "\n" else " "
lbr = renderContext'lineBreaks cx
{- | Render a binding within a 'Let', including the trailing semicolon. -}
render'letBinding :: Render LetBinding
render'letBinding cx =
\case
LetBinding'Eq a b ->
render'var cx a <> " = " <> render'expression cx' b <> ";"
LetBinding'Inherit a b ->
"inherit " <> render'expression'inParens cx a <>
Text.concatMap (\x -> " " <> render'var cx x) b <> ";"
where
cx' = indentMore cx
{- | Render an expression. -}
-- | ==== Examples
--
-- >>> :{
-- >>> render'expression renderContext'terse
-- >>> (lambda
-- >>> (param "a" <> pattern
-- >>> [ dict'param "f"
-- >>> , dict'param "b" & def (apply (var "g") (var "x"))
-- >>> ] <> ellipsis)
-- >>> (apply (var "f") (var "b")))
-- >>> :}
-- "a@{ f, b ? g x, ... }: f b"
render'expression :: Render Expression
render'expression cx =
\case
Expr'Str x -> render'strDynamic'quoted cx x
Expr'Str'Indented x -> render'str'indented cx x
Expr'Dict x -> render'dict cx x
Expr'List x -> render'list cx x
Expr'Var x -> render'var cx x
Expr'Dot x -> render'dot cx x
Expr'Lambda x -> render'lambda cx x
Expr'Apply x -> render'apply cx x
Expr'Let x -> render'let cx x
{- | Render an expression in a list context. -}
render'expression'listContext :: Render Expression
render'expression'listContext cx x =
case x of
Expr'Lambda _ -> render'expression'inParens cx x
Expr'Apply _ -> render'expression'inParens cx x
Expr'Let _ -> render'expression'inParens cx x
_ -> render'expression cx x
{- | Render an expression in the context of the left-hand side of a 'Dot'. -}
render'expression'dotLeftContext :: Render Expression
render'expression'dotLeftContext = render'expression'listContext
{- | Render an expression in the context of the left-hand side of an 'Apply'. -}
render'expression'applyLeftContext :: Render Expression
render'expression'applyLeftContext cx x =
case x of
Expr'Lambda _ -> render'expression'inParens cx x
Expr'Let _ -> render'expression'inParens cx x
_ -> render'expression cx x
{- | Render an expression in the context of the right-hand side of an 'Apply'.
-}
render'expression'applyRightContext :: Render Expression
render'expression'applyRightContext cx x =
case x of
Expr'Apply _ -> render'expression'inParens cx x
Expr'Let _ -> render'expression'inParens cx x
_ -> render'expression cx x
render'expression'inParens :: Render Expression
render'expression'inParens cx x =
"(" <> render'expression cx x <> ")"
render'expression'dictKey :: Render Expression
render'expression'dictKey cx = \case
Expr'Str x -> render'strDynamic'unquotedIfPossible cx x
x -> "${" <> render'expression cx x <> "}"