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

Make cols work around SetBaseY/SetIndentLevel

pull/1/head
Lennart Spitzner 2016-08-04 15:10:44 +02:00
parent 982e19b8b9
commit a82d38fa70
3 changed files with 221 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -101,12 +101,12 @@ layoutBriDoc ast briDoc = do
let filteredAnns = filterAnns ast anns let filteredAnns = filterAnns ast anns
let state = LayoutState let state = LayoutState
{ _lstate_baseY = 0 { _lstate_baseYs = [0]
, _lstate_curYOrAddNewline = Right 0 -- important that we use left here , _lstate_curYOrAddNewline = Right 0 -- important that we use left here
-- because moveToAnn stuff of the -- because moveToAnn stuff of the
-- first node needs to do its -- first node needs to do its
-- thing properly. -- thing properly.
, _lstate_indLevel = 0 , _lstate_indLevels = [0]
, _lstate_indLevelLinger = 0 , _lstate_indLevelLinger = 0
, _lstate_commentsPrior = extractCommentsPrior filteredAnns , _lstate_commentsPrior = extractCommentsPrior filteredAnns
, _lstate_commentsPost = extractCommentsPost filteredAnns , _lstate_commentsPost = extractCommentsPost filteredAnns
@ -250,15 +250,21 @@ transformAlts briDoc
BrIndentNone -> r BrIndentNone -> r
BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r
BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r
BDFSetBaseY bd -> do BDFBaseYPushCur bd -> do
acp <- mGet acp <- mGet
mSet $ acp { _acp_indent = _acp_line acp } mSet $ acp { _acp_indent = _acp_line acp }
r <- rec bd r <- rec bd
return $ reWrap $ BDFBaseYPushCur r
BDFBaseYPop bd -> do
acp <- mGet
r <- rec bd
acp' <- mGet acp' <- mGet
mSet $ acp' { _acp_indent = _acp_indent acp } mSet $ acp' { _acp_indent = _acp_indentPrep acp }
return $ reWrap $ BDFSetBaseY r return $ reWrap $ BDFBaseYPop r
BDFSetIndentLevel bd -> do BDFIndentLevelPushCur bd -> do
reWrap . BDFSetIndentLevel <$> rec bd reWrap . BDFIndentLevelPushCur <$> rec bd
BDFIndentLevelPop bd -> do
reWrap . BDFIndentLevelPop <$> rec bd
BDFPar indent sameLine indented -> do BDFPar indent sameLine indented -> do
indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity
let indAdd = case indent of let indAdd = case indent of
@ -459,7 +465,7 @@ getSpacing !bridoc = rec bridoc
) )
BrIndentSpecial j -> i + j BrIndentSpecial j -> i + j
} }
BDFSetBaseY bd -> do BDFBaseYPushCur bd -> do
mVs <- rec bd mVs <- rec bd
return $ mVs <&> \vs -> vs return $ mVs <&> \vs -> vs
-- We leave par as-is, even though it technically is not -- We leave par as-is, even though it technically is not
@ -474,7 +480,9 @@ getSpacing !bridoc = rec bridoc
VerticalSpacingParNonBottom -> 999) VerticalSpacingParNonBottom -> 999)
, _vs_paragraph = VerticalSpacingParNonBottom , _vs_paragraph = VerticalSpacingParNonBottom
} }
BDFSetIndentLevel bd -> rec bd BDFBaseYPop bd -> rec bd
BDFIndentLevelPushCur bd -> rec bd
BDFIndentLevelPop bd -> rec bd
BDFPar BrIndentNone sameLine indented -> do BDFPar BrIndentNone sameLine indented -> do
mVs <- rec sameLine mVs <- rec sameLine
indSp <- rec indented indSp <- rec indented
@ -600,7 +608,7 @@ getSpacings limit bridoc = rec bridoc
) )
BrIndentSpecial j -> i + j BrIndentSpecial j -> i + j
} }
BDFSetBaseY bd -> do BDFBaseYPushCur bd -> do
mVs <- rec bd mVs <- rec bd
return $ mVs <&> \vs -> vs return $ mVs <&> \vs -> vs
-- We leave par as-is, even though it technically is not -- We leave par as-is, even though it technically is not
@ -617,7 +625,9 @@ getSpacings limit bridoc = rec bridoc
VerticalSpacingParNone -> VerticalSpacingParNone VerticalSpacingParNone -> VerticalSpacingParNone
_ -> VerticalSpacingParNonBottom _ -> VerticalSpacingParNonBottom
} }
BDFSetIndentLevel bd -> rec bd BDFBaseYPop bd -> rec bd
BDFIndentLevelPushCur bd -> rec bd
BDFIndentLevelPop bd -> rec bd
BDFPar BrIndentNone sameLine indented -> do BDFPar BrIndentNone sameLine indented -> do
mVss <- rec sameLine mVss <- rec sameLine
indSps <- rec indented indSps <- rec indented
@ -785,6 +795,22 @@ transformSimplifyFloating = stepBO .> stepFull
BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> BDAnnotationPrior annKey1 (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x
_ -> Nothing _ -> Nothing
descendBYPush = transformDownMay $ \case
BDBaseYPushCur (BDCols sig cols) ->
Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols)
_ -> Nothing
descendBYPop = transformDownMay $ \case
BDBaseYPop (BDCols sig cols) ->
Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)])
_ -> Nothing
descendILPush = transformDownMay $ \case
BDIndentLevelPushCur (BDCols sig cols) ->
Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols)
_ -> Nothing
descendILPop = transformDownMay $ \case
BDIndentLevelPop (BDCols sig cols) ->
Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)])
_ -> Nothing
descendAddB = transformDownMay $ \case descendAddB = transformDownMay $ \case
-- AddIndent floats into Lines. -- AddIndent floats into Lines.
BDAddBaseY BrIndentNone x -> BDAddBaseY BrIndentNone x ->
@ -805,8 +831,10 @@ transformSimplifyFloating = stepBO .> stepFull
Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]
BDAddBaseY _ lit@BDLit{} -> BDAddBaseY _ lit@BDLit{} ->
Just $ lit Just $ lit
BDAddBaseY ind (BDSetBaseY x) -> BDAddBaseY ind (BDBaseYPushCur x) ->
Just $ BDSetBaseY (BDAddBaseY ind x) Just $ BDBaseYPushCur (BDAddBaseY ind x)
BDAddBaseY ind (BDBaseYPop x) ->
Just $ BDBaseYPop (BDAddBaseY ind x)
_ -> Nothing _ -> Nothing
stepBO :: BriDoc -> BriDoc stepBO :: BriDoc -> BriDoc
stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $
@ -816,6 +844,10 @@ transformSimplifyFloating = stepBO .> stepFull
x@BDAnnotationPrior{} -> descendPrior x x@BDAnnotationPrior{} -> descendPrior x
x@BDAnnotationPost{} -> descendPost x x@BDAnnotationPost{} -> descendPost x
x@BDAddBaseY{} -> descendAddB x x@BDAddBaseY{} -> descendAddB x
x@BDBaseYPushCur{} -> descendBYPush x
x@BDBaseYPop{} -> descendBYPop x
x@BDIndentLevelPushCur{} -> descendILPush x
x@BDIndentLevelPop{} -> descendILPop x
x -> x x -> x
stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $
Uniplate.rewrite $ \case Uniplate.rewrite $ \case
@ -834,8 +866,10 @@ transformSimplifyFloating = stepBO .> stepFull
Just $ BDPar (mergeIndents ind1 ind2) line indented Just $ BDPar (mergeIndents ind1 ind2) line indented
BDAddBaseY _ lit@BDLit{} -> BDAddBaseY _ lit@BDLit{} ->
Just $ lit Just $ lit
BDAddBaseY ind (BDSetBaseY x) -> BDAddBaseY ind (BDBaseYPushCur x) ->
Just $ BDSetBaseY (BDAddBaseY ind x) Just $ BDBaseYPushCur (BDAddBaseY ind x)
BDAddBaseY ind (BDBaseYPop x) ->
Just $ BDBaseYPop (BDAddBaseY ind x)
-- prior floating in -- prior floating in
BDAnnotationPrior annKey1 (BDPar ind line indented) -> BDAnnotationPrior annKey1 (BDPar ind line indented) ->
Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented
@ -991,8 +1025,10 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
BDCols{} -> Nothing BDCols{} -> Nothing
BDSeparator -> Nothing BDSeparator -> Nothing
BDAddBaseY{} -> Nothing BDAddBaseY{} -> Nothing
BDSetBaseY{} -> Nothing BDBaseYPushCur{} -> Nothing
BDSetIndentLevel{} -> Nothing BDBaseYPop{} -> Nothing
BDIndentLevelPushCur{} -> Nothing
BDIndentLevelPop{} -> Nothing
BDPar{} -> Nothing BDPar{} -> Nothing
BDAlt{} -> Nothing BDAlt{} -> Nothing
BDForceMultiline{} -> Nothing BDForceMultiline{} -> Nothing
@ -1052,8 +1088,10 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
BDCols _ bds -> sum <$> rec `mapM` bds BDCols _ bds -> sum <$> rec `mapM` bds
BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1 BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1
BDAddBaseY _ bd -> rec bd BDAddBaseY _ bd -> rec bd
BDSetBaseY bd -> rec bd BDBaseYPushCur bd -> rec bd
BDSetIndentLevel bd -> rec bd BDBaseYPop bd -> rec bd
BDIndentLevelPushCur bd -> rec bd
BDIndentLevelPop bd -> rec bd
BDPar _ line _ -> rec line BDPar _ line _ -> rec line
BDAlt{} -> error "briDocLineLength BDAlt" BDAlt{} -> error "briDocLineLength BDAlt"
BDForceMultiline bd -> rec bd BDForceMultiline bd -> rec bd
@ -1104,10 +1142,18 @@ layoutBriDocM = \case
BrIndentRegular -> layoutWithAddBaseCol BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ layoutBriDocM bd indentF $ layoutBriDocM bd
BDSetBaseY bd -> do BDBaseYPushCur bd -> do
layoutSetBaseColCur $ layoutBriDocM bd layoutBaseYPushCur
BDSetIndentLevel bd -> do layoutBriDocM bd
layoutSetIndentLevel $ layoutBriDocM bd BDBaseYPop bd -> do
layoutBriDocM bd
layoutBaseYPop
BDIndentLevelPushCur bd -> do
layoutIndentLevelPushCur
layoutBriDocM bd
BDIndentLevelPop bd -> do
layoutBriDocM bd
layoutIndentLevelPop
BDEnsureIndent indent bd -> do BDEnsureIndent indent bd -> do
let indentF = case indent of let indentF = case indent of
BrIndentNone -> id BrIndentNone -> id

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

@ -24,8 +24,10 @@ module Language.Haskell.Brittany.LayoutBasics
, layoutWithAddBaseColBlock , layoutWithAddBaseColBlock
, layoutWithAddBaseColN , layoutWithAddBaseColN
, layoutWithAddBaseColNBlock , layoutWithAddBaseColNBlock
, layoutSetBaseColCur , layoutBaseYPushCur
, layoutSetIndentLevel , layoutBaseYPop
, layoutIndentLevelPushCur
, layoutIndentLevelPop
, layoutWriteEnsureAbsoluteN , layoutWriteEnsureAbsoluteN
, layoutAddSepSpace , layoutAddSepSpace
, layoutSetCommentCol , layoutSetCommentCol
@ -283,7 +285,7 @@ layoutWriteNewlineBlock = do
traceLocal ("layoutWriteNewlineBlock") traceLocal ("layoutWriteNewlineBlock")
state <- mGet state <- mGet
mSet $ state { _lstate_curYOrAddNewline = Right 1 mSet $ state { _lstate_curYOrAddNewline = Right 1
, _lstate_addSepSpace = Just $ _lstate_baseY state , _lstate_addSepSpace = Just $ lstate_baseY state
, _lstate_inhibitMTEL = False , _lstate_inhibitMTEL = False
} }
@ -308,7 +310,7 @@ layoutSetCommentCol = do
state <- mGet state <- mGet
let col = case _lstate_curYOrAddNewline state of let col = case _lstate_curYOrAddNewline state of
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Right{} -> _lstate_baseY state Right{} -> lstate_baseY state
traceLocal ("layoutSetCommentCol", col) traceLocal ("layoutSetCommentCol", col)
unless (Data.Maybe.isJust $ _lstate_commentCol state) unless (Data.Maybe.isJust $ _lstate_commentCol state)
$ mSet state { _lstate_commentCol = Just col } $ mSet state { _lstate_commentCol = Just col }
@ -346,7 +348,7 @@ layoutMoveToCommentPos y x = do
else _lstate_indLevelLinger state + x else _lstate_indLevelLinger state + x
, _lstate_commentCol = Just $ case _lstate_curYOrAddNewline state of , _lstate_commentCol = Just $ case _lstate_curYOrAddNewline state of
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Right{} -> _lstate_baseY 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.
@ -377,7 +379,7 @@ layoutWriteEnsureNewlineBlock = do
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left{} -> Right 1 Left{} -> Right 1
Right i -> Right $ max 1 i Right i -> Right $ max 1 i
, _lstate_addSepSpace = Just $ _lstate_baseY state , _lstate_addSepSpace = Just $ lstate_baseY state
, _lstate_inhibitMTEL = False , _lstate_inhibitMTEL = False
, _lstate_commentCol = Nothing , _lstate_commentCol = Nothing
} }
@ -392,10 +394,10 @@ layoutWriteEnsureBlock = do
state <- mGet state <- mGet
let let
diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of
(Nothing, Left i) -> _lstate_baseY state - i (Nothing, Left i) -> lstate_baseY state - i
(Nothing, Right{}) -> _lstate_baseY state (Nothing, Right{}) -> lstate_baseY state
(Just sp, Left i) -> max sp (_lstate_baseY state - i) (Just sp, Left i) -> max sp (lstate_baseY state - i)
(Just sp, Right{}) -> max sp (_lstate_baseY state) (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 $ diff } mSet $ state { _lstate_addSepSpace = Just $ diff }
@ -418,22 +420,36 @@ layoutWriteEnsureAbsoluteN n = do
-- bad way. -- bad way.
} }
layoutSetBaseColInternal :: ( MonadMultiState LayoutState m layoutBaseYPushInternal
, MonadMultiWriter (Seq String) m :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m)
) => Int -> m () => Int
layoutSetBaseColInternal i = do -> m ()
traceLocal ("layoutSetBaseColInternal", i) layoutBaseYPushInternal i = do
mModify $ \s -> s { _lstate_baseY = i } traceLocal ("layoutBaseYPushInternal", i)
mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s }
layoutSetIndentLevelInternal :: ( MonadMultiState LayoutState m layoutBaseYPopInternal
, MonadMultiWriter (Seq String) m :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
) => Int -> m () layoutBaseYPopInternal = do
layoutSetIndentLevelInternal i = do traceLocal ("layoutBaseYPopInternal")
#if INSERTTRACES mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s }
tellDebugMessShow ("layoutSetIndentLevelInternal", i)
#endif layoutIndentLevelPushInternal
mModify $ \s -> s { _lstate_indLevelLinger = _lstate_indLevel s :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m)
, _lstate_indLevel = i => Int
-> m ()
layoutIndentLevelPushInternal i = do
traceLocal ("layoutIndentLevelPushInternal", i)
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
, _lstate_indLevels = i : _lstate_indLevels s
}
layoutIndentLevelPopInternal
:: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
layoutIndentLevelPopInternal = do
traceLocal ("layoutIndentLevelPopInternal")
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
, _lstate_indLevels = List.tail $ _lstate_indLevels s
} }
layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m
@ -443,7 +459,7 @@ layoutRemoveIndentLevelLinger = do
#if INSERTTRACES #if INSERTTRACES
tellDebugMessShow ("layoutRemoveIndentLevelLinger") tellDebugMessShow ("layoutRemoveIndentLevelLinger")
#endif #endif
mModify $ \s -> s { _lstate_indLevelLinger = _lstate_indLevel s mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
} }
layoutWithAddBaseCol :: (MonadMultiWriter layoutWithAddBaseCol :: (MonadMultiWriter
@ -459,15 +475,16 @@ layoutWithAddBaseCol m = do
#endif #endif
amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity
state <- mGet state <- mGet
layoutSetBaseColInternal $ _lstate_baseY state + amount layoutBaseYPushInternal $ lstate_baseY state + amount
m m
layoutSetBaseColInternal $ _lstate_baseY state layoutBaseYPopInternal
layoutWithAddBaseColBlock :: (MonadMultiWriter layoutWithAddBaseColBlock
Text.Builder.Builder m, :: ( MonadMultiWriter Text.Builder.Builder m
MonadMultiState LayoutState m , MonadMultiState LayoutState m
, MonadMultiReader Config m , MonadMultiReader Config m
, MonadMultiWriter (Seq String) m) , MonadMultiWriter (Seq String) m
)
=> m () => m ()
-> m () -> m ()
layoutWithAddBaseColBlock m = do layoutWithAddBaseColBlock m = do
@ -476,25 +493,26 @@ layoutWithAddBaseColBlock m = do
#endif #endif
amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity
state <- mGet state <- mGet
layoutSetBaseColInternal $ _lstate_baseY state + amount layoutBaseYPushInternal $ lstate_baseY state + amount
layoutWriteEnsureBlock layoutWriteEnsureBlock
m m
layoutSetBaseColInternal $ _lstate_baseY state layoutBaseYPopInternal
layoutWithAddBaseColNBlock :: (MonadMultiWriter layoutWithAddBaseColNBlock
Text.Builder.Builder m, :: ( MonadMultiWriter Text.Builder.Builder m
MonadMultiState LayoutState m , MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m) , MonadMultiWriter (Seq String) m
)
=> Int => Int
-> m () -> m ()
-> m () -> m ()
layoutWithAddBaseColNBlock amount m = do layoutWithAddBaseColNBlock amount m = do
traceLocal ("layoutWithAddBaseColNBlock", amount) traceLocal ("layoutWithAddBaseColNBlock", amount)
state <- mGet state <- mGet
layoutSetBaseColInternal $ _lstate_baseY state + amount layoutBaseYPushInternal $ lstate_baseY state + amount
layoutWriteEnsureBlock layoutWriteEnsureBlock
m m
layoutSetBaseColInternal $ _lstate_baseY state layoutBaseYPopInternal
layoutWithAddBaseColN :: (MonadMultiWriter layoutWithAddBaseColN :: (MonadMultiWriter
Text.Builder.Builder m, Text.Builder.Builder m,
@ -508,44 +526,47 @@ layoutWithAddBaseColN amount m = do
tellDebugMessShow ("layoutWithAddBaseColN", amount) tellDebugMessShow ("layoutWithAddBaseColN", amount)
#endif #endif
state <- mGet state <- mGet
layoutSetBaseColInternal $ _lstate_baseY state + amount layoutBaseYPushInternal $ lstate_baseY state + amount
m m
layoutSetBaseColInternal $ _lstate_baseY state layoutBaseYPopInternal
layoutSetBaseColCur :: (MonadMultiState layoutBaseYPushCur
LayoutState m, :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
MonadMultiWriter (Seq String) m) layoutBaseYPushCur = do
=> m () -> m () traceLocal ("layoutBaseYPushCur")
layoutSetBaseColCur m = do
#if INSERTTRACES
tellDebugMessShow ("layoutSetBaseColCur")
#endif
state <- mGet state <- mGet
case _lstate_commentCol state of case _lstate_commentCol state of
Nothing -> case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of Nothing -> case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i, Just j) -> layoutSetBaseColInternal (i+j) (Left i, Just j) -> layoutBaseYPushInternal (i+j)
(Left i, Nothing) -> layoutSetBaseColInternal i (Left i, Nothing) -> layoutBaseYPushInternal i
(Right{}, _) -> return () (Right{}, _) -> return ()
Just cCol -> layoutSetBaseColInternal cCol Just cCol -> layoutBaseYPushInternal cCol
m
layoutSetBaseColInternal $ _lstate_baseY state
layoutSetIndentLevel :: (MonadMultiState layoutBaseYPop
LayoutState m, :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
MonadMultiWriter (Seq String) m) layoutBaseYPop = do
=> m () -> m () traceLocal ("layoutBaseYPop")
layoutSetIndentLevel m = do layoutBaseYPopInternal
#if INSERTTRACES
tellDebugMessShow ("layoutSetIndentLevel") layoutIndentLevelPushCur
#endif :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
layoutIndentLevelPushCur = do
traceLocal ("layoutIndentLevelPushCur")
state <- mGet state <- mGet
layoutSetIndentLevelInternal $ case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i, Just j) -> i + j (Left i, Just j) -> i + j
(Left i, Nothing) -> i (Left i, Nothing) -> i
(Right{}, Just j) -> j (Right{}, Just j) -> j
(Right{}, Nothing) -> 0 (Right{}, Nothing) -> 0
m layoutIndentLevelPushInternal y
layoutSetIndentLevelInternal $ _lstate_indLevel state layoutBaseYPushInternal y
layoutIndentLevelPop
:: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
layoutIndentLevelPop = do
traceLocal ("layoutIndentLevelPop")
layoutBaseYPop
layoutIndentLevelPopInternal
-- why are comment indentations relative to the previous indentation on -- why are comment indentations relative to the previous indentation on
-- the first node of an additional indentation, and relative to the outer -- the first node of an additional indentation, and relative to the outer
-- indentation after the last node of some indented stuff? sure does not -- indentation after the last node of some indented stuff? sure does not
@ -588,7 +609,7 @@ moveToExactAnn annKey = do
in state in state
{ _lstate_curYOrAddNewline = upd { _lstate_curYOrAddNewline = upd
, _lstate_addSepSpace = if Data.Either.isRight upd , _lstate_addSepSpace = if Data.Either.isRight upd
then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just (_lstate_baseY state) then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just (lstate_baseY state)
else Nothing else Nothing
, _lstate_commentCol = Nothing , _lstate_commentCol = Nothing
} }
@ -884,10 +905,20 @@ docAddBaseY :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm
docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docSetBaseY bdm = allocateNode . BDFSetBaseY =<< bdm docSetBaseY bdm = do
bd <- bdm
-- the order here is important so that these two nodes can be treated
-- properly over at `transformAlts`.
n1 <- allocateNode $ BDFBaseYPushCur bd
n2 <- allocateNode $ BDFBaseYPop n1
return n2
docSetIndentLevel :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docSetIndentLevel :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docSetIndentLevel bdm = allocateNode . BDFSetIndentLevel =<< bdm docSetIndentLevel bdm = do
bd <- bdm
n1 <- allocateNode $ BDFIndentLevelPushCur bd
n2 <- allocateNode $ BDFIndentLevelPop n1
return n2
docSeparator :: ToBriDocM BriDocNumbered docSeparator :: ToBriDocM BriDocNumbered
docSeparator = allocateNode BDFSeparator docSeparator = allocateNode BDFSeparator

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

@ -35,14 +35,16 @@ type PriorMap = Map AnnKey [(Comment, DeltaPos)]
type PostMap = Map AnnKey [(Comment, DeltaPos)] type PostMap = Map AnnKey [(Comment, DeltaPos)]
data LayoutState = LayoutState data LayoutState = LayoutState
{ _lstate_baseY :: Int -- ^ number of current indentation columns { _lstate_baseYs :: [Int]
-- ^ stack of number of current indentation columns
-- (not number of indentations). -- (not number of indentations).
, _lstate_curYOrAddNewline :: Either Int Int , _lstate_curYOrAddNewline :: Either Int Int
-- ^ Either: -- ^ Either:
-- 1) number of chars in the current line. -- 1) number of chars in the current line.
-- 2) number of newlines to be inserted before inserting any -- 2) number of newlines to be inserted before inserting any
-- non-space elements. -- non-space elements.
, _lstate_indLevel :: Int -- ^ current indentation level. set for , _lstate_indLevels :: [Int]
-- ^ stack of current indentation levels. set for
-- any layout-affected elements such as -- any layout-affected elements such as
-- let/do/case/where elements. -- let/do/case/where elements.
-- The main purpose of this member is to -- The main purpose of this member is to
@ -80,13 +82,19 @@ data LayoutState = LayoutState
-- -- current line only contains (indentation) spaces. -- -- current line only contains (indentation) spaces.
} }
lstate_baseY :: LayoutState -> Int
lstate_baseY = head . _lstate_baseYs
lstate_indLevel :: LayoutState -> Int
lstate_indLevel = head . _lstate_indLevels
-- evil, incomplete Show instance; only for debugging. -- evil, incomplete Show instance; only for debugging.
instance Show LayoutState where instance Show LayoutState where
show state = show state =
"LayoutState" "LayoutState"
++ "{baseY=" ++ show (_lstate_baseY state) ++ "{baseYs=" ++ show (_lstate_baseYs state)
++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state) ++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state)
++ ",indLevel=" ++ show (_lstate_indLevel state) ++ ",indLevels=" ++ show (_lstate_indLevels state)
++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state) ++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state)
++ ",commentCol=" ++ show (_lstate_commentCol state) ++ ",commentCol=" ++ show (_lstate_commentCol state)
++ ",addSepSpace=" ++ show (_lstate_addSepSpace state) ++ ",addSepSpace=" ++ show (_lstate_addSepSpace state)
@ -194,8 +202,10 @@ data BriDoc
-- should not contains BDPars -- should not contains BDPars
| BDSeparator -- semantically, space-unless-at-end-of-line. | BDSeparator -- semantically, space-unless-at-end-of-line.
| BDAddBaseY BrIndent BriDoc | BDAddBaseY BrIndent BriDoc
| BDSetBaseY BriDoc | BDBaseYPushCur BriDoc
| BDSetIndentLevel BriDoc | BDBaseYPop BriDoc
| BDIndentLevelPushCur BriDoc
| BDIndentLevelPop BriDoc
| BDPar | BDPar
{ _bdpar_indent :: BrIndent { _bdpar_indent :: BrIndent
, _bdpar_restOfLine :: BriDoc -- should not contain other BDPars , _bdpar_restOfLine :: BriDoc -- should not contain other BDPars
@ -234,8 +244,10 @@ data BriDocF f
-- should not contains BDPars -- should not contains BDPars
| BDFSeparator -- semantically, space-unless-at-end-of-line. | BDFSeparator -- semantically, space-unless-at-end-of-line.
| BDFAddBaseY BrIndent (f (BriDocF f)) | BDFAddBaseY BrIndent (f (BriDocF f))
| BDFSetBaseY (f (BriDocF f)) | BDFBaseYPushCur (f (BriDocF f))
| BDFSetIndentLevel (f (BriDocF f)) | BDFBaseYPop (f (BriDocF f))
| BDFIndentLevelPushCur (f (BriDocF f))
| BDFIndentLevelPop (f (BriDocF f))
| BDFPar | BDFPar
{ _bdfpar_indent :: BrIndent { _bdfpar_indent :: BrIndent
, _bdfpar_restOfLine :: f (BriDocF f) -- should not contain other BDPars , _bdfpar_restOfLine :: f (BriDocF f) -- should not contain other BDPars
@ -276,8 +288,10 @@ instance Uniplate.Uniplate BriDoc where
uniplate (BDCols sig list) = plate BDCols |- sig ||* list uniplate (BDCols sig list) = plate BDCols |- sig ||* list
uniplate x@BDSeparator = plate x uniplate x@BDSeparator = plate x
uniplate (BDAddBaseY ind bd) = plate BDAddBaseY |- ind |* bd uniplate (BDAddBaseY ind bd) = plate BDAddBaseY |- ind |* bd
uniplate (BDSetBaseY bd) = plate BDSetBaseY |* bd uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd
uniplate (BDSetIndentLevel bd) = plate BDSetIndentLevel |* bd uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd
uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd
uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd
uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented
uniplate (BDAlt alts) = plate BDAlt ||* alts uniplate (BDAlt alts) = plate BDAlt ||* alts
uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd
@ -301,8 +315,10 @@ unwrapBriDocNumbered = snd .> \case
BDFCols sig list -> BDCols sig $ rec <$> list BDFCols sig list -> BDCols sig $ rec <$> list
BDFSeparator -> BDSeparator BDFSeparator -> BDSeparator
BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd
BDFSetBaseY bd -> BDSetBaseY $ rec bd BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd
BDFSetIndentLevel bd -> BDSetIndentLevel $ rec bd BDFBaseYPop bd -> BDBaseYPop $ rec bd
BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd
BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd
BDFPar ind line indented -> BDPar ind (rec line) (rec indented) BDFPar ind line indented -> BDPar ind (rec line) (rec indented)
BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen
BDFForceMultiline bd -> BDForceMultiline $ rec bd BDFForceMultiline bd -> BDForceMultiline $ rec bd
@ -326,8 +342,10 @@ briDocSeqSpine = \case
BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list
BDSeparator -> () BDSeparator -> ()
BDAddBaseY _ind bd -> briDocSeqSpine bd BDAddBaseY _ind bd -> briDocSeqSpine bd
BDSetBaseY bd -> briDocSeqSpine bd BDBaseYPushCur bd -> briDocSeqSpine bd
BDSetIndentLevel bd -> briDocSeqSpine bd BDBaseYPop bd -> briDocSeqSpine bd
BDIndentLevelPushCur bd -> briDocSeqSpine bd
BDIndentLevelPop bd -> briDocSeqSpine bd
BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented
BDAlt alts -> foldl' (\(!()) -> briDocSeqSpine) () alts BDAlt alts -> foldl' (\(!()) -> briDocSeqSpine) () alts
BDForceMultiline bd -> briDocSeqSpine bd BDForceMultiline bd -> briDocSeqSpine bd