diff --git a/brittany.cabal b/brittany.cabal index 69d212c..100f1df 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -34,14 +34,20 @@ library { Language.Haskell.Brittany.Config.Types } other-modules: { - Language.Haskell.Brittany.LayoutBasics - Language.Haskell.Brittany.BriLayouter + Language.Haskell.Brittany.LayouterBasics + Language.Haskell.Brittany.BackendUtils + Language.Haskell.Brittany.Backend Language.Haskell.Brittany.ExactPrintUtils Language.Haskell.Brittany.Layouters.Type Language.Haskell.Brittany.Layouters.Decl Language.Haskell.Brittany.Layouters.Expr Language.Haskell.Brittany.Layouters.Stmt Language.Haskell.Brittany.Layouters.Pattern + Language.Haskell.Brittany.Transformations.Alt + Language.Haskell.Brittany.Transformations.Floating + Language.Haskell.Brittany.Transformations.Par + Language.Haskell.Brittany.Transformations.Columns + Language.Haskell.Brittany.Transformations.Indent } ghc-options: { -Wall diff --git a/src/Language/Haskell/Brittany.hs b/src/Language/Haskell/Brittany.hs index 7bacd59..bd92e3b 100644 --- a/src/Language/Haskell/Brittany.hs +++ b/src/Language/Haskell/Brittany.hs @@ -15,34 +15,35 @@ 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 qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers -import qualified Language.Haskell.GHC.ExactPrint.Preprocess as ExactPrint.Preprocess import qualified Data.Generics as SYB -import qualified Data.Map as Map - import qualified Data.Text.Lazy.Builder as Text.Builder -import qualified Debug.Trace as Trace +import Language.Haskell.Brittany.Types +import Language.Haskell.Brittany.Config.Types +import Language.Haskell.Brittany.LayouterBasics -import Language.Haskell.Brittany.Types -import Language.Haskell.Brittany.Config.Types -import Language.Haskell.Brittany.LayoutBasics import Language.Haskell.Brittany.Layouters.Type import Language.Haskell.Brittany.Layouters.Decl import Language.Haskell.Brittany.Utils -import Language.Haskell.Brittany.BriLayouter +import Language.Haskell.Brittany.Backend +import Language.Haskell.Brittany.BackendUtils import Language.Haskell.Brittany.ExactPrintUtils +import Language.Haskell.Brittany.Transformations.Alt +import Language.Haskell.Brittany.Transformations.Floating +import Language.Haskell.Brittany.Transformations.Par +import Language.Haskell.Brittany.Transformations.Columns +import Language.Haskell.Brittany.Transformations.Indent + import qualified GHC as GHC hiding (parseModule) import ApiAnnotation ( AnnKeywordId(..) ) import RdrName ( RdrName(..) ) import GHC ( runGhc, GenLocated(L), moduleNameString ) import SrcLoc ( SrcSpan ) -import qualified SrcLoc as GHC import HsSyn import Data.HList.HList @@ -249,3 +250,77 @@ _bindHead = \case FunBind fId _ _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) PatBind _pat _ _ _ ([], []) -> "PatBind smth" _ -> "unknown bind" + + + +layoutBriDoc :: Data.Data.Data ast => ast -> BriDocNumbered -> PPM () +layoutBriDoc ast briDoc = do + -- first step: transform the briDoc. + briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do + traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw + $ briDocToDoc + $ unwrapBriDocNumbered + $ briDoc + -- bridoc transformation: remove alts + transformAlts briDoc >>= mSet + mGet + >>= traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt + . briDocToDoc + -- bridoc transformation: float stuff in + mGet <&> transformSimplifyFloating >>= mSet + mGet + >>= traceIfDumpConf "bridoc post-floating" + _dconf_dump_bridoc_simpl_floating + . briDocToDoc + -- bridoc transformation: par removal + mGet <&> transformSimplifyPar >>= mSet + mGet + >>= traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par + . briDocToDoc + -- bridoc transformation: float stuff in + mGet <&> transformSimplifyColumns >>= mSet + mGet + >>= traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns + . briDocToDoc + -- -- bridoc transformation: indent + mGet <&> transformSimplifyIndent >>= mSet + mGet + >>= traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent + . briDocToDoc + mGet + >>= traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final + . briDocToDoc + -- -- convert to Simple type + -- simpl <- mGet <&> transformToSimple + -- return simpl + + anns :: ExactPrint.Types.Anns <- mAsk + let filteredAnns = filterAnns ast anns + + traceIfDumpConf "bridoc annotations filtered/transformed" + _dconf_dump_annotations + $ annsDoc filteredAnns + + let state = LayoutState + { _lstate_baseYs = [0] + , _lstate_curYOrAddNewline = Right 0 -- important that we use left here + -- because moveToAnn stuff of the + -- first node needs to do its + -- thing properly. + , _lstate_indLevels = [0] + , _lstate_indLevelLinger = 0 + , _lstate_comments = filteredAnns + , _lstate_commentCol = Nothing + , _lstate_addSepSpace = Nothing + , _lstate_inhibitMTEL = False + } + + state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' + + let + remainingComments = + extractAllComments =<< Map.elems (_lstate_comments state') + remainingComments + `forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fst) + + return $ () diff --git a/src/Language/Haskell/Brittany/Backend.hs b/src/Language/Haskell/Brittany/Backend.hs new file mode 100644 index 0000000..226d66e --- /dev/null +++ b/src/Language/Haskell/Brittany/Backend.hs @@ -0,0 +1,471 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeApplications #-} + +module Language.Haskell.Brittany.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.LayouterBasics +import Language.Haskell.Brittany.BackendUtils +import Language.Haskell.Brittany.Utils +import Language.Haskell.Brittany.Config.Types +import Language.Haskell.Brittany.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 + + + +briDocLineLength :: BriDoc -> Int +briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc + -- the state encodes whether a separate 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 + +layoutBriDocM + :: forall w m + . ( m ~ MultiRWSS.MultiRWST + '[Config, ExactPrint.Anns] + w + '[LayoutState] + Identity + , ContainsType Text.Builder.Builder w + , ContainsType [LayoutError] w + , ContainsType (Seq String) w + ) + => 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 + where + -- alignColsPar :: [BriDoc] + -- -> m () + -- alignColsPar l = colInfos `forM_` \colInfo -> do + -- layoutWriteNewlineBlock + -- processInfo (_cbs_map finalState) colInfo + -- where + -- (colInfos, finalState) = StateS.runState (mergeBriDocs l) (ColBuildState IntMapS.empty 0) + alignColsLines :: [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 + sequence_ $ List.intersperse layoutWriteEnsureNewlineBlock + $ colInfos <&> processInfo (processedMap curX colMax) + 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 + processedMap :: Int -> Int -> ColMap2 + processedMap curX colMax = fix $ \result -> + _cbs_map finalState <&> \colSpacingss -> + let colss = colSpacingss <&> \spss -> case reverse spss of + [] -> [] + (xN:xR) -> reverse $ fLast 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 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) + briDocToColInfo :: BriDoc -> StateS.State ColBuildState ColInfo + briDocToColInfo = \case + BDCols sig list -> withAlloc $ \ind -> do + subInfos <- mapM briDocToColInfo list + 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 + + 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 lastInfo bd + infor <- mergeBriDocsW info bdr + return $ info : infor + + mergeInfoBriDoc :: ColInfo + -> BriDoc + -> StateS.StateT ColBuildState Identity ColInfo + mergeInfoBriDoc ColInfoStart = briDocToColInfo + mergeInfoBriDoc ColInfoNo{} = briDocToColInfo + mergeInfoBriDoc (ColInfo infoInd infoSig subLengthsInfos) = \case + bd@(BDCols colSig subDocs) + | infoSig == colSig + && length subLengthsInfos == length subDocs -> do + infos <- zip (snd <$> subLengthsInfos) subDocs + `forM` uncurry mergeInfoBriDoc + 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 + (spaces Seq.|> trueSpacings) + m + } + return $ ColInfo infoInd colSig (zip curLengths infos) + | otherwise -> briDocToColInfo bd + bd -> return $ ColInfoNo bd + + withAlloc :: (ColIndex -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo)) + -> StateS.State ColBuildState ColInfo + withAlloc 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 space $ _cbs_map c } + return info + + processInfo :: 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 :: ColInfo -> m () + processInfoIgnore = \case + ColInfoStart -> error "should not happen (TM)" + ColInfoNo doc -> layoutBriDocM doc + ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore) + +type ColIndex = Int + +data ColumnSpacing + = ColumnSpacingLeaf Int + | ColumnSpacingRef Int Int + +type ColumnBlock a = [a] +type ColumnBlocks a = Seq [a] +type ColMap1 = IntMapL.IntMap {- ColIndex -} (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 + } diff --git a/src/Language/Haskell/Brittany/BackendUtils.hs b/src/Language/Haskell/Brittany/BackendUtils.hs new file mode 100644 index 0000000..69fbb4e --- /dev/null +++ b/src/Language/Haskell/Brittany/BackendUtils.hs @@ -0,0 +1,606 @@ +#define INSERTTRACES 0 + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeApplications #-} +#if !INSERTTRACES +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif + +module Language.Haskell.Brittany.BackendUtils + ( layoutWriteAppend + , layoutWriteAppendMultiline + , layoutWriteNewlineBlock + , layoutWriteNewline + , layoutWriteEnsureNewlineBlock + , layoutWriteEnsureBlock + , layoutWithAddBaseCol + , layoutWithAddBaseColBlock + , layoutWithAddBaseColN + , layoutWithAddBaseColNBlock + , layoutBaseYPushCur + , layoutBaseYPop + , layoutIndentLevelPushCur + , layoutIndentLevelPop + , layoutWriteEnsureAbsoluteN + , layoutAddSepSpace + , layoutSetCommentCol + , layoutMoveToCommentPos + , layoutIndentRestorePostComment + , moveToExactAnn + , ppmMoveToExactLoc + , layoutWritePriorComments + , layoutWritePostComments + , layoutRemoveIndentLevelLinger + ) +where + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Types +import Language.Haskell.Brittany.Config.Types +import Language.Haskell.GHC.ExactPrint.Types ( AnnKey + , Annotation + , KeywordId + ) + +import qualified Data.Text.Lazy.Builder as Text.Builder +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +import Language.Haskell.Brittany.Utils + +import GHC ( GenLocated(L), moduleNameString ) +import SrcLoc ( SrcSpan ) + + + +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 + + +layoutWriteAppend + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => Text + -> m () +layoutWriteAppend t = do + traceLocal ("layoutWriteAppend", t) + state <- mGet + case _lstate_curYOrAddNewline state of + Right i -> do +#if INSERTTRACES + tellDebugMessShow (" inserted newlines: ", i) +#endif + 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 + } + +layoutWriteAppendSpaces + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) 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 + , MonadMultiWriter (Seq String) m + ) + => Text + -> m () +layoutWriteAppendMultiline t = do + traceLocal ("layoutWriteAppendMultiline", t) + case Text.lines t of + [] -> layoutWriteAppend t -- 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 + , MonadMultiWriter (Seq String) m + ) + => m () +layoutWriteNewlineBlock = do + traceLocal ("layoutWriteNewlineBlock") + state <- mGet + mSet $ state { _lstate_curYOrAddNewline = Right 1 + , _lstate_addSepSpace = Just $ lstate_baseY state + , _lstate_inhibitMTEL = False + } + +-- 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, MonadMultiWriter (Seq String) 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 } + +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. +layoutWriteNewline + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) 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 + , _lstate_inhibitMTEL = False + } + +layoutWriteEnsureNewlineBlock + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) 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_inhibitMTEL = False + , _lstate_commentCol = Nothing + } + +layoutWriteEnsureAbsoluteN + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => Int + -> m () +layoutWriteEnsureAbsoluteN n = do + state <- mGet + let diff = case _lstate_curYOrAddNewline state of + Left i -> n - i + 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, MonadMultiWriter (Seq String) m) + => Int + -> m () +layoutBaseYPushInternal i = do + traceLocal ("layoutBaseYPushInternal", i) + mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s } + +layoutBaseYPopInternal + :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () +layoutBaseYPopInternal = do + traceLocal ("layoutBaseYPopInternal") + mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s } + +layoutIndentLevelPushInternal + :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) 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, 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 + , MonadMultiWriter (Seq String) m + ) => m () +layoutRemoveIndentLevelLinger = do +#if INSERTTRACES + tellDebugMessShow ("layoutRemoveIndentLevelLinger") +#endif + mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s + } + +layoutWithAddBaseCol + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiReader Config m + , MonadMultiWriter (Seq String) m + ) + => m () + -> m () +layoutWithAddBaseCol m = do +#if INSERTTRACES + tellDebugMessShow ("layoutWithAddBaseCol") +#endif + 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 + , MonadMultiWriter (Seq String) m + ) + => m () + -> m () +layoutWithAddBaseColBlock m = do +#if INSERTTRACES + tellDebugMessShow ("layoutWithAddBaseColBlock") +#endif + 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 + , MonadMultiWriter (Seq String) 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 + , MonadMultiWriter (Seq String) 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 + , MonadMultiWriter (Seq String) m + ) + => Int + -> m () + -> m () +layoutWithAddBaseColN amount m = do +#if INSERTTRACES + tellDebugMessShow ("layoutWithAddBaseColN", amount) +#endif + state <- mGet + layoutBaseYPushInternal $ lstate_baseY state + amount + m + layoutBaseYPopInternal + +layoutBaseYPushCur + :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) 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, MonadMultiWriter (Seq String) m) => m () +layoutBaseYPop = do + traceLocal ("layoutBaseYPop") + layoutBaseYPopInternal + +layoutIndentLevelPushCur + :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) 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 + layoutBaseYPushInternal y + +layoutIndentLevelPop + :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () +layoutIndentLevelPop = do + traceLocal ("layoutIndentLevelPop") + layoutBaseYPopInternal + 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 + , MonadMultiWriter (Seq String) m) + => m () +layoutAddSepSpace = do +#if INSERTTRACES + tellDebugMessShow ("layoutAddSepSpace") +#endif + 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 + , MonadMultiWriter (Seq String) 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 } + 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 " " + +layoutWritePriorComments + :: ( Data.Data.Data ast + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => GenLocated SrcSpan 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 +#if INSERTTRACES + tellDebugMessShow ("layoutWritePriorComments", ExactPrint.mkAnnKey ast, mAnn) +#endif + case mAnn of + Nothing -> return () + Just priors -> do + when (not $ null priors) $ layoutSetCommentCol + priors `forM_` \( ExactPrint.Comment comment _ _ + , ExactPrint.DP (x, y) + ) -> do + replicateM_ x layoutWriteNewline + layoutWriteAppendSpaces y + layoutWriteAppendMultiline $ Text.pack $ comment + +-- 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 + , MonadMultiWriter (Seq String) m) + => GenLocated SrcSpan 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 +#if INSERTTRACES + tellDebugMessShow ("layoutWritePostComments", ExactPrint.mkAnnKey ast, mAnn) +#endif + case mAnn of + Nothing -> return () + Just posts -> do + when (not $ null posts) $ layoutSetCommentCol + posts `forM_` \( ExactPrint.Comment comment _ _ + , ExactPrint.DP (x, y) + ) -> do + replicateM_ x layoutWriteNewline + layoutWriteAppend $ Text.pack $ replicate y ' ' + layoutWriteAppendMultiline $ Text.pack $ comment + +layoutIndentRestorePostComment + :: ( MonadMultiState LayoutState m + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiWriter (Seq String) m + ) + => m () +layoutIndentRestorePostComment = do + state <- mGet + let mCommentCol = _lstate_commentCol state + let eCurYAddNL = _lstate_curYOrAddNewline state +#if INSERTTRACES + tellDebugMessShow ("layoutIndentRestorePostComment", mCommentCol) +#endif + mModify $ \s -> s { _lstate_commentCol = Nothing } + 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) +-- => GenLocated SrcSpan 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) +-- => GenLocated SrcSpan ast -> m () +-- layoutWritePostCommentsRestore x = do +-- layoutWritePostComments x +-- layoutIndentRestorePostComment diff --git a/src/Language/Haskell/Brittany/BriLayouter.hs b/src/Language/Haskell/Brittany/BriLayouter.hs deleted file mode 100644 index a2d8f6b..0000000 --- a/src/Language/Haskell/Brittany/BriLayouter.hs +++ /dev/null @@ -1,1730 +0,0 @@ -#define INSERTTRACESGETSPACING 0 -#define INSERTTRACESALT 0 - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeApplications #-} - -module Language.Haskell.Brittany.BriLayouter - ( layoutBriDoc - ) -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 qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils - -import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation ) -import Language.Haskell.Brittany.LayoutBasics -import Language.Haskell.Brittany.Utils - -import qualified Data.Text.Lazy.Builder as Text.Builder - -import Language.Haskell.Brittany.Config.Types -import Language.Haskell.Brittany.Types - -import RdrName ( RdrName(..) ) -import GHC ( runGhc, GenLocated(L), moduleNameString ) -import qualified Outputable as GHC -import qualified DynFlags as GHC -import qualified FastString as GHC -import qualified SrcLoc as GHC -import SrcLoc ( SrcSpan ) -import OccName ( occNameString ) -import Name ( getOccString ) -import Module ( moduleName ) -import ApiAnnotation ( AnnKeywordId(..) ) -import Data.HList.ContainsType - -import Data.Data -import Data.Generics.Schemes -import Data.Generics.Aliases - -import qualified Data.ByteString as B - -import DataTreePrint - -import qualified Text.PrettyPrint as PP - -import Data.Function ( fix ) - -import Control.Monad.Extra ( whenM ) - -import qualified Data.Generics.Uniplate.Direct as Uniplate --- import qualified Data.Generics.Uniplate as Uniplate - -import qualified Control.Monad.Memo as Memo - -import qualified Control.Monad.Trans.Writer.Strict as WriterS - - - -layoutBriDoc :: Data.Data.Data ast => ast -> BriDocNumbered -> PPM () -layoutBriDoc ast briDoc = do - -- first step: transform the briDoc. - briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do - traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw - $ briDocToDoc - $ unwrapBriDocNumbered - $ briDoc - -- bridoc transformation: remove alts - transformAlts briDoc >>= mSet - mGet - >>= traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt - . briDocToDoc - -- bridoc transformation: float stuff in - mGet <&> transformSimplifyFloating >>= mSet - mGet - >>= traceIfDumpConf "bridoc post-floating" - _dconf_dump_bridoc_simpl_floating - . briDocToDoc - -- bridoc transformation: par removal - mGet <&> transformSimplifyPar >>= mSet - mGet - >>= traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par - . briDocToDoc - -- bridoc transformation: float stuff in - mGet <&> transformSimplifyColumns >>= mSet - mGet - >>= traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns - . briDocToDoc - -- -- bridoc transformation: indent - mGet <&> transformSimplifyIndent >>= mSet - mGet - >>= traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent - . briDocToDoc - mGet - >>= traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final - . briDocToDoc - -- -- convert to Simple type - -- simpl <- mGet <&> transformToSimple - -- return simpl - - anns :: ExactPrint.Types.Anns <- mAsk - let filteredAnns = filterAnns ast anns - - traceIfDumpConf "bridoc annotations filtered/transformed" - _dconf_dump_annotations - $ annsDoc filteredAnns - - let state = LayoutState - { _lstate_baseYs = [0] - , _lstate_curYOrAddNewline = Right 0 -- important that we use left here - -- because moveToAnn stuff of the - -- first node needs to do its - -- thing properly. - , _lstate_indLevels = [0] - , _lstate_indLevelLinger = 0 - , _lstate_comments = filteredAnns - , _lstate_commentCol = Nothing - , _lstate_addSepSpace = Nothing - , _lstate_inhibitMTEL = False - } - - state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' - - let - remainingComments = - extractAllComments =<< Map.elems (_lstate_comments state') - remainingComments - `forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fst) - - return $ () - - -data AltCurPos = AltCurPos - { _acp_line :: Int -- chars in the current line - , _acp_indent :: Int -- current indentation level - , _acp_indentPrep :: Int -- indentChange affecting the next Par - , _acp_forceMLFlag :: AltLineModeState - } - deriving (Show) - -data AltLineModeState - = AltLineModeStateNone - | AltLineModeStateForceML Bool -- true ~ decays on next wrap - | AltLineModeStateForceSL - | AltLineModeStateContradiction - -- i.e. ForceX False -> ForceX True -> None - deriving (Show) - -altLineModeDecay :: AltLineModeState -> AltLineModeState -altLineModeDecay AltLineModeStateNone = AltLineModeStateNone -altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True -altLineModeDecay (AltLineModeStateForceML True ) = AltLineModeStateNone -altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL -altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction - -altLineModeRefresh :: AltLineModeState -> AltLineModeState -altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone -altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False -altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL -altLineModeRefresh AltLineModeStateContradiction = AltLineModeStateContradiction - -mergeLineMode :: AltCurPos -> AltLineModeState -> AltCurPos -mergeLineMode acp s = case (_acp_forceMLFlag acp, s) of - (AltLineModeStateContradiction, _) -> acp - (AltLineModeStateNone, x) -> acp { _acp_forceMLFlag = x } - (AltLineModeStateForceSL, AltLineModeStateForceSL) -> acp - (AltLineModeStateForceML{}, AltLineModeStateForceML{}) -> - acp { _acp_forceMLFlag = s } - _ -> acp { _acp_forceMLFlag = AltLineModeStateContradiction } - --- removes any BDAlt's from the BriDoc -transformAlts - :: forall r w s - . ( Data.HList.ContainsType.ContainsType Config r - , Data.HList.ContainsType.ContainsType (Seq String) w - ) - => BriDocNumbered - -> MultiRWSS.MultiRWS r w s BriDoc -transformAlts briDoc = - MultiRWSS.withMultiStateA (AltCurPos 0 0 0 AltLineModeStateNone) - $ Memo.startEvalMemoT - $ fmap unwrapBriDocNumbered - $ rec - $ briDoc - where - -- this funtion is exponential by nature and cannot be improved in any - -- way i can think of, and if tried. (stupid StableNames.) - -- transWrap :: BriDoc -> BriDocNumbered - -- transWrap brDc = flip StateS.evalState (1::Int) - -- $ Memo.startEvalMemoT - -- $ go brDc - -- where - -- incGet = StateS.get >>= \i -> StateS.put (i+1) $> i - -- go :: BriDoc -> Memo.MemoT BriDoc BriDocNumbered (StateS.State Int) BriDocNumbered - -- go = Memo.memo $ \bdX -> do - -- i <- lift $ incGet - -- fmap (\bd' -> (i,bd')) $ case bdX of - -- BDEmpty -> return $ BDFEmpty - -- BDLit t -> return $ BDFLit t - -- BDSeq list -> BDFSeq <$> go `mapM` list - -- BDCols sig list -> BDFCols sig <$> go `mapM` list - -- BDSeparator -> return $ BDFSeparator - -- BDAddBaseY ind bd -> BDFAddBaseY ind <$> go bd - -- BDSetBaseY bd -> BDFSetBaseY <$> go bd - -- BDSetIndentLevel bd -> BDFSetIndentLevel <$> go bd - -- BDPar ind line indented -> [ BDFPar ind line' indented' - -- | line' <- go line - -- , indented' <- go indented - -- ] - -- BDAlt alts -> BDFAlt <$> go `mapM` alts -- not that this will happen - -- BDForceMultiline bd -> BDFForceMultiline <$> go bd - -- BDForceSingleline bd -> BDFForceSingleline <$> go bd - -- BDForwardLineMode bd -> BDFForwardLineMode <$> go bd - -- BDExternal k ks c t -> return $ BDFExternal k ks c t - -- BDAnnotationPrior annKey bd -> BDFAnnotationPrior annKey <$> go bd - -- BDAnnotationPost annKey bd -> BDFAnnotationRest annKey <$> go bd - -- BDLines lines -> BDFLines <$> go `mapM` lines - -- BDEnsureIndent ind bd -> BDFEnsureIndent ind <$> go bd - -- BDProhibitMTEL bd -> BDFProhibitMTEL <$> go bd - - - - rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] (MultiRWSS.MultiRWS r w (AltCurPos ': s)) BriDocNumbered - rec bdX@(brDcId, brDc) = do -#if INSERTTRACESALT - do - acp :: AltCurPos <- mGet - tellDebugMess $ "transformAlts: visiting: " ++ case brDc of - BDFAnnotationPrior annKey _ -> show (toConstr brDc, annKey, acp) - BDFAnnotationRest annKey _ -> show (toConstr brDc, annKey, acp) - _ -> show (toConstr brDc, acp) -#endif - let reWrap = (,) brDcId - -- debugAcp :: AltCurPos <- mGet - case brDc of - -- BDWrapAnnKey annKey bd -> do - -- acp <- mGet - -- mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } - -- BDWrapAnnKey annKey <$> rec bd - BDFEmpty{} -> processSpacingSimple bdX $> bdX - BDFLit{} -> processSpacingSimple bdX $> bdX - BDFSeq list -> - reWrap . BDFSeq <$> list `forM` rec - BDFCols sig list -> - reWrap . BDFCols sig <$> list `forM` rec - BDFSeparator -> processSpacingSimple bdX $> bdX - BDFAddBaseY indent bd -> do - acp <- mGet - indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - let indAdd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> indAmount - BrIndentSpecial i -> i - mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd } - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indent acp } - return $ case indent of - BrIndentNone -> r - BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r - BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r - BDFBaseYPushCur bd -> do - acp <- mGet - mSet $ acp { _acp_indent = _acp_line acp } - r <- rec bd - return $ reWrap $ BDFBaseYPushCur r - BDFBaseYPop bd -> do - acp <- mGet - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indentPrep acp } - return $ reWrap $ BDFBaseYPop r - BDFIndentLevelPushCur bd -> do - reWrap . BDFIndentLevelPushCur <$> rec bd - BDFIndentLevelPop bd -> do - reWrap . BDFIndentLevelPop <$> rec bd - BDFPar indent sameLine indented -> do - indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - let indAdd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> indAmount - BrIndentSpecial i -> i - acp <- mGet - let ind = _acp_indent acp + _acp_indentPrep acp + indAdd - mSet $ acp - { _acp_indent = ind - , _acp_indentPrep = 0 - } - sameLine' <- rec sameLine - mModify $ \acp' -> acp' - { _acp_line = ind - , _acp_indent = ind - } - indented' <- rec indented - return $ reWrap $ BDFPar indent sameLine' indented' - BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a - -- possibility, but i will prefer a - -- fail-early approach; BDEmpty does not - -- make sense semantically for Alt[]. - BDFAlt alts -> do - altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack - case altChooser of - AltChooserSimpleQuick -> do - rec $ head alts - AltChooserShallowBest -> do - spacings <- alts `forM` getSpacing - acp <- mGet - let lineCheck LineModeInvalid = False - lineCheck (LineModeValid (VerticalSpacing _ p _)) = - case _acp_forceMLFlag acp of - AltLineModeStateNone -> True - AltLineModeStateForceSL{} -> p == VerticalSpacingParNone - AltLineModeStateForceML{} -> p /= VerticalSpacingParNone - AltLineModeStateContradiction -> False - lineCheck _ = error "ghc exhaustive check is insufficient" - lconf <- _conf_layout <$> mAsk -#if INSERTTRACESALT - tellDebugMess $ "considering options with " ++ show (length alts, acp) -#endif - let options = -- trace ("considering options:" ++ show (length alts, acp)) $ - (zip spacings alts - <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) - ( hasSpace1 lconf acp vs && lineCheck vs, bd)) -#if INSERTTRACESALT - zip spacings options `forM_` \(vs, (_, bd)) -> - tellDebugMess $ " " ++ "spacing=" ++ show vs - ++ ",hasSpace=" ++ show (hasSpace1 lconf acp vs) - ++ ",lineCheck=" ++ show (lineCheck vs) - ++ " " ++ show (toConstr bd) -#endif - id -- $ (fmap $ \x -> traceShow (briDocToDoc x) x) - $ rec - $ fromMaybe (-- trace ("choosing last") $ - List.last alts) - $ Data.List.Extra.firstJust (\(_i::Int, (b,x)) -> - [ -- traceShow ("choosing option " ++ show i) $ - x - | b - ]) - $ zip [1..] options - AltChooserBoundedSearch limit -> do - spacings <- alts `forM` getSpacings limit - acp <- mGet - let lineCheck (VerticalSpacing _ p _) = - case _acp_forceMLFlag acp of - AltLineModeStateNone -> True - AltLineModeStateForceSL{} -> p == VerticalSpacingParNone - AltLineModeStateForceML{} -> p /= VerticalSpacingParNone - AltLineModeStateContradiction -> False - lconf <- _conf_layout <$> mAsk -#if INSERTTRACESALT - tellDebugMess $ "considering options with " ++ show (length alts, acp) -#endif - let options = -- trace ("considering options:" ++ show (length alts, acp)) $ - (zip spacings alts - <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) - ( any (hasSpace2 lconf acp) vs - && any lineCheck vs, bd)) - let checkedOptions :: [Maybe (Int, BriDocNumbered)] = - zip [1..] options <&> (\(i, (b,x)) -> [ (i, x) | b ]) -#if INSERTTRACESALT - zip spacings options `forM_` \(vs, (_, bd)) -> - tellDebugMess $ " " ++ "spacing=" ++ show vs - ++ ",hasSpace=" ++ show (hasSpace2 lconf acp <$> vs) - ++ ",lineCheck=" ++ show (lineCheck <$> vs) - ++ " " ++ show (toConstr bd) - tellDebugMess $ " " ++ show (Data.Maybe.mapMaybe (fmap fst) checkedOptions) -#endif - id -- $ (fmap $ \x -> traceShow (briDocToDoc x) x) - $ rec - $ fromMaybe (-- trace ("choosing last") $ - List.last alts) - $ Data.List.Extra.firstJust (fmap snd) checkedOptions - BDFForceMultiline bd -> do - acp <- mGet - x <- do - mSet $ mergeLineMode acp (AltLineModeStateForceML False) - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFForceSingleline bd -> do - acp <- mGet - x <- do - mSet $ mergeLineMode acp AltLineModeStateForceSL - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFForwardLineMode bd -> do - acp <- mGet - x <- do - mSet $ acp { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp } - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFExternal{} -> processSpacingSimple bdX $> bdX - BDFAnnotationPrior annKey bd -> do - acp <- mGet - mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } - bd' <- rec bd - return $ reWrap $ BDFAnnotationPrior annKey bd' - BDFAnnotationRest annKey bd -> - reWrap . BDFAnnotationRest annKey <$> rec bd - BDFAnnotationKW annKey kw bd -> - reWrap . BDFAnnotationKW annKey kw <$> rec bd - BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. - BDFLines (l:lr) -> do - ind <- _acp_indent <$> mGet - l' <- rec l - lr' <- lr `forM` \x -> do - mModify $ \acp -> acp - { _acp_line = ind - , _acp_indent = ind - } - rec x - return $ reWrap $ BDFLines (l':lr') - BDFEnsureIndent indent bd -> do - acp <- mGet - indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - let indAdd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> indAmount - BrIndentSpecial i -> i - mSet $ acp { _acp_indentPrep = 0 -- TODO: i am not sure this is valid, - -- in general. - , _acp_indent = _acp_indent acp + indAdd - , _acp_line = _acp_line acp + indAdd - } - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indent acp } - return $ case indent of - BrIndentNone -> r - BrIndentRegular -> reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r - BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r - BDFNonBottomSpacing bd -> rec bd - BDFSetParSpacing bd -> rec bd - BDFForceParSpacing bd -> rec bd - BDFProhibitMTEL bd -> - reWrap . BDFProhibitMTEL <$> rec bd - BDFDebug s bd -> do - acp :: AltCurPos <- mGet - tellDebugMess $ "transformAlts: BDFDEBUG " ++ s ++ " (node-id=" ++ show brDcId ++ "): acp=" ++ show acp - reWrap . BDFDebug s <$> rec bd - processSpacingSimple :: (MonadMultiReader - Config m, - MonadMultiState AltCurPos m, MonadMultiWriter (Seq String) m) => BriDocNumbered -> m () - processSpacingSimple bd = getSpacing bd >>= \case - LineModeInvalid -> error "processSpacingSimple inv" - LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do - acp <- mGet - mSet $ acp { _acp_line = _acp_line acp + i } - LineModeValid (VerticalSpacing _ _ _) -> error "processSpacingSimple par" - _ -> error "ghc exhaustive check is insufficient" - hasSpace1 :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool - hasSpace1 _ _ LineModeInvalid = False - hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs - hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" - hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool - hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) - hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) - && indent + indentPrep + par <= confUnpack (_lconfig_cols lconf) - hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) - -getSpacing - :: forall m - . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) - => BriDocNumbered - -> m (LineModeValidity VerticalSpacing) -getSpacing !bridoc = rec bridoc - where - rec :: BriDocNumbered -> m (LineModeValidity VerticalSpacing) - rec (brDcId, brDc) = do - config <- mAsk - let colMax = config & _conf_layout & _lconfig_cols & confUnpack - result <- case brDc of - -- BDWrapAnnKey _annKey bd -> rec bd - BDFEmpty -> - return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False - BDFLit t -> - return $ LineModeValid $ VerticalSpacing (Text.length t) VerticalSpacingParNone False - BDFSeq list -> - sumVs <$> rec `mapM` list - BDFCols _sig list -> sumVs <$> rec `mapM` list - BDFSeparator -> - return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False - BDFAddBaseY indent bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - { _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - } - BDFBaseYPushCur bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - -- We leave par as-is, even though it technically is not - -- accurate (in general). - -- the reason is that we really want to _keep_ it Just if it is - -- just so we properly communicate the is-multiline fact. - -- An alternative would be setting to (Just 0). - { _vs_sameLine = max (_vs_sameLine vs) - (case _vs_paragraph vs of - VerticalSpacingParNone -> 0 - VerticalSpacingParSome i -> i - VerticalSpacingParAlways i -> min colMax i) - , _vs_paragraph = VerticalSpacingParAlways 0 - } - BDFBaseYPop bd -> rec bd - BDFIndentLevelPushCur bd -> rec bd - BDFIndentLevelPop bd -> rec bd - BDFPar BrIndentNone sameLine indented -> do - mVs <- rec sameLine - mIndSp <- rec indented - return - $ [ VerticalSpacing lsp pspResult parFlagResult - | VerticalSpacing lsp mPsp _ <- mVs - , indSp <- mIndSp - , lineMax <- getMaxVS $ mIndSp - , let pspResult = case mPsp of - VerticalSpacingParSome psp -> VerticalSpacingParSome $ max psp lineMax - VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax - VerticalSpacingParAlways psp -> VerticalSpacingParAlways $ max psp lineMax - , let parFlagResult = mPsp == VerticalSpacingParNone - && _vs_paragraph indSp == VerticalSpacingParNone - && _vs_parFlag indSp - ] - BDFPar{} -> error "BDPar with indent in getSpacing" - BDFAlt [] -> error "empty BDAlt" - BDFAlt (alt:_) -> rec alt - BDFForceMultiline bd -> rec bd - BDFForceSingleline bd -> do - mVs <- rec bd - return $ mVs >>= _vs_paragraph .> \case - VerticalSpacingParNone -> mVs - _ -> LineModeInvalid - BDFForwardLineMode bd -> rec bd - BDFExternal{} -> return - $ LineModeValid - $ VerticalSpacing 999 VerticalSpacingParNone False - BDFAnnotationPrior _annKey bd -> rec bd - BDFAnnotationKW _annKey _kw bd -> rec bd - BDFAnnotationRest _annKey bd -> rec bd - BDFLines [] -> return - $ LineModeValid - $ VerticalSpacing 0 VerticalSpacingParNone False - BDFLines ls@(_:_) -> do - lSps@(mVs:_) <- rec `mapM` ls - return $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False - | VerticalSpacing lsp _ _ <- mVs - , lineMax <- getMaxVS $ maxVs $ lSps - ] - BDFEnsureIndent indent bd -> do - mVs <- rec bd - let addInd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - BrIndentSpecial i -> i - return $ mVs <&> \(VerticalSpacing lsp psp pf) -> - VerticalSpacing (lsp + addInd) psp pf - BDFNonBottomSpacing bd -> do - mVs <- rec bd - return - $ mVs - <|> LineModeValid (VerticalSpacing 0 - (VerticalSpacingParAlways colMax) - False) - BDFSetParSpacing bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs { _vs_parFlag = True } - BDFForceParSpacing bd -> do - mVs <- rec bd - return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] - BDFProhibitMTEL bd -> rec bd - BDFDebug s bd -> do - r <- rec bd - tellDebugMess $ "getSpacing: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): mVs=" ++ show r - return r -#if INSERTTRACESGETSPACING - tellDebugMess $ "getSpacing: visiting: " ++ show (toConstr $ brDc) ++ " -> " ++ show result -#endif - return result - maxVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing - maxVs = foldl' - (liftM2 (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> - VerticalSpacing (max x1 y1) (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome j, VerticalSpacingParAlways i) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ max x y) False)) - (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False) - sumVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing - sumVs sps = foldl' (liftM2 go) initial sps - where - go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing - (x1 + y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ x + y) - x3 - singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone - singleline _ = False - isPar (LineModeValid x) = _vs_parFlag x - isPar _ = False - parFlag = case sps of - [] -> True - _ -> all singleline (List.init sps) && isPar (List.last sps) - initial = LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone parFlag - getMaxVS :: LineModeValidity VerticalSpacing -> LineModeValidity Int - getMaxVS = fmap $ \(VerticalSpacing x1 x2 _) -> x1 `max` case x2 of - VerticalSpacingParSome i -> i - VerticalSpacingParNone -> 0 - VerticalSpacingParAlways i -> i - -getSpacings - :: forall m - . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) - => Int - -> BriDocNumbered - -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] -getSpacings limit bridoc = preFilterLimit <$> rec bridoc - where - preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing] - preFilterLimit = take (3*limit) - memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v - memoWithKey k v = Memo.memo (const v) k - rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] - rec (brDcId, brdc) = memoWithKey brDcId $ do - config <- mAsk - let colMax = config & _conf_layout & _lconfig_cols & confUnpack - let hasOkColCount (VerticalSpacing lsp psp _) = - lsp <= colMax && case psp of - VerticalSpacingParNone -> True - VerticalSpacingParSome i -> i <= colMax - VerticalSpacingParAlways{} -> True - let filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing] - filterAndLimit = take limit - . filter hasOkColCount - . preFilterLimit -- we need to limit here in case - -- that the input list is - -- _large_ with a similarly _large_ - -- prefix not passing hasOkColCount - -- predicate. - -- TODO: 3 is arbitrary. - result <- case brdc of - -- BDWrapAnnKey _annKey bd -> rec bd - BDFEmpty -> - return $ [VerticalSpacing 0 VerticalSpacingParNone False] - BDFLit t -> - return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] - BDFSeq list -> - fmap sumVs . sequence . fmap filterAndLimit <$> rec `mapM` list - BDFCols _sig list -> - fmap sumVs . sequence . fmap filterAndLimit <$> rec `mapM` list - BDFSeparator -> - return $ [VerticalSpacing 1 VerticalSpacingParNone False] - BDFAddBaseY indent bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - { _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - } - BDFBaseYPushCur bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - -- We leave par as-is, even though it technically is not - -- accurate (in general). - -- the reason is that we really want to _keep_ it Just if it is - -- just so we properly communicate the is-multiline fact. - -- An alternative would be setting to (Just 0). - { _vs_sameLine = max (_vs_sameLine vs) - (case _vs_paragraph vs of - VerticalSpacingParNone -> 0 - VerticalSpacingParSome i -> i - VerticalSpacingParAlways i -> min colMax i) - , _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParSome i -> VerticalSpacingParAlways i -- TODO: is this correct? - VerticalSpacingParAlways i -> VerticalSpacingParAlways i - } - BDFBaseYPop bd -> rec bd - BDFIndentLevelPushCur bd -> rec bd - BDFIndentLevelPop bd -> rec bd - BDFPar BrIndentNone sameLine indented -> do - mVss <- filterAndLimit <$> rec sameLine - indSps <- filterAndLimit <$> rec indented - let mVsIndSp = take limit - $ [ (x,y) - | x<-mVss - , y<-indSps - ] - return $ mVsIndSp <&> - \(VerticalSpacing lsp mPsp _, indSp) -> - VerticalSpacing - lsp - (case mPsp of - VerticalSpacingParSome psp -> - VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO - VerticalSpacingParNone -> spMakePar indSp - VerticalSpacingParAlways psp -> - VerticalSpacingParAlways $ max psp $ getMaxVS indSp) - ( mPsp == VerticalSpacingParNone - && _vs_paragraph indSp == VerticalSpacingParNone - && _vs_parFlag indSp - ) - - BDFPar{} -> error "BDPar with indent in getSpacing" - BDFAlt [] -> error "empty BDAlt" - -- BDAlt (alt:_) -> rec alt - BDFAlt alts -> do - r <- rec `mapM` alts - return $ filterAndLimit =<< r - BDFForceMultiline bd -> rec bd - BDFForceSingleline bd -> do - mVs <- filterAndLimit <$> rec bd - return $ filter ((==VerticalSpacingParNone) . _vs_paragraph) mVs - BDFForwardLineMode bd -> rec bd - BDFExternal{} -> - return $ [] -- yes, we just assume that we cannot properly layout - -- this. - BDFAnnotationPrior _annKey bd -> rec bd - BDFAnnotationKW _annKey _kw bd -> rec bd - BDFAnnotationRest _annKey bd -> rec bd - BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] - BDFLines ls@(_:_) -> do - -- we simply assume that lines is only used "properly", i.e. in - -- such a way that the first line can be treated "as a part of the - -- paragraph". That most importantly means that Lines should never - -- be inserted anywhere but at the start of the line. A - -- counterexample would be anything like Seq[Lit "foo", Lines]. - lSpss <- fmap filterAndLimit <$> rec `mapM` ls - let worbled = fmap reverse - $ sequence - $ reverse - $ lSpss - summed = worbled <&> \lSps@(lSp1:_) -> - VerticalSpacing (_vs_sameLine lSp1) - (spMakePar $ maxVs lSps) - False - return $ summed - -- lSpss@(mVs:_) <- rec `mapM` ls - -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only - -- -- consider the first alternative for the - -- -- line's spacings. - -- -- also i am not sure if always including - -- -- the first line length in the paragraph - -- -- length gives the desired results. - -- -- it is the safe path though, for now. - -- [] -> [] - -- (lSps:_) -> mVs <&> \(VerticalSpacing lsp _) -> - -- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps - BDFEnsureIndent indent bd -> do - mVs <- rec bd - let addInd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - BrIndentSpecial i -> i - return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> - VerticalSpacing (lsp + addInd) psp parFlag - BDFNonBottomSpacing bd -> do - mVs <- rec bd - return $ if null mVs - then [VerticalSpacing 0 (VerticalSpacingParAlways colMax) False] - else mVs <&> \vs -> vs - { _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> VerticalSpacingParAlways i - VerticalSpacingParSome i -> VerticalSpacingParAlways i - } - BDFSetParSpacing bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs { _vs_parFlag = True } - BDFForceParSpacing bd -> do - mVs <- preFilterLimit <$> rec bd - return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] - BDFProhibitMTEL bd -> rec bd - BDFDebug s bd -> do - r <- rec bd - tellDebugMess $ "getSpacings: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): vs=" ++ show (take 9 r) - return r -#if INSERTTRACESGETSPACING - case brdc of - BDFAnnotationPrior{} -> return () - BDFAnnotationRest{} -> return () - _ -> mTell $ Seq.fromList ["getSpacing: visiting: " - ++ show {-(toConstr $ brdc)-} (briDocToDoc $ unwrapBriDocNumbered (0, brdc)) - , " -> " - ++ show (take 9 result) - ] -#endif - return result - maxVs :: [VerticalSpacing] -> VerticalSpacing - maxVs = foldl' - (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> - VerticalSpacing - (max x1 y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ max x y) - False) - (VerticalSpacing 0 VerticalSpacingParNone False) - sumVs :: [VerticalSpacing] -> VerticalSpacing - sumVs sps = foldl' go initial sps - where - go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing - (x1 + y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ x + y) - x3 - singleline x = _vs_paragraph x == VerticalSpacingParNone - isPar x = _vs_parFlag x - parFlag = case sps of - [] -> True - _ -> all singleline (List.init sps) && isPar (List.last sps) - initial = VerticalSpacing 0 VerticalSpacingParNone parFlag - getMaxVS :: VerticalSpacing -> Int - getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of - VerticalSpacingParSome i -> i - VerticalSpacingParNone -> 0 - VerticalSpacingParAlways i -> i - spMakePar :: VerticalSpacing -> VerticalSpacingPar - spMakePar (VerticalSpacing x1 x2 _) = case x2 of - VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i - VerticalSpacingParNone -> VerticalSpacingParSome $ x1 - VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i - - --- note that this is not total, and cannot be with that exact signature. -mergeIndents :: BrIndent -> BrIndent -> BrIndent -mergeIndents BrIndentNone x = x -mergeIndents x BrIndentNone = x -mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j) -mergeIndents _ _ = error "mergeIndents" - - --- TODO: move to uniplate upstream? --- aka `transform` -transformUp :: Uniplate.Uniplate on => (on -> on) -> (on -> on) -transformUp f = g where g = f . Uniplate.descend g -_transformDown :: Uniplate.Uniplate on => (on -> on) -> (on -> on) -_transformDown f = g where g = Uniplate.descend g . f -transformDownMay :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) -transformDownMay f = g where g x = maybe x (Uniplate.descend g) $ f x -_transformDownRec :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) -_transformDownRec f = g where g x = maybe (Uniplate.descend g x) g $ f x - - -transformSimplifyFloating :: BriDoc -> BriDoc -transformSimplifyFloating = stepBO .> stepFull - -- note that semantically, stepFull is completely sufficient. - -- but the bottom-up switch-to-top-down-on-match transformation has much - -- better complexity. - -- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence - -- the push/pop cases would need to be copied over - where - descendPrior = transformDownMay $ \case - -- prior floating in - BDAnnotationPrior annKey1 (BDPar ind line indented) -> - Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented - BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> - Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDLines (l:lr)) -> - Just $ BDLines (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> - Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x - BDAnnotationPrior annKey1 (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationPrior annKey1 x - _ -> Nothing - descendRest = transformDownMay $ \case - -- post floating in - BDAnnotationRest annKey1 (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationRest annKey1 indented - BDAnnotationRest annKey1 (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] - BDAnnotationRest annKey1 (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x - BDAnnotationRest annKey1 (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationRest annKey1 x - _ -> Nothing - descendKW = transformDownMay $ \case - -- post floating in - BDAnnotationKW annKey1 kw (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented - BDAnnotationKW annKey1 kw (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] - BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x - BDAnnotationKW annKey1 kw (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationKW annKey1 kw x - _ -> Nothing - descendBYPush = transformDownMay $ \case - BDBaseYPushCur (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) - BDBaseYPushCur (BDDebug s x) -> - Just $ BDDebug s (BDBaseYPushCur x) - _ -> Nothing - descendBYPop = transformDownMay $ \case - BDBaseYPop (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) - BDBaseYPop (BDDebug s x) -> - Just $ BDDebug s (BDBaseYPop x) - _ -> Nothing - descendILPush = transformDownMay $ \case - BDIndentLevelPushCur (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) - BDIndentLevelPushCur (BDDebug s x) -> - Just $ BDDebug s (BDIndentLevelPushCur x) - _ -> Nothing - descendILPop = transformDownMay $ \case - BDIndentLevelPop (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) - BDIndentLevelPop (BDDebug s x) -> - Just $ BDDebug s (BDIndentLevelPop x) - _ -> Nothing - descendAddB = transformDownMay $ \case - -- AddIndent floats into Lines. - BDAddBaseY BrIndentNone x -> - Just x - BDAddBaseY indent (BDLines lines) -> - Just $ BDLines $ BDAddBaseY indent <$> lines - -- AddIndent floats into last column - BDAddBaseY indent (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] - -- merge AddIndent and Par - BDAddBaseY ind1 (BDPar ind2 line indented) -> - Just $ BDPar (mergeIndents ind1 ind2) line indented - BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> - Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) - BDAddBaseY ind (BDAnnotationRest annKey1 x) -> - Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x) - BDAddBaseY ind (BDAnnotationKW annKey1 kw x) -> - Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) - BDAddBaseY ind (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] - BDAddBaseY _ lit@BDLit{} -> - Just $ lit - BDAddBaseY ind (BDBaseYPushCur x) -> - Just $ BDBaseYPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDBaseYPop x) -> - Just $ BDBaseYPop (BDAddBaseY ind x) - BDAddBaseY ind (BDDebug s x) -> - Just $ BDDebug s (BDAddBaseY ind x) - _ -> Nothing - stepBO :: BriDoc -> BriDoc - stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ - transformUp f - where - f = \case - x@BDAnnotationPrior{} -> descendPrior x - x@BDAnnotationKW{} -> descendKW x - x@BDAnnotationRest{} -> descendRest x - x@BDAddBaseY{} -> descendAddB x - x@BDBaseYPushCur{} -> descendBYPush x - x@BDBaseYPop{} -> descendBYPop x - x@BDIndentLevelPushCur{} -> descendILPush x - x@BDIndentLevelPop{} -> descendILPop x - x -> x - stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ - Uniplate.rewrite $ \case - -- AddIndent floats into Lines. - BDAddBaseY BrIndentNone x -> - Just $ x - BDAddBaseY indent (BDLines lines) -> - Just $ BDLines $ BDAddBaseY indent <$> lines - -- AddIndent floats into last column - BDAddBaseY indent (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] - BDAddBaseY ind (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] - -- merge AddIndent and Par - BDAddBaseY ind1 (BDPar ind2 line indented) -> - Just $ BDPar (mergeIndents ind1 ind2) line indented - BDAddBaseY _ lit@BDLit{} -> - Just $ lit - BDAddBaseY ind (BDBaseYPushCur x) -> - Just $ BDBaseYPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDBaseYPop x) -> - Just $ BDBaseYPop (BDAddBaseY ind x) - -- prior floating in - BDAnnotationPrior annKey1 (BDPar ind line indented) -> - Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented - BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> - Just $ BDSeq ((BDAnnotationPrior annKey1 l):lr) - BDAnnotationPrior annKey1 (BDLines (l:lr)) -> - Just $ BDLines ((BDAnnotationPrior annKey1 l):lr) - BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> - Just $ BDCols sig ((BDAnnotationPrior annKey1 l):lr) - -- EnsureIndent float-in - -- BDEnsureIndent indent (BDCols sig (col:colr)) -> - -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) - -- not sure if the following rule is necessary; tests currently are - -- unaffected. - -- BDEnsureIndent indent (BDLines lines) -> - -- Just $ BDLines $ BDEnsureIndent indent <$> lines - -- post floating in - BDAnnotationRest annKey1 (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationRest annKey1 indented - BDAnnotationRest annKey1 (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] - _ -> Nothing - -transformSimplifyPar :: BriDoc -> BriDoc -transformSimplifyPar = transformUp $ \case - -- BDPar BrIndentNone line1 line2 -> Just $ BDLines [line1, line2] - -- BDPar line indented -> - -- Just $ BDLines [line, indented] - -- BDPar ind1 (BDPar ind2 line p1) p2 | ind1==ind2 -> - -- Just $ BDPar ind1 line (BDLines [p1, p2]) - x@(BDPar _ (BDPar _ BDPar{} _) _) -> x - BDPar ind1 (BDPar ind2 line p1) (BDLines indenteds) -> - BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds)) - BDPar ind1 (BDPar ind2 line p1) p2 -> - BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2]) - BDLines lines | any ( \case - BDLines{} -> True - BDEmpty{} -> True - _ -> False - ) - lines -> case go lines of - [] -> BDEmpty - [x] -> x - xs -> BDLines xs - where - go = (=<<) $ \case - BDLines l -> go l - BDEmpty -> [] - x -> [x] - BDLines [] -> BDEmpty - BDLines [x] -> x - -- BDCols sig cols | BDPar ind line indented <- List.last cols -> - -- Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented - -- BDPar BrIndentNone line indented -> - -- Just $ BDLines [line, indented] - BDEnsureIndent BrIndentNone x -> x - x -> x - -isNotEmpty :: BriDoc -> Bool -isNotEmpty BDEmpty = False -isNotEmpty _ = True - -transformSimplifyColumns :: BriDoc -> BriDoc -transformSimplifyColumns = Uniplate.rewrite $ \case - -- BDWrapAnnKey annKey bd -> - -- BDWrapAnnKey annKey $ transformSimplify bd - BDEmpty -> Nothing - BDLit{} -> Nothing - BDSeq list | any (\case BDSeq{} -> True - BDEmpty{} -> True - _ -> False) list -> Just $ BDSeq $ - filter isNotEmpty list >>= \case - BDSeq l -> l - x -> [x] - BDSeq (BDCols sig1 cols1@(_:_):rest) -> - Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)]) - BDLines lines | any (\case BDLines{} -> True - BDEmpty{} -> True - _ -> False) lines -> - Just $ BDLines $ filter isNotEmpty $ lines >>= \case - BDLines l -> l - x -> [x] - -- prior floating in - BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> - Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDLines (l:lr)) -> - Just $ BDLines (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> - Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) - -- post floating in - BDAnnotationRest annKey1 (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] - BDAnnotationKW annKey1 kw (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] - -- ensureIndent float-in - -- not sure if the following rule is necessary; tests currently are - -- unaffected. - -- BDEnsureIndent indent (BDLines lines) -> - -- Just $ BDLines $ BDEnsureIndent indent <$> lines - -- matching col special transformation - BDCols sig1 cols1@(_:_) - | BDLines lines@(_:_:_) <- List.last cols1 - , BDCols sig2 cols2 <- List.last lines - , sig1==sig2 -> - Just $ BDLines - [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] - , BDCols sig2 cols2 - ] - BDCols sig1 cols1@(_:_) - | BDLines lines@(_:_:_) <- List.last cols1 - , BDEnsureIndent _ (BDCols sig2 cols2) <- List.last lines - , sig1==sig2 -> - Just $ BDLines - [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] - , BDCols sig2 cols2 - ] - BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1==sig2 -> - Just $ BDAddBaseY ind (BDLines [col1, col2]) - BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _):rest)) - | sig1==sig2 -> - Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest) - BDPar ind (BDLines lines1) col2@(BDCols sig2 _) - | BDCols sig1 _ <- List.last lines1 - , sig1==sig2 -> - Just $ BDAddBaseY ind (BDLines $ lines1 ++ [col2]) - BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _):rest)) - | BDCols sig1 _ <- List.last lines1 - , sig1==sig2 -> - Just $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest) - -- BDPar ind1 (BDCols sig1 cols1) (BDPar ind2 line (BDCols sig2 cols2)) - -- | sig1==sig2 -> - -- Just $ BDPar - -- ind1 - -- (BDLines [BDCols sig1 cols1, BDCols sig]) - BDCols sig1 cols | BDPar _ind line (BDCols sig2 cols2) <- List.last cols - , sig1==sig2 -> - Just $ BDLines - [ BDCols sig1 (List.init cols ++ [line]) - , BDCols sig2 cols2 - ] - BDCols sig1 cols | BDPar ind line (BDLines lines) <- List.last cols - , BDCols sig2 cols2 <- List.last lines - , sig1==sig2 -> - Just $ BDLines - [ BDCols sig1 $ List.init cols ++ [BDPar ind line (BDLines $ List.init lines)] - , BDCols sig2 cols2 - ] - BDLines [x] -> Just $ x - BDLines [] -> Just $ BDEmpty - BDSeq{} -> Nothing - BDCols{} -> Nothing - BDSeparator -> Nothing - BDAddBaseY{} -> Nothing - BDBaseYPushCur{} -> Nothing - BDBaseYPop{} -> Nothing - BDIndentLevelPushCur{} -> Nothing - BDIndentLevelPop{} -> Nothing - BDPar{} -> Nothing - BDAlt{} -> Nothing - BDForceMultiline{} -> Nothing - BDForceSingleline{} -> Nothing - BDForwardLineMode{} -> Nothing - BDExternal{} -> Nothing - BDLines{} -> Nothing - BDAnnotationPrior{} -> Nothing - BDAnnotationKW{} -> Nothing - BDAnnotationRest{} -> Nothing - BDEnsureIndent{} -> Nothing - BDProhibitMTEL{} -> Nothing - BDSetParSpacing{} -> Nothing - BDForceParSpacing{} -> Nothing - BDDebug{} -> Nothing - BDNonBottomSpacing x -> Just x - --- prepare layouting by translating BDPar's, replacing them with Indents and --- floating those in. This gives a more clear picture of what exactly is --- affected by what amount of indentation. -transformSimplifyIndent :: BriDoc -> BriDoc -transformSimplifyIndent = Uniplate.rewrite $ \case - BDPar ind (BDLines lines) indented -> - Just $ BDEnsureIndent ind $ BDLines $ lines ++ [indented] - BDPar ind (BDCols sig cols) indented -> - Just $ BDCols sig (List.init cols ++ [BDPar ind (List.last cols) indented]) - BDPar BrIndentNone _ _ -> Nothing - BDPar ind x indented -> - Just $ BDPar BrIndentNone (BDAddBaseY ind x) (BDEnsureIndent ind indented) - -- BDPar ind x indented -> - -- Just $ BDLines - -- [ BDAddBaseY ind x - -- , BDEnsureIndent ind indented - -- ] - BDLines lines | any ( \case - BDLines{} -> True - BDEmpty{} -> True - _ -> False - ) - lines -> - Just $ BDLines $ filter isNotEmpty $ lines >>= \case - BDLines l -> l - x -> [x] - BDLines [l] -> Just l - BDAddBaseY i (BDAnnotationPrior k x) -> - Just $ BDAnnotationPrior k (BDAddBaseY i x) - BDAddBaseY i (BDAnnotationKW k kw x) -> - Just $ BDAnnotationKW k kw (BDAddBaseY i x) - BDAddBaseY i (BDAnnotationRest k x) -> - Just $ BDAnnotationRest k (BDAddBaseY i x) - BDAddBaseY i (BDSeq l) -> - Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l] - BDAddBaseY i (BDCols sig l) -> - Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l] - BDAddBaseY _ lit@BDLit{} -> Just lit - - _ -> Nothing - - -briDocLineLength :: BriDoc -> Int -briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc - -- the state encodes whether a separate 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 - -layoutBriDocM - :: forall w m - . ( m ~ MultiRWSS.MultiRWST - '[Config, ExactPrint.Types.Anns] - w - '[LayoutState] - Identity - , ContainsType Text.Builder.Builder w - , ContainsType [LayoutError] w - , ContainsType (Seq String) w - ) - => 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.Types.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 - where - -- alignColsPar :: [BriDoc] - -- -> m () - -- alignColsPar l = colInfos `forM_` \colInfo -> do - -- layoutWriteNewlineBlock - -- processInfo (_cbs_map finalState) colInfo - -- where - -- (colInfos, finalState) = StateS.runState (mergeBriDocs l) (ColBuildState IntMapS.empty 0) - alignColsLines :: [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 - sequence_ $ List.intersperse layoutWriteEnsureNewlineBlock - $ colInfos <&> processInfo (processedMap curX colMax) - 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 - processedMap :: Int -> Int -> ColMap2 - processedMap curX colMax = fix $ \result -> - _cbs_map finalState <&> \colSpacingss -> - let colss = colSpacingss <&> \spss -> case reverse spss of - [] -> [] - (xN:xR) -> reverse $ fLast 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 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) - briDocToColInfo :: BriDoc -> StateS.State ColBuildState ColInfo - briDocToColInfo = \case - BDCols sig list -> withAlloc $ \ind -> do - subInfos <- mapM briDocToColInfo list - 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 - - 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 lastInfo bd - infor <- mergeBriDocsW info bdr - return $ info : infor - - mergeInfoBriDoc :: ColInfo - -> BriDoc - -> StateS.StateT ColBuildState Identity ColInfo - mergeInfoBriDoc ColInfoStart = briDocToColInfo - mergeInfoBriDoc ColInfoNo{} = briDocToColInfo - mergeInfoBriDoc (ColInfo infoInd infoSig subLengthsInfos) = \case - bd@(BDCols colSig subDocs) - | infoSig == colSig - && length subLengthsInfos == length subDocs -> do - infos <- zip (snd <$> subLengthsInfos) subDocs - `forM` uncurry mergeInfoBriDoc - 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 - (spaces Seq.|> trueSpacings) - m - } - return $ ColInfo infoInd colSig (zip curLengths infos) - | otherwise -> briDocToColInfo bd - bd -> return $ ColInfoNo bd - - withAlloc :: (ColIndex -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo)) - -> StateS.State ColBuildState ColInfo - withAlloc 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 space $ _cbs_map c } - return info - - processInfo :: 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 :: ColInfo -> m () - processInfoIgnore = \case - ColInfoStart -> error "should not happen (TM)" - ColInfoNo doc -> layoutBriDocM doc - ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore) - -type ColIndex = Int - -data ColumnSpacing - = ColumnSpacingLeaf Int - | ColumnSpacingRef Int Int - -type ColumnBlock a = [a] -type ColumnBlocks a = Seq [a] -type ColMap1 = IntMapL.IntMap {- ColIndex -} (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 - } diff --git a/src/Language/Haskell/Brittany/Config.hs b/src/Language/Haskell/Brittany/Config.hs index e42eadd..0f08e9e 100644 --- a/src/Language/Haskell/Brittany/Config.hs +++ b/src/Language/Haskell/Brittany/Config.hs @@ -16,57 +16,19 @@ where #include "prelude.inc" -import DynFlags ( getDynFlags ) -import GHC ( runGhc, GenLocated(L), moduleNameString ) -import qualified Parser as GHC -import qualified ApiAnnotation as GHC -import qualified DynFlags as GHC -import qualified FastString as GHC -import qualified GHC as GHC hiding (parseModule) -import qualified HeaderInfo as GHC -import qualified Lexer as GHC -import qualified MonadUtils as GHC -import qualified Outputable as GHC -import qualified Parser as GHC -import qualified SrcLoc as GHC -import qualified StringBuffer as GHC -import RdrName ( RdrName(..) ) -import Control.Monad.IO.Class -import GHC.Paths (libdir) -import HsSyn -import SrcLoc ( SrcSpan, Located ) --- import Outputable ( ppr, runSDoc ) --- import DynFlags ( unsafeGlobalDynFlags ) - -import ApiAnnotation ( AnnKeywordId(..) ) -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 qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers -import qualified Language.Haskell.GHC.ExactPrint.Preprocess as ExactPrint.Preprocess -import qualified Data.Map as Map - -import qualified Data.Text.Lazy.Builder as Text.Builder - -import qualified Debug.Trace as Trace - -import Language.Haskell.Brittany.Types -import Language.Haskell.Brittany.LayoutBasics - --- import Data.Aeson -import GHC.Generics -import Control.Lens +import Language.Haskell.Brittany.Types +import Language.Haskell.Brittany.LayouterBasics import qualified Data.Yaml -import UI.Butcher.Monadic +import UI.Butcher.Monadic import qualified System.Console.CmdArgs.Explicit as CmdArgs -import Language.Haskell.Brittany.Config.Types -import Language.Haskell.Brittany.Utils +import Language.Haskell.Brittany.Config.Types +import Language.Haskell.Brittany.Utils -import Data.Coerce ( Coercible, coerce ) +import Data.Coerce ( Coercible, coerce ) diff --git a/src/Language/Haskell/Brittany/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/ExactPrintUtils.hs index 1067b1b..8749b93 100644 --- a/src/Language/Haskell/Brittany/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/ExactPrintUtils.hs @@ -12,53 +12,31 @@ where #include "prelude.inc" -import DynFlags ( getDynFlags ) -import GHC ( runGhc, GenLocated(L), moduleNameString ) -import qualified Parser as GHC -import qualified ApiAnnotation as GHC +import Language.Haskell.Brittany.Types +import Language.Haskell.Brittany.Config.Types +import Language.Haskell.Brittany.LayouterBasics +import Language.Haskell.Brittany.Utils + +import DynFlags ( getDynFlags ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) import qualified DynFlags as GHC -import qualified FastString as GHC import qualified GHC as GHC hiding (parseModule) -import qualified HeaderInfo as GHC -import qualified Lexer as GHC -import qualified MonadUtils as GHC -import qualified Outputable as GHC import qualified Parser as GHC import qualified SrcLoc as GHC -import qualified StringBuffer as GHC -import RdrName ( RdrName(..) ) -import Control.Monad.IO.Class -import HsSyn -import SrcLoc ( SrcSpan, Located ) import RdrName ( RdrName(..) ) -import GHC ( runGhc, GenLocated(L), moduleNameString ) -import Name -import qualified FastString -import BasicTypes +import HsSyn +import SrcLoc ( SrcSpan, Located ) +import RdrName ( RdrName(..) ) -import ApiAnnotation ( AnnKeywordId(..) ) -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Preprocess as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint import qualified Data.Generics as SYB -import qualified Data.Map as Map - -import qualified Data.Text.Lazy.Builder as Text.Builder - -import qualified Debug.Trace as Trace - -import Language.Haskell.Brittany.Types -import Language.Haskell.Brittany.Config.Types -import Language.Haskell.Brittany.LayoutBasics -import Language.Haskell.Brittany.Utils - -import DataTreePrint - parseModule diff --git a/src/Language/Haskell/Brittany/LayoutBasics.hs b/src/Language/Haskell/Brittany/LayouterBasics.hs similarity index 50% rename from src/Language/Haskell/Brittany/LayoutBasics.hs rename to src/Language/Haskell/Brittany/LayouterBasics.hs index dfd5509..d0ea1d1 100644 --- a/src/Language/Haskell/Brittany/LayoutBasics.hs +++ b/src/Language/Haskell/Brittany/LayouterBasics.hs @@ -1,45 +1,12 @@ -#define INSERTTRACES 0 - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeApplications #-} -#if !INSERTTRACES -{-# OPTIONS_GHC -Wno-redundant-constraints #-} -#endif - -module Language.Haskell.Brittany.LayoutBasics +module Language.Haskell.Brittany.LayouterBasics ( processDefault , rdrNameToText , lrdrNameToText , lrdrNameToTextAnn , lrdrNameToTextAnnTypeEqualityIsSpecial , askIndent - , layoutWriteAppend - , layoutWriteAppendMultiline - , layoutWriteNewlineBlock - , layoutWriteNewline - , layoutWriteEnsureNewlineBlock - , layoutWriteEnsureBlock - , layoutWithAddBaseCol - , layoutWithAddBaseColBlock - , layoutWithAddBaseColN - , layoutWithAddBaseColNBlock - , layoutBaseYPushCur - , layoutBaseYPop - , layoutIndentLevelPushCur - , layoutIndentLevelPop - , layoutWriteEnsureAbsoluteN - , layoutAddSepSpace - , layoutSetCommentCol - , layoutMoveToCommentPos - , layoutIndentRestorePostComment - , moveToExactAnn - , layoutWritePriorComments - , layoutWritePostComments - , layoutRemoveIndentLevelLinger , extractAllComments , filterAnns - , ppmMoveToExactLoc , docEmpty , docLit , docAlt @@ -102,9 +69,6 @@ import Language.Haskell.Brittany.Utils import RdrName ( RdrName(..) ) import GHC ( runGhc, GenLocated(L), moduleNameString ) -import qualified Outputable as GHC -import qualified DynFlags as GHC -import qualified FastString as GHC import qualified SrcLoc as GHC import SrcLoc ( SrcSpan ) import OccName ( occNameString ) @@ -114,26 +78,10 @@ import ApiAnnotation ( AnnKeywordId(..) ) import Data.Data import Data.Generics.Schemes -import Data.Generics.Aliases import DataTreePrint -import qualified Text.PrettyPrint as PP -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 @@ -228,543 +176,6 @@ lrdrNameToTextAnnTypeEqualityIsSpecial ast = do askIndent :: (MonadMultiReader Config m) => m Int askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk -layoutWriteAppend - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m - ) - => Text - -> m () -layoutWriteAppend t = do - traceLocal ("layoutWriteAppend", t) - state <- mGet - case _lstate_curYOrAddNewline state of - Right i -> do -#if INSERTTRACES - tellDebugMessShow (" inserted newlines: ", i) -#endif - 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 - } - -layoutWriteAppendSpaces - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) 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 - , MonadMultiWriter (Seq String) m - ) - => Text - -> m () -layoutWriteAppendMultiline t = do - traceLocal ("layoutWriteAppendMultiline", t) - case Text.lines t of - [] -> layoutWriteAppend t -- 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 - , MonadMultiWriter (Seq String) m - ) - => m () -layoutWriteNewlineBlock = do - traceLocal ("layoutWriteNewlineBlock") - state <- mGet - mSet $ state { _lstate_curYOrAddNewline = Right 1 - , _lstate_addSepSpace = Just $ lstate_baseY state - , _lstate_inhibitMTEL = False - } - --- 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, MonadMultiWriter (Seq String) 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 } - -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. -layoutWriteNewline - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) 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 - , _lstate_inhibitMTEL = False - } - -layoutWriteEnsureNewlineBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) 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_inhibitMTEL = False - , _lstate_commentCol = Nothing - } - -layoutWriteEnsureBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) 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 } - -layoutWriteEnsureAbsoluteN - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m - ) - => Int - -> m () -layoutWriteEnsureAbsoluteN n = do - state <- mGet - let diff = case _lstate_curYOrAddNewline state of - Left i -> n - i - 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, MonadMultiWriter (Seq String) m) - => Int - -> m () -layoutBaseYPushInternal i = do - traceLocal ("layoutBaseYPushInternal", i) - mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s } - -layoutBaseYPopInternal - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () -layoutBaseYPopInternal = do - traceLocal ("layoutBaseYPopInternal") - mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s } - -layoutIndentLevelPushInternal - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) 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, 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 - , MonadMultiWriter (Seq String) m - ) => m () -layoutRemoveIndentLevelLinger = do -#if INSERTTRACES - tellDebugMessShow ("layoutRemoveIndentLevelLinger") -#endif - mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s - } - -layoutWithAddBaseCol - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiReader Config m - , MonadMultiWriter (Seq String) m - ) - => m () - -> m () -layoutWithAddBaseCol m = do -#if INSERTTRACES - tellDebugMessShow ("layoutWithAddBaseCol") -#endif - 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 - , MonadMultiWriter (Seq String) m - ) - => m () - -> m () -layoutWithAddBaseColBlock m = do -#if INSERTTRACES - tellDebugMessShow ("layoutWithAddBaseColBlock") -#endif - 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 - , MonadMultiWriter (Seq String) m - ) - => Int - -> m () - -> m () -layoutWithAddBaseColNBlock amount m = do - traceLocal ("layoutWithAddBaseColNBlock", amount) - state <- mGet - layoutBaseYPushInternal $ lstate_baseY state + amount - layoutWriteEnsureBlock - m - layoutBaseYPopInternal - -layoutWithAddBaseColN - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m - ) - => Int - -> m () - -> m () -layoutWithAddBaseColN amount m = do -#if INSERTTRACES - tellDebugMessShow ("layoutWithAddBaseColN", amount) -#endif - state <- mGet - layoutBaseYPushInternal $ lstate_baseY state + amount - m - layoutBaseYPopInternal - -layoutBaseYPushCur - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) 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, MonadMultiWriter (Seq String) m) => m () -layoutBaseYPop = do - traceLocal ("layoutBaseYPop") - layoutBaseYPopInternal - -layoutIndentLevelPushCur - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) 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 - layoutBaseYPushInternal y - -layoutIndentLevelPop - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () -layoutIndentLevelPop = do - traceLocal ("layoutIndentLevelPop") - layoutBaseYPopInternal - 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 - , MonadMultiWriter (Seq String) m) - => m () -layoutAddSepSpace = do -#if INSERTTRACES - tellDebugMessShow ("layoutAddSepSpace") -#endif - 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 - , MonadMultiWriter (Seq String) 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.Types.DP (y, _x) = ExactPrint.Types.annEntryDelta ann - -- mModify $ \state -> state { _lstate_addNewline = Just x } - 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.Types.DeltaPos - -> m () -ppmMoveToExactLoc (ExactPrint.Types.DP (x, y)) = do - replicateM_ x $ mTell $ Text.Builder.fromString "\n" - replicateM_ y $ mTell $ Text.Builder.fromString " " - -layoutWritePriorComments - :: ( Data.Data.Data ast - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m - ) - => GenLocated SrcSpan ast - -> m () -layoutWritePriorComments ast = do - mAnn <- do - state <- mGet - let key = ExactPrint.Types.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 -#if INSERTTRACES - tellDebugMessShow ("layoutWritePriorComments", ExactPrint.Types.mkAnnKey ast, mAnn) -#endif - case mAnn of - Nothing -> return () - Just priors -> do - when (not $ null priors) $ layoutSetCommentCol - priors `forM_` \( ExactPrint.Types.Comment comment _ _ - , ExactPrint.Types.DP (x, y) - ) -> do - replicateM_ x layoutWriteNewline - layoutWriteAppendSpaces y - layoutWriteAppendMultiline $ Text.pack $ comment - --- 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 - , MonadMultiWriter (Seq String) m) - => GenLocated SrcSpan ast -> m () -layoutWritePostComments ast = do - mAnn <- do - state <- mGet - let key = ExactPrint.Types.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 -#if INSERTTRACES - tellDebugMessShow ("layoutWritePostComments", ExactPrint.Types.mkAnnKey ast, mAnn) -#endif - case mAnn of - Nothing -> return () - Just posts -> do - when (not $ null posts) $ layoutSetCommentCol - posts `forM_` \( ExactPrint.Types.Comment comment _ _ - , ExactPrint.Types.DP (x, y) - ) -> do - replicateM_ x layoutWriteNewline - layoutWriteAppend $ Text.pack $ replicate y ' ' - layoutWriteAppendMultiline $ Text.pack $ comment - -layoutIndentRestorePostComment - :: ( MonadMultiState LayoutState m - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiWriter (Seq String) m - ) - => m () -layoutIndentRestorePostComment = do - state <- mGet - let mCommentCol = _lstate_commentCol state - let eCurYAddNL = _lstate_curYOrAddNewline state -#if INSERTTRACES - tellDebugMessShow ("layoutIndentRestorePostComment", mCommentCol) -#endif - mModify $ \s -> s { _lstate_commentCol = Nothing } - 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) --- => GenLocated SrcSpan 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) --- => GenLocated SrcSpan ast -> m () --- layoutWritePostCommentsRestore x = do --- layoutWritePostComments x --- layoutIndentRestorePostComment extractAllComments :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] @@ -776,7 +187,6 @@ extractAllComments ann = _ -> [] ) - foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey foldedAnnKeys ast = everything Set.union diff --git a/src/Language/Haskell/Brittany/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Layouters/Decl.hs index dde640f..66da00a 100644 --- a/src/Language/Haskell/Brittany/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Layouters/Decl.hs @@ -17,7 +17,7 @@ where #include "prelude.inc" import Language.Haskell.Brittany.Types -import Language.Haskell.Brittany.LayoutBasics +import Language.Haskell.Brittany.LayouterBasics import Language.Haskell.Brittany.Config.Types import RdrName ( RdrName(..) ) diff --git a/src/Language/Haskell/Brittany/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Layouters/Expr.hs index 66ffeb8..643ef67 100644 --- a/src/Language/Haskell/Brittany/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Layouters/Expr.hs @@ -12,7 +12,7 @@ where #include "prelude.inc" import Language.Haskell.Brittany.Types -import Language.Haskell.Brittany.LayoutBasics +import Language.Haskell.Brittany.LayouterBasics import RdrName ( RdrName(..) ) import GHC ( runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..) ) diff --git a/src/Language/Haskell/Brittany/Layouters/Expr.hs-boot b/src/Language/Haskell/Brittany/Layouters/Expr.hs-boot index 142f6ce..bd9d2de 100644 --- a/src/Language/Haskell/Brittany/Layouters/Expr.hs-boot +++ b/src/Language/Haskell/Brittany/Layouters/Expr.hs-boot @@ -12,7 +12,7 @@ where #include "prelude.inc" import Language.Haskell.Brittany.Types -import Language.Haskell.Brittany.LayoutBasics +import Language.Haskell.Brittany.LayouterBasics import RdrName ( RdrName(..) ) import GHC ( runGhc, GenLocated(L), moduleNameString ) diff --git a/src/Language/Haskell/Brittany/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Layouters/Pattern.hs index f51183d..84b7668 100644 --- a/src/Language/Haskell/Brittany/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Layouters/Pattern.hs @@ -11,7 +11,7 @@ where #include "prelude.inc" import Language.Haskell.Brittany.Types -import Language.Haskell.Brittany.LayoutBasics +import Language.Haskell.Brittany.LayouterBasics import RdrName ( RdrName(..) ) import GHC ( runGhc, GenLocated(L), moduleNameString ) diff --git a/src/Language/Haskell/Brittany/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Layouters/Stmt.hs index d445a75..6252f52 100644 --- a/src/Language/Haskell/Brittany/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Layouters/Stmt.hs @@ -10,7 +10,7 @@ where #include "prelude.inc" import Language.Haskell.Brittany.Types -import Language.Haskell.Brittany.LayoutBasics +import Language.Haskell.Brittany.LayouterBasics import RdrName ( RdrName(..) ) import GHC ( runGhc, GenLocated(L), moduleNameString ) diff --git a/src/Language/Haskell/Brittany/Layouters/Stmt.hs-boot b/src/Language/Haskell/Brittany/Layouters/Stmt.hs-boot index 4c16e8d..4234ec0 100644 --- a/src/Language/Haskell/Brittany/Layouters/Stmt.hs-boot +++ b/src/Language/Haskell/Brittany/Layouters/Stmt.hs-boot @@ -10,7 +10,7 @@ where #include "prelude.inc" import Language.Haskell.Brittany.Types -import Language.Haskell.Brittany.LayoutBasics +import Language.Haskell.Brittany.LayouterBasics import RdrName ( RdrName(..) ) import GHC ( runGhc, GenLocated(L), moduleNameString ) diff --git a/src/Language/Haskell/Brittany/Layouters/Type.hs b/src/Language/Haskell/Brittany/Layouters/Type.hs index a92147d..c7f76c1 100644 --- a/src/Language/Haskell/Brittany/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Layouters/Type.hs @@ -11,7 +11,7 @@ where import Language.Haskell.Brittany.Config.Types import Language.Haskell.Brittany.Types -import Language.Haskell.Brittany.LayoutBasics +import Language.Haskell.Brittany.LayouterBasics import RdrName ( RdrName(..) ) import GHC ( runGhc, GenLocated(L), moduleNameString ) diff --git a/src/Language/Haskell/Brittany/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Transformations/Alt.hs new file mode 100644 index 0000000..d7997a6 --- /dev/null +++ b/src/Language/Haskell/Brittany/Transformations/Alt.hs @@ -0,0 +1,792 @@ +#define INSERTTRACESALT 0 +#define INSERTTRACESGETSPACING 0 + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} + +module Language.Haskell.Brittany.Transformations.Alt + ( transformAlts + ) +where + + + +#include "prelude.inc" + +import Data.HList.ContainsType + +import Language.Haskell.Brittany.Utils +import Language.Haskell.Brittany.Config.Types +import Language.Haskell.Brittany.Types + +import qualified Control.Monad.Memo as Memo + + + +data AltCurPos = AltCurPos + { _acp_line :: Int -- chars in the current line + , _acp_indent :: Int -- current indentation level + , _acp_indentPrep :: Int -- indentChange affecting the next Par + , _acp_forceMLFlag :: AltLineModeState + } + deriving (Show) + +data AltLineModeState + = AltLineModeStateNone + | AltLineModeStateForceML Bool -- true ~ decays on next wrap + | AltLineModeStateForceSL + | AltLineModeStateContradiction + -- i.e. ForceX False -> ForceX True -> None + deriving (Show) + +altLineModeRefresh :: AltLineModeState -> AltLineModeState +altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone +altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False +altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL +altLineModeRefresh AltLineModeStateContradiction = AltLineModeStateContradiction + +altLineModeDecay :: AltLineModeState -> AltLineModeState +altLineModeDecay AltLineModeStateNone = AltLineModeStateNone +altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True +altLineModeDecay (AltLineModeStateForceML True ) = AltLineModeStateNone +altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL +altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction + +mergeLineMode :: AltCurPos -> AltLineModeState -> AltCurPos +mergeLineMode acp s = case (_acp_forceMLFlag acp, s) of + (AltLineModeStateContradiction, _) -> acp + (AltLineModeStateNone, x) -> acp { _acp_forceMLFlag = x } + (AltLineModeStateForceSL, AltLineModeStateForceSL) -> acp + (AltLineModeStateForceML{}, AltLineModeStateForceML{}) -> + acp { _acp_forceMLFlag = s } + _ -> acp { _acp_forceMLFlag = AltLineModeStateContradiction } + + +-- removes any BDAlt's from the BriDoc +transformAlts + :: forall r w s + . ( Data.HList.ContainsType.ContainsType Config r + , Data.HList.ContainsType.ContainsType (Seq String) w + ) + => BriDocNumbered + -> MultiRWSS.MultiRWS r w s BriDoc +transformAlts briDoc = + MultiRWSS.withMultiStateA (AltCurPos 0 0 0 AltLineModeStateNone) + $ Memo.startEvalMemoT + $ fmap unwrapBriDocNumbered + $ rec + $ briDoc + where + -- this funtion is exponential by nature and cannot be improved in any + -- way i can think of, and if tried. (stupid StableNames.) + -- transWrap :: BriDoc -> BriDocNumbered + -- transWrap brDc = flip StateS.evalState (1::Int) + -- $ Memo.startEvalMemoT + -- $ go brDc + -- where + -- incGet = StateS.get >>= \i -> StateS.put (i+1) $> i + -- go :: BriDoc -> Memo.MemoT BriDoc BriDocNumbered (StateS.State Int) BriDocNumbered + -- go = Memo.memo $ \bdX -> do + -- i <- lift $ incGet + -- fmap (\bd' -> (i,bd')) $ case bdX of + -- BDEmpty -> return $ BDFEmpty + -- BDLit t -> return $ BDFLit t + -- BDSeq list -> BDFSeq <$> go `mapM` list + -- BDCols sig list -> BDFCols sig <$> go `mapM` list + -- BDSeparator -> return $ BDFSeparator + -- BDAddBaseY ind bd -> BDFAddBaseY ind <$> go bd + -- BDSetBaseY bd -> BDFSetBaseY <$> go bd + -- BDSetIndentLevel bd -> BDFSetIndentLevel <$> go bd + -- BDPar ind line indented -> [ BDFPar ind line' indented' + -- | line' <- go line + -- , indented' <- go indented + -- ] + -- BDAlt alts -> BDFAlt <$> go `mapM` alts -- not that this will happen + -- BDForceMultiline bd -> BDFForceMultiline <$> go bd + -- BDForceSingleline bd -> BDFForceSingleline <$> go bd + -- BDForwardLineMode bd -> BDFForwardLineMode <$> go bd + -- BDExternal k ks c t -> return $ BDFExternal k ks c t + -- BDAnnotationPrior annKey bd -> BDFAnnotationPrior annKey <$> go bd + -- BDAnnotationPost annKey bd -> BDFAnnotationRest annKey <$> go bd + -- BDLines lines -> BDFLines <$> go `mapM` lines + -- BDEnsureIndent ind bd -> BDFEnsureIndent ind <$> go bd + -- BDProhibitMTEL bd -> BDFProhibitMTEL <$> go bd + + + + rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] (MultiRWSS.MultiRWS r w (AltCurPos ': s)) BriDocNumbered + rec bdX@(brDcId, brDc) = do +#if INSERTTRACESALT + do + acp :: AltCurPos <- mGet + tellDebugMess $ "transformAlts: visiting: " ++ case brDc of + BDFAnnotationPrior annKey _ -> show (toConstr brDc, annKey, acp) + BDFAnnotationRest annKey _ -> show (toConstr brDc, annKey, acp) + _ -> show (toConstr brDc, acp) +#endif + let reWrap = (,) brDcId + -- debugAcp :: AltCurPos <- mGet + case brDc of + -- BDWrapAnnKey annKey bd -> do + -- acp <- mGet + -- mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } + -- BDWrapAnnKey annKey <$> rec bd + BDFEmpty{} -> processSpacingSimple bdX $> bdX + BDFLit{} -> processSpacingSimple bdX $> bdX + BDFSeq list -> + reWrap . BDFSeq <$> list `forM` rec + BDFCols sig list -> + reWrap . BDFCols sig <$> list `forM` rec + BDFSeparator -> processSpacingSimple bdX $> bdX + BDFAddBaseY indent bd -> do + acp <- mGet + indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + let indAdd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> indAmount + BrIndentSpecial i -> i + mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd } + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indent acp } + return $ case indent of + BrIndentNone -> r + BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r + BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r + BDFBaseYPushCur bd -> do + acp <- mGet + mSet $ acp { _acp_indent = _acp_line acp } + r <- rec bd + return $ reWrap $ BDFBaseYPushCur r + BDFBaseYPop bd -> do + acp <- mGet + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indentPrep acp } + return $ reWrap $ BDFBaseYPop r + BDFIndentLevelPushCur bd -> do + reWrap . BDFIndentLevelPushCur <$> rec bd + BDFIndentLevelPop bd -> do + reWrap . BDFIndentLevelPop <$> rec bd + BDFPar indent sameLine indented -> do + indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + let indAdd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> indAmount + BrIndentSpecial i -> i + acp <- mGet + let ind = _acp_indent acp + _acp_indentPrep acp + indAdd + mSet $ acp + { _acp_indent = ind + , _acp_indentPrep = 0 + } + sameLine' <- rec sameLine + mModify $ \acp' -> acp' + { _acp_line = ind + , _acp_indent = ind + } + indented' <- rec indented + return $ reWrap $ BDFPar indent sameLine' indented' + BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a + -- possibility, but i will prefer a + -- fail-early approach; BDEmpty does not + -- make sense semantically for Alt[]. + BDFAlt alts -> do + altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack + case altChooser of + AltChooserSimpleQuick -> do + rec $ head alts + AltChooserShallowBest -> do + spacings <- alts `forM` getSpacing + acp <- mGet + let lineCheck LineModeInvalid = False + lineCheck (LineModeValid (VerticalSpacing _ p _)) = + case _acp_forceMLFlag acp of + AltLineModeStateNone -> True + AltLineModeStateForceSL{} -> p == VerticalSpacingParNone + AltLineModeStateForceML{} -> p /= VerticalSpacingParNone + AltLineModeStateContradiction -> False + lineCheck _ = error "ghc exhaustive check is insufficient" + lconf <- _conf_layout <$> mAsk +#if INSERTTRACESALT + tellDebugMess $ "considering options with " ++ show (length alts, acp) +#endif + let options = -- trace ("considering options:" ++ show (length alts, acp)) $ + (zip spacings alts + <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) + ( hasSpace1 lconf acp vs && lineCheck vs, bd)) +#if INSERTTRACESALT + zip spacings options `forM_` \(vs, (_, bd)) -> + tellDebugMess $ " " ++ "spacing=" ++ show vs + ++ ",hasSpace=" ++ show (hasSpace1 lconf acp vs) + ++ ",lineCheck=" ++ show (lineCheck vs) + ++ " " ++ show (toConstr bd) +#endif + id -- $ (fmap $ \x -> traceShow (briDocToDoc x) x) + $ rec + $ fromMaybe (-- trace ("choosing last") $ + List.last alts) + $ Data.List.Extra.firstJust (\(_i::Int, (b,x)) -> + [ -- traceShow ("choosing option " ++ show i) $ + x + | b + ]) + $ zip [1..] options + AltChooserBoundedSearch limit -> do + spacings <- alts `forM` getSpacings limit + acp <- mGet + let lineCheck (VerticalSpacing _ p _) = + case _acp_forceMLFlag acp of + AltLineModeStateNone -> True + AltLineModeStateForceSL{} -> p == VerticalSpacingParNone + AltLineModeStateForceML{} -> p /= VerticalSpacingParNone + AltLineModeStateContradiction -> False + lconf <- _conf_layout <$> mAsk +#if INSERTTRACESALT + tellDebugMess $ "considering options with " ++ show (length alts, acp) +#endif + let options = -- trace ("considering options:" ++ show (length alts, acp)) $ + (zip spacings alts + <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) + ( any (hasSpace2 lconf acp) vs + && any lineCheck vs, bd)) + let checkedOptions :: [Maybe (Int, BriDocNumbered)] = + zip [1..] options <&> (\(i, (b,x)) -> [ (i, x) | b ]) +#if INSERTTRACESALT + zip spacings options `forM_` \(vs, (_, bd)) -> + tellDebugMess $ " " ++ "spacing=" ++ show vs + ++ ",hasSpace=" ++ show (hasSpace2 lconf acp <$> vs) + ++ ",lineCheck=" ++ show (lineCheck <$> vs) + ++ " " ++ show (toConstr bd) + tellDebugMess $ " " ++ show (Data.Maybe.mapMaybe (fmap fst) checkedOptions) +#endif + id -- $ (fmap $ \x -> traceShow (briDocToDoc x) x) + $ rec + $ fromMaybe (-- trace ("choosing last") $ + List.last alts) + $ Data.List.Extra.firstJust (fmap snd) checkedOptions + BDFForceMultiline bd -> do + acp <- mGet + x <- do + mSet $ mergeLineMode acp (AltLineModeStateForceML False) + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFForceSingleline bd -> do + acp <- mGet + x <- do + mSet $ mergeLineMode acp AltLineModeStateForceSL + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFForwardLineMode bd -> do + acp <- mGet + x <- do + mSet $ acp { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp } + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFExternal{} -> processSpacingSimple bdX $> bdX + BDFAnnotationPrior annKey bd -> do + acp <- mGet + mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } + bd' <- rec bd + return $ reWrap $ BDFAnnotationPrior annKey bd' + BDFAnnotationRest annKey bd -> + reWrap . BDFAnnotationRest annKey <$> rec bd + BDFAnnotationKW annKey kw bd -> + reWrap . BDFAnnotationKW annKey kw <$> rec bd + BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. + BDFLines (l:lr) -> do + ind <- _acp_indent <$> mGet + l' <- rec l + lr' <- lr `forM` \x -> do + mModify $ \acp -> acp + { _acp_line = ind + , _acp_indent = ind + } + rec x + return $ reWrap $ BDFLines (l':lr') + BDFEnsureIndent indent bd -> do + acp <- mGet + indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + let indAdd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> indAmount + BrIndentSpecial i -> i + mSet $ acp { _acp_indentPrep = 0 -- TODO: i am not sure this is valid, + -- in general. + , _acp_indent = _acp_indent acp + indAdd + , _acp_line = _acp_line acp + indAdd + } + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indent acp } + return $ case indent of + BrIndentNone -> r + BrIndentRegular -> reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r + BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r + BDFNonBottomSpacing bd -> rec bd + BDFSetParSpacing bd -> rec bd + BDFForceParSpacing bd -> rec bd + BDFProhibitMTEL bd -> + reWrap . BDFProhibitMTEL <$> rec bd + BDFDebug s bd -> do + acp :: AltCurPos <- mGet + tellDebugMess $ "transformAlts: BDFDEBUG " ++ s ++ " (node-id=" ++ show brDcId ++ "): acp=" ++ show acp + reWrap . BDFDebug s <$> rec bd + processSpacingSimple :: (MonadMultiReader + Config m, + MonadMultiState AltCurPos m, MonadMultiWriter (Seq String) m) => BriDocNumbered -> m () + processSpacingSimple bd = getSpacing bd >>= \case + LineModeInvalid -> error "processSpacingSimple inv" + LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do + acp <- mGet + mSet $ acp { _acp_line = _acp_line acp + i } + LineModeValid (VerticalSpacing _ _ _) -> error "processSpacingSimple par" + _ -> error "ghc exhaustive check is insufficient" + hasSpace1 :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool + hasSpace1 _ _ LineModeInvalid = False + hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs + hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" + hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool + hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _) + = line + sameLine <= confUnpack (_lconfig_cols lconf) + hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _) + = line + sameLine <= confUnpack (_lconfig_cols lconf) + && indent + indentPrep + par <= confUnpack (_lconfig_cols lconf) + hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _) + = line + sameLine <= confUnpack (_lconfig_cols lconf) + +getSpacing + :: forall m + . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) + => BriDocNumbered + -> m (LineModeValidity VerticalSpacing) +getSpacing !bridoc = rec bridoc + where + rec :: BriDocNumbered -> m (LineModeValidity VerticalSpacing) + rec (brDcId, brDc) = do + config <- mAsk + let colMax = config & _conf_layout & _lconfig_cols & confUnpack + result <- case brDc of + -- BDWrapAnnKey _annKey bd -> rec bd + BDFEmpty -> + return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False + BDFLit t -> + return $ LineModeValid $ VerticalSpacing (Text.length t) VerticalSpacingParNone False + BDFSeq list -> + sumVs <$> rec `mapM` list + BDFCols _sig list -> sumVs <$> rec `mapM` list + BDFSeparator -> + return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False + BDFAddBaseY indent bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + { _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of + BrIndentNone -> i + BrIndentRegular -> i + ( confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) + BrIndentSpecial j -> i + j + VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of + BrIndentNone -> i + BrIndentRegular -> i + ( confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) + BrIndentSpecial j -> i + j + } + BDFBaseYPushCur bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + -- We leave par as-is, even though it technically is not + -- accurate (in general). + -- the reason is that we really want to _keep_ it Just if it is + -- just so we properly communicate the is-multiline fact. + -- An alternative would be setting to (Just 0). + { _vs_sameLine = max (_vs_sameLine vs) + (case _vs_paragraph vs of + VerticalSpacingParNone -> 0 + VerticalSpacingParSome i -> i + VerticalSpacingParAlways i -> min colMax i) + , _vs_paragraph = VerticalSpacingParAlways 0 + } + BDFBaseYPop bd -> rec bd + BDFIndentLevelPushCur bd -> rec bd + BDFIndentLevelPop bd -> rec bd + BDFPar BrIndentNone sameLine indented -> do + mVs <- rec sameLine + mIndSp <- rec indented + return + $ [ VerticalSpacing lsp pspResult parFlagResult + | VerticalSpacing lsp mPsp _ <- mVs + , indSp <- mIndSp + , lineMax <- getMaxVS $ mIndSp + , let pspResult = case mPsp of + VerticalSpacingParSome psp -> VerticalSpacingParSome $ max psp lineMax + VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax + VerticalSpacingParAlways psp -> VerticalSpacingParAlways $ max psp lineMax + , let parFlagResult = mPsp == VerticalSpacingParNone + && _vs_paragraph indSp == VerticalSpacingParNone + && _vs_parFlag indSp + ] + BDFPar{} -> error "BDPar with indent in getSpacing" + BDFAlt [] -> error "empty BDAlt" + BDFAlt (alt:_) -> rec alt + BDFForceMultiline bd -> rec bd + BDFForceSingleline bd -> do + mVs <- rec bd + return $ mVs >>= _vs_paragraph .> \case + VerticalSpacingParNone -> mVs + _ -> LineModeInvalid + BDFForwardLineMode bd -> rec bd + BDFExternal{} -> return + $ LineModeValid + $ VerticalSpacing 999 VerticalSpacingParNone False + BDFAnnotationPrior _annKey bd -> rec bd + BDFAnnotationKW _annKey _kw bd -> rec bd + BDFAnnotationRest _annKey bd -> rec bd + BDFLines [] -> return + $ LineModeValid + $ VerticalSpacing 0 VerticalSpacingParNone False + BDFLines ls@(_:_) -> do + lSps@(mVs:_) <- rec `mapM` ls + return $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False + | VerticalSpacing lsp _ _ <- mVs + , lineMax <- getMaxVS $ maxVs $ lSps + ] + BDFEnsureIndent indent bd -> do + mVs <- rec bd + let addInd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + BrIndentSpecial i -> i + return $ mVs <&> \(VerticalSpacing lsp psp pf) -> + VerticalSpacing (lsp + addInd) psp pf + BDFNonBottomSpacing bd -> do + mVs <- rec bd + return + $ mVs + <|> LineModeValid (VerticalSpacing 0 + (VerticalSpacingParAlways colMax) + False) + BDFSetParSpacing bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs { _vs_parFlag = True } + BDFForceParSpacing bd -> do + mVs <- rec bd + return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] + BDFProhibitMTEL bd -> rec bd + BDFDebug s bd -> do + r <- rec bd + tellDebugMess $ "getSpacing: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): mVs=" ++ show r + return r +#if INSERTTRACESGETSPACING + tellDebugMess $ "getSpacing: visiting: " ++ show (toConstr $ brDc) ++ " -> " ++ show result +#endif + return result + maxVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing + maxVs = foldl' + (liftM2 (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> + VerticalSpacing (max x1 y1) (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome j, VerticalSpacingParAlways i) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + VerticalSpacingParSome $ max x y) False)) + (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False) + sumVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing + sumVs sps = foldl' (liftM2 go) initial sps + where + go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing + (x1 + y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + VerticalSpacingParSome $ x + y) + x3 + singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone + singleline _ = False + isPar (LineModeValid x) = _vs_parFlag x + isPar _ = False + parFlag = case sps of + [] -> True + _ -> all singleline (List.init sps) && isPar (List.last sps) + initial = LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone parFlag + getMaxVS :: LineModeValidity VerticalSpacing -> LineModeValidity Int + getMaxVS = fmap $ \(VerticalSpacing x1 x2 _) -> x1 `max` case x2 of + VerticalSpacingParSome i -> i + VerticalSpacingParNone -> 0 + VerticalSpacingParAlways i -> i + +getSpacings + :: forall m + . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) + => Int + -> BriDocNumbered + -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] +getSpacings limit bridoc = preFilterLimit <$> rec bridoc + where + preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing] + preFilterLimit = take (3*limit) + memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v + memoWithKey k v = Memo.memo (const v) k + rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] + rec (brDcId, brdc) = memoWithKey brDcId $ do + config <- mAsk + let colMax = config & _conf_layout & _lconfig_cols & confUnpack + let hasOkColCount (VerticalSpacing lsp psp _) = + lsp <= colMax && case psp of + VerticalSpacingParNone -> True + VerticalSpacingParSome i -> i <= colMax + VerticalSpacingParAlways{} -> True + let filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing] + filterAndLimit = take limit + . filter hasOkColCount + . preFilterLimit -- we need to limit here in case + -- that the input list is + -- _large_ with a similarly _large_ + -- prefix not passing hasOkColCount + -- predicate. + -- TODO: 3 is arbitrary. + result <- case brdc of + -- BDWrapAnnKey _annKey bd -> rec bd + BDFEmpty -> + return $ [VerticalSpacing 0 VerticalSpacingParNone False] + BDFLit t -> + return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] + BDFSeq list -> + fmap sumVs . sequence . fmap filterAndLimit <$> rec `mapM` list + BDFCols _sig list -> + fmap sumVs . sequence . fmap filterAndLimit <$> rec `mapM` list + BDFSeparator -> + return $ [VerticalSpacing 1 VerticalSpacingParNone False] + BDFAddBaseY indent bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + { _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of + BrIndentNone -> i + BrIndentRegular -> i + ( confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) + BrIndentSpecial j -> i + j + VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of + BrIndentNone -> i + BrIndentRegular -> i + ( confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) + BrIndentSpecial j -> i + j + } + BDFBaseYPushCur bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + -- We leave par as-is, even though it technically is not + -- accurate (in general). + -- the reason is that we really want to _keep_ it Just if it is + -- just so we properly communicate the is-multiline fact. + -- An alternative would be setting to (Just 0). + { _vs_sameLine = max (_vs_sameLine vs) + (case _vs_paragraph vs of + VerticalSpacingParNone -> 0 + VerticalSpacingParSome i -> i + VerticalSpacingParAlways i -> min colMax i) + , _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParSome i -> VerticalSpacingParAlways i -- TODO: is this correct? + VerticalSpacingParAlways i -> VerticalSpacingParAlways i + } + BDFBaseYPop bd -> rec bd + BDFIndentLevelPushCur bd -> rec bd + BDFIndentLevelPop bd -> rec bd + BDFPar BrIndentNone sameLine indented -> do + mVss <- filterAndLimit <$> rec sameLine + indSps <- filterAndLimit <$> rec indented + let mVsIndSp = take limit + $ [ (x,y) + | x<-mVss + , y<-indSps + ] + return $ mVsIndSp <&> + \(VerticalSpacing lsp mPsp _, indSp) -> + VerticalSpacing + lsp + (case mPsp of + VerticalSpacingParSome psp -> + VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO + VerticalSpacingParNone -> spMakePar indSp + VerticalSpacingParAlways psp -> + VerticalSpacingParAlways $ max psp $ getMaxVS indSp) + ( mPsp == VerticalSpacingParNone + && _vs_paragraph indSp == VerticalSpacingParNone + && _vs_parFlag indSp + ) + + BDFPar{} -> error "BDPar with indent in getSpacing" + BDFAlt [] -> error "empty BDAlt" + -- BDAlt (alt:_) -> rec alt + BDFAlt alts -> do + r <- rec `mapM` alts + return $ filterAndLimit =<< r + BDFForceMultiline bd -> rec bd + BDFForceSingleline bd -> do + mVs <- filterAndLimit <$> rec bd + return $ filter ((==VerticalSpacingParNone) . _vs_paragraph) mVs + BDFForwardLineMode bd -> rec bd + BDFExternal{} -> + return $ [] -- yes, we just assume that we cannot properly layout + -- this. + BDFAnnotationPrior _annKey bd -> rec bd + BDFAnnotationKW _annKey _kw bd -> rec bd + BDFAnnotationRest _annKey bd -> rec bd + BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] + BDFLines ls@(_:_) -> do + -- we simply assume that lines is only used "properly", i.e. in + -- such a way that the first line can be treated "as a part of the + -- paragraph". That most importantly means that Lines should never + -- be inserted anywhere but at the start of the line. A + -- counterexample would be anything like Seq[Lit "foo", Lines]. + lSpss <- fmap filterAndLimit <$> rec `mapM` ls + let worbled = fmap reverse + $ sequence + $ reverse + $ lSpss + summed = worbled <&> \lSps@(lSp1:_) -> + VerticalSpacing (_vs_sameLine lSp1) + (spMakePar $ maxVs lSps) + False + return $ summed + -- lSpss@(mVs:_) <- rec `mapM` ls + -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only + -- -- consider the first alternative for the + -- -- line's spacings. + -- -- also i am not sure if always including + -- -- the first line length in the paragraph + -- -- length gives the desired results. + -- -- it is the safe path though, for now. + -- [] -> [] + -- (lSps:_) -> mVs <&> \(VerticalSpacing lsp _) -> + -- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps + BDFEnsureIndent indent bd -> do + mVs <- rec bd + let addInd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + BrIndentSpecial i -> i + return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> + VerticalSpacing (lsp + addInd) psp parFlag + BDFNonBottomSpacing bd -> do + mVs <- rec bd + return $ if null mVs + then [VerticalSpacing 0 (VerticalSpacingParAlways colMax) False] + else mVs <&> \vs -> vs + { _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i -> VerticalSpacingParAlways i + VerticalSpacingParSome i -> VerticalSpacingParAlways i + } + BDFSetParSpacing bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs { _vs_parFlag = True } + BDFForceParSpacing bd -> do + mVs <- preFilterLimit <$> rec bd + return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] + BDFProhibitMTEL bd -> rec bd + BDFDebug s bd -> do + r <- rec bd + tellDebugMess $ "getSpacings: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): vs=" ++ show (take 9 r) + return r +#if INSERTTRACESGETSPACING + case brdc of + BDFAnnotationPrior{} -> return () + BDFAnnotationRest{} -> return () + _ -> mTell $ Seq.fromList ["getSpacing: visiting: " + ++ show {-(toConstr $ brdc)-} (briDocToDoc $ unwrapBriDocNumbered (0, brdc)) + , " -> " + ++ show (take 9 result) + ] +#endif + return result + maxVs :: [VerticalSpacing] -> VerticalSpacing + maxVs = foldl' + (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> + VerticalSpacing + (max x1 y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + VerticalSpacingParSome $ max x y) + False) + (VerticalSpacing 0 VerticalSpacingParNone False) + sumVs :: [VerticalSpacing] -> VerticalSpacing + sumVs sps = foldl' go initial sps + where + go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing + (x1 + y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ x + y) + x3 + singleline x = _vs_paragraph x == VerticalSpacingParNone + isPar x = _vs_parFlag x + parFlag = case sps of + [] -> True + _ -> all singleline (List.init sps) && isPar (List.last sps) + initial = VerticalSpacing 0 VerticalSpacingParNone parFlag + getMaxVS :: VerticalSpacing -> Int + getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of + VerticalSpacingParSome i -> i + VerticalSpacingParNone -> 0 + VerticalSpacingParAlways i -> i + spMakePar :: VerticalSpacing -> VerticalSpacingPar + spMakePar (VerticalSpacing x1 x2 _) = case x2 of + VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i + VerticalSpacingParNone -> VerticalSpacingParSome $ x1 + VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i diff --git a/src/Language/Haskell/Brittany/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Transformations/Columns.hs new file mode 100644 index 0000000..13f3161 --- /dev/null +++ b/src/Language/Haskell/Brittany/Transformations/Columns.hs @@ -0,0 +1,136 @@ +module Language.Haskell.Brittany.Transformations.Columns + ( transformSimplifyColumns + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Utils +import Language.Haskell.Brittany.Config.Types +import Language.Haskell.Brittany.Types + +import qualified Data.Generics.Uniplate.Direct as Uniplate + + + +transformSimplifyColumns :: BriDoc -> BriDoc +transformSimplifyColumns = Uniplate.rewrite $ \case + -- BDWrapAnnKey annKey bd -> + -- BDWrapAnnKey annKey $ transformSimplify bd + BDEmpty -> Nothing + BDLit{} -> Nothing + BDSeq list | any (\case BDSeq{} -> True + BDEmpty{} -> True + _ -> False) list -> Just $ BDSeq $ + filter isNotEmpty list >>= \case + BDSeq l -> l + x -> [x] + BDSeq (BDCols sig1 cols1@(_:_):rest) -> + Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)]) + BDLines lines | any (\case BDLines{} -> True + BDEmpty{} -> True + _ -> False) lines -> + Just $ BDLines $ filter isNotEmpty $ lines >>= \case + BDLines l -> l + x -> [x] + -- prior floating in + BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> + Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDLines (l:lr)) -> + Just $ BDLines (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> + Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) + -- post floating in + BDAnnotationRest annKey1 (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] + BDAnnotationKW annKey1 kw (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] + -- ensureIndent float-in + -- not sure if the following rule is necessary; tests currently are + -- unaffected. + -- BDEnsureIndent indent (BDLines lines) -> + -- Just $ BDLines $ BDEnsureIndent indent <$> lines + -- matching col special transformation + BDCols sig1 cols1@(_:_) + | BDLines lines@(_:_:_) <- List.last cols1 + , BDCols sig2 cols2 <- List.last lines + , sig1==sig2 -> + Just $ BDLines + [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] + , BDCols sig2 cols2 + ] + BDCols sig1 cols1@(_:_) + | BDLines lines@(_:_:_) <- List.last cols1 + , BDEnsureIndent _ (BDCols sig2 cols2) <- List.last lines + , sig1==sig2 -> + Just $ BDLines + [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] + , BDCols sig2 cols2 + ] + BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1==sig2 -> + Just $ BDAddBaseY ind (BDLines [col1, col2]) + BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _):rest)) + | sig1==sig2 -> + Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest) + BDPar ind (BDLines lines1) col2@(BDCols sig2 _) + | BDCols sig1 _ <- List.last lines1 + , sig1==sig2 -> + Just $ BDAddBaseY ind (BDLines $ lines1 ++ [col2]) + BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _):rest)) + | BDCols sig1 _ <- List.last lines1 + , sig1==sig2 -> + Just $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest) + -- BDPar ind1 (BDCols sig1 cols1) (BDPar ind2 line (BDCols sig2 cols2)) + -- | sig1==sig2 -> + -- Just $ BDPar + -- ind1 + -- (BDLines [BDCols sig1 cols1, BDCols sig]) + BDCols sig1 cols | BDPar _ind line (BDCols sig2 cols2) <- List.last cols + , sig1==sig2 -> + Just $ BDLines + [ BDCols sig1 (List.init cols ++ [line]) + , BDCols sig2 cols2 + ] + BDCols sig1 cols | BDPar ind line (BDLines lines) <- List.last cols + , BDCols sig2 cols2 <- List.last lines + , sig1==sig2 -> + Just $ BDLines + [ BDCols sig1 $ List.init cols ++ [BDPar ind line (BDLines $ List.init lines)] + , BDCols sig2 cols2 + ] + BDLines [x] -> Just $ x + BDLines [] -> Just $ BDEmpty + BDSeq{} -> Nothing + BDCols{} -> Nothing + BDSeparator -> Nothing + BDAddBaseY{} -> Nothing + BDBaseYPushCur{} -> Nothing + BDBaseYPop{} -> Nothing + BDIndentLevelPushCur{} -> Nothing + BDIndentLevelPop{} -> Nothing + BDPar{} -> Nothing + BDAlt{} -> Nothing + BDForceMultiline{} -> Nothing + BDForceSingleline{} -> Nothing + BDForwardLineMode{} -> Nothing + BDExternal{} -> Nothing + BDLines{} -> Nothing + BDAnnotationPrior{} -> Nothing + BDAnnotationKW{} -> Nothing + BDAnnotationRest{} -> Nothing + BDEnsureIndent{} -> Nothing + BDProhibitMTEL{} -> Nothing + BDSetParSpacing{} -> Nothing + BDForceParSpacing{} -> Nothing + BDDebug{} -> Nothing + BDNonBottomSpacing x -> Just x diff --git a/src/Language/Haskell/Brittany/Transformations/Floating.hs b/src/Language/Haskell/Brittany/Transformations/Floating.hs new file mode 100644 index 0000000..e831011 --- /dev/null +++ b/src/Language/Haskell/Brittany/Transformations/Floating.hs @@ -0,0 +1,192 @@ +module Language.Haskell.Brittany.Transformations.Floating + ( transformSimplifyFloating + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Utils +import Language.Haskell.Brittany.Config.Types +import Language.Haskell.Brittany.Types + +import qualified Data.Generics.Uniplate.Direct as Uniplate + + + +-- note that this is not total, and cannot be with that exact signature. +mergeIndents :: BrIndent -> BrIndent -> BrIndent +mergeIndents BrIndentNone x = x +mergeIndents x BrIndentNone = x +mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j) +mergeIndents _ _ = error "mergeIndents" + + +transformSimplifyFloating :: BriDoc -> BriDoc +transformSimplifyFloating = stepBO .> stepFull + -- note that semantically, stepFull is completely sufficient. + -- but the bottom-up switch-to-top-down-on-match transformation has much + -- better complexity. + -- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence + -- the push/pop cases would need to be copied over + where + descendPrior = transformDownMay $ \case + -- prior floating in + BDAnnotationPrior annKey1 (BDPar ind line indented) -> + Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented + BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> + Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDLines (l:lr)) -> + Just $ BDLines (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> + Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x + BDAnnotationPrior annKey1 (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationPrior annKey1 x + _ -> Nothing + descendRest = transformDownMay $ \case + -- post floating in + BDAnnotationRest annKey1 (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationRest annKey1 indented + BDAnnotationRest annKey1 (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] + BDAnnotationRest annKey1 (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x + BDAnnotationRest annKey1 (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationRest annKey1 x + _ -> Nothing + descendKW = transformDownMay $ \case + -- post floating in + BDAnnotationKW annKey1 kw (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented + BDAnnotationKW annKey1 kw (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] + BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x + BDAnnotationKW annKey1 kw (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationKW annKey1 kw x + _ -> Nothing + descendBYPush = transformDownMay $ \case + BDBaseYPushCur (BDCols sig cols@(_:_)) -> + Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) + BDBaseYPushCur (BDDebug s x) -> + Just $ BDDebug s (BDBaseYPushCur x) + _ -> Nothing + descendBYPop = transformDownMay $ \case + BDBaseYPop (BDCols sig cols@(_:_)) -> + Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) + BDBaseYPop (BDDebug s x) -> + Just $ BDDebug s (BDBaseYPop x) + _ -> Nothing + descendILPush = transformDownMay $ \case + BDIndentLevelPushCur (BDCols sig cols@(_:_)) -> + Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) + BDIndentLevelPushCur (BDDebug s x) -> + Just $ BDDebug s (BDIndentLevelPushCur x) + _ -> Nothing + descendILPop = transformDownMay $ \case + BDIndentLevelPop (BDCols sig cols@(_:_)) -> + Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) + BDIndentLevelPop (BDDebug s x) -> + Just $ BDDebug s (BDIndentLevelPop x) + _ -> Nothing + descendAddB = transformDownMay $ \case + -- AddIndent floats into Lines. + BDAddBaseY BrIndentNone x -> + Just x + BDAddBaseY indent (BDLines lines) -> + Just $ BDLines $ BDAddBaseY indent <$> lines + -- AddIndent floats into last column + BDAddBaseY indent (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] + -- merge AddIndent and Par + BDAddBaseY ind1 (BDPar ind2 line indented) -> + Just $ BDPar (mergeIndents ind1 ind2) line indented + BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> + Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) + BDAddBaseY ind (BDAnnotationRest annKey1 x) -> + Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x) + BDAddBaseY ind (BDAnnotationKW annKey1 kw x) -> + Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) + BDAddBaseY ind (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] + BDAddBaseY _ lit@BDLit{} -> + Just $ lit + BDAddBaseY ind (BDBaseYPushCur x) -> + Just $ BDBaseYPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDBaseYPop x) -> + Just $ BDBaseYPop (BDAddBaseY ind x) + BDAddBaseY ind (BDDebug s x) -> + Just $ BDDebug s (BDAddBaseY ind x) + _ -> Nothing + stepBO :: BriDoc -> BriDoc + stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ + transformUp f + where + f = \case + x@BDAnnotationPrior{} -> descendPrior x + x@BDAnnotationKW{} -> descendKW x + x@BDAnnotationRest{} -> descendRest x + x@BDAddBaseY{} -> descendAddB x + x@BDBaseYPushCur{} -> descendBYPush x + x@BDBaseYPop{} -> descendBYPop x + x@BDIndentLevelPushCur{} -> descendILPush x + x@BDIndentLevelPop{} -> descendILPop x + x -> x + stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ + Uniplate.rewrite $ \case + -- AddIndent floats into Lines. + BDAddBaseY BrIndentNone x -> + Just $ x + BDAddBaseY indent (BDLines lines) -> + Just $ BDLines $ BDAddBaseY indent <$> lines + -- AddIndent floats into last column + BDAddBaseY indent (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] + BDAddBaseY ind (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] + -- merge AddIndent and Par + BDAddBaseY ind1 (BDPar ind2 line indented) -> + Just $ BDPar (mergeIndents ind1 ind2) line indented + BDAddBaseY _ lit@BDLit{} -> + Just $ lit + BDAddBaseY ind (BDBaseYPushCur x) -> + Just $ BDBaseYPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDBaseYPop x) -> + Just $ BDBaseYPop (BDAddBaseY ind x) + -- prior floating in + BDAnnotationPrior annKey1 (BDPar ind line indented) -> + Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented + BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> + Just $ BDSeq ((BDAnnotationPrior annKey1 l):lr) + BDAnnotationPrior annKey1 (BDLines (l:lr)) -> + Just $ BDLines ((BDAnnotationPrior annKey1 l):lr) + BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> + Just $ BDCols sig ((BDAnnotationPrior annKey1 l):lr) + -- EnsureIndent float-in + -- BDEnsureIndent indent (BDCols sig (col:colr)) -> + -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) + -- not sure if the following rule is necessary; tests currently are + -- unaffected. + -- BDEnsureIndent indent (BDLines lines) -> + -- Just $ BDLines $ BDEnsureIndent indent <$> lines + -- post floating in + BDAnnotationRest annKey1 (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationRest annKey1 indented + BDAnnotationRest annKey1 (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] + _ -> Nothing diff --git a/src/Language/Haskell/Brittany/Transformations/Indent.hs b/src/Language/Haskell/Brittany/Transformations/Indent.hs new file mode 100644 index 0000000..703f050 --- /dev/null +++ b/src/Language/Haskell/Brittany/Transformations/Indent.hs @@ -0,0 +1,57 @@ +module Language.Haskell.Brittany.Transformations.Indent + ( transformSimplifyIndent + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Utils +import Language.Haskell.Brittany.Config.Types +import Language.Haskell.Brittany.Types + +import qualified Data.Generics.Uniplate.Direct as Uniplate + + + +-- prepare layouting by translating BDPar's, replacing them with Indents and +-- floating those in. This gives a more clear picture of what exactly is +-- affected by what amount of indentation. +transformSimplifyIndent :: BriDoc -> BriDoc +transformSimplifyIndent = Uniplate.rewrite $ \case + BDPar ind (BDLines lines) indented -> + Just $ BDEnsureIndent ind $ BDLines $ lines ++ [indented] + BDPar ind (BDCols sig cols) indented -> + Just $ BDCols sig (List.init cols ++ [BDPar ind (List.last cols) indented]) + BDPar BrIndentNone _ _ -> Nothing + BDPar ind x indented -> + Just $ BDPar BrIndentNone (BDAddBaseY ind x) (BDEnsureIndent ind indented) + -- BDPar ind x indented -> + -- Just $ BDLines + -- [ BDAddBaseY ind x + -- , BDEnsureIndent ind indented + -- ] + BDLines lines | any ( \case + BDLines{} -> True + BDEmpty{} -> True + _ -> False + ) + lines -> + Just $ BDLines $ filter isNotEmpty $ lines >>= \case + BDLines l -> l + x -> [x] + BDLines [l] -> Just l + BDAddBaseY i (BDAnnotationPrior k x) -> + Just $ BDAnnotationPrior k (BDAddBaseY i x) + BDAddBaseY i (BDAnnotationKW k kw x) -> + Just $ BDAnnotationKW k kw (BDAddBaseY i x) + BDAddBaseY i (BDAnnotationRest k x) -> + Just $ BDAnnotationRest k (BDAddBaseY i x) + BDAddBaseY i (BDSeq l) -> + Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l] + BDAddBaseY i (BDCols sig l) -> + Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l] + BDAddBaseY _ lit@BDLit{} -> Just lit + + _ -> Nothing diff --git a/src/Language/Haskell/Brittany/Transformations/Par.hs b/src/Language/Haskell/Brittany/Transformations/Par.hs new file mode 100644 index 0000000..be3f532 --- /dev/null +++ b/src/Language/Haskell/Brittany/Transformations/Par.hs @@ -0,0 +1,51 @@ +module Language.Haskell.Brittany.Transformations.Par + ( transformSimplifyPar + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Utils +import Language.Haskell.Brittany.Config.Types +import Language.Haskell.Brittany.Types + +import qualified Data.Generics.Uniplate.Direct as Uniplate + + + +transformSimplifyPar :: BriDoc -> BriDoc +transformSimplifyPar = transformUp $ \case + -- BDPar BrIndentNone line1 line2 -> Just $ BDLines [line1, line2] + -- BDPar line indented -> + -- Just $ BDLines [line, indented] + -- BDPar ind1 (BDPar ind2 line p1) p2 | ind1==ind2 -> + -- Just $ BDPar ind1 line (BDLines [p1, p2]) + x@(BDPar _ (BDPar _ BDPar{} _) _) -> x + BDPar ind1 (BDPar ind2 line p1) (BDLines indenteds) -> + BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds)) + BDPar ind1 (BDPar ind2 line p1) p2 -> + BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2]) + BDLines lines | any ( \case + BDLines{} -> True + BDEmpty{} -> True + _ -> False + ) + lines -> case go lines of + [] -> BDEmpty + [x] -> x + xs -> BDLines xs + where + go = (=<<) $ \case + BDLines l -> go l + BDEmpty -> [] + x -> [x] + BDLines [] -> BDEmpty + BDLines [x] -> x + -- BDCols sig cols | BDPar ind line indented <- List.last cols -> + -- Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented + -- BDPar BrIndentNone line indented -> + -- Just $ BDLines [line, indented] + BDEnsureIndent BrIndentNone x -> x + x -> x diff --git a/src/Language/Haskell/Brittany/Types.hs b/src/Language/Haskell/Brittany/Types.hs index 4a7bf64..3f15427 100644 --- a/src/Language/Haskell/Brittany/Types.hs +++ b/src/Language/Haskell/Brittany/Types.hs @@ -350,6 +350,10 @@ unwrapBriDocNumbered tpl = case snd tpl of where rec = unwrapBriDocNumbered +isNotEmpty :: BriDoc -> Bool +isNotEmpty BDEmpty = False +isNotEmpty _ = True + -- this might not work. is not used anywhere either. briDocSeqSpine :: BriDoc -> () briDocSeqSpine = \case diff --git a/src/Language/Haskell/Brittany/Utils.hs b/src/Language/Haskell/Brittany/Utils.hs index 090a620..170938b 100644 --- a/src/Language/Haskell/Brittany/Utils.hs +++ b/src/Language/Haskell/Brittany/Utils.hs @@ -20,6 +20,8 @@ module Language.Haskell.Brittany.Utils , briDocToDocWithAnns , breakEither , spanMaybe + , transformUp + , transformDownMay ) where @@ -263,3 +265,14 @@ spanMaybe f (x1:xR) | Just y <- f x1 = (y : ys, xs) where (ys, xs) = spanMaybe f xR spanMaybe _ xs = ([], xs) + +-- TODO: move to uniplate upstream? +-- aka `transform` +transformUp :: Uniplate.Uniplate on => (on -> on) -> (on -> on) +transformUp f = g where g = f . Uniplate.descend g +_transformDown :: Uniplate.Uniplate on => (on -> on) -> (on -> on) +_transformDown f = g where g = Uniplate.descend g . f +transformDownMay :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) +transformDownMay f = g where g x = maybe x (Uniplate.descend g) $ f x +_transformDownRec :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) +_transformDownRec f = g where g x = maybe (Uniplate.descend g x) g $ f x diff --git a/srcinc/prelude.inc b/srcinc/prelude.inc index 7481537..3a24199 100644 --- a/srcinc/prelude.inc +++ b/srcinc/prelude.inc @@ -522,6 +522,9 @@ import Prelude ( Char , Traversable ) +import Data.Function ( fix + ) + import Data.Foldable ( foldl' , foldr' , fold