Implement new config flag UnknownOperatorHandling

data/30-tests-context-free.blt

@@ -1415,6 +1415,7 @@ foo =
 
 #test issue 176
 
+-- brittany { lconfig_unknownFixityHandling: UFHSafeIgnore }
 record :: Record
 record = Record
   { rProperties =

source/library/Language/Haskell/Brittany/Internal/Components/OpTree.hs

@@ -15,10 +15,13 @@ import           GHC.Types.Fixity               ( Fixity(Fixity)
 import           GHC.Types.SourceText           ( SourceText(NoSourceText) )
 import qualified Safe
 import qualified Data.Char
+import           Data.Data                      ( toConstr )
 
 import           Language.Haskell.Brittany.Internal.Components.BriDoc
 import           Language.Haskell.Brittany.Internal.Utils
 import           Language.Haskell.Brittany.Internal.Types
+import           Language.Haskell.Brittany.Internal.Config.Types
+                                                ( UnknownFixityHandling(..) )
 
 
 
@@ -35,7 +38,7 @@ displayOpTree = \case
          [ ("(" ++ showOp op ++ "," ++ displayOpTree x ++ ")") | (op, x) <- rs ]
     ++ "])"
     )
-  OpKnown p _ _ fixity tree ops ->
+  OpKnown p _ _ _ fixity tree ops ->
     (  "OpKnown "
     ++ show p
     ++ " "
@@ -84,45 +87,44 @@ data ReformatParenMode
 -- || (== a (+ b c)), /= (* d e) f
 -- || (== a (+ b c)) (/= (* d e) f)
 
-data StackElem = StackElem Fixity [(OpTree, BriDocNumbered)]
+data StackElem = StackElem (Bool, Fixity) [(OpTree, BriDocNumbered)]
 type Stack = [StackElem]
 
-balanceOpTree :: Bool -> OpTree -> ([BrittanyError], OpTree)
+balanceOpTree
-balanceOpTree allowUnqualify = \case
+  :: UnknownFixityHandling -> Bool -> OpTree -> ([BrittanyError], OpTree)
-  x@OpLeaf{} -> ([], x)
+balanceOpTree unknownFixityHandling allowUnqualify = outer
-  OpKnown paren locO locC fixity@(Fixity _ (-1) _) left rest ->
-    let
-        (warnsLeft, balancedLeft) = balanceOpTree allowUnqualify left
-        opRes =
-          [ (op, balanceOpTree allowUnqualify argTree) | (op, argTree) <- rest ]
-    in  ( warnsLeft ++ [ w | (_, (warns, _)) <- opRes, w <- warns ]
-        , OpKnown paren
-                  locO
-                  locC
-                  fixity
-                  balancedLeft
-                  [ (op, balanced) | (op, (_, balanced)) <- opRes ]
-        )
-  x@OpKnown{} -> ([], x)
-  x@(OpUnknown paren locO locC left rest) ->
-    let (warns, balancedLeft) = balanceOpTree allowUnqualify left
-    in  case go [] rest balancedLeft of
-          Right (leaf@OpLeaf{}) -> (warns, leaf)
-          Right (OpKnown _paren _ _ fixity c cs) ->
-            (warns, OpKnown paren locO locC fixity c cs)
-          Right t -> (warns, t)
-          Left moreWarns ->
-            ( (  warns
-              ++ [ LayoutWarning ("Fixity of operator not known: " ++ w)
-                 | w <- moreWarns
-                 ]
-              )
-            , x
-            )
  where
+  outer = \case
+    x@OpLeaf{} -> ([], x)
+    OpKnown paren allowT locO locC fixity@(Fixity _ (-1) _) left rest ->
+      let
+          (warnsLeft, balancedLeft) = outer left
+          opRes = [ (op, outer argTree) | (op, argTree) <- rest ]
+      in  ( warnsLeft ++ [ w | (_, (warns, _)) <- opRes, w <- warns ]
+          , OpKnown paren
+                    allowT
+                    locO
+                    locC
+                    fixity
+                    balancedLeft
+                    [ (op, balanced) | (op, (_, balanced)) <- opRes ]
+          )
+    x@OpKnown{} -> ([], x)
+    x@(OpUnknown paren locO locC left rest) ->
+      let (warns, balancedLeft) = outer left
+      in  case go [] rest balancedLeft of
+            Right (leaf@OpLeaf{}) -> (warns, leaf)
+            Right (OpKnown _paren allowT _ _ fixity c cs) ->
+              (warns, OpKnown paren allowT locO locC fixity c cs)
+            Right t         -> (warns, t)
+            Left  moreWarns -> ((warns ++ moreWarns), x)
   -- singleton :: BriDocNumbered -> StackElem
   -- singleton x = StackElem (Fixity NoSourceText 99 InfixN) (OpLeaf x) []
-  go :: Stack -> [(BriDocNumbered, OpTree)] -> OpTree -> Either [String] OpTree
+  go
+    :: Stack
+    -> [(BriDocNumbered, OpTree)]
+    -> OpTree
+    -> Either [BrittanyError] OpTree
   go [] [] _ = Left []
   go [StackElem fxty cs] [] c =
     let (e1, eops) = shiftOps cs c in Right (known fxty e1 eops)
@@ -135,8 +137,8 @@ balanceOpTree allowUnqualify = \case
       fxty <- docFixity opDoc
       go [StackElem fxty [(c, opDoc)]] inputR val
     (StackElem fixityS cs : stackR) -> do
-      let Fixity _ precS dirS = fixityS
+      let (_, Fixity _ precS dirS) = fixityS
-      fxty@(Fixity _ prec dir) <- docFixity opDoc
+      fxty@(_, Fixity _ prec dir) <- docFixity opDoc
       case compare prec precS of
         GT -> go (StackElem fxty [(c, opDoc)] : stack) inputR val
         LT -> do
@@ -148,14 +150,26 @@ balanceOpTree allowUnqualify = \case
           (InfixL, InfixL) ->
             go (StackElem fixityS ((c, opDoc) : cs) : stackR) inputR val
           _ -> Left []
-  docFixity :: BriDocNumbered -> Either [String] Fixity
+  docFixity :: BriDocNumbered -> Either [BrittanyError] (Bool, Fixity)
   docFixity (_, x) = case x of
     BDLit (Text.unpack -> s) -> case hardcodedFixity allowUnqualify s of
-      Just f  -> Right f
+      Just f  -> Right (True, f)
-      Nothing -> Left [s]
+      Nothing -> case unknownFixityHandling of
+        UFHSafeWarn -> Left
+          [LayoutWarning ("Fixity of operator not known: " ++ s)]
+        UFHSafeIgnore       -> Left []
+        UFHDefaultFixity    -> Right (False, defaultFixity)
+        UFHDangerousDefault -> Right (True, defaultFixity)
     BDFlushCommentsPrior _ d -> docFixity d
     BDQueueComments      _ d -> docFixity d
-    _                        -> Left []
+    _                        -> Left
+      [ ( LayoutWarning
+        $ "internal brittany warning: "
+          ++ "Unknown form of operator "
+          ++ show (toConstr x)
+          ++ "!"
+        )
+      ]
   shiftOps
     :: [(OpTree, BriDocNumbered)]
     -> OpTree
@@ -168,31 +182,29 @@ balanceOpTree allowUnqualify = \case
               mapAccumL (\op (nextE, nextOp) -> (nextOp, (op, nextE))) o1 rest
         in  list ++ [(finalOp, final)]
       )
-  known = OpKnown NoParen Nothing Nothing
+  known (allowT, fixity) = OpKnown NoParen allowT Nothing Nothing fixity
 
 addAllParens :: OpParenMode -> OpTree -> OpTree
 addAllParens topLevelParen = \case
-  x@OpLeaf{}    -> x
+  OpKnown _paren True locO locC fixity c cs ->
-  x@OpUnknown{} -> x
-  OpKnown _paren locO locC fixity c cs ->
     OpKnown topLevelParen
+            True
             locO
             locC
             fixity
             (addAllParens ParenWithSpace c)
             [ (op, addAllParens ParenWithSpace tree) | (op, tree) <- cs ]
+  x -> x
 
 remSuperfluousParens :: Int -> OpTree -> OpTree
 remSuperfluousParens outerFixity = \case
-  x@OpLeaf{} -> x
   OpUnknown _ locO locC c@(OpLeaf _ doc) [] | isLit doc ->
     OpUnknown NoParen locO locC c []
   OpUnknown _ locO locC c@(OpUnknown ParenWithSpace _ _ _ _) [] ->
     OpUnknown NoParen locO locC (remSuperfluousParens 11 c) []
   OpUnknown _ locO locC c@(OpUnknown ParenNoSpace _ _ _ _) [] ->
     OpUnknown NoParen locO locC (remSuperfluousParens 11 c) []
-  x@OpUnknown{} -> x
+  OpKnown paren True locO locC fixity c cs ->
-  OpKnown paren locO locC fixity c cs ->
     OpKnown
       -- We do not support removing superfluous parens around
       -- function types yet:
@@ -200,11 +212,13 @@ remSuperfluousParens outerFixity = \case
         then paren
         else NoParen
       )
+      True
       locO
       locC
       fixity
       (remSuperfluousParens (fixLevel fixity) c)
       [ (op, remSuperfluousParens (fixLevel fixity) tree) | (op, tree) <- cs ]
+  x -> x
  where
   fixLevel (Fixity _ i _) = i
   isLit = \case
@@ -455,3 +469,6 @@ hardcodedFixity allowUnqualify = \case
       $ dropWhile (\x -> (Data.Char.isAlpha x || x == '.')) str
     _ -> Nothing
   where fixity a b = Just (Fixity NoSourceText b a)
+
+defaultFixity :: Fixity
+defaultFixity = Fixity NoSourceText 9 InfixL

source/library/Language/Haskell/Brittany/Internal/Config/Config.hs

@@ -61,6 +61,7 @@ staticDefaultConfig = Config
     -- , _lconfig_allowSinglelineRecord     = coerce False
     , _lconfig_fixityAwareOps = coerce True
     , _lconfig_fixityAwareTypeOps = coerce False
+    , _lconfig_unknownFixityHandling = coerce UFHSafeWarn
     , _lconfig_fixityBasedAddAlignParens = coerce False
     , _lconfig_operatorParenthesisRefactorMode = coerce PRMKeep
     , _lconfig_operatorAllowUnqualify = coerce True
@@ -167,6 +168,7 @@ cmdlineConfigParser = do
       , _lconfig_allowSinglelineRecord     = mempty
       , _lconfig_fixityAwareOps = mempty
       , _lconfig_fixityAwareTypeOps = mempty
+      , _lconfig_unknownFixityHandling = mempty
       , _lconfig_fixityBasedAddAlignParens = mempty
       , _lconfig_operatorParenthesisRefactorMode = mempty
       , _lconfig_operatorAllowUnqualify = mempty

source/library/Language/Haskell/Brittany/Internal/Config/Types.hs

@@ -160,6 +160,7 @@ data CLayoutConfig f = LayoutConfig
   , _lconfig_fixityAwareTypeOps :: f (Last Bool)
     -- Same as above, but for type-level operators. Not yet implemented, but
     -- reserved for future use.
+  , _lconfig_unknownFixityHandling :: f (Last UnknownFixityHandling)
   , _lconfig_fixityBasedAddAlignParens :: f (Last Bool)
     -- Layouts multiple-line operator applications with parentheses if
     -- permitted by layout. Note how the arguments are properly aligned:
@@ -285,6 +286,33 @@ data CPPMode = CPPModeAbort  -- abort program on seeing -XCPP
                              -- file.)
   deriving (Show, Generic, Data)
 
+data UnknownFixityHandling
+  = UFHSafeWarn
+    -- ^ If there are operators with unknown fixitiy, then
+    --   1) all operators in this operator-expression will be treated as
+    --      having the same fixity
+    --   2) A warning will be emitted
+    --   3) No transformations (parenthesis normalisation) will be performed
+  | UFHSafeIgnore
+    -- ^ Same as UFHWarning, but without step 2)
+  | UFHDefaultFixity
+    -- ^ Any operators with unknown fixity will be assigned the default
+    --   fixity, InfixL 9, and fixity-aware layouting will proceed for this
+    --   operator-expression. However, non-whitespace transformations will
+    --   be disable to prevent changed semantics.
+  | UFHDangerousDefault
+    -- ^ Like UFHDefaultFixity this assigns default fixity InfixL 9 to unknown
+    --   operators, but it even allows non-whitespace transformations.
+    --   This is dangerous!
+    --   Consider that for an expression such as `a <+> (b ***** c)`, where
+    --   the fixity of the hypothetical operator `*****` is unknown, the
+    --   "remove redundant parentheses" mode would yield `a <+> b ***** c`.
+    --   However, if the true fixity is `infixl 2 *****` then this
+    --   transformation does not retain semantics which may or may not
+    --   lead to type-errors.
+    --   This is the same as UFHDefaultFixity iff ParenRefactorMode is PRMKeep.
+  deriving (Show, Generic, Data)
+
 data ExactPrintFallbackMode
   = ExactPrintFallbackModeNever  -- never fall back on exactprinting
   | ExactPrintFallbackModeInline -- fall back only if there are no newlines in

source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances1.hs

@@ -68,6 +68,13 @@ instance ToJSON CPPMode where
   toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany
   toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany
 
+instance FromJSON UnknownFixityHandling where
+  parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany
+
+instance ToJSON UnknownFixityHandling where
+  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany
+  toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany
+
 instance FromJSON ExactPrintFallbackMode where
   parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany
 

source/library/Language/Haskell/Brittany/Internal/ToBriDoc/OpTree.hs

@@ -154,11 +154,12 @@ gatherOpTreeT hasParen hasComms commWrap locOpen locClose opExprList = \case
 
 processOpTree :: (OpTree, Bool) -> ToBriDocM BriDocNumbered
 processOpTree (unknownTree, hasComments) = do
-  enabled          <- askLayoutConf _lconfig_fixityAwareOps
+  enabled               <- askLayoutConf _lconfig_fixityAwareOps
-  refactorMode     <- askLayoutConf _lconfig_operatorParenthesisRefactorMode
+  refactorMode <- askLayoutConf _lconfig_operatorParenthesisRefactorMode
-  allowOpUnqualify <- askLayoutConf _lconfig_operatorAllowUnqualify
+  allowOpUnqualify      <- askLayoutConf _lconfig_operatorAllowUnqualify
+  unknownFixityHandling <- askLayoutConf _lconfig_unknownFixityHandling
   let (warns, balancedTree) = if enabled
-        then balanceOpTree allowOpUnqualify unknownTree
+        then balanceOpTree unknownFixityHandling allowOpUnqualify unknownTree
         else ([], unknownTree)
   mTell warns
   let processedTree = case refactorMode of
@@ -182,7 +183,7 @@ layoutOpTree allowSinglelinePar = \case
                     sharedOps
                     sharedOps
                     docForceSingleline
-  OpKnown NoParen Nothing Nothing fixity treeL docOps
+  OpKnown NoParen _ Nothing Nothing fixity treeL docOps
     | Fixity _ (-1) _ <- fixity -> do
       dHead <- shareDoc $ layoutOpTree True treeL
       body  <- forM docOps $ \(op, arg) -> do
@@ -209,7 +210,7 @@ layoutOpTree allowSinglelinePar = \case
               ]
           | (prefix, doc) <- body
           ]
-  OpKnown hasParen locO locC fixity treeL docOps -> do
+  OpKnown hasParen _ locO locC fixity treeL docOps -> do
     let Fixity _ _prec _ = fixity
     let flattenList ops = case ops of
           []           -> pure []
@@ -224,7 +225,7 @@ layoutOpTree allowSinglelinePar = \case
             pure $ (pure op1, tree1Doc) : flattenRest
           _ -> simpleTransform ops
         flattenInner op = \case
-          OpKnown NoParen _ _ _ innerL innerOps | isPrec0 fixity -> do
+          OpKnown NoParen _ _ _ _ innerL innerOps | isPrec0 fixity -> do
             flattenList ((op, innerL) : innerOps)
           tree -> do
             treeDoc <- shareDoc $ layoutOpTree True tree

source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs

@@ -103,6 +103,7 @@ splitArrowType ltype@(L _ typ) = case typ of
     (headPart, restParts) <- splitArrowType inner
     pure
       ( OpKnown ParenWithSpace
+                False
                 (Just $ epaLocationRealSrcSpanStart spanOpen)
                 (Just $ epaLocationRealSrcSpanStart spanClose)
                 (Fixity NoSourceText (-1) InfixN)
@@ -169,6 +170,7 @@ layoutSplitArrowType (headPart, restParts) hasComments = do
   layouters <- mAsk
   let opTree =
         OpKnown NoParen
+                False
                 Nothing
                 Nothing
                 (Fixity NoSourceText (-1) InfixN)

source/library/Language/Haskell/Brittany/Internal/Types.hs

@@ -172,12 +172,13 @@ data OpTree
               (Maybe GHC.RealSrcLoc) -- paren close loc
               OpTree -- left operand
               [(BriDocNumbered, OpTree)] -- list of (next operand, symbol)
-  | OpKnown OpParenMode     -- with paren?
+  | OpKnown   OpParenMode     -- with paren?
+              Bool            -- allow non-whitespace transforms
               (Maybe GHC.RealSrcLoc) -- paren open loc
               (Maybe GHC.RealSrcLoc) -- paren close loc
-            GHC.Fixity   -- only Just after (successful!) lookup phase
+              GHC.Fixity   -- only Just after (successful!) lookup phase
-            OpTree
+              OpTree
-            [(BriDocNumbered, OpTree)]
+              [(BriDocNumbered, OpTree)]
   | OpLeaf Bool BriDocNumbered -- bool determines if parspacing is preferred
 
 data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted

source/test-suite/Main.hs

@@ -326,6 +326,7 @@ defaultTestConfig = Config
     , _lconfig_allowSinglelineRecord           = coerce False
     , _lconfig_fixityAwareOps                  = coerce True
     , _lconfig_fixityAwareTypeOps              = coerce True
+    , _lconfig_unknownFixityHandling           = coerce UFHSafeWarn
     , _lconfig_fixityBasedAddAlignParens       = coerce False
     , _lconfig_operatorParenthesisRefactorMode = coerce PRMKeep
     , _lconfig_operatorAllowUnqualify          = coerce True