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

Improve horizontal alignments significantly (patterns)

pull/3/head
Lennart Spitzner 2016-09-03 21:32:18 +02:00
parent d3b7e28c56
commit 48b2057d84
7 changed files with 175 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1118,6 +1118,8 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
filter isNotEmpty list >>= \case
BDSeq l -> l
x -> [x]
BDSeq (BDCols sig1 cols1@(_:_):rest) ->
Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)])
BDLines lines | any (\case BDLines{} -> True
BDEmpty{} -> True
_ -> False) lines ->
@ -1528,10 +1530,24 @@ layoutBriDocM = \case
where
(colInfos, finalState) = StateS.runState (mergeBriDocs bridocs)
(ColBuildState IntMapS.empty 0)
maxZipper :: [Int] -> [Int] -> [Int]
maxZipper [] ys = ys
maxZipper xs [] = xs
maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr
processedMap :: Int -> Int -> ColMap2
processedMap curX colMax =
_cbs_map finalState <&> \colss ->
let maxCols = Foldable.foldl1 (zipWith max) colss
processedMap curX colMax = fix $ \result ->
_cbs_map finalState <&> \colSpacingss ->
let colss = colSpacingss <&> \spss -> case reverse spss of
[] -> []
(xN:xR) -> reverse $ fLast xN : fmap fInit xR
where
fLast (ColumnSpacingLeaf len) = len
fLast (ColumnSpacingRef len _) = len
fInit (ColumnSpacingLeaf len) = len
fInit (ColumnSpacingRef _ i) = case IntMapL.lookup i result of
Nothing -> 0
Just (_, maxs, _) -> sum maxs
maxCols = Foldable.foldl1 maxZipper colss
(_, posXs) = mapAccumL (\acc x -> (acc+x,acc)) curX maxCols
counter count l =
if List.last posXs + List.last l <=colMax
@ -1544,10 +1560,16 @@ layoutBriDocM = \case
briDocToColInfo = \case
BDCols sig list -> withAlloc $ \ind -> do
subInfos <- mapM briDocToColInfo list
let lengths = briDocLineLength <$> list
return $ (Seq.singleton lengths, ColInfo ind sig (zip lengths subInfos))
let lengthInfos = zip (briDocLineLength <$> list) subInfos
let trueSpacings = getTrueSpacings lengthInfos
return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos)
bd -> return $ ColInfoNo bd
getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing]
getTrueSpacings lengthInfos = lengthInfos <&> \case
(len, ColInfo i _ _) -> ColumnSpacingRef len i
(len, _) -> ColumnSpacingLeaf len
mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo]
mergeBriDocs bds = mergeBriDocsW ColInfoStart bds
@ -1570,20 +1592,21 @@ layoutBriDocM = \case
infos <- zip (snd <$> subLengthsInfos) subDocs
`forM` uncurry mergeInfoBriDoc
let curLengths = briDocLineLength <$> subDocs
let trueSpacings = getTrueSpacings (zip curLengths infos)
do -- update map
s <- StateS.get
let m = _cbs_map s
let (Just spaces) = IntMapS.lookup infoInd m
StateS.put s
{ _cbs_map = IntMapS.insert infoInd
(spaces Seq.|> curLengths)
(spaces Seq.|> trueSpacings)
m
}
return $ ColInfo infoInd colSig (zip curLengths infos)
| otherwise -> briDocToColInfo bd
bd -> return $ ColInfoNo bd
withAlloc :: (ColIndex -> StateS.State ColBuildState (ColSpaces, ColInfo))
withAlloc :: (ColIndex -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo))
-> StateS.State ColBuildState ColInfo
withAlloc f = do
cbs <- StateS.get
@ -1652,16 +1675,27 @@ layoutBriDocM = \case
ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore)
type ColIndex = Int
type ColSpace = [Int]
type ColSpaces = Seq [Int]
type ColMap1 = IntMapS.IntMap {- ColIndex -} ColSpaces
type ColMap2 = IntMapS.IntMap {- ColIndex -} (Float, ColSpace, ColSpaces)
data ColumnSpacing
= ColumnSpacingLeaf Int
| ColumnSpacingRef Int Int
type ColumnBlock a = [a]
type ColumnBlocks a = Seq [a]
type ColMap1 = IntMapL.IntMap {- ColIndex -} (ColumnBlocks ColumnSpacing)
type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int)
-- (ratio of hasSpace, maximum, raw)
data ColInfo
= ColInfoStart -- start value to begin the mapAccumL.
| ColInfoNo BriDoc
| ColInfo ColIndex ColSig [(Int, ColInfo)]
instance Show ColInfo where
show ColInfoStart = "ColInfoStart"
show ColInfoNo{} = "ColInfoNo{}"
show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list
data ColBuildState = ColBuildState
{ _cbs_map :: ColMap1
, _cbs_index :: ColIndex

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

@ -1060,6 +1060,34 @@ instance DocWrapable a => DocWrapable [a] where
bdN' <- docWrapNodeRest ast (return bdN)
return $ reverse $ (bdN':bdR)
instance DocWrapable a => DocWrapable (Seq a) where
docWrapNode ast bdsm = do
bds <- bdsm
case Seq.viewl bds of
Seq.EmptyL -> return $ Seq.empty -- TODO: this might be bad. maybe. then again, not really. well.
bd1 Seq.:< rest -> case Seq.viewr rest of
Seq.EmptyR -> do
bd1' <- docWrapNode ast (return bd1)
return $ Seq.singleton bd1'
bdM Seq.:> bdN -> do
bd1' <- docWrapNodePrior ast (return bd1)
bdN' <- docWrapNodeRest ast (return bdN)
return $ (bd1' Seq.<| bdM) Seq.|> bdN'
docWrapNodePrior ast bdsm = do
bds <- bdsm
case Seq.viewl bds of
Seq.EmptyL -> return $ Seq.empty
bd1 Seq.:< bdR -> do
bd1' <- docWrapNodePrior ast (return bd1)
return $ bd1' Seq.<| bdR
docWrapNodeRest ast bdsm = do
bds <- bdsm
case Seq.viewr bds of
Seq.EmptyR -> return $ Seq.empty
bdR Seq.:> bdN -> do
bdN' <- docWrapNodeRest ast (return bdN)
return $ bdR Seq.|> bdN'
instance DocWrapable ([BriDocNumbered], BriDocNumbered, a) where
docWrapNode ast stuffM = do
(bds, bd, x) <- stuffM

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

@ -69,7 +69,9 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
patDoc <- docSharedWrapper layoutPat lPat
expDoc <- docSharedWrapper layoutExpr expr
docCols ColBindStmt
[appSep patDoc, docSeq [appSep $ docLit $ Text.pack "<-", expDoc]]
[ appSep $ colsWrapPat =<< patDoc
, docSeq [appSep $ docLit $ Text.pack "<-", expDoc]
]
_ -> unknownNodeError "" lgstmt -- TODO
layoutBind :: ToBriDocC (HsBindLR RdrName RdrName) (Either [BriDocNumbered] BriDocNumbered)
@ -80,11 +82,11 @@ layoutBind lbind@(L _ bind) = case bind of
funcPatDocs <- docWrapNode lbind $ docWrapNode lmatches $ layoutPatternBind (Just idStr) binderDoc `mapM` matches
return $ Left $ funcPatDocs
PatBind pat (GRHSs grhss whereBinds) _ _ ([], []) -> do
patDoc <- layoutPat pat
patDocs <- colsWrapPat =<< layoutPat pat
clauseDocs <- layoutGrhs `mapM` grhss
mWhereDocs <- layoutLocalBinds whereBinds
binderDoc <- docLit $ Text.pack "="
fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing binderDoc (Just patDoc) clauseDocs mWhereDocs
fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing binderDoc (Just patDocs) clauseDocs mWhereDocs
_ -> Right <$> unknownNodeError "" lbind
data BagBindOrSig = BagBind (LHsBindLR RdrName RdrName)
@ -127,7 +129,7 @@ layoutGrhs lgrhs@(L _ (GRHS guards body))
layoutPatternBind :: Maybe Text -> BriDocNumbered -> LMatch RdrName (LHsExpr RdrName) -> ToBriDocM BriDocNumbered
layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhss whereBinds)))
= do
patDocs <- docSharedWrapper layoutPat `mapM` pats
patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p
let isInfix = isInfixMatch match
patDoc <- docWrapNodePrior lmatch $ case (mIdStr, patDocs) of
(Just idStr, p1:pr) | isInfix -> docCols ColPatternsFuncInfix

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

@ -50,7 +50,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
HsLit lit -> do
allocateNode $ litBriDoc lit
HsLam (MG (L _ [lmatch@(L _ (Match _ pats _ (GRHSs [lgrhs@(L _ (GRHS [] body))] (L _ EmptyLocalBinds))))]) _ _ _) -> do
patDocs <- pats `forM` docSharedWrapper layoutPat
patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p
bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body
let funcPatternPartLine =
docCols ColCasePattern

151
src/Language/Haskell/Brittany/Layouters/Pattern.hs
View File

@ -2,6 +2,7 @@
module Language.Haskell.Brittany.Layouters.Pattern
( layoutPat
, colsWrapPat
)
where
@ -24,33 +25,50 @@ import Language.Haskell.Brittany.Layouters.Type
layoutPat :: ToBriDoc Pat
layoutPat :: ToBriDocC (Pat RdrName) (Seq BriDocNumbered)
layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
WildPat _ -> docLit $ Text.pack "_"
VarPat n -> docLit $ lrdrNameToText n
LitPat lit -> allocateNode $ litBriDoc lit
WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_"
VarPat n -> fmap Seq.singleton $ docLit $ lrdrNameToText n
LitPat lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit
ParPat inner -> do
innerDoc <- docSharedWrapper layoutPat inner
docSeq
[ docLit $ Text.pack "("
, innerDoc
, docLit $ Text.pack ")"
]
innerDocs <- layoutPat inner
left <- docLit $ Text.pack "("
right <- docLit $ Text.pack ")"
return $ (left Seq.<| innerDocs) Seq.|> right
-- case Seq.viewl innerDocs of
-- Seq.EmptyL -> fmap return $ docLit $ Text.pack "()" -- this should never occur..
-- x1 Seq.:< rest -> case Seq.viewr rest of
-- Seq.EmptyR ->
-- fmap return $ docSeq
-- [ docLit $ Text.pack "("
-- , return x1
-- , docLit $ Text.pack ")"
-- ]
-- middle Seq.:> xN -> do
-- x1' <- docSeq [docLit $ Text.pack "(", return x1]
-- xN' <- docSeq [return xN, docLit $ Text.pack ")"]
-- return $ (x1' Seq.<| middle) Seq.|> xN'
ConPatIn lname (PrefixCon args) -> do
let nameDoc = lrdrNameToText lname
argDocs <- docSharedWrapper layoutPat `mapM` args
argDocs <- layoutPat `mapM` args
if null argDocs
then docLit nameDoc
else docSeq
$ appSep (docLit nameDoc) : spacifyDocs argDocs
then return <$> docLit nameDoc
else do
x1 <- appSep (docLit nameDoc)
xR <- fmap Seq.fromList
$ sequence
$ spacifyDocs
$ fmap colsWrapPat argDocs
return $ x1 Seq.<| xR
ConPatIn lname (InfixCon left right) -> do
let nameDoc = lrdrNameToText lname
leftDoc <- docSharedWrapper layoutPat left
rightDoc <- docSharedWrapper layoutPat right
docSeq [leftDoc, docLit nameDoc, rightDoc]
leftDoc <- colsWrapPat =<< layoutPat left
rightDoc <- colsWrapPat =<< layoutPat right
middle <- docLit nameDoc
return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc
ConPatIn lname (RecCon (HsRecFields [] Nothing)) -> do
let t = lrdrNameToText lname
docLit $ t <> Text.pack "{}"
fmap Seq.singleton $ docLit $ t <> Text.pack "{}"
ConPatIn lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do
let t = lrdrNameToText lname
fds <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fPat pun)) -> do
@ -58,7 +76,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
then return Nothing
else Just <$> docSharedWrapper layoutPat fPat
return $ (lrdrNameToText lnameF, fExpDoc)
docSeq
fmap Seq.singleton $ docSeq
[ appSep $ docLit t
, appSep $ docLit $ Text.pack "{"
, docSeq $ List.intersperse docCommaSep
@ -66,7 +84,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
(fieldName, Just fieldDoc) -> docSeq
[ appSep $ docLit $ fieldName
, appSep $ docLit $ Text.pack "="
, fieldDoc
, fieldDoc >>= colsWrapPat
]
(fieldName, Nothing) -> docLit fieldName
, docSeparator
@ -74,59 +92,74 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
]
ConPatIn lname (RecCon (HsRecFields [] (Just 0))) -> do
let t = lrdrNameToText lname
docSeq
fmap Seq.singleton $ docSeq
[ appSep $ docLit t
, docLit $ Text.pack "{..}"
]
TuplePat args boxity _ -> do
argDocs <- docSharedWrapper layoutPat `mapM` args
case boxity of
Boxed -> docAlt
[ docSeq
$ [ docLit $ Text.pack "(" ]
++ List.intersperse (appSep $ docLit $ Text.pack ",") argDocs
++ [ docLit $ Text.pack ")"]
-- TODO
]
Unboxed -> docAlt
[ docSeq
$ [ docLit $ Text.pack "(#" ]
++ List.intersperse (appSep $ docLit $ Text.pack ",") argDocs
++ [ docLit $ Text.pack "#)"]
-- TODO
]
Boxed -> wrapPatListy args "(" ")"
Unboxed -> wrapPatListy args "(#" "#)"
AsPat asName asPat -> do
patDoc <- docSharedWrapper layoutPat asPat
docSeq
[ docLit $ lrdrNameToText asName <> Text.pack "@"
, patDoc
]
wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@")
SigPatIn pat1 (HsIB _ (HsWC _ _ ty1)) -> do
patDoc <- docSharedWrapper layoutPat pat1
patDocs <- layoutPat pat1
tyDoc <- docSharedWrapper layoutType ty1
docSeq
[ appSep $ patDoc
, appSep $ docLit $ Text.pack "::"
, tyDoc
]
ListPat elems _ _ -> do
elemDocs <- docSharedWrapper layoutPat `mapM` elems
docSeq
$ [docLit $ Text.pack "["]
++ List.intersperse docCommaSep (elemDocs)
++ [docLit $ Text.pack "]"]
case Seq.viewr patDocs of
Seq.EmptyR -> error "cannot happen ljoiuxoasdcoviuasd"
xR Seq.:> xN -> do
xN' <- docSeq
[ appSep $ return xN
, appSep $ docLit $ Text.pack "::"
, tyDoc
]
return $ xR Seq.|> xN'
ListPat elems _ _ ->
wrapPatListy elems "[" "]"
BangPat pat1 -> do
patDoc <- docSharedWrapper layoutPat pat1
docSeq [docLit $ Text.pack "!", patDoc]
wrapPatPrepend pat1 (docLit $ Text.pack "!")
LazyPat pat1 -> do
patDoc <- docSharedWrapper layoutPat pat1
docSeq [docLit $ Text.pack "~", patDoc]
wrapPatPrepend pat1 (docLit $ Text.pack "~")
NPat llit@(L _ (OverLit olit _ _ _)) _ _ _ -> do
docWrapNode llit $ allocateNode $ overLitValBriDoc olit
fmap Seq.singleton $ docWrapNode llit $ allocateNode $ overLitValBriDoc olit
-- #if MIN_VERSION_ghc(8,0,0)
-- VarPat n -> return $ stringLayouter lpat $ lrdrNameToText n
-- #else
-- VarPat n -> return $ stringLayouter lpat $ rdrNameToText n
-- #endif
_ -> unknownNodeError "" lpat
_ -> fmap return $ unknownNodeError "" lpat
colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered
colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList
wrapPatPrepend
:: GenLocated SrcSpan (Pat RdrName)
-> ToBriDocM BriDocNumbered
-> ToBriDocM (Seq BriDocNumbered)
wrapPatPrepend pat prepElem = do
patDocs <- layoutPat pat
case Seq.viewl patDocs of
Seq.EmptyL -> return $ Seq.empty
x1 Seq.:< xR -> do
x1' <- docSeq [prepElem, return x1]
return $ x1' Seq.<| xR
wrapPatListy
:: [GenLocated SrcSpan (Pat RdrName)]
-> String
-> String
-> ToBriDocM (Seq BriDocNumbered)
wrapPatListy elems start end = do
elemDocs <- Seq.fromList elems `forM` \e -> layoutPat e >>= colsWrapPat
sDoc <- docLit $ Text.pack start
eDoc <- docLit $ Text.pack end
case Seq.viewl elemDocs of
Seq.EmptyL -> fmap Seq.singleton $ docLit $ Text.pack $ start ++ end
x1 Seq.:< rest -> do
rest' <- rest `forM` \bd -> docSeq
[ docLit $ Text.pack ","
, docSeparator
, return bd
]
return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc

2
src/Language/Haskell/Brittany/Layouters/Stmt.hs
View File

@ -31,7 +31,7 @@ layoutStmt lstmt@(L _ stmt) = docWrapNode lstmt $ case stmt of
LastStmt body False _ -> do
layoutExpr body
BindStmt lPat expr _ _ _ -> do
patDoc <- docSharedWrapper layoutPat lPat
patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat
expDoc <- docSharedWrapper layoutExpr expr
docAlt
[ docCols ColBindStmt

4
srcinc/prelude.inc
View File

@ -393,8 +393,8 @@ import qualified Data.Semigroup as Semigroup
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Lazy as ByteStringL
import qualified Data.IntMap as IntMap
-- import qualified Data.IntMap.Lazy as IntMapL
-- import qualified Data.IntMap as IntMap
import qualified Data.IntMap.Lazy as IntMapL
import qualified Data.IntMap.Strict as IntMapS
-- import qualified Data.IntSet as IntSet
import qualified Data.Map as Map