488 lines
16 KiB
Haskell
488 lines
16 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
|
|
module Language.Haskell.Brittany.Internal.BackendUtils where
|
|
|
|
import qualified Data.Data
|
|
import qualified Data.Either
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Maybe
|
|
import qualified Data.Semigroup as Semigroup
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Lazy.Builder as Text.Builder
|
|
import GHC (Located)
|
|
import qualified GHC.OldList as List
|
|
import Language.Haskell.Brittany.Internal.Config.Types
|
|
import Language.Haskell.Brittany.Internal.Prelude
|
|
import Language.Haskell.Brittany.Internal.PreludeUtils
|
|
import Language.Haskell.Brittany.Internal.Types
|
|
import Language.Haskell.Brittany.Internal.Utils
|
|
import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)
|
|
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
|
|
|
|
|
|
|
|
traceLocal :: (MonadMultiState LayoutState m) => a -> m ()
|
|
traceLocal _ = return ()
|
|
|
|
|
|
layoutWriteAppend
|
|
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
|
|
=> Text
|
|
-> m ()
|
|
layoutWriteAppend t = do
|
|
traceLocal ("layoutWriteAppend", t)
|
|
state <- mGet
|
|
case _lstate_curYOrAddNewline state of
|
|
Right i -> do
|
|
replicateM_ i $ mTell $ Text.Builder.fromString $ "\n"
|
|
Left{} -> do
|
|
return ()
|
|
let spaces = fromMaybe 0 $ _lstate_addSepSpace state
|
|
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, MonadMultiState LayoutState m)
|
|
=> Int
|
|
-> m ()
|
|
layoutWriteAppendSpaces i = do
|
|
traceLocal ("layoutWriteAppendSpaces", i)
|
|
unless (i == 0) $ do
|
|
state <- mGet
|
|
mSet $ state
|
|
{ _lstate_addSepSpace = Just $ maybe i (+ i) $ _lstate_addSepSpace state
|
|
}
|
|
|
|
layoutWriteAppendMultiline
|
|
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
|
|
=> [Text]
|
|
-> m ()
|
|
layoutWriteAppendMultiline ts = do
|
|
traceLocal ("layoutWriteAppendMultiline", ts)
|
|
case ts of
|
|
[] -> layoutWriteAppend (Text.pack "") -- need to write empty, too.
|
|
(l : lr) -> do
|
|
layoutWriteAppend l
|
|
lr `forM_` \x -> do
|
|
layoutWriteNewline
|
|
layoutWriteAppend x
|
|
|
|
-- adds a newline and adds spaces to reach the base column.
|
|
layoutWriteNewlineBlock
|
|
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
|
|
=> m ()
|
|
layoutWriteNewlineBlock = do
|
|
traceLocal ("layoutWriteNewlineBlock")
|
|
state <- mGet
|
|
mSet $ state
|
|
{ _lstate_curYOrAddNewline = Right 1
|
|
, _lstate_addSepSpace = Just $ lstate_baseY state
|
|
}
|
|
|
|
-- 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) => m ()
|
|
layoutSetCommentCol = do
|
|
state <- mGet
|
|
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 }
|
|
|
|
-- This is also used to move to non-comments in a couple of places. Seems
|
|
-- to be harmless so far..
|
|
layoutMoveToCommentPos
|
|
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
|
|
=> Int
|
|
-> Int
|
|
-> Int
|
|
-> m ()
|
|
layoutMoveToCommentPos y x commentLines = do
|
|
traceLocal ("layoutMoveToCommentPos", y, x, commentLines)
|
|
state <- mGet
|
|
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 Data.Maybe.isJust (_lstate_commentCol state)
|
|
then case _lstate_curYOrAddNewline state of
|
|
Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x
|
|
Right{} -> _lstate_indLevelLinger state + x
|
|
else if y == 0 then x else _lstate_indLevelLinger state + x
|
|
, _lstate_commentCol = Just $ case _lstate_commentCol state of
|
|
Just existing -> existing
|
|
Nothing -> case _lstate_curYOrAddNewline state of
|
|
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
|
|
Right{} -> lstate_baseY state
|
|
, _lstate_commentNewlines =
|
|
_lstate_commentNewlines state + y + commentLines - 1
|
|
}
|
|
|
|
-- | does _not_ add spaces to again reach the current base column.
|
|
layoutWriteNewline
|
|
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
|
|
=> m ()
|
|
layoutWriteNewline = do
|
|
traceLocal ("layoutWriteNewline")
|
|
state <- mGet
|
|
mSet $ state
|
|
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
|
|
Left{} -> Right 1
|
|
Right i -> Right (i + 1)
|
|
, _lstate_addSepSpace = Nothing
|
|
}
|
|
|
|
_layoutResetCommentNewlines :: MonadMultiState LayoutState m => m ()
|
|
_layoutResetCommentNewlines = do
|
|
mModify $ \state -> state { _lstate_commentNewlines = 0 }
|
|
|
|
layoutWriteEnsureNewlineBlock
|
|
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
|
|
=> m ()
|
|
layoutWriteEnsureNewlineBlock = do
|
|
traceLocal ("layoutWriteEnsureNewlineBlock")
|
|
state <- mGet
|
|
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_commentCol = Nothing
|
|
}
|
|
|
|
layoutWriteEnsureAbsoluteN
|
|
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
|
|
=> Int
|
|
-> m ()
|
|
layoutWriteEnsureAbsoluteN n = do
|
|
state <- mGet
|
|
let
|
|
diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of
|
|
(Just c, _) -> n - c
|
|
(Nothing, Left i) -> n - i
|
|
(Nothing, 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
|
|
-- overwrite any old value in any
|
|
-- bad way.
|
|
|
|
layoutBaseYPushInternal :: (MonadMultiState LayoutState m) => Int -> m ()
|
|
layoutBaseYPushInternal i = do
|
|
traceLocal ("layoutBaseYPushInternal", i)
|
|
mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s }
|
|
|
|
layoutBaseYPopInternal :: (MonadMultiState LayoutState m) => m ()
|
|
layoutBaseYPopInternal = do
|
|
traceLocal ("layoutBaseYPopInternal")
|
|
mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s }
|
|
|
|
layoutIndentLevelPushInternal :: (MonadMultiState LayoutState m) => 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) => m ()
|
|
layoutIndentLevelPopInternal = do
|
|
traceLocal ("layoutIndentLevelPopInternal")
|
|
mModify $ \s -> s
|
|
{ _lstate_indLevelLinger = lstate_indLevel s
|
|
, _lstate_indLevels = List.tail $ _lstate_indLevels s
|
|
}
|
|
|
|
layoutRemoveIndentLevelLinger :: (MonadMultiState LayoutState m) => m ()
|
|
layoutRemoveIndentLevelLinger = do
|
|
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s }
|
|
|
|
layoutWithAddBaseCol
|
|
:: ( MonadMultiWriter Text.Builder.Builder m
|
|
, MonadMultiState LayoutState m
|
|
, MonadMultiReader Config m
|
|
)
|
|
=> m ()
|
|
-> m ()
|
|
layoutWithAddBaseCol m = do
|
|
amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
|
|
state <- mGet
|
|
layoutBaseYPushInternal $ lstate_baseY state + amount
|
|
m
|
|
layoutBaseYPopInternal
|
|
|
|
layoutWithAddBaseColBlock
|
|
:: ( MonadMultiWriter Text.Builder.Builder m
|
|
, MonadMultiState LayoutState m
|
|
, MonadMultiReader Config m
|
|
)
|
|
=> m ()
|
|
-> m ()
|
|
layoutWithAddBaseColBlock m = do
|
|
amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
|
|
state <- mGet
|
|
layoutBaseYPushInternal $ lstate_baseY state + amount
|
|
layoutWriteEnsureBlock
|
|
m
|
|
layoutBaseYPopInternal
|
|
|
|
layoutWithAddBaseColNBlock
|
|
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
|
|
=> Int
|
|
-> m ()
|
|
-> m ()
|
|
layoutWithAddBaseColNBlock amount m = do
|
|
traceLocal ("layoutWithAddBaseColNBlock", amount)
|
|
state <- mGet
|
|
layoutBaseYPushInternal $ lstate_baseY state + amount
|
|
layoutWriteEnsureBlock
|
|
m
|
|
layoutBaseYPopInternal
|
|
|
|
layoutWriteEnsureBlock
|
|
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
|
|
=> m ()
|
|
layoutWriteEnsureBlock = do
|
|
traceLocal ("layoutWriteEnsureBlock")
|
|
state <- mGet
|
|
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 $ diff }
|
|
|
|
layoutWithAddBaseColN
|
|
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
|
|
=> Int
|
|
-> m ()
|
|
-> m ()
|
|
layoutWithAddBaseColN amount m = do
|
|
state <- mGet
|
|
layoutBaseYPushInternal $ lstate_baseY state + amount
|
|
m
|
|
layoutBaseYPopInternal
|
|
|
|
layoutBaseYPushCur :: (MonadMultiState LayoutState m) => m ()
|
|
layoutBaseYPushCur = do
|
|
traceLocal ("layoutBaseYPushCur")
|
|
state <- mGet
|
|
case _lstate_commentCol state of
|
|
Nothing ->
|
|
case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
|
|
(Left i, Just j) -> layoutBaseYPushInternal (i + j)
|
|
(Left i, Nothing) -> layoutBaseYPushInternal i
|
|
(Right{}, _) -> layoutBaseYPushInternal $ lstate_baseY state
|
|
Just cCol -> layoutBaseYPushInternal cCol
|
|
|
|
layoutBaseYPop :: (MonadMultiState LayoutState m) => m ()
|
|
layoutBaseYPop = do
|
|
traceLocal ("layoutBaseYPop")
|
|
layoutBaseYPopInternal
|
|
|
|
layoutIndentLevelPushCur :: (MonadMultiState LayoutState m) => m ()
|
|
layoutIndentLevelPushCur = do
|
|
traceLocal ("layoutIndentLevelPushCur")
|
|
state <- mGet
|
|
let
|
|
y = 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
|
|
layoutIndentLevelPushInternal y
|
|
|
|
layoutIndentLevelPop :: (MonadMultiState LayoutState m) => m ()
|
|
layoutIndentLevelPop = do
|
|
traceLocal ("layoutIndentLevelPop")
|
|
layoutIndentLevelPopInternal
|
|
-- why are comment indentations relative to the previous indentation on
|
|
-- the first node of an additional indentation, and relative to the outer
|
|
-- indentation after the last node of some indented stuff? sure does not
|
|
-- make sense.
|
|
layoutRemoveIndentLevelLinger
|
|
|
|
layoutAddSepSpace :: (MonadMultiState LayoutState m) => m ()
|
|
layoutAddSepSpace = do
|
|
state <- mGet
|
|
mSet $ state
|
|
{ _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state
|
|
}
|
|
|
|
-- 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
|
|
)
|
|
=> AnnKey
|
|
-> m ()
|
|
moveToExactAnn annKey = do
|
|
traceLocal ("moveToExactAnn", annKey)
|
|
anns <- mAsk
|
|
case Map.lookup annKey anns of
|
|
Nothing -> return ()
|
|
Just ann -> do
|
|
-- curY <- mGet <&> _lstate_curY
|
|
let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann
|
|
-- mModify $ \state -> state { _lstate_addNewline = Just x }
|
|
moveToY y
|
|
|
|
moveToY :: MonadMultiState LayoutState m => Int -> m ()
|
|
moveToY y = 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.DeltaPos -> m ()
|
|
ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do
|
|
replicateM_ x $ mTell $ Text.Builder.fromString "\n"
|
|
replicateM_ y $ mTell $ Text.Builder.fromString " "
|
|
|
|
-- TODO: update and use, or clean up. Currently dead code.
|
|
layoutWritePriorComments
|
|
:: ( Data.Data.Data ast
|
|
, MonadMultiWriter Text.Builder.Builder m
|
|
, MonadMultiState LayoutState m
|
|
)
|
|
=> Located ast
|
|
-> m ()
|
|
layoutWritePriorComments ast = do
|
|
mAnn <- do
|
|
state <- mGet
|
|
let key = ExactPrint.mkAnnKey ast
|
|
let anns = _lstate_comments state
|
|
let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns
|
|
mSet $ state
|
|
{ _lstate_comments = Map.adjust
|
|
(\ann -> ann { ExactPrint.annPriorComments = [] })
|
|
key
|
|
anns
|
|
}
|
|
return mAnn
|
|
case mAnn of
|
|
Nothing -> return ()
|
|
Just priors -> do
|
|
unless (null priors) $ layoutSetCommentCol
|
|
priors `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
|
|
do
|
|
replicateM_ x layoutWriteNewline
|
|
layoutWriteAppendSpaces y
|
|
layoutWriteAppendMultiline $ Text.lines $ Text.pack comment
|
|
|
|
-- TODO: update and use, or clean up. Currently dead code.
|
|
-- this currently only extracs from the `annsDP` field of Annotations.
|
|
-- per documentation, this seems sufficient, as the
|
|
-- "..`annFollowingComments` are only added by AST transformations ..".
|
|
layoutWritePostComments
|
|
:: ( Data.Data.Data ast
|
|
, MonadMultiWriter Text.Builder.Builder m
|
|
, MonadMultiState LayoutState m
|
|
)
|
|
=> Located ast
|
|
-> m ()
|
|
layoutWritePostComments ast = do
|
|
mAnn <- do
|
|
state <- mGet
|
|
let key = ExactPrint.mkAnnKey ast
|
|
let anns = _lstate_comments state
|
|
let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns
|
|
mSet $ state
|
|
{ _lstate_comments = Map.adjust
|
|
(\ann -> ann { ExactPrint.annFollowingComments = [] })
|
|
key
|
|
anns
|
|
}
|
|
return mAnn
|
|
case mAnn of
|
|
Nothing -> return ()
|
|
Just posts -> do
|
|
unless (null posts) $ layoutSetCommentCol
|
|
posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
|
|
do
|
|
replicateM_ x layoutWriteNewline
|
|
layoutWriteAppend $ Text.pack $ replicate y ' '
|
|
mModify $ \s -> s { _lstate_addSepSpace = Nothing }
|
|
layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment
|
|
|
|
layoutIndentRestorePostComment
|
|
:: (MonadMultiState LayoutState m, MonadMultiWriter Text.Builder.Builder m)
|
|
=> m ()
|
|
layoutIndentRestorePostComment = do
|
|
state <- mGet
|
|
let mCommentCol = _lstate_commentCol state
|
|
let eCurYAddNL = _lstate_curYOrAddNewline state
|
|
mModify
|
|
$ \s -> s { _lstate_commentCol = Nothing, _lstate_commentNewlines = 0 }
|
|
case (mCommentCol, eCurYAddNL) of
|
|
(Just commentCol, Left{}) -> do
|
|
layoutWriteEnsureNewlineBlock
|
|
layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe
|
|
0
|
|
(_lstate_addSepSpace state)
|
|
_ -> return ()
|
|
|
|
-- layoutWritePriorCommentsRestore :: (Data.Data.Data ast,
|
|
-- MonadMultiWriter Text.Builder.Builder m,
|
|
-- MonadMultiState LayoutState m
|
|
-- , MonadMultiWriter (Seq String) m)
|
|
-- => Located 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)
|
|
-- => Located ast -> m ()
|
|
-- layoutWritePostCommentsRestore x = do
|
|
-- layoutWritePostComments x
|
|
-- layoutIndentRestorePostComment
|