1{-# LANGUAGE CPP #-} 2{-# LANGUAGE DefaultSignatures #-} 3{-# LANGUAGE GeneralizedNewtypeDeriving #-} 4{-# LANGUAGE OverloadedStrings #-} 5{-# LANGUAGE RecordWildCards #-} 6 7module Floskell.Pretty ( Pretty(..), pretty ) where 8 9import Control.Applicative ( (<|>) ) 10import Control.Monad 11 ( forM_, guard, replicateM_, unless, void, when ) 12import Control.Monad.State.Strict ( get, gets, modify ) 13 14import Data.Bool ( bool ) 15import Data.ByteString ( ByteString ) 16import qualified Data.ByteString as BS 17import qualified Data.ByteString.Char8 as BS8 18import qualified Data.ByteString.Lazy as BL 19import Data.List ( groupBy, sortBy, sortOn ) 20import Data.Maybe ( catMaybes, fromMaybe ) 21import qualified Data.Set as Set 22 23import qualified Floskell.Buffer as Buffer 24import Floskell.Config 25import Floskell.Imports 26 ( groupImports, sortImports, splitImports ) 27import Floskell.Printers 28import Floskell.Types 29 30import qualified Language.Haskell.Exts.Pretty as HSE 31import Language.Haskell.Exts.Syntax 32 33-- | Like `span`, but comparing adjacent items. 34run :: (a -> a -> Bool) -> [a] -> ([a], [a]) 35run _ [] = ([], []) 36run _ [ x ] = ([ x ], []) 37run eq (x : y : xs) 38 | eq x y = let (ys, zs) = run eq (y : xs) in (x : ys, zs) 39 | otherwise = ([ x ], y : xs) 40 41-- | Like `groupBy`, but comparing adjacent items. 42runs :: (a -> a -> Bool) -> [a] -> [[a]] 43runs _ [] = [] 44runs eq xs = let (ys, zs) = run eq xs in ys : runs eq zs 45 46stopImportModule :: TabStop 47stopImportModule = TabStop "import-module" 48 49stopImportSpec :: TabStop 50stopImportSpec = TabStop "import-spec" 51 52stopRecordField :: TabStop 53stopRecordField = TabStop "record" 54 55stopRhs :: TabStop 56stopRhs = TabStop "rhs" 57 58flattenApp :: Annotated ast 59 => (ast NodeInfo -> Maybe (ast NodeInfo, ast NodeInfo)) 60 -> ast NodeInfo 61 -> [ast NodeInfo] 62flattenApp fn = go . amap (\info -> info { nodeInfoLeadingComments = [] 63 , nodeInfoTrailingComments = [] 64 }) 65 where 66 go x = case fn x of 67 Just (lhs, rhs) -> let lhs' = go $ copyComments Before x lhs 68 rhs' = go $ copyComments After x rhs 69 in 70 lhs' ++ rhs' 71 Nothing -> [ x ] 72 73flattenInfix 74 :: (Annotated ast1, Annotated ast2) 75 => (ast1 NodeInfo -> Maybe (ast1 NodeInfo, ast2 NodeInfo, ast1 NodeInfo)) 76 -> ast1 NodeInfo 77 -> (ast1 NodeInfo, [(ast2 NodeInfo, ast1 NodeInfo)]) 78flattenInfix fn = go . amap (\info -> info { nodeInfoLeadingComments = [] 79 , nodeInfoTrailingComments = [] 80 }) 81 where 82 go x = case fn x of 83 Just (lhs, op, rhs) -> 84 let (lhs', ops) = go $ copyComments Before x lhs 85 (lhs'', ops') = go $ copyComments After x rhs 86 in 87 (lhs', ops ++ (op, lhs'') : ops') 88 Nothing -> (x, []) 89 90-- | Pretty printing prettyHSE using haskell-src-exts pretty printer 91prettyHSE :: HSE.Pretty (ast NodeInfo) => ast NodeInfo -> Printer () 92prettyHSE ast = string $ HSE.prettyPrint ast 93 94-- | Type class for pretty-printable types. 95class Pretty ast where 96 prettyPrint :: ast NodeInfo -> Printer () 97 default prettyPrint 98 :: HSE.Pretty (ast NodeInfo) => ast NodeInfo -> Printer () 99 prettyPrint = prettyHSE 100 101-- | Pretty print a syntax tree with annotated comments 102pretty :: (Annotated ast, Pretty ast) => ast NodeInfo -> Printer () 103pretty ast = do 104 printComments Before ast 105 prettyPrint ast 106 printComments After ast 107 108prettyOnside :: (Annotated ast, Pretty ast) => ast NodeInfo -> Printer () 109prettyOnside ast = do 110 eol <- gets psEolComment 111 when eol newline 112 nl <- gets psNewline 113 if nl 114 then do 115 printComments Before ast 116 onside $ prettyPrint ast 117 printComments After ast 118 else onside $ pretty ast 119 120-- | Compare two AST nodes ignoring the annotation 121compareAST 122 :: (Functor ast, Ord (ast ())) => ast NodeInfo -> ast NodeInfo -> Ordering 123compareAST a b = void a `compare` void b 124 125-- | Return leading comments. 126filterComments :: Annotated a => Location -> a NodeInfo -> [Comment] 127filterComments Before = nodeInfoLeadingComments . ann 128filterComments After = nodeInfoTrailingComments . ann 129 130-- | Copy comments from one AST node to another. 131copyComments :: (Annotated ast1, Annotated ast2) 132 => Location 133 -> ast1 NodeInfo 134 -> ast2 NodeInfo 135 -> ast2 NodeInfo 136copyComments Before from to = 137 amap (\n -> 138 n { nodeInfoLeadingComments = nodeInfoLeadingComments $ ann from }) 139 to 140copyComments After from to = 141 amap (\n -> 142 n { nodeInfoTrailingComments = nodeInfoTrailingComments $ ann from }) 143 to 144 145-- | Pretty print a comment. 146printComment :: Int -> (Comment, SrcSpan) -> Printer () 147printComment correction (Comment{..}, nextSpan) = do 148 col <- getNextColumn 149 let padding = max 0 $ srcSpanStartColumn commentSpan + correction - col - 1 150 case commentType of 151 PreprocessorDirective -> do 152 nl <- gets psNewline 153 unless nl newline 154 column 0 $ string commentText 155 modify (\s -> s { psEolComment = True }) 156 InlineComment -> do 157 write $ BS.replicate padding 32 158 write "{-" 159 string commentText 160 write "-}" 161 when (srcSpanEndLine commentSpan /= srcSpanStartLine nextSpan) $ 162 modify (\s -> s { psEolComment = True }) 163 LineComment -> do 164 write $ BS.replicate padding 32 165 write "--" 166 string commentText 167 modify (\s -> s { psEolComment = True }) 168 169-- | Print comments of a node. 170printComments :: Annotated ast => Location -> ast NodeInfo -> Printer () 171printComments = printCommentsInternal True 172 173-- | Print comments of a node, but do not force newline before leading comments. 174printComments' :: Annotated ast => Location -> ast NodeInfo -> Printer () 175printComments' = printCommentsInternal False 176 177printCommentsInternal 178 :: Annotated ast => Bool -> Location -> ast NodeInfo -> Printer () 179printCommentsInternal nlBefore loc ast = unless (null comments) $ do 180 let firstComment = head comments 181 -- Preceeding comments must have a newline before them, but not break onside indent. 182 nl <- gets psNewline 183 onside' <- gets psOnside 184 when nl $ modify $ \s -> s { psOnside = 0 } 185 when (loc == Before && not nl && nlBefore) newline 186 when (loc == After && not nl && notSameLine firstComment) newline 187 188 col <- getNextColumn 189 let correction = case loc of 190 Before -> col - srcSpanStartColumn ssi + 1 191 After -> col - srcSpanEndColumn ssi + 1 192 forM_ (zip comments (tail (map commentSpan comments ++ [ ssi ]))) $ 193 printComment correction 194 195 -- Write newline before restoring onside indent. 196 eol <- gets psEolComment 197 when (loc == Before && eol && onside' > 0) newline 198 when nl $ modify $ \s -> s { psOnside = onside' } 199 where 200 ssi = nodeSpan ast 201 202 comments = filterComments loc ast 203 204 notSameLine comment = srcSpanEndLine ssi 205 < srcSpanStartLine (commentSpan comment) 206 207-- | Return the configuration name of an operator 208opName :: QOp a -> ByteString 209opName op = case op of 210 (QVarOp _ qname) -> opName' qname 211 (QConOp _ qname) -> opName' qname 212 213-- | Return the configuration name of an operator 214opName' :: QName a -> ByteString 215opName' (Qual _ _ name) = opName'' name 216opName' (UnQual _ name) = opName'' name 217opName' (Special _ (FunCon _)) = "->" 218opName' (Special _ (Cons _)) = ":" 219opName' (Special _ _) = "" 220 221-- | Return the configuration name of an operator 222opName'' :: Name a -> ByteString 223opName'' (Ident _ _) = "``" 224opName'' (Symbol _ str) = BS8.pack str 225 226lineDelta :: Annotated ast => ast NodeInfo -> ast NodeInfo -> Int 227lineDelta prev next = nextLine - prevLine 228 where 229 prevLine = maximum (prevNodeLine : prevCommentLines) 230 231 nextLine = minimum (nextNodeLine : nextCommentLines) 232 233 prevNodeLine = srcSpanEndLine $ nodeSpan prev 234 235 nextNodeLine = srcSpanStartLine $ nodeSpan next 236 237 prevCommentLines = map (srcSpanEndLine . commentSpan) $ 238 filterComments After prev 239 240 nextCommentLines = map (srcSpanStartLine . commentSpan) $ 241 filterComments Before next 242 243linedFn :: Annotated ast 244 => (ast NodeInfo -> Printer ()) 245 -> [ast NodeInfo] 246 -> Printer () 247linedFn fn xs = do 248 preserveP <- getOption cfgOptionPreserveVerticalSpace 249 if preserveP 250 then case xs of 251 x : xs' -> do 252 cut $ fn x 253 forM_ (zip xs xs') $ \(prev, cur) -> do 254 replicateM_ (min 2 (max 1 $ lineDelta prev cur)) newline 255 cut $ fn cur 256 [] -> return () 257 else inter newline $ map (cut . fn) xs 258 259lined :: (Annotated ast, Pretty ast) => [ast NodeInfo] -> Printer () 260lined = linedFn pretty 261 262linedOnside :: (Annotated ast, Pretty ast) => [ast NodeInfo] -> Printer () 263linedOnside = linedFn prettyOnside 264 265listVOpLen :: LayoutContext -> ByteString -> Printer Int 266listVOpLen ctx sep = do 267 ws <- getConfig (cfgOpWs ctx sep . cfgOp) 268 return $ if wsLinebreak After ws 269 then 0 270 else BS.length sep + if wsSpace After ws then 1 else 0 271 272listVinternal :: (Annotated ast, Pretty ast) 273 => LayoutContext 274 -> ByteString 275 -> [ast NodeInfo] 276 -> Printer () 277listVinternal ctx sep xs = case xs of 278 [] -> newline 279 (x : xs') -> do 280 nl <- gets psNewline 281 col <- getNextColumn 282 delta <- listVOpLen ctx sep 283 let itemCol = if nl && length xs > 1 then col + delta else col 284 sepCol = itemCol - delta 285 column itemCol $ do 286 printComments' Before x 287 cut $ prettyPrint x 288 printComments After x 289 -- `column sepCol` must not be within `column itemCol`, or the 290 -- former can suppress onside for the latter. 291 forM_ xs' $ \x' -> do 292 column itemCol $ printComments Before x' 293 column sepCol $ operatorV ctx sep 294 column itemCol $ cut $ prettyPrint x' 295 column itemCol $ printComments After x' 296 297listH :: (Annotated ast, Pretty ast) 298 => LayoutContext 299 -> ByteString 300 -> ByteString 301 -> ByteString 302 -> [ast NodeInfo] 303 -> Printer () 304listH _ open close _ [] = do 305 write open 306 write close 307 308listH ctx open close sep xs = 309 groupH ctx open close . inter (operatorH ctx sep) $ map pretty xs 310 311listV :: (Annotated ast, Pretty ast) 312 => LayoutContext 313 -> ByteString 314 -> ByteString 315 -> ByteString 316 -> [ast NodeInfo] 317 -> Printer () 318listV ctx open close sep xs = groupV ctx open close $ do 319 ws <- getConfig (cfgOpWs ctx sep . cfgOp) 320 ws' <- getConfig (cfgGroupWs ctx open . cfgGroup) 321 unless (wsLinebreak Before ws' || wsSpace After ws' || wsLinebreak After ws 322 || not (wsSpace After ws)) 323 space 324 listVinternal ctx sep xs 325 326list :: (Annotated ast, Pretty ast) 327 => LayoutContext 328 -> ByteString 329 -> ByteString 330 -> ByteString 331 -> [ast NodeInfo] 332 -> Printer () 333list ctx open close sep xs = oneline hor <|> ver 334 where 335 hor = listH ctx open close sep xs 336 337 ver = listV ctx open close sep xs 338 339listH' :: (Annotated ast, Pretty ast) 340 => LayoutContext 341 -> ByteString 342 -> [ast NodeInfo] 343 -> Printer () 344listH' ctx sep = inter (operatorH ctx sep) . map pretty 345 346listV' :: (Annotated ast, Pretty ast) 347 => LayoutContext 348 -> ByteString 349 -> [ast NodeInfo] 350 -> Printer () 351listV' ctx sep xs = 352 if length xs > 1 then listVinternal ctx sep xs else mapM_ pretty xs 353 354list' :: (Annotated ast, Pretty ast) 355 => LayoutContext 356 -> ByteString 357 -> [ast NodeInfo] 358 -> Printer () 359list' ctx sep xs = oneline hor <|> ver 360 where 361 hor = listH' ctx sep xs 362 363 ver = listV' ctx sep xs 364 365listAutoWrap :: (Annotated ast, Pretty ast) 366 => LayoutContext 367 -> ByteString 368 -> ByteString 369 -> ByteString 370 -> [ast NodeInfo] 371 -> Printer () 372listAutoWrap _ open close _ [] = do 373 write open 374 write close 375 376listAutoWrap ctx open close sep xs = 377 aligned . groupH ctx open close $ listAutoWrap' ctx sep xs 378 379listAutoWrap' :: (Annotated ast, Pretty ast) 380 => LayoutContext 381 -> ByteString 382 -> [ast NodeInfo] 383 -> Printer () 384listAutoWrap' _ _ [] = return () 385listAutoWrap' ctx sep (x : xs) = aligned $ do 386 ws <- getConfig (cfgOpWs ctx sep . cfgOp) 387 let correction = if wsLinebreak After ws 388 then 0 389 else BS.length sep + if wsSpace After ws then 1 else 0 390 col <- getNextColumn 391 pretty x 392 go (col - correction) xs 393 where 394 go _ [] = return () 395 go col [x'] = do 396 printComments Before x' 397 column col $ operator ctx sep 398 prettyPrint x' 399 printComments After x' 400 go col (x':xs') = do 401 printComments Before x' 402 cut $ do 403 column col $ operator ctx sep 404 prettyPrint x' 405 printComments After x' 406 go col xs' 407 408measure :: Printer a -> Printer (Maybe Int) 409measure p = do 410 s <- get 411 let s' = s { psBuffer = Buffer.empty, psEolComment = False } 412 return $ case execPrinter (oneline p) s' of 413 Nothing -> Nothing 414 Just (_, s'') -> Just . (\x -> x - psIndentLevel s) . fromIntegral 415 . BL.length . Buffer.toLazyByteString $ psBuffer s'' 416 417measure' :: Printer a -> Printer (Maybe [Int]) 418measure' p = fmap (: []) <$> measure p 419 420measureMatch :: Match NodeInfo -> Printer (Maybe [Int]) 421measureMatch (Match _ name pats _ Nothing) = measure' (prettyApp name pats) 422measureMatch (InfixMatch _ pat name pats _ Nothing) = measure' go 423 where 424 go = do 425 pretty pat 426 withOperatorFormatting Pattern 427 (opName'' name) 428 (prettyHSE $ VarOp noNodeInfo name) 429 id 430 inter spaceOrNewline $ map pretty pats 431measureMatch _ = return Nothing 432 433measureDecl :: Decl NodeInfo -> Printer (Maybe [Int]) 434measureDecl (PatBind _ pat _ Nothing) = measure' (pretty pat) 435measureDecl (FunBind _ matches) = 436 fmap concat . sequence <$> traverse measureMatch matches 437measureDecl _ = return Nothing 438 439measureClassDecl :: ClassDecl NodeInfo -> Printer (Maybe [Int]) 440measureClassDecl (ClsDecl _ decl) = measureDecl decl 441measureClassDecl _ = return Nothing 442 443measureInstDecl :: InstDecl NodeInfo -> Printer (Maybe [Int]) 444measureInstDecl (InsDecl _ decl) = measureDecl decl 445measureInstDecl _ = return Nothing 446 447measureAlt :: Alt NodeInfo -> Printer (Maybe [Int]) 448measureAlt (Alt _ pat _ Nothing) = measure' (pretty pat) 449measureAlt _ = return Nothing 450 451withComputedTabStop :: TabStop 452 -> (AlignConfig -> Bool) 453 -> (a -> Printer (Maybe [Int])) 454 -> [a] 455 -> Printer b 456 -> Printer b 457withComputedTabStop name predicate fn xs p = do 458 enabled <- getConfig (predicate . cfgAlign) 459 (limAbs, limRel) <- getConfig (cfgAlignLimits . cfgAlign) 460 mtabss <- sequence <$> traverse fn xs 461 let tab = do 462 tabss <- mtabss 463 let tabs = concat tabss 464 maxtab = maximum tabs 465 mintab = minimum tabs 466 delta = maxtab - mintab 467 diff = delta * 100 `div` maxtab 468 guard enabled 469 guard $ delta <= limAbs || diff <= limRel 470 return maxtab 471 withTabStops [ (name, tab) ] p 472 473------------------------------------------------------------------------ 474-- Module 475-- | Extract the name as a String from a ModuleName 476moduleName :: ModuleName a -> String 477moduleName (ModuleName _ s) = s 478 479prettyPragmas :: [ModulePragma NodeInfo] -> Printer () 480prettyPragmas ps = do 481 splitP <- getOption cfgOptionSplitLanguagePragmas 482 sortP <- getOption cfgOptionSortPragmas 483 let ps' = if splitP then concatMap splitPragma ps else ps 484 let ps'' = if sortP then sortBy compareAST ps' else ps' 485 inter blankline . map lined $ groupBy sameType ps'' 486 where 487 splitPragma (LanguagePragma anno langs) = 488 map (LanguagePragma anno . (: [])) langs 489 splitPragma p = [ p ] 490 491 sameType LanguagePragma{} LanguagePragma{} = True 492 sameType OptionsPragma{} OptionsPragma{} = True 493 sameType AnnModulePragma{} AnnModulePragma{} = True 494 sameType _ _ = False 495 496prettyImports :: [ImportDecl NodeInfo] -> Printer () 497prettyImports is = do 498 sortP <- getOption cfgOptionSortImports 499 alignModuleP <- getConfig (cfgAlignImportModule . cfgAlign) 500 alignSpecP <- getConfig (cfgAlignImportSpec . cfgAlign) 501 let maxNameLength = maximum $ map (length . moduleName . importModule) is 502 alignModule = if alignModuleP then Just 16 else Nothing 503 alignSpec = if alignSpecP 504 then Just (fromMaybe 0 alignModule + 1 + maxNameLength) 505 else Nothing 506 withTabStops [ (stopImportModule, alignModule) 507 , (stopImportSpec, alignSpec) 508 ] $ case sortP of 509 NoImportSort -> lined is 510 SortImportsByPrefix -> prettyGroups . groupImports 0 $ sortImports is 511 SortImportsByGroups groups -> prettyGroups $ splitImports groups is 512 where 513 prettyGroups = inter blankline . map (inter newline . map (cut . pretty)) 514 515skipBlank :: Annotated ast 516 => (ast NodeInfo -> ast NodeInfo -> Bool) 517 -> ast NodeInfo 518 -> ast NodeInfo 519 -> Bool 520skipBlank skip a b = skip a b && null (filterComments After a) 521 && null (filterComments Before b) 522 523skipBlankAfterDecl :: Decl a -> Bool 524skipBlankAfterDecl a = case a of 525 TypeSig{} -> True 526 DeprPragmaDecl{} -> True 527 WarnPragmaDecl{} -> True 528 AnnPragma{} -> True 529 MinimalPragma{} -> True 530 InlineSig{} -> True 531 InlineConlikeSig{} -> True 532 SpecSig{} -> True 533 SpecInlineSig{} -> True 534 InstSig{} -> True 535 PatSynSig{} -> True 536 _ -> False 537 538skipBlankDecl :: Decl NodeInfo -> Decl NodeInfo -> Bool 539skipBlankDecl = skipBlank $ \a _ -> skipBlankAfterDecl a 540 541skipBlankClassDecl :: ClassDecl NodeInfo -> ClassDecl NodeInfo -> Bool 542skipBlankClassDecl = skipBlank $ \a _ -> case a of 543 (ClsDecl _ decl) -> skipBlankAfterDecl decl 544 ClsTyDef{} -> True 545 ClsDefSig{} -> True 546 _ -> False 547 548skipBlankInstDecl :: InstDecl NodeInfo -> InstDecl NodeInfo -> Bool 549skipBlankInstDecl = skipBlank $ \a _ -> case a of 550 (InsDecl _ decl) -> skipBlankAfterDecl decl 551 _ -> False 552 553prettyDecls :: (Annotated ast, Pretty ast) 554 => (ast NodeInfo -> ast NodeInfo -> Bool) 555 -> DeclarationConstruct 556 -> [ast NodeInfo] 557 -> Printer () 558prettyDecls fn dc = inter sep . map lined . runs fn 559 where 560 sep = bool blankline newline . Set.member dc 561 =<< getOption cfgOptionDeclNoBlankLines 562 563prettySimpleDecl :: (Annotated ast1, Pretty ast1, Annotated ast2, Pretty ast2) 564 => ast1 NodeInfo 565 -> ByteString 566 -> ast2 NodeInfo 567 -> Printer () 568prettySimpleDecl lhs op rhs = withLayout cfgLayoutDeclaration flex vertical 569 where 570 flex = do 571 pretty lhs 572 operator Declaration op 573 pretty rhs 574 575 vertical = do 576 pretty lhs 577 operatorV Declaration op 578 pretty rhs 579 580prettyConDecls :: (Annotated ast, Pretty ast) => [ast NodeInfo] -> Printer () 581prettyConDecls condecls = do 582 alignedConDecls <- getOption cfgOptionAlignSumTypeDecl 583 if alignedConDecls && length condecls > 1 584 then withLayout cfgLayoutDeclaration flex' vertical' 585 else withLayout cfgLayoutDeclaration flex vertical 586 where 587 flex = do 588 operator Declaration "=" 589 withLayout cfgLayoutConDecls flexDecls verticalDecls 590 591 flex' = withLayout cfgLayoutConDecls flexDecls' verticalDecls' 592 593 vertical = do 594 operatorV Declaration "=" 595 withLayout cfgLayoutConDecls flexDecls verticalDecls 596 597 vertical' = withLayout cfgLayoutConDecls flexDecls' verticalDecls' 598 599 flexDecls = listAutoWrap' Declaration "|" condecls 600 601 flexDecls' = horizontalDecls' <|> verticalDecls' 602 603 horizontalDecls' = do 604 operatorH Declaration "=" 605 listH' Declaration "|" condecls 606 607 verticalDecls = listV' Declaration "|" condecls 608 609 verticalDecls' = do 610 withOperatorFormattingV Declaration "|" (write "=") id 611 listV' Declaration "|" condecls 612 613prettyForall :: (Annotated ast, Pretty ast) => [ast NodeInfo] -> Printer () 614prettyForall vars = do 615 write "forall " 616 inter space $ map pretty vars 617 operator Type "." 618 619prettyTypesig :: (Annotated ast, Pretty ast) 620 => LayoutContext 621 -> [ast NodeInfo] 622 -> Type NodeInfo 623 -> Printer () 624prettyTypesig ctx names ty = do 625 inter comma $ map pretty names 626 atTabStop stopRecordField 627 withIndentConfig cfgIndentTypesig align indentby 628 where 629 align = onside . alignOnOperator ctx "::" $ pretty ty 630 631 indentby i = indented i $ do 632 operator ctx "::" 633 nl <- gets psNewline 634 when nl $ do 635 delta <- listVOpLen ctx "->" 636 write $ BS.replicate delta 32 637 pretty ty 638 639prettyApp :: (Annotated ast1, Annotated ast2, Pretty ast1, Pretty ast2) 640 => ast1 NodeInfo 641 -> [ast2 NodeInfo] 642 -> Printer () 643prettyApp fn args = withLayout cfgLayoutApp flex vertical 644 where 645 flex = do 646 pretty fn 647 forM_ args $ \arg -> cut $ do 648 spaceOrNewline 649 pretty arg 650 651 vertical = do 652 pretty fn 653 withIndent cfgIndentApp $ lined args 654 655prettyInfixApp 656 :: (Annotated ast, Pretty ast, Annotated op, HSE.Pretty (op NodeInfo)) 657 => (op NodeInfo -> ByteString) 658 -> LayoutContext 659 -> (ast NodeInfo, [(op NodeInfo, ast NodeInfo)]) 660 -> Printer () 661prettyInfixApp nameFn ctx (lhs, args) = 662 withLayout cfgLayoutInfixApp flex vertical 663 where 664 flex = do 665 pretty lhs 666 forM_ args $ \(op, arg) -> cut $ do 667 withOperatorFormatting ctx (nameFn op) (prettyOp op) id 668 pretty arg 669 670 vertical = do 671 pretty lhs 672 forM_ args $ \(op, arg) -> do 673 withOperatorFormattingV ctx (nameFn op) (prettyOp op) id 674 pretty arg 675 676 prettyOp op = do 677 printComments Before op 678 prettyHSE op 679 printComments After op 680 681prettyRecord :: (Annotated ast1, Pretty ast1, Annotated ast2, Pretty ast2) 682 => (ast2 NodeInfo -> Printer (Maybe Int)) 683 -> LayoutContext 684 -> ast1 NodeInfo 685 -> [ast2 NodeInfo] 686 -> Printer () 687prettyRecord len ctx name fields = withLayout cfgLayoutRecord flex vertical 688 where 689 flex = do 690 withOperatorFormattingH ctx "record" (pretty name) id 691 prettyRecordFields len ctx fields 692 693 vertical = do 694 withOperatorFormatting ctx "record" (pretty name) id 695 prettyRecordFields len ctx fields 696 697prettyRecordFields :: (Annotated ast, Pretty ast) 698 => (ast NodeInfo -> Printer (Maybe Int)) 699 -> LayoutContext 700 -> [ast NodeInfo] 701 -> Printer () 702prettyRecordFields len ctx fields = withLayout cfgLayoutRecord flex vertical 703 where 704 flex = groupH ctx "{" "}" $ inter (operatorH ctx ",") $ 705 map prettyOnside fields 706 707 vertical = groupV ctx "{" "}" $ 708 withComputedTabStop stopRecordField 709 cfgAlignRecordFields 710 (fmap (fmap pure) . len) 711 fields $ listVinternal ctx "," fields 712 713prettyPragma :: ByteString -> Printer () -> Printer () 714prettyPragma name = prettyPragma' name . Just 715 716prettyPragma' :: ByteString -> Maybe (Printer ()) -> Printer () 717prettyPragma' name mp = do 718 write "{-# " 719 write name 720 mayM_ mp $ withPrefix space aligned 721 write " #-}" 722 723prettyBinds :: Binds NodeInfo -> Printer () 724prettyBinds binds = withIndentBy cfgIndentWhere $ do 725 write "where" 726 withIndent cfgIndentWhereBinds $ pretty binds 727 728instance Pretty Module where 729 prettyPrint (Module _ mhead pragmas imports decls) = inter blankline $ 730 catMaybes [ ifNotEmpty prettyPragmas pragmas 731 , pretty <$> mhead 732 , ifNotEmpty prettyImports imports 733 , ifNotEmpty (prettyDecls skipBlankDecl DeclModule) decls 734 ] 735 where 736 ifNotEmpty f xs = if null xs then Nothing else Just (f xs) 737 738 prettyPrint ast@XmlPage{} = prettyHSE ast 739 prettyPrint ast@XmlHybrid{} = prettyHSE ast 740 741instance Pretty ModuleHead where 742 prettyPrint (ModuleHead _ name mwarning mexports) = do 743 depend "module" $ do 744 pretty name 745 mayM_ mwarning $ withPrefix spaceOrNewline pretty 746 withLayout cfgLayoutExportSpecList flex vertical 747 where 748 flex = do 749 mayM_ mexports $ \(ExportSpecList _ exports) -> do 750 space 751 listAutoWrap Other "(" ")" "," exports 752 write " where" 753 754 vertical = do 755 mayM_ mexports $ \(ExportSpecList _ exports) -> do 756 withIndent cfgIndentExportSpecList $ 757 listV Other "(" ")" "," exports 758 write " where" 759 760instance Pretty WarningText where 761 prettyPrint (DeprText _ s) = write "{-# DEPRECATED " >> string (show s) 762 >> write " #-}" 763 prettyPrint (WarnText _ s) = write "{-# WARNING " >> string (show s) 764 >> write " #-}" 765 766instance Pretty ExportSpec 767 768instance Pretty ImportDecl where 769 prettyPrint ImportDecl{..} = do 770 inter space . map write $ 771 filter (not . BS.null) 772 [ "import" 773 , if importSrc then "{-# SOURCE #-}" else "" 774 , if importSafe then "safe" else "" 775 , if importQualified then "qualified" else "" 776 ] 777 atTabStop stopImportModule 778 space 779 string $ moduleName importModule 780 mayM_ importAs $ \name -> do 781 atTabStop stopImportSpec 782 write " as " 783 pretty name 784 mayM_ importSpecs pretty 785 786instance Pretty ImportSpecList where 787 prettyPrint (ImportSpecList _ hiding specs) = do 788 sortP <- getOption cfgOptionSortImportLists 789 let specs' = if sortP then sortOn HSE.prettyPrint specs else specs 790 atTabStop stopImportSpec 791 withLayout cfgLayoutImportSpecList (flex specs') (vertical specs') 792 where 793 flex imports = withIndentFlex cfgIndentImportSpecList $ do 794 when hiding $ write "hiding " 795 listAutoWrap Other "(" ")" "," imports 796 797 vertical imports = withIndent cfgIndentImportSpecList $ do 798 when hiding $ write "hiding " 799 listV Other "(" ")" "," imports 800 801instance Pretty ImportSpec 802 803instance Pretty Assoc 804 805instance Pretty Decl where 806 prettyPrint (TypeDecl _ declhead ty) = 807 depend "type" $ prettySimpleDecl declhead "=" ty 808 809 prettyPrint (TypeFamDecl _ declhead mresultsig minjectivityinfo) = 810 depend "type family" $ do 811 pretty declhead 812 mayM_ mresultsig pretty 813 mayM_ minjectivityinfo pretty 814 815 prettyPrint (ClosedTypeFamDecl _ 816 declhead 817 mresultsig 818 minjectivityinfo 819 typeeqns) = depend "type family" $ do 820 pretty declhead 821 mayM_ mresultsig pretty 822 mayM_ minjectivityinfo pretty 823 write " where" 824 newline 825 linedOnside typeeqns 826 827 prettyPrint (DataDecl _ dataornew mcontext declhead qualcondecls derivings) = do 828 depend' (pretty dataornew) $ do 829 mapM_ pretty mcontext 830 pretty declhead 831 unless (null qualcondecls) $ prettyConDecls qualcondecls 832 mapM_ pretty derivings 833 834 prettyPrint (GDataDecl _ 835 dataornew 836 mcontext 837 declhead 838 mkind 839 gadtdecls 840 derivings) = do 841 depend' (pretty dataornew) $ do 842 mapM_ pretty mcontext 843 pretty declhead 844 mayM_ mkind $ \kind -> do 845 operator Declaration "::" 846 pretty kind 847 write " where" 848 newline 849 linedOnside gadtdecls 850 mapM_ pretty derivings 851 852 prettyPrint (DataFamDecl _ mcontext declhead mresultsig) = 853 depend "data family" $ do 854 mapM_ pretty mcontext 855 pretty declhead 856 mapM_ pretty mresultsig 857 858 prettyPrint (TypeInsDecl _ ty ty') = 859 depend "type instance" $ prettySimpleDecl ty "=" ty' 860 861 prettyPrint (DataInsDecl _ dataornew ty qualcondecls derivings) = do 862 depend' (pretty dataornew >> write " instance") $ do 863 pretty ty 864 prettyConDecls qualcondecls 865 mapM_ pretty derivings 866 867 prettyPrint (GDataInsDecl _ dataornew ty mkind gadtdecls derivings) = do 868 depend' (pretty dataornew >> write " instance") $ do 869 pretty ty 870 mayM_ mkind $ \kind -> do 871 operator Declaration "::" 872 pretty kind 873 write " where" 874 newline 875 linedOnside gadtdecls 876 mapM_ pretty derivings 877 878 prettyPrint (ClassDecl _ mcontext declhead fundeps mclassdecls) = do 879 depend "class" $ do 880 mapM_ pretty mcontext 881 pretty declhead 882 unless (null fundeps) $ do 883 operator Declaration "|" 884 list' Declaration "," fundeps 885 mayM_ mclassdecls $ \decls -> do 886 write " where" 887 withIndent cfgIndentClass $ withComputedTabStop stopRhs 888 cfgAlignClass 889 measureClassDecl 890 decls $ 891 prettyDecls skipBlankClassDecl DeclClass decls 892 893 prettyPrint (InstDecl _ moverlap instrule minstdecls) = do 894 depend "instance" $ do 895 mapM_ pretty moverlap 896 pretty instrule 897 mayM_ minstdecls $ \decls -> do 898 write " where" 899 withIndent cfgIndentClass $ 900 withComputedTabStop stopRhs cfgAlignClass measureInstDecl decls $ 901 prettyDecls skipBlankInstDecl DeclInstance decls 902 903#if MIN_VERSION_haskell_src_exts(1,20,0) 904 prettyPrint (DerivDecl _ mderivstrategy moverlap instrule) = 905 depend "deriving" $ do 906 mayM_ mderivstrategy $ withPostfix space pretty 907 write "instance " 908 mayM_ moverlap $ withPostfix space pretty 909 pretty instrule 910#else 911 prettyPrint (DerivDecl _ moverlap instrule) = depend "deriving" $ do 912 write "instance " 913 mayM_ moverlap $ withPostfix space pretty 914 pretty instrule 915#endif 916 917 prettyPrint (InfixDecl _ assoc mint ops) = onside $ do 918 pretty assoc 919 mayM_ mint $ withPrefix space int 920 space 921 inter comma $ map prettyHSE ops 922 923 prettyPrint (DefaultDecl _ types) = do 924 write "default " 925 listAutoWrap Other "(" ")" "," types 926 927 prettyPrint (SpliceDecl _ expr) = pretty expr 928 929 prettyPrint (TypeSig _ names ty) = 930 onside $ prettyTypesig Declaration names ty 931 932#if MIN_VERSION_haskell_src_exts(1,21,0) 933 prettyPrint (PatSynSig _ 934 names 935 mtyvarbinds 936 mcontext 937 mtyvarbinds' 938 mcontext' 939 ty) = depend "pattern" $ do 940 inter comma $ map pretty names 941 operator Declaration "::" 942 mapM_ prettyForall mtyvarbinds 943 mayM_ mcontext pretty 944 mapM_ prettyForall mtyvarbinds' 945 mayM_ mcontext' pretty 946 pretty ty 947#elif MIN_VERSION_haskell_src_exts(1,20,0) 948 prettyPrint (PatSynSig _ names mtyvarbinds mcontext mcontext' ty) = 949 depend "pattern" $ do 950 inter comma $ map pretty names 951 operator Declaration "::" 952 mapM_ prettyForall mtyvarbinds 953 mayM_ mcontext pretty 954 mayM_ mcontext' pretty 955 pretty ty 956#else 957 prettyPrint (PatSynSig _ name mtyvarbinds mcontext mcontext' ty) = 958 depend "pattern" $ do 959 pretty name 960 operator Declaration "::" 961 mapM_ prettyForall mtyvarbinds 962 mayM_ mcontext pretty 963 mayM_ mcontext' pretty 964 pretty ty 965#endif 966 967 prettyPrint (FunBind _ matches) = 968 withComputedTabStop stopRhs cfgAlignMatches measureMatch matches $ 969 linedOnside matches 970 971 prettyPrint (PatBind _ pat rhs mbinds) = do 972 onside $ do 973 pretty pat 974 atTabStop stopRhs 975 pretty rhs 976 mapM_ prettyBinds mbinds 977 978 prettyPrint (PatSyn _ pat pat' patternsyndirection) = do 979 depend "pattern" $ prettySimpleDecl pat sep pat' 980 case patternsyndirection of 981 ExplicitBidirectional _ decls -> 982 prettyBinds (BDecls noNodeInfo decls) 983 _ -> return () 984 where 985 sep = case patternsyndirection of 986 ImplicitBidirectional -> "=" 987 ExplicitBidirectional _ _ -> "<-" 988 Unidirectional -> "<-" 989 990 prettyPrint (ForImp _ callconv msafety mstring name ty) = 991 depend "foreign import" $ do 992 pretty callconv 993 mayM_ msafety $ withPrefix space pretty 994 mayM_ mstring $ withPrefix space (string . show) 995 space 996 prettyTypesig Declaration [ name ] ty 997 998 prettyPrint (ForExp _ callconv mstring name ty) = 999 depend "foreign export" $ do 1000 pretty callconv 1001 mayM_ mstring $ withPrefix space (string . show) 1002 space 1003 prettyTypesig Declaration [ name ] ty 1004 1005 prettyPrint (RulePragmaDecl _ rules) = 1006 if null rules 1007 then prettyPragma' "RULES" Nothing 1008 else prettyPragma "RULES" $ mapM_ pretty rules 1009 1010 prettyPrint (DeprPragmaDecl _ deprecations) = 1011 if null deprecations 1012 then prettyPragma' "DEPRECATED" Nothing 1013 else prettyPragma "DEPRECATED" $ forM_ deprecations $ 1014 \(names, str) -> do 1015 unless (null names) $ do 1016 inter comma $ map pretty names 1017 space 1018 string (show str) 1019 1020 prettyPrint (WarnPragmaDecl _ warnings) = 1021 if null warnings 1022 then prettyPragma' "WARNING" Nothing 1023 else prettyPragma "WARNING" $ forM_ warnings $ \(names, str) -> do 1024 unless (null names) $ do 1025 inter comma $ map pretty names 1026 space 1027 string (show str) 1028 1029 prettyPrint (InlineSig _ inline mactivation qname) = prettyPragma name $ do 1030 mayM_ mactivation $ withPostfix space pretty 1031 pretty qname 1032 where 1033 name = if inline then "INLINE" else "NOINLINE" 1034 1035 prettyPrint (InlineConlikeSig _ mactivation qname) = 1036 prettyPragma "INLINE CONLIKE" $ do 1037 mayM_ mactivation $ withPostfix space pretty 1038 pretty qname 1039 1040 prettyPrint (SpecSig _ mactivation qname types) = 1041 prettyPragma "SPECIALISE" $ do 1042 mayM_ mactivation $ withPostfix space pretty 1043 pretty qname 1044 operator Declaration "::" 1045 inter comma $ map pretty types 1046 1047 prettyPrint (SpecInlineSig _ inline mactivation qname types) = 1048 prettyPragma name $ do 1049 mayM_ mactivation $ withPostfix space pretty 1050 pretty qname 1051 operator Declaration "::" 1052 inter comma $ map pretty types 1053 where 1054 name = if inline then "SPECIALISE INLINE" else "SPECIALISE NOINLINE" 1055 1056 prettyPrint (InstSig _ instrule) = 1057 prettyPragma "SPECIALISE instance" $ pretty instrule 1058 1059 prettyPrint (AnnPragma _ annotation) = 1060 prettyPragma "ANN" $ pretty annotation 1061 1062 prettyPrint (MinimalPragma _ mbooleanformula) = 1063 prettyPragma "MINIMAL" $ mapM_ pretty mbooleanformula 1064 1065 -- prettyPrint (RoleAnnotDecl _ qname roles) = undefined 1066 prettyPrint decl = prettyHSE decl 1067 1068instance Pretty DeclHead where 1069 prettyPrint (DHead _ name) = pretty name 1070 1071 prettyPrint (DHInfix _ tyvarbind name) = do 1072 pretty tyvarbind 1073 pretty $ VarOp noNodeInfo name 1074 1075 prettyPrint (DHParen _ declhead) = parens $ pretty declhead 1076 1077 prettyPrint (DHApp _ declhead tyvarbind) = depend' (pretty declhead) $ 1078 pretty tyvarbind 1079 1080instance Pretty InstRule where 1081 prettyPrint (IRule _ mtyvarbinds mcontext insthead) = do 1082 mapM_ prettyForall mtyvarbinds 1083 mapM_ pretty mcontext 1084 pretty insthead 1085 1086 prettyPrint (IParen _ instrule) = parens $ pretty instrule 1087 1088instance Pretty InstHead where 1089 prettyPrint (IHCon _ qname) = pretty qname 1090 1091 prettyPrint (IHInfix _ ty qname) = do 1092 pretty ty 1093 space 1094 pretty qname 1095 1096 prettyPrint (IHParen _ insthead) = parens $ pretty insthead 1097 1098 prettyPrint (IHApp _ insthead ty) = depend' (pretty insthead) $ pretty ty 1099 1100instance Pretty Binds where 1101 prettyPrint (BDecls _ decls) = 1102 withComputedTabStop stopRhs cfgAlignWhere measureDecl decls $ 1103 prettyDecls skipBlankDecl DeclWhere decls 1104 1105 prettyPrint (IPBinds _ ipbinds) = linedOnside ipbinds 1106 1107instance Pretty IPBind where 1108 prettyPrint (IPBind _ ipname expr) = prettySimpleDecl ipname "=" expr 1109 1110instance Pretty InjectivityInfo where 1111 prettyPrint (InjectivityInfo _ name names) = do 1112 operator Declaration "|" 1113 pretty name 1114 operator Declaration "->" 1115 inter space $ map pretty names 1116 1117instance Pretty ResultSig where 1118 prettyPrint (KindSig _ kind) = 1119 withLayout cfgLayoutDeclaration flex vertical 1120 where 1121 flex = do 1122 operator Declaration "::" 1123 pretty kind 1124 1125 vertical = do 1126 operatorV Declaration "::" 1127 pretty kind 1128 1129 prettyPrint (TyVarSig _ tyvarbind) = 1130 withLayout cfgLayoutDeclaration flex vertical 1131 where 1132 flex = do 1133 operator Declaration "=" 1134 pretty tyvarbind 1135 1136 vertical = do 1137 operatorV Declaration "=" 1138 pretty tyvarbind 1139 1140instance Pretty ClassDecl where 1141 prettyPrint (ClsDecl _ decl) = pretty decl 1142 1143 prettyPrint (ClsDataFam _ mcontext declhead mresultsig) = depend "data" $ do 1144 mapM_ pretty mcontext 1145 pretty declhead 1146 mayM_ mresultsig pretty 1147 1148 prettyPrint (ClsTyFam _ declhead mresultsig minjectivityinfo) = 1149 depend "type" $ do 1150 pretty declhead 1151 mayM_ mresultsig pretty 1152 mapM_ pretty minjectivityinfo 1153 1154 prettyPrint (ClsTyDef _ typeeqn) = depend "type" $ pretty typeeqn 1155 1156 prettyPrint (ClsDefSig _ name ty) = do 1157 write "default" 1158 space 1159 prettyTypesig Declaration [ name ] ty 1160 1161instance Pretty InstDecl where 1162 prettyPrint (InsDecl _ decl) = pretty decl 1163 1164 prettyPrint (InsType _ ty ty') = 1165 depend "type" $ prettySimpleDecl ty "=" ty' 1166 1167 prettyPrint (InsData _ dataornew ty qualcondecls derivings) = 1168 depend' (pretty dataornew) $ do 1169 pretty ty 1170 unless (null qualcondecls) $ prettyConDecls qualcondecls 1171 mapM_ pretty derivings 1172 1173 prettyPrint (InsGData _ dataornew ty mkind gadtdecls derivings) = do 1174 depend' (pretty dataornew) $ do 1175 pretty ty 1176 mayM_ mkind $ \kind -> do 1177 operator Declaration "::" 1178 pretty kind 1179 write " where" 1180 newline 1181 lined gadtdecls 1182 mapM_ pretty derivings 1183 1184instance Pretty Deriving where 1185#if MIN_VERSION_haskell_src_exts(1,20,0) 1186 prettyPrint (Deriving _ mderivstrategy instrules) = 1187 withIndentBy cfgIndentDeriving $ do 1188 write "deriving " 1189 prettyStratBefore 1190 case instrules of 1191 [ i@IRule{} ] -> pretty i 1192 [ IParen _ i ] -> listAutoWrap Other "(" ")" "," [ i ] 1193 _ -> listAutoWrap Other "(" ")" "," instrules 1194 prettyStratAfter 1195 where 1196 (prettyStratBefore, prettyStratAfter) = case mderivstrategy of 1197#if MIN_VERSION_haskell_src_exts(1,21,0) 1198 Just x@DerivVia{} -> (return (), space *> pretty x) 1199#endif 1200 Just x -> (pretty x <* space, return ()) 1201 _ -> (return (), return ()) 1202#else 1203 prettyPrint (Deriving _ instrules) = withIndentBy cfgIndentDeriving $ do 1204 write "deriving " 1205 case instrules of 1206 [ i@IRule{} ] -> pretty i 1207 [ IParen _ i ] -> listAutoWrap Other "(" ")" "," [ i ] 1208 _ -> listAutoWrap Other "(" ")" "," instrules 1209#endif 1210 1211instance Pretty ConDecl where 1212 prettyPrint (ConDecl _ name types) = do 1213 pretty name 1214 unless (null types) $ do 1215 space 1216 oneline hor <|> ver 1217 where 1218 hor = inter space $ map pretty types 1219 1220 ver = aligned $ linedOnside types 1221 1222 prettyPrint (InfixConDecl _ ty name ty') = do 1223 pretty ty 1224 pretty $ ConOp noNodeInfo name 1225 pretty ty' 1226 1227 prettyPrint (RecDecl _ name fielddecls) = 1228 prettyRecord len Declaration name fielddecls 1229 where 1230 len (FieldDecl _ names _) = measure $ inter comma $ map pretty names 1231 1232instance Pretty FieldDecl where 1233 prettyPrint (FieldDecl _ names ty) = prettyTypesig Declaration names ty 1234 1235instance Pretty QualConDecl where 1236 prettyPrint (QualConDecl _ mtyvarbinds mcontext condecl) = do 1237 mapM_ prettyForall mtyvarbinds 1238 mapM_ pretty mcontext 1239 pretty condecl 1240 1241instance Pretty GadtDecl where 1242#if MIN_VERSION_haskell_src_exts(1,21,0) 1243 prettyPrint (GadtDecl _ name _ _ mfielddecls ty) = do 1244 pretty name 1245 operator Declaration "::" 1246 mayM_ mfielddecls $ \decls -> do 1247 prettyRecordFields len Declaration decls 1248 operator Type "->" 1249 pretty ty 1250#else 1251 prettyPrint (GadtDecl _ name mfielddecls ty) = do 1252 pretty name 1253 operator Declaration "::" 1254 mayM_ mfielddecls $ \decls -> do 1255 prettyRecordFields len Declaration decls 1256 operator Type "->" 1257 pretty ty 1258#endif 1259 where 1260 len (FieldDecl _ names _) = measure $ inter comma $ map pretty names 1261 1262instance Pretty Match where 1263 prettyPrint (Match _ name pats rhs mbinds) = do 1264 onside $ do 1265 prettyApp name pats 1266 atTabStop stopRhs 1267 pretty rhs 1268 mapM_ prettyBinds mbinds 1269 1270 prettyPrint (InfixMatch _ pat name pats rhs mbinds) = do 1271 onside $ do 1272 withLayout cfgLayoutInfixApp flex vertical 1273 atTabStop stopRhs 1274 pretty rhs 1275 mapM_ prettyBinds mbinds 1276 where 1277 flex = do 1278 pretty pat 1279 withOperatorFormatting Pattern 1280 (opName'' name) 1281 (prettyHSE $ VarOp noNodeInfo name) 1282 id 1283 inter spaceOrNewline $ map pretty pats 1284 1285 vertical = do 1286 pretty pat 1287 withOperatorFormattingV Pattern 1288 (opName'' name) 1289 (prettyHSE $ VarOp noNodeInfo name) 1290 id 1291 linedOnside pats 1292 1293instance Pretty Rhs where 1294 prettyPrint (UnGuardedRhs _ expr) = 1295 cut $ withLayout cfgLayoutDeclaration flex vertical 1296 where 1297 flex = do 1298 operator Declaration "=" 1299 pretty expr 1300 1301 vertical = do 1302 operatorV Declaration "=" 1303 pretty expr 1304 1305 prettyPrint (GuardedRhss _ guardedrhss) = 1306 withIndent cfgIndentMultiIf $ linedOnside guardedrhss 1307 1308instance Pretty GuardedRhs where 1309 prettyPrint (GuardedRhs _ stmts expr) = 1310 withLayout cfgLayoutDeclaration flex vertical 1311 where 1312 flex = do 1313 operatorSectionR Pattern "|" $ write "|" 1314 inter comma $ map pretty stmts 1315 operator Declaration "=" 1316 pretty expr 1317 1318 vertical = do 1319 operatorSectionR Pattern "|" $ write "|" 1320 inter comma $ map pretty stmts 1321 operatorV Declaration "=" 1322 pretty expr 1323 1324instance Pretty Context where 1325 prettyPrint (CxSingle _ asst) = do 1326 pretty asst 1327 operator Type "=>" 1328 1329 prettyPrint (CxTuple _ assts) = do 1330 list Type "(" ")" "," assts 1331 operator Type "=>" 1332 1333 prettyPrint (CxEmpty _) = do 1334 write "()" 1335 operator Type "=>" 1336 1337instance Pretty FunDep where 1338 prettyPrint (FunDep _ names names') = do 1339 inter space $ map pretty names 1340 operator Declaration "->" 1341 inter space $ map pretty names' 1342 1343#if MIN_VERSION_haskell_src_exts(1,22,0) 1344instance Pretty Asst where 1345 prettyPrint (TypeA _ ty) = pretty ty 1346 prettyPrint (IParam _ ipname ty) = prettyTypesig Declaration [ ipname ] ty 1347 prettyPrint (ParenA _ asst) = parens $ pretty asst 1348 1349#else 1350instance Pretty Asst where 1351 prettyPrint (ClassA _ qname types) = do 1352 pretty qname 1353 space 1354 inter space $ map pretty types 1355 1356 prettyPrint (AppA _ name types) = do 1357 pretty name 1358 space 1359 inter space $ map pretty types 1360 1361 prettyPrint (InfixA _ ty qname ty') = do 1362 pretty ty 1363 withOperatorFormatting Type 1364 (opName' qname) 1365 (prettyHSE $ QVarOp noNodeInfo qname) 1366 id 1367 pretty ty' 1368 1369 prettyPrint (IParam _ ipname ty) = prettyTypesig Declaration [ ipname ] ty 1370 1371 prettyPrint (EqualP _ ty ty') = do 1372 pretty ty 1373 operator Type "~" 1374 pretty ty' 1375 1376 prettyPrint (ParenA _ asst) = parens $ pretty asst 1377 1378 prettyPrint (WildCardA _ mname) = do 1379 write "_" 1380 mapM_ pretty mname 1381#endif 1382 1383instance Pretty Type where 1384 prettyPrint t = do 1385 layout <- gets psTypeLayout 1386 case layout of 1387 TypeFree -> withLayout cfgLayoutType flex vertical 1388 TypeFlex -> prettyF t 1389 TypeVertical -> prettyV t 1390 where 1391 flex = withTypeLayout TypeFlex $ prettyF t 1392 1393 vertical = withTypeLayout TypeVertical $ prettyV t 1394 1395 withTypeLayout :: TypeLayout -> Printer () -> Printer () 1396 withTypeLayout l p = do 1397 layout <- gets psTypeLayout 1398 modify $ \s -> s { psTypeLayout = l } 1399 p 1400 modify $ \s -> s { psTypeLayout = layout } 1401 1402 prettyF (TyForall _ mtyvarbinds mcontext ty) = do 1403 mapM_ prettyForall mtyvarbinds 1404 mapM_ pretty mcontext 1405 pretty ty 1406 1407 prettyF (TyFun _ ty ty') = do 1408 pretty ty 1409 operator Type "->" 1410 pretty ty' 1411 1412 prettyF (TyTuple _ boxed tys) = case boxed of 1413 Unboxed -> list Type "(#" "#)" "," tys 1414 Boxed -> list Type "(" ")" "," tys 1415 1416#if MIN_VERSION_haskell_src_exts(1,20,0) 1417 prettyF (TyUnboxedSum _ tys) = list Type "(#" "#)" "|" tys 1418#endif 1419 1420 prettyF (TyList _ ty) = group Type "[" "]" $ pretty ty 1421 1422 prettyF (TyParArray _ ty) = group Type "[:" ":]" $ pretty ty 1423 1424 prettyF ty@TyApp{} = case flattenApp flatten ty of 1425 ctor : args -> prettyApp ctor args 1426 [] -> error "impossible" 1427 where 1428 flatten (TyApp _ a b) = Just (a, b) 1429 flatten _ = Nothing 1430 1431 prettyF (TyVar _ name) = pretty name 1432 1433 prettyF (TyCon _ qname) = pretty qname 1434 1435 prettyF (TyParen _ ty) = parens . withTypeLayout TypeFree $ pretty ty 1436 1437#if MIN_VERSION_haskell_src_exts(1,20,0) 1438 prettyF (TyInfix _ ty op ty') = do 1439 pretty ty 1440 withOperatorFormatting Type opname (prettyHSE op) id 1441 pretty ty' 1442 where 1443 opname = opName' $ case op of 1444 PromotedName _ qname -> qname 1445 UnpromotedName _ qname -> qname 1446#else 1447 prettyF (TyInfix _ ty qname ty') = do 1448 pretty ty 1449 withOperatorFormatting Type (opName' qname) (prettyHSE qname) id 1450 pretty ty' 1451#endif 1452 1453 prettyF (TyKind _ ty kind) = do 1454 pretty ty 1455 operator Type "::" 1456 pretty kind 1457 1458 prettyF (TyPromoted _ promoted) = pretty promoted 1459 1460 prettyF (TyEquals _ ty ty') = do 1461 pretty ty 1462 operator Type "~" 1463 pretty ty' 1464 1465 prettyF (TySplice _ splice) = pretty splice 1466 1467 prettyF (TyBang _ bangtype unpackedness ty) = do 1468 pretty unpackedness 1469 pretty bangtype 1470 pretty ty 1471 1472 prettyF ty@(TyWildCard _ _mname) = prettyHSE ty -- FIXME 1473 1474 prettyF (TyQuasiQuote _ str str') = do 1475 write "[" 1476 string str 1477 write "|" 1478 string str' 1479 write "|]" 1480 1481#if MIN_VERSION_haskell_src_exts(1,21,0) 1482 prettyF (TyStar _) = write "*" 1483#endif 1484 1485 prettyV (TyForall _ mtyvarbinds mcontext ty) = do 1486 forM_ mtyvarbinds $ \tyvarbinds -> do 1487 write "forall " 1488 inter space $ map pretty tyvarbinds 1489 withOperatorFormattingV Type "." (write "." >> space) id 1490 forM_ mcontext $ \context -> do 1491 case context of 1492 (CxSingle _ asst) -> pretty asst 1493 (CxTuple _ assts) -> list Type "(" ")" "," assts 1494 (CxEmpty _) -> write "()" 1495 operatorV Type "=>" 1496 prettyV ty 1497 1498 prettyV (TyFun _ ty ty') = do 1499 pretty ty 1500 operatorV Type "->" 1501 prettyV ty' 1502 1503 prettyV ty = prettyF ty 1504 1505#if !MIN_VERSION_haskell_src_exts(1,21,0) 1506instance Pretty Kind where 1507 prettyPrint (KindStar _) = write "*" 1508 1509 prettyPrint (KindFn _ kind kind') = do 1510 pretty kind 1511 operator Type "->" 1512 pretty kind' 1513 1514 prettyPrint (KindParen _ kind) = parens $ pretty kind 1515 1516 prettyPrint (KindVar _ qname) = pretty qname 1517 1518 prettyPrint (KindApp _ kind kind') = do 1519 pretty kind 1520 space 1521 pretty kind' 1522 1523 prettyPrint (KindTuple _ kinds) = list Type "'(" ")" "," kinds 1524 1525 prettyPrint (KindList _ kind) = group Type "'[" "]" $ pretty kind 1526#endif 1527 1528instance Pretty Promoted where 1529 prettyPrint (PromotedInteger _ _ str) = string str 1530 1531 prettyPrint (PromotedString _ _ str) = do 1532 write "\"" 1533 string str 1534 write "\"" 1535 1536 prettyPrint (PromotedCon _ quote qname) = do 1537 when quote $ write "'" 1538 pretty qname 1539 1540 prettyPrint (PromotedList _ quote tys) = do 1541 when quote $ write "'" 1542 list Expression "[" "]" "," tys 1543 1544 prettyPrint (PromotedTuple _ tys) = do 1545 write "'" 1546 list Expression "(" ")" "," tys 1547 1548 prettyPrint (PromotedUnit _) = write "'()" 1549 1550instance Pretty TyVarBind where 1551 prettyPrint (KindedVar _ name kind) = parens $ do 1552 pretty name 1553 operator Type "::" 1554 pretty kind 1555 1556 prettyPrint (UnkindedVar _ name) = pretty name 1557 1558instance Pretty TypeEqn where 1559 prettyPrint (TypeEqn _ ty ty') = do 1560 pretty ty 1561 operator Type "=" 1562 pretty ty' 1563 1564flexibleOneline :: Printer a -> Printer a 1565flexibleOneline p = do 1566 allowOneline <- getOption cfgOptionFlexibleOneline 1567 if allowOneline then ignoreOneline p else p 1568 1569instance Pretty Exp where 1570 prettyPrint (Var _ qname) = pretty qname 1571 1572 prettyPrint (OverloadedLabel _ str) = do 1573 write "#" 1574 string str 1575 1576 prettyPrint (IPVar _ ipname) = pretty ipname 1577 1578 prettyPrint (Con _ qname) = pretty qname 1579 1580 prettyPrint (Lit _ literal) = pretty literal 1581 1582 prettyPrint e@(InfixApp _ _ qop _) = 1583 prettyInfixApp opName Expression $ flattenInfix flattenInfixApp e 1584 where 1585 flattenInfixApp (InfixApp _ lhs qop' rhs) = 1586 if compareAST qop qop' == EQ 1587 then Just (lhs, qop', rhs) 1588 else Nothing 1589 flattenInfixApp _ = Nothing 1590 1591 prettyPrint e@App{} = case flattenApp flatten e of 1592 fn : args -> prettyApp fn args 1593 [] -> error "impossible" 1594 where 1595 flatten (App _ fn arg) = Just (fn, arg) 1596 flatten _ = Nothing 1597 1598 prettyPrint (NegApp _ expr) = do 1599 write "-" 1600 pretty expr 1601 1602 prettyPrint (Lambda _ pats expr) = do 1603 write "\\" 1604 maybeSpace 1605 inter space $ map pretty pats 1606 flexibleOneline $ do 1607 operator Expression "->" 1608 pretty expr 1609 where 1610 maybeSpace = case pats of 1611 PIrrPat{} : _ -> space 1612 PBangPat{} : _ -> space 1613 _ -> return () 1614 1615 prettyPrint (Let _ binds expr) = withLayout cfgLayoutLet flex vertical 1616 where 1617 flex = do 1618 write "let " 1619 prettyOnside (CompactBinds binds) 1620 spaceOrNewline 1621 write "in " 1622 prettyOnside expr 1623 1624 vertical = withIndentAfter cfgIndentLet 1625 (do 1626 write "let" 1627 withIndent cfgIndentLetBinds $ 1628 pretty (CompactBinds binds)) 1629 (do 1630 newline 1631 write "in" 1632 withIndent cfgIndentLetIn $ pretty expr) 1633 1634 prettyPrint (If _ expr expr' expr'') = withLayout cfgLayoutIf flex vertical 1635 where 1636 flex = do 1637 write "if " 1638 prettyOnside expr 1639 spaceOrNewline 1640 write "then " 1641 prettyOnside expr' 1642 spaceOrNewline 1643 write "else " 1644 prettyOnside expr'' 1645 1646 vertical = withIndentAfter cfgIndentIf 1647 (do 1648 write "if " 1649 prettyOnside expr) 1650 (do 1651 newline 1652 write "then " 1653 prettyOnside expr' 1654 newline 1655 write "else " 1656 prettyOnside expr'') 1657 1658 prettyPrint (MultiIf _ guardedrhss) = do 1659 write "if" 1660 withIndent cfgIndentMultiIf . linedOnside $ map GuardedAlt guardedrhss 1661 1662 prettyPrint (Case _ expr alts) = do 1663 write "case " 1664 pretty expr 1665 write " of" 1666 if null alts 1667 then write " { }" 1668 else flexibleOneline . withIndent cfgIndentCase 1669 . withComputedTabStop stopRhs cfgAlignCase measureAlt alts $ 1670 lined alts 1671 1672 prettyPrint (Do _ stmts) = flexibleOneline $ do 1673 write "do" 1674 withIndent cfgIndentDo $ linedOnside stmts 1675 1676 prettyPrint (MDo _ stmts) = flexibleOneline $ do 1677 write "mdo" 1678 withIndent cfgIndentDo $ linedOnside stmts 1679 1680 prettyPrint (Tuple _ boxed exprs) = case boxed of 1681 Boxed -> list Expression "(" ")" "," exprs 1682 Unboxed -> list Expression "(#" "#)" "," exprs 1683 1684#if MIN_VERSION_haskell_src_exts(1,20,0) 1685 prettyPrint (UnboxedSum _ before after expr) = group Expression "(#" "#)" 1686 . inter space $ replicate before (write "|") ++ [ pretty expr ] 1687 ++ replicate after (write "|") 1688#endif 1689 1690#if MIN_VERSION_haskell_src_exts(1,23,0) 1691 prettyPrint (ArrOp _ expr) = group Expression "(|" "|)" $ pretty expr 1692#endif 1693 1694 prettyPrint (TupleSection _ boxed mexprs) = case boxed of 1695 Boxed -> list Expression "(" ")" "," $ map (MayAst noNodeInfo) mexprs 1696 Unboxed -> list Expression "(#" "#)" "," $ 1697 map (MayAst noNodeInfo) mexprs 1698 1699 prettyPrint (List _ exprs) = list Expression "[" "]" "," exprs 1700 1701 prettyPrint (ParArray _ exprs) = list Expression "[:" ":]" "," exprs 1702 1703 prettyPrint (Paren _ expr) = parens $ pretty expr 1704 1705 prettyPrint (LeftSection _ expr qop) = parens $ do 1706 pretty expr 1707 operatorSectionL Expression (opName qop) $ prettyHSE qop 1708 1709 prettyPrint (RightSection _ qop expr) = parens $ do 1710 operatorSectionR Expression (opName qop) $ prettyHSE qop 1711 pretty expr 1712 1713 prettyPrint (RecConstr _ qname fieldupdates) = 1714 prettyRecord len Expression qname fieldupdates 1715 where 1716 len (FieldUpdate _ n _) = measure $ pretty n 1717 len (FieldPun _ n) = measure $ pretty n 1718 len (FieldWildcard _) = measure $ write ".." 1719 1720 prettyPrint (RecUpdate _ expr fieldupdates) = 1721 prettyRecord len Expression expr fieldupdates 1722 where 1723 len (FieldUpdate _ n _) = measure $ pretty n 1724 len (FieldPun _ n) = measure $ pretty n 1725 len (FieldWildcard _) = measure $ write ".." 1726 1727 prettyPrint (EnumFrom _ expr) = group Expression "[" "]" $ do 1728 pretty expr 1729 operatorSectionL Expression ".." $ write ".." 1730 1731 prettyPrint (EnumFromTo _ expr expr') = group Expression "[" "]" $ do 1732 pretty expr 1733 operator Expression ".." 1734 pretty expr' 1735 1736 prettyPrint (EnumFromThen _ expr expr') = group Expression "[" "]" $ do 1737 pretty expr 1738 comma 1739 pretty expr' 1740 operatorSectionL Expression ".." $ write ".." 1741 1742 prettyPrint (EnumFromThenTo _ expr expr' expr'') = 1743 group Expression "[" "]" $ do 1744 pretty expr 1745 comma 1746 pretty expr' 1747 operator Expression ".." 1748 pretty expr'' 1749 1750 prettyPrint (ParArrayFromTo _ expr expr') = group Expression "[:" ":]" $ do 1751 pretty expr 1752 operator Expression ".." 1753 pretty expr' 1754 1755 prettyPrint (ParArrayFromThenTo _ expr expr' expr'') = 1756 group Expression "[:" ":]" $ do 1757 pretty expr 1758 comma 1759 pretty expr' 1760 operator Expression ".." 1761 pretty expr'' 1762 1763 prettyPrint (ListComp _ expr qualstmts) = 1764 withLayout cfgLayoutListComp flex vertical 1765 where 1766 flex = group Expression "[" "]" $ do 1767 prettyOnside expr 1768 operator Expression "|" 1769 list' Expression "," qualstmts 1770 1771 vertical = groupV Expression "[" "]" $ do 1772 prettyOnside expr 1773 operatorV Expression "|" 1774 listV' Expression "," qualstmts 1775 1776 prettyPrint (ParComp _ expr qualstmtss) = 1777 withLayout cfgLayoutListComp flex vertical 1778 where 1779 flex = group Expression "[" "]" $ do 1780 prettyOnside expr 1781 forM_ qualstmtss $ \qualstmts -> cut $ do 1782 operator Expression "|" 1783 list' Expression "," qualstmts 1784 1785 vertical = groupV Expression "[" "]" $ do 1786 prettyOnside expr 1787 forM_ qualstmtss $ \qualstmts -> cut $ do 1788 operatorV Expression "|" 1789 listV' Expression "," qualstmts 1790 1791 prettyPrint (ParArrayComp _ expr qualstmtss) = 1792 withLayout cfgLayoutListComp flex vertical 1793 where 1794 flex = group Expression "[:" ":]" $ do 1795 prettyOnside expr 1796 forM_ qualstmtss $ \qualstmts -> cut $ do 1797 operator Expression "|" 1798 list' Expression "," qualstmts 1799 1800 vertical = groupV Expression "[:" ":]" $ do 1801 prettyOnside expr 1802 forM_ qualstmtss $ \qualstmts -> cut $ do 1803 operatorV Expression "|" 1804 listV' Expression "," qualstmts 1805 1806 prettyPrint (ExpTypeSig _ expr typ) = prettyTypesig Expression [ expr ] typ 1807 1808 prettyPrint (VarQuote _ qname) = do 1809 write "'" 1810 pretty qname 1811 1812 prettyPrint (TypQuote _ qname) = do 1813 write "''" 1814 pretty qname 1815 1816 prettyPrint (BracketExp _ bracket) = pretty bracket 1817 1818 prettyPrint (SpliceExp _ splice) = pretty splice 1819 1820 prettyPrint (QuasiQuote _ str str') = do 1821 write "[" 1822 string str 1823 write "|" 1824 string str' 1825 write "|]" 1826 1827 prettyPrint (TypeApp _ typ) = do 1828 write "@" 1829 pretty typ 1830 1831 prettyPrint (XTag _ xname xattrs mexpr exprs) = do 1832 write "<" 1833 pretty xname 1834 forM_ xattrs $ withPrefix space pretty 1835 mayM_ mexpr $ withPrefix space pretty 1836 write ">" 1837 mapM_ pretty exprs 1838 write "</" 1839 pretty xname 1840 write ">" 1841 1842 prettyPrint (XETag _ xname xattrs mexpr) = do 1843 write "<" 1844 pretty xname 1845 forM_ xattrs $ withPrefix space pretty 1846 mayM_ mexpr $ withPrefix space pretty 1847 write "/>" 1848 1849 prettyPrint (XPcdata _ str) = string str 1850 1851 prettyPrint (XExpTag _ expr) = do 1852 write "<% " 1853 pretty expr 1854 write " %>" 1855 1856 prettyPrint (XChildTag _ exprs) = do 1857 write "<%>" 1858 inter space $ map pretty exprs 1859 write "</%>" 1860 1861 prettyPrint (CorePragma _ str expr) = do 1862 prettyPragma "CORE" . string $ show str 1863 space 1864 pretty expr 1865 1866 prettyPrint (SCCPragma _ str expr) = do 1867 prettyPragma "SCC" . string $ show str 1868 space 1869 pretty expr 1870 1871 prettyPrint (GenPragma _ str (a, b) (c, d) expr) = do 1872 prettyPragma "GENERATED" $ 1873 inter space 1874 [ string $ show str 1875 , int a 1876 , write ":" 1877 , int b 1878 , write "-" 1879 , int c 1880 , write ":" 1881 , int d 1882 ] 1883 space 1884 pretty expr 1885 1886 prettyPrint (Proc _ pat expr) = do 1887 write "proc " 1888 pretty pat 1889 operator Expression "->" 1890 pretty expr 1891 1892 prettyPrint (LeftArrApp _ expr expr') = do 1893 pretty expr 1894 operator Expression "-<" 1895 pretty expr' 1896 1897 prettyPrint (RightArrApp _ expr expr') = do 1898 pretty expr 1899 operator Expression ">-" 1900 pretty expr' 1901 1902 prettyPrint (LeftArrHighApp _ expr expr') = do 1903 pretty expr 1904 operator Expression "-<<" 1905 pretty expr' 1906 1907 prettyPrint (RightArrHighApp _ expr expr') = do 1908 pretty expr 1909 operator Expression ">>-" 1910 pretty expr' 1911 1912 prettyPrint (LCase _ alts) = flexibleOneline $ do 1913 write "\\case" 1914 if null alts 1915 then write " { }" 1916 else withIndent cfgIndentCase $ 1917 withComputedTabStop stopRhs cfgAlignCase measureAlt alts $ 1918 lined alts 1919 1920#if !MIN_VERSION_haskell_src_exts(1,20,0) 1921 prettyPrint (ExprHole _) = write "_" 1922#endif 1923 1924instance Pretty Alt where 1925 prettyPrint (Alt _ pat rhs mbinds) = do 1926 onside $ do 1927 pretty pat 1928 atTabStop stopRhs 1929 pretty $ GuardedAlts rhs 1930 mapM_ prettyBinds mbinds 1931 1932instance Pretty XAttr where 1933 prettyPrint (XAttr _ xname expr) = do 1934 pretty xname 1935 operator Expression "=" 1936 pretty expr 1937 1938instance Pretty Pat where 1939 prettyPrint (PVar _ name) = pretty name 1940 1941 prettyPrint (PLit _ sign literal) = do 1942 case sign of 1943 Signless _ -> return () 1944 Negative _ -> write "-" 1945 pretty literal 1946 1947 prettyPrint (PNPlusK _ name integer) = do 1948 pretty name 1949 operator Pattern "+" 1950 int $ fromIntegral integer 1951 1952 prettyPrint p@(PInfixApp _ _ qname _) = 1953 prettyInfixApp opName Pattern $ flattenInfix flattenPInfixApp p 1954 where 1955 flattenPInfixApp (PInfixApp _ lhs qname' rhs) = 1956 if compareAST qname qname' == EQ 1957 then Just (lhs, QConOp noNodeInfo qname', rhs) 1958 else Nothing 1959 flattenPInfixApp _ = Nothing 1960 1961 prettyPrint (PApp _ qname pats) = prettyApp qname pats 1962 1963 prettyPrint (PTuple _ boxed pats) = case boxed of 1964 Boxed -> list Pattern "(" ")" "," pats 1965 Unboxed -> list Pattern "(#" "#)" "," pats 1966 1967#if MIN_VERSION_haskell_src_exts(1,20,0) 1968 prettyPrint (PUnboxedSum _ before after pat) = group Pattern "(#" "#)" 1969 . inter space $ replicate before (write "|") ++ [ pretty pat ] 1970 ++ replicate after (write "|") 1971#endif 1972 1973 prettyPrint (PList _ pats) = list Pattern "[" "]" "," pats 1974 1975 prettyPrint (PParen _ pat) = parens $ pretty pat 1976 1977 prettyPrint (PRec _ qname patfields) = do 1978 withOperatorFormatting Pattern "record" (pretty qname) id 1979 list Pattern "{" "}" "," patfields 1980 1981 prettyPrint (PAsPat _ name pat) = do 1982 pretty name 1983 operator Pattern "@" 1984 pretty pat 1985 1986 prettyPrint (PWildCard _) = write "_" 1987 1988 prettyPrint (PIrrPat _ pat) = do 1989 write "~" 1990 pretty pat 1991 1992 prettyPrint (PatTypeSig _ pat ty) = prettyTypesig Pattern [ pat ] ty 1993 1994 prettyPrint (PViewPat _ expr pat) = do 1995 pretty expr 1996 operator Pattern "->" 1997 pretty pat 1998 1999 prettyPrint (PRPat _ rpats) = list Pattern "[" "]" "," rpats 2000 2001 prettyPrint (PXTag _ xname pxattrs mpat pats) = do 2002 write "<" 2003 pretty xname 2004 forM_ pxattrs $ withPrefix space pretty 2005 mayM_ mpat $ withPrefix space pretty 2006 write ">" 2007 mapM_ pretty pats 2008 write "<" 2009 pretty xname 2010 write ">" 2011 2012 prettyPrint (PXETag _ xname pxattrs mpat) = do 2013 write "<" 2014 pretty xname 2015 forM_ pxattrs $ withPrefix space pretty 2016 mayM_ mpat $ withPrefix space pretty 2017 write "/>" 2018 2019 prettyPrint (PXPcdata _ str) = string str 2020 2021 prettyPrint (PXPatTag _ pat) = do 2022 write "<%" 2023 pretty pat 2024 write "%>" 2025 2026 prettyPrint (PXRPats _ rpats) = do 2027 write "<[" 2028 inter space $ map pretty rpats 2029 write "%>" 2030 2031#if MIN_VERSION_haskell_src_exts(1,20,0) 2032 prettyPrint (PSplice _ splice) = pretty splice 2033#endif 2034 2035 prettyPrint (PQuasiQuote _ str str') = do 2036 write "[$" 2037 string str 2038 write "|" 2039 string str' 2040 write "|]" 2041 2042 prettyPrint (PBangPat _ pat) = do 2043 write "!" 2044 pretty pat 2045 2046instance Pretty PatField where 2047 prettyPrint (PFieldPat _ qname pat) = do 2048 pretty qname 2049 operator Pattern "=" 2050 pretty pat 2051 2052 prettyPrint (PFieldPun _ qname) = pretty qname 2053 2054 prettyPrint (PFieldWildcard _) = write ".." 2055 2056instance Pretty PXAttr where 2057 prettyPrint (PXAttr _ xname pat) = do 2058 pretty xname 2059 operator Pattern "=" 2060 pretty pat 2061 2062instance Pretty Literal where 2063 prettyPrint (Char _ _ str) = do 2064 write "'" 2065 string str 2066 write "'" 2067 2068 prettyPrint (String _ _ str) = do 2069 write "\"" 2070 string str 2071 write "\"" 2072 2073 prettyPrint (Int _ _ str) = string str 2074 2075 prettyPrint (Frac _ _ str) = string str 2076 2077 prettyPrint (PrimInt _ _ str) = do 2078 string str 2079 write "#" 2080 2081 prettyPrint (PrimWord _ _ str) = do 2082 string str 2083 write "##" 2084 2085 prettyPrint (PrimFloat _ _ str) = do 2086 string str 2087 write "#" 2088 2089 prettyPrint (PrimDouble _ _ str) = do 2090 string str 2091 write "##" 2092 2093 prettyPrint (PrimChar _ _ str) = do 2094 write "'" 2095 string str 2096 write "'#" 2097 2098 prettyPrint (PrimString _ _ str) = do 2099 write "\"" 2100 string str 2101 write "\"#" 2102 2103instance Pretty QualStmt where 2104 prettyPrint (QualStmt _ stmt) = pretty stmt 2105 2106 prettyPrint (ThenTrans _ expr) = do 2107 write "then " 2108 pretty expr 2109 2110 prettyPrint (ThenBy _ expr expr') = do 2111 write "then " 2112 pretty expr 2113 write " by " 2114 pretty expr' 2115 2116 prettyPrint (GroupBy _ expr) = do 2117 write "then group by " 2118 pretty expr 2119 2120 prettyPrint (GroupUsing _ expr) = do 2121 write "then group using " 2122 pretty expr 2123 2124 prettyPrint (GroupByUsing _ expr expr') = do 2125 write "then group by " 2126 pretty expr 2127 write " using " 2128 pretty expr' 2129 2130instance Pretty Stmt where 2131 prettyPrint (Generator _ pat expr) = do 2132 pretty pat 2133 operator Expression "<-" 2134 pretty expr 2135 2136 prettyPrint (Qualifier _ expr) = pretty expr 2137 2138 prettyPrint (LetStmt _ binds) = do 2139 write "let " 2140 pretty $ CompactBinds binds 2141 2142 prettyPrint (RecStmt _ stmts) = do 2143 write "rec " 2144 aligned $ linedOnside stmts 2145 2146instance Pretty FieldUpdate where 2147 prettyPrint (FieldUpdate _ qname expr) = do 2148 pretty qname 2149 onside $ do 2150 atTabStop stopRecordField 2151 operator Expression "=" 2152 pretty expr 2153 2154 prettyPrint (FieldPun _ qname) = pretty qname 2155 2156 prettyPrint (FieldWildcard _) = write ".." 2157 2158instance Pretty QOp where 2159 prettyPrint qop = 2160 withOperatorFormatting Expression (opName qop) (prettyHSE qop) id 2161 2162instance Pretty Op where 2163 prettyPrint (VarOp l name) = prettyPrint (QVarOp l (UnQual noNodeInfo name)) 2164 prettyPrint (ConOp l name) = prettyPrint (QConOp l (UnQual noNodeInfo name)) 2165 2166instance Pretty Bracket where 2167 prettyPrint (ExpBracket _ expr) = group Expression "[|" "|]" $ pretty expr 2168 2169#if MIN_VERSION_haskell_src_exts(1,22,0) 2170 prettyPrint (TExpBracket _ expr) = 2171 group Expression "[||" "||]" $ pretty expr 2172#endif 2173 2174 prettyPrint (PatBracket _ pat) = group Expression "[p|" "|]" $ pretty pat 2175 2176 prettyPrint (TypeBracket _ ty) = group Expression "[t|" "|]" $ pretty ty 2177 2178 prettyPrint (DeclBracket _ decls) = 2179 group Expression "[d|" "|]" . aligned $ lined decls 2180 2181instance Pretty Splice where 2182 prettyPrint (IdSplice _ str) = do 2183 write "$" 2184 string str 2185 2186 prettyPrint (ParenSplice _ expr) = group Expression "$(" ")" $ pretty expr 2187 2188#if MIN_VERSION_haskell_src_exts(1,22,0) 2189 prettyPrint (TIdSplice _ str) = do 2190 write "$$" 2191 string str 2192 2193 prettyPrint (TParenSplice _ expr) = group Expression "$$(" ")" $ pretty expr 2194#endif 2195 2196instance Pretty ModulePragma where 2197 prettyPrint (LanguagePragma _ names) = 2198 prettyPragma "LANGUAGE" . inter comma $ map pretty names 2199 2200 prettyPrint (OptionsPragma _ mtool str) = prettyPragma name $ 2201 string (trim str) 2202 where 2203 name = case mtool of 2204 Just tool -> "OPTIONS_" `mappend` BS8.pack (HSE.prettyPrint tool) 2205 Nothing -> "OPTIONS" 2206 2207 trim = reverse . dropWhile (== ' ') . reverse . dropWhile (== ' ') 2208 2209 prettyPrint (AnnModulePragma _ annotation) = 2210 prettyPragma "ANN" $ pretty annotation 2211 2212instance Pretty Rule where 2213 prettyPrint (Rule _ str mactivation mrulevars expr expr') = do 2214 string (show str) 2215 space 2216 mayM_ mactivation $ withPostfix space pretty 2217 mapM_ prettyForall mrulevars 2218 pretty expr 2219 operator Expression "=" 2220 pretty expr' 2221 2222instance Pretty RuleVar where 2223 prettyPrint (RuleVar _ name) = pretty name 2224 2225 prettyPrint (TypedRuleVar _ name ty) = 2226 parens $ prettyTypesig Declaration [ name ] ty 2227 2228instance Pretty Activation where 2229 prettyPrint (ActiveFrom _ pass) = brackets $ int pass 2230 2231 prettyPrint (ActiveUntil _ pass) = brackets $ do 2232 write "~" 2233 int pass 2234 2235instance Pretty Annotation where 2236 prettyPrint (Ann _ name expr) = do 2237 pretty name 2238 space 2239 pretty expr 2240 2241 prettyPrint (TypeAnn _ name expr) = do 2242 write "type " 2243 pretty name 2244 space 2245 pretty expr 2246 2247 prettyPrint (ModuleAnn _ expr) = do 2248 write "module " 2249 pretty expr 2250 2251instance Pretty BooleanFormula where 2252 prettyPrint (VarFormula _ name) = pretty name 2253 2254 prettyPrint (AndFormula _ booleanformulas) = 2255 inter comma $ map pretty booleanformulas 2256 2257 prettyPrint (OrFormula _ booleanformulas) = 2258 inter (operator Expression "|") $ map pretty booleanformulas 2259 2260 prettyPrint (ParenFormula _ booleanformula) = parens $ pretty booleanformula 2261 2262-- Stick with HSE 2263#if MIN_VERSION_haskell_src_exts(1,20,0) 2264instance Pretty DerivStrategy 2265#endif 2266 2267instance Pretty DataOrNew 2268 2269instance Pretty BangType 2270 2271instance Pretty Unpackedness 2272 2273instance Pretty RPat 2274 2275instance Pretty ModuleName 2276 2277instance Pretty QName 2278 2279instance Pretty Name 2280 2281instance Pretty IPName 2282 2283instance Pretty XName 2284 2285instance Pretty Safety 2286 2287instance Pretty CallConv 2288 2289instance Pretty Overlap 2290 2291-- Helpers 2292newtype GuardedAlt l = GuardedAlt (GuardedRhs l) 2293 deriving ( Functor, Annotated ) 2294 2295instance Pretty GuardedAlt where 2296 prettyPrint (GuardedAlt (GuardedRhs _ stmts expr)) = cut $ do 2297 operatorSectionR Pattern "|" $ write "|" 2298 inter comma $ map pretty stmts 2299 operator Expression "->" 2300 pretty expr 2301 2302newtype GuardedAlts l = GuardedAlts (Rhs l) 2303 deriving ( Functor, Annotated ) 2304 2305instance Pretty GuardedAlts where 2306 prettyPrint (GuardedAlts (UnGuardedRhs _ expr)) = cut $ do 2307 operator Expression "->" 2308 pretty expr 2309 2310 prettyPrint (GuardedAlts (GuardedRhss _ guardedrhss)) = 2311 withIndent cfgIndentMultiIf $ linedOnside $ map GuardedAlt guardedrhss 2312 2313newtype CompactBinds l = CompactBinds (Binds l) 2314 deriving ( Functor, Annotated ) 2315 2316instance Pretty CompactBinds where 2317 prettyPrint (CompactBinds (BDecls _ decls)) = aligned $ 2318 withComputedTabStop stopRhs cfgAlignLetBinds measureDecl decls $ 2319 lined decls 2320 prettyPrint (CompactBinds (IPBinds _ ipbinds)) = 2321 aligned $ linedOnside ipbinds 2322 2323data MayAst a l = MayAst l (Maybe (a l)) 2324 2325instance Functor a => Functor (MayAst a) where 2326 fmap f (MayAst l x) = MayAst (f l) (fmap (fmap f) x) 2327 2328instance Annotated a => Annotated (MayAst a) where 2329 ann (MayAst l x) = maybe l ann x 2330 2331 amap f (MayAst l x) = MayAst (f l) (fmap (amap f) x) 2332 2333instance (Annotated a, Pretty a) => Pretty (MayAst a) where 2334 prettyPrint (MayAst _ x) = mapM_ pretty x 2335 2336{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} 2337