Format based on operator fixity (#741)

* Format based on operator fixity * Format
mihaimaruseac · May 9, 2023 · a5d5e87 · a5d5e87
1 parent 5a268e0
commit a5d5e87
Show file tree

Hide file tree

Showing 20 changed files with 589 additions and 488 deletions.
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -15,6 +15,7 @@
 - HIndent now assumes no extensions are enabled by default ([#728]).
 - All modules except for `HIndent` are now private, and the minimum necessary definitions are exposed from the module ([#729]).
 - HIndent now prints all `do` expressions in a unified style  ([#739]).
+- HIndent now formats operators based on their fixities ([#741]).
 
 ### Fixed
 
@@ -350,6 +351,7 @@ This version is accidentally pushlished, and is the same as 5.3.3.
 [@uhbif19]: https://github.com/uhbif19
 [@toku-sa-n]: https://github.com/toku-sa-n
 
+[#741]: https://github.com/mihaimaruseac/hindent/pull/741
 [#739]: https://github.com/mihaimaruseac/hindent/pull/739
 [#731]: https://github.com/mihaimaruseac/hindent/pull/731
 [#729]: https://github.com/mihaimaruseac/hindent/pull/729

diff --git a/TESTS.md b/TESTS.md
@@ -1012,8 +1012,10 @@ f
 
 ```haskell
 foo =
-  if fooooooo ||
-     baaaaaaaaaaaaaaaaaaaaa || apsdgiuhasdpfgiuahdfpgiuah || bazzzzzzzzzzzzz
+  if fooooooo
+       || baaaaaaaaaaaaaaaaaaaaa
+       || apsdgiuhasdpfgiuahdfpgiuah
+       || bazzzzzzzzzzzzz
     then a
     else b
 ```
@@ -2498,8 +2500,8 @@ With operators
 
 ```haskell
 defaultExtensions =
-  [e | e@EnableExtension {} <- knownExtensions] \\
-  map EnableExtension badExtensions
+  [e | e@EnableExtension {} <- knownExtensions]
+    \\ map EnableExtension badExtensions
 ```
 
 Transform list comprehensions
@@ -2541,24 +2543,6 @@ fun xs ys =
 
 ### Operators
 
-Bad
-
-```haskell
-x =
-  Value <$> thing <*> secondThing <*> thirdThing <*> fourthThing <*>
-  Just thisissolong <*>
-  Just stilllonger <*>
-  evenlonger
-```
-
-Good
-
-```haskell pending
-x =
-  Value <$> thing <*> secondThing <*> thirdThing <*> fourthThing <*>
-  Just thisissolong <*> Just stilllonger <*> evenlonger
-```
-
 With `do`
 
 ```haskell
@@ -2576,14 +2560,6 @@ a =
     Left x -> x
 ```
 
-`$` chain
-
-```haskell
-f =
-  Right $
-  S.lazyByteStrings $ addPrefix prefix $ S.toLazyByteString $ prettyPrint m
-```
-
 Qualified operator as an argument
 
 ```haskell
@@ -2639,12 +2615,48 @@ Force indent and print RHS in a top-level expression
 ```haskell
 -- https://github.com/mihaimaruseac/hindent/issues/473
 a =
-  template $
-  haskell
-    [ SomeVeryLongName
-    , AnotherLongNameEvenLongToBreakTheLine
-    , LastLongNameInList
-    ]
+  template
+    $ haskell
+        [ SomeVeryLongName
+        , AnotherLongNameEvenLongToBreakTheLine
+        , LastLongNameInList
+        ]
+```
+
+#### Operator chains
+
+Applicative style
+
+```haskell
+x =
+  Value
+    <$> thing
+    <*> secondThing
+    <*> thirdThing
+    <*> fourthThing
+    <*> Just thisissolong
+    <*> Just stilllonger
+    <*> evenlonger
+```
+
+`$` chain
+
+```haskell
+f =
+  Right
+    $ S.lazyByteStrings
+    $ addPrefix prefix
+    $ S.toLazyByteString
+    $ prettyPrint m
+```
+
+Arithmetic operations
+
+```haskell
+f =
+  aaaaaaaaaa * bbbbbbbbbbbbbb / cccccccccccccccccccccc
+    + dddddddddddddd * eeeeeeeeeeeeeeee
+    - ffffffffffffffff / -ggggggggggggg
 ```
 
 ### Primitive type values
@@ -3033,17 +3045,21 @@ bob -- after bob
        Just -- after Just
         -> do
          justice -- after justice
-          *
-           foo
-             (blah * blah + z + 2 / 4 + a - -- before a line break
-              2 * -- inside this mess
-              z /
-              2 /
-              2 /
-              aooooo /
-              aaaaa -- bob comment
-              ) +
-           (sdfsdfsd fsdfsdf) -- blah comment
+           * foo
+               (blah * blah
+                  + z
+                  + 2 / 4
+                  + a
+                  - -- before a line break
+                   2
+                     * -- inside this mess
+                      z
+                     / 2
+                     / 2
+                     / aooooo
+                     / aaaaa -- bob comment
+                )
+           + (sdfsdfsd fsdfsdf) -- blah comment
          putStrLn "")
     [1, 2, 3]
     [ 1 -- foo
@@ -3186,17 +3202,21 @@ bob {- after bob -}
        Just {- after Just -}
         -> do
          justice {- after justice -}
-          *
-           foo
-             (blah * blah + z + 2 / 4 + a - {- before a line break -}
-              2 * {- inside this mess -}
-              z /
-              2 /
-              2 /
-              aooooo /
-              aaaaa {- bob comment -}
-              ) +
-           (sdfsdfsd fsdfsdf) {- blah comment -}
+           * foo
+               (blah * blah
+                  + z
+                  + 2 / 4
+                  + a
+                  - {- before a line break -}
+                   2
+                     * {- inside this mess -}
+                      z
+                     / 2
+                     / 2
+                     / aooooo
+                     / aaaaa {- bob comment -}
+                )
+           + (sdfsdfsd fsdfsdf) {- blah comment -}
          putStrLn "")
     [1, 2, 3]
     [ 1 {- foo -}
@@ -3418,4 +3438,4 @@ Code with `>`s
 > -- https://github.com/mihaimaruseac/hindent/issues/103
 > foo :: a
 > foo = undefined
-```
+```
diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs
@@ -31,10 +31,10 @@ toCriterion = go
         then bench
                (UTF8.toString desc)
                (nf
-                  (either (error . show) id .
-                   reformat HIndent.defaultConfig [] Nothing)
-                  code) :
-             go next
+                  (either (error . show) id
+                     . reformat HIndent.defaultConfig [] Nothing)
+                  code)
+               : go next
         else go next
     go (PlainText {}:next) = go next
     go (CodeFence {}:next) = go next

diff --git a/internal/HIndent/Internal/Test/Markdone.hs b/internal/HIndent/Internal/Test/Markdone.hs
@@ -65,14 +65,14 @@ tokenize input =
         Normal ->
           if S8.isPrefixOf "#" line
             then let (hashes, title) = S8.span (== '#') line
-                  in return $
-                     Heading (S8.length hashes) (S8.dropWhile isSpace title)
+                  in return
+                       $ Heading (S8.length hashes) (S8.dropWhile isSpace title)
             else if S8.isPrefixOf "```" line
                    then do
                      put Fenced
-                     return $
-                       BeginFence
-                         (S8.dropWhile (\c -> c == '`' || c == ' ') line)
+                     return
+                       $ BeginFence
+                           (S8.dropWhile (\c -> c == '`' || c == ' ') line)
                    else return $ PlainLine line
         Fenced ->
           if line == "```"

diff --git a/src/HIndent.hs b/src/HIndent.hs
@@ -65,43 +65,45 @@ hindent :: [String] -> IO ()
 hindent args = do
   config <- getConfig
   runMode <-
-    handleParseResult $
-    execParserPure
-      defaultPrefs
-      (info
-         (options config <**> helper)
-         (header "hindent - Reformat Haskell source code"))
-      args
+    handleParseResult
+      $ execParserPure
+          defaultPrefs
+          (info
+             (options config <**> helper)
+             (header "hindent - Reformat Haskell source code"))
+          args
   case runMode of
     ShowVersion -> putStrLn ("hindent " ++ showVersion version)
     Run style exts action paths ->
       if null paths
         then S8.interact
-               (either (error . prettyParseError) id .
-                reformat style exts Nothing)
+               (either (error . prettyParseError) id
+                  . reformat style exts Nothing)
         else forM_ paths $ \filepath -> do
                cabalexts <- getCabalExtensionsForSourcePath filepath
                text <- S.readFile filepath
                case reformat style (cabalexts ++ exts) (Just filepath) text of
                  Left e -> error $ prettyParseError e
                  Right out ->
-                   unless (text == out) $
-                   case action of
-                     Validate -> do
-                       IO.putStrLn $ filepath ++ " is not formatted"
-                       exitWith (ExitFailure 1)
-                     Reformat -> do
-                       tmpDir <- IO.getTemporaryDirectory
-                       (fp, h) <- IO.openTempFile tmpDir "hindent.hs"
-                       S8.hPutStr h out
-                       IO.hFlush h
-                       IO.hClose h
-                       let exdev e =
-                             if ioe_errno e == Just ((\(Errno a) -> a) eXDEV)
-                               then IO.copyFile fp filepath >> IO.removeFile fp
-                               else throw e
-                       IO.copyPermissions filepath fp
-                       IO.renameFile fp filepath `catch` exdev
+                   unless (text == out)
+                     $ case action of
+                         Validate -> do
+                           IO.putStrLn $ filepath ++ " is not formatted"
+                           exitWith (ExitFailure 1)
+                         Reformat -> do
+                           tmpDir <- IO.getTemporaryDirectory
+                           (fp, h) <- IO.openTempFile tmpDir "hindent.hs"
+                           S8.hPutStr h out
+                           IO.hFlush h
+                           IO.hClose h
+                           let exdev e =
+                                 if ioe_errno e
+                                      == Just ((\(Errno a) -> a) eXDEV)
+                                   then IO.copyFile fp filepath
+                                          >> IO.removeFile fp
+                                   else throw e
+                           IO.copyPermissions filepath fp
+                           IO.renameFile fp filepath `catch` exdev
 
 -- | Format the given source.
 reformat ::
@@ -124,17 +126,19 @@ reformat config mexts mfilepath rawCode =
           code = unlines' (map (stripPrefix prefix) ls)
        in case parseModule mfilepath allExts (UTF8.toString code) of
             POk _ m ->
-              Right $
-              addPrefix prefix $
-              L.toStrict $ S.toLazyByteString $ prettyPrint config m
+              Right
+                $ addPrefix prefix
+                $ L.toStrict
+                $ S.toLazyByteString
+                $ prettyPrint config m
             PFailed st ->
               let rawErrLoc = psRealLoc $ loc st
-               in Left $
-                  ParseError
-                    { errorLine = srcLocLine rawErrLoc + yPos
-                    , errorCol = srcLocCol rawErrLoc
-                    , errorFile = fromMaybe "<interactive>" mfilepath
-                    }
+               in Left
+                    $ ParseError
+                        { errorLine = srcLocLine rawErrLoc + yPos
+                        , errorCol = srcLocCol rawErrLoc
+                        , errorFile = fromMaybe "<interactive>" mfilepath
+                        }
     preserveTrailingNewline f x
       | S8.null x || S8.all isSpace x = return mempty
       | hasTrailingLine x || configTrailingNewline config =
@@ -146,9 +150,9 @@ reformat config mexts mfilepath rawCode =
           (f x)
       | otherwise = f x
     allExts =
-      CE.uniqueExtensions $
-      concatMap (\x -> x : extensionImplies x) $
-      mexts ++ configExtensions config ++ allExtsFromCode
+      CE.uniqueExtensions
+        $ concatMap (\x -> x : extensionImplies x)
+        $ mexts ++ configExtensions config ++ allExtsFromCode
     allExtsFromCode = concatMap f codeBlocks
       where
         f (HaskellSource _ text) =
@@ -162,13 +166,15 @@ testAst x =
   case parseModule Nothing exts (UTF8.toString x) of
     POk _ m -> Right $ modifyASTForPrettyPrinting m
     PFailed st ->
-      Left $
-      ParseError <$> srcLocLine <*> srcLocCol <*> pure "<interactive>" $
-      psRealLoc $ loc st
+      Left
+        $ ParseError <$> srcLocLine <*> srcLocCol <*> pure "<interactive>"
+        $ psRealLoc
+        $ loc st
   where
     exts =
-      CE.uniqueExtensions $
-      collectLanguageExtensionsFromSource $ UTF8.toString x
+      CE.uniqueExtensions
+        $ collectLanguageExtensionsFromSource
+        $ UTF8.toString x
 
 -- | Print the module.
 prettyPrint :: Config -> HsModule' -> Builder
@@ -178,8 +184,8 @@ prettyPrint config m =
 -- | Pretty print the given printable thing.
 runPrinterStyle :: Config -> Printer () -> Builder
 runPrinterStyle config m =
-  maybe (error "Printer failed with mzero call.") psOutput $
-  execStateT (runPrinter m) initState
+  maybe (error "Printer failed with mzero call.") psOutput
+    $ execStateT (runPrinter m) initState
   where
     initState =
       PrintState