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

Various minor layouting fixes

pull/1/head
Lennart Spitzner 2016-08-03 22:13:41 +02:00
parent 24dffbfe55
commit 1ce40c861c
4 changed files with 107 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -102,7 +102,10 @@ layoutBriDoc ast briDoc = do
let state = LayoutState
{ _lstate_baseY = 0
, _lstate_curYOrAddNewline = Right 0
, _lstate_curYOrAddNewline = Right 0 -- important that we use left here
-- because moveToAnn stuff of the
-- first node needs to do its
-- thing properly.
, _lstate_indLevel = 0
, _lstate_indLevelLinger = 0
, _lstate_commentsPrior = extractCommentsPrior filteredAnns
@ -213,7 +216,10 @@ transformAlts briDoc
#if INSERTTRACESALT
do
acp :: AltCurPos <- mGet
tellDebugMess $ "transformAlts: visiting: " ++ show (toConstr brDc, acp)
tellDebugMess $ "transformAlts: visiting: " ++ case brDc of
BDFAnnotationPrior annKey _ -> show (toConstr brDc, annKey, acp)
BDFAnnotationPost annKey _ -> show (toConstr brDc, annKey, acp)
_ -> show (toConstr brDc, acp)
#endif
let reWrap = (,) brDcId
-- debugAcp :: AltCurPos <- mGet
@ -335,23 +341,21 @@ transformAlts briDoc
<&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs))
( any (hasSpace2 lconf acp) vs
&& any lineCheck vs, bd))
let checkedOptions :: [Maybe (Int, BriDocNumbered)] =
zip [1..] options <&> (\(i, (b,x)) -> [ (i, x) | b ])
#if INSERTTRACESALT
zip spacings options `forM_` \(vs, (_, bd)) ->
tellDebugMess $ " " ++ "spacing=" ++ show vs
++ ",hasSpace=" ++ show (hasSpace2 lconf acp <$> vs)
++ ",lineCheck=" ++ show (lineCheck <$> vs)
++ " " ++ show (toConstr bd)
tellDebugMess $ " " ++ show (Data.Maybe.mapMaybe (fmap fst) checkedOptions)
#endif
id -- $ (fmap $ \x -> traceShow (briDocToDoc x) x)
$ rec
$ fromMaybe (-- trace ("choosing last") $
List.last alts)
$ Data.List.Extra.firstJust (\(_i::Int, (b,x)) ->
[ -- traceShow ("choosing option " ++ show i) $
x
| b
])
$ zip [1..] options
$ Data.List.Extra.firstJust (fmap snd) checkedOptions
BDFForceMultiline bd -> do
acp <- mGet
x <- do
@ -635,7 +639,7 @@ getSpacings limit bridoc = rec bridoc
BDFAlt [] -> error "empty BDAlt"
-- BDAlt (alt:_) -> rec alt
BDFAlt alts -> do
r <- filterAndLimit . join . Control.Lens.transposeOf traverse <$> (rec `mapM` alts)
r <- filterAndLimit . join . transpose <$> (rec `mapM` alts)
return r
BDFForceMultiline bd -> rec bd
BDFForceSingleline bd -> do

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

@ -510,10 +510,12 @@ layoutSetBaseColCur m = do
tellDebugMessShow ("layoutSetBaseColCur")
#endif
state <- mGet
case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
case _lstate_commentCol state of
Nothing -> case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i, Just j) -> layoutSetBaseColInternal (i+j)
(Left i, Nothing) -> layoutSetBaseColInternal i
(Right{}, _) -> return ()
Just cCol -> layoutSetBaseColInternal cCol
m
layoutSetBaseColInternal $ _lstate_baseY state

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

@ -180,19 +180,44 @@ layoutPatternBindFinal binderDoc mPatDoc clauseDocs mWhereDocs = do
]
_ -> []
] ++
-- two-line solution
[ docLines
$ [ docForceSingleline
$ docSeq (patPartInline ++ [guardPart, return binderDoc])
, docEnsureIndent BrIndentRegular
$ docForceSingleline
$ return body
] ++ wherePart
| [(guards, body, _bodyRaw)] <- [clauseDocs]
, let guardPart = case guards of
[] -> docEmpty
[g] -> docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator]
gs -> docSeq
$ [appSep $ docLit $ Text.pack "|"]
++ List.intersperse docCommaSep (return <$> gs)
++ [docSeparator]
, let wherePart = case mWhereDocs of
Nothing -> []
Just ws -> pure $ docEnsureIndent BrIndentRegular $ docPar
(docLit $ Text.pack "where")
(docSetIndentLevel $ docLines $ return <$> ws)
] ++
-- pattern and exactly one clause in single line, body and where
-- indented if necessary.
[ docAddBaseY BrIndentRegular
$ docPar
( docCols ColBindingLine
[ docLines
$ [ docCols ColBindingLine
[ docSeq
(patPartInline ++ [appSep guardPart])
, docSeq
[ appSep $ return binderDoc
, lineMod $ docAddBaseY BrIndentRegular $ return body
-- , lineMod $ docAlt
-- [ docSetBaseY $ return body
-- , docAddBaseY BrIndentRegular $ return body
-- ]
]
])
wherePart
]
] ++ wherePart
| [(guards, body, bodyRaw)] <- [clauseDocs]
, let lineMod = case () of
_ | isExpressionTypeHeadPar bodyRaw -> id
@ -203,9 +228,9 @@ layoutPatternBindFinal binderDoc mPatDoc clauseDocs mWhereDocs = do
gs -> docSeq
$ [appSep $ docLit $ Text.pack "|"]
++ List.intersperse docCommaSep (return <$> gs)
, wherePart <- case mWhereDocs of
, let wherePart = case mWhereDocs of
Nothing -> []
Just ws -> pure $ docAddBaseY BrIndentRegular $ docPar
Just ws -> pure $ docEnsureIndent BrIndentRegular $ docPar
(docLit $ Text.pack "where")
(docSetIndentLevel $ docLines $ return <$> ws)
] ++
@ -227,6 +252,7 @@ layoutPatternBindFinal binderDoc mPatDoc clauseDocs mWhereDocs = do
(docLit $ Text.pack "where")
(docSetIndentLevel $ docLines $ return <$> ws)
] ++
-- conservative approach: everything starts on the left.
[ docAddBaseY BrIndentRegular
$ patPartParWrap
$ docLines $

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

@ -60,11 +60,18 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
docAlt
[ docSeq
[ docLit $ Text.pack "\\"
, docWrapNode lmatch $ funcPatternPartLine
, docWrapNode lmatch $ docForceSingleline funcPatternPartLine
, appSep $ docLit $ Text.pack "->"
, docWrapNode lgrhs $ bodyDoc
, docWrapNode lgrhs $ docForceSingleline bodyDoc
]
-- TODO
, docAddBaseY BrIndentRegular
$ docPar
(docSeq
[ docLit $ Text.pack "\\"
, docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine
, docLit $ Text.pack "->"
])
(docWrapNode lgrhs $ docNonBottomSpacing bodyDoc)
]
HsLam{} ->
unknownNodeError "HsLam too complex" lexpr
@ -142,15 +149,19 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
, appSep $ docForceSingleline opLastDoc
, docForceSingleline expLastDoc
]
, docAddBaseY BrIndentRegular
, docSetBaseY
$ docPar
(docSetBaseY leftOperandDoc)
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]]
)
-- TODO: singleline
-- TODO: wrapping on spine nodes
]
OpApp expLeft expOp _ expRight -> do
expDocLeft <- docSharedWrapper layoutExpr expLeft
@ -179,7 +190,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
$ docPar
expDocLeft
-- TODO: turn this into docCols?
(docCols ColOpPrefix [appSep $ expDocOp, expDocRight])
(docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight])
]
NegApp{} -> do
-- TODO
@ -192,7 +203,13 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
, docForceSingleline innerExpDoc
, docLit $ Text.pack ")"
]
-- TODO
, docSetBaseY $ docLines
[ docCols ColOpPrefix
[ docParenLSep
, docAddBaseY (BrIndentSpecial 2) innerExpDoc
]
, docLit $ Text.pack ")"
]
]
SectionL left op -> do -- TODO: add to testsuite
leftDoc <- docSharedWrapper layoutExpr left
@ -241,7 +258,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
)
( docAddBaseY BrIndentRegular
$ docPar (docLit $ Text.pack "of")
(docSetIndentLevel $ docLines $ return <$> funcPatDocs)
(docSetIndentLevel $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs)
)
]
HsIf _ ifExpr thenExpr elseExpr -> do
@ -379,7 +396,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
[appSep $ docLit $ Text.pack "|", s1]
lineM = sM <&> \d ->
docCols ColListComp [docCommaSep, d]
end = docLit $ Text.pack "]"
end = docLit $ Text.pack " ]"
in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end]
]
HsDo{} -> do
@ -443,19 +460,20 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
docSeq [rExprDoc, docLit $ Text.pack "{}"]
RecordUpd rExpr fields@(_:_) _ _ _ _ -> do
rExprDoc <- docSharedWrapper layoutExpr rExpr
rFs@(rF1:rFr) <- fields `forM` \(L _ (HsRecField (L _ ambName) rFExpr _)) -> do
rFs@((rF1f, rF1n, rF1e):rFr) <- fields
`forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr _)) -> do
rFExpDoc <- docSharedWrapper layoutExpr rFExpr
return $ case ambName of
Unambiguous n _ -> (lrdrNameToText n, rFExpDoc)
Ambiguous n _ -> (lrdrNameToText n, rFExpDoc)
Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc)
Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc)
docAlt
-- singleline
[ docSeq
[ appSep rExprDoc
, appSep $ docLit $ Text.pack "{"
, appSep $ docSeq $ List.intersperse docCommaSep
$ rFs <&> \(fieldStr, fieldDoc) ->
docSeq [ appSep $ docLit fieldStr
$ rFs <&> \(lfield, fieldStr, fieldDoc) ->
docSeq [ appSep $ docWrapNode lfield $ docLit fieldStr
, appSep $ docLit $ Text.pack "="
, docForceSingleline fieldDoc
]
@ -467,14 +485,14 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
, docSetBaseY $ docLines $ let
line1 = docCols ColRecUpdate
[ appSep $ docLit $ Text.pack "{"
, appSep $ docLit $ fst rF1
, appSep $ docLit $ rF1n
, docSeq [ appSep $ docLit $ Text.pack "="
, docForceSingleline $ snd rF1
, docForceSingleline $ rF1e
]
]
lineR = rFr <&> \(fText, fDoc) -> docCols ColRecUpdate
lineR = rFr <&> \(lfield, fText, fDoc) -> docCols ColRecUpdate
[ appSep $ docLit $ Text.pack ","
, appSep $ docLit $ fText
, appSep $ docWrapNode lfield $ docLit $ fText
, docSeq [ appSep $ docLit $ Text.pack "="
, docForceSingleline fDoc
]
@ -486,17 +504,17 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
, docAddBaseY BrIndentRegular
$ docPar
rExprDoc
(docLines $ let
(docNonBottomSpacing $ docLines $ let
line1 = docCols ColRecUpdate
[ appSep $ docLit $ Text.pack "{"
, appSep $ docLit $ fst rF1
, appSep $ docWrapNode rF1f $ docLit $ rF1n
, docSeq [ appSep $ docLit $ Text.pack "="
, docAddBaseY BrIndentRegular $ snd rF1
, docAddBaseY BrIndentRegular $ rF1e
]
]
lineR = rFr <&> \(fText, fDoc) -> docCols ColRecUpdate
lineR = rFr <&> \(lfield, fText, fDoc) -> docCols ColRecUpdate
[ appSep $ docLit $ Text.pack ","
, appSep $ docLit $ fText
, appSep $ docWrapNode lfield $ docLit $ fText
, docSeq [ appSep $ docLit $ Text.pack "="
, docAddBaseY BrIndentRegular fDoc
]
@ -623,12 +641,18 @@ isExpressionTypeHeadPar (L _ expr) = case expr of
RecordUpd{} -> True
HsDo{} -> True
HsIf{} -> True
HsCase{} -> 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
@ -637,7 +661,6 @@ isExpressionTypeHeadPar' (L _ expr) = case expr of
RecordUpd{} -> True
HsDo{} -> True
HsIf{} -> True
HsCase{} -> True
HsLamCase{} -> True
-- TODO: these cases might have unfortunate layouts, if for some reason
-- the first operand is multiline.