From 48b2057d8463b04ad5cf1570d2711c337efb7ed9 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 3 Sep 2016 21:32:18 +0200 Subject: [PATCH] Improve horizontal alignments significantly (patterns) --- src/Language/Haskell/Brittany/BriLayouter.hs | 56 +++++-- src/Language/Haskell/Brittany/LayoutBasics.hs | 28 ++++ .../Haskell/Brittany/Layouters/Decl.hs | 10 +- .../Haskell/Brittany/Layouters/Expr.hs | 2 +- .../Haskell/Brittany/Layouters/Pattern.hs | 151 +++++++++++------- .../Haskell/Brittany/Layouters/Stmt.hs | 2 +- srcinc/prelude.inc | 4 +- 7 files changed, 175 insertions(+), 78 deletions(-) diff --git a/src/Language/Haskell/Brittany/BriLayouter.hs b/src/Language/Haskell/Brittany/BriLayouter.hs index 10fc700..4f1ea65 100644 --- a/src/Language/Haskell/Brittany/BriLayouter.hs +++ b/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 = - _cbs_map finalState <&> \colss -> - let maxCols = Foldable.foldl1 (zipWith max) colss + processedMap curX colMax = fix $ \result -> + _cbs_map finalState <&> \colSpacingss -> + 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 - return $ (Seq.singleton lengths, ColInfo ind sig (zip lengths subInfos)) + let lengthInfos = zip (briDocLineLength <$> list) 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] -type ColMap1 = IntMapS.IntMap {- ColIndex -} ColSpaces -type ColMap2 = IntMapS.IntMap {- ColIndex -} (Float, ColSpace, ColSpaces) + +data ColumnSpacing + = ColumnSpacingLeaf Int + | 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 diff --git a/src/Language/Haskell/Brittany/LayoutBasics.hs b/src/Language/Haskell/Brittany/LayoutBasics.hs index 3452eae..76fc7f1 100644 --- a/src/Language/Haskell/Brittany/LayoutBasics.hs +++ b/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 diff --git a/src/Language/Haskell/Brittany/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Layouters/Decl.hs index 64202d1..55ef0eb 100644 --- a/src/Language/Haskell/Brittany/Layouters/Decl.hs +++ b/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 diff --git a/src/Language/Haskell/Brittany/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Layouters/Expr.hs index 9ba6acf..38bdeee 100644 --- a/src/Language/Haskell/Brittany/Layouters/Expr.hs +++ b/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 diff --git a/src/Language/Haskell/Brittany/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Layouters/Pattern.hs index 857c9ca..f51183d 100644 --- a/src/Language/Haskell/Brittany/Layouters/Pattern.hs +++ b/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 "_" - VarPat n -> docLit $ lrdrNameToText n - LitPat lit -> allocateNode $ litBriDoc lit + WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" + VarPat n -> fmap Seq.singleton $ docLit $ lrdrNameToText n + LitPat lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit ParPat inner -> do - innerDoc <- docSharedWrapper layoutPat inner - docSeq - [ docLit $ Text.pack "(" - , innerDoc - , docLit $ Text.pack ")" - ] + innerDocs <- layoutPat inner + left <- docLit $ Text.pack "(" + right <- docLit $ Text.pack ")" + 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 + -- 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 - else docSeq - $ appSep (docLit nameDoc) : spacifyDocs argDocs + then return <$> docLit nameDoc + else do + 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 - rightDoc <- docSharedWrapper layoutPat right - docSeq [leftDoc, docLit nameDoc, rightDoc] + leftDoc <- colsWrapPat =<< layoutPat left + rightDoc <- colsWrapPat =<< layoutPat right + 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 - [ docSeq - $ [ 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 - ] + Boxed -> wrapPatListy args "(" ")" + Unboxed -> wrapPatListy args "(#" "#)" AsPat asName asPat -> do - patDoc <- docSharedWrapper layoutPat asPat - docSeq - [ docLit $ lrdrNameToText asName <> Text.pack "@" - , patDoc - ] + wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@") SigPatIn pat1 (HsIB _ (HsWC _ _ ty1)) -> do - patDoc <- docSharedWrapper layoutPat pat1 + patDocs <- layoutPat pat1 tyDoc <- docSharedWrapper layoutType ty1 - docSeq - [ appSep $ patDoc - , appSep $ docLit $ Text.pack "::" - , tyDoc - ] - ListPat elems _ _ -> do - elemDocs <- docSharedWrapper layoutPat `mapM` elems - docSeq - $ [docLit $ Text.pack "["] - ++ List.intersperse docCommaSep (elemDocs) - ++ [docLit $ Text.pack "]"] + case Seq.viewr patDocs of + Seq.EmptyR -> error "cannot happen ljoiuxoasdcoviuasd" + xR Seq.:> xN -> do + xN' <- docSeq + [ appSep $ return xN + , appSep $ docLit $ Text.pack "::" + , tyDoc + ] + return $ xR Seq.|> xN' + ListPat elems _ _ -> + wrapPatListy elems "[" "]" BangPat pat1 -> do - patDoc <- docSharedWrapper layoutPat pat1 - docSeq [docLit $ Text.pack "!", patDoc] + wrapPatPrepend pat1 (docLit $ Text.pack "!") LazyPat pat1 -> do - patDoc <- docSharedWrapper layoutPat pat1 - docSeq [docLit $ Text.pack "~", patDoc] + wrapPatPrepend pat1 (docLit $ Text.pack "~") 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 diff --git a/src/Language/Haskell/Brittany/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Layouters/Stmt.hs index 2b87aa5..51446ed 100644 --- a/src/Language/Haskell/Brittany/Layouters/Stmt.hs +++ b/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 diff --git a/srcinc/prelude.inc b/srcinc/prelude.inc index 095aade..7481537 100644 --- a/srcinc/prelude.inc +++ b/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.Lazy as IntMapL +-- import qualified Data.IntMap as IntMap +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