From 986a720ca8247e8c1726148f5dd07d455c0bcd3e Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 2 Aug 2016 13:52:09 +0200 Subject: [PATCH] Make newlining "lazy" in backend --- src/Language/Haskell/Brittany/BriLayouter.hs | 33 +- src/Language/Haskell/Brittany/LayoutBasics.hs | 373 +++++++++--------- .../Haskell/Brittany/Layouters/Decl.hs | 6 +- .../Haskell/Brittany/Layouters/Expr.hs | 2 +- src/Language/Haskell/Brittany/Types.hs | 46 ++- src/Language/Haskell/Brittany/Utils.hs | 2 +- 6 files changed, 251 insertions(+), 211 deletions(-) diff --git a/src/Language/Haskell/Brittany/BriLayouter.hs b/src/Language/Haskell/Brittany/BriLayouter.hs index 13a06a3..4d65cce 100644 --- a/src/Language/Haskell/Brittany/BriLayouter.hs +++ b/src/Language/Haskell/Brittany/BriLayouter.hs @@ -102,7 +102,7 @@ layoutBriDoc ast briDoc = do let state = LayoutState { _lstate_baseY = 0 - , _lstate_curY = 0 + , _lstate_curYOrAddNewline = Right 0 , _lstate_indLevel = 0 , _lstate_indLevelLinger = 0 , _lstate_commentsPrior = extractCommentsPrior filteredAnns @@ -110,7 +110,6 @@ layoutBriDoc ast briDoc = do , _lstate_commentCol = Nothing , _lstate_addSepSpace = Nothing , _lstate_inhibitMTEL = False - , _lstate_isNewline = NewLineStateInit } state' <- MultiRWSS.withMultiStateS state @@ -1073,6 +1072,7 @@ layoutBriDocM = \case BDEmpty -> do return () -- can it be that simple BDLit t -> do + layoutIndentRestorePostComment layoutRemoveIndentLevelLinger layoutWriteAppend t BDSeq list -> do @@ -1142,7 +1142,7 @@ layoutBriDocM = \case state <- mGet let m = _lstate_commentsPrior state let allowMTEL = not (_lstate_inhibitMTEL state) - && _lstate_isNewline state /= NewLineStateNo + && Data.Either.isRight (_lstate_curYOrAddNewline state) mAnn <- do let mAnn = Map.lookup annKey m mSet $ state { _lstate_commentsPrior = Map.delete annKey m } @@ -1152,17 +1152,16 @@ layoutBriDocM = \case Just [] -> when allowMTEL $ moveToExactAnn annKey Just priors -> do -- layoutResetSepSpace - layoutSetCommentCol priors `forM_` \( ExactPrint.Types.Comment comment _ _ - , ExactPrint.Types.DP (x, y) + , ExactPrint.Types.DP (y, x) ) -> do - fixedX <- fixMoveToLineByIsNewline x - replicateM_ fixedX layoutWriteNewline - layoutMoveToIndentCol y - -- layoutWriteAppend $ Text.pack $ replicate y ' ' + layoutMoveToCommentPos y x + -- fixedX <- fixMoveToLineByIsNewline x + -- replicateM_ fixedX layoutWriteNewline + -- layoutMoveToIndentCol y layoutWriteAppendMultiline $ Text.pack $ comment + -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } when allowMTEL $ moveToExactAnn annKey - layoutIndentRestorePostComment layoutBriDocM bd BDAnnotationPost annKey bd -> do layoutBriDocM bd @@ -1176,16 +1175,15 @@ layoutBriDocM = \case case mAnn of Nothing -> return () Just posts -> do - when (not $ null posts) $ layoutSetCommentCol posts `forM_` \( ExactPrint.Types.Comment comment _ _ , ExactPrint.Types.DP (x, y) ) -> do - fixedX <- fixMoveToLineByIsNewline x - replicateM_ fixedX layoutWriteNewline - -- layoutWriteAppend $ Text.pack $ replicate y ' ' - layoutMoveToIndentCol y + layoutMoveToCommentPos x y + -- fixedX <- fixMoveToLineByIsNewline x + -- replicateM_ fixedX layoutWriteNewline + -- layoutMoveToIndentCol y layoutWriteAppendMultiline $ Text.pack $ comment - layoutIndentRestorePostComment + -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } BDNonBottomSpacing bd -> layoutBriDocM bd BDProhibitMTEL bd -> do -- set flag to True for this child, but disable afterwards. @@ -1279,7 +1277,8 @@ layoutBriDocM = \case ColInfo ind _ list -> do curX <- do state <- mGet - return $ _lstate_curY state + fromMaybe 0 (_lstate_addSepSpace state) + 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) diff --git a/src/Language/Haskell/Brittany/LayoutBasics.hs b/src/Language/Haskell/Brittany/LayoutBasics.hs index 23ac0a2..7d62477 100644 --- a/src/Language/Haskell/Brittany/LayoutBasics.hs +++ b/src/Language/Haskell/Brittany/LayoutBasics.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeApplications #-} #if !INSERTTRACES {-# OPTIONS_GHC -Wno-redundant-constraints #-} #endif @@ -12,14 +13,12 @@ module Language.Haskell.Brittany.LayoutBasics , lrdrNameToText , lrdrNameToTextAnn , askIndent - , getCurRemaining , layoutWriteAppend , layoutWriteAppendMultiline , layoutWriteNewlineBlock , layoutWriteNewline , layoutWriteEnsureNewlineBlock , layoutWriteEnsureBlock - , layoutWriteEnsureBlockPlusN , layoutWithAddBaseCol , layoutWithAddBaseColBlock , layoutWithAddBaseColN @@ -28,18 +27,15 @@ module Language.Haskell.Brittany.LayoutBasics , layoutSetIndentLevel , layoutWriteEnsureAbsoluteN , layoutAddSepSpace - , layoutMoveToIndentCol , layoutSetCommentCol + , layoutMoveToCommentPos + , layoutIndentRestorePostComment , moveToExactAnn , layoutWritePriorComments , layoutWritePostComments - , layoutIndentRestorePostComment - , layoutWritePriorCommentsRestore - , layoutWritePostCommentsRestore , layoutRemoveIndentLevelLinger , extractCommentsPrior , extractCommentsPost - , fixMoveToLineByIsNewline , filterAnns , ppmMoveToExactLoc , docEmpty @@ -118,6 +114,17 @@ import qualified Text.PrettyPrint as PP import Data.Function ( fix ) +traceLocal + :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m, Show a) + => a + -> m () +#if INSERTTRACES +traceLocal x = do + mGet >>= tellDebugMessShow @LayoutState + tellDebugMessShow x +#else +traceLocal _ = return () +#endif processDefault :: (ExactPrint.Annotate.Annotate ast, MonadMultiWriter Text.Builder.Builder m, @@ -189,15 +196,6 @@ lrdrNameToTextAnn ast@(L _ n) = do askIndent :: (MonadMultiReader Config m) => m Int askIndent = runIdentity . _lconfig_indentAmount . _conf_layout <$> mAsk -getCurRemaining :: ( MonadMultiReader Config m - , MonadMultiState LayoutState m - ) - => m Int -getCurRemaining = do - cols <- mAsk <&> _conf_layout .> _lconfig_cols .> runIdentity - clc <- _lstate_curY <$> mGet - return $ cols - clc - layoutWriteAppend :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m @@ -205,28 +203,33 @@ layoutWriteAppend :: (MonadMultiWriter => Text -> m () layoutWriteAppend t = do -#if INSERTTRACES - tellDebugMessShow ("layoutWriteAppend", t) -#endif + traceLocal ("layoutWriteAppend", t) state <- mGet - case _lstate_addSepSpace state of - Just i -> do + case _lstate_curYOrAddNewline state of + Right i -> do #if INSERTTRACES - tellDebugMessShow (" inserted spaces: ", i) + tellDebugMessShow (" inserted newlines: ", i) #endif - mSet $ state { _lstate_curY = _lstate_curY state + Text.length t + i - , _lstate_addSepSpace = Nothing - , _lstate_isNewline = NewLineStateNo - } - mTell $ Text.Builder.fromText $ Text.pack (replicate i ' ') <> t - Nothing -> do + replicateM_ i $ mTell $ Text.Builder.fromString $ "\n" + Left{} -> do #if INSERTTRACES - tellDebugMessShow (" inserted no spaces") + tellDebugMessShow (" inserted no newlines") #endif - mSet $ state { _lstate_curY = _lstate_curY state + Text.length t - , _lstate_isNewline = NewLineStateNo - } - mTell $ Text.Builder.fromText t + return () + let spaces = case _lstate_addSepSpace state of + Just i -> i + Nothing -> 0 +#if INSERTTRACES + tellDebugMessShow (" inserted spaces: ", spaces) +#endif + mTell $ Text.Builder.fromText $ Text.pack (replicate spaces ' ') + mTell $ Text.Builder.fromText $ t + mModify $ \s -> s + { _lstate_curYOrAddNewline = Left $ case _lstate_curYOrAddNewline s of + Left c -> c + Text.length t + spaces + Right{} -> Text.length t + spaces + , _lstate_addSepSpace = Nothing + } layoutWriteAppendSpaces :: (MonadMultiWriter Text.Builder.Builder m, @@ -235,9 +238,7 @@ layoutWriteAppendSpaces :: (MonadMultiWriter => Int -> m () layoutWriteAppendSpaces i = do -#if INSERTTRACES - tellDebugMessShow ("layoutWriteAppendSpaces", i) -#endif + traceLocal ("layoutWriteAppendSpaces", i) unless (i==0) $ do state <- mGet mSet $ state { _lstate_addSepSpace = Just @@ -252,9 +253,7 @@ layoutWriteAppendMultiline :: (MonadMultiWriter => Text -> m () layoutWriteAppendMultiline t = do -#if INSERTTRACES - tellDebugMessShow ("layoutWriteAppendMultiline", t) -#endif + traceLocal ("layoutWriteAppendMultiline", t) case Text.lines t of [] -> layoutWriteAppend t -- need to write empty, too. @@ -271,30 +270,74 @@ layoutWriteNewlineBlock :: (MonadMultiWriter , MonadMultiWriter (Seq String) m) => m () layoutWriteNewlineBlock = do -#if INSERTTRACES - tellDebugMessShow ("layoutWriteNewlineBlock") -#endif + traceLocal ("layoutWriteNewlineBlock") state <- mGet - mSet $ state { _lstate_curY = 0 -- _lstate_baseY state + mSet $ state { _lstate_curYOrAddNewline = Right 1 , _lstate_addSepSpace = Just $ _lstate_baseY state , _lstate_inhibitMTEL = False - , _lstate_isNewline = NewLineStateYes } - mTell $ Text.Builder.fromString $ "\n" -- ++ replicate (_lstate_baseY state) ' ' -layoutMoveToIndentCol :: ( MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m) => Int -> m () -layoutMoveToIndentCol i = do -#if INSERTTRACES - tellDebugMessShow ("layoutMoveToIndentCol", i) -#endif +-- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m +-- , MonadMultiWriter (Seq String) m) => Int -> m () +-- layoutMoveToIndentCol i = do +-- #if INSERTTRACES +-- tellDebugMessShow ("layoutMoveToIndentCol", i) +-- #endif +-- state <- mGet +-- mSet $ state +-- { _lstate_addSepSpace = Just +-- $ if isJust $ _lstate_addNewline state +-- then i +-- else _lstate_indLevelLinger state + i - _lstate_curY state +-- } + +layoutSetCommentCol :: ( MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m ) + => m () +layoutSetCommentCol = do state <- mGet - mSet $ state - { _lstate_addSepSpace = Just - $ if _lstate_isNewline state == NewLineStateNo - then i - else _lstate_indLevelLinger state + i - _lstate_curY state - } + let col = case _lstate_curYOrAddNewline state of + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> _lstate_baseY state + traceLocal ("layoutSetCommentCol", col) + unless (Data.Maybe.isJust $ _lstate_commentCol state) + $ mSet state { _lstate_commentCol = Just col } + +layoutMoveToCommentPos + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => Int + -> Int + -> m () +layoutMoveToCommentPos y x = do + traceLocal ("layoutMoveToCommentPos", y, x) + state <- mGet + if Data.Maybe.isJust (_lstate_commentCol state) + then do + mSet state + { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of + Left i -> if y==0 then Left i else Right y + Right{} -> Right y + , _lstate_addSepSpace = Just $ case _lstate_curYOrAddNewline state of + Left{} -> if y==0 + then x + else _lstate_indLevelLinger state + x + Right{} -> _lstate_indLevelLinger state + x + } + else do + mSet state + { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of + Left i -> if y==0 then Left i else Right y + Right{} -> Right y + , _lstate_addSepSpace = Just $ if y==0 + then x + else _lstate_indLevelLinger state + x + , _lstate_commentCol = Just $ case _lstate_curYOrAddNewline state of + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> _lstate_baseY state + } -- | does _not_ add spaces to again reach the current base column. layoutWriteNewline :: (MonadMultiWriter @@ -303,16 +346,14 @@ layoutWriteNewline :: (MonadMultiWriter , MonadMultiWriter (Seq String) m) => m () layoutWriteNewline = do -#if INSERTTRACES - tellDebugMessShow ("layoutWriteNewline") -#endif + traceLocal ("layoutWriteNewline") state <- mGet - mSet $ state { _lstate_curY = 0 + mSet $ state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of + Left{} -> Right 1 + Right i -> Right (i+1) , _lstate_addSepSpace = Nothing , _lstate_inhibitMTEL = False - , _lstate_isNewline = NewLineStateYes } - mTell $ Text.Builder.fromString $ "\n" layoutWriteEnsureNewlineBlock :: (MonadMultiWriter Text.Builder.Builder m, @@ -320,14 +361,15 @@ layoutWriteEnsureNewlineBlock :: (MonadMultiWriter , MonadMultiWriter (Seq String) m) => m () layoutWriteEnsureNewlineBlock = do -#if INSERTTRACES - tellDebugMessShow ("layoutWriteEnsureNewlineBlock") -#endif + traceLocal ("layoutWriteEnsureNewlineBlock") state <- mGet - mSet $ state { _lstate_addSepSpace = Just $ _lstate_baseY state } - when (_lstate_isNewline state == NewLineStateNo) $ do - layoutWriteNewlineBlock - + mSet $ state + { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of + Left{} -> Right 1 + Right i -> Right $ max 1 i + , _lstate_addSepSpace = Just $ _lstate_baseY state + , _lstate_inhibitMTEL = False + } layoutWriteEnsureBlock :: (MonadMultiWriter Text.Builder.Builder m, @@ -335,19 +377,17 @@ layoutWriteEnsureBlock :: (MonadMultiWriter , MonadMultiWriter (Seq String) m) => m () layoutWriteEnsureBlock = do -#if INSERTTRACES - tellDebugMessShow ("layoutWriteEnsureBlock") -#endif + traceLocal ("layoutWriteEnsureBlock") state <- mGet - let diff = case _lstate_addSepSpace state of - Nothing -> _lstate_curY state - _lstate_baseY state - Just sp -> _lstate_baseY state - sp - _lstate_curY state + let + diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of + (Nothing, Left i) -> _lstate_baseY state - i + (Nothing, Right{}) -> _lstate_baseY state + (Just sp, Left i) -> max sp (_lstate_baseY state - i) + (Just sp, Right{}) -> max sp (_lstate_baseY state) -- when (diff>0) $ layoutWriteNewlineBlock - when (diff>0) $ do - mSet $ state { _lstate_addSepSpace = Just - $ _lstate_baseY state - - _lstate_curY state - } + when (diff > 0) $ do + mSet $ state { _lstate_addSepSpace = Just $ diff } layoutWriteEnsureAbsoluteN :: (MonadMultiWriter Text.Builder.Builder m, @@ -355,11 +395,11 @@ layoutWriteEnsureAbsoluteN :: (MonadMultiWriter , MonadMultiWriter (Seq String) m) => Int -> m () layoutWriteEnsureAbsoluteN n = do -#if INSERTTRACES - tellDebugMessShow ("layoutWriteEnsureAbsoluteN", n) -#endif state <- mGet - let diff = n - _lstate_curY state + let diff = case _lstate_curYOrAddNewline state of + Left i -> n-i + Right{} -> n + traceLocal ("layoutWriteEnsureAbsoluteN", n, diff) when (diff>0) $ do mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to -- at least (Just 1), so we won't @@ -367,31 +407,11 @@ layoutWriteEnsureAbsoluteN n = do -- bad way. } -layoutWriteEnsureBlockPlusN :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m) - => Int -> m () -layoutWriteEnsureBlockPlusN n = do -#if INSERTTRACES - tellDebugMessShow ("layoutWriteEnsureBlockPlusN", n) -#endif - state <- mGet - let diff = _lstate_curY state - _lstate_baseY state - n - if diff>0 - then layoutWriteNewlineBlock - else if diff<0 - then do - layoutWriteAppendSpaces $ negate diff - else return () - layoutSetBaseColInternal :: ( MonadMultiState LayoutState m , MonadMultiWriter (Seq String) m ) => Int -> m () layoutSetBaseColInternal i = do -#if INSERTTRACES - tellDebugMessShow ("layoutSetBaseColInternal", i) -#endif + traceLocal ("layoutSetBaseColInternal", i) mModify $ \s -> s { _lstate_baseY = i } layoutSetIndentLevelInternal :: ( MonadMultiState LayoutState m @@ -458,9 +478,7 @@ layoutWithAddBaseColNBlock :: (MonadMultiWriter -> m () -> m () layoutWithAddBaseColNBlock amount m = do -#if INSERTTRACES - tellDebugMessShow ("layoutWithAddBaseColNBlock", amount) -#endif + traceLocal ("layoutWithAddBaseColNBlock", amount) state <- mGet layoutSetBaseColInternal $ _lstate_baseY state + amount layoutWriteEnsureBlock @@ -492,9 +510,10 @@ layoutSetBaseColCur m = do tellDebugMessShow ("layoutSetBaseColCur") #endif state <- mGet - layoutSetBaseColInternal $ case _lstate_addSepSpace state of - Nothing -> _lstate_curY state - Just i -> _lstate_curY state + i + case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of + (Left i, Just j) -> layoutSetBaseColInternal (i+j) + (Left i, Nothing) -> layoutSetBaseColInternal i + (Right{}, _) -> return () m layoutSetBaseColInternal $ _lstate_baseY state @@ -507,7 +526,11 @@ layoutSetIndentLevel m = do tellDebugMessShow ("layoutSetIndentLevel") #endif state <- mGet - layoutSetIndentLevelInternal $ _lstate_curY state + fromMaybe 0 (_lstate_addSepSpace state) + layoutSetIndentLevelInternal $ case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of + (Left i, Just j) -> i + j + (Left i, Nothing) -> i + (Right{}, Just j) -> j + (Right{}, Nothing) -> 0 m layoutSetIndentLevelInternal $ _lstate_indLevel state -- why are comment indentations relative to the previous indentation on @@ -528,30 +551,41 @@ layoutAddSepSpace = do -- TODO: when refactoring is complete, the other version of this method -- can probably be removed. -moveToExactAnn :: (MonadMultiWriter Text.Builder.Builder m, - MonadMultiState LayoutState m, - MonadMultiReader (Map AnnKey Annotation) m - , MonadMultiWriter (Seq String) m) => AnnKey -> m () +moveToExactAnn + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiReader (Map AnnKey Annotation) m + , MonadMultiWriter (Seq String) m + ) + => AnnKey + -> m () moveToExactAnn annKey = do -#if INSERTTRACES - tellDebugMessShow ("moveToExactAnn'", annKey) -#endif + traceLocal ("moveToExactAnn", annKey) anns <- mAsk case Map.lookup annKey anns of Nothing -> return () Just ann -> do -- curY <- mGet <&> _lstate_curY - let ExactPrint.Types.DP (x, _y) = ExactPrint.Types.annEntryDelta ann - fixedX <- fixMoveToLineByIsNewline x - replicateM_ fixedX $ layoutWriteNewlineBlock - -fixMoveToLineByIsNewline :: MonadMultiState - LayoutState m => Int -> m Int -fixMoveToLineByIsNewline x = do - newLineState <- mGet <&> _lstate_isNewline - return $ if newLineState == NewLineStateYes - then x-1 - else x + let ExactPrint.Types.DP (y, _x) = ExactPrint.Types.annEntryDelta ann + -- mModify $ \state -> state { _lstate_addNewline = Just x } + mModify $ \state -> + let upd = case _lstate_curYOrAddNewline state of + Left i -> if y==0 then Left i else Right y + Right i -> Right $ max y i + in state + { _lstate_curYOrAddNewline = upd + , _lstate_addSepSpace = if Data.Either.isRight upd + then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just (_lstate_baseY state) + else Nothing + , _lstate_commentCol = Nothing + } +-- fixMoveToLineByIsNewline :: MonadMultiState +-- LayoutState m => Int -> m Int +-- fixMoveToLineByIsNewline x = do +-- newLineState <- mGet <&> _lstate_isNewline +-- return $ if newLineState == NewLineStateYes +-- then x-1 +-- else x ppmMoveToExactLoc :: MonadMultiWriter Text.Builder.Builder m => ExactPrint.Types.DeltaPos @@ -560,18 +594,6 @@ ppmMoveToExactLoc (ExactPrint.Types.DP (x,y)) = do replicateM_ x $ mTell $ Text.Builder.fromString "\n" replicateM_ y $ mTell $ Text.Builder.fromString " " -layoutSetCommentCol :: ( MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m ) - => m () -layoutSetCommentCol = do - state <- mGet - let col = _lstate_curY state - + fromMaybe 0 (_lstate_addSepSpace state) -#if INSERTTRACES - tellDebugMessShow ("layoutSetCommentCol", col) -#endif - mSet state { _lstate_commentCol = Just col } - layoutWritePriorComments :: (Data.Data.Data ast, MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m @@ -591,9 +613,7 @@ layoutWritePriorComments ast = do case mAnn of Nothing -> return () Just priors -> do - when (not $ null priors) $ do - state <- mGet - mSet $ state { _lstate_commentCol = Just $ _lstate_curY state } + when (not $ null priors) $ layoutSetCommentCol priors `forM_` \( ExactPrint.Types.Comment comment _ _ , ExactPrint.Types.DP (x, y) ) -> do @@ -623,9 +643,7 @@ layoutWritePostComments ast = do case mAnn of Nothing -> return () Just posts -> do - when (not $ null posts) $ do - state <- mGet - mSet $ state { _lstate_commentCol = Just $ _lstate_curY state } + when (not $ null posts) $ layoutSetCommentCol posts `forM_` \( ExactPrint.Types.Comment comment _ _ , ExactPrint.Types.DP (x, y) ) -> do @@ -633,42 +651,43 @@ layoutWritePostComments ast = do layoutWriteAppend $ Text.pack $ replicate y ' ' layoutWriteAppendMultiline $ Text.pack $ comment -layoutIndentRestorePostComment :: ( Monad m - , MonadMultiState LayoutState m - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiWriter (Seq String) m - ) - => m () +layoutIndentRestorePostComment + :: ( Monad m + , MonadMultiState LayoutState m + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiWriter (Seq String) m + ) + => m () layoutIndentRestorePostComment = do - isNotNewline <- mGet <&> _lstate_isNewline .> (==NewLineStateNo) mCommentCol <- _lstate_commentCol <$> mGet + eCurYAddNL <- _lstate_curYOrAddNewline <$> mGet #if INSERTTRACES tellDebugMessShow ("layoutIndentRestorePostComment", mCommentCol) #endif mModify $ \s -> s { _lstate_commentCol = Nothing } - case mCommentCol of - Just commentCol | isNotNewline -> do - layoutWriteNewline - layoutWriteAppendSpaces commentCol + case (mCommentCol, eCurYAddNL) of + (Just commentCol, Left{}) -> do + layoutWriteEnsureNewlineBlock + layoutWriteEnsureAbsoluteN commentCol _ -> return () -layoutWritePriorCommentsRestore :: (Data.Data.Data ast, - MonadMultiWriter Text.Builder.Builder m, - MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m) - => GenLocated SrcSpan ast -> m () -layoutWritePriorCommentsRestore x = do - layoutWritePriorComments x - layoutIndentRestorePostComment - -layoutWritePostCommentsRestore :: (Data.Data.Data ast, - MonadMultiWriter Text.Builder.Builder m, - MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m) - => GenLocated SrcSpan ast -> m () -layoutWritePostCommentsRestore x = do - layoutWritePostComments x - layoutIndentRestorePostComment +-- layoutWritePriorCommentsRestore :: (Data.Data.Data ast, +-- MonadMultiWriter Text.Builder.Builder m, +-- MonadMultiState LayoutState m +-- , MonadMultiWriter (Seq String) m) +-- => GenLocated SrcSpan ast -> m () +-- layoutWritePriorCommentsRestore x = do +-- layoutWritePriorComments x +-- layoutIndentRestorePostComment +-- +-- layoutWritePostCommentsRestore :: (Data.Data.Data ast, +-- MonadMultiWriter Text.Builder.Builder m, +-- MonadMultiState LayoutState m +-- , MonadMultiWriter (Seq String) m) +-- => GenLocated SrcSpan ast -> m () +-- layoutWritePostCommentsRestore x = do +-- layoutWritePostComments x +-- layoutIndentRestorePostComment extractCommentsPrior :: ExactPrint.Types.Anns -> PriorMap extractCommentsPrior anns = flip Map.mapMaybe anns $ \ann -> diff --git a/src/Language/Haskell/Brittany/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Layouters/Decl.hs index 54ef5f0..2891eb4 100644 --- a/src/Language/Haskell/Brittany/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Layouters/Decl.hs @@ -43,8 +43,8 @@ layoutSig lsig@(L _loc sig) = docWrapNode lsig $ case sig of typeDoc <- docSharedWrapper layoutType typ docAlt [ docSeq - [ docPostComment lsig $ docLit nameStr - , docLit $ Text.pack " :: " + [ appSep $ docPostComment lsig $ docLit nameStr + , appSep $ docLit $ Text.pack "::" , docForceSingleline typeDoc ] , docAddBaseY BrIndentRegular @@ -65,7 +65,7 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of patDoc <- docSharedWrapper layoutPat lPat expDoc <- docSharedWrapper layoutExpr expr docCols ColBindStmt - [patDoc, docSeq [docLit $ Text.pack " <- ", expDoc]] + [appSep patDoc, docSeq [appSep $ docLit $ Text.pack "<-", expDoc]] _ -> briDocByExact lgstmt -- TODO layoutBind :: ToBriDocC (HsBindLR RdrName RdrName) (Either [BriDocNumbered] BriDocNumbered) diff --git a/src/Language/Haskell/Brittany/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Layouters/Expr.hs index 8eb2e93..5930529 100644 --- a/src/Language/Haskell/Brittany/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Layouters/Expr.hs @@ -73,7 +73,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "\\case") - (docLines $ return <$> funcPatDocs) + (docSetIndentLevel $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) HsApp exp1@(L _ HsApp{}) exp2 -> do let gather :: [LHsExpr RdrName] -> LHsExpr RdrName -> (LHsExpr RdrName, [LHsExpr RdrName]) gather list = \case diff --git a/src/Language/Haskell/Brittany/Types.hs b/src/Language/Haskell/Brittany/Types.hs index b99b0a3..cfefa67 100644 --- a/src/Language/Haskell/Brittany/Types.hs +++ b/src/Language/Haskell/Brittany/Types.hs @@ -37,7 +37,11 @@ type PostMap = Map AnnKey [(Comment, DeltaPos)] data LayoutState = LayoutState { _lstate_baseY :: Int -- ^ number of current indentation columns -- (not number of indentations). - , _lstate_curY :: Int -- ^ number of chars in the current line. + , _lstate_curYOrAddNewline :: Either Int Int + -- ^ Either: + -- 1) number of chars in the current line. + -- 2) number of newlines to be inserted before inserting any + -- non-space elements. , _lstate_indLevel :: Int -- ^ current indentation level. set for -- any layout-affected elements such as -- let/do/case/where elements. @@ -54,7 +58,12 @@ data LayoutState = LayoutState -- really _should_ be included in the -- output. , _lstate_commentsPost :: PostMap -- similarly, for post-node comments. - , _lstate_commentCol :: Maybe Int + , _lstate_commentCol :: Maybe Int -- this communicates two things: + -- firstly, that cursor is currently + -- at the end of a comment (so needs + -- newline before any actual content). + -- secondly, the column at which + -- insertion of comments started. , _lstate_addSepSpace :: Maybe Int -- number of spaces to insert if anyone -- writes (any non-spaces) in the -- current line. @@ -66,18 +75,31 @@ data LayoutState = LayoutState -- While this flag is on, this behaviour will be disabled. -- The flag is automatically turned off when inserting any kind of -- newline. - , _lstate_isNewline :: NewLineState - -- captures if the layouter currently is in a new line, i.e. if the - -- current line only contains (indentation) spaces. + -- , _lstate_isNewline :: NewLineState + -- -- captures if the layouter currently is in a new line, i.e. if the + -- -- current line only contains (indentation) spaces. } -data NewLineState = NewLineStateInit -- initial state. we do not know if in a - -- newline, really. by special-casing - -- this we can appropriately handle it - -- differently at use-site. - | NewLineStateYes - | NewLineStateNo - deriving Eq +-- evil, incomplete Show instance; only for debugging. +instance Show LayoutState where + show state = + "LayoutState" + ++ "{baseY=" ++ show (_lstate_baseY state) + ++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state) + ++ ",indLevel=" ++ show (_lstate_indLevel state) + ++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state) + ++ ",commentCol=" ++ show (_lstate_commentCol state) + ++ ",addSepSpace=" ++ show (_lstate_addSepSpace state) + ++ ",inhibitMTEL=" ++ show (_lstate_inhibitMTEL state) + ++ "}" + +-- data NewLineState = NewLineStateInit -- initial state. we do not know if in a +-- -- newline, really. by special-casing +-- -- this we can appropriately handle it +-- -- differently at use-site. +-- | NewLineStateYes +-- | NewLineStateNo +-- deriving Eq -- data LayoutSettings = LayoutSettings -- { _lsettings_cols :: Int -- the thing that has default 80. diff --git a/src/Language/Haskell/Brittany/Utils.hs b/src/Language/Haskell/Brittany/Utils.hs index 7bbb94d..1803e60 100644 --- a/src/Language/Haskell/Brittany/Utils.hs +++ b/src/Language/Haskell/Brittany/Utils.hs @@ -207,7 +207,7 @@ tellDebugMess :: MonadMultiWriter (Seq String) m => String -> m () tellDebugMess s = mTell $ Seq.singleton s -tellDebugMessShow :: (MonadMultiWriter +tellDebugMessShow :: forall a m . (MonadMultiWriter (Seq String) m, Show a) => a -> m () tellDebugMessShow = tellDebugMess . show