From cb93a6903c99d339f571a46e1d70ff3925540268 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 4 Sep 2016 14:16:44 +0200 Subject: [PATCH] Fix horizontal alignment issue; Add testcases --- src-unittests/IdentityTests.hs | 73 +++++++++++++++++++ src-unittests/TestUtils.hs | 2 +- src/Language/Haskell/Brittany/Backend.hs | 51 +++++++------ .../Haskell/Brittany/Layouters/Pattern.hs | 7 +- 4 files changed, 107 insertions(+), 26 deletions(-) diff --git a/src-unittests/IdentityTests.hs b/src-unittests/IdentityTests.hs index 90472bd..71d699b 100644 --- a/src-unittests/IdentityTests.hs +++ b/src-unittests/IdentityTests.hs @@ -705,3 +705,76 @@ regressionTests = do | otherwise -> do return conf |] + it "nested pattern alignment issue" $ do + roundTripEqual $ + [text| + func = BuildReport + where + convertInstallOutcome = case result of + Left BR.PlanningFailed -> PlanningFailed + Left (BR.DependentFailed p) -> DependencyFailed p + Left (BR.DownloadFailed _) -> DownloadFailed + Left (BR.UnpackFailed _) -> UnpackFailed + Left (BR.ConfigureFailed _) -> ConfigureFailed + Left (BR.BuildFailed _) -> BuildFailed + Left (BR.TestsFailed _) -> TestsFailed + Left (BR.InstallFailed _) -> InstallFailed + Right (BR.BuildOk _ _ _ ) -> InstallOk + |] + it "nested pattern alignment issue" $ do + roundTripEqual $ + [text| + func = BuildReport + where + convertInstallOutcome = case result of + Left BR.PlanningFailed -> PlanningFailed + Left (BR.DependentFailed p) -> DependencyFailed p + Left (BR.DownloadFailed _) -> DownloadFailed + Left (BR.UnpackFailed _) -> UnpackFailed + Left (BR.ConfigureFailed _) -> ConfigureFailed + Left (BR.BuildFailed _) -> BuildFailed + Left (BR.TestsFailed _) -> TestsFailed + Left (BR.InstallFailed _) -> InstallFailed + Right (BR.BuildOk _ _ _ ) -> InstallOk + |] + it "partially overflowing alignment issue" $ do + roundTripEqual $ + [text| + showPackageDetailedInfo pkginfo = + renderStyle (style { lineLength = 80, ribbonsPerLine = 1 }) + $ char '*' + $+$ something + [ entry "Synopsis" synopsis hideIfNull reflowParagraphs + , entry "Versions available" + sourceVersions + (altText null "[ Not available from server ]") + (dispTopVersions 9 (preferredVersions pkginfo)) + , entry + "Versions installed" + installedVersions + ( altText + null + (if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]") + ) + (dispTopVersions 4 (preferredVersions pkginfo)) + , entry "Homepage" homepage orNotSpecified text + , entry "Bug reports" bugReports orNotSpecified text + , entry "Description" description hideIfNull reflowParagraphs + , entry "Category" category hideIfNull text + , entry "License" license alwaysShow disp + , entry "Author" author hideIfNull reflowLines + , entry "Maintainer" maintainer hideIfNull reflowLines + , entry "Source repo" sourceRepo orNotSpecified text + , entry "Executables" executables hideIfNull (commaSep text) + , entry "Flags" flags hideIfNull (commaSep dispFlag) + , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep) + , entry "Documentation" haddockHtml showIfInstalled text + , entry "Cached" haveTarball alwaysShow dispYesNo + , if not (hasLib pkginfo) + then + empty + else + text "Modules:" + $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo)) + ] + |] \ No newline at end of file diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index 0024c41..f46230b 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -50,7 +50,7 @@ defaultTestConfig = Config , _lconfig_indentListSpecial = coerce True , _lconfig_importColumn = coerce (60 :: Int) , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 - , _lconfig_columnAlignMode = coerce ColumnAlignModeUnanimously + , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) } , _conf_errorHandling = _conf_errorHandling staticDefaultConfig , _conf_forward = ForwardOptions diff --git a/src/Language/Haskell/Brittany/Backend.hs b/src/Language/Haskell/Brittany/Backend.hs index 226d66e..6159919 100644 --- a/src/Language/Haskell/Brittany/Backend.hs +++ b/src/Language/Haskell/Brittany/Backend.hs @@ -305,10 +305,11 @@ layoutBriDocM = \case maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr processedMap :: Int -> Int -> ColMap2 processedMap curX colMax = fix $ \result -> - _cbs_map finalState <&> \colSpacingss -> + _cbs_map finalState <&> \(lastFlag, colSpacingss) -> let colss = colSpacingss <&> \spss -> case reverse spss of [] -> [] - (xN:xR) -> reverse $ fLast xN : fmap fInit xR + (xN:xR) -> reverse + $ (if lastFlag then fLast else fInit) xN : fmap fInit xR where fLast (ColumnSpacingLeaf len) = len fLast (ColumnSpacingRef len _) = len @@ -325,10 +326,12 @@ layoutBriDocM = \case 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 + 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) @@ -345,45 +348,49 @@ layoutBriDocM = \case mergeBriDocsW :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo] mergeBriDocsW _ [] = return [] mergeBriDocsW lastInfo (bd:bdr) = do - info <- mergeInfoBriDoc lastInfo bd + info <- mergeInfoBriDoc True lastInfo bd infor <- mergeBriDocsW info bdr return $ info : infor - mergeInfoBriDoc :: ColInfo + mergeInfoBriDoc :: Bool + -> ColInfo -> BriDoc -> StateS.StateT ColBuildState Identity ColInfo - mergeInfoBriDoc ColInfoStart = briDocToColInfo - mergeInfoBriDoc ColInfoNo{} = briDocToColInfo - mergeInfoBriDoc (ColInfo infoInd infoSig subLengthsInfos) = \case - bd@(BDCols colSig subDocs) + 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 - infos <- zip (snd <$> subLengthsInfos) subDocs - `forM` uncurry mergeInfoBriDoc + 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 + let (Just (_, spaces)) = IntMapS.lookup infoInd m StateS.put s { _cbs_map = IntMapS.insert infoInd - (spaces Seq.|> trueSpacings) + (lastFlag, spaces Seq.|> trueSpacings) m } return $ ColInfo infoInd colSig (zip curLengths infos) - | otherwise -> briDocToColInfo bd - bd -> return $ ColInfoNo bd + | otherwise -> briDocToColInfo lastFlag brdc + brdc -> return $ ColInfoNo brdc - withAlloc :: (ColIndex -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo)) + withAlloc :: Bool + -> (ColIndex -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo)) -> StateS.State ColBuildState ColInfo - withAlloc f = do + withAlloc lastFlag f = do cbs <- StateS.get let ind = _cbs_index cbs StateS.put $ cbs { _cbs_index = ind + 1 } (space, info) <- f ind StateS.get >>= \c -> StateS.put - $ c { _cbs_map = IntMapS.insert ind space $ _cbs_map c } + $ c { _cbs_map = IntMapS.insert ind (lastFlag, space) $ _cbs_map c } return info processInfo :: ColMap2 -> ColInfo -> m () @@ -451,7 +458,7 @@ data ColumnSpacing type ColumnBlock a = [a] type ColumnBlocks a = Seq [a] -type ColMap1 = IntMapL.IntMap {- ColIndex -} (ColumnBlocks ColumnSpacing) +type ColMap1 = IntMapL.IntMap {- ColIndex -} (Bool, ColumnBlocks ColumnSpacing) type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int) -- (ratio of hasSpace, maximum, raw) diff --git a/src/Language/Haskell/Brittany/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Layouters/Pattern.hs index 84b7668..c0e53c9 100644 --- a/src/Language/Haskell/Brittany/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Layouters/Pattern.hs @@ -31,10 +31,11 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of VarPat n -> fmap Seq.singleton $ docLit $ lrdrNameToText n LitPat lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit ParPat inner -> do - innerDocs <- layoutPat inner - left <- docLit $ Text.pack "(" + left <- docLit $ Text.pack "(" right <- docLit $ Text.pack ")" - return $ (left Seq.<| innerDocs) Seq.|> right + innerDocs <- colsWrapPat =<< layoutPat inner + return $ Seq.empty Seq.|> left Seq.|> innerDocs Seq.|> right + -- return $ (left Seq.<| innerDocs) Seq.|> right -- case Seq.viewl innerDocs of -- Seq.EmptyL -> fmap return $ docLit $ Text.pack "()" -- this should never occur.. -- x1 Seq.:< rest -> case Seq.viewr rest of