Fix horizontal alignment issue; Add testcases
Lennart Spitzner
parent
a29836d09c
commit
cb93a6903c
|
|
@ -705,3 +705,76 @@ regressionTests = do
|
|||
| otherwise -> do
|
||||
return conf
|
||||
|]
|
||||
it "nested pattern alignment issue" $ do
|
||||
roundTripEqual $
|
||||
[text|
|
||||
func = BuildReport
|
||||
where
|
||||
convertInstallOutcome = case result of
|
||||
Left BR.PlanningFailed -> PlanningFailed
|
||||
Left (BR.DependentFailed p) -> DependencyFailed p
|
||||
Left (BR.DownloadFailed _) -> DownloadFailed
|
||||
Left (BR.UnpackFailed _) -> UnpackFailed
|
||||
Left (BR.ConfigureFailed _) -> ConfigureFailed
|
||||
Left (BR.BuildFailed _) -> BuildFailed
|
||||
Left (BR.TestsFailed _) -> TestsFailed
|
||||
Left (BR.InstallFailed _) -> InstallFailed
|
||||
Right (BR.BuildOk _ _ _ ) -> InstallOk
|
||||
|]
|
||||
it "nested pattern alignment issue" $ do
|
||||
roundTripEqual $
|
||||
[text|
|
||||
func = BuildReport
|
||||
where
|
||||
convertInstallOutcome = case result of
|
||||
Left BR.PlanningFailed -> PlanningFailed
|
||||
Left (BR.DependentFailed p) -> DependencyFailed p
|
||||
Left (BR.DownloadFailed _) -> DownloadFailed
|
||||
Left (BR.UnpackFailed _) -> UnpackFailed
|
||||
Left (BR.ConfigureFailed _) -> ConfigureFailed
|
||||
Left (BR.BuildFailed _) -> BuildFailed
|
||||
Left (BR.TestsFailed _) -> TestsFailed
|
||||
Left (BR.InstallFailed _) -> InstallFailed
|
||||
Right (BR.BuildOk _ _ _ ) -> InstallOk
|
||||
|]
|
||||
it "partially overflowing alignment issue" $ do
|
||||
roundTripEqual $
|
||||
[text|
|
||||
showPackageDetailedInfo pkginfo =
|
||||
renderStyle (style { lineLength = 80, ribbonsPerLine = 1 })
|
||||
$ char '*'
|
||||
$+$ something
|
||||
[ entry "Synopsis" synopsis hideIfNull reflowParagraphs
|
||||
, entry "Versions available"
|
||||
sourceVersions
|
||||
(altText null "[ Not available from server ]")
|
||||
(dispTopVersions 9 (preferredVersions pkginfo))
|
||||
, entry
|
||||
"Versions installed"
|
||||
installedVersions
|
||||
( altText
|
||||
null
|
||||
(if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]")
|
||||
)
|
||||
(dispTopVersions 4 (preferredVersions pkginfo))
|
||||
, entry "Homepage" homepage orNotSpecified text
|
||||
, entry "Bug reports" bugReports orNotSpecified text
|
||||
, entry "Description" description hideIfNull reflowParagraphs
|
||||
, entry "Category" category hideIfNull text
|
||||
, entry "License" license alwaysShow disp
|
||||
, entry "Author" author hideIfNull reflowLines
|
||||
, entry "Maintainer" maintainer hideIfNull reflowLines
|
||||
, entry "Source repo" sourceRepo orNotSpecified text
|
||||
, entry "Executables" executables hideIfNull (commaSep text)
|
||||
, entry "Flags" flags hideIfNull (commaSep dispFlag)
|
||||
, entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep)
|
||||
, entry "Documentation" haddockHtml showIfInstalled text
|
||||
, entry "Cached" haveTarball alwaysShow dispYesNo
|
||||
, if not (hasLib pkginfo)
|
||||
then
|
||||
empty
|
||||
else
|
||||
text "Modules:"
|
||||
$+$ nest 4 (vcat (map disp . sort . modules $ pkginfo))
|
||||
]
|
||||
|]
|
||||
|
|
@ -50,7 +50,7 @@ defaultTestConfig = Config
|
|||
, _lconfig_indentListSpecial = coerce True
|
||||
, _lconfig_importColumn = coerce (60 :: Int)
|
||||
, _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3
|
||||
, _lconfig_columnAlignMode = coerce ColumnAlignModeUnanimously
|
||||
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
|
||||
}
|
||||
, _conf_errorHandling = _conf_errorHandling staticDefaultConfig
|
||||
, _conf_forward = ForwardOptions
|
||||
|
|
|
|||
|
|
@ -305,10 +305,11 @@ layoutBriDocM = \case
|
|||
maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr
|
||||
processedMap :: Int -> Int -> ColMap2
|
||||
processedMap curX colMax = fix $ \result ->
|
||||
_cbs_map finalState <&> \colSpacingss ->
|
||||
_cbs_map finalState <&> \(lastFlag, colSpacingss) ->
|
||||
let colss = colSpacingss <&> \spss -> case reverse spss of
|
||||
[] -> []
|
||||
(xN:xR) -> reverse $ fLast xN : fmap fInit xR
|
||||
(xN:xR) -> reverse
|
||||
$ (if lastFlag then fLast else fInit) xN : fmap fInit xR
|
||||
where
|
||||
fLast (ColumnSpacingLeaf len) = len
|
||||
fLast (ColumnSpacingRef len _) = len
|
||||
|
|
@ -325,10 +326,12 @@ layoutBriDocM = \case
|
|||
ratio = fromIntegral (foldl counter (0::Int) colss)
|
||||
/ fromIntegral (length colss)
|
||||
in (ratio, maxCols, colss)
|
||||
briDocToColInfo :: BriDoc -> StateS.State ColBuildState ColInfo
|
||||
briDocToColInfo = \case
|
||||
BDCols sig list -> withAlloc $ \ind -> do
|
||||
subInfos <- mapM briDocToColInfo list
|
||||
briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo
|
||||
briDocToColInfo lastFlag = \case
|
||||
BDCols sig list -> withAlloc lastFlag $ \ind -> do
|
||||
let isLastList =
|
||||
if lastFlag then (== length list) <$> [1..] else repeat False
|
||||
subInfos <- zip isLastList list `forM` uncurry briDocToColInfo
|
||||
let lengthInfos = zip (briDocLineLength <$> list) subInfos
|
||||
let trueSpacings = getTrueSpacings lengthInfos
|
||||
return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos)
|
||||
|
|
@ -345,45 +348,49 @@ layoutBriDocM = \case
|
|||
mergeBriDocsW :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo]
|
||||
mergeBriDocsW _ [] = return []
|
||||
mergeBriDocsW lastInfo (bd:bdr) = do
|
||||
info <- mergeInfoBriDoc lastInfo bd
|
||||
info <- mergeInfoBriDoc True lastInfo bd
|
||||
infor <- mergeBriDocsW info bdr
|
||||
return $ info : infor
|
||||
|
||||
mergeInfoBriDoc :: ColInfo
|
||||
mergeInfoBriDoc :: Bool
|
||||
-> ColInfo
|
||||
-> BriDoc
|
||||
-> StateS.StateT ColBuildState Identity ColInfo
|
||||
mergeInfoBriDoc ColInfoStart = briDocToColInfo
|
||||
mergeInfoBriDoc ColInfoNo{} = briDocToColInfo
|
||||
mergeInfoBriDoc (ColInfo infoInd infoSig subLengthsInfos) = \case
|
||||
bd@(BDCols colSig subDocs)
|
||||
mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag
|
||||
mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag
|
||||
mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) = \case
|
||||
brdc@(BDCols colSig subDocs)
|
||||
| infoSig == colSig
|
||||
&& length subLengthsInfos == length subDocs -> do
|
||||
infos <- zip (snd <$> subLengthsInfos) subDocs
|
||||
`forM` uncurry mergeInfoBriDoc
|
||||
let isLastList =
|
||||
if lastFlag then (== length subDocs) <$> [1..] else repeat False
|
||||
infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs
|
||||
`forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd
|
||||
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
|
||||
let (Just (_, spaces)) = IntMapS.lookup infoInd m
|
||||
StateS.put s
|
||||
{ _cbs_map = IntMapS.insert infoInd
|
||||
(spaces Seq.|> trueSpacings)
|
||||
(lastFlag, spaces Seq.|> trueSpacings)
|
||||
m
|
||||
}
|
||||
return $ ColInfo infoInd colSig (zip curLengths infos)
|
||||
| otherwise -> briDocToColInfo bd
|
||||
bd -> return $ ColInfoNo bd
|
||||
| otherwise -> briDocToColInfo lastFlag brdc
|
||||
brdc -> return $ ColInfoNo brdc
|
||||
|
||||
withAlloc :: (ColIndex -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo))
|
||||
withAlloc :: Bool
|
||||
-> (ColIndex -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo))
|
||||
-> StateS.State ColBuildState ColInfo
|
||||
withAlloc f = do
|
||||
withAlloc lastFlag f = do
|
||||
cbs <- StateS.get
|
||||
let ind = _cbs_index cbs
|
||||
StateS.put $ cbs { _cbs_index = ind + 1 }
|
||||
(space, info) <- f ind
|
||||
StateS.get >>= \c -> StateS.put
|
||||
$ c { _cbs_map = IntMapS.insert ind space $ _cbs_map c }
|
||||
$ c { _cbs_map = IntMapS.insert ind (lastFlag, space) $ _cbs_map c }
|
||||
return info
|
||||
|
||||
processInfo :: ColMap2 -> ColInfo -> m ()
|
||||
|
|
@ -451,7 +458,7 @@ data ColumnSpacing
|
|||
|
||||
type ColumnBlock a = [a]
|
||||
type ColumnBlocks a = Seq [a]
|
||||
type ColMap1 = IntMapL.IntMap {- ColIndex -} (ColumnBlocks ColumnSpacing)
|
||||
type ColMap1 = IntMapL.IntMap {- ColIndex -} (Bool, ColumnBlocks ColumnSpacing)
|
||||
type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int)
|
||||
-- (ratio of hasSpace, maximum, raw)
|
||||
|
||||
|
|
|
|||
|
|
@ -31,10 +31,11 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
|
|||
VarPat n -> fmap Seq.singleton $ docLit $ lrdrNameToText n
|
||||
LitPat lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit
|
||||
ParPat inner -> do
|
||||
innerDocs <- layoutPat inner
|
||||
left <- docLit $ Text.pack "("
|
||||
left <- docLit $ Text.pack "("
|
||||
right <- docLit $ Text.pack ")"
|
||||
return $ (left Seq.<| innerDocs) Seq.|> right
|
||||
innerDocs <- colsWrapPat =<< layoutPat inner
|
||||
return $ Seq.empty Seq.|> left Seq.|> innerDocs Seq.|> right
|
||||
-- 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
|
||||
|
|
|
|||
Loading…
Reference in New Issue