{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wall #-}
module Dhall.Pretty.Internal (
Ann(..)
, annToAnsiStyle
, prettyExpr
, CharacterSet(..)
, prettyCharacterSet
, prettyVar
, pretty
, escapeText
, prettyConst
, prettyLabel
, prettyLabels
, prettyNatural
, prettyNumber
, prettyDouble
, prettyToStrictText
, prettyToString
, docToStrictText
, builtin
, keyword
, literal
, operator
, colon
, comma
, dot
, equals
, forall
, label
, lambda
, langle
, lbrace
, lbracket
, lparen
, pipe
, rangle
, rarrow
, rbrace
, rbracket
, rparen
) where
import Dhall.Core
#if MIN_VERSION_base(4,8,0)
#else
import Control.Applicative (Applicative(..), (<$>))
#endif
import Data.Foldable
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Text.Prettyprint.Doc (Doc, Pretty, space)
import Dhall.Map (Map)
import Dhall.Set (Set)
import Numeric.Natural (Natural)
import Prelude hiding (succ)
import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal
import qualified Data.Char
import qualified Data.HashSet
import qualified Data.List
import qualified Data.Set
import qualified Data.Text as Text
import qualified Data.Text.Prettyprint.Doc as Pretty
import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty
import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty
import qualified Dhall.Map
import qualified Dhall.Set
data Ann
= Keyword
| Syntax
| Label
| Literal
| Builtin
| Operator
annToAnsiStyle :: Ann -> Terminal.AnsiStyle
annToAnsiStyle Keyword = Terminal.bold <> Terminal.colorDull Terminal.Green
annToAnsiStyle Syntax = Terminal.bold <> Terminal.colorDull Terminal.Green
annToAnsiStyle Label = mempty
annToAnsiStyle Literal = Terminal.colorDull Terminal.Magenta
annToAnsiStyle Builtin = Terminal.underlined
annToAnsiStyle Operator = Terminal.bold <> Terminal.colorDull Terminal.Green
data CharacterSet = ASCII | Unicode
prettyExpr :: Pretty a => Expr s a -> Doc Ann
prettyExpr = prettyCharacterSet Unicode
duplicate :: a -> (a, a)
duplicate x = (x, x)
keyword, syntax, label, literal, builtin, operator :: Doc Ann -> Doc Ann
keyword = Pretty.annotate Keyword
syntax = Pretty.annotate Syntax
label = Pretty.annotate Label
literal = Pretty.annotate Literal
builtin = Pretty.annotate Builtin
operator = Pretty.annotate Operator
comma, lbracket, rbracket, langle, rangle, lbrace, rbrace, lparen, rparen, pipe, backtick, dollar, colon, equals, dot :: Doc Ann
comma = syntax Pretty.comma
lbracket = syntax Pretty.lbracket
rbracket = syntax Pretty.rbracket
langle = syntax Pretty.langle
rangle = syntax Pretty.rangle
lbrace = syntax Pretty.lbrace
rbrace = syntax Pretty.rbrace
lparen = syntax Pretty.lparen
rparen = syntax Pretty.rparen
pipe = syntax Pretty.pipe
backtick = syntax "`"
dollar = syntax "$"
colon = syntax ":"
equals = syntax "="
dot = syntax "."
lambda :: CharacterSet -> Doc Ann
lambda Unicode = syntax "λ"
lambda ASCII = syntax "\\"
forall :: CharacterSet -> Doc Ann
forall Unicode = syntax "∀"
forall ASCII = syntax "forall "
rarrow :: CharacterSet -> Doc Ann
rarrow Unicode = syntax "→"
rarrow ASCII = syntax "->"
list :: [Doc Ann] -> Doc Ann
list [] = lbracket <> rbracket
list docs =
enclose
(lbracket <> space)
(lbracket <> space)
(comma <> space)
(comma <> space)
(space <> rbracket)
rbracket
(fmap duplicate docs)
angles :: [(Doc Ann, Doc Ann)] -> Doc Ann
angles [] = langle <> rangle
angles docs =
enclose
(langle <> space)
(langle <> space)
(space <> pipe <> space)
(pipe <> space)
(space <> rangle)
rangle
docs
braces :: [(Doc Ann, Doc Ann)] -> Doc Ann
braces [] = lbrace <> rbrace
braces docs =
enclose
(lbrace <> space)
(lbrace <> space)
(comma <> space)
(comma <> space)
(space <> rbrace)
rbrace
docs
arrows :: CharacterSet -> [(Doc Ann, Doc Ann)] -> Doc Ann
arrows ASCII =
enclose'
""
" "
(" " <> rarrow ASCII <> " ")
(rarrow ASCII <> " ")
arrows Unicode =
enclose'
""
" "
(" " <> rarrow Unicode <> " ")
(rarrow Unicode <> " ")
combine :: CharacterSet -> Text
combine ASCII = "/\\"
combine Unicode = "∧"
combineTypes :: CharacterSet -> Text
combineTypes ASCII = "//\\\\"
combineTypes Unicode = "⩓"
prefer :: CharacterSet -> Text
prefer ASCII = "//"
prefer Unicode = "⫽"
enclose
:: Doc ann
-> Doc ann
-> Doc ann
-> Doc ann
-> Doc ann
-> Doc ann
-> [(Doc ann, Doc ann)]
-> Doc ann
enclose beginShort _ _ _ endShort _ [] =
beginShort <> endShort
where
enclose beginShort beginLong sepShort sepLong endShort endLong docs =
Pretty.group
(Pretty.flatAlt
(Pretty.align
(mconcat (zipWith combineLong (beginLong : repeat sepLong) docsLong) <> endLong)
)
(mconcat (zipWith combineShort (beginShort : repeat sepShort) docsShort) <> endShort)
)
where
docsShort = fmap fst docs
docsLong = fmap snd docs
combineLong x y = x <> y <> Pretty.hardline
combineShort x y = x <> y
enclose'
:: Doc ann
-> Doc ann
-> Doc ann
-> Doc ann
-> [(Doc ann, Doc ann)]
-> Doc ann
enclose' beginShort beginLong sepShort sepLong docs =
Pretty.group (Pretty.flatAlt long short)
where
longLines = zipWith (<>) (beginLong : repeat sepLong) docsLong
long =
Pretty.align (mconcat (Data.List.intersperse Pretty.hardline longLines))
short = mconcat (zipWith (<>) (beginShort : repeat sepShort) docsShort)
docsShort = fmap fst docs
docsLong = fmap snd docs
alpha :: Char -> Bool
alpha c = ('\x41' <= c && c <= '\x5A') || ('\x61' <= c && c <= '\x7A')
digit :: Char -> Bool
digit c = '\x30' <= c && c <= '\x39'
headCharacter :: Char -> Bool
headCharacter c = alpha c || c == '_'
tailCharacter :: Char -> Bool
tailCharacter c = alpha c || digit c || c == '_' || c == '-' || c == '/'
prettyLabel :: Text -> Doc Ann
prettyLabel a = label doc
where
doc =
case Text.uncons a of
Just (h, t)
| headCharacter h && Text.all tailCharacter t && not (Data.HashSet.member a reservedIdentifiers)
-> Pretty.pretty a
_ -> backtick <> Pretty.pretty a <> backtick
prettyLabels :: Set Text -> Doc Ann
prettyLabels a
| Data.Set.null (Dhall.Set.toSet a) =
lbrace <> rbrace
| otherwise =
braces (map (duplicate . prettyLabel) (Dhall.Set.toList a))
prettyNumber :: Integer -> Doc Ann
prettyNumber = literal . Pretty.pretty
prettyNatural :: Natural -> Doc Ann
prettyNatural = literal . Pretty.pretty
prettyDouble :: Double -> Doc Ann
prettyDouble = literal . Pretty.pretty
prettyConst :: Const -> Doc Ann
prettyConst Type = builtin "Type"
prettyConst Kind = builtin "Kind"
prettyConst Sort = builtin "Sort"
prettyVar :: Var -> Doc Ann
prettyVar (V x 0) = label (Pretty.unAnnotate (prettyLabel x))
prettyVar (V x n) = label (Pretty.unAnnotate (prettyLabel x <> "@" <> prettyNumber n))
prettyCharacterSet :: Pretty a => CharacterSet -> Expr s a -> Doc Ann
prettyCharacterSet characterSet = prettyExpression
where
prettyExpression a0@(Lam _ _ _) =
arrows characterSet (fmap duplicate (docs a0))
where
docs (Lam a b c) = Pretty.group (Pretty.flatAlt long short) : docs c
where
long = (lambda characterSet <> space)
<> Pretty.align
( (lparen <> space)
<> prettyLabel a
<> Pretty.hardline
<> (colon <> space)
<> prettyExpression b
<> Pretty.hardline
<> rparen
)
short = (lambda characterSet <> lparen)
<> prettyLabel a
<> (space <> colon <> space)
<> prettyExpression b
<> rparen
docs (Note _ c) = docs c
docs c = [ prettyExpression c ]
prettyExpression a0@(BoolIf _ _ _) =
Pretty.group (Pretty.flatAlt long short)
where
prefixesLong =
" "
: cycle
[ Pretty.hardline <> keyword "then" <> " "
, Pretty.hardline <> keyword "else" <> " "
]
prefixesShort =
""
: cycle
[ space <> keyword "then" <> space
, space <> keyword "else" <> space
]
longLines = zipWith (<>) prefixesLong (docsLong a0)
long =
Pretty.align (mconcat (Data.List.intersperse Pretty.hardline longLines))
short = mconcat (zipWith (<>) prefixesShort (docsShort a0))
docsLong (BoolIf a b c) =
docLong ++ docsLong c
where
docLong =
[ keyword "if" <> " " <> prettyExpression a
, prettyExpression b
]
docsLong (Note _ c) = docsLong c
docsLong c = [ prettyExpression c ]
docsShort (BoolIf a b c) =
docShort ++ docsShort c
where
docShort =
[ keyword "if" <> " " <> prettyExpression a
, prettyExpression b
]
docsShort (Note _ c) = docsShort c
docsShort c = [ prettyExpression c ]
prettyExpression (Let as b) =
enclose' "" "" space Pretty.hardline
(fmap duplicate (fmap docA (toList as)) ++ [ docB ])
where
docA (Binding c Nothing e) =
Pretty.group (Pretty.flatAlt long short)
where
long = keyword "let" <> space
<> Pretty.align
( prettyLabel c
<> space <> equals
<> Pretty.hardline
<> " "
<> prettyExpression e
)
short = keyword "let" <> space
<> prettyLabel c
<> (space <> equals <> space)
<> prettyExpression e
docA (Binding c (Just d) e) =
Pretty.group (Pretty.flatAlt long short)
where
long = keyword "let" <> space
<> Pretty.align
( prettyLabel c
<> Pretty.hardline
<> colon <> space
<> prettyExpression d
<> Pretty.hardline
<> equals <> space
<> prettyExpression e
)
short = keyword "let" <> space
<> prettyLabel c
<> space <> colon <> space
<> prettyExpression d
<> space <> equals <> space
<> prettyExpression e
docB =
( keyword "in" <> " " <> prettyExpression b
, keyword "in" <> " " <> prettyExpression b
)
prettyExpression a0@(Pi _ _ _) =
arrows characterSet (fmap duplicate (docs a0))
where
docs (Pi "_" b c) = prettyOperatorExpression b : docs c
docs (Pi a b c) = Pretty.group (Pretty.flatAlt long short) : docs c
where
long = forall characterSet <> space
<> Pretty.align
( lparen <> space
<> prettyLabel a
<> Pretty.hardline
<> colon <> space
<> prettyExpression b
<> Pretty.hardline
<> rparen
)
short = forall characterSet <> lparen
<> prettyLabel a
<> space <> colon <> space
<> prettyExpression b
<> rparen
docs (Note _ c) = docs c
docs c = [ prettyExpression c ]
prettyExpression (Note _ a) =
prettyExpression a
prettyExpression a0 =
prettyAnnotatedExpression a0
prettyAnnotatedExpression :: Pretty a => Expr s a -> Doc Ann
prettyAnnotatedExpression (Merge a b (Just c)) =
Pretty.group (Pretty.flatAlt long short)
where
long =
Pretty.align
( keyword "merge"
<> Pretty.hardline
<> prettyImportExpression a
<> Pretty.hardline
<> prettyImportExpression b
<> Pretty.hardline
<> colon <> space
<> prettyApplicationExpression c
)
short = keyword "merge" <> space
<> prettyImportExpression a
<> " "
<> prettyImportExpression b
<> space <> colon <> space
<> prettyApplicationExpression c
prettyAnnotatedExpression (Merge a b Nothing) =
Pretty.group (Pretty.flatAlt long short)
where
long =
Pretty.align
( keyword "merge"
<> Pretty.hardline
<> prettyImportExpression a
<> Pretty.hardline
<> prettyImportExpression b
)
short = keyword "merge" <> space
<> prettyImportExpression a
<> " "
<> prettyImportExpression b
prettyAnnotatedExpression a0@(Annot _ _) =
enclose'
""
" "
(" " <> colon <> " ")
(colon <> space)
(fmap duplicate (docs a0))
where
docs (Annot a b) = prettyOperatorExpression a : docs b
docs (Note _ b) = docs b
docs b = [ prettyExpression b ]
prettyAnnotatedExpression (ListLit (Just a) b) =
list (map prettyExpression (Data.Foldable.toList b))
<> " : "
<> prettyApplicationExpression (App List a)
prettyAnnotatedExpression (OptionalLit a b) =
list (map prettyExpression (Data.Foldable.toList b))
<> " : "
<> prettyApplicationExpression (App Optional a)
prettyAnnotatedExpression (Note _ a) =
prettyAnnotatedExpression a
prettyAnnotatedExpression a0 =
prettyOperatorExpression a0
prettyOperatorExpression :: Pretty a => Expr s a -> Doc Ann
prettyOperatorExpression = prettyImportAltExpression
prettyOperator :: Text -> [Doc Ann] -> Doc Ann
prettyOperator op docs =
enclose'
""
prefix
(" " <> operator (Pretty.pretty op) <> " ")
(operator (Pretty.pretty op) <> spacer)
(reverse (fmap duplicate docs))
where
prefix = if Text.length op == 1 then " " else " "
spacer = if Text.length op == 1 then " " else " "
prettyImportAltExpression :: Pretty a => Expr s a -> Doc Ann
prettyImportAltExpression a0@(ImportAlt _ _) =
prettyOperator "?" (docs a0)
where
docs (ImportAlt a b) = prettyOrExpression b : docs a
docs (Note _ b) = docs b
docs b = [ prettyOrExpression b ]
prettyImportAltExpression (Note _ a) =
prettyImportAltExpression a
prettyImportAltExpression a0 =
prettyOrExpression a0
prettyOrExpression :: Pretty a => Expr s a -> Doc Ann
prettyOrExpression a0@(BoolOr _ _) =
prettyOperator "||" (docs a0)
where
docs (BoolOr a b) = prettyPlusExpression b : docs a
docs (Note _ b) = docs b
docs b = [ prettyPlusExpression b ]
prettyOrExpression (Note _ a) =
prettyOrExpression a
prettyOrExpression a0 =
prettyPlusExpression a0
prettyPlusExpression :: Pretty a => Expr s a -> Doc Ann
prettyPlusExpression a0@(NaturalPlus _ _) =
prettyOperator "+" (docs a0)
where
docs (NaturalPlus a b) = prettyTextAppendExpression b : docs a
docs (Note _ b) = docs b
docs b = [ prettyTextAppendExpression b ]
prettyPlusExpression (Note _ a) =
prettyPlusExpression a
prettyPlusExpression a0 =
prettyTextAppendExpression a0
prettyTextAppendExpression :: Pretty a => Expr s a -> Doc Ann
prettyTextAppendExpression a0@(TextAppend _ _) =
prettyOperator "++" (docs a0)
where
docs (TextAppend a b) = prettyListAppendExpression b : docs a
docs (Note _ b) = docs b
docs b = [ prettyListAppendExpression b ]
prettyTextAppendExpression (Note _ a) =
prettyTextAppendExpression a
prettyTextAppendExpression a0 =
prettyListAppendExpression a0
prettyListAppendExpression :: Pretty a => Expr s a -> Doc Ann
prettyListAppendExpression a0@(ListAppend _ _) =
prettyOperator "#" (docs a0)
where
docs (ListAppend a b) = prettyAndExpression b : docs a
docs (Note _ b) = docs b
docs b = [ prettyAndExpression b ]
prettyListAppendExpression (Note _ a) =
prettyListAppendExpression a
prettyListAppendExpression a0 =
prettyAndExpression a0
prettyAndExpression :: Pretty a => Expr s a -> Doc Ann
prettyAndExpression a0@(BoolAnd _ _) =
prettyOperator "&&" (docs a0)
where
docs (BoolAnd a b) = prettyCombineExpression b : docs a
docs (Note _ b) = docs b
docs b = [ prettyCombineExpression b ]
prettyAndExpression (Note _ a) =
prettyAndExpression a
prettyAndExpression a0 =
prettyCombineExpression a0
prettyCombineExpression :: Pretty a => Expr s a -> Doc Ann
prettyCombineExpression a0@(Combine _ _) =
prettyOperator (combine characterSet) (docs a0)
where
docs (Combine a b) = prettyPreferExpression b : docs a
docs (Note _ b) = docs b
docs b = [ prettyPreferExpression b ]
prettyCombineExpression (Note _ a) =
prettyCombineExpression a
prettyCombineExpression a0 =
prettyPreferExpression a0
prettyPreferExpression :: Pretty a => Expr s a -> Doc Ann
prettyPreferExpression a0@(Prefer _ _) =
prettyOperator (prefer characterSet) (docs a0)
where
docs (Prefer a b) = prettyCombineTypesExpression b : docs a
docs (Note _ b) = docs b
docs b = [ prettyCombineTypesExpression b ]
prettyPreferExpression (Note _ a) =
prettyPreferExpression a
prettyPreferExpression a0 =
prettyCombineTypesExpression a0
prettyCombineTypesExpression :: Pretty a => Expr s a -> Doc Ann
prettyCombineTypesExpression a0@(CombineTypes _ _) =
prettyOperator (combineTypes characterSet) (docs a0)
where
docs (CombineTypes a b) = prettyTimesExpression b : docs a
docs (Note _ b) = docs b
docs b = [ prettyTimesExpression b ]
prettyCombineTypesExpression (Note _ a) =
prettyCombineTypesExpression a
prettyCombineTypesExpression a0 =
prettyTimesExpression a0
prettyTimesExpression :: Pretty a => Expr s a -> Doc Ann
prettyTimesExpression a0@(NaturalTimes _ _) =
prettyOperator "*" (docs a0)
where
docs (NaturalTimes a b) = prettyEqualExpression b : docs a
docs (Note _ b) = docs b
docs b = [ prettyEqualExpression b ]
prettyTimesExpression (Note _ a) =
prettyTimesExpression a
prettyTimesExpression a0 =
prettyEqualExpression a0
prettyEqualExpression :: Pretty a => Expr s a -> Doc Ann
prettyEqualExpression a0@(BoolEQ _ _) =
prettyOperator "==" (docs a0)
where
docs (BoolEQ a b) = prettyNotEqualExpression b : docs a
docs (Note _ b) = docs b
docs b = [ prettyNotEqualExpression b ]
prettyEqualExpression (Note _ a) =
prettyEqualExpression a
prettyEqualExpression a0 =
prettyNotEqualExpression a0
prettyNotEqualExpression :: Pretty a => Expr s a -> Doc Ann
prettyNotEqualExpression a0@(BoolNE _ _) =
prettyOperator "!=" (docs a0)
where
docs (BoolNE a b) = prettyApplicationExpression b : docs a
docs (Note _ b) = docs b
docs b = [ prettyApplicationExpression b ]
prettyNotEqualExpression (Note _ a) =
prettyNotEqualExpression a
prettyNotEqualExpression a0 =
prettyApplicationExpression a0
prettyApplicationExpression :: Pretty a => Expr s a -> Doc Ann
prettyApplicationExpression a0 = case a0 of
App _ _ -> result
Some _ -> result
Note _ b -> prettyApplicationExpression b
_ -> prettyImportExpression a0
where
result = enclose' "" "" " " "" (fmap duplicate (reverse (docs a0)))
docs (App a b) = prettyImportExpression b : docs a
docs (Some a) = [ prettyImportExpression a , builtin "Some" ]
docs (Note _ b) = docs b
docs b = [ prettyImportExpression b ]
prettyImportExpression :: Pretty a => Expr s a -> Doc Ann
prettyImportExpression (Embed a) =
Pretty.pretty a
prettyImportExpression (Note _ a) =
prettyImportExpression a
prettyImportExpression a0 =
prettySelectorExpression a0
prettySelectorExpression :: Pretty a => Expr s a -> Doc Ann
prettySelectorExpression (Field a b) =
prettySelectorExpression a <> dot <> prettyLabel b
prettySelectorExpression (Project a b) =
prettySelectorExpression a <> dot <> prettyLabels b
prettySelectorExpression (Note _ b) =
prettySelectorExpression b
prettySelectorExpression a0 =
prettyPrimitiveExpression a0
prettyPrimitiveExpression :: Pretty a => Expr s a -> Doc Ann
prettyPrimitiveExpression (Var a) =
prettyVar a
prettyPrimitiveExpression (Const k) =
prettyConst k
prettyPrimitiveExpression Bool =
builtin "Bool"
prettyPrimitiveExpression Natural =
builtin "Natural"
prettyPrimitiveExpression NaturalFold =
builtin "Natural/fold"
prettyPrimitiveExpression NaturalBuild =
builtin "Natural/build"
prettyPrimitiveExpression NaturalIsZero =
builtin "Natural/isZero"
prettyPrimitiveExpression NaturalEven =
builtin "Natural/even"
prettyPrimitiveExpression NaturalOdd =
builtin "Natural/odd"
prettyPrimitiveExpression NaturalToInteger =
builtin "Natural/toInteger"
prettyPrimitiveExpression NaturalShow =
builtin "Natural/show"
prettyPrimitiveExpression Integer =
builtin "Integer"
prettyPrimitiveExpression IntegerShow =
builtin "Integer/show"
prettyPrimitiveExpression IntegerToDouble =
builtin "Integer/toDouble"
prettyPrimitiveExpression Double =
builtin "Double"
prettyPrimitiveExpression DoubleShow =
builtin "Double/show"
prettyPrimitiveExpression Text =
builtin "Text"
prettyPrimitiveExpression TextShow =
builtin "Text/show"
prettyPrimitiveExpression List =
builtin "List"
prettyPrimitiveExpression ListBuild =
builtin "List/build"
prettyPrimitiveExpression ListFold =
builtin "List/fold"
prettyPrimitiveExpression ListLength =
builtin "List/length"
prettyPrimitiveExpression ListHead =
builtin "List/head"
prettyPrimitiveExpression ListLast =
builtin "List/last"
prettyPrimitiveExpression ListIndexed =
builtin "List/indexed"
prettyPrimitiveExpression ListReverse =
builtin "List/reverse"
prettyPrimitiveExpression Optional =
builtin "Optional"
prettyPrimitiveExpression None =
builtin "None"
prettyPrimitiveExpression OptionalFold =
builtin "Optional/fold"
prettyPrimitiveExpression OptionalBuild =
builtin "Optional/build"
prettyPrimitiveExpression (BoolLit True) =
builtin "True"
prettyPrimitiveExpression (BoolLit False) =
builtin "False"
prettyPrimitiveExpression (IntegerLit a)
| 0 <= a = literal "+" <> prettyNumber a
| otherwise = prettyNumber a
prettyPrimitiveExpression (NaturalLit a) =
prettyNatural a
prettyPrimitiveExpression (DoubleLit a) =
prettyDouble a
prettyPrimitiveExpression (TextLit a) =
prettyChunks a
prettyPrimitiveExpression (Record a) =
prettyRecord a
prettyPrimitiveExpression (RecordLit a) =
prettyRecordLit a
prettyPrimitiveExpression (Union a) =
prettyUnion a
prettyPrimitiveExpression (UnionLit a b c) =
prettyUnionLit a b c
prettyPrimitiveExpression (ListLit Nothing b) =
list (map prettyExpression (Data.Foldable.toList b))
prettyPrimitiveExpression (Note _ b) =
prettyPrimitiveExpression b
prettyPrimitiveExpression a =
Pretty.group (Pretty.flatAlt long short)
where
long =
Pretty.align
(lparen <> space <> prettyExpression a <> Pretty.hardline <> rparen)
short = lparen <> prettyExpression a <> rparen
prettyKeyValue :: Pretty a => Doc Ann -> (Text, Expr s a) -> (Doc Ann, Doc Ann)
prettyKeyValue separator (key, val) =
( prettyLabel key <> " " <> separator <> " " <> prettyExpression val
, prettyLabel key
<> " "
<> separator
<> long
)
where
long = Pretty.hardline <> " " <> prettyExpression val
prettyRecord :: Pretty a => Map Text (Expr s a) -> Doc Ann
prettyRecord =
braces . map (prettyKeyValue colon) . Dhall.Map.toList
prettyRecordLit :: Pretty a => Map Text (Expr s a) -> Doc Ann
prettyRecordLit a
| Data.Foldable.null a =
lbrace <> equals <> rbrace
| otherwise
= braces (map (prettyKeyValue equals) (Dhall.Map.toList a))
prettyUnion :: Pretty a => Map Text (Expr s a) -> Doc Ann
prettyUnion =
angles . map (prettyKeyValue colon) . Dhall.Map.toList
prettyUnionLit
:: Pretty a => Text -> Expr s a -> Map Text (Expr s a) -> Doc Ann
prettyUnionLit a b c =
angles (front : map adapt (Dhall.Map.toList c))
where
front = prettyKeyValue equals (a, b)
adapt = prettyKeyValue colon
prettyChunks :: Pretty a => Chunks s a -> Doc Ann
prettyChunks (Chunks a b) =
if any (\(builder, _) -> hasNewLine builder) a || hasNewLine b
then Pretty.flatAlt long short
else short
where
long =
Pretty.align
( literal ("''" <> Pretty.hardline)
<> Pretty.align
(foldMap prettyMultilineChunk a <> prettyMultilineBuilder b)
<> literal "''"
)
short =
literal "\"" <> foldMap prettyChunk a <> literal (prettyText b <> "\"")
hasNewLine = Text.any (== '\n')
prettyMultilineChunk (c, d) =
prettyMultilineBuilder c
<> dollar
<> lbrace
<> prettyExpression d
<> rbrace
prettyMultilineBuilder builder = literal (mconcat docs)
where
lazyLines = Text.splitOn "\n" (escapeSingleQuotedText builder)
docs =
Data.List.intersperse Pretty.hardline (fmap Pretty.pretty lazyLines)
prettyChunk (c, d) =
prettyText c
<> syntax "${"
<> prettyExpression d
<> syntax rbrace
prettyText t = literal (Pretty.pretty (escapeText t))
pretty :: Pretty a => a -> Text
pretty = Pretty.renderStrict . Pretty.layoutPretty options . Pretty.pretty
where
options = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded }
escapeSingleQuotedText :: Text -> Text
escapeSingleQuotedText inputBuilder = outputBuilder
where
outputText = substitute "${" "''${" (substitute "''" "'''" inputBuilder)
outputBuilder = outputText
substitute before after = Text.intercalate after . Text.splitOn before
escapeText :: Text -> Text
escapeText text = Text.concatMap adapt text
where
adapt c
| '\x20' <= c && c <= '\x21' = Text.singleton c
| '\x23' == c = Text.singleton c
| '\x25' <= c && c <= '\x5B' = Text.singleton c
| '\x5D' <= c && c <= '\x10FFFF' = Text.singleton c
| c == '"' = "\\\""
| c == '$' = "\\$"
| c == '\\' = "\\\\"
| c == '\b' = "\\b"
| c == '\f' = "\\f"
| c == '\n' = "\\n"
| c == '\r' = "\\r"
| c == '\t' = "\\t"
| otherwise = "\\u" <> showDigits (Data.Char.ord c)
showDigits r0 = Text.pack (map showDigit [q1, q2, q3, r3])
where
(q1, r1) = r0 `quotRem` 4096
(q2, r2) = r1 `quotRem` 256
(q3, r3) = r2 `quotRem` 16
showDigit n
| n < 10 = Data.Char.chr (Data.Char.ord '0' + n)
| otherwise = Data.Char.chr (Data.Char.ord 'A' + n - 10)
prettyToString :: Pretty a => a -> String
prettyToString =
Pretty.renderString . Pretty.layoutPretty options . Pretty.pretty
where
options = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded }
docToStrictText :: Doc ann -> Text.Text
docToStrictText = Pretty.renderStrict . Pretty.layoutPretty options
where
options = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded }
prettyToStrictText :: Pretty a => a -> Text.Text
prettyToStrictText = docToStrictText . Pretty.pretty