From 449d4b478707da400afdfb180dc02e988c3c592f Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 6 Aug 2016 13:59:05 +0200 Subject: [PATCH] Add BDDebug node to BriDoc --- src/Language/Haskell/Brittany/BriLayouter.hs | 38 ++++++++++++++++--- src/Language/Haskell/Brittany/LayoutBasics.hs | 4 ++ src/Language/Haskell/Brittany/Types.hs | 7 +++- 3 files changed, 43 insertions(+), 6 deletions(-) diff --git a/src/Language/Haskell/Brittany/BriLayouter.hs b/src/Language/Haskell/Brittany/BriLayouter.hs index 86942d3..9f599d8 100644 --- a/src/Language/Haskell/Brittany/BriLayouter.hs +++ b/src/Language/Haskell/Brittany/BriLayouter.hs @@ -412,6 +412,10 @@ transformAlts briDoc 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 () @@ -439,7 +443,7 @@ getSpacing :: forall m . (MonadMultiReader Config m, MonadMultiWriter (Seq Strin getSpacing !bridoc = rec bridoc where rec :: BriDocNumbered -> m (LineModeValidity VerticalSpacing) - rec (_, brDc) = do + rec (brDcId, brDc) = do config <- mAsk result <- case brDc of -- BDWrapAnnKey _annKey bd -> rec bd @@ -550,11 +554,12 @@ getSpacing !bridoc = rec bridoc 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 - mTell $ Seq.singleton ("getSpacing: visiting: " - ++ show (toConstr $ brDc) - ++ " -> " - ++ show result) + tellDebugMess $ "getSpacing: visiting: " ++ show (toConstr $ brDc) ++ " -> " ++ show result #endif return result maxVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing @@ -743,6 +748,10 @@ getSpacings limit bridoc = rec bridoc 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 $ "getSpacings: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): vs=" ++ show r + return r #if INSERTTRACESGETSPACING case brdc of BDFAnnotationPrior{} -> return () @@ -837,6 +846,8 @@ transformSimplifyFloating = stepBO .> stepFull Just $ BDCols sig $ List.init cols ++ [BDAnnotationPost annKey1 $ List.last cols] BDAnnotationPost annKey1 (BDAddBaseY indent x) -> Just $ BDAddBaseY indent $ BDAnnotationPost annKey1 x + BDAnnotationPost annKey1 (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationPost annKey1 x _ -> Nothing descendPrior = transformDownMay $ \case -- prior floating in @@ -850,22 +861,32 @@ transformSimplifyFloating = stepBO .> stepFull 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 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. @@ -891,6 +912,8 @@ transformSimplifyFloating = stepBO .> stepFull 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) $ @@ -1098,6 +1121,7 @@ transformSimplifyColumns = Uniplate.rewrite $ \case BDProhibitMTEL{} -> Nothing BDSetParSpacing{} -> Nothing BDForceParSpacing{} -> Nothing + BDDebug{} -> Nothing BDNonBottomSpacing x -> Just x -- prepare layouting by translating BDPar's, replacing them with Indents and @@ -1165,6 +1189,7 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc BDSetParSpacing bd -> rec bd BDForceParSpacing bd -> rec bd BDNonBottomSpacing bd -> rec bd + BDDebug _ bd -> rec bd layoutBriDocM :: forall w m @@ -1325,6 +1350,9 @@ layoutBriDocM = \case 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 () diff --git a/src/Language/Haskell/Brittany/LayoutBasics.hs b/src/Language/Haskell/Brittany/LayoutBasics.hs index 774b075..4f44d8c 100644 --- a/src/Language/Haskell/Brittany/LayoutBasics.hs +++ b/src/Language/Haskell/Brittany/LayoutBasics.hs @@ -64,6 +64,7 @@ module Language.Haskell.Brittany.LayoutBasics , docNonBottomSpacing , docSetParSpacing , docForceParSpacing + , docDebug , briDocByExact , briDocByExactNoComment , fromMaybeIdentity @@ -942,6 +943,9 @@ docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm docForceParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docForceParSpacing bdm = allocateNode . BDFForceParSpacing =<< bdm +docDebug :: String -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docDebug s bdm = allocateNode . BDFDebug s =<< bdm + appSep :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered appSep x = docSeq [x, docSeparator] diff --git a/src/Language/Haskell/Brittany/Types.hs b/src/Language/Haskell/Brittany/Types.hs index bfca5f5..f82ec9f 100644 --- a/src/Language/Haskell/Brittany/Types.hs +++ b/src/Language/Haskell/Brittany/Types.hs @@ -238,6 +238,7 @@ data BriDoc -- still work, but i should probably completely -- remove it, as i have no proper usecase for -- it anymore. + | BDDebug String BriDoc deriving (Data.Data.Data, Eq, Ord) data BriDocF f @@ -282,6 +283,7 @@ data BriDocF f -- still work, but i should probably completely -- remove it, as i have no proper usecase for -- it anymore. + | BDFDebug String (f (BriDocF f)) -- deriving instance Data.Data.Data (BriDocF Identity) deriving instance Data.Data.Data (BriDocF ((,) Int)) @@ -314,11 +316,12 @@ instance Uniplate.Uniplate BriDoc where uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd uniplate (BDProhibitMTEL bd) = plate BDProhibitMTEL |* bd + uniplate (BDDebug s bd) = plate BDDebug |- s |* bd newtype NodeAllocIndex = NodeAllocIndex Int unwrapBriDocNumbered :: BriDocNumbered -> BriDoc -unwrapBriDocNumbered = snd .> \case +unwrapBriDocNumbered tpl = case snd tpl of BDFEmpty -> BDEmpty BDFLit t -> BDLit t BDFSeq list -> BDSeq $ rec <$> list @@ -343,6 +346,7 @@ unwrapBriDocNumbered = snd .> \case BDFSetParSpacing bd -> BDSetParSpacing $ rec bd BDFForceParSpacing bd -> BDForceParSpacing $ rec bd BDFProhibitMTEL bd -> BDProhibitMTEL $ rec bd + BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd where rec = unwrapBriDocNumbered @@ -372,6 +376,7 @@ briDocSeqSpine = \case BDSetParSpacing bd -> briDocSeqSpine bd BDForceParSpacing bd -> briDocSeqSpine bd BDProhibitMTEL bd -> briDocSeqSpine bd + BDDebug _s bd -> briDocSeqSpine bd briDocForceSpine :: BriDoc -> BriDoc briDocForceSpine bd = briDocSeqSpine bd `seq` bd