hexagoxel
/
brittany
1
0
Fork 0
Code Issues 117 Pull Requests 5 Packages Projects Releases 5 Wiki Activity

Implement new config flag UnknownOperatorHandling

ghc92
Lennart Spitzner 2023-08-28 15:27:30 +02:00
parent dbc4266f18
commit 28e3ec18a3
9 changed files with 118 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
data/30-tests-context-free.blt
View File

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

112
source/library/Language/Haskell/Brittany/Internal/Components/OpTree.hs
View File

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

2
source/library/Language/Haskell/Brittany/Internal/Config/Config.hs
View File

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

28
source/library/Language/Haskell/Brittany/Internal/Config/Types.hs
View File

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

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

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

15
source/library/Language/Haskell/Brittany/Internal/ToBriDoc/OpTree.hs
View File

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

2
source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs
View File

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

9
source/library/Language/Haskell/Brittany/Internal/Types.hs
View File

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

1
source/test-suite/Main.hs
View File

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