Add Set/ForceParSpacing flag special bridoc constructors

src/Language/Haskell/Brittany/BriLayouter.hs

@@ -297,7 +297,7 @@ transformAlts briDoc
               spacings <- alts `forM` getSpacing
               acp <- mGet
               let lineCheck LineModeInvalid = False
-                  lineCheck (LineModeValid (VerticalSpacing _ p)) =
+                  lineCheck (LineModeValid (VerticalSpacing _ p _)) =
                     case _acp_forceMLFlag acp of
                       AltLineModeStateNone      -> True
                       AltLineModeStateForceSL{} -> p == VerticalSpacingParNone
@@ -332,7 +332,7 @@ transformAlts briDoc
             AltChooserBoundedSearch limit -> do
               spacings <- alts `forM` getSpacings limit
               acp <- mGet
-              let lineCheck (VerticalSpacing _ p) =
+              let lineCheck (VerticalSpacing _ p _) =
                     case _acp_forceMLFlag acp of
                       AltLineModeStateNone      -> True
                       AltLineModeStateForceSL{} -> p == VerticalSpacingParNone
@@ -408,6 +408,8 @@ transformAlts briDoc
         BDFEnsureIndent indent bd ->
           reWrap . BDFEnsureIndent indent <$> rec bd
         BDFNonBottomSpacing bd -> rec bd
+        BDFSetParSpacing bd -> rec bd
+        BDFForceParSpacing bd -> rec bd
         BDFProhibitMTEL bd ->
           reWrap . BDFProhibitMTEL <$> rec bd
     processSpacingSimple :: (MonadMultiReader
@@ -415,22 +417,22 @@ transformAlts briDoc
                                                    MonadMultiState AltCurPos m, MonadMultiWriter (Seq String) m) => BriDocNumbered -> m ()
     processSpacingSimple bd = getSpacing bd >>= \case
       LineModeInvalid                           -> error "processSpacingSimple inv"
-      LineModeValid (VerticalSpacing i VerticalSpacingParNone) -> do
+      LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do
         acp <- mGet
         mSet $ acp { _acp_line = _acp_line acp + i }
-      LineModeValid (VerticalSpacing _ _)  -> error "processSpacingSimple par"
+      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)
+    hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _)
       = line + sameLine <= runIdentity (_lconfig_cols lconf)
-    hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par))
+    hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _)
       = line + sameLine <= runIdentity (_lconfig_cols lconf)
         && indent + indentPrep + par <= runIdentity (_lconfig_cols lconf)
-    hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNonBottom)
+    hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNonBottom _)
       = line + sameLine <= runIdentity (_lconfig_cols lconf)
 
 getSpacing :: forall m . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) => BriDocNumbered -> m (LineModeValidity VerticalSpacing)
@@ -442,14 +444,14 @@ getSpacing !bridoc = rec bridoc
     result <- case brDc of
       -- BDWrapAnnKey _annKey bd -> rec bd
       BDFEmpty ->
-        return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone
+        return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False
       BDFLit t ->
-        return $ LineModeValid $ VerticalSpacing (Text.length t) VerticalSpacingParNone
+        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
+        return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False
       BDFAddBaseY indent bd -> do
         mVs <- rec bd
         return $ mVs <&> \vs -> vs
@@ -485,13 +487,19 @@ getSpacing !bridoc = rec bridoc
       BDFIndentLevelPop bd -> rec bd
       BDFPar BrIndentNone sameLine indented -> do
         mVs <- rec sameLine
-        indSp <- rec indented
+        mIndSp <- rec indented
-        return $ [ VerticalSpacing lsp $ case mPsp of
+        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
                     VerticalSpacingParNonBottom -> VerticalSpacingParNonBottom
-                 | VerticalSpacing lsp mPsp <- mVs
+            , let parFlagResult =  mPsp == VerticalSpacingParNone
-                 , lineMax <- getMaxVS $ indSp
+                                && _vs_paragraph indSp ==  VerticalSpacingParNone
+                                && _vs_parFlag indSp
             ]
       BDFPar{} -> error "BDPar with indent in getSpacing"
       BDFAlt [] -> error "empty BDAlt"
@@ -499,20 +507,22 @@ getSpacing !bridoc = rec bridoc
       BDFForceMultiline  bd -> rec bd
       BDFForceSingleline bd -> do
         mVs <- rec bd
-        return $ mVs >>= \(VerticalSpacing _ psp) ->
+        return $ mVs >>= _vs_paragraph .> \case
-          case psp of
           VerticalSpacingParNone -> mVs
           _  -> LineModeInvalid
       BDFForwardLineMode bd -> rec bd
-      BDFExternal{} ->
+      BDFExternal{} -> return
-        return $ LineModeValid $ VerticalSpacing 999 VerticalSpacingParNone
+        $ LineModeValid
+        $ VerticalSpacing 999 VerticalSpacingParNone False
       BDFAnnotationPrior _annKey bd -> rec bd
       BDFAnnotationPost  _annKey bd -> rec bd
-      BDFLines [] -> return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone
+      BDFLines [] -> return
+        $ LineModeValid
+        $ VerticalSpacing 0 VerticalSpacingParNone False
       BDFLines ls@(_:_) -> do
         lSps@(mVs:_) <- rec `mapM` ls
-        return $ [ VerticalSpacing lsp $ VerticalSpacingParSome $ lineMax
+        return $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False
-                 | VerticalSpacing lsp _ <- mVs
+                 | VerticalSpacing lsp _ _ <- mVs
                  , lineMax <- getMaxVS $ maxVs $ lSps
                  ]
       BDFEnsureIndent indent bd -> do
@@ -524,11 +534,21 @@ getSpacing !bridoc = rec bridoc
                                  $ _conf_layout
                                  $ config
               BrIndentSpecial i -> i
-        return $ mVs <&> \(VerticalSpacing lsp psp) ->
+        return $ mVs <&> \(VerticalSpacing lsp psp pf) ->
-          VerticalSpacing (lsp + addInd) psp
+          VerticalSpacing (lsp + addInd) psp pf
       BDFNonBottomSpacing bd -> do
         mVs <- rec bd
-        return $ mVs <|> LineModeValid (VerticalSpacing 0 VerticalSpacingParNonBottom)
+        return
+          $   mVs
+          <|> LineModeValid (VerticalSpacing 0
+                                             VerticalSpacingParNonBottom
+                                             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
 #if INSERTTRACESGETSPACING
     mTell $ Seq.singleton ("getSpacing: visiting: "
@@ -539,26 +559,36 @@ getSpacing !bridoc = rec bridoc
     return result
   maxVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing
   maxVs = foldl'
-    (liftM2 (\(VerticalSpacing x1 x2) (VerticalSpacing y1 y2) ->
+    (liftM2 (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) ->
         VerticalSpacing (max x1 y1) (case (x2, y2) of
           (x, VerticalSpacingParNone) -> x
           (VerticalSpacingParNone, x) -> x
           (_, VerticalSpacingParNonBottom) -> VerticalSpacingParNonBottom
           (VerticalSpacingParNonBottom, _) -> VerticalSpacingParNonBottom
-          (VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ max x y)))
+          (VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ max x y) False))
-    (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone)
+    (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False)
   sumVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing
-  sumVs = foldl'
+  sumVs sps = foldl' (liftM2 go) initial sps
-    (liftM2 (\(VerticalSpacing x1 x2) (VerticalSpacing y1 y2) ->
+   where
-        VerticalSpacing (x1 + y1) (case (x2, y2) of
+    go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing
+      (x1 + y1)
+      (case (x2, y2) of
         (x, VerticalSpacingParNone) -> x
         (VerticalSpacingParNone, x) -> x
         (_, VerticalSpacingParNonBottom) -> VerticalSpacingParNonBottom
         (VerticalSpacingParNonBottom, _) -> VerticalSpacingParNonBottom
-          (VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ x + y)))
+        (VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ x + y)
-    (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone)
+      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
+  getMaxVS = fmap $ \(VerticalSpacing x1 x2 _) -> x1 `max` case x2 of
     VerticalSpacingParSome i -> i
     VerticalSpacingParNone -> 0
     VerticalSpacingParNonBottom -> 999
@@ -570,10 +600,10 @@ getSpacings limit bridoc = rec bridoc
     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 (bdKey, brdc) = memoWithKey bdKey $ do
+    rec (brDcId, brdc) = memoWithKey brDcId $ do
       config <- mAsk
       let colMax = config & _conf_layout & _lconfig_cols & runIdentity
-      let hasOkColCount (VerticalSpacing lsp psp) =
+      let hasOkColCount (VerticalSpacing lsp psp _) =
             lsp <= colMax && case psp of
               VerticalSpacingParNone -> True
               VerticalSpacingParSome i -> i <= colMax
@@ -584,15 +614,15 @@ getSpacings limit bridoc = rec bridoc
       result <- case brdc of
         -- BDWrapAnnKey _annKey bd -> rec bd
         BDFEmpty ->
-          return $ [VerticalSpacing 0 VerticalSpacingParNone]
+          return $ [VerticalSpacing 0 VerticalSpacingParNone False]
         BDFLit t ->
-          return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone]
+          return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False]
         BDFSeq list ->
           filterAndLimit . fmap sumVs . sequence <$> rec `mapM` list
         BDFCols _sig list ->
           filterAndLimit . fmap sumVs . sequence <$> rec `mapM` list
         BDFSeparator ->
-          return $ [VerticalSpacing 1 VerticalSpacingParNone]
+          return $ [VerticalSpacing 1 VerticalSpacingParNone False]
         BDFAddBaseY indent bd -> do
           mVs <- rec bd
           return $ mVs <&> \vs -> vs
@@ -639,12 +669,19 @@ getSpacings limit bridoc = rec bridoc
                          , hasOkColCount y
                          ]
           return $ mVsIndSp <&>
-            \(VerticalSpacing lsp mPsp, indSp) ->
+            \(VerticalSpacing lsp mPsp _, indSp) ->
-              VerticalSpacing lsp $ case mPsp of
+              VerticalSpacing
+                lsp
+                (case mPsp of
                   VerticalSpacingParSome psp ->
                     VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO
                   VerticalSpacingParNone -> spMakePar indSp
-                VerticalSpacingParNonBottom -> VerticalSpacingParNonBottom
+                  VerticalSpacingParNonBottom -> VerticalSpacingParNonBottom)
+                (  mPsp == VerticalSpacingParNone
+                && _vs_paragraph indSp == VerticalSpacingParNone
+                && _vs_parFlag indSp
+                )
+
         BDFPar{} -> error "BDPar with indent in getSpacing"
         BDFAlt [] -> error "empty BDAlt"
         -- BDAlt (alt:_) -> rec alt
@@ -661,7 +698,7 @@ getSpacings limit bridoc = rec bridoc
                       -- this.
         BDFAnnotationPrior _annKey bd -> rec bd
         BDFAnnotationPost  _annKey bd -> rec bd
-        BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone]
+        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
@@ -671,7 +708,7 @@ getSpacings limit bridoc = rec bridoc
           lSpss <- rec `mapM` ls
           return $ filterAndLimit
                  $ Control.Lens.transposeOf traverse lSpss <&> \lSps ->
-                     VerticalSpacing 0 (spMakePar $ maxVs lSps)
+                     VerticalSpacing 0 (spMakePar $ maxVs lSps) False
           -- lSpss@(mVs:_) <- rec `mapM` ls
           -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only
           --                      -- consider the first alternative for the
@@ -692,13 +729,19 @@ getSpacings limit bridoc = rec bridoc
                                    $ _conf_layout
                                    $ config
                 BrIndentSpecial i -> i
-          return $ mVs <&> \(VerticalSpacing lsp psp) ->
+          return $ mVs <&> \(VerticalSpacing lsp psp parFlag) ->
-            VerticalSpacing (lsp + addInd) psp
+            VerticalSpacing (lsp + addInd) psp parFlag
         BDFNonBottomSpacing bd -> do
           mVs <- rec bd
           return $ if null mVs
-            then [VerticalSpacing 0 VerticalSpacingParNonBottom]
+            then [VerticalSpacing 0 VerticalSpacingParNonBottom False]
             else mVs <&> \vs -> vs { _vs_paragraph = VerticalSpacingParNonBottom}
+        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
 #if INSERTTRACESGETSPACING
       case brdc of
@@ -713,31 +756,42 @@ getSpacings limit bridoc = rec bridoc
       return result
     maxVs :: [VerticalSpacing] -> VerticalSpacing
     maxVs = foldl'
-      (\(VerticalSpacing x1 x2) (VerticalSpacing y1 y2) ->
+      (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) ->
-          VerticalSpacing (max x1 y1) (case (x2, y2) of
+          VerticalSpacing
+            (max x1 y1)
+            (case (x2, y2) of
               (x, VerticalSpacingParNone) -> x
               (VerticalSpacingParNone, x) -> x
               (_, VerticalSpacingParNonBottom) -> VerticalSpacingParNonBottom
               (VerticalSpacingParNonBottom, _) -> VerticalSpacingParNonBottom
-            (VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ max x y))
+              (VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ max x y)
-      (VerticalSpacing 0 VerticalSpacingParNone)
+            False)
+      (VerticalSpacing 0 VerticalSpacingParNone False)
     sumVs :: [VerticalSpacing] -> VerticalSpacing
-    sumVs = foldl'
+    sumVs sps = foldl' go initial sps
-      (\(VerticalSpacing x1 x2) (VerticalSpacing y1 y2) ->
+     where
-          VerticalSpacing (x1 + y1) (case (x2, y2) of
+      go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing
+        (x1 + y1)
+        (case (x2, y2) of
           (x, VerticalSpacingParNone) -> x
           (VerticalSpacingParNone, x) -> x
           (_, VerticalSpacingParNonBottom) -> VerticalSpacingParNonBottom
           (VerticalSpacingParNonBottom, _) -> VerticalSpacingParNonBottom
-            (VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ x + y))
+          (VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ x + y)
-      (VerticalSpacing 0 VerticalSpacingParNone)
+        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
+    getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of
       VerticalSpacingParSome i -> i
       VerticalSpacingParNone -> 0
       VerticalSpacingParNonBottom -> 999
     spMakePar :: VerticalSpacing -> VerticalSpacingPar
-    spMakePar (VerticalSpacing x1 x2) = case x2 of
+    spMakePar (VerticalSpacing x1 x2 _) = case x2 of
       VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i
       VerticalSpacingParNone -> VerticalSpacingParSome $ x1
       VerticalSpacingParNonBottom -> VerticalSpacingParNonBottom
@@ -1042,6 +1096,8 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
   BDAnnotationPost{}  -> Nothing
   BDEnsureIndent{}    -> Nothing
   BDProhibitMTEL{}    -> Nothing
+  BDSetParSpacing{}   -> Nothing
+  BDForceParSpacing{} -> Nothing
   BDNonBottomSpacing x -> Just x
 
 -- prepare layouting by translating BDPar's, replacing them with Indents and
@@ -1106,6 +1162,8 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
     BDLines [] -> error "briDocLineLength BDLines []"
     BDEnsureIndent _ bd -> rec bd
     BDProhibitMTEL bd -> rec bd
+    BDSetParSpacing bd -> rec bd
+    BDForceParSpacing bd -> rec bd
     BDNonBottomSpacing bd -> rec bd
 
 layoutBriDocM
@@ -1249,6 +1307,8 @@ layoutBriDocM = \case
             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

src/Language/Haskell/Brittany/LayoutBasics.hs

@@ -62,6 +62,8 @@ module Language.Haskell.Brittany.LayoutBasics
   , docAnnotationPrior
   , docAnnotationPost
   , docNonBottomSpacing
+  , docSetParSpacing
+  , docForceParSpacing
   , briDocByExact
   , briDocByExactNoComment
   , fromMaybeIdentity
@@ -934,6 +936,12 @@ docAnnotationPost  annKey bdm = allocateNode . BDFAnnotationPost annKey =<< bdm
 docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
 docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm
 
+docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
+docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm
+
+docForceParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
+docForceParSpacing bdm = allocateNode . BDFForceParSpacing =<< bdm
+
 appSep :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
 appSep x = docSeq [x, docSeparator]
 

src/Language/Haskell/Brittany/Layouters/Decl.hs

@@ -112,6 +112,8 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of
   EmptyLocalBinds     ->
     return $ Nothing
 
+-- TODO: we don't need the `LHsExpr RdrName` anymore, now that there is
+-- parSpacing stuff.B
 layoutGrhs :: LGRHS RdrName (LHsExpr RdrName) -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr RdrName)
 layoutGrhs lgrhs@(L _ (GRHS guards body))
   = do
@@ -175,15 +177,11 @@ layoutPatternBindFinal binderDoc mPatDoc clauseDocs mWhereDocs = do
         (patPartInline ++ [guardPart])
       , docSeq
         [ appSep $ return binderDoc
-        , lineMod $ return body
+        , docForceSingleline $ return body
         , wherePart
         ]
       ]
-    | [(guards, body, bodyRaw)] <- [clauseDocs]
+    | [(guards, body, _bodyRaw)] <- [clauseDocs]
-    , let lineMod = case mWhereDocs of
-            Nothing | isExpressionTypeHeadPar bodyRaw ->
-              docAddBaseY BrIndentRegular
-            _ -> docForceSingleline
     , let guardPart = case guards of
             [] -> docEmpty
             [g] -> docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator]
@@ -207,15 +205,11 @@ layoutPatternBindFinal binderDoc mPatDoc clauseDocs mWhereDocs = do
           (patPartInline ++ [guardPart])
         , docSeq
           [ appSep $ return binderDoc
-          , lineMod $ return body
+          , docForceParSpacing $ return body
           ]
         ]
       ] ++ wherePartMultiLine
-    | [(guards, body, bodyRaw)] <- [clauseDocs]
+    | [(guards, body, _bodyRaw)] <- [clauseDocs]
-    , let lineMod = case mWhereDocs of
-            Nothing | isExpressionTypeHeadPar bodyRaw ->
-              docAddBaseY BrIndentRegular
-            _ -> docForceSingleline
     , let guardPart = case guards of
             [] -> docEmpty
             [g] -> docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator]
@@ -250,7 +244,7 @@ layoutPatternBindFinal binderDoc mPatDoc clauseDocs mWhereDocs = do
           (patPartInline ++ [appSep guardPart])
         , docSeq
           [ appSep $ return binderDoc
-          , lineMod $ docAddBaseY BrIndentRegular $ return body
+          , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body
           -- , lineMod $ docAlt
           --   [ docSetBaseY $ return body
           --   , docAddBaseY BrIndentRegular $ return body
@@ -258,10 +252,7 @@ layoutPatternBindFinal binderDoc mPatDoc clauseDocs mWhereDocs = do
           ]
         ]
       ] ++ wherePartMultiLine
-    | [(guards, body, bodyRaw)] <- [clauseDocs]
+    | [(guards, body, _bodyRaw)] <- [clauseDocs]
-    , let lineMod = case () of
-            _ | isExpressionTypeHeadPar bodyRaw -> id
-            _ -> docForceSingleline
     , let guardPart = case guards of
             [] -> docEmpty
             [g] -> docSeq [appSep $ docLit $ Text.pack "|", return g]
@@ -274,8 +265,7 @@ layoutPatternBindFinal binderDoc mPatDoc clauseDocs mWhereDocs = do
     $ [ docSeq (patPartInline ++ [appSep $ guardPart, return binderDoc])
       , docEnsureIndent BrIndentRegular
       $ docNonBottomSpacing
-      $ docLines
+      $ (docAddBaseY BrIndentRegular $ return body)
-      $ [ docAddBaseY BrIndentRegular $ return body ]
       ] ++ wherePartMultiLine
     | [(guards, body, _)] <- [clauseDocs]
     , let guardPart = case guards of

src/Language/Haskell/Brittany/Layouters/Expr.hs

@@ -3,8 +3,6 @@
 module Language.Haskell.Brittany.Layouters.Expr
   ( layoutExpr
   , litBriDoc
-  , isExpressionTypeHeadPar
-  , isExpressionTypeHeadPar'
   , overLitValBriDoc
   )
 where
@@ -57,15 +55,12 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
     let funcPatternPartLine =
           docCols ColCasePattern
             $ (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator]))
-    let lineMod = if isExpressionTypeHeadPar body
-          then id
-          else docForceSingleline
     docAlt
       [ docSeq
         [ docLit $ Text.pack "\\"
         , docWrapNode lmatch $ docForceSingleline funcPatternPartLine
         , appSep $ docLit $ Text.pack "->"
-        , docWrapNode lgrhs $ lineMod bodyDoc
+        , docWrapNode lgrhs $ docForceParSpacing bodyDoc
         ]
       , docAddBaseY BrIndentRegular
       $ docPar
@@ -81,7 +76,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
   HsLamCase _ (MG lmatches@(L _ matches) _ _ _) -> do
     binderDoc <- docLit $ Text.pack "->"
     funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches
-    docAddBaseY BrIndentRegular $ docPar
+    docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
       (docLit $ Text.pack "\\case")
       (docSetIndentLevel $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs)
   HsApp exp1@(L _ HsApp{}) exp2 -> do
@@ -103,6 +98,13 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
         $ docLines
         $ paramDocs
         ]
+      , docSetParSpacing
+      $ docAddBaseY BrIndentRegular
+      $ docPar
+        (docForceSingleline headDoc)
+        ( docNonBottomSpacing
+        $ docLines paramDocs
+        )
       , docAddBaseY BrIndentRegular
       $ docPar
         headDoc
@@ -116,6 +118,11 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
     expDoc2 <- docSharedWrapper layoutExpr exp2
     docAlt
       [ docSeq [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2]
+      , docSetParSpacing
+      $ docAddBaseY BrIndentRegular
+      $ docPar
+        (docForceSingleline expDoc1)
+        expDoc2
       , docAddBaseY BrIndentRegular
       $ docPar
         expDoc1
@@ -150,49 +157,59 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
             ]
           )
         , appSep $ docForceSingleline opLastDoc
-        , docForceSingleline expLastDoc
+        , docForceParSpacing expLastDoc
         ]
-      , docSetBaseY
+      -- this case rather leads to some unfortunate layouting than to anything
+      -- useful; disabling for now. (it interfers with cols stuff.)
+      -- , docSetBaseY
+      -- $ docPar
+      --     leftOperandDoc
+      --     ( docLines
+      --     $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed])
+      --       ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]]
+      --     )
+      , docAddBaseY BrIndentRegular
       $ docPar
           leftOperandDoc
           ( docLines
           $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed])
             ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]]
           )
-      , docPar
-          leftOperandDoc
-          ( docLines
-          $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed])
-            ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]]
-          )
       ]
   OpApp expLeft expOp _ expRight -> do
     expDocLeft  <- docSharedWrapper layoutExpr expLeft
     expDocOp    <- docSharedWrapper layoutExpr expOp
     expDocRight <- docSharedWrapper layoutExpr expRight
     docAlt
-      $   [ docSeq
+      $   [ -- one-line
+            docSeq
             [ appSep $ docForceSingleline expDocLeft
             , appSep $ docForceSingleline expDocOp
             , docForceSingleline expDocRight
             ]
-          ]
+          , -- line + freely indented block for right expression
-      ++  [ docSeq
+            docSeq
-            [ appSep $ docForceSingleline expDocLeft
-            , appSep $ docForceSingleline expDocOp
-            , docForceMultiline expDocRight
-            ]
-          | isExpressionTypeHeadPar expRight
-          ]
-      ++  [ docSeq
             [ appSep $ docForceSingleline expDocLeft
             , appSep $ docForceSingleline expDocOp
             , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight
             ]
-          , docAddBaseY BrIndentRegular
+          , -- two-line
+            docAddBaseY BrIndentRegular
+          $ docPar
+              expDocLeft
+              ( docForceSingleline
+              $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight]
+              )
+          , -- one-line + par
+            docSeq
+            [ appSep $ docForceSingleline expDocLeft
+            , appSep $ docForceSingleline expDocOp
+            , docForceParSpacing expDocRight
+            ]
+          , -- more lines
+            docAddBaseY BrIndentRegular
           $ docPar
               expDocLeft
-              -- TODO: turn this into docCols?
               (docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight])
           ]
   NegApp{} -> do
@@ -247,7 +264,8 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
     binderDoc <- docLit $ Text.pack "->"
     funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches
     docAlt
-      [ docAddBaseY BrIndentRegular
+      [ docSetParSpacing
+      $ docAddBaseY BrIndentRegular
       $ docPar
         ( docSeq
           [ appSep $ docLit $ Text.pack "case"
@@ -268,12 +286,6 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
     ifExprDoc   <- docSharedWrapper layoutExpr ifExpr
     thenExprDoc <- docSharedWrapper layoutExpr thenExpr
     elseExprDoc <- docSharedWrapper layoutExpr elseExpr
-    let thenMod = if isExpressionTypeHeadPar thenExpr
-          then id
-          else docForceSingleline
-        elseMod = if isExpressionTypeHeadPar elseExpr
-          then id
-          else docForceSingleline
     docAlt
       [ docSeq
         [ appSep $ docLit $ Text.pack "if"
@@ -283,6 +295,25 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
         , appSep $ docLit $ Text.pack "else"
         , docForceSingleline elseExprDoc
         ]
+      , docSetParSpacing
+      $ docAddBaseY BrIndentRegular
+      $ docPar
+          ( docAddBaseY (BrIndentSpecial 3)
+          $ docSeq [appSep $ docLit $ Text.pack "if", docForceSingleline ifExprDoc])
+          (docLines
+            [ docAddBaseY BrIndentRegular
+            $ docAlt
+              [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc]
+              , docAddBaseY BrIndentRegular
+              $ docPar (docLit $ Text.pack "then") thenExprDoc
+              ]
+            , docAddBaseY BrIndentRegular
+            $ docAlt
+              [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc]
+              , docAddBaseY BrIndentRegular
+              $ docPar (docLit $ Text.pack "else") elseExprDoc
+              ]
+            ])
       , docAddBaseY BrIndentRegular
       $ docPar
           ( docAddBaseY (BrIndentSpecial 3)
@@ -290,13 +321,13 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
           (docLines
             [ docAddBaseY BrIndentRegular
             $ docAlt
-              [ docSeq [appSep $ docLit $ Text.pack "then", thenMod thenExprDoc]
+              [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc]
               , docAddBaseY BrIndentRegular
               $ docPar (docLit $ Text.pack "then") thenExprDoc
               ]
             , docAddBaseY BrIndentRegular
             $ docAlt
-              [ docSeq [appSep $ docLit $ Text.pack "else", elseMod elseExprDoc]
+              [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc]
               , docAddBaseY BrIndentRegular
               $ docPar (docLit $ Text.pack "else") elseExprDoc
               ]
@@ -374,7 +405,8 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
     -- docSeq [appSep $ docLit "let in", expDoc1]
   HsDo DoExpr (L _ stmts) _ -> do
     stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts
-    docAddBaseY BrIndentRegular
+    docSetParSpacing
+      $ docAddBaseY BrIndentRegular
       $ docPar
           (docLit $ Text.pack "do")
           (docSetIndentLevel $ docNonBottomSpacing $ docLines stmtDocs)
@@ -434,7 +466,8 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
       fExpDoc <- docSharedWrapper layoutExpr fExpr
       return $ (fieldl, lrdrNameToText lnameF, fExpDoc)
     docAlt
-      [ docAddBaseY BrIndentRegular
+      [ docSetParSpacing
+      $ docAddBaseY BrIndentRegular
       $ docPar
           (docLit t)
           (docLines $ let
@@ -471,7 +504,8 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
           Ambiguous   n _ -> (lfield, lrdrNameToText n, rFExpDoc)
     docAlt
       -- singleline
-      [ docSeq
+      [ docSetParSpacing
+      $ docSeq
         [ appSep rExprDoc
         , appSep $ docLit $ Text.pack "{"
         , appSep $ docSeq $ List.intersperse docCommaSep
@@ -504,7 +538,8 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
             in [line1] ++ lineR ++ [lineN]
         ]
       -- strict indentation block
-      , docAddBaseY BrIndentRegular
+      , docSetParSpacing
+      $ docAddBaseY BrIndentRegular
       $ docPar
           rExprDoc
           (docNonBottomSpacing $ docLines $ let
@@ -638,42 +673,6 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
     -- TODO
     briDocByExact lexpr
 
-isExpressionTypeHeadPar :: LHsExpr RdrName -> Bool
-isExpressionTypeHeadPar (L _ expr) = case expr of
-  RecordCon{} -> True
-  RecordUpd{} -> True
-  HsDo{} -> True
-  HsIf{} -> True
-  HsLamCase{} -> True
-  -- TODO: these cases might have unfortunate layouts, if for some reason
-  -- the first operand is multiline.
-  OpApp _ _ _ (L _ HsDo{}) -> True
-  OpApp _ _ _ (L _ HsLamCase{}) -> True
-  OpApp _ _ _ (L _ HsLam{}) -> True
-  OpApp (L _ (OpApp left _ _ _)) _ _ _ | leftVar left -> True
-    where
-      -- leftVar (L _ x) | traceShow (Data.Data.toConstr x) False = error "foo"
-      leftVar (L _ HsVar{}) = True
-      leftVar (L _ (OpApp x _ _ _)) = leftVar x
-      leftVar _ = False
-  _ -> False
-
-isExpressionTypeHeadPar' :: LHsExpr RdrName -> Bool
-isExpressionTypeHeadPar' (L _ expr) = case expr of
-  RecordCon{} -> True
-  RecordUpd{} -> True
-  HsDo{} -> True
-  HsIf{} -> True
-  HsLamCase{} -> True
-  -- TODO: these cases might have unfortunate layouts, if for some reason
-  -- the first operand is multiline.
-  OpApp _ _ _ (L _ HsDo{}) -> True
-  OpApp _ _ _ (L _ HsLamCase{}) -> True
-  HsApp (L _ HsVar{}) _ -> True
-  HsApp (L _ (HsApp (L _ HsVar{}) _)) _ -> True
-  HsApp (L _ (HsApp (L _ (HsApp (L _ HsVar{}) _)) _)) _ -> True -- TODO: the obvious
-  _ -> False
-
 litBriDoc :: HsLit -> BriDocFInt
 litBriDoc = \case
   HsChar       t _c           -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\'']

src/Language/Haskell/Brittany/Layouters/Expr.hs-boot

@@ -3,8 +3,6 @@
 module Language.Haskell.Brittany.Layouters.Expr
   ( layoutExpr
   , litBriDoc
-  , isExpressionTypeHeadPar
-  , isExpressionTypeHeadPar'
   , overLitValBriDoc
   )
 where
@@ -30,7 +28,4 @@ layoutExpr :: ToBriDoc HsExpr
 
 litBriDoc :: HsLit -> BriDocFInt
 
-isExpressionTypeHeadPar :: LHsExpr RdrName -> Bool
-isExpressionTypeHeadPar' :: LHsExpr RdrName -> Bool
-
 overLitValBriDoc :: OverLitVal -> BriDocFInt

src/Language/Haskell/Brittany/Types.hs

@@ -214,8 +214,6 @@ data BriDoc
   -- | BDAddIndent BrIndent (BriDocF f)
   -- | BDNewline
   | BDAlt [BriDoc]
-  | BDForceMultiline BriDoc
-  | BDForceSingleline BriDoc
   | BDForwardLineMode BriDoc
   | BDExternal AnnKey
                (Set AnnKey) -- set of annkeys contained within the node
@@ -226,7 +224,15 @@ data BriDoc
   | BDAnnotationPost  AnnKey BriDoc
   | BDLines [BriDoc]
   | BDEnsureIndent BrIndent BriDoc
+  -- the following constructors are only relevant for the alt transformation
+  -- and are removed afterwards. They should never occur in any BriDoc
+  -- after the alt transformation.
+  | BDForceMultiline BriDoc
+  | BDForceSingleline BriDoc
   | BDNonBottomSpacing BriDoc
+  | BDSetParSpacing BriDoc
+  | BDForceParSpacing BriDoc
+  -- pseudo-deprecated
   | BDProhibitMTEL BriDoc -- move to exact location
                           -- TODO: this constructor is deprecated. should
                           --       still work, but i should probably completely
@@ -256,8 +262,6 @@ data BriDocF f
   -- | BDAddIndent BrIndent (BriDocF f)
   -- | BDNewline
   | BDFAlt [f (BriDocF f)]
-  | BDFForceMultiline (f (BriDocF f))
-  | BDFForceSingleline (f (BriDocF f))
   | BDFForwardLineMode (f (BriDocF f))
   | BDFExternal AnnKey
                (Set AnnKey) -- set of annkeys contained within the node
@@ -268,7 +272,11 @@ data BriDocF f
   | BDFAnnotationPost  AnnKey (f (BriDocF f))
   | BDFLines [(f (BriDocF f))]
   | BDFEnsureIndent BrIndent (f (BriDocF f))
+  | BDFForceMultiline (f (BriDocF f))
+  | BDFForceSingleline (f (BriDocF f))
   | BDFNonBottomSpacing (f (BriDocF f))
+  | BDFSetParSpacing (f (BriDocF f))
+  | BDFForceParSpacing (f (BriDocF f))
   | BDFProhibitMTEL (f (BriDocF f)) -- move to exact location
                           -- TODO: this constructor is deprecated. should
                           --       still work, but i should probably completely
@@ -294,15 +302,17 @@ instance Uniplate.Uniplate BriDoc where
   uniplate (BDIndentLevelPop bd)         = plate BDIndentLevelPop |* bd
   uniplate (BDPar ind line indented)     = plate BDPar |- ind |* line |* indented
   uniplate (BDAlt alts)                  = plate BDAlt ||* alts
-  uniplate (BDForceMultiline  bd)        = plate BDForceMultiline |* bd
-  uniplate (BDForceSingleline bd)        = plate BDForceSingleline |* bd
   uniplate (BDForwardLineMode bd)        = plate BDForwardLineMode |* bd
   uniplate x@BDExternal{}                = plate x
   uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd
   uniplate (BDAnnotationPost  annKey bd) = plate BDAnnotationPost  |- annKey |* bd
   uniplate (BDLines lines)               = plate BDLines ||* lines
   uniplate (BDEnsureIndent ind bd)       = plate BDEnsureIndent |- ind |* bd
+  uniplate (BDForceMultiline  bd)        = plate BDForceMultiline |* bd
+  uniplate (BDForceSingleline bd)        = plate BDForceSingleline |* bd
   uniplate (BDNonBottomSpacing bd)       = plate BDNonBottomSpacing |* bd
+  uniplate (BDSetParSpacing bd)          = plate BDSetParSpacing |* bd
+  uniplate (BDForceParSpacing bd)        = plate BDForceParSpacing |* bd
   uniplate (BDProhibitMTEL bd)           = plate BDProhibitMTEL |* bd
 
 newtype NodeAllocIndex = NodeAllocIndex Int
@@ -321,15 +331,17 @@ unwrapBriDocNumbered = snd .> \case
   BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd
   BDFPar ind line indented -> BDPar ind (rec line) (rec indented)
   BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen
-  BDFForceMultiline  bd -> BDForceMultiline $ rec bd
-  BDFForceSingleline bd -> BDForceSingleline $ rec bd
   BDFForwardLineMode bd -> BDForwardLineMode $ rec bd
   BDFExternal k ks c t -> BDExternal k ks c t
   BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd
   BDFAnnotationPost  annKey bd -> BDAnnotationPost  annKey $ rec bd
   BDFLines lines -> BDLines $ rec <$> lines
   BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd
+  BDFForceMultiline  bd -> BDForceMultiline $ rec bd
+  BDFForceSingleline bd -> BDForceSingleline $ rec bd
   BDFNonBottomSpacing bd -> BDNonBottomSpacing $ rec bd
+  BDFSetParSpacing bd -> BDSetParSpacing $ rec bd
+  BDFForceParSpacing bd -> BDForceParSpacing $ rec bd
   BDFProhibitMTEL bd -> BDProhibitMTEL $ rec bd
  where
   rec = unwrapBriDocNumbered
@@ -348,15 +360,17 @@ briDocSeqSpine = \case
   BDIndentLevelPop bd -> briDocSeqSpine bd
   BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented
   BDAlt alts -> foldl' (\(!()) -> briDocSeqSpine) () alts
-  BDForceMultiline  bd -> briDocSeqSpine bd
-  BDForceSingleline bd -> briDocSeqSpine bd
   BDForwardLineMode bd -> briDocSeqSpine bd
   BDExternal{} -> ()
   BDAnnotationPrior _annKey bd -> briDocSeqSpine bd
   BDAnnotationPost  _annKey bd -> briDocSeqSpine bd
   BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines
   BDEnsureIndent _ind bd -> briDocSeqSpine bd
+  BDForceMultiline  bd -> briDocSeqSpine bd
+  BDForceSingleline bd -> briDocSeqSpine bd
   BDNonBottomSpacing bd -> briDocSeqSpine bd
+  BDSetParSpacing bd -> briDocSeqSpine bd
+  BDForceParSpacing bd -> briDocSeqSpine bd
   BDProhibitMTEL bd -> briDocSeqSpine bd
 
 briDocForceSpine :: BriDoc -> BriDoc
@@ -377,6 +391,7 @@ data VerticalSpacing
   = VerticalSpacing
     { _vs_sameLine  :: !Int
     , _vs_paragraph :: !VerticalSpacingPar
+    , _vs_parFlag   :: !Bool
     }
   deriving Show