Implement support for fractional precedence

Author: mrkkrp

CHANGELOG.md

@@ -2,6 +2,9 @@
 
 * 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).

README.md

@@ -184,10 +184,16 @@ infixl 1  >>, >>=
 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

data/examples/declaration/value/function/infix/fractional-precedence-out.hs

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

data/examples/declaration/value/function/infix/fractional-precedence.hs

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

extract-hackage-info/hackage-info.bin

@@ -32,6 +32,9 @@ 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)
@@ -96,10 +99,20 @@ data FixityInfo = FixityInfo
   { -- | Fixity direction
     fiDirection :: FixityDirection,
     -- | Precedence
-    fiPrecedence :: Int
+    fiPrecedence :: Double
   }
   deriving stock (Eq, Ord, Show, Generic)
-  deriving anyclass (Binary, NFData)
+  deriving anyclass (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
@@ -116,13 +129,25 @@ data FixityApproximation = FixityApproximation
     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)
+  deriving anyclass (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.

src/Ormolu/Fixity/Internal.hs

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

src/Ormolu/Fixity/Parser.hs

@@ -19,6 +19,7 @@ import Data.Text.Lazy qualified as TL
 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 @@ renderSingleFixityOverride (OpName operator, FixityInfo {..}) =
         InfixR -> "infixr"
         InfixN -> "infix",
       " ",
-      B.decimal fiPrecedence,
+      renderPrecedence fiPrecedence,
       " ",
       if isTickedOperator operator
         then "`" <> B.fromText operator <> "`"
@@ -75,3 +76,12 @@ renderSingleModuleReexport (exportingModule, exports) =
 
 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

src/Ormolu/Fixity/Printer.hs

@@ -35,6 +35,18 @@ spec = do
         `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
         ""
@@ -231,6 +243,16 @@ exampleFixityOverrides =
         ]
     )
 
+fractionalFixityOverrides :: FixityOverrides
+fractionalFixityOverrides =
+  FixityOverrides
+    ( Map.fromList
+        [ (">~<", FixityInfo InfixR 3),
+          ("|~|", FixityInfo InfixR 3.3),
+          ("<~>", FixityInfo InfixR 3.7)
+        ]
+    )
+
 exampleModuleReexports :: ModuleReexports
 exampleModuleReexports =
   ModuleReexports . Map.fromList $

tests/Ormolu/Fixity/ParserSpec.hs

@@ -37,7 +37,12 @@ instance Arbitrary FixityOverrides where
               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

tests/Ormolu/Fixity/PrinterSpec.hs

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