git.iko.soy/ormolu
on master help sign in
Format Ormolu with Ormolu
commit480d6edfb36e6818a5de2c5095cbabce4b97d53a authormrkkrp <mark.karpov@tweag.io> dateThu 3 Oct 2019, 15:48 (7 years ago) parentc386de8
44 files changed+1646−1546
compare with master
unifiedsplit
.circleci/config.yml+1−1 default.nix+7−3 format.sh+5−4 src/Ormolu.hs+55−48 src/Ormolu/Config.hs+32−33 src/Ormolu/Diff.hs+65−61 src/Ormolu/Exception.hs+41−40 src/Ormolu/Imports.hs+4−11 src/Ormolu/Parser.hs+85−79 src/Ormolu/Parser/Anns.hs+18−20 src/Ormolu/Parser/CommentStream.hs+48−53 src/Ormolu/Parser/Pragma.hs+24−26 src/Ormolu/Parser/Result.hs+21−22 src/Ormolu/Printer.hs+11−11 src/Ormolu/Printer/Combinators.hs+106−101 src/Ormolu/Printer/Comments.hs+94−83 src/Ormolu/Printer/Internal.hs+257−242 src/Ormolu/Printer/Meat/Common.hs+42−40 src/Ormolu/Printer/Meat/Declaration.hs+50−49 src/Ormolu/Printer/Meat/Declaration.hs-boot+3−2 src/Ormolu/Printer/Meat/Declaration/Annotation.hs+2−2 src/Ormolu/Printer/Meat/Declaration/Class.hs+18−18 src/Ormolu/Printer/Meat/Declaration/Data.hs+56−45 src/Ormolu/Printer/Meat/Declaration/Default.hs+2−2 src/Ormolu/Printer/Meat/Declaration/Foreign.hs+3−5 src/Ormolu/Printer/Meat/Declaration/Instance.hs+13−12 src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs+4−6 src/Ormolu/Printer/Meat/Declaration/Rule.hs+6−5 src/Ormolu/Printer/Meat/Declaration/Signature.hs+77−58 src/Ormolu/Printer/Meat/Declaration/Splice.hs+1−1 src/Ormolu/Printer/Meat/Declaration/Type.hs+13−10 src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs+16−16 src/Ormolu/Printer/Meat/Declaration/Value.hs+281−241 src/Ormolu/Printer/Meat/Declaration/Value.hs-boot+5−5 src/Ormolu/Printer/Meat/Declaration/Warning.hs+3−3 src/Ormolu/Printer/Meat/ImportExport.hs+15−17 src/Ormolu/Printer/Meat/Module.hs+3−4 src/Ormolu/Printer/Meat/Pragma.hs+7−8 src/Ormolu/Printer/Meat/Type.hs+25−24 src/Ormolu/Printer/Operators.hs+62−64 src/Ormolu/Printer/SpanStream.hs+18−20 src/Ormolu/Utils.hs+22−27 tests/Ormolu/Parser/PragmaSpec.hs+3−2 tests/Ormolu/PrinterSpec.hs+22−22
.circleci/config.yml+1−1
@@ -33,7 +33,7 @@ jobs:
3333 name: Check formatting
3434 command: |
3535 ./format.sh
36− git diff --exit-code --color=always
36+ nix-shell -p "(import ./nix/nixpkgs/default.nix).git" --command "git diff --exit-code --color=always"
3737 - run:
3838 name: Generate Haddocks
3939 command: nix-build --attr ormolu.doc
default.nix+7−3
@@ -41,10 +41,14 @@ let
4141 }) haskellPackages;
4242in {
4343 ormolu = haskellPackages.ormolu;
44− locales = pkgs.glibcLocales;
4544 ormoluShell = haskellPackages.shellFor {
46− packages = ps: [ ps.ormolu ];
47− buildInputs = [ haskellPackages.cabal-install haskellPackages.ghcid ];
45+ packages = ps: [
46+ ps.ormolu
47+ ];
48+ buildInputs = [
49+ haskellPackages.cabal-install
50+ haskellPackages.ghcid
51+ ];
4852 };
4953 inherit ormoluOverlay ormoluCompiler;
5054 hackage = ormolizedPackages false;
format.sh+5−4
@@ -1,10 +1,11 @@
1−#!/usr/bin/env bash
1+#!/usr/bin/env nix-shell
2+#!nix-shell -p "(import ./default.nix {}).ormolu" -i bash --pure
23#
34# Format Ormolu using current version of Ormolu.
45
56set -e
67
7−export LANG="en_US.UTF-8"
8+export LANG="C.UTF-8"
89
9−nix run -f default.nix ormolu locales -c ormolu --mode inplace $(find src -type f \( -name "*.hs" -o -name "*.hs-boot" \))
10−nix run -f default.nix ormolu locales -c ormolu --mode inplace $(find tests -type f -name "*.hs")
10+ormolu --mode inplace $(find src -type f \( -name "*.hs" -o -name "*.hs-boot" \))
11+ormolu --mode inplace $(find tests -type f -name "*.hs")
src/Ormolu.hs+55−48
@@ -1,24 +1,25 @@
1−-- | A formatter for Haskell source code.
2−
3−{-# LANGUAGE BangPatterns #-}
1+{-# LANGUAGE BangPatterns #-}
42{-# LANGUAGE RecordWildCards #-}
53
4+-- | A formatter for Haskell source code.
65module Ormolu
7− ( ormolu
8− , ormoluFile
9− , ormoluStdin
10− , Config (..)
11− , defaultConfig
12− , DynOption (..)
13− , OrmoluException (..)
14− , withPrettyOrmoluExceptions
6+ ( ormolu,
7+ ormoluFile,
8+ ormoluStdin,
9+ Config (..),
10+ defaultConfig,
11+ DynOption (..),
12+ OrmoluException (..),
13+ withPrettyOrmoluExceptions,
1514 )
1615where
1716
17+import qualified CmdLineParser as GHC
1818import Control.Exception
1919import Control.Monad
2020import Control.Monad.IO.Class (MonadIO (..))
2121import Data.Text (Text)
22+import qualified Data.Text as T
2223import Debug.Trace
2324import Ormolu.Config
2425import Ormolu.Diff
@@ -27,10 +28,8 @@ import Ormolu.Parser
2728import Ormolu.Parser.Result
2829import Ormolu.Printer
2930import Ormolu.Utils (showOutputable)
30−import System.IO (hGetContents, stdin)
31−import qualified CmdLineParser as GHC
32−import qualified Data.Text as T
3331import qualified SrcLoc as GHC
32+import System.IO (hGetContents, stdin)
3433
3534-- | Format a 'String', return formatted version as 'Text'.
3635--
@@ -42,13 +41,15 @@ import qualified SrcLoc as GHC
4241-- side-effects though.
4342-- * Takes file name just to use it in parse error messages.
4443-- * Throws 'OrmoluException'.
45−
46−ormolu
47− :: MonadIO m
48− => Config -- ^ Ormolu configuration
49− -> FilePath -- ^ Location of source file
50− -> String -- ^ Input to format
51− -> m Text
44+ormolu ::
45+ MonadIO m =>
46+ -- | Ormolu configuration
47+ Config ->
48+ -- | Location of source file
49+ FilePath ->
50+ -- | Input to format
51+ String ->
52+ m Text
5253ormolu cfg path str = do
5354 (ws, result0) <-
5455 parseModule' cfg OrmoluParsingFailed path str
@@ -82,8 +83,9 @@ ormolu cfg path str = do
8283 let txt2 = printModule result1
8384 in case diffText txt txt2 pathRendered of
8485 Nothing -> return ()
85− Just (loc, l, r) -> liftIO $
86− throwIO (OrmoluNonIdempotentOutput loc l r)
86+ Just (loc, l, r) ->
87+ liftIO $
88+ throwIO (OrmoluNonIdempotentOutput loc l r)
8789 return txt
8890
8991-- | Load a file and format it. The file stays intact and the rendered
@@ -91,12 +93,14 @@ ormolu cfg path str = do
9193--
9294-- > ormoluFile cfg path =
9395-- > liftIO (readFile path) >>= ormolu cfg path
94−
95−ormoluFile
96− :: MonadIO m
97− => Config -- ^ Ormolu configuration
98− -> FilePath -- ^ Location of source file
99− -> m Text -- ^ Resulting rendition
96+ormoluFile ::
97+ MonadIO m =>
98+ -- | Ormolu configuration
99+ Config ->
100+ -- | Location of source file
101+ FilePath ->
102+ -- | Resulting rendition
103+ m Text
100104ormoluFile cfg path =
101105 liftIO (readFile path) >>= ormolu cfg path
102106
@@ -104,11 +108,12 @@ ormoluFile cfg path =
104108--
105109-- > ormoluStdin cfg =
106110-- > liftIO (hGetContents stdin) >>= ormolu cfg "<stdin>"
107−
108−ormoluStdin
109− :: MonadIO m
110− => Config -- ^ Ormolu configuration
111− -> m Text -- ^ Resulting rendition
111+ormoluStdin ::
112+ MonadIO m =>
113+ -- | Ormolu configuration
114+ Config ->
115+ -- | Resulting rendition
116+ m Text
112117ormoluStdin cfg =
113118 liftIO (hGetContents stdin) >>= ormolu cfg "<stdin>"
114119
@@ -116,15 +121,17 @@ ormoluStdin cfg =
116121-- Helpers
117122
118123-- | A wrapper around 'parseModule'.
119−
120−parseModule'
121− :: MonadIO m
122− => Config -- ^ Ormolu configuration
123− -> (GHC.SrcSpan -> String -> OrmoluException)
124− -- ^ How to obtain 'OrmoluException' to throw when parsing fails
125− -> FilePath -- ^ File name to use in errors
126− -> String -- ^ Actual input for the parser
127− -> m ([GHC.Warn], ParseResult)
124+parseModule' ::
125+ MonadIO m =>
126+ -- | Ormolu configuration
127+ Config ->
128+ -- | How to obtain 'OrmoluException' to throw when parsing fails
129+ (GHC.SrcSpan -> String -> OrmoluException) ->
130+ -- | File name to use in errors
131+ FilePath ->
132+ -- | Actual input for the parser
133+ String ->
134+ m ([GHC.Warn], ParseResult)
128135parseModule' cfg mkException path str = do
129136 (ws, r) <- parseModule cfg path str
130137 case r of
@@ -132,9 +139,9 @@ parseModule' cfg mkException path str = do
132139 Right x -> return (ws, x)
133140
134141-- | Pretty-print a 'GHC.Warn'.
135−
136142showWarn :: GHC.Warn -> String
137−showWarn (GHC.Warn reason l) = unlines
138− [ showOutputable reason
139− , showOutputable l
140− ]
143+showWarn (GHC.Warn reason l) =
144+ unlines
145+ [ showOutputable reason,
146+ showOutputable l
147+ ]
src/Ormolu/Config.hs+32−33
@@ -1,54 +1,53 @@
11{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE RecordWildCards #-}
44
55-- | Configuration options used by the tool.
6−
76module Ormolu.Config
8− ( Config (..)
9− , defaultConfig
10− , DynOption (..)
11− , dynOptionToLocatedStr
7+ ( Config (..),
8+ defaultConfig,
9+ DynOption (..),
10+ dynOptionToLocatedStr,
1211 )
1312where
1413
1514import qualified SrcLoc as GHC
1615
1716-- | Ormolu configuration.
18−
19−data Config = Config
20− { cfgDynOptions :: ![DynOption]
21− -- ^ Dynamic options to pass to GHC parser
22− , cfgUnsafe :: !Bool
23− -- ^ Do formatting faster but without automatic detection of defects
24− , cfgDebug :: !Bool
25− -- ^ Output information useful for debugging
26− , cfgTolerateCpp :: !Bool
27− -- ^ Do not fail if CPP pragma is present (still doesn't handle CPP but
28− -- useful for formatting of files that enable the extension without
29− -- actually containing CPP macros)
30− , cfgCheckIdempotency :: !Bool
31− -- ^ Checks if re-formatting the result is idempotent.
32− } deriving (Eq, Show)
17+data Config
18+ = Config
19+ { -- | Dynamic options to pass to GHC parser
20+ cfgDynOptions :: ![DynOption],
21+ -- | Do formatting faster but without automatic detection of defects
22+ cfgUnsafe :: !Bool,
23+ -- | Output information useful for debugging
24+ cfgDebug :: !Bool,
25+ -- | Do not fail if CPP pragma is present (still doesn't handle CPP but
26+ -- useful for formatting of files that enable the extension without
27+ -- actually containing CPP macros)
28+ cfgTolerateCpp :: !Bool,
29+ -- | Checks if re-formatting the result is idempotent.
30+ cfgCheckIdempotency :: !Bool
31+ }
32+ deriving (Eq, Show)
3333
3434-- | Default 'Config'.
35−
3635defaultConfig :: Config
3736defaultConfig = Config
38− { cfgDynOptions = []
39− , cfgUnsafe = False
40− , cfgDebug = False
41− , cfgTolerateCpp = False
42− , cfgCheckIdempotency = False
37+ { cfgDynOptions = [],
38+ cfgUnsafe = False,
39+ cfgDebug = False,
40+ cfgTolerateCpp = False,
41+ cfgCheckIdempotency = False
4342 }
4443
4544-- | A wrapper for dynamic options.
46−
47−newtype DynOption = DynOption
48− { unDynOption :: String
49− } deriving (Eq, Ord, Show)
45+newtype DynOption
46+ = DynOption
47+ { unDynOption :: String
48+ }
49+ deriving (Eq, Ord, Show)
5050
5151-- | Convert 'DynOption' to @'GHC.Located' 'String'@.
52−
5352dynOptionToLocatedStr :: DynOption -> GHC.Located String
5453dynOptionToLocatedStr (DynOption o) = GHC.L GHC.noSrcSpan o
src/Ormolu/Diff.hs+65−61
@@ -1,13 +1,12 @@
11{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE RankNTypes #-}
3−{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE RankNTypes #-}
3+{-# LANGUAGE RecordWildCards #-}
44
55-- | Diffing GHC ASTs modulo span positions.
6−
76module Ormolu.Diff
8− ( Diff(..)
9− , diffParseResult
10− , diffText
7+ ( Diff (..),
8+ diffParseResult,
9+ diffText,
1110 )
1211where
1312
@@ -15,19 +14,20 @@ import BasicTypes (SourceText)
1514import Data.ByteString (ByteString)
1615import Data.Generics
1716import Data.Text (Text)
17+import qualified Data.Text as T
18+import qualified FastString as GHC
1819import GHC
1920import Ormolu.Imports (sortImports)
2021import Ormolu.Parser.Result
2122import Ormolu.Utils
22−import qualified Data.Text as T
23−import qualified FastString as GHC
2423import qualified SrcLoc as GHC
2524
2625-- | Result of comparing two 'ParseResult's.
27−
2826data Diff
29− = Same -- ^ Two parse results are the same
30− | Different [SrcSpan] -- ^ Two parse results differ
27+ = -- | Two parse results are the same
28+ Same
29+ | -- | Two parse results differ
30+ Different [SrcSpan]
3131
3232instance Semigroup Diff where
3333 Same <> a = a
@@ -38,21 +38,21 @@ instance Monoid Diff where
3838 mempty = Same
3939
4040-- | Return 'Diff' of two 'ParseResult's.
41−
4241diffParseResult :: ParseResult -> ParseResult -> Diff
4342diffParseResult
44− ParseResult { prCommentStream = cstream0
45− , prParsedSource = ps0
46− }
47− ParseResult { prCommentStream = cstream1
48− , prParsedSource = ps1
49− } =
50− matchIgnoringSrcSpans cstream0 cstream1 <>
51− matchIgnoringSrcSpans ps0 ps1
43+ ParseResult
44+ { prCommentStream = cstream0,
45+ prParsedSource = ps0
46+ }
47+ ParseResult
48+ { prCommentStream = cstream1,
49+ prParsedSource = ps1
50+ } =
51+ matchIgnoringSrcSpans cstream0 cstream1
52+ <> matchIgnoringSrcSpans ps0 ps1
5253
5354-- | Compare two values for equality disregarding differences in 'SrcSpan's
5455-- and the ordering of import lists.
55−
5656matchIgnoringSrcSpans :: Data a => a -> a -> Diff
5757matchIgnoringSrcSpans = genericQuery
5858 where
@@ -60,36 +60,37 @@ matchIgnoringSrcSpans = genericQuery
6060 genericQuery x y
6161 -- NOTE 'ByteString' implement 'Data' instance manually and does not
6262 -- implement 'toConstr', so we have to deal with it in a special way.
63− | Just x' <- cast x, Just y' <- cast y =
63+ | Just x' <- cast x,
64+ Just y' <- cast y =
6465 if x' == (y' :: ByteString)
6566 then Same
6667 else Different []
67− | typeOf x == typeOf y, toConstr x == toConstr y =
68− mconcat $ gzipWithQ
69− (genericQuery
70− `extQ` srcSpanEq
71− `extQ` hsModuleEq
72− `extQ` sourceTextEq
73− `extQ` hsDocStringEq
74− `ext2Q` forLocated)
75− x y
68+ | typeOf x == typeOf y,
69+ toConstr x == toConstr y =
70+ mconcat $
71+ gzipWithQ
72+ ( genericQuery
73+ `extQ` srcSpanEq
74+ `extQ` hsModuleEq
75+ `extQ` sourceTextEq
76+ `extQ` hsDocStringEq
77+ `ext2Q` forLocated
78+ )
79+ x
80+ y
7681 | otherwise = Different []
77−
7882 srcSpanEq :: SrcSpan -> GenericQ Diff
7983 srcSpanEq _ _ = Same
80−
8184 hsModuleEq :: HsModule GhcPs -> GenericQ Diff
8285 hsModuleEq hs0 hs1' =
8386 case cast hs1' :: Maybe (HsModule GhcPs) of
8487 Nothing -> Different []
8588 Just hs1 ->
8689 matchIgnoringSrcSpans
87− hs0 { hsmodImports = sortImports (hsmodImports hs0) }
88− hs1 { hsmodImports = sortImports (hsmodImports hs1) }
89−
90+ hs0 {hsmodImports = sortImports (hsmodImports hs0)}
91+ hs1 {hsmodImports = sortImports (hsmodImports hs1)}
9092 sourceTextEq :: SourceText -> GenericQ Diff
9193 sourceTextEq _ _ = Same
92−
9394 hsDocStringEq :: HsDocString -> GenericQ Diff
9495 hsDocStringEq str0 str1' =
9596 case cast str1' :: Maybe HsDocString of
@@ -98,16 +99,14 @@ matchIgnoringSrcSpans = genericQuery
9899 if splitDocString str0 == splitDocString str1
99100 then Same
100101 else Different []
101−
102− forLocated
103− :: (Data e0, Data e1)
104− => GenLocated e0 e1
105− -> GenericQ Diff
102+ forLocated ::
103+ (Data e0, Data e1) =>
104+ GenLocated e0 e1 ->
105+ GenericQ Diff
106106 forLocated x@(L mspn _) y =
107107 maybe id appendSpan (cast mspn) (genericQuery x y)
108−
109108 appendSpan :: SrcSpan -> Diff -> Diff
110− appendSpan s (Different ss) | fresh && helpful = Different (s:ss)
109+ appendSpan s (Different ss) | fresh && helpful = Different (s : ss)
111110 where
112111 fresh = not $ any (flip isSubspanOf s) ss
113112 helpful = isGoodSrcSpan s
@@ -115,32 +114,37 @@ matchIgnoringSrcSpans = genericQuery
115114
116115-- | Diff two texts and return the location they start to differ, alongside
117116-- with excerpts around that location.
118−
119−diffText
120− :: Text -- ^ Text before
121− -> Text -- ^ Text after
122− -> FilePath -- ^ Path to use to construct 'GHC.RealSrcLoc'
123− -> Maybe (GHC.RealSrcLoc, Text, Text)
117+diffText ::
118+ -- | Text before
119+ Text ->
120+ -- | Text after
121+ Text ->
122+ -- | Path to use to construct 'GHC.RealSrcLoc'
123+ FilePath ->
124+ Maybe (GHC.RealSrcLoc, Text, Text)
124125diffText left right fp =
125126 case go (0, 0, 0) left right of
126127 Nothing -> Nothing
127− Just (row, col, loc) -> Just (
128− GHC.mkRealSrcLoc (GHC.mkFastString fp) row col,
129− getSpan loc left,
130− getSpan loc right
131− )
128+ Just (row, col, loc) ->
129+ Just
130+ ( GHC.mkRealSrcLoc (GHC.mkFastString fp) row col,
131+ getSpan loc left,
132+ getSpan loc right
133+ )
132134 where
133− go (row, col, loc) t1 t2 =
135+ go (row, col, loc) t1 t2 =
134136 case (T.uncons t1, T.uncons t2) of
135137 -- both text empty, all good
136138 (Nothing, Nothing) ->
137139 Nothing
138140 -- first chars are the same, adjust position and recurse
139− (Just (c1, r1), Just (c2, r2)) | c1 == c2 ->
140− let (row', col', loc') = if c1 == '\n'
141− then (row + 1, 0, loc + 1)
142− else (row, col + 1, loc + 1)
143− in go (row', col', loc') r1 r2
141+ (Just (c1, r1), Just (c2, r2))
142+ | c1 == c2 ->
143+ let (row', col', loc') =
144+ if c1 == '\n'
145+ then (row + 1, 0, loc + 1)
146+ else (row, col + 1, loc + 1)
147+ in go (row', col', loc') r1 r2
144148 -- something is different, return the position
145149 _ ->
146150 Just (row, col, loc)
src/Ormolu/Exception.hs+41−40
@@ -1,65 +1,66 @@
11{-# LANGUAGE LambdaCase #-}
22
33-- | 'OrmoluException' type and surrounding definitions.
4−
54module Ormolu.Exception
6− ( OrmoluException (..)
7− , withPrettyOrmoluExceptions
5+ ( OrmoluException (..),
6+ withPrettyOrmoluExceptions,
87 )
98where
109
1110import Control.Exception
1211import Data.Text (Text)
12+import qualified GHC
1313import Ormolu.Utils (showOutputable)
14+import qualified Outputable as GHC
1415import System.Exit (ExitCode (..), exitWith)
1516import System.IO
16−import qualified GHC
17−import qualified Outputable as GHC
1817
1918-- | Ormolu exception representing all cases when Ormolu can fail.
20−
2119data OrmoluException
22− = OrmoluCppEnabled FilePath
23− -- ^ Ormolu does not work with source files that use CPP
24− | OrmoluParsingFailed GHC.SrcSpan String
25− -- ^ Parsing of original source code failed
26− | OrmoluOutputParsingFailed GHC.SrcSpan String
27− -- ^ Parsing of formatted source code failed
28− | OrmoluASTDiffers FilePath [GHC.SrcSpan]
29− -- ^ Original and resulting ASTs differ
30− | OrmoluNonIdempotentOutput GHC.RealSrcLoc Text Text
31− -- ^ Formatted source code is not idempotent
20+ = -- | Ormolu does not work with source files that use CPP
21+ OrmoluCppEnabled FilePath
22+ | -- | Parsing of original source code failed
23+ OrmoluParsingFailed GHC.SrcSpan String
24+ | -- | Parsing of formatted source code failed
25+ OrmoluOutputParsingFailed GHC.SrcSpan String
26+ | -- | Original and resulting ASTs differ
27+ OrmoluASTDiffers FilePath [GHC.SrcSpan]
28+ | -- | Formatted source code is not idempotent
29+ OrmoluNonIdempotentOutput GHC.RealSrcLoc Text Text
3230 deriving (Eq, Show)
3331
3432instance Exception OrmoluException where
3533 displayException = \case
36− OrmoluCppEnabled path -> unlines
37− [ "CPP is not supported:"
38− , withIndent path
39− ]
34+ OrmoluCppEnabled path ->
35+ unlines
36+ [ "CPP is not supported:",
37+ withIndent path
38+ ]
4039 OrmoluParsingFailed s e ->
4140 showParsingErr "Parsing of source code failed:" s [e]
4241 OrmoluOutputParsingFailed s e ->
43− showParsingErr "Parsing of formatted code failed:" s [e] ++
44− "Please, consider reporting the bug.\n"
45− OrmoluASTDiffers path ss -> unlines $
46− [ "AST of input and AST of formatted code differ."
47− ]
48− ++ (fmap withIndent $ case fmap (\s -> "at " ++ showOutputable s) ss of
49− [] -> ["in " ++ path]
50− xs -> xs) ++
51− [ "Please, consider reporting the bug." ]
42+ showParsingErr "Parsing of formatted code failed:" s [e]
43+ ++ "Please, consider reporting the bug.\n"
44+ OrmoluASTDiffers path ss ->
45+ unlines $
46+ [ "AST of input and AST of formatted code differ."
47+ ]
48+ ++ ( fmap withIndent $ case fmap (\s -> "at " ++ showOutputable s) ss of
49+ [] -> ["in " ++ path]
50+ xs -> xs
51+ )
52+ ++ ["Please, consider reporting the bug."]
5253 OrmoluNonIdempotentOutput loc left right ->
5354 showParsingErr "Formatting is not idempotent:" loc
54− [ "before: " ++ show left , "after: " ++ show right ]
55+ ["before: " ++ show left, "after: " ++ show right]
5556 ++ "Please, consider reporting the bug.\n"
5657
5758-- | Inside this wrapper 'OrmoluException' will be caught and displayed
5859-- nicely using 'displayException'.
59−
60−withPrettyOrmoluExceptions
61− :: IO a -- ^ Action that may throw the exception
62− -> IO a
60+withPrettyOrmoluExceptions ::
61+ -- | Action that may throw the exception
62+ IO a ->
63+ IO a
6364withPrettyOrmoluExceptions m = m `catch` h
6465 where
6566 h :: OrmoluException -> IO a
@@ -78,14 +79,14 @@ withPrettyOrmoluExceptions m = m `catch` h
7879-- Helpers
7980
8081-- | Show a parse error.
81−
8282showParsingErr :: GHC.Outputable a => String -> a -> [String] -> String
83−showParsingErr msg spn err = unlines $
84− [ msg
85− , withIndent (showOutputable spn)
86− ] ++ map withIndent err
83+showParsingErr msg spn err =
84+ unlines $
85+ [ msg,
86+ withIndent (showOutputable spn)
87+ ]
88+ ++ map withIndent err
8789
8890-- | Indent with 2 spaces for readability.
89−
9091withIndent :: String -> String
9192withIndent txt = " " ++ txt
src/Ormolu/Imports.hs+4−11
@@ -2,9 +2,8 @@
22{-# LANGUAGE RankNTypes #-}
33
44-- | Manipulations on import lists.
5−
65module Ormolu.Imports
7− ( sortImports
6+ ( sortImports,
87 )
98where
109
@@ -19,17 +18,16 @@ import Ormolu.Utils (notImplemented)
1918
2019-- | Sort imports by module name. This also sorts explicit import lists for
2120-- each declaration.
22−
2321sortImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs]
2422sortImports = sortBy compareIdecl . fmap (fmap sortImportLists)
2523 where
2624 sortImportLists :: ImportDecl GhcPs -> ImportDecl GhcPs
2725 sortImportLists decl =
28− decl { ideclHiding = second (fmap sortLies) <$> ideclHiding decl
29− }
26+ decl
27+ { ideclHiding = second (fmap sortLies) <$> ideclHiding decl
28+ }
3029
3130-- | Compare two @'LImportDecl' 'GhcPs'@ things.
32−
3331compareIdecl :: LImportDecl GhcPs -> LImportDecl GhcPs -> Ordering
3432compareIdecl (L _ m0) (L _ m1) =
3533 case (isPrelude n0, isPrelude n1) of
@@ -43,12 +41,10 @@ compareIdecl (L _ m0) (L _ m1) =
4341 isPrelude = (== "Prelude") . moduleNameString
4442
4543-- | Sort located import or export.
46−
4744sortLies :: [LIE GhcPs] -> [LIE GhcPs]
4845sortLies = sortBy (compareIE `on` unLoc) . fmap (fmap sortThings)
4946
5047-- | Sort imports\/exports inside of 'IEThingWith'.
51−
5248sortThings :: IE GhcPs -> IE GhcPs
5349sortThings = \case
5450 IEThingWith NoExt x w xs fl ->
@@ -56,12 +52,10 @@ sortThings = \case
5652 other -> other
5753
5854-- | Compare two located imports or exports.
59−
6055compareIE :: IE GhcPs -> IE GhcPs -> Ordering
6156compareIE = compareIewn `on` getIewn
6257
6358-- | Project @'IEWrappedName' 'RdrName'@ from @'IE' 'GhcPs'@.
64−
6559getIewn :: IE GhcPs -> IEWrappedName RdrName
6660getIewn = \case
6761 IEVar NoExt x -> unLoc x
@@ -75,7 +69,6 @@ getIewn = \case
7569 XIE NoExt -> notImplemented "XIE"
7670
7771-- | Compare two @'IEWrapppedName' 'RdrName'@ things.
78−
7972compareIewn :: IEWrappedName RdrName -> IEWrappedName RdrName -> Ordering
8073compareIewn (IEName x) (IEName y) = unLoc x `compare` unLoc y
8174compareIewn (IEName _) (IEPattern _) = LT
src/Ormolu/Parser.hs+85−79
@@ -1,97 +1,99 @@
1−{-# LANGUAGE RecordWildCards #-}
1+{-# LANGUAGE RecordWildCards #-}
22{-# LANGUAGE StandaloneDeriving #-}
33{-# OPTIONS_GHC -fno-warn-orphans #-}
44
55-- | Parser for Haskell source code.
6−
76module Ormolu.Parser
8− ( parseModule
9− , manualExts
7+ ( parseModule,
8+ manualExts,
109 )
1110where
1211
12+import qualified CmdLineParser as GHC
1313import Control.Exception
1414import Control.Monad
1515import Control.Monad.IO.Class
16−import Data.List (isPrefixOf, foldl', (\\))
16+import Data.List ((\\), foldl', isPrefixOf)
1717import Data.Maybe (catMaybes)
18+import qualified DynFlags as GHC
19+import qualified FastString as GHC
1820import GHC hiding (IE, parseModule, parser)
1921import GHC.LanguageExtensions.Type (Extension (..))
2022import GHC.Paths (libdir)
23+import qualified HeaderInfo as GHC
24+import qualified Lexer as GHC
2125import Ormolu.Config
2226import Ormolu.Exception
2327import Ormolu.Parser.Anns
2428import Ormolu.Parser.CommentStream
2529import Ormolu.Parser.Result
26−import qualified CmdLineParser as GHC
27−import qualified DynFlags as GHC
28−import qualified FastString as GHC
29−import qualified HeaderInfo as GHC
30−import qualified Lexer as GHC
3130import qualified Outputable as GHC
3231import qualified Parser as GHC
3332import qualified SrcLoc as GHC
3433import qualified StringBuffer as GHC
3534
3635-- | Parse a complete module from string.
37−
38−parseModule
39− :: MonadIO m
40− => Config -- ^ Ormolu configuration
41− -> FilePath -- ^ File name (only for source location annotations)
42− -> String -- ^ Input for parser
43− -> m ( [GHC.Warn]
44− , Either (SrcSpan, String) ParseResult
45− )
36+parseModule ::
37+ MonadIO m =>
38+ -- | Ormolu configuration
39+ Config ->
40+ -- | File name (only for source location annotations)
41+ FilePath ->
42+ -- | Input for parser
43+ String ->
44+ m
45+ ( [GHC.Warn],
46+ Either (SrcSpan, String) ParseResult
47+ )
4648parseModule Config {..} path input' = liftIO $ do
4749 let (input, extraComments) = stripLinePragmas path input'
4850 (ws, dynFlags) <- ghcWrapper $ do
4951 dynFlags0 <- initDynFlagsPure path input
50− (dynFlags1, _, ws) <- GHC.parseDynamicFilePragma
51− dynFlags0
52− (dynOptionToLocatedStr <$> cfgDynOptions)
52+ (dynFlags1, _, ws) <-
53+ GHC.parseDynamicFilePragma
54+ dynFlags0
55+ (dynOptionToLocatedStr <$> cfgDynOptions)
5356 return (ws, GHC.setGeneralFlag' GHC.Opt_Haddock dynFlags1)
5457 -- NOTE It's better to throw this outside of 'ghcWrapper' because
5558 -- otherwise the exception will be wrapped as a GHC panic, which we don't
5659 -- want.
5760 when (GHC.xopt Cpp dynFlags && not cfgTolerateCpp) $
58− throwIO (OrmoluCppEnabled path)
61+ throwIO (OrmoluCppEnabled path)
5962 let r = case runParser GHC.parseModule dynFlags path input of
6063 GHC.PFailed _ ss m ->
6164 Left (ss, GHC.showSDoc dynFlags m)
6265 GHC.POk pstate pmod ->
6366 let (comments, exts) = mkCommentStream extraComments pstate
64− in Right ParseResult
65− { prParsedSource = pmod
66− , prAnns = mkAnns pstate
67− , prCommentStream = comments
68− , prExtensions = exts
69− }
67+ in Right ParseResult
68+ { prParsedSource = pmod,
69+ prAnns = mkAnns pstate,
70+ prCommentStream = comments,
71+ prExtensions = exts
72+ }
7073 return (ws, r)
7174
7275-- | Extensions that are not enabled automatically and should be activated
7376-- by user.
74−
7577manualExts :: [Extension]
7678manualExts =
77− [ Arrows -- steals proc
78− , Cpp -- forbidden
79− , BangPatterns -- makes certain patterns with ! fail
80− , PatternSynonyms -- steals the pattern keyword
81− , RecursiveDo -- steals the rec keyword
82− , StaticPointers -- steals static keyword
83− , TransformListComp -- steals the group keyword
84− , UnboxedTuples -- breaks (#) lens operator
85− , MagicHash -- screws {-# these things #-}
86− , TypeApplications -- steals (@) operator on some cases
87− , AlternativeLayoutRule
88− , AlternativeLayoutRuleTransitional
89− , MonadComprehensions
90− , UnboxedSums
91− , UnicodeSyntax -- gives special meanings to operators like (→)
92− , TemplateHaskellQuotes -- enables TH subset of quasi-quotes, this
93− -- apparently interferes with QuasiQuotes in
94− -- weird ways
79+ [ Arrows, -- steals proc
80+ Cpp, -- forbidden
81+ BangPatterns, -- makes certain patterns with ! fail
82+ PatternSynonyms, -- steals the pattern keyword
83+ RecursiveDo, -- steals the rec keyword
84+ StaticPointers, -- steals static keyword
85+ TransformListComp, -- steals the group keyword
86+ UnboxedTuples, -- breaks (#) lens operator
87+ MagicHash, -- screws {-# these things #-}
88+ TypeApplications, -- steals (@) operator on some cases
89+ AlternativeLayoutRule,
90+ AlternativeLayoutRuleTransitional,
91+ MonadComprehensions,
92+ UnboxedSums,
93+ UnicodeSyntax, -- gives special meanings to operators like (→)
94+ TemplateHaskellQuotes -- enables TH subset of quasi-quotes, this
95+ -- apparently interferes with QuasiQuotes in
96+ -- weird ways
9597 ]
9698
9799----------------------------------------------------------------------------
@@ -106,12 +108,14 @@ manualExts =
106108-- environment files. However this only works if there is no invocation of
107109-- 'setSessionDynFlags' before calling 'initDynFlagsPure'. See GHC tickets
108110-- #15513, #15541.
109−
110−initDynFlagsPure
111− :: GHC.GhcMonad m
112− => FilePath -- ^ Module path
113− -> String -- ^ Module contents
114− -> m GHC.DynFlags -- ^ Dynamic flags for that module
111+initDynFlagsPure ::
112+ GHC.GhcMonad m =>
113+ -- | Module path
114+ FilePath ->
115+ -- | Module contents
116+ String ->
117+ -- | Dynamic flags for that module
118+ m GHC.DynFlags
115119initDynFlagsPure fp input = do
116120 -- I was told we could get away with using the 'unsafeGlobalDynFlags'. as
117121 -- long as 'parseDynamicFilePragma' is impure there seems to be no reason
@@ -122,28 +126,32 @@ initDynFlagsPure fp input = do
122126 -- Turn this on last to avoid T10942
123127 let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream
124128 -- Prevent parsing of .ghc.environment.* "package environment files"
125− (dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine
126− dflags2
127− [GHC.noLoc "-hide-all-packages"]
129+ (dflags3, _, _) <-
130+ GHC.parseDynamicFlagsCmdLine
131+ dflags2
132+ [GHC.noLoc "-hide-all-packages"]
128133 _ <- GHC.setSessionDynFlags dflags3
129134 return dflags3
130135
131136-- | Default runner of 'GHC.Ghc' action in 'IO'.
132−
133137ghcWrapper :: GHC.Ghc a -> IO a
134138ghcWrapper act =
135139 let GHC.FlushOut flushOut = GHC.defaultFlushOut
136− in GHC.runGhc (Just libdir) act
140+ in GHC.runGhc (Just libdir) act
137141 `finally` flushOut
138142
139143-- | Run a 'GHC.P' computation.
140−
141−runParser
142− :: GHC.P a -- ^ Computation to run
143− -> GHC.DynFlags -- ^ Dynamic flags
144− -> FilePath -- ^ Module path
145− -> String -- ^ Module contents
146− -> GHC.ParseResult a -- ^ Parse result
144+runParser ::
145+ -- | Computation to run
146+ GHC.P a ->
147+ -- | Dynamic flags
148+ GHC.DynFlags ->
149+ -- | Module path
150+ FilePath ->
151+ -- | Module contents
152+ String ->
153+ -- | Parse result
154+ GHC.ParseResult a
147155runParser parser flags filename input = GHC.unP parser parseState
148156 where
149157 location = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1
@@ -152,44 +160,42 @@ runParser parser flags filename input = GHC.unP parser parseState
152160
153161-- | Remove GHC style line pragams (@{-# LINE .. #-}@) and convert them into
154162-- comments.
155−
156163stripLinePragmas :: FilePath -> String -> (String, [Located String])
157164stripLinePragmas path = unlines' . unzip . findLines path . lines
158165 where
159166 unlines' (a, b) = (unlines a, catMaybes b)
160167
161168findLines :: FilePath -> [String] -> [(String, Maybe (Located String))]
162−findLines path = zipWith (checkLine path) [1..]
169+findLines path = zipWith (checkLine path) [1 ..]
163170
164171checkLine :: FilePath -> Int -> String -> (String, Maybe (Located String))
165172checkLine path line s
166173 | "{-# LINE" `isPrefixOf` s =
167− let (pragma, res) = getPragma s
168− size = length pragma
169− ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (size + 1))
170− in (res, Just $ L ss pragma)
174+ let (pragma, res) = getPragma s
175+ size = length pragma
176+ ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (size + 1))
177+ in (res, Just $ L ss pragma)
171178 | "#!" `isPrefixOf` s =
172− let ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (length s))
173− in ("",Just $ L ss s)
179+ let ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (length s))
180+ in ("", Just $ L ss s)
174181 | otherwise = (s, Nothing)
175182 where
176183 mkSrcLoc' = mkSrcLoc (GHC.mkFastString path) line
177184
178185getPragma :: String -> (String, String)
179186getPragma [] = error "Ormolu.Parser.getPragma: input must not be empty"
180−getPragma s@(x:xs)
187+getPragma s@(x : xs)
181188 | "#-}" `isPrefixOf` s = ("#-}", " " ++ drop 3 s)
182189 | otherwise =
183− let (prag, remline) = getPragma xs
184− in (x:prag, ' ':remline)
190+ let (prag, remline) = getPragma xs
191+ in (x : prag, ' ' : remline)
185192
186193-- | Enable all language extensions that we think should be enabled by
187194-- default for ease of use.
188−
189195setDefaultExts :: DynFlags -> DynFlags
190196setDefaultExts flags = foldl' GHC.xopt_set flags autoExts
191197 where
192198 autoExts = allExts \\ manualExts
193− allExts = [minBound..maxBound]
199+ allExts = [minBound .. maxBound]
194200
195201deriving instance Bounded Extension
src/Ormolu/Parser/Anns.hs+18−20
@@ -1,37 +1,34 @@
11-- | Ormolu-specific representation of GHC annotations.
2−
32module Ormolu.Parser.Anns
4− ( Anns (..)
5− , emptyAnns
6− , mkAnns
7− , lookupAnns
3+ ( Anns (..),
4+ emptyAnns,
5+ mkAnns,
6+ lookupAnns,
87 )
98where
109
1110import Data.Map.Strict (Map)
12−import Data.Maybe (mapMaybe)
13−import SrcLoc
1411import qualified Data.Map.Strict as M
12+import Data.Maybe (mapMaybe)
1513import qualified GHC
1614import qualified Lexer as GHC
15+import SrcLoc
1716
1817-- | Ormolu-specific representation of GHC annotations.
19−
2018newtype Anns = Anns (Map RealSrcSpan [GHC.AnnKeywordId])
2119 deriving (Eq)
2220
2321-- | Empty 'Anns'.
24−
2522emptyAnns :: Anns
2623emptyAnns = Anns M.empty
2724
2825-- | Create 'Anns' from 'GHC.PState'.
29−
30−mkAnns
31− :: GHC.PState
32− -> Anns
33−mkAnns pstate = Anns $
34− M.fromListWith (++) (mapMaybe f (GHC.annotations pstate))
26+mkAnns ::
27+ GHC.PState ->
28+ Anns
29+mkAnns pstate =
30+ Anns $
31+ M.fromListWith (++) (mapMaybe f (GHC.annotations pstate))
3532 where
3633 f ((spn, kid), _) =
3734 case spn of
@@ -39,10 +36,11 @@ mkAnns pstate = Anns $
3936 UnhelpfulSpan _ -> Nothing
4037
4138-- | Lookup 'GHC.AnnKeywordId's corresponding to a given 'SrcSpan'.
42−
43−lookupAnns
44− :: SrcSpan -- ^ Span to lookup with
45− -> Anns -- ^ Collection of annotations
46− -> [GHC.AnnKeywordId]
39+lookupAnns ::
40+ -- | Span to lookup with
41+ SrcSpan ->
42+ -- | Collection of annotations
43+ Anns ->
44+ [GHC.AnnKeywordId]
4745lookupAnns (RealSrcSpan rspn) (Anns m) = M.findWithDefault [] rspn m
4846lookupAnns (UnhelpfulSpan _) _ = []
src/Ormolu/Parser/CommentStream.hs+48−53
@@ -1,87 +1,84 @@
1−{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
33{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4−{-# LANGUAGE LambdaCase #-}
5−{-# LANGUAGE TupleSections #-}
4+{-# LANGUAGE LambdaCase #-}
5+{-# LANGUAGE TupleSections #-}
66
77-- | Functions for working with comment stream.
8−
98module Ormolu.Parser.CommentStream
10− ( CommentStream (..)
11− , Comment (..)
12− , mkCommentStream
13− , isPrevHaddock
14− , isMultilineComment
15− , showCommentStream
9+ ( CommentStream (..),
10+ Comment (..),
11+ mkCommentStream,
12+ isPrevHaddock,
13+ isMultilineComment,
14+ showCommentStream,
1615 )
1716where
1817
1918import Data.Char (isSpace)
2019import Data.Data (Data)
2120import Data.Either (partitionEithers)
22−import Data.List (isPrefixOf, sortOn, dropWhileEnd)
21+import Data.List (dropWhileEnd, isPrefixOf, sortOn)
2322import Data.List.NonEmpty (NonEmpty (..))
23+import qualified Data.List.NonEmpty as NE
2424import Data.Maybe (mapMaybe)
25+import qualified GHC
26+import qualified Lexer as GHC
2527import Ormolu.Parser.Pragma
2628import Ormolu.Utils (showOutputable)
2729import SrcLoc
28−import qualified Data.List.NonEmpty as NE
29−import qualified GHC
30−import qualified Lexer as GHC
3130
3231-- | A stream of 'RealLocated' 'Comment's in ascending order with respect to
3332-- beginning of corresponding spans.
34−
3533newtype CommentStream = CommentStream [RealLocated Comment]
3634 deriving (Eq, Data, Semigroup, Monoid)
3735
3836-- | A wrapper for a single comment. The 'NonEmpty' list inside contains
3937-- lines of multiline comment @{- … -}@ or just single item\/line otherwise.
40−
4138newtype Comment = Comment (NonEmpty String)
4239 deriving (Eq, Show, Data)
4340
4441-- | Create 'CommentStream' from 'GHC.PState'. We also create a 'Set' of
4542-- extensions here, which is not sorted in any way. The pragma comment are
4643-- removed from the 'CommentStream'.
47−
48−mkCommentStream
49− :: [Located String] -- ^ Extra comments to include
50− -> GHC.PState -- ^ Parser state to use for comment extraction
51− -> (CommentStream, [Pragma])
52− -- ^ Comment stream and a set of extracted pragmas
44+mkCommentStream ::
45+ -- | Extra comments to include
46+ [Located String] ->
47+ -- | Parser state to use for comment extraction
48+ GHC.PState ->
49+ -- | Comment stream and a set of extracted pragmas
50+ (CommentStream, [Pragma])
5351mkCommentStream extraComments pstate =
5452 ( CommentStream $
5553 -- NOTE It's easier to normalize pragmas right when we construct comment
5654 -- streams. Because this way we need to do it only once and when we
5755 -- perform checking later they'll automatically match.
58− mkComment <$> sortOn (realSrcSpanStart . getLoc) comments
59− , pragmas
56+ mkComment <$> sortOn (realSrcSpanStart . getLoc) comments,
57+ pragmas
6058 )
6159 where
6260 (comments, pragmas) = partitionEithers (partitionComments <$> rawComments)
63− rawComments = mapMaybe toRealSpan $
64− extraComments ++
65− mapMaybe (liftMaybe . fmap unAnnotationComment) (GHC.comment_q pstate) ++
66− concatMap (mapMaybe (liftMaybe . fmap unAnnotationComment) . snd)
67− (GHC.annotations_comments pstate)
61+ rawComments =
62+ mapMaybe toRealSpan $
63+ extraComments
64+ ++ mapMaybe (liftMaybe . fmap unAnnotationComment) (GHC.comment_q pstate)
65+ ++ concatMap (mapMaybe (liftMaybe . fmap unAnnotationComment) . snd)
66+ (GHC.annotations_comments pstate)
6867
6968-- | Test whether a 'Comment' looks like a Haddock following a definition,
7069-- i.e. something starting with @-- ^@.
71−
7270isPrevHaddock :: Comment -> Bool
7371isPrevHaddock (Comment (x :| _)) = "-- ^" `isPrefixOf` x
7472
7573-- | Is this comment multiline-style?
76−
7774isMultilineComment :: Comment -> Bool
7875isMultilineComment (Comment (x :| _)) = "{-" `isPrefixOf` x
7976
8077-- | Pretty-print a 'CommentStream'.
81−
8278showCommentStream :: CommentStream -> String
83−showCommentStream (CommentStream xs) = unlines $
84− showComment <$> xs
79+showCommentStream (CommentStream xs) =
80+ unlines $
81+ showComment <$> xs
8582 where
8683 showComment (GHC.L l str) = showOutputable l ++ " " ++ show str
8784
@@ -91,26 +88,25 @@ showCommentStream (CommentStream xs) = unlines $
9188-- | Normalize comment string. Sometimes one multi-line comment is turned
9289-- into several lines for subsequent outputting with correct indentation for
9390-- each line.
94−
9591mkComment :: RealLocated String -> RealLocated Comment
96−mkComment (L l s) = L l . Comment . fmap dropTrailing $
97− if "{-" `isPrefixOf` s
98− then case NE.nonEmpty (lines s) of
99− Nothing -> s :| []
100− Just (x:|xs) ->
101− let getIndent y =
102− if all isSpace y
103− then startIndent
104− else length (takeWhile isSpace y)
105− n = minimum (startIndent : fmap getIndent xs)
106− in x :| (drop n <$> xs)
107− else s :| []
92+mkComment (L l s) =
93+ L l . Comment . fmap dropTrailing $
94+ if "{-" `isPrefixOf` s
95+ then case NE.nonEmpty (lines s) of
96+ Nothing -> s :| []
97+ Just (x :| xs) ->
98+ let getIndent y =
99+ if all isSpace y
100+ then startIndent
101+ else length (takeWhile isSpace y)
102+ n = minimum (startIndent : fmap getIndent xs)
103+ in x :| (drop n <$> xs)
104+ else s :| []
108105 where
109106 dropTrailing = dropWhileEnd isSpace
110107 startIndent = srcSpanStartCol l - 1
111108
112109-- | Get a 'String' from 'GHC.AnnotationComment'.
113−
114110unAnnotationComment :: GHC.AnnotationComment -> Maybe String
115111unAnnotationComment = \case
116112 GHC.AnnDocCommentNext _ -> Nothing -- @-- |@
@@ -132,10 +128,9 @@ toRealSpan _ = Nothing
132128
133129-- | If a given comment is a pragma, return it in parsed form in 'Right'.
134130-- Otherwise return the original comment unchanged.
135−
136−partitionComments
137− :: RealLocated String
138− -> Either (RealLocated String) Pragma
131+partitionComments ::
132+ RealLocated String ->
133+ Either (RealLocated String) Pragma
139134partitionComments input =
140135 case parsePragma (unLoc input) of
141136 Nothing -> Left input
src/Ormolu/Parser/Pragma.hs+24−26
@@ -1,38 +1,39 @@
1−-- | A module for parsing of pragmas from comments.
2−
3−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
42{-# LANGUAGE OverloadedStrings #-}
53
4+-- | A module for parsing of pragmas from comments.
65module Ormolu.Parser.Pragma
7− ( Pragma (..)
8− , parsePragma
6+ ( Pragma (..),
7+ parsePragma,
98 )
109where
1110
1211import Control.Monad
13−import Data.Char (toLower, isSpace)
12+import Data.Char (isSpace, toLower)
1413import Data.List
14+import qualified EnumSet as ES
1515import FastString (mkFastString, unpackFS)
16−import Module (newSimpleUnitId, ComponentId (..))
16+import qualified Lexer as L
17+import Module (ComponentId (..), newSimpleUnitId)
1718import SrcLoc
1819import StringBuffer
19−import qualified EnumSet as ES
20−import qualified Lexer as L
2120
2221-- | Ormolu's representation of pragmas.
23−
2422data Pragma
25− = PragmaLanguage [String] -- ^ Language pragma
26− | PragmaOptionsGHC String -- ^ GHC options pragma
27− | PragmaOptionsHaddock String -- ^ Haddock options pragma
23+ = -- | Language pragma
24+ PragmaLanguage [String]
25+ | -- | GHC options pragma
26+ PragmaOptionsGHC String
27+ | -- | Haddock options pragma
28+ PragmaOptionsHaddock String
2829 deriving (Show, Eq)
2930
3031-- | Extract a pragma from a comment if possible, or return 'Nothing'
3132-- otherwise.
32−
33−parsePragma
34− :: String -- ^ Comment to try to parse
35− -> Maybe Pragma
33+parsePragma ::
34+ -- | Comment to try to parse
35+ String ->
36+ Maybe Pragma
3637parsePragma input = do
3738 inputNoPrefix <- stripPrefix "{-#" input
3839 guard ("#-}" `isSuffixOf` input)
@@ -49,8 +50,7 @@ parsePragma input = do
4950
5051-- | Assuming the input consists of a series of tokens from a language
5152-- pragma, return the set of enabled extensions.
52−
53−parseExtensions :: String -> Maybe [String]
53+parseExtensions :: String -> Maybe [String]
5454parseExtensions str = tokenize str >>= go
5555 where
5656 go = \case
@@ -59,7 +59,6 @@ parseExtensions str = tokenize str >>= go
5959 _ -> Nothing
6060
6161-- | Tokenize a given input using GHC's lexer.
62−
6362tokenize :: String -> Maybe [L.Token]
6463tokenize input =
6564 case L.unP pLexer parseState of
@@ -70,14 +69,13 @@ tokenize input =
7069 buffer = stringToStringBuffer input
7170 parseState = L.mkPStatePure parserFlags buffer location
7271 parserFlags = L.ParserFlags
73− { L.pWarningFlags = ES.empty
74− , L.pExtensionFlags = ES.empty
75− , L.pThisPackage = newSimpleUnitId (ComponentId (mkFastString ""))
76− , L.pExtsBitmap = 0xffffffffffffffff
72+ { L.pWarningFlags = ES.empty,
73+ L.pExtensionFlags = ES.empty,
74+ L.pThisPackage = newSimpleUnitId (ComponentId (mkFastString "")),
75+ L.pExtsBitmap = 0xffffffffffffffff
7776 }
7877
7978-- | Haskell lexer.
80−
8179pLexer :: L.P [L.Token]
8280pLexer = go
8381 where
@@ -85,4 +83,4 @@ pLexer = go
8583 r <- L.lexer False return
8684 case unLoc r of
8785 L.ITeof -> return []
88− x -> (x:) <$> go
86+ x -> (x :) <$> go
src/Ormolu/Parser/Result.hs+21−22
@@ -1,10 +1,9 @@
1−-- | A type for result of parsing.
2−
31{-# LANGUAGE RecordWildCards #-}
42
3+-- | A type for result of parsing.
54module Ormolu.Parser.Result
6− ( ParseResult (..)
7− , prettyPrintParseResult
5+ ( ParseResult (..),
6+ prettyPrintParseResult,
87 )
98where
109
@@ -14,24 +13,24 @@ import Ormolu.Parser.CommentStream
1413import Ormolu.Parser.Pragma (Pragma)
1514
1615-- | A collection of data that represents a parsed module in Ormolu.
17−
18−data ParseResult = ParseResult
19− { prParsedSource :: ParsedSource
20− -- ^ 'ParsedSource' from GHC
21− , prAnns :: Anns
22− -- ^ Ormolu-specfic representation of annotations
23− , prCommentStream :: CommentStream
24− -- ^ Comment stream
25− , prExtensions :: [Pragma]
26− -- ^ Extensions enabled in that module
27− }
16+data ParseResult
17+ = ParseResult
18+ { -- | 'ParsedSource' from GHC
19+ prParsedSource :: ParsedSource,
20+ -- | Ormolu-specfic representation of annotations
21+ prAnns :: Anns,
22+ -- | Comment stream
23+ prCommentStream :: CommentStream,
24+ -- | Extensions enabled in that module
25+ prExtensions :: [Pragma]
26+ }
2827
2928-- | Pretty-print a 'ParseResult'.
30−
3129prettyPrintParseResult :: ParseResult -> String
32−prettyPrintParseResult ParseResult {..} = unlines
33− [ "parse result:"
34− , " comment stream:"
35− , showCommentStream prCommentStream
36− -- XXX extend as needed
37− ]
30+prettyPrintParseResult ParseResult {..} =
31+ unlines
32+ [ "parse result:",
33+ " comment stream:",
34+ showCommentStream prCommentStream
35+ -- XXX extend as needed
36+ ]
src/Ormolu/Printer.hs+11−11
@@ -1,11 +1,10 @@
1−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE RecordWildCards #-}
44
55-- | Pretty-printer for Haskell AST.
6−
76module Ormolu.Printer
8− ( printModule
7+ ( printModule,
98 )
109where
1110
@@ -16,12 +15,13 @@ import Ormolu.Printer.Meat.Module
1615import Ormolu.Printer.SpanStream
1716
1817-- | Render a module.
19−
20−printModule
21− :: ParseResult -- ^ Result of parsing
22− -> Text -- ^ Resulting rendition
18+printModule ::
19+ -- | Result of parsing
20+ ParseResult ->
21+ -- | Resulting rendition
22+ Text
2323printModule ParseResult {..} =
2424 runR (p_hsModule prExtensions prParsedSource)
25− (mkSpanStream prParsedSource)
26− prCommentStream
27− prAnns
25+ (mkSpanStream prParsedSource)
26+ prCommentStream
27+ prAnns
src/Ormolu/Printer/Combinators.hs+106−101
@@ -1,55 +1,60 @@
1−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE RecordWildCards #-}
44
55-- | Printing combinators. The definitions here are presented in such an
66-- order so you can just go through the Haddocks and by the end of the file
77-- you should have a pretty good idea how to program rendering logic.
8−
98module Ormolu.Printer.Combinators
109 ( -- * The 'R' monad
11− R
12− , runR
13− , getAnns
14− , getEnclosingSpan
10+ R,
11+ runR,
12+ getAnns,
13+ getEnclosingSpan,
14+
1515 -- * Combinators
16+
1617 -- ** Basic
17− , txt
18− , atom
19− , space
20− , newline
21− , inci
22− , located
23− , located'
24− , switchLayout
25− , Layout (..)
26− , vlayout
27− , getLayout
28− , breakpoint
29− , breakpoint'
18+ txt,
19+ atom,
20+ space,
21+ newline,
22+ inci,
23+ located,
24+ located',
25+ switchLayout,
26+ Layout (..),
27+ vlayout,
28+ getLayout,
29+ breakpoint,
30+ breakpoint',
31+
3032 -- ** Formatting lists
31− , sep
32− , sepSemi
33− , canUseBraces
34− , useBraces
35− , dontUseBraces
33+ sep,
34+ sepSemi,
35+ canUseBraces,
36+ useBraces,
37+ dontUseBraces,
38+
3639 -- ** Wrapping
37− , BracketStyle (..)
38− , sitcc
39− , backticks
40− , banana
41− , braces
42− , brackets
43− , parens
44− , parensHash
45− , pragmaBraces
46− , pragma
40+ BracketStyle (..),
41+ sitcc,
42+ backticks,
43+ banana,
44+ braces,
45+ brackets,
46+ parens,
47+ parensHash,
48+ pragmaBraces,
49+ pragma,
50+
4751 -- ** Literals
48− , comma
52+ comma,
53+
4954 -- ** Comments
50− , HaddockStyle (..)
51− , setLastCommentSpan
52− , getLastCommentSpan
55+ HaddockStyle (..),
56+ setLastCommentSpan,
57+ getLastCommentSpan,
5358 )
5459where
5560
@@ -70,12 +75,13 @@ import SrcLoc
7075-- Roughly, the rule for using 'located' is that every time there is a
7176-- 'Located' wrapper, it should be “discharged” with a corresponding
7277-- 'located' invocation.
73−
74−located
75− :: Data a
76− => Located a -- ^ Thing to enter
77− -> (a -> R ()) -- ^ How to render inner value
78− -> R ()
78+located ::
79+ Data a =>
80+ -- | Thing to enter
81+ Located a ->
82+ -- | How to render inner value
83+ (a -> R ()) ->
84+ R ()
7985located loc f = do
8086 let withRealLocated (L l a) g =
8187 case l of
@@ -93,12 +99,13 @@ located loc f = do
9399 withRealLocated loc spitFollowingComments
94100
95101-- | A version of 'located' with arguments flipped.
96−
97−located'
98− :: Data a
99− => (a -> R ()) -- ^ How to render inner value
100− -> Located a -- ^ Thing to enter
101− -> R ()
102+located' ::
103+ Data a =>
104+ -- | How to render inner value
105+ (a -> R ()) ->
106+ -- | Thing to enter
107+ Located a ->
108+ R ()
102109located' = flip located
103110
104111-- | Set layout according to combination of given 'SrcSpan's for a given.
@@ -107,19 +114,19 @@ located' = flip located
107114-- provided by GHC AST. It is relatively rare that this one is needed.
108115--
109116-- Given empty list this function will set layout to single line.
110−
111−switchLayout
112− :: [SrcSpan] -- ^ Span that controls layout
113− -> R () -- ^ Computation to run with changed layout
114− -> R ()
117+switchLayout ::
118+ -- | Span that controls layout
119+ [SrcSpan] ->
120+ -- | Computation to run with changed layout
121+ R () ->
122+ R ()
115123switchLayout spans' = enterLayout (spansLayout spans')
116124
117125-- | Which layout combined spans result in?
118−
119126spansLayout :: [SrcSpan] -> Layout
120127spansLayout = \case
121128 [] -> SingleLine
122− (x:xs) ->
129+ (x : xs) ->
123130 if isOneLineSpan (foldr combineSrcSpans x xs)
124131 then SingleLine
125132 else MultiLine
@@ -128,7 +135,6 @@ spansLayout = \case
128135-- multiline.
129136--
130137-- > breakpoint = vlayout space newline
131−
132138breakpoint :: R ()
133139breakpoint = vlayout space newline
134140
@@ -136,7 +142,6 @@ breakpoint = vlayout space newline
136142-- layout.
137143--
138144-- > breakpoint' = vlayout (return ()) newline
139−
140145breakpoint' :: R ()
141146breakpoint' = vlayout (return ()) newline
142147
@@ -144,12 +149,14 @@ breakpoint' = vlayout (return ()) newline
144149-- Formatting lists
145150
146151-- | Render a collection of elements inserting a separator between them.
147−
148−sep
149− :: R () -- ^ Separator
150− -> (a -> R ()) -- ^ How to render an element
151− -> [a] -- ^ Elements to render
152− -> R ()
152+sep ::
153+ -- | Separator
154+ R () ->
155+ -- | How to render an element
156+ (a -> R ()) ->
157+ -- | Elements to render
158+ [a] ->
159+ R ()
153160sep s f xs = sequence_ (intersperse s (f <$> xs))
154161
155162-- | Render a collection of elements layout-sensitively using given printer,
@@ -161,11 +168,12 @@ sep s f xs = sequence_ (intersperse s (f <$> xs))
161168--
162169-- > dontUseBraces $ sepSemi txt ["foo", "bar"]
163170-- > == vlayout (txt "foo; bar") (txt "foo\nbar")
164−
165−sepSemi
166− :: (a -> R ()) -- ^ How to render an element
167− -> [a] -- ^ Elements to render
168− -> R ()
171+sepSemi ::
172+ -- | How to render an element
173+ (a -> R ()) ->
174+ -- | Elements to render
175+ [a] ->
176+ R ()
169177sepSemi f xs = vlayout singleLine multiLine
170178 where
171179 singleLine = do
@@ -174,12 +182,11 @@ sepSemi f xs = vlayout singleLine multiLine
174182 [] -> when ub $ txt "{}"
175183 xs' ->
176184 if ub
177− then do
178− txt "{ "
179− sep (txt "; ") (dontUseBraces . f) xs'
180− txt " }"
181− else
182− sep (txt "; ") f xs'
185+ then do
186+ txt "{ "
187+ sep (txt "; ") (dontUseBraces . f) xs'
188+ txt " }"
189+ else sep (txt "; ") f xs'
183190 multiLine =
184191 sep newline (dontUseBraces . f) xs
185192
@@ -187,13 +194,13 @@ sepSemi f xs = vlayout singleLine multiLine
187194-- Wrapping
188195
189196-- | 'BracketStyle' controlling how closing bracket is rendered.
190−
191197data BracketStyle
192− = N -- ^ Normal
193− | S -- ^ Shifted one level
198+ = -- | Normal
199+ N
200+ | -- | Shifted one level
201+ S
194202
195203-- | Surround given entity by backticks.
196−
197204backticks :: R () -> R ()
198205backticks m = do
199206 txt "`"
@@ -201,32 +208,26 @@ backticks m = do
201208 txt "`"
202209
203210-- | Surround given entity by banana brackets (i.e., from arrow notation.)
204−
205211banana :: R () -> R ()
206212banana = brackets_ True "(|" "|)" N
207213
208214-- | Surround given entity by curly braces @{@ and @}@.
209−
210215braces :: BracketStyle -> R () -> R ()
211216braces = brackets_ False "{" "}"
212217
213218-- | Surround given entity by square brackets @[@ and @]@.
214−
215219brackets :: BracketStyle -> R () -> R ()
216220brackets = brackets_ False "[" "]"
217221
218222-- | Surround given entity by parentheses @(@ and @)@.
219−
220223parens :: BracketStyle -> R () -> R ()
221224parens = brackets_ False "(" ")"
222225
223226-- | Surround given entity by @(# @ and @ #)@.
224−
225227parensHash :: BracketStyle -> R () -> R ()
226228parensHash = brackets_ True "(#" "#)"
227229
228230-- | Braces as used for pragmas: @{-#@ and @#-}@.
229−
230231pragmaBraces :: R () -> R ()
231232pragmaBraces m = sitcc $ do
232233 txt "{-#"
@@ -236,25 +237,30 @@ pragmaBraces m = sitcc $ do
236237 inci (txt "#-}")
237238
238239-- | Surround the body with a pragma name and 'pragmaBraces'.
239−
240−pragma
241− :: Text -- ^ Pragma text
242− -> R () -- ^ Pragma body
243− -> R ()
240+pragma ::
241+ -- | Pragma text
242+ Text ->
243+ -- | Pragma body
244+ R () ->
245+ R ()
244246pragma pragmaText body = pragmaBraces $ do
245247 txt pragmaText
246248 breakpoint
247249 body
248250
249251-- | A helper for defining wrappers like 'parens' and 'braces'.
250−
251−brackets_
252− :: Bool -- ^ Insert breakpoints around brackets
253− -> Text -- ^ Opening bracket
254− -> Text -- ^ Closing bracket
255− -> BracketStyle -- ^ Bracket style
256− -> R () -- ^ Inner expression
257− -> R ()
252+brackets_ ::
253+ -- | Insert breakpoints around brackets
254+ Bool ->
255+ -- | Opening bracket
256+ Text ->
257+ -- | Closing bracket
258+ Text ->
259+ -- | Bracket style
260+ BracketStyle ->
261+ -- | Inner expression
262+ R () ->
263+ R ()
258264brackets_ needBreaks open close style m = sitcc (vlayout singleLine multiLine)
259265 where
260266 singleLine = do
@@ -277,6 +283,5 @@ brackets_ needBreaks open close style m = sitcc (vlayout singleLine multiLine)
277283-- Literals
278284
279285-- | Print @,@.
280−
281286comma :: R ()
282287comma = txt ","
src/Ormolu/Printer/Comments.hs+94−83
@@ -1,35 +1,34 @@
1−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
33
44-- | Helpers for formatting of comments. This is low-level code, use
55-- "Ormolu.Printer.Combinators" unless you know what you are doing.
6−
76module Ormolu.Printer.Comments
8− ( spitPrecedingComments
9− , spitFollowingComments
10− , spitRemainingComments
7+ ( spitPrecedingComments,
8+ spitFollowingComments,
9+ spitRemainingComments,
1110 )
1211where
1312
1413import Control.Monad
1514import Data.Coerce (coerce)
1615import Data.Data (Data)
16+import qualified Data.List.NonEmpty as NE
17+import qualified Data.Text as T
1718import Ormolu.Parser.CommentStream
1819import Ormolu.Printer.Internal
1920import Ormolu.Utils (isModule)
2021import SrcLoc
21−import qualified Data.List.NonEmpty as NE
22−import qualified Data.Text as T
2322
2423----------------------------------------------------------------------------
2524-- Top-level
2625
2726-- | Output all preceding comments for an element at given location.
28−
29−spitPrecedingComments
30− :: Data a
31− => RealLocated a -- ^ AST element to attach comments to
32− -> R ()
27+spitPrecedingComments ::
28+ Data a =>
29+ -- | AST element to attach comments to
30+ RealLocated a ->
31+ R ()
3332spitPrecedingComments ref = do
3433 r <- getLastCommentSpan
3534 case r of
@@ -46,17 +45,16 @@ spitPrecedingComments ref = do
4645 when (needsNewlineBefore (getLoc ref) lastSpn) newline
4746
4847-- | Output all comments following an element at given location.
49−
50−spitFollowingComments
51− :: Data a
52− => RealLocated a -- ^ AST element of attach comments to
53− -> R ()
48+spitFollowingComments ::
49+ Data a =>
50+ -- | AST element of attach comments to
51+ RealLocated a ->
52+ R ()
5453spitFollowingComments ref = do
5554 trimSpanStream (getLoc ref)
5655 void $ handleCommentSeries (spitFollowingComment ref)
5756
5857-- | Output all remaining comments in the comment stream.
59−
6058spitRemainingComments :: R ()
6159spitRemainingComments = void $ handleCommentSeries spitRemainingComment
6260
@@ -64,12 +62,14 @@ spitRemainingComments = void $ handleCommentSeries spitRemainingComment
6462-- Single-comment functions
6563
6664-- | Output a single preceding comment for an element at given location.
67−
68−spitPrecedingComment
69− :: Data a
70− => RealLocated a -- ^ AST element to attach comments to
71− -> Maybe RealSrcSpan -- ^ Location of last comment in the series
72− -> R Bool -- ^ Are we done?
65+spitPrecedingComment ::
66+ Data a =>
67+ -- | AST element to attach comments to
68+ RealLocated a ->
69+ -- | Location of last comment in the series
70+ Maybe RealSrcSpan ->
71+ -- | Are we done?
72+ R Bool
7373spitPrecedingComment (L ref a) mlastSpn = do
7474 let p (L l _) = realSrcSpanEnd l <= realSrcSpanStart ref
7575 withPoppedComment p $ \l comment -> do
@@ -91,12 +91,14 @@ spitPrecedingComment (L ref a) mlastSpn = do
9191
9292-- | Output a comment that follows element at given location immediately on
9393-- the same line, if there is any.
94−
95−spitFollowingComment
96− :: Data a
97− => RealLocated a -- ^ AST element to attach comments to
98− -> Maybe RealSrcSpan -- ^ Location of last comment in the series
99− -> R Bool -- ^ Are we done?
94+spitFollowingComment ::
95+ Data a =>
96+ -- | AST element to attach comments to
97+ RealLocated a ->
98+ -- | Location of last comment in the series
99+ Maybe RealSrcSpan ->
100+ -- | Are we done?
101+ R Bool
100102spitFollowingComment (L ref a) mlastSpn = do
101103 mnSpn <- nextEltSpan
102104 -- Get first enclosing span that is not equal to reference span, i.e. it's
@@ -104,19 +106,21 @@ spitFollowingComment (L ref a) mlastSpn = do
104106 meSpn <- getEnclosingSpan (/= ref)
105107 withPoppedComment (commentFollowsElt ref mnSpn meSpn mlastSpn) $ \l comment ->
106108 if theSameLinePost l ref && not (isModule a)
107− then if isMultilineComment comment
108− then space >> spitCommentNow l comment
109− else spitCommentPending OnTheSameLine l comment
109+ then
110+ if isMultilineComment comment
111+ then space >> spitCommentNow l comment
112+ else spitCommentPending OnTheSameLine l comment
110113 else do
111114 when (needsNewlineBefore l mlastSpn) $
112115 registerPendingCommentLine OnNextLine ""
113116 spitCommentPending OnNextLine l comment
114117
115118-- | Output a single remaining comment from the comment stream.
116−
117−spitRemainingComment
118− :: Maybe RealSrcSpan -- ^ Location of last comment in the series
119− -> R Bool -- ^ Are we done?
119+spitRemainingComment ::
120+ -- | Location of last comment in the series
121+ Maybe RealSrcSpan ->
122+ -- | Are we done?
123+ R Bool
120124spitRemainingComment mlastSpn =
121125 withPoppedComment (const True) $ \l comment -> do
122126 when (needsNewlineBefore l mlastSpn) newline
@@ -127,12 +131,12 @@ spitRemainingComment mlastSpn =
127131-- Helpers
128132
129133-- | Output series of comments.
130−
131−handleCommentSeries
132− :: (Maybe RealSrcSpan -> R Bool)
133− -- ^ Given location of previous comment, output the next comment
134− -- returning 'True' if we're done
135− -> R Bool -- ^ Whether we printed any comments
134+handleCommentSeries ::
135+ -- | Given location of previous comment, output the next comment
136+ -- returning 'True' if we're done
137+ (Maybe RealSrcSpan -> R Bool) ->
138+ -- | Whether we printed any comments
139+ R Bool
136140handleCommentSeries f = go False
137141 where
138142 go gotSome = do
@@ -143,11 +147,13 @@ handleCommentSeries f = go False
143147
144148-- | Try to pop a comment using given predicate and if there is a comment
145149-- matching the predicate, print it out.
146−
147−withPoppedComment
148− :: (RealLocated Comment -> Bool) -- ^ Comment predicate
149− -> (RealSrcSpan -> Comment -> R ()) -- ^ Printing function
150− -> R Bool -- ^ Are we done?
150+withPoppedComment ::
151+ -- | Comment predicate
152+ (RealLocated Comment -> Bool) ->
153+ -- | Printing function
154+ (RealSrcSpan -> Comment -> R ()) ->
155+ -- | Are we done?
156+ R Bool
151157withPoppedComment p f = do
152158 r <- popComment p
153159 case r of
@@ -156,11 +162,12 @@ withPoppedComment p f = do
156162
157163-- | Determine if we need to insert a newline between current comment and
158164-- last printed comment.
159−
160−needsNewlineBefore
161− :: RealSrcSpan -- ^ Current comment span
162− -> Maybe RealSrcSpan -- ^ Last printed comment span
163− -> Bool
165+needsNewlineBefore ::
166+ -- | Current comment span
167+ RealSrcSpan ->
168+ -- | Last printed comment span
169+ Maybe RealSrcSpan ->
170+ Bool
164171needsNewlineBefore l mlastSpn =
165172 case mlastSpn of
166173 Nothing -> False
@@ -168,32 +175,38 @@ needsNewlineBefore l mlastSpn =
168175 srcSpanStartLine l > srcSpanEndLine lastSpn + 1
169176
170177-- | Is the preceding comment and AST element are on the same line?
171−
172−theSameLinePre
173− :: RealSrcSpan -- ^ Current comment span
174− -> RealSrcSpan -- ^ AST element location
175− -> Bool
178+theSameLinePre ::
179+ -- | Current comment span
180+ RealSrcSpan ->
181+ -- | AST element location
182+ RealSrcSpan ->
183+ Bool
176184theSameLinePre l ref =
177185 srcSpanEndLine l == srcSpanStartLine ref
178186
179187-- | Is the following comment and AST element are on the same line?
180−
181−theSameLinePost
182− :: RealSrcSpan -- ^ Current comment span
183− -> RealSrcSpan -- ^ AST element location
184− -> Bool
188+theSameLinePost ::
189+ -- | Current comment span
190+ RealSrcSpan ->
191+ -- | AST element location
192+ RealSrcSpan ->
193+ Bool
185194theSameLinePost l ref =
186195 srcSpanStartLine l == srcSpanEndLine ref
187196
188197-- | Determine if given comment follows AST element.
189−
190−commentFollowsElt
191− :: RealSrcSpan -- ^ Location of AST element
192− -> Maybe RealSrcSpan -- ^ Location of next AST element
193− -> Maybe RealSrcSpan -- ^ Location of enclosing AST element
194− -> Maybe RealSrcSpan -- ^ Location of last comment in the series
195− -> RealLocated Comment -- ^ Comment to test
196− -> Bool
198+commentFollowsElt ::
199+ -- | Location of AST element
200+ RealSrcSpan ->
201+ -- | Location of next AST element
202+ Maybe RealSrcSpan ->
203+ -- | Location of enclosing AST element
204+ Maybe RealSrcSpan ->
205+ -- | Location of last comment in the series
206+ Maybe RealSrcSpan ->
207+ -- | Comment to test
208+ RealLocated Comment ->
209+ Bool
197210commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) =
198211 -- A comment follows a AST element if all 4 conditions are satisfied:
199212 goesAfter
@@ -205,11 +218,11 @@ commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) =
205218 goesAfter =
206219 realSrcSpanStart l >= realSrcSpanEnd ref
207220 -- 2) The comment logically belongs to the element, four cases:
208− logicallyFollows
209− = theSameLinePost l ref -- a) it's on the same line
210− || isPrevHaddock comment -- b) it's a Haddock string starting with -- ^
211− || continuation -- c) it's a continuation of a comment block
212− || lastInEnclosing -- d) it's the last element in the enclosing construct
221+ logicallyFollows =
222+ theSameLinePost l ref -- a) it's on the same line
223+ || isPrevHaddock comment -- b) it's a Haddock string starting with -- ^
224+ || continuation -- c) it's a continuation of a comment block
225+ || lastInEnclosing -- d) it's the last element in the enclosing construct
213226
214227 -- 3) There is no other AST element between this element and the comment:
215228 noEltBetween =
@@ -231,15 +244,15 @@ commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) =
231244 Nothing -> True
232245 Just espn ->
233246 let startColumn = srcLocCol . realSrcSpanStart
234− in if startColumn espn > startColumn ref
235− then True
236− else abs (startColumn espn - startColumn l)
237− >= abs (startColumn ref - startColumn l)
247+ in if startColumn espn > startColumn ref
248+ then True
249+ else
250+ abs (startColumn espn - startColumn l)
251+ >= abs (startColumn ref - startColumn l)
238252 continuation =
239253 case mlastSpn of
240254 Nothing -> False
241255 Just spn -> srcSpanEndLine spn + 1 == srcSpanStartLine l
242−
243256 lastInEnclosing =
244257 case meSpn of
245258 -- When there is no enclosing element, return false
@@ -255,7 +268,6 @@ commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) =
255268 in insideParent && nextOutsideParent
256269
257270-- | Output a 'Comment' immediately. This is a low-level printing function.
258−
259271spitCommentNow :: RealSrcSpan -> Comment -> R ()
260272spitCommentNow spn comment = do
261273 sitcc
@@ -269,7 +281,6 @@ spitCommentNow spn comment = do
269281-- | Output a 'Comment' at the end of correct line or after it depending on
270282-- 'CommentPosition'. Used for comments that may potentially follow on the
271283-- same line as something we just rendered, but not immediately after it.
272−
273284spitCommentPending :: CommentPosition -> RealSrcSpan -> Comment -> R ()
274285spitCommentPending position spn comment = do
275286 let wrapper = case position of
src/Ormolu/Printer/Internal.hs+257−242
@@ -1,46 +1,49 @@
11{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2−{-# LANGUAGE LambdaCase #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE RankNTypes #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE RankNTypes #-}
55
66-- | In most cases import "Ormolu.Printer.Combinators" instead, these
77-- functions are the low-level building blocks and should not be used on
88-- their own. The 'R' monad is re-exported from "Ormolu.Printer.Combinators"
99-- as well.
10−
1110module Ormolu.Printer.Internal
1211 ( -- * The 'R' monad
13− R
14− , runR
12+ R,
13+ runR,
14+
1515 -- * Internal functions
16− , txt
17− , atom
18− , space
19− , newline
20− , isLineDirty
21− , inci
22− , sitcc
23− , Layout (..)
24− , enterLayout
25− , vlayout
26− , getLayout
16+ txt,
17+ atom,
18+ space,
19+ newline,
20+ isLineDirty,
21+ inci,
22+ sitcc,
23+ Layout (..),
24+ enterLayout,
25+ vlayout,
26+ getLayout,
27+
2728 -- * Helpers for braces
28− , useBraces
29− , dontUseBraces
30− , canUseBraces
29+ useBraces,
30+ dontUseBraces,
31+ canUseBraces,
32+
3133 -- * Special helpers for comment placement
32− , CommentPosition (..)
33− , registerPendingCommentLine
34− , trimSpanStream
35− , nextEltSpan
36− , popComment
37− , getEnclosingSpan
38− , withEnclosingSpan
39− , HaddockStyle (..)
40− , setLastCommentSpan
41− , getLastCommentSpan
34+ CommentPosition (..),
35+ registerPendingCommentLine,
36+ trimSpanStream,
37+ nextEltSpan,
38+ popComment,
39+ getEnclosingSpan,
40+ withEnclosingSpan,
41+ HaddockStyle (..),
42+ setLastCommentSpan,
43+ getLastCommentSpan,
44+
4245 -- * Annotations
43− , getAnns
46+ getAnns,
4447 )
4548where
4649
@@ -50,6 +53,8 @@ import Data.Bool (bool)
5053import Data.Coerce
5154import Data.Maybe (listToMaybe)
5255import Data.Text (Text)
56+import qualified Data.Text as T
57+import qualified Data.Text.Lazy as TL
5358import Data.Text.Lazy.Builder
5459import GHC
5560import Ormolu.Parser.Anns
@@ -58,109 +63,116 @@ import Ormolu.Printer.SpanStream
5863import Ormolu.Utils (showOutputable)
5964import Outputable (Outputable)
6065import SrcLoc
61−import qualified Data.Text as T
62−import qualified Data.Text.Lazy as TL
6366
6467----------------------------------------------------------------------------
6568-- The 'R' monad
6669
6770-- | The 'R' monad hosts combinators that allow us to describe how to render
6871-- AST.
69−
7072newtype R a = R (ReaderT RC (State SC) a)
7173 deriving (Functor, Applicative, Monad)
7274
7375-- | Reader context of 'R'. This should be used when we control rendering by
7476-- enclosing certain expressions with wrappers.
75−
76−data RC = RC
77− { rcIndent :: !Int
78− -- ^ Indentation level, as the column index we need to start from after
79− -- a newline if we break lines
80− , rcLayout :: Layout
81− -- ^ Current layout
82− , rcEnclosingSpans :: [RealSrcSpan]
83− -- ^ Spans of enclosing elements of AST
84− , rcAnns :: Anns
85− -- ^ Collection of annotations
86− , rcCanUseBraces :: Bool
87− -- ^ If the last expression in the layout can use braces
88− }
77+data RC
78+ = RC
79+ { -- | Indentation level, as the column index we need to start from after
80+ -- a newline if we break lines
81+ rcIndent :: !Int,
82+ -- | Current layout
83+ rcLayout :: Layout,
84+ -- | Spans of enclosing elements of AST
85+ rcEnclosingSpans :: [RealSrcSpan],
86+ -- | Collection of annotations
87+ rcAnns :: Anns,
88+ -- | If the last expression in the layout can use braces
89+ rcCanUseBraces :: Bool
90+ }
8991
9092-- | State context of 'R'.
91−
92−data SC = SC
93− { scColumn :: !Int
94− -- ^ Index of the next column to render
95− , scBuilder :: Builder
96− -- ^ Rendered source code so far
97− , scSpanStream :: SpanStream
98− -- ^ Span stream
99− , scCommentStream :: CommentStream
100− -- ^ Comment stream
101− , scPendingComments :: ![(CommentPosition, Int, Text)]
102− -- ^ Pending comment lines (in reverse order) to be inserted before next
103− -- newline, 'Int' is the indentation level
104− , scDirtyLine :: !Bool
105− -- ^ Whether the current line is “dirty”, that is, already contains
106− -- atoms that can have comments attached to them
107− , scRequestedDelimiter :: !RequestedDelimiter
108− -- ^ Whether to output a space before the next output
109− , scLastCommentSpan :: !(Maybe (Maybe HaddockStyle, RealSrcSpan))
110− -- ^ Span of last output comment
111− }
93+data SC
94+ = SC
95+ { -- | Index of the next column to render
96+ scColumn :: !Int,
97+ -- | Rendered source code so far
98+ scBuilder :: Builder,
99+ -- | Span stream
100+ scSpanStream :: SpanStream,
101+ -- | Comment stream
102+ scCommentStream :: CommentStream,
103+ -- | Pending comment lines (in reverse order) to be inserted before next
104+ -- newline, 'Int' is the indentation level
105+ scPendingComments :: ![(CommentPosition, Int, Text)],
106+ -- | Whether the current line is “dirty”, that is, already contains
107+ -- atoms that can have comments attached to them
108+ scDirtyLine :: !Bool,
109+ -- | Whether to output a space before the next output
110+ scRequestedDelimiter :: !RequestedDelimiter,
111+ -- | Span of last output comment
112+ scLastCommentSpan :: !(Maybe (Maybe HaddockStyle, RealSrcSpan))
113+ }
112114
113115-- | Make sure next output is delimited by one of the following.
114−
115116data RequestedDelimiter
116− = RequestedSpace -- ^ A space
117− | RequestedNewline -- ^ A newline
118− | RequestedNothing -- ^ Nothing
119− | AfterNewline -- ^ We just output a newline
120− | VeryBeginning -- ^ We haven't printed anything yet
117+ = -- | A space
118+ RequestedSpace
119+ | -- | A newline
120+ RequestedNewline
121+ | -- | Nothing
122+ RequestedNothing
123+ | -- | We just output a newline
124+ AfterNewline
125+ | -- | We haven't printed anything yet
126+ VeryBeginning
121127 deriving (Eq, Show)
122128
123129-- | 'Layout' options.
124−
125130data Layout
126− = SingleLine -- ^ Put everything on single line
127− | MultiLine -- ^ Use multiple lines
131+ = -- | Put everything on single line
132+ SingleLine
133+ | -- | Use multiple lines
134+ MultiLine
128135 deriving (Eq, Show)
129136
130137-- | Modes for rendering of pending comments.
131−
132138data CommentPosition
133− = OnTheSameLine -- ^ Put the comment on the same line
134− | OnNextLine -- ^ Put the comment on next line
139+ = -- | Put the comment on the same line
140+ OnTheSameLine
141+ | -- | Put the comment on next line
142+ OnNextLine
135143 deriving (Eq, Show)
136144
137145-- | Run an 'R' monad.
138−
139−runR
140− :: R () -- ^ Monad to run
141− -> SpanStream -- ^ Span stream
142− -> CommentStream -- ^ Comment stream
143− -> Anns -- ^ Annotations
144− -> Text -- ^ Resulting rendition
146+runR ::
147+ -- | Monad to run
148+ R () ->
149+ -- | Span stream
150+ SpanStream ->
151+ -- | Comment stream
152+ CommentStream ->
153+ -- | Annotations
154+ Anns ->
155+ -- | Resulting rendition
156+ Text
145157runR (R m) sstream cstream anns =
146158 TL.toStrict . toLazyText . scBuilder $ execState (runReaderT m rc) sc
147159 where
148160 rc = RC
149− { rcIndent = 0
150− , rcLayout = MultiLine
151− , rcEnclosingSpans = []
152− , rcAnns = anns
153− , rcCanUseBraces = False
161+ { rcIndent = 0,
162+ rcLayout = MultiLine,
163+ rcEnclosingSpans = [],
164+ rcAnns = anns,
165+ rcCanUseBraces = False
154166 }
155167 sc = SC
156− { scColumn = 0
157− , scBuilder = mempty
158− , scSpanStream = sstream
159− , scCommentStream = cstream
160− , scPendingComments = []
161− , scDirtyLine = False
162− , scRequestedDelimiter = VeryBeginning
163− , scLastCommentSpan = Nothing
168+ { scColumn = 0,
169+ scBuilder = mempty,
170+ scSpanStream = sstream,
171+ scCommentStream = cstream,
172+ scPendingComments = [],
173+ scDirtyLine = False,
174+ scRequestedDelimiter = VeryBeginning,
175+ scLastCommentSpan = Nothing
164176 }
165177
166178----------------------------------------------------------------------------
@@ -173,35 +185,38 @@ runR (R m) sstream cstream anns =
173185-- To separate various bits of syntax with white space use 'space' instead
174186-- of @'txt' " "@. To output 'Outputable' Haskell entities like numbers use
175187-- 'atom'.
176−
177−txt
178− :: Text -- ^ 'Text' to output
179− -> R ()
188+txt ::
189+ -- | 'Text' to output
190+ Text ->
191+ R ()
180192txt = spit False False
181193
182194-- | Output 'Outputable' fragment of AST. This can be used to output numeric
183195-- literals and similar. Everything that doesn't have inner structure but
184196-- does have an 'Outputable' instance.
185−
186−atom
187− :: Outputable a
188− => a
189− -> R ()
197+atom ::
198+ Outputable a =>
199+ a ->
200+ R ()
190201atom = spit True False . T.pack . showOutputable
191202
192203-- | Low-level non-public helper to define 'txt' and 'atom'.
193−
194−spit
195− :: Bool -- ^ Should we mark the line as dirty?
196− -> Bool -- ^ Used during outputting of pending comments?
197− -> Text -- ^ 'Text' to output
198− -> R ()
204+spit ::
205+ -- | Should we mark the line as dirty?
206+ Bool ->
207+ -- | Used during outputting of pending comments?
208+ Bool ->
209+ -- | 'Text' to output
210+ Text ->
211+ R ()
199212spit dirty printingComments txt' = do
200213 requestedDel <- R (gets scRequestedDelimiter)
201214 case requestedDel of
202215 RequestedNewline -> do
203− R . modify $ \sc -> sc
204− { scRequestedDelimiter = RequestedNothing }
216+ R . modify $ \sc ->
217+ sc
218+ { scRequestedDelimiter = RequestedNothing
219+ }
205220 if printingComments
206221 then newlineRaw
207222 else newline
@@ -214,18 +229,19 @@ spit dirty printingComments txt' = do
214229 then T.replicate (i - c) " "
215230 else bool mempty " " (requestedDel == RequestedSpace)
216231 indentedTxt = spaces <> txt'
217− modify $ \sc -> sc
218− { scBuilder = scBuilder sc <> fromText indentedTxt
219− , scColumn = scColumn sc + T.length indentedTxt
220− , scDirtyLine = scDirtyLine sc || dirty
221− , scRequestedDelimiter = RequestedNothing
222− , scLastCommentSpan =
223− -- NOTE If there are pending comments, do not reset last comment
224− -- location.
225− if printingComments || (not . null . scPendingComments) sc
226− then scLastCommentSpan sc
227− else Nothing
228− }
232+ modify $ \sc ->
233+ sc
234+ { scBuilder = scBuilder sc <> fromText indentedTxt,
235+ scColumn = scColumn sc + T.length indentedTxt,
236+ scDirtyLine = scDirtyLine sc || dirty,
237+ scRequestedDelimiter = RequestedNothing,
238+ scLastCommentSpan =
239+ -- NOTE If there are pending comments, do not reset last comment
240+ -- location.
241+ if printingComments || (not . null . scPendingComments) sc
242+ then scLastCommentSpan sc
243+ else Nothing
244+ }
229245
230246-- | This primitive /does not/ necessarily output a space. It just ensures
231247-- that the next thing that will be printed on the same line will be
@@ -235,14 +251,13 @@ spit dirty printingComments txt' = do
235251-- In practice this design prevents trailing white space and makes it hard
236252-- to output more than one delimiting space in a row, which is what we
237253-- usually want.
238−
239254space :: R ()
240−space = R . modify $ \sc -> sc
241− { scRequestedDelimiter =
242− case scRequestedDelimiter sc of
255+space = R . modify $ \sc ->
256+ sc
257+ { scRequestedDelimiter = case scRequestedDelimiter sc of
243258 RequestedNothing -> RequestedSpace
244259 other -> other
245− }
260+ }
246261
247262-- | Output a newline. First time 'newline' is used after some non-'newline'
248263-- output it gets inserted immediately. Second use of 'newline' does not
@@ -253,56 +268,53 @@ space = R . modify $ \sc -> sc
253268--
254269-- Similarly to 'space', this design prevents trailing newlines and makes it
255270-- hard to output more than one blank newline in a row.
256−
257271newline :: R ()
258272newline = do
259273 cs <- reverse <$> R (gets scPendingComments)
260274 case cs of
261275 [] -> newlineRaw
262− ((position, _, _):_) -> do
276+ ((position, _, _) : _) -> do
263277 case position of
264278 OnTheSameLine -> space
265279 OnNextLine -> newlineRaw
266280 R . forM_ cs $ \(_, indent, txt') ->
267− let modRC rc = rc
268− { rcIndent = indent
269− }
281+ let modRC rc =
282+ rc
283+ { rcIndent = indent
284+ }
270285 R m = do
271286 unless (T.null txt') $
272287 spit False True txt'
273288 newlineRaw
274− in local modRC m
275− R . modify $ \sc -> sc
276− { scPendingComments = []
277− }
289+ in local modRC m
290+ R . modify $ \sc ->
291+ sc
292+ { scPendingComments = []
293+ }
278294
279295-- | Low-level newline primitive. This one always just inserts a newline, no
280296-- hooks can be attached.
281−
282297newlineRaw :: R ()
283298newlineRaw = R . modify $ \sc ->
284299 let requestedDel = scRequestedDelimiter sc
285300 builderSoFar = scBuilder sc
286− in sc
287− { scBuilder =
288− case requestedDel of
289− AfterNewline -> builderSoFar
290− RequestedNewline -> builderSoFar
291− VeryBeginning -> builderSoFar
292− _ -> builderSoFar <> "\n"
293− , scColumn = 0
294− , scDirtyLine = False
295− , scRequestedDelimiter =
296− case scRequestedDelimiter sc of
297− AfterNewline -> RequestedNewline
298− RequestedNewline -> RequestedNewline
299− VeryBeginning -> VeryBeginning
300− _ -> AfterNewline
301− }
301+ in sc
302+ { scBuilder = case requestedDel of
303+ AfterNewline -> builderSoFar
304+ RequestedNewline -> builderSoFar
305+ VeryBeginning -> builderSoFar
306+ _ -> builderSoFar <> "\n",
307+ scColumn = 0,
308+ scDirtyLine = False,
309+ scRequestedDelimiter = case scRequestedDelimiter sc of
310+ AfterNewline -> RequestedNewline
311+ RequestedNewline -> RequestedNewline
312+ VeryBeginning -> VeryBeginning
313+ _ -> AfterNewline
314+ }
302315
303316-- | Check if the current line is “dirty”, that is, there is something on it
304317-- that can have comments attached to it.
305−
306318isLineDirty :: R Bool
307319isLineDirty = R (gets scDirtyLine)
308320
@@ -311,51 +323,52 @@ isLineDirty = R (gets scDirtyLine)
311323-- indented relative to the parts outside of 'inci' in order for the output
312324-- to be valid Haskell. When layout is single-line there is no obvious
313325-- effect, but with multi-line layout correct indentation levels matter.
314−
315326inci :: R () -> R ()
316327inci (R m) = R (local modRC m)
317328 where
318− modRC rc = rc
319− { rcIndent = rcIndent rc + indentStep
320− }
329+ modRC rc =
330+ rc
331+ { rcIndent = rcIndent rc + indentStep
332+ }
321333
322334-- | Set indentation level for the inner computation equal to current
323335-- column. This makes sure that the entire inner block is uniformly
324336-- \"shifted\" to the right. Only works (and makes sense) when enclosing
325337-- layout is multi-line.
326−
327338sitcc :: R () -> R ()
328339sitcc (R m) = do
329340 requestedDel <- R (gets scRequestedDelimiter)
330341 i <- R (asks rcIndent)
331342 c <- R (gets scColumn)
332− let modRC rc = rc
333− { rcIndent = max i c + bool 0 1 (requestedDel == RequestedSpace)
334− }
343+ let modRC rc =
344+ rc
345+ { rcIndent = max i c + bool 0 1 (requestedDel == RequestedSpace)
346+ }
335347 vlayout (R m) . R $ do
336− modify $ \sc -> sc
337− { scRequestedDelimiter =
338− case requestedDel of
348+ modify $ \sc ->
349+ sc
350+ { scRequestedDelimiter = case requestedDel of
339351 RequestedSpace -> RequestedNothing
340352 other -> other
341− }
353+ }
342354 local modRC m
343355
344356-- | Set 'Layout' for internal computation.
345−
346357enterLayout :: Layout -> R () -> R ()
347358enterLayout l (R m) = R (local modRC m)
348359 where
349− modRC rc = rc
350− { rcLayout = l
351− }
360+ modRC rc =
361+ rc
362+ { rcLayout = l
363+ }
352364
353365-- | Do one or another thing depending on current 'Layout'.
354−
355−vlayout
356− :: R a -- ^ Single line
357− -> R a -- ^ Multi line
358− -> R a
366+vlayout ::
367+ -- | Single line
368+ R a ->
369+ -- | Multi line
370+ R a ->
371+ R a
359372vlayout sline mline = do
360373 l <- getLayout
361374 case l of
@@ -363,7 +376,6 @@ vlayout sline mline = do
363376 MultiLine -> mline
364377
365378-- | Get current 'Layout'.
366−
367379getLayout :: R Layout
368380getLayout = R (asks rcLayout)
369381
@@ -374,91 +386,99 @@ getLayout = R (asks rcLayout)
374386-- before next newline. When the comment goes after something else on the
375387-- same line, a space will be inserted between preceding text and the
376388-- comment when necessary.
377−
378−registerPendingCommentLine
379− :: CommentPosition -- ^ Comment position
380− -> Text -- ^ 'Text' to output
381− -> R ()
389+registerPendingCommentLine ::
390+ -- | Comment position
391+ CommentPosition ->
392+ -- | 'Text' to output
393+ Text ->
394+ R ()
382395registerPendingCommentLine position txt' = R $ do
383396 i <- asks rcIndent
384− modify $ \sc -> sc
385− { scPendingComments = (position, i, txt') : scPendingComments sc
386− }
397+ modify $ \sc ->
398+ sc
399+ { scPendingComments = (position, i, txt') : scPendingComments sc
400+ }
387401
388402-- | Drop elements that begin before or at the same place as given
389403-- 'SrcSpan'.
390−
391−trimSpanStream
392− :: RealSrcSpan -- ^ Reference span
393− -> R ()
404+trimSpanStream ::
405+ -- | Reference span
406+ RealSrcSpan ->
407+ R ()
394408trimSpanStream ref = do
395409 let leRef :: RealSrcSpan -> Bool
396410 leRef x = realSrcSpanStart x <= realSrcSpanStart ref
397− R . modify $ \sc -> sc
398− { scSpanStream = coerce (dropWhile leRef) (scSpanStream sc)
399− }
411+ R . modify $ \sc ->
412+ sc
413+ { scSpanStream = coerce (dropWhile leRef) (scSpanStream sc)
414+ }
400415
401416-- | Get location of next element in AST.
402−
403417nextEltSpan :: R (Maybe RealSrcSpan)
404418nextEltSpan = listToMaybe . coerce <$> R (gets scSpanStream)
405419
406420-- | Pop a 'Comment' from the 'CommentStream' if given predicate is
407421-- satisfied and there are comments in the stream.
408−
409−popComment
410− :: (RealLocated Comment -> Bool)
411− -> R (Maybe (RealLocated Comment))
422+popComment ::
423+ (RealLocated Comment -> Bool) ->
424+ R (Maybe (RealLocated Comment))
412425popComment f = R $ do
413426 CommentStream cstream <- gets scCommentStream
414427 case cstream of
415428 [] -> return Nothing
416− (x:xs) ->
429+ (x : xs) ->
417430 if f x
418− then Just x <$ modify (\sc -> sc
419− { scCommentStream = CommentStream xs
420− })
431+ then
432+ Just x
433+ <$ modify
434+ ( \sc ->
435+ sc
436+ { scCommentStream = CommentStream xs
437+ }
438+ )
421439 else return Nothing
422440
423441-- | Get the first enclosing 'RealSrcSpan' that satisfies given predicate.
424−
425−getEnclosingSpan
426− :: (RealSrcSpan -> Bool) -- ^ Predicate to use
427− -> R (Maybe RealSrcSpan)
442+getEnclosingSpan ::
443+ -- | Predicate to use
444+ (RealSrcSpan -> Bool) ->
445+ R (Maybe RealSrcSpan)
428446getEnclosingSpan f =
429447 listToMaybe . filter f <$> R (asks rcEnclosingSpans)
430448
431449-- | Set 'RealSrcSpan' of enclosing span for the given computation.
432−
433450withEnclosingSpan :: RealSrcSpan -> R () -> R ()
434451withEnclosingSpan spn (R m) = R (local modRC m)
435452 where
436− modRC rc = rc
437− { rcEnclosingSpans = spn : rcEnclosingSpans rc
438− }
453+ modRC rc =
454+ rc
455+ { rcEnclosingSpans = spn : rcEnclosingSpans rc
456+ }
439457
440458-- | Haddock string style.
441−
442459data HaddockStyle
443− = Pipe -- ^ @-- |@
444− | Caret -- ^ @-- ^@
445− | Asterisk Int -- ^ @-- *@
446− | Named String -- ^ @-- $@
460+ = -- | @-- |@
461+ Pipe
462+ | -- | @-- ^@
463+ Caret
464+ | -- | @-- *@
465+ Asterisk Int
466+ | -- | @-- $@
467+ Named String
447468
448469-- | Set span of last output comment.
449−
450−setLastCommentSpan
451− :: Maybe HaddockStyle
452− -- ^ 'HaddockStyle' or 'Nothing' if it's a non-Haddock comment
453− -> RealSrcSpan
454− -- ^ Location of last printed comment
455− -> R ()
456−setLastCommentSpan mhStyle spn = R . modify $ \sc -> sc
457− { scLastCommentSpan = Just (mhStyle, spn)
458− }
470+setLastCommentSpan ::
471+ -- | 'HaddockStyle' or 'Nothing' if it's a non-Haddock comment
472+ Maybe HaddockStyle ->
473+ -- | Location of last printed comment
474+ RealSrcSpan ->
475+ R ()
476+setLastCommentSpan mhStyle spn = R . modify $ \sc ->
477+ sc
478+ { scLastCommentSpan = Just (mhStyle, spn)
479+ }
459480
460481-- | Get span of last output comment.
461−
462482getLastCommentSpan :: R (Maybe (Maybe HaddockStyle, RealSrcSpan))
463483getLastCommentSpan = R (gets scLastCommentSpan)
464484
@@ -466,27 +486,23 @@ getLastCommentSpan = R (gets scLastCommentSpan)
466486-- Annotations
467487
468488-- | For a given span return 'AnnKeywordId's associated with it.
469−
470−getAnns
471− :: SrcSpan
472− -> R [AnnKeywordId]
489+getAnns ::
490+ SrcSpan ->
491+ R [AnnKeywordId]
473492getAnns spn = lookupAnns spn <$> R (asks rcAnns)
474493
475494----------------------------------------------------------------------------
476495-- Helpers for braces
477496
478497-- | Make the inner computation use braces around single-line layouts.
479−
480498useBraces :: R () -> R ()
481−useBraces (R r) = R (local (\i -> i {rcCanUseBraces = True}) r)
499+useBraces (R r) = R (local (\i -> i {rcCanUseBraces = True}) r)
482500
483501-- | Make the inner computation omit braces around single-line layouts.
484−
485502dontUseBraces :: R () -> R ()
486−dontUseBraces (R r) = R (local (\i -> i {rcCanUseBraces = False}) r)
503+dontUseBraces (R r) = R (local (\i -> i {rcCanUseBraces = False}) r)
487504
488505-- | Return 'True' if we can use braces in this context.
489−
490506canUseBraces :: R Bool
491507canUseBraces = R $ asks rcCanUseBraces
492508
@@ -494,6 +510,5 @@ canUseBraces = R $ asks rcCanUseBraces
494510-- Constants
495511
496512-- | Indentation step.
497−
498513indentStep :: Int
499514indentStep = 2
src/Ormolu/Printer/Meat/Common.hs+42−40
@@ -1,37 +1,37 @@
1−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
33
44-- | Rendering of commonly useful bits.
5−
65module Ormolu.Printer.Meat.Common
7− ( FamilyStyle (..)
8− , p_hsmodName
9− , p_ieWrappedName
10− , p_rdrName
11− , doesNotNeedExtraParens
12− , p_qualName
13− , p_infixDefHelper
14− , p_hsDocString
15− , p_hsDocName
6+ ( FamilyStyle (..),
7+ p_hsmodName,
8+ p_ieWrappedName,
9+ p_rdrName,
10+ doesNotNeedExtraParens,
11+ p_qualName,
12+ p_infixDefHelper,
13+ p_hsDocString,
14+ p_hsDocName,
1615 )
1716where
1817
1918import Control.Monad
2019import Data.List (isPrefixOf)
2120import Data.Maybe (isJust)
21+import qualified Data.Text as T
2222import GHC hiding (GhcPs, IE)
2323import Name (nameStableString)
2424import OccName (OccName (..))
2525import Ormolu.Printer.Combinators
2626import Ormolu.Utils
2727import RdrName (RdrName (..))
28−import qualified Data.Text as T
2928
3029-- | Data and type family style.
31−
3230data FamilyStyle
33− = Associated -- ^ Declarations in type classes
34− | Free -- ^ Top-level declarations
31+ = -- | Declarations in type classes
32+ Associated
33+ | -- | Top-level declarations
34+ Free
3535
3636p_hsmodName :: ModuleName -> R ()
3737p_hsmodName mname = do
@@ -52,7 +52,6 @@ p_ieWrappedName = \case
5252 p_rdrName x
5353
5454-- | Render a @'Located' 'RdrName'@.
55−
5655p_rdrName :: Located RdrName -> R ()
5756p_rdrName l@(L spn _) = located l $ \x -> do
5857 ids <- getAnns spn
@@ -67,9 +66,9 @@ p_rdrName l@(L spn _) = located l $ \x -> do
6766 singleQuoteWrapper =
6867 if AnnSimpleQuote `elem` ids
6968 then \y -> do
70− txt "'"
71− y
72− else id
69+ txt "'"
70+ y
71+ else id
7372 m =
7473 case x of
7574 Unqual occName ->
@@ -96,16 +95,15 @@ p_rdrName l@(L spn _) = located l $ \x -> do
9695-- to detect e.g. tuples for which annotations will indicate parentheses,
9796-- but the parentheses are already part of the symbol, so no extra layer of
9897-- parentheses should be added. It also detects the [] literal.
99−
10098doesNotNeedExtraParens :: RdrName -> Bool
10199doesNotNeedExtraParens = \case
102100 Exact name ->
103101 let s = nameStableString name
104− -- NOTE I'm not sure this "stable string" is stable enough, but it looks
105− -- like this is the most robust way to tell if we're looking at exactly
106− -- this piece of built-in syntax.
107− in ("$ghc-prim$GHC.Tuple$" `isPrefixOf` s) ||
108− ("$ghc-prim$GHC.Types$[]" `isPrefixOf` s)
102+ in -- NOTE I'm not sure this "stable string" is stable enough, but it looks
103+ -- like this is the most robust way to tell if we're looking at exactly
104+ -- this piece of built-in syntax.
105+ ("$ghc-prim$GHC.Tuple$" `isPrefixOf` s)
106+ || ("$ghc-prim$GHC.Types$[]" `isPrefixOf` s)
109107 _ -> False
110108
111109p_qualName :: ModuleName -> OccName -> R ()
@@ -115,16 +113,19 @@ p_qualName mname occName = do
115113 atom occName
116114
117115-- | A helper for formatting infix constructions in lhs of definitions.
118−
119−p_infixDefHelper
120− :: Bool -- ^ Whether to format in infix style
121− -> (R () -> R ()) -- ^ Indentation-bumping wrapper
122− -> R () -- ^ How to print the operator\/name
123− -> [R ()] -- ^ How to print the arguments
124− -> R ()
116+p_infixDefHelper ::
117+ -- | Whether to format in infix style
118+ Bool ->
119+ -- | Indentation-bumping wrapper
120+ (R () -> R ()) ->
121+ -- | How to print the operator\/name
122+ R () ->
123+ -- | How to print the arguments
124+ [R ()] ->
125+ R ()
125126p_infixDefHelper isInfix inci' name args =
126127 case (isInfix, args) of
127− (True, p0:p1:ps) -> do
128+ (True, p0 : p1 : ps) -> do
128129 let parens' =
129130 if null ps
130131 then id
@@ -146,12 +147,14 @@ p_infixDefHelper isInfix inci' name args =
146147 inci' $ sitcc (sep breakpoint sitcc args)
147148
148149-- | Print a Haddock.
149−
150−p_hsDocString
151− :: HaddockStyle -- ^ Haddock style
152− -> Bool -- ^ Finish the doc string with a newline
153− -> LHsDocString -- ^ The doc string to render
154− -> R ()
150+p_hsDocString ::
151+ -- | Haddock style
152+ HaddockStyle ->
153+ -- | Finish the doc string with a newline
154+ Bool ->
155+ -- | The doc string to render
156+ LHsDocString ->
157+ R ()
155158p_hsDocString hstyle needsNewline (L l str) = do
156159 goesAfterComment <- isJust <$> getLastCommentSpan
157160 -- Make sure the Haddock is separated by a newline from other comments.
@@ -175,6 +178,5 @@ p_hsDocString hstyle needsNewline (L l str) = do
175178 RealSrcSpan spn -> setLastCommentSpan (Just hstyle) spn
176179
177180-- | Print anchor of named doc section.
178−
179181p_hsDocName :: String -> R ()
180182p_hsDocName name = txt ("-- $" <> T.pack name)
src/Ormolu/Printer/Meat/Declaration.hs+50−49
@@ -1,19 +1,19 @@
1−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
33{-# LANGUAGE PatternSynonyms #-}
44{-# LANGUAGE RecordWildCards #-}
5−{-# LANGUAGE ViewPatterns #-}
5+{-# LANGUAGE ViewPatterns #-}
66
77-- | Rendering of declarations.
8−
98module Ormolu.Printer.Meat.Declaration
10− ( p_hsDecls
11− , hasSeparatedDecls
9+ ( p_hsDecls,
10+ hasSeparatedDecls,
1211 )
1312where
1413
1514import Data.List (sort)
16−import Data.List.NonEmpty (NonEmpty (..), (<|))
15+import Data.List.NonEmpty ((<|), NonEmpty (..))
16+import qualified Data.List.NonEmpty as NE
1717import GHC
1818import OccName (occNameFS)
1919import Ormolu.Printer.Combinators
@@ -35,7 +35,6 @@ import Ormolu.Printer.Meat.Declaration.Warning
3535import Ormolu.Printer.Meat.Type
3636import Ormolu.Utils
3737import RdrName (rdrNameOcc)
38−import qualified Data.List.NonEmpty as NE
3938
4039p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
4140p_hsDecls style decls = sepSemi id $
@@ -43,7 +42,7 @@ p_hsDecls style decls = sepSemi id $
4342 -- groups.
4443 case groupDecls decls of
4544 [] -> []
46− (x:xs) ->
45+ (x : xs) ->
4746 NE.toList (renderGroup x)
4847 ++ concatMap (NE.toList . separateGroup . renderGroup) xs
4948 where
@@ -54,7 +53,6 @@ p_hsDecls style decls = sepSemi id $
5453--
5554-- Add a declaration to a group iff it is relevant to either the first or
5655-- the last declaration of the group.
57−
5856groupDecls :: [LHsDecl GhcPs] -> [NonEmpty (LHsDecl GhcPs)]
5957groupDecls [] = []
6058groupDecls (l@(L _ DocNext) : xs) =
@@ -62,19 +60,19 @@ groupDecls (l@(L _ DocNext) : xs) =
6260 -- in the next block:
6361 case groupDecls xs of
6462 [] -> [l :| []]
65− (x:xs') -> (l <| x) : xs'
66−groupDecls (lhdr:xs) =
67− let -- Pick the first decl as the group header
68− hdr = unLoc lhdr
69− -- Zip rest of the decls with their previous decl
70− zipped = zip (lhdr:xs) xs
71− -- Pick decls from the tail if they are relevant to the group header
72− -- or the previous decl.
73− (grp, rest) = flip span zipped $ \(L _ prev, L _ cur) ->
74− let relevantToHdr = groupedDecls hdr cur
75− relevantToPrev = groupedDecls prev cur
76− in relevantToHdr || relevantToPrev
77− in (lhdr :| map snd grp) : groupDecls (map snd rest)
63+ (x : xs') -> (l <| x) : xs'
64+groupDecls (lhdr : xs) =
65+ let -- Pick the first decl as the group header
66+ hdr = unLoc lhdr
67+ -- Zip rest of the decls with their previous decl
68+ zipped = zip (lhdr : xs) xs
69+ -- Pick decls from the tail if they are relevant to the group header
70+ -- or the previous decl.
71+ (grp, rest) = flip span zipped $ \(L _ prev, L _ cur) ->
72+ let relevantToHdr = groupedDecls hdr cur
73+ relevantToPrev = groupedDecls prev cur
74+ in relevantToHdr || relevantToPrev
75+ in (lhdr :| map snd grp) : groupDecls (map snd rest)
7876
7977p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R ()
8078p_hsDecl style = \case
@@ -94,7 +92,7 @@ p_hsDecl style = \case
9492 DocCommentNext str -> p_hsDocString Pipe False (noLoc str)
9593 DocCommentPrev str -> p_hsDocString Caret False (noLoc str)
9694 DocCommentNamed name str -> p_hsDocString (Named name) False (noLoc str)
97− DocGroup n str -> p_hsDocString (Asterisk n) False (noLoc str)
95+ DocGroup n str -> p_hsDocString (Asterisk n) False (noLoc str)
9896 RoleAnnotD NoExt x -> p_roleAnnot x
9997 XHsDecl _ -> notImplemented "XHsDecl"
10098
@@ -136,17 +134,17 @@ p_derivDecl = \case
136134 XDerivDecl _ -> notImplemented "XDerivDecl standalone deriving"
137135
138136-- | Determine if these declarations should be grouped together.
139−
140−groupedDecls
141− :: HsDecl GhcPs
142− -> HsDecl GhcPs
143− -> Bool
137+groupedDecls ::
138+ HsDecl GhcPs ->
139+ HsDecl GhcPs ->
140+ Bool
144141groupedDecls (TypeSignature ns) (FunctionBody ns') = ns `intersects` ns'
145142groupedDecls x (FunctionBody ns) | Just ns' <- isPragma x = ns `intersects` ns'
146143groupedDecls (FunctionBody ns) x | Just ns' <- isPragma x = ns `intersects` ns'
147144groupedDecls x (DataDeclaration n) | Just ns <- isPragma x = n `elem` ns
148−groupedDecls (DataDeclaration n) x | Just ns <- isPragma x =
149− let f = occNameFS . rdrNameOcc in f n `elem` map f ns
145+groupedDecls (DataDeclaration n) x
146+ | Just ns <- isPragma x =
147+ let f = occNameFS . rdrNameOcc in f n `elem` map f ns
150148groupedDecls x y | Just ns <- isPragma x, Just ns' <- isPragma y = ns `intersects` ns'
151149groupedDecls x (TypeSignature ns) | Just ns' <- isPragma x = ns `intersects` ns'
152150groupedDecls (TypeSignature ns) x | Just ns' <- isPragma x = ns `intersects` ns'
@@ -161,22 +159,21 @@ intersects a b = go (sort a) (sort b)
161159 go :: Ord a => [a] -> [a] -> Bool
162160 go _ [] = False
163161 go [] _ = False
164− go (x:xs) (y:ys)
165− | x < y = go xs (y:ys)
166− | x > y = go (x:xs) ys
162+ go (x : xs) (y : ys)
163+ | x < y = go xs (y : ys)
164+ | x > y = go (x : xs) ys
167165 | otherwise = True
168166
169167-- | Checks if given list of declarations contain a pair which should
170168-- be separated by a blank line.
171−
172169hasSeparatedDecls :: [LHsDecl GhcPs] -> Bool
173170hasSeparatedDecls xs = case groupDecls xs of
174− _:_:_ -> True
171+ _ : _ : _ -> True
175172 _ -> False
176173
177−isPragma
178− :: HsDecl GhcPs
179− -> Maybe [RdrName]
174+isPragma ::
175+ HsDecl GhcPs ->
176+ Maybe [RdrName]
180177isPragma = \case
181178 InlinePragma n -> Just [n]
182179 SpecializePragma n -> Just [n]
@@ -188,13 +185,15 @@ isPragma = \case
188185
189186-- Declarations referring to a single name
190187
191−pattern InlinePragma
192− , SpecializePragma
193− , SCCPragma
194− , AnnTypePragma
195− , AnnValuePragma
196− , Pattern
197− , DataDeclaration :: RdrName -> HsDecl GhcPs
188+pattern
189+ InlinePragma,
190+ SpecializePragma,
191+ SCCPragma,
192+ AnnTypePragma,
193+ AnnValuePragma,
194+ Pattern,
195+ DataDeclaration ::
196+ RdrName -> HsDecl GhcPs
198197pattern InlinePragma n <- SigD NoExt (InlineSig NoExt (L _ n) _)
199198pattern SpecializePragma n <- SigD NoExt (SpecSig NoExt (L _ n) _ _)
200199pattern SCCPragma n <- SigD NoExt (SCCFunSig NoExt _ (L _ n) _)
@@ -205,10 +204,12 @@ pattern DataDeclaration n <- TyClD NoExt (DataDecl NoExt (L _ n) _ _ _)
205204
206205-- Declarations which can refer to multiple names
207206
208−pattern TypeSignature
209− , FunctionBody
210− , PatternSignature
211− , WarningPragma :: [RdrName] -> HsDecl GhcPs
207+pattern
208+ TypeSignature,
209+ FunctionBody,
210+ PatternSignature,
211+ WarningPragma ::
212+ [RdrName] -> HsDecl GhcPs
212213pattern TypeSignature n <- (sigRdrNames -> Just n)
213214pattern FunctionBody n <- (funRdrNames -> Just n)
214215pattern PatternSignature n <- (patSigRdrNames -> Just n)
src/Ormolu/Printer/Meat/Declaration.hs-boot+3−2
@@ -1,6 +1,6 @@
11module Ormolu.Printer.Meat.Declaration
2− ( p_hsDecls
3− , hasSeparatedDecls
2+ ( p_hsDecls,
3+ hasSeparatedDecls,
44 )
55where
66
@@ -9,4 +9,5 @@ import Ormolu.Printer.Combinators
99import Ormolu.Printer.Meat.Common
1010
1111p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
12+
1213hasSeparatedDecls :: [LHsDecl GhcPs] -> Bool
src/Ormolu/Printer/Meat/Declaration/Annotation.hs+2−2
@@ -1,8 +1,8 @@
1−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
33
44module Ormolu.Printer.Meat.Declaration.Annotation
5− ( p_annDecl
5+ ( p_annDecl,
66 )
77where
88
src/Ormolu/Printer/Meat/Declaration/Class.hs+18−18
@@ -1,11 +1,10 @@
1−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE RecordWildCards #-}
44
55-- | Rendering of type class declarations.
6−
76module Ormolu.Printer.Meat.Declaration.Class
8− ( p_classDecl
7+ ( p_classDecl,
98 )
109where
1110
@@ -18,23 +17,23 @@ import Data.Ord (comparing)
1817import GHC
1918import Ormolu.Printer.Combinators
2019import Ormolu.Printer.Meat.Common
20+import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
2121import Ormolu.Printer.Meat.Type
2222import Ormolu.Utils
2323import RdrName (RdrName (..))
24−import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
2524
26−p_classDecl
27− :: LHsContext GhcPs
28− -> Located RdrName
29− -> LHsQTyVars GhcPs
30− -> LexicalFixity
31− -> [Located (FunDep (Located RdrName))]
32− -> [LSig GhcPs]
33− -> LHsBinds GhcPs
34− -> [LFamilyDecl GhcPs]
35− -> [LTyFamDefltEqn GhcPs]
36− -> [LDocDecl]
37− -> R ()
25+p_classDecl ::
26+ LHsContext GhcPs ->
27+ Located RdrName ->
28+ LHsQTyVars GhcPs ->
29+ LexicalFixity ->
30+ [Located (FunDep (Located RdrName))] ->
31+ [LSig GhcPs] ->
32+ LHsBinds GhcPs ->
33+ [LFamilyDecl GhcPs] ->
34+ [LTyFamDefltEqn GhcPs] ->
35+ [LDocDecl] ->
36+ R ()
3837p_classDecl ctx name tvars fixity fdeps csigs cdefs cats catdefs cdocs = do
3938 let HsQTvs {..} = tvars
4039 variableSpans = getLoc <$> hsq_explicit
@@ -63,7 +62,8 @@ p_classDecl ctx name tvars fixity fdeps csigs cdefs cats catdefs cdocs = do
6362 docs = (getLoc &&& fmap (DocD NoExt)) <$> cdocs
6463 tyFamDefs =
6564 ( getLoc &&& fmap (InstD NoExt . TyFamInstD NoExt . defltEqnToInstDecl)
66− ) <$> catdefs
65+ )
66+ <$> catdefs
6767 allDecls =
6868 snd <$> sortBy (comparing fst) (sigs <> vals <> tyFams <> tyFamDefs <> docs)
6969 unless (null allDecls) $ do
src/Ormolu/Printer/Meat/Declaration/Data.hs+56−45
@@ -1,11 +1,10 @@
1−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE RecordWildCards #-}
44
55-- | Renedring of data type declarations.
6−
76module Ormolu.Printer.Meat.Declaration.Data
8− ( p_dataDecl
7+ ( p_dataDecl,
98 )
109where
1110
@@ -20,13 +19,18 @@ import Ormolu.Utils
2019import RdrName (RdrName (..))
2120import SrcLoc (Located)
2221
23−p_dataDecl
24− :: FamilyStyle -- ^ Whether to format as data family
25− -> Located RdrName -- ^ Type constructor
26− -> [LHsType GhcPs] -- ^ Type patterns
27− -> LexicalFixity -- ^ Lexical fixity
28− -> HsDataDefn GhcPs -- ^ Data definition
29− -> R ()
22+p_dataDecl ::
23+ -- | Whether to format as data family
24+ FamilyStyle ->
25+ -- | Type constructor
26+ Located RdrName ->
27+ -- | Type patterns
28+ [LHsType GhcPs] ->
29+ -- | Lexical fixity
30+ LexicalFixity ->
31+ -- | Data definition
32+ HsDataDefn GhcPs ->
33+ R ()
3034p_dataDecl style name tpats fixity HsDataDefn {..} = do
3135 txt $ case dd_ND of
3236 NewType -> "newtype"
@@ -36,11 +40,12 @@ p_dataDecl style name tpats fixity HsDataDefn {..} = do
3640 Free -> " instance"
3741 switchLayout (getLoc name : fmap getLoc tpats) $ do
3842 breakpoint
39− inci $ p_infixDefHelper
40− (isInfix fixity)
41− inci
42− (p_rdrName name)
43− (located' p_hsType <$> tpats)
43+ inci $
44+ p_infixDefHelper
45+ (isInfix fixity)
46+ inci
47+ (p_rdrName name)
48+ (located' p_hsType <$> tpats)
4449 case dd_kindSig of
4550 Nothing -> return ()
4651 Just k -> do
@@ -56,14 +61,16 @@ p_dataDecl style name tpats fixity HsDataDefn {..} = do
5661 txt "where"
5762 breakpoint
5863 inci $ sepSemi (located' p_conDecl) dd_cons
59− else switchLayout (getLoc name : (getLoc <$> dd_cons)) $
60− inci $ do
64+ else switchLayout (getLoc name : (getLoc <$> dd_cons))
65+ $ inci
66+ $ do
6167 breakpoint
6268 txt "="
6369 space
64− let s = vlayout
65− (space >> txt "|" >> space)
66− (newline >> txt "|" >> space)
70+ let s =
71+ vlayout
72+ (space >> txt "|" >> space)
73+ (newline >> txt "|" >> space)
6774 sep s (sitcc . located' p_conDecl) dd_cons
6875 unless (null $ unLoc dd_derivs) breakpoint
6976 inci . located dd_derivs $ \xs -> do
@@ -74,15 +81,16 @@ p_conDecl :: ConDecl GhcPs -> R ()
7481p_conDecl = \case
7582 ConDeclGADT {..} -> do
7683 mapM_ (p_hsDocString Pipe True) con_doc
77− let conDeclSpn = fmap getLoc con_names
78− <> [getLoc con_forall]
79− <> conTyVarsSpans con_qvars
80− <> maybeToList (fmap getLoc con_mb_cxt)
81− <> conArgsSpans con_args
84+ let conDeclSpn =
85+ fmap getLoc con_names
86+ <> [getLoc con_forall]
87+ <> conTyVarsSpans con_qvars
88+ <> maybeToList (fmap getLoc con_mb_cxt)
89+ <> conArgsSpans con_args
8290 switchLayout conDeclSpn $ do
8391 case con_names of
8492 [] -> return ()
85− (c:cs) -> do
93+ (c : cs) -> do
8694 p_rdrName c
8795 unless (null cs) . inci $ do
8896 comma
@@ -116,10 +124,11 @@ p_conDecl = \case
116124 p_hsType (unLoc con_res_ty)
117125 ConDeclH98 {..} -> do
118126 mapM_ (p_hsDocString Pipe True) con_doc
119− let conDeclSpn = [getLoc con_name]
120− <> fmap getLoc con_ex_tvs
121− <> maybeToList (fmap getLoc con_mb_cxt)
122− <> conArgsSpans con_args
127+ let conDeclSpn =
128+ [getLoc con_name]
129+ <> fmap getLoc con_ex_tvs
130+ <> maybeToList (fmap getLoc con_mb_cxt)
131+ <> conArgsSpans con_args
123132 switchLayout conDeclSpn $ do
124133 p_forallBndrs con_ex_tvs
125134 unless (null con_ex_tvs) breakpoint
@@ -156,20 +165,20 @@ conTyVarsSpans = \case
156165 HsQTvs {..} -> getLoc <$> hsq_explicit
157166 XLHsQTyVars NoExt -> []
158167
159−p_forallBndrs
160− :: [LHsTyVarBndr GhcPs]
161− -> R ()
168+p_forallBndrs ::
169+ [LHsTyVarBndr GhcPs] ->
170+ R ()
162171p_forallBndrs = \case
163172 [] -> return ()
164173 bndrs -> do
165174 txt "forall"
166175 space
167− sep space (located' p_hsTyVarBndr) bndrs
176+ sep space (located' p_hsTyVarBndr) bndrs
168177 txt "."
169178
170−p_lhsContext
171− :: LHsContext GhcPs
172− -> R ()
179+p_lhsContext ::
180+ LHsContext GhcPs ->
181+ R ()
173182p_lhsContext = \case
174183 L _ [] -> pure ()
175184 ctx -> do
@@ -184,17 +193,19 @@ isGadt = \case
184193 ConDeclH98 {} -> False
185194 XConDecl {} -> False
186195
187−p_hsDerivingClause
188− :: HsDerivingClause GhcPs
189− -> R ()
196+p_hsDerivingClause ::
197+ HsDerivingClause GhcPs ->
198+ R ()
190199p_hsDerivingClause HsDerivingClause {..} = do
191200 txt "deriving"
192201 let derivingWhat = located deriv_clause_tys $ \case
193202 [] -> txt "()"
194− xs -> parens N . sitcc $ sep
195− (comma >> breakpoint)
196− (sitcc . located' p_hsType . hsib_body)
197− xs
203+ xs ->
204+ parens N . sitcc $
205+ sep
206+ (comma >> breakpoint)
207+ (sitcc . located' p_hsType . hsib_body)
208+ xs
198209 space
199210 case deriv_clause_strategy of
200211 Nothing -> do
src/Ormolu/Printer/Meat/Declaration/Default.hs+2−2
@@ -1,8 +1,8 @@
1−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
33
44module Ormolu.Printer.Meat.Declaration.Default
5− ( p_defaultDecl
5+ ( p_defaultDecl,
66 )
77where
88
src/Ormolu/Printer/Meat/Declaration/Foreign.hs+3−5
@@ -1,9 +1,9 @@
1−{-# LANGUAGE LambdaCase #-}
2−{-# LANGUAGE NamedFieldPuns #-}
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE NamedFieldPuns #-}
33{-# LANGUAGE OverloadedStrings #-}
44
55module Ormolu.Printer.Meat.Declaration.Foreign
6− ( p_foreignDecl
6+ ( p_foreignDecl,
77 )
88where
99
@@ -29,7 +29,6 @@ p_foreignDecl = \case
2929
3030-- | Printer for the last part of an import\/export, which is function name
3131-- and type signature.
32−
3332p_foreignTypeSig :: ForeignDecl GhcPs -> R ()
3433p_foreignTypeSig fd = do
3534 breakpoint
@@ -51,7 +50,6 @@ p_foreignTypeSig fd = do
5150-- We also layout the identifier using the 'SourceText', because printing
5251-- with the other two fields of 'CImport' is very complicated. See the
5352-- 'Outputable' instance of 'ForeignImport' for details.
54−
5553p_foreignImport :: ForeignImport -> R ()
5654p_foreignImport (CImport cCallConv safety _ _ sourceText) = do
5755 txt "foreign import"
src/Ormolu/Printer/Meat/Declaration/Instance.hs+13−12
@@ -1,14 +1,13 @@
1−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE RecordWildCards #-}
44
55-- | Type class, type family, and data family instance declarations.
6−
76module Ormolu.Printer.Meat.Declaration.Instance
8− ( p_clsInstDecl
9− , p_tyFamInstDecl
10− , p_dataFamInstDecl
11− , p_standaloneDerivDecl
7+ ( p_clsInstDecl,
8+ p_tyFamInstDecl,
9+ p_dataFamInstDecl,
10+ p_standaloneDerivDecl,
1211 )
1312where
1413
@@ -21,11 +20,11 @@ import Data.Ord (comparing)
2120import GHC
2221import Ormolu.Printer.Combinators
2322import Ormolu.Printer.Meat.Common
23+import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
2424import Ormolu.Printer.Meat.Declaration.Data
2525import Ormolu.Printer.Meat.Declaration.TypeFamily
2626import Ormolu.Printer.Meat.Type
2727import Ormolu.Utils
28−import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
2928
3029p_standaloneDerivDecl :: DerivDecl GhcPs -> R ()
3130p_standaloneDerivDecl DerivDecl {..} = do
@@ -76,13 +75,15 @@ p_clsInstDecl = \case
7675 vals = (getLoc &&& fmap (ValD NoExt)) <$> toList cid_binds
7776 tyFamInsts =
7877 ( getLoc &&& fmap (InstD NoExt . TyFamInstD NoExt)
79− ) <$> cid_tyfam_insts
78+ )
79+ <$> cid_tyfam_insts
8080 dataFamInsts =
8181 ( getLoc &&& fmap (InstD NoExt . DataFamInstD NoExt)
82− ) <$> cid_datafam_insts
82+ )
83+ <$> cid_datafam_insts
8384 allDecls =
84− snd <$>
85− sortBy (comparing fst) (sigs <> vals <> tyFamInsts <> dataFamInsts)
85+ snd
86+ <$> sortBy (comparing fst) (sigs <> vals <> tyFamInsts <> dataFamInsts)
8687 located hsib_body $ \x -> do
8788 breakpoint
8889 inci $ do
src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs+4−6
@@ -1,12 +1,11 @@
1−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE RecordWildCards #-}
44{-# LANGUAGE TypeFamilies #-}
55
66-- | Rendering of Role annotation declarations.
7−
87module Ormolu.Printer.Meat.Declaration.RoleAnnotation
9− ( p_roleAnnot
8+ ( p_roleAnnot,
109 )
1110where
1211
@@ -30,8 +29,7 @@ p_roleAnnot' l_name anns = do
3029 inci $ do
3130 p_rdrName l_name
3231 breakpoint
33− let
34− p_role' = maybe (txt "_") p_role
32+ let p_role' = maybe (txt "_") p_role
3533 inci . sitcc $ sep breakpoint (sitcc . located' p_role') anns
3634
3735p_role :: Role -> R ()
src/Ormolu/Printer/Meat/Declaration/Rule.hs+6−5
@@ -1,9 +1,9 @@
1−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE RecordWildCards #-}
44
55module Ormolu.Printer.Meat.Declaration.Rule
6− ( p_ruleDecls
6+ ( p_ruleDecls,
77 )
88where
99
@@ -17,8 +17,9 @@ import Ormolu.Utils
1717
1818p_ruleDecls :: RuleDecls GhcPs -> R ()
1919p_ruleDecls = \case
20− HsRules NoExt _ xs -> pragma "RULES" . sitcc $
21− sep breakpoint (sitcc . located' p_ruleDecl) xs
20+ HsRules NoExt _ xs ->
21+ pragma "RULES" . sitcc $
22+ sep breakpoint (sitcc . located' p_ruleDecl) xs
2223 XRuleDecls NoExt -> notImplemented "XRuleDecls"
2324
2425p_ruleDecl :: RuleDecl GhcPs -> R ()
src/Ormolu/Printer/Meat/Declaration/Signature.hs+77−58
@@ -1,13 +1,12 @@
1−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE RecordWildCards #-}
44
55-- | Type signature declarations.
6−
76module Ormolu.Printer.Meat.Declaration.Signature
8− ( p_sigDecl
9− , p_typeAscription
10− , p_activation
7+ ( p_sigDecl,
8+ p_typeAscription,
9+ p_activation,
1110 )
1211where
1312
@@ -35,13 +34,16 @@ p_sigDecl = \case
3534 SCCFunSig NoExt _ name literal -> p_sccSig name literal
3635 _ -> notImplemented "certain types of signature declarations"
3736
38−p_typeSig
39− :: Bool -- ^ Should the tail of the names be indented
40− -> [Located RdrName] -- ^ Names (before @::@)
41− -> LHsSigWcType GhcPs -- ^ Type
42− -> R ()
37+p_typeSig ::
38+ -- | Should the tail of the names be indented
39+ Bool ->
40+ -- | Names (before @::@)
41+ [Located RdrName] ->
42+ -- | Type
43+ LHsSigWcType GhcPs ->
44+ R ()
4345p_typeSig _ [] _ = return () -- should not happen though
44−p_typeSig indentTail (n:ns) hswc = do
46+p_typeSig indentTail (n : ns) hswc = do
4547 p_rdrName n
4648 if null ns
4749 then p_typeAscription hswc
@@ -51,9 +53,9 @@ p_typeSig indentTail (n:ns) hswc = do
5153 sep (comma >> breakpoint) p_rdrName ns
5254 p_typeAscription hswc
5355
54−p_typeAscription
55− :: LHsSigWcType GhcPs
56− -> R ()
56+p_typeAscription ::
57+ LHsSigWcType GhcPs ->
58+ R ()
5759p_typeAscription HsWC {..} = do
5860 space
5961 inci $ do
@@ -65,10 +67,10 @@ p_typeAscription HsWC {..} = do
6567 located t p_hsType
6668p_typeAscription (XHsWildCardBndrs NoExt) = notImplemented "XHsWildCardBndrs"
6769
68−p_patSynSig
69− :: [Located RdrName]
70− -> HsImplicitBndrs GhcPs (LHsType GhcPs)
71− -> R ()
70+p_patSynSig ::
71+ [Located RdrName] ->
72+ HsImplicitBndrs GhcPs (LHsType GhcPs) ->
73+ R ()
7274p_patSynSig names hsib = do
7375 txt "pattern"
7476 let body = p_typeSig False names HsWC {hswc_ext = NoExt, hswc_body = hsib}
@@ -76,18 +78,21 @@ p_patSynSig names hsib = do
7678 then breakpoint >> inci body
7779 else space >> body
7880
79−p_classOpSig
80− :: Bool -- ^ Whether this is a \"default\" signature
81− -> [Located RdrName] -- ^ Names (before @::@)
82− -> HsImplicitBndrs GhcPs (LHsType GhcPs) -- ^ Type
83− -> R ()
84−p_classOpSig def names hsib = do
81+p_classOpSig ::
82+ -- | Whether this is a \"default\" signature
83+ Bool ->
84+ -- | Names (before @::@)
85+ [Located RdrName] ->
86+ -- | Type
87+ HsImplicitBndrs GhcPs (LHsType GhcPs) ->
88+ R ()
89+p_classOpSig def names hsib = do
8590 when def (txt "default" >> space)
8691 p_typeSig True names HsWC {hswc_ext = NoExt, hswc_body = hsib}
8792
88−p_fixSig
89− :: FixitySig GhcPs
90− -> R ()
93+p_fixSig ::
94+ FixitySig GhcPs ->
95+ R ()
9196p_fixSig = \case
9297 FixitySig NoExt names (Fixity _ n dir) -> do
9398 txt $ case dir of
@@ -100,10 +105,12 @@ p_fixSig = \case
100105 sitcc $ sep (comma >> breakpoint) p_rdrName names
101106 XFixitySig NoExt -> notImplemented "XFixitySig"
102107
103−p_inlineSig
104− :: Located RdrName -- ^ Name
105− -> InlinePragma -- ^ Inline pragma specification
106− -> R ()
108+p_inlineSig ::
109+ -- | Name
110+ Located RdrName ->
111+ -- | Inline pragma specification
112+ InlinePragma ->
113+ R ()
107114p_inlineSig name InlinePragma {..} = pragmaBraces $ do
108115 p_inlineSpec inl_inline
109116 space
@@ -115,11 +122,14 @@ p_inlineSig name InlinePragma {..} = pragmaBraces $ do
115122 space
116123 p_rdrName name
117124
118−p_specSig
119− :: Located RdrName -- ^ Name
120− -> [LHsSigType GhcPs] -- ^ The types to specialize to
121− -> InlinePragma -- ^ For specialize inline
122− -> R ()
125+p_specSig ::
126+ -- | Name
127+ Located RdrName ->
128+ -- | The types to specialize to
129+ [LHsSigType GhcPs] ->
130+ -- | For specialize inline
131+ InlinePragma ->
132+ R ()
123133p_specSig name ts InlinePragma {..} = pragmaBraces $ do
124134 txt "SPECIALIZE"
125135 space
@@ -154,35 +164,44 @@ p_activation = \case
154164 txt "]"
155165
156166p_specInstSig :: LHsSigType GhcPs -> R ()
157−p_specInstSig hsib = pragma "SPECIALIZE instance" . inci $
158− located (hsib_body hsib) p_hsType
159−
160−p_minimalSig
161− :: LBooleanFormula (Located RdrName) -- ^ Boolean formula
162− -> R ()
167+p_specInstSig hsib =
168+ pragma "SPECIALIZE instance" . inci $
169+ located (hsib_body hsib) p_hsType
170+
171+p_minimalSig ::
172+ -- | Boolean formula
173+ LBooleanFormula (Located RdrName) ->
174+ R ()
163175p_minimalSig =
164176 located' $ \booleanFormula ->
165177 pragma "MINIMAL" (inci $ p_booleanFormula booleanFormula)
166178
167−p_booleanFormula
168− :: BooleanFormula (Located RdrName) -- ^ Boolean formula
169− -> R ()
179+p_booleanFormula ::
180+ -- | Boolean formula
181+ BooleanFormula (Located RdrName) ->
182+ R ()
170183p_booleanFormula = \case
171184 Var name -> p_rdrName name
172− And xs -> sitcc $ sep
173− (comma >> breakpoint)
174− (located' p_booleanFormula)
175− xs
176− Or xs -> sitcc $ sep
177− (breakpoint >> txt "| ")
178− (located' p_booleanFormula)
179− xs
185+ And xs ->
186+ sitcc $
187+ sep
188+ (comma >> breakpoint)
189+ (located' p_booleanFormula)
190+ xs
191+ Or xs ->
192+ sitcc $
193+ sep
194+ (breakpoint >> txt "| ")
195+ (located' p_booleanFormula)
196+ xs
180197 Parens l -> located l (parens N . p_booleanFormula)
181198
182−p_completeSig
183− :: Located [Located RdrName] -- ^ Constructors\/patterns
184− -> Maybe (Located RdrName) -- ^ Type
185− -> R ()
199+p_completeSig ::
200+ -- | Constructors\/patterns
201+ Located [Located RdrName] ->
202+ -- | Type
203+ Maybe (Located RdrName) ->
204+ R ()
186205p_completeSig cs' mty =
187206 located cs' $ \cs ->
188207 pragma "COMPLETE" . inci $ do
src/Ormolu/Printer/Meat/Declaration/Splice.hs+1−1
@@ -1,7 +1,7 @@
11{-# LANGUAGE LambdaCase #-}
22
33module Ormolu.Printer.Meat.Declaration.Splice
4− ( p_spliceDecl
4+ ( p_spliceDecl,
55 )
66where
77
src/Ormolu/Printer/Meat/Declaration/Type.hs+13−10
@@ -1,10 +1,9 @@
11{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE RecordWildCards #-}
33
44-- | Rendering of type synonym declarations.
5−
65module Ormolu.Printer.Meat.Declaration.Type
7− ( p_synDecl
6+ ( p_synDecl,
87 )
98where
109
@@ -15,19 +14,23 @@ import Ormolu.Printer.Meat.Type
1514import RdrName (RdrName (..))
1615import SrcLoc (Located)
1716
18−p_synDecl
19− :: Located RdrName -- ^ Type constructor
20− -> LexicalFixity -- ^ Fixity
21− -> LHsQTyVars GhcPs -- ^ Type variables
22− -> LHsType GhcPs -- ^ RHS of type declaration
23− -> R ()
17+p_synDecl ::
18+ -- | Type constructor
19+ Located RdrName ->
20+ -- | Fixity
21+ LexicalFixity ->
22+ -- | Type variables
23+ LHsQTyVars GhcPs ->
24+ -- | RHS of type declaration
25+ LHsType GhcPs ->
26+ R ()
2427p_synDecl name fixity tvars t = do
2528 txt "type"
2629 space
2730 let HsQTvs {..} = tvars
2831 switchLayout (getLoc name : map getLoc hsq_explicit) $ do
2932 p_infixDefHelper
30− (case fixity of Infix -> True; _ -> False)
33+ (case fixity of { Infix -> True; _ -> False })
3134 inci
3235 (p_rdrName name)
3336 (map (located' p_hsTyVarBndr) hsq_explicit)
src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs+16−16
@@ -1,24 +1,23 @@
1−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE RecordWildCards #-}
44
55-- | Rendering of data\/type families.
6−
76module Ormolu.Printer.Meat.Declaration.TypeFamily
8− ( p_famDecl
9− , p_tyFamInstEqn
7+ ( p_famDecl,
8+ p_tyFamInstEqn,
109 )
1110where
1211
1312import BasicTypes (LexicalFixity (..))
1413import Control.Monad
15−import Data.Maybe (isNothing, isJust)
14+import Data.Maybe (isJust, isNothing)
1615import GHC
1716import Ormolu.Printer.Combinators
1817import Ormolu.Printer.Meat.Common
1918import Ormolu.Printer.Meat.Type
2019import Ormolu.Utils
21−import SrcLoc (Located, GenLocated (..))
20+import SrcLoc (GenLocated (..), Located)
2221
2322p_famDecl :: FamilyStyle -> FamilyDecl GhcPs -> R ()
2423p_famDecl style FamilyDecl {..} = do
@@ -59,10 +58,10 @@ p_famDecl style FamilyDecl {..} = do
5958 sep newline (located' (inci . p_tyFamInstEqn)) eqs
6059p_famDecl _ (XFamilyDecl NoExt) = notImplemented "XFamilyDecl"
6160
62−p_familyResultSigL
63− :: Bool
64− -> Located (FamilyResultSig GhcPs)
65− -> Maybe (R ())
61+p_familyResultSigL ::
62+ Bool ->
63+ Located (FamilyResultSig GhcPs) ->
64+ Maybe (R ())
6665p_familyResultSigL injAnn l =
6766 case l of
6867 L _ a -> case a of
@@ -91,11 +90,12 @@ p_injectivityAnn (InjectivityAnn a bs) = do
9190p_tyFamInstEqn :: TyFamInstEqn GhcPs -> R ()
9291p_tyFamInstEqn HsIB {..} = do
9392 let FamEqn {..} = hsib_body
94− switchLayout (getLoc feqn_tycon : (getLoc <$> feqn_pats)) $ p_infixDefHelper
95− (isInfix feqn_fixity)
96− inci
97− (p_rdrName feqn_tycon)
98− (located' p_hsType <$> feqn_pats)
93+ switchLayout (getLoc feqn_tycon : (getLoc <$> feqn_pats)) $
94+ p_infixDefHelper
95+ (isInfix feqn_fixity)
96+ inci
97+ (p_rdrName feqn_tycon)
98+ (located' p_hsType <$> feqn_pats)
9999 space
100100 txt "="
101101 breakpoint
src/Ormolu/Printer/Meat/Declaration/Value.hs+281−241
@@ -1,13 +1,13 @@
1−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE RecordWildCards #-}
44
55module Ormolu.Printer.Meat.Declaration.Value
6− ( p_valDecl
7− , p_pat
8− , p_hsExpr
9− , p_hsSplice
10− , p_stringLit
6+ ( p_valDecl,
7+ p_pat,
8+ p_hsExpr,
9+ p_hsSplice,
10+ p_stringLit,
1111 )
1212where
1313
@@ -20,11 +20,14 @@ import Data.Char (isPunctuation, isSymbol)
2020import Data.Data hiding (Infix, Prefix)
2121import Data.List (intersperse, sortOn)
2222import Data.List.NonEmpty (NonEmpty ((:|)))
23+import qualified Data.List.NonEmpty as NE
2324import Data.Text (Text)
25+import qualified Data.Text as Text
2426import GHC
2527import OccName (mkVarOcc)
2628import Ormolu.Printer.Combinators
2729import Ormolu.Printer.Meat.Common
30+import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
2831import Ormolu.Printer.Meat.Declaration.Signature
2932import Ormolu.Printer.Meat.Type
3033import Ormolu.Printer.Operators
@@ -32,12 +35,8 @@ import Ormolu.Utils
3235import RdrName (RdrName (..))
3336import RdrName (rdrNameOcc)
3437import SrcLoc (combineSrcSpans, isOneLineSpan)
35−import qualified Data.List.NonEmpty as NE
36−import qualified Data.Text as Text
37−import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
3838
3939-- | Style of a group of equations.
40−
4140data MatchGroupStyle
4241 = Function (Located RdrName)
4342 | PatternBind
@@ -46,21 +45,21 @@ data MatchGroupStyle
4645 | LambdaCase
4746
4847-- | Style of equations in a group.
49−
5048data GroupStyle
5149 = EqualSign
5250 | RightArrow
5351
5452-- | Expression placement. This marks the places where expressions that
5553-- implement handing forms may use them.
56−
5754data Placement
58− = Normal -- ^ Multi-line layout should cause
59− -- insertion of a newline and indentation
60− -- bump
61− | Hanging -- ^ Expressions that have hanging form
62− -- should use it and avoid bumping one level
63− -- of indentation
55+ = -- | Multi-line layout should cause
56+ -- insertion of a newline and indentation
57+ -- bump
58+ Normal
59+ | -- | Expressions that have hanging form
60+ -- should use it and avoid bumping one level
61+ -- of indentation
62+ Hanging
6463 deriving (Eq)
6564
6665p_valDecl :: HsBindLR GhcPs GhcPs -> R ()
@@ -72,25 +71,29 @@ p_valDecl = \case
7271 PatSynBind NoExt psb -> p_patSynBind psb
7372 XHsBindsLR NoExt -> notImplemented "XHsBindsLR"
7473
75−p_funBind
76− :: Located RdrName
77− -> MatchGroup GhcPs (LHsExpr GhcPs)
78− -> R ()
74+p_funBind ::
75+ Located RdrName ->
76+ MatchGroup GhcPs (LHsExpr GhcPs) ->
77+ R ()
7978p_funBind name = p_matchGroup (Function name)
8079
81−p_matchGroup
82− :: MatchGroupStyle
83− -> MatchGroup GhcPs (LHsExpr GhcPs)
84− -> R ()
80+p_matchGroup ::
81+ MatchGroupStyle ->
82+ MatchGroup GhcPs (LHsExpr GhcPs) ->
83+ R ()
8584p_matchGroup = p_matchGroup' exprPlacement p_hsExpr
8685
87−p_matchGroup'
88− :: Data body
89− => (body -> Placement) -- ^ How to get body placement
90− -> (body -> R ()) -- ^ How to print body
91− -> MatchGroupStyle -- ^ Style of this group of equations
92− -> MatchGroup GhcPs (Located body) -- ^ Match group
93− -> R ()
86+p_matchGroup' ::
87+ Data body =>
88+ -- | How to get body placement
89+ (body -> Placement) ->
90+ -- | How to print body
91+ (body -> R ()) ->
92+ -- | Style of this group of equations
93+ MatchGroupStyle ->
94+ -- | Match group
95+ MatchGroup GhcPs (Located body) ->
96+ R ()
9497p_matchGroup' placer render style MG {..} = do
9598 let ob = case style of
9699 Case -> id
@@ -119,11 +122,10 @@ p_matchGroup' _ _ _ (XMatchGroup NoExt) = notImplemented "XMatchGroup"
119122-- and paretheses) associated with them. It is necessary to use per-equation
120123-- names obtained from 'm_ctxt' of 'Match'. This function replaces function
121124-- name inside of 'Function' accordingly.
122−
123−adjustMatchGroupStyle
124− :: Match GhcPs body
125− -> MatchGroupStyle
126− -> MatchGroupStyle
125+adjustMatchGroupStyle ::
126+ Match GhcPs body ->
127+ MatchGroupStyle ->
128+ MatchGroupStyle
127129adjustMatchGroupStyle m = \case
128130 Function _ -> (Function . mc_fun . m_ctxt) m
129131 style -> style
@@ -131,28 +133,40 @@ adjustMatchGroupStyle m = \case
131133matchStrictness :: Match id body -> SrcStrictness
132134matchStrictness match =
133135 case m_ctxt match of
134− FunRhs{mc_strictness=s} -> s
136+ FunRhs {mc_strictness = s} -> s
135137 _ -> NoSrcStrict
136138
137−p_match
138− :: MatchGroupStyle -- ^ Style of the group
139− -> Bool -- ^ Is this an infix match?
140− -> SrcStrictness -- ^ Strictness prefix (FunBind)
141− -> [LPat GhcPs] -- ^ Argument patterns
142− -> GRHSs GhcPs (LHsExpr GhcPs) -- ^ Equations
143− -> R ()
139+p_match ::
140+ -- | Style of the group
141+ MatchGroupStyle ->
142+ -- | Is this an infix match?
143+ Bool ->
144+ -- | Strictness prefix (FunBind)
145+ SrcStrictness ->
146+ -- | Argument patterns
147+ [LPat GhcPs] ->
148+ -- | Equations
149+ GRHSs GhcPs (LHsExpr GhcPs) ->
150+ R ()
144151p_match = p_match' exprPlacement p_hsExpr
145152
146−p_match'
147− :: Data body
148− => (body -> Placement) -- ^ How to get body placement
149− -> (body -> R ()) -- ^ How to print body
150− -> MatchGroupStyle -- ^ Style of this group of equations
151− -> Bool -- ^ Is this an infix match?
152− -> SrcStrictness -- ^ Strictness prefix (FunBind)
153− -> [LPat GhcPs] -- ^ Argument patterns
154− -> GRHSs GhcPs (Located body) -- ^ Equations
155− -> R ()
153+p_match' ::
154+ Data body =>
155+ -- | How to get body placement
156+ (body -> Placement) ->
157+ -- | How to print body
158+ (body -> R ()) ->
159+ -- | Style of this group of equations
160+ MatchGroupStyle ->
161+ -- | Is this an infix match?
162+ Bool ->
163+ -- | Strictness prefix (FunBind)
164+ SrcStrictness ->
165+ -- | Argument patterns
166+ [LPat GhcPs] ->
167+ -- | Equations
168+ GRHSs GhcPs (Located body) ->
169+ R ()
156170p_match' placer render style isInfix strictness m_pats m_grhss = do
157171 -- NOTE Normally, since patterns may be placed in a multi-line layout, it
158172 -- is necessary to bump indentation for the pattern group so it's more
@@ -170,11 +184,13 @@ p_match' placer render style isInfix strictness m_pats m_grhss = do
170184 Function name -> p_rdrName name
171185 _ -> return ()
172186 Just ne_pats -> do
173− let combinedSpans = combineSrcSpans' $
174− getLoc <$> ne_pats
175− inci' = if isOneLineSpan combinedSpans
176− then id
177− else inci
187+ let combinedSpans =
188+ combineSrcSpans' $
189+ getLoc <$> ne_pats
190+ inci' =
191+ if isOneLineSpan combinedSpans
192+ then id
193+ else inci
178194 switchLayout [combinedSpans] $ do
179195 let stdCase = sep breakpoint (located' p_pat) m_pats
180196 case style of
@@ -197,18 +213,17 @@ p_match' placer render style isInfix strictness m_pats m_grhss = do
197213 sitcc stdCase
198214 LambdaCase -> stdCase
199215 return inci'
200− let
201− -- Calculate position of end of patterns. This is useful when we decide
202− -- about putting certain constructions in hanging positions.
203− endOfPats = case NE.nonEmpty m_pats of
204− Nothing -> case style of
205− Function name -> (Just . srcSpanEnd . getLoc) name
206− _ -> Nothing
207− Just pats -> (Just . srcSpanEnd . getLoc . NE.last) pats
208− isCase = \case
209− Case -> True
210− LambdaCase -> True
211− _ -> False
216+ let -- Calculate position of end of patterns. This is useful when we decide
217+ -- about putting certain constructions in hanging positions.
218+ endOfPats = case NE.nonEmpty m_pats of
219+ Nothing -> case style of
220+ Function name -> (Just . srcSpanEnd . getLoc) name
221+ _ -> Nothing
222+ Just pats -> (Just . srcSpanEnd . getLoc . NE.last) pats
223+ isCase = \case
224+ Case -> True
225+ LambdaCase -> True
226+ _ -> False
212227 let GRHSs {..} = m_grhss
213228 hasGuards = withGuards grhssGRHSs
214229 unless (length grhssGRHSs > 1) $ do
@@ -218,10 +233,13 @@ p_match' placer render style isInfix strictness m_pats m_grhss = do
218233 PatternBind -> space >> txt "="
219234 s | isCase s && hasGuards -> return ()
220235 _ -> space >> txt "->"
221− let grhssSpan = combineSrcSpans' $
222− getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs
223− patGrhssSpan = maybe grhssSpan
224− (combineSrcSpans grhssSpan . srcLocSpan) endOfPats
236+ let grhssSpan =
237+ combineSrcSpans' $
238+ getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs
239+ patGrhssSpan =
240+ maybe grhssSpan
241+ (combineSrcSpans grhssSpan . srcLocSpan)
242+ endOfPats
225243 placement =
226244 case endOfPats of
227245 Nothing -> blockPlacement placer grhssGRHSs
@@ -233,8 +251,8 @@ p_match' placer render style isInfix strictness m_pats m_grhss = do
233251 p_body = do
234252 let groupStyle =
235253 if isCase style && hasGuards
236− then RightArrow
237− else EqualSign
254+ then RightArrow
255+ else EqualSign
238256 sep newline (located' (p_grhs' placer render groupStyle)) grhssGRHSs
239257 p_where = do
240258 let whereIsEmpty = GHC.isEmptyLocalBindsPR (unLoc grhssLocalBinds)
@@ -251,13 +269,15 @@ p_match' placer render style isInfix strictness m_pats m_grhss = do
251269p_grhs :: GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R ()
252270p_grhs = p_grhs' exprPlacement p_hsExpr
253271
254−p_grhs'
255− :: Data body
256− => (body -> Placement) -- ^ How to get body placement
257− -> (body -> R ()) -- ^ How to print body
258− -> GroupStyle
259− -> GRHS GhcPs (Located body)
260− -> R ()
272+p_grhs' ::
273+ Data body =>
274+ -- | How to get body placement
275+ (body -> Placement) ->
276+ -- | How to print body
277+ (body -> R ()) ->
278+ GroupStyle ->
279+ GRHS GhcPs (Located body) ->
280+ R ()
261281p_grhs' placer render style (GRHS NoExt guards body) =
262282 case guards of
263283 [] -> p_body
@@ -276,8 +296,8 @@ p_grhs' placer render style (GRHS NoExt guards body) =
276296 Nothing -> placer (unLoc body)
277297 Just spn ->
278298 if isOneLineSpan (mkSrcSpan spn (srcSpanStart (getLoc body)))
279− then placer (unLoc body)
280− else Normal
299+ then placer (unLoc body)
300+ else Normal
281301 endOfGuards =
282302 case NE.nonEmpty guards of
283303 Nothing -> Nothing
@@ -335,12 +355,15 @@ p_hsCmdTop = \case
335355p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()
336356p_stmt = p_stmt' exprPlacement p_hsExpr
337357
338−p_stmt'
339− :: Data body
340− => (body -> Placement) -- ^ Placer
341− -> (body -> R ()) -- ^ Render
342− -> Stmt GhcPs (Located body) -- ^ Statement to render
343− -> R ()
358+p_stmt' ::
359+ Data body =>
360+ -- | Placer
361+ (body -> Placement) ->
362+ -- | Render
363+ (body -> R ()) ->
364+ -- | Statement to render
365+ Stmt GhcPs (Located body) ->
366+ R ()
344367p_stmt' placer render = \case
345368 LastStmt NoExt body _ _ -> located body render
346369 BindStmt NoExt l f _ _ -> do
@@ -417,9 +440,10 @@ gatherStmtBlock XParStmtBlock {} = notImplemented "XParStmtBlock"
417440p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()
418441p_hsLocalBinds = \case
419442 HsValBinds NoExt (ValBinds NoExt bag lsigs) -> do
420− let ssStart = either
421− (srcSpanStart . getLoc)
422− (srcSpanStart . getLoc)
443+ let ssStart =
444+ either
445+ (srcSpanStart . getLoc)
446+ (srcSpanStart . getLoc)
423447 items =
424448 (Left <$> bagToList bag) ++ (Right <$> lsigs)
425449 p_item (Left x) = located x p_valDecl
@@ -427,15 +451,16 @@ p_hsLocalBinds = \case
427451 -- Assigns 'False' to the last element, 'True' to the rest.
428452 markInit :: [a] -> [(Bool, a)]
429453 markInit [] = []
430− markInit (x:[]) = [(False, x)]
431− markInit (x:xs) = (True, x) : markInit xs
454+ markInit (x : []) = [(False, x)]
455+ markInit (x : xs) = (True, x) : markInit xs
432456 -- NOTE When in a single-line layout, there is a chance that the inner
433457 -- elements will also contain semicolons and they will confuse the
434458 -- parser. so we request braces around every element except the last.
435459 br <- layoutToBraces <$> getLayout
436− sitcc $ sepSemi
437− (\(m, i) -> (if m then br else id) $ p_item i)
438− (markInit $ sortOn ssStart items)
460+ sitcc $
461+ sepSemi
462+ (\(m, i) -> (if m then br else id) $ p_item i)
463+ (markInit $ sortOn ssStart items)
439464 HsValBinds NoExt _ -> notImplemented "HsValBinds"
440465 HsIPBinds NoExt (IPBinds NoExt xs) ->
441466 -- Second argument of IPBind is always Left before type-checking.
@@ -451,9 +476,9 @@ p_hsLocalBinds = \case
451476 EmptyLocalBinds NoExt -> return ()
452477 XHsLocalBindsLR _ -> notImplemented "XHsLocalBindsLR"
453478
454−p_hsRecField
455− :: HsRecField' RdrName (LHsExpr GhcPs)
456− -> R ()
479+p_hsRecField ::
480+ HsRecField' RdrName (LHsExpr GhcPs) ->
481+ R ()
457482p_hsRecField = \HsRecField {..} -> do
458483 p_rdrName hsRecFieldLbl
459484 unless hsRecPun $ do
@@ -505,8 +530,8 @@ p_hsExpr' s = \case
505530 -- and then use 'p_withoutHanging' for the descendants.
506531 let p_withoutHanging (HsApp NoExt f' x') = do
507532 case f' of
508− L _ (HsApp _ _ _) -> located f' p_withoutHanging
509− _ -> located f' (p_hsExpr' s)
533+ L _ (HsApp _ _ _) -> located f' p_withoutHanging
534+ _ -> located f' (p_hsExpr' s)
510535 breakpoint
511536 inci $ located x' p_hsExpr
512537 p_withoutHanging e = p_hsExpr e
@@ -514,15 +539,16 @@ p_hsExpr' s = \case
514539 -- a single line.
515540 placement =
516541 if isOneLineSpan (getLoc f)
517− then exprPlacement (unLoc x)
518− else Normal
542+ then exprPlacement (unLoc x)
543+ else Normal
519544 -- We only sit when the last expression is not hanging.
520545 -- This is to allow:
521546 -- f = foo bar do
522547 -- baz
523− sit' = if placement == Normal
524− then sitcc
525− else id
548+ sit' =
549+ if placement == Normal
550+ then sitcc
551+ else id
526552 sit' $ do
527553 useBraces $ located f p_withoutHanging
528554 placeHanging placement $
@@ -559,10 +585,12 @@ p_hsExpr' s = \case
559585 Boxed -> parens
560586 Unboxed -> parensHash
561587 if isSection
562− then switchLayout [] . parens' s $
563− sep comma (located' p_hsTupArg) args
564− else switchLayout (getLoc <$> args) . parens' s . sitcc $
565− sep (comma >> breakpoint) (sitcc . located' p_hsTupArg) args
588+ then
589+ switchLayout [] . parens' s $
590+ sep comma (located' p_hsTupArg) args
591+ else
592+ switchLayout (getLoc <$> args) . parens' s . sitcc $
593+ sep (comma >> breakpoint) (sitcc . located' p_hsTupArg) args
566594 ExplicitSum NoExt tag arity e ->
567595 p_unboxedSum N tag arity (located e p_hsExpr)
568596 HsCase NoExt e mgroup ->
@@ -580,16 +608,20 @@ p_hsExpr' s = \case
580608 txt header
581609 breakpoint
582610 ub <- layoutToBraces <$> getLayout
583− inci $ sepSemi
584− (located' (ub . p_stmt' exprPlacement (p_hsExpr' S)))
585− (unLoc es)
611+ inci $
612+ sepSemi
613+ (located' (ub . p_stmt' exprPlacement (p_hsExpr' S)))
614+ (unLoc es)
586615 compBody = brackets N $ located es $ \xs -> do
587− let p_parBody = sep
588− (breakpoint >> txt "| ")
589− p_seqBody
590− p_seqBody = sitcc . sep
591− (comma >> breakpoint)
592− (located' (sitcc . p_stmt))
616+ let p_parBody =
617+ sep
618+ (breakpoint >> txt "| ")
619+ p_seqBody
620+ p_seqBody =
621+ sitcc
622+ . sep
623+ (comma >> breakpoint)
624+ (located' (sitcc . p_stmt))
593625 stmts = init xs
594626 yield = last xs
595627 lists = foldr (liftAppend . gatherStmt) [] stmts
@@ -603,7 +635,7 @@ p_hsExpr' s = \case
603635 MDoExpr -> doBody "mdo"
604636 ListComp -> compBody
605637 MonadComp -> notImplemented "MonadComp"
606− ArrowExpr -> notImplemented "ArrowExpr"
638+ ArrowExpr -> notImplemented "ArrowExpr"
607639 GhciStmtCtxt -> notImplemented "GhciStmtCtxt"
608640 PatGuard _ -> notImplemented "PatGuard"
609641 ParStmtCtxt _ -> notImplemented "ParStmtCtxt"
@@ -615,11 +647,12 @@ p_hsExpr' s = \case
615647 located rcon_con_name atom
616648 breakpoint
617649 let HsRecFields {..} = rcon_flds
618− updName f = f {
619− hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
620− FieldOcc _ n -> n
621− XFieldOcc _ -> notImplemented "XFieldOcc"
622− }
650+ updName f =
651+ f
652+ { hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
653+ FieldOcc _ n -> n
654+ XFieldOcc _ -> notImplemented "XFieldOcc"
655+ }
623656 fields = located' (p_hsRecField . updName) <$> rec_flds
624657 dotdot =
625658 case rec_dotdot of
@@ -630,12 +663,13 @@ p_hsExpr' s = \case
630663 RecordUpd {..} -> do
631664 located rupd_expr p_hsExpr
632665 breakpoint
633− let updName f = f {
634− hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
635− Ambiguous _ n -> n
636− Unambiguous _ n -> n
637− XAmbiguousFieldOcc _ -> notImplemented "XAmbiguousFieldOcc"
638− }
666+ let updName f =
667+ f
668+ { hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
669+ Ambiguous _ n -> n
670+ Unambiguous _ n -> n
671+ XAmbiguousFieldOcc _ -> notImplemented "XAmbiguousFieldOcc"
672+ }
639673 inci . braces N . sitcc $
640674 sep
641675 (comma >> breakpoint)
@@ -697,7 +731,7 @@ p_hsExpr' s = \case
697731 txt "->"
698732 placeHanging (cmdTopPlacement (unLoc e)) $
699733 located e p_hsCmdTop
700− HsStatic _ e -> do
734+ HsStatic _ e -> do
701735 txt "static"
702736 breakpoint
703737 inci (located e p_hsExpr)
@@ -736,7 +770,7 @@ p_patSynBind PSB {..} = do
736770 txt "<-"
737771 breakpoint
738772 located psb_def p_pat
739− ImplicitBidirectional -> do
773+ ImplicitBidirectional -> do
740774 txt "="
741775 breakpoint
742776 located psb_def p_pat
@@ -753,7 +787,7 @@ p_patSynBind PSB {..} = do
753787 PrefixCon xs -> do
754788 space
755789 p_rdrName psb_id
756− inci $ do
790+ inci $ do
757791 switchLayout (getLoc <$> xs) $ do
758792 unless (null xs) breakpoint
759793 sitcc (sep breakpoint p_rdrName xs)
@@ -779,13 +813,17 @@ p_patSynBind PSB {..} = do
779813 inci rhs
780814p_patSynBind (XPatSynBind NoExt) = notImplemented "XPatSynBind"
781815
782−p_case
783− :: Data body
784− => (body -> Placement) -- ^ Placer
785− -> (body -> R ()) -- ^ Render
786− -> LHsExpr GhcPs -- ^ Expression
787− -> (MatchGroup GhcPs (Located body)) -- ^ Match group
788− -> R ()
816+p_case ::
817+ Data body =>
818+ -- | Placer
819+ (body -> Placement) ->
820+ -- | Render
821+ (body -> R ()) ->
822+ -- | Expression
823+ LHsExpr GhcPs ->
824+ -- | Match group
825+ (MatchGroup GhcPs (Located body)) ->
826+ R ()
789827p_case placer render e mgroup = do
790828 txt "case"
791829 space
@@ -795,14 +833,19 @@ p_case placer render e mgroup = do
795833 breakpoint
796834 inci (p_matchGroup' placer render Case mgroup)
797835
798−p_if
799− :: Data body
800− => (body -> Placement) -- ^ Placer
801− -> (body -> R ()) -- ^ Render
802− -> LHsExpr GhcPs -- ^ If
803− -> Located body -- ^ Then
804− -> Located body -- ^ Else
805− -> R ()
836+p_if ::
837+ Data body =>
838+ -- | Placer
839+ (body -> Placement) ->
840+ -- | Render
841+ (body -> R ()) ->
842+ -- | If
843+ LHsExpr GhcPs ->
844+ -- | Then
845+ Located body ->
846+ -- | Else
847+ Located body ->
848+ R ()
806849p_if placer render if' then' else' = do
807850 txt "if"
808851 space
@@ -817,12 +860,13 @@ p_if placer render if' then' else' = do
817860 located else' $ \x ->
818861 placeHanging (placer x) (render x)
819862
820−p_let
821− :: Data body
822− => (body -> R ()) -- ^ Render
823− -> Located (HsLocalBindsLR GhcPs GhcPs)
824− -> Located body
825− -> R ()
863+p_let ::
864+ Data body =>
865+ -- | Render
866+ (body -> R ()) ->
867+ Located (HsLocalBindsLR GhcPs GhcPs) ->
868+ Located body ->
869+ R ()
826870p_let render localBinds e = sitcc $ do
827871 txt "let"
828872 space
@@ -919,7 +963,7 @@ p_unboxedSum s tag arity m = do
919963 let before = tag - 1
920964 after = arity - before - 1
921965 args = replicate before Nothing <> [Just m] <> replicate after Nothing
922− f (x,i) = do
966+ f (x, i) = do
923967 let isFirst = i == 0
924968 isLast = i == arity - 1
925969 case x :: Maybe (R ()) of
@@ -929,7 +973,7 @@ p_unboxedSum s tag arity m = do
929973 unless isFirst space
930974 m'
931975 unless isLast space
932− parensHash s $ sep (txt "|") f (zip args [0..])
976+ parensHash s $ sep (txt "|") f (zip args [0 ..])
933977
934978p_hsSplice :: HsSplice GhcPs -> R ()
935979p_hsSplice = \case
@@ -946,11 +990,14 @@ p_hsSplice = \case
946990 HsSpliced {} -> notImplemented "HsSpliced"
947991 XSplice {} -> notImplemented "XSplice"
948992
949−p_hsSpliceTH
950− :: Bool -- ^ Typed splice?
951− -> LHsExpr GhcPs -- ^ Splice expression
952− -> SpliceDecoration -- ^ Splice decoration
953− -> R ()
993+p_hsSpliceTH ::
994+ -- | Typed splice?
995+ Bool ->
996+ -- | Splice expression
997+ LHsExpr GhcPs ->
998+ -- | Splice decoration
999+ SpliceDecoration ->
1000+ R ()
9541001p_hsSpliceTH isTyped expr = \case
9551002 HasParens -> do
9561003 txt decoSymbol
@@ -968,7 +1015,7 @@ p_hsBracket = \case
9681015 ExpBr NoExt expr -> do
9691016 anns <- getEnclosingAnns
9701017 let name = case anns of
971− AnnOpenEQ:_ -> ""
1018+ AnnOpenEQ : _ -> ""
9721019 _ -> "e"
9731020 quote name (located expr p_hsExpr)
9741021 PatBr NoExt pat -> quote "p" (located pat p_pat)
@@ -983,10 +1030,11 @@ p_hsBracket = \case
9831030 -- turn makes it impossible to detect if there are parentheses around
9841031 -- it, etc. So we have to add parentheses manually assuming they are
9851032 -- necessary for all operators.
986− let isOperator = all
987− (\i -> isPunctuation i || isSymbol i)
988− (showOutputable (rdrNameOcc name))
989− && not (doesNotNeedExtraParens name)
1033+ let isOperator =
1034+ all
1035+ (\i -> isPunctuation i || isSymbol i)
1036+ (showOutputable (rdrNameOcc name))
1037+ && not (doesNotNeedExtraParens name)
9901038 wrapper = if isOperator then parens N else id
9911039 wrapper $ p_rdrName (noLoc name)
9921040 TExpBr NoExt expr -> do
@@ -1019,50 +1067,46 @@ p_stringLit src =
10191067 multiLine =
10201068 sitcc $ sep breakpoint (txt . Text.pack) (backslashes s)
10211069 in vlayout singleLine multiLine
1022− where
1023− -- Split a string on gaps (backslash delimited whitespaces)
1024− --
1025− -- > splitGaps "bar\\ \\fo\\&o" == ["bar", "fo\\&o"]
1026− splitGaps :: String -> [String]
1027− splitGaps "" = []
1028− splitGaps s =
1029− let -- A backslash and a whitespace starts a "gap"
1030− p (Just '\\', _, _) = True
1031− p (_, '\\', Just c) | ghcSpace c = False
1032− p _ = True
1033− in case span p (zipPrevNext s) of
1034− (l, r) ->
1035− let -- drop the initial '\', any amount of 'ghcSpace', and another '\'
1070+ where
1071+ -- Split a string on gaps (backslash delimited whitespaces)
1072+ --
1073+ -- > splitGaps "bar\\ \\fo\\&o" == ["bar", "fo\\&o"]
1074+ splitGaps :: String -> [String]
1075+ splitGaps "" = []
1076+ splitGaps s =
1077+ let -- A backslash and a whitespace starts a "gap"
1078+ p (Just '\\', _, _) = True
1079+ p (_, '\\', Just c) | ghcSpace c = False
1080+ p _ = True
1081+ in case span p (zipPrevNext s) of
1082+ (l, r) ->
1083+ let -- drop the initial '\', any amount of 'ghcSpace', and another '\'
10361084 r' = drop 1 . dropWhile ghcSpace . drop 1 $ map orig r
1037− in map orig l : splitGaps r'
1038−
1039− -- GHC's definition of whitespaces in strings
1040− -- See: https://gitlab.haskell.org/ghc/ghc/blob/86753475/compiler/parser/Lexer.x#L1653
1041− ghcSpace :: Char -> Bool
1042− ghcSpace c = c <= '\x7f' && is_space c
1043−
1044− -- Add backslashes to the inner side of the strings
1045− --
1046− -- > backslashes ["a", "b", "c"] == ["a\\", "\\b\\", "\\c"]
1047− backslashes :: [String] -> [String]
1048− backslashes (x:y:xs) = (x ++ "\\") : backslashes (('\\' : y) : xs)
1049− backslashes xs = xs
1050−
1051− -- Attaches previous and next items to each list element
1052− zipPrevNext :: [a] -> [(Maybe a, a, Maybe a)]
1053− zipPrevNext xs =
1054− let z = zip (zip (Nothing : map Just xs) xs)
1055− (map Just (tail xs) ++ repeat Nothing)
1056− in map (\((p, x), n) -> (p, x, n)) z
1057−
1058− orig (_, x, _) = x
1085+ in map orig l : splitGaps r'
1086+ -- GHC's definition of whitespaces in strings
1087+ -- See: https://gitlab.haskell.org/ghc/ghc/blob/86753475/compiler/parser/Lexer.x#L1653
1088+ ghcSpace :: Char -> Bool
1089+ ghcSpace c = c <= '\x7f' && is_space c
1090+ -- Add backslashes to the inner side of the strings
1091+ --
1092+ -- > backslashes ["a", "b", "c"] == ["a\\", "\\b\\", "\\c"]
1093+ backslashes :: [String] -> [String]
1094+ backslashes (x : y : xs) = (x ++ "\\") : backslashes (('\\' : y) : xs)
1095+ backslashes xs = xs
1096+ -- Attaches previous and next items to each list element
1097+ zipPrevNext :: [a] -> [(Maybe a, a, Maybe a)]
1098+ zipPrevNext xs =
1099+ let z =
1100+ zip (zip (Nothing : map Just xs) xs)
1101+ (map Just (tail xs) ++ repeat Nothing)
1102+ in map (\((p, x), n) -> (p, x, n)) z
1103+ orig (_, x, _) = x
10591104
10601105----------------------------------------------------------------------------
10611106-- Helpers
10621107
10631108-- | Return the wrapping function controlling the use of braces according to
10641109-- the current layout.
1065−
10661110layoutToBraces :: Layout -> R () -> R ()
10671111layoutToBraces = \case
10681112 SingleLine -> useBraces
@@ -1070,7 +1114,6 @@ layoutToBraces = \case
10701114
10711115-- | Append each element in both lists with semigroups. If one list is shorter
10721116-- than the other, return the rest of the longer list unchanged.
1073−
10741117liftAppend :: Semigroup a => [a] -> [a] -> [a]
10751118liftAppend [] [] = []
10761119liftAppend [] (y : ys) = y : ys
@@ -1085,7 +1128,6 @@ getGRHSSpan (XGRHS NoExt) = notImplemented "XGRHS"
10851128-- | Place a thing that may have a hanging form. This function handles how
10861129-- to separate it from preceding expressions and whether to bump indentation
10871130-- depending on what sort of expression we have.
1088−
10891131placeHanging :: Placement -> R () -> R ()
10901132placeHanging placement m =
10911133 case placement of
@@ -1098,16 +1140,14 @@ placeHanging placement m =
10981140
10991141-- | Check if given block contains single expression which has a hanging
11001142-- form.
1101−
1102−blockPlacement
1103− :: (body -> Placement)
1104− -> [LGRHS GhcPs (Located body)]
1105− -> Placement
1143+blockPlacement ::
1144+ (body -> Placement) ->
1145+ [LGRHS GhcPs (Located body)] ->
1146+ Placement
11061147blockPlacement placer [(L _ (GRHS NoExt _ (L _ x)))] = placer x
11071148blockPlacement _ _ = Normal
11081149
11091150-- | Check if given command has a hanging form.
1110−
11111151cmdPlacement :: HsCmd GhcPs -> Placement
11121152cmdPlacement = \case
11131153 HsCmdLam NoExt _ -> Hanging
@@ -1121,14 +1161,13 @@ cmdTopPlacement = \case
11211161 XCmdTop {} -> notImplemented "XCmdTop"
11221162
11231163-- | Check if given expression has a hanging form.
1124−
11251164exprPlacement :: HsExpr GhcPs -> Placement
11261165exprPlacement = \case
11271166 -- Only hang lambdas with single line parameter lists
11281167 HsLam NoExt mg -> case mg of
1129− MG _ (L _ [L _ (Match NoExt _ (x:xs) _)]) _
1130− | isOneLineSpan (combineSrcSpans' $ fmap getLoc (x :| xs))
1131− -> Hanging
1168+ MG _ (L _ [L _ (Match NoExt _ (x : xs) _)]) _
1169+ | isOneLineSpan (combineSrcSpans' $ fmap getLoc (x :| xs)) ->
1170+ Hanging
11321171 _ -> Normal
11331172 HsLamCase NoExt _ -> Hanging
11341173 HsCase NoExt _ _ -> Hanging
@@ -1145,8 +1184,8 @@ exprPlacement = \case
11451184 -- Indentation breaks if pattern is longer than one line and left
11461185 -- hanging. Consequently, only apply hanging when it is safe.
11471186 if isOneLineSpan s
1148− then Hanging
1149− else Normal
1187+ then Hanging
1188+ else Normal
11501189 _ -> Normal
11511190
11521191withGuards :: [LGRHS GhcPs (Located body)] -> Bool
@@ -1165,11 +1204,13 @@ getOpName = \case
11651204 HsVar NoExt (L _ a) -> Just a
11661205 _ -> Nothing
11671206
1168−p_exprOpTree
1169− :: Bool -- ^ Can use special handling of dollar?
1170− -> BracketStyle -- ^ Bracket style to use
1171− -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
1172− -> R ()
1207+p_exprOpTree ::
1208+ -- | Can use special handling of dollar?
1209+ Bool ->
1210+ -- | Bracket style to use
1211+ BracketStyle ->
1212+ OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) ->
1213+ R ()
11731214p_exprOpTree _ s (OpNode x) = located x (p_hsExpr' s)
11741215p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
11751216 -- NOTE If the beginning of the first argument and the second argument
@@ -1179,8 +1220,8 @@ p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
11791220 if isOneLineSpan
11801221 (mkSrcSpan (srcSpanStart (opTreeLoc x)) (srcSpanStart (opTreeLoc y)))
11811222 then case y of
1182− OpNode (L _ n) -> exprPlacement n
1183− _ -> Normal
1223+ OpNode (L _ n) -> exprPlacement n
1224+ _ -> Normal
11841225 else Normal
11851226 opWrapper = case unLoc op of
11861227 EWildPat NoExt -> backticks
@@ -1194,8 +1235,9 @@ p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
11941235 gotDollar = case getOpName (unLoc op) of
11951236 Just rname -> mkVarOcc "$" == (rdrNameOcc rname)
11961237 _ -> False
1197− switchLayout [opTreeLoc x] $
1198− ub $ p_exprOpTree (not gotDollar) s x
1238+ switchLayout [opTreeLoc x]
1239+ $ ub
1240+ $ p_exprOpTree (not gotDollar) s x
11991241 let p_op = located op (opWrapper . p_hsExpr)
12001242 p_y = switchLayout [opTreeLoc y] (p_exprOpTree True N y)
12011243 if isDollarSpecial && gotDollar && placement == Normal && isOneLineSpan (opTreeLoc x)
@@ -1204,17 +1246,15 @@ p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
12041246 p_op
12051247 breakpoint
12061248 inci p_y
1207− else
1208− placeHanging placement $ do
1209− p_op
1210− space
1211− p_y
1249+ else placeHanging placement $ do
1250+ p_op
1251+ space
1252+ p_y
12121253
12131254-- | Get annotations for the enclosing element.
1214−
12151255getEnclosingAnns :: R [AnnKeywordId]
12161256getEnclosingAnns = do
12171257 e <- getEnclosingSpan (const True)
12181258 case e of
12191259 Nothing -> return []
1220− Just e' -> getAnns (RealSrcSpan e')
1260+ Just e' -> getAnns (RealSrcSpan e')
src/Ormolu/Printer/Meat/Declaration/Value.hs-boot+5−5
@@ -1,9 +1,9 @@
11module Ormolu.Printer.Meat.Declaration.Value
2− ( p_valDecl
3− , p_pat
4− , p_hsExpr
5− , p_hsSplice
6− , p_stringLit
2+ ( p_valDecl,
3+ p_pat,
4+ p_hsExpr,
5+ p_hsSplice,
6+ p_stringLit,
77 )
88where
99
src/Ormolu/Printer/Meat/Declaration/Warning.hs+3−3
@@ -1,9 +1,9 @@
1−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
33
44module Ormolu.Printer.Meat.Declaration.Warning
5− ( p_warnDecls
6− , p_moduleWarning
5+ ( p_warnDecls,
6+ p_moduleWarning,
77 )
88where
99
src/Ormolu/Printer/Meat/ImportExport.hs+15−17
@@ -1,12 +1,11 @@
1−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE RecordWildCards #-}
44
55-- | Rendering of import and export lists.
6−
76module Ormolu.Printer.Meat.ImportExport
8− ( p_hsmodExports
9− , p_hsmodImport
7+ ( p_hsmodExports,
8+ p_hsmodImport,
109 )
1110where
1211
@@ -84,13 +83,13 @@ p_lie encLayout (i, totalItems) = \case
8483 inci $ do
8584 let names :: [R ()]
8685 names = located' p_ieWrappedName <$> xs
87− parens N . sitcc $
88− sep (comma >> breakpoint) sitcc $
89− case w of
90− NoIEWildcard -> names
91− IEWildcard n ->
92− let (before, after) = splitAt n names
93− in before ++ [txt ".."] ++ after
86+ parens N . sitcc
87+ $ sep (comma >> breakpoint) sitcc
88+ $ case w of
89+ NoIEWildcard -> names
90+ IEWildcard n ->
91+ let (before, after) = splitAt n names
92+ in before ++ [txt ".."] ++ after
9493 p_comma
9594 IEModuleContents NoExt l1 -> do
9695 located l1 p_hsmodName
@@ -109,11 +108,10 @@ p_lie encLayout (i, totalItems) = \case
109108 MultiLine -> comma
110109
111110-- | Attach positions to 'Located' things in a list.
112−
113−attachPositions
114− :: [Located a]
115− -> [Located ((Int, Int), a)]
111+attachPositions ::
112+ [Located a] ->
113+ [Located ((Int, Int), a)]
116114attachPositions xs =
117115 let f i (L l x) = L l ((i, n), x)
118116 n = length xs
119− in zipWith f [0..] xs
117+ in zipWith f [0 ..] xs
src/Ormolu/Printer/Meat/Module.hs+3−4
@@ -1,11 +1,10 @@
1−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE RecordWildCards #-}
44
55-- | Rendering of modules.
6−
76module Ormolu.Printer.Meat.Module
8− ( p_hsModule
7+ ( p_hsModule,
98 )
109where
1110
src/Ormolu/Printer/Meat/Pragma.hs+7−8
@@ -1,18 +1,17 @@
1−-- | Pretty-printing of language pragmas.
2−
3−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
42{-# LANGUAGE OverloadedStrings #-}
5−{-# LANGUAGE TupleSections #-}
3+{-# LANGUAGE TupleSections #-}
64
5+-- | Pretty-printing of language pragmas.
76module Ormolu.Printer.Meat.Pragma
8− ( p_pragmas
7+ ( p_pragmas,
98 )
109where
1110
12−import Ormolu.Printer.Combinators
13−import Ormolu.Parser.Pragma (Pragma (..))
1411import qualified Data.Set as S
1512import qualified Data.Text as T
13+import Ormolu.Parser.Pragma (Pragma (..))
14+import Ormolu.Printer.Combinators
1615
1716data PragmaTy = Language | OptionsGHC | OptionsHaddock
1817 deriving (Eq, Ord)
@@ -23,7 +22,7 @@ p_pragmas ps =
2322 PragmaLanguage xs -> (Language,) <$> xs
2423 PragmaOptionsGHC x -> [(OptionsGHC, x)]
2524 PragmaOptionsHaddock x -> [(OptionsHaddock, x)]
26− in mapM_ (uncurry p_pragma) (S.toAscList . S.fromList . prepare $ ps)
25+ in mapM_ (uncurry p_pragma) (S.toAscList . S.fromList . prepare $ ps)
2726
2827p_pragma :: PragmaTy -> String -> R ()
2928p_pragma ty c = do
src/Ormolu/Printer/Meat/Type.hs+25−24
@@ -1,16 +1,15 @@
1−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE RecordWildCards #-}
44
55-- | Rendering of types.
6−
76module Ormolu.Printer.Meat.Type
8− ( p_hsType
9− , hasDocStrings
10− , p_hsContext
11− , p_hsTyVarBndr
12− , p_conDeclFields
13− , tyVarsToTypes
7+ ( p_hsType,
8+ hasDocStrings,
9+ p_hsContext,
10+ p_hsTyVarBndr,
11+ p_conDeclFields,
12+ tyVarsToTypes,
1413 )
1514where
1615
@@ -18,9 +17,9 @@ import BasicTypes
1817import GHC
1918import Ormolu.Printer.Combinators
2019import Ormolu.Printer.Meat.Common
20+import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Value (p_hsSplice, p_stringLit)
2121import Ormolu.Printer.Operators
2222import Ormolu.Utils
23−import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Value (p_hsSplice, p_stringLit)
2423
2524p_hsType :: HsType GhcPs -> R ()
2625p_hsType t = p_hsType' (hasDocStrings t) t
@@ -61,7 +60,7 @@ p_hsType' multilineArgs = \case
6160 txt "->"
6261 interArgBreak
6362 case y' of
64− HsFunTy{} -> p_hsTypeR y'
63+ HsFunTy {} -> p_hsTypeR y'
6564 _ -> located y p_hsTypeR
6665 HsListTy NoExt t ->
6766 located t (brackets N . p_hsType)
@@ -72,8 +71,8 @@ p_hsType' multilineArgs = \case
7271 HsBoxedTuple -> parens N
7372 HsConstraintTuple -> parens N
7473 HsBoxedOrConstraintTuple -> parens N
75− in parens' . sitcc $
76− sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
74+ in parens' . sitcc $
75+ sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
7776 HsSumTy NoExt xs ->
7877 parensHash N . sitcc $
7978 sep (txt "|" >> breakpoint) (sitcc . located' p_hsType) xs
@@ -127,14 +126,14 @@ p_hsType' multilineArgs = \case
127126 -- If both this list itself and the first element is promoted,
128127 -- we need to put a space in between or it fails to parse.
129128 case (p, xs) of
130− (Promoted, ((L _ t):_)) | isPromoted t -> space
129+ (Promoted, ((L _ t) : _)) | isPromoted t -> space
131130 _ -> return ()
132131 sitcc $ sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
133132 HsExplicitTupleTy NoExt xs -> do
134133 txt "'"
135134 parens N $ do
136135 case xs of
137− ((L _ t):_) | isPromoted t -> space
136+ ((L _ t) : _) | isPromoted t -> space
138137 _ -> return ()
139138 sep (comma >> breakpoint) (located' p_hsType) xs
140139 HsTyLit NoExt t ->
@@ -157,7 +156,6 @@ p_hsType' multilineArgs = \case
157156
158157-- | Return 'True' if at least one argument in 'HsType' has a doc string
159158-- attached to it.
160−
161159hasDocStrings :: HsType GhcPs -> Bool
162160hasDocStrings = \case
163161 HsDocTy _ _ _ -> True
@@ -168,8 +166,9 @@ p_hsContext :: HsContext GhcPs -> R ()
168166p_hsContext = \case
169167 [] -> txt "()"
170168 [x] -> located x p_hsType
171− xs -> parens N . sitcc $
172− sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
169+ xs ->
170+ parens N . sitcc $
171+ sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
173172
174173p_hsTyVarBndr :: HsTyVarBndr GhcPs -> R ()
175174p_hsTyVarBndr = \case
@@ -184,15 +183,17 @@ p_hsTyVarBndr = \case
184183 XTyVarBndr NoExt -> notImplemented "XTyVarBndr"
185184
186185p_conDeclFields :: [LConDeclField GhcPs] -> R ()
187−p_conDeclFields xs = braces N . sitcc $
188− sep (comma >> breakpoint) (sitcc . located' p_conDeclField) xs
186+p_conDeclFields xs =
187+ braces N . sitcc $
188+ sep (comma >> breakpoint) (sitcc . located' p_conDeclField) xs
189189
190190p_conDeclField :: ConDeclField GhcPs -> R ()
191191p_conDeclField ConDeclField {..} = do
192192 mapM_ (p_hsDocString Pipe True) cd_fld_doc
193− sitcc $ sep (comma >> breakpoint)
194− (located' (p_rdrName . rdrNameFieldOcc))
195− cd_fld_names
193+ sitcc $
194+ sep (comma >> breakpoint)
195+ (located' (p_rdrName . rdrNameFieldOcc))
196+ cd_fld_names
196197 space
197198 txt "::"
198199 breakpoint
@@ -228,5 +229,5 @@ tyVarToType = \case
228229 UserTyVar NoExt tvar -> HsTyVar NoExt NotPromoted tvar
229230 KindedTyVar NoExt tvar kind ->
230231 HsParTy NoExt $ noLoc $
231− HsKindSig NoExt (noLoc (HsTyVar NoExt NotPromoted tvar)) kind
232+ HsKindSig NoExt (noLoc (HsTyVar NoExt NotPromoted tvar)) kind
232233 XTyVarBndr {} -> notImplemented "XTyVarBndr"
src/Ormolu/Printer/Operators.hs+62−64
@@ -1,16 +1,16 @@
1−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE ScopedTypeVariables #-}
33
44-- | This module helps handle operator chains composed of different
55-- operators that may have different precedence and fixities.
6−
76module Ormolu.Printer.Operators
8− ( OpTree (..)
9− , opTreeLoc
10− , reassociateOpTree
11− ) where
7+ ( OpTree (..),
8+ opTreeLoc,
9+ reassociateOpTree,
10+ )
11+where
1212
13−import BasicTypes (Fixity (..), SourceText (NoSourceText), defaultFixity, compareFixity)
13+import BasicTypes (Fixity (..), SourceText (NoSourceText), compareFixity, defaultFixity)
1414import Data.Function (on)
1515import Data.List
1616import Data.Maybe (fromMaybe)
@@ -22,7 +22,6 @@ import SrcLoc (combineSrcSpans)
2222-- | Intermediate representation of operator trees. It has two type
2323-- parameters: @ty@ is the type of sub-expressions, while @op@ is the type
2424-- of operators.
25−
2625data OpTree ty op
2726 = OpNode ty
2827 | OpBranch
@@ -31,7 +30,6 @@ data OpTree ty op
3130 (OpTree ty op)
3231
3332-- | Return combined 'SrcSpan's of all elements in this 'OpTree'.
34−
3533opTreeLoc :: OpTree (Located a) b -> SrcSpan
3634opTreeLoc (OpNode (L l _)) = l
3735opTreeLoc (OpBranch l _ r) = combineSrcSpans (opTreeLoc l) (opTreeLoc r)
@@ -40,11 +38,13 @@ opTreeLoc (OpBranch l _ r) = combineSrcSpans (opTreeLoc l) (opTreeLoc r)
4038-- relative precedence of operators. Users are expected to first construct
4139-- an initial 'OpTree', then re-associate it using this function before
4240-- printing.
43−
44−reassociateOpTree
45− :: (op -> Maybe RdrName) -- ^ How to get name of an operator
46− -> OpTree (Located ty) (Located op) -- ^ Original 'OpTree'
47− -> OpTree (Located ty) (Located op) -- ^ Re-associated 'OpTree'
41+reassociateOpTree ::
42+ -- | How to get name of an operator
43+ (op -> Maybe RdrName) ->
44+ -- | Original 'OpTree'
45+ OpTree (Located ty) (Located op) ->
46+ -- | Re-associated 'OpTree'
47+ OpTree (Located ty) (Located op)
4848reassociateOpTree getOpName opTree =
4949 reassociateOpTreeWith
5050 (buildFixityMap getOpName normOpTree)
@@ -54,20 +54,22 @@ reassociateOpTree getOpName opTree =
5454 normOpTree = normalizeOpTree opTree
5555
5656-- | Re-associate an 'OpTree' given the map with operator fixities.
57−
58−reassociateOpTreeWith
59− :: forall ty op.
60− [(RdrName, Fixity)] -- ^ Fixity map for operators
61− -> (op -> Maybe RdrName) -- ^ How to get the name of an operator
62− -> OpTree ty op -- ^ Original 'OpTree'
63− -> OpTree ty op -- ^ Re-associated 'OpTree'
57+reassociateOpTreeWith ::
58+ forall ty op.
59+ -- | Fixity map for operators
60+ [(RdrName, Fixity)] ->
61+ -- | How to get the name of an operator
62+ (op -> Maybe RdrName) ->
63+ -- | Original 'OpTree'
64+ OpTree ty op ->
65+ -- | Re-associated 'OpTree'
66+ OpTree ty op
6467reassociateOpTreeWith fixityMap getOpName = go
6568 where
6669 fixityOf :: op -> Fixity
6770 fixityOf op = fromMaybe defaultFixity $ do
6871 opName <- getOpName op
6972 lookup opName fixityMap
70−
7173 -- Here, left branch is already associated and the root alongside with
7274 -- the right branch is right-associated. This function picks up one item
7375 -- from the right and inserts it correctly to the left.
@@ -84,24 +86,26 @@ reassociateOpTreeWith fixityMap getOpName = go
8486 -- at the last operator, place the operator and don't recurse
8587 go (OpBranch (OpBranch l op r) op' r'@(OpNode _)) =
8688 if snd $ compareFixity (fixityOf op) (fixityOf op')
87− then OpBranch l op (go $ OpBranch r op' r')
88− else OpBranch (OpBranch l op r) op' r'
89+ then OpBranch l op (go $ OpBranch r op' r')
90+ else OpBranch (OpBranch l op r) op' r'
8991 -- else, shift one operator to left and recurse.
9092 go (OpBranch (OpBranch l op r) op' (OpBranch l' op'' r')) =
9193 if snd $ compareFixity (fixityOf op) (fixityOf op')
92− then go $ OpBranch (OpBranch l op (go $ OpBranch r op' l')) op'' r'
93− else go $ OpBranch (OpBranch (OpBranch l op r) op' l') op'' r'
94+ then go $ OpBranch (OpBranch l op (go $ OpBranch r op' l')) op'' r'
95+ else go $ OpBranch (OpBranch (OpBranch l op r) op' l') op'' r'
9496
9597-- | Build a map of inferred 'Fixity's from an 'OpTree'.
96−
97−buildFixityMap
98− :: forall ty op.
99− (op -> Maybe RdrName) -- ^ How to get the name of an operator
100− -> OpTree (Located ty) (Located op) -- ^ Operator tree
101− -> [(RdrName, Fixity)] -- ^ Fixity map
98+buildFixityMap ::
99+ forall ty op.
100+ -- | How to get the name of an operator
101+ (op -> Maybe RdrName) ->
102+ -- | Operator tree
103+ OpTree (Located ty) (Located op) ->
104+ -- | Fixity map
105+ [(RdrName, Fixity)]
102106buildFixityMap getOpName opTree =
103107 concatMap (\(i, ns) -> map (\(n, _) -> (n, fixity i InfixL)) ns)
104− . zip [0..]
108+ . zip [0 ..]
105109 . groupBy (doubleWithinEps 0.00001 `on` snd)
106110 . (overrides ++)
107111 . avgScores
@@ -113,7 +117,6 @@ buildFixityMap getOpName opTree =
113117 overrides =
114118 [ (mkRdrUnqual $ mkVarOcc "$", -1)
115119 ]
116−
117120 -- Assign scores to operators based on their location in the source.
118121 score :: OpTree (Located ty) (Located op) -> [(RdrName, Double)]
119122 score (OpNode _) = []
@@ -126,40 +129,36 @@ buildFixityMap getOpName opTree =
126129 rb <- srcSpanStartLine <$> unSrcSpan (opTreeLoc r) -- right begin
127130 oc <- srcSpanStartCol <$> unSrcSpan (getLoc o) -- operator column
128131 opName <- getOpName (unLoc o)
129−
130132 let s =
131− if le < ob
132− -- if the operator is in the beginning of a line, assign
133− -- a score relative to its column within range [0, 1).
134− then fromIntegral oc / fromIntegral (maxCol + 1)
135− -- if the operator is in the end of the line, assign the
136− -- score 1.
137− else
138− if oe < rb
139− then 1
140− else 2 -- otherwise, assign a high score.
133+ if le < ob
134+ then-- if the operator is in the beginning of a line, assign
135+ -- a score relative to its column within range [0, 1).
136+ fromIntegral oc / fromIntegral (maxCol + 1)
137+ else-- if the operator is in the end of the line, assign the
138+ -- score 1.
139+
140+ if oe < rb
141+ then 1
142+ else 2 -- otherwise, assign a high score.
141143 return $ (opName, s) : score r
142−
143144 avgScores :: [(RdrName, Double)] -> [(RdrName, Double)]
144− avgScores
145− = sortOn snd
146− . map (\xs@((n, _):_) -> (n, avg $ map snd xs))
145+ avgScores =
146+ sortOn snd
147+ . map (\xs@((n, _) : _) -> (n, avg $ map snd xs))
147148 . groupBy ((==) `on` fst)
148149 . sort
149−
150150 avg :: [Double] -> Double
151151 avg i = sum i / fromIntegral (length i)
152−
153152 -- The start column of the rightmost operator.
154153 maxCol = go opTree
155154 where
156155 go (OpNode (L _ _)) = 0
157− go (OpBranch l (L o _) r) = maximum
158− [ go l
159− , maybe 0 srcSpanStartCol (unSrcSpan o)
160− , go r
161− ]
162−
156+ go (OpBranch l (L o _) r) =
157+ maximum
158+ [ go l,
159+ maybe 0 srcSpanStartCol (unSrcSpan o),
160+ go r
161+ ]
163162 unSrcSpan (RealSrcSpan r) = Just r
164163 unSrcSpan (UnhelpfulSpan _) = Nothing
165164
@@ -168,14 +167,13 @@ buildFixityMap getOpName opTree =
168167
169168-- | Convert an 'OpTree' to with all operators having the same fixity and
170169-- associativity (left infix).
171−
172170normalizeOpTree :: OpTree ty op -> OpTree ty op
173−normalizeOpTree (OpNode n)
174− = OpNode n
175−normalizeOpTree (OpBranch (OpNode l) lop r)
176− = OpBranch (OpNode l) lop (normalizeOpTree r)
177−normalizeOpTree (OpBranch (OpBranch l' lop' r') lop r)
178− = normalizeOpTree (OpBranch l' lop' (OpBranch r' lop r))
171+normalizeOpTree (OpNode n) =
172+ OpNode n
173+normalizeOpTree (OpBranch (OpNode l) lop r) =
174+ OpBranch (OpNode l) lop (normalizeOpTree r)
175+normalizeOpTree (OpBranch (OpBranch l' lop' r') lop r) =
176+ normalizeOpTree (OpBranch l' lop' (OpBranch r' lop r))
179177
180178fixity :: Int -> FixityDirection -> Fixity
181179fixity = Fixity NoSourceText
src/Ormolu/Printer/SpanStream.hs+18−20
@@ -1,46 +1,44 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
1+{-# LANGUAGE DeriveDataTypeable #-}
22{-# LANGUAGE GeneralizedNewtypeDeriving #-}
33
44-- | Build span stream from AST.
5−
65module Ormolu.Printer.SpanStream
7− ( SpanStream (..)
8− , mkSpanStream
6+ ( SpanStream (..),
7+ mkSpanStream,
98 )
109where
1110
1211import Data.DList (DList)
12+import qualified Data.DList as D
1313import Data.Data (Data)
1414import Data.Generics (everything, ext2Q)
1515import Data.List (sortOn)
1616import Data.Typeable (cast)
1717import SrcLoc
18−import qualified Data.DList as D
1918
2019-- | A stream of 'RealSrcSpan's in ascending order. This allows us to tell
2120-- e.g. whether there is another \"located\" element of AST between current
2221-- element and comment we're considering for printing.
23−
2422newtype SpanStream = SpanStream [RealSrcSpan]
2523 deriving (Eq, Show, Data, Semigroup, Monoid)
2624
2725-- | Create 'SpanStream' from a data structure containing \"located\"
2826-- elements.
29−
30−mkSpanStream
31− :: Data a
32− => a -- ^ Data structure to inspect (AST)
33− -> SpanStream
34−mkSpanStream a
35− = SpanStream
36− . sortOn realSrcSpanStart
37− . D.toList
38− $ everything mappend (const mempty `ext2Q` queryLocated) a
27+mkSpanStream ::
28+ Data a =>
29+ -- | Data structure to inspect (AST)
30+ a ->
31+ SpanStream
32+mkSpanStream a =
33+ SpanStream
34+ . sortOn realSrcSpanStart
35+ . D.toList
36+ $ everything mappend (const mempty `ext2Q` queryLocated) a
3937 where
40− queryLocated
41− :: (Data e0, Data e1)
42− => GenLocated e0 e1
43− -> DList RealSrcSpan
38+ queryLocated ::
39+ (Data e0, Data e1) =>
40+ GenLocated e0 e1 ->
41+ DList RealSrcSpan
4442 queryLocated (L mspn _) =
4543 case cast mspn :: Maybe SrcSpan of
4644 Nothing -> mempty
src/Ormolu/Utils.hs+22−27
@@ -1,14 +1,13 @@
1−-- | Random utilities used by the code.
2−
3−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
42{-# LANGUAGE OverloadedStrings #-}
53
4+-- | Random utilities used by the code.
65module Ormolu.Utils
7− ( combineSrcSpans'
8− , isModule
9− , notImplemented
10− , showOutputable
11− , splitDocString
6+ ( combineSrcSpans',
7+ isModule,
8+ notImplemented,
9+ showOutputable,
10+ splitDocString,
1211 )
1312where
1413
@@ -16,46 +15,42 @@ import Data.Data (Data, showConstr, toConstr)
1615import Data.List (dropWhileEnd)
1716import Data.List.NonEmpty (NonEmpty (..))
1817import Data.Text (Text)
19−import HsDoc (HsDocString, unpackHDS)
20−import SrcLoc
2118import qualified Data.Text as T
19+import HsDoc (HsDocString, unpackHDS)
2220import qualified Outputable as GHC
21+import SrcLoc
2322
2423-- | Combine all source spans from the given list.
25−
2624combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan
27−combineSrcSpans' (x:|xs) = foldr combineSrcSpans x xs
25+combineSrcSpans' (x :| xs) = foldr combineSrcSpans x xs
2826
2927-- | Return 'True' if given element of AST is module.
30−
3128isModule :: Data a => a -> Bool
3229isModule x = showConstr (toConstr x) == "HsModule"
3330
3431-- | Placeholder for things that are not yet implemented.
35−
3632notImplemented :: String -> a
3733notImplemented msg = error $ "not implemented yet: " ++ msg
3834
3935-- | Pretty-print an 'GHC.Outputable' thing.
40−
4136showOutputable :: GHC.Outputable o => o -> String
4237showOutputable = GHC.showSDocUnsafe . GHC.ppr
4338
4439-- | Split and normalize a doc string. The result is a list of lines that
4540-- make up the comment.
46−
4741splitDocString :: HsDocString -> [Text]
4842splitDocString docStr =
4943 case r of
5044 [] -> [""]
51− _ -> r
45+ _ -> r
5246 where
53− r = fmap escapeLeadingDollar
54− . dropPaddingSpace
55− . dropWhileEnd T.null
56− . fmap (T.stripEnd . T.pack)
57− . lines
58− $ unpackHDS docStr
47+ r =
48+ fmap escapeLeadingDollar
49+ . dropPaddingSpace
50+ . dropWhileEnd T.null
51+ . fmap (T.stripEnd . T.pack)
52+ . lines
53+ $ unpackHDS docStr
5954 -- We cannot have the first character to be a dollar because in that
6055 -- case it'll be a parse error (apparently collides with named docs
6156 -- syntax @-- $name@ somehow).
@@ -66,7 +61,7 @@ splitDocString docStr =
6661 dropPaddingSpace xs =
6762 case dropWhile T.null xs of
6863 [] -> []
69− (x:_) ->
64+ (x : _) ->
7065 let leadingSpace txt = case T.uncons txt of
7166 Just (' ', _) -> True
7267 _ -> False
@@ -74,6 +69,6 @@ splitDocString docStr =
7469 if leadingSpace txt
7570 then T.drop 1 txt
7671 else txt
77− in if leadingSpace x
78− then dropSpace <$> xs
79− else xs
72+ in if leadingSpace x
73+ then dropSpace <$> xs
74+ else xs
tests/Ormolu/Parser/PragmaSpec.hs+3−2
@@ -21,5 +21,6 @@ spec = do
2121 stdTest "{-#OPTIONS_HADDOCK foo, bar, baz #-}" (Just $ PragmaOptionsHaddock "foo, bar, baz")
2222
2323stdTest :: String -> Maybe Pragma -> Spec
24−stdTest input result = it input $
25− parsePragma input `shouldBe` result
24+stdTest input result =
25+ it input $
26+ parsePragma input `shouldBe` result
tests/Ormolu/PrinterSpec.hs+22−22
@@ -1,19 +1,22 @@
11{-# LANGUAGE TemplateHaskell #-}
22
3−module Ormolu.PrinterSpec (spec) where
3+module Ormolu.PrinterSpec
4+ ( spec,
5+ )
6+where
47
58import Control.Exception
69import Control.Monad
710import Control.Monad.IO.Class
811import Data.List (isSuffixOf)
912import Data.Text (Text)
13+import qualified Data.Text as T
14+import qualified Data.Text.IO as T
1015import Ormolu
1116import Path
1217import Path.IO
1318import System.FilePath (addExtension, dropExtensions, splitExtensions)
1419import Test.Hspec
15−import qualified Data.Text as T
16−import qualified Data.Text.IO as T
1720
1821spec :: Spec
1922spec = do
@@ -21,7 +24,6 @@ spec = do
2124 forM_ es checkExample
2225
2326-- | Check a single given example.
24−
2527checkExample :: Path Rel File -> Spec
2628checkExample srcPath' = it (fromRelFile srcPath' ++ " works") . withNiceExceptions $ do
2729 let srcPath = examplesDir </> srcPath'
@@ -42,37 +44,35 @@ checkExample srcPath' = it (fromRelFile srcPath' ++ " works") . withNiceExceptio
4244 shouldMatch True formatted1 formatted0
4345
4446-- | Build list of examples for testing.
45−
4647locateExamples :: IO [Path Rel File]
4748locateExamples =
4849 filter isInput . snd <$> listDirRecurRel examplesDir
4950
5051-- | Does given path look like input path (as opposed to expected output
5152-- path)?
52−
5353isInput :: Path Rel File -> Bool
5454isInput path =
5555 let s = fromRelFile path
5656 (s', exts) = splitExtensions s
57− in exts == ".hs" && not ("-out" `isSuffixOf` s')
57+ in exts == ".hs" && not ("-out" `isSuffixOf` s')
5858
5959-- | For given path of input file return expected name of output.
60−
6160deriveOutput :: Path Rel File -> IO (Path Rel File)
62−deriveOutput path = parseRelFile $
63− addExtension (dropExtensions (fromRelFile path) ++ "-out") "hs"
61+deriveOutput path =
62+ parseRelFile $
63+ addExtension (dropExtensions (fromRelFile path) ++ "-out") "hs"
6464
6565-- | A version of 'shouldBe' that is specialized to comparing 'Text' values.
6666-- It also prints multi-line snippets in a more readable form.
67−
6867shouldMatch :: Bool -> Text -> Text -> Expectation
69−shouldMatch idempotencyTest actual expected =
70− when (actual /= expected) . expectationFailure $ unlines
71− [ ">>>>>>>>>>>>>>>>>>>>>> expected (" ++ pass ++ "):"
72− , T.unpack expected
73− , ">>>>>>>>>>>>>>>>>>>>>> but got:"
74− , T.unpack actual
75− ]
68+shouldMatch idempotencyTest actual expected =
69+ when (actual /= expected) . expectationFailure $
70+ unlines
71+ [ ">>>>>>>>>>>>>>>>>>>>>> expected (" ++ pass ++ "):",
72+ T.unpack expected,
73+ ">>>>>>>>>>>>>>>>>>>>>> but got:",
74+ T.unpack actual
75+ ]
7676 where
7777 pass =
7878 if idempotencyTest
@@ -84,10 +84,10 @@ examplesDir = $(mkRelDir "data/examples")
8484
8585-- | Inside this wrapper 'OrmoluException' will be caught and displayed
8686-- nicely using 'displayException'.
87−
88−withNiceExceptions
89− :: Expectation -- ^ Action that may throw the exception
90− -> Expectation
87+withNiceExceptions ::
88+ -- | Action that may throw the exception
89+ Expectation ->
90+ Expectation
9191withNiceExceptions m = m `catch` h
9292 where
9393 h :: OrmoluException -> IO ()