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

Implement fixity-aware-ops feature

ghc92
Lennart Spitzner 2023-04-05 14:44:53 +00:00
parent 75d17b961c
commit 676695a609
24 changed files with 1854 additions and 865 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
brittany.cabal
View File

@ -129,6 +129,7 @@ library
Language.Haskell.Brittany.Internal.ToBriDoc.DataDecl Language.Haskell.Brittany.Internal.ToBriDoc.DataDecl
Language.Haskell.Brittany.Internal.ToBriDoc.Decl Language.Haskell.Brittany.Internal.ToBriDoc.Decl
Language.Haskell.Brittany.Internal.ToBriDoc.Expr Language.Haskell.Brittany.Internal.ToBriDoc.Expr
Language.Haskell.Brittany.Internal.ToBriDoc.OpTree
Language.Haskell.Brittany.Internal.ToBriDoc.IE Language.Haskell.Brittany.Internal.ToBriDoc.IE
Language.Haskell.Brittany.Internal.ToBriDoc.Import Language.Haskell.Brittany.Internal.ToBriDoc.Import
Language.Haskell.Brittany.Internal.ToBriDoc.Module Language.Haskell.Brittany.Internal.ToBriDoc.Module
@ -137,6 +138,7 @@ library
Language.Haskell.Brittany.Internal.ToBriDoc.Type Language.Haskell.Brittany.Internal.ToBriDoc.Type
Language.Haskell.Brittany.Internal.Components.BriDoc Language.Haskell.Brittany.Internal.Components.BriDoc
Language.Haskell.Brittany.Internal.Components.Obfuscation Language.Haskell.Brittany.Internal.Components.Obfuscation
Language.Haskell.Brittany.Internal.Components.OpTree
Language.Haskell.Brittany.Internal.S1_Parsing Language.Haskell.Brittany.Internal.S1_Parsing
Language.Haskell.Brittany.Internal.S2_SplitModule Language.Haskell.Brittany.Internal.S2_SplitModule
Language.Haskell.Brittany.Internal.S3_ToBriDocTools Language.Haskell.Brittany.Internal.S3_ToBriDocTools

232
data/10-structured/op-precedence.blt Normal file
View File

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

4
data/15-regressions.blt
View File

@ -162,9 +162,7 @@ readMergePersConfig path shouldCreate conf = do
Left e -> do Left e -> do
liftIO liftIO
$ putStrErrLn $ putStrErrLn
$ "error reading in brittany config from " $ "error reading in brittany config from " ++ path ++ ":"
++ path
++ ":"
liftIO $ putStrErrLn e liftIO $ putStrErrLn e
mzero mzero
Right x -> return x Right x -> return x

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

@ -1100,9 +1100,7 @@ readMergePersConfig path shouldCreate conf = do
Left e -> do Left e -> do
liftIO liftIO
$ putStrErrLn $ putStrErrLn
$ "error reading in brittany config from " $ "error reading in brittany config from " ++ path ++ ":"
++ path
++ ":"
liftIO $ putStrErrLn e liftIO $ putStrErrLn e
mzero mzero
Right x -> return x Right x -> return x

6
source/library/Language/Haskell/Brittany/Internal.hs
View File

@ -55,9 +55,9 @@ parsePrintModule traceFunc configWithDebugs inputText = runExceptT $ do
configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig }
let ghcOptions = config & _conf_forward & _options_ghc & runIdentity let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
let config_pp = config & _conf_preprocessor let config_pp = config & _conf_preprocessor
let cppMode = config_pp & _ppconf_CPPMode & confUnpack @CPPMode let cppMode = config_pp & _ppconf_CPPMode & confUnpack
let hackAroundIncludes = let hackAroundIncludes =
config_pp & _ppconf_hackAroundIncludes & confUnpack @Bool config_pp & _ppconf_hackAroundIncludes & confUnpack
(parsedSource, hasCPP) <- do (parsedSource, hasCPP) <- do
let hackF s = if "#include" `isPrefixOf` s let hackF s = if "#include" `isPrefixOf` s
then "-- BRITANY_INCLUDE_HACK " ++ s then "-- BRITANY_INCLUDE_HACK " ++ s
@ -84,7 +84,7 @@ parsePrintModule traceFunc configWithDebugs inputText = runExceptT $ do
$ extractCommentConfigs (useTraceFunc traceFunc) parsedSource $ extractCommentConfigs (useTraceFunc traceFunc) parsedSource
let moduleConfig = cZipWith fromOptionIdentity config inlineConf let moduleConfig = cZipWith fromOptionIdentity config inlineConf
let disableFormatting = let disableFormatting =
moduleConfig & _conf_disable_formatting & confUnpack @Bool moduleConfig & _conf_disable_formatting & confUnpack
if disableFormatting if disableFormatting
then do then do
return inputText return inputText

35
source/library/Language/Haskell/Brittany/Internal/Components/BriDoc.hs
View File

@ -87,11 +87,7 @@ data BriDocW (w :: IsWrapped)
-- the following constructors are only relevant for the alt transformation -- the following constructors are only relevant for the alt transformation
-- and are removed afterwards. They should never occur in any (BriDocRec w) -- and are removed afterwards. They should never occur in any (BriDocRec w)
-- after the alt transformation. -- after the alt transformation.
| BDForceMultiline (BriDocRec w) | BDForceAlt ForceAlt (BriDocRec w)
| BDForceSingleline (BriDocRec w)
| BDNonBottomSpacing Bool (BriDocRec w)
| BDSetParSpacing (BriDocRec w)
| BDForceParSpacing (BriDocRec w)
-- pseudo-deprecated -- pseudo-deprecated
| BDDebug String (BriDocRec w) | BDDebug String (BriDocRec w)
@ -102,8 +98,19 @@ type BriDoc = BriDocW 'Unwrapped
type BriDocWrapped = BriDocW 'Wrapped type BriDocWrapped = BriDocW 'Wrapped
type BriDocNumbered = (Int, BriDocWrapped) type BriDocNumbered = (Int, BriDocWrapped)
data ForceAlt
= ForceMultiline
| ForceSingleline
| NonBottomSpacing Bool
| SetParSpacing
| ForceParSpacing
| ForceZeroAdd
deriving (Eq, Ord, Data.Data.Data, Show)
data BrIndent = BrIndentNone data BrIndent = BrIndentNone
| BrIndentRegular | BrIndentRegular
| BrIndentRegularForce
| BrIndentSpecial Int | BrIndentSpecial Int
deriving (Eq, Ord, Data.Data.Data, Show) 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 (BDEntryDelta dp bd ) = plate BDEntryDelta |- dp |* bd
uniplate (BDLines lines ) = plate BDLines ||* lines uniplate (BDLines lines ) = plate BDLines ||* lines
uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd
uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd uniplate (BDForceAlt forceFlag bd) = plate BDForceAlt |- forceFlag |* 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 (BDDebug s bd ) = plate BDDebug |- s |* bd uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd
-- this might not work. is not used anywhere either. -- this might not work. is not used anywhere either.
@ -161,11 +164,7 @@ briDocSeqSpine = \case
BDEntryDelta _dp bd -> briDocSeqSpine bd BDEntryDelta _dp bd -> briDocSeqSpine bd
BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines
BDEnsureIndent _ind bd -> briDocSeqSpine bd BDEnsureIndent _ind bd -> briDocSeqSpine bd
BDForceMultiline bd -> briDocSeqSpine bd BDForceAlt _ bd -> briDocSeqSpine bd
BDForceSingleline bd -> briDocSeqSpine bd
BDNonBottomSpacing _ bd -> briDocSeqSpine bd
BDSetParSpacing bd -> briDocSeqSpine bd
BDForceParSpacing bd -> briDocSeqSpine bd
BDDebug _s bd -> briDocSeqSpine bd BDDebug _s bd -> briDocSeqSpine bd
briDocForceSpine :: BriDoc -> BriDoc briDocForceSpine :: BriDoc -> BriDoc
@ -198,11 +197,7 @@ unwrapBriDocNumbered tpl = case snd tpl of
BDEntryDelta dp bd -> BDEntryDelta dp $ rec bd BDEntryDelta dp bd -> BDEntryDelta dp $ rec bd
BDLines lines -> BDLines $ rec <$> lines BDLines lines -> BDLines $ rec <$> lines
BDEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd BDEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd
BDForceMultiline bd -> BDForceMultiline $ rec bd BDForceAlt forceFlag bd -> BDForceAlt forceFlag $ rec bd
BDForceSingleline bd -> BDForceSingleline $ rec bd
BDNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd
BDSetParSpacing bd -> BDSetParSpacing $ rec bd
BDForceParSpacing bd -> BDForceParSpacing $ rec bd
BDDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd BDDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd
where rec = unwrapBriDocNumbered where rec = unwrapBriDocNumbered

289
source/library/Language/Haskell/Brittany/Internal/Components/OpTree.hs Normal file
View File

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

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

@ -59,6 +59,11 @@ staticDefaultConfig = Config
, _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_allowHangingQuasiQuotes = coerce True
, _lconfig_experimentalSemicolonNewlines = coerce False , _lconfig_experimentalSemicolonNewlines = coerce False
-- , _lconfig_allowSinglelineRecord = 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 , _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = coerce False { _econf_produceOutputOnErrors = coerce False
@ -159,6 +164,11 @@ cmdlineConfigParser = do
, _lconfig_allowHangingQuasiQuotes = mempty , _lconfig_allowHangingQuasiQuotes = mempty
, _lconfig_experimentalSemicolonNewlines = mempty , _lconfig_experimentalSemicolonNewlines = mempty
-- , _lconfig_allowSinglelineRecord = mempty -- , _lconfig_allowSinglelineRecord = mempty
, _lconfig_fixityAwareOps = mempty
, _lconfig_fixityAwareTypeOps = mempty
, _lconfig_fixityBasedAddAlignParens = mempty
, _lconfig_operatorParenthesisRefactorMode = mempty
, _lconfig_operatorAllowUnqualify = mempty
} }
, _conf_errorHandling = ErrorHandlingConfig , _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors

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

@ -4,6 +4,7 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Language.Haskell.Brittany.Internal.Config.Types where 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 confUnpack (Identity x) = coerce x
type family ConfUnpacked a where
ConfUnpacked (Last a) = a
ConfUnpacked a = a
data CDebugConfig f = DebugConfig data CDebugConfig f = DebugConfig
{ _dconf_dump_config :: f (Semigroup.Last Bool) { _dconf_dump_config :: f (Semigroup.Last Bool)
, _dconf_dump_annotations :: f (Semigroup.Last Bool) , _dconf_dump_annotations :: f (Semigroup.Last Bool)
@ -137,6 +143,38 @@ data CLayoutConfig f = LayoutConfig
-- -- > { x :: Double -- -- > { x :: Double
-- -- > , y :: 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 deriving Generic
@ -255,3 +293,13 @@ data ExactPrintFallbackMode
-- THIS MAY THEORETICALLY CHANGE SEMANTICS OF -- THIS MAY THEORETICALLY CHANGE SEMANTICS OF
-- A PROGRAM BY TRANSFORMING IT. -- A PROGRAM BY TRANSFORMING IT.
deriving (Show, Generic, Data) 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)

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

@ -75,6 +75,13 @@ instance ToJSON ExactPrintFallbackMode where
toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany
toEncoding = Aeson.genericToEncoding 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 instance FromJSON (CLayoutConfig Maybe) where
parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany

23
source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs
View File

@ -31,6 +31,7 @@ import GHC.Types.Name.Occurrence ( occNameString )
import GHC.Types.Name.Reader ( RdrName(..) ) import GHC.Types.Name.Reader ( RdrName(..) )
import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Types.SrcLoc as GHC
import GHC.Utils.Outputable ( Outputable ) import GHC.Utils.Outputable ( Outputable )
import Data.Coerce ( Coercible )
import Language.Haskell.Brittany.Internal.Components.BriDoc import Language.Haskell.Brittany.Internal.Components.BriDoc
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude 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.NameParensHash _ _ _ _) _ -> f "(#" name "#)"
EpAnn _ (GHC.NameAnn GHC.NameBackquotes _ _ _ _) _ -> f "`" name "`" EpAnn _ (GHC.NameAnn GHC.NameBackquotes _ _ _ _) _ -> f "`" name "`"
EpAnn _ (GHC.NameAnn GHC.NameSquare _ _ _ _) _ -> f "[" name "]" EpAnn _ (GHC.NameAnn GHC.NameSquare _ _ _ _) _ -> f "[" name "]"
EpAnn _ (GHC.NameAnnQuote _ _ _) _ -> f "'" name ""
-- TODO92 There are way more possible constructors here -- 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 -- see https://hackage.haskell.org/package/ghc-9.2.5/docs/GHC-Parser-Annotation.html#t:NameAnn
EpAnn _ _ _ -> rdrNameToText name EpAnn _ _ _ -> rdrNameToText name
@ -397,16 +399,19 @@ docSeparator :: ToBriDocM BriDocNumbered
docSeparator = allocateNode BDSeparator docSeparator = allocateNode BDSeparator
docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docNonBottomSpacing bdm = allocateNode . BDNonBottomSpacing False =<< bdm docNonBottomSpacing bdm = allocateNode . BDForceAlt (NonBottomSpacing False) =<< bdm
docNonBottomSpacingS :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docNonBottomSpacingS :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docNonBottomSpacingS bdm = allocateNode . BDNonBottomSpacing True =<< bdm docNonBottomSpacingS bdm = allocateNode . BDForceAlt (NonBottomSpacing True) =<< bdm
docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docSetParSpacing bdm = allocateNode . BDSetParSpacing =<< bdm docSetParSpacing bdm = allocateNode . BDForceAlt SetParSpacing =<< bdm
docForceParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered 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 :: String -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docDebug s bdm = allocateNode . BDDebug s =<< bdm docDebug s bdm = allocateNode . BDDebug s =<< bdm
@ -459,10 +464,10 @@ docPar lineM indentedM = do
allocateNode $ BDPar BrIndentNone line indented allocateNode $ BDPar BrIndentNone line indented
docForceSingleline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docForceSingleline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docForceSingleline bdm = allocateNode . BDForceSingleline =<< bdm docForceSingleline bdm = allocateNode . BDForceAlt ForceSingleline =<< bdm
docForceMultiline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docForceMultiline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docForceMultiline bdm = allocateNode . BDForceMultiline =<< bdm docForceMultiline bdm = allocateNode . BDForceAlt ForceMultiline =<< bdm
docEnsureIndent docEnsureIndent
:: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
@ -774,3 +779,9 @@ docHandleListElemCommsProperPost layouter es = case es of
epaLocationRealSrcSpanStart :: GHC.EpaLocation -> GHC.RealSrcLoc epaLocationRealSrcSpanStart :: GHC.EpaLocation -> GHC.RealSrcLoc
epaLocationRealSrcSpanStart = GHC.realSrcSpanStart . GHC.epaLocationRealSrcSpan epaLocationRealSrcSpanStart = GHC.realSrcSpanStart . GHC.epaLocationRealSrcSpan
askLayoutConf
:: Coercible a (ConfUnpacked a)
=> (CLayoutConfig Identity -> Identity a)
-> ToBriDocM (ConfUnpacked a)
askLayoutConf f = mAsk <&> _conf_layout .> f .> confUnpack

30
source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs
View File

@ -144,6 +144,7 @@ layoutBriDocM = \case
let indentF = case indent of let indentF = case indent of
BrIndentNone -> id BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol BrIndentRegular -> layoutWithAddBaseCol
BrIndentRegularForce -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ layoutBriDocM bd indentF $ layoutBriDocM bd
BDBaseYPushCur bd -> do BDBaseYPushCur bd -> do
@ -160,6 +161,7 @@ layoutBriDocM = \case
let indentF = case indent of let indentF = case indent of
BrIndentNone -> id BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol BrIndentRegular -> layoutWithAddBaseCol
BrIndentRegularForce -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ do indentF $ do
layoutWriteEnsureBlock layoutWriteEnsureBlock
@ -169,6 +171,7 @@ layoutBriDocM = \case
let indentF = case indent of let indentF = case indent of
BrIndentNone -> id BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol BrIndentRegular -> layoutWithAddBaseCol
BrIndentRegularForce -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ do indentF $ do
layoutWriteNewline layoutWriteNewline
@ -183,8 +186,7 @@ layoutBriDocM = \case
BDLines lines -> alignColsLines layoutBriDocM lines BDLines lines -> alignColsLines layoutBriDocM lines
BDAlt [] -> error "empty BDAlt" BDAlt [] -> error "empty BDAlt"
BDAlt (alt : _) -> layoutBriDocM alt BDAlt (alt : _) -> layoutBriDocM alt
BDForceMultiline bd -> layoutBriDocM bd BDForceAlt _ bd -> layoutBriDocM bd
BDForceSingleline bd -> layoutBriDocM bd
BDForwardLineMode bd -> layoutBriDocM bd BDForwardLineMode bd -> layoutBriDocM bd
BDExternal shouldAddComment t -> do BDExternal shouldAddComment t -> do
let tlines = Text.lines $ t <> Text.pack "\n" let tlines = Text.lines $ t <> Text.pack "\n"
@ -276,17 +278,23 @@ layoutBriDocM = \case
printComments comms printComments comms
mModify (\s -> s + CommentCounter (length comms)) mModify (\s -> s + CommentCounter (length comms))
do do
marker <- mGet <&> _lstate_markerForDelta state <- mGet
mModify $ \s -> s { _lstate_markerForDelta = Nothing } mModify $ \s -> s { _lstate_markerForDelta = Nothing }
case marker of case _lstate_markerForDelta state of
Nothing -> pure ()
Just m -> do Just m -> do
let p1 = (srcLocLine m, srcLocCol m) let p1 = (srcLocLine m, srcLocCol m)
let p2 = (srcLocLine loc, srcLocCol loc) 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 () -- traceShow (ExactPrint.pos2delta p1 p2) $ pure ()
case ExactPrint.pos2delta p1 p2 of case ExactPrint.pos2delta p1 p2 of
SameLine{} -> pure () SameLine{} -> pure ()
DifferentLine n _ -> layoutWriteNewlines n DifferentLine n _ | newlinePlanned -> layoutWriteNewlines n
| otherwise -> pure ()
_ -> pure ()
layoutBriDocM bd layoutBriDocM bd
BDFlushCommentsPost loc shouldMark bd -> do BDFlushCommentsPost loc shouldMark bd -> do
layoutBriDocM bd layoutBriDocM bd
@ -297,20 +305,10 @@ layoutBriDocM = \case
comms <- takeBefore loc comms <- takeBefore loc
mModify (\s -> s + CommentCounter (length comms)) mModify (\s -> s + CommentCounter (length comms))
printComments comms printComments comms
BDNonBottomSpacing _ bd -> layoutBriDocM bd
BDSetParSpacing bd -> layoutBriDocM bd
BDForceParSpacing bd -> layoutBriDocM bd
BDDebug s bd -> do BDDebug s bd -> do
mTell $ TextL.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}" mTell $ TextL.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}"
layoutBriDocM bd 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 takeBefore
:: MonadMultiState [LEpaComment] m => RealSrcLoc -> m [LEpaComment] :: MonadMultiState [LEpaComment] m => RealSrcLoc -> m [LEpaComment]
takeBefore loc = do takeBefore loc = do

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

@ -60,7 +60,7 @@ processModule
-> IO ([BrittanyError], TextL.Text) -> IO ([BrittanyError], TextL.Text)
processModule traceFunc conf inlineConf parsedModule = do processModule traceFunc conf inlineConf parsedModule = do
let shouldReformatHead = let shouldReformatHead =
conf & _conf_layout & _lconfig_reformatModulePreamble & confUnpack @Bool conf & _conf_layout & _lconfig_reformatModulePreamble & confUnpack
let let
wrapNonDeclToBriDoc = MultiRWSS.withMultiReader conf wrapNonDeclToBriDoc = MultiRWSS.withMultiReader conf
. MultiRWSS.withMultiState_ (CommentCounter 0) . MultiRWSS.withMultiState_ (CommentCounter 0)
@ -143,18 +143,18 @@ processModule traceFunc conf inlineConf parsedModule = do
-- trace ("---- DEBUGMESSAGES ---- ") -- trace ("---- DEBUGMESSAGES ---- ")
-- . foldr (seq . join trace) id debugStrings -- . foldr (seq . join trace) id debugStrings
debugStrings `forM_` \s -> useTraceFunc traceFunc s debugStrings `forM_` \s -> useTraceFunc traceFunc s
moduleElementsStream -- moduleElementsStream
(\el rest -> do -- (\el rest -> do
case el of -- case el of
MEExactModuleHead{} -> useTraceFunc traceFunc "MEExactModuleHead" -- MEExactModuleHead{} -> useTraceFunc traceFunc "MEExactModuleHead"
MEPrettyModuleHead{} -> useTraceFunc traceFunc "MEPrettyModuleHead" -- MEPrettyModuleHead{} -> useTraceFunc traceFunc "MEPrettyModuleHead"
MEImportDecl{} -> useTraceFunc traceFunc "MEImportDecl" -- MEImportDecl{} -> useTraceFunc traceFunc "MEImportDecl"
MEDecl{} -> useTraceFunc traceFunc "MEDecl" -- MEDecl{} -> useTraceFunc traceFunc "MEDecl"
MEComment{} -> useTraceFunc traceFunc "MEComment" -- MEComment{} -> useTraceFunc traceFunc "MEComment"
MEWhitespace dp -> useTraceFunc traceFunc ("MEWhitespace " ++ show dp) -- MEWhitespace dp -> useTraceFunc traceFunc ("MEWhitespace " ++ show dp)
rest -- rest
) -- )
(\_ -> pure ()) -- (\_ -> pure ())
pure (errs, TextL.Builder.toLazyText out) pure (errs, TextL.Builder.toLazyText out)
commentToDoc :: (Int, EpaCommentTok) -> ToBriDocM BriDocNumbered commentToDoc :: (Int, EpaCommentTok) -> ToBriDocM BriDocNumbered
@ -213,7 +213,7 @@ getDeclConfig config inlineConf decl = cZipWith fromOptionIdentity config
ppToplevelDecl :: LHsDecl GhcPs -> [(Int, EpaCommentTok)] -> PPMLocal () ppToplevelDecl :: LHsDecl GhcPs -> [(Int, EpaCommentTok)] -> PPMLocal ()
ppToplevelDecl decl immediateAfterComms = do ppToplevelDecl decl immediateAfterComms = do
exactprintOnly <- mAsk <&> \declConfig -> exactprintOnly <- mAsk <&> \declConfig ->
declConfig & _conf_roundtrip_exactprint_only & confUnpack @Bool declConfig & _conf_roundtrip_exactprint_only & confUnpack
bd <- fmap fst $ if exactprintOnly bd <- fmap fst $ if exactprintOnly
then briDocMToPPM then briDocMToPPM
$ docSeq (briDocByExact decl : map commentToDoc immediateAfterComms) $ docSeq (briDocByExact decl : map commentToDoc immediateAfterComms)

493
source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs
View File

@ -6,31 +6,37 @@ module Language.Haskell.Brittany.Internal.ToBriDoc.Expr where
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Text as Text import qualified Data.Text as Text
import GHC (GenLocated(L), RdrName(..)) import GHC ( GenLocated(L)
, RdrName(..)
)
import qualified GHC.Data.FastString as FastString import qualified GHC.Data.FastString as FastString
import GHC.Types.SourceText
(IntegralLit(IL), FractionalLit(FL), SourceText(SourceText))
import GHC.Hs import GHC.Hs
import qualified GHC.Types.SrcLoc as GHC
import qualified GHC.OldList as List import qualified GHC.OldList as List
import GHC.Types.Basic import GHC.Types.Basic
import GHC.Types.Name 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.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
import Language.Haskell.Brittany.Internal.ToBriDoc.Decl import Language.Haskell.Brittany.Internal.ToBriDoc.Decl
import Language.Haskell.Brittany.Internal.ToBriDoc.Pattern import Language.Haskell.Brittany.Internal.ToBriDoc.Pattern
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.ToBriDoc.Stmt import {-# SOURCE #-} Language.Haskell.Brittany.Internal.ToBriDoc.Stmt
import Language.Haskell.Brittany.Internal.ToBriDoc.Type import Language.Haskell.Brittany.Internal.ToBriDoc.Type
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Components.BriDoc import Language.Haskell.Brittany.Internal.ToBriDoc.OpTree
layoutExpr :: ToBriDoc HsExpr layoutExpr :: ToBriDoc HsExpr
layoutExpr lexpr@(L _ expr) = do layoutExpr lexpr@(L _ expr) = do
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack indentPolicy <- askLayoutConf _lconfig_indentPolicy
let allowFreeIndent = indentPolicy == IndentPolicyFree let allowFreeIndent = indentPolicy == IndentPolicyFree
docHandleComms lexpr $ case expr of docHandleComms lexpr $ case expr of
HsVar NoExtField vname -> docHandleComms lexpr $ do HsVar NoExtField vname -> docHandleComms lexpr $ do
@ -64,8 +70,7 @@ layoutExpr lexpr@(L _ expr) = do
-- (TODO: we create a BDCols here, but then make it ineffective -- (TODO: we create a BDCols here, but then make it ineffective
-- by wrapping it in docSeq below. We _could_ add alignments for -- by wrapping it in docSeq below. We _could_ add alignments for
-- stuff like lists-of-lambdas. Nothing terribly important..) -- stuff like lists-of-lambdas. Nothing terribly important..)
let let shouldPrefixSeparator = case p of
shouldPrefixSeparator = case p of
L _ LazyPat{} -> isFirst L _ LazyPat{} -> isFirst
L _ BangPat{} -> isFirst L _ BangPat{} -> isFirst
_ -> False _ -> False
@ -76,11 +81,12 @@ layoutExpr lexpr@(L _ expr) = do
pure (p1' Seq.<| pr) pure (p1' Seq.<| pr)
_ -> pure patDocSeq _ -> pure patDocSeq
colsWrapPat fixed colsWrapPat fixed
bodyDoc <- shareDoc bodyDoc <-
shareDoc
$ docAddBaseY BrIndentRegular $ docAddBaseY BrIndentRegular
$ docHandleComms epAnn $ layoutExpr body $ docHandleComms epAnn
let $ layoutExpr body
funcPatternPartLine = docCols let funcPatternPartLine = docCols
ColCasePattern ColCasePattern
(patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator]))
docAlt docAlt
@ -95,8 +101,7 @@ layoutExpr lexpr@(L _ expr) = do
, docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
(docSeq (docSeq
[ docLit $ Text.pack "\\" [ docLit $ Text.pack "\\"
, appSep $ docForceSingleline , appSep $ docForceSingleline funcPatternPartLine
funcPatternPartLine
, docLit $ Text.pack "->" , docLit $ Text.pack "->"
] ]
) )
@ -112,8 +117,7 @@ layoutExpr lexpr@(L _ expr) = do
, docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
(docSeq (docSeq
[ docLit $ Text.pack "\\" [ docLit $ Text.pack "\\"
, appSep $ docForceSingleline , appSep $ docForceSingleline funcPatternPartLine
funcPatternPartLine
, docLit $ Text.pack "->" , docLit $ Text.pack "->"
] ]
) )
@ -124,19 +128,16 @@ layoutExpr lexpr@(L _ expr) = do
docSetParSpacing docSetParSpacing
$ docAddBaseY BrIndentRegular $ docAddBaseY BrIndentRegular
$ (docLit $ Text.pack "\\case {}") $ (docLit $ Text.pack "\\case {}")
HsLamCase _ (MG _ _lmatches@(L _ matches) _) -> do HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do
binderDoc <- docLit $ Text.pack "->" binderDoc <- docLit $ Text.pack "->"
funcPatDocs <- funcPatDocs <- layoutPatternBind Nothing binderDoc `mapM` matches
-- docWrapNode lmatches
layoutPatternBind Nothing binderDoc
`mapM` matches
docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
(docLit $ Text.pack "\\case") (docLit $ Text.pack "\\case")
( docSetBaseAndIndent ( docSetBaseAndIndent
$ docNonBottomSpacing $ docNonBottomSpacing
$ docHandleComms lmatches
$ docLines $ docLines
$ return $ return <$> funcPatDocs
<$> funcPatDocs
) )
HsApp _ exp1 _ -> do HsApp _ exp1 _ -> do
let gather let gather
@ -172,8 +173,7 @@ layoutExpr lexpr@(L _ expr) = do
, case splitFirstLast paramDocs of , case splitFirstLast paramDocs of
FirstLastEmpty -> docEmpty FirstLastEmpty -> docEmpty
FirstLastSingleton e1 -> docForceParSpacing e1 FirstLastSingleton e1 -> docForceParSpacing e1
FirstLast e1 ems eN -> FirstLast e1 ems eN -> docSeq
docSeq
( spacifyDocs (docForceSingleline <$> (e1 : ems)) ( spacifyDocs (docForceSingleline <$> (e1 : ems))
++ [docSeparator, docForceParSpacing eN] ++ [docSeparator, docForceParSpacing eN]
) )
@ -222,76 +222,19 @@ layoutExpr lexpr@(L _ expr) = do
] ]
, docPar e (docSeq [docLit $ Text.pack "@", t]) , docPar e (docSeq [docLit $ Text.pack "@", t])
] ]
OpApp _topEpAnn expLeft@(L _ OpApp{}) expOp expRight -> do OpApp _topEpAnn _expLeft@(L _ OpApp{}) _expOp _expRight -> do
let -- let
allowPar = case (expOp, expRight) of -- allowPar = case (expOp, expRight) of
(L _ (HsVar _ (L _ (Unqual occname))), _) -- (L _ (HsVar _ (L _ (Unqual occname))), _)
| occNameString occname == "$" -> True -- | occNameString occname == "$" -> True
(_, L _ (HsApp _ _ (L _ HsVar{}))) -> False -- (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False
_ -> True -- _ -> True
let -- let hasComments =
gather -- not
:: Bool -- $ hasAnyCommentsConnected expLeft
-> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered, Bool)] -- || hasAnyCommentsConnected expOp
-> LHsExpr GhcPs treeAndHasComms <- gatherOpTreeE False False id Nothing Nothing [] lexpr
-> ( ToBriDocM BriDocNumbered processOpTree treeAndHasComms
, [(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 epAnn expLeft expOp expRight -> docHandleComms epAnn $ do OpApp epAnn expLeft expOp expRight -> docHandleComms epAnn $ do
expDocLeft <- shareDoc $ layoutExpr expLeft expDocLeft <- shareDoc $ layoutExpr expLeft
expDocOp <- shareDoc $ layoutExpr expOp expDocOp <- shareDoc $ layoutExpr expOp
@ -302,8 +245,7 @@ layoutExpr lexpr@(L _ expr) = do
| occNameString occname == "$" -> True | occNameString occname == "$" -> True
(_, L _ (HsApp _ _ (L _ HsVar{}))) -> False (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False
_ -> True _ -> True
let let leftIsDoBlock = case expLeft of
leftIsDoBlock = case expLeft of
L _ HsDo{} -> True L _ HsDo{} -> True
_ -> False _ -> False
runFilteredAlternative $ do runFilteredAlternative $ do
@ -322,8 +264,7 @@ layoutExpr lexpr@(L _ expr) = do
-- ] -- ]
-- two-line -- two-line
addAlternative $ do addAlternative $ do
let let expDocOpAndRight = docForceSingleline $ docCols
expDocOpAndRight = docForceSingleline $ docCols
ColOpPrefix ColOpPrefix
[appSep $ expDocOp, docSetBaseY expDocRight] [appSep $ expDocOp, docSetBaseY expDocRight]
if leftIsDoBlock if leftIsDoBlock
@ -342,8 +283,7 @@ layoutExpr lexpr@(L _ expr) = do
] ]
-- more lines -- more lines
addAlternative $ do addAlternative $ do
let let expDocOpAndRight =
expDocOpAndRight =
docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight] docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight]
if leftIsDoBlock if leftIsDoBlock
then docLines [expDocLeft, expDocOpAndRight] then docLines [expDocLeft, expDocOpAndRight]
@ -352,6 +292,25 @@ layoutExpr lexpr@(L _ expr) = do
NegApp _ op _ -> do NegApp _ op _ -> do
opDoc <- shareDoc $ layoutExpr op opDoc <- shareDoc $ layoutExpr op
docSeq [docLit $ Text.pack "-", opDoc] 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 HsPar epAnn innerExp -> docHandleComms epAnn $ do
let AnnParen _ spanOpen spanClose = anns epAnn let AnnParen _ spanOpen spanClose = anns epAnn
let wrapOpen = docHandleComms spanOpen let wrapOpen = docHandleComms spanOpen
@ -437,26 +396,13 @@ layoutExpr lexpr@(L _ expr) = do
, wrapClose $ docLit $ Text.pack ")" , wrapClose $ docLit $ Text.pack ")"
) )
Unboxed -> Unboxed ->
( wrapOpen $ docParenHashLSep (wrapOpen $ docParenHashLSep, wrapClose $ docParenHashRSep)
, wrapClose $ docParenHashRSep
)
case splitFirstLast argDocs of case splitFirstLast argDocs of
FirstLastEmpty -> FirstLastEmpty -> docSeq [openLit, closeLit]
docSeq [openLit, closeLit]
FirstLastSingleton e -> docAlt FirstLastSingleton e -> docAlt
[ docCols [ docCols ColTuple [openLit, docForceSingleline e, closeLit]
ColTuple , docSetBaseY
[ openLit $ docLines [docSeq [openLit, docForceSingleline e], closeLit]
, docForceSingleline e
, closeLit
]
, docSetBaseY $ docLines
[ docSeq
[ openLit
, docForceSingleline e
]
, closeLit
]
] ]
FirstLast e1 ems eN -> runFilteredAlternative $ do FirstLast e1 ems eN -> runFilteredAlternative $ do
addAlternativeCond (not hasComments) addAlternativeCond (not hasComments)
@ -471,13 +417,14 @@ layoutExpr lexpr@(L _ expr) = do
] ]
] ]
addAlternative addAlternative
$ let $ let start = docCols ColTuples [appSep openLit, docSetBaseY e1]
start = docCols ColTuples [appSep openLit, e1] linesM = ems <&> \d -> docCols ColTuples [docCommaSep, docSetBaseY d]
linesM = ems <&> \d -> docCols ColTuples [docCommaSep, d]
lineN = docCols lineN = docCols
ColTuples ColTuples
[docCommaSep, -- TODO92 docNodeAnnKW lexpr (Just AnnOpenP) [ docCommaSep
eN] , -- TODO92 docNodeAnnKW lexpr (Just AnnOpenP)
docSetBaseY eN
]
end = closeLit end = closeLit
in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end]
HsCase epAnn cExp (MG _ (L _ []) _) -> docHandleComms epAnn $ do HsCase epAnn cExp (MG _ (L _ []) _) -> docHandleComms epAnn $ do
@ -494,13 +441,13 @@ layoutExpr lexpr@(L _ expr) = do
) )
(docLit $ Text.pack "of {}") (docLit $ Text.pack "of {}")
] ]
HsCase epAnn cExp (MG _ lmatches@(L _ matches) _) -> docHandleComms epAnn $ do HsCase epAnn cExp (MG _ lmatches@(L _ matches) _) ->
docHandleComms epAnn $ do
cExpDoc <- shareDoc $ layoutExpr cExp cExpDoc <- shareDoc $ layoutExpr cExp
binderDoc <- docLit $ Text.pack "->" binderDoc <- docLit $ Text.pack "->"
funcPatDocs <- funcPatDocs <-
-- docWrapNode lmatches -- docWrapNode lmatches
layoutPatternBind Nothing binderDoc layoutPatternBind Nothing binderDoc `mapM` matches
`mapM` matches
docAlt docAlt
[ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar [ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
(docSeq (docSeq
@ -540,8 +487,7 @@ layoutExpr lexpr@(L _ expr) = do
thenExprDoc <- shareDoc $ layoutExpr thenExpr thenExprDoc <- shareDoc $ layoutExpr thenExpr
elseExprDoc <- shareDoc $ layoutExpr elseExpr elseExprDoc <- shareDoc $ layoutExpr elseExpr
let hasComments = hasAnyCommentsBelow lexpr let hasComments = hasAnyCommentsBelow lexpr
let let maySpecialIndent = case indentPolicy of
maySpecialIndent = case indentPolicy of
IndentPolicyLeft -> BrIndentRegular IndentPolicyLeft -> BrIndentRegular
IndentPolicyMultiple -> BrIndentRegular IndentPolicyMultiple -> BrIndentRegular
IndentPolicyFree -> BrIndentSpecial 3 IndentPolicyFree -> BrIndentSpecial 3
@ -583,20 +529,12 @@ layoutExpr lexpr@(L _ expr) = do
-- TODO92 $ docNodeAnnKW lexpr (Just AnnThen) -- TODO92 $ docNodeAnnKW lexpr (Just AnnThen)
$ docNonBottomSpacing $ docNonBottomSpacing
$ docAlt $ docAlt
[ docSeq [ docSeq [appSep $ thenDoc, docForceParSpacing thenExprDoc]
[ appSep $ thenDoc , docAddBaseY BrIndentRegular $ docPar thenDoc thenExprDoc
, docForceParSpacing thenExprDoc
]
, docAddBaseY BrIndentRegular
$ docPar thenDoc thenExprDoc
] ]
, docAddBaseY BrIndentRegular $ docNonBottomSpacing $ docAlt , docAddBaseY BrIndentRegular $ docNonBottomSpacing $ docAlt
[ docSeq [ docSeq [appSep $ elseDoc, docForceParSpacing elseExprDoc]
[ appSep $ elseDoc , docAddBaseY BrIndentRegular $ docPar elseDoc elseExprDoc
, docForceParSpacing elseExprDoc
]
, docAddBaseY BrIndentRegular
$ docPar elseDoc elseExprDoc
] ]
] ]
) )
@ -618,25 +556,14 @@ layoutExpr lexpr@(L _ expr) = do
-- stuff -- stuff
-- note that this does _not_ have par-spacing -- note that this does _not_ have par-spacing
addAlternative $ docPar addAlternative $ docPar
(docAddBaseY maySpecialIndent $ docSeq (docAddBaseY maySpecialIndent $ docSeq [appSep $ ifDoc, ifExprDoc])
[ appSep $ ifDoc
, ifExprDoc
]
)
(docLines (docLines
[ docAddBaseY BrIndentRegular [ docAddBaseY BrIndentRegular $ docAlt
$ docAlt [ docSeq [appSep $ thenDoc, docForceParSpacing thenExprDoc]
[ docSeq
[ appSep $ thenDoc
, docForceParSpacing thenExprDoc
]
, docPar thenDoc thenExprDoc , docPar thenDoc thenExprDoc
] ]
, docAddBaseY BrIndentRegular $ docAlt , docAddBaseY BrIndentRegular $ docAlt
[ docSeq [ docSeq [appSep $ elseDoc, docForceParSpacing elseExprDoc]
[ appSep $ elseDoc
, docForceParSpacing elseExprDoc
]
, docPar elseDoc elseExprDoc , docPar elseDoc elseExprDoc
] ]
] ]
@ -649,8 +576,7 @@ layoutExpr lexpr@(L _ expr) = do
let posIf = obtainAnnPos epAnn AnnIf let posIf = obtainAnnPos epAnn AnnIf
docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
(docHandleComms posIf $ docLit $ Text.pack "if") (docHandleComms posIf $ docLit $ Text.pack "if")
(layoutPatternBindFinal (layoutPatternBindFinal Nothing
Nothing
binderDoc binderDoc
Nothing Nothing
(Right cases) (Right cases)
@ -663,8 +589,7 @@ layoutExpr lexpr@(L _ expr) = do
let wrapLet = docHandleComms spanLet let wrapLet = docHandleComms spanLet
let wrapIn = docHandleComms spanIn let wrapIn = docHandleComms spanIn
mBindDocs <- layoutLocalBinds binds mBindDocs <- layoutLocalBinds binds
let let ifIndentFreeElse :: a -> a -> a
ifIndentFreeElse :: a -> a -> a
ifIndentFreeElse x y = case indentPolicy of ifIndentFreeElse x y = case indentPolicy of
IndentPolicyLeft -> y IndentPolicyLeft -> y
IndentPolicyMultiple -> y IndentPolicyMultiple -> y
@ -695,15 +620,15 @@ layoutExpr lexpr@(L _ expr) = do
, ifIndentFreeElse docSetBaseAndIndent docForceSingleline , ifIndentFreeElse docSetBaseAndIndent docForceSingleline
$ pure bindDoc $ pure bindDoc
] ]
, docAddBaseY BrIndentRegular $ docPar , docAddBaseY BrIndentRegular
(letDoc) $ docPar (letDoc) (docSetBaseAndIndent $ pure bindDoc)
(docSetBaseAndIndent $ pure bindDoc)
] ]
, docAlt , docAlt
[ docSeq [ docSeq
[ appSep $ wrapIn $ docLit $ Text.pack $ ifIndentFreeElse "in " "in" [ appSep $ wrapIn $ docLit $ Text.pack $ ifIndentFreeElse
, ifIndentFreeElse "in "
docSetBaseAndIndent "in"
, ifIndentFreeElse docSetBaseAndIndent
docForceSingleline docForceSingleline
expDoc1 expDoc1
] ]
@ -725,8 +650,7 @@ layoutExpr lexpr@(L _ expr) = do
-- c = d -- c = d
-- in -- in
-- fooooooooooooooooooo -- fooooooooooooooooooo
let let noHangingBinds =
noHangingBinds =
[ docNonBottomSpacing $ docAddBaseY BrIndentRegular $ docPar [ docNonBottomSpacing $ docAddBaseY BrIndentRegular $ docPar
(letDoc) (letDoc)
(docSetBaseAndIndent $ docLines $ pure <$> bindDocs) (docSetBaseAndIndent $ docLines $ pure <$> bindDocs)
@ -744,23 +668,21 @@ layoutExpr lexpr@(L _ expr) = do
[ appSep $ letDoc [ appSep $ letDoc
, docSetBaseAndIndent $ docLines $ pure <$> bindDocs , docSetBaseAndIndent $ docLines $ pure <$> bindDocs
] ]
, docSeq [appSep $ wrapIn $ docLit $ Text.pack "in ", docSetBaseY expDoc1] , docSeq
[ appSep $ wrapIn $ docLit $ Text.pack "in "
, docSetBaseY expDoc1
]
] ]
addAlternative $ docLines addAlternative $ docLines
[ -- TODO92 docNodeAnnKW lexpr (Just AnnLet) $ [ -- TODO92 docNodeAnnKW lexpr (Just AnnLet) $
docAddBaseY BrIndentRegular docAddBaseY BrIndentRegular $ docPar
$ docPar
(letDoc) (letDoc)
(docSetBaseAndIndent $ docLines $ pure <$> bindDocs) (docSetBaseAndIndent $ docLines $ pure <$> bindDocs)
, docAddBaseY BrIndentRegular , docAddBaseY BrIndentRegular
$ docPar (inDoc) (docSetBaseY $ expDoc1) $ docPar (inDoc) (docSetBaseY $ expDoc1)
] ]
_ -> docSeq _ -> docSeq
[ docForceSingleline $ docSeq [ docForceSingleline $ docSeq [letDoc, docSeparator, inDoc]
[ letDoc
, docSeparator
, inDoc
]
, docSeparator , docSeparator
, expDoc1 , expDoc1
] ]
@ -771,22 +693,23 @@ layoutExpr lexpr@(L _ expr) = do
DoExpr _ -> do DoExpr _ -> do
stmtDocs <- docHandleComms stmtEpAnn $ do stmtDocs <- docHandleComms stmtEpAnn $ do
stmts `forM` docHandleListElemComms layoutStmt stmts `forM` docHandleListElemComms layoutStmt
docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar docSetParSpacing $ docAddBaseY BrIndentRegularForce $ docPar
(docLit $ Text.pack "do") (docLit $ Text.pack "do")
( docSetBaseAndIndent ( docSetBaseAndIndent
$ docNonBottomSpacing $ docNonBottomSpacing
$ docLines $ docLines
$ pure <$> stmtDocs $ (pure <$> stmtDocs)
) )
MDoExpr _ -> do MDoExpr _ -> do
stmtDocs <- docHandleComms stmtEpAnn $ do stmtDocs <- docHandleComms stmtEpAnn $ do
stmts `forM` docHandleListElemComms layoutStmt stmts `forM` docHandleListElemComms layoutStmt
docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar docSetParSpacing $ docAddBaseY BrIndentRegularForce $ docPar
(docLit $ Text.pack "mdo") (docLit $ Text.pack "mdo")
( docSetBaseAndIndent ( docSetBaseAndIndent
$ docNonBottomSpacing $ docNonBottomSpacing
$ docLines $ docLines
$ pure <$> stmtDocs $ pure
<$> stmtDocs
) )
x x
| case x of | case x of
@ -794,21 +717,22 @@ layoutExpr lexpr@(L _ expr) = do
MonadComp -> True MonadComp -> True
_ -> False _ -> False
-> do -> do
stmtDocs <- docHandleComms stmtEpAnn $ stmtDocs <-
stmts `forM` docHandleListElemComms layoutStmt docHandleComms stmtEpAnn
$ stmts
`forM` docHandleListElemComms layoutStmt
let hasComments = hasAnyCommentsBelow lexpr let hasComments = hasAnyCommentsBelow lexpr
runFilteredAlternative $ do runFilteredAlternative $ do
addAlternativeCond (not hasComments) $ docSeq addAlternativeCond (not hasComments) $ docSeq
[ -- TODO92 docNodeAnnKW lexpr Nothing $ [ -- TODO92 docNodeAnnKW lexpr Nothing $
appSep $ docLit $ Text.pack "[" appSep $ docLit $ Text.pack "["
, -- TODO92 docNodeAnnKW lexpr (Just AnnOpenS) $ , -- TODO92 docNodeAnnKW lexpr (Just AnnOpenS) $
appSep appSep $ docForceSingleline $ pure (List.last stmtDocs)
$ docForceSingleline
$ pure (List.last stmtDocs)
, appSep $ docLit $ Text.pack "|" , appSep $ docLit $ Text.pack "|"
, docSeq , docSeq
$ List.intersperse docCommaSep $ List.intersperse docCommaSep
$ (docForceSingleline . pure) <$> List.init stmtDocs $ (docForceSingleline . pure)
<$> List.init stmtDocs
, docLit $ Text.pack " ]" , docLit $ Text.pack " ]"
] ]
addAlternative addAlternative
@ -824,11 +748,14 @@ layoutExpr lexpr@(L _ expr) = do
(s1, sM) = case List.init stmtDocs of (s1, sM) = case List.init stmtDocs of
(a : b) -> (a, b) (a : b) -> (a, b)
_ -> error "layoutExp: stmtDocs list too short" _ -> error "layoutExp: stmtDocs list too short"
line1 = line1 = docCols
docCols ColListComp [appSep $ docLit $ Text.pack "|", pure s1] ColListComp
lineM = sM <&> \d -> docCols ColListComp [docCommaSep, pure d] [appSep $ docLit $ Text.pack "|", pure s1]
lineM =
sM <&> \d -> docCols ColListComp [docCommaSep, pure d]
end = docLit $ Text.pack "]" end = docLit $ Text.pack "]"
in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] in
docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end]
_ -> do _ -> do
-- TODO -- TODO
unknownNodeError "HsDo{} unknown stmtCtx" lexpr unknownNodeError "HsDo{} unknown stmtCtx" lexpr
@ -837,47 +764,38 @@ layoutExpr lexpr@(L _ expr) = do
let posClose = obtainAnnPos listEpAnn AnnCloseS let posClose = obtainAnnPos listEpAnn AnnCloseS
let openDoc = docHandleComms posOpen $ docLitS "[" let openDoc = docHandleComms posOpen $ docLitS "["
let closeDoc = docHandleComms posClose $ docLitS "]" let closeDoc = docHandleComms posClose $ docLitS "]"
elemDocs <- elems `forM` (shareDoc . docHandleListElemComms layoutExpr) elemDocs <- docHandleListElemCommsProperPost layoutExpr elems
let hasComments = hasAnyCommentsBelow lexpr let hasComments = hasAnyCommentsBelow lexpr
case splitFirstLast elemDocs of case splitFirstLast elemDocs of
FirstLastEmpty -> docSeq FirstLastEmpty -> docSeq [docLit $ Text.pack "[", closeDoc]
[ docLit $ Text.pack "[" FirstLastSingleton (_, e) -> docAlt
, closeDoc [ docSeq [openDoc, docForceSingleline e, closeDoc]
]
FirstLastSingleton e -> docAlt
[ docSeq
[ openDoc
, docForceSingleline e
, closeDoc
]
, docSetBaseY $ docLines , docSetBaseY $ docLines
[ docSeq [docSeq [openDoc, docSeparator, docSetBaseY $ e], closeDoc]
[ openDoc
, docSeparator
, docSetBaseY $ e
] ]
, closeDoc FirstLast (_, e1) ems (finalCommaPos, eN) -> runFilteredAlternative $ do
]
]
FirstLast e1 ems eN -> runFilteredAlternative $ do
addAlternativeCond (not hasComments) addAlternativeCond (not hasComments)
$ docSeq $ docSeq
$ [openDoc] $ [openDoc, docForceSingleline e1]
++ List.intersperse ++ [ x
docCommaSep | (commaPos, e) <- ems
(docForceSingleline , x <- [docHandleComms commaPos docCommaSep, docForceSingleline e]
<$> (e1 : ems ++ [eN]) ]
) ++ [ docHandleComms finalCommaPos docCommaSep
++ [closeDoc] , docForceSingleline eN
, closeDoc]
addAlternative addAlternative
$ let $ let start = docCols ColList [appSep $ openDoc, e1]
start = docCols ColList [appSep $ openDoc, e1] linesM = ems <&> \(p, d) ->
linesM = ems <&> \d -> docCols ColList [docCommaSep, d] docCols ColList [docHandleComms p docCommaSep, d]
lineN = docCols lineN = docCols ColList
ColList [docHandleComms finalCommaPos $ docCommaSep, eN]
[docCommaSep, eN] in docSetBaseY
in docSetBaseY $ $ docLines
docLines $ [start] ++ linesM ++ [lineN] ++ [closeDoc] $ [start]
++ linesM
++ [lineN]
++ [closeDoc]
ExplicitList epAnn [] -> docHandleComms epAnn $ docLit $ Text.pack "[]" ExplicitList epAnn [] -> docHandleComms epAnn $ docLit $ Text.pack "[]"
RecordCon epAnn lname fields -> docHandleComms epAnn $ do RecordCon epAnn lname fields -> docHandleComms epAnn $ do
let (wrapOpen, wrapClose) = case epAnn of let (wrapOpen, wrapClose) = case epAnn of
@ -892,7 +810,15 @@ layoutExpr lexpr@(L _ expr) = do
case fields of case fields of
HsRecFields fs Nothing -> do HsRecFields fs Nothing -> do
let nameDoc = docHandleComms lname $ docLit $ lrdrNameToText lname 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 HsRecFields [] (Just (L dotdotLoc 0)) -> do
let wrapDotDot = docHandleComms dotdotLoc let wrapDotDot = docHandleComms dotdotLoc
let t = lrdrNameToText lname let t = lrdrNameToText lname
@ -905,10 +831,19 @@ layoutExpr lexpr@(L _ expr) = do
, docSeparator , docSeparator
, wrapClose $ docLitS "}" , wrapClose $ docLitS "}"
] ]
HsRecFields fs@(_ : _) (Just (L dotdotLoc dotdoti)) | dotdoti == length fs -> do HsRecFields fs@(_ : _) (Just (L dotdotLoc dotdoti))
| dotdoti == length fs -> do
let nameDoc = docHandleComms lname $ docLit $ lrdrNameToText lname let nameDoc = docHandleComms lname $ docLit $ lrdrNameToText lname
let wrapDotDot = docHandleComms dotdotLoc let wrapDotDot = docHandleComms dotdotLoc
recordExpression True wrapOpen wrapDotDot wrapClose indentPolicy lexpr nameDoc fieldLayouter fs recordExpression True
wrapOpen
wrapDotDot
wrapClose
indentPolicy
lexpr
nameDoc
fieldLayouter
fs
_ -> unknownNodeError "RecordCon with puns" lexpr _ -> unknownNodeError "RecordCon with puns" lexpr
RecordUpd epAnn rExpr (Left fields) -> docHandleComms epAnn $ do RecordUpd epAnn rExpr (Left fields) -> docHandleComms epAnn $ do
let (wrapOpen, wrapClose) = case epAnn of let (wrapOpen, wrapClose) = case epAnn of
@ -922,7 +857,15 @@ layoutExpr lexpr@(L _ expr) = do
Ambiguous _ n -> docLit (lrdrNameToText n) Ambiguous _ n -> docLit (lrdrNameToText n)
XAmbiguousFieldOcc _ -> error "XAmbiguousFieldOcc" XAmbiguousFieldOcc _ -> error "XAmbiguousFieldOcc"
rExprDoc <- shareDoc $ layoutExpr rExpr 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 RecordUpd epAnn rExpr (Right fields) -> do
let (wrapOpen, wrapClose) = case epAnn of let (wrapOpen, wrapClose) = case epAnn of
EpAnn _ [open, close] _ -> EpAnn _ [open, close] _ ->
@ -938,10 +881,17 @@ layoutExpr lexpr@(L _ expr) = do
let fieldLayouter = \case let fieldLayouter = \case
FieldLabelStrings [] -> docEmpty FieldLabelStrings [] -> docEmpty
FieldLabelStrings [label] -> labelLayouter label FieldLabelStrings [label] -> labelLayouter label
FieldLabelStrings labels -> docSeq FieldLabelStrings labels ->
$ List.intersperse docCommaSep docSeq $ List.intersperse docCommaSep $ map labelLayouter labels
$ map labelLayouter labels recordExpression False
recordExpression False wrapOpen id wrapClose indentPolicy lexpr rExprDoc fieldLayouter fields wrapOpen
id
wrapClose
indentPolicy
lexpr
rExprDoc
fieldLayouter
fields
ExprWithTySig _ exp1 (HsWC _ typ1) -> do ExprWithTySig _ exp1 (HsWC _ typ1) -> do
expDoc <- shareDoc $ layoutExpr exp1 expDoc <- shareDoc $ layoutExpr exp1
typDoc <- shareDoc $ layoutSigType typ1 typDoc <- shareDoc $ layoutSigType typ1
@ -988,8 +938,7 @@ layoutExpr lexpr@(L _ expr) = do
, docLit $ Text.pack "]" , docLit $ Text.pack "]"
] ]
HsGetField _epAnn _exp1 _field -> do HsGetField _epAnn _exp1 _field -> do
let let labelLayouter label = case label of
labelLayouter label = case label of
L flAnn (HsFieldLabel _ (L _ n)) -> L flAnn (HsFieldLabel _ (L _ n)) ->
docHandleComms flAnn $ docLitS $ FastString.unpackFS n docHandleComms flAnn $ docLitS $ FastString.unpackFS n
L _ann (XHsFieldLabel _) -> error "XHsFieldLabel" L _ann (XHsFieldLabel _) -> error "XHsFieldLabel"
@ -998,18 +947,15 @@ layoutExpr lexpr@(L _ expr) = do
-> LHsExpr GhcPs -> LHsExpr GhcPs
-> (LHsExpr GhcPs, [ToBriDocM BriDocNumbered]) -> (LHsExpr GhcPs, [ToBriDocM BriDocNumbered])
gather list = \case gather list = \case
L _ (HsGetField epAnn l r) -> gather L _ (HsGetField epAnn l r) ->
(docHandleComms epAnn $ labelLayouter r : list) l gather (docHandleComms epAnn $ labelLayouter r : list) l
x -> (x, list) x -> (x, list)
let (headE, paramEs) = gather let (headE, paramEs) = gather [] lexpr
[]
lexpr
expDoc <- shareDoc $ layoutExpr headE expDoc <- shareDoc $ layoutExpr headE
-- this only has single-line layout, afaik -- this only has single-line layout, afaik
docForceSingleline $ docSeq $ intersperse (docLitS ".") (expDoc : paramEs) docForceSingleline $ docSeq $ intersperse (docLitS ".") (expDoc : paramEs)
HsProjection epAnn (f1 :| fR) -> do HsProjection epAnn (f1 :| fR) -> do
let let labelLayouter label = case label of
labelLayouter label = case label of
L flAnn (HsFieldLabel _ (L _ n)) -> L flAnn (HsFieldLabel _ (L _ n)) ->
docHandleComms flAnn $ docLitS $ FastString.unpackFS n docHandleComms flAnn $ docLitS $ FastString.unpackFS n
L _ann (XHsFieldLabel _) -> error "XHsFieldLabel" L _ann (XHsFieldLabel _) -> error "XHsFieldLabel"
@ -1062,6 +1008,7 @@ layoutExpr lexpr@(L _ expr) = do
-- TODO -- TODO
briDocByExactInlineOnly "HsPragE{}" lexpr briDocByExactInlineOnly "HsPragE{}" lexpr
recordExpression recordExpression
:: Bool :: Bool
-> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered)
@ -1088,8 +1035,10 @@ recordExpression True wrapO wrapDD wrapC _ _lexpr nameDoc _ [] = docSeq -- this
, docSeparator , docSeparator
, wrapC $ docLit $ Text.pack "}" , wrapC $ docLit $ Text.pack "}"
] ]
recordExpression dotdot wrapO wrapDD wrapC indentPolicy _lexpr nameDoc nameLayouter (rF1 : rFr) = do recordExpression dotdot wrapO wrapDD wrapC indentPolicy _lexpr nameDoc nameLayouter (rF1 : rFr)
let mkFieldTuple = \case = do
let
mkFieldTuple = \case
L srcSpan (HsRecField fEpAnn (L _ nameThing) rFExpr pun) -> do L srcSpan (HsRecField fEpAnn (L _ nameThing) rFExpr pun) -> do
let (posStart, _posSomething) = case fEpAnn of -- TODO92 not sure what posSomething is let (posStart, _posSomething) = case fEpAnn of -- TODO92 not sure what posSomething is
EpAnn anch [AddEpAnn _ span] _ -> EpAnn anch [AddEpAnn _ span] _ ->
@ -1132,9 +1081,8 @@ recordExpression dotdot wrapO wrapDD wrapC indentPolicy _lexpr nameDoc nameLayou
[ -- TODO92 docNodeAnnKW lexpr Nothing $ [ -- TODO92 docNodeAnnKW lexpr Nothing $
appSep $ docForceSingleline nameDoc appSep $ docForceSingleline nameDoc
, appSep $ wrapO $ docLit $ Text.pack "{" , appSep $ wrapO $ docLit $ Text.pack "{"
, docSeq , docSeq $ List.intersperse docCommaSep $ fieldWiths () () $ \() ->
$ List.intersperse docCommaSep \case
$ fieldWiths () () $ \() -> \case
Left (pos, fnameDoc) -> docHandleComms pos $ fnameDoc Left (pos, fnameDoc) -> docHandleComms pos $ fnameDoc
Right (pos, fnameDoc, expDoc) -> docHandleComms pos $ docSeq Right (pos, fnameDoc, expDoc) -> docHandleComms pos $ docSeq
[ appSep $ fnameDoc [ appSep $ fnameDoc
@ -1142,7 +1090,8 @@ recordExpression dotdot wrapO wrapDD wrapC indentPolicy _lexpr nameDoc nameLayou
, docForceSingleline $ expDoc , docForceSingleline $ expDoc
] ]
, if dotdot , if dotdot
then docSeq [docCommaSep, wrapDD $ docLit $ Text.pack "..", docSeparator] then docSeq
[docCommaSep, wrapDD $ docLit $ Text.pack "..", docSeparator]
else docSeparator else docSeparator
, wrapC $ docLit $ Text.pack "}" , wrapC $ docLit $ Text.pack "}"
] ]
@ -1156,21 +1105,19 @@ recordExpression dotdot wrapO wrapDD wrapC indentPolicy _lexpr nameDoc nameLayou
, docSetBaseY , docSetBaseY
$ docLines $ docLines
$ let $ let
fieldLines = fieldWiths fieldLines =
(appSep $ wrapO $ docLit $ Text.pack "{") fieldWiths (appSep $ wrapO $ docLit $ Text.pack "{") docCommaSep
docCommaSep
$ \prep -> \case $ \prep -> \case
Left (pos, fnameDoc) -> docCols Left (pos, fnameDoc) ->
ColRec docCols ColRec [prep, docHandleComms pos $ fnameDoc]
[ prep
, docHandleComms pos $ fnameDoc
]
Right (pos, fnameDoc, expDoc) -> docCols Right (pos, fnameDoc, expDoc) -> docCols
ColRec ColRec
[ prep [ prep
, docHandleComms pos $ appSep $ fnameDoc , docHandleComms pos $ appSep $ fnameDoc
, docSeq , docSeq
[appSep $ docLit $ Text.pack "=", docForceSingleline expDoc] [ appSep $ docLit $ Text.pack "="
, docForceSingleline expDoc
]
] ]
dotdotLine = if dotdot dotdotLine = if dotdot
then docCols then docCols
@ -1182,7 +1129,8 @@ recordExpression dotdot wrapO wrapDD wrapC indentPolicy _lexpr nameDoc nameLayou
else -- TODO92 docNodeAnnKW lexpr (Just AnnOpenC) else -- TODO92 docNodeAnnKW lexpr (Just AnnOpenC)
docEmpty docEmpty
lineN = wrapC $ docLit $ Text.pack "}" lineN = wrapC $ docLit $ Text.pack "}"
in fieldLines ++ [dotdotLine, lineN] in
fieldLines ++ [dotdotLine, lineN]
] ]
-- non-hanging with expressions placed to the right of the names -- non-hanging with expressions placed to the right of the names
-- container -- container
@ -1196,23 +1144,27 @@ recordExpression dotdot wrapO wrapDD wrapC indentPolicy _lexpr nameDoc nameLayou
( docNonBottomSpacing ( docNonBottomSpacing
$ docLines $ docLines
$ let $ let
fieldLines = fieldWiths fieldLines =
(appSep $ wrapO $ docLit $ Text.pack "{") fieldWiths (appSep $ wrapO $ docLit $ Text.pack "{") docCommaSep
docCommaSep
$ \prep -> \case $ \prep -> \case
Left (pos, fnameDoc) -> docCols ColRec Left (pos, fnameDoc) ->
[ prep docCols ColRec [prep, docHandleComms pos $ fnameDoc]
, docHandleComms pos $ fnameDoc Right (pos, fnameDoc, expDoc) -> docCols
] ColRec
Right (pos, fnameDoc, expDoc) -> docCols ColRec
[ prep [ prep
, docHandleComms pos $ appSep $ fnameDoc , docHandleComms pos $ appSep $ fnameDoc
, runFilteredAlternative $ do , runFilteredAlternative $ do
addAlternativeCond (indentPolicy == IndentPolicyFree) $ do addAlternativeCond (indentPolicy == IndentPolicyFree)
docSeq [appSep $ docLit $ Text.pack "=", docSetBaseY expDoc] $ do
docSeq
[ appSep $ docLit $ Text.pack "="
, docSetBaseY expDoc
]
addAlternative $ do addAlternative $ do
docSeq docSeq
[appSep $ docLit $ Text.pack "=", docForceParSpacing expDoc] [ appSep $ docLit $ Text.pack "="
, docForceParSpacing expDoc
]
addAlternative $ do addAlternative $ do
docAddBaseY BrIndentRegular docAddBaseY BrIndentRegular
$ docPar (docLit $ Text.pack "=") expDoc $ docPar (docLit $ Text.pack "=") expDoc
@ -1227,7 +1179,8 @@ recordExpression dotdot wrapO wrapDD wrapC indentPolicy _lexpr nameDoc nameLayou
else -- TODO92 docNodeAnnKW lexpr (Just AnnOpenC) else -- TODO92 docNodeAnnKW lexpr (Just AnnOpenC)
docEmpty docEmpty
lineN = wrapC $ docLit $ Text.pack "}" lineN = wrapC $ docLit $ Text.pack "}"
in fieldLines ++ [dotdotLine, lineN] in
fieldLines ++ [dotdotLine, lineN]
) )
litBriDoc :: HsLit GhcPs -> BriDocWrapped litBriDoc :: HsLit GhcPs -> BriDocWrapped

311
source/library/Language/Haskell/Brittany/Internal/ToBriDoc/OpTree.hs Normal file
View File

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

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

@ -17,6 +17,7 @@ import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Components.BriDoc import Language.Haskell.Brittany.Internal.Components.BriDoc
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Utils
(FirstLastView(..), splitFirstLast) (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) (docAddBaseY (BrIndentSpecial 2) line1)
(docLines $ lines ++ [wrapEnd end]) (docLines $ lines ++ [wrapEnd end])
] ]
HsOpTy{} -> -- TODO HsOpTy{} -> do
briDocByExactInlineOnly "HsOpTy{}" ltype treeAndHasComms <- gatherOpTreeT False False id Nothing Nothing [] ltype
processOpTree treeAndHasComms
-- HsOpTy typ1 opName typ2 -> do -- HsOpTy typ1 opName typ2 -> do
-- -- TODO: these need some proper fixing. precedences don't add up. -- -- TODO: these need some proper fixing. precedences don't add up.
-- -- maybe the parser just returns some trivial right recursion -- -- maybe the parser just returns some trivial right recursion

10
source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs-boot Normal file
View File

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

317
source/library/Language/Haskell/Brittany/Internal/Transformations/T1_Alt.hs
View File

@ -39,6 +39,7 @@ data VerticalSpacing
{ _vs_sameLine :: !Int { _vs_sameLine :: !Int
, _vs_paragraph :: !VerticalSpacingPar , _vs_paragraph :: !VerticalSpacingPar
, _vs_parFlag :: !Bool , _vs_parFlag :: !Bool
, _vs_onlyZeroAddInd :: !Bool
} }
deriving (Eq, Show) deriving (Eq, Show)
@ -54,6 +55,7 @@ data AltCurPos = AltCurPos
{ _acp_line :: Int -- chars in the current line { _acp_line :: Int -- chars in the current line
, _acp_indent :: Int -- current indentation level , _acp_indent :: Int -- current indentation level
, _acp_indentPrep :: Int -- indentChange affecting the next Par , _acp_indentPrep :: Int -- indentChange affecting the next Par
, _acp_indentPrepForced :: Bool
, _acp_forceMLFlag :: AltLineModeState , _acp_forceMLFlag :: AltLineModeState
} }
deriving Show deriving Show
@ -99,7 +101,7 @@ transformAlts
=> BriDocNumbered => BriDocNumbered
-> MultiRWSS.MultiRWS r w s BriDoc -> MultiRWSS.MultiRWS r w s BriDoc
transformAlts = transformAlts =
MultiRWSS.withMultiStateA (AltCurPos 0 0 0 AltLineModeStateNone) MultiRWSS.withMultiStateA (AltCurPos 0 0 0 False AltLineModeStateNone)
. Memo.startEvalMemoT . Memo.startEvalMemoT
. fmap unwrapBriDocNumbered . fmap unwrapBriDocNumbered
. rec . rec
@ -163,14 +165,18 @@ transformAlts =
BDSeparator -> processSpacingSimple bdX $> bdX BDSeparator -> processSpacingSimple bdX $> bdX
BDAddBaseY indent bd -> do BDAddBaseY indent bd -> do
acp <- mGet acp <- mGet
indAdd <- fixIndentationForMultiple acp indent (indAdd, forced) <- fixIndentationForMultiple acp indent
mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd } mSet $ acp
{ _acp_indentPrep = max (_acp_indentPrep acp) indAdd
, _acp_indentPrepForced = forced || _acp_indentPrepForced acp
}
r <- rec bd r <- rec bd
acp' <- mGet acp' <- mGet
mSet $ acp' { _acp_indent = _acp_indent acp } mSet $ acp' { _acp_indent = _acp_indent acp }
return $ case indent of return $ case indent of
BrIndentNone -> r BrIndentNone -> r
BrIndentRegular -> reWrap $ BDAddBaseY (BrIndentSpecial indAdd) r BrIndentRegular -> reWrap $ BDAddBaseY (BrIndentSpecial indAdd) r
BrIndentRegularForce -> reWrap $ BDAddBaseY (BrIndentSpecial indAdd) r
BrIndentSpecial i -> reWrap $ BDAddBaseY (BrIndentSpecial i) r BrIndentSpecial i -> reWrap $ BDAddBaseY (BrIndentSpecial i) r
BDBaseYPushCur bd -> do BDBaseYPushCur bd -> do
acp <- mGet acp <- mGet
@ -188,16 +194,24 @@ transformAlts =
BDPar indent sameLine indented -> do BDPar indent sameLine indented -> do
indAmount <- indAmount <-
mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
let
indAdd = case indent of
BrIndentNone -> 0
BrIndentRegular -> indAmount
BrIndentSpecial i -> i
acp <- mGet 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 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 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 indented' <- rec indented
return $ reWrap $ BDPar indent sameLine' indented' return $ reWrap $ BDPar indent sameLine' indented'
BDAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a BDAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a
@ -214,12 +228,14 @@ transformAlts =
acp <- mGet acp <- mGet
let let
lineCheck LineModeInvalid = False lineCheck LineModeInvalid = False
lineCheck (LineModeValid (VerticalSpacing _ p _)) = lineCheck (LineModeValid (VerticalSpacing _ p _ z)) =
case _acp_forceMLFlag acp of let pRes = case _acp_forceMLFlag acp of
AltLineModeStateNone -> True AltLineModeStateNone -> True
AltLineModeStateForceSL{} -> p == VerticalSpacingParNone AltLineModeStateForceSL{} -> p == VerticalSpacingParNone
AltLineModeStateForceML{} -> p /= VerticalSpacingParNone AltLineModeStateForceML{} -> p /= VerticalSpacingParNone
AltLineModeStateContradiction -> False AltLineModeStateContradiction -> False
zRes = not z || not (_acp_indentPrepForced acp)
in pRes && zRes
-- TODO: use COMPLETE pragma instead? -- TODO: use COMPLETE pragma instead?
lineCheck _ = error "ghc exhaustive check is insufficient" lineCheck _ = error "ghc exhaustive check is insufficient"
lconf <- _conf_layout <$> mAsk lconf <- _conf_layout <$> mAsk
@ -244,11 +260,14 @@ transformAlts =
spacings <- alts `forM` getSpacings limit spacings <- alts `forM` getSpacings limit
acp <- mGet acp <- mGet
let let
lineCheck (VerticalSpacing _ p _) = case _acp_forceMLFlag acp of lineCheck (VerticalSpacing _ p _ z) =
let pRes = case _acp_forceMLFlag acp of
AltLineModeStateNone -> True AltLineModeStateNone -> True
AltLineModeStateForceSL{} -> p == VerticalSpacingParNone AltLineModeStateForceSL{} -> p == VerticalSpacingParNone
AltLineModeStateForceML{} -> p /= VerticalSpacingParNone AltLineModeStateForceML{} -> p /= VerticalSpacingParNone
AltLineModeStateContradiction -> False AltLineModeStateContradiction -> False
zRes = not z || not (_acp_indentPrepForced acp)
in pRes && zRes
lconf <- _conf_layout <$> mAsk lconf <- _conf_layout <$> mAsk
let let
options = -- trace ("considering options:" ++ show (length alts, acp)) $ options = -- trace ("considering options:" ++ show (length alts, acp)) $
@ -263,32 +282,27 @@ transformAlts =
$ fromMaybe (-- trace ("choosing last") $ $ fromMaybe (-- trace ("choosing last") $
List.last alts) List.last alts)
$ Data.List.Extra.firstJust (fmap snd) checkedOptions $ Data.List.Extra.firstJust (fmap snd) checkedOptions
BDForceMultiline bd -> do BDForceAlt ForceMultiline bd -> do
acp <- mGet acp <- mGet
x <- do
mSet $ mergeLineMode acp (AltLineModeStateForceML False) mSet $ mergeLineMode acp (AltLineModeStateForceML False)
rec bd x <- rec bd
acp' <- mGet mModify $ \acp' -> acp' { _acp_forceMLFlag = _acp_forceMLFlag acp }
mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } pure $ x
return $ x BDForceAlt ForceSingleline bd -> do
BDForceSingleline bd -> do
acp <- mGet acp <- mGet
x <- do
mSet $ mergeLineMode acp AltLineModeStateForceSL mSet $ mergeLineMode acp AltLineModeStateForceSL
rec bd x <- rec bd
acp' <- mGet mModify $ \acp' -> acp' { _acp_forceMLFlag = _acp_forceMLFlag acp }
mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } pure $ x
return $ x
BDForwardLineMode bd -> do BDForwardLineMode bd -> do
acp <- mGet acp <- mGet
x <- do
mSet $ acp mSet $ acp
{ _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp
} }
rec bd x <- rec bd
acp' <- mGet mModify $ \acp' -> acp' { _acp_forceMLFlag = _acp_forceMLFlag acp }
mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } pure $ x
return $ x BDForceAlt ForceZeroAdd bd -> rec bd
BDExternal{} -> processSpacingSimple bdX $> bdX BDExternal{} -> processSpacingSimple bdX $> bdX
BDPlain{} -> processSpacingSimple bdX $> bdX BDPlain{} -> processSpacingSimple bdX $> bdX
BDQueueComments comms bd -> BDQueueComments comms bd ->
@ -305,18 +319,23 @@ transformAlts =
reWrap . BDFlushCommentsPost loc shouldMark <$> rec bd reWrap . BDFlushCommentsPost loc shouldMark <$> rec bd
BDLines [] -> return $ reWrap BDEmpty -- evil transformation. or harmless. BDLines [] -> return $ reWrap BDEmpty -- evil transformation. or harmless.
BDLines (l : lr) -> do BDLines (l : lr) -> do
ind <- _acp_indent <$> mGet initialAcp <- mGet
l' <- rec l l' <- rec l
lr' <- lr `forM` \x -> do 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 rec x
return $ reWrap $ BDLines (l' : lr') return $ reWrap $ BDLines (l' : lr')
BDEnsureIndent indent bd -> do BDEnsureIndent indent bd -> do
acp <- mGet acp <- mGet
indAdd <- fixIndentationForMultiple acp indent (indAdd, forced) <- fixIndentationForMultiple acp indent
mSet $ acp mSet $ acp
{ _acp_indentPrep = 0 { _acp_indentPrep = 0
-- TODO: i am not sure this is valid, in general. -- TODO: i am not sure this is valid, in general.
, _acp_indentPrepForced = forced
, _acp_indent = _acp_indent acp + indAdd , _acp_indent = _acp_indent acp + indAdd
, _acp_line = max (_acp_line acp) (_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 -- we cannot use just _acp_line acp + indAdd because of the case
@ -331,10 +350,12 @@ transformAlts =
BrIndentNone -> r BrIndentNone -> r
BrIndentRegular -> BrIndentRegular ->
reWrap $ BDEnsureIndent (BrIndentSpecial indAdd) r reWrap $ BDEnsureIndent (BrIndentSpecial indAdd) r
BrIndentRegularForce ->
reWrap $ BDEnsureIndent (BrIndentSpecial indAdd) r
BrIndentSpecial i -> reWrap $ BDEnsureIndent (BrIndentSpecial i) r BrIndentSpecial i -> reWrap $ BDEnsureIndent (BrIndentSpecial i) r
BDNonBottomSpacing _ bd -> rec bd BDForceAlt (NonBottomSpacing _) bd -> rec bd
BDSetParSpacing bd -> rec bd BDForceAlt SetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd BDForceAlt ForceParSpacing bd -> rec bd
BDDebug s bd -> do BDDebug s bd -> do
acp :: AltCurPos <- mGet acp :: AltCurPos <- mGet
tellDebugMess tellDebugMess
@ -354,7 +375,7 @@ transformAlts =
-> m () -> m ()
processSpacingSimple bd = getSpacing bd >>= \case processSpacingSimple bd = getSpacing bd >>= \case
LineModeInvalid -> error "processSpacingSimple inv" LineModeInvalid -> error "processSpacingSimple inv"
LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do LineModeValid (VerticalSpacing i VerticalSpacingParNone _ _) -> do
acp <- mGet acp <- mGet
mSet $ acp { _acp_line = _acp_line acp + i } mSet $ acp { _acp_line = _acp_line acp + i }
LineModeValid VerticalSpacing{} -> error "processSpacingSimple par" LineModeValid VerticalSpacing{} -> error "processSpacingSimple par"
@ -365,9 +386,9 @@ transformAlts =
hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs
hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient"
hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool 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) = 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 = line
+ sameLine + sameLine
<= confUnpack (_lconfig_cols lconf) <= confUnpack (_lconfig_cols lconf)
@ -375,7 +396,7 @@ transformAlts =
+ indentPrep + indentPrep
+ par + par
<= confUnpack (_lconfig_cols lconf) <= 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) = line + sameLine <= confUnpack (_lconfig_cols lconf)
getSpacing getSpacing
@ -389,40 +410,45 @@ getSpacing !bridoc = rec bridoc
rec (brDcId, brDc) = do rec (brDcId, brDc) = do
config <- mAsk config <- mAsk
let colMax = config & _conf_layout & _lconfig_cols & confUnpack 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 -- BDWrapAnnKey _annKey bd -> rec bd
BDEmpty -> BDEmpty ->
return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False pure
BDLit t -> return $ LineModeValid $ VerticalSpacing $ LineModeValid
(Text.length t) $ VerticalSpacing 0 VerticalSpacingParNone False False
VerticalSpacingParNone BDLit t ->
False pure
$ LineModeValid
$ VerticalSpacing (Text.length t) VerticalSpacingParNone False False
BDSeq list -> sumVs <$> rec `mapM` list BDSeq list -> sumVs <$> rec `mapM` list
BDCols _sig list -> sumVs <$> rec `mapM` list BDCols _sig list -> sumVs <$> rec `mapM` list
BDSeparator -> BDSeparator ->
return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False pure
$ LineModeValid
$ VerticalSpacing 1 VerticalSpacingParNone False False
BDAddBaseY indent bd -> do BDAddBaseY indent bd -> do
mVs <- rec bd mVs <- rec bd
return $ mVs <&> \vs -> vs pure
[ vs
{ _vs_paragraph = case _vs_paragraph vs of { _vs_paragraph = case _vs_paragraph vs of
VerticalSpacingParNone -> VerticalSpacingParNone VerticalSpacingParNone -> VerticalSpacingParNone
VerticalSpacingParAlways i -> VerticalSpacingParAlways i ->
VerticalSpacingParAlways $ case indent of VerticalSpacingParAlways $ case indent of
BrIndentNone -> i BrIndentNone -> i
BrIndentRegular -> BrIndentRegular -> i + indAmount
i BrIndentRegularForce -> i + indAmount
+ (confUnpack
$ _lconfig_indentAmount
$ _conf_layout
$ config
)
BrIndentSpecial j -> i + j BrIndentSpecial j -> i + j
VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of VerticalSpacingParSome i ->
VerticalSpacingParSome $ case indent of
BrIndentNone -> i BrIndentNone -> i
BrIndentRegular -> BrIndentRegular -> i + indAmount
i + (confUnpack $ _lconfig_indentAmount $ _conf_layout $ config) BrIndentRegularForce -> i + indAmount
BrIndentSpecial j -> i + j BrIndentSpecial j -> i + j
} }
| vs <- mVs
, indent == BrIndentNone || _vs_onlyZeroAddInd vs == False
]
BDBaseYPushCur bd -> do BDBaseYPushCur bd -> do
mVs <- rec bd mVs <- rec bd
return $ mVs <&> \vs -> vs return $ mVs <&> \vs -> vs
@ -446,8 +472,8 @@ getSpacing !bridoc = rec bridoc
mVs <- rec sameLine mVs <- rec sameLine
mIndSp <- rec indented mIndSp <- rec indented
return return
$ [ VerticalSpacing lsp pspResult parFlagResult $ [ VerticalSpacing lsp pspResult parFlagResult False -- TODO92 should we turn this on?
| VerticalSpacing lsp mPsp _ <- mVs | VerticalSpacing lsp mPsp _ _ <- mVs
, indSp <- mIndSp , indSp <- mIndSp
, lineMax <- getMaxVS $ mIndSp , lineMax <- getMaxVS $ mIndSp
, let , let
@ -468,49 +494,59 @@ getSpacing !bridoc = rec bridoc
BDPar{} -> error "BDPar with indent in getSpacing" BDPar{} -> error "BDPar with indent in getSpacing"
BDAlt [] -> error "empty BDAlt" BDAlt [] -> error "empty BDAlt"
BDAlt (alt : _) -> rec alt BDAlt (alt : _) -> rec alt
BDForceMultiline bd -> do BDForceAlt ForceMultiline bd -> do
mVs <- rec bd mVs <- rec bd
return $ mVs >>= _vs_paragraph .> \case return $ mVs >>= _vs_paragraph .> \case
VerticalSpacingParNone -> LineModeInvalid VerticalSpacingParNone -> LineModeInvalid
_ -> mVs _ -> mVs
BDForceSingleline bd -> do BDForceAlt ForceSingleline bd -> do
mVs <- rec bd mVs <- rec bd
return $ mVs >>= _vs_paragraph .> \case return $ mVs >>= _vs_paragraph .> \case
VerticalSpacingParNone -> mVs VerticalSpacingParNone -> mVs
_ -> LineModeInvalid _ -> LineModeInvalid
BDForceAlt ForceZeroAdd bd -> do
mVs <- rec bd
pure $ [ vs { _vs_onlyZeroAddInd = True } | vs <- mVs ]
BDForwardLineMode bd -> rec bd BDForwardLineMode bd -> rec bd
BDExternal _ txt -> return $ LineModeValid $ case Text.lines txt of BDExternal _ txt -> return $ LineModeValid $ case Text.lines txt of
[t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False [t] ->
_ -> VerticalSpacing 999 VerticalSpacingParNone False VerticalSpacing (Text.length t) VerticalSpacingParNone False False
_ -> VerticalSpacing 999 VerticalSpacingParNone False False
BDPlain txt -> return $ LineModeValid $ case Text.lines txt of BDPlain txt -> return $ LineModeValid $ case Text.lines txt of
[t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False [t] ->
_ -> VerticalSpacing 999 VerticalSpacingParNone False VerticalSpacing (Text.length t) VerticalSpacingParNone False False
_ -> VerticalSpacing 999 VerticalSpacingParNone False False
BDQueueComments _comms bd -> rec bd BDQueueComments _comms bd -> rec bd
BDFlushCommentsPrior _loc bd -> rec bd BDFlushCommentsPrior _loc bd -> rec bd
BDFlushCommentsPost _loc _shouldMark bd -> rec bd BDFlushCommentsPost _loc _shouldMark bd -> rec bd
BDEntryDelta _dp bd -> rec bd BDEntryDelta _dp bd -> rec bd
BDLines [] -> 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 BDLines (l1 : lR) -> do
mVs <- rec l1 mVs <- rec l1
mVRs <- rec `mapM` lR mVRs <- rec `mapM` lR
let lSps = mVs : mVRs let lSps = mVs : mVRs
return return
$ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False False
| VerticalSpacing lsp _ _ <- mVs -- 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 , lineMax <- getMaxVS $ maxVs $ lSps
] ]
BDEnsureIndent indent bd -> do BDEnsureIndent indent bd -> do
mVs <- rec bd mVs <- rec bd
let let addInd = case indent of
addInd = case indent of
BrIndentNone -> 0 BrIndentNone -> 0
BrIndentRegular -> BrIndentRegular -> indAmount
confUnpack $ _lconfig_indentAmount $ _conf_layout $ config BrIndentRegularForce -> indAmount
BrIndentSpecial i -> i BrIndentSpecial i -> i
return $ mVs <&> \(VerticalSpacing lsp psp pf) -> return $ mVs <&> \(VerticalSpacing lsp psp pf _) ->
VerticalSpacing (lsp + addInd) psp pf VerticalSpacing (lsp + addInd) psp pf False
BDNonBottomSpacing b bd -> do BDForceAlt (NonBottomSpacing b) bd -> do
mVs <- rec bd mVs <- rec bd
return $ mVs <|> LineModeValid return $ mVs <|> LineModeValid
(VerticalSpacing (VerticalSpacing
@ -520,11 +556,12 @@ getSpacing !bridoc = rec bridoc
else VerticalSpacingParAlways colMax else VerticalSpacingParAlways colMax
) )
False False
False
) )
BDSetParSpacing bd -> do BDForceAlt SetParSpacing bd -> do
mVs <- rec bd mVs <- rec bd
return $ mVs <&> \vs -> vs { _vs_parFlag = True } return $ mVs <&> \vs -> vs { _vs_parFlag = True }
BDForceParSpacing bd -> do BDForceAlt ForceParSpacing bd -> do
mVs <- rec bd mVs <- rec bd
return return
$ [ vs $ [ vs
@ -541,12 +578,12 @@ getSpacing !bridoc = rec bridoc
++ "): mVs=" ++ "): mVs="
++ show r ++ show r
return r return r
return result pure result
maxVs maxVs
:: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing
maxVs = foldl' maxVs = foldl'
(liftM2 (liftM2
(\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing (\(VerticalSpacing x1 x2 _ _) (VerticalSpacing y1 y2 _ _) -> VerticalSpacing
(max x1 y1) (max x1 y1)
(case (x2, y2) of (case (x2, y2) of
(x, VerticalSpacingParNone) -> x (x, VerticalSpacingParNone) -> x
@ -561,14 +598,16 @@ getSpacing !bridoc = rec bridoc
VerticalSpacingParSome $ max x y VerticalSpacingParSome $ max x y
) )
False False
False
) )
) )
(LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False) (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False False)
sumVs sumVs
:: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing
sumVs sps = foldl' (liftM2 go) initial sps sumVs sps = foldl' (liftM2 go) initial sps
where where
go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing go (VerticalSpacing x1 x2 x3 x4) (VerticalSpacing y1 y2 _ y4) =
VerticalSpacing
(x1 + y1) (x1 + y1)
(case (x2, y2) of (case (x2, y2) of
(x, VerticalSpacingParNone) -> x (x, VerticalSpacingParNone) -> x
@ -583,6 +622,7 @@ getSpacing !bridoc = rec bridoc
VerticalSpacingParSome $ x + y VerticalSpacingParSome $ x + y
) )
x3 x3
(x4 || y4)
singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone
singleline _ = False singleline _ = False
isPar (LineModeValid x) = _vs_parFlag x isPar (LineModeValid x) = _vs_parFlag x
@ -590,9 +630,10 @@ getSpacing !bridoc = rec bridoc
parFlag = case sps of parFlag = case sps of
[] -> True [] -> True
_ -> all singleline (List.init sps) && isPar (List.last sps) _ -> 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 :: 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 VerticalSpacingParSome i -> i
VerticalSpacingParNone -> 0 VerticalSpacingParNone -> 0
VerticalSpacingParAlways i -> i VerticalSpacingParAlways i -> i
@ -621,7 +662,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
config <- mAsk config <- mAsk
let colMax = config & _conf_layout & _lconfig_cols & confUnpack let colMax = config & _conf_layout & _lconfig_cols & confUnpack
let let
hasOkColCount (VerticalSpacing lsp psp _) = lsp <= colMax && case psp of hasOkColCount (VerticalSpacing lsp psp _ _) = lsp <= colMax && case psp of
VerticalSpacingParNone -> True VerticalSpacingParNone -> True
VerticalSpacingParSome i -> i <= colMax VerticalSpacingParSome i -> i <= colMax
VerticalSpacingParAlways{} -> True VerticalSpacingParAlways{} -> True
@ -638,6 +679,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
let let
allowHangingQuasiQuotes = allowHangingQuasiQuotes =
config & _conf_layout & _lconfig_allowHangingQuasiQuotes & confUnpack 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 let -- this is like List.nub, with one difference: if two elements
-- are unequal only in _vs_paragraph, with both ParAlways, we -- are unequal only in _vs_paragraph, with both ParAlways, we
-- treat them like equals and replace the first occurence with the -- treat them like equals and replace the first occurence with the
@ -690,12 +732,14 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
. preFilterLimit . preFilterLimit
result <- case brdc of result <- case brdc of
-- BDWrapAnnKey _annKey bd -> rec bd -- BDWrapAnnKey _annKey bd -> rec bd
BDEmpty -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] BDEmpty -> return $ [VerticalSpacing 0 VerticalSpacingParNone False False]
BDLit t -> BDLit t -> do
return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] let l = Text.length t
pure $ [VerticalSpacing l VerticalSpacingParNone False False]
BDSeq list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list BDSeq list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list
BDCols _sig 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 BDAddBaseY indent bd -> do
mVs <- rec bd mVs <- rec bd
return $ mVs <&> \vs -> vs return $ mVs <&> \vs -> vs
@ -704,18 +748,13 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
VerticalSpacingParAlways i -> VerticalSpacingParAlways i ->
VerticalSpacingParAlways $ case indent of VerticalSpacingParAlways $ case indent of
BrIndentNone -> i BrIndentNone -> i
BrIndentRegular -> BrIndentRegular -> i + indAmount
i BrIndentRegularForce -> i + indAmount
+ (confUnpack
$ _lconfig_indentAmount
$ _conf_layout
$ config
)
BrIndentSpecial j -> i + j BrIndentSpecial j -> i + j
VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of
BrIndentNone -> i BrIndentNone -> i
BrIndentRegular -> BrIndentRegular -> i + indAmount
i + (confUnpack $ _lconfig_indentAmount $ _conf_layout $ config) BrIndentRegularForce -> i + indAmount
BrIndentSpecial j -> i + j BrIndentSpecial j -> i + j
} }
BDBaseYPushCur bd -> do BDBaseYPushCur bd -> do
@ -744,7 +783,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
mVss <- filterAndLimit <$> rec sameLine mVss <- filterAndLimit <$> rec sameLine
indSps <- filterAndLimit <$> rec indented indSps <- filterAndLimit <$> rec indented
let mVsIndSp = take limit $ [ (x, y) | x <- mVss, y <- indSps ] let mVsIndSp = take limit $ [ (x, y) | x <- mVss, y <- indSps ]
return $ mVsIndSp <&> \(VerticalSpacing lsp mPsp _, indSp) -> return $ mVsIndSp <&> \(VerticalSpacing lsp mPsp _ _, indSp) ->
VerticalSpacing VerticalSpacing
lsp lsp
(case mPsp of (case mPsp of
@ -760,6 +799,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
== VerticalSpacingParNone == VerticalSpacingParNone
&& _vs_parFlag indSp && _vs_parFlag indSp
) )
False -- TODO92 should we turn this on?
BDPar{} -> error "BDPar with indent in getSpacing" BDPar{} -> error "BDPar with indent in getSpacing"
BDAlt [] -> error "empty BDAlt" BDAlt [] -> error "empty BDAlt"
@ -767,31 +807,35 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
BDAlt alts -> do BDAlt alts -> do
r <- rec `mapM` alts r <- rec `mapM` alts
return $ filterAndLimit =<< r return $ filterAndLimit =<< r
BDForceMultiline bd -> do BDForceAlt ForceMultiline bd -> do
mVs <- filterAndLimit <$> rec bd mVs <- filterAndLimit <$> rec bd
return $ filter ((/= VerticalSpacingParNone) . _vs_paragraph) mVs return $ filter ((/= VerticalSpacingParNone) . _vs_paragraph) mVs
BDForceSingleline bd -> do BDForceAlt ForceSingleline bd -> do
mVs <- filterAndLimit <$> rec bd mVs <- filterAndLimit <$> rec bd
return $ filter ((== VerticalSpacingParNone) . _vs_paragraph) mVs return $ filter ((== VerticalSpacingParNone) . _vs_paragraph) mVs
BDForwardLineMode bd -> rec bd BDForwardLineMode bd -> rec bd
BDExternal _ txt | [t] <- Text.lines txt -> BDExternal _ txt | [t] <- Text.lines txt -> do
return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] let l = Text.length t
pure $ [VerticalSpacing l VerticalSpacingParNone False False]
BDExternal{} -> return $ [] -- yes, we just assume that we cannot properly layout BDExternal{} -> return $ [] -- yes, we just assume that we cannot properly layout
-- this. -- this.
BDPlain t -> return BDPlain t -> do
let tl = Text.length
pure
[ case Text.lines t of [ case Text.lines t of
[] -> VerticalSpacing 0 VerticalSpacingParNone False [] -> VerticalSpacing 0 VerticalSpacingParNone False False
[t1] -> [t1] ->
VerticalSpacing (Text.length t1) VerticalSpacingParNone False VerticalSpacing (tl t1) VerticalSpacingParNone False False
(t1 : _) -> (t1 : _) ->
VerticalSpacing (Text.length t1) (VerticalSpacingParAlways 0) True VerticalSpacing (tl t1) (VerticalSpacingParAlways 0) True False
| allowHangingQuasiQuotes | allowHangingQuasiQuotes
] ]
BDQueueComments _comms bd -> rec bd BDQueueComments _comms bd -> rec bd
BDFlushCommentsPrior _loc bd -> rec bd BDFlushCommentsPrior _loc bd -> rec bd
BDFlushCommentsPost _loc _shouldMark bd -> rec bd BDFlushCommentsPost _loc _shouldMark bd -> rec bd
BDEntryDelta _dp bd -> rec bd BDEntryDelta _dp bd -> rec bd
BDLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] BDLines [] ->
pure $ [VerticalSpacing 0 VerticalSpacingParNone False False]
BDLines ls@(_ : _) -> do BDLines ls@(_ : _) -> do
-- we simply assume that lines is only used "properly", i.e. in -- 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 -- 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 let
worbled = fmap reverse $ sequence $ reverse $ lSpss worbled = fmap reverse $ sequence $ reverse $ lSpss
sumF lSps@(lSp1 : _) = sumF lSps@(lSp1 : _) =
VerticalSpacing (_vs_sameLine lSp1) (spMakePar $ maxVs lSps) False VerticalSpacing (_vs_sameLine lSp1)
(spMakePar $ maxVs lSps)
False
False -- TODO92
sumF [] = sumF [] =
error error
$ "should not happen. if my logic does not fail" $ "should not happen. if my logic does not fail"
@ -824,12 +871,12 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
let let
addInd = case indent of addInd = case indent of
BrIndentNone -> 0 BrIndentNone -> 0
BrIndentRegular -> BrIndentRegular -> indAmount
confUnpack $ _lconfig_indentAmount $ _conf_layout $ config BrIndentRegularForce -> indAmount
BrIndentSpecial i -> i BrIndentSpecial i -> i
return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> return $ mVs <&> \(VerticalSpacing lsp psp parFlag _) ->
VerticalSpacing (lsp + addInd) psp parFlag VerticalSpacing (lsp + addInd) psp parFlag False
BDNonBottomSpacing b bd -> do BDForceAlt (NonBottomSpacing b) bd -> do
-- TODO: the `b` flag is an ugly hack, but I was not able to make -- 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 -- all tests work without it. It should be possible to have
-- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this
@ -844,6 +891,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
else VerticalSpacingParAlways colMax else VerticalSpacingParAlways colMax
) )
False False
False
] ]
else mVs <&> \vs -> vs else mVs <&> \vs -> vs
{ _vs_sameLine = min colMax (_vs_sameLine vs) { _vs_sameLine = min colMax (_vs_sameLine vs)
@ -884,16 +932,19 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- False) -- False)
-- mVs -- mVs
-- ] -- ]
BDSetParSpacing bd -> do BDForceAlt SetParSpacing bd -> do
mVs <- rec bd mVs <- rec bd
return $ mVs <&> \vs -> vs { _vs_parFlag = True } return $ mVs <&> \vs -> vs { _vs_parFlag = True }
BDForceParSpacing bd -> do BDForceAlt ForceParSpacing bd -> do
mVs <- preFilterLimit <$> rec bd mVs <- preFilterLimit <$> rec bd
return return
$ [ vs $ [ vs
| vs <- mVs | vs <- mVs
, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone , _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 BDDebug s bd -> do
r <- rec bd r <- rec bd
tellDebugMess tellDebugMess
@ -907,7 +958,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
return result return result
maxVs :: [VerticalSpacing] -> VerticalSpacing maxVs :: [VerticalSpacing] -> VerticalSpacing
maxVs = foldl' maxVs = foldl'
(\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing (\(VerticalSpacing x1 x2 _ _) (VerticalSpacing y1 y2 _ _) -> VerticalSpacing
(max x1 y1) (max x1 y1)
(case (x2, y2) of (case (x2, y2) of
(x, VerticalSpacingParNone) -> x (x, VerticalSpacingParNone) -> x
@ -922,12 +973,14 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
VerticalSpacingParSome $ max x y VerticalSpacingParSome $ max x y
) )
False False
False
) )
(VerticalSpacing 0 VerticalSpacingParNone False) (VerticalSpacing 0 VerticalSpacingParNone False False)
sumVs :: [VerticalSpacing] -> VerticalSpacing sumVs :: [VerticalSpacing] -> VerticalSpacing
sumVs sps = foldl' go initial sps sumVs sps = foldl' go initial sps
where where
go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing go (VerticalSpacing x1 x2 x3 x4) (VerticalSpacing y1 y2 _ y4) =
VerticalSpacing
(x1 + y1) (x1 + y1)
(case (x2, y2) of (case (x2, y2) of
(x, VerticalSpacingParNone) -> x (x, VerticalSpacingParNone) -> x
@ -942,37 +995,43 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
VerticalSpacingParSome $ x + y VerticalSpacingParSome $ x + y
) )
x3 x3
(x4 || y4)
singleline x = _vs_paragraph x == VerticalSpacingParNone singleline x = _vs_paragraph x == VerticalSpacingParNone
isPar x = _vs_parFlag x isPar x = _vs_parFlag x
parFlag = case sps of parFlag = case sps of
[] -> True [] -> True
_ -> all singleline (List.init sps) && isPar (List.last sps) _ -> 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 -> Int
getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of getMaxVS (VerticalSpacing x1 x2 _ _) = x1 `max` case x2 of
VerticalSpacingParSome i -> i VerticalSpacingParSome i -> i
VerticalSpacingParNone -> 0 VerticalSpacingParNone -> 0
VerticalSpacingParAlways i -> i VerticalSpacingParAlways i -> i
spMakePar :: VerticalSpacing -> VerticalSpacingPar spMakePar :: VerticalSpacing -> VerticalSpacingPar
spMakePar (VerticalSpacing x1 x2 _) = case x2 of spMakePar (VerticalSpacing x1 x2 _ _) = case x2 of
VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i
VerticalSpacingParNone -> VerticalSpacingParSome $ x1 VerticalSpacingParNone -> VerticalSpacingParSome $ x1
VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i
fixIndentationForMultiple fixIndentationForMultiple
:: (MonadMultiReader (CConfig Identity) m) => AltCurPos -> BrIndent -> m Int :: (MonadMultiReader (CConfig Identity) m)
=> AltCurPos
-> BrIndent
-> m (Int, Bool)
fixIndentationForMultiple acp indent = do fixIndentationForMultiple acp indent = do
indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
let let
indAddRaw = case indent of (indAddRaw, strongFlag) = case indent of
BrIndentNone -> 0 BrIndentNone -> (0, False)
BrIndentRegular -> indAmount BrIndentRegular -> (indAmount, False)
BrIndentSpecial i -> i BrIndentRegularForce -> (indAmount, True)
BrIndentSpecial i -> (i, False)
-- for IndentPolicyMultiple, we restrict the amount of added -- for IndentPolicyMultiple, we restrict the amount of added
-- indentation in such a manner that we end up on a multiple of the -- indentation in such a manner that we end up on a multiple of the
-- base indentation. -- base indentation.
indPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack indPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
pure $ if indPolicy == IndentPolicyMultiple pure
$ ( if indPolicy == IndentPolicyMultiple
then then
let let
indAddMultiple1 = indAddMultiple1 =
@ -982,3 +1041,5 @@ fixIndentationForMultiple acp indent = do
else indAddMultiple1 else indAddMultiple1
in indAddMultiple2 in indAddMultiple2
else indAddRaw else indAddRaw
, strongFlag
)

31
source/library/Language/Haskell/Brittany/Internal/Transformations/T2_Floating.hs
View File

@ -5,8 +5,11 @@ module Language.Haskell.Brittany.Internal.Transformations.T2_Floating where
import qualified Data.Generics.Uniplate.Direct as Uniplate import qualified Data.Generics.Uniplate.Direct as Uniplate
import qualified GHC.OldList as List import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Prelude import GHC ( GenLocated(L) )
import Language.Haskell.Brittany.Internal.Components.BriDoc 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 descendQueueComments = transformDownMay $ \case
-- queue comments floating in -- queue comments floating in
BDQueueComments comms1 (BDQueueComments comms2 x) -> 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) -> BDQueueComments comms1 (BDPar ind line indented) ->
Just $ BDPar ind (BDQueueComments comms1 line) indented Just $ BDPar ind (BDQueueComments comms1 line) indented
BDQueueComments comms1 (BDSeq (l : lr)) -> BDQueueComments comms1 (BDSeq (l : lr)) ->
@ -131,11 +134,11 @@ transformSimplifyFloating = stepBO .> stepFull
descendAddB = transformDownMay $ \case descendAddB = transformDownMay $ \case
BDAddBaseY BrIndentNone x -> Just x BDAddBaseY BrIndentNone x -> Just x
-- AddIndent floats into Lines. -- AddIndent floats into Lines.
BDAddBaseY indent (BDLines lines) -> BDAddBaseY _ind (BDLines lines) ->
Just $ BDLines $ BDAddBaseY indent <$> lines Just $ BDLines $ lines
-- AddIndent floats into last column -- AddIndent floats into last column
BDAddBaseY indent (BDCols sig cols) -> BDAddBaseY ind (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] Just $ BDCols sig $ List.init cols ++ [BDAddBaseY ind $ List.last cols]
-- merge AddIndent and Par -- merge AddIndent and Par
BDAddBaseY ind1 (BDPar ind2 line indented) -> BDAddBaseY ind1 (BDPar ind2 line indented) ->
Just $ BDPar (mergeIndents ind1 ind2) line indented Just $ BDPar (mergeIndents ind1 ind2) line indented
@ -148,8 +151,8 @@ transformSimplifyFloating = stepBO .> stepFull
BDAddBaseY ind (BDSeq list) -> BDAddBaseY ind (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]
BDAddBaseY _ lit@BDLit{} -> Just $ lit BDAddBaseY _ lit@BDLit{} -> Just $ lit
BDAddBaseY ind (BDBaseYPushCur x) -> BDAddBaseY _ind (BDBaseYPushCur x) ->
Just $ BDBaseYPushCur (BDAddBaseY ind x) Just $ BDBaseYPushCur x
-- TODO92 We have several rules here in conflict with each other. -- TODO92 We have several rules here in conflict with each other.
-- Unless I forget some detail related to some elements being able -- Unless I forget some detail related to some elements being able
-- to float in further, we probably should define some -- to float in further, we probably should define some
@ -193,19 +196,19 @@ transformSimplifyFloating = stepBO .> stepFull
-- copying them here (incompletely). -- copying them here (incompletely).
BDAddBaseY BrIndentNone x -> Just $ x BDAddBaseY BrIndentNone x -> Just $ x
-- AddIndent floats into Lines. -- AddIndent floats into Lines.
BDAddBaseY indent (BDLines lines) -> BDAddBaseY _ind (BDLines lines) ->
Just $ BDLines $ BDAddBaseY indent <$> lines Just $ BDLines lines
-- AddIndent floats into last column -- AddIndent floats into last column
BDAddBaseY indent (BDCols sig cols) -> BDAddBaseY ind (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] Just $ BDCols sig $ List.init cols ++ [BDAddBaseY ind $ List.last cols]
BDAddBaseY ind (BDSeq list) -> BDAddBaseY ind (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]
-- merge AddIndent and Par -- merge AddIndent and Par
BDAddBaseY ind1 (BDPar ind2 line indented) -> BDAddBaseY ind1 (BDPar ind2 line indented) ->
Just $ BDPar (mergeIndents ind1 ind2) line indented Just $ BDPar (mergeIndents ind1 ind2) line indented
BDAddBaseY _ lit@BDLit{} -> Just $ lit BDAddBaseY _ lit@BDLit{} -> Just $ lit
BDAddBaseY ind (BDBaseYPushCur x) -> BDAddBaseY _ind (BDBaseYPushCur x) ->
Just $ BDBaseYPushCur (BDAddBaseY ind x) Just $ BDBaseYPushCur x
-- EnsureIndent float-in -- EnsureIndent float-in
-- BDEnsureIndent indent (BDCols sig (col:colr)) -> -- BDEnsureIndent indent (BDCols sig (col:colr)) ->
-- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr))

6
source/library/Language/Haskell/Brittany/Internal/Transformations/T4_Columns.hs
View File

@ -129,8 +129,7 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
BDIndentLevelPop{} -> Nothing BDIndentLevelPop{} -> Nothing
BDPar{} -> Nothing BDPar{} -> Nothing
BDAlt{} -> Nothing BDAlt{} -> Nothing
BDForceMultiline{} -> Nothing BDForceAlt{} -> Nothing
BDForceSingleline{} -> Nothing
BDForwardLineMode{} -> Nothing BDForwardLineMode{} -> Nothing
BDExternal{} -> Nothing BDExternal{} -> Nothing
BDPlain{} -> Nothing BDPlain{} -> Nothing
@ -140,7 +139,4 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
BDFlushCommentsPost{} -> Nothing BDFlushCommentsPost{} -> Nothing
BDEntryDelta{} -> Nothing BDEntryDelta{} -> Nothing
BDEnsureIndent{} -> Nothing BDEnsureIndent{} -> Nothing
BDSetParSpacing{} -> Nothing
BDForceParSpacing{} -> Nothing
BDDebug{} -> Nothing BDDebug{} -> Nothing
BDNonBottomSpacing _ x -> Just x

46
source/library/Language/Haskell/Brittany/Internal/Utils.hs
View File

@ -20,7 +20,7 @@ import qualified GHC.Types.Name.Reader as RdrName (rdrNameOcc)
import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Types.SrcLoc as GHC
import qualified GHC.Utils.Outputable as GHC import qualified GHC.Utils.Outputable as GHC
import qualified GHC.Parser.Annotation 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 Text.PrettyPrint as PP
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified System.IO.Unsafe as Unsafe import qualified System.IO.Unsafe as Unsafe
@ -108,7 +108,6 @@ customLayouterNoSrcSpansF layoutF =
`extQ` internalLayouterSrcSpan `extQ` internalLayouterSrcSpan
`extQ` internalLayouterRdrName `extQ` internalLayouterRdrName
`extQ` realSrcSpan `extQ` realSrcSpan
`extQ` deltaComment
`extQ` anchored `extQ` anchored
`ext1Q` srcSpanAnn `ext1Q` srcSpanAnn
-- `ext2Q` located -- `ext2Q` located
@ -122,9 +121,9 @@ customLayouterNoSrcSpansF layoutF =
anchored (GHC.Anchor _ op) = f op anchored (GHC.Anchor _ op) = f op
srcSpanAnn :: forall a . Data a => GHC.SrcSpanAnn' a -> NodeLayouter srcSpanAnn :: forall a . Data a => GHC.SrcSpanAnn' a -> NodeLayouter
srcSpanAnn (GHC.SrcSpanAnn ann _loc) = f ann srcSpanAnn (GHC.SrcSpanAnn ann _loc) = f ann
deltaComment :: GHC.LEpaComment -> NodeLayouter -- deltaComment :: GHC.LEpaComment -> NodeLayouter
deltaComment (GHC.L anchor (GHC.EpaComment token prior)) = -- deltaComment (GHC.L anchor (GHC.EpaComment token prior)) =
f (GHC.L (ExactPrint.Utils.ss2deltaEnd prior (GHC.anchor anchor)) token) -- f (GHC.L (ExactPrint.Utils.ss2deltaEnd prior (GHC.anchor anchor)) token)
-- located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter -- located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter
-- located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a -- located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a
-- where -- where
@ -143,11 +142,34 @@ customLayouterNoAnnsF layoutF =
`extQ` internalLayouterOccName `extQ` internalLayouterOccName
`extQ` internalLayouterSrcSpan `extQ` internalLayouterSrcSpan
`extQ` internalLayouterRdrName `extQ` internalLayouterRdrName
`extQ` realSrcSpan
`extQ` realSrcLoc
`ext2Q` located `ext2Q` located
`extQ` lepaComment
where where
DataToLayouter f = defaultLayouterF layoutF DataToLayouter f = defaultLayouterF layoutF
located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter
located (GHC.L _ss a) = runDataToLayouter layoutF a 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 :: String -> NodeLayouter
internalLayouterSimple s = NodeLayouter (length s) False (const $ PP.text s) internalLayouterSimple s = NodeLayouter (length s) False (const $ PP.text s)
@ -248,9 +270,9 @@ briDocToDoc :: BriDoc -> PP.Doc
briDocToDoc = astToDoc . removeAnnotations briDocToDoc = astToDoc . removeAnnotations
where where
removeAnnotations = Uniplate.transform $ \case removeAnnotations = Uniplate.transform $ \case
BDFlushCommentsPrior _ x -> x -- BDFlushCommentsPrior _ x -> x
BDFlushCommentsPost _ _ x -> x -- BDFlushCommentsPost _ _ x -> x
BDQueueComments _ x -> x -- BDQueueComments _ x -> x
x -> x x -> x
briDocToDocWithAnns :: BriDoc -> PP.Doc briDocToDocWithAnns :: BriDoc -> PP.Doc
@ -305,3 +327,11 @@ traceIfDumpConf s accessor val = do
Unsafe.unsafePerformIO $ do Unsafe.unsafePerformIO $ do
f ("---- " ++ s ++ " ----\n" ++ show val) f ("---- " ++ s ++ " ----\n" ++ show val)
pure $ pure () 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

12
source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/AlignmentAlgo.hs
View File

@ -402,8 +402,7 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
BDIndentLevelPop bd -> rec bd BDIndentLevelPop bd -> rec bd
BDPar _ line _ -> rec line BDPar _ line _ -> rec line
BDAlt{} -> error "briDocLineLength BDAlt" BDAlt{} -> error "briDocLineLength BDAlt"
BDForceMultiline bd -> rec bd BDForceAlt _ bd -> rec bd
BDForceSingleline bd -> rec bd
BDForwardLineMode bd -> rec bd BDForwardLineMode bd -> rec bd
BDExternal _ t -> return $ Text.length t BDExternal _ t -> return $ Text.length t
BDPlain 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 BDEntryDelta _dp bd -> rec bd
BDLines [] -> error "briDocLineLength BDLines []" BDLines [] -> error "briDocLineLength BDLines []"
BDEnsureIndent _ bd -> rec bd BDEnsureIndent _ bd -> rec bd
BDSetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd
BDNonBottomSpacing _ bd -> rec bd
BDDebug _ bd -> rec bd BDDebug _ bd -> rec bd
briDocIsMultiLine :: BriDoc -> Bool briDocIsMultiLine :: BriDoc -> Bool
@ -437,8 +433,7 @@ briDocIsMultiLine briDoc = rec briDoc
BDIndentLevelPop bd -> rec bd BDIndentLevelPop bd -> rec bd
BDPar{} -> True BDPar{} -> True
BDAlt{} -> error "briDocIsMultiLine BDAlt" BDAlt{} -> error "briDocIsMultiLine BDAlt"
BDForceMultiline _ -> True BDForceAlt _ bd -> rec bd
BDForceSingleline bd -> rec bd
BDForwardLineMode bd -> rec bd BDForwardLineMode bd -> rec bd
BDExternal _ t | [_] <- Text.lines t -> False BDExternal _ t | [_] <- Text.lines t -> False
BDExternal{} -> True BDExternal{} -> True
@ -452,9 +447,6 @@ briDocIsMultiLine briDoc = rec briDoc
BDLines [_] -> False BDLines [_] -> False
BDLines [] -> error "briDocIsMultiLine BDLines []" BDLines [] -> error "briDocIsMultiLine BDLines []"
BDEnsureIndent _ bd -> rec bd BDEnsureIndent _ bd -> rec bd
BDSetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd
BDNonBottomSpacing _ bd -> rec bd
BDDebug _ bd -> rec bd BDDebug _ bd -> rec bd
briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo

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

@ -5,12 +5,12 @@
import Data.Coerce (coerce) import Data.Coerce (coerce)
import Data.List (groupBy) import Data.List (groupBy)
import qualified Data.Maybe 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 as Text
import qualified Data.Text.IO as Text.IO 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 qualified Data.Map.Strict as Map
import Data.These -- import Data.These
import Language.Haskell.Brittany.Internal import Language.Haskell.Brittany.Internal
import Language.Haskell.Brittany.Internal.Config.Config import Language.Haskell.Brittany.Internal.Config.Config
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
@ -21,6 +21,7 @@ import System.Timeout (timeout)
import Test.Hspec import Test.Hspec
import qualified Text.Parsec as Parsec import qualified Text.Parsec as Parsec
import Text.Parsec.Text (Parser) import Text.Parsec.Text (Parser)
import qualified Data.List.Extra
hush :: Either a b -> Maybe b hush :: Either a b -> Maybe b
hush = either (const Nothing) Just hush = either (const Nothing) Just
@ -61,7 +62,9 @@ roundTripEqualWithTimeout time t =
data InputLine data InputLine
= GroupLine Text = GroupLine Text
| HeaderLine Text | HeaderLine Text
| HeaderLineGolden Text
| PendingLine | PendingLine
| HeaderLineGoldenOutput
| NormalLine Text | NormalLine Text
| CommentLine | CommentLine
deriving Show deriving Show
@ -70,6 +73,7 @@ data TestCase = TestCase
{ testName :: Text { testName :: Text
, isPending :: Bool , isPending :: Bool
, content :: Text , content :: Text
, expectedOutput :: Maybe Text -- Nothing if input is expected not to change
} }
main :: IO () main :: IO ()
@ -146,8 +150,9 @@ main = do
(tests `forM_` \test -> do (tests `forM_` \test -> do
(if isPending test then before_ pending else id) (if isPending test then before_ pending else id)
$ it (Text.unpack $ testName test) $ it (Text.unpack $ testName test)
$ roundTripEqual conf $ case expectedOutput test of
$ content test Nothing -> roundTripEqual conf (content test)
Just expctd -> goldenTest conf (content test) expctd
) )
ks ks
) )
@ -187,13 +192,30 @@ main = do
{ testName = n { testName = n
, isPending = any isPendingLine rest , isPending = any isPendingLine rest
, content = Text.unlines normalLines , 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 -> l ->
error $ "first non-empty line must start with #test footest\n" ++ show l error $ "first non-empty line must start with #test footest\n" ++ show l
extractNormal (NormalLine l) = Just l extractNormal (NormalLine l) = Just l
extractNormal _ = Nothing extractNormal _ = Nothing
isPendingLine PendingLine{} = True isPendingLine PendingLine{} = True
isPendingLine _ = False isPendingLine _ = False
isGoldenOutputLine = \case
HeaderLineGoldenOutput -> True
_ -> False
specialLineParser :: Parser InputLine specialLineParser :: Parser InputLine
specialLineParser = Parsec.choice specialLineParser = Parsec.choice
[ [ GroupLine $ Text.pack name [ [ GroupLine $ Text.pack name
@ -208,11 +230,21 @@ main = do
, name <- Parsec.many1 $ Parsec.noneOf "\r\n:" , name <- Parsec.many1 $ Parsec.noneOf "\r\n:"
, _ <- Parsec.eof , _ <- 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 , [ PendingLine
| _ <- Parsec.try $ Parsec.string "#pending" | _ <- Parsec.try $ Parsec.string "#pending"
, _ <- Parsec.optional $ many (Parsec.noneOf "\r\n") , _ <- Parsec.optional $ many (Parsec.noneOf "\r\n")
, _ <- Parsec.eof , _ <- Parsec.eof
] ]
, [ HeaderLineGoldenOutput
| _ <- Parsec.try $ Parsec.string "#expected"
, _ <- Parsec.eof
]
, [ CommentLine , [ CommentLine
| _ <- Parsec.many $ Parsec.oneOf " \t" | _ <- Parsec.many $ Parsec.oneOf " \t"
, _ <- Parsec.optional $ Parsec.string "##" <* many , _ <- Parsec.optional $ Parsec.string "##" <* many
@ -236,6 +268,7 @@ main = do
grouperG _ _ = True grouperG _ _ = True
grouperT :: InputLine -> InputLine -> Bool grouperT :: InputLine -> InputLine -> Bool
grouperT _ HeaderLine{} = False grouperT _ HeaderLine{} = False
grouperT _ HeaderLineGolden{} = False
grouperT _ _ = True grouperT _ _ = True
@ -247,6 +280,11 @@ roundTripEqual c t =
fmap (fmap PPTextWrapper) (parsePrintModuleTests c "TestFakeFileName.hs" t) fmap (fmap PPTextWrapper) (parsePrintModuleTests c "TestFakeFileName.hs" t)
`shouldReturn` Right (PPTextWrapper 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 newtype PPTextWrapper = PPTextWrapper Text
deriving Eq deriving Eq
@ -277,6 +315,11 @@ defaultTestConfig = Config
, _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_allowHangingQuasiQuotes = coerce True
, _lconfig_experimentalSemicolonNewlines = coerce False , _lconfig_experimentalSemicolonNewlines = coerce False
-- , _lconfig_allowSinglelineRecord = 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_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True }
, _conf_preprocessor = _conf_preprocessor staticDefaultConfig , _conf_preprocessor = _conf_preprocessor staticDefaultConfig