brittany-0.8.0.2: src/Language/Haskell/Brittany/Internal/Backend.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ConstraintKinds #-}
module Language.Haskell.Brittany.Internal.Backend
( layoutBriDocM
)
where
#include "prelude.inc"
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation )
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.BackendUtils
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types
import qualified Data.Text.Lazy.Builder as Text.Builder
import Data.HList.ContainsType
import Control.Monad.Extra ( whenM )
import qualified Control.Monad.Trans.Writer.Strict as WriterS
type ColIndex = Int
data ColumnSpacing
= ColumnSpacingLeaf Int
| ColumnSpacingRef Int Int
type ColumnBlock a = [a]
type ColumnBlocks a = Seq [a]
type ColMap1 = IntMapL.IntMap {- ColIndex -} (Bool, ColumnBlocks ColumnSpacing)
type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int)
-- (ratio of hasSpace, maximum, raw)
data ColInfo
= ColInfoStart -- start value to begin the mapAccumL.
| ColInfoNo BriDoc
| ColInfo ColIndex ColSig [(Int, ColInfo)]
instance Show ColInfo where
show ColInfoStart = "ColInfoStart"
show ColInfoNo{} = "ColInfoNo{}"
show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list
data ColBuildState = ColBuildState
{ _cbs_map :: ColMap1
, _cbs_index :: ColIndex
}
type LayoutConstraints m = ( MonadMultiReader Config m
, MonadMultiReader ExactPrint.Types.Anns m
, MonadMultiWriter Text.Builder.Builder m
, MonadMultiWriter (Seq String) m
, MonadMultiState LayoutState m
)
layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m ()
layoutBriDocM = \case
BDEmpty -> do
return () -- can it be that simple
BDLit t -> do
layoutIndentRestorePostComment
layoutRemoveIndentLevelLinger
layoutWriteAppend t
BDSeq list -> do
list `forM_` layoutBriDocM
-- in this situation, there is nothing to do about cols.
-- i think this one does not happen anymore with the current simplifications.
-- BDCols cSig list | BDPar sameLine lines <- List.last list ->
-- alignColsPar $ BDCols cSig (List.init list ++ [sameLine]) : lines
BDCols _ list -> do
list `forM_` layoutBriDocM
BDSeparator -> do
layoutAddSepSpace
BDAddBaseY indent bd -> do
let indentF = case indent of
BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ layoutBriDocM bd
BDBaseYPushCur bd -> do
layoutBaseYPushCur
layoutBriDocM bd
BDBaseYPop bd -> do
layoutBriDocM bd
layoutBaseYPop
BDIndentLevelPushCur bd -> do
layoutIndentLevelPushCur
layoutBriDocM bd
BDIndentLevelPop bd -> do
layoutBriDocM bd
layoutIndentLevelPop
BDEnsureIndent indent bd -> do
let indentF = case indent of
BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ do
layoutWriteEnsureBlock
layoutBriDocM bd
BDPar indent sameLine indented -> do
layoutBriDocM sameLine
let indentF = case indent of
BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ do
layoutWriteNewlineBlock
layoutBriDocM indented
BDLines lines -> alignColsLines lines
BDAlt [] -> error "empty BDAlt"
BDAlt (alt:_) -> layoutBriDocM alt
BDForceMultiline bd -> layoutBriDocM bd
BDForceSingleline bd -> layoutBriDocM bd
BDForwardLineMode bd -> layoutBriDocM bd
BDExternal annKey subKeys shouldAddComment t -> do
let tlines = Text.lines $ t <> Text.pack "\n"
tlineCount = length tlines
anns :: ExactPrint.Anns <- mAsk
when shouldAddComment $ do
layoutWriteAppend
$ Text.pack
$ "{-"
++ show (annKey, Map.lookup annKey anns)
++ "-}"
zip [1 ..] tlines `forM_` \(i, l) -> do
layoutWriteAppend $ l
unless (i == tlineCount) layoutWriteNewlineBlock
do
state <- mGet
let filterF k _ = not $ k `Set.member` subKeys
mSet $ state
{ _lstate_comments = Map.filterWithKey filterF $ _lstate_comments state
}
BDAnnotationPrior annKey bd -> do
state <- mGet
let m = _lstate_comments state
let allowMTEL = not (_lstate_inhibitMTEL state)
&& Data.Either.isRight (_lstate_curYOrAddNewline state)
mAnn <- do
let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m
mSet $ state
{ _lstate_comments = Map.adjust
(\ann -> ann { ExactPrint.annPriorComments = [] })
annKey
m
}
return mAnn
case mAnn of
Nothing -> when allowMTEL $ moveToExactAnn annKey
Just [] -> when allowMTEL $ moveToExactAnn annKey
Just priors -> do
-- layoutResetSepSpace
priors
`forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
do
-- evil hack for CPP:
case comment of
('#':_) -> layoutMoveToCommentPos y (-999)
_ -> 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
layoutBriDocM bd
BDAnnotationKW annKey keyword bd -> do
layoutBriDocM bd
mAnn <- do
state <- mGet
let m = _lstate_comments state
let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
let mToSpan = case mAnn of
Just anns | keyword == Nothing -> Just anns
Just ((ExactPrint.Types.G kw1, _):annR) | keyword == Just kw1 -> Just
annR
_ -> Nothing
case mToSpan of
Just anns -> do
let (comments, rest) = flip spanMaybe anns $ \case
(ExactPrint.Types.AnnComment x, dp) -> Just (x, dp)
_ -> Nothing
mSet $ state
{ _lstate_comments = Map.adjust
(\ann -> ann { ExactPrint.annsDP = rest })
annKey
m
}
return $ [ comments | not $ null comments ]
_ -> return Nothing
forM_ mAnn
$ mapM_
$ \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
do
-- evil hack for CPP:
case comment of
('#':_) -> layoutMoveToCommentPos y (-999)
_ -> layoutMoveToCommentPos y x
-- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline
-- layoutMoveToIndentCol y
layoutWriteAppendMultiline $ Text.pack $ comment
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
BDAnnotationRest annKey bd -> do
layoutBriDocM bd
mAnn <- do
state <- mGet
let m = _lstate_comments state
let mAnn = extractAllComments <$> Map.lookup annKey m
mSet $ state
{ _lstate_comments = Map.adjust
( \ann -> ann { ExactPrint.annFollowingComments = []
, ExactPrint.annPriorComments = []
, ExactPrint.annsDP = []
}
)
annKey
m
}
return mAnn
forM_ mAnn
$ mapM_
$ \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
do
-- evil hack for CPP:
case comment of
('#':_) -> layoutMoveToCommentPos y (-999)
_ -> layoutMoveToCommentPos y x
-- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline
-- layoutMoveToIndentCol y
layoutWriteAppendMultiline $ Text.pack $ comment
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
BDNonBottomSpacing bd -> layoutBriDocM bd
BDSetParSpacing bd -> layoutBriDocM bd
BDForceParSpacing bd -> layoutBriDocM bd
BDProhibitMTEL bd -> do
-- set flag to True for this child, but disable afterwards.
-- two hard aspects
-- 1) nesting should be allowed. this means that resetting at the end must
-- not indiscriminantely set to False, but take into account the
-- previous value
-- 2) nonetheless, newlines cancel inhibition. this means that if we ever
-- find the flag set to False afterwards, we must not return it to
-- the previous value, which might be True in the case of testing; it
-- must remain False.
state <- mGet
mSet $ state { _lstate_inhibitMTEL = True }
layoutBriDocM bd
state' <- mGet
when (_lstate_inhibitMTEL state') $ do
mSet $ state' { _lstate_inhibitMTEL = _lstate_inhibitMTEL state }
BDDebug s bd -> do
mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}"
layoutBriDocM bd
briDocLineLength :: BriDoc -> Int
briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
-- the state encodes whether a separator was already
-- appended at the current position.
where
rec = \case
BDEmpty -> return $ 0
BDLit t -> StateS.put False $> Text.length t
BDSeq bds -> sum <$> rec `mapM` bds
BDCols _ bds -> sum <$> rec `mapM` bds
BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1
BDAddBaseY _ bd -> rec bd
BDBaseYPushCur bd -> rec bd
BDBaseYPop bd -> rec bd
BDIndentLevelPushCur bd -> rec bd
BDIndentLevelPop bd -> rec bd
BDPar _ line _ -> rec line
BDAlt{} -> error "briDocLineLength BDAlt"
BDForceMultiline bd -> rec bd
BDForceSingleline bd -> rec bd
BDForwardLineMode bd -> rec bd
BDExternal _ _ _ t -> return $ Text.length t
BDAnnotationPrior _ bd -> rec bd
BDAnnotationKW _ _ bd -> rec bd
BDAnnotationRest _ bd -> rec bd
BDLines ls@(_:_) -> do
x <- StateS.get
return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x
BDLines [] -> error "briDocLineLength BDLines []"
BDEnsureIndent _ bd -> rec bd
BDProhibitMTEL bd -> rec bd
BDSetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd
BDNonBottomSpacing bd -> rec bd
BDDebug _ bd -> rec bd
briDocIsMultiLine :: BriDoc -> Bool
briDocIsMultiLine briDoc = rec briDoc
where
rec :: BriDoc -> Bool
rec = \case
BDEmpty -> False
BDLit _ -> False
BDSeq bds -> any rec bds
BDCols _ bds -> any rec bds
BDSeparator -> False
BDAddBaseY _ bd -> rec bd
BDBaseYPushCur bd -> rec bd
BDBaseYPop bd -> rec bd
BDIndentLevelPushCur bd -> rec bd
BDIndentLevelPop bd -> rec bd
BDPar _ _ _ -> True
BDAlt{} -> error "briDocIsMultiLine BDAlt"
BDForceMultiline _ -> True
BDForceSingleline bd -> rec bd
BDForwardLineMode bd -> rec bd
BDExternal _ _ _ _ -> True
BDAnnotationPrior _ bd -> rec bd
BDAnnotationKW _ _ bd -> rec bd
BDAnnotationRest _ bd -> rec bd
BDLines (_:_:_) -> True
BDLines [_ ] -> False
BDLines [] -> error "briDocIsMultiLine BDLines []"
BDEnsureIndent _ bd -> rec bd
BDProhibitMTEL bd -> rec bd
BDSetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd
BDNonBottomSpacing bd -> rec bd
BDDebug _ bd -> rec bd
alignColsLines :: LayoutConstraints m => [BriDoc] -> m ()
alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
curX <- do
state <- mGet
return $ either id (const 0) (_lstate_curYOrAddNewline state) + fromMaybe
0
(_lstate_addSepSpace state)
colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack
alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack
alignBreak <-
mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack
case () of
_ ->
sequence_
$ List.intersperse layoutWriteEnsureNewlineBlock
$ colInfos
<&> processInfo processedMap
where
(colInfos, finalState) =
StateS.runState (mergeBriDocs bridocs) (ColBuildState IntMapS.empty 0)
-- maxZipper :: [Int] -> [Int] -> [Int]
-- maxZipper [] ys = ys
-- maxZipper xs [] = xs
-- maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr
colAggregation :: [Int] -> Int
colAggregation xs = maximum [ x | x <- xs, x < minimum xs + alignMax ]
processedMap :: ColMap2
processedMap =
fix $ \result -> _cbs_map finalState <&> \(lastFlag, colSpacingss) ->
let
colss = colSpacingss <&> \spss -> case reverse spss of
[] -> []
(xN:xR) ->
reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR
where
fLast (ColumnSpacingLeaf len ) = len
fLast (ColumnSpacingRef len _) = len
fInit (ColumnSpacingLeaf len) = len
fInit (ColumnSpacingRef _ i ) = case IntMapL.lookup i result of
Nothing -> 0
Just (_, maxs, _) -> sum maxs
maxCols = {-Foldable.foldl1 maxZipper-}
fmap colAggregation $ transpose $ Foldable.toList colss
(_, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols
counter count l = if List.last posXs + List.last l <= colMax
then count + 1
else count
ratio = fromIntegral (foldl counter (0 :: Int) colss)
/ fromIntegral (length colss)
in
(ratio, maxCols, colss)
mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo]
mergeBriDocs bds = mergeBriDocsW ColInfoStart bds
mergeBriDocsW
:: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo]
mergeBriDocsW _ [] = return []
mergeBriDocsW lastInfo (bd:bdr) = do
info <- mergeInfoBriDoc True lastInfo bd
infor <- mergeBriDocsW
(if alignBreak && briDocIsMultiLine bd then ColInfoStart else info)
bdr
return $ info : infor
mergeInfoBriDoc
:: Bool
-> ColInfo
-> BriDoc
-> StateS.StateT ColBuildState Identity ColInfo
mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag
mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag
mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) =
\case
brdc@(BDCols colSig subDocs)
| infoSig == colSig && length subLengthsInfos == length subDocs
-> do
let
isLastList = if lastFlag
then (==length subDocs) <$> [1 ..]
else repeat False
infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs
`forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd
let curLengths = briDocLineLength <$> subDocs
let trueSpacings = getTrueSpacings (zip curLengths infos)
do -- update map
s <- StateS.get
let m = _cbs_map s
let (Just (_, spaces)) = IntMapS.lookup infoInd m
StateS.put s
{ _cbs_map = IntMapS.insert
infoInd
(lastFlag, spaces Seq.|> trueSpacings)
m
}
return $ ColInfo infoInd colSig (zip curLengths infos)
| otherwise
-> briDocToColInfo lastFlag brdc
brdc -> return $ ColInfoNo brdc
briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo
briDocToColInfo lastFlag = \case
BDCols sig list -> withAlloc lastFlag $ \ind -> do
let isLastList =
if lastFlag then (==length list) <$> [1 ..] else repeat False
subInfos <- zip isLastList list `forM` uncurry briDocToColInfo
let lengthInfos = zip (briDocLineLength <$> list) subInfos
let trueSpacings = getTrueSpacings lengthInfos
return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos)
bd -> return $ ColInfoNo bd
getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing]
getTrueSpacings lengthInfos = lengthInfos <&> \case
(len, ColInfo i _ _) -> ColumnSpacingRef len i
(len, _ ) -> ColumnSpacingLeaf len
withAlloc
:: Bool
-> ( ColIndex
-> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo)
)
-> StateS.State ColBuildState ColInfo
withAlloc lastFlag f = do
cbs <- StateS.get
let ind = _cbs_index cbs
StateS.put $ cbs { _cbs_index = ind + 1 }
(space, info) <- f ind
StateS.get >>= \c -> StateS.put
$ c { _cbs_map = IntMapS.insert ind (lastFlag, space) $ _cbs_map c }
return info
processInfo :: LayoutConstraints m => ColMap2 -> ColInfo -> m ()
processInfo m = \case
ColInfoStart -> error "should not happen (TM)"
ColInfoNo doc -> layoutBriDocM doc
ColInfo ind _ list -> do
colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack
alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack
curX <- do
state <- mGet
return $ either id (const 0) (_lstate_curYOrAddNewline state) + fromMaybe
0
(_lstate_addSepSpace state)
-- tellDebugMess $ show curX
let Just (ratio, maxCols, _colss) = IntMapS.lookup ind m
let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols
-- handle the cases that the vertical alignment leads to more than max
-- cols:
-- this is not a full fix, and we must correct individually in addition.
-- because: the (at least) line with the largest element in the last
-- column will always still overflow, because we just updated the column
-- sizes in such a way that it works _if_ we have sizes (*factor)
-- in each column. but in that line, in the last column, we will be
-- forced to occupy the full vertical space, not reduced by any factor.
let fixedPosXs = case alignMode of
ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+curX)
where
factor :: Float =
-- 0.0001 as an offering to the floating point gods.
min
1.0001
(fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX))
offsets = (subtract curX) <$> posXs
fixed = offsets <&> fromIntegral .> (*factor) .> truncate
_ -> posXs
let alignAct = zip fixedPosXs list `forM_` \(destX, x) -> do
layoutWriteEnsureAbsoluteN destX
processInfo m (snd x)
noAlignAct = list `forM_` (snd .> processInfoIgnore)
animousAct =
-- per-item check if there is overflowing.
if List.last fixedPosXs + fst (List.last list) > colMax
then noAlignAct
else alignAct
case alignMode of
ColumnAlignModeDisabled -> noAlignAct
ColumnAlignModeUnanimously | maxX <= colMax -> alignAct
ColumnAlignModeUnanimously -> noAlignAct
ColumnAlignModeMajority limit | ratio >= limit -> animousAct
ColumnAlignModeMajority{} -> noAlignAct
ColumnAlignModeAnimouslyScale{} -> animousAct
ColumnAlignModeAnimously -> animousAct
ColumnAlignModeAlways -> alignAct
processInfoIgnore :: LayoutConstraints m => ColInfo -> m ()
processInfoIgnore = \case
ColInfoStart -> error "should not happen (TM)"
ColInfoNo doc -> layoutBriDocM doc
ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore)