From 28e3ec18a3ff3bdfce8e221e38a0f3fb465aa84a Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 28 Aug 2023 15:27:30 +0200 Subject: [PATCH] Implement new config flag UnknownOperatorHandling --- data/30-tests-context-free.blt | 1 + .../Brittany/Internal/Components/OpTree.hs | 112 ++++++++++-------- .../Brittany/Internal/Config/Config.hs | 2 + .../Haskell/Brittany/Internal/Config/Types.hs | 28 +++++ .../Internal/Config/Types/Instances1.hs | 7 ++ .../Brittany/Internal/ToBriDoc/OpTree.hs | 15 +-- .../Brittany/Internal/ToBriDoc/Type.hs | 2 + .../Haskell/Brittany/Internal/Types.hs | 9 +- source/test-suite/Main.hs | 1 + 9 files changed, 118 insertions(+), 59 deletions(-) diff --git a/data/30-tests-context-free.blt b/data/30-tests-context-free.blt index d0768d0..3f43822 100644 --- a/data/30-tests-context-free.blt +++ b/data/30-tests-context-free.blt @@ -1415,6 +1415,7 @@ foo = #test issue 176 +-- brittany { lconfig_unknownFixityHandling: UFHSafeIgnore } record :: Record record = Record { rProperties = diff --git a/source/library/Language/Haskell/Brittany/Internal/Components/OpTree.hs b/source/library/Language/Haskell/Brittany/Internal/Components/OpTree.hs index f68a434..9cd1edd 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Components/OpTree.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Components/OpTree.hs @@ -19,6 +19,8 @@ import qualified Data.Char 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 +37,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 +86,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 allowUnqualify = \case - x@OpLeaf{} -> ([], x) - 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 - ) +balanceOpTree + :: UnknownFixityHandling -> Bool -> OpTree -> ([BrittanyError], OpTree) +balanceOpTree unknownFixityHandling allowUnqualify = outer 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 +136,8 @@ balanceOpTree allowUnqualify = \case fxty <- docFixity opDoc go [StackElem fxty [(c, opDoc)]] inputR val (StackElem fixityS cs : stackR) -> do - let Fixity _ precS dirS = fixityS - fxty@(Fixity _ prec dir) <- docFixity opDoc + let (_, Fixity _ precS dirS) = fixityS + fxty@(_, Fixity _ prec dir) <- docFixity opDoc case compare prec precS of GT -> go (StackElem fxty [(c, opDoc)] : stack) inputR val LT -> do @@ -148,14 +149,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 - Nothing -> Left [s] + Just f -> Right (True, f) + 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 +181,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 - x@OpUnknown{} -> x - OpKnown _paren locO locC fixity c cs -> + OpKnown _paren True 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 locO locC fixity c cs -> + OpKnown paren True locO locC fixity c cs -> OpKnown -- We do not support removing superfluous parens around -- function types yet: @@ -200,11 +211,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 +468,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 diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Config.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Config.hs index 03b95cf..4981de5 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Config.hs +++ b/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 diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs index 4ed4735..ec09557 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/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 diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances1.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances1.hs index 253bc5f..d99c048 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances1.hs +++ b/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 diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/OpTree.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/OpTree.hs index 8676594..4a94cf7 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/OpTree.hs +++ b/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 - refactorMode <- askLayoutConf _lconfig_operatorParenthesisRefactorMode - allowOpUnqualify <- askLayoutConf _lconfig_operatorAllowUnqualify + enabled <- askLayoutConf _lconfig_fixityAwareOps + refactorMode <- askLayoutConf _lconfig_operatorParenthesisRefactorMode + 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 diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs index bcd0688..678c462 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs +++ b/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) diff --git a/source/library/Language/Haskell/Brittany/Internal/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Types.hs index 4c2cea0..faa0112 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Types.hs +++ b/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 - OpTree - [(BriDocNumbered, OpTree)] + GHC.Fixity -- only Just after (successful!) lookup phase + OpTree + [(BriDocNumbered, OpTree)] | OpLeaf Bool BriDocNumbered -- bool determines if parspacing is preferred data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs index 19c9d1c..6f06f31 100644 --- a/source/test-suite/Main.hs +++ b/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