From 371fad303d2ad89db59c6ce73c7f3e18a23b855e Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 2 Sep 2016 00:08:10 +0200 Subject: [PATCH] Improve column aligning; Add config for aligning --- src-unittests/IdentityTests.hs | 2 +- src-unittests/TestUtils.hs | 1 + src/Language/Haskell/Brittany/BriLayouter.hs | 103 +++++++++++------- src/Language/Haskell/Brittany/Config.hs | 1 + src/Language/Haskell/Brittany/Config/Types.hs | 34 +++++- 5 files changed, 100 insertions(+), 41 deletions(-) diff --git a/src-unittests/IdentityTests.hs b/src-unittests/IdentityTests.hs index fa35c15..5632153 100644 --- a/src-unittests/IdentityTests.hs +++ b/src-unittests/IdentityTests.hs @@ -636,7 +636,7 @@ regressionTests = do let (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs' (bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets'' -- default local dir target if there's no given target - utargets'' = "foo" + utargets'' = "foo" return () |] it "list comprehension comment placement" $ do diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index 31a5383..482a25f 100644 --- a/src-unittests/TestUtils.hs +++ b/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 diff --git a/src/Language/Haskell/Brittany/BriLayouter.hs b/src/Language/Haskell/Brittany/BriLayouter.hs index d1c782f..10fc700 100644 --- a/src/Language/Haskell/Brittany/BriLayouter.hs +++ b/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 - colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack - sequence_ $ List.intersperse layoutWriteEnsureNewlineBlock $ colInfos <&> processInfo colMax (_cbs_map finalState) + 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 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 colMax m = \case + processInfo :: ColMap2 -> ColInfo -> m () + 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 (maxX, posXs) = (mapAccumL (\acc x -> (acc+x,acc)) curX cols) + let Just (ratio, maxCols, _colss) = IntMapS.lookup ind m + 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 - then let - factor :: Float = - -- 0.0001 as an offering to the floating point gods. - min 1.0001 ( fromIntegral (10 + colMax - curX) -- TODO: remove arbitrary 10.. - / fromIntegral (maxX - curX) - ) - offsets = (subtract curX) <$> posXs - fixed = offsets <&> fromIntegral .> (*factor) .> truncate - in fixed <&> (+curX) - else posXs - -- 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) + let fixedPosXs = case alignMode of + ColumnAlignModeAnimouslyScale i | maxX>colMax -> fixed <&> (+curX) + where + factor :: Float = + -- 0.0001 as an offering to the floating point gods. + min 1.0001 ( fromIntegral (i + colMax - curX) + / fromIntegral (maxX - curX) + ) + offsets = (subtract curX) <$> posXs + fixed = offsets <&> fromIntegral .> (*factor) .> truncate + _ -> posXs + let alignAct = zip fixedPosXs list `forM_` \(destX, x) -> do + layoutWriteEnsureAbsoluteN destX + 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 ColIndex = Int +type ColSpace = [Int] +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 } diff --git a/src/Language/Haskell/Brittany/Config.hs b/src/Language/Haskell/Brittany/Config.hs index 33bb981..9f3002b 100644 --- a/src/Language/Haskell/Brittany/Config.hs +++ b/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 diff --git a/src/Language/Haskell/Brittany/Config/Types.hs b/src/Language/Haskell/Brittany/Config/Types.hs index b521f0a..a655a74 100644 --- a/src/Language/Haskell/Brittany/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Config/Types.hs @@ -52,7 +52,8 @@ data LayoutConfigF f = LayoutConfig -- when creating zero-indentation -- multi-line list literals. , _lconfig_importColumn :: f (Last Int) - , _lconfig_altChooser :: f (Last AltChooser) + , _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) - (LayoutConfig y1 y2 y3 y4 y5 y6 y7) = LayoutConfig + cZip f (LayoutConfig x1 x2 x3 x4 x5 x6 x7 x8) + (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)