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 let state = LayoutState
{ _lstate_baseY = 0 { _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_indLevel = 0
, _lstate_indLevelLinger = 0 , _lstate_indLevelLinger = 0
, _lstate_commentsPrior = extractCommentsPrior filteredAnns , _lstate_commentsPrior = extractCommentsPrior filteredAnns
@ -213,7 +216,10 @@ transformAlts briDoc
#if INSERTTRACESALT #if INSERTTRACESALT
do do
acp :: AltCurPos <- mGet 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 #endif
let reWrap = (,) brDcId let reWrap = (,) brDcId
-- debugAcp :: AltCurPos <- mGet -- 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)) <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs))
( any (hasSpace2 lconf acp) vs ( any (hasSpace2 lconf acp) vs
&& any lineCheck vs, bd)) && any lineCheck vs, bd))
let checkedOptions :: [Maybe (Int, BriDocNumbered)] =
zip [1..] options <&> (\(i, (b,x)) -> [ (i, x) | b ])
#if INSERTTRACESALT #if INSERTTRACESALT
zip spacings options `forM_` \(vs, (_, bd)) -> zip spacings options `forM_` \(vs, (_, bd)) ->
tellDebugMess $ " " ++ "spacing=" ++ show vs tellDebugMess $ " " ++ "spacing=" ++ show vs
++ ",hasSpace=" ++ show (hasSpace2 lconf acp <$> vs) ++ ",hasSpace=" ++ show (hasSpace2 lconf acp <$> vs)
++ ",lineCheck=" ++ show (lineCheck <$> vs) ++ ",lineCheck=" ++ show (lineCheck <$> vs)
++ " " ++ show (toConstr bd) ++ " " ++ show (toConstr bd)
tellDebugMess $ " " ++ show (Data.Maybe.mapMaybe (fmap fst) checkedOptions)
#endif #endif
id -- $ (fmap $ \x -> traceShow (briDocToDoc x) x) id -- $ (fmap $ \x -> traceShow (briDocToDoc x) x)
$ rec $ rec
$ fromMaybe (-- trace ("choosing last") $ $ fromMaybe (-- trace ("choosing last") $
List.last alts) List.last alts)
$ Data.List.Extra.firstJust (\(_i::Int, (b,x)) -> $ Data.List.Extra.firstJust (fmap snd) checkedOptions
[ -- traceShow ("choosing option " ++ show i) $
x
| b
])
$ zip [1..] options
BDFForceMultiline bd -> do BDFForceMultiline bd -> do
acp <- mGet acp <- mGet
x <- do x <- do
@ -635,7 +639,7 @@ getSpacings limit bridoc = rec bridoc
BDFAlt [] -> error "empty BDAlt" BDFAlt [] -> error "empty BDAlt"
-- BDAlt (alt:_) -> rec alt -- BDAlt (alt:_) -> rec alt
BDFAlt alts -> do BDFAlt alts -> do
r <- filterAndLimit . join . Control.Lens.transposeOf traverse <$> (rec `mapM` alts) r <- filterAndLimit . join . transpose <$> (rec `mapM` alts)
return r return r
BDFForceMultiline bd -> rec bd BDFForceMultiline bd -> rec bd
BDFForceSingleline bd -> do BDFForceSingleline bd -> do

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

@ -510,10 +510,12 @@ layoutSetBaseColCur m = do
tellDebugMessShow ("layoutSetBaseColCur") tellDebugMessShow ("layoutSetBaseColCur")
#endif #endif
state <- mGet 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, Just j) -> layoutSetBaseColInternal (i+j)
(Left i, Nothing) -> layoutSetBaseColInternal i (Left i, Nothing) -> layoutSetBaseColInternal i
(Right{}, _) -> return () (Right{}, _) -> return ()
Just cCol -> layoutSetBaseColInternal cCol
m m
layoutSetBaseColInternal $ _lstate_baseY state 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 -- pattern and exactly one clause in single line, body and where
-- indented if necessary. -- indented if necessary.
[ docAddBaseY BrIndentRegular [ docLines
$ docPar $ [ docCols ColBindingLine
( docCols ColBindingLine
[ docSeq [ docSeq
(patPartInline ++ [appSep guardPart]) (patPartInline ++ [appSep guardPart])
, docSeq , docSeq
[ appSep $ return binderDoc [ appSep $ return binderDoc
, lineMod $ docAddBaseY BrIndentRegular $ return body , lineMod $ docAddBaseY BrIndentRegular $ return body
-- , lineMod $ docAlt
-- [ docSetBaseY $ return body
-- , docAddBaseY BrIndentRegular $ return body
-- ]
] ]
]) ]
wherePart ] ++ wherePart
| [(guards, body, bodyRaw)] <- [clauseDocs] | [(guards, body, bodyRaw)] <- [clauseDocs]
, let lineMod = case () of , let lineMod = case () of
_ | isExpressionTypeHeadPar bodyRaw -> id _ | isExpressionTypeHeadPar bodyRaw -> id
@ -203,9 +228,9 @@ layoutPatternBindFinal binderDoc mPatDoc clauseDocs mWhereDocs = do
gs -> docSeq gs -> docSeq
$ [appSep $ docLit $ Text.pack "|"] $ [appSep $ docLit $ Text.pack "|"]
++ List.intersperse docCommaSep (return <$> gs) ++ List.intersperse docCommaSep (return <$> gs)
, wherePart <- case mWhereDocs of , let wherePart = case mWhereDocs of
Nothing -> [] Nothing -> []
Just ws -> pure $ docAddBaseY BrIndentRegular $ docPar Just ws -> pure $ docEnsureIndent BrIndentRegular $ docPar
(docLit $ Text.pack "where") (docLit $ Text.pack "where")
(docSetIndentLevel $ docLines $ return <$> ws) (docSetIndentLevel $ docLines $ return <$> ws)
] ++ ] ++
@ -227,6 +252,7 @@ layoutPatternBindFinal binderDoc mPatDoc clauseDocs mWhereDocs = do
(docLit $ Text.pack "where") (docLit $ Text.pack "where")
(docSetIndentLevel $ docLines $ return <$> ws) (docSetIndentLevel $ docLines $ return <$> ws)
] ++ ] ++
-- conservative approach: everything starts on the left.
[ docAddBaseY BrIndentRegular [ docAddBaseY BrIndentRegular
$ patPartParWrap $ patPartParWrap
$ docLines $ $ 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 docAlt
[ docSeq [ docSeq
[ docLit $ Text.pack "\\" [ docLit $ Text.pack "\\"
, docWrapNode lmatch $ funcPatternPartLine , docWrapNode lmatch $ docForceSingleline funcPatternPartLine
, appSep $ docLit $ Text.pack "->" , 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{} -> HsLam{} ->
unknownNodeError "HsLam too complex" lexpr unknownNodeError "HsLam too complex" lexpr
@ -142,15 +149,19 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
, appSep $ docForceSingleline opLastDoc , appSep $ docForceSingleline opLastDoc
, docForceSingleline expLastDoc , docForceSingleline expLastDoc
] ]
, docAddBaseY BrIndentRegular , docSetBaseY
$ docPar $ docPar
(docSetBaseY leftOperandDoc) leftOperandDoc
( docLines
$ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed])
++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]]
)
, docPar
leftOperandDoc
( docLines ( docLines
$ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed])
++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]]
) )
-- TODO: singleline
-- TODO: wrapping on spine nodes
] ]
OpApp expLeft expOp _ expRight -> do OpApp expLeft expOp _ expRight -> do
expDocLeft <- docSharedWrapper layoutExpr expLeft expDocLeft <- docSharedWrapper layoutExpr expLeft
@ -179,7 +190,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
$ docPar $ docPar
expDocLeft expDocLeft
-- TODO: turn this into docCols? -- TODO: turn this into docCols?
(docCols ColOpPrefix [appSep $ expDocOp, expDocRight]) (docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight])
] ]
NegApp{} -> do NegApp{} -> do
-- TODO -- TODO
@ -192,7 +203,13 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
, docForceSingleline innerExpDoc , docForceSingleline innerExpDoc
, docLit $ Text.pack ")" , docLit $ Text.pack ")"
] ]
-- TODO , docSetBaseY $ docLines
[ docCols ColOpPrefix
[ docParenLSep
, docAddBaseY (BrIndentSpecial 2) innerExpDoc
]
, docLit $ Text.pack ")"
]
] ]
SectionL left op -> do -- TODO: add to testsuite SectionL left op -> do -- TODO: add to testsuite
leftDoc <- docSharedWrapper layoutExpr left leftDoc <- docSharedWrapper layoutExpr left
@ -241,7 +258,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
) )
( docAddBaseY BrIndentRegular ( docAddBaseY BrIndentRegular
$ docPar (docLit $ Text.pack "of") $ docPar (docLit $ Text.pack "of")
(docSetIndentLevel $ docLines $ return <$> funcPatDocs) (docSetIndentLevel $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs)
) )
] ]
HsIf _ ifExpr thenExpr elseExpr -> do HsIf _ ifExpr thenExpr elseExpr -> do
@ -379,7 +396,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
[appSep $ docLit $ Text.pack "|", s1] [appSep $ docLit $ Text.pack "|", s1]
lineM = sM <&> \d -> lineM = sM <&> \d ->
docCols ColListComp [docCommaSep, d] docCols ColListComp [docCommaSep, d]
end = docLit $ Text.pack "]" end = docLit $ Text.pack " ]"
in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end]
] ]
HsDo{} -> do HsDo{} -> do
@ -443,19 +460,20 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
docSeq [rExprDoc, docLit $ Text.pack "{}"] docSeq [rExprDoc, docLit $ Text.pack "{}"]
RecordUpd rExpr fields@(_:_) _ _ _ _ -> do RecordUpd rExpr fields@(_:_) _ _ _ _ -> do
rExprDoc <- docSharedWrapper layoutExpr rExpr 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 rFExpDoc <- docSharedWrapper layoutExpr rFExpr
return $ case ambName of return $ case ambName of
Unambiguous n _ -> (lrdrNameToText n, rFExpDoc) Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc)
Ambiguous n _ -> (lrdrNameToText n, rFExpDoc) Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc)
docAlt docAlt
-- singleline -- singleline
[ docSeq [ docSeq
[ appSep rExprDoc [ appSep rExprDoc
, appSep $ docLit $ Text.pack "{" , appSep $ docLit $ Text.pack "{"
, appSep $ docSeq $ List.intersperse docCommaSep , appSep $ docSeq $ List.intersperse docCommaSep
$ rFs <&> \(fieldStr, fieldDoc) -> $ rFs <&> \(lfield, fieldStr, fieldDoc) ->
docSeq [ appSep $ docLit fieldStr docSeq [ appSep $ docWrapNode lfield $ docLit fieldStr
, appSep $ docLit $ Text.pack "=" , appSep $ docLit $ Text.pack "="
, docForceSingleline fieldDoc , docForceSingleline fieldDoc
] ]
@ -467,14 +485,14 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
, docSetBaseY $ docLines $ let , docSetBaseY $ docLines $ let
line1 = docCols ColRecUpdate line1 = docCols ColRecUpdate
[ appSep $ docLit $ Text.pack "{" [ appSep $ docLit $ Text.pack "{"
, appSep $ docLit $ fst rF1 , appSep $ docLit $ rF1n
, docSeq [ appSep $ docLit $ Text.pack "=" , 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 $ Text.pack ","
, appSep $ docLit $ fText , appSep $ docWrapNode lfield $ docLit $ fText
, docSeq [ appSep $ docLit $ Text.pack "=" , docSeq [ appSep $ docLit $ Text.pack "="
, docForceSingleline fDoc , docForceSingleline fDoc
] ]
@ -486,17 +504,17 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
, docAddBaseY BrIndentRegular , docAddBaseY BrIndentRegular
$ docPar $ docPar
rExprDoc rExprDoc
(docLines $ let (docNonBottomSpacing $ docLines $ let
line1 = docCols ColRecUpdate line1 = docCols ColRecUpdate
[ appSep $ docLit $ Text.pack "{" [ appSep $ docLit $ Text.pack "{"
, appSep $ docLit $ fst rF1 , appSep $ docWrapNode rF1f $ docLit $ rF1n
, docSeq [ appSep $ docLit $ Text.pack "=" , 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 $ Text.pack ","
, appSep $ docLit $ fText , appSep $ docWrapNode lfield $ docLit $ fText
, docSeq [ appSep $ docLit $ Text.pack "=" , docSeq [ appSep $ docLit $ Text.pack "="
, docAddBaseY BrIndentRegular fDoc , docAddBaseY BrIndentRegular fDoc
] ]
@ -623,12 +641,18 @@ isExpressionTypeHeadPar (L _ expr) = case expr of
RecordUpd{} -> True RecordUpd{} -> True
HsDo{} -> True HsDo{} -> True
HsIf{} -> True HsIf{} -> True
HsCase{} -> True
HsLamCase{} -> True HsLamCase{} -> True
-- TODO: these cases might have unfortunate layouts, if for some reason -- TODO: these cases might have unfortunate layouts, if for some reason
-- the first operand is multiline. -- the first operand is multiline.
OpApp _ _ _ (L _ HsDo{}) -> True OpApp _ _ _ (L _ HsDo{}) -> True
OpApp _ _ _ (L _ HsLamCase{}) -> 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 _ -> False
isExpressionTypeHeadPar' :: LHsExpr RdrName -> Bool isExpressionTypeHeadPar' :: LHsExpr RdrName -> Bool
@ -637,7 +661,6 @@ isExpressionTypeHeadPar' (L _ expr) = case expr of
RecordUpd{} -> True RecordUpd{} -> True
HsDo{} -> True HsDo{} -> True
HsIf{} -> True HsIf{} -> True
HsCase{} -> True
HsLamCase{} -> True HsLamCase{} -> True
-- TODO: these cases might have unfortunate layouts, if for some reason -- TODO: these cases might have unfortunate layouts, if for some reason
-- the first operand is multiline. -- the first operand is multiline.