fourmolu 0.8.1.0 → 0.8.2.0
raw patch · 19 files changed
+576/−105 lines, 19 files
Files
- CHANGELOG.md +5/−0
- README.md +18/−15
- data/fourmolu/function-arrows/input.hs +85/−0
- data/fourmolu/function-arrows/output-LeadingArrows.hs +89/−0
- data/fourmolu/function-arrows/output-TrailingArrows.hs +89/−0
- data/fourmolu/haddock-style/output-HaddockMultiLineCompact.hs +31/−0
- fourmolu.cabal +1/−1
- fourmolu.yaml +3/−2
- src/Ormolu/Config.hs +38/−15
- src/Ormolu/Config/Types.hs +13/−4
- src/Ormolu/Printer/Combinators.hs +27/−0
- src/Ormolu/Printer/Internal.hs +37/−2
- src/Ormolu/Printer/Meat/Common.hs +7/−1
- src/Ormolu/Printer/Meat/Declaration/Data.hs +2/−2
- src/Ormolu/Printer/Meat/Declaration/Signature.hs +11/−10
- src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs +2/−1
- src/Ormolu/Printer/Meat/Declaration/Value.hs +2/−2
- src/Ormolu/Printer/Meat/Type.hs +94/−36
- tests/Ormolu/Config/PrinterOptsSpec.hs +22/−14
CHANGELOG.md view
@@ -1,3 +1,8 @@+## Fourmolu 0.8.2.0++* Add `multi-line-compact` option to `haddock-style` that will output `{-|` for multiline haddocks instead of `{- |` ([#130](https://github.com/fourmolu/fourmolu/pull/130))+* Add `function-arrows` configuration option to style arrow placement in type signatures ([#209](https://github.com/fourmolu/fourmolu/pull/209))+ ## Fourmolu 0.8.1.0 * Add `emptyConfig` ([#221](https://github.com/fourmolu/fourmolu/pull/221))
README.md view
@@ -41,17 +41,18 @@ ### Available options -| Configuration option | Valid options | Description |-|----------------------|---------------|-------------|-| `indentation` | any integer | Number of spaces to use as indentation |-| `comma-style` | `leading`, `trailing` | Where to put the comma in lists, tuples, etc. |-| `import-export-style` | `leading`, `trailing`, `diff-friendly` | How to format multiline import/export lists (`diff-friendly` lists have trailing commas but keep the open-parentheses on the same line as the `import` line) |-| `indent-wheres` | `true`, `false` | `false` means save space by only half-indenting the `where` keyword |-| `record-brace-space` | `true`, `false` | `rec {x = 1}` vs `rec{x = 1}` |-| `respectful` | `true`, `false` | Whether to respect user-specified newlines, e.g. in import groupings |-| `haddock-style` | `multi-line`, `single-line` | Whether multiline haddocks should use `{-` or `--` |-| `newlines-between-decls` | any integer | number of newlines between top-level declarations |-| `fixities` | A list of strings for defining fixities; see the "Language extensions, dependencies, and fixities" section below |+| Configuration option | Valid options | Description |+|--------------------------|-----------------|-------------|+| `indentation` | any integer | Number of spaces to use as indentation |+| `function-arrows` | `trailing`, `leading`| How to format arrows in type signatures |+| `comma-style` | `leading`, `trailing` | Where to put the comma in lists, tuples, etc. |+| `import-export-style` | `leading`, `trailing`, `diff-friendly` | How to format multiline import/export lists (`diff-friendly` lists have trailing commas but keep the open-parentheses on the same line as the `import` line) |+| `indent-wheres` | `true`, `false` | `false` means save space by only half-indenting the `where` keyword |+| `record-brace-space` | `true`, `false` | `rec {x = 1}` vs `rec{x = 1}` |+| `newlines-between-decls` | any integer | number of newlines between top-level declarations |+| `haddock-style` | `single-line`, `multi-line`, `multi-line-compact` | Whether multiline haddocks should use `-- \|`, `{- \|`, or `{-\|` (single-line haddocks will always use `--` for now) |+| `respectful` | `true`, `false` | Whether to respect user-specified newlines, e.g. in import groupings |+| `fixities` | A list of strings | See the "Language extensions, dependencies, and fixities" section below | For examples of each of these options, see the [test files](https://github.com/fourmolu/fourmolu/tree/main/data/fourmolu/). @@ -63,13 +64,14 @@ ```yaml indentation: 4+function-arrows: trailing comma-style: leading import-export-style: diff-friendly indent-wheres: false record-brace-space: false-respectful: true-haddock-style: multi-line newlines-between-decls: 1+haddock-style: multi-line+respectful: true fixities: [] ``` @@ -77,13 +79,14 @@ ```yaml indentation: 2+function-arrows: trailing comma-style: trailing import-export-style: trailing indent-wheres: true record-brace-space: true-respectful: false-haddock-style: single-line newlines-between-decls: 1+haddock-style: single-line+respectful: false fixities: [] ```
+ data/fourmolu/function-arrows/input.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE InstanceSigs #-}+module Main where++-- | Something else.+class Bar a where+ -- | Bar+ bar ::+ String ->+ String ->+ a+ -- Pointless comment+ default bar ::+ ( Read a,+ Semigroup a+ ) =>+ a ->+ a ->+ a+ -- Even more pointless comment+ bar+ a+ b =+ read a <> read b++-- | Here goes a comment.+data Foo a where+ -- | 'Foo' is wonderful.+ Foo ::+ forall a b.+ (Show a, Eq b) => -- foo+ -- bar+ a ->+ b ->+ Foo 'Int+ -- | But 'Bar' is also not too bad.+ Bar ::+ -- | An Int+ Int ->+ Maybe Text ->+ -- ^ And a Maybe Text+ Foo 'Bool+ -- | So is 'Baz'.+ Baz ::+ forall a.+ a ->+ Foo 'String+ (:~>) :: Foo a -> Foo a -> Foo a++-- Single line type signature is preserved+instance Eq Int where+ (==) :: Int -> Int -> Bool+ (==) _ _ = False+singleLineFun :: forall a. (C1, C2) => Int -> Bool++instance Ord Int where+ compare ::+ Int ->+ Int ->+ Ordering+ compare+ _+ _ =+ GT++functionName ::+ (C1, C2, C3, C4, C5) =>+ a ->+ b ->+ ( forall a.+ (C6, C7) =>+ LongDataTypeName ->+ a ->+ AnotherLongDataTypeName ->+ b ->+ c+ ) ->+ (c -> d) ->+ (a, b, c, d)++data Record = Record+ { recFun :: forall a. (C1, C2) => Int ->+ Int ->+ Bool+ , recOther :: Bool+ }
+ data/fourmolu/function-arrows/output-LeadingArrows.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE InstanceSigs #-}++module Main where++-- | Something else.+class Bar a where+ -- | Bar+ bar+ :: String+ -> String+ -> a+ -- Pointless comment+ default bar+ :: ( Read a+ , Semigroup a+ )+ => a+ -> a+ -> a+ -- Even more pointless comment+ bar+ a+ b =+ read a <> read b++-- | Here goes a comment.+data Foo a where+ -- | 'Foo' is wonderful.+ Foo+ :: forall a b+ . (Show a, Eq b) -- foo+ -- bar+ => a+ -> b+ -> Foo 'Int+ -- | But 'Bar' is also not too bad.+ Bar+ :: Int+ -- ^ An Int+ -> Maybe Text+ -- ^ And a Maybe Text+ -> Foo 'Bool+ -- | So is 'Baz'.+ Baz+ :: forall a+ . a+ -> Foo 'String+ (:~>) :: Foo a -> Foo a -> Foo a++-- Single line type signature is preserved+instance Eq Int where+ (==) :: Int -> Int -> Bool+ (==) _ _ = False+singleLineFun :: forall a. (C1, C2) => Int -> Bool++instance Ord Int where+ compare+ :: Int+ -> Int+ -> Ordering+ compare+ _+ _ =+ GT++functionName+ :: (C1, C2, C3, C4, C5)+ => a+ -> b+ -> ( forall a+ . (C6, C7)+ => LongDataTypeName+ -> a+ -> AnotherLongDataTypeName+ -> b+ -> c+ )+ -> (c -> d)+ -> (a, b, c, d)++data Record = Record+ { recFun+ :: forall a+ . (C1, C2)+ => Int+ -> Int+ -> Bool+ , recOther :: Bool+ }
+ data/fourmolu/function-arrows/output-TrailingArrows.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE InstanceSigs #-}++module Main where++-- | Something else.+class Bar a where+ -- | Bar+ bar ::+ String ->+ String ->+ a+ -- Pointless comment+ default bar ::+ ( Read a+ , Semigroup a+ ) =>+ a ->+ a ->+ a+ -- Even more pointless comment+ bar+ a+ b =+ read a <> read b++-- | Here goes a comment.+data Foo a where+ -- | 'Foo' is wonderful.+ Foo ::+ forall a b.+ (Show a, Eq b) => -- foo+ -- bar+ a ->+ b ->+ Foo 'Int+ -- | But 'Bar' is also not too bad.+ Bar ::+ -- | An Int+ Int ->+ -- | And a Maybe Text+ Maybe Text ->+ Foo 'Bool+ -- | So is 'Baz'.+ Baz ::+ forall a.+ a ->+ Foo 'String+ (:~>) :: Foo a -> Foo a -> Foo a++-- Single line type signature is preserved+instance Eq Int where+ (==) :: Int -> Int -> Bool+ (==) _ _ = False+singleLineFun :: forall a. (C1, C2) => Int -> Bool++instance Ord Int where+ compare ::+ Int ->+ Int ->+ Ordering+ compare+ _+ _ =+ GT++functionName ::+ (C1, C2, C3, C4, C5) =>+ a ->+ b ->+ ( forall a.+ (C6, C7) =>+ LongDataTypeName ->+ a ->+ AnotherLongDataTypeName ->+ b ->+ c+ ) ->+ (c -> d) ->+ (a, b, c, d)++data Record = Record+ { recFun ::+ forall a.+ (C1, C2) =>+ Int ->+ Int ->+ Bool+ , recOther :: Bool+ }
+ data/fourmolu/haddock-style/output-HaddockMultiLineCompact.hs view
@@ -0,0 +1,31 @@+{-| This is a test multiline+ module haddock+-}+module Foo where++-- | This is a singleline function haddock+single1 :: Int++-- | This is a singleline function haddock+single2 :: Int++{-| This is a multiline+ function haddock+-}+multi1 :: Int++{-|+This is a multiline+function haddock+-}+multi2 :: Int++{-| This is a haddock++ with two consecutive newlines+++ https://github.com/fourmolu/fourmolu/issues/172+-}+foo :: Int+foo = 42
fourmolu.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: fourmolu-version: 0.8.1.0+version: 0.8.2.0 license: BSD-3-Clause license-file: LICENSE.md maintainer:
fourmolu.yaml view
@@ -1,10 +1,11 @@ # Options should imitate Ormolu's style indentation: 2+function-arrows: trailing comma-style: trailing import-export-style: trailing indent-wheres: true record-brace-space: true-respectful: false-haddock-style: single-line newlines-between-decls: 1+haddock-style: single-line+respectful: false fixities: []
src/Ormolu/Config.hs view
@@ -218,13 +218,14 @@ overFieldsM :: Applicative m => (forall a. f a -> m (g a)) -> PrinterOpts f -> m (PrinterOpts g) overFieldsM f $(unpackFieldsWithSuffix 'PrinterOpts "0") = do poIndentation <- f poIndentation0+ poFunctionArrows <- f poFunctionArrows0 poCommaStyle <- f poCommaStyle0 poImportExportStyle <- f poImportExportStyle0 poIndentWheres <- f poIndentWheres0 poRecordBraceSpace <- f poRecordBraceSpace0- poRespectful <- f poRespectful0- poHaddockStyle <- f poHaddockStyle0 poNewlinesBetweenDecls <- f poNewlinesBetweenDecls0+ poHaddockStyle <- f poHaddockStyle0+ poRespectful <- f poRespectful0 return PrinterOpts {..} defaultPrinterOpts :: PrinterOptsTotal@@ -269,6 +270,14 @@ metaHelp = "Number of spaces per indentation step", metaDefault = 4 },+ poFunctionArrows =+ PrinterOptsFieldMeta+ { metaName = "function-arrows",+ metaGetField = poFunctionArrows,+ metaPlaceholder = "STYLE",+ metaHelp = "Styling of arrows in type signatures",+ metaDefault = TrailingArrows+ }, poCommaStyle = PrinterOptsFieldMeta { metaName = "comma-style",@@ -311,13 +320,13 @@ metaHelp = "Whether to leave a space before an opening record brace", metaDefault = False },- poRespectful =+ poNewlinesBetweenDecls = PrinterOptsFieldMeta- { metaName = "respectful",- metaGetField = poRespectful,- metaPlaceholder = "BOOL",- metaHelp = "Give the programmer more choice on where to insert blank lines",- metaDefault = True+ { metaName = "newlines-between-decls",+ metaGetField = poNewlinesBetweenDecls,+ metaPlaceholder = "HEIGHT",+ metaHelp = "Number of spaces between top-level declarations",+ metaDefault = 1 }, poHaddockStyle = PrinterOptsFieldMeta@@ -330,13 +339,13 @@ (showAllValues haddockPrintStyleMap), metaDefault = HaddockMultiLine },- poNewlinesBetweenDecls =+ poRespectful = PrinterOptsFieldMeta- { metaName = "newlines-between-decls",- metaGetField = poNewlinesBetweenDecls,- metaPlaceholder = "HEIGHT",- metaHelp = "Number of spaces between top-level declarations",- metaDefault = 1+ { metaName = "respectful",+ metaGetField = poRespectful,+ metaPlaceholder = "BOOL",+ metaHelp = "Give the programmer more choice on where to insert blank lines",+ metaDefault = True } } @@ -373,11 +382,20 @@ ] ) +functionArrowsStyleMap :: BijectiveMap FunctionArrowsStyle+functionArrowsStyleMap =+ $( mkBijectiveMap+ [ ('TrailingArrows, "trailing"),+ ('LeadingArrows, "leading")+ ]+ )+ haddockPrintStyleMap :: BijectiveMap HaddockPrintStyle haddockPrintStyleMap = $( mkBijectiveMap [ ('HaddockSingleLine, "single-line"),- ('HaddockMultiLine, "multi-line")+ ('HaddockMultiLine, "multi-line"),+ ('HaddockMultiLineCompact, "multi-line-compact") ] ) @@ -394,6 +412,11 @@ parseJSON = parseJSONWith commaStyleMap "CommaStyle" parseText = parseTextWith commaStyleMap showText = show . showTextWith commaStyleMap++instance PrinterOptsFieldType FunctionArrowsStyle where+ parseJSON = parseJSONWith functionArrowsStyleMap "FunctionArrowStyle"+ parseText = parseTextWith functionArrowsStyleMap+ showText = show . showTextWith functionArrowsStyleMap instance PrinterOptsFieldType HaddockPrintStyle where parseJSON = parseJSONWith haddockPrintStyleMap "HaddockPrintStyle"
src/Ormolu/Config/Types.hs view
@@ -4,6 +4,7 @@ module Ormolu.Config.Types ( PrinterOpts (..), CommaStyle (..),+ FunctionArrowsStyle (..), HaddockPrintStyle (..), ImportExportStyle (..), )@@ -15,6 +16,8 @@ data PrinterOpts f = PrinterOpts { -- | Number of spaces to use for indentation poIndentation :: f Int,+ -- | How to style arrows in type signatures+ poFunctionArrows :: f FunctionArrowsStyle, -- | Whether to place commas at start or end of lines poCommaStyle :: f CommaStyle, -- | Styling of import/export lists@@ -23,12 +26,12 @@ poIndentWheres :: f Bool, -- | Leave space before opening record brace poRecordBraceSpace :: f Bool,- -- | Be less opinionated about spaces/newlines etc.- poRespectful :: f Bool,+ -- | Number of newlines between top-level decls+ poNewlinesBetweenDecls :: f Int, -- | How to print doc comments poHaddockStyle :: f HaddockPrintStyle,- -- | Number of newlines between top-level decls- poNewlinesBetweenDecls :: f Int+ -- | Be less opinionated about spaces/newlines etc.+ poRespectful :: f Bool } deriving (Generic) @@ -37,9 +40,15 @@ | Trailing deriving (Eq, Show, Enum, Bounded) +data FunctionArrowsStyle+ = TrailingArrows+ | LeadingArrows+ deriving (Eq, Show, Enum, Bounded)+ data HaddockPrintStyle = HaddockSingleLine | HaddockMultiLine+ | HaddockMultiLineCompact deriving (Eq, Show, Enum, Bounded) data ImportExportStyle
src/Ormolu/Printer/Combinators.hs view
@@ -29,6 +29,7 @@ askSourceType, askFixityOverrides, askFixityMap,+ inciByExact, located, located', switchLayout,@@ -74,6 +75,10 @@ -- ** Placement Placement (..), placeHanging,++ -- ** Helpers for leading/trailing arrows+ leadingArrowType,+ trailingArrowType, ) where @@ -82,6 +87,7 @@ import Data.Text (Text) import GHC.Types.SrcLoc import Ormolu.Config+import Ormolu.Config.Types (FunctionArrowsStyle (..)) import Ormolu.Printer.Comments import Ormolu.Printer.Internal import Ormolu.Utils (HasSrcSpan (..))@@ -364,3 +370,24 @@ Normal -> do breakpoint inci m++----------------------------------------------------------------------------+-- Arrow style++-- | Output @space >> txt "::"@ when we are printing with trailing arrows+trailingArrowType :: R ()+trailingArrowType =+ getPrinterOpt poFunctionArrows >>= \case+ TrailingArrows -> do+ space+ txt "::"+ LeadingArrows -> pure ()++-- | Output @txt "::" >> space@ when we are printing with leading arrows+leadingArrowType :: R ()+leadingArrowType =+ getPrinterOpt poFunctionArrows >>= \case+ LeadingArrows -> do+ txt "::"+ space+ TrailingArrows -> pure ()
src/Ormolu/Printer/Internal.hs view
@@ -26,6 +26,7 @@ inciBy, inciByFrac, inciHalf,+ inciByExact, sitcc, sitccIfTrailing, Layout (..),@@ -58,6 +59,9 @@ -- * Extensions isExtensionEnabled,+ PrevTypeCtx (..),+ getPrevTypeCtx,+ setPrevTypeCtx, ) where @@ -135,7 +139,9 @@ -- | Whether to output a space before the next output scRequestedDelimiter :: !RequestedDelimiter, -- | An auxiliary marker for keeping track of last output element- scSpanMark :: !(Maybe SpanMark)+ scSpanMark :: !(Maybe SpanMark),+ -- | What (if any) precedes the current type on the same line+ scPrevTypeCtx :: PrevTypeCtx } -- | Make sure next output is delimited by one of the following.@@ -212,7 +218,8 @@ scCommentStream = cstream, scPendingComments = [], scRequestedDelimiter = VeryBeginning,- scSpanMark = Nothing+ scSpanMark = Nothing,+ scPrevTypeCtx = TypeCtxStart } ----------------------------------------------------------------------------@@ -443,6 +450,15 @@ inciHalf :: R () -> R () inciHalf = inciByFrac 2 +-- | Like 'inci', but indents by exactly the given number of spaces.+inciByExact :: Int -> R () -> R ()+inciByExact spaces (R m) = R (local modRC m)+ where+ modRC rc =+ rc+ { rcIndent = rcIndent rc + spaces+ }+ -- | Set indentation level for the inner computation equal to current -- column. This makes sure that the entire inner block is uniformly -- \"shifted\" to the right.@@ -638,3 +654,22 @@ isExtensionEnabled :: Extension -> R Bool isExtensionEnabled ext = R . asks $ EnumSet.member ext . rcExtensions++----------------------------------------------------------------------------+-- Previous type context++-- | What (if anything) precedes the current type on the same line+-- Only used for the `function-arrows` setting+data PrevTypeCtx+ = TypeCtxStart+ | TypeCtxForall+ | TypeCtxContext+ | TypeCtxArgument+ deriving (Eq, Show)++getPrevTypeCtx :: R PrevTypeCtx+getPrevTypeCtx = R (gets scPrevTypeCtx)++setPrevTypeCtx :: PrevTypeCtx -> R ()+setPrevTypeCtx prevTypeCtx =+ R $ modify (\sc -> sc {scPrevTypeCtx = prevTypeCtx})
src/Ormolu/Printer/Meat/Common.hs view
@@ -168,7 +168,13 @@ txt $ "-- " <> haddockDelim body $ newline >> txt "--" else do- txt $ "{- " <> haddockDelim+ txt . T.concat $+ [ "{-",+ case (hstyle, printStyle) of+ (Pipe, HaddockMultiLineCompact) -> ""+ _ -> " ",+ haddockDelim+ ] -- 'newline' doesn't allow multiple blank newlines, which changes the comment -- if the user writes a comment with multiple newlines. So we have to do this -- to force the printer to output a newline. The HaddockSingleLine branch
src/Ormolu/Printer/Meat/Declaration/Data.hs view
@@ -126,13 +126,13 @@ commaDel sep commaDel p_rdrName cs inci $ do- space- txt "::"+ trailingArrowType let interArgBreak = if hasDocStrings (unLoc con_res_ty) then newline else breakpoint interArgBreak+ leadingArrowType let conTy = case con_g_args of PrefixConGADT xs -> let go (HsScaled a b) t = addCLocAA t b (HsFunTy EpAnnNotUsed a b t)
src/Ormolu/Printer/Meat/Declaration/Signature.hs view
@@ -60,11 +60,11 @@ LHsSigType GhcPs -> R () p_typeAscription sigType = inci $ do- space- txt "::"+ trailingArrowType if hasDocStrings (unLoc . sig_body . unLoc $ sigType) then newline else breakpoint+ leadingArrowType located sigType p_hsSigType p_patSynSig ::@@ -137,10 +137,11 @@ p_activation inl_act space p_rdrName name- space- txt "::"- breakpoint- inci $ sep commaDel (located' p_hsSigType) ts+ trailingArrowType+ inci $ do+ leadingArrowType+ breakpoint+ sep commaDel (located' p_hsSigType) ts p_inlineSpec :: InlineSpec -> R () p_inlineSpec = \case@@ -207,9 +208,9 @@ pragma "COMPLETE" . inci $ do sep commaDel p_rdrName cs forM_ mty $ \ty -> do- space- txt "::"+ trailingArrowType breakpoint+ leadingArrowType inci (p_rdrName ty) p_sccSig :: LocatedN RdrName -> Maybe (Located StringLiteral) -> R ()@@ -225,7 +226,7 @@ inci $ do space p_rdrName name- space- txt "::"+ trailingArrowType breakpoint+ leadingArrowType located sigTy p_hsSigType
src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs view
@@ -63,8 +63,9 @@ p_familyResultSigL (L _ a) = case a of NoSig NoExtField -> Nothing KindSig NoExtField k -> Just $ do- txt "::"+ trailingArrowType breakpoint+ leadingArrowType located k p_hsType TyVarSig NoExtField bndr -> Just $ do equals
src/Ormolu/Printer/Meat/Declaration/Value.hs view
@@ -817,9 +817,9 @@ p_fieldLabels (NE.toList proj_flds) ExprWithTySig _ x HsWC {hswc_body} -> sitcc $ do located x p_hsExpr- space- txt "::"+ trailingArrowType breakpoint+ leadingArrowType inci $ located hswc_body p_hsSigType ArithSeq _ _ x -> case x of
src/Ormolu/Printer/Meat/Type.hs view
@@ -23,6 +23,7 @@ where import Control.Monad+import Data.Bool (bool) import Data.Foldable (for_) import GHC.Hs import GHC.Types.Basic hiding (isPromoted)@@ -30,15 +31,34 @@ import GHC.Types.SrcLoc import GHC.Types.Var import Ormolu.Config+import Ormolu.Config.Types (FunctionArrowsStyle (..)) import Ormolu.Printer.Combinators+import Ormolu.Printer.Internal (PrevTypeCtx (..), enterLayout, getPrevTypeCtx, setPrevTypeCtx) import Ormolu.Printer.Meat.Common import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.OpTree (p_tyOpTree, tyOpTree) import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Value (p_hsSplice, p_stringLit) import Ormolu.Printer.Operators import Ormolu.Utils +-- | Render an "PrevTypeCtx" infix+p_after :: Bool -> R ()+p_after multilineArgs =+ getPrevTypeCtx >>= \case+ TypeCtxStart -> pure ()+ TypeCtxForall | multilineArgs -> txt " ." >> space+ TypeCtxForall -> txt "." >> space+ TypeCtxContext -> txt "=>" >> space+ TypeCtxArgument -> txt "->" >> space++-- | Like 'p_hsType' but indent properly following a forall p_hsType :: HsType GhcPs -> R ()-p_hsType t = p_hsType' (hasDocStrings t) PipeStyle t+p_hsType t = do+ s <-+ getPrinterOpt poFunctionArrows >>= \case+ TrailingArrows -> pure PipeStyle+ LeadingArrows -> pure CaretStyle+ layout <- getLayout+ p_hsType' (hasDocStrings t || layout == MultiLine) s t p_hsTypePostDoc :: HsType GhcPs -> R () p_hsTypePostDoc t = p_hsType' (hasDocStrings t) CaretStyle t@@ -52,16 +72,27 @@ p_hsType' multilineArgs docStyle = \case HsForAllTy _ tele t -> do case tele of- HsForAllInvis _ bndrs -> p_forallBndrs ForAllInvis p_hsTyVarBndr bndrs- HsForAllVis _ bndrs -> p_forallBndrs ForAllVis p_hsTyVarBndr bndrs+ HsForAllInvis _ bndrs -> p_forallBndrs' ForAllInvis p_hsTyVarBndr bndrs+ HsForAllVis _ bndrs -> p_forallBndrs' ForAllVis p_hsTyVarBndr bndrs+ getPrinterOpt poFunctionArrows >>= \case+ LeadingArrows | multilineArgs -> pure ()+ _ -> p_after False >> setPrevTypeCtx TypeCtxStart interArgBreak p_hsTypeR (unLoc t) HsQualTy _ qs' t -> do- for_ qs' $ \qs -> do- located qs p_hsContext- space- txt "=>"- interArgBreak+ getPrinterOpt poFunctionArrows >>= \case+ LeadingArrows -> do+ after <- getPrevTypeCtx+ bool id (inciByExact 3) (after == TypeCtxForall) $ for_ qs' $ \qs -> do+ located qs p_hsContext+ interArgBreak+ TrailingArrows -> do+ for_ qs' $ \qs -> do+ located qs p_hsContext+ space+ txt "=>"+ interArgBreak+ setPrevTypeCtx TypeCtxContext case unLoc t of HsQualTy {} -> p_hsTypeR (unLoc t) HsFunTy {} -> p_hsTypeR (unLoc t)@@ -100,19 +131,30 @@ txt "@" located kd p_hsType HsFunTy _ arrow x y@(L _ y') -> do- located x p_hsType- space- case arrow of- HsUnrestrictedArrow _ -> txt "->"- HsLinearArrow _ _ -> txt "%1 ->"- HsExplicitMult _ _ mult -> do- txt "%"- p_hsTypeR (unLoc mult)+ getPrinterOpt poFunctionArrows >>= \case+ LeadingArrows -> do+ after <- getPrevTypeCtx+ bool id (inciByExact 3) (after == TypeCtxForall) (located x p_hsType)+ interArgBreak+ TrailingArrows -> do+ located x p_hsType space- txt "->"- interArgBreak+ case arrow of+ HsUnrestrictedArrow _ -> txt "->"+ HsLinearArrow _ _ -> txt "%1 ->"+ HsExplicitMult _ _ mult -> do+ txt "%"+ setPrevTypeCtx TypeCtxContext+ p_hsTypeR (unLoc mult)+ space+ txt "->"+ interArgBreak+ setPrevTypeCtx TypeCtxArgument case y' of- HsFunTy {} -> p_hsTypeR y'+ HsFunTy {} -> do+ layout <- getLayout+ -- Render the comments properly, but keep the existing layout+ located y (enterLayout layout . p_hsTypeR) _ -> located y p_hsTypeR HsListTy _ t -> located t (brackets N . p_hsType)@@ -135,16 +177,16 @@ parens N $ sitcc $ located t p_hsType HsIParamTy _ n t -> sitcc $ do located n atom- space- txt "::"+ trailingArrowType breakpoint+ leadingArrowType inci (located t p_hsType) HsStarTy _ _ -> txt "*" HsKindSig _ t k -> sitcc $ do located t p_hsType- space- txt "::"+ trailingArrowType breakpoint+ leadingArrowType inci (located k p_hsType) HsSpliceTy _ splice -> p_hsSplice splice HsDocTy _ t str ->@@ -203,7 +245,11 @@ if multilineArgs then newline else breakpoint- p_hsTypeR = p_hsType' multilineArgs docStyle+ p_hsTypeR m = do+ getPrinterOpt poFunctionArrows >>= \case+ TrailingArrows -> pure ()+ LeadingArrows -> p_after multilineArgs+ p_hsType' multilineArgs docStyle m -- | Return 'True' if at least one argument in 'HsType' has a doc string -- attached to it.@@ -238,26 +284,31 @@ (if isInferred flag then braces N else id) $ p_rdrName x KindedTyVar _ flag l k -> (if isInferred flag then braces else parens) N . sitcc $ do located l atom- space- txt "::"+ trailingArrowType breakpoint+ leadingArrowType inci (located k p_hsType) data ForAllVisibility = ForAllInvis | ForAllVis -- | Render several @forall@-ed variables. p_forallBndrs :: ForAllVisibility -> (a -> R ()) -> [LocatedA a] -> R ()-p_forallBndrs ForAllInvis _ [] = txt "forall."-p_forallBndrs ForAllVis _ [] = txt "forall ->"-p_forallBndrs vis p tyvars =+p_forallBndrs vis p tyvars = do+ p_forallBndrs' vis p tyvars+ p_after False++p_forallBndrs' :: ForAllVisibility -> (a -> R ()) -> [LocatedA a] -> R ()+p_forallBndrs' ForAllInvis _ [] = txt "forall" >> setPrevTypeCtx TypeCtxForall+p_forallBndrs' ForAllVis _ [] = txt "forall" >> space >> setPrevTypeCtx TypeCtxArgument+p_forallBndrs' vis p tyvars = do switchLayout (getLocA <$> tyvars) $ do txt "forall" breakpoint inci $ do sitcc $ sep breakpoint (sitcc . located' p) tyvars- case vis of- ForAllInvis -> txt "."- ForAllVis -> space >> txt "->"+ case vis of+ ForAllInvis -> setPrevTypeCtx TypeCtxForall+ ForAllVis -> space >> setPrevTypeCtx TypeCtxArgument p_conDeclFields :: [LConDeclField GhcPs] -> R () p_conDeclFields xs =@@ -273,10 +324,17 @@ commaDel (located' (p_rdrName . rdrNameFieldOcc)) cd_fld_names- space- txt "::"- breakpoint- sitcc . inci $ p_hsType (unLoc cd_fld_type)+ getPrinterOpt poFunctionArrows >>= \case+ LeadingArrows -> inci $ do+ breakpoint+ txt "::"+ space+ p_hsType (unLoc cd_fld_type)+ TrailingArrows -> do+ space+ txt "::"+ breakpoint+ sitcc . inci $ p_hsType (unLoc cd_fld_type) when (commaStyle == Leading) $ mapM_ (inciByFrac (-1) . (newline >>) . p_hsDocString Caret False) cd_fld_doc
tests/Ormolu/Config/PrinterOptsSpec.hs view
@@ -66,6 +66,14 @@ suffixWith [show indent, if indentWheres then "indent_wheres" else ""] }, TestGroup+ { label = "function-arrows",+ testCases = allOptions,+ updateConfig = \functionArrows opts ->+ opts {poFunctionArrows = pure functionArrows},+ showTestCase = show,+ testCaseSuffix = suffix1+ },+ TestGroup { label = "comma-style", testCases = allOptions, updateConfig = \commaStyle opts -> opts {poCommaStyle = pure commaStyle},@@ -88,20 +96,6 @@ testCaseSuffix = suffix1 }, TestGroup- { label = "respectful",- testCases = allOptions,- updateConfig = \respectful opts -> opts {poRespectful = pure respectful},- showTestCase = show,- testCaseSuffix = suffix1- },- TestGroup- { label = "haddock-style",- testCases = allOptions,- updateConfig = \haddockStyle opts -> opts {poHaddockStyle = pure haddockStyle},- showTestCase = show,- testCaseSuffix = suffix1- },- TestGroup { label = "newlines-between-decls", testCases = (,) <$> [0, 1, 2] <*> allOptions, updateConfig = \(newlines, respectful) opts ->@@ -113,6 +107,20 @@ show newlines ++ if respectful then " (respectful)" else "", testCaseSuffix = \(newlines, respectful) -> suffixWith [show newlines, if respectful then "respectful" else ""]+ },+ TestGroup+ { label = "haddock-style",+ testCases = allOptions,+ updateConfig = \haddockStyle opts -> opts {poHaddockStyle = pure haddockStyle},+ showTestCase = show,+ testCaseSuffix = suffix1+ },+ TestGroup+ { label = "respectful",+ testCases = allOptions,+ updateConfig = \respectful opts -> opts {poRespectful = pure respectful},+ showTestCase = show,+ testCaseSuffix = suffix1 } ] where