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

24
src-literatetests/Main.hs
View File

@ -143,21 +143,23 @@ instance Show PPTextWrapper where
defaultTestConfig :: Config
defaultTestConfig = Config
{ _conf_debug = _conf_debug staticDefaultConfig
, _conf_layout = LayoutConfig
{ _lconfig_cols = coerce (80 :: Int)
, _lconfig_indentPolicy = coerce IndentPolicyFree
, _lconfig_indentAmount = coerce (2 :: Int)
, _lconfig_indentWhereSpecial = coerce True
, _lconfig_indentListSpecial = coerce True
, _lconfig_importColumn = coerce (60 :: Int)
, _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
{ _conf_debug = _conf_debug staticDefaultConfig
, _conf_layout = LayoutConfig
{ _lconfig_cols = coerce (80 :: Int)
, _lconfig_indentPolicy = coerce IndentPolicyFree
, _lconfig_indentAmount = coerce (2 :: Int)
, _lconfig_indentWhereSpecial = coerce True
, _lconfig_indentListSpecial = coerce True
, _lconfig_importColumn = coerce (60 :: Int)
, _lconfig_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
}
, _conf_forward = ForwardOptions
, _conf_forward = ForwardOptions
{ _options_ghc = Identity []
}
}

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

26
src-unittests/TestUtils.hs
View File

@ -41,21 +41,23 @@ instance Show PPTextWrapper where
defaultTestConfig :: Config
defaultTestConfig = Config
{ _conf_debug = _conf_debug staticDefaultConfig
, _conf_layout = LayoutConfig
{ _lconfig_cols = coerce (80 :: Int)
, _lconfig_indentPolicy = coerce IndentPolicyFree
, _lconfig_indentAmount = coerce (2 :: Int)
, _lconfig_indentWhereSpecial = coerce True
, _lconfig_indentListSpecial = coerce True
, _lconfig_importColumn = coerce (60 :: Int)
, _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
{ _conf_debug = _conf_debug staticDefaultConfig
, _conf_layout = LayoutConfig
{ _lconfig_cols = coerce (80 :: Int)
, _lconfig_indentPolicy = coerce IndentPolicyFree
, _lconfig_indentAmount = coerce (2 :: Int)
, _lconfig_indentWhereSpecial = coerce True
, _lconfig_indentListSpecial = coerce True
, _lconfig_importColumn = coerce (60 :: Int)
, _lconfig_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
{ _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever
}
, _conf_forward = ForwardOptions
, _conf_forward = ForwardOptions
{ _options_ghc = Identity []
}
}

192
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,46 +320,93 @@ 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
sequence_ $ List.intersperse layoutWriteEnsureNewlineBlock
$ colInfos <&> processInfo (processedMap curX colMax)
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 ->
_cbs_map finalState <&> \(lastFlag, colSpacingss) ->
let colss = colSpacingss <&> \spss -> case reverse spss of
[] -> []
(xN:xR) -> reverse
$ (if lastFlag then fLast else fInit) xN : fmap fInit xR
where
fLast (ColumnSpacingLeaf len) = len
fLast (ColumnSpacingRef len _) = len
fInit (ColumnSpacingLeaf len) = len
fInit (ColumnSpacingRef _ i) = case IntMapL.lookup i result of
Nothing -> 0
Just (_, maxs, _) -> sum maxs
maxCols = Foldable.foldl1 maxZipper colss
(_, posXs) = mapAccumL (\acc x -> (acc+x,acc)) curX maxCols
counter count l =
if List.last posXs + List.last l <=colMax
then count + 1
else count
ratio = fromIntegral (foldl counter (0::Int) colss)
/ fromIntegral (length colss)
in (ratio, maxCols, colss)
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
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
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
[] -> []
(xN:xR) -> reverse
$ (if lastFlag then fLast else fInit) xN : fmap fInit xR
where
fLast (ColumnSpacingLeaf len) = len
fLast (ColumnSpacingRef len _) = len
fInit (ColumnSpacingLeaf len) = len
fInit (ColumnSpacingRef _ i) = case IntMapL.lookup i result of
Nothing -> 0
Just (_, maxs, _) -> sum maxs
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
then count + 1
else count
ratio = fromIntegral (foldl counter (0::Int) colss)
/ fromIntegral (length colss)
in (ratio, maxCols, colss)
mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo]
mergeBriDocs bds = mergeBriDocsW ColInfoStart bds
mergeBriDocsW :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo]
mergeBriDocsW _ [] = return []
mergeBriDocsW lastInfo (bd:bdr) = do
info <- mergeInfoBriDoc True lastInfo bd
infor <- mergeBriDocsW (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info) bdr
return $ info : infor
mergeInfoBriDoc :: Bool
-> ColInfo
-> BriDoc
-> StateS.StateT ColBuildState Identity ColInfo
mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag
mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag
mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) = \case
brdc@(BDCols colSig subDocs)
| infoSig == colSig
&& length subLengthsInfos == length subDocs -> do
let isLastList =
if lastFlag then (== length subDocs) <$> [1..] else repeat False
infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs
`forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd
let curLengths = briDocLineLength <$> subDocs
let trueSpacings = getTrueSpacings (zip curLengths infos)
do -- update map
s <- StateS.get
let m = _cbs_map s
let (Just (_, spaces)) = IntMapS.lookup infoInd m
StateS.put s
{ _cbs_map = IntMapS.insert infoInd
(lastFlag, spaces Seq.|> trueSpacings)
m
}
return $ ColInfo infoInd colSig (zip curLengths infos)
| 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
@ -342,45 +423,6 @@ layoutBriDocM = \case
(len, ColInfo i _ _) -> ColumnSpacingRef len i
(len, _) -> ColumnSpacingLeaf len
mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo]
mergeBriDocs bds = mergeBriDocsW ColInfoStart bds
mergeBriDocsW :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo]
mergeBriDocsW _ [] = return []
mergeBriDocsW lastInfo (bd:bdr) = do
info <- mergeInfoBriDoc True lastInfo bd
infor <- mergeBriDocsW info bdr
return $ info : infor
mergeInfoBriDoc :: Bool
-> ColInfo
-> BriDoc
-> StateS.StateT ColBuildState Identity ColInfo
mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag
mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag
mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) = \case
brdc@(BDCols colSig subDocs)
| infoSig == colSig
&& length subLengthsInfos == length subDocs -> do
let isLastList =
if lastFlag then (== length subDocs) <$> [1..] else repeat False
infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs
`forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd
let curLengths = briDocLineLength <$> subDocs
let trueSpacings = getTrueSpacings (zip curLengths infos)
do -- update map
s <- StateS.get
let m = _cbs_map s
let (Just (_, spaces)) = IntMapS.lookup infoInd m
StateS.put s
{ _cbs_map = IntMapS.insert infoInd
(lastFlag, spaces Seq.|> trueSpacings)
m
}
return $ ColInfo infoInd colSig (zip curLengths infos)
| otherwise -> briDocToColInfo lastFlag brdc
brdc -> return $ ColInfoNo brdc
withAlloc :: Bool
-> (ColIndex -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo))
-> StateS.State ColBuildState ColInfo

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

@ -49,25 +49,21 @@ configParser = do
dumpBriDocFloating <- addSimpleBoolFlag ""
["dump-bridoc-floating"]
(flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating")
dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns")
dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent")
dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc")
dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns")
dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent")
dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc")
outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible")
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")
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
""
["ghc-options"]
"STRING"
( flagHelp
$ parDoc
"allows to define default language extensions. The parameter is forwarded to ghc."
)
optionsGhc <- addFlagStringParams ""
["ghc-options"]
"STRING"
(flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.")
return $ Config
{ _conf_debug = DebugConfig
{ _conf_debug = DebugConfig
{ _dconf_dump_config = wrapLast $ falseToNothing dumpConfig
, _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations
, _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST
@ -80,24 +76,26 @@ configParser = do
, _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent
, _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal
}
, _conf_layout = LayoutConfig
{ _lconfig_cols = optionConcat cols
, _lconfig_indentPolicy = mempty
, _lconfig_indentAmount = optionConcat ind
, _lconfig_indentWhereSpecial = mempty -- falseToNothing _
, _lconfig_indentListSpecial = mempty -- falseToNothing _
, _lconfig_importColumn = optionConcat importCol
, _lconfig_altChooser = mempty
, _lconfig_columnAlignMode = mempty
, _conf_layout = LayoutConfig
{ _lconfig_cols = optionConcat cols
, _lconfig_indentPolicy = mempty
, _lconfig_indentAmount = optionConcat ind
, _lconfig_indentWhereSpecial = mempty -- falseToNothing _
, _lconfig_indentListSpecial = mempty -- falseToNothing _
, _lconfig_importColumn = optionConcat importCol
, _lconfig_altChooser = mempty
, _lconfig_columnAlignMode = mempty
, _lconfig_alignmentLimit = mempty
, _lconfig_alignmentBreakOnMultiline = mempty
}
, _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors
, _econf_Werror = wrapLast $ falseToNothing wError
, _econf_CPPMode = mempty
, _econf_ExactPrintFallback = mempty
{ _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors
, _econf_Werror = wrapLast $ falseToNothing wError
, _econf_CPPMode = mempty
, _econf_ExactPrintFallback = mempty
, _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck
}
, _conf_forward = ForwardOptions
, _conf_forward = ForwardOptions
{ _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ]
}
}

41
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)
@ -250,7 +267,7 @@ data ExactPrintFallbackMode
staticDefaultConfig :: Config
staticDefaultConfig = Config
{ _conf_debug = DebugConfig
{ _conf_debug = DebugConfig
{ _dconf_dump_config = coerce False
, _dconf_dump_annotations = coerce False
, _dconf_dump_ast_unknown = coerce False
@ -263,15 +280,17 @@ staticDefaultConfig = Config
, _dconf_dump_bridoc_simpl_indent = coerce False
, _dconf_dump_bridoc_final = coerce False
}
, _conf_layout = LayoutConfig
{ _lconfig_cols = coerce (80 :: Int)
, _lconfig_indentPolicy = coerce IndentPolicyFree
, _lconfig_indentAmount = coerce (2 :: Int)
, _lconfig_indentWhereSpecial = coerce True
, _lconfig_indentListSpecial = coerce True
, _lconfig_importColumn = coerce (60 :: Int)
, _lconfig_altChooser = coerce (AltChooserBoundedSearch 3)
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
, _conf_layout = LayoutConfig
{ _lconfig_cols = coerce (80 :: Int)
, _lconfig_indentPolicy = coerce IndentPolicyFree
, _lconfig_indentAmount = coerce (2 :: Int)
, _lconfig_indentWhereSpecial = coerce True
, _lconfig_indentListSpecial = coerce True
, _lconfig_importColumn = coerce (60 :: Int)
, _lconfig_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
@ -280,7 +299,7 @@ staticDefaultConfig = Config
, _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline
, _econf_omit_output_valid_check = coerce False
}
, _conf_forward = ForwardOptions
, _conf_forward = ForwardOptions
{ _options_ghc = Identity []
}
}