hexagoxel
/
brittany
1
0
Fork 0
Code Issues 117 Pull Requests 5 Packages Projects Releases 5 Wiki Activity

Add Set/ForceParSpacing flag special bridoc constructors

pull/1/head
Lennart Spitzner 2016-08-06 13:51:54 +02:00
parent 4d650306c0
commit 1c5795f718
6 changed files with 257 additions and 190 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

214
src/Language/Haskell/Brittany/BriLayouter.hs
View File

@ -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

8
src/Language/Haskell/Brittany/LayoutBasics.hs
View File

@ -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]

28
src/Language/Haskell/Brittany/Layouters/Decl.hs
View File

@ -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

157
src/Language/Haskell/Brittany/Layouters/Expr.hs
View File

@ -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, '\'']

5
src/Language/Haskell/Brittany/Layouters/Expr.hs-boot
View File

@ -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

35
src/Language/Haskell/Brittany/Types.hs
View File

@ -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