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

src-literatetests/Main.hs

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

src-literatetests/tests.blt

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

src-unittests/TestUtils.hs

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

src/Language/Haskell/Brittany/Backend.hs

@@ -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]
+    alignColsLines :: [BriDoc] -> m ()
-              -> 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 :: [Int] -> [Int] -> [Int]
-        maxZipper [] ys = ys
+          -- maxZipper [] ys = ys
-        maxZipper xs [] = xs
+          -- maxZipper xs [] = xs
-        maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr
+          -- maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr
-        processedMap :: Int -> Int -> ColMap2
+          colAggregation :: [Int] -> Int
-        processedMap curX colMax = fix $ \result ->
+          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

src/Language/Haskell/Brittany/Config.hs

@@ -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
+                                           (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.")
-    $ 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

src/Language/Haskell/Brittany/Config/Types.hs

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