Add BDDebug node to BriDoc

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: "
+    tellDebugMess $ "getSpacing: visiting: " ++ show (toConstr $ brDc) ++ " -> " ++ show result
-                          ++ 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 ()

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]
 

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