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

Apply brittany to `layoutBriDocM`

pull/35/head
Lennart Spitzner 2017-05-17 21:38:50 +02:00
parent 6448ee780a
commit 56e53a9cbb
1 changed files with 257 additions and 228 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

483
src/Language/Haskell/Brittany/Backend.hs
View File

@ -171,57 +171,61 @@ layoutBriDocM = \case
indentF $ do indentF $ do
layoutWriteNewlineBlock layoutWriteNewlineBlock
layoutBriDocM indented layoutBriDocM indented
BDLines lines -> BDLines lines -> alignColsLines lines
alignColsLines lines BDAlt [] -> error "empty BDAlt"
BDAlt [] -> error "empty BDAlt" BDAlt (alt:_) -> layoutBriDocM alt
BDAlt (alt:_) -> layoutBriDocM alt BDForceMultiline bd -> layoutBriDocM bd
BDForceMultiline bd -> layoutBriDocM bd BDForceSingleline bd -> layoutBriDocM bd
BDForceSingleline bd -> layoutBriDocM bd BDForwardLineMode bd -> layoutBriDocM bd
BDForwardLineMode bd -> layoutBriDocM bd
BDExternal annKey subKeys shouldAddComment t -> do BDExternal annKey subKeys shouldAddComment t -> do
let tlines = Text.lines $ t <> Text.pack "\n" let tlines = Text.lines $ t <> Text.pack "\n"
tlineCount = length tlines tlineCount = length tlines
anns :: ExactPrint.Anns <- mAsk anns :: ExactPrint.Anns <- mAsk
when shouldAddComment $ do when shouldAddComment $ do
layoutWriteAppend $ Text.pack $ "{-" ++ show (annKey, Map.lookup annKey anns) ++ "-}" layoutWriteAppend
zip [1..] tlines `forM_` \(i, l) -> do $ Text.pack
$ "{-"
++ show (annKey, Map.lookup annKey anns)
++ "-}"
zip [1 ..] tlines `forM_` \(i, l) -> do
layoutWriteAppend $ l layoutWriteAppend $ l
unless (i==tlineCount) layoutWriteNewlineBlock unless (i == tlineCount) layoutWriteNewlineBlock
do do
state <- mGet state <- mGet
let filterF k _ = not $ k `Set.member` subKeys let filterF k _ = not $ k `Set.member` subKeys
mSet $ state mSet $ state
{ _lstate_comments = Map.filterWithKey filterF { _lstate_comments = Map.filterWithKey filterF $ _lstate_comments state
$ _lstate_comments state
} }
BDAnnotationPrior annKey bd -> do BDAnnotationPrior annKey bd -> do
state <- mGet state <- mGet
let m = _lstate_comments state let m = _lstate_comments state
let allowMTEL = not (_lstate_inhibitMTEL state) let allowMTEL = not (_lstate_inhibitMTEL state)
&& Data.Either.isRight (_lstate_curYOrAddNewline state) && Data.Either.isRight (_lstate_curYOrAddNewline state)
mAnn <- do mAnn <- do
let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m
mSet $ state mSet $ state
{ _lstate_comments = { _lstate_comments = Map.adjust
Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) annKey m (\ann -> ann { ExactPrint.annPriorComments = [] })
} annKey
m
}
return mAnn return mAnn
case mAnn of case mAnn of
Nothing -> when allowMTEL $ moveToExactAnn annKey Nothing -> when allowMTEL $ moveToExactAnn annKey
Just [] -> when allowMTEL $ moveToExactAnn annKey Just [] -> when allowMTEL $ moveToExactAnn annKey
Just priors -> do Just priors -> do
-- layoutResetSepSpace -- layoutResetSepSpace
priors `forM_` \( ExactPrint.Types.Comment comment _ _ priors
, ExactPrint.Types.DP (y, x) `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
) -> do do
-- evil hack for CPP: -- evil hack for CPP:
case comment of case comment of
('#':_) -> layoutMoveToCommentPos y (-999) ('#':_) -> layoutMoveToCommentPos y (-999)
_ -> layoutMoveToCommentPos y x _ -> layoutMoveToCommentPos y x
-- fixedX <- fixMoveToLineByIsNewline x -- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline -- replicateM_ fixedX layoutWriteNewline
-- layoutMoveToIndentCol y -- layoutMoveToIndentCol y
layoutWriteAppendMultiline $ Text.pack $ comment layoutWriteAppendMultiline $ Text.pack $ comment
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
when allowMTEL $ moveToExactAnn annKey when allowMTEL $ moveToExactAnn annKey
layoutBriDocM bd layoutBriDocM bd
@ -229,71 +233,73 @@ layoutBriDocM = \case
layoutBriDocM bd layoutBriDocM bd
mAnn <- do mAnn <- do
state <- mGet state <- mGet
let m = _lstate_comments state let m = _lstate_comments state
let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
let mToSpan = case mAnn of let mToSpan = case mAnn of
Just anns | keyword==Nothing -> Just anns Just anns | keyword == Nothing -> Just anns
Just ((ExactPrint.Types.G kw1, _):annR) Just ((ExactPrint.Types.G kw1, _):annR) | keyword == Just kw1 -> Just
| keyword==Just kw1 -> Just annR annR
_ -> Nothing _ -> Nothing
case mToSpan of case mToSpan of
Just anns -> do Just anns -> do
let (comments, rest) = flip spanMaybe anns $ \case let (comments, rest) = flip spanMaybe anns $ \case
(ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp)
_ -> Nothing _ -> Nothing
mSet $ state mSet $ state
{ _lstate_comments = { _lstate_comments = Map.adjust
Map.adjust (\ann -> ann { ExactPrint.annsDP = rest }) (\ann -> ann { ExactPrint.annsDP = rest })
annKey annKey
m m
} }
return $ [ comments | not $ null comments ] return $ [ comments | not $ null comments ]
_ -> return Nothing _ -> return Nothing
forM_ mAnn $ mapM_ $ \( ExactPrint.Types.Comment comment _ _ forM_ mAnn
, ExactPrint.Types.DP (y, x) $ mapM_
) -> do $ \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
-- evil hack for CPP: do
case comment of -- evil hack for CPP:
('#':_) -> layoutMoveToCommentPos y (-999) case comment of
_ -> layoutMoveToCommentPos y x ('#':_) -> layoutMoveToCommentPos y (-999)
-- fixedX <- fixMoveToLineByIsNewline x _ -> layoutMoveToCommentPos y x
-- replicateM_ fixedX layoutWriteNewline -- fixedX <- fixMoveToLineByIsNewline x
-- layoutMoveToIndentCol y -- replicateM_ fixedX layoutWriteNewline
layoutWriteAppendMultiline $ Text.pack $ comment -- layoutMoveToIndentCol y
layoutWriteAppendMultiline $ Text.pack $ comment
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
BDAnnotationRest annKey bd -> do BDAnnotationRest annKey bd -> do
layoutBriDocM bd layoutBriDocM bd
mAnn <- do mAnn <- do
state <- mGet state <- mGet
let m = _lstate_comments state let m = _lstate_comments state
let mAnn = extractAllComments <$> Map.lookup annKey m let mAnn = extractAllComments <$> Map.lookup annKey m
mSet $ state mSet $ state
{ _lstate_comments = { _lstate_comments = Map.adjust
Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = [] ( \ann -> ann { ExactPrint.annFollowingComments = []
, ExactPrint.annPriorComments = [] , ExactPrint.annPriorComments = []
, ExactPrint.annsDP = [] , ExactPrint.annsDP = []
} }
) )
annKey annKey
m m
} }
return mAnn return mAnn
forM_ mAnn $ mapM_ $ \( ExactPrint.Types.Comment comment _ _ forM_ mAnn
, ExactPrint.Types.DP (y, x) $ mapM_
) -> do $ \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
do
-- evil hack for CPP: -- evil hack for CPP:
case comment of case comment of
('#':_) -> layoutMoveToCommentPos y (-999) ('#':_) -> layoutMoveToCommentPos y (-999)
_ -> layoutMoveToCommentPos y x _ -> layoutMoveToCommentPos y x
-- fixedX <- fixMoveToLineByIsNewline x -- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline -- replicateM_ fixedX layoutWriteNewline
-- layoutMoveToIndentCol y -- layoutMoveToIndentCol y
layoutWriteAppendMultiline $ Text.pack $ comment layoutWriteAppendMultiline $ Text.pack $ comment
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
BDNonBottomSpacing bd -> layoutBriDocM bd BDNonBottomSpacing bd -> layoutBriDocM bd
BDSetParSpacing bd -> layoutBriDocM bd BDSetParSpacing bd -> layoutBriDocM bd
BDForceParSpacing bd -> layoutBriDocM bd BDForceParSpacing 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.
-- two hard aspects -- two hard aspects
-- 1) nesting should be allowed. this means that resetting at the end must -- 1) nesting should be allowed. this means that resetting at the end must
@ -312,7 +318,7 @@ layoutBriDocM = \case
BDDebug s bd -> do BDDebug s bd -> do
mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}" mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}"
layoutBriDocM bd layoutBriDocM bd
where where
-- alignColsPar :: [BriDoc] -- alignColsPar :: [BriDoc]
-- -> m () -- -> m ()
-- alignColsPar l = colInfos `forM_` \colInfo -> do -- alignColsPar l = colInfos `forM_` \colInfo -> do
@ -320,177 +326,200 @@ layoutBriDocM = \case
-- processInfo (_cbs_map finalState) colInfo -- processInfo (_cbs_map finalState) colInfo
-- where -- where
-- (colInfos, finalState) = StateS.runState (mergeBriDocs l) (ColBuildState IntMapS.empty 0) -- (colInfos, finalState) = StateS.runState (mergeBriDocs l) (ColBuildState IntMapS.empty 0)
alignColsLines :: [BriDoc] -> m () alignColsLines :: [BriDoc] -> m ()
alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
curX <- do curX <- do
state <- mGet state <- mGet
return $ either id (const 0) (_lstate_curYOrAddNewline state) return $ either id (const 0) (_lstate_curYOrAddNewline state) + fromMaybe
+ fromMaybe 0 (_lstate_addSepSpace state) 0
colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack (_lstate_addSepSpace state)
alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack
alignBreak <- mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack
case () of alignBreak <-
_ -> mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack
sequence_ $ List.intersperse layoutWriteEnsureNewlineBlock case () of
$ colInfos <&> processInfo processedMap _ ->
where sequence_
(colInfos, finalState) = StateS.runState (mergeBriDocs bridocs) $ List.intersperse layoutWriteEnsureNewlineBlock
(ColBuildState IntMapS.empty 0) $ colInfos
-- maxZipper :: [Int] -> [Int] -> [Int] <&> processInfo processedMap
-- maxZipper [] ys = ys where
-- maxZipper xs [] = xs (colInfos, finalState) =
-- maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr StateS.runState (mergeBriDocs bridocs) (ColBuildState IntMapS.empty 0)
colAggregation :: [Int] -> Int -- maxZipper :: [Int] -> [Int] -> [Int]
colAggregation xs = maximum [ x | x <- xs, x < minimum xs + alignMax ] -- 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 :: ColMap2
processedMap = fix $ \result -> processedMap =
_cbs_map finalState <&> \(lastFlag, colSpacingss) -> fix $ \result -> _cbs_map finalState <&> \(lastFlag, colSpacingss) ->
let colss = colSpacingss <&> \spss -> case reverse spss of let
[] -> [] colss = colSpacingss <&> \spss -> case reverse spss of
(xN:xR) -> reverse [] -> []
$ (if lastFlag then fLast else fInit) xN : fmap fInit xR (xN:xR) ->
where reverse $ (if lastFlag then fLast else fInit) xN : fmap
fLast (ColumnSpacingLeaf len) = len fInit
fLast (ColumnSpacingRef len _) = len xR
fInit (ColumnSpacingLeaf len) = len where
fInit (ColumnSpacingRef _ i) = case IntMapL.lookup i result of fLast (ColumnSpacingLeaf len ) = len
Nothing -> 0 fLast (ColumnSpacingRef len _) = len
Just (_, maxs, _) -> sum maxs fInit (ColumnSpacingLeaf len) = len
maxCols = {-Foldable.foldl1 maxZipper-} fInit (ColumnSpacingRef _ i ) = case IntMapL.lookup i result of
fmap colAggregation $ transpose $ Foldable.toList colss Nothing -> 0
(_, posXs) = mapAccumL (\acc x -> (acc+x,acc)) curX maxCols Just (_, maxs, _) -> sum maxs
counter count l = maxCols = {-Foldable.foldl1 maxZipper-}
if List.last posXs + List.last l <=colMax fmap colAggregation $ transpose $ Foldable.toList colss
then count + 1 (_, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols
else count counter count l = if List.last posXs + List.last l <= colMax
ratio = fromIntegral (foldl counter (0::Int) colss) then count + 1
/ fromIntegral (length colss) else count
in (ratio, maxCols, colss) ratio = fromIntegral (foldl counter (0 :: Int) colss)
/ fromIntegral (length colss)
in
(ratio, maxCols, colss)
mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo] mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo]
mergeBriDocs bds = mergeBriDocsW ColInfoStart bds mergeBriDocs bds = mergeBriDocsW ColInfoStart bds
mergeBriDocsW :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo] mergeBriDocsW
mergeBriDocsW _ [] = return [] :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo]
mergeBriDocsW lastInfo (bd:bdr) = do mergeBriDocsW _ [] = return []
info <- mergeInfoBriDoc True lastInfo bd mergeBriDocsW lastInfo (bd:bdr) = do
infor <- mergeBriDocsW (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info) bdr info <- mergeInfoBriDoc True lastInfo bd
return $ info : infor infor <- mergeBriDocsW
(if alignBreak && briDocIsMultiLine bd then ColInfoStart else info)
bdr
return $ info : infor
mergeInfoBriDoc :: Bool mergeInfoBriDoc
-> ColInfo :: Bool
-> BriDoc -> ColInfo
-> StateS.StateT ColBuildState Identity ColInfo -> BriDoc
mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag -> StateS.StateT ColBuildState Identity ColInfo
mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag
mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) = \case mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag
mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) =
\case
brdc@(BDCols colSig subDocs) brdc@(BDCols colSig subDocs)
| infoSig == colSig | infoSig == colSig && length subLengthsInfos == length subDocs
&& length subLengthsInfos == length subDocs -> do -> do
let isLastList = let
if lastFlag then (== length subDocs) <$> [1..] else repeat False isLastList = if lastFlag
then (==length subDocs) <$> [1 ..]
else repeat False
infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs
`forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd `forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd
let curLengths = briDocLineLength <$> subDocs let curLengths = briDocLineLength <$> subDocs
let trueSpacings = getTrueSpacings (zip curLengths infos) let trueSpacings = getTrueSpacings (zip curLengths infos)
do -- update map do -- update map
s <- StateS.get s <- StateS.get
let m = _cbs_map s let m = _cbs_map s
let (Just (_, spaces)) = IntMapS.lookup infoInd m let (Just (_, spaces)) = IntMapS.lookup infoInd m
StateS.put s StateS.put s
{ _cbs_map = IntMapS.insert infoInd { _cbs_map = IntMapS.insert
(lastFlag, spaces Seq.|> trueSpacings) infoInd
m (lastFlag, spaces Seq.|> trueSpacings)
m
} }
return $ ColInfo infoInd colSig (zip curLengths infos) return $ ColInfo infoInd colSig (zip curLengths infos)
| otherwise -> briDocToColInfo lastFlag brdc | otherwise
brdc -> return $ ColInfoNo brdc -> briDocToColInfo lastFlag brdc
brdc -> return $ ColInfoNo brdc
briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo
briDocToColInfo lastFlag = \case briDocToColInfo lastFlag = \case
BDCols sig list -> withAlloc lastFlag $ \ind -> do BDCols sig list -> withAlloc lastFlag $ \ind -> do
let isLastList = let isLastList =
if lastFlag then (== length list) <$> [1..] else repeat False if lastFlag then (==length list) <$> [1 ..] else repeat False
subInfos <- zip isLastList list `forM` uncurry briDocToColInfo subInfos <- zip isLastList list `forM` uncurry briDocToColInfo
let lengthInfos = zip (briDocLineLength <$> list) subInfos let lengthInfos = zip (briDocLineLength <$> list) subInfos
let trueSpacings = getTrueSpacings lengthInfos let trueSpacings = getTrueSpacings lengthInfos
return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos) return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos)
bd -> return $ ColInfoNo bd bd -> return $ ColInfoNo bd
getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing] getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing]
getTrueSpacings lengthInfos = lengthInfos <&> \case getTrueSpacings lengthInfos = lengthInfos <&> \case
(len, ColInfo i _ _) -> ColumnSpacingRef len i (len, ColInfo i _ _) -> ColumnSpacingRef len i
(len, _) -> ColumnSpacingLeaf len (len, _ ) -> ColumnSpacingLeaf len
withAlloc :: Bool withAlloc
-> (ColIndex -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo)) :: Bool
-> StateS.State ColBuildState ColInfo -> ( ColIndex
withAlloc lastFlag f = do -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo)
cbs <- StateS.get )
let ind = _cbs_index cbs -> StateS.State ColBuildState ColInfo
StateS.put $ cbs { _cbs_index = ind + 1 } withAlloc lastFlag f = do
(space, info) <- f ind cbs <- StateS.get
StateS.get >>= \c -> StateS.put let ind = _cbs_index cbs
$ c { _cbs_map = IntMapS.insert ind (lastFlag, space) $ _cbs_map c } StateS.put $ cbs { _cbs_index = ind + 1 }
return info (space, info) <- f ind
StateS.get >>= \c -> StateS.put
$ c { _cbs_map = IntMapS.insert ind (lastFlag, space) $ _cbs_map c }
return info
processInfo :: ColMap2 -> ColInfo -> m () processInfo :: ColMap2 -> ColInfo -> m ()
processInfo m = \case processInfo m = \case
ColInfoStart -> error "should not happen (TM)" ColInfoStart -> error "should not happen (TM)"
ColInfoNo doc -> layoutBriDocM doc ColInfoNo doc -> layoutBriDocM doc
ColInfo ind _ list -> do ColInfo ind _ list -> do
colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack
alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack alignMode <-
curX <- do mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack
state <- mGet curX <- do
return $ either id (const 0) (_lstate_curYOrAddNewline state) state <- mGet
+ fromMaybe 0 (_lstate_addSepSpace state) return
-- tellDebugMess $ show curX $ either id (const 0) (_lstate_curYOrAddNewline state)
let Just (ratio, maxCols, _colss) = IntMapS.lookup ind m + fromMaybe 0 (_lstate_addSepSpace state)
let (maxX, posXs) = mapAccumL (\acc x -> (acc+x,acc)) curX maxCols -- tellDebugMess $ show curX
-- handle the cases that the vertical alignment leads to more than max let Just (ratio, maxCols, _colss) = IntMapS.lookup ind m
-- cols: let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols
-- this is not a full fix, and we must correct individually in addition. -- handle the cases that the vertical alignment leads to more than max
-- because: the (at least) line with the largest element in the last -- cols:
-- column will always still overflow, because we just updated the column -- this is not a full fix, and we must correct individually in addition.
-- sizes in such a way that it works _if_ we have sizes (*factor) -- because: the (at least) line with the largest element in the last
-- in each column. but in that line, in the last column, we will be -- column will always still overflow, because we just updated the column
-- forced to occupy the full vertical space, not reduced by any factor. -- sizes in such a way that it works _if_ we have sizes (*factor)
let fixedPosXs = case alignMode of -- in each column. but in that line, in the last column, we will be
ColumnAlignModeAnimouslyScale i | maxX>colMax -> fixed <&> (+curX) -- forced to occupy the full vertical space, not reduced by any factor.
where let
factor :: Float = fixedPosXs = case alignMode of
-- 0.0001 as an offering to the floating point gods. ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+curX)
min 1.0001 ( fromIntegral (i + colMax - curX) where
/ fromIntegral (maxX - curX) factor :: Float =
) -- 0.0001 as an offering to the floating point gods.
offsets = (subtract curX) <$> posXs min
fixed = offsets <&> fromIntegral .> (*factor) .> truncate 1.0001
_ -> posXs (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX))
let alignAct = zip fixedPosXs list `forM_` \(destX, x) -> do offsets = (subtract curX) <$> posXs
layoutWriteEnsureAbsoluteN destX fixed = offsets <&> fromIntegral .> (*factor) .> truncate
processInfo m (snd x) _ -> posXs
noAlignAct = list `forM_` (snd .> processInfoIgnore) let alignAct = zip fixedPosXs list `forM_` \(destX, x) -> do
animousAct = layoutWriteEnsureAbsoluteN destX
-- per-item check if there is overflowing. processInfo m (snd x)
if List.last fixedPosXs + fst (List.last list) > colMax noAlignAct = list `forM_` (snd .> processInfoIgnore)
then noAlignAct animousAct =
else alignAct -- per-item check if there is overflowing.
case alignMode of if List.last fixedPosXs + fst (List.last list) > colMax
ColumnAlignModeDisabled -> noAlignAct then noAlignAct
ColumnAlignModeUnanimously | maxX<=colMax -> alignAct else alignAct
ColumnAlignModeUnanimously -> noAlignAct case alignMode of
ColumnAlignModeMajority limit | ratio>=limit -> animousAct ColumnAlignModeDisabled -> noAlignAct
ColumnAlignModeMajority{} -> noAlignAct ColumnAlignModeUnanimously | maxX <= colMax -> alignAct
ColumnAlignModeAnimouslyScale{} -> animousAct ColumnAlignModeUnanimously -> noAlignAct
ColumnAlignModeAnimously -> animousAct ColumnAlignModeMajority limit | ratio >= limit -> animousAct
ColumnAlignModeAlways -> alignAct ColumnAlignModeMajority{} -> noAlignAct
processInfoIgnore :: ColInfo -> m () ColumnAlignModeAnimouslyScale{} -> animousAct
processInfoIgnore = \case ColumnAlignModeAnimously -> animousAct
ColInfoStart -> error "should not happen (TM)" ColumnAlignModeAlways -> alignAct
ColInfoNo doc -> layoutBriDocM doc
ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore) processInfoIgnore :: ColInfo -> m ()
processInfoIgnore = \case
ColInfoStart -> error "should not happen (TM)"
ColInfoNo doc -> layoutBriDocM doc
ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore)
type ColIndex = Int type ColIndex = Int