ormolu 0.7.7.0 → 0.8.0.0

raw patch · 68 files changed

+1256/−433 lines, 68 filesdep +unliftiodep −deepseqdep ~Cabal-syntaxdep ~ghc-lib-parserPVP ok

version bump matches the API change (PVP)

Dependencies added: unliftio

Dependencies removed: deepseq

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

API changes (from Hackage documentation)

Files

• CHANGELOG.md +28/−0
• CONTRIBUTING.md +8/−2
• README.md +7/−1
• app/Main.hs +26/−11
• data/examples/declaration/data/wildcard-binders-out.hs +1/−0
• data/examples/declaration/data/wildcard-binders.hs +1/−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-out.hs +5/−0
• data/examples/declaration/type/promotion-no-puns.hs +5/−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-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-out.hs +3/−0
• data/examples/declaration/value/function/infix/fractional-precedence.hs +3/−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-out.hs +10/−0
• data/examples/declaration/value/function/multiline-strings-1.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-out.hs +32/−0
• data/examples/declaration/value/function/multiline-strings-3.hs +32/−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-out.hs +26/−0
• data/examples/declaration/value/function/multiline-strings-5.hs +26/−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-out.hs +30/−0
• data/examples/declaration/value/function/multiline-strings-7.hs +30/−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-out.hs +36/−0
• data/examples/declaration/value/function/pattern/or-patterns.hs +33/−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-out.hs +2/−0
• data/examples/declaration/value/function/type-applications.hs +2/−0
• extract-hackage-info/hackage-info.bin binary
• ormolu.cabal +195/−180
• src/Ormolu/Diff/ParseResult.hs +40/−20
• 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 +68/−100
• src/Ormolu/Printer/Meat/Declaration/Value.hs-boot +0/−3
• src/Ormolu/Printer/Meat/Type.hs +44/−32
• 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,31 @@+## 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).+ ## Ormolu 0.7.7.0  * Use single-line layout for parens around single-line content. [Issue

@@ -40,7 +40,13 @@  ## Formatting -Use `nix run .#format` script to format Ormolu with the current version of-Ormolu. If Ormolu is not formatted like this, the CI will fail.+ - Use `nix run .#format` script to format Ormolu with the current version of+   Ormolu.++ - Additional formatters are configured via a pre-commit hook which is+   automatically installed when entering the Nix shell. You can also run it via+   `pre-commit run`/`pre-commit run -a`.++If Ormolu is not formatted like this, the CI will fail.  [issues]: https://github.com/tweag/ormolu/issues

@@ -184,10 +184,16 @@ 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.  As of Ormolu 0.7.0.0, `.ormolu` files can also contain instructions about module re-exports that Ormolu 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)@@ -33,17 +34,22 @@ 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 {..} <- execParser optsParserInfo+  -- We use this to guard writes to stdout in order to avoid+  -- garbled output from concurrent formatting processes.+  outputLock <- newMVar ()   let formatOne' =         formatOne           optConfigFileOpts           optMode           optSourceType           optConfig+          outputLock   exitCode <- case optInputFiles of     [] -> formatOne' Nothing     ["-"] -> formatOne' Nothing@@ -53,7 +59,8 @@             ExitSuccess -> Nothing             ExitFailure n -> Just n       errorCodes <--        mapMaybe selectFailure <$> mapM (formatOne' . Just) (sort xs)+        mapMaybe selectFailure+          <$> pooledMapConcurrently (formatOne' . Just) (sort xs)       return $         if null errorCodes           then ExitSuccess@@ -74,10 +81,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@@ -85,18 +94,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@@ -116,7 +127,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@@ -145,7 +158,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

@@ -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,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 -< ()+    )+    -<+      ()

@@ -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,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,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,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,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,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,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,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,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|]

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

binary file changed (989821 → 1002933 bytes)

@@ -1,199 +1,214 @@-cabal-version:      2.4-name:               ormolu-version:            0.7.7.0-license:            BSD-3-Clause-license-file:       LICENSE.md-maintainer:         Mark Karpov <mark.karpov@tweag.io>-tested-with:        ghc ==9.6.5 ghc ==9.8.2 ghc ==9.10.1-homepage:           https://github.com/tweag/ormolu-bug-reports:        https://github.com/tweag/ormolu/issues-synopsis:           A formatter for Haskell source code-description:        A formatter for Haskell source code.-category:           Development, Formatting-build-type:         Simple+cabal-version: 2.4+name: ormolu+version: 0.8.0.0+license: BSD-3-Clause+license-file: LICENSE.md+maintainer: Mark Karpov <mark.karpov@tweag.io>+tested-with:+  ghc ==9.8.4+  ghc ==9.10.1+  ghc ==9.12.1++homepage: https://github.com/tweag/ormolu+bug-reports: https://github.com/tweag/ormolu/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+  data/**/*.cabal+  data/**/*.hs+  data/**/*.txt+  extract-hackage-info/hackage-info.bin  extra-doc-files:-    CONTRIBUTING.md-    CHANGELOG.md-    DESIGN.md-    README.md+  CHANGELOG.md+  CONTRIBUTING.md+  DESIGN.md+  README.md  source-repository head-    type:     git-    location: https://github.com/tweag/ormolu.git+  type: git+  location: https://github.com/tweag/ormolu.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.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.IO--    hs-source-dirs:   src-    other-modules:    GHC.DynFlags-    default-language: GHC2021-    build-depends:-        Cabal-syntax >=3.12 && <3.13,-        Diff >=0.4 && <1,-        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--    if flag(dev)-        ghc-options:-            -Wall -Werror -Wredundant-constraints -Wpartial-fields-            -Wunused-packages+  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 -    else-        ghc-options: -O2 -Wall+  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, -    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 ormolu-    main-is:          Main.hs-    hs-source-dirs:   app-    other-modules:    Paths_ormolu-    autogen-modules:  Paths_ormolu-    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,-        ormolu,-        text >=2.1 && <3,-        th-env >=0.1.1 && <0.2+  main-is: Main.hs+  hs-source-dirs: app+  other-modules: Paths_ormolu+  autogen-modules: Paths_ormolu+  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,+    ormolu,+    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+  -- We use parallelism so we need a threaded runtime to get any+  -- benefit.+  ghc-options:+    -threaded+    -rtsopts+    -with-rtsopts=-N -    else-        ghc-options: -O2 -Wall -rtsopts+  if flag(dev)+    ghc-options:+      -Wall+      -Werror+      -Wredundant-constraints+      -Wpartial-fields+      -Wunused-packages+      -Wwarn=unused-packages+  else+    ghc-options:+      -O2+      -Wall  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--    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,-        ormolu,-        path >=0.6 && <0.10,-        path-io >=1.4.2 && <2,-        temporary ^>=1.3,-        text >=2.1 && <3+  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+  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,+    ormolu,+    path >=0.6 && <0.10,+    path-io >=1.4.2 && <2,+    temporary ^>=1.3,+    text >=2.1 && <3, -    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 RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} @@ -14,12 +15,14 @@ import Data.Foldable import Data.Function import Data.Generics+import GHC.Data.FastString (FastString) import GHC.Hs import GHC.Types.SourceText import GHC.Types.SrcLoc 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@@ -61,16 +64,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@@ -83,34 +78,59 @@           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` derivedTyClsParensEq                   `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` considerEqual @AnnSynDecl+                  -- 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` derivedTyClsParensEq+                  -- 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.

@@ -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 GHC.Data.FastString import GHC.Hs import GHC.Hs.ImpExp as GHC@@ -155,7 +156,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' _ ->@@ -207,15 +208,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 =

@@ -175,7 +175,11 @@ normalizeModule :: HsModule GhcPs -> HsModule GhcPs normalizeModule hsmod =   everywhere-    (mkT dropBlankTypeHaddocks `extT` dropBlankDataDeclHaddocks `extT` patchContext)+    ( mkT dropBlankTypeHaddocks+        `extT` dropBlankDataDeclHaddocks+        `extT` patchContext+        `extT` patchExprContext+    )     hsmod       { hsmodImports =           normalizeImports (hsmodImports hsmod),@@ -209,11 +213,18 @@         | 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 _ _))] -> [x]       [x@(L lx _)] -> [L lx (HsParTy noAnn 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  -- | Enable all language extensions that we think should be enabled by -- default for ease of use.@@ -253,7 +264,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_hsDocName,     p_sourceText,     p_namespaceSpec,+    p_arrow,   ) where @@ -33,6 +34,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 (SourceType (..)) import Ormolu.Printer.Combinators@@ -58,6 +60,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@@ -73,13 +79,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@@ -201,3 +207,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 _ -> txt "->"+  HsLinearArrow _ -> txt "%1 ->"+  HsExplicitMult _ mult -> do+    txt "%"+    p_mult mult+    space+    txt "->"

@@ -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

@@ -18,9 +18,8 @@ import Data.Choice qualified as Choice 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.Void-import GHC.Data.Strict qualified as Strict import GHC.Hs import GHC.Types.Fixity import GHC.Types.ForeignCall@@ -238,10 +237,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

@@ -169,7 +169,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 

@@ -93,7 +93,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

@@ -9,7 +9,6 @@     p_pat,     p_hsExpr,     p_hsUntypedSplice,-    p_stringLit,     IsApplicand (..),     p_hsExpr',     p_hsCmdTop,@@ -20,24 +19,19 @@  import Control.Monad import Data.Bool (bool)-import Data.Coerce (coerce) import Data.Data hiding (Infix, Prefix) import Data.Function (on) import Data.Functor ((<&>)) import Data.Generics.Schemes (everything)-import Data.List (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@@ -49,6 +43,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@@ -119,7 +114,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@@ -345,7 +341,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@@ -355,19 +351,19 @@         (HsHigherOrderApp, False) -> txt ">>-"       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@@ -421,8 +417,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@@ -430,7 +427,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)@@ -444,7 +441,6 @@           | otherwise = Normal     switchLayout [loc, l] $       placeHanging placement (located f (render N))-  ApplicativeStmt {} -> notImplemented "ApplicativeStmt" -- generated by renamer   BodyStmt _ body _ _ -> located body (render s)   LetStmt _ binds -> do     txt "let"@@ -490,8 +486,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 ->@@ -500,7 +497,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@@ -520,7 +517,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.@@ -528,7 +525,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@@ -537,8 +534,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@@ -560,12 +557,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@@ -607,8 +604,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@@ -619,6 +615,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@@ -672,11 +669,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@@ -772,25 +764,22 @@   RecordUpd {..} -> do     located rupd_expr p_hsExpr     breakpoint-    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     space@@ -825,7 +814,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@@ -853,11 +842,30 @@     txt "type"     space     located hswc_body p_hsType+  -- similar to HsForAllTy+  HsForAll _ tele e -> do+    p_hsForAllTelescope tele+    breakpoint+    located e p_hsExpr+  -- similar to HsQualTy+  HsQual _ qs e -> do+    located qs $ p_hsContext' p_hsExpr+    space+    txt "=>"+    breakpoint+    located e p_hsExpr+  -- similar to HsFunTy+  HsFunArr _ arrow x y -> do+    located x p_hsExpr+    space+    p_arrow (located' p_hsExpr) arrow+    breakpoint+    located y p_hsExpr  -- | 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@@ -874,10 +882,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 "|"@@ -1162,6 +1169,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 ->@@ -1172,7 +1181,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         breakpoint         let f = \case@@ -1279,12 +1288,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))@@ -1318,47 +1327,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 @@ -1399,7 +1367,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 

@@ -10,12 +10,14 @@   ( p_hsType,     hasDocStrings,     p_hsContext,+    p_hsContext',     p_hsTyVarBndr,     ForAllVisibility (..),     p_forallBndrs,     p_conDeclFields,     p_lhsTypeArg,     p_hsSigType,+    p_hsForAllTelescope,     hsOuterTyVarBndrsToHsType,     lhsTypeToSigType,   )@@ -30,7 +32,8 @@ 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 @@ -40,9 +43,7 @@ p_hsType' :: Bool -> HsType GhcPs -> R () p_hsType' multilineArgs = \case   HsForAllTy _ tele t -> do-    case tele of-      HsForAllInvis _ bndrs -> p_forallBndrs ForAllInvis p_hsTyVarBndr bndrs-      HsForAllVis _ bndrs -> p_forallBndrs ForAllVis p_hsTyVarBndr bndrs+    p_hsForAllTelescope tele     interArgBreak     located t p_hsType   HsQualTy _ qs t -> do@@ -89,14 +90,7 @@   HsFunTy _ arrow x y@(L _ y') -> do     located x p_hsType     space-    case arrow of-      HsUnrestrictedArrow _ -> txt "->"-      HsLinearArrow _ -> txt "%1 ->"-      HsExplicitMult _ mult -> do-        txt "%"-        p_hsTypeR (unLoc mult)-        space-        txt "->"+    p_arrow (located' p_hsTypeR) arrow     interArgBreak     case y' of       HsFunTy {} -> p_hsTypeR y'@@ -140,7 +134,7 @@   HsDocTy _ t str -> do     p_hsDoc Pipe (With #endNewline) str     located t p_hsType-  HsBangTy _ (HsSrcBang _ u s) t -> do+  HsBangTy _ (HsBang u s) t -> do     case u of       SrcUnpack -> txt "{-# UNPACK #-}" >> space       SrcNoUnpack -> txt "{-# NOUNPACK #-}" >> space@@ -163,11 +157,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,10 +199,13 @@   _ -> False  p_hsContext :: HsContext GhcPs -> R ()-p_hsContext = \case+p_hsContext = p_hsContext' p_hsType++p_hsContext' :: (HasLoc (Anno a)) => (a -> R ()) -> [XRec GhcPs a] -> R ()+p_hsContext' f = \case   [] -> txt "()"-  [x] -> located x p_hsType-  xs -> parens N $ sep commaDel (sitcc . located' p_hsType) xs+  [x] -> located x f+  xs -> parens N $ sep commaDel (sitcc . located' f) xs  class IsTyVarBndrFlag flag where   isInferred :: flag -> Bool@@ -226,18 +227,24 @@     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 $ do-      located l atom-      space-      txt "::"-      breakpoint-      inci (located 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 -> do+        space+        txt "::"+        breakpoint+        inci (located k p_hsType)+      HsBndrNoKind _ -> pure ()  data ForAllVisibility = ForAllInvis | ForAllVis @@ -289,6 +296,11 @@ p_hsSigType :: HsSigType GhcPs -> R () p_hsSigType HsSig {..} =   p_hsType $ hsOuterTyVarBndrsToHsType sig_bndrs sig_body++p_hsForAllTelescope :: HsForAllTelescope GhcPs -> R ()+p_hsForAllTelescope = \case+  HsForAllInvis _ bndrs -> p_forallBndrs ForAllInvis p_hsTyVarBndr bndrs+  HsForAllVis _ bndrs -> p_forallBndrs ForAllVis p_hsTyVarBndr bndrs  ---------------------------------------------------------------------------- -- 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.

@@ -13,7 +13,6 @@     separatedByBlank,     separatedByBlankNE,     onTheSameLine,-    matchAddEpAnn,     textToStringBuffer,     ghcModuleNameToCabal,   )@@ -138,13 +137,6 @@ onTheSameLine :: SrcSpan -> SrcSpan -> Bool onTheSameLine a b =   isOneLineSpan (mkSrcSpan (srcSpanEnd a) (srcSpanStart b))---- | 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)@@ -29,7 +28,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)@@ -101,8 +100,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'.@@ -118,7 +117,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) $@@ -190,17 +189,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` "ormolu"       ciDynOpts `shouldBe` [DynOption "-XGHC2021"]-      Set.map unPackageName ciDependencies `shouldBe` Set.fromList ["Cabal-syntax", "Diff", "MemoTrie", "ansi-terminal", "array", "base", "binary", "bytestring", "choice", "containers", "deepseq", "directory", "file-embed", "filepath", "ghc-lib-parser", "megaparsec", "mtl", "syb", "text"]+      Set.map unPackageName ciDependencies `shouldBe` Set.fromList ["Cabal-syntax", "Diff", "MemoTrie", "ansi-terminal", "array", "base", "binary", "bytestring", "choice", "containers", "directory", "file-embed", "filepath", "ghc-lib-parser", "megaparsec", "mtl", "syb", "text"]       ciCabalFilePath `shouldSatisfy` isAbsolute       makeRelativeToCurrentDirectory ciCabalFilePath `shouldReturn` "ormolu.cabal"     it "extracts correct cabal info from ormolu.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

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