fourmolu 0.17.0.0 → 0.18.0.0

raw patch · 89 files changed

+1685/−551 lines, 89 filesdep +unliftiodep −deepseqdep ~Cabal-syntaxdep ~ghc-lib-parser

Dependencies added: unliftio

Dependencies removed: deepseq

Dependency ranges changed: Cabal-syntax, ghc-lib-parser

Files

• CHANGELOG.md +34/−0
• README.md +6/−1
• app/Main.hs +27/−11
• data/examples/declaration/data/wildcard-binders-four-out.hs +1/−0
• data/examples/declaration/data/wildcard-binders-out.hs +1/−0
• data/examples/declaration/data/wildcard-binders.hs +1/−0
• data/examples/declaration/default/default-four-out.hs +7/−0
• data/examples/declaration/default/default-out.hs +8/−0
• data/examples/declaration/default/default.hs +7/−0
• data/examples/declaration/type/promotion-no-puns-four-out.hs +5/−0
• data/examples/declaration/type/promotion-no-puns-out.hs +5/−0
• data/examples/declaration/type/promotion-no-puns.hs +5/−0
• data/examples/declaration/type/wildcard-binders-four-out.hs +1/−0
• data/examples/declaration/type/wildcard-binders-out.hs +1/−0
• data/examples/declaration/type/wildcard-binders.hs +1/−0
• data/examples/declaration/value/function/arrow/proc-form-do-indent-four-out.hs +7/−0
• data/examples/declaration/value/function/arrow/proc-form-do-indent-out.hs +7/−0
• data/examples/declaration/value/function/arrow/proc-form-do-indent.hs +5/−0
• data/examples/declaration/value/function/infix/fractional-precedence-four-out.hs +3/−0
• data/examples/declaration/value/function/infix/fractional-precedence-out.hs +3/−0
• data/examples/declaration/value/function/infix/fractional-precedence.hs +3/−0
• data/examples/declaration/value/function/multiline-strings-0-four-out.hs +28/−0
• data/examples/declaration/value/function/multiline-strings-0-out.hs +29/−0
• data/examples/declaration/value/function/multiline-strings-0.hs +31/−0
• data/examples/declaration/value/function/multiline-strings-1-four-out.hs +10/−0
• data/examples/declaration/value/function/multiline-strings-1-out.hs +10/−0
• data/examples/declaration/value/function/multiline-strings-1.hs +11/−0
• data/examples/declaration/value/function/multiline-strings-2-four-out.hs +11/−0
• data/examples/declaration/value/function/multiline-strings-2-out.hs +11/−0
• data/examples/declaration/value/function/multiline-strings-2.hs +11/−0
• data/examples/declaration/value/function/multiline-strings-3-four-out.hs +31/−0
• data/examples/declaration/value/function/multiline-strings-3-out.hs +32/−0
• data/examples/declaration/value/function/multiline-strings-3.hs +32/−0
• data/examples/declaration/value/function/multiline-strings-4-four-out.hs +25/−0
• data/examples/declaration/value/function/multiline-strings-4-out.hs +25/−0
• data/examples/declaration/value/function/multiline-strings-4.hs +26/−0
• data/examples/declaration/value/function/multiline-strings-5-four-out.hs +26/−0
• data/examples/declaration/value/function/multiline-strings-5-out.hs +26/−0
• data/examples/declaration/value/function/multiline-strings-5.hs +26/−0
• data/examples/declaration/value/function/multiline-strings-6-four-out.hs +10/−0
• data/examples/declaration/value/function/multiline-strings-6-out.hs +10/−0
• data/examples/declaration/value/function/multiline-strings-6.hs +10/−0
• data/examples/declaration/value/function/multiline-strings-7-four-out.hs +30/−0
• data/examples/declaration/value/function/multiline-strings-7-out.hs +30/−0
• data/examples/declaration/value/function/multiline-strings-7.hs +30/−0
• data/examples/declaration/value/function/multiline-strings-8-four-out.hs +12/−0
• data/examples/declaration/value/function/multiline-strings-8-out.hs +12/−0
• data/examples/declaration/value/function/multiline-strings-8.hs +9/−0
• data/examples/declaration/value/function/pattern/or-patterns-four-out.hs +35/−0
• data/examples/declaration/value/function/pattern/or-patterns-out.hs +36/−0
• data/examples/declaration/value/function/pattern/or-patterns.hs +33/−0
• data/examples/declaration/value/function/required-type-arguments-2-four-out.hs +19/−0
• data/examples/declaration/value/function/required-type-arguments-2-out.hs +22/−0
• data/examples/declaration/value/function/required-type-arguments-2.hs +14/−0
• data/examples/declaration/value/function/type-applications-four-out.hs +2/−0
• data/examples/declaration/value/function/type-applications-out.hs +2/−0
• data/examples/declaration/value/function/type-applications.hs +2/−0
• data/fourmolu/sort-constraints/input.hs +3/−0
• data/fourmolu/sort-constraints/output-False.hs +3/−0
• data/fourmolu/sort-constraints/output-True.hs +3/−0
• extract-hackage-info/hackage-info.bin binary
• fourmolu.cabal +233/−213
• src/Ormolu/Diff/ParseResult.hs +72/−62
• src/Ormolu/Fixity.hs +1/−16
• src/Ormolu/Fixity/Internal.hs +31/−9
• src/Ormolu/Fixity/Parser.hs +3/−1
• src/Ormolu/Fixity/Printer.hs +11/−1
• src/Ormolu/Imports.hs +10/−10
• src/Ormolu/Parser.hs +14/−2
• src/Ormolu/Printer/Meat/Common.hs +19/−3
• src/Ormolu/Printer/Meat/Declaration.hs +1/−0
• src/Ormolu/Printer/Meat/Declaration/Data.hs +2/−6
• src/Ormolu/Printer/Meat/Declaration/Default.hs +6/−1
• src/Ormolu/Printer/Meat/Declaration/OpTree.hs +1/−1
• src/Ormolu/Printer/Meat/Declaration/Signature.hs +1/−1
• src/Ormolu/Printer/Meat/Declaration/StringLiteral.hs +152/−0
• src/Ormolu/Printer/Meat/Declaration/Value.hs +72/−113
• src/Ormolu/Printer/Meat/Declaration/Value.hs-boot +0/−3
• src/Ormolu/Printer/Meat/Module.hs +14/−13
• src/Ormolu/Printer/Meat/Type.hs +115/−51
• src/Ormolu/Processing/Preprocess.hs +1/−1
• src/Ormolu/Utils.hs +0/−8
• src/Ormolu/Utils/Cabal.hs +7/−8
• src/Ormolu/Utils/Fixity.hs +4/−7
• src/Ormolu/Utils/IO.hs +16/−6
• tests/Ormolu/CabalInfoSpec.hs +1/−1
• tests/Ormolu/Fixity/ParserSpec.hs +22/−0
• tests/Ormolu/Fixity/PrinterSpec.hs +6/−1
• tests/Ormolu/PrinterSpec.hs +4/−1

@@ -1,3 +1,37 @@+## Fourmolu 0.18.0.0++* Fix AST check with sort-constraints in data constructor ([#451](https://github.com/fourmolu/fourmolu/issues/451)++### Upstream changes:++#### Ormolu 0.8.0.0++* Format multiple files in parallel. [Issue+  1128](https://github.com/tweag/ormolu/issues/1128).++* Fractional precedences are now allowed in `.ormolu` files for more precise+  control over formatting of complex operator chains. [Issue+  1106](https://github.com/tweag/ormolu/issues/1106).++* Correctly format type applications of `QuasiQuotes`. [Issue+  1134](https://github.com/tweag/ormolu/issues/1134).++* Correctly format multi-line parentheses in arrow `do` blocks. [Issue+  1144](https://github.com/tweag/ormolu/issues/1144).++* Switched to `ghc-lib-parser-9.12`, with the following new syntactic features:+   * GHC proposal [#522](https://github.com/ghc-proposals/ghc-proposals/blob/c9401f037cb22d1661931b2ec621925101052997/proposals/0522-or-patterns.rst): `OrPatterns` (enabled by default)+   * GHC proposal [#569](https://github.com/ghc-proposals/ghc-proposals/blob/c9401f037cb22d1661931b2ec621925101052997/proposals/0569-multiline-strings.rst): `MultilineStrings` (disabled by default)+   * GHC proposal [#409](https://github.com/ghc-proposals/ghc-proposals/blob/f79438cf8dbfcd90187f7af3a380515ffe45dbdc/proposals/0409-exportable-named-default.rst): `NamedDefaults` (enabled by default)+   * GHC proposal [#281](https://github.com/ghc-proposals/ghc-proposals/blob/c9401f037cb22d1661931b2ec621925101052997/proposals/0281-visible-forall.rst): accept more types in terms: `forall` quantifications, constraint arrows `=>`, type arrows `->` (enabled by default)+   * Part of GHC proposal [#425](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0425-decl-invis-binders.rst): wildcard binders (enabled by default)++* Correctly format non-promoted type-level tuples with `NoListTuplePuns`. [Issue+  1146](https://github.com/tweag/ormolu/issues/1146).++* Updated to `Cabal-syntax-3.14`. [Issue+  1152](https://github.com/tweag/ormolu/issues/1152).+ ## Fourmolu 0.17.0.0  * Add new `import-grouping` option to group imports with grouping rules specified in configuration ([#403](https://github.com/fourmolu/fourmolu/pull/403))

@@ -140,10 +140,15 @@   - infixr 1  =<<   - infixr 0  $, $!   - infixl 4 <*>, <*, *>, <**>+  - infixr 3 >~<+  - infixr 3.3 |~|+  - infixr 3.7 <~> ```  It uses exactly the same syntax as usual Haskell fixity declarations to make-it easier for Haskellers to edit and maintain.+it easier for Haskellers to edit and maintain. Since Ormolu 0.7.8.0+fractional precedences are supported for more precise control over+formatting of complex operator chains.  `fourmolu.yaml` can also contain instructions about module re-exports that Fourmolu should be aware of. This might be desirable

@@ -7,6 +7,7 @@  module Main (main) where +import Control.Concurrent (MVar, newMVar, withMVar) import Control.Exception (throwIO) import Control.Monad import Data.Bool (bool)@@ -36,11 +37,16 @@ import System.Exit (ExitCode (..), exitWith) import System.FilePath qualified as FP import System.IO (hPutStrLn, stderr)+import UnliftIO.Async (pooledMapConcurrently)  -- | Entry point of the program. main :: IO () main = do   opts@Opts {..} <- runParser optsParserInfo+  -- We use this to guard writes to stdout in order to avoid+  -- garbled output from concurrent formatting processes.+  outputLock <- newMVar ()+   cfg <- resolveConfig opts    let formatOne' =@@ -49,6 +55,7 @@           optMode           optSourceType           cfg+          outputLock    exitCode <- case optInputFiles of     [] -> formatOne' Nothing@@ -59,7 +66,8 @@             ExitFailure n -> Just n       files <- Set.toAscList . Set.fromList . concat <$> mapM getHaskellFiles inputs       errorCodes <--        mapMaybe selectFailure <$> mapM (formatOne' . Just) files+        mapMaybe selectFailure+          <$> pooledMapConcurrently (formatOne' . Just) files       return $         if null errorCodes           then ExitSuccess@@ -159,10 +167,12 @@   Maybe SourceType ->   -- | Configuration   Config RegionIndices ->+  -- | Lock for writing to output handles+  MVar () ->   -- | File to format or stdin as 'Nothing'   Maybe FilePath ->   IO ExitCode-formatOne ConfigFileOpts {..} mode reqSourceType rawConfig mpath =+formatOne ConfigFileOpts {..} mode reqSourceType rawConfig outputLock mpath =   withPrettyOrmoluExceptions (cfgColorMode rawConfig) $ do     let getCabalInfoForSourceFile' sourceFile = do           cabalSearchResult <- getCabalInfoForSourceFile sourceFile@@ -170,18 +180,20 @@           case cabalSearchResult of             CabalNotFound -> do               when debugEnabled $-                hPutStrLn stderr $-                  "Could not find a .cabal file for " <> sourceFile+                withMVar outputLock $ \_ ->+                  hPutStrLn stderr $+                    "Could not find a .cabal file for " <> sourceFile               return Nothing             CabalDidNotMention cabalInfo -> do               when debugEnabled $ do                 relativeCabalFile <-                   makeRelativeToCurrentDirectory (ciCabalFilePath cabalInfo)-                hPutStrLn stderr $-                  "Found .cabal file "-                    <> relativeCabalFile-                    <> ", but it did not mention "-                    <> sourceFile+                withMVar outputLock $ \_ ->+                  hPutStrLn stderr $+                    "Found .cabal file "+                      <> relativeCabalFile+                      <> ", but it did not mention "+                      <> sourceFile               return (Just cabalInfo)             CabalFound cabalInfo -> return (Just cabalInfo)         getDotOrmoluForSourceFile' sourceFile = do@@ -201,7 +213,9 @@         config <- patchConfig Nothing mcabalInfo mdotOrmolu         case mode of           Stdout -> do-            ormoluStdin config >>= T.Utf8.putStr+            output <- ormoluStdin config+            withMVar outputLock $ \_ ->+              T.Utf8.putStr output             return ExitSuccess           InPlace -> do             hPutStrLn@@ -230,7 +244,9 @@             mdotOrmolu         case mode of           Stdout -> do-            ormoluFile config inputFile >>= T.Utf8.putStr+            output <- ormoluFile config inputFile+            withMVar outputLock $ \_ ->+              T.Utf8.putStr output             return ExitSuccess           InPlace -> do             -- ormoluFile is not used because we need originalInput

@@ -0,0 +1,1 @@+data Proxy _ = Proxy

@@ -0,0 +1,1 @@+data Proxy _ = Proxy

@@ -0,0 +1,1 @@+data Proxy _ = Proxy

@@ -1,3 +1,5 @@+module MyModule (default Monoid) where+ default (Int, Foo, Bar)  default@@ -5,3 +7,8 @@     , Foo     , Bar     )++default Num (Int, Float)+default IsList ([], Vector)++default IsString (Text.Text, Foundation.String, String)

@@ -1,3 +1,5 @@+module MyModule (default Monoid) where+ default (Int, Foo, Bar)  default@@ -5,3 +7,9 @@     Foo,     Bar   )++default Num (Int, Float)++default IsList ([], Vector)++default IsString (Text.Text, Foundation.String, String)

@@ -1,6 +1,13 @@+module MyModule (default Monoid) where+ default        (  Int , Foo     , Bar      )  default ( Int                , Foo,   Bar            )++default Num (Int, Float)+default IsList ([], Vector)++default IsString (Text.Text, Foundation.String, String)

@@ -0,0 +1,5 @@+{-# LANGUAGE NoListTuplePuns #-}++type X = (Int, String)++type Y = [String, Int]

@@ -0,0 +1,5 @@+{-# LANGUAGE NoListTuplePuns #-}++type X = (Int, String)++type Y = [String, Int]

@@ -0,0 +1,5 @@+{-# Language NoListTuplePuns #-}++type X = (Int, String)++type Y = [String, Int]

@@ -0,0 +1,1 @@+type Const a _ = a

@@ -0,0 +1,1 @@+type Const a _ = a

@@ -0,0 +1,1 @@+type Const a _ = a

@@ -12,3 +12,10 @@             (bindA -< y)         |)         z++foo2 = proc () -> do+    ( proc () ->+            returnA -< ()+        )+        -<+            ()

@@ -12,3 +12,10 @@       (bindA -< y)     |)     z++foo2 = proc () -> do+  ( proc () ->+      returnA -< ()+    )+    -<+      ()

@@ -11,3 +11,8 @@     bar       (bindA -< y)     |) z++foo2 = proc () -> do+  (proc () ->+    returnA -< ()+    ) -< ()

@@ -0,0 +1,3 @@+startFormTok |~| messageTag+    >~< startMessageTok |~| name+    >~< p' |~| endMessageTok |~| endFormTok

@@ -0,0 +1,3 @@+startFormTok |~| messageTag+  >~< startMessageTok |~| name+  >~< p' |~| endMessageTok |~| endFormTok

@@ -0,0 +1,3 @@+startFormTok |~| messageTag+  >~< startMessageTok |~| name+  >~< p' |~| endMessageTok |~| endFormTok

@@ -0,0 +1,28 @@+{-# LANGUAGE MultilineStrings #-}++s =+    """Line 1+       Line 2+    Line 3+    """++s_2 =+    """Line 1+       Line 2+    Line 3+    """++-- equivalent to+s' = "Line 1\n   Line 2\nLine 3"++-- the following are equivalent+s = """hello world"""+s' = "hello world"++s =+    """    hello+    world+    """++-- equivalent to+s' = "    hello\nworld"

@@ -0,0 +1,29 @@+{-# LANGUAGE MultilineStrings #-}++s =+  """Line 1+     Line 2+  Line 3+  """++s_2 =+  """Line 1+     Line 2+  Line 3+  """++-- equivalent to+s' = "Line 1\n   Line 2\nLine 3"++-- the following are equivalent+s = """hello world"""++s' = "hello world"++s =+  """    hello+  world+  """++-- equivalent to+s' = "    hello\nworld"

@@ -0,0 +1,31 @@+{-# LANGUAGE MultilineStrings #-}++s =+  """Line 1+     Line 2+  Line 3+  """++s_2 =+  """\+ \Line 1+     Line 2+  Line 3+  """++-- equivalent to+s' = "Line 1\n   Line 2\nLine 3"+++-- the following are equivalent+s = """hello world"""+s' = "hello world"+++s =+  """    hello+  world+  """++-- equivalent to+s' = "    hello\nworld"

@@ -0,0 +1,10 @@+{-# LANGUAGE MultilineStrings #-}++s =+    """+    a b c d e+    f g+    """++-- equivalent to+s' = "a b c d e\nf g"

@@ -0,0 +1,10 @@+{-# LANGUAGE MultilineStrings #-}++s =+  """+  a b c d e+  f g+  """++-- equivalent to+s' = "a b c d e\nf g"

@@ -0,0 +1,11 @@+{-# LANGUAGE MultilineStrings #-}++s =+    """+      a b\+  \ c d e+      f g+    """++-- equivalent to+s' = "a b c d e\nf g"

@@ -0,0 +1,11 @@+{-# LANGUAGE MultilineStrings #-}++s =+    """+    a+    b+    c+    """++-- equivalent to+s' = "a\nb\nc"

@@ -0,0 +1,11 @@+{-# LANGUAGE MultilineStrings #-}++s =+  """+  a+  b+  c+  """++-- equivalent to+s' = "a\nb\nc"

@@ -0,0 +1,11 @@+{-# LANGUAGE MultilineStrings #-}++s =+	"""+	        a+	 	b+	    	c+	"""++-- equivalent to+s' = "a\nb\nc"

@@ -0,0 +1,31 @@+{-# LANGUAGE MultilineStrings #-}++s =+    """++    a+    b+    c+    """++-- equivalent to+s' = "\na\nb\nc"++s1 =+    """    a+    b+    c+    """++s2 =+    """+    a+    b+    c+    """++-- In the current proposal, these are equivalent to+-- the below. If leading newline were removed at the+-- beginning, both would result in s1'.+s1' = "    a\nb\nc"+s2' = "a\nb\nc"

@@ -0,0 +1,32 @@+{-# LANGUAGE MultilineStrings #-}++s =+  """++  a+  b+  c+  """++-- equivalent to+s' = "\na\nb\nc"++s1 =+  """    a+  b+  c+  """++s2 =+  """+  a+  b+  c+  """++-- In the current proposal, these are equivalent to+-- the below. If leading newline were removed at the+-- beginning, both would result in s1'.+s1' = "    a\nb\nc"++s2' = "a\nb\nc"

@@ -0,0 +1,32 @@+{-# LANGUAGE MultilineStrings #-}++s =+  """++  a+  b+  c+  """++-- equivalent to+s' = "\na\nb\nc"+++s1 =+  """    a+  b+  c+  """++s2 =+  """+  a+  b+  c+  """++-- In the current proposal, these are equivalent to+-- the below. If leading newline were removed at the+-- beginning, both would result in s1'.+s1' = "    a\nb\nc"+s2' = "a\nb\nc"

@@ -0,0 +1,25 @@+{-# LANGUAGE MultilineStrings #-}++s =+    """+    a+    b++    """++-- equivalent to+s' = "a\nb\n"++s1 =+    """+    line 1+    line 2+    """++s2 = "line 3"++s3 =+    """+    line 4+    line 5+    """

@@ -0,0 +1,25 @@+{-# LANGUAGE MultilineStrings #-}++s =+  """+  a+  b++  """++-- equivalent to+s' = "a\nb\n"++s1 =+  """+  line 1+  line 2+  """++s2 = "line 3"++s3 =+  """+  line 4+  line 5+  """

@@ -0,0 +1,26 @@+{-# LANGUAGE MultilineStrings #-}++s =+  """+  a+  b++  """++-- equivalent to+s' = "a\nb\n"+++s1 =+  """+  line 1+  line 2+  """++s2 = "line 3"++s3 =+  """+  line 4+  line 5+  """

@@ -0,0 +1,26 @@+{-# LANGUAGE MultilineStrings #-}++s1 =+    """+    a+    b+    c+    """++s1' = "a\nb\nc"++s2 =+    """+    \&  a+      b+      c+    """++s2_2 =+    """+    \&  a+    \&  b+    \&  c+    """++s2' = "  a\n  b\n  c"

@@ -0,0 +1,26 @@+{-# LANGUAGE MultilineStrings #-}++s1 =+  """+  a+  b+  c+  """++s1' = "a\nb\nc"++s2 =+  """+  \&  a+    b+    c+  """++s2_2 =+  """+  \&  a+  \&  b+  \&  c+  """++s2' = "  a\n  b\n  c"

@@ -0,0 +1,26 @@+{-# LANGUAGE MultilineStrings #-}++s1 =+  """+    a+    b+    c+  """++s1' = "a\nb\nc"++s2 =+  """+  \&  a+    b+    c+  """++s2_2 =+  """+  \&  a+  \&  b+  \&  c+  """++s2' = "  a\n  b\n  c"

@@ -0,0 +1,10 @@+{-# LANGUAGE MultilineStrings #-}++x =+    """+    This is a literal multiline string:+    \"\"\"+    Hello+      world!+    \"""+    """

@@ -0,0 +1,10 @@+{-# LANGUAGE MultilineStrings #-}++x =+  """+  This is a literal multiline string:+  \"\"\"+  Hello+    world!+  \"""+  """

@@ -0,0 +1,10 @@+{-# LANGUAGE MultilineStrings #-}++x =+  """+  This is a literal multiline string:+  \"\"\"+  Hello+    world!+  \"""+  """

@@ -0,0 +1,30 @@+{-# LANGUAGE MultilineStrings #-}++printf+    """+    instance Aeson.FromJSON %s where+      parseJSON =+        Aeson.withText "%s" $ \\s ->+          either Aeson.parseFail pure $+            parsePrinterOptType (Text.unpack s)++    instance PrinterOptsFieldType %s where+      parsePrinterOptType s =+        case s of+    %s+          _ ->+            Left . unlines $+              [ "unknown value: " <> show s+              , "Valid values are: %s"+              ]++    """+    fieldTypeName+    fieldTypeName+    fieldTypeName+    ( unlines_+        [ printf "      \"%s\" -> Right %s" val con+        | (con, val) <- enumOptions+        ]+    )+    (renderEnumOptions enumOptions)

@@ -0,0 +1,30 @@+{-# LANGUAGE MultilineStrings #-}++printf+  """+  instance Aeson.FromJSON %s where+    parseJSON =+      Aeson.withText "%s" $ \\s ->+        either Aeson.parseFail pure $+          parsePrinterOptType (Text.unpack s)++  instance PrinterOptsFieldType %s where+    parsePrinterOptType s =+      case s of+  %s+        _ ->+          Left . unlines $+            [ "unknown value: " <> show s+            , "Valid values are: %s"+            ]++  """+  fieldTypeName+  fieldTypeName+  fieldTypeName+  ( unlines_+      [ printf "      \"%s\" -> Right %s" val con+      | (con, val) <- enumOptions+      ]+  )+  (renderEnumOptions enumOptions)

@@ -0,0 +1,30 @@+{-# LANGUAGE MultilineStrings #-}++printf+  """+  instance Aeson.FromJSON %s where+    parseJSON =+      Aeson.withText "%s" $ \\s ->+        either Aeson.parseFail pure $+          parsePrinterOptType (Text.unpack s)++  instance PrinterOptsFieldType %s where+    parsePrinterOptType s =+      case s of+  %s+        _ ->+          Left . unlines $+            [ "unknown value: " <> show s+            , "Valid values are: %s"+            ]++  """+  fieldTypeName+  fieldTypeName+  fieldTypeName+  ( unlines_+      [ printf "      \"%s\" -> Right %s" val con+      | (con, val) <- enumOptions+      ]+  )+  (renderEnumOptions enumOptions)

@@ -0,0 +1,12 @@+{-# LANGUAGE MultilineStrings #-}++type Foo =+    """+    yeah+      yeah"""++foo =+    foo+        @"""yeah+         yeah+         """

@@ -0,0 +1,12 @@+{-# LANGUAGE MultilineStrings #-}++type Foo =+  """+  yeah+    yeah"""++foo =+  foo+    @"""yeah+     yeah+     """

@@ -0,0 +1,9 @@+{-# LANGUAGE MultilineStrings #-}++type Foo = """+  yeah+    yeah"""++foo = foo @"""yeah+           yeah+           """

@@ -0,0 +1,35 @@+{-# LANGUAGE PatternSynonyms #-}++tasty (Cupcake; Cookie) = True+tasty (Liquorice; Raisins) = False++f :: (Eq a, Show a) => a -> a -> Bool+f a ((== a) -> True; show -> "yes") = True+f _ _ = False++small (abs -> (0; 1; 2); 3) = True -- -3 is not small+small _ = False++type Coll a = Either [a] (Set a)+pattern None <- (Left []; Right (toList -> []))++case e of+    1; 2; 3 -> x+    4; (5; 6) -> y++sane e = case e of+    1+    2+    3 -> a+    4+    5+    6 -> b+    7; 8 -> c++insane e = case e of+    A _ _+    B _+    C -> 3+    (D; E (Just _) Nothing) ->+        4+    F -> 5

@@ -0,0 +1,36 @@+{-# LANGUAGE PatternSynonyms #-}++tasty (Cupcake; Cookie) = True+tasty (Liquorice; Raisins) = False++f :: (Eq a, Show a) => a -> a -> Bool+f a ((== a) -> True; show -> "yes") = True+f _ _ = False++small (abs -> (0; 1; 2); 3) = True -- -3 is not small+small _ = False++type Coll a = Either [a] (Set a)++pattern None <- (Left []; Right (toList -> []))++case e of+  1; 2; 3 -> x+  4; (5; 6) -> y++sane e = case e of+  1+  2+  3 -> a+  4+  5+  6 -> b+  7; 8 -> c++insane e = case e of+  A _ _+  B _+  C -> 3+  (D; E (Just _) Nothing) ->+    4+  F -> 5

@@ -0,0 +1,33 @@+{-# LANGUAGE PatternSynonyms #-}++tasty (Cupcake; Cookie) = True+tasty (Liquorice; Raisins) = False++f :: (Eq a, Show a) => a -> a -> Bool+f a ((== a) -> True; show -> "yes") = True+f _ _ = False++small (abs -> (0; 1; 2); 3) = True -- -3 is not small+small _ = False++type Coll a = Either [a] (Set a)+pattern None <- (Left []; Right (toList -> []))++case e of+  1; 2; 3 -> x+  4; (5; 6) -> y++sane e = case e of+  1+  2+  3 -> a+  4+  5;6 -> b+  7;8 -> c++insane e = case e of+  A _ _; B _+  C -> 3+  (D; E (Just _) Nothing)+   -> 4+  F -> 5

@@ -0,0 +1,19 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE UnicodeSyntax #-}++ex1 = f (forall a. Proxy a)+ex2 = f ((ctx) => Int)+ex2' = f ((ctx, ctx') => Int)+ex3 = f (String -> Bool)++long =+    f+        ( forall m a.+          (A a, M m) =>+          String ->+          Bool %1 ->+          Maybe Int ->+          Maybe+            (String, Int) %1 ->+          Word %m -> Text+        )

@@ -0,0 +1,22 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE UnicodeSyntax #-}++ex1 = f (forall a. Proxy a)++ex2 = f ((ctx) => Int)++ex2' = f ((ctx, ctx') => Int)++ex3 = f (String -> Bool)++long =+  f+    ( forall m a.+      (A a, M m) =>+      String ->+      Bool %1 ->+      Maybe Int ->+      Maybe+        (String, Int) %1 ->+      Word %m -> Text+    )

@@ -0,0 +1,14 @@+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE LinearTypes #-}++ex1  = f (forall a. Proxy a)+ex2  = f (ctx => Int)+ex2' = f ((ctx,ctx') => Int)+ex3  = f (String -> Bool)++long = f (forall m a. (A a, M m) => String+       -> Bool %1 ->+          Maybe Int+       -> Maybe+             (String,Int)+        ⊸ Word %m -> Text )

@@ -22,3 +22,5 @@         @u         v ->             ""++foo = foo @[k|bar|]

@@ -22,3 +22,5 @@     @u     v ->       ""++foo = foo @[k|bar|]

@@ -17,3 +17,5 @@   Bar    @t @u v     -> ""++foo = foo @[k|bar|]

@@ -41,3 +41,6 @@ -- We can't know this is a constraint tuple type rather than a normal -- tuple type without type information type MyConstraints a = (Show a, Eq a)++-- https://github.com/fourmolu/fourmolu/issues/451+data Foo = forall a. (B, A a) => Foo a

@@ -43,3 +43,6 @@ -- We can't know this is a constraint tuple type rather than a normal -- tuple type without type information type MyConstraints a = (Show a, Eq a)++-- https://github.com/fourmolu/fourmolu/issues/451+data Foo = forall a. (B, A a) => Foo a

@@ -43,3 +43,6 @@ -- We can't know this is a constraint tuple type rather than a normal -- tuple type without type information type MyConstraints a = (Show a, Eq a)++-- https://github.com/fourmolu/fourmolu/issues/451+data Foo = forall a. (A a, B) => Foo a

binary file changed (989821 → 1002933 bytes)

@@ -1,238 +1,258 @@-cabal-version:      2.4-name:               fourmolu-version:            0.17.0.0-license:            BSD-3-Clause-license-file:       LICENSE.md+cabal-version: 2.4+name: fourmolu+version: 0.18.0.0+license: BSD-3-Clause+license-file: LICENSE.md maintainer:     Matt Parsons <parsonsmatt@gmail.com>     George Thomas <georgefsthomas@gmail.com>     Brandon Chinn <brandonchinn178@gmail.com>-tested-with:        ghc ==9.6.5 ghc ==9.8.2 ghc ==9.10.1-homepage:           https://github.com/fourmolu/fourmolu-bug-reports:        https://github.com/fourmolu/fourmolu/issues-synopsis:           A formatter for Haskell source code-description:        A formatter for Haskell source code.-category:           Development, Formatting-build-type:         Simple+tested-with:+  ghc ==9.8.4+  ghc ==9.10.1+  ghc ==9.12.1++homepage: https://github.com/fourmolu/fourmolu+bug-reports: https://github.com/fourmolu/fourmolu/issues+synopsis: A formatter for Haskell source code+description: A formatter for Haskell source code.+category: Development, Formatting+build-type: Simple extra-source-files:-    data/**/*.hs-    data/**/*.txt-    data/**/*.cabal-    extract-hackage-info/hackage-info.bin-    -- needed for integration tests-    fixity-tests/*.hs-    region-tests/*.hs-    fourmolu.yaml+  data/**/*.cabal+  data/**/*.hs+  data/**/*.txt+  extract-hackage-info/hackage-info.bin+  -- needed for integration tests+  fixity-tests/*.hs+  region-tests/*.hs+  fourmolu.yaml  extra-doc-files:-    CHANGELOG.md-    README.md+  CHANGELOG.md+  README.md  source-repository head-    type:     git-    location: https://github.com/fourmolu/fourmolu.git+  type:     git+  location: https://github.com/fourmolu/fourmolu.git  flag dev-    description: Turn on development settings.-    default:     False-    manual:      True--flag internal-bundle-fixities-    description:-        An internal ad-hoc flag that is enabled by default, Ormolu Live disables-        it due to missing WASM TH support.--    manual:      True+  description: Turn on development settings.+  default: False+  manual: True  library-    exposed-modules:-        Ormolu-        Ormolu.Config-        Ormolu.Diff.ParseResult-        Ormolu.Diff.Text-        Ormolu.Exception-        Ormolu.Imports-        Ormolu.Imports.Grouping-        Ormolu.Parser-        Ormolu.Parser.CommentStream-        Ormolu.Parser.Pragma-        Ormolu.Parser.Result-        Ormolu.Printer-        Ormolu.Printer.Combinators-        Ormolu.Printer.Comments-        Ormolu.Printer.Internal-        Ormolu.Printer.Meat.Common-        Ormolu.Printer.Meat.Declaration-        Ormolu.Printer.Meat.Declaration.Annotation-        Ormolu.Printer.Meat.Declaration.Class-        Ormolu.Printer.Meat.Declaration.Data-        Ormolu.Printer.Meat.Declaration.Default-        Ormolu.Printer.Meat.Declaration.Foreign-        Ormolu.Printer.Meat.Declaration.Instance-        Ormolu.Printer.Meat.Declaration.RoleAnnotation-        Ormolu.Printer.Meat.Declaration.Rule-        Ormolu.Printer.Meat.Declaration.Signature-        Ormolu.Printer.Meat.Declaration.Splice-        Ormolu.Printer.Meat.Declaration.Type-        Ormolu.Printer.Meat.Declaration.TypeFamily-        Ormolu.Printer.Meat.Declaration.Value-        Ormolu.Printer.Meat.Declaration.OpTree-        Ormolu.Printer.Meat.Declaration.Warning-        Ormolu.Printer.Meat.ImportExport-        Ormolu.Printer.Meat.Module-        Ormolu.Printer.Meat.Pragma-        Ormolu.Printer.Meat.Type-        Ormolu.Printer.Operators-        Ormolu.Fixity-        Ormolu.Fixity.Imports-        Ormolu.Fixity.Internal-        Ormolu.Fixity.Parser-        Ormolu.Fixity.Printer-        Ormolu.Printer.SpanStream-        Ormolu.Processing.Common-        Ormolu.Processing.Cpp-        Ormolu.Processing.Preprocess-        Ormolu.Terminal-        Ormolu.Terminal.QualifiedDo-        Ormolu.Utils-        Ormolu.Utils.Cabal-        Ormolu.Utils.Fixity-        Ormolu.Utils.Glob-        Ormolu.Utils.IO-        Paths_fourmolu-    other-modules:-        Ormolu.Config.Gen-        Ormolu.Config.Types-    autogen-modules:-        Paths_fourmolu--    hs-source-dirs:   src-    other-modules:    GHC.DynFlags-    default-language: GHC2021-    build-depends:-        Cabal-syntax >=3.12 && <3.13,-        Diff >=0.4 && <2,-        MemoTrie >=0.6 && <0.7,-        ansi-terminal >=0.10 && <1.2,-        array >=0.5 && <0.6,-        base >=4.14 && <5,-        binary >=0.8 && <0.9,-        bytestring >=0.2 && <0.13,-        choice >=0.2.4.1 && <0.3,-        containers >=0.5 && <0.8,-        deepseq >=1.4 && <1.6,-        directory ^>=1.3,-        file-embed >=0.0.15 && <0.1,-        filepath >=1.2 && <1.6,-        ghc-lib-parser >=9.10 && <9.11,-        megaparsec >=9,-        mtl >=2 && <3,-        syb >=0.7 && <0.8,-        text >=2.1 && <3,-        -- fourmolu-only deps-        aeson >=1.0 && <3.0,-        scientific >=0.3.2 && <1,+  exposed-modules:+    Ormolu+    Ormolu.Config+    Ormolu.Diff.ParseResult+    Ormolu.Diff.Text+    Ormolu.Exception+    Ormolu.Fixity+    Ormolu.Fixity.Imports+    Ormolu.Fixity.Internal+    Ormolu.Fixity.Parser+    Ormolu.Fixity.Printer+    Ormolu.Imports+    Ormolu.Parser+    Ormolu.Parser.CommentStream+    Ormolu.Parser.Pragma+    Ormolu.Parser.Result+    Ormolu.Printer+    Ormolu.Printer.Combinators+    Ormolu.Printer.Comments+    Ormolu.Printer.Internal+    Ormolu.Printer.Meat.Common+    Ormolu.Printer.Meat.Declaration+    Ormolu.Printer.Meat.Declaration.Annotation+    Ormolu.Printer.Meat.Declaration.Class+    Ormolu.Printer.Meat.Declaration.Data+    Ormolu.Printer.Meat.Declaration.Default+    Ormolu.Printer.Meat.Declaration.Foreign+    Ormolu.Printer.Meat.Declaration.Instance+    Ormolu.Printer.Meat.Declaration.OpTree+    Ormolu.Printer.Meat.Declaration.RoleAnnotation+    Ormolu.Printer.Meat.Declaration.Rule+    Ormolu.Printer.Meat.Declaration.Signature+    Ormolu.Printer.Meat.Declaration.Splice+    Ormolu.Printer.Meat.Declaration.StringLiteral+    Ormolu.Printer.Meat.Declaration.Type+    Ormolu.Printer.Meat.Declaration.TypeFamily+    Ormolu.Printer.Meat.Declaration.Value+    Ormolu.Printer.Meat.Declaration.Warning+    Ormolu.Printer.Meat.ImportExport+    Ormolu.Printer.Meat.Module+    Ormolu.Printer.Meat.Pragma+    Ormolu.Printer.Meat.Type+    Ormolu.Printer.Operators+    Ormolu.Printer.SpanStream+    Ormolu.Processing.Common+    Ormolu.Processing.Cpp+    Ormolu.Processing.Preprocess+    Ormolu.Terminal+    Ormolu.Terminal.QualifiedDo+    Ormolu.Utils+    Ormolu.Utils.Cabal+    Ormolu.Utils.Fixity+    Ormolu.Utils.IO -    if flag(dev)-        ghc-options:-            -Wall -Werror -Wredundant-constraints -Wpartial-fields-            -Wunused-packages+  hs-source-dirs: src+  other-modules: GHC.DynFlags+  default-language: GHC2021+  build-depends:+    Cabal-syntax >=3.14 && <3.15,+    Diff >=0.4 && <2,+    MemoTrie >=0.6 && <0.7,+    ansi-terminal >=0.10 && <1.2,+    array >=0.5 && <0.6,+    base >=4.14 && <5,+    binary >=0.8 && <0.9,+    bytestring >=0.2 && <0.13,+    choice >=0.2.4.1 && <0.3,+    containers >=0.5 && <0.8,+    directory ^>=1.3,+    file-embed >=0.0.15 && <0.1,+    filepath >=1.2 && <1.6,+    ghc-lib-parser >=9.12 && <9.13,+    megaparsec >=9,+    mtl >=2 && <3,+    syb >=0.7 && <0.8,+    text >=2.1 && <3, -    else-        ghc-options: -O2 -Wall+  -- specific to fourmolu+  exposed-modules:+    Ormolu.Imports.Grouping+    Ormolu.Utils.Glob+    Paths_fourmolu+  other-modules:+    Ormolu.Config.Gen+    Ormolu.Config.Types+  autogen-modules:+    Paths_fourmolu+  build-depends:+    aeson >=1.0 && <3.0,+    scientific >=0.3.2 && <1, -    if flag(internal-bundle-fixities)-        cpp-options: -DBUNDLE_FIXITIES+  if flag(dev)+    ghc-options:+      -Wall+      -Werror+      -Wredundant-constraints+      -Wpartial-fields+      -Wunused-packages+  else+    ghc-options:+      -O2+      -Wall  executable fourmolu-    main-is:          Main.hs-    hs-source-dirs:   app-    other-modules:    Paths_fourmolu-    autogen-modules:  Paths_fourmolu-    default-language: GHC2021-    build-depends:-        Cabal-syntax >=3.12 && <3.13,-        base >=4.12 && <5,-        containers >=0.5 && <0.8,-        directory ^>=1.3,-        filepath >=1.2 && <1.6,-        ghc-lib-parser >=9.10 && <9.11,-        optparse-applicative >=0.14 && <0.19,-        text >=2.1 && <3,-        th-env >=0.1.1 && <0.2,-        -- fourmolu-only deps-        directory >=1.3.3 && <1.4,-        optparse-applicative >=0.17,-        terminal-size >=0.1 && <0.4,-        yaml >=0.11.6.0 && <1,-        fourmolu+  main-is: Main.hs+  hs-source-dirs: app+  other-modules: Paths_fourmolu+  autogen-modules: Paths_fourmolu+  default-language: GHC2021+  build-depends:+    Cabal-syntax >=3.14 && <3.15,+    base >=4.12 && <5,+    containers >=0.5 && <0.8,+    directory ^>=1.3,+    filepath >=1.2 && <1.6,+    ghc-lib-parser >=9.12 && <9.13,+    optparse-applicative >=0.14 && <0.19,+    text >=2.1 && <3,+    th-env >=0.1.1 && <0.2,+    unliftio >=0.2.10 && <0.3, -    if flag(dev)-        ghc-options:-            -Wall -Werror -Wredundant-constraints -Wpartial-fields-            -Wunused-packages -Wwarn=unused-packages+  -- specific to fourmolu+  build-depends:+    directory >=1.3.3 && <1.4,+    fourmolu,+    optparse-applicative >=0.17,+    terminal-size >=0.1 && <0.4,+    yaml >=0.11.6.0 && <1, -    else-        ghc-options: -O2 -Wall -rtsopts+  -- We use parallelism so we need a threaded runtime to get any+  -- benefit.+  ghc-options:+    -threaded+    -rtsopts+    -with-rtsopts=-N -test-suite tests-    type:               exitcode-stdio-1.0-    main-is:            Spec.hs-    build-tool-depends: hspec-discover:hspec-discover >=2 && <3-    hs-source-dirs:     tests-    other-modules:-        Ormolu.CabalInfoSpec-        Ormolu.Diff.TextSpec-        Ormolu.Fixity.ParserSpec-        Ormolu.Fixity.PrinterSpec-        Ormolu.FixitySpec-        Ormolu.OpTreeSpec-        Ormolu.Parser.OptionsSpec-        Ormolu.Parser.ParseFailureSpec-        Ormolu.Parser.PragmaSpec-        Ormolu.PrinterSpec+  if flag(dev)+    ghc-options:+      -Wall+      -Werror+      -Wredundant-constraints+      -Wpartial-fields+      -Wunused-packages+      -Wwarn=unused-packages+  else+    ghc-options:+      -O2+      -Wall -    default-language:   GHC2021-    build-depends:-        Cabal-syntax >=3.12 && <3.13,-        QuickCheck >=2.14,-        base >=4.14 && <5,-        choice >=0.2.4.1 && <0.3,-        containers >=0.5 && <0.8,-        directory ^>=1.3,-        filepath >=1.2 && <1.6,-        ghc-lib-parser >=9.10 && <9.11,-        hspec >=2 && <3,-        hspec-megaparsec >=2.2,-        megaparsec >=9,-        path >=0.6 && <0.10,-        path-io >=1.4.2 && <2,-        temporary ^>=1.3,-        text >=2.1 && <3+test-suite tests+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  build-tool-depends: hspec-discover:hspec-discover >=2 && <3+  hs-source-dirs: tests+  other-modules:+    Ormolu.CabalInfoSpec+    Ormolu.Diff.TextSpec+    Ormolu.Fixity.ParserSpec+    Ormolu.Fixity.PrinterSpec+    Ormolu.FixitySpec+    Ormolu.OpTreeSpec+    Ormolu.Parser.OptionsSpec+    Ormolu.Parser.ParseFailureSpec+    Ormolu.Parser.PragmaSpec+    Ormolu.PrinterSpec -    -- specific to fourmolu tests-    other-modules:-        Ormolu.Config.PrinterOptsSpec-        Ormolu.ConfigSpec-        Ormolu.Integration.CLIOptionsSpec-        Ormolu.Integration.CLISpec-        Ormolu.Integration.FixitySpec-        Ormolu.Integration.RegionSpec-        Ormolu.Integration.Utils-        Ormolu.Utils.GlobSpec-    build-depends:-        bytestring,-        Diff >=1 && <2,-        pretty >=1.0 && <2.0,-        process >=1.6 && <2.0,-        yaml,-        fourmolu-    build-tool-depends: fourmolu:fourmolu+  default-language: GHC2021+  build-depends:+    Cabal-syntax >=3.14 && <3.15,+    QuickCheck >=2.14,+    base >=4.14 && <5,+    choice >=0.2.4.1 && <0.3,+    containers >=0.5 && <0.8,+    directory ^>=1.3,+    filepath >=1.2 && <1.6,+    ghc-lib-parser >=9.12 && <9.13,+    hspec >=2 && <3,+    hspec-megaparsec >=2.2,+    megaparsec >=9,+    path >=0.6 && <0.10,+    path-io >=1.4.2 && <2,+    temporary ^>=1.3,+    text >=2.1 && <3, -    if flag(dev)-        ghc-options:-            -Wall -Werror -Wredundant-constraints -Wpartial-fields-            -Wunused-packages+  -- specific to fourmolu tests+  other-modules:+    Ormolu.Config.PrinterOptsSpec+    Ormolu.ConfigSpec+    Ormolu.Integration.CLIOptionsSpec+    Ormolu.Integration.CLISpec+    Ormolu.Integration.FixitySpec+    Ormolu.Integration.RegionSpec+    Ormolu.Integration.Utils+    Ormolu.Utils.GlobSpec+  build-depends:+    Diff >=1 && <2,+    bytestring,+    fourmolu,+    pretty >=1.0 && <2.0,+    process >=1.6 && <2.0,+    yaml,+  build-tool-depends: fourmolu:fourmolu -    else-        ghc-options: -O2 -Wall+  if flag(dev)+    ghc-options:+      -Wall+      -Werror+      -Wredundant-constraints+      -Wpartial-fields+      -Wunused-packages+  else+    ghc-options:+      -O2+      -Wall

@@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeepSubsumption #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-}@@ -18,6 +19,7 @@ import Data.Generics import Data.List (sortOn) import Data.Text qualified as T+import GHC.Data.FastString (FastString) import GHC.Hs import GHC.Types.SourceText import GHC.Types.SrcLoc@@ -26,6 +28,7 @@ import Ormolu.Parser.CommentStream import Ormolu.Parser.Result import Ormolu.Utils+import Type.Reflection qualified as TR  -- | Result of comparing two 'ParseResult's. data ParseResultDiff@@ -69,16 +72,8 @@   where     commentLines = concatMap (toList . unComment . unLoc) --- | Compare two modules for equality disregarding the following aspects:------     * 'SrcSpan's---     * ordering of import lists---     * style (ASCII vs Unicode) of arrows, colons---     * LayoutInfo (brace style) in extension fields---     * Empty contexts in type classes---     * Parens around derived type classes---     * 'TokenLocation' (in 'LHsToken'/'LHsUniToken')---     * 'EpaLocation'+-- | Compare two modules for equality disregarding certain semantically+-- irrelevant features like exact print annotations. diffHsModule :: HsModule GhcPs -> HsModule GhcPs -> ParseResultDiff diffHsModule = genericQuery   where@@ -91,38 +86,64 @@           if x' == (y' :: ByteString)             then Same             else Different []+      | Just rep <- isEpTokenish x,+        Just rep' <- isEpTokenish y =+          -- Only check whether the Ep(Uni)Tokens are of the same type; don't+          -- look at the actual payload (e.g. the location).+          if rep == rep' then Same else Different []       | typeOf x == typeOf y,         toConstr x == toConstr y =           mconcat $             gzipWithQ               ( genericQuery+                  -- EPA-related                   `extQ` considerEqual @SrcSpan                   `ext1Q` epAnnEq                   `extQ` considerEqual @SourceText-                  `extQ` hsDocStringEq-                  `extQ` importDeclQualifiedStyleEq-                  `extQ` classDeclCtxEq-                  `extQ` derivedTyClsEq-                  `extQ` qualTyCtxEq-                  `extQ` dataDeclEq                   `extQ` considerEqual @EpAnnComments -- ~ XCGRHSs GhcPs-                  `extQ` considerEqual @TokenLocation -- in LHs(Uni)Token                   `extQ` considerEqual @EpaLocation                   `extQ` considerEqual @EpLayout-                  `extQ` considerEqual @[AddEpAnn]                   `extQ` considerEqual @AnnSig                   `extQ` considerEqual @HsRuleAnn-                  `ext2Q` forLocated-                  -- unicode-related-                  `extQ` considerEqual @(EpUniToken "->" "→")-                  `extQ` considerEqual @(EpUniToken "::" "∷")                   `extQ` considerEqual @EpLinearArrow-                  `extQ` considerEqualVia' compareAnnKeywordId+                  `extQ` considerEqual @AnnSynDecl+                  `extQ` considerEqual @IsUnicodeSyntax+                  -- FastString (for example for string literals)+                  `extQ` considerEqualVia' ((==) @FastString)+                  -- Haddock strings+                  `extQ` hsDocStringEq+                  -- Whether imports are pre- or post-qualified+                  `extQ` importDeclQualifiedStyleEq+                  -- Whether a class has an empty context+                  `extQ` classDeclCtxEq+                  -- Whether there are parens around a derived type class+                  `extQ` derivedTyClsEq+                  `extQ` typeEq+                  `extQ` dataDeclEq+                  `extQ` conDeclEq+                  -- For better error messages+                  `ext2Q` forLocated               )               x               y       | otherwise = Different [] +    -- Return the 'TR.SomeTypeRep' of the type of the given value if it is an+    -- 'EpToken', an 'EpUniToken', or a list of these.+    isEpTokenish :: (Typeable a) => a -> Maybe TR.SomeTypeRep+    isEpTokenish = fmap TR.SomeTypeRep . go . TR.typeOf+      where+        go :: TR.TypeRep a -> Maybe (TR.TypeRep a)+        go rep = case rep of+          TR.App t t'+            | Just HRefl <- TR.eqTypeRep t (TR.typeRep @[]) ->+                TR.App t <$> go t'+          TR.App (TR.App t _) _ ->+            rep <$ TR.eqTypeRep t (TR.typeRep @EpUniToken)+          TR.App t _ ->+            rep <$ TR.eqTypeRep t (TR.typeRep @EpToken)+          _ -> Nothing+     considerEqualVia ::       forall a.       (Typeable a) =>@@ -135,6 +156,13 @@     considerEqualVia' f =       considerEqualVia $ \x x' -> if f x x' then Same else Different [] +    considerEqualOn ::+      (Typeable a, Data b) =>+      (a -> b) ->+      a ->+      GenericQ ParseResultDiff+    considerEqualOn f = considerEqualVia (genericQuery `on` f)+     considerEqual :: forall a. (Typeable a) => a -> GenericQ ParseResultDiff     considerEqual = considerEqualVia $ \_ _ -> Same @@ -178,32 +206,32 @@     normalizeMContext (Just (L _ [])) = Nothing     normalizeMContext (Just (L ann ctx)) = Just (L ann $ normalizeContext ctx) -    qualTyCtxEq :: HsType GhcPs -> GenericQ ParseResultDiff-    qualTyCtxEq = considerEqualVia $ \lt rt -> genericQuery (normalizeQualTy lt) (normalizeQualTy rt)-      where-        normalizeQualTy :: HsType GhcPs -> HsType GhcPs-        normalizeQualTy (HsQualTy ann ctx body) = HsQualTy ann (fmap normalizeContext ctx) body-        normalizeQualTy ty = ty+    typeEq :: HsType GhcPs -> GenericQ ParseResultDiff+    typeEq = considerEqualOn $ \case+      HsQualTy ann ctx body -> HsQualTy ann (fmap normalizeContext ctx) body+      ty -> ty      classDeclCtxEq :: TyClDecl GhcPs -> GenericQ ParseResultDiff-    classDeclCtxEq = considerEqualVia $ \lc rc -> genericQuery (normalizeClassDecl lc) (normalizeClassDecl rc)-      where-        normalizeClassDecl ClassDecl {tcdCtxt, ..} = ClassDecl {tcdCtxt = normalizeMContext tcdCtxt, ..}-        normalizeClassDecl d = d+    classDeclCtxEq = considerEqualOn $ \case+      ClassDecl {..} -> ClassDecl {tcdCtxt = normalizeMContext tcdCtxt, ..}+      d -> d      dataDeclEq :: HsDataDefn GhcPs -> GenericQ ParseResultDiff-    dataDeclEq = considerEqualVia $ \dd dd' -> genericQuery (normalizeDataDecl dd) (normalizeDataDecl dd')+    dataDeclEq = considerEqualOn $ \case+      HsDataDefn {..} ->+        HsDataDefn+          { -- The order of classes in the context doesn't matter+            dd_ctxt = normalizeMContext dd_ctxt,+            -- The order of deriving clauses doesn't matter. Note: need to normalize before sorting, otherwise+            -- we'll get a different sort order!+            dd_derivs = sortOn showOutputable ((fmap . fmap) normalizeDerivingClause dd_derivs),+            ..+          } -    normalizeDataDecl :: HsDataDefn GhcPs -> HsDataDefn GhcPs-    normalizeDataDecl HsDataDefn {dd_ctxt, dd_derivs, ..} =-      HsDataDefn-        { -- The order of classes in the context doesn't matter-          dd_ctxt = normalizeMContext dd_ctxt,-          -- The order of deriving clauses doesn't matter. Note: need to normalize before sorting, otherwise-          -- we'll get a different sort order!-          dd_derivs = sortOn showOutputable ((fmap . fmap) normalizeDerivingClause dd_derivs),-          ..-        }+    conDeclEq :: ConDecl GhcPs -> GenericQ ParseResultDiff+    conDeclEq = considerEqualOn $ \case+      ConDeclGADT {..} -> ConDeclGADT {con_mb_cxt = normalizeMContext con_mb_cxt, ..}+      ConDeclH98 {..} -> ConDeclH98 {con_mb_cxt = normalizeMContext con_mb_cxt, ..}      normalizeDerivingClause :: HsDerivingClause GhcPs -> HsDerivingClause GhcPs     normalizeDerivingClause HsDerivingClause {deriv_clause_tys, ..} =@@ -216,21 +244,3 @@      derivedTyClsEq :: DerivClauseTys GhcPs -> GenericQ ParseResultDiff     derivedTyClsEq = considerEqualVia $ \lc rc -> genericQuery (normalizeDerivClauseTys lc) (normalizeDerivClauseTys rc)--    compareAnnKeywordId x y =-      let go = curry $ \case-            (AnnCloseB, AnnCloseBU) -> True-            (AnnCloseQ, AnnCloseQU) -> True-            (AnnDarrow, AnnDarrowU) -> True-            (AnnDcolon, AnnDcolonU) -> True-            (AnnForall, AnnForallU) -> True-            (AnnLarrow, AnnLarrowU) -> True-            (AnnOpenB, AnnOpenBU) -> True-            (AnnOpenEQ, AnnOpenEQU) -> True-            (AnnRarrow, AnnRarrowU) -> True-            (Annlarrowtail, AnnlarrowtailU) -> True-            (Annrarrowtail, AnnrarrowtailU) -> True-            (AnnLarrowtail, AnnLarrowtailU) -> True-            (AnnRarrowtail, AnnRarrowtailU) -> True-            (_, _) -> False-       in go x y || go y x || x == y

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-}@@ -35,6 +34,7 @@ import Data.Binary qualified as Binary import Data.Binary.Get qualified as Binary import Data.ByteString.Lazy qualified as BL+import Data.FileEmbed (embedFile) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as Map@@ -46,27 +46,12 @@ import Language.Haskell.Syntax.ImpExp (ImportListInterpretation (..)) import Ormolu.Fixity.Imports (FixityImport (..)) import Ormolu.Fixity.Internal-#if BUNDLE_FIXITIES-import Data.FileEmbed (embedFile)-#else-import qualified Data.ByteString as B-import System.IO.Unsafe (unsafePerformIO)-#endif  -- | The built-in 'HackageInfo' used by Ormolu. hackageInfo :: HackageInfo-#if BUNDLE_FIXITIES hackageInfo =   Binary.runGet Binary.get $     BL.fromStrict $(embedFile "extract-hackage-info/hackage-info.bin")-#else--- The GHC WASM backend does not yet support Template Haskell, so we instead--- pass in the encoded fixity DB via pre-initialization with Wizer.-hackageInfo =-  unsafePerformIO $-    Binary.runGet Binary.get . BL.fromStrict <$> B.readFile "hackage-info.bin"-{-# NOINLINE hackageInfo #-}-#endif  -- | Default set of packages to assume as dependencies e.g. when no Cabal -- file is found or taken into consideration.

@@ -30,8 +30,10 @@   ) where -import Control.DeepSeq (NFData) import Data.Binary (Binary)+import Data.Binary qualified as Binary+import Data.Binary.Get qualified as Binary+import Data.Binary.Put qualified as Binary import Data.ByteString.Short (ShortByteString) import Data.ByteString.Short qualified as SBS import Data.Choice (Choice)@@ -59,7 +61,7 @@   { -- | Invariant: UTF-8 encoded     getOpName :: ShortByteString   }-  deriving newtype (Eq, Ord, Binary, NFData)+  deriving newtype (Eq, Ord, Binary)  -- | Convert an 'OpName' to 'Text'. unOpName :: OpName -> Text@@ -88,7 +90,7 @@   | InfixR   | InfixN   deriving stock (Eq, Ord, Show, Generic)-  deriving anyclass (Binary, NFData)+  deriving anyclass (Binary)  -- | Fixity information about an infix operator. This type provides precise -- information as opposed to 'FixityApproximation'.@@ -96,11 +98,20 @@   { -- | Fixity direction     fiDirection :: FixityDirection,     -- | Precedence-    fiPrecedence :: Int+    fiPrecedence :: Double   }   deriving stock (Eq, Ord, Show, Generic)-  deriving anyclass (Binary, NFData) +instance Binary FixityInfo where+  put FixityInfo {..} = do+    Binary.put fiDirection+    Binary.putDoublele fiPrecedence++  get = do+    fiDirection <- Binary.get+    fiPrecedence <- Binary.getDoublele+    pure FixityInfo {..}+ -- | Fixity info of the built-in colon data constructor. colonFixityInfo :: FixityInfo colonFixityInfo = FixityInfo InfixR 5@@ -116,14 +127,25 @@     faDirection :: Maybe FixityDirection,     -- | Minimum precedence level found in the (maybe conflicting)     -- definitions for the operator (inclusive)-    faMinPrecedence :: Int,+    faMinPrecedence :: Double,     -- | Maximum precedence level found in the (maybe conflicting)     -- definitions for the operator (inclusive)-    faMaxPrecedence :: Int+    faMaxPrecedence :: Double   }   deriving stock (Eq, Ord, Show, Generic)-  deriving anyclass (Binary, NFData) +instance Binary FixityApproximation where+  put FixityApproximation {..} = do+    Binary.put faDirection+    Binary.putDoublele faMinPrecedence+    Binary.putDoublele faMaxPrecedence++  get = do+    faDirection <- Binary.get+    faMinPrecedence <- Binary.getDoublele+    faMaxPrecedence <- Binary.getDoublele+    pure FixityApproximation {..}+ -- | Gives the ability to merge two (maybe conflicting) definitions for an -- operator, keeping the higher level of compatible information from both. instance Semigroup FixityApproximation where@@ -156,7 +178,7 @@ newtype HackageInfo   = HackageInfo (Map PackageName (Map ModuleName (Map OpName FixityInfo)))   deriving stock (Generic)-  deriving anyclass (Binary, NFData)+  deriving anyclass (Binary)  -- | Map from the operator name to its 'FixityInfo'. newtype FixityOverrides = FixityOverrides

@@ -103,7 +103,9 @@   fiDirection <- pFixityDirection   hidden hspace1   offsetAtPrecedence <- getOffset-  fiPrecedence <- L.decimal+  fiPrecedence <-+    try L.float+      <|> (fromIntegral <$> (L.decimal :: Parser Integer))   when (fiPrecedence > 9) $     region       (setErrorOffset offsetAtPrecedence)

@@ -19,6 +19,7 @@ import Data.Text.Lazy.Builder (Builder) import Data.Text.Lazy.Builder qualified as B import Data.Text.Lazy.Builder.Int qualified as B+import Data.Text.Lazy.Builder.RealFloat qualified as B import Distribution.ModuleName (ModuleName) import Distribution.ModuleName qualified as ModuleName import Distribution.Types.PackageName@@ -44,7 +45,7 @@         InfixR -> "infixr"         InfixN -> "infix",       " ",-      B.decimal fiPrecedence,+      renderPrecedence fiPrecedence,       " ",       if isTickedOperator operator         then "`" <> B.fromText operator <> "`"@@ -75,3 +76,12 @@  renderModuleName :: ModuleName -> Builder renderModuleName = B.fromString . intercalate "." . ModuleName.components++-- | Render precedence using integer representation for whole numbers.+renderPrecedence :: Double -> Builder+renderPrecedence x =+  let (n :: Int, fraction :: Double) = properFraction x+      isWholeEnough = fraction < 0.0001+   in if isWholeEnough+        then B.decimal n+        else B.realFloat x

@@ -17,6 +17,7 @@ import Data.List (nubBy, sortBy, sortOn) import Data.Map.Strict (Map) import Data.Map.Strict qualified as M+import Data.Ord (comparing) import Data.Set (Set) import Distribution.ModuleName qualified as Cabal import GHC.Data.FastString@@ -170,7 +171,7 @@                         IEVar _ _ _ ->                           error "Ormolu.Imports broken presupposition"                         IEThingAbs x _ _ ->-                          IEThingWith x n wildcard g Nothing+                          IEThingWith (x, noAnn) n wildcard g Nothing                         IEThingAll x n' _ ->                           IEThingAll x n' Nothing                         IEThingWith x n' wildcard' g' _ ->@@ -222,15 +223,14 @@  -- | Compare two @'IEWrapppedName' 'GhcPs'@ things. compareIewn :: IEWrappedName GhcPs -> IEWrappedName GhcPs -> Ordering-compareIewn (IEName _ x) (IEName _ y) = unLoc x `compareRdrName` unLoc y-compareIewn (IEName _ _) (IEPattern _ _) = LT-compareIewn (IEName _ _) (IEType _ _) = LT-compareIewn (IEPattern _ _) (IEName _ _) = GT-compareIewn (IEPattern _ x) (IEPattern _ y) = unLoc x `compareRdrName` unLoc y-compareIewn (IEPattern _ _) (IEType _ _) = LT-compareIewn (IEType _ _) (IEName _ _) = GT-compareIewn (IEType _ _) (IEPattern _ _) = GT-compareIewn (IEType _ x) (IEType _ y) = unLoc x `compareRdrName` unLoc y+compareIewn = (comparing fst <> (compareRdrName `on` unLoc . snd)) `on` classify+  where+    classify :: IEWrappedName GhcPs -> (Int, LocatedN RdrName)+    classify = \case+      IEName _ x -> (0, x)+      IEDefault _ x -> (1, x)+      IEPattern _ x -> (2, x)+      IEType _ x -> (3, x)  compareRdrName :: RdrName -> RdrName -> Ordering compareRdrName x y =

@@ -178,7 +178,11 @@ normalizeModule :: Config RegionDeltas -> HsModule GhcPs -> HsModule GhcPs normalizeModule Config {..} hsmod =   everywhere-    (mkT dropBlankTypeHaddocks `extT` dropBlankDataDeclHaddocks `extT` patchContext)+    ( mkT dropBlankTypeHaddocks+        `extT` dropBlankDataDeclHaddocks+        `extT` patchContext+        `extT` patchExprContext+    )     hsmod       { hsmodImports =           hsmodImports hsmod,@@ -212,6 +216,8 @@         | isBlankDocString s -> ConDeclH98 {con_doc = Nothing, ..}       a -> a +    -- For constraint contexts (both in types and in expressions), normalize+    -- parenthesis as decided in https://github.com/tweag/ormolu/issues/264.     patchContext :: LHsContext GhcPs -> LHsContext GhcPs     patchContext = fmap $ \case       [x@(L _ (HsParTy _ inner))]@@ -224,6 +230,11 @@         | ConstraintAlways <- constraintParens -> [L lx (HsParTy noAnn x)]         | otherwise -> [x]       xs -> xs+    patchExprContext :: LHsExpr GhcPs -> LHsExpr GhcPs+    patchExprContext = fmap $ \case+      x@(HsQual _ (L _ [L _ HsPar {}]) _) -> x+      HsQual l0 (L l1 [x@(L lx _)]) e -> HsQual l0 (L l1 [L lx (HsPar noAnn x)]) e+      x -> x     constraintParens = runIdentity (poSingleConstraintParens cfgPrinterOpts)  -- | Enable all language extensions that we think should be enabled by@@ -264,7 +275,8 @@     OverloadedRecordDot, -- f.g parses differently     OverloadedRecordUpdate, -- qualified fields are not supported     OverloadedLabels, -- a#b is parsed differently-    ExtendedLiterals -- 1#Word32 is parsed differently+    ExtendedLiterals, -- 1#Word32 is parsed differently+    MultilineStrings -- """""" is parsed differently   ]  -- | Run a 'GHC.P' computation.

@@ -15,6 +15,7 @@     p_hsDoc',     p_sourceText,     p_namespaceSpec,+    p_arrow,   ) where @@ -34,6 +35,7 @@ import GHC.Types.Name.Reader import GHC.Types.SourceText import GHC.Types.SrcLoc+import Language.Haskell.Syntax (HsArrowOf (..)) import Language.Haskell.Syntax.Module.Name import Ormolu.Config import Ormolu.Printer.Combinators@@ -59,6 +61,10 @@ p_ieWrappedName :: IEWrappedName GhcPs -> R () p_ieWrappedName = \case   IEName _ x -> p_rdrName x+  IEDefault _ x -> do+    txt "default"+    space+    p_rdrName x   IEPattern _ x -> do     txt "pattern"     space@@ -74,13 +80,13 @@   unboxedSums <- isExtensionEnabled UnboxedSums   let wrapper EpAnn {anns} = case anns of         NameAnnQuote {nann_quoted} -> tickPrefix . wrapper nann_quoted-        NameAnn {nann_adornment = NameParens} ->+        NameAnn {nann_adornment = NameParens {}} ->           parens N . handleUnboxedSumsAndHashInteraction-        NameAnn {nann_adornment = NameBackquotes} -> backticks+        NameAnn {nann_adornment = NameBackquotes {}} -> backticks         -- whether the `->` identifier is parenthesized         NameAnnRArrow {nann_mopen = Just _} -> parens N         -- special case for unboxed unit tuples-        NameAnnOnly {nann_adornment = NameParensHash} -> const $ txt "(# #)"+        NameAnnOnly {nann_adornment = NameParensHash {}} -> const $ txt "(# #)"         _ -> id        -- When UnboxedSums is enabled, `(#` is a single lexeme, so we have to@@ -235,3 +241,13 @@   NoNamespaceSpecifier -> pure ()   TypeNamespaceSpecifier _ -> txt "type" *> space   DataNamespaceSpecifier _ -> txt "data" *> space++p_arrow :: (mult -> R ()) -> HsArrowOf mult GhcPs -> R ()+p_arrow p_mult = \case+  HsUnrestrictedArrow _ -> token'rarrow+  HsLinearArrow _ -> token'lolly+  HsExplicitMult _ mult -> do+    txt "%"+    p_mult mult+    space+    token'rarrow

@@ -313,6 +313,7 @@  patBindNames :: Pat GhcPs -> [RdrName] patBindNames (TuplePat _ ps _) = concatMap (patBindNames . unLoc) ps+patBindNames (OrPat _ ps) = foldMap (patBindNames . unLoc) ps patBindNames (VarPat _ (L _ n)) = [n] patBindNames (WildPat _) = [] patBindNames (LazyPat _ (L _ p)) = patBindNames p

@@ -19,10 +19,9 @@ import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE-import Data.Maybe (isJust, isNothing, mapMaybe, maybeToList)+import Data.Maybe (isJust, isNothing, maybeToList) import Data.Text qualified as Text import Data.Void-import GHC.Data.Strict qualified as Strict import GHC.Hs import GHC.Types.Fixity import GHC.Types.ForeignCall@@ -256,10 +255,7 @@         forM_ con_mb_cxt p_lhsContext      conNameWithContextSpn =-      [ RealSrcSpan real Strict.Nothing-      | EpaSpan (RealSrcSpan real _) <--          mapMaybe (matchAddEpAnn AnnForall) con_ext-      ]+      [getHasLoc $ acdh_forall con_ext]         <> fmap getLocA con_ex_tvs         <> maybeToList (fmap getLocA con_mb_cxt)         <> [conNameSpn]

@@ -5,13 +5,18 @@   ) where +import GHC.Data.Maybe (whenIsJust) import GHC.Hs import Ormolu.Printer.Combinators+import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Type  p_defaultDecl :: DefaultDecl GhcPs -> R ()-p_defaultDecl (DefaultDecl _ ts) = do+p_defaultDecl (DefaultDecl _ mclass ts) = do   txt "default"+  whenIsJust mclass $ \c -> do+    breakpoint+    p_rdrName c   breakpoint   inci . parens N $     sep commaDel (sitcc . located' p_hsType) ts

@@ -185,7 +185,7 @@ -- intermediate representation. cmdOpTree :: LHsCmdTop GhcPs -> OpTree (LHsCmdTop GhcPs) (LHsExpr GhcPs) cmdOpTree = \case-  (L _ (HsCmdTop _ (L _ (HsCmdArrForm _ op Infix _ [x, y])))) ->+  (L _ (HsCmdTop _ (L _ (HsCmdArrForm _ op Infix [x, y])))) ->     BinaryOpBranches (cmdOpTree x) op (cmdOpTree y)   n -> OpNode n 

@@ -88,7 +88,7 @@   FixitySig GhcPs ->   R () p_fixSig = \case-  FixitySig namespace names (Fixity _ n dir) -> do+  FixitySig namespace names (Fixity n dir) -> do     txt $ case dir of       InfixL -> "infixl"       InfixR -> "infixr"

@@ -0,0 +1,152 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++module Ormolu.Printer.Meat.Declaration.StringLiteral (p_stringLit) where++import Control.Applicative (Alternative (..))+import Control.Category ((>>>))+import Control.Monad ((>=>))+import Data.Semigroup (Min (..))+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Data.FastString+import GHC.Parser.CharClass (is_space)+import Ormolu.Printer.Combinators+import Ormolu.Utils++-- | Print the source text of a string literal while indenting gaps and newlines+-- correctly.+p_stringLit :: FastString -> R ()+p_stringLit src = case parseStringLiteral $ T.pack $ unpackFS src of+  Nothing -> error $ "Internal Ormolu error: couldn't parse string literal: " <> show src+  Just ParsedStringLiteral {..} -> sitcc do+    txt startMarker+    case stringLiteralKind of+      RegularStringLiteral -> do+        let singleLine =+              txt $ T.concat segments+            multiLine =+              sep breakpoint f (attachRelativePos segments)+              where+                f :: (RelativePos, Text) -> R ()+                f (pos, s) = case pos of+                  SinglePos -> txt s+                  FirstPos -> txt s *> txt "\\"+                  MiddlePos -> txt "\\" *> txt s *> txt "\\"+                  LastPos -> txt "\\" *> txt s+        vlayout singleLine multiLine+      MultilineStringLiteral ->+        sep breakpoint' txt segments+    txt endMarker++-- | The start/end marker of the literal, whether it is a regular or a multiline+-- literal, and the segments of the literals (separated by gaps for a regular+-- literal, and separated by newlines for a multiline literal).+data ParsedStringLiteral = ParsedStringLiteral+  { startMarker, endMarker :: Text,+    stringLiteralKind :: StringLiteralKind,+    segments :: [Text]+  }+  deriving stock (Show, Eq)++-- | A regular or a multiline string literal.+data StringLiteralKind = RegularStringLiteral | MultilineStringLiteral+  deriving stock (Show, Eq)++-- | Turn a string literal (as it exists in the source) into a more structured+-- form for printing. This should never return 'Nothing' for literals that the+-- GHC parser accepted.+parseStringLiteral :: Text -> Maybe ParsedStringLiteral+parseStringLiteral = \s -> do+  psl <-+    (stripStartEndMarker MultilineStringLiteral "\"\"\"" s)+      <|> (stripStartEndMarker RegularStringLiteral "\"" s)+  let splitSegments = case stringLiteralKind psl of+        RegularStringLiteral -> splitGaps+        MultilineStringLiteral -> splitMultilineString+  pure psl {segments = concatMap splitSegments $ segments psl}+  where+    -- Remove the given marker from the start and the end (at the end,+    -- optionally also remove a #).+    stripStartEndMarker ::+      StringLiteralKind -> Text -> Text -> Maybe ParsedStringLiteral+    stripStartEndMarker stringLiteralKind marker s = do+      let startMarker = marker+      suffix <- T.stripPrefix startMarker s+      let markerWithHash = marker <> "#"+      (endMarker, infix_) <-+        ((markerWithHash,) <$> T.stripSuffix markerWithHash suffix)+          <|> ((marker,) <$> T.stripSuffix marker suffix)+      pure ParsedStringLiteral {segments = [infix_], ..}++    -- Split a string on gaps (backslash delimited whitespaces).+    --+    -- > splitGaps "bar\\  \\fo\\&o" == ["bar", "fo\\&o"]+    splitGaps :: Text -> [Text]+    splitGaps s = go $ T.breakOnAll "\\" s+      where+        go [] = [s]+        go ((pre, suf) : bs) = case T.uncons suf of+          Just ('\\', T.uncons -> Just (c, s'))+            | is_space c,+              let rest = T.drop 1 $ T.dropWhile (/= '\\') s' ->+                pre : splitGaps rest+            | otherwise -> go $ (if c == '\\' then drop 1 else id) bs+          _ -> go bs++    -- See the the MultilineStrings GHC proposal and 'lexMultilineString' from+    -- "GHC.Parser.String" for reference.+    --+    -- https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0569-multiline-strings.rst#proposed-change-specification+    splitMultilineString :: Text -> [Text]+    splitMultilineString =+      splitGaps+        -- There is no reason to use gaps with multiline string literals, so+        -- we collapse them.+        >>> T.concat+        >>> splitNewlines+        >>> fmap expandLeadingTabs+        >>> rmCommonWhitespacePrefixAndBlank++    -- See the definition of newlines on+    -- <https://www.haskell.org/onlinereport/haskell2010/haskellch10.html#x17-17800010.3>.+    splitNewlines :: Text -> [Text]+    splitNewlines = T.splitOn "\r\n" >=> T.split isNewlineish+      where+        isNewlineish c = c == '\n' || c == '\r' || c == '\f'++    -- See GHC's 'lexMultilineString'.+    expandLeadingTabs :: Text -> Text+    expandLeadingTabs = T.concat . go 0+      where+        go :: Int -> Text -> [Text]+        go col s = case T.breakOn "\t" s of+          (pre, T.uncons -> Just (_, suf)) ->+            let col' = col + T.length pre+                fill = 8 - (col' `mod` 8)+             in pre : T.replicate fill " " : go (col' + fill) suf+          _ -> [s]++    -- Don't touch the first line, and remove common whitespace from all+    -- remaining lines as well as convert those consisting only of whitespace to+    -- empty lines.+    rmCommonWhitespacePrefixAndBlank :: [Text] -> [Text]+    rmCommonWhitespacePrefixAndBlank = \case+      [] -> []+      hd : tl -> hd : tl'+        where+          (leadingSpaces, tl') = unzip $ countLeadingAndBlank <$> tl++          commonWs :: Int+          commonWs = maybe 0 getMin $ mconcat leadingSpaces++          countLeadingAndBlank :: Text -> (Maybe (Min Int), Text)+          countLeadingAndBlank l+            | T.all is_space l = (Nothing, "")+            | otherwise = (Just $ Min leadingSpace, T.drop commonWs l)+            where+              leadingSpace = T.length $ T.takeWhile is_space l

@@ -1,6 +1,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}@@ -10,7 +12,6 @@     p_pat,     p_hsExpr,     p_hsUntypedSplice,-    p_stringLit,     IsApplicand (..),     p_hsExpr',     p_hsCmdTop,@@ -21,24 +22,21 @@  import Control.Monad import Data.Bool (bool)-import Data.Coerce (coerce)+import Data.Choice (pattern Isn't) import Data.Data hiding (Infix, Prefix) import Data.Function (on) import Data.Functor ((<&>)) import Data.Generics.Schemes (everything)-import Data.List (find, intersperse, sortBy)+import Data.List (intersperse, sortBy, unsnoc) import Data.List.NonEmpty (NonEmpty (..), (<|)) import Data.List.NonEmpty qualified as NE import Data.Maybe import Data.Text (Text) import Data.Text qualified as Text import Data.Void-import GHC.Data.Bag (bagToList)-import GHC.Data.FastString import GHC.Data.Strict qualified as Strict import GHC.Hs import GHC.LanguageExtensions.Type (Extension (NegativeLiterals))-import GHC.Parser.CharClass (is_space) import GHC.Types.Basic import GHC.Types.Fixity import GHC.Types.Name.Reader@@ -52,6 +50,7 @@ import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.OpTree import Ormolu.Printer.Meat.Declaration.Signature+import Ormolu.Printer.Meat.Declaration.StringLiteral import Ormolu.Printer.Meat.Type import Ormolu.Printer.Operators import Ormolu.Utils@@ -122,7 +121,8 @@         (isInfixMatch m)         (HsNoMultAnn NoExtField)         (matchStrictness m)-        m_pats+        -- We use the spans of the individual patterns.+        (unLoc m_pats)         m_grhss  -- | Function id obtained through pattern matching on 'FunBind' should not@@ -350,7 +350,7 @@ p_hsCmd' isApp s = \case   HsCmdArrApp _ body input arrType rightToLeft -> do     let (l, r) = if rightToLeft then (body, input) else (input, body)-    located l p_hsExpr+    located l $ p_hsExpr' NotApplicand s     breakpoint     inci $ do       case (arrType, rightToLeft) of@@ -360,19 +360,19 @@         (HsHigherOrderApp, False) -> token'Rarrowtail       placeHanging (exprPlacement (unLoc input)) $         located r p_hsExpr-  HsCmdArrForm _ form Prefix _ cmds -> banana s $ do+  HsCmdArrForm _ form Prefix cmds -> banana s $ do     located form p_hsExpr     unless (null cmds) $ do       breakpoint       inci (sequence_ (intersperse breakpoint (located' (p_hsCmdTop N) <$> cmds)))-  HsCmdArrForm _ form Infix _ [left, right] -> do+  HsCmdArrForm _ form Infix [left, right] -> do     modFixityMap <- askModuleFixityMap     debug <- askDebug     let opTree = BinaryOpBranches (cmdOpTree left) form (cmdOpTree right)     p_cmdOpTree       s       (reassociateOpTree debug (getOpName . unLoc) modFixityMap opTree)-  HsCmdArrForm _ _ Infix _ _ -> notImplemented "HsCmdArrForm"+  HsCmdArrForm _ _ Infix _ -> notImplemented "HsCmdArrForm"   HsCmdApp _ cmd expr -> do     located cmd (p_hsCmd' Applicand s)     breakpoint@@ -426,8 +426,9 @@ p_stmt = p_stmt' N exprPlacement (p_hsExpr' NotApplicand)  p_stmt' ::-  ( Anno (Stmt GhcPs (LocatedA body)) ~ SrcSpanAnnA,-    Anno [LocatedA (Stmt GhcPs (LocatedA body))] ~ SrcSpanAnnL+  ( Anno [LStmt GhcPs (XRec GhcPs body)] ~ SrcSpanAnnLW,+    Anno (Stmt GhcPs (XRec GhcPs body)) ~ SrcSpanAnnA,+    Anno body ~ SrcSpanAnnA   ) =>   BracketStyle ->   -- | Placer@@ -435,7 +436,7 @@   -- | Render   (BracketStyle -> body -> R ()) ->   -- | Statement to render-  Stmt GhcPs (LocatedA body) ->+  Stmt GhcPs (XRec GhcPs body) ->   R () p_stmt' s placer render = \case   LastStmt _ body _ _ -> located body (render s)@@ -449,14 +450,8 @@           | otherwise = Normal     switchLayout [loc, l] $       placeHanging placement (located f (render N))-  ApplicativeStmt {} -> notImplemented "ApplicativeStmt" -- generated by renamer   BodyStmt _ body _ _ -> located body (render s)-  LetStmt epAnnLet binds -> do-    let letLoc =-          fmap (\(AddEpAnn _ loc) -> loc)-            . find (\(AddEpAnn ann _) -> ann == AnnLet)-            $ epAnnLet-    p_let' True letLoc binds Nothing+  LetStmt epAnnLet binds -> p_let' True epAnnLet binds Nothing   ParStmt {} ->     -- 'ParStmt' should always be eliminated in 'gatherStmts' already, such     -- that it never occurs in 'p_stmt''. Consequently, handling it here@@ -497,8 +492,9 @@     sitcc . located recS_stmts $ sepSemi (withSpacing (p_stmt' s placer render))  p_stmts ::-  ( Anno (Stmt GhcPs (LocatedA body)) ~ SrcSpanAnnA,-    Anno [LocatedA (Stmt GhcPs (LocatedA body))] ~ SrcSpanAnnL+  ( Anno [LStmt GhcPs (XRec GhcPs body)] ~ SrcSpanAnnLW,+    Anno (Stmt GhcPs (XRec GhcPs body)) ~ SrcSpanAnnA,+    Anno body ~ SrcSpanAnnA   ) =>   BracketStyle ->   IsApplicand ->@@ -507,7 +503,7 @@   -- | Render   (BracketStyle -> body -> R ()) ->   -- | Statements to render-  LocatedL [LocatedA (Stmt GhcPs (LocatedA body))] ->+  XRec GhcPs [LStmt GhcPs (XRec GhcPs body)] ->   R () p_stmts s isApp placer render es = do   breakpoint@@ -527,7 +523,7 @@  p_hsLocalBinds :: HsLocalBinds GhcPs -> R () p_hsLocalBinds = \case-  HsValBinds epAnn (ValBinds _ bag lsigs) -> pseudoLocated epAnn $ do+  HsValBinds epAnn (ValBinds _ binds lsigs) -> pseudoLocated epAnn $ do     -- When in a single-line layout, there is a chance that the inner     -- elements will also contain semicolons and they will confuse the     -- parser. so we request braces around every element except the last.@@ -535,7 +531,7 @@     let items =           let injectLeft (L l x) = L l (Left x)               injectRight (L l x) = L l (Right x)-           in (injectLeft <$> bagToList bag) ++ (injectRight <$> lsigs)+           in (injectLeft <$> binds) ++ (injectRight <$> lsigs)         positionToBracing = \case           SinglePos -> id           FirstPos -> br@@ -544,8 +540,8 @@         p_item' (p, item) =           positionToBracing p $             withSpacing (either p_valDecl p_sigDecl) item-        binds = sortBy (leftmost_smallest `on` getLocA) items-    sitcc $ sepSemi p_item' (attachRelativePos binds)+        items' = sortBy (leftmost_smallest `on` getLocA) items+    sitcc $ sepSemi p_item' (attachRelativePos items')   HsValBinds _ _ -> notImplemented "HsValBinds"   HsIPBinds epAnn (IPBinds _ xs) -> pseudoLocated epAnn $ do     let p_ipBind (IPBind _ (L _ name) expr) = do@@ -567,12 +563,12 @@             located (L al_anchor ()) . const       _ -> id -p_ldotFieldOcc :: XRec GhcPs (DotFieldOcc GhcPs) -> R ()-p_ldotFieldOcc =-  located' $ p_rdrName . fmap (mkVarUnqual . field_label) . dfoLabel+p_dotFieldOcc :: DotFieldOcc GhcPs -> R ()+p_dotFieldOcc =+  p_rdrName . fmap (mkVarUnqual . field_label) . dfoLabel -p_ldotFieldOccs :: [XRec GhcPs (DotFieldOcc GhcPs)] -> R ()-p_ldotFieldOccs = sep (txt ".") p_ldotFieldOcc+p_dotFieldOccs :: [DotFieldOcc GhcPs] -> R ()+p_dotFieldOccs = sep (txt ".") p_dotFieldOcc  p_fieldOcc :: FieldOcc GhcPs -> R () p_fieldOcc FieldOcc {..} = p_rdrName foLabel@@ -614,8 +610,7 @@ p_hsExpr' isApp s = \case   HsVar _ name -> p_rdrName name   HsUnboundVar _ occ -> atom occ-  HsRecSel _ fldOcc -> p_fieldOcc fldOcc-  HsOverLabel _ sourceText _ -> do+  HsOverLabel sourceText _ -> do     txt "#"     p_sourceText sourceText   HsIPVar _ (HsIPName name) -> do@@ -626,6 +621,7 @@     case lit of       HsString (SourceText stxt) _ -> p_stringLit stxt       HsStringPrim (SourceText stxt) _ -> p_stringLit stxt+      HsMultilineString (SourceText stxt) _ -> p_stringLit stxt       r -> atom r   HsLam _ variant mgroup ->     p_lam isApp variant exprPlacement p_hsExpr mgroup@@ -691,11 +687,6 @@     breakpoint     inci $ do       txt "@"-      -- Insert a space when the type is represented as a TH splice to avoid-      -- gluing @ and $ together.-      case unLoc (hswc_body a) of-        HsSpliceTy {} -> space-        _ -> return ()       located (hswc_body a) p_hsType   OpApp _ x op y -> do     modFixityMap <- askModuleFixityMap@@ -791,25 +782,22 @@   RecordUpd {..} -> do     located rupd_expr p_hsExpr     breakpointPreRecordBrace-    let p_updLbl =-          located' $-            p_rdrName . \case-              (Unambiguous NoExtField n :: AmbiguousFieldOcc GhcPs) -> n-              Ambiguous NoExtField n -> n-        p_recFields p_lbl =+    let p_recFields p_lbl =           sep commaDel (sitcc . located' (p_hsFieldBind p_lbl))+        p_fieldLabelStrings (FieldLabelStrings flss) =+          p_dotFieldOccs $ unLoc <$> flss     inci . braces N $ case rupd_flds of       RegularRecUpdFields {..} ->-        p_recFields p_updLbl recUpdFields+        p_recFields (located' p_fieldOcc) recUpdFields       OverloadedRecUpdFields {..} ->-        p_recFields (located' (coerce p_ldotFieldOccs)) olRecUpdFields+        p_recFields (located' p_fieldLabelStrings) olRecUpdFields   HsGetField {..} -> do     located gf_expr p_hsExpr     txt "."-    p_ldotFieldOcc gf_field+    located gf_field p_dotFieldOcc   HsProjection {..} -> parens N $ do     txt "."-    p_ldotFieldOccs (NE.toList proj_flds)+    p_dotFieldOccs (NE.toList proj_flds)   ExprWithTySig _ x HsWC {hswc_body} -> sitcc $ do     located x p_hsExpr     inci $ startTypeAnnotation hswc_body p_hsSigType@@ -841,7 +829,7 @@     located expr p_hsExpr     breakpoint'     txt "||]"-  HsUntypedBracket anns x -> p_hsQuote anns x+  HsUntypedBracket _ x -> p_hsQuote x   HsTypedSplice _ expr -> p_hsSpliceTH True expr DollarSplice   HsUntypedSplice _ untySplice -> p_hsUntypedSplice DollarSplice untySplice   HsProc _ p e -> do@@ -869,11 +857,24 @@     txt "type"     space     located hswc_body p_hsType+  -- similar to HsForAllTy+  HsForAll _ tele e -> do+    p_hsForAllTelescope (Isn't #multiline) tele+    located e p_hsExpr+  -- similar to HsQualTy+  HsQual _ qs e -> do+    located qs $ p_hsContext' p_hsExpr+    p_hsQualArrow (Isn't #multiline)+    located e p_hsExpr+  -- similar to HsFunTy+  HsFunArr _ arrow x y -> do+    located x p_hsExpr+    p_hsFun (Isn't #multiline) p_hsExpr arrow y  -- | Print a list comprehension. -- -- BracketStyle should be N except in a do-block, which must be S or else it's a parse error.-p_listComp :: BracketStyle -> GenLocated SrcSpanAnnL [ExprLStmt GhcPs] -> R ()+p_listComp :: BracketStyle -> XRec GhcPs [ExprLStmt GhcPs] -> R () p_listComp s es = sitcc (vlayout singleLine multiLine)   where     singleLine = do@@ -890,10 +891,9 @@     body = located es p_body     p_body xs = do       let (stmts, yield) =-            -- TODO: use unsnoc when require GHC 9.8+-            case xs of-              [] -> error $ "list comprehension unexpectedly had no expressions"-              _ -> (init xs, last xs)+            case unsnoc xs of+              Nothing -> error $ "list comprehension unexpectedly had no expressions"+              Just (ys, y) -> (ys, y)       sitcc $ located yield p_stmt       breakpoint       txt "|"@@ -1149,18 +1149,13 @@   HsLocalBinds GhcPs ->   LocatedA body ->   R ()-p_let inDo render letToken localBinds e = p_let' inDo letLoc localBinds $ Just (located e render)-  where-    letLoc =-      case letToken of-        EpTok loc -> Just loc-        NoEpTok -> Nothing+p_let inDo render letToken localBinds e = p_let' inDo letToken localBinds $ Just (located e render)  p_let' ::   -- | True if in do-block   Bool ->   -- | Annotation for the `let` block-  Maybe EpaLocation ->+  EpToken "let" ->   -- | Let bindings   HsLocalBinds GhcPs ->   -- | Optional 'in' body@@ -1180,7 +1175,10 @@             -- check if local binds are on the same line as the "let" keyword;             -- if we can't figure out the positions, just fallback to `inline` style             fromMaybe True $ do-              letStartLine <- srcSpanStartLine . epaLocationRealSrcSpan <$> letLoc+              letStartLine <-+                case letLoc of+                  EpTok loc -> pure . srcSpanStartLine . epaLocationRealSrcSpan $ loc+                  NoEpTok -> Nothing               localBindsStartLine <- localBindsEpAnns localBinds >>= epAnnsStartLine               pure $                 -- special case when let has zero local binds@@ -1259,6 +1257,8 @@             Boxed -> parens S             Unboxed -> parensHash S     parens' $ sep commaDel (sitcc . located' p_pat) pats+  OrPat _ pats ->+    sepSemi (located' p_pat) (NE.toList pats)   SumPat _ pat tag arity ->     p_unboxedSum S tag arity (located pat p_pat)   ConPat _ pat details ->@@ -1269,7 +1269,7 @@         inci . sitcc $           sep breakpoint (sitcc . either p_hsConPatTyArg (located' p_pat)) $             (Left <$> tys) <> (Right <$> xs)-      RecCon (HsRecFields fields dotdot) -> do+      RecCon (HsRecFields _ fields dotdot) -> do         p_rdrName pat         breakpointPreRecordBrace         let f = \case@@ -1376,12 +1376,12 @@   where     decoSymbol = if isTyped then "$$" else "$" -p_hsQuote :: [AddEpAnn] -> HsQuote GhcPs -> R ()-p_hsQuote anns = \case-  ExpBr _ expr -> do-    let name-          | any (isJust . matchAddEpAnn AnnOpenEQ) anns = ""-          | otherwise = "e"+p_hsQuote :: HsQuote GhcPs -> R ()+p_hsQuote = \case+  ExpBr (bracketAnn, _) expr -> do+    let name = case bracketAnn of+          BracketNoE {} -> ""+          BracketHasE {} -> "e"     quote name (located expr p_hsExpr)   PatBr _ pat -> located pat (quote "p" . p_pat)   DecBrL _ decls -> quote "d" (handleStarIsType decls (p_hsDecls Free decls))@@ -1417,47 +1417,6 @@           Just HsStarTy {} -> True           _ -> False --- | Print the source text of a string literal while indenting gaps correctly.-p_stringLit :: FastString -> R ()-p_stringLit src =-  let s = splitGaps (unpackFS src)-      singleLine =-        txt $ Text.pack (mconcat s)-      multiLine =-        sitcc $ sep breakpoint (txt . Text.pack) (backslashes s)-   in vlayout singleLine multiLine-  where-    -- Split a string on gaps (backslash delimited whitespaces)-    ---    -- > splitGaps "bar\\  \\fo\\&o" == ["bar", "fo\\&o"]-    splitGaps :: String -> [String]-    splitGaps "" = []-    splitGaps s =-      let -- A backslash and a whitespace starts a "gap"-          p (Just '\\', _, _) = True-          p (_, '\\', Just c) | ghcSpace c = False-          p _ = True-       in case span p (zipPrevNext s) of-            (l, r) ->-              let -- drop the initial '\', any amount of 'ghcSpace', and another '\'-                  r' = drop 1 . dropWhile ghcSpace . drop 1 $ map orig r-               in map orig l : splitGaps r'-    -- GHC's definition of whitespaces in strings-    -- See: https://gitlab.haskell.org/ghc/ghc/blob/86753475/compiler/parser/Lexer.x#L1653-    ghcSpace :: Char -> Bool-    ghcSpace c = c <= '\x7f' && is_space c-    -- Add backslashes to the inner side of the strings-    ---    -- > backslashes ["a", "b", "c"] == ["a\\", "\\b\\", "\\c"]-    backslashes :: [String] -> [String]-    backslashes (x : y : xs) = (x ++ "\\") : backslashes (('\\' : y) : xs)-    backslashes xs = xs-    -- Attaches previous and next items to each list element-    zipPrevNext :: [a] -> [(Maybe a, a, Maybe a)]-    zipPrevNext xs =-      zip3 (Nothing : map Just xs) xs (map Just (drop 1 xs) ++ [Nothing])-    orig (_, x, _) = x- ---------------------------------------------------------------------------- -- Helpers @@ -1498,7 +1457,7 @@   -- Only hang lambdas with single line parameter lists   HsLam _ variant mg -> case variant of     LamSingle -> case mg of-      MG _ (L _ [L _ (Match _ _ (x : xs) _)])+      MG _ (L _ [L _ (Match _ _ (L _ (x : xs)) _)])         | isOneLineSpan (combineSrcSpans' $ fmap getLocA (x :| xs)) ->             Hanging       _ -> Normal

@@ -3,7 +3,6 @@     p_pat,     p_hsExpr,     p_hsUntypedSplice,-    p_stringLit,     p_hsExpr',     p_hsCmdTop,     exprPlacement,@@ -11,7 +10,6 @@   ) where -import GHC.Data.FastString import GHC.Hs import Ormolu.Printer.Combinators @@ -19,7 +17,6 @@ p_pat :: Pat GhcPs -> R () p_hsExpr :: HsExpr GhcPs -> R () p_hsUntypedSplice :: SpliceDecoration -> HsUntypedSplice GhcPs -> R ()-p_stringLit :: FastString -> R ()  data IsApplicand 

@@ -14,7 +14,6 @@ import Data.Choice (pattern With) import GHC.Hs hiding (comment) import GHC.Types.SrcLoc-import GHC.Utils.Outputable (ppr, showSDocUnsafe) import Ormolu.Config import Ormolu.Imports (normalizeImports) import Ormolu.Parser.CommentStream@@ -87,8 +86,8 @@           _ -> breakpoint       breakpointBeforeWhere         | not isRespectful = breakpointBeforeExportList-        | isOnSameLine moduleKeyword whereKeyword = space-        | Just closeParen <- exportClosePSpan, isOnSameLine closeParen whereKeyword = space+        | isOnSameLine am_mod am_where || isOnSameLine am_sig am_where = space+        | Just closeParen <- mCloseParen, isOnSameLine closeParen am_where = space         | otherwise = newline    case hsmodExports of@@ -102,13 +101,15 @@   txt "where"   newline   where-    (moduleKeyword, whereKeyword) =-      case am_main (anns hsmodAnn) of-        -- [AnnModule, AnnWhere] or [AnnSignature, AnnWhere]-        [AddEpAnn _ moduleLoc, AddEpAnn AnnWhere whereLoc] ->-          (epaLocationRealSrcSpan moduleLoc, epaLocationRealSrcSpan whereLoc)-        anns -> error $ "Module had unexpected annotations: " ++ showSDocUnsafe (ppr anns)-    exportClosePSpan = do-      AddEpAnn AnnCloseP loc <- al_close . anns . getLoc =<< hsmodExports-      Just $ epaLocationRealSrcSpan loc-    isOnSameLine token1 token2 = srcSpanEndLine token1 == srcSpanStartLine token2+    AnnsModule {am_sig, am_mod, am_where} = anns hsmodAnn+    mCloseParen = do+      AnnList {al_brackets} <- anns . getLoc <$> hsmodExports+      case al_brackets of+        ListParens _ closeParen -> pure closeParen+        _ -> error "Unexpectedly got a different kind of bracket in module export list"+    isOnSameLine = curry $ \case+      (EpTok token1, EpTok token2) ->+        let loc1 = epaLocationRealSrcSpan token1+            loc2 = epaLocationRealSrcSpan token2+         in srcSpanEndLine loc1 == srcSpanStartLine loc2+      _ -> False

@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}@@ -12,19 +13,24 @@     startTypeAnnotationDecl,     hasDocStrings,     p_hsContext,+    p_hsContext',     p_hsTyVarBndr,     ForAllVisibility (..),     p_forallBndrs,     p_conDeclFields,     p_lhsTypeArg,     p_hsSigType,+    p_hsForAllTelescope,+    p_hsQualArrow,+    p_hsFun,     hsOuterTyVarBndrsToHsType,     lhsTypeToSigType,   ) where  import Control.Monad-import Data.Choice (pattern With, pattern Without)+import Data.Choice (Choice, pattern With, pattern Without)+import Data.Choice qualified as Choice import Data.Functor ((<&>)) import Data.List (sortOn) import GHC.Data.Strict qualified as Strict@@ -32,36 +38,29 @@ import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Types.Var+import GHC.Utils.Outputable (Outputable) import Ormolu.Config import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.OpTree (p_tyOpTree, tyOpTree)-import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Value (p_hsUntypedSplice, p_stringLit)+import Ormolu.Printer.Meat.Declaration.StringLiteral+import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Value (p_hsUntypedSplice) import Ormolu.Printer.Operators import Ormolu.Utils  p_hsType :: HsType GhcPs -> R () p_hsType t = do   layout <- getLayout-  p_hsType' (hasDocStrings t || layout == MultiLine) t+  p_hsType' (Choice.fromBool $ hasDocStrings t || layout == MultiLine) t -p_hsType' :: Bool -> HsType GhcPs -> R ()-p_hsType' multilineArgs = \case+p_hsType' :: Choice "multiline" -> HsType GhcPs -> R ()+p_hsType' isMultiline = \case   HsForAllTy _ tele t -> do-    vis <--      case tele of-        HsForAllInvis _ bndrs -> p_forallBndrsStart p_hsTyVarBndr bndrs >> pure ForAllInvis-        HsForAllVis _ bndrs -> p_forallBndrsStart p_hsTyVarBndr bndrs >> pure ForAllVis-    getPrinterOpt poFunctionArrows >>= \case-      LeadingArrows | multilineArgs -> interArgBreak >> txt " " >> p_forallBndrsEnd vis-      _ -> p_forallBndrsEnd vis >> interArgBreak+    p_hsForAllTelescope isMultiline tele     located t p_hsType   HsQualTy _ qs t -> do     located qs p_hsContext-    getPrinterOpt poFunctionArrows >>= \case-      LeadingArrows -> interArgBreak >> token'darrow >> space-      TrailingArrows -> space >> token'darrow >> interArgBreak-      LeadingArgsArrows -> space >> token'darrow >> interArgBreak+    p_hsQualArrow isMultiline     case unLoc t of       HsQualTy {} -> p_hsTypeR (unLoc t)       HsFunTy {} -> located t p_hsType@@ -99,20 +98,8 @@       txt "@"       located kd p_hsType   HsFunTy _ arrow x y -> do-    let p_arrow =-          case arrow of-            HsUnrestrictedArrow _ -> token'rarrow-            HsLinearArrow _ -> token'lolly-            HsExplicitMult _ mult -> do-              txt "%"-              p_hsTypeR (unLoc mult)-              space-              token'rarrow     located x p_hsType-    getPrinterOpt poFunctionArrows >>= \case-      LeadingArrows -> interArgBreak >> located y (\y' -> p_arrow >> space >> p_hsTypeR y')-      TrailingArrows -> space >> p_arrow >> interArgBreak >> located y p_hsTypeR-      LeadingArgsArrows -> interArgBreak >> located y (\y' -> p_arrow >> space >> p_hsTypeR y')+    p_hsFun isMultiline p_hsTypeR arrow y   HsListTy _ t ->     located t (brackets N . p_hsType)   HsTupleTy _ tsort xs ->@@ -157,7 +144,7 @@         located t p_hsType         newline         p_hsDoc Caret (Without #endNewline) str-  HsBangTy _ (HsSrcBang _ u s) t -> do+  HsBangTy _ (HsBang u s) t -> do     case u of       SrcUnpack -> txt "{-# UNPACK #-}" >> space       SrcNoUnpack -> txt "{-# NOUNPACK #-}" >> space@@ -180,11 +167,15 @@         (IsPromoted, L _ t : _) | startsWithSingleQuote t -> space         _ -> return ()       sep commaDel (sitcc . located' p_hsType) xs-  HsExplicitTupleTy _ xs -> do-    txt "'"+  HsExplicitTupleTy _ p xs -> do+    case p of+      IsPromoted -> txt "'"+      NotPromoted -> return ()     parens N $ do-      case xs of-        L _ t : _ | startsWithSingleQuote t -> space+      -- If this tuple is promoted and the first element starts with a single+      -- quote, we need to put a space in between or it fails to parse.+      case (p, xs) of+        (IsPromoted, L _ t : _) | startsWithSingleQuote t -> space         _ -> return ()       sep commaDel (located' p_hsType) xs   HsTyLit _ t ->@@ -201,11 +192,7 @@       HsExplicitListTy {} -> True       HsTyLit _ HsCharTy {} -> True       _ -> False-    interArgBreak =-      if multilineArgs-        then newline-        else breakpoint-    p_hsTypeR m = p_hsType' multilineArgs m+    p_hsTypeR m = p_hsType' isMultiline m  startTypeAnnotation ::   (HasLoc l) =>@@ -266,13 +253,20 @@   _ -> False  p_hsContext :: HsContext GhcPs -> R ()-p_hsContext = \case+p_hsContext = p_hsContext' p_hsType++p_hsContext' ::+  (Outputable (GenLocated (Anno a) a), HasLoc (Anno a)) =>+  (a -> R ()) ->+  [XRec GhcPs a] ->+  R ()+p_hsContext' f = \case   [] -> txt "()"-  [x] -> located x p_hsType+  [x] -> located x f   xs -> do     shouldSort <- getPrinterOpt poSortConstraints     let sort = if shouldSort then sortOn showOutputable else id-    parens N $ sep commaDel (sitcc . located' p_hsType) (sort xs)+    parens N $ sep commaDel (sitcc . located' f) (sort xs)  class IsTyVarBndrFlag flag where   isInferred :: flag -> Bool@@ -294,15 +288,20 @@     HsBndrInvisible _ -> txt "@"  p_hsTyVarBndr :: (IsTyVarBndrFlag flag) => HsTyVarBndr flag GhcPs -> R ()-p_hsTyVarBndr = \case-  UserTyVar _ flag x -> do-    p_tyVarBndrFlag flag-    (if isInferred flag then braces N else id) $ p_rdrName x-  KindedTyVar _ flag l k -> do-    p_tyVarBndrFlag flag-    (if isInferred flag then braces else parens) N . sitcc $ do-      located l atom-      inci $ startTypeAnnotation k p_hsType+p_hsTyVarBndr HsTvb {..} = do+  p_tyVarBndrFlag tvb_flag+  let wrap+        | isInferred tvb_flag = braces N+        | otherwise = case tvb_kind of+            HsBndrKind {} -> parens N+            HsBndrNoKind {} -> id+  wrap $ do+    case tvb_var of+      HsBndrVar _ x -> p_rdrName x+      HsBndrWildCard _ -> txt "_"+    case tvb_kind of+      HsBndrKind _ k -> inci $ startTypeAnnotation k p_hsType+      HsBndrNoKind _ -> pure ()  data ForAllVisibility = ForAllInvis | ForAllVis @@ -375,6 +374,71 @@ p_hsSigType :: HsSigType GhcPs -> R () p_hsSigType HsSig {..} =   p_hsType $ hsOuterTyVarBndrsToHsType sig_bndrs sig_body++p_hsForAllTelescope ::+  Choice "multiline" ->+  HsForAllTelescope GhcPs ->+  R ()+p_hsForAllTelescope isMultiline tele = do+  vis <-+    case tele of+      HsForAllInvis _ bndrs -> do+        p_forallBndrsStart p_hsTyVarBndr bndrs+        pure ForAllInvis+      HsForAllVis _ bndrs -> do+        p_forallBndrsStart p_hsTyVarBndr bndrs+        pure ForAllVis++  getPrinterOpt poFunctionArrows >>= \case+    LeadingArrows | Choice.isTrue isMultiline -> do+      interArgBreak+      txt " "+      p_forallBndrsEnd vis+    _ -> do+      p_forallBndrsEnd vis+      interArgBreak+  where+    interArgBreak = if Choice.isTrue isMultiline then newline else breakpoint++p_hsQualArrow :: Choice "multiline" -> R ()+p_hsQualArrow isMultiline =+  getPrinterOpt poFunctionArrows >>= \case+    LeadingArrows -> interArgBreak >> token'darrow >> space+    TrailingArrows -> space >> token'darrow >> interArgBreak+    LeadingArgsArrows -> space >> token'darrow >> interArgBreak+  where+    interArgBreak = if Choice.isTrue isMultiline then newline else breakpoint++p_hsFun ::+  (HasLoc l) =>+  Choice "multiline" ->+  (a -> R ()) ->+  HsArrowOf (GenLocated l a) GhcPs ->+  GenLocated l a ->+  R ()+p_hsFun isMultiline renderItem arrow rhsLoc =+  getPrinterOpt poFunctionArrows >>= \case+    LeadingArrows -> do+      interArgBreak+      located rhsLoc $ \rhs -> do+        renderArrow+        space+        renderItem rhs+    TrailingArrows -> do+      space+      renderArrow+      interArgBreak+      located rhsLoc $ \rhs -> do+        renderItem rhs+    LeadingArgsArrows -> do+      interArgBreak+      located rhsLoc $ \rhs -> do+        renderArrow+        space+        renderItem rhs+  where+    interArgBreak = if Choice.isTrue isMultiline then newline else breakpoint+    renderArrow = p_arrow (located' renderItem) arrow  ---------------------------------------------------------------------------- -- Conversion functions

@@ -85,7 +85,7 @@     interleave [] bs = bs     interleave (a : as) bs = a : interleave bs as -    xs !!? i = if A.bounds rawLines `A.inRange` i then Just $ xs A.! i else Nothing+    xs !!? i = if A.bounds xs `A.inRange` i then Just $ xs A.! i else Nothing  -- | All lines we are not supposed to format, and a set of replacements -- for specific lines.

@@ -14,7 +14,6 @@     separatedByBlankNE,     onTheSameLine,     groupBy',-    matchAddEpAnn,     textToStringBuffer,     ghcModuleNameToCabal,   )@@ -163,13 +162,6 @@     if x `eq` y       then (x :| y : ys) : zs       else pure x : (y :| ys) : zs---- | Check whether the given 'AnnKeywordId' or its Unicode variant is in an--- 'AddEpAnn', and return the 'EpaLocation' if so.-matchAddEpAnn :: AnnKeywordId -> AddEpAnn -> Maybe EpaLocation-matchAddEpAnn annId (AddEpAnn annId' loc)-  | annId == annId' || unicodeAnn annId == annId' = Just loc-  | otherwise = Nothing  -- | Convert 'Text' to a 'StringBuffer' by making a copy. textToStringBuffer :: Text -> StringBuffer

@@ -14,7 +14,6 @@ import Control.Exception import Control.Monad.IO.Class import Data.ByteString qualified as B-import Data.IORef import Data.Map.Lazy (Map) import Data.Map.Lazy qualified as M import Data.Maybe (maybeToList)@@ -30,7 +29,7 @@ import Ormolu.Config import Ormolu.Exception import Ormolu.Fixity-import Ormolu.Utils.IO (findClosestFileSatisfying, withIORefCache)+import Ormolu.Utils.IO (Cache, findClosestFileSatisfying, newCache, withCache) import System.Directory import System.FilePath import System.IO.Unsafe (unsafePerformIO)@@ -106,8 +105,8 @@   deriving (Show)  -- | Cache ref that stores 'CachedCabalFile' per Cabal file.-cacheRef :: IORef (Map FilePath CachedCabalFile)-cacheRef = unsafePerformIO $ newIORef M.empty+cacheRef :: Cache FilePath CachedCabalFile+cacheRef = unsafePerformIO newCache {-# NOINLINE cacheRef #-}  -- | Parse 'CabalInfo' from a @.cabal@ file at the given 'FilePath'.@@ -123,7 +122,7 @@ parseCabalInfo cabalFileAsGiven sourceFileAsGiven = liftIO $ do   cabalFile <- makeAbsolute cabalFileAsGiven   sourceFileAbs <- makeAbsolute sourceFileAsGiven-  CachedCabalFile {..} <- withIORefCache cacheRef cabalFile $ do+  CachedCabalFile {..} <- withCache cacheRef cabalFile $ do     cabalFileBs <- B.readFile cabalFile     genericPackageDescription <-       whenLeft (snd . runParseResult $ parseGenericPackageDescription cabalFileBs) $@@ -229,17 +228,17 @@     extractFromLibrary Library {..} =       extractFromBuildInfo (ModuleName.toFilePath <$> exposedModules) libBuildInfo     extractFromExecutable Executable {..} =-      extractFromBuildInfo [modulePath] buildInfo+      extractFromBuildInfo [getSymbolicPath modulePath] buildInfo     extractFromTestSuite TestSuite {..} =       extractFromBuildInfo mainPath testBuildInfo       where         mainPath = case testInterface of-          TestSuiteExeV10 _ p -> [p]+          TestSuiteExeV10 _ p -> [getSymbolicPath p]           TestSuiteLibV09 _ p -> [ModuleName.toFilePath p]           TestSuiteUnsupported {} -> []     extractFromBenchmark Benchmark {..} =       extractFromBuildInfo mainPath benchmarkBuildInfo       where         mainPath = case benchmarkInterface of-          BenchmarkExeV10 _ p -> [p]+          BenchmarkExeV10 _ p -> [getSymbolicPath p]           BenchmarkUnsupported {} -> []

@@ -10,10 +10,7 @@ import Control.Exception (throwIO) import Control.Monad.IO.Class import Data.Bifunctor (first)-import Data.IORef import Data.List.NonEmpty (NonEmpty)-import Data.Map.Strict (Map)-import Data.Map.Strict qualified as Map import Data.Text qualified as T import Data.Text.IO.Utf8 qualified as T.Utf8 import Distribution.ModuleName (ModuleName)@@ -21,7 +18,7 @@ import Ormolu.Exception import Ormolu.Fixity import Ormolu.Fixity.Parser-import Ormolu.Utils.IO (findClosestFileSatisfying, withIORefCache)+import Ormolu.Utils.IO (Cache, findClosestFileSatisfying, newCache, withCache) import System.Directory import System.IO.Unsafe (unsafePerformIO) import Text.Megaparsec (errorBundlePretty)@@ -37,7 +34,7 @@   m (FixityOverrides, ModuleReexports) getDotOrmoluForSourceFile sourceFile =   liftIO (findDotOrmoluFile sourceFile) >>= \case-    Just dotOrmoluFile -> liftIO $ withIORefCache cacheRef dotOrmoluFile $ do+    Just dotOrmoluFile -> liftIO $ withCache cacheRef dotOrmoluFile $ do       dotOrmoluRelative <- makeRelativeToCurrentDirectory dotOrmoluFile       contents <- T.Utf8.readFile dotOrmoluFile       case parseDotOrmolu dotOrmoluRelative contents of@@ -58,8 +55,8 @@   x == ".ormolu"  -- | Cache ref that maps names of @.ormolu@ files to their contents.-cacheRef :: IORef (Map FilePath (FixityOverrides, ModuleReexports))-cacheRef = unsafePerformIO (newIORef Map.empty)+cacheRef :: Cache FilePath (FixityOverrides, ModuleReexports)+cacheRef = unsafePerformIO newCache {-# NOINLINE cacheRef #-}  -- | A wrapper around 'parseFixityDeclaration' for parsing individual fixity

@@ -3,11 +3,14 @@  module Ormolu.Utils.IO   ( findClosestFileSatisfying,-    withIORefCache,+    Cache,+    newCache,+    withCache,   ) where  import Control.Exception (catch, throwIO)+import Control.Monad (void) import Control.Monad.IO.Class import Data.IORef import Data.Map.Lazy (Map)@@ -48,14 +51,21 @@         then pure Nothing         else findClosestFileSatisfying isRightFile parentDir +newtype Cache k v = Cache (IORef (Map k v))++newCache :: (Ord k) => IO (Cache k v)+newCache = do+  var <- newIORef mempty+  pure (Cache var)+ -- | Execute an 'IO' action but only if the given key is not found in the--- 'IORef' cache.-withIORefCache :: (Ord k) => IORef (Map k v) -> k -> IO v -> IO v-withIORefCache cacheRef k action = do-  cache <- readIORef cacheRef+-- cache.+withCache :: (Ord k) => Cache k v -> k -> IO v -> IO v+withCache (Cache cacheVar) k action = do+  cache <- readIORef cacheVar   case M.lookup k cache of     Just v -> pure v     Nothing -> do       v <- action-      modifyIORef' cacheRef (M.insert k v)+      void $ atomicModifyIORef cacheVar (pure . M.insert k v)       pure v

@@ -36,7 +36,7 @@       mentioned `shouldBe` True       unPackageName ciPackageName `shouldBe` "fourmolu"       ciDynOpts `shouldBe` [DynOption "-XGHC2021"]-      Set.map unPackageName ciDependencies `shouldBe` Set.fromList ["Cabal-syntax", "Diff", "MemoTrie", "aeson", "ansi-terminal", "array", "base", "binary", "bytestring", "choice", "containers", "deepseq", "directory", "file-embed", "filepath", "ghc-lib-parser", "megaparsec", "mtl", "scientific", "syb", "text"]+      Set.map unPackageName ciDependencies `shouldBe` Set.fromList ["Cabal-syntax", "Diff", "MemoTrie", "aeson", "ansi-terminal", "array", "base", "binary", "bytestring", "choice", "containers", "directory", "file-embed", "filepath", "ghc-lib-parser", "megaparsec", "mtl", "scientific", "syb", "text"]       ciCabalFilePath `shouldSatisfy` isAbsolute       makeRelativeToCurrentDirectory ciCabalFilePath `shouldReturn` "fourmolu.cabal"     it "extracts correct cabal info from fourmolu.cabal for tests/Ormolu/PrinterSpec.hs" $ do

@@ -35,6 +35,18 @@         `shouldParse` ( exampleFixityOverrides,                         ModuleReexports Map.empty                       )+    it "accepts fractional operator precedences" $+      parseDotOrmolu+        ""+        ( T.unlines+            [ "infixr 3 >~<",+              "infixr 3.3 |~|",+              "infixr 3.7 <~>"+            ]+        )+        `shouldParse` ( fractionalFixityOverrides,+                        ModuleReexports Map.empty+                      )     it "combines conflicting fixity declarations correctly" $       parseDotOrmolu         ""@@ -228,6 +240,16 @@           ("=<<", FixityInfo InfixR 1),           (">>", FixityInfo InfixL 1),           (">>=", FixityInfo InfixL 1)+        ]+    )++fractionalFixityOverrides :: FixityOverrides+fractionalFixityOverrides =+  FixityOverrides+    ( Map.fromList+        [ (">~<", FixityInfo InfixR 3),+          ("|~|", FixityInfo InfixR 3.3),+          ("<~>", FixityInfo InfixR 3.7)         ]     ) 

@@ -37,7 +37,12 @@               InfixR,               InfixN             ]-        fiPrecedence <- chooseInt (0, 9)+        precedenceWholePart <- fromIntegral <$> chooseInt (0, 9)+        precedenceFractionalPart <-+          if precedenceWholePart < 9.0+            then (* 0.1) . fromIntegral <$> chooseInt (0, 1)+            else return 0+        let fiPrecedence = precedenceWholePart + precedenceFractionalPart         return FixityInfo {..}  instance Arbitrary ModuleReexports where

@@ -41,7 +41,10 @@   FixityOverrides     ( Map.fromList         [ (".=", FixityInfo InfixR 8),-          ("#", FixityInfo InfixR 5)+          ("#", FixityInfo InfixR 5),+          (">~<", FixityInfo InfixR 3),+          ("|~|", FixityInfo InfixR 3.3),+          ("<~>", FixityInfo InfixR 3.7)         ]     )