From 1c5795f71846111527f32e99881ec6cbd6897eaf Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 6 Aug 2016 13:51:54 +0200 Subject: [PATCH] Add Set/ForceParSpacing flag special bridoc constructors --- src/Language/Haskell/Brittany/BriLayouter.hs | 214 +++++++++++------- src/Language/Haskell/Brittany/LayoutBasics.hs | 8 + .../Haskell/Brittany/Layouters/Decl.hs | 28 +-- .../Haskell/Brittany/Layouters/Expr.hs | 157 +++++++------ .../Haskell/Brittany/Layouters/Expr.hs-boot | 5 - src/Language/Haskell/Brittany/Types.hs | 35 ++- 6 files changed, 257 insertions(+), 190 deletions(-) diff --git a/src/Language/Haskell/Brittany/BriLayouter.hs b/src/Language/Haskell/Brittany/BriLayouter.hs index b9ccaba..86942d3 100644 --- a/src/Language/Haskell/Brittany/BriLayouter.hs +++ b/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,34 +487,42 @@ getSpacing !bridoc = rec bridoc BDFIndentLevelPop bd -> rec bd BDFPar BrIndentNone sameLine indented -> do mVs <- rec sameLine - indSp <- rec indented - return $ [ VerticalSpacing lsp $ case mPsp of - VerticalSpacingParSome psp -> VerticalSpacingParSome $ max psp lineMax - VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax + 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 VerticalSpacingParNonBottom -> VerticalSpacingParNonBottom - | VerticalSpacing lsp mPsp <- mVs - , lineMax <- getMaxVS $ indSp - ] + , 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 >>= \(VerticalSpacing _ psp) -> - case psp of - VerticalSpacingParNone -> mVs - _ -> LineModeInvalid + return $ mVs >>= _vs_paragraph .> \case + VerticalSpacingParNone -> mVs + _ -> LineModeInvalid BDFForwardLineMode bd -> rec bd - BDFExternal{} -> - return $ LineModeValid $ VerticalSpacing 999 VerticalSpacingParNone + BDFExternal{} -> return + $ 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 - | VerticalSpacing lsp _ <- mVs + return $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False + | 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) -> - VerticalSpacing (lsp + addInd) psp + return $ mVs <&> \(VerticalSpacing lsp psp pf) -> + 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))) - (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone) + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ max x y) False)) + (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False) sumVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing - sumVs = foldl' - (liftM2 (\(VerticalSpacing x1 x2) (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))) - (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone) + 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 + (_, VerticalSpacingParNonBottom) -> VerticalSpacingParNonBottom + (VerticalSpacingParNonBottom, _) -> VerticalSpacingParNonBottom + (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 + 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 $ case mPsp of - VerticalSpacingParSome psp -> - VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO - VerticalSpacingParNone -> spMakePar indSp - VerticalSpacingParNonBottom -> VerticalSpacingParNonBottom + \(VerticalSpacing lsp mPsp _, indSp) -> + VerticalSpacing + lsp + (case mPsp of + VerticalSpacingParSome psp -> + VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO + VerticalSpacingParNone -> spMakePar indSp + 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) -> - VerticalSpacing (lsp + addInd) psp + return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> + 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 (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)) - (VerticalSpacing 0 VerticalSpacingParNone) + (\(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) + False) + (VerticalSpacing 0 VerticalSpacingParNone False) sumVs :: [VerticalSpacing] -> VerticalSpacing - sumVs = foldl' - (\(VerticalSpacing x1 x2) (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)) - (VerticalSpacing 0 VerticalSpacingParNone) + 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 + (_, VerticalSpacingParNonBottom) -> VerticalSpacingParNonBottom + (VerticalSpacingParNonBottom, _) -> VerticalSpacingParNonBottom + (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 + 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 diff --git a/src/Language/Haskell/Brittany/LayoutBasics.hs b/src/Language/Haskell/Brittany/LayoutBasics.hs index 5eb0d85..774b075 100644 --- a/src/Language/Haskell/Brittany/LayoutBasics.hs +++ b/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] diff --git a/src/Language/Haskell/Brittany/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Layouters/Decl.hs index e85b133..4b13219 100644 --- a/src/Language/Haskell/Brittany/Layouters/Decl.hs +++ b/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] - , let lineMod = case mWhereDocs of - Nothing | isExpressionTypeHeadPar bodyRaw -> - docAddBaseY BrIndentRegular - _ -> docForceSingleline + | [(guards, body, _bodyRaw)] <- [clauseDocs] , 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] - , let lineMod = case mWhereDocs of - Nothing | isExpressionTypeHeadPar bodyRaw -> - docAddBaseY BrIndentRegular - _ -> docForceSingleline + | [(guards, body, _bodyRaw)] <- [clauseDocs] , 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] - , let lineMod = case () of - _ | isExpressionTypeHeadPar bodyRaw -> id - _ -> docForceSingleline + | [(guards, body, _bodyRaw)] <- [clauseDocs] , 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 diff --git a/src/Language/Haskell/Brittany/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Layouters/Expr.hs index 1dffb81..4509be6 100644 --- a/src/Language/Haskell/Brittany/Layouters/Expr.hs +++ b/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 ] - ] - ++ [ docSeq - [ appSep $ docForceSingleline expDocLeft - , appSep $ docForceSingleline expDocOp - , docForceMultiline expDocRight - ] - | isExpressionTypeHeadPar expRight - ] - ++ [ docSeq + , -- line + freely indented block for right expression + 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,10 +405,11 @@ 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 - $ docPar - (docLit $ Text.pack "do") - (docSetIndentLevel $ docNonBottomSpacing $ docLines stmtDocs) + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "do") + (docSetIndentLevel $ docNonBottomSpacing $ docLines stmtDocs) HsDo x (L _ stmts) _ | case x of { ListComp -> True ; MonadComp -> True ; _ -> False } -> do @@ -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, '\''] diff --git a/src/Language/Haskell/Brittany/Layouters/Expr.hs-boot b/src/Language/Haskell/Brittany/Layouters/Expr.hs-boot index a86f8d2..142f6ce 100644 --- a/src/Language/Haskell/Brittany/Layouters/Expr.hs-boot +++ b/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 diff --git a/src/Language/Haskell/Brittany/Types.hs b/src/Language/Haskell/Brittany/Types.hs index 8205e45..bfca5f5 100644 --- a/src/Language/Haskell/Brittany/Types.hs +++ b/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