1{-# LANGUAGE DeriveAnyClass #-} 2{-# LANGUAGE DeriveDataTypeable #-} 3{-# LANGUAGE DeriveGeneric #-} 4{-# LANGUAGE DeriveLift #-} 5{-# LANGUAGE LambdaCase #-} 6{-# LANGUAGE OverloadedStrings #-} 7{-# LANGUAGE RecordWildCards #-} 8{-# LANGUAGE ViewPatterns #-} 9 10{-# OPTIONS_GHC -Wall #-} 11 12{-| This module provides internal pretty-printing utilities which are used by 13 other modules but are not part of the public facing API 14-} 15 16module Dhall.Pretty.Internal ( 17 Ann(..) 18 , annToAnsiStyle 19 , prettyExpr 20 , prettySrcExpr 21 22 , CharacterSet(..) 23 , detectCharacterSet 24 , prettyCharacterSet 25 , prettyImportExpression 26 27 , prettyVar 28 , pretty_ 29 , escapeText_ 30 , escapeEnvironmentVariable 31 , prettyEnvironmentVariable 32 33 , prettyConst 34 , escapeLabel 35 , prettyLabel 36 , prettyAnyLabel 37 , prettyLabels 38 , prettyNatural 39 , prettyNumber 40 , prettyInt 41 , prettyDouble 42 , prettyToStrictText 43 , prettyToString 44 , layout 45 , layoutOpts 46 47 , docToStrictText 48 49 , builtin 50 , keyword 51 , literal 52 , operator 53 54 , colon 55 , comma 56 , dot 57 , equals 58 , forall 59 , label 60 , lambda 61 , langle 62 , lbrace 63 , lbracket 64 , lparen 65 , pipe 66 , rangle 67 , rarrow 68 , rbrace 69 , rbracket 70 , rparen 71 ) where 72 73import Control.DeepSeq (NFData) 74import Data.Aeson (FromJSON (..), Value (String)) 75import Data.Aeson.Types (typeMismatch, unexpected) 76import Data.Data (Data) 77import Data.Foldable 78import Data.List.NonEmpty (NonEmpty (..)) 79import Data.Text (Text) 80import Data.Text.Prettyprint.Doc (Doc, Pretty, space) 81import Dhall.Map (Map) 82import Dhall.Optics (cosmosOf, foldOf, to) 83import Dhall.Src (Src (..)) 84import Dhall.Syntax 85import GHC.Generics (Generic) 86import Language.Haskell.TH.Syntax (Lift) 87import Numeric.Natural (Natural) 88 89import qualified Data.Char 90import qualified Data.HashSet 91import qualified Data.List 92import qualified Data.List.NonEmpty as NonEmpty 93import qualified Data.Maybe 94import qualified Data.Text as Text 95import qualified Data.Text.Prettyprint.Doc as Pretty 96import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty 97import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal 98import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty 99import qualified Dhall.Map as Map 100 101{-| Annotation type used to tag elements in a pretty-printed document for 102 syntax highlighting purposes 103-} 104data Ann 105 = Keyword -- ^ Used for syntactic keywords 106 | Syntax -- ^ Syntax punctuation such as commas, parenthesis, and braces 107 | Label -- ^ Record labels 108 | Literal -- ^ Literals such as integers and strings 109 | Builtin -- ^ Builtin types and values 110 | Operator -- ^ Operators 111 deriving Show 112 113{-| Convert annotations to their corresponding color for syntax highlighting 114 purposes 115-} 116annToAnsiStyle :: Ann -> Terminal.AnsiStyle 117annToAnsiStyle Keyword = Terminal.bold <> Terminal.colorDull Terminal.Green 118annToAnsiStyle Syntax = Terminal.bold <> Terminal.colorDull Terminal.Green 119annToAnsiStyle Label = mempty 120annToAnsiStyle Literal = Terminal.colorDull Terminal.Magenta 121annToAnsiStyle Builtin = Terminal.underlined 122annToAnsiStyle Operator = Terminal.bold <> Terminal.colorDull Terminal.Green 123 124-- | This type determines whether to render code as `ASCII` or `Unicode` 125data CharacterSet = ASCII | Unicode 126 deriving (Eq, Ord, Show, Data, Generic, Lift, NFData) 127 128-- | Since ASCII is a subset of Unicode, if either argument is Unicode, the 129-- result is Unicode 130instance Semigroup CharacterSet where 131 Unicode <> _ = Unicode 132 _ <> other = other 133 134instance Monoid CharacterSet where 135 mempty = ASCII 136 137instance FromJSON CharacterSet where 138 parseJSON (String "unicode") = pure Unicode 139 parseJSON (String "ascii") = pure ASCII 140 parseJSON v@(String _) = unexpected v 141 parseJSON v = typeMismatch "String" v 142 143-- | Detect which character set is used for the syntax of an expression 144-- If any parts of the expression uses the Unicode syntax, the whole expression 145-- is deemed to be using the Unicode syntax. 146detectCharacterSet :: Expr Src a -> CharacterSet 147detectCharacterSet = foldOf (cosmosOf subExpressions . to exprToCharacterSet) 148 where 149 exprToCharacterSet = \case 150 Embed _ -> mempty -- Don't go down the embed route, otherwise: <<loop>> 151 Lam (Just Unicode) _ _ -> Unicode 152 Pi (Just Unicode) _ _ _ -> Unicode 153 Combine (Just Unicode) _ _ _ -> Unicode 154 CombineTypes (Just Unicode) _ _ -> Unicode 155 Prefer (Just Unicode) _ _ _ -> Unicode 156 _ -> mempty 157 158-- | Pretty print an expression 159prettyExpr :: Pretty a => Expr s a -> Doc Ann 160prettyExpr = prettySrcExpr . denote 161 162prettySrcExpr :: Pretty a => Expr Src a -> Doc Ann 163prettySrcExpr = prettyCharacterSet Unicode 164 165{-| Internal utility for pretty-printing, used when generating element lists 166 to supply to `enclose` or `enclose'`. This utility indicates that the 167 compact represent is the same as the multi-line representation for each 168 element 169-} 170duplicate :: a -> (a, a) 171duplicate x = (x, x) 172 173isWhitespace :: Char -> Bool 174isWhitespace c = 175 case c of 176 ' ' -> True 177 '\n' -> True 178 '\t' -> True 179 '\r' -> True 180 _ -> False 181 182{-| Used to render inline `Src` spans preserved by the syntax tree 183 184 >>> let unusedSourcePos = Text.Megaparsec.SourcePos "" (Text.Megaparsec.mkPos 1) (Text.Megaparsec.mkPos 1) 185 >>> let nonEmptySrc = Src unusedSourcePos unusedSourcePos "-- Documentation for x\n" 186 >>> "let" <> " " <> renderSrc id (Just nonEmptySrc) <> "x = 1 in x" 187 let -- Documentation for x 188 x = 1 in x 189 >>> let emptySrc = Src unusedSourcePos unusedSourcePos " " 190 >>> "let" <> " " <> renderSrc id (Just emptySrc) <> "x = 1 in x" 191 let x = 1 in x 192 >>> "let" <> " " <> renderSrc id Nothing <> "x = 1 in x" 193 let x = 1 in x 194-} 195renderSrc 196 :: (Text -> Text) 197 -- ^ Used to preprocess the comment string (e.g. to strip whitespace) 198 -> Maybe Src 199 -- ^ Source span to render (if present) 200 -> Doc Ann 201renderSrc strip (Just (Src {..})) 202 | not (Text.all isWhitespace srcText) = 203 renderComment (strip srcText) 204renderSrc _ _ = 205 mempty 206 207{-| Render a comment. 208 209 Any preprocessing, such as whitespace stripping, needs to be handled by the 210 caller, see e.g. 'renderSrc'. 211 212 See the documentation for 'renderSrc' for examples. 213-} 214renderComment :: Text -> Doc Ann 215renderComment text = 216 Pretty.align (Pretty.concatWith f newLines <> suffix) 217 where 218 horizontalSpace c = c == ' ' || c == '\t' 219 220 suffix = 221 if Text.null text || Text.last text == '\n' 222 then mempty 223 else " " 224 225 oldLines = Text.splitOn "\n" text 226 227 spacePrefix = Text.takeWhile horizontalSpace 228 229 commonPrefix a b = case Text.commonPrefixes a b of 230 Nothing -> "" 231 Just (c, _, _) -> c 232 233 sharedSpacePrefix [] = "" 234 sharedSpacePrefix (l : ls) = foldl' commonPrefix (spacePrefix l) ls 235 236 blank = Text.all horizontalSpace 237 238 newLines = 239 case oldLines of 240 [] -> 241 [] 242 l0 : ls -> 243 let sharedPrefix = 244 sharedSpacePrefix (filter (not . blank) ls) 245 246 perLine l = 247 case Text.stripPrefix sharedPrefix l of 248 Nothing -> Pretty.pretty l 249 Just l' -> Pretty.pretty l' 250 251 in Pretty.pretty l0 : map perLine ls 252 253 f x y = x <> Pretty.hardline <> y 254 255{-| This is a variant of 'renderSrc' with the following differences: 256 257 * The 'srcText' is stripped of all whitespace at the start and the end. 258 * When the stripped 'srcText' is empty, the result is 'Nothing'. 259-} 260renderSrcMaybe :: Maybe Src -> Maybe (Doc Ann) 261renderSrcMaybe (Just Src{..}) = 262 case Text.dropAround isWhitespace srcText of 263 "" -> Nothing 264 t -> Just (renderComment t) 265renderSrcMaybe _ = Nothing 266 267{-| @ 268 'containsComment' mSrc ≡ 'Data.Maybe.isJust' ('renderSrcMaybe' mSrc) 269 @ 270-} 271containsComment :: Maybe Src -> Bool 272containsComment Nothing = False 273containsComment (Just Src{..}) = not (Text.all isWhitespace srcText) 274 275-- Annotation helpers 276keyword, syntax, label, literal, builtin, operator :: Doc Ann -> Doc Ann 277keyword = Pretty.annotate Keyword 278syntax = Pretty.annotate Syntax 279label = Pretty.annotate Label 280literal = Pretty.annotate Literal 281builtin = Pretty.annotate Builtin 282operator = Pretty.annotate Operator 283 284comma, lbracket, rbracket, langle, rangle, lbrace, rbrace, lparen, rparen, pipe, dollar, colon, equals, dot :: Doc Ann 285comma = syntax Pretty.comma 286lbracket = syntax Pretty.lbracket 287rbracket = syntax Pretty.rbracket 288langle = syntax Pretty.langle 289rangle = syntax Pretty.rangle 290lbrace = syntax Pretty.lbrace 291rbrace = syntax Pretty.rbrace 292lparen = syntax Pretty.lparen 293rparen = syntax Pretty.rparen 294pipe = syntax Pretty.pipe 295dollar = syntax "$" 296colon = syntax ":" 297equals = syntax "=" 298dot = syntax "." 299 300lambda :: CharacterSet -> Doc Ann 301lambda Unicode = syntax "λ" 302lambda ASCII = syntax "\\" 303 304forall :: CharacterSet -> Doc Ann 305forall Unicode = syntax "∀" 306forall ASCII = syntax "forall " 307 308rarrow :: CharacterSet -> Doc Ann 309rarrow Unicode = syntax "→" 310rarrow ASCII = syntax "->" 311 312doubleColon :: Doc Ann 313doubleColon = syntax "::" 314 315-- | Pretty-print a list 316list :: [Doc Ann] -> Doc Ann 317list [] = lbracket <> rbracket 318list docs = 319 enclose 320 (lbracket <> space) 321 (lbracket <> space) 322 (comma <> space) 323 (comma <> space) 324 (space <> rbracket) 325 rbracket 326 (fmap duplicate docs) 327 328-- | Pretty-print union types and literals 329angles :: [(Doc Ann, Doc Ann)] -> Doc Ann 330angles [] = langle <> rangle 331angles docs = 332 enclose 333 (langle <> space) 334 (langle <> space) 335 (space <> pipe <> space) 336 (pipe <> space) 337 (space <> rangle) 338 rangle 339 docs 340 341-- | Pretty-print record types and literals 342braces :: [(Doc Ann, Doc Ann)] -> Doc Ann 343braces [] = lbrace <> rbrace 344braces docs = 345 enclose 346 (lbrace <> space) 347 (lbrace <> space) 348 (comma <> space) 349 (comma <> space) 350 (space <> rbrace) 351 rbrace 352 docs 353 354hangingBraces :: Int -> [(Doc Ann, Doc Ann)] -> Doc Ann 355hangingBraces _ [] = 356 lbrace <> rbrace 357hangingBraces n docs = 358 Pretty.group 359 (Pretty.flatAlt 360 ( lbrace 361 <> Pretty.hardline 362 <> Pretty.indent n 363 ( mconcat (map (combineLong separator) docsLong) 364 <> rbrace 365 ) 366 ) 367 (mconcat (zipWith (<>) (beginShort : repeat separator) docsShort) <> space <> rbrace) 368 ) 369 where 370 separator = comma <> space 371 372 docsShort = fmap fst docs 373 374 docsLong = fmap snd docs 375 376 beginShort = lbrace <> space 377 378 combineLong x y = x <> y <> Pretty.hardline 379 380unsnoc :: [a] -> Maybe ([a], a) 381unsnoc [] = Nothing 382unsnoc (x0 : xs0) = Just (go id x0 xs0) 383 where 384 go diffXs x [] = (diffXs [], x) 385 go diffXs x (y : ys) = go (diffXs . (x:)) y ys 386 387-- | Pretty-print anonymous functions and function types 388arrows :: CharacterSet -> [ Doc Ann ] -> Doc Ann 389arrows characterSet docs = Pretty.group (Pretty.flatAlt long short) 390 where 391 long = Pretty.align (mconcat (Data.List.intersperse Pretty.hardline docs')) 392 where 393 docs' = case unsnoc docs of 394 Nothing -> docs 395 396 Just (init_, last_) -> init' ++ [ last' ] 397 where 398 appendArrow doc = doc <> space <> rarrow characterSet 399 400 init' = map appendArrow init_ 401 402 last' = space <> space <> last_ 403 404 short = mconcat (Data.List.intersperse separator docs) 405 where 406 separator = space <> rarrow characterSet <> space 407 408combine :: CharacterSet -> Text 409combine ASCII = "/\\" 410combine Unicode = "∧" 411 412combineTypes :: CharacterSet -> Text 413combineTypes ASCII = "//\\\\" 414combineTypes Unicode = "⩓" 415 416prefer :: CharacterSet -> Text 417prefer ASCII = "//" 418prefer Unicode = "⫽" 419 420equivalent :: CharacterSet -> Text 421equivalent ASCII = "===" 422equivalent Unicode = "≡" 423 424{-| Format an expression that holds a variable number of elements, such as a 425 list, record, or union 426-} 427enclose 428 :: Doc ann 429 -- ^ Beginning document for compact representation 430 -> Doc ann 431 -- ^ Beginning document for multi-line representation 432 -> Doc ann 433 -- ^ Separator for compact representation 434 -> Doc ann 435 -- ^ Separator for multi-line representation 436 -> Doc ann 437 -- ^ Ending document for compact representation 438 -> Doc ann 439 -- ^ Ending document for multi-line representation 440 -> [(Doc ann, Doc ann)] 441 -- ^ Elements to format, each of which is a pair: @(compact, multi-line)@ 442 -> Doc ann 443enclose beginShort _ _ _ endShort _ [] = 444 beginShort <> endShort 445enclose beginShort beginLong sepShort sepLong endShort endLong docs = 446 Pretty.group 447 (Pretty.flatAlt 448 (Pretty.align 449 (mconcat (zipWith combineLong (beginLong : repeat sepLong) docsLong) <> endLong) 450 ) 451 (mconcat (zipWith combineShort (beginShort : repeat sepShort) docsShort) <> endShort) 452 ) 453 where 454 docsShort = fmap fst docs 455 456 docsLong = fmap snd docs 457 458 combineLong x y = x <> y <> Pretty.hardline 459 460 combineShort x y = x <> y 461 462{-| Format an expression that holds a variable number of elements without a 463 trailing document such as nested `let`, nested lambdas, or nested `forall`s 464-} 465enclose' 466 :: Doc ann 467 -- ^ Beginning document for compact representation 468 -> Doc ann 469 -- ^ Beginning document for multi-line representation 470 -> Doc ann 471 -- ^ Separator for compact representation 472 -> Doc ann 473 -- ^ Separator for multi-line representation 474 -> [(Doc ann, Doc ann)] 475 -- ^ Elements to format, each of which is a pair: @(compact, multi-line)@ 476 -> Doc ann 477enclose' beginShort beginLong sepShort sepLong docs = 478 Pretty.group (Pretty.flatAlt long short) 479 where 480 longLines = zipWith (<>) (beginLong : repeat sepLong) docsLong 481 482 long = 483 Pretty.align (mconcat (Data.List.intersperse Pretty.hardline longLines)) 484 485 short = mconcat (zipWith (<>) (beginShort : repeat sepShort) docsShort) 486 487 docsShort = fmap fst docs 488 489 docsLong = fmap snd docs 490 491alpha :: Char -> Bool 492alpha c = ('\x41' <= c && c <= '\x5A') || ('\x61' <= c && c <= '\x7A') 493 494digit :: Char -> Bool 495digit c = '\x30' <= c && c <= '\x39' 496 497alphaNum :: Char -> Bool 498alphaNum c = alpha c || digit c 499 500headCharacter :: Char -> Bool 501headCharacter c = alpha c || c == '_' 502 503tailCharacter :: Char -> Bool 504tailCharacter c = alphaNum c || c == '_' || c == '-' || c == '/' 505 506-- | Escape a label if it is not valid when unquoted 507escapeLabel :: Bool -> Text -> Text 508escapeLabel allowReserved l = 509 case Text.uncons l of 510 Just (h, t) 511 | headCharacter h && Text.all tailCharacter t && (notReservedIdentifier || (allowReserved && someOrNotLanguageKeyword)) 512 -> l 513 _ -> "`" <> l <> "`" 514 where 515 notReservedIdentifier = not (Data.HashSet.member l reservedIdentifiers) 516 someOrNotLanguageKeyword = l == "Some" || not (Data.HashSet.member l reservedKeywords) 517 518prettyLabelShared :: Bool -> Text -> Doc Ann 519prettyLabelShared b l = label (Pretty.pretty (escapeLabel b l)) 520 521prettyLabel :: Text -> Doc Ann 522prettyLabel = prettyLabelShared False 523 524prettyAnyLabel :: Text -> Doc Ann 525prettyAnyLabel = prettyLabelShared True 526 527prettyAnyLabels :: Foldable list => list (Maybe Src, Text, Maybe Src) -> Doc Ann 528prettyAnyLabels keys = Pretty.group (Pretty.flatAlt long short) 529 where 530 short = (mconcat . Pretty.punctuate dot . map prettyKey . toList) keys 531 532 long = 533 case map prettyKey (toList keys) of 534 [] -> mempty 535 [doc] -> doc 536 doc:docs -> 537 Pretty.align 538 . mconcat 539 . Pretty.punctuate (Pretty.hardline <> ". ") 540 $ Pretty.indent 2 doc : docs 541 542 prettyKey (mSrc0, key, mSrc1) = 543 Pretty.align 544 . mconcat 545 . Pretty.punctuate Pretty.hardline 546 . Data.Maybe.catMaybes 547 $ [ renderSrcMaybe mSrc0 548 , Just (prettyAnyLabel key) 549 , renderSrcMaybe mSrc1 550 ] 551 552prettyLabels :: [Text] -> Doc Ann 553prettyLabels a 554 | null a = lbrace <> rbrace 555 | otherwise = braces (map (duplicate . prettyAnyLabel) a) 556 557prettyNumber :: Integer -> Doc Ann 558prettyNumber = literal . Pretty.pretty 559 560prettyInt :: Int -> Doc Ann 561prettyInt = literal . Pretty.pretty 562 563prettyNatural :: Natural -> Doc Ann 564prettyNatural = literal . Pretty.pretty 565 566prettyDouble :: Double -> Doc Ann 567prettyDouble = literal . Pretty.pretty 568 569prettyConst :: Const -> Doc Ann 570prettyConst Type = builtin "Type" 571prettyConst Kind = builtin "Kind" 572prettyConst Sort = builtin "Sort" 573 574prettyVar :: Var -> Doc Ann 575prettyVar (V x 0) = label (Pretty.unAnnotate (prettyLabel x)) 576prettyVar (V x n) = label (Pretty.unAnnotate (prettyLabel x <> "@" <> prettyInt n)) 577 578prettyEnvironmentVariable :: Text -> Doc ann 579prettyEnvironmentVariable t = Pretty.pretty (escapeEnvironmentVariable t) 580 581preserveSource :: Expr Src a -> Maybe (Doc Ann) 582preserveSource (Note Src{..} (DoubleLit {})) = Just (Pretty.pretty srcText) 583preserveSource (Note Src{..} (IntegerLit {})) = Just (Pretty.pretty srcText) 584preserveSource (Note Src{..} (NaturalLit {})) = Just (Pretty.pretty srcText) 585preserveSource _ = Nothing 586 587-- | Escape an environment variable if not a valid Bash environment variable 588escapeEnvironmentVariable :: Text -> Text 589escapeEnvironmentVariable t 590 | validBashEnvVar t = t 591 | otherwise = "\"" <> escapeText_ t <> "\"" 592 where 593 validBashEnvVar v = case Text.uncons v of 594 Nothing -> False 595 Just (c, v') -> 596 (alpha c || c == '_') 597 && Text.all (\c' -> alphaNum c' || c' == '_') v' 598 599{- There is a close correspondence between the pretty-printers in 'prettyCharacterSet' 600 and the sub-parsers in 'Dhall.Parser.Expression.parsers'. Most pretty-printers are 601 named after the corresponding parser and the relationship between pretty-printers 602 exactly matches the relationship between parsers. This leads to the nice emergent 603 property of automatically getting all the parentheses and precedences right. 604 605 This approach has one major disadvantage: you can get an infinite loop if 606 you add a new constructor to the syntax tree without adding a matching 607 case the corresponding builder. 608-} 609 610{-| Pretty-print an 'Expr' using the given 'CharacterSet'. 611 612'prettyCharacterSet' largely ignores 'Note's. 'Note's do however matter for 613the layout of let-blocks: 614 615>>> let inner = Let (Binding Nothing "x" Nothing Nothing Nothing (NaturalLit 1)) (Var (V "x" 0)) :: Expr Src () 616>>> prettyCharacterSet ASCII (Let (Binding Nothing "y" Nothing Nothing Nothing (NaturalLit 2)) inner) 617let y = 2 let x = 1 in x 618>>> prettyCharacterSet ASCII (Let (Binding Nothing "y" Nothing Nothing Nothing (NaturalLit 2)) (Note (Src unusedSourcePos unusedSourcePos "") inner)) 619let y = 2 in let x = 1 in x 620 621This means the structure of parsed let-blocks is preserved. 622-} 623prettyCharacterSet :: Pretty a => CharacterSet -> Expr Src a -> Doc Ann 624prettyCharacterSet characterSet = prettyCompleteExpression 625 where 626 PrettyPrinters{..} = prettyPrinters characterSet 627 628-- Mainly used by the `Pretty` instance for `Import` 629prettyImportExpression :: Pretty a => Expr Src a -> Doc Ann 630prettyImportExpression = prettyImportExpression_ 631 where 632 PrettyPrinters{..} = prettyPrinters Unicode 633 634data PrettyPrinters a = PrettyPrinters 635 { prettyCompleteExpression :: Expr Src a -> Doc Ann 636 , prettyImportExpression_ :: Expr Src a -> Doc Ann 637 } 638 639prettyPrinters :: Pretty a => CharacterSet -> PrettyPrinters a 640prettyPrinters characterSet = 641 PrettyPrinters{..} 642 where 643 prettyCompleteExpression expression = 644 Pretty.group (prettyExpression expression) 645 646 prettyExpression a0@(Lam _ _ _) = 647 arrows characterSet (docs a0) 648 where 649 docs (Lam _ (FunctionBinding { functionBindingVariable = a, functionBindingAnnotation = b }) c) = 650 Pretty.group (Pretty.flatAlt long short) : docs c 651 where 652 long = (lambda characterSet <> space) 653 <> Pretty.align 654 ( (lparen <> space) 655 <> prettyLabel a 656 <> Pretty.hardline 657 <> (colon <> space) 658 <> prettyExpression b 659 <> Pretty.hardline 660 <> rparen 661 ) 662 663 short = (lambda characterSet <> lparen) 664 <> prettyLabel a 665 <> (space <> colon <> space) 666 <> prettyExpression b 667 <> rparen 668 docs c 669 | Just doc <- preserveSource c = 670 [ doc ] 671 | Note _ d <- c = 672 docs d 673 | otherwise = 674 [ prettyExpression c ] 675 prettyExpression a0@(BoolIf _ _ _) = 676 Pretty.group (Pretty.flatAlt long short) 677 where 678 prefixesLong = 679 "" 680 : cycle 681 [ keyword "then" <> " " 682 , keyword "else" <> " " 683 ] 684 685 prefixesShort = 686 "" 687 : cycle 688 [ space <> keyword "then" <> space 689 , space <> keyword "else" <> space 690 ] 691 692 longLines = zipWith (<>) prefixesLong (docsLong True a0) 693 694 long = 695 Pretty.align (mconcat (Data.List.intersperse Pretty.hardline longLines)) 696 697 short = mconcat (zipWith (<>) prefixesShort (docsShort a0)) 698 699 docsLong initial (BoolIf a b c) = 700 docLong ++ docsLong False c 701 where 702 padding 703 | initial = " " 704 | otherwise = mempty 705 706 docLong = 707 [ keyword "if" <> padding <> " " <> prettyExpression a 708 , prettyExpression b 709 ] 710 docsLong initial c 711 | Just doc <- preserveSource c = 712 [ doc ] 713 | Note _ d <- c = 714 docsLong initial d 715 | otherwise = 716 [ prettyExpression c ] 717 718 docsShort (BoolIf a b c) = 719 docShort ++ docsShort c 720 where 721 docShort = 722 [ keyword "if" <> " " <> prettyExpression a 723 , prettyExpression b 724 ] 725 docsShort c 726 | Just doc <- preserveSource c = 727 [ doc ] 728 | Note _ d <- c = 729 docsShort d 730 | otherwise = 731 [ prettyExpression c ] 732 prettyExpression (Let a0 b0) = 733 enclose' "" "" space Pretty.hardline 734 (fmap (duplicate . docA) (toList as) ++ [ docB ]) 735 where 736 MultiLet as b = multiLet a0 b0 737 738 isSpace c = c == ' ' || c == '\t' 739 stripSpaces = 740 Text.dropAround isSpace 741 . Text.intercalate "\n" 742 . map (Text.dropWhileEnd isSpace) 743 . Text.splitOn "\n" 744 745 -- Strip a single newline character. Needed to ensure idempotency in 746 -- cases where we add hard line breaks. 747 stripNewline t = 748 case Text.uncons t' of 749 Just ('\n', t'') -> stripSpaces t'' 750 _ -> t' 751 where t' = stripSpaces t 752 753 docA (Binding src0 c src1 Nothing src2 e) = 754 Pretty.group (Pretty.flatAlt long short) 755 where 756 long = keyword "let" <> space 757 <> Pretty.align 758 ( renderSrc stripSpaces src0 759 <> prettyLabel c <> space <> renderSrc stripSpaces src1 760 <> equals <> Pretty.hardline <> renderSrc stripNewline src2 761 <> " " <> prettyExpression e 762 ) 763 764 short = keyword "let" <> space <> renderSrc stripSpaces src0 765 <> prettyLabel c <> space <> renderSrc stripSpaces src1 766 <> equals <> space <> renderSrc stripSpaces src2 767 <> prettyExpression e 768 docA (Binding src0 c src1 (Just (src3, d)) src2 e) = 769 keyword "let" <> space 770 <> Pretty.align 771 ( renderSrc stripSpaces src0 772 <> prettyLabel c <> Pretty.hardline <> renderSrc stripNewline src1 773 <> colon <> space <> renderSrc stripSpaces src3 <> prettyExpression d <> Pretty.hardline 774 <> equals <> space <> renderSrc stripSpaces src2 775 <> prettyExpression e 776 ) 777 778 docB = 779 ( keyword "in" <> " " <> prettyExpression b 780 , keyword "in" <> " " <> prettyExpression b 781 ) 782 prettyExpression a0@(Pi _ _ _ _) = 783 arrows characterSet (docs a0) 784 where 785 docs (Pi _ "_" b c) = prettyOperatorExpression b : docs c 786 docs (Pi _ a b c) = Pretty.group (Pretty.flatAlt long short) : docs c 787 where 788 long = forall characterSet <> space 789 <> Pretty.align 790 ( lparen <> space 791 <> prettyLabel a 792 <> Pretty.hardline 793 <> colon <> space 794 <> prettyExpression b 795 <> Pretty.hardline 796 <> rparen 797 ) 798 799 short = forall characterSet <> lparen 800 <> prettyLabel a 801 <> space <> colon <> space 802 <> prettyExpression b 803 <> rparen 804 docs c 805 | Just doc <- preserveSource c = 806 [ doc ] 807 | Note _ d <- c = 808 docs d 809 | otherwise = 810 [ prettyExpression c ] 811 prettyExpression (With (Dhall.Syntax.shallowDenote -> a) b c) = 812 case a of 813 With{} -> 814 -- Don't parenthesize an inner with-expression 815 prettyExpression a 816 _ -> 817 prettyImportExpression_ a 818 <> Pretty.flatAlt long short 819 where 820 short = " " <> keyword "with" <> " " <> update 821 822 long = Pretty.hardline 823 <> " " 824 <> Pretty.align (keyword "with" <> " " <> update) 825 826 (update, _) = 827 prettyKeyValue prettyOperatorExpression equals (makeKeyValue b c) 828 prettyExpression (Assert a) = 829 Pretty.group (Pretty.flatAlt long short) 830 where 831 short = keyword "assert" <> " " <> colon <> " " <> prettyExpression a 832 833 long = 834 Pretty.align 835 ( " " <> keyword "assert" 836 <> Pretty.hardline <> colon <> " " <> prettyExpression a 837 ) 838 prettyExpression a 839 | Just doc <- preserveSource a = 840 doc 841 | Note _ b <- a = 842 prettyExpression b 843 | otherwise = 844 prettyAnnotatedExpression a 845 846 prettyAnnotatedExpression :: Pretty a => Expr Src a -> Doc Ann 847 prettyAnnotatedExpression (Merge a b (Just c)) = 848 Pretty.group (Pretty.flatAlt long short) 849 where 850 long = 851 Pretty.align 852 ( keyword "merge" 853 <> Pretty.hardline 854 <> Pretty.indent 2 (prettyImportExpression_ a) 855 <> Pretty.hardline 856 <> Pretty.indent 2 (prettyImportExpression_ b) 857 <> Pretty.hardline 858 <> colon <> space 859 <> prettyApplicationExpression c 860 ) 861 862 short = keyword "merge" <> space 863 <> prettyImportExpression_ a 864 <> " " 865 <> prettyImportExpression_ b 866 <> space <> colon <> space 867 <> prettyApplicationExpression c 868 prettyAnnotatedExpression (ToMap a (Just b)) = 869 Pretty.group (Pretty.flatAlt long short) 870 where 871 long = 872 Pretty.align 873 ( keyword "toMap" 874 <> Pretty.hardline 875 <> Pretty.indent 2 (prettyImportExpression_ a) 876 <> Pretty.hardline 877 <> colon <> space 878 <> prettyApplicationExpression b 879 ) 880 881 short = keyword "toMap" <> space 882 <> prettyImportExpression_ a 883 <> space <> colon <> space 884 <> prettyApplicationExpression b 885 prettyAnnotatedExpression a0@(Annot _ _) = 886 enclose' 887 "" 888 " " 889 (" " <> colon <> " ") 890 (colon <> space) 891 (fmap duplicate (docs a0)) 892 where 893 docs (Annot a b) = prettyOperatorExpression a : docs b 894 docs a 895 | Just doc <- preserveSource a = 896 [ doc ] 897 | Note _ b <- a = 898 docs b 899 | otherwise = 900 [ prettyExpression a ] 901 prettyAnnotatedExpression (ListLit (Just a) b) = 902 list (map prettyExpression (Data.Foldable.toList b)) 903 <> " : " 904 <> prettyApplicationExpression a 905 prettyAnnotatedExpression a 906 | Just doc <- preserveSource a = 907 doc 908 | Note _ b <- a = 909 prettyAnnotatedExpression b 910 | otherwise = 911 prettyOperatorExpression a 912 913 prettyOperatorExpression :: Pretty a => Expr Src a -> Doc Ann 914 prettyOperatorExpression = prettyEquivalentExpression 915 916 prettyOperator :: Text -> [Doc Ann] -> Doc Ann 917 prettyOperator op docs = 918 enclose' 919 "" 920 prefix 921 (" " <> operator (Pretty.pretty op) <> " ") 922 (operator (Pretty.pretty op) <> spacer) 923 (reverse (fmap duplicate docs)) 924 where 925 prefix = if Text.length op == 1 then " " else " " 926 927 spacer = if Text.length op == 1 then " " else " " 928 929 prettyEquivalentExpression :: Pretty a => Expr Src a -> Doc Ann 930 prettyEquivalentExpression a0@(Equivalent _ _) = 931 prettyOperator (equivalent characterSet) (docs a0) 932 where 933 docs (Equivalent a b) = prettyImportAltExpression b : docs a 934 docs a 935 | Just doc <- preserveSource a = 936 [ doc ] 937 | Note _ b <- a = 938 docs b 939 | otherwise = 940 [ prettyImportAltExpression a ] 941 prettyEquivalentExpression a 942 | Just doc <- preserveSource a = 943 doc 944 | Note _ b <- a = 945 prettyEquivalentExpression b 946 | otherwise = 947 prettyImportAltExpression a 948 949 prettyImportAltExpression :: Pretty a => Expr Src a -> Doc Ann 950 prettyImportAltExpression a0@(ImportAlt _ _) = 951 prettyOperator "?" (docs a0) 952 where 953 docs (ImportAlt a b) = prettyOrExpression b : docs a 954 docs a 955 | Just doc <- preserveSource a = 956 [ doc ] 957 | Note _ b <- a = 958 docs b 959 | otherwise = 960 [ prettyOrExpression a ] 961 prettyImportAltExpression a 962 | Just doc <- preserveSource a = 963 doc 964 | Note _ b <- a = 965 prettyImportAltExpression b 966 | otherwise = 967 prettyOrExpression a 968 969 prettyOrExpression :: Pretty a => Expr Src a -> Doc Ann 970 prettyOrExpression a0@(BoolOr _ _) = 971 prettyOperator "||" (docs a0) 972 where 973 docs (BoolOr a b) = prettyPlusExpression b : docs a 974 docs a 975 | Just doc <- preserveSource a = 976 [ doc ] 977 | Note _ b <- a = 978 docs b 979 | otherwise = 980 [ prettyPlusExpression a ] 981 prettyOrExpression a 982 | Just doc <- preserveSource a = 983 doc 984 | Note _ b <- a = 985 prettyOrExpression b 986 | otherwise = 987 prettyPlusExpression a 988 989 prettyPlusExpression :: Pretty a => Expr Src a -> Doc Ann 990 prettyPlusExpression a0@(NaturalPlus _ _) = 991 prettyOperator "+" (docs a0) 992 where 993 docs (NaturalPlus a b) = prettyTextAppendExpression b : docs a 994 docs a 995 | Just doc <- preserveSource a = 996 [ doc ] 997 | Note _ b <- a = 998 docs b 999 | otherwise = 1000 [ prettyTextAppendExpression a ] 1001 prettyPlusExpression a 1002 | Just doc <- preserveSource a = 1003 doc 1004 | Note _ b <- a = 1005 prettyPlusExpression b 1006 | otherwise = 1007 prettyTextAppendExpression a 1008 1009 prettyTextAppendExpression :: Pretty a => Expr Src a -> Doc Ann 1010 prettyTextAppendExpression a0@(TextAppend _ _) = 1011 prettyOperator "++" (docs a0) 1012 where 1013 docs (TextAppend a b) = prettyListAppendExpression b : docs a 1014 docs a 1015 | Just doc <- preserveSource a = 1016 [ doc ] 1017 | Note _ b <- a = 1018 docs b 1019 | otherwise = 1020 [ prettyListAppendExpression a ] 1021 prettyTextAppendExpression a 1022 | Just doc <- preserveSource a = 1023 doc 1024 | Note _ b <- a = 1025 prettyTextAppendExpression b 1026 | otherwise = 1027 prettyListAppendExpression a 1028 1029 prettyListAppendExpression :: Pretty a => Expr Src a -> Doc Ann 1030 prettyListAppendExpression a0@(ListAppend _ _) = 1031 prettyOperator "#" (docs a0) 1032 where 1033 docs (ListAppend a b) = prettyAndExpression b : docs a 1034 docs a 1035 | Just doc <- preserveSource a = 1036 [ doc ] 1037 | Note _ b <- a = 1038 docs b 1039 | otherwise = 1040 [ prettyAndExpression a ] 1041 prettyListAppendExpression a 1042 | Just doc <- preserveSource a = 1043 doc 1044 | Note _ b <- a = 1045 prettyListAppendExpression b 1046 | otherwise = 1047 prettyAndExpression a 1048 1049 prettyAndExpression :: Pretty a => Expr Src a -> Doc Ann 1050 prettyAndExpression a0@(BoolAnd _ _) = 1051 prettyOperator "&&" (docs a0) 1052 where 1053 docs (BoolAnd a b) = prettyCombineExpression b : docs a 1054 docs a 1055 | Just doc <- preserveSource a = 1056 [ doc ] 1057 | Note _ b <- a = 1058 docs b 1059 | otherwise = 1060 [ prettyCombineExpression a ] 1061 prettyAndExpression a 1062 | Just doc <- preserveSource a = 1063 doc 1064 | Note _ b <- a = 1065 prettyAndExpression b 1066 | otherwise = 1067 prettyCombineExpression a 1068 1069 prettyCombineExpression :: Pretty a => Expr Src a -> Doc Ann 1070 prettyCombineExpression a0@(Combine _ _ _ _) = 1071 prettyOperator (combine characterSet) (docs a0) 1072 where 1073 docs (Combine _ _ a b) = prettyPreferExpression b : docs a 1074 docs a 1075 | Just doc <- preserveSource a = 1076 [ doc ] 1077 | Note _ b <- a = 1078 docs b 1079 | otherwise = 1080 [ prettyPreferExpression a ] 1081 prettyCombineExpression a 1082 | Just doc <- preserveSource a = 1083 doc 1084 | Note _ b <- a = 1085 prettyCombineExpression b 1086 | otherwise = 1087 prettyPreferExpression a 1088 1089 prettyPreferExpression :: Pretty a => Expr Src a -> Doc Ann 1090 prettyPreferExpression a0@(Prefer {}) = 1091 prettyOperator (prefer characterSet) (docs a0) 1092 where 1093 docs (Prefer _ _ a b) = prettyCombineTypesExpression b : docs a 1094 docs a 1095 | Just doc <- preserveSource a = 1096 [ doc ] 1097 | Note _ b <- a = 1098 docs b 1099 | otherwise = 1100 [ prettyCombineTypesExpression a ] 1101 prettyPreferExpression a 1102 | Just doc <- preserveSource a = 1103 doc 1104 | Note _ b <- a = 1105 prettyPreferExpression b 1106 | otherwise = 1107 prettyCombineTypesExpression a 1108 1109 prettyCombineTypesExpression :: Pretty a => Expr Src a -> Doc Ann 1110 prettyCombineTypesExpression a0@(CombineTypes _ _ _) = 1111 prettyOperator (combineTypes characterSet) (docs a0) 1112 where 1113 docs (CombineTypes _ a b) = prettyTimesExpression b : docs a 1114 docs a 1115 | Just doc <- preserveSource a = 1116 [ doc ] 1117 | Note _ b <- a = 1118 docs b 1119 | otherwise = 1120 [ prettyTimesExpression a ] 1121 prettyCombineTypesExpression a 1122 | Just doc <- preserveSource a = 1123 doc 1124 | Note _ b <- a = 1125 prettyCombineTypesExpression b 1126 | otherwise = 1127 prettyTimesExpression a 1128 1129 prettyTimesExpression :: Pretty a => Expr Src a -> Doc Ann 1130 prettyTimesExpression a0@(NaturalTimes _ _) = 1131 prettyOperator "*" (docs a0) 1132 where 1133 docs (NaturalTimes a b) = prettyEqualExpression b : docs a 1134 docs a 1135 | Just doc <- preserveSource a = 1136 [ doc ] 1137 | Note _ b <- a = 1138 docs b 1139 | otherwise = 1140 [ prettyEqualExpression a ] 1141 prettyTimesExpression a 1142 | Just doc <- preserveSource a = 1143 doc 1144 | Note _ b <- a = 1145 prettyTimesExpression b 1146 | otherwise = 1147 prettyEqualExpression a 1148 1149 prettyEqualExpression :: Pretty a => Expr Src a -> Doc Ann 1150 prettyEqualExpression a0@(BoolEQ _ _) = 1151 prettyOperator "==" (docs a0) 1152 where 1153 docs (BoolEQ a b) = prettyNotEqualExpression b : docs a 1154 docs a 1155 | Just doc <- preserveSource a = 1156 [ doc ] 1157 | Note _ b <- a = 1158 docs b 1159 | otherwise = 1160 [ prettyNotEqualExpression a ] 1161 prettyEqualExpression a 1162 | Just doc <- preserveSource a = 1163 doc 1164 | Note _ b <- a = 1165 prettyEqualExpression b 1166 | otherwise = 1167 prettyNotEqualExpression a 1168 1169 prettyNotEqualExpression :: Pretty a => Expr Src a -> Doc Ann 1170 prettyNotEqualExpression a0@(BoolNE _ _) = 1171 prettyOperator "!=" (docs a0) 1172 where 1173 docs (BoolNE a b) = prettyApplicationExpression b : docs a 1174 docs a 1175 | Just doc <- preserveSource a = 1176 [ doc ] 1177 | Note _ b <- a = 1178 docs b 1179 | otherwise = 1180 [ prettyApplicationExpression a ] 1181 prettyNotEqualExpression a 1182 | Just doc <- preserveSource a = 1183 doc 1184 | Note _ b <- a = 1185 prettyNotEqualExpression b 1186 | otherwise = 1187 prettyApplicationExpression a 1188 1189 prettyApplicationExpression :: Pretty a => Expr Src a -> Doc Ann 1190 prettyApplicationExpression = go [] 1191 where 1192 go args = \case 1193 App a b -> go (b : args) a 1194 Some a -> app (builtin "Some") (a : args) 1195 Merge a b Nothing -> app (keyword "merge") (a : b : args) 1196 ToMap a Nothing -> app (keyword "toMap") (a : args) 1197 e | Note _ b <- e -> 1198 go args b 1199 | null args -> 1200 prettyImportExpression_ e -- just a performance optimization 1201 | Just doc <- preserveSource e -> 1202 app doc args 1203 | otherwise -> 1204 app (prettyImportExpression_ e) args 1205 1206 app f args = 1207 enclose' 1208 "" "" " " "" 1209 ( duplicate f 1210 : map (fmap (Pretty.indent 2) . duplicate . prettyImportExpression_) args 1211 ) 1212 1213 prettyImportExpression_ :: Pretty a => Expr Src a -> Doc Ann 1214 prettyImportExpression_ (Embed a) = 1215 Pretty.pretty a 1216 prettyImportExpression_ a 1217 | Just doc <- preserveSource a = 1218 doc 1219 | Note _ b <- a = 1220 prettyImportExpression_ b 1221 | otherwise = 1222 prettyCompletionExpression a 1223 1224 prettyCompletionExpression :: Pretty a => Expr Src a -> Doc Ann 1225 prettyCompletionExpression (RecordCompletion a b) = 1226 case shallowDenote b of 1227 RecordLit kvs -> 1228 Pretty.align 1229 ( prettySelectorExpression a 1230 <> doubleColon 1231 <> prettyCompletionLit 0 kvs 1232 ) 1233 _ -> prettySelectorExpression a 1234 <> doubleColon 1235 <> prettySelectorExpression b 1236 prettyCompletionExpression a 1237 | Just doc <- preserveSource a = 1238 doc 1239 | Note _ b <- a = 1240 prettyCompletionExpression b 1241 | otherwise = 1242 prettySelectorExpression a 1243 1244 prettySelectorExpression :: Pretty a => Expr Src a -> Doc Ann 1245 prettySelectorExpression (Field a (Dhall.Syntax.fieldSelectionLabel -> b)) = 1246 prettySelectorExpression a <> dot <> prettyAnyLabel b 1247 prettySelectorExpression (Project a (Left b)) = 1248 prettySelectorExpression a <> dot <> prettyLabels b 1249 prettySelectorExpression (Project a (Right b)) = 1250 prettySelectorExpression a 1251 <> dot 1252 <> lparen 1253 <> prettyExpression b 1254 <> rparen 1255 prettySelectorExpression a 1256 | Just doc <- preserveSource a = 1257 doc 1258 | Note _ b <- a = 1259 prettySelectorExpression b 1260 | otherwise = 1261 prettyPrimitiveExpression a 1262 1263 prettyPrimitiveExpression :: Pretty a => Expr Src a -> Doc Ann 1264 prettyPrimitiveExpression (Var a) = 1265 prettyVar a 1266 prettyPrimitiveExpression (Const k) = 1267 prettyConst k 1268 prettyPrimitiveExpression Bool = 1269 builtin "Bool" 1270 prettyPrimitiveExpression Natural = 1271 builtin "Natural" 1272 prettyPrimitiveExpression NaturalFold = 1273 builtin "Natural/fold" 1274 prettyPrimitiveExpression NaturalBuild = 1275 builtin "Natural/build" 1276 prettyPrimitiveExpression NaturalIsZero = 1277 builtin "Natural/isZero" 1278 prettyPrimitiveExpression NaturalEven = 1279 builtin "Natural/even" 1280 prettyPrimitiveExpression NaturalOdd = 1281 builtin "Natural/odd" 1282 prettyPrimitiveExpression NaturalToInteger = 1283 builtin "Natural/toInteger" 1284 prettyPrimitiveExpression NaturalShow = 1285 builtin "Natural/show" 1286 prettyPrimitiveExpression NaturalSubtract = 1287 builtin "Natural/subtract" 1288 prettyPrimitiveExpression Integer = 1289 builtin "Integer" 1290 prettyPrimitiveExpression IntegerClamp = 1291 builtin "Integer/clamp" 1292 prettyPrimitiveExpression IntegerNegate = 1293 builtin "Integer/negate" 1294 prettyPrimitiveExpression IntegerShow = 1295 builtin "Integer/show" 1296 prettyPrimitiveExpression IntegerToDouble = 1297 builtin "Integer/toDouble" 1298 prettyPrimitiveExpression Double = 1299 builtin "Double" 1300 prettyPrimitiveExpression DoubleShow = 1301 builtin "Double/show" 1302 prettyPrimitiveExpression Text = 1303 builtin "Text" 1304 prettyPrimitiveExpression TextReplace = 1305 builtin "Text/replace" 1306 prettyPrimitiveExpression TextShow = 1307 builtin "Text/show" 1308 prettyPrimitiveExpression List = 1309 builtin "List" 1310 prettyPrimitiveExpression ListBuild = 1311 builtin "List/build" 1312 prettyPrimitiveExpression ListFold = 1313 builtin "List/fold" 1314 prettyPrimitiveExpression ListLength = 1315 builtin "List/length" 1316 prettyPrimitiveExpression ListHead = 1317 builtin "List/head" 1318 prettyPrimitiveExpression ListLast = 1319 builtin "List/last" 1320 prettyPrimitiveExpression ListIndexed = 1321 builtin "List/indexed" 1322 prettyPrimitiveExpression ListReverse = 1323 builtin "List/reverse" 1324 prettyPrimitiveExpression Optional = 1325 builtin "Optional" 1326 prettyPrimitiveExpression None = 1327 builtin "None" 1328 prettyPrimitiveExpression (BoolLit True) = 1329 builtin "True" 1330 prettyPrimitiveExpression (BoolLit False) = 1331 builtin "False" 1332 prettyPrimitiveExpression (IntegerLit a) 1333 | 0 <= a = literal "+" <> prettyNumber a 1334 | otherwise = prettyNumber a 1335 prettyPrimitiveExpression (NaturalLit a) = 1336 prettyNatural a 1337 prettyPrimitiveExpression (DoubleLit (DhallDouble a)) = 1338 prettyDouble a 1339 prettyPrimitiveExpression (TextLit a) = 1340 prettyChunks a 1341 prettyPrimitiveExpression (Record a) = 1342 prettyRecord a 1343 prettyPrimitiveExpression (RecordLit a) = 1344 prettyRecordLit a 1345 prettyPrimitiveExpression (Union a) = 1346 prettyUnion a 1347 prettyPrimitiveExpression (ListLit Nothing b) = 1348 list (map prettyExpression (Data.Foldable.toList b)) 1349 prettyPrimitiveExpression a 1350 | Just doc <- preserveSource a = 1351 doc 1352 | Note _ b <- a = 1353 prettyPrimitiveExpression b 1354 | otherwise = 1355 Pretty.group (Pretty.flatAlt long short) 1356 where 1357 long = 1358 Pretty.align 1359 (lparen <> space <> prettyExpression a <> Pretty.hardline <> rparen) 1360 1361 short = lparen <> prettyExpression a <> rparen 1362 1363 prettyKeyValue 1364 :: Pretty a 1365 => (Expr Src a -> Doc Ann) 1366 -> Doc Ann 1367 -> KeyValue Src a 1368 -> (Doc Ann, Doc Ann) 1369 prettyKeyValue prettyValue separator (KeyValue key mSrc val) = 1370 duplicate (Pretty.group (Pretty.flatAlt long short)) 1371 where 1372 completion _T r = 1373 prettySelectorExpression _T 1374 <> doubleColon 1375 <> case shallowDenote r of 1376 RecordLit kvs -> 1377 prettyCompletionLit 2 kvs 1378 _ -> 1379 prettySelectorExpression r 1380 1381 short = prettyAnyLabels key 1382 <> " " 1383 <> separator 1384 <> " " 1385 <> case renderSrcMaybe mSrc of 1386 Nothing -> mempty 1387 Just doc -> doc <> Pretty.hardline 1388 <> prettyValue val 1389 1390 long = Pretty.align 1391 ( prettyAnyLabels key 1392 <> preSeparator 1393 ) 1394 <> separator 1395 <> case renderSrcMaybe mSrc of 1396 Just doc -> 1397 preComment 1398 <> Pretty.align 1399 ( doc 1400 <> Pretty.hardline 1401 <> prettyValue val 1402 ) 1403 Nothing -> 1404 case shallowDenote val of 1405 Some val' -> 1406 " " 1407 <> builtin "Some" 1408 <> case shallowDenote val' of 1409 RecordCompletion _T r -> 1410 " " 1411 <> completion _T r 1412 1413 RecordLit _ -> 1414 Pretty.hardline 1415 <> " " 1416 <> prettyImportExpression_ val' 1417 1418 ListLit _ xs 1419 | not (null xs) -> 1420 Pretty.hardline 1421 <> " " 1422 <> prettyImportExpression_ val' 1423 1424 _ -> Pretty.hardline 1425 <> " " 1426 <> prettyImportExpression_ val' 1427 1428 ToMap val' Nothing -> 1429 " " 1430 <> keyword "toMap" 1431 <> case shallowDenote val' of 1432 RecordCompletion _T r -> 1433 completion _T r 1434 _ -> Pretty.hardline 1435 <> " " 1436 <> prettyImportExpression_ val' 1437 1438 RecordCompletion _T r -> 1439 " " <> completion _T r 1440 1441 RecordLit _ -> 1442 Pretty.hardline 1443 <> " " 1444 <> prettyValue val 1445 1446 ListLit _ xs 1447 | not (null xs) -> 1448 Pretty.hardline 1449 <> " " 1450 <> prettyValue val 1451 1452 _ -> 1453 Pretty.group 1454 ( Pretty.flatAlt (Pretty.hardline <> " ") " " 1455 <> prettyValue val 1456 ) 1457 where 1458 (preSeparator, preComment) = 1459 case key of 1460 (_, _, mSrc2) :| [] | not (containsComment mSrc2) -> 1461 (" ", Pretty.hardline <> " ") 1462 _ -> 1463 (Pretty.hardline, " ") 1464 1465 1466 prettyRecord :: Pretty a => Map Text (RecordField Src a) -> Doc Ann 1467 prettyRecord = 1468 braces 1469 . map (prettyKeyValue prettyExpression colon . adapt) 1470 . Map.toList 1471 where 1472 adapt (key, RecordField mSrc0 val mSrc1 mSrc2) = KeyValue (pure (mSrc0, key, mSrc1)) mSrc2 val 1473 1474 prettyRecordLit :: Pretty a => Map Text (RecordField Src a) -> Doc Ann 1475 prettyRecordLit = prettyRecordLike braces 1476 1477 prettyCompletionLit :: Pretty a => Int -> Map Text (RecordField Src a) -> Doc Ann 1478 prettyCompletionLit = prettyRecordLike . hangingBraces 1479 1480 prettyRecordLike 1481 :: Pretty a 1482 => ([(Doc Ann, Doc Ann)] -> Doc Ann) 1483 -> Map Text (RecordField Src a) 1484 -> Doc Ann 1485 prettyRecordLike braceStyle a 1486 | Data.Foldable.null a = 1487 lbrace <> equals <> rbrace 1488 | otherwise = 1489 braceStyle (map prettyRecordEntry (consolidateRecordLiteral a)) 1490 where 1491 prettyRecordEntry kv@(KeyValue keys mSrc2 val) = 1492 case keys of 1493 (mSrc0, key, mSrc1) :| [] 1494 | Var (V key' 0) <- Dhall.Syntax.shallowDenote val 1495 , key == key' 1496 , not (containsComment mSrc2) -> 1497 duplicate (prettyAnyLabels [(mSrc0, key, mSrc1)]) 1498 _ -> 1499 prettyKeyValue prettyExpression equals kv 1500 1501 prettyAlternative (key, Just val) = 1502 prettyKeyValue prettyExpression colon (makeKeyValue (pure key) val) 1503 prettyAlternative (key, Nothing) = 1504 duplicate (prettyAnyLabel key) 1505 1506 prettyUnion :: Pretty a => Map Text (Maybe (Expr Src a)) -> Doc Ann 1507 prettyUnion = 1508 angles . map prettyAlternative . Map.toList 1509 1510 prettyChunks :: Pretty a => Chunks Src a -> Doc Ann 1511 prettyChunks chunks@(Chunks a b) 1512 | anyText (== '\n') = 1513 if not (null a) || anyText (/= '\n') 1514 then long 1515 else Pretty.group (Pretty.flatAlt long short) 1516 | otherwise = 1517 short 1518 where 1519 long = 1520 Pretty.align 1521 ( literal "''" <> Pretty.hardline 1522 <> Pretty.align 1523 (foldMap prettyMultilineChunk a' <> prettyMultilineText b') 1524 <> literal "''" 1525 ) 1526 where 1527 Chunks a' b' = multilineChunks chunks 1528 1529 short = 1530 literal "\"" <> foldMap prettyChunk a <> literal (prettyText b <> "\"") 1531 1532 anyText predicate = any (\(text, _) -> Text.any predicate text) a || Text.any predicate b 1533 1534 prettyMultilineChunk (c, d) = 1535 prettyMultilineText c 1536 <> dollar 1537 <> lbrace 1538 <> prettyExpression d 1539 <> rbrace 1540 1541 prettyMultilineText text = mconcat docs 1542 where 1543 lines_ = Text.splitOn "\n" text 1544 1545 -- Annotate only non-empty lines so trailing whitespace can be 1546 -- removed on empty ones. 1547 prettyLine line = 1548 (if Text.null line then id else literal) 1549 (Pretty.pretty line) 1550 1551 docs = 1552 Data.List.intersperse Pretty.hardline (map prettyLine lines_) 1553 1554 prettyChunk (c, d) = 1555 prettyText c 1556 <> syntax "${" 1557 <> prettyExpression d 1558 <> syntax rbrace 1559 1560 prettyText t = literal (Pretty.pretty (escapeText_ t)) 1561 1562 1563-- | Prepare 'Chunks' for multi-line formatting by escaping problematic 1564-- character sequences via string interpolations 1565-- 1566-- >>> multilineChunks (Chunks [] "\n \tx") 1567-- Chunks [("\n",TextLit (Chunks [] " \t"))] "x" 1568-- >>> multilineChunks (Chunks [] "\n\NUL\b\f\t") 1569-- Chunks [("\n",TextLit (Chunks [] "\NUL\b\f"))] "\t" 1570multilineChunks :: Chunks s a -> Chunks s a 1571multilineChunks = 1572 escapeSingleQuotedText 1573 . escapeTrailingSingleQuote 1574 . escapeControlCharacters 1575 . escapeSingleQuoteBeforeInterpolation 1576 . escapeSharedWhitespacePrefix 1577 1578-- | Escape any leading whitespace shared by all lines 1579-- 1580-- This ensures that significant shared leading whitespace is not stripped 1581-- 1582-- >>> escapeSharedWhitespacePrefix (Chunks [] "\n \tx") 1583-- Chunks [("\n",TextLit (Chunks [] " \t"))] "x" 1584-- >>> escapeSharedWhitespacePrefix (Chunks [("\n",Var (V "x" 0))] " ") 1585-- Chunks [("\n",Var (V "x" 0))] " " 1586-- >>> escapeSharedWhitespacePrefix (Chunks [("\n ",Var (V "x" 0))] "") 1587-- Chunks [("\n",TextLit (Chunks [] " ")),("",Var (V "x" 0))] "" 1588-- >>> escapeSharedWhitespacePrefix (Chunks [("\n ",Var (V "x" 0))] "\n") 1589-- Chunks [("\n ",Var (V "x" 0))] "\n" 1590-- >>> escapeSharedWhitespacePrefix (Chunks [] " ") 1591-- Chunks [("",TextLit (Chunks [] " "))] "" 1592escapeSharedWhitespacePrefix :: Chunks s a -> Chunks s a 1593escapeSharedWhitespacePrefix literal_ = unlinesLiteral literals₁ 1594 where 1595 literals₀ = linesLiteral literal_ 1596 1597 sharedPrefix = longestSharedWhitespacePrefix literals₀ 1598 1599 stripPrefix = Text.drop (Text.length sharedPrefix) 1600 1601 escapeSharedPrefix (Chunks [] prefix₀) 1602 | Text.isPrefixOf sharedPrefix prefix₀ = 1603 Chunks [ ("", TextLit (Chunks [] sharedPrefix)) ] prefix₁ 1604 where 1605 prefix₁ = stripPrefix prefix₀ 1606 escapeSharedPrefix (Chunks ((prefix₀, y) : xys) z) 1607 | Text.isPrefixOf sharedPrefix prefix₀ = 1608 Chunks (("", TextLit (Chunks [] sharedPrefix)) : (prefix₁, y) : xys) z 1609 where 1610 prefix₁ = stripPrefix prefix₀ 1611 escapeSharedPrefix line = line 1612 1613 literals₁ 1614 | not (Text.null sharedPrefix) = fmap escapeSharedPrefix literals₀ 1615 | otherwise = literals₀ 1616 1617-- | Escape control characters by moving them into string interpolations 1618-- 1619-- >>> escapeControlCharacters (Chunks [] "\n\NUL\b\f\t") 1620-- Chunks [("\n",TextLit (Chunks [] "\NUL\b\f"))] "\t" 1621escapeControlCharacters :: Chunks s a -> Chunks s a 1622escapeControlCharacters = splitWith (splitOnPredicate predicate) 1623 where 1624 predicate c = Data.Char.isControl c && c /= ' ' && c /= '\t' && c /= '\n' 1625 1626-- | Escape @'${@ correctly 1627-- 1628-- See: https://github.com/dhall-lang/dhall-haskell/issues/2078 1629escapeSingleQuoteBeforeInterpolation :: Chunks s a -> Chunks s a 1630escapeSingleQuoteBeforeInterpolation = splitWith f 1631 where 1632 f text = 1633 case Text.splitOn "'${" text of 1634 -- `splitOn` should never return an empty list, but just in case… 1635 [] -> mempty 1636 t : ts -> loop t ts 1637 1638 loop head_ tail_ = 1639 case tail_ of 1640 [] -> 1641 Chunks [] head_ 1642 newHead : newTail -> 1643 Chunks [ (head_, TextLit (Chunks [] "'")) ] "${" 1644 <> loop newHead newTail 1645 1646{-| You can think of this as sort of like `concatMap` for `Chunks` 1647 1648 Given a function that splits plain text into interpolated chunks, apply 1649 that function to each uninterpolated span to yield a new 1650 possibly-interpolated span, and flatten the results. 1651-} 1652splitWith :: (Text -> Chunks s a) -> Chunks s a -> Chunks s a 1653splitWith splitter (Chunks xys z) = mconcat (xys' ++ [ splitter z ]) 1654 where 1655 xys' = do 1656 (x, y) <- xys 1657 1658 [ splitter x, Chunks [ ("", y) ] "" ] 1659 1660-- | Split `Data.Text.Text` into interpolated chunks, where all characters 1661-- matching the predicate are pushed into a string interpolation. 1662-- 1663-- >>> splitOnPredicate (== 'x') "" 1664-- Chunks [] "" 1665-- >>> splitOnPredicate (== 'x') " xx " 1666-- Chunks [(" ",TextLit (Chunks [] "xx"))] " " 1667-- >>> splitOnPredicate (== 'x') "xx" 1668-- Chunks [("",TextLit (Chunks [] "xx"))] "" 1669-- 1670-- prop> \(Fun _ p) s -> let {t = Text.pack s; Chunks xys z = splitOnPredicate p t} in foldMap (\(x, TextLit (Chunks [] y)) -> x <> y) xys <> z == t 1671splitOnPredicate :: (Char -> Bool) -> Text -> Chunks s a 1672splitOnPredicate predicate text 1673 | Text.null b = 1674 Chunks [] a 1675 | otherwise = 1676 Chunks ((a, TextLit (Chunks [] c)) : e) f 1677 where 1678 (a, b) = Text.break predicate text 1679 1680 (c, d) = Text.span predicate b 1681 1682 Chunks e f = splitOnPredicate predicate d 1683 1684-- | Escape a trailing single quote by moving it into a string interpolation 1685-- 1686-- Otherwise the multiline-string would end with @'''@, which would be parsed 1687-- as an escaped @''@. 1688-- 1689-- >>> escapeTrailingSingleQuote (Chunks [] "\n'") 1690-- Chunks [("\n",TextLit (Chunks [] "'"))] "" 1691escapeTrailingSingleQuote :: Chunks s a -> Chunks s a 1692escapeTrailingSingleQuote chunks@(Chunks as b) = 1693 case Text.unsnoc b of 1694 Just (b', '\'') -> Chunks (as ++ [(b', TextLit (Chunks [] "'"))]) "" 1695 _ -> chunks 1696 1697-- | Pretty-print a value 1698pretty_ :: Pretty a => a -> Text 1699pretty_ = prettyToStrictText 1700 1701data KeyValue s a = KeyValue 1702 { _keyValueKeys :: NonEmpty (Maybe s, Text, Maybe s) 1703 , _keyValueSrc :: Maybe s 1704 , _keyValueValue :: Expr s a 1705 } 1706 1707makeKeyValue :: NonEmpty Text -> Expr s a -> KeyValue s a 1708makeKeyValue keys expr = KeyValue (adapt <$> keys) Nothing expr 1709 where 1710 adapt key = (Nothing, key, Nothing) 1711 1712{- This utility function converts 1713 `{ x = { y = { z = 1 } } }` to `{ x.y.z = 1 }` 1714-} 1715consolidateRecordLiteral :: Map Text (RecordField Src a) -> [KeyValue Src a] 1716consolidateRecordLiteral = concatMap adapt . Map.toList 1717 where 1718 adapt :: (Text, RecordField Src a) -> [KeyValue Src a] 1719 adapt (key, RecordField mSrc0 val mSrc1 mSrc2) 1720 | not (containsComment mSrc2) 1721 , RecordLit m <- e 1722 , [ KeyValue keys mSrc2' val' ] <- concatMap adapt (Map.toList m) = 1723 [ KeyValue (NonEmpty.cons (mSrc0, key, mSrc1) keys) mSrc2' val' ] 1724 1725 | Combine _ (Just _) l r <- e = 1726 adapt (key, makeRecordField l) <> adapt (key, makeRecordField r) 1727 | otherwise = 1728 [ KeyValue (pure (mSrc0, key, mSrc1)) mSrc2 val ] 1729 where 1730 e = shallowDenote val 1731 1732-- | Escape a `Data.Text.Text` literal using Dhall's escaping rules for 1733-- single-quoted @Text@ 1734escapeSingleQuotedText :: Chunks s a -> Chunks s a 1735escapeSingleQuotedText = splitWith f 1736 where 1737 f inputText = Chunks [] outputText 1738 where 1739 outputText = 1740 Text.replace "${" "''${" (Text.replace "''" "'''" inputText) 1741 1742{-| Escape a `Data.Text.Text` literal using Dhall's escaping rules 1743 1744 Note that the result does not include surrounding quotes 1745-} 1746escapeText_ :: Text -> Text 1747escapeText_ text = Text.concatMap adapt text 1748 where 1749 adapt c 1750 | '\x20' <= c && c <= '\x21' = Text.singleton c 1751 -- '\x22' == '"' 1752 | '\x23' == c = Text.singleton c 1753 -- '\x24' == '$' 1754 | '\x25' <= c && c <= '\x5B' = Text.singleton c 1755 -- '\x5C' == '\\' 1756 | '\x5D' <= c && c <= '\x10FFFF' = Text.singleton c 1757 | c == '"' = "\\\"" 1758 | c == '$' = "\\$" 1759 | c == '\\' = "\\\\" 1760 | c == '\b' = "\\b" 1761 | c == '\f' = "\\f" 1762 | c == '\n' = "\\n" 1763 | c == '\r' = "\\r" 1764 | c == '\t' = "\\t" 1765 | otherwise = "\\u" <> showDigits (Data.Char.ord c) 1766 1767 showDigits r0 = Text.pack (map showDigit [q1, q2, q3, r3]) 1768 where 1769 (q1, r1) = r0 `quotRem` 4096 1770 (q2, r2) = r1 `quotRem` 256 1771 (q3, r3) = r2 `quotRem` 16 1772 1773 showDigit n 1774 | n < 10 = Data.Char.chr (Data.Char.ord '0' + n) 1775 | otherwise = Data.Char.chr (Data.Char.ord 'A' + n - 10) 1776 1777prettyToString :: Pretty a => a -> String 1778prettyToString = 1779 Pretty.renderString . layout . Pretty.pretty 1780 1781docToStrictText :: Doc ann -> Text.Text 1782docToStrictText = Pretty.renderStrict . layout 1783 1784prettyToStrictText :: Pretty a => a -> Text.Text 1785prettyToStrictText = docToStrictText . Pretty.pretty 1786 1787-- | Layout using 'layoutOpts' 1788-- 1789-- Tries hard to fit the document into 80 columns. 1790-- 1791-- This also removes trailing space characters (@' '@) /unless/ 1792-- they are enclosed in an annotation. 1793layout :: Pretty.Doc ann -> Pretty.SimpleDocStream ann 1794layout = Pretty.removeTrailingWhitespace . Pretty.layoutSmart layoutOpts 1795 1796-- | Default layout options 1797layoutOpts :: Pretty.LayoutOptions 1798layoutOpts = 1799 Pretty.defaultLayoutOptions 1800 { Pretty.layoutPageWidth = Pretty.AvailablePerLine 80 1.0 } 1801 1802{- $setup 1803>>> import Test.QuickCheck (Fun(..)) 1804-} 1805