├── .gitignore ├── ChangeLog.md ├── LICENSE ├── Main.hs ├── PrettyPrint.hs ├── PrettyPrint └── Lifted.hs ├── README.md ├── Setup.hs ├── hsfmt.cabal ├── shell.nix ├── src └── HSFmt.hs ├── stack.yaml └── test └── Roundtrip.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | .stack-work/ 3 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for hsfmt 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, Oliver Charles 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Oliver Charles nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import System.Environment (getArgs) 4 | import System.Exit (die) 5 | 6 | import HSFmt (prettyPrintFile) 7 | 8 | main :: IO () 9 | main = do 10 | args <- getArgs 11 | case args of 12 | [] -> die "Please specify a filename." 13 | (f:_) -> prettyPrintFile f >>= putStrLn 14 | -------------------------------------------------------------------------------- /PrettyPrint.hs: -------------------------------------------------------------------------------- 1 | module PrettyPrint where 2 | 3 | import Prelude hiding ((<$>)) 4 | import Data.Text.Lazy (Text) 5 | import Data.String (IsString(..)) 6 | import qualified Data.Text.Lazy as T 7 | import Data.Monoid 8 | import Data.Text.Lazy.Builder (Builder, fromLazyText, singleton, toLazyText) 9 | import Data.Int (Int64) 10 | 11 | data Necessity = Essential | Cosmetic 12 | 13 | infixr 5 ,,<$>,<$$> 14 | infixr 6 <+>,<++> 15 | 16 | data Doc 17 | = Empty 18 | | Char !Char 19 | | Line 20 | | Text Int64 21 | Builder 22 | | Union Doc 23 | Doc 24 | | Cat Doc 25 | Doc 26 | | Spaces Int64 27 | | Column (Int64 -> Doc) 28 | | Nesting (Int64 -> Doc) 29 | | Nest !Int64 30 | Doc 31 | | Expanded Doc Doc 32 | 33 | instance Monoid Doc where 34 | mempty = Empty 35 | mappend = Cat 36 | 37 | instance IsString Doc where 38 | fromString = string . T.pack 39 | 40 | empty :: Doc 41 | empty = Empty 42 | 43 | line :: Doc 44 | line = Expanded Line space 45 | 46 | char :: Char -> Doc 47 | char '\n' = line 48 | char c = Char c 49 | 50 | text :: Text -> Doc 51 | text s 52 | | T.null s = Empty 53 | | otherwise = 54 | Text (T.length s) 55 | (fromLazyText s) 56 | 57 | string :: T.Text -> Doc 58 | string str = 59 | case T.uncons str of 60 | Nothing -> empty 61 | Just ('\n',str') -> line <> string str' 62 | _ -> 63 | case (T.span (/= '\n') str) of 64 | (xs,ys) -> text xs <> string ys 65 | 66 | data SimpleDoc 67 | = SEmpty 68 | | SChar Char 69 | SimpleDoc 70 | | SText !Int64 71 | Builder 72 | SimpleDoc 73 | | SLine !Int64 74 | SimpleDoc 75 | 76 | renderSmart :: Int64 -> Doc -> SimpleDoc 77 | renderSmart = renderFits nicestR 78 | 79 | data Docs 80 | = Nil 81 | | Cons {-# UNPACK #-} !Int64 82 | Doc 83 | Docs 84 | 85 | renderFits :: (Int64 -> Int64 -> Int64 -> SimpleDoc -> SimpleDoc -> SimpleDoc) 86 | -> Int64 87 | -> Doc 88 | -> SimpleDoc 89 | renderFits nicest w x = best 0 0 (Cons 0 x Nil) 90 | where 91 | -- best :: n = indentation of current line 92 | -- k = current column 93 | -- (ie. (k >= n) && (k - n == count of inserted characters) 94 | best _ _ Nil = SEmpty 95 | best n k (Cons i d ds) = 96 | case d of 97 | Empty -> best n k ds 98 | Char c -> 99 | let k' = k + 1 100 | in seq k' $ SChar c (best n k' ds) 101 | Text l s -> 102 | let k' = k + l 103 | in seq k' $ SText l s (best n k' ds) 104 | Line -> SLine i (best i i ds) 105 | Cat x y -> best n k (Cons i x (Cons i y ds)) 106 | Nest j x -> 107 | let i' = i + j 108 | in seq i' (best n k (Cons i' x ds)) 109 | Union x y -> 110 | nicest n 111 | k 112 | w 113 | (best n k $ Cons i x ds) 114 | (best n k $ Cons i y ds) 115 | Column f -> best n k (Cons i (f k) ds) 116 | Nesting f -> best n k (Cons i (f i) ds) 117 | Spaces l -> 118 | let k' = k + l 119 | in seq k' $ 120 | SText l 121 | (indentation l) 122 | (best n k' ds) 123 | Expanded l _ -> best n k (Cons i l ds) 124 | 125 | -- @nicestR@ compares the initial lines of the two documents that are nested at 126 | -- least as deep as the current nesting level. If the initial lines of both 127 | -- documents fit within the page width, the document that takes fewer lines is 128 | -- prefered, with preference toward the first. 129 | nicestR :: Int64 -> Int64 -> Int64 -> SimpleDoc -> SimpleDoc -> SimpleDoc 130 | nicestR n k p x' y = 131 | if fits (min n k) wid x' <= fits (min n k) wid y then x' else y 132 | where wid = p - k 133 | inf = 1.0/0 :: Double 134 | -- @fitsR@ has a little more lookahead: assuming that nesting roughly 135 | -- corresponds to syntactic depth, @fitsR@ checks that not only the 136 | -- current line fits, but the entire syntactic structure being formatted 137 | -- at this level of indentation fits. If we were to remove the second 138 | -- case for @SLine@, we would check that not only the current structure 139 | -- fits, but also the rest of the document, which would be slightly more 140 | -- intelligent but would have exponential runtime (and is prohibitively 141 | -- expensive in practice). 142 | -- m = minimum nesting level to fit in 143 | -- w = the width in which to fit the first line 144 | fits _ w _ | w < 0 = inf 145 | fits _ _ SEmpty = 0 146 | fits m w (SChar _ x) = fits m (w - 1) x 147 | fits m w (SText l _ x) = fits m (w - l) x 148 | fits m _ (SLine i x) | m < i = 1 + fits m (p - i) x 149 | | otherwise = 0 150 | 151 | displayB :: SimpleDoc -> Builder 152 | displayB SEmpty = mempty 153 | displayB (SChar c x) = c `consB` displayB x 154 | displayB (SText _ s x) = s <> displayB x 155 | displayB (SLine i x) = '\n' `consB` (indentation i <> displayB x) 156 | 157 | consB :: Char -> Builder -> Builder 158 | c `consB` b = singleton c `mappend` b 159 | 160 | indentation :: Int64 -> Builder 161 | indentation l = mconcat (replicate (fromIntegral l) (singleton ' ')) 162 | 163 | group :: Doc -> Doc 164 | group x = Union (flatten x) x 165 | 166 | expanded :: Doc -> Doc -> Doc 167 | expanded = Expanded 168 | 169 | flatten :: Doc -> Doc 170 | flatten (Expanded _ r) = flatten r 171 | flatten (Cat x y) = Cat (flatten x) (flatten y) 172 | flatten (Nest i x) = Nest i (flatten x) 173 | flatten Line = Empty 174 | flatten (Union x _) = flatten x 175 | flatten (Column f) = Column (flatten . f) 176 | flatten (Nesting f) = Nesting (flatten . f) 177 | flatten other = other 178 | 179 | displayT = toLazyText . displayB 180 | 181 | hang :: Int -> Doc -> Doc 182 | hang i d = align (nest i d) 183 | 184 | align :: Doc -> Doc 185 | align d = column (\k -> 186 | nesting (\i -> nest (k - i) d)) 187 | 188 | nest :: Int -> Doc -> Doc 189 | nest _ Empty = Empty 190 | nest i x = Nest (fromIntegral i) x 191 | 192 | column :: (Int -> Doc) -> Doc 193 | column f = Column (f . fromIntegral) 194 | 195 | nesting :: (Int -> Doc) -> Doc 196 | nesting f = Nesting (f . fromIntegral) 197 | 198 | (<+>) :: Doc -> Doc -> Doc 199 | Empty <+> y = y 200 | x <+> Empty = x 201 | x <+> y = x <> space <> y 202 | 203 | () :: Doc -> Doc -> Doc 204 | () = splitWithBreak False 205 | 206 | () :: Doc -> Doc -> Doc 207 | () = splitWithBreak True 208 | 209 | splitWithBreak :: Bool -> Doc -> Doc -> Doc 210 | splitWithBreak _ Empty b = b 211 | splitWithBreak _ a Empty = a 212 | splitWithBreak f a b = a <> group (mkLine f) <> b 213 | 214 | mkLine False = line 215 | mkLine True = linebreak 216 | 217 | linebreak = expanded line empty 218 | 219 | -- | The document @(x \<$\> y)@ concatenates document @x@ and @y@ with 220 | -- a 'line' in between. (infixr 5) 221 | (<$>) :: Doc -> Doc -> Doc 222 | (<$>) = splitWithLine False 223 | 224 | -- | The document @(x \<$$\> y)@ concatenates document @x@ and @y@ 225 | -- with a 'linebreak' in between. (infixr 5) 226 | (<$$>) :: Doc -> Doc -> Doc 227 | (<$$>) = splitWithLine True 228 | 229 | splitWithLine :: Bool -> Doc -> Doc -> Doc 230 | splitWithLine _ Empty b = b 231 | splitWithLine _ a Empty = a 232 | splitWithLine f a b = a <> mkLine f <> b 233 | 234 | vsep :: [Doc] -> Doc 235 | vsep = fold (<$>) 236 | 237 | fold :: (Doc -> Doc -> Doc) -> [Doc] -> Doc 238 | fold _ [] = empty 239 | fold f ds = foldr1 f ds 240 | 241 | equals = char '=' 242 | 243 | indent :: Int -> Doc -> Doc 244 | indent _ Empty = Empty 245 | indent i d = hang i (spaced i <> d) 246 | 247 | spaced :: Int -> Doc 248 | spaced l = Spaces l' 249 | where 250 | l' = fromIntegral l 251 | 252 | hsep :: [Doc] -> Doc 253 | hsep = fold (<+>) 254 | 255 | softbreak :: Doc 256 | softbreak = group linebreak 257 | 258 | -- | The document @spacebreak@ behaves like 'space' when rendered normally 259 | -- but like 'empty' when using 'renderCompact' or 'renderOneLine'. 260 | spacebreak :: Doc 261 | spacebreak = Spaces 1 262 | 263 | -- | Document @(squotes x)@ encloses document @x@ with single quotes 264 | -- \"'\". 265 | squotes :: Doc -> Doc 266 | squotes = enclose squote squote 267 | 268 | -- | Document @(dquotes x)@ encloses document @x@ with double quotes 269 | -- '\"'. 270 | dquotes :: Doc -> Doc 271 | dquotes = enclose dquote dquote 272 | 273 | -- | Document @(braces x)@ encloses document @x@ in braces, \"{\" and 274 | -- \"}\". 275 | braces :: Doc -> Doc 276 | braces = enclose lbrace rbrace 277 | 278 | -- | Document @(parens x)@ encloses document @x@ in parenthesis, \"(\" 279 | -- and \")\". 280 | parens :: Doc -> Doc 281 | parens = enclose lparen rparen 282 | 283 | -- | Document @(angles x)@ encloses document @x@ in angles, \"\<\" and 284 | -- \"\>\". 285 | angles :: Doc -> Doc 286 | angles = enclose langle rangle 287 | 288 | -- | Document @(brackets x)@ encloses document @x@ in square brackets, 289 | -- \"[\" and \"]\". 290 | brackets :: Doc -> Doc 291 | brackets = enclose lbracket rbracket 292 | 293 | -- | The document @(enclose l r x)@ encloses document @x@ between 294 | -- documents @l@ and @r@ using @(\<\>)@. 295 | -- 296 | -- > enclose l r x = l <> x <> r 297 | enclose :: Doc -> Doc -> Doc -> Doc 298 | enclose l r x = l <> x <> r 299 | 300 | -- | The document @lparen@ contains a left parenthesis, \"(\". 301 | lparen :: Doc 302 | lparen = char '(' 303 | 304 | -- | The document @rparen@ contains a right parenthesis, \")\". 305 | rparen :: Doc 306 | rparen = char ')' 307 | 308 | -- | The document @langle@ contains a left angle, \"\<\". 309 | langle :: Doc 310 | langle = char '<' 311 | 312 | -- | The document @rangle@ contains a right angle, \">\". 313 | rangle :: Doc 314 | rangle = char '>' 315 | 316 | -- | The document @lbrace@ contains a left brace, \"{\". 317 | lbrace :: Doc 318 | lbrace = char '{' 319 | 320 | -- | The document @rbrace@ contains a right brace, \"}\". 321 | rbrace :: Doc 322 | rbrace = char '}' 323 | 324 | -- | The document @lbracket@ contains a left square bracket, \"[\". 325 | lbracket :: Doc 326 | lbracket = char '[' 327 | 328 | -- | The document @rbracket@ contains a right square bracket, \"]\". 329 | rbracket :: Doc 330 | rbracket = char ']' 331 | 332 | -- | The document @squote@ contains a single quote, \"'\". 333 | squote :: Doc 334 | squote = char '\'' 335 | 336 | -- | The document @dquote@ contains a double quote, '\"'. 337 | dquote :: Doc 338 | dquote = char '"' 339 | 340 | -- | The document @semi@ contains a semi colon, \";\". 341 | semi :: Doc 342 | semi = char ';' 343 | 344 | -- | The document @colon@ contains a colon, \":\". 345 | colon :: Doc 346 | colon = char ':' 347 | 348 | -- | The document @comma@ contains a comma, \",\". 349 | comma :: Doc 350 | comma = char ',' 351 | 352 | -- | The document @space@ contains a single space, \" \". 353 | -- 354 | -- > x <+> y = x <> space <> y 355 | space :: Doc 356 | space = char ' ' 357 | 358 | -- | The document @dot@ contains a single dot, \".\". 359 | dot :: Doc 360 | dot = char '.' 361 | 362 | -- | The document @backslash@ contains a back slash, \"\\\". 363 | backslash :: Doc 364 | backslash = char '\\' 365 | 366 | ----------------------------------------------------------- 367 | -- list, tupled and semiBraces pretty print a list of 368 | -- documents either horizontally or vertically aligned. 369 | ----------------------------------------------------------- 370 | 371 | 372 | -- | The document @(list xs)@ comma separates the documents @xs@ and 373 | -- encloses them in square brackets. The documents are rendered 374 | -- horizontally if that fits the page. Otherwise they are aligned 375 | -- vertically. All comma separators are put in front of the 376 | -- elements. 377 | list :: [Doc] -> Doc 378 | list = encloseSep lbracket rbracket comma 379 | 380 | -- | The document @(tupled xs)@ comma separates the documents @xs@ and 381 | -- encloses them in parenthesis. The documents are rendered 382 | -- horizontally if that fits the page. Otherwise they are aligned 383 | -- vertically. All comma separators are put in front of the 384 | -- elements. 385 | tupled :: [Doc] -> Doc 386 | tupled = encloseSep lparen rparen comma 387 | 388 | -- | The document @(semiBraces xs)@ separates the documents @xs@ with 389 | -- semi colons and encloses them in braces. The documents are 390 | -- rendered horizontally if that fits the page. Otherwise they are 391 | -- aligned vertically. All semi colons are put in front of the 392 | -- elements. 393 | semiBraces :: [Doc] -> Doc 394 | semiBraces = encloseSep lbrace rbrace semi 395 | 396 | -- | The document @(encloseSep l r sep xs)@ concatenates the documents 397 | -- @xs@ separated by @sep@ and encloses the resulting document by 398 | -- @l@ and @r@. The documents are rendered horizontally if that fits 399 | -- the page. Otherwise they are aligned vertically. All separators 400 | -- are put in front of the elements. For example, the combinator 401 | -- 'list' can be defined with @encloseSep@: 402 | -- 403 | -- > list xs = encloseSep lbracket rbracket comma xs 404 | -- > test = text "list" <+> (list (map int [10,200,3000])) 405 | -- 406 | -- Which is laid out with a page width of 20 as: 407 | -- 408 | -- @ 409 | -- list [10,200,3000] 410 | -- @ 411 | -- 412 | -- But when the page width is 15, it is laid out as: 413 | -- 414 | -- @ 415 | -- list [10 416 | -- ,200 417 | -- ,3000] 418 | -- @ 419 | encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc 420 | encloseSep left right sp ds 421 | = case ds of 422 | [] -> left <> right 423 | [d] -> left <> d <> right 424 | _ -> align (cat (zipWith (<>) (left : repeat sp) ds) <> right) 425 | 426 | ----------------------------------------------------------- 427 | -- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn] 428 | ----------------------------------------------------------- 429 | 430 | 431 | -- | @(punctuate p xs)@ concatenates all documents in @xs@ with 432 | -- document @p@ except for the last document. 433 | -- 434 | -- > someText = map text ["words","in","a","tuple"] 435 | -- > test = parens (align (cat (punctuate comma someText))) 436 | -- 437 | -- This is laid out on a page width of 20 as: 438 | -- 439 | -- @ 440 | -- (words,in,a,tuple) 441 | -- @ 442 | -- 443 | -- But when the page width is 15, it is laid out as: 444 | -- 445 | -- @ 446 | -- (words, 447 | -- in, 448 | -- a, 449 | -- tuple) 450 | -- @ 451 | -- 452 | -- (If you want put the commas in front of their elements instead of 453 | -- at the end, you should use 'tupled' or, in general, 'encloseSep'.) 454 | punctuate :: Doc -> [Doc] -> [Doc] 455 | punctuate _ [] = [] 456 | punctuate _ [d] = [d] 457 | punctuate p (d:ds) = (d <> p) : punctuate p ds 458 | 459 | -- | The document @(cat xs)@ concatenates all documents @xs@ either 460 | -- horizontally with @(\<\>)@, if it fits the page, or vertically 461 | -- with @(\<$$\>)@. 462 | -- 463 | -- > cat xs = group (vcat xs) 464 | cat :: [Doc] -> Doc 465 | cat = group . vcat 466 | 467 | vcat :: [Doc] -> Doc 468 | vcat = fold (<$$>) 469 | 470 | -- | The document @(sep xs)@ concatenates all documents @xs@ either 471 | -- horizontally with @(\<+\>)@, if it fits the page, or vertically 472 | -- with @(\<$\>)@. 473 | -- 474 | -- > sep xs = group (vsep xs) 475 | sep :: [Doc] -> Doc 476 | sep = group . vsep 477 | 478 | -- | The document @(fillSep xs)@ concatenates documents @xs@ 479 | -- horizontally with @(\<+\>)@ as long as its fits the page, then 480 | -- inserts a @line@ and continues doing that for all documents in 481 | -- @xs@. 482 | -- 483 | -- > fillSep xs = foldr () empty xs 484 | fillSep :: [Doc] -> Doc 485 | fillSep = fold () 486 | 487 | -- | The document @(fillCat xs)@ concatenates documents @xs@ 488 | -- horizontally with @(\<\>)@ as long as its fits the page, then 489 | -- inserts a @linebreak@ and continues doing that for all documents 490 | -- in @xs@. 491 | -- 492 | -- > fillCat xs = foldr () empty xs 493 | fillCat :: [Doc] -> Doc 494 | fillCat = fold () 495 | 496 | -- | The document @(hcat xs)@ concatenates all documents @xs@ 497 | -- horizontally with @(\<\>)@. 498 | hcat :: [Doc] -> Doc 499 | hcat = fold (<>) 500 | 501 | -- | The document @(x \<++\> y)@ concatenates document @x@ and @y@ with 502 | -- a 'spacebreak' in between. (infixr 6) 503 | (<++>) :: Doc -> Doc -> Doc 504 | Empty <++> y = y 505 | x <++> Empty = x 506 | x <++> y = x <> spacebreak <> y 507 | 508 | 509 | -- | The document @softline@ behaves like 'space' if the resulting 510 | -- output fits the page, otherwise it behaves like 'line'. 511 | -- 512 | -- > softline = group line 513 | softline :: Doc 514 | softline = group line 515 | 516 | -- | The document @(integer i)@ shows the literal integer @i@ using 517 | -- 'text'. 518 | integer :: Integer -> Doc 519 | integer i = text' i 520 | 521 | text' :: (Show a) => a -> Doc 522 | text' = text . T.pack . show 523 | -------------------------------------------------------------------------------- /PrettyPrint/Lifted.hs: -------------------------------------------------------------------------------- 1 | module PrettyPrint.Lifted (module PrettyPrint.Lifted, Doc, displayT, renderSmart) where 2 | 3 | import qualified Data.Monoid as Monoid 4 | import Control.Applicative 5 | import qualified Control.Applicative as Ap 6 | import Data.Text.Lazy (Text) 7 | import PrettyPrint (Doc, displayT, renderSmart) 8 | import qualified PrettyPrint as PP 9 | 10 | 11 | infixr 5 ,,<$>,<$$> 12 | infixr 6 <+>,<++> 13 | 14 | ----------------------------------------------------------- 15 | 16 | -- | The document @(list xs)@ comma separates the documents @xs@ and 17 | -- encloses them in square brackets. The documents are rendered 18 | -- horizontally if that fits the page. Otherwise they are aligned 19 | -- vertically. All comma separators are put in front of the 20 | -- elements. 21 | list :: (Functor m) => m [Doc] -> m Doc 22 | list = fmap PP.list 23 | 24 | -- | The document @(tupled xs)@ comma separates the documents @xs@ and 25 | -- encloses them in parenthesis. The documents are rendered 26 | -- horizontally if that fits the page. Otherwise they are aligned 27 | -- vertically. All comma separators are put in front of the 28 | -- elements. 29 | tupled :: (Functor m) => m [Doc] -> m Doc 30 | tupled = fmap PP.tupled 31 | 32 | -- | The document @(semiBraces xs)@ separates the documents @xs@ with 33 | -- semi colons and encloses them in braces. The documents are 34 | -- rendered horizontally if that fits the page. Otherwise they are 35 | -- aligned vertically. All semi colons are put in front of the 36 | -- elements. 37 | semiBraces :: (Functor m) => m [Doc] -> m Doc 38 | semiBraces = fmap PP.semiBraces 39 | 40 | -- | The document @(encloseSep l r sep xs)@ concatenates the documents 41 | -- @xs@ separated by @sep@ and encloses the resulting document by 42 | -- @l@ and @r@. The documents are rendered horizontally if that fits 43 | -- the page. Otherwise they are aligned vertically. All separators 44 | -- are put in front of the elements. For example, the combinator 45 | -- 'list' can be defined with @encloseSep@: 46 | -- 47 | -- > list xs = encloseSep lbracket rbracket comma xs 48 | -- > test = text "list" <+> (list (map int [10,200,3000])) 49 | -- 50 | -- Which is laid out with a page width of 20 as: 51 | -- 52 | -- @ 53 | -- list [10,200,3000] 54 | -- @ 55 | -- 56 | -- But when the page width is 15, it is laid out as: 57 | -- 58 | -- @ 59 | -- list [10 60 | -- ,200 61 | -- ,3000] 62 | -- @ 63 | encloseSep :: (Applicative m) => m Doc -> m Doc -> m Doc -> m [Doc] -> m Doc 64 | encloseSep = liftA4 PP.encloseSep 65 | 66 | -- | @(punctuate p xs)@ concatenates all documents in @xs@ with 67 | -- document @p@ except for the last document. 68 | -- 69 | -- > someText = map text ["words","in","a","tuple"] 70 | -- > test = parens (align (cat (punctuate comma someText))) 71 | -- 72 | -- This is laid out on a page width of 20 as: 73 | -- 74 | -- @ 75 | -- (words,in,a,tuple) 76 | -- @ 77 | -- 78 | -- But when the page width is 15, it is laid out as: 79 | -- 80 | -- @ 81 | -- (words, 82 | -- in, 83 | -- a, 84 | -- tuple) 85 | -- @ 86 | -- 87 | -- (If you want put the commas in front of their elements instead of 88 | -- at the end, you should use 'tupled' or, in general, 'encloseSep'.) 89 | punctuate :: (Monad m) => m Doc -> m [Doc] -> m [Doc] 90 | punctuate = liftA2 PP.punctuate 91 | 92 | -- | The document @(sep xs)@ concatenates all documents @xs@ either 93 | -- horizontally with @(\<+\>)@, if it fits the page, or vertically 94 | -- with @(\<$\>)@. 95 | -- 96 | -- > sep xs = group (vsep xs) 97 | sep :: (Monad m) => m [Doc] -> m Doc 98 | sep = fmap PP.sep 99 | 100 | -- | The document @(fillSep xs)@ concatenates documents @xs@ 101 | -- horizontally with @(\<+\>)@ as long as its fits the page, then 102 | -- inserts a @line@ and continues doing that for all documents in 103 | -- @xs@. 104 | -- 105 | -- > fillSep xs = foldr () empty xs 106 | fillSep :: (Monad m) => m [Doc] -> m Doc 107 | fillSep = fmap PP.fillSep 108 | 109 | -- | The document @(hsep xs)@ concatenates all documents @xs@ 110 | -- horizontally with @(\<+\>)@. 111 | hsep :: (Monad m) => m [Doc] -> m Doc 112 | hsep = fmap PP.hsep 113 | 114 | -- | The document @(vsep xs)@ concatenates all documents @xs@ 115 | -- vertically with @(\<$\>)@. If a 'group' undoes the line breaks 116 | -- inserted by @vsep@, all documents are separated with a space. 117 | -- 118 | -- > someText = map text (words ("text to lay out")) 119 | -- > 120 | -- > test = text "some" <+> vsep someText 121 | -- 122 | -- This is laid out as: 123 | -- 124 | -- @ 125 | -- some text 126 | -- to 127 | -- lay 128 | -- out 129 | -- @ 130 | -- 131 | -- The 'align' combinator can be used to align the documents under 132 | -- their first element 133 | -- 134 | -- > test = text "some" <+> align (vsep someText) 135 | -- 136 | -- Which is printed as: 137 | -- 138 | -- @ 139 | -- some text 140 | -- to 141 | -- lay 142 | -- out 143 | -- @ 144 | vsep :: (Monad m) => m [Doc] -> m Doc 145 | vsep = fmap PP.vsep 146 | 147 | -- | The document @(cat xs)@ concatenates all documents @xs@ either 148 | -- horizontally with @(\<\>)@, if it fits the page, or vertically 149 | -- with @(\<$$\>)@. 150 | -- 151 | -- > cat xs = group (vcat xs) 152 | cat :: (Monad m) => m [Doc] -> m Doc 153 | cat = fmap PP.cat 154 | 155 | -- | The document @(fillCat xs)@ concatenates documents @xs@ 156 | -- horizontally with @(\<\>)@ as long as its fits the page, then 157 | -- inserts a @linebreak@ and continues doing that for all documents 158 | -- in @xs@. 159 | -- 160 | -- > fillCat xs = foldr () empty xs 161 | fillCat :: (Monad m) => m [Doc] -> m Doc 162 | fillCat = fmap PP.fillCat 163 | 164 | -- | The document @(hcat xs)@ concatenates all documents @xs@ 165 | -- horizontally with @(\<\>)@. 166 | hcat :: (Monad m) => m [Doc] -> m Doc 167 | hcat = fmap PP.hcat 168 | 169 | -- | The document @(vcat xs)@ concatenates all documents @xs@ 170 | -- vertically with @(\<$$\>)@. If a 'group' undoes the line breaks 171 | -- inserted by @vcat@, all documents are directly concatenated. 172 | vcat :: (Monad m) => m [Doc] -> m Doc 173 | vcat = fmap PP.vcat 174 | 175 | -- | The document @(x \<\> y)@ concatenates document @x@ and document 176 | -- @y@. It is an associative operation having 'empty' as a left and 177 | -- right unit. (infixr 6) 178 | (<>) :: (Monad m) => m Doc -> m Doc -> m Doc 179 | (<>) = liftA2 (Monoid.<>) 180 | 181 | -- | The document @(x \<+\> y)@ concatenates document @x@ and @y@ with 182 | -- a 'space' in between. (infixr 6) 183 | (<+>) :: (Monad m) => m Doc -> m Doc -> m Doc 184 | (<+>) = liftA2 (PP.<+>) 185 | 186 | -- | The document @(x \<++\> y)@ concatenates document @x@ and @y@ with 187 | -- a 'spacebreak' in between. (infixr 6) 188 | (<++>) :: (Monad m) => m Doc -> m Doc -> m Doc 189 | (<++>) = liftA2 (PP.<++>) 190 | 191 | -- | The document @(x \<\/\> y)@ concatenates document @x@ and @y@ 192 | -- with a 'softline' in between. This effectively puts @x@ and @y@ 193 | -- either next to each other (with a @space@ in between) or 194 | -- underneath each other. (infixr 5) 195 | () :: (Monad m) => m Doc -> m Doc -> m Doc 196 | () = liftA2 (PP.) 197 | 198 | -- | The document @(x \<\/\/\> y)@ concatenates document @x@ and @y@ 199 | -- with a 'softbreak' in between. This effectively puts @x@ and @y@ 200 | -- either right next to each other or underneath each other. (infixr 201 | -- 5) 202 | () :: (Monad m) => m Doc -> m Doc -> m Doc 203 | () = liftA2 (PP.) 204 | 205 | -- | The document @(x \<$\> y)@ concatenates document @x@ and @y@ with 206 | -- a 'line' in between. (infixr 5) 207 | (<$>) :: (Monad m) => m Doc -> m Doc -> m Doc 208 | (<$>) = liftA2 (PP.<$>) 209 | 210 | -- | The document @(x \<$$\> y)@ concatenates document @x@ and @y@ 211 | -- with a 'linebreak' in between. (infixr 5) 212 | (<$$>) :: (Monad m) => m Doc -> m Doc -> m Doc 213 | (<$$>) = liftA2 (PP.<$$>) 214 | 215 | -- | The document @softline@ behaves like 'space' if the resulting 216 | -- output fits the page, otherwise it behaves like 'line'. 217 | softline :: (Monad m) => m Doc 218 | softline = return PP.softline 219 | 220 | -- | The document @softbreak@ behaves like 'empty' if the resulting 221 | -- output fits the page, otherwise it behaves like 'line'. 222 | softbreak :: (Monad m) => m Doc 223 | softbreak = return PP.softbreak 224 | 225 | -- | The document @spacebreak@ behaves like 'space' when rendered normally 226 | -- but like 'empty' when using 'renderCompact' or 'renderOneLine'. 227 | spacebreak :: (Monad m) => m Doc 228 | spacebreak = return PP.spacebreak 229 | 230 | -- | Document @(squotes x)@ encloses document @x@ with single quotes 231 | -- \"'\". 232 | squotes :: (Monad m) => m Doc -> m Doc 233 | squotes = fmap PP.squotes 234 | 235 | -- | Document @(dquotes x)@ encloses document @x@ with double quotes 236 | -- '\"'. 237 | dquotes :: (Monad m) => m Doc -> m Doc 238 | dquotes = fmap PP.dquotes 239 | 240 | -- | Document @(braces x)@ encloses document @x@ in braces, \"{\" and 241 | -- \"}\". 242 | braces :: (Monad m) => m Doc -> m Doc 243 | braces = fmap PP.braces 244 | 245 | -- | Document @(parens x)@ encloses document @x@ in parenthesis, \"(\" 246 | -- and \")\". 247 | parens :: (Monad m) => m Doc -> m Doc 248 | parens = fmap PP.parens 249 | 250 | -- | Document @(angles x)@ encloses document @x@ in angles, \"\<\" and 251 | -- \"\>\". 252 | angles :: (Monad m) => m Doc -> m Doc 253 | angles = fmap PP.angles 254 | 255 | -- | Document @(brackets x)@ encloses document @x@ in square brackets, 256 | -- \"[\" and \"]\". 257 | brackets :: (Monad m) => m Doc -> m Doc 258 | brackets = fmap PP.brackets 259 | 260 | -- | The document @(enclose l r x)@ encloses document @x@ between 261 | -- documents @l@ and @r@ using @(\<\>)@. 262 | -- 263 | -- > enclose l r x = l <> x <> r 264 | enclose :: (Monad m) => m Doc -> m Doc -> m Doc -> m Doc 265 | enclose = liftA3 PP.enclose 266 | 267 | -- | The document @lparen@ contains a left parenthesis, \"(\". 268 | lparen :: (Monad m) => m Doc 269 | lparen = return PP.lparen 270 | 271 | -- | The document @rparen@ contains a right parenthesis, \")\". 272 | rparen :: (Monad m) => m Doc 273 | rparen = return PP.rparen 274 | 275 | -- | The document @langle@ contains a left angle, \"\<\". 276 | langle :: (Monad m) => m Doc 277 | langle = return PP.langle 278 | 279 | -- | The document @rangle@ contains a right angle, \">\". 280 | rangle :: (Monad m) => m Doc 281 | rangle = return PP.rangle 282 | 283 | -- | The document @lbrace@ contains a left brace, \"{\". 284 | lbrace :: (Monad m) => m Doc 285 | lbrace = return PP.lbrace 286 | 287 | -- | The document @rbrace@ contains a right brace, \"}\". 288 | rbrace :: (Monad m) => m Doc 289 | rbrace = return PP.rbrace 290 | 291 | -- | The document @lbracket@ contains a left square bracket, \"[\". 292 | lbracket :: (Monad m) => m Doc 293 | lbracket = return PP.lbracket 294 | 295 | -- | The document @rbracket@ contains a right square bracket, \"]\". 296 | rbracket :: (Monad m) => m Doc 297 | rbracket = return PP.rbracket 298 | 299 | -- | The document @squote@ contains a single quote, \"'\". 300 | squote :: (Monad m) => m Doc 301 | squote = return PP.squote 302 | 303 | -- | The document @dquote@ contains a double quote, '\"'. 304 | dquote :: (Monad m) => m Doc 305 | dquote = return PP.dquote 306 | 307 | -- | The document @semi@ contains a semi colon, \";\". 308 | semi :: (Monad m) => m Doc 309 | semi = return PP.semi 310 | 311 | -- | The document @colon@ contains a colon, \":\". 312 | colon :: (Monad m) => m Doc 313 | colon = return PP.colon 314 | 315 | -- | The document @comma@ contains a comma, \",\". 316 | comma :: (Monad m) => m Doc 317 | comma = return PP.comma 318 | 319 | -- | The document @space@ contains a single space, \" \". 320 | -- 321 | -- > x <+> y = x <> space <> y 322 | space :: (Monad m) => m Doc 323 | space = return PP.space 324 | 325 | -- | The document @dot@ contains a single dot, \".\". 326 | dot :: (Monad m) => m Doc 327 | dot = return PP.dot 328 | 329 | -- | The document @backslash@ contains a back slash, \"\\\". 330 | backslash :: (Monad m) => m Doc 331 | backslash = return PP.backslash 332 | 333 | -- | The document @equals@ contains an equal sign, \"=\". 334 | equals :: (Monad m) => m Doc 335 | equals = return PP.equals 336 | 337 | liftA4 f a b c d = f Ap.<$> a <*> b <*> c <*> d 338 | 339 | 340 | -- | The @group@ combinator is used to specify alternative 341 | -- layouts. The document @(group x)@ undoes all line breaks in 342 | -- document @x@. The resulting line is added to the current line if 343 | -- that fits the page. Otherwise, the document @x@ is rendered 344 | -- without any changes. 345 | group :: (Functor m) => m Doc -> m Doc 346 | group = fmap PP.group 347 | 348 | -- | The document @(string s)@ concatenates all characters in @s@ 349 | -- using @line@ for newline characters and @char@ for all other 350 | -- characters. It is used instead of 'text' whenever the text 351 | -- contains newline characters. 352 | string :: (Applicative m) => Text -> m Doc 353 | string = pure . PP.string 354 | 355 | -- | The document @(indent i x)@ indents document @x@ with @i@ spaces. 356 | -- 357 | -- > test = indent 4 (fillSep (map text 358 | -- > (words "the indent combinator indents these words !"))) 359 | -- 360 | -- Which lays out with a page width of 20 as: 361 | -- 362 | -- @ 363 | -- the indent 364 | -- combinator 365 | -- indents these 366 | -- words ! 367 | -- @ 368 | indent :: (Functor m) => Int -> m Doc -> m Doc 369 | indent = fmap . PP.indent 370 | 371 | -- | The hang combinator implements hanging indentation. The document 372 | -- @(hang i x)@ renders document @x@ with a nesting level set to the 373 | -- current column plus @i@. The following example uses hanging 374 | -- indentation for some text: 375 | -- 376 | -- > test = hang 4 (fillSep (map text 377 | -- > (words "the hang combinator indents these words !"))) 378 | -- 379 | -- Which lays out on a page with a width of 20 characters as: 380 | -- 381 | -- @ 382 | -- the hang combinator 383 | -- indents these 384 | -- words ! 385 | -- @ 386 | -- 387 | -- The @hang@ combinator is implemented as: 388 | -- 389 | -- > hang i x = align (nest i x) 390 | hang :: (Functor m) => Int -> m Doc -> m Doc 391 | hang = fmap . PP.hang 392 | 393 | -- | The empty document is, indeed, empty. Although @empty@ has no 394 | -- content, it does have a \'height\' of 1 and behaves exactly like 395 | -- @(text \"\")@ (and is therefore not a unit of @\<$\>@). 396 | empty :: (Monad m) => m Doc 397 | empty = return PP.empty 398 | 399 | -- | The document @(char c)@ contains the literal character @c@. The 400 | -- character shouldn't be a newline (@'\n'@), the function 'line' 401 | -- should be used for line breaks. 402 | char :: (Monad m) => Char -> m Doc 403 | char = return . PP.char 404 | 405 | -- | The document @(text s)@ contains the literal string @s@. The 406 | -- string shouldn't contain any newline (@'\n'@) characters. If the 407 | -- string contains newline characters, the function 'string' should 408 | -- be used. 409 | text :: (Monad m) => Text -> m Doc 410 | text = return . PP.text 411 | 412 | -- | The @line@ document advances to the next line and indents to the 413 | -- current nesting level. Document @line@ behaves like @(text \" 414 | -- \")@ if the line break is undone by 'group' or if rendered with 415 | -- 'renderOneLine'. 416 | line :: (Monad m) => m Doc 417 | line = return PP.line 418 | 419 | -- | The @linebreak@ document advances to the next line and indents to 420 | -- the current nesting level. Document @linebreak@ behaves like 421 | -- 'empty' if the line break is undone by 'group'. 422 | linebreak :: (Monad m) => m Doc 423 | linebreak = return PP.linebreak 424 | 425 | -- | The document @(nest i x)@ renders document @x@ with the current 426 | -- indentation level increased by @i@ (See also 'hang', 'align' and 427 | -- 'indent'). 428 | -- 429 | -- > nest 2 (text "hello" <$> text "world") <$> text "!" 430 | -- 431 | -- outputs as: 432 | -- 433 | -- @ 434 | -- hello 435 | -- world 436 | -- ! 437 | -- @ 438 | nest :: (Monad m) => Int -> m Doc -> m Doc 439 | nest = fmap . PP.nest 440 | 441 | -- | The document @(align x)@ renders document @x@ with the nesting 442 | -- level set to the current column. It is used for example to 443 | -- implement 'hang'. 444 | -- 445 | -- As an example, we will put a document right above another one, 446 | -- regardless of the current nesting level: 447 | -- 448 | -- > x $$ y = align (x <$> y) 449 | -- 450 | -- > test = text "hi" <+> (text "nice" $$ text "world") 451 | -- 452 | -- which will be laid out as: 453 | -- 454 | -- @ 455 | -- hi nice 456 | -- world 457 | -- @ 458 | align :: (Monad m) => m Doc -> m Doc 459 | align = fmap PP.align 460 | 461 | -- | The document @(integer i)@ shows the literal integer @i@ using 462 | -- 'text'. 463 | integer :: (Monad m) => Integer -> m Doc 464 | integer = return . PP.integer 465 | 466 | expanded :: Applicative m => m Doc -> m Doc -> m Doc 467 | expanded = liftA2 PP.expanded 468 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # hsfmt 2 | A Haskell code formatter using prettyprinter and the GHC API 3 | 4 | This project is not complete. Don't tell me you don't like how it looks, because neither do I. We'll get there. However, if you want to send a pull request that changes formatting, by all means go ahead! Just make sure the tests all pass :) 5 | 6 | 7 | ## Usage 8 | 9 | Right now, `hs-fmt` just formats a single file, and prints out the result to `STDOUT`. 10 | 11 | 12 | $ stack build 13 | $ stack exec -- hs-fmt FILENAME 14 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /hsfmt.cabal: -------------------------------------------------------------------------------- 1 | -- Initial hsfmt.cabal generated by cabal init. For further documentation, 2 | -- see http://haskell.org/cabal/users-guide/ 3 | 4 | name: hsfmt 5 | version: 0.1.0.0 6 | synopsis: A Haskell source code formatter 7 | -- description: 8 | homepage: https://github.com/ocharles/hsfmt 9 | license: BSD3 10 | license-file: LICENSE 11 | author: Oliver Charles 12 | maintainer: ollie@ocharles.org.uk 13 | -- copyright: 14 | category: Development 15 | build-type: Simple 16 | extra-source-files: ChangeLog.md 17 | cabal-version: >=1.18 18 | 19 | library 20 | default-extensions: RecordWildCards 21 | , NamedFieldPuns 22 | , OverloadedStrings 23 | , FlexibleContexts 24 | , UndecidableInstances 25 | build-depends: base >=4.9 && <4.10 26 | , containers 27 | , ghc 28 | , ghc-exactprint >=0.5 && <0.6 29 | , ghc-paths 30 | , hedgehog 31 | , mtl 32 | , prettyprinter 33 | , template-haskell >= 2.11.1.0 34 | , text >=1.2 && <1.3 35 | , transformers >=0.5 && <0.6 36 | default-language: Haskell2010 37 | hs-source-dirs: src 38 | exposed-modules: HSFmt 39 | 40 | executable hs-fmt 41 | main-is: Main.hs 42 | build-depends: base, hsfmt 43 | 44 | test-suite properties 45 | type: exitcode-stdio-1.0 46 | build-depends: Diff 47 | , base 48 | , ghc 49 | , ghc-exactprint 50 | , hedgehog 51 | , hsfmt 52 | , prettyprinter 53 | , template-haskell >= 2.11.1.0 54 | main-is: Roundtrip.hs 55 | hs-source-dirs: test 56 | default-language: Haskell2010 57 | other-extensions: TemplateHaskell 58 | ghc-options: -threaded 59 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import {} }: 2 | 3 | let 4 | 5 | inherit (nixpkgs) pkgs; 6 | 7 | f = { mkDerivation, base, ghc-exactprint, stdenv, text 8 | , transformers, prettyprinter, mtl, hedgehog 9 | }: 10 | mkDerivation { 11 | pname = "hsfmt"; 12 | version = "0.1.0.0"; 13 | src = ./.; 14 | isLibrary = false; 15 | isExecutable = true; 16 | executableHaskellDepends = [ 17 | base ghc-exactprint mtl text transformers prettyprinter 18 | hedgehog 19 | ]; 20 | homepage = "https://github.com/ocharles/hsfmt"; 21 | description = "A Haskell source code formatter"; 22 | license = stdenv.lib.licenses.bsd3; 23 | }; 24 | 25 | haskellPackages = pkgs.haskellPackages.override { 26 | overrides = self: super: { 27 | }; 28 | }; 29 | 30 | drv = haskellPackages.callPackage f {}; 31 | 32 | in 33 | 34 | if pkgs.lib.inNixShell then drv.env else drv 35 | -------------------------------------------------------------------------------- /src/HSFmt.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE TypeSynonymInstances #-} 3 | module HSFmt (prettyPrintFile) where 4 | 5 | import Control.Monad 6 | import qualified Data.Map as Map 7 | import Data.Char 8 | import BasicTypes (fl_text, InlinePragma(..), WarningTxt(..), sl_st, Fixity(..)) 9 | import Data.Maybe 10 | import Data.Text.Prettyprint.Doc hiding (list, tupled) 11 | import Data.Text.Prettyprint.Doc.Render.String 12 | import Data.Foldable (toList) 13 | import FastString 14 | import GHC hiding (parseModule) 15 | import Language.Haskell.GHC.ExactPrint ( Annotation(..) 16 | , Anns 17 | , AnnKey(..) 18 | , parseModule 19 | ) 20 | import Language.Haskell.GHC.ExactPrint.Types ( annGetConstr 21 | , KeywordId(AnnComment) 22 | , Comment(..) 23 | ) 24 | import Module 25 | import qualified Name as GHC 26 | import OccName 27 | import RdrName 28 | 29 | 30 | 31 | groupDecls :: Eq id => [LHsDecl id] -> [[LHsDecl id]] 32 | groupDecls [] = 33 | [] 34 | groupDecls (x@(L _ (SigD (TypeSig names _))) : xs) = 35 | let 36 | (binds, rest) = 37 | splitNames (fmap unLoc names) xs 38 | 39 | in 40 | (x : binds) : groupDecls rest 41 | groupDecls (x : xs) = 42 | [x] : groupDecls xs 43 | 44 | 45 | splitNames :: Eq id => [id] -> [LHsDecl id] -> ([LHsDecl id], [LHsDecl id]) 46 | splitNames names [] = 47 | ([], []) 48 | splitNames names (x : xs) = 49 | case unLoc x of 50 | ValD (FunBind {..}) -> 51 | if unLoc fun_id `elem` names then 52 | let 53 | (binds, rest) = 54 | splitNames names xs 55 | 56 | in 57 | (x : binds, rest) 58 | else 59 | ([], x : xs) 60 | 61 | _ -> 62 | ([], x : xs) 63 | 64 | 65 | nullWhitespace :: String -> String 66 | nullWhitespace s = 67 | fromMaybe s (go s) 68 | 69 | where 70 | 71 | go [] = 72 | Just [] 73 | go (a : as) 74 | | isSpace a = go as 75 | | otherwise = Nothing 76 | 77 | 78 | prettyPrintFile :: FilePath -> IO String 79 | prettyPrintFile path = 80 | do 81 | out <- 82 | parseModule path 83 | 84 | case out of 85 | Left e -> 86 | error (show e) 87 | 88 | Right (anns, parsed) -> 89 | return 90 | $ concat 91 | [ case parsed of 92 | L srcSpan a -> 93 | case AnnKey srcSpan (annGetConstr a) `Map.lookup` anns of 94 | Just ann -> 95 | unlines $ concatMap yieldComment (annsDP ann) 96 | 97 | Nothing -> 98 | mzero 99 | , unlines $ map nullWhitespace $ lines $ renderString 100 | $ layoutPretty 101 | defaultLayoutOptions 102 | { layoutPageWidth = AvailablePerLine 80 1 } 103 | (((pretty parsed :: Doc ()))) 104 | ] 105 | 106 | where 107 | 108 | yieldComment ((AnnComment (Comment c _ _)), _) = 109 | return c 110 | yieldComment _ = 111 | mzero 112 | 113 | 114 | instance Pretty ParsedSource where 115 | pretty (L _loc parsedSource) = 116 | pretty parsedSource 117 | 118 | 119 | instance Pretty (HsModule RdrName) where 120 | pretty HsModule {hsmodName, hsmodExports, hsmodImports, hsmodDecls} = 121 | concatWith 122 | (\x y -> 123 | x <> hardline <> hardline <> hardline <> hardline <> y) 124 | [ concatWith 125 | (\x y -> 126 | x <> hardline <> hardline <> y) 127 | $ catMaybes 128 | [ fmap 129 | (\moduleName -> 130 | hsep 131 | $ catMaybes 132 | [ Just "module" 133 | , Just $ pretty moduleName 134 | , fmap pretty hsmodExports 135 | , Just "where" 136 | ]) 137 | hsmodName 138 | , case hsmodImports of 139 | [] -> 140 | Nothing 141 | 142 | _ -> 143 | Just (pretty hsmodImports) 144 | ] 145 | , pretty hsmodDecls 146 | ] 147 | 148 | 149 | instance Pretty (Located (HsDecl RdrName)) where 150 | pretty (L _loc decl) = 151 | pretty decl 152 | 153 | prettyList = 154 | concatWith 155 | (\x y -> 156 | x <> hardline <> hardline <> hardline <> y) 157 | . map (hardVsep . map pretty) 158 | . groupDecls 159 | 160 | 161 | instance Pretty (HsDecl RdrName) where 162 | pretty (TyClD a) = 163 | pretty a 164 | pretty (InstD inst) = 165 | pretty inst 166 | pretty (ValD b) = 167 | prettyBind equals b 168 | pretty (SigD a) = 169 | pretty a 170 | pretty (SpliceD a) = 171 | pretty a 172 | pretty (AnnD ann) = 173 | pretty ann 174 | pretty (DerivD d) = 175 | pretty d 176 | pretty (WarningD w) = 177 | pretty w 178 | 179 | 180 | instance Pretty (WarnDecls RdrName) where 181 | pretty (Warnings {wd_src, wd_warnings}) = 182 | pretty wd_src <+> hsep (map pretty wd_warnings) <+> "-#}" 183 | 184 | 185 | instance Pretty (Located (WarnDecl RdrName)) where 186 | pretty = 187 | pretty . unLoc 188 | 189 | 190 | instance Pretty (WarnDecl RdrName) where 191 | pretty (Warning names txt) = 192 | hsep (punctuate comma (map pretty names)) <+> pretty txt 193 | 194 | 195 | instance Pretty WarningTxt where 196 | pretty (DeprecatedTxt a b) = 197 | pretty (unLoc a) <> hsep (map (pretty . sl_st . unLoc) b) 198 | 199 | 200 | instance Pretty (DerivDecl RdrName) where 201 | pretty (DerivDecl t _) = 202 | "deriving instance" <+> pretty t 203 | 204 | 205 | instance Pretty (AnnDecl RdrName) where 206 | pretty (HsAnnotation st _ expr) = 207 | pretty st <+> pretty expr <+> "#-}" 208 | 209 | 210 | instance Pretty (SpliceDecl RdrName) where 211 | pretty (SpliceDecl a _) = 212 | pretty a 213 | 214 | 215 | instance Pretty (Located (HsSplice RdrName)) where 216 | pretty (L _loc a) = 217 | pretty a 218 | 219 | 220 | instance Pretty (FamilyDecl RdrName) where 221 | pretty (FamilyDecl (ClosedTypeFamily equations) name tys res _) = 222 | "type family" <+> pretty name <+> pretty tys <+> pretty res <+> "where" 223 | <> hardline 224 | <> indent 2 (pretty equations) 225 | 226 | 227 | instance Pretty (LFamilyResultSig RdrName) where 228 | pretty = 229 | pretty . unLoc 230 | 231 | 232 | instance Pretty (FamilyResultSig RdrName) where 233 | pretty NoSig = 234 | mempty 235 | pretty (KindSig t) = 236 | "::" <+> pretty t 237 | pretty (TyVarSig s) = 238 | pretty s 239 | 240 | 241 | instance Pretty (TyClDecl RdrName) where 242 | pretty (FamDecl fam) = 243 | pretty fam 244 | pretty SynDecl {tcdLName, tcdRhs} = 245 | "type" <+> pretty tcdLName <+> equals <> hardline 246 | <> indent 2 (pretty tcdRhs) 247 | pretty DataDecl {..} = 248 | let 249 | HsDataDefn {..} = 250 | tcdDataDefn 251 | 252 | in 253 | nest 2 254 | $ (case dd_ND of 255 | NewType -> 256 | "newtype" 257 | 258 | DataType -> 259 | "data") 260 | <+> pretty tcdLName 261 | <> (case hsq_explicit tcdTyVars of 262 | [] -> 263 | mempty 264 | 265 | vars -> 266 | space <> hsep (map pretty vars)) 267 | <> (case dd_cons of 268 | [] -> 269 | mempty 270 | 271 | cons -> 272 | space <> equals <+> pretty dd_cons) 273 | <> foldMap 274 | (\a -> 275 | space <> "deriving" <+> pretty a) 276 | dd_derivs 277 | pretty ClassDecl {..} = 278 | "class" <+> pretty tcdLName <+> pretty tcdTyVars <+> "where" <> hardline 279 | <> indent 2 280 | (concatWith 281 | (\x y -> 282 | x <> hardline <> hardline <> y) 283 | $ map (prettyBind equals . unLoc) (toList tcdMeths) 284 | ++ map pretty tcdSigs) 285 | 286 | 287 | instance Pretty (LHsQTyVars RdrName) where 288 | pretty HsQTvs {..} = 289 | hsep $ map pretty hsq_explicit 290 | 291 | 292 | instance Pretty (LHsTyVarBndr RdrName) where 293 | pretty (L _loc a) = 294 | pretty a 295 | 296 | 297 | instance Pretty (HsTyVarBndr RdrName) where 298 | pretty (UserTyVar n) = 299 | pretty n 300 | pretty (KindedTyVar t k) = 301 | parens (pretty t <+> "::" <+> pretty k) 302 | 303 | 304 | instance Pretty (LSig RdrName) where 305 | pretty (L _loc a) = 306 | pretty a 307 | 308 | 309 | instance Pretty (Located [LHsSigType RdrName]) where 310 | pretty (L _loc a) = 311 | pretty a 312 | 313 | 314 | instance Pretty (Located (ConDecl RdrName)) where 315 | pretty (L _loc a) = 316 | pretty a 317 | 318 | prettyList = 319 | hsep . punctuate "|" . map pretty 320 | 321 | 322 | instance Pretty (ConDecl RdrName) where 323 | pretty ConDeclGADT {con_names, con_type} = 324 | hsep (punctuate comma (map pretty con_names)) <+> "::" <+> pretty con_type 325 | pretty ConDeclH98 {con_name, con_details, con_cxt, con_qvars} = 326 | (foldMap 327 | (\vars -> 328 | "forall" <+> pretty con_qvars <> dot <> space) 329 | con_qvars) 330 | <> (foldMap 331 | (\ctx -> 332 | pretty ctx <+> "=>" <> space) 333 | con_cxt) 334 | <> pretty con_name 335 | <+> (case con_details of 336 | RecCon xs -> 337 | align (braces (pretty xs)) 338 | 339 | PrefixCon args -> 340 | hsep (map (parTy . unLoc) args)) 341 | 342 | where 343 | 344 | parTy (t@HsForAllTy {}) = 345 | parens (pretty t) 346 | parTy (t@HsQualTy {}) = 347 | parens (pretty t) 348 | parTy (t@HsAppsTy {}) = 349 | parens (pretty t) 350 | parTy (t@HsAppTy {}) = 351 | parens (pretty t) 352 | parTy (t@HsFunTy {}) = 353 | parens (pretty t) 354 | parTy t = 355 | pretty t 356 | 357 | 358 | instance Pretty (Located [LConDeclField RdrName]) where 359 | pretty (L _loc a) = 360 | pretty a 361 | 362 | 363 | instance Pretty (Located (ConDeclField RdrName)) where 364 | pretty (L _loc a) = 365 | pretty a 366 | 367 | prettyList = 368 | hsep . punctuate comma . map pretty 369 | 370 | 371 | instance Pretty (ConDeclField RdrName) where 372 | pretty ConDeclField {cd_fld_names, cd_fld_type} = 373 | pretty cd_fld_names <+> "::" <+> align (pretty cd_fld_type) 374 | 375 | 376 | instance Pretty (Located (FieldOcc RdrName)) where 377 | pretty (L _loc a) = 378 | pretty a 379 | 380 | prettyList = 381 | hsep . punctuate comma . map pretty 382 | 383 | 384 | instance Pretty (FieldOcc RdrName) where 385 | pretty FieldOcc {rdrNameFieldOcc} = 386 | pretty rdrNameFieldOcc 387 | 388 | 389 | instance Pretty (InstDecl RdrName) where 390 | pretty ClsInstD {cid_inst} = 391 | pretty cid_inst 392 | pretty TyFamInstD {tfid_inst} = 393 | pretty tfid_inst 394 | 395 | 396 | instance Pretty (TyFamInstDecl RdrName) where 397 | pretty eqn = 398 | hang 2 $ "type instance" <+> pretty (tfid_eqn eqn) 399 | 400 | 401 | instance Pretty (LTyFamInstEqn RdrName) where 402 | pretty = 403 | pretty . unLoc 404 | 405 | prettyList = 406 | vsep . map (hang 2 . pretty) 407 | 408 | 409 | instance Pretty (TyFamInstEqn RdrName) where 410 | pretty (TyFamEqn n pats rhs) = 411 | pretty n <+> pretty pats <+> equals <> hardline <> pretty rhs 412 | 413 | 414 | instance Pretty (HsTyPats RdrName) where 415 | pretty = 416 | pretty . hsib_body 417 | 418 | 419 | instance Pretty (ClsInstDecl RdrName) where 420 | pretty ClsInstDecl {cid_poly_ty, cid_binds} = 421 | "instance" <+> align (pretty cid_poly_ty) <+> "where" <> hardline 422 | <> indent 2 423 | (concatWith 424 | (\x y -> 425 | x <> hardline <> hardline <> y) 426 | (map (prettyBind equals . unLoc) (toList cid_binds))) 427 | 428 | 429 | instance Pretty (Located (StmtLR RdrName RdrName (LHsExpr RdrName))) where 430 | pretty (L _loc a) = 431 | pretty a 432 | 433 | 434 | instance Pretty body => Pretty (StmtLR RdrName RdrName body) where 435 | pretty (BindStmt p bod _ _ _) = 436 | align $ hang 2 (parPat (unLoc p)) <+> "<-" <> hardline 437 | <> indent 2 (pretty bod) 438 | pretty (BodyStmt body _ _ _) = 439 | pretty body 440 | pretty (LetStmt binds) = 441 | "let" <> hardline <+> indent 2 (prettyHsLocalBinds equals (unLoc binds)) 442 | pretty (ParStmt stmts expr _ _) = 443 | brackets $ pretty expr 444 | pretty (LastStmt a _ _) = 445 | pretty a 446 | 447 | 448 | instance Pretty (Located (HsExpr RdrName)) where 449 | pretty (L _loc a) = 450 | pretty a 451 | 452 | 453 | instance Pretty (HsOverLit RdrName) where 454 | pretty OverLit {ol_val} = 455 | pretty ol_val 456 | 457 | 458 | instance Pretty OverLitVal where 459 | pretty (HsIntegral st _) = 460 | pretty st 461 | pretty (HsIsString st _) = 462 | pretty st 463 | pretty (HsFractional ft) = 464 | pretty (fl_text ft) 465 | 466 | 467 | parensExpr (expr@HsLam {}) = 468 | parens (pretty expr) 469 | parensExpr (expr@HsCase {}) = 470 | parens (pretty expr) 471 | parensExpr (expr@HsIf {}) = 472 | parens (pretty expr) 473 | parensExpr (expr@HsLet {}) = 474 | parens (pretty expr) 475 | parensExpr (expr@HsDo {}) = 476 | parens (pretty expr) 477 | parensExpr (expr@NegApp {}) = 478 | parens (pretty expr) 479 | parensExpr (expr@ExprWithTySig {}) = 480 | parens (pretty expr) 481 | parensExpr (expr@OpApp {}) = 482 | parens (pretty expr) 483 | parensExpr a = 484 | pretty a 485 | 486 | 487 | parensLeftOp (expr@HsLam {}) = 488 | parens (pretty expr) 489 | parensLeftOp (expr@HsCase {}) = 490 | parens (pretty expr) 491 | parensLeftOp (expr@HsIf {}) = 492 | parens (pretty expr) 493 | parensLeftOp (expr@HsLet {}) = 494 | parens (pretty expr) 495 | parensLeftOp (expr@HsDo {}) = 496 | parens (pretty expr) 497 | parensLeftOp (expr@NegApp {}) = 498 | parens (pretty expr) 499 | parensLeftOp (expr@ExprWithTySig {}) = 500 | parens (pretty expr) 501 | parensLeftOp a = 502 | pretty a 503 | 504 | 505 | instance Pretty (HsExpr RdrName) where 506 | pretty (HsVar id_) = 507 | pretty id_ 508 | pretty (HsOverLit a) = 509 | pretty a 510 | pretty (HsLit lit) = 511 | pretty lit 512 | pretty (HsLam mg) = 513 | "\\" <> align (prettyMatchGroup "->" mg) 514 | pretty (HsApp a b) = 515 | group . hang 2 $ parensExpr (unLoc a) <> line <> parensExpr (unLoc b) 516 | pretty (OpApp (L _ a) (L _ (HsVar op)) _ (L _ b)) 517 | | HSFmt.isSymOcc op = group $ hang 2 $ parensLeftOp a <> line 518 | <> prettyName (unLoc op) 519 | <+> pretty b 520 | | otherwise = group $ hang 2 $ parensLeftOp a <> line <> "`" <> pretty op 521 | <> "`" 522 | <+> pretty b 523 | pretty (OpApp a other _ b) = 524 | error "OpApp with a non-HsVar operator" 525 | pretty (NegApp a _) = 526 | "-" <> pretty a 527 | pretty (HsPar expr) = 528 | parens (pretty expr) 529 | pretty (ExplicitTuple args _) = 530 | parens $ hsep $ punctuate comma (map pretty args) 531 | pretty (HsCase expr MG {mg_alts}) = 532 | align $ "case" <+> align (pretty expr) <+> "of" <> hardline 533 | <> indent 2 534 | (concatWith 535 | (\x y -> 536 | x <> hardline <> hardline <> y) 537 | (map (prettyMatch "->" (hang 2) . unLoc) (unLoc mg_alts))) 538 | pretty (HsIf _ a b c) = 539 | align $ "if" <+> align (pretty a) <+> "then" <> hardline 540 | <> indent 2 (pretty b) 541 | <> hardline 542 | <> "else" 543 | <> hardline 544 | <> indent 2 (pretty c) 545 | pretty (HsLet binds expr) = 546 | align $ "let" <> hardline 547 | <> indent 2 (prettyHsLocalBinds equals (unLoc binds)) 548 | <> hardline 549 | <> hardline 550 | <> "in" 551 | <> hardline 552 | <> indent 2 (pretty expr) 553 | pretty (HsDo ListComp (L _ exprs) _) = 554 | let 555 | go [] expr acc = 556 | brackets $ expr <+> "|" <+> align (hsep (punctuate comma (reverse acc))) 557 | go (L _ x : xs) expr acc = 558 | case x of 559 | LastStmt e _ _ -> 560 | go xs (expr <> pretty e) acc 561 | 562 | bnd -> 563 | go xs expr (pretty bnd : acc) 564 | 565 | in 566 | go exprs mempty [] 567 | pretty (HsDo DoExpr exprs _) = 568 | align $ "do" <> hardline 569 | <> indent 2 570 | (concatWith 571 | (\x y -> 572 | x <> hardline <> hardline <> y) 573 | (map (hang 2 . pretty) (unLoc exprs))) 574 | pretty (HsDo MDoExpr exprs _) = 575 | align $ "mdo" <> hardline 576 | <> indent 2 577 | (concatWith 578 | (\x y -> 579 | x <> hardline <> hardline <> y) 580 | (map (hang 2 . pretty) (unLoc exprs))) 581 | pretty (ExplicitList _ _ exprs) = 582 | list (map (align . pretty) exprs) 583 | pretty RecordCon {rcon_con_name, rcon_flds} = 584 | group (hang 2 (pretty rcon_con_name <> line <> pretty rcon_flds)) 585 | pretty (HsSpliceE a) = 586 | pretty a 587 | pretty (ExprWithTySig (L _ a) b) = 588 | parens (parensExpr a <+> "::" <+> pretty b) 589 | pretty RecordUpd {rupd_expr, rupd_flds} = 590 | group (hang 2 (parensExpr (unLoc rupd_expr) <> line <> pretty rupd_flds)) 591 | pretty (HsProc pat cmds) = 592 | align $ "proc" <+> align (pretty pat) <+> "->" <+> pretty cmds 593 | pretty (SectionR (L _ (HsVar op)) a) = 594 | prettyName (unLoc op) <+> pretty a 595 | pretty (SectionL a (L _ (HsVar op))) = 596 | pretty a <+> prettyName (unLoc op) 597 | pretty (ArithSeq _ _ arithSeq) = 598 | lbracket <> pretty arithSeq <> rbracket 599 | pretty (HsAppType expr ty) = 600 | pretty expr <+> "@" <> pretty ty 601 | pretty (HsLamCase _ mg) = 602 | "\\" <> (hang 2 $ "case" <> hardline <> align (prettyMatchGroup "->" mg)) 603 | pretty (HsBracket a) = 604 | pretty a 605 | 606 | 607 | instance Pretty (HsBracket RdrName) where 608 | pretty (VarBr False a) = 609 | squote <> squote <> prettyName a 610 | 611 | 612 | instance Pretty (ArithSeqInfo RdrName) where 613 | pretty (From a) = 614 | pretty a <> ".." 615 | pretty (FromThen a b) = 616 | pretty a <> comma <+> pretty b <> comma <+> ".." 617 | pretty (FromTo a b) = 618 | pretty a <+> ".." <+> pretty b 619 | pretty (FromThenTo a b c) = 620 | pretty a <> comma <+> pretty b <> comma <+> ".." <+> pretty c 621 | 622 | 623 | instance Pretty (Located (HsCmdTop RdrName)) where 624 | pretty (L _ a) = 625 | pretty a 626 | 627 | 628 | instance Pretty (HsCmdTop RdrName) where 629 | pretty (HsCmdTop cmd _ _ _) = 630 | pretty cmd 631 | 632 | 633 | instance Pretty (Located (HsCmd RdrName)) where 634 | pretty (L _ a) = 635 | pretty a 636 | 637 | 638 | instance Pretty (HsCmd RdrName) where 639 | pretty (HsCmdDo stmts _) = 640 | "do" <+> align (pretty stmts) 641 | pretty (HsCmdArrApp expr args _ HsFirstOrderApp True ) = 642 | pretty expr <+> "-<" <+> pretty args 643 | pretty (HsCmdArrForm expr _ args) = 644 | "(|" <+> align (pretty expr <+> hsep (map pretty args) <+> "|)") 645 | pretty (HsCmdPar p) = 646 | parens (pretty p) 647 | 648 | 649 | instance Pretty (Located [CmdLStmt RdrName]) where 650 | pretty (L _ a) = 651 | align 652 | $ concatWith 653 | (\x y -> 654 | x <> hardline <> hardline <> y) 655 | (map pretty a) 656 | 657 | 658 | instance Pretty (Located (StmtLR RdrName RdrName (LHsCmd RdrName))) where 659 | pretty (L _ a) = 660 | pretty a 661 | 662 | 663 | instance Pretty (Located (HsRecUpdField RdrName)) where 664 | pretty (L _loc a) = 665 | pretty a 666 | 667 | prettyList xs = 668 | lbrace <+> hsep (punctuate comma (map pretty xs)) <+> rbrace 669 | 670 | 671 | instance Pretty (HsRecUpdField RdrName) where 672 | pretty HsRecField {hsRecFieldLbl, hsRecFieldArg} = 673 | pretty hsRecFieldLbl <+> equals <+> pretty hsRecFieldArg 674 | 675 | 676 | instance Pretty (Located (AmbiguousFieldOcc RdrName)) where 677 | pretty (L _loc a) = 678 | pretty a 679 | 680 | 681 | instance Pretty (AmbiguousFieldOcc RdrName) where 682 | pretty (Unambiguous n _) = 683 | pretty n 684 | pretty (Ambiguous n _) = 685 | pretty n 686 | 687 | 688 | instance Pretty (HsRecordBinds RdrName) where 689 | pretty HsRecFields {rec_flds, rec_dotdot} = 690 | braces 691 | (hsep . punctuate comma $ map pretty rec_flds 692 | ++ (case rec_dotdot of 693 | Nothing -> 694 | [] 695 | 696 | Just _ -> 697 | [".."])) 698 | 699 | 700 | instance Pretty (LHsRecField RdrName (LHsExpr RdrName)) where 701 | pretty (L _loc a) = 702 | pretty a 703 | 704 | 705 | instance Pretty (HsRecField RdrName (LHsExpr RdrName)) where 706 | pretty HsRecField {hsRecFieldLbl, hsRecFieldArg} = 707 | pretty hsRecFieldLbl <+> equals <+> pretty hsRecFieldArg 708 | 709 | 710 | instance Pretty (HsSplice RdrName) where 711 | pretty (HsUntypedSplice id_ expr) = 712 | pretty expr 713 | pretty (HsQuasiQuote a b _ src) = 714 | brackets 715 | (prettyInfixName b <> "|" 716 | <> column 717 | (\n -> 718 | indent (negate n) (pretty src)) 719 | <> "|") 720 | pretty (HsTypedSplice x expr) = 721 | "$$" <> parens (pretty expr) 722 | 723 | 724 | instance Pretty (Located [ExprLStmt RdrName]) where 725 | pretty (L _loc a) = 726 | pretty a 727 | 728 | 729 | instance Pretty (LHsTupArg RdrName) where 730 | pretty (L _loc a) = 731 | pretty a 732 | 733 | 734 | instance Pretty (HsTupArg RdrName) where 735 | pretty (Present expr) = 736 | pretty expr 737 | pretty Missing {} = 738 | mempty 739 | 740 | 741 | instance Pretty HsLit where 742 | pretty (HsString src _) = 743 | pretty src 744 | pretty (HsChar src _) = 745 | pretty src 746 | pretty (HsIntPrim src _) = 747 | pretty src 748 | 749 | 750 | parPat (a@(ConPatIn _ InfixCon {})) = 751 | parens (pretty a) 752 | parPat (a@AsPat {}) = 753 | parens (pretty a) 754 | parPat (a@ViewPat {}) = 755 | parens (pretty a) 756 | parPat a = 757 | pretty a 758 | 759 | 760 | instance Pretty (Pat RdrName) where 761 | pretty WildPat {} = 762 | "_" 763 | pretty (VarPat name) = 764 | pretty name 765 | pretty (AsPat id_ pat) = 766 | pretty id_ <> "@" <> parPat (unLoc pat) 767 | pretty (ParPat p) = 768 | parens (pretty p) 769 | pretty (TuplePat pats _ _) = 770 | tupled (map pretty pats) 771 | pretty (ConPatIn id_ (InfixCon a b)) = 772 | pretty a <+> prettyName (unLoc id_) <+> pretty b 773 | pretty (ConPatIn id_ details) = 774 | pretty id_ <+> pretty details 775 | pretty (LitPat a) = 776 | pretty a 777 | pretty (ListPat pats _ _) = 778 | brackets (hsep $ punctuate comma $ map pretty pats) 779 | pretty (ViewPat expr pat _) = 780 | align (parensExpr (unLoc expr)) <+> "->" <+> pretty pat 781 | pretty (NPat l neg _ _) = 782 | foldMap (const "-") neg <> pretty l 783 | pretty (SigPatIn pat t) = 784 | pretty pat <+> "::" <+> pretty t 785 | 786 | 787 | instance Pretty (Located (HsOverLit RdrName)) where 788 | pretty (L _ a) = 789 | pretty a 790 | 791 | 792 | instance Pretty (HsConPatDetails RdrName) where 793 | pretty (PrefixCon args) = 794 | hsep (map pretty args) 795 | pretty (RecCon rec_) = 796 | pretty rec_ 797 | pretty (InfixCon a b) = 798 | parens $ pretty a <+> pretty b 799 | 800 | 801 | instance Pretty (HsRecFields RdrName (LPat RdrName)) where 802 | pretty HsRecFields {rec_flds, rec_dotdot} = 803 | braces $ hsep $ punctuate comma $ map pretty rec_flds 804 | ++ maybe [] (const [".."]) rec_dotdot 805 | 806 | 807 | instance Pretty (Located (HsRecField RdrName (LPat RdrName))) where 808 | pretty (L _loc a) = 809 | pretty a 810 | 811 | 812 | instance Pretty (HsRecField RdrName (LPat RdrName)) where 813 | pretty HsRecField {..} = 814 | pretty hsRecFieldLbl 815 | <> (if hsRecPun then 816 | mempty 817 | else 818 | space <> equals <+> pretty hsRecFieldArg) 819 | 820 | 821 | instance Pretty (Located (Pat RdrName)) where 822 | pretty (L _loc a) = 823 | pretty a 824 | 825 | 826 | instance Pretty (LHsSigType RdrName) where 827 | pretty (HsIB _ thing) = 828 | pretty thing 829 | 830 | prettyList = 831 | tupled . map pretty 832 | 833 | 834 | instance Pretty (Sig RdrName) where 835 | pretty (TypeSig names sig) = 836 | hsep (punctuate comma (map pretty names)) <+> "::" <+> align (pretty sig) 837 | pretty (ClassOpSig isDefault b c) = 838 | (if isDefault then 839 | "default" <> space 840 | else 841 | mempty) 842 | <> hsep (punctuate comma (map pretty b)) 843 | <+> "::" 844 | <+> align (pretty c) 845 | pretty (InlineSig n (InlinePragma {inl_src})) = 846 | pretty inl_src <+> pretty n <+> "#-}" 847 | pretty (FixSig fixity) = 848 | pretty fixity 849 | 850 | 851 | instance Pretty (FixitySig RdrName) where 852 | pretty (FixitySig names (Fixity _ n dir)) = 853 | pretty dir <+> pretty n 854 | <+> hsep (punctuate comma (map (prettyName . unLoc) names)) 855 | 856 | 857 | instance Pretty FixityDirection where 858 | pretty InfixL = 859 | "infixl" 860 | pretty InfixR = 861 | "infixr" 862 | pretty InfixN = 863 | "infix" 864 | 865 | 866 | instance Pretty (LHsSigWcType RdrName) where 867 | pretty HsIB {hsib_body} = 868 | pretty hsib_body 869 | 870 | 871 | instance Pretty (LHsWcType RdrName) where 872 | pretty HsWC {hswc_body} = 873 | pretty hswc_body 874 | 875 | 876 | instance Pretty (LHsType RdrName) where 877 | pretty (L _loTcT ty) = 878 | pretty ty 879 | 880 | prettyList = 881 | tupled . map pretty 882 | 883 | 884 | instance Pretty (HsType RdrName) where 885 | pretty HsQualTy {hst_ctxt, hst_body} = 886 | pretty hst_ctxt <+> "=>" <+> pretty hst_body 887 | pretty (HsTyVar name) = 888 | pretty name 889 | pretty (HsAppsTy apps) = 890 | pretty apps 891 | pretty (HsAppTy a b) = 892 | pretty a <+> pretty b 893 | pretty (HsFunTy l r) = 894 | pretty l <+> "->" <+> pretty r 895 | pretty (HsListTy t) = 896 | lbracket <> pretty t <> rbracket 897 | pretty (HsTupleTy tupleSort tys) = 898 | tupled (map pretty tys) 899 | pretty (HsParTy a) = 900 | parens (pretty a) 901 | pretty (HsForAllTy bndrs t) = 902 | "forall" <+> hsep (map pretty bndrs) <> dot <+> pretty t 903 | pretty (HsTyLit t) = 904 | pretty t 905 | pretty (HsExplicitTupleTy _ tys) = 906 | squote <> tupled (map pretty tys) 907 | pretty (HsBangTy _ t) = 908 | "!" <> pretty t 909 | 910 | 911 | instance Pretty HsTyLit where 912 | pretty (HsNumTy src _) = 913 | pretty src 914 | pretty (HsStrTy src _) = 915 | pretty src 916 | 917 | 918 | instance Pretty (Located (HsAppType RdrName)) where 919 | pretty (L _loc appty) = 920 | pretty appty 921 | 922 | prettyList = 923 | hsep . map pretty 924 | 925 | 926 | instance Pretty (HsAppType RdrName) where 927 | pretty (HsAppPrefix t) = 928 | pretty t 929 | pretty (HsAppInfix t) = 930 | prettyName (unLoc t) 931 | 932 | 933 | instance Pretty (LHsContext RdrName) where 934 | pretty (L _loc [] ) = 935 | "()" 936 | pretty (L _loc [L _ t]) = 937 | pretty t 938 | pretty (L _loc ts) = 939 | pretty ts 940 | 941 | 942 | instance Pretty (Located (ImportDecl RdrName)) where 943 | pretty (L _loc importDecl) = 944 | pretty importDecl 945 | 946 | prettyList = 947 | hardVsep . map pretty 948 | 949 | 950 | instance Pretty (ImportDecl RdrName) where 951 | pretty ImportDecl {ideclName, ideclHiding, ideclQualified, ideclAs, ideclSource} = 952 | hsep 953 | $ catMaybes 954 | [ Just "import" 955 | , if ideclSource then 956 | Just "{-# SOURCE #-}" 957 | else 958 | Nothing 959 | , if ideclQualified then 960 | Just "qualified" 961 | else 962 | Nothing 963 | , Just (pretty ideclName) 964 | , fmap 965 | (\as -> 966 | "as" <+> pretty as) 967 | ideclAs 968 | , fmap 969 | (\(hiding, things) -> 970 | hsep 971 | $ catMaybes 972 | [ if hiding then 973 | Just "hiding" 974 | else 975 | Nothing 976 | , Just (align (pretty things)) 977 | ]) 978 | ideclHiding 979 | ] 980 | 981 | 982 | instance Pretty (Located ModuleName) where 983 | pretty (L _loc moduleName) = 984 | pretty moduleName 985 | 986 | 987 | instance Pretty ModuleName where 988 | pretty = 989 | pretty . moduleNameFS 990 | 991 | 992 | instance Pretty FastString where 993 | pretty fs = 994 | pretty (unpackFS fs) 995 | 996 | 997 | instance Pretty (Located [LIE RdrName]) where 998 | pretty (L _loc rdrNames) = 999 | pretty rdrNames 1000 | 1001 | 1002 | instance Pretty (Located (IE RdrName)) where 1003 | pretty (L _loc rdrName) = 1004 | pretty rdrName 1005 | 1006 | prettyList = 1007 | tupled . map pretty 1008 | 1009 | 1010 | instance Pretty (IE RdrName) where 1011 | pretty (IEVar name) = 1012 | pretty name 1013 | pretty (IEThingAbs name) = 1014 | pretty name 1015 | pretty (IEThingAll name) = 1016 | pretty name <> "(..)" 1017 | pretty (IEThingWith name _ names _) = 1018 | pretty name <> tupled (map pretty names) 1019 | pretty (IEModuleContents mod) = 1020 | "module" <+> pretty mod 1021 | 1022 | 1023 | instance Pretty (Located RdrName) where 1024 | pretty (L _loc rdrName) = 1025 | prettyInfixName rdrName 1026 | 1027 | 1028 | prettyName :: RdrName -> Doc ann 1029 | prettyName n = 1030 | case n of 1031 | Unqual occName -> 1032 | pretty occName 1033 | 1034 | Qual mod name -> 1035 | pretty mod <> dot <> pretty name 1036 | 1037 | Orig _mod name -> 1038 | pretty name 1039 | 1040 | Exact name -> 1041 | pretty (GHC.nameOccName name) 1042 | 1043 | 1044 | prettyInfixName :: RdrName -> Doc ann 1045 | prettyInfixName n 1046 | | HSFmt.isSymOcc n = lparen <> prettyName n <> rparen 1047 | | otherwise = prettyName n 1048 | 1049 | 1050 | instance Pretty Module where 1051 | pretty = 1052 | pretty . moduleName 1053 | 1054 | 1055 | instance Pretty OccName where 1056 | pretty = 1057 | pretty . occNameString 1058 | 1059 | 1060 | class IsSymOcc a where 1061 | isSymOcc :: a -> Bool 1062 | 1063 | 1064 | instance IsSymOcc GHC.OccName where 1065 | isSymOcc = 1066 | GHC.isSymOcc 1067 | 1068 | 1069 | instance IsSymOcc RdrName where 1070 | isSymOcc = 1071 | HSFmt.isSymOcc . rdrNameOcc 1072 | 1073 | 1074 | instance IsSymOcc b => IsSymOcc (GenLocated a b) where 1075 | isSymOcc = 1076 | HSFmt.isSymOcc . unLoc 1077 | 1078 | 1079 | hardVsep :: [Doc ann] -> Doc ann 1080 | hardVsep = 1081 | concatWith 1082 | (\x y -> 1083 | x <> hardline <> y) 1084 | 1085 | 1086 | prettyBind :: Doc ann -> HsBind RdrName -> Doc ann 1087 | prettyBind bind hsBind = 1088 | case hsBind of 1089 | FunBind {fun_id, fun_matches} -> 1090 | hardVsep 1091 | $ map 1092 | (\alt -> 1093 | pretty fun_id <+> prettyMatch bind align (unLoc alt)) 1094 | (unLoc $ mg_alts fun_matches) 1095 | 1096 | PatBind {pat_lhs, pat_rhs} -> 1097 | hang 2 (parPat (unLoc pat_lhs)) <+> prettyGRHSs bind pat_rhs 1098 | 1099 | VarBind {var_id, var_rhs} -> 1100 | prettyInfixName var_id <+> bind <> hardline <> indent 2 (pretty var_rhs) 1101 | 1102 | 1103 | prettyMatch :: Doc ann -> (Doc ann -> Doc ann) -> Match RdrName (LHsExpr RdrName) -> Doc ann 1104 | prettyMatch bind alignPatterns Match {m_pats, m_grhss} = 1105 | (case m_pats of 1106 | [] -> 1107 | mempty 1108 | 1109 | _ -> 1110 | alignPatterns (hsep (map (parPat . unLoc) m_pats) <> space)) 1111 | <> prettyGRHSs bind m_grhss 1112 | 1113 | 1114 | prettyGRHSs bind GRHSs {grhssGRHSs, grhssLocalBinds} = 1115 | (case grhssGRHSs of 1116 | [grhs] -> 1117 | prettyGRHS bind (unLoc grhs) 1118 | 1119 | _ -> 1120 | hardline <> indent 2 (vsep (map (prettyGRHS bind . unLoc) grhssGRHSs))) 1121 | <> (case unLoc grhssLocalBinds of 1122 | EmptyLocalBinds -> 1123 | mempty 1124 | 1125 | _ -> 1126 | hardline <> hardline 1127 | <> indent 2 1128 | ("where" <> hardline <> hardline 1129 | <> indent 2 1130 | (prettyHsLocalBinds bind (unLoc grhssLocalBinds)))) 1131 | 1132 | 1133 | prettyGRHS bind (GRHS [] body) = 1134 | bind <> hardline <> indent 2 (pretty body) 1135 | prettyGRHS bind (GRHS guards body) = 1136 | "|" 1137 | <+> align 1138 | (hsep (punctuate comma (map (prettyGuard . unLoc) guards)) <+> bind 1139 | <+> pretty body) 1140 | 1141 | 1142 | prettyGuard :: GuardStmt RdrName -> Doc ann 1143 | prettyGuard (a@(BodyStmt (L _ e) _ _ _)) | needsParens e = parens (pretty a) 1144 | 1145 | where 1146 | 1147 | needsParens (ExprWithTySig {}) = 1148 | True 1149 | needsParens HsLam {} = 1150 | True 1151 | needsParens (HsIf _ _ _ (L _ (ExprWithTySig {}))) = 1152 | True 1153 | needsParens HsCase {} = 1154 | True 1155 | needsParens _ = 1156 | False 1157 | prettyGuard a = 1158 | pretty a 1159 | 1160 | 1161 | prettyHsLocalBinds bind (HsValBinds b) = 1162 | prettyHsValBindsLR bind b 1163 | 1164 | 1165 | prettyHsValBindsLR bind (ValBindsIn bnds _) = 1166 | concatWith 1167 | (\x y -> 1168 | x <> hardline <> hardline <> y) 1169 | $ map (prettyBind bind . unLoc) (toList bnds) 1170 | 1171 | 1172 | prettyMatchGroup bind MG {mg_alts} = 1173 | hardVsep $ map (prettyMatch bind align . unLoc) (unLoc mg_alts) 1174 | 1175 | 1176 | atLeastAlign d = 1177 | column 1178 | (\k -> 1179 | nesting 1180 | (\i -> 1181 | nest (max 0 (k - i)) d)) 1182 | 1183 | 1184 | tupled :: [Doc ann] -> Doc ann 1185 | tupled = 1186 | group 1187 | . encloseSepAligning atLeastAlign (lparen <> flatAlt space mempty) 1188 | (line' <> rparen) 1189 | (comma <> space) 1190 | 1191 | 1192 | list :: [Doc ann] -> Doc ann 1193 | list = 1194 | group 1195 | . encloseSepAligning atLeastAlign (lbracket <> flatAlt space mempty) 1196 | (line' <> rbracket) 1197 | (comma <> space) 1198 | 1199 | 1200 | encloseSepAligning :: (Doc ann -> Doc ann) -> Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann 1201 | encloseSepAligning align' l r s ds = 1202 | case ds of 1203 | [] -> 1204 | l <> r 1205 | 1206 | [d] -> 1207 | l <> d <> r 1208 | 1209 | _ -> 1210 | align' (cat (zipWith (<>) (l : repeat s) ds) <> r) 1211 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-9.3 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.4" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /test/Roundtrip.hs: -------------------------------------------------------------------------------- 1 | {-# language DefaultSignatures #-} 2 | {-# language FlexibleInstances #-} 3 | {-# language OverloadedStrings #-} 4 | {-# language RecordWildCards #-} 5 | {-# language TemplateHaskell #-} 6 | {-# language TypeSynonymInstances #-} 7 | module Main where 8 | 9 | import qualified Bag 10 | import qualified BasicTypes 11 | import BasicTypes (Boxity(Boxed), Origin(FromSource)) 12 | import Control.Monad.IO.Class 13 | import Data.Algorithm.Diff 14 | import Data.Algorithm.DiffOutput 15 | import Data.Function (on) 16 | import Data.Text.Prettyprint.Doc (pretty) 17 | import qualified FastString 18 | import qualified GHC 19 | import HSFmt () 20 | import Hedgehog 21 | import qualified Hedgehog.Gen as Gen 22 | import qualified Hedgehog.Range as Range 23 | import Language.Haskell.GHC.ExactPrint (exactPrint) 24 | import Language.Haskell.GHC.ExactPrint.Parsers (parseModuleFromString) 25 | import qualified RdrName 26 | import System.IO 27 | import TcEvidence (HsWrapper(WpHole)) 28 | 29 | 30 | 31 | main :: IO () 32 | main = 33 | do 34 | hSetEncoding stdout utf8 35 | 36 | hSetEncoding stderr utf8 37 | 38 | checkParallel $$(discover) 39 | 40 | return () 41 | 42 | 43 | prop_moduleRoundtrip :: Property 44 | prop_moduleRoundtrip = 45 | withTests 1000 $ property 46 | $ do 47 | ShowModule mod <- 48 | forAll (fmap ShowModule genModule) 49 | 50 | footnote (show $ ShowModule mod) 51 | 52 | parse <- 53 | liftIO (parseModuleFromString "input.hs" (show (pretty mod))) 54 | 55 | case parse of 56 | Left e -> 57 | fail (show e) 58 | 59 | Right (_, parsed) -> 60 | footnote 61 | (ppDiff 62 | $ getGroupedDiff (lines $ show (pretty mod)) 63 | (lines $ show (pretty parsed))) 64 | 65 | 66 | newtype ShowModule = ShowModule (GHC.HsModule GHC.RdrName) 67 | 68 | 69 | instance Show ShowModule where 70 | show (ShowModule mod) = 71 | show (pretty mod) 72 | 73 | 74 | class SynEq a where 75 | synEq = 76 | (==) 77 | 78 | synEq :: a -> a -> Bool 79 | 80 | default synEq :: Eq a => a -> a -> Bool 81 | 82 | 83 | instance SynEq a => SynEq (GHC.HsModule a) where 84 | synEq a b = 85 | GHC.hsmodName a `synEq` GHC.hsmodName b && GHC.hsmodImports a 86 | `synEq` GHC.hsmodImports b 87 | && GHC.hsmodDecls a 88 | `synEq` GHC.hsmodDecls b 89 | 90 | 91 | instance SynEq a => SynEq (GHC.HsDecl a) where 92 | synEq (GHC.TyClD a) (GHC.TyClD b) = 93 | a `synEq` b 94 | synEq (GHC.InstD a) (GHC.InstD b) = 95 | True 96 | synEq (GHC.ValD a) (GHC.ValD b) = 97 | True 98 | synEq (GHC.SigD a) (GHC.SigD b) = 99 | True 100 | 101 | 102 | instance SynEq a => SynEq (GHC.TyClDecl a) where 103 | synEq (a@GHC.ClassDecl {}) (b@GHC.ClassDecl {}) = 104 | True 105 | synEq (a@GHC.DataDecl {}) (b@GHC.DataDecl {}) = 106 | True 107 | synEq (a@GHC.SynDecl {}) (b@GHC.SynDecl {}) = 108 | True 109 | 110 | 111 | instance SynEq a => SynEq [a] where 112 | synEq (a : as) (b : bs) = 113 | a `synEq` b && as `synEq` bs 114 | synEq [] [] = 115 | True 116 | synEq _ _ = 117 | False 118 | 119 | 120 | instance SynEq a => SynEq (GHC.ImportDecl a) where 121 | synEq a b = 122 | GHC.ideclName a `synEq` GHC.ideclName b && GHC.ideclPkgQual a 123 | `synEq` GHC.ideclPkgQual b 124 | && GHC.ideclSource a 125 | `synEq` GHC.ideclSource b 126 | && GHC.ideclQualified a 127 | `synEq` GHC.ideclQualified b 128 | && GHC.ideclHiding a 129 | `synEq` GHC.ideclHiding b 130 | && GHC.ideclAs a 131 | `synEq` GHC.ideclAs b 132 | 133 | 134 | instance SynEq Bool where 135 | 136 | 137 | 138 | instance (SynEq a, SynEq b) => SynEq (a, b) where 139 | synEq (a, a') (b, b') = 140 | a `synEq` b && a' `synEq` b' 141 | 142 | 143 | instance (SynEq a) => SynEq (GHC.IE a) where 144 | synEq a b = 145 | GHC.ieNames a `synEq` GHC.ieNames b 146 | 147 | 148 | instance SynEq BasicTypes.StringLiteral where 149 | 150 | 151 | 152 | instance SynEq a => SynEq (Maybe a) where 153 | synEq Nothing Nothing = 154 | True 155 | synEq (Just a) (Just b) = 156 | a `synEq` b 157 | synEq _ _ = 158 | False 159 | 160 | 161 | instance SynEq a => SynEq (GHC.Located a) where 162 | synEq (GHC.L _ a) (GHC.L _ b) = 163 | synEq a b 164 | 165 | 166 | instance SynEq GHC.ModuleName where 167 | 168 | 169 | 170 | instance SynEq Char where 171 | 172 | 173 | 174 | genModule :: Gen (GHC.HsModule RdrName.RdrName) 175 | genModule = 176 | do 177 | hsmodName <- 178 | Gen.maybe . located $ genModuleName 179 | 180 | hsmodImports <- 181 | Gen.list (Range.linear 0 10) (located genImportDecl) 182 | 183 | hsmodExports <- 184 | Gen.maybe . located $ Gen.list (Range.linear 0 10) (located genIE) 185 | 186 | hsmodDecls <- 187 | Gen.list (Range.linear 0 10) (located genDecl) 188 | 189 | hsmodDeprecMessage <- 190 | pure Nothing 191 | 192 | hsmodHaddockModHeader <- 193 | pure Nothing 194 | 195 | pure GHC.HsModule {..} 196 | 197 | 198 | genDecl :: Gen (GHC.HsDecl RdrName.RdrName) 199 | genDecl = 200 | Gen.choice 201 | [ GHC.TyClD <$> genTyClDecl 202 | , GHC.InstD <$> genInstDecl 203 | , GHC.SigD <$> genSig 204 | , GHC.ValD <$> genBind 205 | ] 206 | 207 | 208 | genSpliceDecl :: Gen (GHC.SpliceDecl RdrName.RdrName) 209 | genSpliceDecl = 210 | GHC.SpliceDecl <$> located genHsSplice 211 | <*> Gen.element [GHC.ExplicitSplice, GHC.ImplicitSplice] 212 | 213 | 214 | genHsSplice :: Gen (GHC.HsSplice RdrName.RdrName) 215 | genHsSplice = 216 | Gen.choice [GHC.HsUntypedSplice <$> genTyVar <*> located genExpr] 217 | 218 | 219 | genInstDecl :: Gen (GHC.InstDecl RdrName.RdrName) 220 | genInstDecl = 221 | Gen.choice [GHC.ClsInstD <$> genClsInstDecl] 222 | 223 | 224 | genClsInstDecl :: Gen (GHC.ClsInstDecl RdrName.RdrName) 225 | genClsInstDecl = 226 | GHC.ClsInstDecl <$> genLHsSigType <*> genBinds <*> pure [] <*> pure [] 227 | <*> pure [] 228 | <*> pure Nothing 229 | 230 | 231 | genLDataFamInstDecl :: Gen (GHC.Located (GHC.DataFamInstDecl RdrName.RdrName)) 232 | genLDataFamInstDecl = 233 | located genDataFamInstDecl 234 | 235 | 236 | genDataFamInstDecl :: Gen (GHC.DataFamInstDecl RdrName.RdrName) 237 | genDataFamInstDecl = 238 | GHC.DataFamInstDecl <$> located genTypeName <*> genHsTyPats <*> genHsDataDefn 239 | <*> pure GHC.PlaceHolder 240 | 241 | 242 | genHsTyPats :: Gen (GHC.HsImplicitBndrs RdrName.RdrName [GHC.Located (GHC.HsType RdrName.RdrName)]) 243 | genHsTyPats = 244 | GHC.HsIB <$> pure GHC.PlaceHolder 245 | <*> Gen.list (Range.linear 0 10) (located genHsType) 246 | 247 | 248 | genHsImplicitBndrs :: Gen (GHC.HsImplicitBndrs RdrName.RdrName (GHC.Located (GHC.HsType RdrName.RdrName))) 249 | genHsImplicitBndrs = 250 | GHC.HsIB <$> pure GHC.PlaceHolder 251 | <*> located 252 | (GHC.HsAppTy <$> located (GHC.HsTyVar <$> located genTypeName) 253 | <*> located genHsType) 254 | 255 | 256 | genSig :: Gen (GHC.Sig RdrName.RdrName) 257 | genSig = 258 | Gen.choice 259 | [ GHC.TypeSig <$> Gen.list (Range.linear 1 10) (located genVarName) 260 | <*> (GHC.HsIB <$> pure GHC.PlaceHolder 261 | <*> (GHC.HsWC <$> pure GHC.PlaceHolder <*> pure Nothing 262 | <*> located genHsType)) 263 | ] 264 | 265 | 266 | genTyClDecl :: Gen (GHC.TyClDecl RdrName.RdrName) 267 | genTyClDecl = 268 | Gen.choice [dataDecl, synDecl, classDecl] 269 | 270 | where 271 | 272 | dataDecl = 273 | GHC.DataDecl <$> located genTypeName <*> genLHsQTyVars <*> genHsDataDefn 274 | <*> pure GHC.PlaceHolder 275 | <*> pure GHC.PlaceHolder 276 | 277 | synDecl = 278 | GHC.SynDecl <$> located genTypeName <*> genLHsQTyVars 279 | <*> located genHsType 280 | <*> pure GHC.PlaceHolder 281 | 282 | classDecl = 283 | GHC.ClassDecl <$> located (pure []) <*> located genTypeName 284 | <*> genLHsQTyVars 285 | <*> pure [] 286 | <*> Gen.list (Range.linear 0 10) 287 | (located 288 | $ Gen.choice 289 | [ genSig 290 | , GHC.ClassOpSig <$> Gen.bool 291 | <*> Gen.list (Range.singleton 1) (located genVarName) 292 | <*> genLHsSigType 293 | ]) 294 | <*> genBinds 295 | <*> pure [] 296 | <*> pure [] 297 | <*> pure [] 298 | <*> pure GHC.PlaceHolder 299 | 300 | 301 | genLHsQTyVars :: Gen (GHC.LHsQTyVars RdrName.RdrName) 302 | genLHsQTyVars = 303 | GHC.HsQTvs <$> pure GHC.PlaceHolder 304 | <*> Gen.list (Range.linear 0 10) (located genHsTyVarBndr) 305 | <*> pure GHC.PlaceHolder 306 | 307 | 308 | genHsTyVarBndr :: Gen (GHC.HsTyVarBndr RdrName.RdrName) 309 | genHsTyVarBndr = 310 | Gen.choice [GHC.UserTyVar <$> located genTyVar] 311 | 312 | 313 | genHsDataDefn :: Gen (GHC.HsDataDefn RdrName.RdrName) 314 | genHsDataDefn = 315 | do 316 | newOrData <- 317 | genNewOrData 318 | 319 | GHC.HsDataDefn <$> pure newOrData 320 | <*> located (Gen.list (Range.linear 0 10) (located genHsType)) 321 | <*> pure Nothing 322 | <*> Gen.maybe (located genHsKind) 323 | <*> Gen.list 324 | (if newOrData == GHC.NewType then 325 | Range.singleton 1 326 | else 327 | Range.linear 0 10) 328 | (located genConDecl) 329 | <*> genHsDeriving 330 | 331 | 332 | genHsDeriving :: Gen (Maybe (GHC.Located [GHC.HsImplicitBndrs RdrName.RdrName (GHC.Located (GHC.HsType RdrName.RdrName))])) 333 | genHsDeriving = 334 | Gen.maybe (located (Gen.list (Range.linear 0 10) genLHsSigType)) 335 | 336 | 337 | genLHsSigType :: Gen (GHC.HsImplicitBndrs RdrName.RdrName (GHC.Located (GHC.HsType RdrName.RdrName))) 338 | genLHsSigType = 339 | genHsImplicitBndrs 340 | 341 | 342 | genConDecl :: Gen (GHC.ConDecl RdrName.RdrName) 343 | genConDecl = 344 | Gen.choice 345 | [ GHC.ConDeclH98 <$> located genTypeName <*> Gen.maybe genLHsQTyVars 346 | <*> Gen.maybe 347 | (located (Gen.list (Range.linear 0 10) (located genHsType))) 348 | <*> genHsConDeclDetails 349 | <*> pure Nothing 350 | ] 351 | 352 | 353 | genHsConDeclDetails :: Gen (GHC.HsConDetails (GHC.Located (GHC.HsType RdrName.RdrName)) (GHC.Located [GHC.Located (GHC.ConDeclField RdrName.RdrName)])) 354 | genHsConDeclDetails = 355 | Gen.choice 356 | [ GHC.PrefixCon <$> Gen.list (Range.linear 0 10) (located genHsType) 357 | , GHC.RecCon 358 | <$> located (Gen.list (Range.linear 0 10) (located genConDeclField)) 359 | ] 360 | 361 | 362 | genConDeclField :: Gen (GHC.ConDeclField RdrName.RdrName) 363 | genConDeclField = 364 | GHC.ConDeclField 365 | <$> Gen.list (Range.linear 1 10) 366 | (located 367 | (GHC.FieldOcc <$> located genVarName <*> pure GHC.PlaceHolder)) 368 | <*> located genHsType 369 | <*> pure Nothing 370 | 371 | 372 | genHsKind :: Gen (GHC.HsType RdrName.RdrName) 373 | genHsKind = 374 | genHsType 375 | 376 | 377 | genHsType :: Gen (GHC.HsType RdrName.RdrName) 378 | genHsType = 379 | Gen.recursive Gen.choice [GHC.HsTyVar <$> located genTyVar] 380 | [ GHC.HsAppsTy 381 | <$> Gen.list (Range.linear 1 3) 382 | (located (GHC.HsAppPrefix <$> located genHsType)) 383 | , Gen.subterm2 genHsType genHsType (GHC.HsAppTy `on` GHC.L srcSpan) 384 | , Gen.subterm2 genHsType genHsType (GHC.HsFunTy `on` GHC.L srcSpan) 385 | , Gen.subtermM genHsType 386 | (\expr -> 387 | GHC.HsListTy <$> located (pure expr)) 388 | , GHC.HsTupleTy 389 | <$> Gen.element 390 | [ GHC.HsUnboxedTuple 391 | , GHC.HsBoxedTuple 392 | , GHC.HsConstraintTuple 393 | , GHC.HsBoxedOrConstraintTuple 394 | ] 395 | <*> Gen.list (Range.linear 0 3) (located genHsType) 396 | , Gen.subterm genHsType $ GHC.HsParTy . GHC.L GHC.noSrcSpan 397 | , GHC.HsTyLit 398 | <$> Gen.choice 399 | [ fmap 400 | (\n -> 401 | GHC.HsNumTy (show n) n) 402 | (Gen.integral (Range.linear 0 100)) 403 | , fmap 404 | (\s -> 405 | GHC.HsStrTy (show s) (FastString.fsLit s)) 406 | (Gen.string (Range.linear 0 10) Gen.latin1) 407 | ] 408 | ] 409 | 410 | 411 | genHsTypeCtx :: Gen (GHC.HsType RdrName.RdrName) 412 | genHsTypeCtx = 413 | Gen.choice 414 | [ genHsType 415 | , GHC.HsQualTy <$> located (Gen.list (Range.linear 0 3) (located genHsType)) 416 | <*> located genHsType 417 | ] 418 | 419 | 420 | genNewOrData :: Gen GHC.NewOrData 421 | genNewOrData = 422 | Gen.choice [pure GHC.NewType, pure GHC.DataType] 423 | 424 | 425 | genBind :: Gen (GHC.HsBindLR RdrName.RdrName RdrName.RdrName) 426 | genBind = 427 | Gen.choice 428 | [ GHC.VarBind <$> genVarName <*> located genExpr <*> Gen.bool 429 | , GHC.FunBind <$> located genVarName 430 | <*> (GHC.MG 431 | <$> located 432 | (Gen.list (Range.singleton 1) 433 | (located $ GHC.Match <$> pure GHC.NonFunBindMatch 434 | <*> Gen.list (Range.linear 0 10) (located genPat) 435 | <*> pure Nothing 436 | <*> grhsss)) 437 | <*> pure [] 438 | <*> pure GHC.PlaceHolder 439 | <*> pure FromSource) 440 | <*> pure WpHole 441 | <*> pure GHC.PlaceHolder 442 | <*> pure [] 443 | , GHC.PatBind <$> located genPat <*> grhsss <*> pure GHC.PlaceHolder 444 | <*> pure GHC.PlaceHolder 445 | <*> pure ([], []) 446 | ] 447 | 448 | where 449 | 450 | grhsss = 451 | GHC.GRHSs <$> Gen.list (Range.linear 1 3) (located genGRHS) 452 | <*> located 453 | (Gen.choice 454 | [ pure GHC.EmptyLocalBinds 455 | , GHC.HsValBinds <$> (GHC.ValBindsIn <$> genBinds <*> pure []) 456 | ]) 457 | 458 | 459 | genBinds :: Gen (GHC.LHsBinds RdrName.RdrName) 460 | genBinds = 461 | Gen.recursive Gen.choice 462 | [ (Bag.listToBag . map (GHC.L GHC.noSrcSpan)) 463 | <$> Gen.list (Range.singleton 1) 464 | (GHC.VarBind <$> genVarName <*> located genExpr <*> Gen.bool) 465 | ] 466 | [ Gen.subtermM genBinds 467 | (\localBinds -> 468 | (Bag.listToBag . map (GHC.L GHC.noSrcSpan)) 469 | <$> Gen.list (Range.linear 0 10) 470 | (Gen.choice 471 | [ GHC.FunBind <$> located genVarName 472 | <*> (GHC.MG 473 | <$> located 474 | (Gen.list (Range.singleton 1) 475 | (located $ GHC.Match 476 | <$> pure GHC.NonFunBindMatch 477 | <*> Gen.list (Range.linear 1 10) 478 | (located genPat) 479 | <*> pure Nothing 480 | <*> grhsss localBinds)) 481 | <*> pure [] 482 | <*> pure GHC.PlaceHolder 483 | <*> pure FromSource) 484 | <*> pure WpHole 485 | <*> pure GHC.PlaceHolder 486 | <*> pure [] 487 | , GHC.PatBind <$> located genPat <*> grhsss localBinds 488 | <*> pure GHC.PlaceHolder 489 | <*> pure GHC.PlaceHolder 490 | <*> pure ([], []) 491 | ])) 492 | ] 493 | 494 | where 495 | 496 | grhsss localBinds = 497 | GHC.GRHSs <$> Gen.list (Range.singleton 1) (located genGRHS) 498 | <*> located 499 | (Gen.choice 500 | [ pure GHC.EmptyLocalBinds 501 | , GHC.HsValBinds 502 | <$> (GHC.ValBindsIn <$> pure localBinds <*> pure []) 503 | ]) 504 | 505 | 506 | genPat :: Gen (GHC.Pat RdrName.RdrName) 507 | genPat = 508 | Gen.recursive Gen.choice 509 | [ pure $ GHC.WildPat GHC.PlaceHolder 510 | , GHC.VarPat <$> located genVarName 511 | , GHC.LitPat <$> genLit 512 | ] 513 | [ GHC.ListPat <$> Gen.list (Range.linear 1 10) (located genPat) 514 | <*> pure GHC.PlaceHolder 515 | <*> pure Nothing 516 | , Gen.subterm2 genPat genPat 517 | (\l r -> 518 | GHC.ConPatIn 519 | (GHC.L GHC.noSrcSpan 520 | (RdrName.mkVarUnqual . FastString.fsLit $ ":")) 521 | (GHC.InfixCon (GHC.L GHC.noSrcSpan l) (GHC.L GHC.noSrcSpan r))) 522 | , GHC.ConPatIn <$> located genTypeName 523 | <*> (GHC.RecCon 524 | <$> (GHC.HsRecFields 525 | <$> Gen.list (Range.linear 0 3) 526 | (located 527 | (GHC.HsRecField 528 | <$> located 529 | (GHC.FieldOcc <$> located genVarName 530 | <*> pure GHC.PlaceHolder) 531 | <*> located genPat 532 | <*> Gen.bool)) 533 | <*> Gen.maybe (Gen.integral (Range.linear 0 2)))) 534 | , Gen.subtermM genPat 535 | (\p -> 536 | GHC.AsPat <$> located genVarName <*> located (pure p)) 537 | , Gen.subtermM genPat 538 | (\p -> 539 | GHC.ViewPat <$> located genExpr <*> located (pure p) 540 | <*> pure GHC.PlaceHolder) 541 | , Gen.subtermM genPat 542 | (\p -> 543 | GHC.ParPat <$> located (pure p)) 544 | , GHC.TuplePat <$> Gen.list (Range.linear 1 3) (located genPat) 545 | <*> pure Boxed 546 | <*> pure [] 547 | ] 548 | 549 | 550 | genGRHS :: Gen (GHC.GRHS RdrName.RdrName (GHC.Located (GHC.HsExpr RdrName.RdrName))) 551 | genGRHS = 552 | GHC.GRHS <$> Gen.list (Range.linear 1 2) genBodyStmt <*> located genExpr 553 | 554 | 555 | syntaxExpr = 556 | GHC.SyntaxExpr 557 | {syn_expr = GHC.EWildPat, syn_arg_wraps = [], syn_res_wrap = WpHole} 558 | 559 | 560 | genBodyStmt :: Gen (GHC.ExprLStmt RdrName.RdrName) 561 | genBodyStmt = 562 | located $ GHC.BodyStmt <$> located (Gen.filter (not . isHsLet) genExpr) 563 | <*> pure syntaxExpr 564 | <*> pure syntaxExpr 565 | <*> pure GHC.PlaceHolder 566 | 567 | where 568 | 569 | isHsLet GHC.HsLet {} = 570 | True 571 | isHsLet _ = 572 | False 573 | 574 | 575 | genStmt :: Gen (GHC.ExprLStmt RdrName.RdrName) 576 | genStmt = 577 | Gen.choice 578 | [ genBodyStmt 579 | , located $ GHC.BindStmt <$> located genPat <*> located genExpr 580 | <*> pure syntaxExpr 581 | <*> pure syntaxExpr 582 | <*> pure GHC.PlaceHolder 583 | , located $ GHC.LetStmt <$> located genLocalBinds 584 | ] 585 | 586 | 587 | genLocalBinds = 588 | GHC.HsValBinds 589 | <$> (GHC.ValBindsIn 590 | <$> fmap Bag.listToBag 591 | (Gen.list (Range.linear 1 10) (located genBind)) 592 | <*> pure []) 593 | 594 | 595 | genLit = 596 | Gen.choice 597 | [ (\s -> 598 | GHC.HsString (show s) (FastString.fsLit s)) 599 | <$> Gen.string (Range.linear 0 100) Gen.alphaNum 600 | , fmap 601 | (\c -> 602 | GHC.HsChar (show c) c) 603 | Gen.latin1 604 | ] 605 | 606 | 607 | genExpr :: Gen (GHC.HsExpr RdrName.RdrName) 608 | genExpr = 609 | Gen.recursive Gen.choice 610 | [ GHC.HsVar <$> located genVarName 611 | , GHC.HsOverLit 612 | <$> (GHC.OverLit 613 | <$> Gen.choice 614 | [ (\i -> 615 | GHC.HsIntegral (show i) i) 616 | <$> Gen.integral (Range.linear 0 100) 617 | ] 618 | <*> pure GHC.PlaceHolder 619 | <*> pure GHC.EWildPat 620 | <*> pure GHC.PlaceHolder) 621 | , GHC.HsLit <$> genLit 622 | ] 623 | [ Gen.subtermM genExpr 624 | (\expr -> 625 | GHC.HsLam 626 | <$> genMG (Range.singleton 1) (Range.linear 1 3) 627 | (Range.singleton 0) 628 | (pure expr)) 629 | , Gen.subterm2 genExpr genExpr (GHC.HsApp `on` GHC.L GHC.noSrcSpan) 630 | , Gen.subtermM2 genExpr genExpr 631 | (\l r -> 632 | GHC.OpApp <$> located (pure l) 633 | <*> located (GHC.HsVar <$> located genVarName) 634 | <*> pure GHC.PlaceHolder 635 | <*> located (pure r)) 636 | , Gen.subterm genExpr (GHC.HsPar . GHC.L GHC.noSrcSpan) 637 | , Gen.shrink 638 | (\expr -> 639 | case expr of 640 | GHC.HsCase _ (GHC.MG (GHC.L _ alts) _ _ _) -> 641 | do 642 | GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs bnds _)) <- 643 | alts 644 | 645 | GHC.L _ (GHC.GRHS _ (GHC.L _ body)) <- 646 | bnds 647 | 648 | return body 649 | 650 | _ -> 651 | []) 652 | $ Gen.subtermM genExpr 653 | (\e -> 654 | GHC.HsCase <$> located (pure e) 655 | <*> genMG (Range.linear 1 3) (Range.singleton 1) 656 | (Range.linear 0 2) 657 | genExpr) 658 | , Gen.subterm3 genExpr genExpr genExpr 659 | (\a b c -> 660 | GHC.HsIf Nothing (GHC.L GHC.noSrcSpan a) (GHC.L GHC.noSrcSpan b) 661 | (GHC.L GHC.noSrcSpan c)) 662 | , Gen.subtermM genExpr 663 | (\body -> 664 | GHC.HsLet <$> located genLocalBinds <*> located (pure body)) 665 | , GHC.HsDo <$> pure GHC.DoExpr 666 | <*> located (Gen.list (Range.linear 1 10) genStmt) 667 | <*> pure GHC.PlaceHolder 668 | , GHC.ExplicitTuple 669 | <$> Gen.list (Range.linear 1 10) 670 | (located (GHC.Present <$> located genExpr)) 671 | <*> pure Boxed 672 | , GHC.ExplicitList <$> pure GHC.PlaceHolder <*> pure Nothing 673 | <*> Gen.list (Range.linear 1 10) (located genExpr) 674 | , GHC.RecordCon <$> located genTypeName <*> pure GHC.PlaceHolder 675 | <*> pure GHC.EWildPat 676 | <*> (GHC.HsRecFields 677 | <$> Gen.list (Range.linear 1 3) 678 | (located 679 | (GHC.HsRecField 680 | <$> located 681 | (GHC.FieldOcc <$> located genVarName 682 | <*> pure GHC.PlaceHolder) 683 | <*> located genExpr 684 | <*> Gen.bool)) 685 | <*> Gen.maybe (Gen.integral (Range.linear 0 100))) 686 | , Gen.subtermM genExpr 687 | (\e -> 688 | GHC.ExprWithTySig <$> located (pure e) 689 | <*> (GHC.HsIB <$> pure GHC.PlaceHolder 690 | <*> (GHC.HsWC <$> pure GHC.PlaceHolder <*> pure Nothing 691 | <*> located genHsType))) 692 | , Gen.subtermM genExpr 693 | (\expr -> 694 | GHC.RecordUpd <$> located (pure expr) 695 | <*> Gen.list (Range.linear 1 3) 696 | (located $ GHC.HsRecField 697 | <$> located 698 | (GHC.Unambiguous <$> located genVarName 699 | <*> pure GHC.PlaceHolder) 700 | <*> located genExpr 701 | <*> Gen.bool) 702 | <*> pure GHC.PlaceHolder 703 | <*> pure GHC.PlaceHolder 704 | <*> pure GHC.PlaceHolder 705 | <*> pure GHC.PlaceHolder) 706 | ] 707 | 708 | 709 | genMG :: Range Int -> Range Int -> Range Int -> Gen a -> Gen (GHC.MatchGroup RdrName.RdrName (GHC.Located a)) 710 | genMG matches patterns guards genExpr = 711 | GHC.MG 712 | <$> located 713 | (Gen.list matches 714 | (located 715 | (GHC.Match <$> pure GHC.NonFunBindMatch 716 | <*> Gen.list patterns (located genPat) 717 | <*> pure Nothing 718 | <*> (GHC.GRHSs 719 | <$> (pure 720 | <$> located 721 | (GHC.GRHS <$> Gen.list guards genBodyStmt 722 | <*> located genExpr)) 723 | <*> located (pure GHC.EmptyLocalBinds))))) 724 | <*> pure [] 725 | <*> pure GHC.PlaceHolder 726 | <*> pure FromSource 727 | 728 | 729 | located :: Monad m => m a -> m (GHC.Located a) 730 | located = 731 | fmap (GHC.L srcSpan) 732 | 733 | 734 | srcSpan :: GHC.SrcSpan 735 | srcSpan = 736 | GHC.noSrcSpan 737 | 738 | 739 | genImportDecl :: Gen (GHC.ImportDecl RdrName.RdrName) 740 | genImportDecl = 741 | do 742 | ideclSourceSrc <- 743 | pure Nothing 744 | 745 | ideclName <- 746 | located genModuleName 747 | 748 | ideclPkgQual <- 749 | pure Nothing 750 | 751 | ideclSource <- 752 | Gen.bool 753 | 754 | ideclSafe <- 755 | Gen.bool 756 | 757 | ideclQualified <- 758 | Gen.bool 759 | 760 | ideclImplicit <- 761 | Gen.bool 762 | 763 | ideclHiding <- 764 | Gen.maybe 765 | ((,) <$> Gen.bool 766 | <*> located (Gen.list (Range.linear 0 10) (located genIE))) 767 | 768 | ideclAs <- 769 | Gen.maybe genModuleName 770 | 771 | pure GHC.ImportDecl {..} 772 | 773 | 774 | genIE :: Gen (GHC.IE RdrName.RdrName) 775 | genIE = 776 | Gen.choice 777 | [ GHC.IEVar <$> located genAnyName 778 | , GHC.IEThingAbs <$> located genAnyName 779 | , GHC.IEThingAll <$> located genTypeName 780 | , GHC.IEThingWith <$> located genTypeName <*> pure GHC.NoIEWildcard 781 | <*> Gen.list (Range.linear 0 3) (located genVarName) 782 | <*> pure [] 783 | , GHC.IEModuleContents <$> located genModuleName 784 | ] 785 | 786 | 787 | genModuleName :: Gen GHC.ModuleName 788 | genModuleName = 789 | fmap GHC.mkModuleName $ (:) <$> Gen.upper 790 | <*> Gen.string (Range.linear 0 10) Gen.alphaNum 791 | 792 | 793 | typeName :: Gen String 794 | typeName = 795 | (:) <$> Gen.upper <*> Gen.string (Range.linear 0 10) Gen.alphaNum 796 | 797 | 798 | genTypeName :: Gen RdrName.RdrName 799 | genTypeName = 800 | fmap (RdrName.mkVarUnqual . FastString.fsLit) typeName 801 | 802 | 803 | genTyVar :: Gen RdrName.RdrName 804 | genTyVar = 805 | RdrName.mkVarUnqual . FastString.fsLit 806 | <$> Gen.filter 807 | (\name -> 808 | name `notElem` ["do", "if", "of", "in", "let"]) 809 | ((:) <$> Gen.lower <*> Gen.string (Range.linear 0 10) Gen.alphaNum) 810 | 811 | 812 | genVarName :: Gen RdrName.RdrName 813 | genVarName = 814 | Gen.choice [genTyVar, pure $ RdrName.mkVarUnqual . FastString.fsLit $ "+"] 815 | 816 | 817 | genAnyName = 818 | Gen.choice [genVarName, genTypeName] 819 | --------------------------------------------------------------------------------