Improve horizontal alignments significantly (patterns)

src/Language/Haskell/Brittany/BriLayouter.hs

@@ -1118,6 +1118,8 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
     filter isNotEmpty list >>= \case
       BDSeq l -> l
       x -> [x]
+  BDSeq (BDCols sig1 cols1@(_:_):rest) ->
+    Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)])
   BDLines lines | any (\case BDLines{} -> True
                              BDEmpty{} -> True
                              _ -> False) lines ->
@@ -1528,10 +1530,24 @@ layoutBriDocM = \case
       where
         (colInfos, finalState) = StateS.runState (mergeBriDocs bridocs)
                                                  (ColBuildState IntMapS.empty 0)
+        maxZipper :: [Int] -> [Int] -> [Int]
+        maxZipper [] ys = ys
+        maxZipper xs [] = xs
+        maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr
         processedMap :: Int -> Int -> ColMap2
-        processedMap curX colMax =
+        processedMap curX colMax = fix $ \result ->
-          _cbs_map finalState <&> \colss ->
+          _cbs_map finalState <&> \colSpacingss ->
-            let maxCols = Foldable.foldl1 (zipWith max) colss
+            let colss = colSpacingss <&> \spss -> case reverse spss of
+                  [] -> []
+                  (xN:xR) -> reverse $ fLast xN : fmap fInit xR
+                  where
+                    fLast (ColumnSpacingLeaf len)  = len
+                    fLast (ColumnSpacingRef len _) = len
+                    fInit (ColumnSpacingLeaf len) = len
+                    fInit (ColumnSpacingRef _ i) = case IntMapL.lookup i result of
+                      Nothing           -> 0
+                      Just (_, maxs, _) -> sum maxs
+                maxCols = Foldable.foldl1 maxZipper colss
                 (_, posXs) = mapAccumL (\acc x -> (acc+x,acc)) curX maxCols
                 counter count l =
                   if List.last posXs + List.last l <=colMax
@@ -1544,10 +1560,16 @@ layoutBriDocM = \case
     briDocToColInfo = \case
       BDCols sig list -> withAlloc $ \ind -> do
         subInfos <- mapM briDocToColInfo list
-        let lengths = briDocLineLength <$> list
+        let lengthInfos = zip (briDocLineLength <$> list) subInfos
-        return $ (Seq.singleton lengths, ColInfo ind sig (zip lengths 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
 
@@ -1570,20 +1592,21 @@ layoutBriDocM = \case
           infos <- zip (snd <$> subLengthsInfos) subDocs
             `forM` uncurry mergeInfoBriDoc
           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
             StateS.put s
               { _cbs_map = IntMapS.insert infoInd
-                                          (spaces Seq.|> curLengths)
+                                          (spaces Seq.|> trueSpacings)
                                           m
               }
           return $ ColInfo infoInd colSig (zip curLengths infos)
         | otherwise -> briDocToColInfo bd
       bd            -> return $ ColInfoNo bd
     
-    withAlloc :: (ColIndex -> StateS.State ColBuildState (ColSpaces, ColInfo))
+    withAlloc :: (ColIndex -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo))
               -> StateS.State ColBuildState ColInfo
     withAlloc f = do
       cbs <- StateS.get
@@ -1652,16 +1675,27 @@ layoutBriDocM = \case
       ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore)
 
 type ColIndex  = Int
-type ColSpace  = [Int]
+
-type ColSpaces = Seq [Int]
+data ColumnSpacing
-type ColMap1 = IntMapS.IntMap {- ColIndex -} ColSpaces
+  = ColumnSpacingLeaf Int
-type ColMap2 = IntMapS.IntMap {- ColIndex -} (Float, ColSpace, ColSpaces)
+  | ColumnSpacingRef Int Int
+
+type ColumnBlock  a = [a]
+type ColumnBlocks a = Seq [a]
+type ColMap1 = IntMapL.IntMap {- ColIndex -} (ColumnBlocks ColumnSpacing)
+type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int)
+                                          -- (ratio of hasSpace, maximum, raw)
 
 data ColInfo
   = ColInfoStart -- start value to begin the mapAccumL.
   | ColInfoNo BriDoc
   | ColInfo ColIndex ColSig [(Int, ColInfo)]
 
+instance Show ColInfo where
+  show ColInfoStart = "ColInfoStart"
+  show ColInfoNo{} = "ColInfoNo{}"
+  show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list
+
 data ColBuildState = ColBuildState
   { _cbs_map :: ColMap1
   , _cbs_index :: ColIndex

src/Language/Haskell/Brittany/LayoutBasics.hs

@@ -1060,6 +1060,34 @@ instance DocWrapable a => DocWrapable [a] where
         bdN' <- docWrapNodeRest ast (return bdN)
         return $ reverse $ (bdN':bdR)
 
+instance DocWrapable a => DocWrapable (Seq a) where
+  docWrapNode ast bdsm = do
+    bds <- bdsm
+    case Seq.viewl bds of
+      Seq.EmptyL -> return $ Seq.empty -- TODO: this might be bad. maybe. then again, not really. well.
+      bd1 Seq.:< rest -> case Seq.viewr rest of
+        Seq.EmptyR -> do
+          bd1' <- docWrapNode ast (return bd1)
+          return $ Seq.singleton bd1'
+        bdM Seq.:> bdN -> do
+          bd1' <- docWrapNodePrior ast (return bd1)
+          bdN' <- docWrapNodeRest  ast (return bdN)
+          return $ (bd1' Seq.<| bdM) Seq.|> bdN'
+  docWrapNodePrior ast bdsm = do
+    bds <- bdsm
+    case Seq.viewl bds of
+      Seq.EmptyL -> return $ Seq.empty
+      bd1 Seq.:< bdR -> do
+        bd1' <- docWrapNodePrior ast (return bd1)
+        return $ bd1' Seq.<| bdR
+  docWrapNodeRest ast bdsm = do
+    bds <- bdsm
+    case Seq.viewr bds of
+      Seq.EmptyR -> return $ Seq.empty
+      bdR Seq.:> bdN -> do
+        bdN' <- docWrapNodeRest ast (return bdN)
+        return $ bdR Seq.|> bdN'
+
 instance DocWrapable ([BriDocNumbered], BriDocNumbered, a) where
   docWrapNode ast stuffM = do
     (bds, bd, x) <- stuffM

src/Language/Haskell/Brittany/Layouters/Decl.hs

@@ -69,7 +69,9 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
     patDoc <- docSharedWrapper layoutPat lPat
     expDoc <- docSharedWrapper layoutExpr expr
     docCols ColBindStmt
-      [appSep patDoc, docSeq [appSep $ docLit $ Text.pack "<-", expDoc]]
+      [ appSep $ colsWrapPat =<< patDoc
+      , docSeq [appSep $ docLit $ Text.pack "<-", expDoc]
+      ]
   _ -> unknownNodeError "" lgstmt -- TODO
 
 layoutBind :: ToBriDocC (HsBindLR RdrName RdrName) (Either [BriDocNumbered] BriDocNumbered)
@@ -80,11 +82,11 @@ layoutBind lbind@(L _ bind) = case bind of
     funcPatDocs <- docWrapNode lbind $ docWrapNode lmatches $ layoutPatternBind (Just idStr) binderDoc `mapM` matches
     return $ Left $ funcPatDocs
   PatBind pat (GRHSs grhss whereBinds) _ _ ([], []) -> do
-    patDoc <- layoutPat pat
+    patDocs <- colsWrapPat =<< layoutPat pat
     clauseDocs <- layoutGrhs `mapM` grhss
     mWhereDocs <- layoutLocalBinds whereBinds
     binderDoc <- docLit $ Text.pack "="
-    fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing binderDoc (Just patDoc) clauseDocs mWhereDocs
+    fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing binderDoc (Just patDocs) clauseDocs mWhereDocs
   _ -> Right <$> unknownNodeError "" lbind
 
 data BagBindOrSig = BagBind (LHsBindLR RdrName RdrName)
@@ -127,7 +129,7 @@ layoutGrhs lgrhs@(L _ (GRHS guards body))
 layoutPatternBind :: Maybe Text -> BriDocNumbered -> LMatch RdrName (LHsExpr RdrName) -> ToBriDocM BriDocNumbered
 layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhss whereBinds)))
   = do
-    patDocs <- docSharedWrapper layoutPat `mapM` pats
+    patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p
     let isInfix = isInfixMatch match
     patDoc <- docWrapNodePrior lmatch $ case (mIdStr, patDocs) of
       (Just idStr, p1:pr) | isInfix -> docCols ColPatternsFuncInfix

src/Language/Haskell/Brittany/Layouters/Expr.hs

@@ -50,7 +50,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
   HsLit lit -> do
     allocateNode $ litBriDoc lit
   HsLam (MG (L _ [lmatch@(L _ (Match _ pats _ (GRHSs [lgrhs@(L _ (GRHS [] body))] (L _ EmptyLocalBinds))))]) _ _ _) -> do
-    patDocs <- pats `forM` docSharedWrapper layoutPat
+    patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p
     bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body
     let funcPatternPartLine =
           docCols ColCasePattern

src/Language/Haskell/Brittany/Layouters/Pattern.hs

@@ -2,6 +2,7 @@
 
 module Language.Haskell.Brittany.Layouters.Pattern
   ( layoutPat
+  , colsWrapPat
   )
 where
 
@@ -24,33 +25,50 @@ import           Language.Haskell.Brittany.Layouters.Type
 
 
 
-layoutPat :: ToBriDoc Pat
+layoutPat :: ToBriDocC (Pat RdrName) (Seq BriDocNumbered)
 layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
-  WildPat _  -> docLit $ Text.pack "_"
+  WildPat _  -> fmap Seq.singleton $ docLit $ Text.pack "_"
-  VarPat n   -> docLit $ lrdrNameToText n
+  VarPat n   -> fmap Seq.singleton $ docLit $ lrdrNameToText n
-  LitPat lit -> allocateNode $ litBriDoc lit
+  LitPat lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit
   ParPat inner -> do
-    innerDoc <- docSharedWrapper layoutPat inner
+    innerDocs <- layoutPat inner
-    docSeq
+    left <- docLit $ Text.pack "("
-      [ docLit $ Text.pack "("
+    right <- docLit $ Text.pack ")"
-      , innerDoc
+    return $ (left Seq.<| innerDocs) Seq.|> right
-      , docLit $ Text.pack ")"
+    -- case Seq.viewl innerDocs of
-      ]
+    --   Seq.EmptyL -> fmap return $ docLit $ Text.pack "()" -- this should never occur..
+    --   x1 Seq.:< rest -> case Seq.viewr rest of
+    --     Seq.EmptyR ->
+    --       fmap return $ docSeq
+    --       [ docLit $ Text.pack "("
+    --       , return x1
+    --       , docLit $ Text.pack ")"
+    --       ]
+    --     middle Seq.:> xN -> do
+    --       x1' <- docSeq [docLit $ Text.pack "(", return x1]
+    --       xN' <- docSeq [return xN, docLit $ Text.pack ")"]
+    --       return $ (x1' Seq.<| middle) Seq.|> xN'
   ConPatIn lname (PrefixCon args) -> do
     let nameDoc = lrdrNameToText lname
-    argDocs <- docSharedWrapper layoutPat `mapM` args
+    argDocs <- layoutPat `mapM` args
     if null argDocs
-      then docLit nameDoc
+      then return <$> docLit nameDoc
-      else docSeq
+      else do
-             $ appSep (docLit nameDoc) : spacifyDocs argDocs
+        x1 <- appSep (docLit nameDoc)
+        xR <- fmap Seq.fromList
+          $ sequence
+          $ spacifyDocs
+          $ fmap colsWrapPat argDocs
+        return $ x1 Seq.<| xR
   ConPatIn lname (InfixCon left right) -> do
     let nameDoc = lrdrNameToText lname
-    leftDoc  <- docSharedWrapper layoutPat left
+    leftDoc  <- colsWrapPat =<< layoutPat left
-    rightDoc <- docSharedWrapper layoutPat right
+    rightDoc <- colsWrapPat =<< layoutPat right
-    docSeq [leftDoc, docLit nameDoc, rightDoc]
+    middle <- docLit nameDoc
+    return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc
   ConPatIn lname (RecCon (HsRecFields [] Nothing)) -> do
     let t = lrdrNameToText lname
-    docLit $ t <> Text.pack "{}"
+    fmap Seq.singleton $ docLit $ t <> Text.pack "{}"
   ConPatIn lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do
     let t = lrdrNameToText lname
     fds <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fPat pun)) -> do
@@ -58,7 +76,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
         then return Nothing
         else Just <$> docSharedWrapper layoutPat fPat
       return $ (lrdrNameToText lnameF, fExpDoc)
-    docSeq
+    fmap Seq.singleton $ docSeq
       [ appSep $ docLit t
       , appSep $ docLit $ Text.pack "{"
       , docSeq $ List.intersperse docCommaSep
@@ -66,7 +84,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
           (fieldName, Just fieldDoc) -> docSeq
             [ appSep $ docLit $ fieldName
             , appSep $ docLit $ Text.pack "="
-            , fieldDoc
+            , fieldDoc >>= colsWrapPat
             ]
           (fieldName, Nothing) -> docLit fieldName
       , docSeparator
@@ -74,59 +92,74 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
       ]
   ConPatIn lname (RecCon (HsRecFields [] (Just 0))) -> do
     let t = lrdrNameToText lname
-    docSeq
+    fmap Seq.singleton $ docSeq
       [ appSep $ docLit t
       , docLit $ Text.pack "{..}"
       ]
   TuplePat args boxity _ -> do
-    argDocs <- docSharedWrapper layoutPat `mapM` args
     case boxity of
-      Boxed -> docAlt
+      Boxed   -> wrapPatListy args "(" ")"
-        [ docSeq
+      Unboxed -> wrapPatListy args "(#" "#)"
-        $  [ docLit $ Text.pack "(" ]
-        ++ List.intersperse (appSep $ docLit $ Text.pack ",") argDocs
-        ++ [ docLit $ Text.pack ")"]
-        -- TODO
-        ]
-      Unboxed -> docAlt
-        [ docSeq
-        $  [ docLit $ Text.pack "(#" ]
-        ++ List.intersperse (appSep $ docLit $ Text.pack ",") argDocs
-        ++ [ docLit $ Text.pack "#)"]
-        -- TODO
-        ]
   AsPat asName asPat -> do
-    patDoc <- docSharedWrapper layoutPat asPat
+    wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@")
-    docSeq
-      [ docLit $ lrdrNameToText asName <> Text.pack "@"
-      , patDoc
-      ]
   SigPatIn pat1 (HsIB _ (HsWC _ _ ty1)) -> do
-    patDoc <- docSharedWrapper layoutPat pat1
+    patDocs <- layoutPat pat1
     tyDoc <- docSharedWrapper layoutType ty1
-    docSeq
+    case Seq.viewr patDocs of
-      [ appSep $ patDoc
+      Seq.EmptyR -> error "cannot happen ljoiuxoasdcoviuasd"
-      , appSep $ docLit $ Text.pack "::"
+      xR Seq.:> xN -> do
-      , tyDoc
+        xN' <- docSeq
-      ]
+          [ appSep $ return xN
-  ListPat elems _ _ -> do
+          , appSep $ docLit $ Text.pack "::"
-    elemDocs <- docSharedWrapper layoutPat `mapM` elems
+          , tyDoc
-    docSeq
+          ]
-      $  [docLit $ Text.pack "["]
+        return $ xR Seq.|> xN'
-      ++ List.intersperse docCommaSep (elemDocs)
+  ListPat elems _ _ ->
-      ++ [docLit $ Text.pack "]"]
+    wrapPatListy elems "[" "]"
   BangPat pat1 -> do
-    patDoc <- docSharedWrapper layoutPat pat1
+    wrapPatPrepend pat1 (docLit $ Text.pack "!")
-    docSeq [docLit $ Text.pack "!", patDoc]
   LazyPat pat1 -> do
-    patDoc <- docSharedWrapper layoutPat pat1
+    wrapPatPrepend pat1 (docLit $ Text.pack "~")
-    docSeq [docLit $ Text.pack "~", patDoc]
   NPat llit@(L _ (OverLit olit _ _ _)) _ _ _ -> do
-    docWrapNode llit $ allocateNode $ overLitValBriDoc olit
+    fmap Seq.singleton $ docWrapNode llit $ allocateNode $ overLitValBriDoc olit
 
 -- #if MIN_VERSION_ghc(8,0,0)
 --   VarPat n -> return $ stringLayouter lpat $ lrdrNameToText n
 -- #else
 --   VarPat n -> return $ stringLayouter lpat $ rdrNameToText n
 -- #endif
-  _ -> unknownNodeError "" lpat
+  _ -> fmap return $ unknownNodeError "" lpat
+
+colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered
+colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList
+
+wrapPatPrepend
+  :: GenLocated SrcSpan (Pat RdrName)
+  -> ToBriDocM BriDocNumbered
+  -> ToBriDocM (Seq BriDocNumbered)
+wrapPatPrepend pat prepElem = do
+  patDocs <- layoutPat pat
+  case Seq.viewl patDocs of
+    Seq.EmptyL -> return $ Seq.empty
+    x1 Seq.:< xR -> do
+      x1' <- docSeq [prepElem, return x1]
+      return $ x1' Seq.<| xR
+
+wrapPatListy
+  :: [GenLocated SrcSpan (Pat RdrName)]
+  -> String
+  -> String
+  -> ToBriDocM (Seq BriDocNumbered)
+wrapPatListy elems start end = do
+  elemDocs <- Seq.fromList elems `forM` \e -> layoutPat e >>= colsWrapPat
+  sDoc <- docLit $ Text.pack start
+  eDoc <- docLit $ Text.pack end
+  case Seq.viewl elemDocs of
+    Seq.EmptyL -> fmap Seq.singleton $ docLit $ Text.pack $ start ++ end
+    x1 Seq.:< rest -> do
+        rest' <- rest `forM` \bd -> docSeq
+          [ docLit $ Text.pack ","
+          , docSeparator
+          , return bd
+          ]
+        return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc

src/Language/Haskell/Brittany/Layouters/Stmt.hs

@@ -31,7 +31,7 @@ layoutStmt lstmt@(L _ stmt) = docWrapNode lstmt $ case stmt of
   LastStmt body False _ -> do
     layoutExpr body
   BindStmt lPat expr _ _ _ -> do
-    patDoc <- docSharedWrapper layoutPat lPat
+    patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat
     expDoc <- docSharedWrapper layoutExpr expr
     docAlt
       [ docCols ColBindStmt

srcinc/prelude.inc

@@ -393,8 +393,8 @@ import qualified Data.Semigroup as Semigroup
 import qualified Data.ByteString as ByteString
 import qualified Data.ByteString.Lazy as ByteStringL
 
-import qualified Data.IntMap as IntMap
+-- import qualified Data.IntMap as IntMap
--- import qualified Data.IntMap.Lazy as IntMapL
+import qualified Data.IntMap.Lazy as IntMapL
 import qualified Data.IntMap.Strict as IntMapS
 -- import qualified Data.IntSet as IntSet
 import qualified Data.Map as Map