diff --git a/brittany.cabal b/brittany.cabal index 23f0efa..c16e1be 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -129,6 +129,7 @@ library Language.Haskell.Brittany.Internal.ToBriDoc.DataDecl Language.Haskell.Brittany.Internal.ToBriDoc.Decl Language.Haskell.Brittany.Internal.ToBriDoc.Expr + Language.Haskell.Brittany.Internal.ToBriDoc.OpTree Language.Haskell.Brittany.Internal.ToBriDoc.IE Language.Haskell.Brittany.Internal.ToBriDoc.Import Language.Haskell.Brittany.Internal.ToBriDoc.Module @@ -137,6 +138,7 @@ library Language.Haskell.Brittany.Internal.ToBriDoc.Type Language.Haskell.Brittany.Internal.Components.BriDoc Language.Haskell.Brittany.Internal.Components.Obfuscation + Language.Haskell.Brittany.Internal.Components.OpTree Language.Haskell.Brittany.Internal.S1_Parsing Language.Haskell.Brittany.Internal.S2_SplitModule Language.Haskell.Brittany.Internal.S3_ToBriDocTools diff --git a/data/10-structured/op-precedence.blt b/data/10-structured/op-precedence.blt new file mode 100644 index 0000000..3b3ec38 --- /dev/null +++ b/data/10-structured/op-precedence.blt @@ -0,0 +1,232 @@ +#group expression/op-precedence + + + +#test basic precedence-aware layouting +operatorExpr1 = + ( foo1 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr1 + + foo2 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr2 + + foo3 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr3 + + foo4 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr4 + + foo5 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr5 + + foo6 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr6 + + foo7 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr7 + + foo8 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr8 + + foo9 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr9 + ) + +#test nested different precedences +operatorExpr2 = + ( foo1 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr1 + + foo2 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr2 + + foo3 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr3 + + foo4 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr4 + == foo5 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr5 + + foo6 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr6 + + foo7 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr7 + + foo8 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr8 + + foo9 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr9 + ) + +#test simple comment respecting +alternatives = -- a + ( -- b + alternativeOne -- c + <|> alterantiveTwo -- d + <|> alternativeThree -- e + ) -- f + +#golden retaining comments while minimizing duplicated parens +#pending +-- brittany { lconfig_operatorParenthesisRefactorMode: PRMMinimize } +alternatives = -- a + x + + ( -- b + ( -- c + alternativeOne -- c + <|> alterantiveTwo -- d + <|> alternativeThree -- e + ) -- f + ) -- g +#expected +-- brittany { lconfig_operatorParenthesisRefactorMode: PRMMinimize } +alternatives = -- a + x + + -- b + ( -- c + alternativeOne -- c + <|> alterantiveTwo -- d + <|> alternativeThree -- e + ) -- f -- g + +#golden refactoring unnecessary parens basic example +-- brittany { lconfig_operatorParenthesisRefactorMode: PRMMinimize } +operatorExpr1 = + ( (goo1 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr1) + + goo2 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr2 + + goo3 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr3 + + goo4 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr4 + ) +#expected +-- brittany { lconfig_operatorParenthesisRefactorMode: PRMMinimize } +operatorExpr1 = + ( goo1 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr1 + + goo2 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr2 + + goo3 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr3 + + goo4 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr4 + ) + +#test feature flag fixityAwareOps works +-- brittany { lconfig_fixityAwareOps: False } +operatorExpr1 = + ( goo1 + * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr1 + + goo2 + * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr2 + + goo3 + * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr3 + + goo4 + * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr4 + + goo5 + * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr5 + + goo6 + * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr6 + + goo7 + * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr7 + + goo8 + * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr8 + + goo9 + * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr9 + ) + +#golden op-app simple golden test +operatorExpr1 = + ( goo1 + * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr1 + + goo2 + * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr2 + + goo3 + * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr3 + + goo4 + * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr4 + + goo5 + * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr5 + + goo6 + * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr6 + + goo7 + * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr7 + + goo8 + * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr8 + + goo9 + * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr9 + ) +#expected +operatorExpr1 = + ( goo1 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr1 + + goo2 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr2 + + goo3 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr3 + + goo4 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr4 + + goo5 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr5 + + goo6 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr6 + + goo7 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr7 + + goo8 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr8 + + goo9 * barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr9 + ) + +#golden op-app mixed golden +doop = + some long invocation == + loooooooooongman + (third nested expression) + - 4 && {- meow -} 5 + - 6 + > 7 + `mod` loooooooooongwoman || ill just invoke a function with these args + || foo && dooasdoiaosdoi ** oaisdoioasido <= asduiuaisduiasdu + asdahjsd + ahsjdhjhasd +#expected +doop = + some long invocation == loooooooooongman + (third nested expression) - 4 + && {- meow -} 5 - 6 > 7 `mod` loooooooooongwoman + || ill just invoke a function with these args + || foo + && dooasdoiaosdoi ** oaisdoioasido + <= asduiuaisduiasdu + asdahjsd + ahsjdhjhasd + +#golden op-app mixed golden with added parens +-- brittany { lconfig_fixityBasedAddAlignParens: True } +doop = + some long invocation == + loooooooooongman + (third nested expression) + - 4 && {- meow -} 5 + - 6 + > 7 + `mod` loooooooooongwoman || ill just invoke a function with these args + || foo && dooasdoiaosdoi ** oaisdoioasido <= asduiuaisduiasdu + asdahjsd + ahsjdhjhasd +#expected +-- brittany { lconfig_fixityBasedAddAlignParens: True } +doop = + ( some long invocation == loooooooooongman + (third nested expression) - 4 + && {- meow -} 5 - 6 > 7 `mod` loooooooooongwoman + || ill just invoke a function with these args + || ( foo + && dooasdoiaosdoi ** oaisdoioasido + <= asduiuaisduiasdu + asdahjsd + ahsjdhjhasd + ) + ) + +#golden multiline mixed op expression 1 +-- brittany { lconfig_fixityBasedAddAlignParens: True } +meow = + [docSeparator, docForceSL od1, docSeparator, docForceSL ed1] + ++ join + [ [docSeparator, docForceSingleline od, docSeparator, docForceSingleline ed] + | (od, ed) <- ems + ] + ++ [docSeparator, docForceSingleline odN, docSeparator, lastWrap edN] +#expected +-- brittany { lconfig_fixityBasedAddAlignParens: True } +meow = + ( [docSeparator, docForceSL od1, docSeparator, docForceSL ed1] + ++ join + [ [ docSeparator + , docForceSingleline od + , docSeparator + , docForceSingleline ed + ] + | (od, ed) <- ems + ] + ++ [docSeparator, docForceSingleline odN, docSeparator, lastWrap edN] + ) + +#golden multiline mixed op expression 2 +-- brittany { lconfig_fixityBasedAddAlignParens: True } +meow = + [docSeparator, docForceSingleline od1, docSeparator, docForceSingleline ed1, something] + ++ join + [ [docSeparator, docForceSingleline od, docSeparator, docForceSingleline ed] + | (od, ed) <- ems + ] + ++ [docSeparator, docForceSingleline odN, docSeparator, lastWrap edN, something] +#expected +-- brittany { lconfig_fixityBasedAddAlignParens: True } +meow = + ( [ docSeparator + , docForceSingleline od1 + , docSeparator + , docForceSingleline ed1 + , something + ] + ++ join + [ [ docSeparator + , docForceSingleline od + , docSeparator + , docForceSingleline ed + ] + | (od, ed) <- ems + ] + ++ [ docSeparator + , docForceSingleline odN + , docSeparator + , lastWrap edN + , something + ] + ) diff --git a/data/15-regressions.blt b/data/15-regressions.blt index e1ca647..7112f36 100644 --- a/data/15-regressions.blt +++ b/data/15-regressions.blt @@ -161,10 +161,8 @@ readMergePersConfig path shouldCreate conf = do fileConf <- case Data.Yaml.decodeEither contents of Left e -> do liftIO - $ putStrErrLn - $ "error reading in brittany config from " - ++ path - ++ ":" + $ putStrErrLn + $ "error reading in brittany config from " ++ path ++ ":" liftIO $ putStrErrLn e mzero Right x -> return x diff --git a/data/30-tests-context-free.blt b/data/30-tests-context-free.blt index f71287b..9751027 100644 --- a/data/30-tests-context-free.blt +++ b/data/30-tests-context-free.blt @@ -1032,7 +1032,7 @@ func #test some indentation thingy func = - (lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj + ( lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj $ abc $ def $ ghi @@ -1100,9 +1100,7 @@ readMergePersConfig path shouldCreate conf = do Left e -> do liftIO $ putStrErrLn - $ "error reading in brittany config from " - ++ path - ++ ":" + $ "error reading in brittany config from " ++ path ++ ":" liftIO $ putStrErrLn e mzero Right x -> return x diff --git a/source/library/Language/Haskell/Brittany/Internal.hs b/source/library/Language/Haskell/Brittany/Internal.hs index 5ccfcdb..b07e16e 100644 --- a/source/library/Language/Haskell/Brittany/Internal.hs +++ b/source/library/Language/Haskell/Brittany/Internal.hs @@ -55,9 +55,9 @@ parsePrintModule traceFunc configWithDebugs inputText = runExceptT $ do configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } let ghcOptions = config & _conf_forward & _options_ghc & runIdentity let config_pp = config & _conf_preprocessor - let cppMode = config_pp & _ppconf_CPPMode & confUnpack @CPPMode + let cppMode = config_pp & _ppconf_CPPMode & confUnpack let hackAroundIncludes = - config_pp & _ppconf_hackAroundIncludes & confUnpack @Bool + config_pp & _ppconf_hackAroundIncludes & confUnpack (parsedSource, hasCPP) <- do let hackF s = if "#include" `isPrefixOf` s then "-- BRITANY_INCLUDE_HACK " ++ s @@ -84,7 +84,7 @@ parsePrintModule traceFunc configWithDebugs inputText = runExceptT $ do $ extractCommentConfigs (useTraceFunc traceFunc) parsedSource let moduleConfig = cZipWith fromOptionIdentity config inlineConf let disableFormatting = - moduleConfig & _conf_disable_formatting & confUnpack @Bool + moduleConfig & _conf_disable_formatting & confUnpack if disableFormatting then do return inputText diff --git a/source/library/Language/Haskell/Brittany/Internal/Components/BriDoc.hs b/source/library/Language/Haskell/Brittany/Internal/Components/BriDoc.hs index 4397484..03e3ba9 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Components/BriDoc.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Components/BriDoc.hs @@ -87,11 +87,7 @@ data BriDocW (w :: IsWrapped) -- the following constructors are only relevant for the alt transformation -- and are removed afterwards. They should never occur in any (BriDocRec w) -- after the alt transformation. - | BDForceMultiline (BriDocRec w) - | BDForceSingleline (BriDocRec w) - | BDNonBottomSpacing Bool (BriDocRec w) - | BDSetParSpacing (BriDocRec w) - | BDForceParSpacing (BriDocRec w) + | BDForceAlt ForceAlt (BriDocRec w) -- pseudo-deprecated | BDDebug String (BriDocRec w) @@ -102,8 +98,19 @@ type BriDoc = BriDocW 'Unwrapped type BriDocWrapped = BriDocW 'Wrapped type BriDocNumbered = (Int, BriDocWrapped) +data ForceAlt + = ForceMultiline + | ForceSingleline + | NonBottomSpacing Bool + | SetParSpacing + | ForceParSpacing + | ForceZeroAdd + deriving (Eq, Ord, Data.Data.Data, Show) + + data BrIndent = BrIndentNone | BrIndentRegular + | BrIndentRegularForce | BrIndentSpecial Int deriving (Eq, Ord, Data.Data.Data, Show) @@ -131,11 +138,7 @@ instance Uniplate.Uniplate BriDoc where uniplate (BDEntryDelta dp bd ) = plate BDEntryDelta |- dp |* bd uniplate (BDLines lines ) = plate BDLines ||* lines uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd - uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd - uniplate (BDForceSingleline bd ) = plate BDForceSingleline |* bd - uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd - uniplate (BDSetParSpacing bd ) = plate BDSetParSpacing |* bd - uniplate (BDForceParSpacing bd ) = plate BDForceParSpacing |* bd + uniplate (BDForceAlt forceFlag bd) = plate BDForceAlt |- forceFlag |* bd uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd -- this might not work. is not used anywhere either. @@ -161,11 +164,7 @@ briDocSeqSpine = \case BDEntryDelta _dp bd -> briDocSeqSpine bd BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines BDEnsureIndent _ind bd -> briDocSeqSpine bd - BDForceMultiline bd -> briDocSeqSpine bd - BDForceSingleline bd -> briDocSeqSpine bd - BDNonBottomSpacing _ bd -> briDocSeqSpine bd - BDSetParSpacing bd -> briDocSeqSpine bd - BDForceParSpacing bd -> briDocSeqSpine bd + BDForceAlt _ bd -> briDocSeqSpine bd BDDebug _s bd -> briDocSeqSpine bd briDocForceSpine :: BriDoc -> BriDoc @@ -198,11 +197,7 @@ unwrapBriDocNumbered tpl = case snd tpl of BDEntryDelta dp bd -> BDEntryDelta dp $ rec bd BDLines lines -> BDLines $ rec <$> lines BDEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd - BDForceMultiline bd -> BDForceMultiline $ rec bd - BDForceSingleline bd -> BDForceSingleline $ rec bd - BDNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd - BDSetParSpacing bd -> BDSetParSpacing $ rec bd - BDForceParSpacing bd -> BDForceParSpacing $ rec bd + BDForceAlt forceFlag bd -> BDForceAlt forceFlag $ rec bd BDDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd where rec = unwrapBriDocNumbered diff --git a/source/library/Language/Haskell/Brittany/Internal/Components/OpTree.hs b/source/library/Language/Haskell/Brittany/Internal/Components/OpTree.hs new file mode 100644 index 0000000..1575423 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Components/OpTree.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ViewPatterns #-} +module Language.Haskell.Brittany.Internal.Components.OpTree where + +import Language.Haskell.Brittany.Internal.Prelude + +import qualified Data.Text as Text +import GHC ( RealSrcLoc ) +import GHC.Types.Fixity ( Fixity(Fixity) + , FixityDirection + ( InfixL + , InfixN + , InfixR + ) + ) +import GHC.Types.SourceText ( SourceText(NoSourceText) ) +import qualified Safe +import qualified Data.Char + +import Language.Haskell.Brittany.Internal.Components.BriDoc +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Types + + + +data OpTree + = OpUnknown Bool -- Z paren? + (Maybe RealSrcLoc) -- paren open loc + (Maybe RealSrcLoc) -- paren close loc + OpTree -- left operand + [(BriDocNumbered, BriDocNumbered)] -- list of (next operand, symbol) + | OpKnown Bool -- with paren? + (Maybe RealSrcLoc) -- paren open loc + (Maybe RealSrcLoc) -- paren close loc + Fixity -- only Just after (successful!) lookup phase + OpTree + [(BriDocNumbered, OpTree)] + | OpLeaf BriDocNumbered + +displayOpTree :: OpTree -> String +displayOpTree = \case + OpUnknown p _ _ leftTree rs -> + ( "(OpUnknown " + ++ show p + ++ " " + ++ displayOpTree leftTree + ++ " [" + ++ intercalate + "," + [ ("(" ++ showOp op ++ "," ++ show x ++ ")") | (op, (x, _)) <- rs ] + ++ "]" + ) + OpKnown p _ _ fixity tree ops -> + ( "OpKnown " + ++ show p + ++ " " + ++ showOutputable fixity + ++ " (" + ++ displayOpTree tree + ++ ")" + ++ join [ (showOp op ++ "(" ++ displayOpTree t ++ ")") | (op, t) <- ops ] + ) + OpLeaf (x, _) -> show x + where + showOp :: BriDocNumbered -> String + showOp = \case + (_, BDFlushCommentsPrior _ x) -> showOp x + (_, BDQueueComments _ x ) -> showOp x + (_, BDLit x ) -> Text.unpack x + -- (_, BDFlushCommentsPrior _ (_, BDFlushCommentsPrior _ (_, x))) + -- | trace (show $ toConstr x) False -> "meow" + (i, _ ) -> show i + + +-- lookupFixities :: Monad m => OpTree -> m OpTree +-- lookupFixities = \case +-- OpNode par Nothing opDoc chldrn -> do +-- pure $ OpNode par (hardcodedFixity (Text.unpack opDoc)) opDoc chldrn +-- x@OpNode{} -> pure x +-- x@OpLeaf{} -> pure x + +data ReformatParenMode + = ReformatParenModeKeep -- don't modify parens at all + | ReformatParenModeClean -- remove unnecessary parens + | ReformatParenModeAll -- add superfluous parens everywhere + +-- [(Bool, Fixity, Text, [OpTree])] + +-- a == b + c || d * e /= f +-- _ a +-- == a, _ b +-- == a, + b, _ c +-- == a, + b c +-- == a (+ b c) +-- || (== a (+ b c)), _ d +-- || (== a (+ b c)), * d, _ e +-- || (== a (+ b c)), * d e +-- || (== a (+ b c)), /= (* d e), _ f +-- || (== a (+ b c)), /= (* d e) f +-- || (== a (+ b c)) (/= (* d e) f) + +data StackElem = StackElem Fixity [(OpTree, BriDocNumbered)] +type Stack = [StackElem] + +balanceOpTree :: Bool -> OpTree -> ([BrittanyError], OpTree) +balanceOpTree allowUnqualify = \case + x@OpLeaf{} -> ([], x) + 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 + -- singleton :: BriDocNumbered -> StackElem + -- singleton x = StackElem (Fixity NoSourceText 99 InfixN) (OpLeaf x) [] + go + :: Stack + -> [(BriDocNumbered, BriDocNumbered)] + -> OpTree + -> Either [String] OpTree + go [] [] _ = Left [] + go [StackElem fxty cs] [] c = + let (e1, eops) = shiftOps cs c in Right (known fxty e1 eops) + go (StackElem fxty cs : StackElem fixity cs2 : rest) [] c = + -- go (StackElem fixity (OpKnown False fxty (reverse cs) : cs2) : rest) [] + let (e1, eops) = shiftOps cs c + in go (StackElem fixity cs2 : rest) [] (known fxty e1 eops) + go stack input@((opDoc, val) : inputR) c = case stack of + [] -> do + fxty <- docFixity opDoc + go [StackElem fxty [(c, opDoc)]] inputR (OpLeaf val) + (StackElem fixityS cs : stackR) -> do + let Fixity _ precS dirS = fixityS + fxty@(Fixity _ prec dir) <- docFixity opDoc + case compare prec precS of + GT -> go (StackElem fxty [(c, opDoc)] : stack) inputR (OpLeaf val) + LT -> do + let (e1, eops) = shiftOps cs c + go stackR input (known fixityS e1 eops) + EQ -> case (dir, dirS) of + (InfixR, InfixR) -> + go (StackElem fixityS ((c, opDoc) : cs) : stackR) + inputR + (OpLeaf val) + (InfixL, InfixL) -> + go (StackElem fixityS ((c, opDoc) : cs) : stackR) + inputR + (OpLeaf val) + _ -> Left [] + docFixity :: BriDocNumbered -> Either [String] Fixity + docFixity (_, x) = case x of + BDLit (Text.unpack -> s) -> case hardcodedFixity allowUnqualify s of + Just f -> Right f + Nothing -> Left [s] + BDFlushCommentsPrior _ d -> docFixity d + BDQueueComments _ d -> docFixity d + _ -> Left [] + shiftOps + :: [(OpTree, BriDocNumbered)] + -> OpTree + -> (OpTree, [(BriDocNumbered, OpTree)]) + shiftOps ops final = case reverse ops of + [] -> (final, []) + ((e1, o1) : rest) -> + ( e1 + , let (finalOp, list) = + mapAccumL (\op (nextE, nextOp) -> (nextOp, (op, nextE))) o1 rest + in list ++ [(finalOp, final)] + ) + known = OpKnown False Nothing Nothing + +addAllParens :: Bool -> OpTree -> OpTree +addAllParens topLevelParen = \case + x@OpLeaf{} -> x + x@OpUnknown{} -> x + OpKnown _paren locO locC fixity c cs -> + OpKnown topLevelParen + locO + locC + fixity + (addAllParens True c) + [ (op, addAllParens True tree) | (op, tree) <- cs ] + +remSuperfluousParens :: Int -> OpTree -> OpTree +remSuperfluousParens outerFixity = \case + x@OpLeaf{} -> x + x@OpUnknown{} -> x + OpKnown paren locO locC fixity c cs -> + OpKnown + (paren && outerFixity > fixLevel fixity) + locO + locC + fixity + (remSuperfluousParens (fixLevel fixity) c) + [ (op, remSuperfluousParens (fixLevel fixity) tree) | (op, tree) <- cs ] + where fixLevel (Fixity _ i _) = i + +hardcodedFixity :: Bool -> String -> Maybe Fixity +hardcodedFixity allowUnqualify = \case + "." -> Just $ Fixity NoSourceText 9 InfixR + "!!" -> Just $ Fixity NoSourceText 9 InfixL + "**" -> Just $ Fixity NoSourceText 8 InfixR + "^" -> Just $ Fixity NoSourceText 8 InfixR + "^^" -> Just $ Fixity NoSourceText 8 InfixR + "*" -> Just $ Fixity NoSourceText 7 InfixL + "/" -> Just $ Fixity NoSourceText 7 InfixL + "`quot`" -> Just $ Fixity NoSourceText 7 InfixL + "`rem`" -> Just $ Fixity NoSourceText 7 InfixL + "`div`" -> Just $ Fixity NoSourceText 7 InfixL + "`mod`" -> Just $ Fixity NoSourceText 7 InfixL + "+" -> Just $ Fixity NoSourceText 6 InfixL + "-" -> Just $ Fixity NoSourceText 6 InfixL + ":" -> Just $ Fixity NoSourceText 5 InfixR + "==" -> Just $ Fixity NoSourceText 4 InfixN + "/=" -> Just $ Fixity NoSourceText 4 InfixN + "<" -> Just $ Fixity NoSourceText 4 InfixN + "<=" -> Just $ Fixity NoSourceText 4 InfixN + ">" -> Just $ Fixity NoSourceText 4 InfixN + ">=" -> Just $ Fixity NoSourceText 4 InfixN + "&&" -> Just $ Fixity NoSourceText 3 InfixR + "||" -> Just $ Fixity NoSourceText 2 InfixR + ">>=" -> Just $ Fixity NoSourceText 1 InfixL + ">>" -> Just $ Fixity NoSourceText 1 InfixL + "=<<" -> Just $ Fixity NoSourceText 1 InfixR + "$" -> Just $ Fixity NoSourceText 0 InfixR + "`seq`" -> Just $ Fixity NoSourceText 0 InfixR + "$!" -> Just $ Fixity NoSourceText 0 InfixR + "!" -> Just $ Fixity NoSourceText 9 InfixL + "//" -> Just $ Fixity NoSourceText 9 InfixL + "<>" -> Just $ Fixity NoSourceText 6 InfixR + "<$" -> Just $ Fixity NoSourceText 4 InfixL + "<$>" -> Just $ Fixity NoSourceText 4 InfixL + "<&>" -> Just $ Fixity NoSourceText 1 InfixL + "&" -> Just $ Fixity NoSourceText 1 InfixL + "<*>" -> Just $ Fixity NoSourceText 4 InfixL + "<**>" -> Just $ Fixity NoSourceText 4 InfixL + "*>" -> Just $ Fixity NoSourceText 4 InfixL + "<*" -> Just $ Fixity NoSourceText 4 InfixL + "`elem`" -> Just $ Fixity NoSourceText 4 InfixN + "`notElem`" -> Just $ Fixity NoSourceText 4 InfixN + "++" -> Just $ Fixity NoSourceText 5 InfixR + "%" -> Just $ Fixity NoSourceText 7 InfixL + "<|>" -> Just $ Fixity NoSourceText 3 InfixL + ".&." -> Just $ Fixity NoSourceText 7 InfixL + ".|." -> Just $ Fixity NoSourceText 5 InfixL + "`xor`" -> Just $ Fixity NoSourceText 6 InfixL + "`shift`" -> Just $ Fixity NoSourceText 8 InfixL + "`rotate`" -> Just $ Fixity NoSourceText 8 InfixL + "`shiftL`" -> Just $ Fixity NoSourceText 8 InfixL + "`shiftR`" -> Just $ Fixity NoSourceText 8 InfixL + "`rotateL`" -> Just $ Fixity NoSourceText 8 InfixL + "`rotateR`" -> Just $ Fixity NoSourceText 8 InfixL + ".^." -> Just $ Fixity NoSourceText 6 InfixL + ".>>." -> Just $ Fixity NoSourceText 8 InfixL + ".<<." -> Just $ Fixity NoSourceText 8 InfixL + "!>>." -> Just $ Fixity NoSourceText 8 InfixL + "!<<." -> Just $ Fixity NoSourceText 8 InfixL + ">=>" -> Just $ Fixity NoSourceText 1 InfixR + "<=<" -> Just $ Fixity NoSourceText 1 InfixR + + ":~:" -> Just $ Fixity NoSourceText 4 InfixN + ":~~:" -> Just $ Fixity NoSourceText 4 InfixN + + -- non-base from random sources. + "<|" -> Just $ Fixity NoSourceText 5 InfixR + "|>" -> Just $ Fixity NoSourceText 5 InfixL + "><" -> Just $ Fixity NoSourceText 5 InfixR + "$+$" -> Just $ Fixity NoSourceText 5 InfixL + "\\\\" -> Just $ Fixity NoSourceText 5 InfixN + ".>" -> Just $ Fixity NoSourceText 9 InfixL + ":?" -> Just $ Fixity NoSourceText 7 InfixN + ":-" -> Just $ Fixity NoSourceText 9 InfixR + + str -> case (Safe.headMay str, Safe.lastMay str) of + (Just '\'', _) -> hardcodedFixity False (drop 1 str) + (Just '`', Just '`') -> Just $ Fixity NoSourceText 9 InfixL + (Just c, _) | Data.Char.isAlpha c && allowUnqualify -> hardcodedFixity False + $ dropWhile (\x -> (Data.Char.isAlpha x || x == '.')) str + _ -> Nothing diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Config.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Config.hs index 7229129..ff72577 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Config.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config/Config.hs @@ -59,6 +59,11 @@ staticDefaultConfig = Config , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False -- , _lconfig_allowSinglelineRecord = coerce False + , _lconfig_fixityAwareOps = coerce True + , _lconfig_fixityAwareTypeOps = coerce False + , _lconfig_fixityBasedAddAlignParens = coerce False + , _lconfig_operatorParenthesisRefactorMode = coerce PRMKeep + , _lconfig_operatorAllowUnqualify = coerce True } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = coerce False @@ -159,6 +164,11 @@ cmdlineConfigParser = do , _lconfig_allowHangingQuasiQuotes = mempty , _lconfig_experimentalSemicolonNewlines = mempty -- , _lconfig_allowSinglelineRecord = mempty + , _lconfig_fixityAwareOps = mempty + , _lconfig_fixityAwareTypeOps = mempty + , _lconfig_fixityBasedAddAlignParens = mempty + , _lconfig_operatorParenthesisRefactorMode = mempty + , _lconfig_operatorAllowUnqualify = mempty } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs index 6779a05..8a2969d 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -4,6 +4,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Brittany.Internal.Config.Types where @@ -16,9 +17,14 @@ import Language.Haskell.Brittany.Internal.Prelude -confUnpack :: forall b a . Coercible a b => Identity a -> b +confUnpack + :: forall a . Coercible a (ConfUnpacked a) => Identity a -> ConfUnpacked a confUnpack (Identity x) = coerce x +type family ConfUnpacked a where + ConfUnpacked (Last a) = a + ConfUnpacked a = a + data CDebugConfig f = DebugConfig { _dconf_dump_config :: f (Semigroup.Last Bool) , _dconf_dump_annotations :: f (Semigroup.Last Bool) @@ -137,6 +143,38 @@ data CLayoutConfig f = LayoutConfig -- -- > { x :: Double -- -- > , y :: Double -- -- > } + , _lconfig_fixityAwareOps :: f (Last Bool) + -- enables fixity-based layouting, e.g. + -- > foo = + -- > ( aaaaaaaaaaaaaa * bbbbbbbbbbbbbbbbbbb + -- > + ccccccccccc * ddddddddddddddddd + -- > ) + -- Note how the layout puts multiplication in a line because brittany + -- is aware that there are implicit parens around the lines. + -- The fixities are currently taken from a static (baked-in) lookup table + -- that was derived from the base library. + -- Operator applications with unknown fixities will be treated as if + -- this feature was turned off. In other words, such applications will be + -- treated as if all operators had the same fixity without changing + -- parentheses in any way. + , _lconfig_fixityAwareTypeOps :: f (Last Bool) + -- Same as above, but for type-level operators. Not yet implemented, but + -- reserved for future use. + , _lconfig_fixityBasedAddAlignParens :: f (Last Bool) + -- Layouts multiple-line operator applications with parentheses if + -- permitted by layout. Note how the arguments are properly aligned: + -- > ( aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + -- > <> bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb + -- > <> ccccccccccccccccccccccc + -- > ) + -- while this has operands at different indentations: + -- > aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + -- > <> bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb + -- > <> ccccccccccccccccccccccc + -- But this _does_ waste a line for the closing paren, so no clear winner. + -- Only has an effect in combination with fixityAware(Type)Ops. + , _lconfig_operatorParenthesisRefactorMode :: f (Last ParenRefactorMode) + , _lconfig_operatorAllowUnqualify :: f (Last Bool) } deriving Generic @@ -255,3 +293,13 @@ data ExactPrintFallbackMode -- THIS MAY THEORETICALLY CHANGE SEMANTICS OF -- A PROGRAM BY TRANSFORMING IT. deriving (Show, Generic, Data) + +data ParenRefactorMode + = PRMKeep + -- ^ neither add parens (beyond _lconfig_fixityBasedAddAlignParens) + -- Unknown operators will force Keep behaviour. + | PRMMinimize + -- ^ remove superfluous parens + | PRMMaximize + -- ^ insert parens around all operator applications. + deriving (Show, Generic, Data) 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 31f9242..253bc5f 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances1.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances1.hs @@ -75,6 +75,13 @@ instance ToJSON ExactPrintFallbackMode where toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany +instance FromJSON ParenRefactorMode where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON ParenRefactorMode where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany + instance FromJSON (CLayoutConfig Maybe) where parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany diff --git a/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs b/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs index 770af17..eb851c1 100644 --- a/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs +++ b/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs @@ -31,6 +31,7 @@ import GHC.Types.Name.Occurrence ( occNameString ) import GHC.Types.Name.Reader ( RdrName(..) ) import qualified GHC.Types.SrcLoc as GHC import GHC.Utils.Outputable ( Outputable ) +import Data.Coerce ( Coercible ) import Language.Haskell.Brittany.Internal.Components.BriDoc import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Prelude @@ -137,6 +138,7 @@ instance PrintRdrNameWithAnns GHC.SrcSpanAnnN where EpAnn _ (GHC.NameAnn GHC.NameParensHash _ _ _ _) _ -> f "(#" name "#)" EpAnn _ (GHC.NameAnn GHC.NameBackquotes _ _ _ _) _ -> f "`" name "`" EpAnn _ (GHC.NameAnn GHC.NameSquare _ _ _ _) _ -> f "[" name "]" + EpAnn _ (GHC.NameAnnQuote _ _ _) _ -> f "'" name "" -- TODO92 There are way more possible constructors here -- see https://hackage.haskell.org/package/ghc-9.2.5/docs/GHC-Parser-Annotation.html#t:NameAnn EpAnn _ _ _ -> rdrNameToText name @@ -397,16 +399,19 @@ docSeparator :: ToBriDocM BriDocNumbered docSeparator = allocateNode BDSeparator docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docNonBottomSpacing bdm = allocateNode . BDNonBottomSpacing False =<< bdm +docNonBottomSpacing bdm = allocateNode . BDForceAlt (NonBottomSpacing False) =<< bdm docNonBottomSpacingS :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docNonBottomSpacingS bdm = allocateNode . BDNonBottomSpacing True =<< bdm +docNonBottomSpacingS bdm = allocateNode . BDForceAlt (NonBottomSpacing True) =<< bdm docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docSetParSpacing bdm = allocateNode . BDSetParSpacing =<< bdm +docSetParSpacing bdm = allocateNode . BDForceAlt SetParSpacing =<< bdm docForceParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docForceParSpacing bdm = allocateNode . BDForceParSpacing =<< bdm +docForceParSpacing bdm = allocateNode . BDForceAlt ForceParSpacing =<< bdm + +docForceZeroAdd :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docForceZeroAdd bdm = allocateNode . BDForceAlt ForceZeroAdd =<< bdm docDebug :: String -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docDebug s bdm = allocateNode . BDDebug s =<< bdm @@ -459,10 +464,10 @@ docPar lineM indentedM = do allocateNode $ BDPar BrIndentNone line indented docForceSingleline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docForceSingleline bdm = allocateNode . BDForceSingleline =<< bdm +docForceSingleline bdm = allocateNode . BDForceAlt ForceSingleline =<< bdm docForceMultiline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docForceMultiline bdm = allocateNode . BDForceMultiline =<< bdm +docForceMultiline bdm = allocateNode . BDForceAlt ForceMultiline =<< bdm docEnsureIndent :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered @@ -774,3 +779,9 @@ docHandleListElemCommsProperPost layouter es = case es of epaLocationRealSrcSpanStart :: GHC.EpaLocation -> GHC.RealSrcLoc epaLocationRealSrcSpanStart = GHC.realSrcSpanStart . GHC.epaLocationRealSrcSpan + +askLayoutConf + :: Coercible a (ConfUnpacked a) + => (CLayoutConfig Identity -> Identity a) + -> ToBriDocM (ConfUnpacked a) +askLayoutConf f = mAsk <&> _conf_layout .> f .> confUnpack diff --git a/source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs b/source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs index dd6fa59..281e35d 100644 --- a/source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs +++ b/source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs @@ -142,9 +142,10 @@ layoutBriDocM = \case layoutAddSepSpace BDAddBaseY indent bd -> do let indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentRegularForce -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i indentF $ layoutBriDocM bd BDBaseYPushCur bd -> do layoutBaseYPushCur @@ -158,18 +159,20 @@ layoutBriDocM = \case layoutIndentLevelPop BDEnsureIndent indent bd -> do let indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentRegularForce -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i indentF $ do layoutWriteEnsureBlock layoutBriDocM bd BDPar indent sameLine indented -> do layoutBriDocM sameLine let indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentRegularForce -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i indentF $ do layoutWriteNewline layoutBriDocM indented @@ -183,8 +186,7 @@ layoutBriDocM = \case BDLines lines -> alignColsLines layoutBriDocM lines BDAlt [] -> error "empty BDAlt" BDAlt (alt : _) -> layoutBriDocM alt - BDForceMultiline bd -> layoutBriDocM bd - BDForceSingleline bd -> layoutBriDocM bd + BDForceAlt _ bd -> layoutBriDocM bd BDForwardLineMode bd -> layoutBriDocM bd BDExternal shouldAddComment t -> do let tlines = Text.lines $ t <> Text.pack "\n" @@ -276,17 +278,23 @@ layoutBriDocM = \case printComments comms mModify (\s -> s + CommentCounter (length comms)) do - marker <- mGet <&> _lstate_markerForDelta + state <- mGet mModify $ \s -> s { _lstate_markerForDelta = Nothing } - case marker of - Nothing -> pure () + case _lstate_markerForDelta state of Just m -> do let p1 = (srcLocLine m, srcLocCol m) let p2 = (srcLocLine loc, srcLocCol loc) + let newlinePlanned = case _lstate_plannedSpace state of + PlannedNone -> False + PlannedSameline{} -> False + PlannedNewline{} -> True + PlannedDelta{} -> True -- traceShow (ExactPrint.pos2delta p1 p2) $ pure () case ExactPrint.pos2delta p1 p2 of SameLine{} -> pure () - DifferentLine n _ -> layoutWriteNewlines n + DifferentLine n _ | newlinePlanned -> layoutWriteNewlines n + | otherwise -> pure () + _ -> pure () layoutBriDocM bd BDFlushCommentsPost loc shouldMark bd -> do layoutBriDocM bd @@ -297,20 +305,10 @@ layoutBriDocM = \case comms <- takeBefore loc mModify (\s -> s + CommentCounter (length comms)) printComments comms - BDNonBottomSpacing _ bd -> layoutBriDocM bd - BDSetParSpacing bd -> layoutBriDocM bd - BDForceParSpacing bd -> layoutBriDocM bd BDDebug s bd -> do mTell $ TextL.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}" layoutBriDocM bd -mergeOn :: Ord b => (a -> b) -> [a] -> [a] -> [a] -mergeOn _f xs [] = xs -mergeOn _f [] ys = ys -mergeOn f xs@(x:xr) ys@(y:yr) - | f x <= f y = x : mergeOn f xr ys - | otherwise = y : mergeOn f xs yr - takeBefore :: MonadMultiState [LEpaComment] m => RealSrcLoc -> m [LEpaComment] takeBefore loc = do diff --git a/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs b/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs index d7f3d68..0e09c6e 100644 --- a/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs +++ b/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs @@ -60,7 +60,7 @@ processModule -> IO ([BrittanyError], TextL.Text) processModule traceFunc conf inlineConf parsedModule = do let shouldReformatHead = - conf & _conf_layout & _lconfig_reformatModulePreamble & confUnpack @Bool + conf & _conf_layout & _lconfig_reformatModulePreamble & confUnpack let wrapNonDeclToBriDoc = MultiRWSS.withMultiReader conf . MultiRWSS.withMultiState_ (CommentCounter 0) @@ -143,18 +143,18 @@ processModule traceFunc conf inlineConf parsedModule = do -- trace ("---- DEBUGMESSAGES ---- ") -- . foldr (seq . join trace) id debugStrings debugStrings `forM_` \s -> useTraceFunc traceFunc s - moduleElementsStream - (\el rest -> do - case el of - MEExactModuleHead{} -> useTraceFunc traceFunc "MEExactModuleHead" - MEPrettyModuleHead{} -> useTraceFunc traceFunc "MEPrettyModuleHead" - MEImportDecl{} -> useTraceFunc traceFunc "MEImportDecl" - MEDecl{} -> useTraceFunc traceFunc "MEDecl" - MEComment{} -> useTraceFunc traceFunc "MEComment" - MEWhitespace dp -> useTraceFunc traceFunc ("MEWhitespace " ++ show dp) - rest - ) - (\_ -> pure ()) + -- moduleElementsStream + -- (\el rest -> do + -- case el of + -- MEExactModuleHead{} -> useTraceFunc traceFunc "MEExactModuleHead" + -- MEPrettyModuleHead{} -> useTraceFunc traceFunc "MEPrettyModuleHead" + -- MEImportDecl{} -> useTraceFunc traceFunc "MEImportDecl" + -- MEDecl{} -> useTraceFunc traceFunc "MEDecl" + -- MEComment{} -> useTraceFunc traceFunc "MEComment" + -- MEWhitespace dp -> useTraceFunc traceFunc ("MEWhitespace " ++ show dp) + -- rest + -- ) + -- (\_ -> pure ()) pure (errs, TextL.Builder.toLazyText out) commentToDoc :: (Int, EpaCommentTok) -> ToBriDocM BriDocNumbered @@ -213,7 +213,7 @@ getDeclConfig config inlineConf decl = cZipWith fromOptionIdentity config ppToplevelDecl :: LHsDecl GhcPs -> [(Int, EpaCommentTok)] -> PPMLocal () ppToplevelDecl decl immediateAfterComms = do exactprintOnly <- mAsk <&> \declConfig -> - declConfig & _conf_roundtrip_exactprint_only & confUnpack @Bool + declConfig & _conf_roundtrip_exactprint_only & confUnpack bd <- fmap fst $ if exactprintOnly then briDocMToPPM $ docSeq (briDocByExact decl : map commentToDoc immediateAfterComms) diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs index 8a96955..25c4329 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs @@ -4,33 +4,39 @@ module Language.Haskell.Brittany.Internal.ToBriDoc.Expr where -import qualified Data.Sequence as Seq -import qualified Data.Text as Text -import GHC (GenLocated(L), RdrName(..)) -import qualified GHC.Data.FastString as FastString -import GHC.Types.SourceText - (IntegralLit(IL), FractionalLit(FL), SourceText(SourceText)) -import GHC.Hs -import qualified GHC.Types.SrcLoc as GHC -import qualified GHC.OldList as List -import GHC.Types.Basic -import GHC.Types.Name -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.S3_ToBriDocTools -import Language.Haskell.Brittany.Internal.ToBriDoc.Decl -import Language.Haskell.Brittany.Internal.ToBriDoc.Pattern +import qualified Data.Sequence as Seq +import qualified Data.Text as Text +import GHC ( GenLocated(L) + , RdrName(..) + ) +import qualified GHC.Data.FastString as FastString +import GHC.Hs +import qualified GHC.OldList as List +import GHC.Types.Basic +import GHC.Types.Name +import GHC.Types.SourceText ( FractionalLit(FL) + , IntegralLit(IL) + , SourceText(SourceText) + ) +import qualified GHC.Types.SrcLoc as GHC + +import Language.Haskell.Brittany.Internal.Components.BriDoc +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.S3_ToBriDocTools +import Language.Haskell.Brittany.Internal.ToBriDoc.Decl +import Language.Haskell.Brittany.Internal.ToBriDoc.Pattern import {-# SOURCE #-} Language.Haskell.Brittany.Internal.ToBriDoc.Stmt -import Language.Haskell.Brittany.Internal.ToBriDoc.Type -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Components.BriDoc +import Language.Haskell.Brittany.Internal.ToBriDoc.Type +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.ToBriDoc.OpTree layoutExpr :: ToBriDoc HsExpr layoutExpr lexpr@(L _ expr) = do - indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + indentPolicy <- askLayoutConf _lconfig_indentPolicy let allowFreeIndent = indentPolicy == IndentPolicyFree docHandleComms lexpr $ case expr of HsVar NoExtField vname -> docHandleComms lexpr $ do @@ -64,25 +70,25 @@ layoutExpr lexpr@(L _ expr) = do -- (TODO: we create a BDCols here, but then make it ineffective -- by wrapping it in docSeq below. We _could_ add alignments for -- stuff like lists-of-lambdas. Nothing terribly important..) - let - shouldPrefixSeparator = case p of - L _ LazyPat{} -> isFirst - L _ BangPat{} -> isFirst - _ -> False + let shouldPrefixSeparator = case p of + L _ LazyPat{} -> isFirst + L _ BangPat{} -> isFirst + _ -> False patDocSeq <- layoutPat p - fixed <- case Seq.viewl patDocSeq of + fixed <- case Seq.viewl patDocSeq of p1 Seq.:< pr | shouldPrefixSeparator -> do p1' <- docSeq [docSeparator, pure p1] pure (p1' Seq.<| pr) _ -> pure patDocSeq colsWrapPat fixed - bodyDoc <- shareDoc + bodyDoc <- + shareDoc $ docAddBaseY BrIndentRegular - $ docHandleComms epAnn $ layoutExpr body - let - funcPatternPartLine = docCols - ColCasePattern - (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) + $ docHandleComms epAnn + $ layoutExpr body + let funcPatternPartLine = docCols + ColCasePattern + (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) docAlt [ -- single line docSeq @@ -95,8 +101,7 @@ layoutExpr lexpr@(L _ expr) = do , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docSeq [ docLit $ Text.pack "\\" - , appSep $ docForceSingleline - funcPatternPartLine + , appSep $ docForceSingleline funcPatternPartLine , docLit $ Text.pack "->" ] ) @@ -112,31 +117,27 @@ layoutExpr lexpr@(L _ expr) = do , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docSeq [ docLit $ Text.pack "\\" - , appSep $ docForceSingleline - funcPatternPartLine + , appSep $ docForceSingleline funcPatternPartLine , docLit $ Text.pack "->" ] ) (docNonBottomSpacing bodyDoc) ] - HsLam{} -> unknownNodeError "HsLam too complex" lexpr + HsLam{} -> unknownNodeError "HsLam too complex" lexpr HsLamCase _ (MG _ (L _ []) _) -> do docSetParSpacing $ docAddBaseY BrIndentRegular $ (docLit $ Text.pack "\\case {}") - HsLamCase _ (MG _ _lmatches@(L _ matches) _) -> do - binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- - -- docWrapNode lmatches - layoutPatternBind Nothing binderDoc - `mapM` matches + HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do + binderDoc <- docLit $ Text.pack "->" + funcPatDocs <- layoutPatternBind Nothing binderDoc `mapM` matches docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "\\case") - (docSetBaseAndIndent + ( docSetBaseAndIndent $ docNonBottomSpacing + $ docHandleComms lmatches $ docLines - $ return - <$> funcPatDocs + $ return <$> funcPatDocs ) HsApp _ exp1 _ -> do let gather @@ -170,22 +171,21 @@ layoutExpr lexpr@(L _ expr) = do addAlternativeCond (not hasComments) $ docSetParSpacing $ docSeq [ appSep (docForceSingleline headDoc) , case splitFirstLast paramDocs of - FirstLastEmpty -> docEmpty - FirstLastSingleton e1 -> docForceParSpacing e1 - FirstLast e1 ems eN -> - docSeq - ( spacifyDocs (docForceSingleline <$> (e1:ems)) - ++ [docSeparator, docForceParSpacing eN] - ) + FirstLastEmpty -> docEmpty + FirstLastSingleton e1 -> docForceParSpacing e1 + FirstLast e1 ems eN -> docSeq + ( spacifyDocs (docForceSingleline <$> (e1 : ems)) + ++ [docSeparator, docForceParSpacing eN] + ) ] -- foo x -- y addAlternativeCond allowFreeIndent $ docSeq [ appSep (docForceSingleline headDoc) , docSetBaseY - $ docAddBaseY BrIndentRegular - $ docLines - $ docForceSingleline + $ docAddBaseY BrIndentRegular + $ docLines + $ docForceSingleline <$> paramDocs ] -- foo @@ -222,79 +222,22 @@ layoutExpr lexpr@(L _ expr) = do ] , docPar e (docSeq [docLit $ Text.pack "@", t]) ] - OpApp _topEpAnn expLeft@(L _ OpApp{}) expOp expRight -> do - let - allowPar = case (expOp, expRight) of - (L _ (HsVar _ (L _ (Unqual occname))), _) - | occNameString occname == "$" -> True - (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False - _ -> True - let - gather - :: Bool - -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered, Bool)] - -> LHsExpr GhcPs - -> ( ToBriDocM BriDocNumbered - , [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered, Bool)] - ) - gather last opExprList = \case - (L _ (OpApp epAnn l1 op1 r1)) -> - gather - False - ( ( docHandleComms epAnn $ layoutExpr op1 - , layoutExpr r1 - , last - ) - : opExprList - ) - l1 - final -> (layoutExpr final, opExprList) - (leftOperand, appList) = gather True [] lexpr - leftOperandDoc <- shareDoc leftOperand - appListDocs <- appList `forM` \(x, y, last) -> - [ (xD, yD, last) - | xD <- shareDoc x - , yD <- shareDoc y - ] - let allowSinglelinePar = not (hasAnyCommentsConnected expLeft) - && not (hasAnyCommentsConnected expOp) - runFilteredAlternative $ do - -- > one + two + three - -- or - -- > one + two + case x of - -- > _ -> three - addAlternativeCond allowSinglelinePar $ docSeq - [ appSep $ docForceSingleline leftOperandDoc - , docSeq $ appListDocs <&> \(od, ed, last) -> docSeq - [ appSep $ docForceSingleline od - , if last - then if allowPar - then docForceParSpacing ed - else docForceSingleline ed - else appSep $ docForceSingleline ed - ] - ] - -- this case rather leads to some unfortunate layouting than to anything - -- useful; disabling for now. (it interfers with cols stuff.) - -- addAlternative - -- $ docSetBaseY - -- $ docPar - -- leftOperandDoc - -- ( docLines - -- $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) - -- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] - -- ) - -- > one - -- > + two - -- > + three - addAlternative $ docPar - leftOperandDoc - (docLines $ appListDocs <&> \(od, ed, _) -> - docCols ColOpPrefix [appSep od, docSetBaseY ed] - ) + OpApp _topEpAnn _expLeft@(L _ OpApp{}) _expOp _expRight -> do + -- let + -- allowPar = case (expOp, expRight) of + -- (L _ (HsVar _ (L _ (Unqual occname))), _) + -- | occNameString occname == "$" -> True + -- (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False + -- _ -> True + -- let hasComments = + -- not + -- $ hasAnyCommentsConnected expLeft + -- || hasAnyCommentsConnected expOp + treeAndHasComms <- gatherOpTreeE False False id Nothing Nothing [] lexpr + processOpTree treeAndHasComms OpApp epAnn expLeft expOp expRight -> docHandleComms epAnn $ do - expDocLeft <- shareDoc $ layoutExpr expLeft - expDocOp <- shareDoc $ layoutExpr expOp + expDocLeft <- shareDoc $ layoutExpr expLeft + expDocOp <- shareDoc $ layoutExpr expOp expDocRight <- shareDoc $ layoutExpr expRight let allowPar = case (expOp, expRight) of @@ -302,10 +245,9 @@ layoutExpr lexpr@(L _ expr) = do | occNameString occname == "$" -> True (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False _ -> True - let - leftIsDoBlock = case expLeft of - L _ HsDo{} -> True - _ -> False + let leftIsDoBlock = case expLeft of + L _ HsDo{} -> True + _ -> False runFilteredAlternative $ do -- one-line addAlternative $ docSeq @@ -322,10 +264,9 @@ layoutExpr lexpr@(L _ expr) = do -- ] -- two-line addAlternative $ do - let - expDocOpAndRight = docForceSingleline $ docCols - ColOpPrefix - [appSep $ expDocOp, docSetBaseY expDocRight] + let expDocOpAndRight = docForceSingleline $ docCols + ColOpPrefix + [appSep $ expDocOp, docSetBaseY expDocRight] if leftIsDoBlock then docLines [expDocLeft, expDocOpAndRight] else docAddBaseY BrIndentRegular @@ -342,9 +283,8 @@ layoutExpr lexpr@(L _ expr) = do ] -- more lines addAlternative $ do - let - expDocOpAndRight = - docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight] + let expDocOpAndRight = + docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight] if leftIsDoBlock then docLines [expDocLeft, expDocOpAndRight] else docAddBaseY BrIndentRegular @@ -352,16 +292,35 @@ layoutExpr lexpr@(L _ expr) = do NegApp _ op _ -> do opDoc <- shareDoc $ layoutExpr op docSeq [docLit $ Text.pack "-", opDoc] + HsPar _epAnn (L _ (OpApp _topEpAnn _expLeft _expOp _)) -> do + -- let innerHasComments = + -- not + -- $ hasAnyCommentsConnected expLeft + -- || hasAnyCommentsConnected expOp + -- let AnnParen _ spanOpen spanClose = anns epAnn + -- docHandleComms epAnn + -- $ processOpTree + -- lop + -- innerHasComments + -- True + -- (Just $ epaLocationRealSrcSpanStart spanOpen) + -- (Just $ epaLocationRealSrcSpanStart spanClose) + -- let hasComments = hasAnyCommentsConnected lexpr + -- not + -- $ hasAnyCommentsConnected expLeft + -- || hasAnyCommentsConnected expOp + treeAndHasComms <- gatherOpTreeE False False id Nothing Nothing [] lexpr + processOpTree treeAndHasComms HsPar epAnn innerExp -> docHandleComms epAnn $ do let AnnParen _ spanOpen spanClose = anns epAnn - let wrapOpen = docHandleComms spanOpen - let wrapClose = docHandleComms spanClose + let wrapOpen = docHandleComms spanOpen + let wrapClose = docHandleComms spanClose innerExpDoc <- shareDoc $ layoutExpr innerExp docAlt [ docSeq [ wrapOpen $ docLit $ Text.pack "(" , docForceSingleline innerExpDoc - , wrapClose $ docLit $ Text.pack ")" + , wrapClose $ docLit $ Text.pack ")" ] , docSetBaseY $ docLines [ docCols @@ -374,10 +333,10 @@ layoutExpr lexpr@(L _ expr) = do ] SectionL _ left op -> do -- TODO: add to testsuite leftDoc <- shareDoc $ layoutExpr left - opDoc <- shareDoc $ layoutExpr op + opDoc <- shareDoc $ layoutExpr op docSeq [leftDoc, docSeparator, opDoc] SectionR _ op right -> do -- TODO: add to testsuite - opDoc <- shareDoc $ layoutExpr op + opDoc <- shareDoc $ layoutExpr op rightDoc <- shareDoc $ layoutExpr right docSeq [opDoc, docSeparator, rightDoc] ExplicitTuple epAnn args boxity -> docHandleComms epAnn $ do @@ -393,7 +352,7 @@ layoutExpr lexpr@(L _ expr) = do ) _ -> (id, id) argDocs <- forM args $ \case - Present _ e -> shareDoc $ docHandleListElemComms layoutExpr e + Present _ e -> shareDoc $ docHandleListElemComms layoutExpr e Missing missingEpAnn -> shareDoc $ docHandleComms missingEpAnn docEmpty -- let ((c1, argsWithC, c2), cRemain) = case epAnn of -- EpAnn _ [open, close] comms -> @@ -432,36 +391,23 @@ layoutExpr lexpr@(L _ expr) = do -- overzealous for comments before open & after close let (openLit, closeLit) = case boxity of - Boxed -> + Boxed -> ( wrapOpen $ docLit $ Text.pack "(" , wrapClose $ docLit $ Text.pack ")" ) Unboxed -> - ( wrapOpen $ docParenHashLSep - , wrapClose $ docParenHashRSep - ) + (wrapOpen $ docParenHashLSep, wrapClose $ docParenHashRSep) case splitFirstLast argDocs of - FirstLastEmpty -> - docSeq [openLit, closeLit] + FirstLastEmpty -> docSeq [openLit, closeLit] FirstLastSingleton e -> docAlt - [ docCols - ColTuple - [ openLit - , docForceSingleline e - , closeLit - ] - , docSetBaseY $ docLines - [ docSeq - [ openLit - , docForceSingleline e - ] - , closeLit - ] + [ docCols ColTuple [openLit, docForceSingleline e, closeLit] + , docSetBaseY + $ docLines [docSeq [openLit, docForceSingleline e], closeLit] ] FirstLast e1 ems eN -> runFilteredAlternative $ do addAlternativeCond (not hasComments) - $ docCols ColTuple - $ [docSeq [openLit, docForceSingleline e1]] + $ docCols ColTuple + $ [docSeq [openLit, docForceSingleline e1]] ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e]) ++ [ docSeq [ docCommaSep @@ -471,15 +417,16 @@ layoutExpr lexpr@(L _ expr) = do ] ] addAlternative - $ let - start = docCols ColTuples [appSep openLit, e1] - linesM = ems <&> \d -> docCols ColTuples [docCommaSep, d] - lineN = docCols - ColTuples - [docCommaSep, -- TODO92 docNodeAnnKW lexpr (Just AnnOpenP) - eN] - end = closeLit - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] + $ let start = docCols ColTuples [appSep openLit, docSetBaseY e1] + linesM = ems <&> \d -> docCols ColTuples [docCommaSep, docSetBaseY d] + lineN = docCols + ColTuples + [ docCommaSep + , -- TODO92 docNodeAnnKW lexpr (Just AnnOpenP) + docSetBaseY eN + ] + end = closeLit + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] HsCase epAnn cExp (MG _ (L _ []) _) -> docHandleComms epAnn $ do cExpDoc <- shareDoc $ layoutExpr cExp docAlt @@ -489,62 +436,61 @@ layoutExpr lexpr@(L _ expr) = do , docLit $ Text.pack "of {}" ] , docPar - (docAddBaseY BrIndentRegular + ( docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "case") cExpDoc ) (docLit $ Text.pack "of {}") ] - HsCase epAnn cExp (MG _ lmatches@(L _ matches) _) -> docHandleComms epAnn $ do - cExpDoc <- shareDoc $ layoutExpr cExp - binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- - -- docWrapNode lmatches - layoutPatternBind Nothing binderDoc - `mapM` matches - docAlt - [ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docSeq - [ appSep $ docLit $ Text.pack "case" - , appSep $ docForceSingleline cExpDoc - , docLit $ Text.pack "of" - ] - ) - (docSetBaseAndIndent - $ docNonBottomSpacing - $ docHandleComms lmatches - $ docLines - $ return - <$> funcPatDocs - ) - , docPar - (docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "case") cExpDoc - ) - (docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "of") - (docSetBaseAndIndent - $ docNonBottomSpacing - $ docHandleComms lmatches - $ docLines - $ return + HsCase epAnn cExp (MG _ lmatches@(L _ matches) _) -> + docHandleComms epAnn $ do + cExpDoc <- shareDoc $ layoutExpr cExp + binderDoc <- docLit $ Text.pack "->" + funcPatDocs <- + -- docWrapNode lmatches + layoutPatternBind Nothing binderDoc `mapM` matches + docAlt + [ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docSeq + [ appSep $ docLit $ Text.pack "case" + , appSep $ docForceSingleline cExpDoc + , docLit $ Text.pack "of" + ] + ) + ( docSetBaseAndIndent + $ docNonBottomSpacing + $ docHandleComms lmatches + $ docLines + $ return <$> funcPatDocs ) - ) - ] + , docPar + ( docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "case") cExpDoc + ) + (docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "of") + ( docSetBaseAndIndent + $ docNonBottomSpacing + $ docHandleComms lmatches + $ docLines + $ return + <$> funcPatDocs + ) + ) + ] HsIf epAnn ifExpr thenExpr elseExpr -> docHandleComms epAnn $ do let AnnsIf spanIf spanThen spanElse _ _ = anns epAnn let ifDoc = docHandleComms spanIf $ docLit $ Text.pack "if" let thenDoc = docHandleComms spanThen $ docLit $ Text.pack "then" let elseDoc = docHandleComms spanElse $ docLit $ Text.pack "else" - ifExprDoc <- shareDoc $ layoutExpr ifExpr + ifExprDoc <- shareDoc $ layoutExpr ifExpr thenExprDoc <- shareDoc $ layoutExpr thenExpr elseExprDoc <- shareDoc $ layoutExpr elseExpr let hasComments = hasAnyCommentsBelow lexpr - let - maySpecialIndent = case indentPolicy of - IndentPolicyLeft -> BrIndentRegular - IndentPolicyMultiple -> BrIndentRegular - IndentPolicyFree -> BrIndentSpecial 3 + let maySpecialIndent = case indentPolicy of + IndentPolicyLeft -> BrIndentRegular + IndentPolicyMultiple -> BrIndentRegular + IndentPolicyFree -> BrIndentSpecial 3 -- TODO: some of the alternatives (especially last and last-but-one) -- overlap. docSetIndentLevel $ runFilteredAlternative $ do @@ -583,20 +529,12 @@ layoutExpr lexpr@(L _ expr) = do -- TODO92 $ docNodeAnnKW lexpr (Just AnnThen) $ docNonBottomSpacing $ docAlt - [ docSeq - [ appSep $ thenDoc - , docForceParSpacing thenExprDoc - ] - , docAddBaseY BrIndentRegular - $ docPar thenDoc thenExprDoc + [ docSeq [appSep $ thenDoc, docForceParSpacing thenExprDoc] + , docAddBaseY BrIndentRegular $ docPar thenDoc thenExprDoc ] , docAddBaseY BrIndentRegular $ docNonBottomSpacing $ docAlt - [ docSeq - [ appSep $ elseDoc - , docForceParSpacing elseExprDoc - ] - , docAddBaseY BrIndentRegular - $ docPar elseDoc elseExprDoc + [ docSeq [appSep $ elseDoc, docForceParSpacing elseExprDoc] + , docAddBaseY BrIndentRegular $ docPar elseDoc elseExprDoc ] ] ) @@ -618,25 +556,14 @@ layoutExpr lexpr@(L _ expr) = do -- stuff -- note that this does _not_ have par-spacing addAlternative $ docPar - (docAddBaseY maySpecialIndent $ docSeq - [ appSep $ ifDoc - , ifExprDoc - ] - ) + (docAddBaseY maySpecialIndent $ docSeq [appSep $ ifDoc, ifExprDoc]) (docLines - [ docAddBaseY BrIndentRegular - $ docAlt - [ docSeq - [ appSep $ thenDoc - , docForceParSpacing thenExprDoc - ] - , docPar thenDoc thenExprDoc - ] + [ docAddBaseY BrIndentRegular $ docAlt + [ docSeq [appSep $ thenDoc, docForceParSpacing thenExprDoc] + , docPar thenDoc thenExprDoc + ] , docAddBaseY BrIndentRegular $ docAlt - [ docSeq - [ appSep $ elseDoc - , docForceParSpacing elseExprDoc - ] + [ docSeq [appSep $ elseDoc, docForceParSpacing elseExprDoc] , docPar elseDoc elseExprDoc ] ] @@ -649,26 +576,24 @@ layoutExpr lexpr@(L _ expr) = do let posIf = obtainAnnPos epAnn AnnIf docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docHandleComms posIf $ docLit $ Text.pack "if") - (layoutPatternBindFinal - Nothing - binderDoc - Nothing - (Right cases) - Nothing - hasComments + (layoutPatternBindFinal Nothing + binderDoc + Nothing + (Right cases) + Nothing + hasComments ) HsLet epAnn binds exp1 -> docHandleComms epAnn $ do let AnnsLet spanLet spanIn = anns epAnn - let hasComments = hasAnyCommentsBelow lexpr - let wrapLet = docHandleComms spanLet - let wrapIn = docHandleComms spanIn + let hasComments = hasAnyCommentsBelow lexpr + let wrapLet = docHandleComms spanLet + let wrapIn = docHandleComms spanIn mBindDocs <- layoutLocalBinds binds - let - ifIndentFreeElse :: a -> a -> a - ifIndentFreeElse x y = case indentPolicy of - IndentPolicyLeft -> y - IndentPolicyMultiple -> y - IndentPolicyFree -> x + let ifIndentFreeElse :: a -> a -> a + ifIndentFreeElse x y = case indentPolicy of + IndentPolicyLeft -> y + IndentPolicyMultiple -> y + IndentPolicyFree -> x expDoc1 <- shareDoc $ layoutExpr exp1 -- this `docSetBaseAndIndent` might seem out of place (especially the -- Indent part; setBase is necessary due to the use of docLines below), @@ -678,8 +603,8 @@ layoutExpr lexpr@(L _ expr) = do -- to making brittany idempotent, even though the result is non-optimal -- if "let" is moved horizontally as part of the transformation, as the -- comments before the first let item are moved horizontally with it. - letDoc <- shareDoc $ wrapLet $ docLit $ Text.pack "let" - inDoc <- shareDoc $ wrapIn $ docLit $ Text.pack "in" + letDoc <- shareDoc $ wrapLet $ docLit $ Text.pack "let" + inDoc <- shareDoc $ wrapIn $ docLit $ Text.pack "in" docSetBaseAndIndent $ case fmap snd mBindDocs of Just [bindDoc] -> runFilteredAlternative $ do addAlternativeCond (not hasComments) $ docSeq @@ -695,17 +620,17 @@ layoutExpr lexpr@(L _ expr) = do , ifIndentFreeElse docSetBaseAndIndent docForceSingleline $ pure bindDoc ] - , docAddBaseY BrIndentRegular $ docPar - (letDoc) - (docSetBaseAndIndent $ pure bindDoc) + , docAddBaseY BrIndentRegular + $ docPar (letDoc) (docSetBaseAndIndent $ pure bindDoc) ] , docAlt [ docSeq - [ appSep $ wrapIn $ docLit $ Text.pack $ ifIndentFreeElse "in " "in" - , ifIndentFreeElse - docSetBaseAndIndent - docForceSingleline - expDoc1 + [ appSep $ wrapIn $ docLit $ Text.pack $ ifIndentFreeElse + "in " + "in" + , ifIndentFreeElse docSetBaseAndIndent + docForceSingleline + expDoc1 ] , docAddBaseY BrIndentRegular $ docPar (inDoc) (docSetBaseY expDoc1) @@ -725,45 +650,42 @@ layoutExpr lexpr@(L _ expr) = do -- c = d -- in -- fooooooooooooooooooo - let - noHangingBinds = - [ docNonBottomSpacing $ docAddBaseY BrIndentRegular $ docPar - (letDoc) - (docSetBaseAndIndent $ docLines $ pure <$> bindDocs) - , docSeq - [ wrapIn $ docLit $ Text.pack "in " - , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc1 + let noHangingBinds = + [ docNonBottomSpacing $ docAddBaseY BrIndentRegular $ docPar + (letDoc) + (docSetBaseAndIndent $ docLines $ pure <$> bindDocs) + , docSeq + [ wrapIn $ docLit $ Text.pack "in " + , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc1 + ] ] - ] addAlternative $ case indentPolicy of - IndentPolicyLeft -> docLines noHangingBinds + IndentPolicyLeft -> docLines noHangingBinds IndentPolicyMultiple -> docLines noHangingBinds - IndentPolicyFree -> docLines + IndentPolicyFree -> docLines [ -- TODO92 docNodeAnnKW lexpr (Just AnnLet) $ docSeq [ appSep $ letDoc , docSetBaseAndIndent $ docLines $ pure <$> bindDocs ] - , docSeq [appSep $ wrapIn $ docLit $ Text.pack "in ", docSetBaseY expDoc1] + , docSeq + [ appSep $ wrapIn $ docLit $ Text.pack "in " + , docSetBaseY expDoc1 + ] ] addAlternative $ docLines [ -- TODO92 docNodeAnnKW lexpr (Just AnnLet) $ - docAddBaseY BrIndentRegular - $ docPar - (letDoc) - (docSetBaseAndIndent $ docLines $ pure <$> bindDocs) + docAddBaseY BrIndentRegular $ docPar + (letDoc) + (docSetBaseAndIndent $ docLines $ pure <$> bindDocs) , docAddBaseY BrIndentRegular $ docPar (inDoc) (docSetBaseY $ expDoc1) ] _ -> docSeq - [ docForceSingleline $ docSeq - [ letDoc - , docSeparator - , inDoc - ] - , docSeparator - , expDoc1 - ] + [ docForceSingleline $ docSeq [letDoc, docSeparator, inDoc] + , docSeparator + , expDoc1 + ] -- docSeq [appSep $ docLit "let in", expDoc1] HsDo epAnn stmtCtx (L (SrcSpanAnn stmtEpAnn _) stmts) -> docHandleComms epAnn $ do @@ -771,44 +693,46 @@ layoutExpr lexpr@(L _ expr) = do DoExpr _ -> do stmtDocs <- docHandleComms stmtEpAnn $ do stmts `forM` docHandleListElemComms layoutStmt - docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + docSetParSpacing $ docAddBaseY BrIndentRegularForce $ docPar (docLit $ Text.pack "do") - (docSetBaseAndIndent - $ docNonBottomSpacing - $ docLines - $ pure <$> stmtDocs + ( docSetBaseAndIndent + $ docNonBottomSpacing + $ docLines + $ (pure <$> stmtDocs) ) MDoExpr _ -> do stmtDocs <- docHandleComms stmtEpAnn $ do stmts `forM` docHandleListElemComms layoutStmt - docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + docSetParSpacing $ docAddBaseY BrIndentRegularForce $ docPar (docLit $ Text.pack "mdo") - (docSetBaseAndIndent - $ docNonBottomSpacing - $ docLines - $ pure <$> stmtDocs + ( docSetBaseAndIndent + $ docNonBottomSpacing + $ docLines + $ pure + <$> stmtDocs ) x | case x of - ListComp -> True + ListComp -> True MonadComp -> True - _ -> False + _ -> False -> do - stmtDocs <- docHandleComms stmtEpAnn $ - stmts `forM` docHandleListElemComms layoutStmt + stmtDocs <- + docHandleComms stmtEpAnn + $ stmts + `forM` docHandleListElemComms layoutStmt let hasComments = hasAnyCommentsBelow lexpr runFilteredAlternative $ do addAlternativeCond (not hasComments) $ docSeq [ -- TODO92 docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "[" , -- TODO92 docNodeAnnKW lexpr (Just AnnOpenS) $ - appSep - $ docForceSingleline - $ pure (List.last stmtDocs) + appSep $ docForceSingleline $ pure (List.last stmtDocs) , appSep $ docLit $ Text.pack "|" , docSeq - $ List.intersperse docCommaSep - $ (docForceSingleline . pure) <$> List.init stmtDocs + $ List.intersperse docCommaSep + $ (docForceSingleline . pure) + <$> List.init stmtDocs , docLit $ Text.pack " ]" ] addAlternative @@ -819,65 +743,59 @@ layoutExpr lexpr@(L _ expr) = do appSep $ docLit $ Text.pack "[" , docSetBaseY -- TODO92 $ docNodeAnnKW lexpr (Just AnnOpenS) - $ pure (List.last stmtDocs) + $ pure (List.last stmtDocs) ] (s1, sM) = case List.init stmtDocs of - (a: b) -> (a, b) - _ -> error "layoutExp: stmtDocs list too short" - line1 = - docCols ColListComp [appSep $ docLit $ Text.pack "|", pure s1] - lineM = sM <&> \d -> docCols ColListComp [docCommaSep, pure d] + (a : b) -> (a, b) + _ -> error "layoutExp: stmtDocs list too short" + line1 = docCols + ColListComp + [appSep $ docLit $ Text.pack "|", pure s1] + lineM = + sM <&> \d -> docCols ColListComp [docCommaSep, pure d] end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] + in + docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] _ -> do -- TODO unknownNodeError "HsDo{} unknown stmtCtx" lexpr ExplicitList listEpAnn elems@(_ : _) -> docHandleComms listEpAnn $ do - let posOpen = obtainAnnPos listEpAnn AnnOpenS + let posOpen = obtainAnnPos listEpAnn AnnOpenS let posClose = obtainAnnPos listEpAnn AnnCloseS - let openDoc = docHandleComms posOpen $ docLitS "[" + let openDoc = docHandleComms posOpen $ docLitS "[" let closeDoc = docHandleComms posClose $ docLitS "]" - elemDocs <- elems `forM` (shareDoc . docHandleListElemComms layoutExpr) + elemDocs <- docHandleListElemCommsProperPost layoutExpr elems let hasComments = hasAnyCommentsBelow lexpr case splitFirstLast elemDocs of - FirstLastEmpty -> docSeq - [ docLit $ Text.pack "[" - , closeDoc - ] - FirstLastSingleton e -> docAlt - [ docSeq - [ openDoc - , docForceSingleline e - , closeDoc - ] + FirstLastEmpty -> docSeq [docLit $ Text.pack "[", closeDoc] + FirstLastSingleton (_, e) -> docAlt + [ docSeq [openDoc, docForceSingleline e, closeDoc] , docSetBaseY $ docLines - [ docSeq - [ openDoc - , docSeparator - , docSetBaseY $ e - ] - , closeDoc - ] + [docSeq [openDoc, docSeparator, docSetBaseY $ e], closeDoc] ] - FirstLast e1 ems eN -> runFilteredAlternative $ do + FirstLast (_, e1) ems (finalCommaPos, eN) -> runFilteredAlternative $ do addAlternativeCond (not hasComments) - $ docSeq - $ [openDoc] - ++ List.intersperse - docCommaSep - (docForceSingleline - <$> (e1 : ems ++ [eN]) - ) - ++ [closeDoc] + $ docSeq + $ [openDoc, docForceSingleline e1] + ++ [ x + | (commaPos, e) <- ems + , x <- [docHandleComms commaPos docCommaSep, docForceSingleline e] + ] + ++ [ docHandleComms finalCommaPos docCommaSep + , docForceSingleline eN + , closeDoc] addAlternative - $ let - start = docCols ColList [appSep $ openDoc, e1] - linesM = ems <&> \d -> docCols ColList [docCommaSep, d] - lineN = docCols - ColList - [docCommaSep, eN] - in docSetBaseY $ - docLines $ [start] ++ linesM ++ [lineN] ++ [closeDoc] + $ let start = docCols ColList [appSep $ openDoc, e1] + linesM = ems <&> \(p, d) -> + docCols ColList [docHandleComms p docCommaSep, d] + lineN = docCols ColList + [docHandleComms finalCommaPos $ docCommaSep, eN] + in docSetBaseY + $ docLines + $ [start] + ++ linesM + ++ [lineN] + ++ [closeDoc] ExplicitList epAnn [] -> docHandleComms epAnn $ docLit $ Text.pack "[]" RecordCon epAnn lname fields -> docHandleComms epAnn $ do let (wrapOpen, wrapClose) = case epAnn of @@ -888,14 +806,22 @@ layoutExpr lexpr@(L _ expr) = do _ -> (id, id) fieldLayouter = \case FieldOcc _ lnameF -> docLit (lrdrNameToText lnameF) - XFieldOcc _ -> error "XFieldOcc" + XFieldOcc _ -> error "XFieldOcc" case fields of HsRecFields fs Nothing -> do let nameDoc = docHandleComms lname $ docLit $ lrdrNameToText lname - recordExpression False wrapOpen id wrapClose indentPolicy lexpr nameDoc fieldLayouter fs + recordExpression False + wrapOpen + id + wrapClose + indentPolicy + lexpr + nameDoc + fieldLayouter + fs HsRecFields [] (Just (L dotdotLoc 0)) -> do let wrapDotDot = docHandleComms dotdotLoc - let t = lrdrNameToText lname + let t = lrdrNameToText lname docHandleComms lname $ docSeq [ docLit t , docSeparator @@ -905,10 +831,19 @@ layoutExpr lexpr@(L _ expr) = do , docSeparator , wrapClose $ docLitS "}" ] - HsRecFields fs@(_ : _) (Just (L dotdotLoc dotdoti)) | dotdoti == length fs -> do - let nameDoc = docHandleComms lname $ docLit $ lrdrNameToText lname - let wrapDotDot = docHandleComms dotdotLoc - recordExpression True wrapOpen wrapDotDot wrapClose indentPolicy lexpr nameDoc fieldLayouter fs + HsRecFields fs@(_ : _) (Just (L dotdotLoc dotdoti)) + | dotdoti == length fs -> do + let nameDoc = docHandleComms lname $ docLit $ lrdrNameToText lname + let wrapDotDot = docHandleComms dotdotLoc + recordExpression True + wrapOpen + wrapDotDot + wrapClose + indentPolicy + lexpr + nameDoc + fieldLayouter + fs _ -> unknownNodeError "RecordCon with puns" lexpr RecordUpd epAnn rExpr (Left fields) -> docHandleComms epAnn $ do let (wrapOpen, wrapClose) = case epAnn of @@ -918,11 +853,19 @@ layoutExpr lexpr@(L _ expr) = do ) _ -> (id, id) let fieldLayouter = \case - Unambiguous _ n -> docLit (lrdrNameToText n) - Ambiguous _ n -> docLit (lrdrNameToText n) + Unambiguous _ n -> docLit (lrdrNameToText n) + Ambiguous _ n -> docLit (lrdrNameToText n) XAmbiguousFieldOcc _ -> error "XAmbiguousFieldOcc" rExprDoc <- shareDoc $ layoutExpr rExpr - recordExpression False wrapOpen id wrapClose indentPolicy lexpr rExprDoc fieldLayouter fields + recordExpression False + wrapOpen + id + wrapClose + indentPolicy + lexpr + rExprDoc + fieldLayouter + fields RecordUpd epAnn rExpr (Right fields) -> do let (wrapOpen, wrapClose) = case epAnn of EpAnn _ [open, close] _ -> @@ -936,12 +879,19 @@ layoutExpr lexpr@(L _ expr) = do docHandleComms flAnn $ docLitS $ FastString.unpackFS n L _ann (XHsFieldLabel _) -> error "XHsFieldLabel" let fieldLayouter = \case - FieldLabelStrings [] -> docEmpty + FieldLabelStrings [] -> docEmpty FieldLabelStrings [label] -> labelLayouter label - FieldLabelStrings labels -> docSeq - $ List.intersperse docCommaSep - $ map labelLayouter labels - recordExpression False wrapOpen id wrapClose indentPolicy lexpr rExprDoc fieldLayouter fields + FieldLabelStrings labels -> + docSeq $ List.intersperse docCommaSep $ map labelLayouter labels + recordExpression False + wrapOpen + id + wrapClose + indentPolicy + lexpr + rExprDoc + fieldLayouter + fields ExprWithTySig _ exp1 (HsWC _ typ1) -> do expDoc <- shareDoc $ layoutExpr exp1 typDoc <- shareDoc $ layoutSigType typ1 @@ -988,37 +938,33 @@ layoutExpr lexpr@(L _ expr) = do , docLit $ Text.pack "]" ] HsGetField _epAnn _exp1 _field -> do - let - labelLayouter label = case label of - L flAnn (HsFieldLabel _ (L _ n)) -> - docHandleComms flAnn $ docLitS $ FastString.unpackFS n - L _ann (XHsFieldLabel _) -> error "XHsFieldLabel" - gather - :: [ToBriDocM BriDocNumbered] - -> LHsExpr GhcPs - -> (LHsExpr GhcPs, [ToBriDocM BriDocNumbered]) - gather list = \case - L _ (HsGetField epAnn l r) -> gather - (docHandleComms epAnn $ labelLayouter r : list) l - x -> (x, list) - let (headE, paramEs) = gather - [] - lexpr + let labelLayouter label = case label of + L flAnn (HsFieldLabel _ (L _ n)) -> + docHandleComms flAnn $ docLitS $ FastString.unpackFS n + L _ann (XHsFieldLabel _) -> error "XHsFieldLabel" + gather + :: [ToBriDocM BriDocNumbered] + -> LHsExpr GhcPs + -> (LHsExpr GhcPs, [ToBriDocM BriDocNumbered]) + gather list = \case + L _ (HsGetField epAnn l r) -> + gather (docHandleComms epAnn $ labelLayouter r : list) l + x -> (x, list) + let (headE, paramEs) = gather [] lexpr expDoc <- shareDoc $ layoutExpr headE -- this only has single-line layout, afaik - docForceSingleline $ docSeq $ intersperse (docLitS ".") (expDoc: paramEs) + docForceSingleline $ docSeq $ intersperse (docLitS ".") (expDoc : paramEs) HsProjection epAnn (f1 :| fR) -> do - let - labelLayouter label = case label of - L flAnn (HsFieldLabel _ (L _ n)) -> - docHandleComms flAnn $ docLitS $ FastString.unpackFS n - L _ann (XHsFieldLabel _) -> error "XHsFieldLabel" + let labelLayouter label = case label of + L flAnn (HsFieldLabel _ (L _ n)) -> + docHandleComms flAnn $ docLitS $ FastString.unpackFS n + L _ann (XHsFieldLabel _) -> error "XHsFieldLabel" docForceSingleline $ docHandleComms epAnn $ docSeq - ( [ docLitS "(" ] - ++ [ doc | f <- f1:fR, doc <- [docLitS ".", labelLayouter f] ] - ++ [ docLitS ")" ] + ( [docLitS "("] + ++ [ doc | f <- f1 : fR, doc <- [docLitS ".", labelLayouter f] ] + ++ [docLitS ")"] ) - ArithSeq{} -> briDocByExactInlineOnly "ArithSeq" lexpr + ArithSeq{} -> briDocByExactInlineOnly "ArithSeq" lexpr HsBracket{} -> do -- TODO briDocByExactInlineOnly "HsBracket{}" lexpr @@ -1030,8 +976,8 @@ layoutExpr lexpr@(L _ expr) = do briDocByExactInlineOnly "HsTcBracketOut{}" lexpr HsSpliceE _ (HsQuasiQuote _ _ quoter _loc content) -> do allocateNode $ BDPlain - (Text.pack - $ "[" + ( Text.pack + $ "[" ++ showOutputable quoter ++ "|" ++ showOutputable content @@ -1062,6 +1008,7 @@ layoutExpr lexpr@(L _ expr) = do -- TODO briDocByExactInlineOnly "HsPragE{}" lexpr + recordExpression :: Bool -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) @@ -1088,8 +1035,10 @@ recordExpression True wrapO wrapDD wrapC _ _lexpr nameDoc _ [] = docSeq -- this , docSeparator , wrapC $ docLit $ Text.pack "}" ] -recordExpression dotdot wrapO wrapDD wrapC indentPolicy _lexpr nameDoc nameLayouter (rF1 : rFr) = do - let mkFieldTuple = \case +recordExpression dotdot wrapO wrapDD wrapC indentPolicy _lexpr nameDoc nameLayouter (rF1 : rFr) + = do + let + mkFieldTuple = \case L srcSpan (HsRecField fEpAnn (L _ nameThing) rFExpr pun) -> do let (posStart, _posSomething) = case fEpAnn of -- TODO92 not sure what posSomething is EpAnn anch [AddEpAnn _ span] _ -> @@ -1104,131 +1053,135 @@ recordExpression dotdot wrapO wrapDD wrapC indentPolicy _lexpr nameDoc nameLayou SrcSpanAnn EpAnnNotUsed _ -> Nothing fnameDoc <- shareDoc $ nameLayouter nameThing if pun - then pure $ Left (posStart, fnameDoc) - else do - expDoc <- - shareDoc $ docFlushCommsPost True posComma $ layoutExpr rFExpr - pure $ Right (posStart, fnameDoc, expDoc) - fieldTuple1 <- mkFieldTuple rF1 - fieldTupleR <- rFr `forM` mkFieldTuple - let fieldWiths - :: a - -> a - -> ( a - -> Either - (Maybe GHC.RealSrcLoc, ToBriDocM BriDocNumbered) - ( Maybe GHC.RealSrcLoc - , ToBriDocM BriDocNumbered - , ToBriDocM BriDocNumbered - ) - -> ToBriDocM BriDocNumbered - ) - -> [ToBriDocM BriDocNumbered] - fieldWiths extra1 extraR f = - f extra1 fieldTuple1 : map (f extraR) fieldTupleR - runFilteredAlternative $ do - -- container { fieldA = blub, fieldB = blub } - addAlternative $ docSeq - [ -- TODO92 docNodeAnnKW lexpr Nothing $ - appSep $ docForceSingleline nameDoc - , appSep $ wrapO $ docLit $ Text.pack "{" - , docSeq - $ List.intersperse docCommaSep - $ fieldWiths () () $ \() -> \case - Left (pos, fnameDoc) -> docHandleComms pos $ fnameDoc - Right (pos, fnameDoc, expDoc) -> docHandleComms pos $ docSeq - [ appSep $ fnameDoc - , appSep $ docLit $ Text.pack "=" - , docForceSingleline $ expDoc - ] - , if dotdot - then docSeq [docCommaSep, wrapDD $ docLit $ Text.pack "..", docSeparator] - else docSeparator - , wrapC $ docLit $ Text.pack "}" - ] - -- hanging single-line fields - -- container { fieldA = blub - -- , fieldB = blub - -- } - addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq - [ -- TODO92 docNodeAnnKW lexpr Nothing $ - docForceSingleline $ appSep nameDoc - , docSetBaseY - $ docLines - $ let - fieldLines = fieldWiths - (appSep $ wrapO $ docLit $ Text.pack "{") - docCommaSep - $ \prep -> \case - Left (pos, fnameDoc) -> docCols - ColRec - [ prep - , docHandleComms pos $ fnameDoc - ] - Right (pos, fnameDoc, expDoc) -> docCols - ColRec - [ prep - , docHandleComms pos $ appSep $ fnameDoc - , docSeq - [appSep $ docLit $ Text.pack "=", docForceSingleline expDoc] - ] - dotdotLine = if dotdot - then docCols - ColRec - [ -- TODO92 docNodeAnnKW lexpr (Just AnnOpenC) - docCommaSep - , wrapDD $ docLit $ Text.pack ".." + then pure $ Left (posStart, fnameDoc) + else do + expDoc <- + shareDoc $ docFlushCommsPost True posComma $ layoutExpr rFExpr + pure $ Right (posStart, fnameDoc, expDoc) + fieldTuple1 <- mkFieldTuple rF1 + fieldTupleR <- rFr `forM` mkFieldTuple + let fieldWiths + :: a + -> a + -> ( a + -> Either + (Maybe GHC.RealSrcLoc, ToBriDocM BriDocNumbered) + ( Maybe GHC.RealSrcLoc + , ToBriDocM BriDocNumbered + , ToBriDocM BriDocNumbered + ) + -> ToBriDocM BriDocNumbered + ) + -> [ToBriDocM BriDocNumbered] + fieldWiths extra1 extraR f = + f extra1 fieldTuple1 : map (f extraR) fieldTupleR + runFilteredAlternative $ do + -- container { fieldA = blub, fieldB = blub } + addAlternative $ docSeq + [ -- TODO92 docNodeAnnKW lexpr Nothing $ + appSep $ docForceSingleline nameDoc + , appSep $ wrapO $ docLit $ Text.pack "{" + , docSeq $ List.intersperse docCommaSep $ fieldWiths () () $ \() -> + \case + Left (pos, fnameDoc) -> docHandleComms pos $ fnameDoc + Right (pos, fnameDoc, expDoc) -> docHandleComms pos $ docSeq + [ appSep $ fnameDoc + , appSep $ docLit $ Text.pack "=" + , docForceSingleline $ expDoc ] - else -- TODO92 docNodeAnnKW lexpr (Just AnnOpenC) - docEmpty - lineN = wrapC $ docLit $ Text.pack "}" - in fieldLines ++ [dotdotLine, lineN] - ] - -- non-hanging with expressions placed to the right of the names - -- container - -- { fieldA = blub - -- , fieldB = potentially - -- multiline - -- } - addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (-- TODO92 docNodeAnnKW lexpr Nothing + , if dotdot + then docSeq + [docCommaSep, wrapDD $ docLit $ Text.pack "..", docSeparator] + else docSeparator + , wrapC $ docLit $ Text.pack "}" + ] + -- hanging single-line fields + -- container { fieldA = blub + -- , fieldB = blub + -- } + addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq + [ -- TODO92 docNodeAnnKW lexpr Nothing $ + docForceSingleline $ appSep nameDoc + , docSetBaseY + $ docLines + $ let + fieldLines = + fieldWiths (appSep $ wrapO $ docLit $ Text.pack "{") docCommaSep + $ \prep -> \case + Left (pos, fnameDoc) -> + docCols ColRec [prep, docHandleComms pos $ fnameDoc] + Right (pos, fnameDoc, expDoc) -> docCols + ColRec + [ prep + , docHandleComms pos $ appSep $ fnameDoc + , docSeq + [ appSep $ docLit $ Text.pack "=" + , docForceSingleline expDoc + ] + ] + dotdotLine = if dotdot + then docCols + ColRec + [ -- TODO92 docNodeAnnKW lexpr (Just AnnOpenC) + docCommaSep + , wrapDD $ docLit $ Text.pack ".." + ] + else -- TODO92 docNodeAnnKW lexpr (Just AnnOpenC) + docEmpty + lineN = wrapC $ docLit $ Text.pack "}" + in + fieldLines ++ [dotdotLine, lineN] + ] + -- non-hanging with expressions placed to the right of the names + -- container + -- { fieldA = blub + -- , fieldB = potentially + -- multiline + -- } + addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (-- TODO92 docNodeAnnKW lexpr Nothing nameDoc) - (docNonBottomSpacing - $ docLines - $ let - fieldLines = fieldWiths - (appSep $ wrapO $ docLit $ Text.pack "{") - docCommaSep - $ \prep -> \case - Left (pos, fnameDoc) -> docCols ColRec - [ prep - , docHandleComms pos $ fnameDoc + ( docNonBottomSpacing + $ docLines + $ let + fieldLines = + fieldWiths (appSep $ wrapO $ docLit $ Text.pack "{") docCommaSep + $ \prep -> \case + Left (pos, fnameDoc) -> + docCols ColRec [prep, docHandleComms pos $ fnameDoc] + Right (pos, fnameDoc, expDoc) -> docCols + ColRec + [ prep + , docHandleComms pos $ appSep $ fnameDoc + , runFilteredAlternative $ do + addAlternativeCond (indentPolicy == IndentPolicyFree) + $ do + docSeq + [ appSep $ docLit $ Text.pack "=" + , docSetBaseY expDoc + ] + addAlternative $ do + docSeq + [ appSep $ docLit $ Text.pack "=" + , docForceParSpacing expDoc + ] + addAlternative $ do + docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") expDoc + ] + dotdotLine = if dotdot + then docCols + ColRec + [ -- TODO92 docNodeAnnKW lexpr (Just AnnOpenC) + docCommaSep + , wrapDD $ docLit $ Text.pack ".." ] - Right (pos, fnameDoc, expDoc) -> docCols ColRec - [ prep - , docHandleComms pos $ appSep $ fnameDoc - , runFilteredAlternative $ do - addAlternativeCond (indentPolicy == IndentPolicyFree) $ do - docSeq [appSep $ docLit $ Text.pack "=", docSetBaseY expDoc] - addAlternative $ do - docSeq - [appSep $ docLit $ Text.pack "=", docForceParSpacing expDoc] - addAlternative $ do - docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") expDoc - ] - dotdotLine = if dotdot - then docCols - ColRec - [ -- TODO92 docNodeAnnKW lexpr (Just AnnOpenC) - docCommaSep - , wrapDD $ docLit $ Text.pack ".." - ] - else -- TODO92 docNodeAnnKW lexpr (Just AnnOpenC) - docEmpty - lineN = wrapC $ docLit $ Text.pack "}" - in fieldLines ++ [dotdotLine, lineN] - ) + else -- TODO92 docNodeAnnKW lexpr (Just AnnOpenC) + docEmpty + lineN = wrapC $ docLit $ Text.pack "}" + in + fieldLines ++ [dotdotLine, lineN] + ) litBriDoc :: HsLit GhcPs -> BriDocWrapped litBriDoc = \case diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/OpTree.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/OpTree.hs new file mode 100644 index 0000000..273c569 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/OpTree.hs @@ -0,0 +1,311 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.ToBriDoc.OpTree where + +import qualified Data.Text as Text +import GHC ( GenLocated(L) ) +import GHC.Hs +import GHC.Types.Fixity ( Fixity(Fixity) ) +import qualified GHC.Types.SrcLoc as GHC + +import Language.Haskell.Brittany.Internal.Components.BriDoc +import Language.Haskell.Brittany.Internal.Components.OpTree +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.S3_ToBriDocTools +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.ToBriDoc.Expr +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.ToBriDoc.Type + + +gatherOpTreeE + :: Bool + -> Bool + -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) + -> Maybe GHC.RealSrcLoc + -> Maybe GHC.RealSrcLoc + -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)] + -> LHsExpr GhcPs + -> ToBriDocM (OpTree, Bool) +gatherOpTreeE hasParen hasComms commWrap locOpen locClose opExprList = \case + (L _ (OpApp epAnn l1 op1 r1)) -> + gatherOpTreeE + hasParen + (hasComms || hasAnyCommentsBelow epAnn) + commWrap + locOpen + locClose + ((docHandleComms epAnn $ layoutExpr op1, layoutExpr r1) : opExprList) + l1 + (L _ (HsPar epAnn inner)) -> do + let AnnParen _ spanOpen spanClose = anns epAnn + let mergePoses locMay span = case locMay of + Nothing -> Just (epaLocationRealSrcSpanStart span) + Just loc -> Just (min (epaLocationRealSrcSpanStart span) loc) + (innerTree, innerHasComms) <- + gatherOpTreeE True + (hasComms || hasAnyCommentsBelow epAnn) + (commWrap . docHandleComms epAnn) + (mergePoses locOpen spanOpen) + (mergePoses locClose spanClose) + [] + inner + if null opExprList + then pure (innerTree, innerHasComms) + else do + numberedRights <- opExprList `forM` \(x, y) -> do + x' <- x + y' <- y + pure (x', y') + pure + $ ( OpUnknown hasParen locOpen locClose innerTree numberedRights + , innerHasComms + ) + final -> do + numberedLeft <- commWrap $ layoutExpr final + numberedRights <- opExprList `forM` \(x, y) -> do + x' <- x + y' <- y + pure (x', y') + pure + $ ( OpUnknown hasParen + locOpen + locClose + (OpLeaf $ numberedLeft) + numberedRights + , hasComms + ) + +gatherOpTreeT + :: Bool + -> Bool + -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) + -> Maybe GHC.RealSrcLoc + -> Maybe GHC.RealSrcLoc + -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)] + -> LHsType GhcPs + -> ToBriDocM (OpTree, Bool) +gatherOpTreeT hasParen hasComms commWrap locOpen locClose opExprList = \case + (L _ (HsOpTy NoExtField l1 op1 r1)) -> + gatherOpTreeT + hasParen + hasComms + commWrap + locOpen + locClose + ((docLit $ printRdrNameWithAnns op1, layoutType r1) : opExprList) + l1 + (L _ (HsParTy epAnn inner)) -> do + let AnnParen _ spanOpen spanClose = anns epAnn + let mergePoses locMay span = case locMay of + Nothing -> Just (epaLocationRealSrcSpanStart span) + Just loc -> Just (min (epaLocationRealSrcSpanStart span) loc) + (innerTree, innerHasComms) <- + gatherOpTreeT True + (hasComms || hasAnyCommentsBelow epAnn) + (commWrap . docHandleComms epAnn) + (mergePoses locOpen spanOpen) + (mergePoses locClose spanClose) + [] + inner + if null opExprList + then pure (innerTree, innerHasComms) + else do + numberedRights <- opExprList `forM` \(x, y) -> do + x' <- x + y' <- y + pure (x', y') + pure + $ ( OpUnknown hasParen locOpen locClose innerTree numberedRights + , innerHasComms + ) + final -> do + numberedLeft <- commWrap $ layoutType final + numberedRights <- opExprList `forM` \(x, y) -> do + x' <- x + y' <- y + pure (x', y') + pure + $ ( OpUnknown hasParen + locOpen + locClose + (OpLeaf $ numberedLeft) + numberedRights + , hasComms + ) + +processOpTree :: (OpTree, Bool) -> ToBriDocM BriDocNumbered +processOpTree (unknownTree, hasComments) = do + enabled <- askLayoutConf _lconfig_fixityAwareOps + refactorMode <- askLayoutConf _lconfig_operatorParenthesisRefactorMode + allowOpUnqualify <- askLayoutConf _lconfig_operatorAllowUnqualify + let (warns, balancedTree) = if enabled + then balanceOpTree allowOpUnqualify unknownTree + else ([], unknownTree) + mTell warns + let processedTree = case refactorMode of + PRMKeep -> balancedTree + PRMMinimize -> remSuperfluousParens 11 balancedTree + PRMMaximize -> addAllParens False balancedTree + -- tellDebugMess $ displayOpTree balancedTree + -- tellDebugMess $ displayOpTree processedTree + layoutOpTree (not hasComments) processedTree + +layoutOpTree :: Bool -> OpTree -> ToBriDocM BriDocNumbered +layoutOpTree allowSinglelinePar = \case + OpUnknown hasParen locO locC leftTree docOps -> do + let sharedOps = fmap (\(a, b) -> (pure a, pure b)) docOps + leftDoc <- layoutOpTree True leftTree + coreAlternative hasParen + locO + locC + Nothing + (pure leftDoc) + sharedOps + sharedOps + docForceSingleline + OpKnown hasParen locO locC fixity treeL docOps -> do + let Fixity _ _prec _ = fixity + docL <- shareDoc $ layoutOpTree True treeL + let flattenList ops = case ops of + [] -> pure [] + [(op, tree)] -> case treeL of + OpLeaf{} -> flattenInner op tree + _ -> do + treeDoc <- shareDoc $ layoutOpTree True tree + pure [(pure op, treeDoc)] + ((op1, tree1@OpLeaf{}) : tR) -> do + tree1Doc <- shareDoc $ layoutOpTree True tree1 + flattenRest <- flattenList tR + pure $ (pure op1, tree1Doc) : flattenRest + _ -> simpleTransform ops + flattenInner op = \case + OpKnown False _ _ _ innerL innerOps | isPrec0 fixity -> do + flattenList ((op, innerL) : innerOps) + tree -> do + treeDoc <- shareDoc $ layoutOpTree True tree + pure [(pure op, treeDoc)] + simpleTransform + :: [(BriDocNumbered, OpTree)] + -> ToBriDocM [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)] + simpleTransform = mapM $ \(op, subTree) -> do + subDoc <- shareDoc $ layoutOpTree True subTree + pure (pure op, subDoc) + sharedOpsFlat <- flattenList docOps + sharedOps <- simpleTransform docOps + coreAlternative hasParen + locO + locC + (Just fixity) + docL + sharedOps + sharedOpsFlat + docForceParSpacing + OpLeaf l -> pure l + where + isPrec0 = \case + Fixity _ prec _ -> prec == 0 + coreAlternative + :: Bool + -> Maybe GHC.RealSrcLoc + -> Maybe GHC.RealSrcLoc + -> Maybe Fixity + -> ToBriDocM BriDocNumbered + -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)] + -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)] + -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) + -> ToBriDocM BriDocNumbered + coreAlternative hasParen locO locC fixity docL sharedOps sharedOpsFlat lastWrap + = do + let wrapParenIfSl x inner = if x then wrapParenSl inner else inner + wrapParenSl inner = docAlt + [ docSeq + [ docLit $ Text.pack "(" + , docHandleComms locO $ docForceSingleline inner + , docHandleComms locC $ docLit $ Text.pack ")" + ] + , docLines + [ docSeq [docLitS "(", docHandleComms locO inner] + , docHandleComms locC $ docLit $ Text.pack ")" + ] + ] + wrapParenMlIf x innerHead innerLines = if x + then wrapParenMl innerHead innerLines + else docPar innerHead (docLines innerLines) + wrapParenMl innerHead innerLines = docSetBaseY $ docLines + ( [ docCols + ColOpPrefix + [ appSep $ docLit $ Text.pack "(" + , docHandleComms locO $ innerHead + ] + ] + ++ innerLines + ++ [docHandleComms locC $ docLit $ Text.pack ")"] + ) + + configAllowsParInsert <- askLayoutConf _lconfig_fixityBasedAddAlignParens + let allowParIns = configAllowsParInsert && case fixity of + Nothing -> False + Just (Fixity _ prec _) -> prec > 0 + + runFilteredAlternative $ do + -- > one + two + three + -- or + -- > one + two + case x of + -- > _ -> three + addAlternativeCond allowSinglelinePar $ wrapParenIfSl hasParen $ docSeq + ([docForceSingleline docL] ++ case splitFirstLast sharedOps of + FirstLastEmpty -> [] + FirstLastSingleton (od, ed) -> + [docSeparator, docForceSingleline od, docSeparator, lastWrap ed] + FirstLast (od1, ed1) ems (odN, edN) -> + ( [ docSeparator + , docForceSingleline od1 + , docSeparator + , docForceSingleline ed1 + ] + ++ join + [ [ docSeparator + , docForceSingleline od + , docSeparator + , docForceSingleline ed + ] + | (od, ed) <- ems + ] + ++ [ docSeparator + , docForceSingleline odN + , docSeparator + , lastWrap edN + ] + ) + ) + -- this case rather leads to some unfortunate layouting than to anything + -- useful; disabling for now. (it interfers with cols stuff.) + addAlternativeCond (not hasParen) $ docPar + (docHandleComms locO $ docForceSingleline $ docL) + (docFlushCommsPost False locC $ docLines $ sharedOps <&> \(od, ed) -> + docCols ColOpPrefix [appSep od, docForceSingleline ed] + ) + -- > ( one + -- > + two + -- > + three + -- > ) + addAlternativeCond (allowParIns && not hasParen) + $ docForceZeroAdd + $ wrapParenMl + (docSetBaseY docL) + (sharedOpsFlat <&> \(od, ed) -> + docCols ColOpPrefix [appSep od, docSetBaseY ed] + ) + -- > one + -- > + two + -- > + three + addAlternative + $ wrapParenMlIf + hasParen + -- ((if not hasParen then docAddBaseY BrIndentRegular else id) docL) + (if hasParen then docSetBaseY docL else docL) + (sharedOpsFlat <&> \(od, ed) -> + docCols ColOpPrefix [appSep od, docSetBaseY ed] + ) diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs index 3cdad5b..ea88739 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs @@ -17,6 +17,7 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Components.BriDoc import Language.Haskell.Brittany.Internal.Utils (FirstLastView(..), splitFirstLast) +import Language.Haskell.Brittany.Internal.ToBriDoc.OpTree @@ -262,8 +263,9 @@ layoutType ltype@(L _ typ) = docHandleComms ltype $ case typ of (docAddBaseY (BrIndentSpecial 2) line1) (docLines $ lines ++ [wrapEnd end]) ] - HsOpTy{} -> -- TODO - briDocByExactInlineOnly "HsOpTy{}" ltype + HsOpTy{} -> do + treeAndHasComms <- gatherOpTreeT False False id Nothing Nothing [] ltype + processOpTree treeAndHasComms -- HsOpTy typ1 opName typ2 -> do -- -- TODO: these need some proper fixing. precedences don't add up. -- -- maybe the parser just returns some trivial right recursion diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs-boot b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs-boot new file mode 100644 index 0000000..3d1d004 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs-boot @@ -0,0 +1,10 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.ToBriDoc.Type where + +import GHC.Hs + +import Language.Haskell.Brittany.Internal.Types + +layoutType :: ToBriDoc HsType diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/T1_Alt.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/T1_Alt.hs index b86e8e9..ccdd985 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/T1_Alt.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/T1_Alt.hs @@ -36,9 +36,10 @@ data VerticalSpacingPar data VerticalSpacing = VerticalSpacing - { _vs_sameLine :: !Int - , _vs_paragraph :: !VerticalSpacingPar - , _vs_parFlag :: !Bool + { _vs_sameLine :: !Int + , _vs_paragraph :: !VerticalSpacingPar + , _vs_parFlag :: !Bool + , _vs_onlyZeroAddInd :: !Bool } deriving (Eq, Show) @@ -54,6 +55,7 @@ data AltCurPos = AltCurPos { _acp_line :: Int -- chars in the current line , _acp_indent :: Int -- current indentation level , _acp_indentPrep :: Int -- indentChange affecting the next Par + , _acp_indentPrepForced :: Bool , _acp_forceMLFlag :: AltLineModeState } deriving Show @@ -99,7 +101,7 @@ transformAlts => BriDocNumbered -> MultiRWSS.MultiRWS r w s BriDoc transformAlts = - MultiRWSS.withMultiStateA (AltCurPos 0 0 0 AltLineModeStateNone) + MultiRWSS.withMultiStateA (AltCurPos 0 0 0 False AltLineModeStateNone) . Memo.startEvalMemoT . fmap unwrapBriDocNumbered . rec @@ -163,14 +165,18 @@ transformAlts = BDSeparator -> processSpacingSimple bdX $> bdX BDAddBaseY indent bd -> do acp <- mGet - indAdd <- fixIndentationForMultiple acp indent - mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd } + (indAdd, forced) <- fixIndentationForMultiple acp indent + mSet $ acp + { _acp_indentPrep = max (_acp_indentPrep acp) indAdd + , _acp_indentPrepForced = forced || _acp_indentPrepForced acp + } r <- rec bd acp' <- mGet mSet $ acp' { _acp_indent = _acp_indent acp } return $ case indent of BrIndentNone -> r BrIndentRegular -> reWrap $ BDAddBaseY (BrIndentSpecial indAdd) r + BrIndentRegularForce -> reWrap $ BDAddBaseY (BrIndentSpecial indAdd) r BrIndentSpecial i -> reWrap $ BDAddBaseY (BrIndentSpecial i) r BDBaseYPushCur bd -> do acp <- mGet @@ -188,16 +194,24 @@ transformAlts = BDPar indent sameLine indented -> do indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - let - indAdd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> indAmount - BrIndentSpecial i -> i acp <- mGet + let parentForced = _acp_indentPrepForced acp + let + (indAdd, forced) = case indent of + BrIndentNone -> (0 , parentForced) + BrIndentRegular -> (indAmount, parentForced) + BrIndentRegularForce -> (indAmount, True ) + BrIndentSpecial i -> (i , parentForced) let ind = _acp_indent acp + _acp_indentPrep acp + indAdd - mSet $ acp { _acp_indent = ind, _acp_indentPrep = 0 } + mSet $ acp + { _acp_indent = ind, _acp_indentPrep = 0 + , _acp_indentPrepForced = False + } sameLine' <- rec sameLine - mModify $ \acp' -> acp' { _acp_line = ind, _acp_indent = ind } + mModify $ \acp' -> acp' + { _acp_line = ind, _acp_indent = ind + , _acp_indentPrepForced = forced + } indented' <- rec indented return $ reWrap $ BDPar indent sameLine' indented' BDAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a @@ -214,12 +228,14 @@ transformAlts = acp <- mGet let lineCheck LineModeInvalid = False - lineCheck (LineModeValid (VerticalSpacing _ p _)) = - case _acp_forceMLFlag acp of - AltLineModeStateNone -> True - AltLineModeStateForceSL{} -> p == VerticalSpacingParNone - AltLineModeStateForceML{} -> p /= VerticalSpacingParNone - AltLineModeStateContradiction -> False + lineCheck (LineModeValid (VerticalSpacing _ p _ z)) = + let pRes = case _acp_forceMLFlag acp of + AltLineModeStateNone -> True + AltLineModeStateForceSL{} -> p == VerticalSpacingParNone + AltLineModeStateForceML{} -> p /= VerticalSpacingParNone + AltLineModeStateContradiction -> False + zRes = not z || not (_acp_indentPrepForced acp) + in pRes && zRes -- TODO: use COMPLETE pragma instead? lineCheck _ = error "ghc exhaustive check is insufficient" lconf <- _conf_layout <$> mAsk @@ -244,11 +260,14 @@ transformAlts = spacings <- alts `forM` getSpacings limit acp <- mGet let - lineCheck (VerticalSpacing _ p _) = case _acp_forceMLFlag acp of - AltLineModeStateNone -> True - AltLineModeStateForceSL{} -> p == VerticalSpacingParNone - AltLineModeStateForceML{} -> p /= VerticalSpacingParNone - AltLineModeStateContradiction -> False + lineCheck (VerticalSpacing _ p _ z) = + let pRes = case _acp_forceMLFlag acp of + AltLineModeStateNone -> True + AltLineModeStateForceSL{} -> p == VerticalSpacingParNone + AltLineModeStateForceML{} -> p /= VerticalSpacingParNone + AltLineModeStateContradiction -> False + zRes = not z || not (_acp_indentPrepForced acp) + in pRes && zRes lconf <- _conf_layout <$> mAsk let options = -- trace ("considering options:" ++ show (length alts, acp)) $ @@ -263,32 +282,27 @@ transformAlts = $ fromMaybe (-- trace ("choosing last") $ List.last alts) $ Data.List.Extra.firstJust (fmap snd) checkedOptions - BDForceMultiline bd -> do + BDForceAlt ForceMultiline bd -> do acp <- mGet - x <- do - mSet $ mergeLineMode acp (AltLineModeStateForceML False) - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDForceSingleline bd -> do + mSet $ mergeLineMode acp (AltLineModeStateForceML False) + x <- rec bd + mModify $ \acp' -> acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + pure $ x + BDForceAlt ForceSingleline bd -> do acp <- mGet - x <- do - mSet $ mergeLineMode acp AltLineModeStateForceSL - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x + mSet $ mergeLineMode acp AltLineModeStateForceSL + x <- rec bd + mModify $ \acp' -> acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + pure $ x BDForwardLineMode bd -> do acp <- mGet - x <- do - mSet $ acp - { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp - } - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x + mSet $ acp + { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp + } + x <- rec bd + mModify $ \acp' -> acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + pure $ x + BDForceAlt ForceZeroAdd bd -> rec bd BDExternal{} -> processSpacingSimple bdX $> bdX BDPlain{} -> processSpacingSimple bdX $> bdX BDQueueComments comms bd -> @@ -305,18 +319,23 @@ transformAlts = reWrap . BDFlushCommentsPost loc shouldMark <$> rec bd BDLines [] -> return $ reWrap BDEmpty -- evil transformation. or harmless. BDLines (l : lr) -> do - ind <- _acp_indent <$> mGet + initialAcp <- mGet l' <- rec l lr' <- lr `forM` \x -> do - mModify $ \acp -> acp { _acp_line = ind, _acp_indent = ind } + mModify $ \acp -> acp + { _acp_line = _acp_indent initialAcp + , _acp_indent = _acp_indent initialAcp + , _acp_indentPrepForced = _acp_indentPrepForced initialAcp + } rec x return $ reWrap $ BDLines (l' : lr') BDEnsureIndent indent bd -> do acp <- mGet - indAdd <- fixIndentationForMultiple acp indent + (indAdd, forced) <- fixIndentationForMultiple acp indent mSet $ acp { _acp_indentPrep = 0 -- TODO: i am not sure this is valid, in general. + , _acp_indentPrepForced = forced , _acp_indent = _acp_indent acp + indAdd , _acp_line = max (_acp_line acp) (_acp_indent acp + indAdd) -- we cannot use just _acp_line acp + indAdd because of the case @@ -331,10 +350,12 @@ transformAlts = BrIndentNone -> r BrIndentRegular -> reWrap $ BDEnsureIndent (BrIndentSpecial indAdd) r + BrIndentRegularForce -> + reWrap $ BDEnsureIndent (BrIndentSpecial indAdd) r BrIndentSpecial i -> reWrap $ BDEnsureIndent (BrIndentSpecial i) r - BDNonBottomSpacing _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd + BDForceAlt (NonBottomSpacing _) bd -> rec bd + BDForceAlt SetParSpacing bd -> rec bd + BDForceAlt ForceParSpacing bd -> rec bd BDDebug s bd -> do acp :: AltCurPos <- mGet tellDebugMess @@ -354,7 +375,7 @@ transformAlts = -> m () processSpacingSimple bd = getSpacing bd >>= \case LineModeInvalid -> error "processSpacingSimple inv" - LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do + LineModeValid (VerticalSpacing i VerticalSpacingParNone _ _) -> do acp <- mGet mSet $ acp { _acp_line = _acp_line acp + i } LineModeValid VerticalSpacing{} -> error "processSpacingSimple par" @@ -365,9 +386,9 @@ transformAlts = hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool - hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _) + hasSpace2 lconf (AltCurPos line _indent _ _ _) (VerticalSpacing sameLine VerticalSpacingParNone _ _) = line + sameLine <= confUnpack (_lconfig_cols lconf) - hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _) + hasSpace2 lconf (AltCurPos line indent indentPrep _ _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _ _) = line + sameLine <= confUnpack (_lconfig_cols lconf) @@ -375,7 +396,7 @@ transformAlts = + indentPrep + par <= confUnpack (_lconfig_cols lconf) - hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _) + hasSpace2 lconf (AltCurPos line _indent _ _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _ _) = line + sameLine <= confUnpack (_lconfig_cols lconf) getSpacing @@ -389,40 +410,45 @@ getSpacing !bridoc = rec bridoc rec (brDcId, brDc) = do config <- mAsk let colMax = config & _conf_layout & _lconfig_cols & confUnpack - result <- case brDc of + let indAmount = confUnpack $ _lconfig_indentAmount $ _conf_layout $ config + result :: LineModeValidity VerticalSpacing <- case brDc of -- BDWrapAnnKey _annKey bd -> rec bd BDEmpty -> - return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False - BDLit t -> return $ LineModeValid $ VerticalSpacing - (Text.length t) - VerticalSpacingParNone - False + pure + $ LineModeValid + $ VerticalSpacing 0 VerticalSpacingParNone False False + BDLit t -> + pure + $ LineModeValid + $ VerticalSpacing (Text.length t) VerticalSpacingParNone False False BDSeq list -> sumVs <$> rec `mapM` list BDCols _sig list -> sumVs <$> rec `mapM` list BDSeparator -> - return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False + pure + $ LineModeValid + $ VerticalSpacing 1 VerticalSpacingParNone False False BDAddBaseY indent bd -> do mVs <- rec bd - return $ mVs <&> \vs -> vs - { _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> - VerticalSpacingParAlways $ case indent of - BrIndentNone -> i - BrIndentRegular -> - i - + (confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of - BrIndentNone -> i - BrIndentRegular -> - i + (confUnpack $ _lconfig_indentAmount $ _conf_layout $ config) - BrIndentSpecial j -> i + j - } + pure + [ vs + { _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i -> + VerticalSpacingParAlways $ case indent of + BrIndentNone -> i + BrIndentRegular -> i + indAmount + BrIndentRegularForce -> i + indAmount + BrIndentSpecial j -> i + j + VerticalSpacingParSome i -> + VerticalSpacingParSome $ case indent of + BrIndentNone -> i + BrIndentRegular -> i + indAmount + BrIndentRegularForce -> i + indAmount + BrIndentSpecial j -> i + j + } + | vs <- mVs + , indent == BrIndentNone || _vs_onlyZeroAddInd vs == False + ] BDBaseYPushCur bd -> do mVs <- rec bd return $ mVs <&> \vs -> vs @@ -446,8 +472,8 @@ getSpacing !bridoc = rec bridoc mVs <- rec sameLine mIndSp <- rec indented return - $ [ VerticalSpacing lsp pspResult parFlagResult - | VerticalSpacing lsp mPsp _ <- mVs + $ [ VerticalSpacing lsp pspResult parFlagResult False -- TODO92 should we turn this on? + | VerticalSpacing lsp mPsp _ _ <- mVs , indSp <- mIndSp , lineMax <- getMaxVS $ mIndSp , let @@ -468,49 +494,59 @@ getSpacing !bridoc = rec bridoc BDPar{} -> error "BDPar with indent in getSpacing" BDAlt [] -> error "empty BDAlt" BDAlt (alt : _) -> rec alt - BDForceMultiline bd -> do + BDForceAlt ForceMultiline bd -> do mVs <- rec bd return $ mVs >>= _vs_paragraph .> \case VerticalSpacingParNone -> LineModeInvalid _ -> mVs - BDForceSingleline bd -> do + BDForceAlt ForceSingleline bd -> do mVs <- rec bd return $ mVs >>= _vs_paragraph .> \case VerticalSpacingParNone -> mVs _ -> LineModeInvalid + BDForceAlt ForceZeroAdd bd -> do + mVs <- rec bd + pure $ [ vs { _vs_onlyZeroAddInd = True } | vs <- mVs ] BDForwardLineMode bd -> rec bd BDExternal _ txt -> return $ LineModeValid $ case Text.lines txt of - [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False - _ -> VerticalSpacing 999 VerticalSpacingParNone False + [t] -> + VerticalSpacing (Text.length t) VerticalSpacingParNone False False + _ -> VerticalSpacing 999 VerticalSpacingParNone False False BDPlain txt -> return $ LineModeValid $ case Text.lines txt of - [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False - _ -> VerticalSpacing 999 VerticalSpacingParNone False + [t] -> + VerticalSpacing (Text.length t) VerticalSpacingParNone False False + _ -> VerticalSpacing 999 VerticalSpacingParNone False False BDQueueComments _comms bd -> rec bd BDFlushCommentsPrior _loc bd -> rec bd BDFlushCommentsPost _loc _shouldMark bd -> rec bd BDEntryDelta _dp bd -> rec bd BDLines [] -> - return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False + pure + $ LineModeValid + $ VerticalSpacing 0 VerticalSpacingParNone False False + -- TODO92 should we set _vs_onlyZeroAddInd here too? + -- did not do that before, but it makes sense for lines.. BDLines (l1 : lR) -> do mVs <- rec l1 mVRs <- rec `mapM` lR let lSps = mVs : mVRs return - $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False - | VerticalSpacing lsp _ _ <- mVs + $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False False + -- TODO92 should we set _vs_onlyZeroAddInd here too? + -- did not do that before, but it makes sense for lines.. + | VerticalSpacing lsp _ _ _ <- mVs , lineMax <- getMaxVS $ maxVs $ lSps ] BDEnsureIndent indent bd -> do mVs <- rec bd - let - addInd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> - confUnpack $ _lconfig_indentAmount $ _conf_layout $ config - BrIndentSpecial i -> i - return $ mVs <&> \(VerticalSpacing lsp psp pf) -> - VerticalSpacing (lsp + addInd) psp pf - BDNonBottomSpacing b bd -> do + let addInd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> indAmount + BrIndentRegularForce -> indAmount + BrIndentSpecial i -> i + return $ mVs <&> \(VerticalSpacing lsp psp pf _) -> + VerticalSpacing (lsp + addInd) psp pf False + BDForceAlt (NonBottomSpacing b) bd -> do mVs <- rec bd return $ mVs <|> LineModeValid (VerticalSpacing @@ -520,11 +556,12 @@ getSpacing !bridoc = rec bridoc else VerticalSpacingParAlways colMax ) False + False ) - BDSetParSpacing bd -> do + BDForceAlt SetParSpacing bd -> do mVs <- rec bd return $ mVs <&> \vs -> vs { _vs_parFlag = True } - BDForceParSpacing bd -> do + BDForceAlt ForceParSpacing bd -> do mVs <- rec bd return $ [ vs @@ -541,12 +578,12 @@ getSpacing !bridoc = rec bridoc ++ "): mVs=" ++ show r return r - return result + pure result maxVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing maxVs = foldl' (liftM2 - (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing + (\(VerticalSpacing x1 x2 _ _) (VerticalSpacing y1 y2 _ _) -> VerticalSpacing (max x1 y1) (case (x2, y2) of (x, VerticalSpacingParNone) -> x @@ -561,28 +598,31 @@ getSpacing !bridoc = rec bridoc VerticalSpacingParSome $ max x y ) False + False ) ) - (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False) + (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False False) sumVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing sumVs sps = foldl' (liftM2 go) initial sps where - go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing - (x1 + y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i + j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ i + j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i + j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ x + y - ) - x3 + go (VerticalSpacing x1 x2 x3 x4) (VerticalSpacing y1 y2 _ y4) = + VerticalSpacing + (x1 + y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i + j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ i + j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i + j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + VerticalSpacingParSome $ x + y + ) + x3 + (x4 || y4) singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone singleline _ = False isPar (LineModeValid x) = _vs_parFlag x @@ -590,9 +630,10 @@ getSpacing !bridoc = rec bridoc parFlag = case sps of [] -> True _ -> all singleline (List.init sps) && isPar (List.last sps) - initial = LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone parFlag + initial = + LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone parFlag False getMaxVS :: LineModeValidity VerticalSpacing -> LineModeValidity Int - getMaxVS = fmap $ \(VerticalSpacing x1 x2 _) -> x1 `max` case x2 of + getMaxVS = fmap $ \(VerticalSpacing x1 x2 _ _) -> x1 `max` case x2 of VerticalSpacingParSome i -> i VerticalSpacingParNone -> 0 VerticalSpacingParAlways i -> i @@ -621,7 +662,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc config <- mAsk let colMax = config & _conf_layout & _lconfig_cols & confUnpack let - hasOkColCount (VerticalSpacing lsp psp _) = lsp <= colMax && case psp of + hasOkColCount (VerticalSpacing lsp psp _ _) = lsp <= colMax && case psp of VerticalSpacingParNone -> True VerticalSpacingParSome i -> i <= colMax VerticalSpacingParAlways{} -> True @@ -638,6 +679,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc let allowHangingQuasiQuotes = config & _conf_layout & _lconfig_allowHangingQuasiQuotes & confUnpack + let indAmount = confUnpack $ _lconfig_indentAmount $ _conf_layout $ config let -- this is like List.nub, with one difference: if two elements -- are unequal only in _vs_paragraph, with both ParAlways, we -- treat them like equals and replace the first occurence with the @@ -690,12 +732,14 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc . preFilterLimit result <- case brdc of -- BDWrapAnnKey _annKey bd -> rec bd - BDEmpty -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] - BDLit t -> - return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] + BDEmpty -> return $ [VerticalSpacing 0 VerticalSpacingParNone False False] + BDLit t -> do + let l = Text.length t + pure $ [VerticalSpacing l VerticalSpacingParNone False False] BDSeq list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list BDCols _sig list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list - BDSeparator -> return $ [VerticalSpacing 1 VerticalSpacingParNone False] + BDSeparator -> + pure $ [VerticalSpacing 1 VerticalSpacingParNone False False] BDAddBaseY indent bd -> do mVs <- rec bd return $ mVs <&> \vs -> vs @@ -704,18 +748,13 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of BrIndentNone -> i - BrIndentRegular -> - i - + (confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) + BrIndentRegular -> i + indAmount + BrIndentRegularForce -> i + indAmount BrIndentSpecial j -> i + j VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of BrIndentNone -> i - BrIndentRegular -> - i + (confUnpack $ _lconfig_indentAmount $ _conf_layout $ config) + BrIndentRegular -> i + indAmount + BrIndentRegularForce -> i + indAmount BrIndentSpecial j -> i + j } BDBaseYPushCur bd -> do @@ -744,7 +783,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc mVss <- filterAndLimit <$> rec sameLine indSps <- filterAndLimit <$> rec indented let mVsIndSp = take limit $ [ (x, y) | x <- mVss, y <- indSps ] - return $ mVsIndSp <&> \(VerticalSpacing lsp mPsp _, indSp) -> + return $ mVsIndSp <&> \(VerticalSpacing lsp mPsp _ _, indSp) -> VerticalSpacing lsp (case mPsp of @@ -760,6 +799,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc == VerticalSpacingParNone && _vs_parFlag indSp ) + False -- TODO92 should we turn this on? BDPar{} -> error "BDPar with indent in getSpacing" BDAlt [] -> error "empty BDAlt" @@ -767,31 +807,35 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc BDAlt alts -> do r <- rec `mapM` alts return $ filterAndLimit =<< r - BDForceMultiline bd -> do + BDForceAlt ForceMultiline bd -> do mVs <- filterAndLimit <$> rec bd return $ filter ((/= VerticalSpacingParNone) . _vs_paragraph) mVs - BDForceSingleline bd -> do + BDForceAlt ForceSingleline bd -> do mVs <- filterAndLimit <$> rec bd return $ filter ((== VerticalSpacingParNone) . _vs_paragraph) mVs BDForwardLineMode bd -> rec bd - BDExternal _ txt | [t] <- Text.lines txt -> - return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] + BDExternal _ txt | [t] <- Text.lines txt -> do + let l = Text.length t + pure $ [VerticalSpacing l VerticalSpacingParNone False False] BDExternal{} -> return $ [] -- yes, we just assume that we cannot properly layout -- this. - BDPlain t -> return - [ case Text.lines t of - [] -> VerticalSpacing 0 VerticalSpacingParNone False - [t1] -> - VerticalSpacing (Text.length t1) VerticalSpacingParNone False - (t1 : _) -> - VerticalSpacing (Text.length t1) (VerticalSpacingParAlways 0) True - | allowHangingQuasiQuotes - ] + BDPlain t -> do + let tl = Text.length + pure + [ case Text.lines t of + [] -> VerticalSpacing 0 VerticalSpacingParNone False False + [t1] -> + VerticalSpacing (tl t1) VerticalSpacingParNone False False + (t1 : _) -> + VerticalSpacing (tl t1) (VerticalSpacingParAlways 0) True False + | allowHangingQuasiQuotes + ] BDQueueComments _comms bd -> rec bd BDFlushCommentsPrior _loc bd -> rec bd BDFlushCommentsPost _loc _shouldMark bd -> rec bd BDEntryDelta _dp bd -> rec bd - BDLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] + BDLines [] -> + pure $ [VerticalSpacing 0 VerticalSpacingParNone False False] BDLines ls@(_ : _) -> do -- we simply assume that lines is only used "properly", i.e. in -- such a way that the first line can be treated "as a part of the @@ -802,7 +846,10 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc let worbled = fmap reverse $ sequence $ reverse $ lSpss sumF lSps@(lSp1 : _) = - VerticalSpacing (_vs_sameLine lSp1) (spMakePar $ maxVs lSps) False + VerticalSpacing (_vs_sameLine lSp1) + (spMakePar $ maxVs lSps) + False + False -- TODO92 sumF [] = error $ "should not happen. if my logic does not fail" @@ -824,12 +871,12 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc let addInd = case indent of BrIndentNone -> 0 - BrIndentRegular -> - confUnpack $ _lconfig_indentAmount $ _conf_layout $ config + BrIndentRegular -> indAmount + BrIndentRegularForce -> indAmount BrIndentSpecial i -> i - return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> - VerticalSpacing (lsp + addInd) psp parFlag - BDNonBottomSpacing b bd -> do + return $ mVs <&> \(VerticalSpacing lsp psp parFlag _) -> + VerticalSpacing (lsp + addInd) psp parFlag False + BDForceAlt (NonBottomSpacing b) bd -> do -- TODO: the `b` flag is an ugly hack, but I was not able to make -- all tests work without it. It should be possible to have -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this @@ -844,6 +891,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc else VerticalSpacingParAlways colMax ) False + False ] else mVs <&> \vs -> vs { _vs_sameLine = min colMax (_vs_sameLine vs) @@ -884,16 +932,19 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc -- False) -- mVs -- ] - BDSetParSpacing bd -> do + BDForceAlt SetParSpacing bd -> do mVs <- rec bd return $ mVs <&> \vs -> vs { _vs_parFlag = True } - BDForceParSpacing bd -> do + BDForceAlt ForceParSpacing bd -> do mVs <- preFilterLimit <$> rec bd return $ [ vs | vs <- mVs , _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] + BDForceAlt ForceZeroAdd bd -> do + mVs <- preFilterLimit <$> rec bd + pure [ vs { _vs_onlyZeroAddInd = True } | vs <- mVs ] BDDebug s bd -> do r <- rec bd tellDebugMess @@ -907,7 +958,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc return result maxVs :: [VerticalSpacing] -> VerticalSpacing maxVs = foldl' - (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing + (\(VerticalSpacing x1 x2 _ _) (VerticalSpacing y1 y2 _ _) -> VerticalSpacing (max x1 y1) (case (x2, y2) of (x, VerticalSpacingParNone) -> x @@ -922,63 +973,73 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc VerticalSpacingParSome $ max x y ) False + False ) - (VerticalSpacing 0 VerticalSpacingParNone False) + (VerticalSpacing 0 VerticalSpacingParNone False False) sumVs :: [VerticalSpacing] -> VerticalSpacing sumVs sps = foldl' go initial sps where - go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing - (x1 + y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i + j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ i + j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i + j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ x + y - ) - x3 + go (VerticalSpacing x1 x2 x3 x4) (VerticalSpacing y1 y2 _ y4) = + VerticalSpacing + (x1 + y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i + j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ i + j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i + j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + VerticalSpacingParSome $ x + y + ) + x3 + (x4 || y4) singleline x = _vs_paragraph x == VerticalSpacingParNone isPar x = _vs_parFlag x parFlag = case sps of [] -> True _ -> all singleline (List.init sps) && isPar (List.last sps) - initial = VerticalSpacing 0 VerticalSpacingParNone parFlag + initial = VerticalSpacing 0 VerticalSpacingParNone parFlag False getMaxVS :: VerticalSpacing -> Int - getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of + getMaxVS (VerticalSpacing x1 x2 _ _) = x1 `max` case x2 of VerticalSpacingParSome i -> i VerticalSpacingParNone -> 0 VerticalSpacingParAlways i -> i spMakePar :: VerticalSpacing -> VerticalSpacingPar - spMakePar (VerticalSpacing x1 x2 _) = case x2 of + spMakePar (VerticalSpacing x1 x2 _ _) = case x2 of VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i VerticalSpacingParNone -> VerticalSpacingParSome $ x1 VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i fixIndentationForMultiple - :: (MonadMultiReader (CConfig Identity) m) => AltCurPos -> BrIndent -> m Int + :: (MonadMultiReader (CConfig Identity) m) + => AltCurPos + -> BrIndent + -> m (Int, Bool) fixIndentationForMultiple acp indent = do indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack let - indAddRaw = case indent of - BrIndentNone -> 0 - BrIndentRegular -> indAmount - BrIndentSpecial i -> i + (indAddRaw, strongFlag) = case indent of + BrIndentNone -> (0, False) + BrIndentRegular -> (indAmount, False) + BrIndentRegularForce -> (indAmount, True) + BrIndentSpecial i -> (i, False) -- for IndentPolicyMultiple, we restrict the amount of added -- indentation in such a manner that we end up on a multiple of the -- base indentation. indPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - pure $ if indPolicy == IndentPolicyMultiple - then - let - indAddMultiple1 = - indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount) - indAddMultiple2 = if indAddMultiple1 <= 0 - then indAddMultiple1 + indAmount - else indAddMultiple1 - in indAddMultiple2 - else indAddRaw + pure + $ ( if indPolicy == IndentPolicyMultiple + then + let + indAddMultiple1 = + indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount) + indAddMultiple2 = if indAddMultiple1 <= 0 + then indAddMultiple1 + indAmount + else indAddMultiple1 + in indAddMultiple2 + else indAddRaw + , strongFlag + ) diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/T2_Floating.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/T2_Floating.hs index daf2fa5..9309a08 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/T2_Floating.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/T2_Floating.hs @@ -5,8 +5,11 @@ module Language.Haskell.Brittany.Internal.Transformations.T2_Floating where import qualified Data.Generics.Uniplate.Direct as Uniplate import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Components.BriDoc +import GHC ( GenLocated(L) ) + +import Language.Haskell.Brittany.Internal.Components.BriDoc +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.Utils @@ -83,7 +86,7 @@ transformSimplifyFloating = stepBO .> stepFull descendQueueComments = transformDownMay $ \case -- queue comments floating in BDQueueComments comms1 (BDQueueComments comms2 x) -> - Just $ BDQueueComments (comms1 ++ comms2) x + Just $ BDQueueComments (mergeOn (\(L l _) -> l) comms1 comms2) x BDQueueComments comms1 (BDPar ind line indented) -> Just $ BDPar ind (BDQueueComments comms1 line) indented BDQueueComments comms1 (BDSeq (l : lr)) -> @@ -131,11 +134,11 @@ transformSimplifyFloating = stepBO .> stepFull descendAddB = transformDownMay $ \case BDAddBaseY BrIndentNone x -> Just x -- AddIndent floats into Lines. - BDAddBaseY indent (BDLines lines) -> - Just $ BDLines $ BDAddBaseY indent <$> lines + BDAddBaseY _ind (BDLines lines) -> + Just $ BDLines $ lines -- AddIndent floats into last column - BDAddBaseY indent (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] + BDAddBaseY ind (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAddBaseY ind $ List.last cols] -- merge AddIndent and Par BDAddBaseY ind1 (BDPar ind2 line indented) -> Just $ BDPar (mergeIndents ind1 ind2) line indented @@ -148,8 +151,8 @@ transformSimplifyFloating = stepBO .> stepFull BDAddBaseY ind (BDSeq list) -> Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] BDAddBaseY _ lit@BDLit{} -> Just $ lit - BDAddBaseY ind (BDBaseYPushCur x) -> - Just $ BDBaseYPushCur (BDAddBaseY ind x) + BDAddBaseY _ind (BDBaseYPushCur x) -> + Just $ BDBaseYPushCur x -- TODO92 We have several rules here in conflict with each other. -- Unless I forget some detail related to some elements being able -- to float in further, we probably should define some @@ -193,19 +196,19 @@ transformSimplifyFloating = stepBO .> stepFull -- copying them here (incompletely). BDAddBaseY BrIndentNone x -> Just $ x -- AddIndent floats into Lines. - BDAddBaseY indent (BDLines lines) -> - Just $ BDLines $ BDAddBaseY indent <$> lines + BDAddBaseY _ind (BDLines lines) -> + Just $ BDLines lines -- AddIndent floats into last column - BDAddBaseY indent (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] + BDAddBaseY ind (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAddBaseY ind $ List.last cols] BDAddBaseY ind (BDSeq list) -> Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] -- merge AddIndent and Par BDAddBaseY ind1 (BDPar ind2 line indented) -> Just $ BDPar (mergeIndents ind1 ind2) line indented BDAddBaseY _ lit@BDLit{} -> Just $ lit - BDAddBaseY ind (BDBaseYPushCur x) -> - Just $ BDBaseYPushCur (BDAddBaseY ind x) + BDAddBaseY _ind (BDBaseYPushCur x) -> + Just $ BDBaseYPushCur x -- EnsureIndent float-in -- BDEnsureIndent indent (BDCols sig (col:colr)) -> -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/T4_Columns.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/T4_Columns.hs index fab8d20..f0256aa 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/T4_Columns.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/T4_Columns.hs @@ -129,8 +129,7 @@ transformSimplifyColumns = Uniplate.rewrite $ \case BDIndentLevelPop{} -> Nothing BDPar{} -> Nothing BDAlt{} -> Nothing - BDForceMultiline{} -> Nothing - BDForceSingleline{} -> Nothing + BDForceAlt{} -> Nothing BDForwardLineMode{} -> Nothing BDExternal{} -> Nothing BDPlain{} -> Nothing @@ -140,7 +139,4 @@ transformSimplifyColumns = Uniplate.rewrite $ \case BDFlushCommentsPost{} -> Nothing BDEntryDelta{} -> Nothing BDEnsureIndent{} -> Nothing - BDSetParSpacing{} -> Nothing - BDForceParSpacing{} -> Nothing BDDebug{} -> Nothing - BDNonBottomSpacing _ x -> Just x diff --git a/source/library/Language/Haskell/Brittany/Internal/Utils.hs b/source/library/Language/Haskell/Brittany/Internal/Utils.hs index ec86c02..238e425 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Utils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Utils.hs @@ -20,7 +20,7 @@ import qualified GHC.Types.Name.Reader as RdrName (rdrNameOcc) import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Utils.Outputable as GHC import qualified GHC.Parser.Annotation as GHC -import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils +-- import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils import qualified Text.PrettyPrint as PP import qualified Data.Semigroup as Semigroup import qualified System.IO.Unsafe as Unsafe @@ -108,7 +108,6 @@ customLayouterNoSrcSpansF layoutF = `extQ` internalLayouterSrcSpan `extQ` internalLayouterRdrName `extQ` realSrcSpan - `extQ` deltaComment `extQ` anchored `ext1Q` srcSpanAnn -- `ext2Q` located @@ -122,9 +121,9 @@ customLayouterNoSrcSpansF layoutF = anchored (GHC.Anchor _ op) = f op srcSpanAnn :: forall a . Data a => GHC.SrcSpanAnn' a -> NodeLayouter srcSpanAnn (GHC.SrcSpanAnn ann _loc) = f ann - deltaComment :: GHC.LEpaComment -> NodeLayouter - deltaComment (GHC.L anchor (GHC.EpaComment token prior)) = - f (GHC.L (ExactPrint.Utils.ss2deltaEnd prior (GHC.anchor anchor)) token) + -- deltaComment :: GHC.LEpaComment -> NodeLayouter + -- deltaComment (GHC.L anchor (GHC.EpaComment token prior)) = + -- f (GHC.L (ExactPrint.Utils.ss2deltaEnd prior (GHC.anchor anchor)) token) -- located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter -- located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a -- where @@ -143,11 +142,34 @@ customLayouterNoAnnsF layoutF = `extQ` internalLayouterOccName `extQ` internalLayouterSrcSpan `extQ` internalLayouterRdrName + `extQ` realSrcSpan + `extQ` realSrcLoc `ext2Q` located + `extQ` lepaComment where DataToLayouter f = defaultLayouterF layoutF located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter located (GHC.L _ss a) = runDataToLayouter layoutF a + lepaComment :: GHC.LEpaComment -> NodeLayouter + lepaComment (GHC.L anchor (GHC.EpaComment token _)) = f + ( token + , GHC.srcSpanStartLine (GHC.anchor anchor) + , GHC.srcSpanStartCol (GHC.anchor anchor) + , GHC.srcSpanEndLine (GHC.anchor anchor) + , GHC.srcSpanEndCol (GHC.anchor anchor) + ) + realSrcSpan :: GHC.RealSrcSpan -> NodeLayouter + realSrcSpan span = internalLayouterSimple + (show + ( GHC.srcSpanStartLine span + , GHC.srcSpanStartCol span + , GHC.srcSpanEndLine span + , GHC.srcSpanEndCol span + ) + ) + realSrcLoc :: GHC.RealSrcLoc -> NodeLayouter + realSrcLoc loc = + internalLayouterSimple (show (GHC.srcLocLine loc, GHC.srcLocCol loc)) internalLayouterSimple :: String -> NodeLayouter internalLayouterSimple s = NodeLayouter (length s) False (const $ PP.text s) @@ -248,9 +270,9 @@ briDocToDoc :: BriDoc -> PP.Doc briDocToDoc = astToDoc . removeAnnotations where removeAnnotations = Uniplate.transform $ \case - BDFlushCommentsPrior _ x -> x - BDFlushCommentsPost _ _ x -> x - BDQueueComments _ x -> x + -- BDFlushCommentsPrior _ x -> x + -- BDFlushCommentsPost _ _ x -> x + -- BDQueueComments _ x -> x x -> x briDocToDocWithAnns :: BriDoc -> PP.Doc @@ -305,3 +327,11 @@ traceIfDumpConf s accessor val = do Unsafe.unsafePerformIO $ do f ("---- " ++ s ++ " ----\n" ++ show val) pure $ pure () + +mergeOn :: Ord b => (a -> b) -> [a] -> [a] -> [a] +mergeOn _f xs [] = xs +mergeOn _f [] ys = ys +mergeOn f xs@(x:xr) ys@(y:yr) + | f x <= f y = x : mergeOn f xr ys + | otherwise = y : mergeOn f xs yr + diff --git a/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/AlignmentAlgo.hs b/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/AlignmentAlgo.hs index 5cfa242..dfd91b4 100644 --- a/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/AlignmentAlgo.hs +++ b/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/AlignmentAlgo.hs @@ -402,8 +402,7 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc BDIndentLevelPop bd -> rec bd BDPar _ line _ -> rec line BDAlt{} -> error "briDocLineLength BDAlt" - BDForceMultiline bd -> rec bd - BDForceSingleline bd -> rec bd + BDForceAlt _ bd -> rec bd BDForwardLineMode bd -> rec bd BDExternal _ t -> return $ Text.length t BDPlain t -> return $ Text.length t @@ -416,9 +415,6 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc BDEntryDelta _dp bd -> rec bd BDLines [] -> error "briDocLineLength BDLines []" BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing _ bd -> rec bd BDDebug _ bd -> rec bd briDocIsMultiLine :: BriDoc -> Bool @@ -437,8 +433,7 @@ briDocIsMultiLine briDoc = rec briDoc BDIndentLevelPop bd -> rec bd BDPar{} -> True BDAlt{} -> error "briDocIsMultiLine BDAlt" - BDForceMultiline _ -> True - BDForceSingleline bd -> rec bd + BDForceAlt _ bd -> rec bd BDForwardLineMode bd -> rec bd BDExternal _ t | [_] <- Text.lines t -> False BDExternal{} -> True @@ -452,9 +447,6 @@ briDocIsMultiLine briDoc = rec briDoc BDLines [_] -> False BDLines [] -> error "briDocIsMultiLine BDLines []" BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing _ bd -> rec bd BDDebug _ bd -> rec bd briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo diff --git a/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Operators.hs b/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Operators.hs index 6117fc2..65d2dfe 100644 --- a/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Operators.hs +++ b/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Operators.hs @@ -285,7 +285,7 @@ layoutBaseYPushCur = do , _lstate_plannedSpace state ) layoutBaseYPushInternal $ case _lstate_plannedSpace state of - PlannedNone -> _lstate_curY state + PlannedNone -> _lstate_curY state PlannedSameline i -> _lstate_curY state + i PlannedNewline _l -> lstate_baseY state PlannedDelta _l i -> i diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs index 63636ac..3604b81 100644 --- a/source/test-suite/Main.hs +++ b/source/test-suite/Main.hs @@ -5,12 +5,12 @@ import Data.Coerce (coerce) import Data.List (groupBy) import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup +-- import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO -import qualified GHC.OldList as List +-- import qualified GHC.OldList as List import qualified Data.Map.Strict as Map -import Data.These +-- import Data.These import Language.Haskell.Brittany.Internal import Language.Haskell.Brittany.Internal.Config.Config import Language.Haskell.Brittany.Internal.Config.Types @@ -21,6 +21,7 @@ import System.Timeout (timeout) import Test.Hspec import qualified Text.Parsec as Parsec import Text.Parsec.Text (Parser) +import qualified Data.List.Extra hush :: Either a b -> Maybe b hush = either (const Nothing) Just @@ -61,7 +62,9 @@ roundTripEqualWithTimeout time t = data InputLine = GroupLine Text | HeaderLine Text + | HeaderLineGolden Text | PendingLine + | HeaderLineGoldenOutput | NormalLine Text | CommentLine deriving Show @@ -70,6 +73,7 @@ data TestCase = TestCase { testName :: Text , isPending :: Bool , content :: Text + , expectedOutput :: Maybe Text -- Nothing if input is expected not to change } main :: IO () @@ -146,8 +150,9 @@ main = do (tests `forM_` \test -> do (if isPending test then before_ pending else id) $ it (Text.unpack $ testName test) - $ roundTripEqual conf - $ content test + $ case expectedOutput test of + Nothing -> roundTripEqual conf (content test) + Just expctd -> goldenTest conf (content test) expctd ) ks ) @@ -187,13 +192,30 @@ main = do { testName = n , isPending = any isPendingLine rest , content = Text.unlines normalLines + , expectedOutput = Nothing } + HeaderLineGolden n : rest -> + case Data.List.Extra.wordsBy isGoldenOutputLine rest of + [inputLines, outputLines] -> + let + inputs = Data.Maybe.mapMaybe extractNormal inputLines + outputs = Data.Maybe.mapMaybe extractNormal outputLines + in TestCase + { testName = n + , isPending = any isPendingLine rest + , content = Text.unlines inputs + , expectedOutput = Just (Text.unlines outputs) + } + _ -> error $ "malformed golden test at " ++ show n l -> error $ "first non-empty line must start with #test footest\n" ++ show l extractNormal (NormalLine l) = Just l extractNormal _ = Nothing isPendingLine PendingLine{} = True isPendingLine _ = False + isGoldenOutputLine = \case + HeaderLineGoldenOutput -> True + _ -> False specialLineParser :: Parser InputLine specialLineParser = Parsec.choice [ [ GroupLine $ Text.pack name @@ -208,11 +230,21 @@ main = do , name <- Parsec.many1 $ Parsec.noneOf "\r\n:" , _ <- Parsec.eof ] + , [ HeaderLineGolden $ Text.pack name + | _ <- Parsec.try $ Parsec.string "#golden" + , _ <- Parsec.many1 $ Parsec.oneOf " \t" + , name <- Parsec.many1 $ Parsec.noneOf "\r\n:" + , _ <- Parsec.eof + ] , [ PendingLine | _ <- Parsec.try $ Parsec.string "#pending" , _ <- Parsec.optional $ many (Parsec.noneOf "\r\n") , _ <- Parsec.eof ] + , [ HeaderLineGoldenOutput + | _ <- Parsec.try $ Parsec.string "#expected" + , _ <- Parsec.eof + ] , [ CommentLine | _ <- Parsec.many $ Parsec.oneOf " \t" , _ <- Parsec.optional $ Parsec.string "##" <* many @@ -235,8 +267,9 @@ main = do grouperG _ GroupLine{} = False grouperG _ _ = True grouperT :: InputLine -> InputLine -> Bool - grouperT _ HeaderLine{} = False - grouperT _ _ = True + grouperT _ HeaderLine{} = False + grouperT _ HeaderLineGolden{} = False + grouperT _ _ = True -------------------- @@ -247,6 +280,11 @@ roundTripEqual c t = fmap (fmap PPTextWrapper) (parsePrintModuleTests c "TestFakeFileName.hs" t) `shouldReturn` Right (PPTextWrapper t) +goldenTest :: Config -> Text -> Text -> Expectation +goldenTest c input expected = + fmap (fmap PPTextWrapper) (parsePrintModuleTests c "TestFakeFileName.hs" input) + `shouldReturn` Right (PPTextWrapper expected) + newtype PPTextWrapper = PPTextWrapper Text deriving Eq @@ -260,23 +298,28 @@ defaultTestConfig = Config { _conf_version = _conf_version staticDefaultConfig , _conf_debug = _conf_debug staticDefaultConfig , _conf_layout = LayoutConfig - { _lconfig_cols = coerce (80 :: Int) - , _lconfig_indentPolicy = coerce IndentPolicyFree - , _lconfig_indentAmount = coerce (2 :: Int) - , _lconfig_indentWhereSpecial = coerce True - , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (60 :: Int) - , _lconfig_importAsColumn = coerce (60 :: Int) - , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 - , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) - , _lconfig_alignmentLimit = coerce (30 :: Int) - , _lconfig_alignmentBreakOnMultiline = coerce True - , _lconfig_hangingTypeSignature = coerce False - , _lconfig_reformatModulePreamble = coerce True - , _lconfig_allowSingleLineExportList = coerce True - , _lconfig_allowHangingQuasiQuotes = coerce True - , _lconfig_experimentalSemicolonNewlines = coerce False + { _lconfig_cols = coerce (80 :: Int) + , _lconfig_indentPolicy = coerce IndentPolicyFree + , _lconfig_indentAmount = coerce (2 :: Int) + , _lconfig_indentWhereSpecial = coerce True + , _lconfig_indentListSpecial = coerce True + , _lconfig_importColumn = coerce (60 :: Int) + , _lconfig_importAsColumn = coerce (60 :: Int) + , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 + , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) + , _lconfig_alignmentLimit = coerce (30 :: Int) + , _lconfig_alignmentBreakOnMultiline = coerce True + , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True + , _lconfig_allowSingleLineExportList = coerce True + , _lconfig_allowHangingQuasiQuotes = coerce True + , _lconfig_experimentalSemicolonNewlines = coerce False -- , _lconfig_allowSinglelineRecord = coerce False + , _lconfig_fixityAwareOps = coerce True + , _lconfig_fixityAwareTypeOps = coerce True + , _lconfig_fixityBasedAddAlignParens = coerce False + , _lconfig_operatorParenthesisRefactorMode = coerce PRMKeep + , _lconfig_operatorAllowUnqualify = coerce True } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } , _conf_preprocessor = _conf_preprocessor staticDefaultConfig