diff --git a/src-literatetests/tests.blt b/src-literatetests/tests.blt index a923d81..0e30f69 100644 --- a/src-literatetests/tests.blt +++ b/src-literatetests/tests.blt @@ -690,10 +690,8 @@ showPackageDetailedInfo pkginfo = , entry "Documentation" haddockHtml showIfInstalled text , entry "Cached" haveTarball alwaysShow dispYesNo , if not (hasLib pkginfo) - then - empty - else - text "Modules:" + then empty + else text "Modules:" $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo)) ] @@ -710,6 +708,10 @@ foo = Reflex.runSpiderHost $ ReflexHost.hostApp $ do liftIO . forkIO . forever $ getLine >>= inputFire ReflexHost.performEvent_ $ fmap (liftIO . putStrLn) inputEvent +#test issue 16 +foldrDesc f z = unSwitchQueue $ \q -> + switch (Min.foldrDesc (f unTaggedF) z q) (Min.foldrAsc (f unTaggedF) z q) + ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Layouters/Expr.hs index 72c39bc..bbc128f 100644 --- a/src/Language/Haskell/Brittany/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Layouters/Expr.hs @@ -109,24 +109,36 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of headDoc <- docSharedWrapper layoutExpr headE paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs docAlt - [ docCols ColApp + [ -- foo x y + docCols ColApp $ appSep (docForceSingleline headDoc) : spacifyDocs (docForceSingleline <$> paramDocs) - , docSeq + , -- foo x + -- y + docSeq [ appSep (docForceSingleline headDoc) , docSetBaseY $ docAddBaseY BrIndentRegular $ docLines - $ paramDocs + $ (docForceSingleline <$> paramDocs) ] - , docSetParSpacing + , -- foo + -- x + -- y + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docForceSingleline headDoc) ( docNonBottomSpacing $ docLines paramDocs ) - , docAddBaseY BrIndentRegular + , -- ( multi + -- line + -- function + -- ) + -- x + -- y + docAddBaseY BrIndentRegular $ docPar headDoc ( docNonBottomSpacing @@ -317,7 +329,8 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of elseExprDoc <- docSharedWrapper layoutExpr elseExpr hasComments <- hasAnyCommentsBelow lexpr docAltFilter - [ (,) (not hasComments) + [ -- if _ then _ else _ + (,) (not hasComments) $ docSeq [ appSep $ docLit $ Text.pack "if" , appSep $ docForceSingleline ifExprDoc @@ -326,7 +339,20 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of , appSep $ docLit $ Text.pack "else" , docForceSingleline elseExprDoc ] - , (,) True + , -- either + -- if expr + -- then foo + -- bar + -- else foo + -- bar + -- or + -- if expr + -- then + -- stuff + -- else + -- stuff + -- note that this has par-spacing + (,) True $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar @@ -350,7 +376,24 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of $ docPar (docLit $ Text.pack "else") elseExprDoc ] ]) - , (,) True + , -- either + -- if multi + -- line + -- condition + -- then foo + -- bar + -- else foo + -- bar + -- or + -- if multi + -- line + -- condition + -- then + -- stuff + -- else + -- stuff + -- note that this does _not_ have par-spacing + (,) True $ docAddBaseY BrIndentRegular $ docPar ( docAddBaseY (BrIndentSpecial 3) @@ -374,6 +417,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of ] ]) , (,) True + $ docSetBaseY $ docLines [ docAddBaseY (BrIndentSpecial 3) $ docSeq diff --git a/src/Language/Haskell/Brittany/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Transformations/Alt.hs index acf5a04..208771e 100644 --- a/src/Language/Haskell/Brittany/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Transformations/Alt.hs @@ -552,6 +552,11 @@ getSpacings -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] getSpacings limit bridoc = preFilterLimit <$> rec bridoc where + -- when we do `take K . filter someCondition` on a list of spacings, we + -- need to first (also) limit the size of the input list, otherwise a + -- _large_ input with a similarly _large_ prefix not passing our filtering + -- process could lead to exponential runtime behaviour. + -- TODO: 3 is arbitrary. preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing] preFilterLimit = take (3*limit) memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v @@ -565,15 +570,41 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc VerticalSpacingParNone -> True VerticalSpacingParSome i -> i <= colMax VerticalSpacingParAlways{} -> True - let filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing] + let -- the standard function used to enforce a constant upper bound + -- on the number of elements returned for each node. Should be + -- applied whenever in a parent the combination of spacings from + -- its children might cause excess of the upper bound. + filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing] filterAndLimit = take limit + -- prune so we always consider a constant + -- amount of spacings per node of the BriDoc. . filter hasOkColCount - . preFilterLimit -- we need to limit here in case - -- that the input list is - -- _large_ with a similarly _large_ - -- prefix not passing hasOkColCount - -- predicate. - -- TODO: 3 is arbitrary. + -- throw out any spacings (i.e. children) that + -- already use more columns than available in + -- total. + . List.nub + -- In the end we want to know if there is at least + -- one valid spacing for any alternative. + -- If there are duplicates in the list, then these + -- will either all be valid (so having more than the + -- first is pointless) or all invalid (in which + -- case having any of them is pointless). + -- Nonetheless I think the order of spacings should + -- be preserved as it provides a deterministic + -- choice for which spacings to prune (which is + -- an argument against simly using a Set). + -- I have also considered `fmap head . group` which + -- seems to work similarly well for common cases + -- and which might behave even better when it comes + -- to determinism of the algorithm. But determinism + -- should not be overrated here either - in the end + -- this is about deterministic behaviour of the + -- pruning we do that potentially results in + -- non-optimal layouts, and we'd rather take optimal + -- layouts when we can than take non-optimal layouts + -- just to be consistent with other cases where + -- we'd choose non-optimal layouts. + . preFilterLimit result <- case brdc of -- BDWrapAnnKey _annKey bd -> rec bd BDFEmpty -> diff --git a/src/Language/Haskell/Brittany/Types.hs b/src/Language/Haskell/Brittany/Types.hs index ae7ddd1..af05370 100644 --- a/src/Language/Haskell/Brittany/Types.hs +++ b/src/Language/Haskell/Brittany/Types.hs @@ -412,7 +412,7 @@ data VerticalSpacing , _vs_paragraph :: !VerticalSpacingPar , _vs_parFlag :: !Bool } - deriving Show + deriving (Eq, Show) newtype LineModeValidity a = LineModeValidity (Strict.Maybe a) deriving (Functor, Applicative, Monad, Show, Alternative)