Fix horizontal alignment issue; Add testcases

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))
+                ]
+      |]

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

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 :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo
-    briDocToColInfo = \case
+    briDocToColInfo lastFlag = \case
-      BDCols sig list -> withAlloc $ \ind -> do
+      BDCols sig list -> withAlloc lastFlag $ \ind -> do
-        subInfos <- mapM briDocToColInfo list
+        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 lastFlag ColInfoStart = briDocToColInfo lastFlag
-    mergeInfoBriDoc ColInfoNo{}  = briDocToColInfo
+    mergeInfoBriDoc lastFlag ColInfoNo{}  = briDocToColInfo lastFlag
-    mergeInfoBriDoc (ColInfo infoInd infoSig subLengthsInfos) = \case
+    mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) = \case
-      bd@(BDCols colSig subDocs)
+      brdc@(BDCols colSig subDocs)
         | infoSig == colSig
         && length subLengthsInfos == length subDocs -> do
-          infos <- zip (snd <$> subLengthsInfos) subDocs
+          let isLastList =
-            `forM` uncurry mergeInfoBriDoc
+                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
+        | otherwise -> briDocToColInfo lastFlag brdc
-      bd            -> return $ ColInfoNo bd
+      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)
 

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