Improve column aligning; Add config for aligning

src-unittests/TestUtils.hs

@@ -48,6 +48,7 @@ defaultTestConfig = Config
       , _lconfig_indentListSpecial  = coerce True
       , _lconfig_importColumn       = coerce (60 :: Int)
       , _lconfig_altChooser         = coerce $ AltChooserBoundedSearch 3
+      , _lconfig_columnAlignMode    = coerce ColumnAlignModeUnanimously
       }
     , _conf_errorHandling = _conf_errorHandling staticDefaultConfig
     , _conf_forward = ForwardOptions

src/Language/Haskell/Brittany/BriLayouter.hs

@@ -1517,17 +1517,35 @@ layoutBriDocM = \case
     --     (colInfos, finalState) = StateS.runState (mergeBriDocs l) (ColBuildState IntMapS.empty 0)
     alignColsLines :: [BriDoc]
               -> m ()
-    alignColsLines l = do -- colInfos `forM_` \colInfo -> do
+    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 colMax (_cbs_map finalState)
+      sequence_ $ List.intersperse layoutWriteEnsureNewlineBlock
+                $ colInfos <&> processInfo (processedMap curX colMax)
       where
-        (colInfos, finalState) = StateS.runState (mergeBriDocs l) (ColBuildState IntMapS.empty 0)
+        (colInfos, finalState) = StateS.runState (mergeBriDocs bridocs)
+                                                 (ColBuildState IntMapS.empty 0)
+        processedMap :: Int -> Int -> ColMap2
+        processedMap curX colMax =
+          _cbs_map finalState <&> \colss ->
+            let maxCols = Foldable.foldl1 (zipWith max) 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)
     briDocToColInfo :: BriDoc -> StateS.State ColBuildState ColInfo
     briDocToColInfo = \case
       BDCols sig list -> withAlloc $ \ind -> do
         subInfos <- mapM briDocToColInfo list
         let lengths = briDocLineLength <$> list
-        return $ (lengths, ColInfo ind sig (zip lengths subInfos))
+        return $ (Seq.singleton lengths, ColInfo ind sig (zip lengths subInfos))
       bd -> return $ ColInfoNo bd
 
     mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo]
@@ -1558,14 +1576,14 @@ layoutBriDocM = \case
             let (Just spaces) = IntMapS.lookup infoInd m
             StateS.put s
               { _cbs_map = IntMapS.insert infoInd
-                                          (zipWith max spaces curLengths)
+                                          (spaces Seq.|> curLengths)
                                           m
               }
           return $ ColInfo infoInd colSig (zip curLengths infos)
         | otherwise -> briDocToColInfo bd
       bd            -> return $ ColInfoNo bd
     
-    withAlloc :: (ColIndex -> StateS.State ColBuildState (ColSpace, ColInfo))
+    withAlloc :: (ColIndex -> StateS.State ColBuildState (ColSpaces, ColInfo))
               -> StateS.State ColBuildState ColInfo
     withAlloc f = do
       cbs <- StateS.get
@@ -1576,18 +1594,20 @@ layoutBriDocM = \case
         $ c { _cbs_map = IntMapS.insert ind space $ _cbs_map c }
       return info
 
-    processInfo :: Int -> ColMap -> ColInfo -> m ()
+    processInfo :: ColMap2 -> ColInfo -> m ()
-    processInfo colMax m = \case
+    processInfo m = \case
       ColInfoStart -> error "should not happen (TM)"
       ColInfoNo doc -> layoutBriDocM doc
       ColInfo ind _ list -> do
+        colMax    <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack
+        alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack
         curX <- do
           state <- mGet
           return $ either id (const 0) (_lstate_curYOrAddNewline state)
                  + fromMaybe 0 (_lstate_addSepSpace state)
         -- tellDebugMess $ show curX
-        let Just cols = IntMapS.lookup ind m
+        let Just (ratio, maxCols, _colss) = IntMapS.lookup ind m
-        let (maxX, posXs) = (mapAccumL (\acc x -> (acc+x,acc)) curX cols)
+        let (maxX, posXs) = mapAccumL (\acc x -> (acc+x,acc)) curX maxCols
         -- handle the cases that the vertical alignment leads to more than max
         -- cols:
         -- this is not a full fix, and we must correct individually in addition.
@@ -1596,37 +1616,46 @@ layoutBriDocM = \case
         -- sizes in such a way that it works _if_ we have sizes (*factor)
         -- in each column. but in that line, in the last column, we will be
         -- forced to occupy the full vertical space, not reduced by any factor.
-        let fixedPosXs = if maxX>colMax
+        let fixedPosXs = case alignMode of
-              then let
+              ColumnAlignModeAnimouslyScale i | maxX>colMax -> fixed <&> (+curX)
+                where
                   factor :: Float = 
                     -- 0.0001 as an offering to the floating point gods.
-                       min 1.0001 ( fromIntegral (10 + colMax - curX) -- TODO: remove arbitrary 10..
+                    min 1.0001 ( fromIntegral (i + colMax - curX)
                                / fromIntegral (maxX - curX)
                                )
                   offsets = (subtract curX) <$> posXs
                   fixed = offsets <&> fromIntegral .> (*factor) .> truncate
-                   in  fixed <&> (+curX)
+              _ -> posXs
-              else posXs
+        let alignAct = zip fixedPosXs list `forM_` \(destX, x) -> do
-        -- fixing overflows, act II.
-        if List.last fixedPosXs + fst (List.last list) > colMax
-          then -- we are doomed. there is no space in the world for us.
-               -- or our children.
-            list `forM_` (snd .> processInfoIgnore)
-            -- we COULD do some fancy put-as-much-to-the-right-as-possible
-            -- here. could. dunno if that would look good even, though.
-          else zip fixedPosXs list `forM_` \(destX, x) -> do
               layoutWriteEnsureAbsoluteN destX
-            processInfo colMax m (snd x)
+              processInfo m (snd x)
+            noAlignAct = list `forM_` (snd .> processInfoIgnore)
+            animousAct =
+              -- per-item check if there is overflowing.
+              if List.last fixedPosXs + fst (List.last list) > colMax
+                then noAlignAct
+                else alignAct
+        case alignMode of
+          ColumnAlignModeDisabled                      -> noAlignAct
+          ColumnAlignModeUnanimously | maxX<=colMax    -> alignAct
+          ColumnAlignModeUnanimously                   -> noAlignAct
+          ColumnAlignModeMajority limit | ratio>=limit -> animousAct
+          ColumnAlignModeMajority{}                    -> noAlignAct
+          ColumnAlignModeAnimouslyScale{}              -> animousAct
+          ColumnAlignModeAnimously                     -> animousAct
+          ColumnAlignModeAlways                        -> alignAct
     processInfoIgnore :: ColInfo -> m ()
     processInfoIgnore = \case
       ColInfoStart -> error "should not happen (TM)"
       ColInfoNo doc -> layoutBriDocM doc
       ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore)
 
-
 type ColIndex  = Int
 type ColSpace  = [Int]
-type ColMap = IntMapS.IntMap {- ColIndex -} ColSpace
+type ColSpaces = Seq [Int]
+type ColMap1 = IntMapS.IntMap {- ColIndex -} ColSpaces
+type ColMap2 = IntMapS.IntMap {- ColIndex -} (Float, ColSpace, ColSpaces)
 
 data ColInfo
   = ColInfoStart -- start value to begin the mapAccumL.
@@ -1634,6 +1663,6 @@ data ColInfo
   | ColInfo ColIndex ColSig [(Int, ColInfo)]
 
 data ColBuildState = ColBuildState
-  { _cbs_map :: ColMap
+  { _cbs_map :: ColMap1
   , _cbs_index :: ColIndex
   }

src/Language/Haskell/Brittany/Config.hs

@@ -119,6 +119,7 @@ configParser = do
       , _lconfig_indentListSpecial  = mempty -- falseToNothing _
       , _lconfig_importColumn       = optionConcat importCol
       , _lconfig_altChooser         = mempty
+      , _lconfig_columnAlignMode    = mempty
       }
     , _conf_errorHandling = ErrorHandlingConfig
       { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors

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

@@ -53,6 +53,7 @@ data LayoutConfigF f = LayoutConfig
                                                  -- multi-line list literals.
   , _lconfig_importColumn :: f (Last Int)
   , _lconfig_altChooser      :: f (Last AltChooser)
+  , _lconfig_columnAlignMode :: f (Last ColumnAlignMode)
   }
   deriving (Generic)
 
@@ -132,6 +133,8 @@ instance FromJSON IndentPolicy
 instance ToJSON   IndentPolicy
 instance FromJSON AltChooser
 instance ToJSON   AltChooser
+instance FromJSON ColumnAlignMode
+instance ToJSON   ColumnAlignMode
 instance FromJSON CPPMode
 instance ToJSON   CPPMode
 
@@ -192,6 +195,29 @@ data AltChooser = AltChooserSimpleQuick -- always choose last alternative.
                                         -- options having sufficient space.
   deriving (Show, Generic, Data)
 
+data ColumnAlignMode
+  = ColumnAlignModeDisabled
+    -- ^ Make no column alignments whatsoever
+  | ColumnAlignModeUnanimously
+    -- ^ Make column alignments only if it does not cause overflow for any of
+    -- the affected lines.
+  | ColumnAlignModeMajority Float
+    -- ^ If at least (ratio::Float) of the aligned elements have sufficient
+    -- space for the alignment, act like ColumnAlignModeAnimously; otherwise
+    -- act like ColumnAlignModeDisabled.
+  | ColumnAlignModeAnimouslyScale Int
+    -- ^ Scale back columns to some degree if their sum leads to overflow.
+    -- This is done in a linear fashion.
+    -- The Int specifies additional columns to be added to column maximum for
+    -- scaling calculation purposes.
+  | ColumnAlignModeAnimously
+    -- ^ Decide on a case-by-case basis if alignment would cause overflow.
+    -- If it does, cancel all alignments for this (nested) column description.
+  -- ColumnAlignModeAnimouslySome -- potentially to implement
+  | ColumnAlignModeAlways
+    -- ^ Always respect column alignments, even if it makes stuff overflow.
+  deriving (Show, Generic, Data)
+
 data CPPMode = CPPModeAbort  -- abort program on seeing -XCPP
              | CPPModeWarn   -- warn about CPP and non-roundtripping in its
                              -- presence.
@@ -222,6 +248,7 @@ staticDefaultConfig = Config
       , _lconfig_indentListSpecial  = coerce True
       , _lconfig_importColumn       = coerce (60 :: Int)
       , _lconfig_altChooser         = coerce (AltChooserBoundedSearch 3)
+      , _lconfig_columnAlignMode    = coerce (ColumnAlignModeMajority 0.7)
       }
     , _conf_errorHandling = ErrorHandlingConfig
       { _econf_produceOutputOnErrors = coerce False
@@ -255,8 +282,8 @@ instance CZip DebugConfigF where
     (f x11 y11)
 
 instance CZip LayoutConfigF where
-  cZip f (LayoutConfig x1 x2 x3 x4 x5 x6 x7)
+  cZip f (LayoutConfig x1 x2 x3 x4 x5 x6 x7 x8)
-         (LayoutConfig y1 y2 y3 y4 y5 y6 y7) = LayoutConfig
+         (LayoutConfig y1 y2 y3 y4 y5 y6 y7 y8) = LayoutConfig
     (f x1 y1)
     (f x2 y2)
     (f x3 y3)
@@ -264,6 +291,7 @@ instance CZip LayoutConfigF where
     (f x5 y5)
     (f x6 y6)
     (f x7 y7)
+    (f x8 y8)
 
 instance CZip ErrorHandlingConfigF where
   cZip f (ErrorHandlingConfig x1 x2 x3)