hexagoxel
/
brittany
1
0
Fork 0
Code Issues 117 Pull Requests 5 Packages Projects Releases 5 Wiki Activity

Make newlining "lazy" in backend

pull/1/head
Lennart Spitzner 2016-08-02 13:52:09 +02:00
parent 58c2bfbcc8
commit 986a720ca8
6 changed files with 251 additions and 211 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
src/Language/Haskell/Brittany/BriLayouter.hs
View File

@ -102,7 +102,7 @@ layoutBriDoc ast briDoc = do
let state = LayoutState let state = LayoutState
{ _lstate_baseY = 0 { _lstate_baseY = 0
, _lstate_curY = 0 , _lstate_curYOrAddNewline = Right 0
, _lstate_indLevel = 0 , _lstate_indLevel = 0
, _lstate_indLevelLinger = 0 , _lstate_indLevelLinger = 0
, _lstate_commentsPrior = extractCommentsPrior filteredAnns , _lstate_commentsPrior = extractCommentsPrior filteredAnns
@ -110,7 +110,6 @@ layoutBriDoc ast briDoc = do
, _lstate_commentCol = Nothing , _lstate_commentCol = Nothing
, _lstate_addSepSpace = Nothing , _lstate_addSepSpace = Nothing
, _lstate_inhibitMTEL = False , _lstate_inhibitMTEL = False
, _lstate_isNewline = NewLineStateInit
} }
state' <- MultiRWSS.withMultiStateS state state' <- MultiRWSS.withMultiStateS state
@ -1073,6 +1072,7 @@ layoutBriDocM = \case
BDEmpty -> do BDEmpty -> do
return () -- can it be that simple return () -- can it be that simple
BDLit t -> do BDLit t -> do
layoutIndentRestorePostComment
layoutRemoveIndentLevelLinger layoutRemoveIndentLevelLinger
layoutWriteAppend t layoutWriteAppend t
BDSeq list -> do BDSeq list -> do
@ -1142,7 +1142,7 @@ layoutBriDocM = \case
state <- mGet state <- mGet
let m = _lstate_commentsPrior state let m = _lstate_commentsPrior state
let allowMTEL = not (_lstate_inhibitMTEL state) let allowMTEL = not (_lstate_inhibitMTEL state)
&& _lstate_isNewline state /= NewLineStateNo && Data.Either.isRight (_lstate_curYOrAddNewline state)
mAnn <- do mAnn <- do
let mAnn = Map.lookup annKey m let mAnn = Map.lookup annKey m
mSet $ state { _lstate_commentsPrior = Map.delete annKey m } mSet $ state { _lstate_commentsPrior = Map.delete annKey m }
@ -1152,17 +1152,16 @@ layoutBriDocM = \case
Just [] -> when allowMTEL $ moveToExactAnn annKey Just [] -> when allowMTEL $ moveToExactAnn annKey
Just priors -> do Just priors -> do
-- layoutResetSepSpace -- layoutResetSepSpace
layoutSetCommentCol
priors `forM_` \( ExactPrint.Types.Comment comment _ _ priors `forM_` \( ExactPrint.Types.Comment comment _ _
, ExactPrint.Types.DP (x, y) , ExactPrint.Types.DP (y, x)
) -> do ) -> do
fixedX <- fixMoveToLineByIsNewline x layoutMoveToCommentPos y x
replicateM_ fixedX layoutWriteNewline -- fixedX <- fixMoveToLineByIsNewline x
layoutMoveToIndentCol y -- replicateM_ fixedX layoutWriteNewline
-- layoutWriteAppend $ Text.pack $ replicate y ' ' -- layoutMoveToIndentCol y
layoutWriteAppendMultiline $ Text.pack $ comment layoutWriteAppendMultiline $ Text.pack $ comment
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
when allowMTEL $ moveToExactAnn annKey when allowMTEL $ moveToExactAnn annKey
layoutIndentRestorePostComment
layoutBriDocM bd layoutBriDocM bd
BDAnnotationPost annKey bd -> do BDAnnotationPost annKey bd -> do
layoutBriDocM bd layoutBriDocM bd
@ -1176,16 +1175,15 @@ layoutBriDocM = \case
case mAnn of case mAnn of
Nothing -> return () Nothing -> return ()
Just posts -> do Just posts -> do
when (not $ null posts) $ layoutSetCommentCol
posts `forM_` \( ExactPrint.Types.Comment comment _ _ posts `forM_` \( ExactPrint.Types.Comment comment _ _
, ExactPrint.Types.DP (x, y) , ExactPrint.Types.DP (x, y)
) -> do ) -> do
fixedX <- fixMoveToLineByIsNewline x layoutMoveToCommentPos x y
replicateM_ fixedX layoutWriteNewline -- fixedX <- fixMoveToLineByIsNewline x
-- layoutWriteAppend $ Text.pack $ replicate y ' ' -- replicateM_ fixedX layoutWriteNewline
layoutMoveToIndentCol y -- layoutMoveToIndentCol y
layoutWriteAppendMultiline $ Text.pack $ comment layoutWriteAppendMultiline $ Text.pack $ comment
layoutIndentRestorePostComment -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
BDNonBottomSpacing bd -> layoutBriDocM bd BDNonBottomSpacing bd -> layoutBriDocM bd
BDProhibitMTEL bd -> do BDProhibitMTEL bd -> do
-- set flag to True for this child, but disable afterwards. -- set flag to True for this child, but disable afterwards.
@ -1279,7 +1277,8 @@ layoutBriDocM = \case
ColInfo ind _ list -> do ColInfo ind _ list -> do
curX <- do curX <- do
state <- mGet 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 -- tellDebugMess $ show curX
let Just cols = IntMapS.lookup ind m let Just cols = IntMapS.lookup ind m
let (maxX, posXs) = (mapAccumL (\acc x -> (acc+x,acc)) curX cols) let (maxX, posXs) = (mapAccumL (\acc x -> (acc+x,acc)) curX cols)

361
src/Language/Haskell/Brittany/LayoutBasics.hs
View File

@ -2,6 +2,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeApplications #-}
#if !INSERTTRACES #if !INSERTTRACES
{-# OPTIONS_GHC -Wno-redundant-constraints #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-}
#endif #endif
@ -12,14 +13,12 @@ module Language.Haskell.Brittany.LayoutBasics
, lrdrNameToText , lrdrNameToText
, lrdrNameToTextAnn , lrdrNameToTextAnn
, askIndent , askIndent
, getCurRemaining
, layoutWriteAppend , layoutWriteAppend
, layoutWriteAppendMultiline , layoutWriteAppendMultiline
, layoutWriteNewlineBlock , layoutWriteNewlineBlock
, layoutWriteNewline , layoutWriteNewline
, layoutWriteEnsureNewlineBlock , layoutWriteEnsureNewlineBlock
, layoutWriteEnsureBlock , layoutWriteEnsureBlock
, layoutWriteEnsureBlockPlusN
, layoutWithAddBaseCol , layoutWithAddBaseCol
, layoutWithAddBaseColBlock , layoutWithAddBaseColBlock
, layoutWithAddBaseColN , layoutWithAddBaseColN
@ -28,18 +27,15 @@ module Language.Haskell.Brittany.LayoutBasics
, layoutSetIndentLevel , layoutSetIndentLevel
, layoutWriteEnsureAbsoluteN , layoutWriteEnsureAbsoluteN
, layoutAddSepSpace , layoutAddSepSpace
, layoutMoveToIndentCol
, layoutSetCommentCol , layoutSetCommentCol
, layoutMoveToCommentPos
, layoutIndentRestorePostComment
, moveToExactAnn , moveToExactAnn
, layoutWritePriorComments , layoutWritePriorComments
, layoutWritePostComments , layoutWritePostComments
, layoutIndentRestorePostComment
, layoutWritePriorCommentsRestore
, layoutWritePostCommentsRestore
, layoutRemoveIndentLevelLinger , layoutRemoveIndentLevelLinger
, extractCommentsPrior , extractCommentsPrior
, extractCommentsPost , extractCommentsPost
, fixMoveToLineByIsNewline
, filterAnns , filterAnns
, ppmMoveToExactLoc , ppmMoveToExactLoc
, docEmpty , docEmpty
@ -118,6 +114,17 @@ import qualified Text.PrettyPrint as PP
import Data.Function ( fix ) 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 processDefault :: (ExactPrint.Annotate.Annotate ast, MonadMultiWriter
Text.Builder.Builder m, Text.Builder.Builder m,
@ -189,15 +196,6 @@ lrdrNameToTextAnn ast@(L _ n) = do
askIndent :: (MonadMultiReader Config m) => m Int askIndent :: (MonadMultiReader Config m) => m Int
askIndent = runIdentity . _lconfig_indentAmount . _conf_layout <$> mAsk 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 layoutWriteAppend :: (MonadMultiWriter
Text.Builder.Builder m, Text.Builder.Builder m,
MonadMultiState LayoutState m MonadMultiState LayoutState m
@ -205,28 +203,33 @@ layoutWriteAppend :: (MonadMultiWriter
=> Text => Text
-> m () -> m ()
layoutWriteAppend t = do layoutWriteAppend t = do
#if INSERTTRACES traceLocal ("layoutWriteAppend", t)
tellDebugMessShow ("layoutWriteAppend", t)
#endif
state <- mGet state <- mGet
case _lstate_addSepSpace state of case _lstate_curYOrAddNewline state of
Just i -> do Right i -> do
#if INSERTTRACES #if INSERTTRACES
tellDebugMessShow (" inserted spaces: ", i) tellDebugMessShow (" inserted newlines: ", i)
#endif #endif
mSet $ state { _lstate_curY = _lstate_curY state + Text.length t + i replicateM_ i $ mTell $ Text.Builder.fromString $ "\n"
Left{} -> do
#if INSERTTRACES
tellDebugMessShow (" inserted no newlines")
#endif
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 , _lstate_addSepSpace = Nothing
, _lstate_isNewline = NewLineStateNo
} }
mTell $ Text.Builder.fromText $ Text.pack (replicate i ' ') <> t
Nothing -> do
#if INSERTTRACES
tellDebugMessShow (" inserted no spaces")
#endif
mSet $ state { _lstate_curY = _lstate_curY state + Text.length t
, _lstate_isNewline = NewLineStateNo
}
mTell $ Text.Builder.fromText t
layoutWriteAppendSpaces :: (MonadMultiWriter layoutWriteAppendSpaces :: (MonadMultiWriter
Text.Builder.Builder m, Text.Builder.Builder m,
@ -235,9 +238,7 @@ layoutWriteAppendSpaces :: (MonadMultiWriter
=> Int => Int
-> m () -> m ()
layoutWriteAppendSpaces i = do layoutWriteAppendSpaces i = do
#if INSERTTRACES traceLocal ("layoutWriteAppendSpaces", i)
tellDebugMessShow ("layoutWriteAppendSpaces", i)
#endif
unless (i==0) $ do unless (i==0) $ do
state <- mGet state <- mGet
mSet $ state { _lstate_addSepSpace = Just mSet $ state { _lstate_addSepSpace = Just
@ -252,9 +253,7 @@ layoutWriteAppendMultiline :: (MonadMultiWriter
=> Text => Text
-> m () -> m ()
layoutWriteAppendMultiline t = do layoutWriteAppendMultiline t = do
#if INSERTTRACES traceLocal ("layoutWriteAppendMultiline", t)
tellDebugMessShow ("layoutWriteAppendMultiline", t)
#endif
case Text.lines t of case Text.lines t of
[] -> [] ->
layoutWriteAppend t -- need to write empty, too. layoutWriteAppend t -- need to write empty, too.
@ -271,29 +270,73 @@ layoutWriteNewlineBlock :: (MonadMultiWriter
, MonadMultiWriter (Seq String) m) , MonadMultiWriter (Seq String) m)
=> m () => m ()
layoutWriteNewlineBlock = do layoutWriteNewlineBlock = do
#if INSERTTRACES traceLocal ("layoutWriteNewlineBlock")
tellDebugMessShow ("layoutWriteNewlineBlock")
#endif
state <- mGet state <- mGet
mSet $ state { _lstate_curY = 0 -- _lstate_baseY state mSet $ state { _lstate_curYOrAddNewline = Right 1
, _lstate_addSepSpace = Just $ _lstate_baseY state , _lstate_addSepSpace = Just $ _lstate_baseY state
, _lstate_inhibitMTEL = False , _lstate_inhibitMTEL = False
, _lstate_isNewline = NewLineStateYes
} }
mTell $ Text.Builder.fromString $ "\n" -- ++ replicate (_lstate_baseY state) ' '
layoutMoveToIndentCol :: ( MonadMultiState LayoutState m -- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m) => Int -> m () -- , MonadMultiWriter (Seq String) m) => Int -> m ()
layoutMoveToIndentCol i = do -- layoutMoveToIndentCol i = do
#if INSERTTRACES -- #if INSERTTRACES
tellDebugMessShow ("layoutMoveToIndentCol", i) -- tellDebugMessShow ("layoutMoveToIndentCol", i)
#endif -- #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 state <- mGet
mSet $ state let col = case _lstate_curYOrAddNewline state of
{ _lstate_addSepSpace = Just Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
$ if _lstate_isNewline state == NewLineStateNo Right{} -> _lstate_baseY state
then i traceLocal ("layoutSetCommentCol", col)
else _lstate_indLevelLinger state + i - _lstate_curY state 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. -- | does _not_ add spaces to again reach the current base column.
@ -303,16 +346,14 @@ layoutWriteNewline :: (MonadMultiWriter
, MonadMultiWriter (Seq String) m) , MonadMultiWriter (Seq String) m)
=> m () => m ()
layoutWriteNewline = do layoutWriteNewline = do
#if INSERTTRACES traceLocal ("layoutWriteNewline")
tellDebugMessShow ("layoutWriteNewline")
#endif
state <- mGet 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_addSepSpace = Nothing
, _lstate_inhibitMTEL = False , _lstate_inhibitMTEL = False
, _lstate_isNewline = NewLineStateYes
} }
mTell $ Text.Builder.fromString $ "\n"
layoutWriteEnsureNewlineBlock :: (MonadMultiWriter layoutWriteEnsureNewlineBlock :: (MonadMultiWriter
Text.Builder.Builder m, Text.Builder.Builder m,
@ -320,14 +361,15 @@ layoutWriteEnsureNewlineBlock :: (MonadMultiWriter
, MonadMultiWriter (Seq String) m) , MonadMultiWriter (Seq String) m)
=> m () => m ()
layoutWriteEnsureNewlineBlock = do layoutWriteEnsureNewlineBlock = do
#if INSERTTRACES traceLocal ("layoutWriteEnsureNewlineBlock")
tellDebugMessShow ("layoutWriteEnsureNewlineBlock")
#endif
state <- mGet state <- mGet
mSet $ state { _lstate_addSepSpace = Just $ _lstate_baseY state } mSet $ state
when (_lstate_isNewline state == NewLineStateNo) $ do { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
layoutWriteNewlineBlock Left{} -> Right 1
Right i -> Right $ max 1 i
, _lstate_addSepSpace = Just $ _lstate_baseY state
, _lstate_inhibitMTEL = False
}
layoutWriteEnsureBlock :: (MonadMultiWriter layoutWriteEnsureBlock :: (MonadMultiWriter
Text.Builder.Builder m, Text.Builder.Builder m,
@ -335,19 +377,17 @@ layoutWriteEnsureBlock :: (MonadMultiWriter
, MonadMultiWriter (Seq String) m) , MonadMultiWriter (Seq String) m)
=> m () => m ()
layoutWriteEnsureBlock = do layoutWriteEnsureBlock = do
#if INSERTTRACES traceLocal ("layoutWriteEnsureBlock")
tellDebugMessShow ("layoutWriteEnsureBlock")
#endif
state <- mGet state <- mGet
let diff = case _lstate_addSepSpace state of let
Nothing -> _lstate_curY state - _lstate_baseY state diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of
Just sp -> _lstate_baseY state - sp - _lstate_curY state (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) $ layoutWriteNewlineBlock
when (diff>0) $ do when (diff > 0) $ do
mSet $ state { _lstate_addSepSpace = Just mSet $ state { _lstate_addSepSpace = Just $ diff }
$ _lstate_baseY state
- _lstate_curY state
}
layoutWriteEnsureAbsoluteN :: (MonadMultiWriter layoutWriteEnsureAbsoluteN :: (MonadMultiWriter
Text.Builder.Builder m, Text.Builder.Builder m,
@ -355,11 +395,11 @@ layoutWriteEnsureAbsoluteN :: (MonadMultiWriter
, MonadMultiWriter (Seq String) m) , MonadMultiWriter (Seq String) m)
=> Int -> m () => Int -> m ()
layoutWriteEnsureAbsoluteN n = do layoutWriteEnsureAbsoluteN n = do
#if INSERTTRACES
tellDebugMessShow ("layoutWriteEnsureAbsoluteN", n)
#endif
state <- mGet 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 when (diff>0) $ do
mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to
-- at least (Just 1), so we won't -- at least (Just 1), so we won't
@ -367,31 +407,11 @@ layoutWriteEnsureAbsoluteN n = do
-- bad way. -- 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 layoutSetBaseColInternal :: ( MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m , MonadMultiWriter (Seq String) m
) => Int -> m () ) => Int -> m ()
layoutSetBaseColInternal i = do layoutSetBaseColInternal i = do
#if INSERTTRACES traceLocal ("layoutSetBaseColInternal", i)
tellDebugMessShow ("layoutSetBaseColInternal", i)
#endif
mModify $ \s -> s { _lstate_baseY = i } mModify $ \s -> s { _lstate_baseY = i }
layoutSetIndentLevelInternal :: ( MonadMultiState LayoutState m layoutSetIndentLevelInternal :: ( MonadMultiState LayoutState m
@ -458,9 +478,7 @@ layoutWithAddBaseColNBlock :: (MonadMultiWriter
-> m () -> m ()
-> m () -> m ()
layoutWithAddBaseColNBlock amount m = do layoutWithAddBaseColNBlock amount m = do
#if INSERTTRACES traceLocal ("layoutWithAddBaseColNBlock", amount)
tellDebugMessShow ("layoutWithAddBaseColNBlock", amount)
#endif
state <- mGet state <- mGet
layoutSetBaseColInternal $ _lstate_baseY state + amount layoutSetBaseColInternal $ _lstate_baseY state + amount
layoutWriteEnsureBlock layoutWriteEnsureBlock
@ -492,9 +510,10 @@ layoutSetBaseColCur m = do
tellDebugMessShow ("layoutSetBaseColCur") tellDebugMessShow ("layoutSetBaseColCur")
#endif #endif
state <- mGet state <- mGet
layoutSetBaseColInternal $ case _lstate_addSepSpace state of case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
Nothing -> _lstate_curY state (Left i, Just j) -> layoutSetBaseColInternal (i+j)
Just i -> _lstate_curY state + i (Left i, Nothing) -> layoutSetBaseColInternal i
(Right{}, _) -> return ()
m m
layoutSetBaseColInternal $ _lstate_baseY state layoutSetBaseColInternal $ _lstate_baseY state
@ -507,7 +526,11 @@ layoutSetIndentLevel m = do
tellDebugMessShow ("layoutSetIndentLevel") tellDebugMessShow ("layoutSetIndentLevel")
#endif #endif
state <- mGet 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 m
layoutSetIndentLevelInternal $ _lstate_indLevel state layoutSetIndentLevelInternal $ _lstate_indLevel state
-- why are comment indentations relative to the previous indentation on -- 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 -- TODO: when refactoring is complete, the other version of this method
-- can probably be removed. -- can probably be removed.
moveToExactAnn :: (MonadMultiWriter Text.Builder.Builder m, moveToExactAnn
MonadMultiState LayoutState m, :: ( MonadMultiWriter Text.Builder.Builder m
MonadMultiReader (Map AnnKey Annotation) m , MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m) => AnnKey -> m () , MonadMultiReader (Map AnnKey Annotation) m
, MonadMultiWriter (Seq String) m
)
=> AnnKey
-> m ()
moveToExactAnn annKey = do moveToExactAnn annKey = do
#if INSERTTRACES traceLocal ("moveToExactAnn", annKey)
tellDebugMessShow ("moveToExactAnn'", annKey)
#endif
anns <- mAsk anns <- mAsk
case Map.lookup annKey anns of case Map.lookup annKey anns of
Nothing -> return () Nothing -> return ()
Just ann -> do Just ann -> do
-- curY <- mGet <&> _lstate_curY -- curY <- mGet <&> _lstate_curY
let ExactPrint.Types.DP (x, _y) = ExactPrint.Types.annEntryDelta ann let ExactPrint.Types.DP (y, _x) = ExactPrint.Types.annEntryDelta ann
fixedX <- fixMoveToLineByIsNewline x -- mModify $ \state -> state { _lstate_addNewline = Just x }
replicateM_ fixedX $ layoutWriteNewlineBlock mModify $ \state ->
let upd = case _lstate_curYOrAddNewline state of
fixMoveToLineByIsNewline :: MonadMultiState Left i -> if y==0 then Left i else Right y
LayoutState m => Int -> m Int Right i -> Right $ max y i
fixMoveToLineByIsNewline x = do in state
newLineState <- mGet <&> _lstate_isNewline { _lstate_curYOrAddNewline = upd
return $ if newLineState == NewLineStateYes , _lstate_addSepSpace = if Data.Either.isRight upd
then x-1 then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just (_lstate_baseY state)
else x 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 ppmMoveToExactLoc :: MonadMultiWriter Text.Builder.Builder m
=> ExactPrint.Types.DeltaPos => ExactPrint.Types.DeltaPos
@ -560,18 +594,6 @@ ppmMoveToExactLoc (ExactPrint.Types.DP (x,y)) = do
replicateM_ x $ mTell $ Text.Builder.fromString "\n" replicateM_ x $ mTell $ Text.Builder.fromString "\n"
replicateM_ y $ mTell $ Text.Builder.fromString " " 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, layoutWritePriorComments :: (Data.Data.Data ast,
MonadMultiWriter Text.Builder.Builder m, MonadMultiWriter Text.Builder.Builder m,
MonadMultiState LayoutState m MonadMultiState LayoutState m
@ -591,9 +613,7 @@ layoutWritePriorComments ast = do
case mAnn of case mAnn of
Nothing -> return () Nothing -> return ()
Just priors -> do Just priors -> do
when (not $ null priors) $ do when (not $ null priors) $ layoutSetCommentCol
state <- mGet
mSet $ state { _lstate_commentCol = Just $ _lstate_curY state }
priors `forM_` \( ExactPrint.Types.Comment comment _ _ priors `forM_` \( ExactPrint.Types.Comment comment _ _
, ExactPrint.Types.DP (x, y) , ExactPrint.Types.DP (x, y)
) -> do ) -> do
@ -623,9 +643,7 @@ layoutWritePostComments ast = do
case mAnn of case mAnn of
Nothing -> return () Nothing -> return ()
Just posts -> do Just posts -> do
when (not $ null posts) $ do when (not $ null posts) $ layoutSetCommentCol
state <- mGet
mSet $ state { _lstate_commentCol = Just $ _lstate_curY state }
posts `forM_` \( ExactPrint.Types.Comment comment _ _ posts `forM_` \( ExactPrint.Types.Comment comment _ _
, ExactPrint.Types.DP (x, y) , ExactPrint.Types.DP (x, y)
) -> do ) -> do
@ -633,42 +651,43 @@ layoutWritePostComments ast = do
layoutWriteAppend $ Text.pack $ replicate y ' ' layoutWriteAppend $ Text.pack $ replicate y ' '
layoutWriteAppendMultiline $ Text.pack $ comment layoutWriteAppendMultiline $ Text.pack $ comment
layoutIndentRestorePostComment :: ( Monad m layoutIndentRestorePostComment
:: ( Monad m
, MonadMultiState LayoutState m , MonadMultiState LayoutState m
, MonadMultiWriter Text.Builder.Builder m , MonadMultiWriter Text.Builder.Builder m
, MonadMultiWriter (Seq String) m , MonadMultiWriter (Seq String) m
) )
=> m () => m ()
layoutIndentRestorePostComment = do layoutIndentRestorePostComment = do
isNotNewline <- mGet <&> _lstate_isNewline .> (==NewLineStateNo)
mCommentCol <- _lstate_commentCol <$> mGet mCommentCol <- _lstate_commentCol <$> mGet
eCurYAddNL <- _lstate_curYOrAddNewline <$> mGet
#if INSERTTRACES #if INSERTTRACES
tellDebugMessShow ("layoutIndentRestorePostComment", mCommentCol) tellDebugMessShow ("layoutIndentRestorePostComment", mCommentCol)
#endif #endif
mModify $ \s -> s { _lstate_commentCol = Nothing } mModify $ \s -> s { _lstate_commentCol = Nothing }
case mCommentCol of case (mCommentCol, eCurYAddNL) of
Just commentCol | isNotNewline -> do (Just commentCol, Left{}) -> do
layoutWriteNewline layoutWriteEnsureNewlineBlock
layoutWriteAppendSpaces commentCol layoutWriteEnsureAbsoluteN commentCol
_ -> return () _ -> return ()
layoutWritePriorCommentsRestore :: (Data.Data.Data ast, -- layoutWritePriorCommentsRestore :: (Data.Data.Data ast,
MonadMultiWriter Text.Builder.Builder m, -- MonadMultiWriter Text.Builder.Builder m,
MonadMultiState LayoutState m -- MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m) -- , MonadMultiWriter (Seq String) m)
=> GenLocated SrcSpan ast -> m () -- => GenLocated SrcSpan ast -> m ()
layoutWritePriorCommentsRestore x = do -- layoutWritePriorCommentsRestore x = do
layoutWritePriorComments x -- layoutWritePriorComments x
layoutIndentRestorePostComment -- layoutIndentRestorePostComment
--
layoutWritePostCommentsRestore :: (Data.Data.Data ast, -- layoutWritePostCommentsRestore :: (Data.Data.Data ast,
MonadMultiWriter Text.Builder.Builder m, -- MonadMultiWriter Text.Builder.Builder m,
MonadMultiState LayoutState m -- MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m) -- , MonadMultiWriter (Seq String) m)
=> GenLocated SrcSpan ast -> m () -- => GenLocated SrcSpan ast -> m ()
layoutWritePostCommentsRestore x = do -- layoutWritePostCommentsRestore x = do
layoutWritePostComments x -- layoutWritePostComments x
layoutIndentRestorePostComment -- layoutIndentRestorePostComment
extractCommentsPrior :: ExactPrint.Types.Anns -> PriorMap extractCommentsPrior :: ExactPrint.Types.Anns -> PriorMap
extractCommentsPrior anns = flip Map.mapMaybe anns $ \ann -> extractCommentsPrior anns = flip Map.mapMaybe anns $ \ann ->

6
src/Language/Haskell/Brittany/Layouters/Decl.hs
View File

@ -43,8 +43,8 @@ layoutSig lsig@(L _loc sig) = docWrapNode lsig $ case sig of
typeDoc <- docSharedWrapper layoutType typ typeDoc <- docSharedWrapper layoutType typ
docAlt docAlt
[ docSeq [ docSeq
[ docPostComment lsig $ docLit nameStr [ appSep $ docPostComment lsig $ docLit nameStr
, docLit $ Text.pack " :: " , appSep $ docLit $ Text.pack "::"
, docForceSingleline typeDoc , docForceSingleline typeDoc
] ]
, docAddBaseY BrIndentRegular , docAddBaseY BrIndentRegular
@ -65,7 +65,7 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
patDoc <- docSharedWrapper layoutPat lPat patDoc <- docSharedWrapper layoutPat lPat
expDoc <- docSharedWrapper layoutExpr expr expDoc <- docSharedWrapper layoutExpr expr
docCols ColBindStmt docCols ColBindStmt
[patDoc, docSeq [docLit $ Text.pack " <- ", expDoc]] [appSep patDoc, docSeq [appSep $ docLit $ Text.pack "<-", expDoc]]
_ -> briDocByExact lgstmt -- TODO _ -> briDocByExact lgstmt -- TODO
layoutBind :: ToBriDocC (HsBindLR RdrName RdrName) (Either [BriDocNumbered] BriDocNumbered) layoutBind :: ToBriDocC (HsBindLR RdrName RdrName) (Either [BriDocNumbered] BriDocNumbered)

2
src/Language/Haskell/Brittany/Layouters/Expr.hs
View File

@ -73,7 +73,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches
docAddBaseY BrIndentRegular $ docPar docAddBaseY BrIndentRegular $ docPar
(docLit $ Text.pack "\\case") (docLit $ Text.pack "\\case")
(docLines $ return <$> funcPatDocs) (docSetIndentLevel $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs)
HsApp exp1@(L _ HsApp{}) exp2 -> do HsApp exp1@(L _ HsApp{}) exp2 -> do
let gather :: [LHsExpr RdrName] -> LHsExpr RdrName -> (LHsExpr RdrName, [LHsExpr RdrName]) let gather :: [LHsExpr RdrName] -> LHsExpr RdrName -> (LHsExpr RdrName, [LHsExpr RdrName])
gather list = \case gather list = \case

46
src/Language/Haskell/Brittany/Types.hs
View File

@ -37,7 +37,11 @@ type PostMap = Map AnnKey [(Comment, DeltaPos)]
data LayoutState = LayoutState data LayoutState = LayoutState
{ _lstate_baseY :: Int -- ^ number of current indentation columns { _lstate_baseY :: Int -- ^ number of current indentation columns
-- (not number of indentations). -- (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 , _lstate_indLevel :: Int -- ^ current indentation level. set for
-- any layout-affected elements such as -- any layout-affected elements such as
-- let/do/case/where elements. -- let/do/case/where elements.
@ -54,7 +58,12 @@ data LayoutState = LayoutState
-- really _should_ be included in the -- really _should_ be included in the
-- output. -- output.
, _lstate_commentsPost :: PostMap -- similarly, for post-node comments. , _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 , _lstate_addSepSpace :: Maybe Int -- number of spaces to insert if anyone
-- writes (any non-spaces) in the -- writes (any non-spaces) in the
-- current line. -- current line.
@ -66,18 +75,31 @@ data LayoutState = LayoutState
-- While this flag is on, this behaviour will be disabled. -- While this flag is on, this behaviour will be disabled.
-- The flag is automatically turned off when inserting any kind of -- The flag is automatically turned off when inserting any kind of
-- newline. -- newline.
, _lstate_isNewline :: NewLineState -- , _lstate_isNewline :: NewLineState
-- captures if the layouter currently is in a new line, i.e. if the -- -- captures if the layouter currently is in a new line, i.e. if the
-- current line only contains (indentation) spaces. -- -- current line only contains (indentation) spaces.
} }
data NewLineState = NewLineStateInit -- initial state. we do not know if in a -- evil, incomplete Show instance; only for debugging.
-- newline, really. by special-casing instance Show LayoutState where
-- this we can appropriately handle it show state =
-- differently at use-site. "LayoutState"
| NewLineStateYes ++ "{baseY=" ++ show (_lstate_baseY state)
| NewLineStateNo ++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state)
deriving Eq ++ ",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 -- data LayoutSettings = LayoutSettings
-- { _lsettings_cols :: Int -- the thing that has default 80. -- { _lsettings_cols :: Int -- the thing that has default 80.

2
src/Language/Haskell/Brittany/Utils.hs
View File

@ -207,7 +207,7 @@ tellDebugMess :: MonadMultiWriter
(Seq String) m => String -> m () (Seq String) m => String -> m ()
tellDebugMess s = mTell $ Seq.singleton s tellDebugMess s = mTell $ Seq.singleton s
tellDebugMessShow :: (MonadMultiWriter tellDebugMessShow :: forall a m . (MonadMultiWriter
(Seq String) m, Show a) => a -> m () (Seq String) m, Show a) => a -> m ()
tellDebugMessShow = tellDebugMess . show tellDebugMessShow = tellDebugMess . show