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

Restrict aggressive horizontal alignment (fixes #21) 

- Add config values:
  _lconfig_alignmentLimit for roughly "max spaces inserted"
  _lconfig_alignmentBreakOnMultiline for stopping
  alignment after non-singleline-items
pull/35/head
Lennart Spitzner 2017-05-17 21:34:49 +02:00
parent 07164b39dc
commit 6448ee780a
6 changed files with 212 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src-literatetests/Main.hs
View File

@ -153,6 +153,8 @@ defaultTestConfig = Config
, _lconfig_importColumn = coerce (60 :: Int)
, _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
, _lconfig_alignmentLimit = coerce (30 :: Int)
, _lconfig_alignmentBreakOnMultiline = coerce True
}
, _conf_errorHandling = (_conf_errorHandling staticDefaultConfig)
{ _econf_omit_output_valid_check = coerce True

12
src-literatetests/tests.blt
View File

@ -774,6 +774,18 @@ foo a b = g a b -- fooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
#test issue 26b
foo a b = g a b where g a b = b + b * a -- fooooooooooooooooooooooooooooooooooo
#test aggressive alignment 1
func = do
abc <- expr
abcccccccccccccccccc <- expr
abcccccccccccccccccccccccccccccccccccccccccc <- expr
abccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc <- expr
#test example alignment 1
func (MyLongFoo abc def) = 1
func (Bar a d ) = 2
func _ = 3
###############################################################################
###############################################################################

2
src-unittests/TestUtils.hs
View File

@ -51,6 +51,8 @@ defaultTestConfig = Config
, _lconfig_importColumn = coerce (60 :: Int)
, _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
, _lconfig_alignmentLimit = coerce (30 :: Int)
, _lconfig_alignmentBreakOnMultiline = coerce True
}
, _conf_errorHandling = (_conf_errorHandling staticDefaultConfig)
{ _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever

96
src/Language/Haskell/Brittany/Backend.hs
View File

@ -38,7 +38,7 @@ import qualified Control.Monad.Trans.Writer.Strict as WriterS
briDocLineLength :: BriDoc -> Int
briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
-- the state encodes whether a separate was already
-- the state encodes whether a separator was already
-- appended at the current position.
where
rec = \case
@ -72,6 +72,40 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
BDNonBottomSpacing bd -> rec bd
BDDebug _ bd -> rec bd
briDocIsMultiLine :: BriDoc -> Bool
briDocIsMultiLine briDoc = rec briDoc
where
rec :: BriDoc -> Bool
rec = \case
BDEmpty -> False
BDLit _ -> False
BDSeq bds -> any rec bds
BDCols _ bds -> any rec bds
BDSeparator -> False
BDAddBaseY _ bd -> rec bd
BDBaseYPushCur bd -> rec bd
BDBaseYPop bd -> rec bd
BDIndentLevelPushCur bd -> rec bd
BDIndentLevelPop bd -> rec bd
BDPar _ _ _ -> True
BDAlt{} -> error "briDocIsMultiLine BDAlt"
BDForceMultiline _ -> True
BDForceSingleline bd -> rec bd
BDForwardLineMode bd -> rec bd
BDExternal _ _ _ _ -> True
BDAnnotationPrior _ bd -> rec bd
BDAnnotationKW _ _ bd -> rec bd
BDAnnotationRest _ bd -> rec bd
BDLines (_:_:_) -> True
BDLines [_ ] -> False
BDLines [] -> error "briDocIsMultiLine BDLines []"
BDEnsureIndent _ bd -> rec bd
BDProhibitMTEL bd -> rec bd
BDSetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd
BDNonBottomSpacing bd -> rec bd
BDDebug _ bd -> rec bd
layoutBriDocM
:: forall w m
. ( m ~ MultiRWSS.MultiRWST
@ -286,25 +320,31 @@ layoutBriDocM = \case
-- processInfo (_cbs_map finalState) colInfo
-- where
-- (colInfos, finalState) = StateS.runState (mergeBriDocs l) (ColBuildState IntMapS.empty 0)
alignColsLines :: [BriDoc]
-> m ()
alignColsLines :: [BriDoc] -> m ()
alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
curX <- do
state <- mGet
return $ either id (const 0) (_lstate_curYOrAddNewline state)
+ fromMaybe 0 (_lstate_addSepSpace state)
colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack
alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack
alignBreak <- mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack
case () of
_ ->
sequence_ $ List.intersperse layoutWriteEnsureNewlineBlock
$ colInfos <&> processInfo (processedMap curX colMax)
$ colInfos <&> processInfo processedMap
where
(colInfos, finalState) = StateS.runState (mergeBriDocs bridocs)
(ColBuildState IntMapS.empty 0)
maxZipper :: [Int] -> [Int] -> [Int]
maxZipper [] ys = ys
maxZipper xs [] = xs
maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr
processedMap :: Int -> Int -> ColMap2
processedMap curX colMax = fix $ \result ->
-- maxZipper :: [Int] -> [Int] -> [Int]
-- maxZipper [] ys = ys
-- maxZipper xs [] = xs
-- maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr
colAggregation :: [Int] -> Int
colAggregation xs = maximum [ x | x <- xs, x < minimum xs + alignMax ]
processedMap :: ColMap2
processedMap = fix $ \result ->
_cbs_map finalState <&> \(lastFlag, colSpacingss) ->
let colss = colSpacingss <&> \spss -> case reverse spss of
[] -> []
@ -317,7 +357,8 @@ layoutBriDocM = \case
fInit (ColumnSpacingRef _ i) = case IntMapL.lookup i result of
Nothing -> 0
Just (_, maxs, _) -> sum maxs
maxCols = Foldable.foldl1 maxZipper colss
maxCols = {-Foldable.foldl1 maxZipper-}
fmap colAggregation $ transpose $ Foldable.toList colss
(_, posXs) = mapAccumL (\acc x -> (acc+x,acc)) curX maxCols
counter count l =
if List.last posXs + List.last l <=colMax
@ -326,21 +367,6 @@ layoutBriDocM = \case
ratio = fromIntegral (foldl counter (0::Int) colss)
/ fromIntegral (length colss)
in (ratio, maxCols, colss)
briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo
briDocToColInfo lastFlag = \case
BDCols sig list -> withAlloc lastFlag $ \ind -> do
let isLastList =
if lastFlag then (== length list) <$> [1..] else repeat False
subInfos <- zip isLastList list `forM` uncurry briDocToColInfo
let lengthInfos = zip (briDocLineLength <$> list) subInfos
let trueSpacings = getTrueSpacings lengthInfos
return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos)
bd -> return $ ColInfoNo bd
getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing]
getTrueSpacings lengthInfos = lengthInfos <&> \case
(len, ColInfo i _ _) -> ColumnSpacingRef len i
(len, _) -> ColumnSpacingLeaf len
mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo]
mergeBriDocs bds = mergeBriDocsW ColInfoStart bds
@ -349,7 +375,7 @@ layoutBriDocM = \case
mergeBriDocsW _ [] = return []
mergeBriDocsW lastInfo (bd:bdr) = do
info <- mergeInfoBriDoc True lastInfo bd
infor <- mergeBriDocsW info bdr
infor <- mergeBriDocsW (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info) bdr
return $ info : infor
mergeInfoBriDoc :: Bool
@ -381,6 +407,22 @@ layoutBriDocM = \case
| otherwise -> briDocToColInfo lastFlag brdc
brdc -> return $ ColInfoNo brdc
briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo
briDocToColInfo lastFlag = \case
BDCols sig list -> withAlloc lastFlag $ \ind -> do
let isLastList =
if lastFlag then (== length list) <$> [1..] else repeat False
subInfos <- zip isLastList list `forM` uncurry briDocToColInfo
let lengthInfos = zip (briDocLineLength <$> list) subInfos
let trueSpacings = getTrueSpacings lengthInfos
return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos)
bd -> return $ ColInfoNo bd
getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing]
getTrueSpacings lengthInfos = lengthInfos <&> \case
(len, ColInfo i _ _) -> ColumnSpacingRef len i
(len, _) -> ColumnSpacingLeaf len
withAlloc :: Bool
-> (ColIndex -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo))
-> StateS.State ColBuildState ColInfo

10
src/Language/Haskell/Brittany/Config.hs
View File

@ -57,14 +57,10 @@ configParser = do
wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors")
omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid; for dev on brittany")
optionsGhc <- addFlagStringParams
""
optionsGhc <- addFlagStringParams ""
["ghc-options"]
"STRING"
( flagHelp
$ parDoc
"allows to define default language extensions. The parameter is forwarded to ghc."
)
(flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.")
return $ Config
{ _conf_debug = DebugConfig
@ -89,6 +85,8 @@ configParser = do
, _lconfig_importColumn = optionConcat importCol
, _lconfig_altChooser = mempty
, _lconfig_columnAlignMode = mempty
, _lconfig_alignmentLimit = mempty
, _lconfig_alignmentBreakOnMultiline = mempty
}
, _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors

19
src/Language/Haskell/Brittany/Config/Types.hs
View File

@ -56,6 +56,23 @@ data CLayoutConfig f = LayoutConfig
, _lconfig_importColumn :: f (Last Int)
, _lconfig_altChooser :: f (Last AltChooser)
, _lconfig_columnAlignMode :: f (Last ColumnAlignMode)
, _lconfig_alignmentLimit :: f (Last Int)
-- roughly speaking, this sets an upper bound to the number of spaces
-- inserted to create horizontal alignment.
-- More specifically, if 'xs' are the widths of the columns in some
-- alignment-block, then the block will be aligned with the width
-- maximum [ x | x <- xs, x < minimum xs + alignmentLimit ].
, _lconfig_alignmentBreakOnMultiline :: f (Last Bool)
-- stops alignment between items that are not layouted as a single line.
-- e.g. for single-line alignment, things remain unchanged:
-- do
-- short <- stuff
-- loooooooong <- stuff
-- but not in cases such as:
-- do
-- short <- some more stuff
-- that requires two lines
-- loooooooong <- stuff
}
deriving (Generic)
@ -272,6 +289,8 @@ staticDefaultConfig = Config
, _lconfig_importColumn = coerce (60 :: Int)
, _lconfig_altChooser = coerce (AltChooserBoundedSearch 3)
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
, _lconfig_alignmentLimit = coerce (30 :: Int)
, _lconfig_alignmentBreakOnMultiline = coerce True
}
, _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = coerce False