From e9689394b17f204ead6a33fb8d696ce74ab96b43 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Fri, 30 Mar 2018 11:19:08 +0100 Subject: [PATCH 01/11] Add Semigroup instance for 'Max' monoid Otherwise ghc 8.4 will complain since Semigroup became a superclass of Monoid. --- src-brittany/Main.hs | 3 ++- src/Language/Haskell/Brittany/Internal/Prelude.hs | 6 ++++-- src/Language/Haskell/Brittany/Internal/Utils.hs | 5 ++++- 3 files changed, 10 insertions(+), 4 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 73eccd0..7538411 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -11,6 +11,7 @@ import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers import qualified Data.Map as Map +import qualified Data.Monoid import Text.Read (Read(..)) import qualified Text.ParserCombinators.ReadP as ReadP @@ -148,7 +149,7 @@ mainCmdParser helpDesc = do , PP.text "inplace: override respective input file (without backup!)" ] ) - <> flagDefault Display + Data.Monoid.<> flagDefault Display ) inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input/inout haskell source files") reorderStop diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs index 0ed9b6c..cc45d2a 100644 --- a/src/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -255,14 +255,16 @@ import Debug.Trace as E ( trace import Foreign.ForeignPtr as E ( ForeignPtr ) -import Data.Monoid as E ( (<>) - , mconcat +import Data.Monoid as E ( mconcat , Monoid (..) ) import Data.Bifunctor as E ( bimap ) import Data.Functor as E ( (<$), ($>) ) import Data.Function as E ( (&) ) +import Data.Semigroup as E ( (<>) + , Semigroup(..) + ) import System.IO as E ( hFlush , stdout ) diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs index b0896b8..aca6754 100644 --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -84,9 +84,12 @@ fromOptionIdentity x y = newtype Max a = Max { getMax :: a } deriving (Eq, Ord, Show, Bounded, Num) +instance (Num a, Ord a) => Semigroup (Max a) where + (<>) = Data.Coerce.coerce (max :: a -> a -> a) + instance (Num a, Ord a) => Monoid (Max a) where mempty = Max 0 - mappend = Data.Coerce.coerce (max :: a -> a -> a) + mappend = (<>) newtype ShowIsId = ShowIsId String deriving Data From 8410fbff8e4c076e97a1e840179f304186aa4010 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Fri, 30 Mar 2018 11:20:06 +0100 Subject: [PATCH 02/11] Trailing whitespace --- .../Brittany/Internal/LayouterBasics.hs | 48 +++++++++---------- .../Haskell/Brittany/Internal/Prelude.hs | 2 +- .../Haskell/Brittany/Internal/Utils.hs | 2 +- 3 files changed, 26 insertions(+), 26 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 5fb5c8d..21d0f2f 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -297,10 +297,10 @@ allocNodeIndex = do -- docEmpty :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -- docEmpty = allocateNode BDFEmpty --- +-- -- docLit :: MonadMultiState NodeAllocIndex m => Text -> m BriDocNumbered -- docLit t = allocateNode $ BDFLit t --- +-- -- docExt :: (ExactPrint.Annotate.Annotate ast, MonadMultiState NodeAllocIndex m) -- => Located ast -> ExactPrint.Types.Anns -> Bool -> m BriDocNumbered -- docExt x anns shouldAddComment = allocateNode $ BDFExternal @@ -308,51 +308,51 @@ allocNodeIndex = do -- (foldedAnnKeys x) -- shouldAddComment -- (Text.pack $ ExactPrint.exactPrint x anns) --- +-- -- docAlt :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered -- docAlt l = allocateNode . BDFAlt =<< sequence l --- --- +-- +-- -- docSeq :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered -- docSeq l = allocateNode . BDFSeq =<< sequence l --- +-- -- docLines :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered -- docLines l = allocateNode . BDFLines =<< sequence l --- +-- -- docCols :: MonadMultiState NodeAllocIndex m => ColSig -> [m BriDocNumbered] -> m BriDocNumbered -- docCols sig l = allocateNode . BDFCols sig =<< sequence l --- +-- -- docAddBaseY :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered -- docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm --- +-- -- docSetBaseY :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered -- docSetBaseY bdm = allocateNode . BDFSetBaseY =<< bdm --- +-- -- docSetIndentLevel :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered -- docSetIndentLevel bdm = allocateNode . BDFSetIndentLevel =<< bdm --- +-- -- docSeparator :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -- docSeparator = allocateNode BDFSeparator --- +-- -- docAnnotationPrior :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered -- docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm --- +-- -- docAnnotationPost :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered -- docAnnotationPost annKey bdm = allocateNode . BDFAnnotationPost annKey =<< bdm --- +-- -- docNonBottomSpacing :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered -- docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm --- +-- -- appSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered -- appSep x = docSeq [x, docSeparator] --- +-- -- docCommaSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -- docCommaSep = appSep $ docLit $ Text.pack "," --- +-- -- docParenLSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -- docParenLSep = appSep $ docLit $ Text.pack "(" --- --- +-- +-- -- docPostComment :: (Data.Data.Data ast, MonadMultiState NodeAllocIndex m) -- => Located ast -- -> m BriDocNumbered @@ -360,7 +360,7 @@ allocNodeIndex = do -- docPostComment ast bdm = do -- bd <- bdm -- allocateNode $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd --- +-- -- docWrapNode :: ( Data.Data.Data ast, MonadMultiState NodeAllocIndex m) -- => Located ast -- -> m BriDocNumbered @@ -375,7 +375,7 @@ allocNodeIndex = do -- $ (,) i2 -- $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) -- $ bd --- +-- -- docPar :: MonadMultiState NodeAllocIndex m -- => m BriDocNumbered -- -> m BriDocNumbered @@ -384,13 +384,13 @@ allocNodeIndex = do -- line <- lineM -- indented <- indentedM -- allocateNode $ BDFPar BrIndentNone line indented --- +-- -- docForceSingleline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered -- docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm --- +-- -- docForceMultiline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered -- docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm --- +-- -- docEnsureIndent :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered -- docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs index cc45d2a..646ebb7 100644 --- a/src/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -308,7 +308,7 @@ import Data.Tree as E ( Tree(..) import Control.Monad.Trans.MultiRWS as E ( -- MultiRWST (..) -- , MultiRWSTNull -- , MultiRWS - -- , + -- , MonadMultiReader(..) , MonadMultiWriter(..) , MonadMultiState(..) diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs index aca6754..b454890 100644 --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -225,7 +225,7 @@ tellDebugMess :: MonadMultiWriter tellDebugMess s = mTell $ Seq.singleton s tellDebugMessShow :: forall a m . (MonadMultiWriter - (Seq String) m, Show a) => a -> m () + (Seq String) m, Show a) => a -> m () tellDebugMessShow = tellDebugMess . show -- i should really put that into multistate.. From 2ed9a13fdb022e17d877608a11465e92af975a03 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Mon, 2 Apr 2018 21:18:37 +0100 Subject: [PATCH 03/11] Replace 'docAltFilter' with 'runFilteredAlternative' --- .../Brittany/Internal/LayouterBasics.hs | 30 +- .../Brittany/Internal/Layouters/Decl.hs | 468 +++++++------- .../Brittany/Internal/Layouters/Expr.hs | 600 +++++++++--------- .../Haskell/Brittany/Internal/Layouters/IE.hs | 39 +- .../Brittany/Internal/Layouters/Import.hs | 30 +- .../Brittany/Internal/Layouters/Module.hs | 42 +- .../Brittany/Internal/Layouters/Stmt.hs | 68 +- stack.yaml | 2 +- 8 files changed, 622 insertions(+), 657 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 21d0f2f..ec9d505 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Language.Haskell.Brittany.Internal.LayouterBasics ( processDefault , rdrNameToText @@ -11,7 +13,11 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docEmpty , docLit , docAlt - , docAltFilter + , CollectAltM + , addAlternativeCondM + , addAlternativeCond + , addAlternative + , runFilteredAlternative , docLines , docCols , docSeq @@ -60,6 +66,8 @@ where #include "prelude.inc" +import qualified Control.Monad.Writer.Strict as Writer + import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types @@ -415,8 +423,24 @@ docExt x anns shouldAddComment = allocateNode $ BDFExternal docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered docAlt l = allocateNode . BDFAlt =<< sequence l -docAltFilter :: [(Bool, ToBriDocM BriDocNumbered)] -> ToBriDocM BriDocNumbered -docAltFilter = docAlt . map snd . filter fst +newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a) + deriving (Functor, Applicative, Monad) + +addAlternativeCondM :: Bool -> CollectAltM (ToBriDocM BriDocNumbered) -> CollectAltM () +addAlternativeCondM cond doc = + addAlternativeCond cond =<< doc + +addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM () +addAlternativeCond cond doc = + when cond (addAlternative doc) + +addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM () +addAlternative = + CollectAltM . Writer.tell . (: []) + +runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered +runFilteredAlternative (CollectAltM action) = + docAlt $ Writer.execWriter action docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 400d422..d27c385 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -313,253 +313,231 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - docAltFilter - $ -- one-line solution - [ ( True - , docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return body - , wherePart - ] - ] - ) - | not hasComments - , [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - , wherePart <- case mWhereDocs of - Nothing -> return @[] $ docEmpty - Just [w] -> return @[] $ docSeq - [ docSeparator - , appSep $ docLit $ Text.pack "where" - , docSetIndentLevel $ docForceSingleline $ return w - ] - _ -> [] - ] - ++ -- one-line solution + where in next line(s) - [ ( True - , docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [appSep $ return binderDoc, docForceParSpacing $ return body] + runFilteredAlternative $ do + + let wherePart = case mWhereDocs of + Nothing -> Just docEmpty + Just [w] -> Just $ docSeq + [ docSeparator + , appSep $ docLit $ Text.pack "where" + , docSetIndentLevel $ docForceSingleline $ return w + ] + _ -> Nothing + case clauseDocs of + [(guards, body, _bodyRaw)] -> do + let guardPart = singleLineGuardsDoc guards + forM_ wherePart $ \wherePart' -> + -- one-line solution + addAlternativeCond (not hasComments) $ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return body + , wherePart' ] ] - ++ wherePartMultiLine - ) - | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - , Data.Maybe.isJust mWhereDocs - ] - ++ -- two-line solution + where in next line(s) - [ ( True - , docLines - $ [ docForceSingleline - $ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body - ] - ++ wherePartMultiLine - ) - | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - ] - ++ -- pattern and exactly one clause in single line, body as par; - -- where in following lines - [ ( True - , docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body - ] - ] - ] - -- , lineMod $ docAlt - -- [ docSetBaseY $ return body - -- , docAddBaseY BrIndentRegular $ return body - -- ] - ++ wherePartMultiLine - ) - | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - ] - ++ -- pattern and exactly one clause in single line, body in new line. - [ ( True - , docLines - $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docEnsureIndent BrIndentRegular - $ docNonBottomSpacing - $ (docAddBaseY BrIndentRegular $ return body) - ] - ++ wherePartMultiLine - ) - | [(guards, body, _)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - ] - ++ -- multiple clauses added in-paragraph, each in a single line - -- example: foo | bar = baz - -- | lll = asd - [ ( indentPolicy /= IndentPolicyLeft - , docLines - $ [ docSeq - [ appSep $ docForceSingleline $ return patDoc - , docSetBaseY - $ docLines - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> do - let guardPart = singleLineGuardsDoc guardDocs - -- the docForceSingleline might seems superflous, but it - -- helps the alternative resolving impl. - docForceSingleline $ docCols - ColGuardedBody - [ guardPart - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return bodyDoc - -- i am not sure if there is a benefit to using - -- docForceParSpacing additionally here: - -- , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ] - ++ wherePartMultiLine - ) - | Just patDoc <- [mPatDoc] - ] - ++ -- multiple clauses, each in a separate, single line - [ ( True - , docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> do - let guardPart = singleLineGuardsDoc guardDocs - -- the docForceSingleline might seems superflous, but it - -- helps the alternative resolving impl. - docForceSingleline $ docCols - ColGuardedBody - [ guardPart - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return bodyDoc - -- i am not sure if there is a benefit to using - -- docForceParSpacing additionally here: - -- , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - ) - ] - ++ -- multiple clauses, each with the guard(s) in a single line, body - -- as a paragraph - [ ( True - , docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> - docSeq - $ ( case guardDocs of - [] -> [] - [g] -> - [ docForceSingleline - $ docSeq [appSep $ docLit $ Text.pack "|", return g] - ] - gs -> - [ docForceSingleline - $ docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ] - ) - ++ [ docSeparator - , docCols - ColOpPrefix - [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular - $ docForceParSpacing - $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - ) - ] - ++ -- multiple clauses, each with the guard(s) in a single line, body - -- in a new line as a paragraph - [ ( True - , docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - >>= \(guardDocs, bodyDoc, _) -> - ( case guardDocs of - [] -> [] - [g] -> - [ docForceSingleline - $ docSeq [appSep $ docLit $ Text.pack "|", return g] - ] - gs -> - [ docForceSingleline - $ docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ] - ) - ++ [ docCols - ColOpPrefix + -- one-line solution + where in next line(s) + addAlternativeCond (Data.Maybe.isJust mWhereDocs) + $ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [appSep $ return binderDoc, docForceParSpacing $ return body] + ] + ] + ++ wherePartMultiLine + -- two-line solution + where in next line(s) + addAlternative + $ docLines + $ [ docForceSingleline + $ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body + ] + ++ wherePartMultiLine + -- pattern and exactly one clause in single line, body as par; + -- where in following lines + addAlternative + $ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body + ] + ] + ] + -- , lineMod $ docAlt + -- [ docSetBaseY $ return body + -- , docAddBaseY BrIndentRegular $ return body + -- ] + ++ wherePartMultiLine + -- pattern and exactly one clause in single line, body in new line. + addAlternative + $ docLines + $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docEnsureIndent BrIndentRegular + $ docNonBottomSpacing + $ docAddBaseY BrIndentRegular + $ return body + ] + ++ wherePartMultiLine + + _ -> return () + + case mPatDoc of + Nothing -> return () + Just patDoc -> + -- multiple clauses added in-paragraph, each in a single line + -- example: foo | bar = baz + -- | lll = asd + addAlternativeCond (indentPolicy /= IndentPolicyLeft) + $ docLines + $ [ docSeq + [ appSep $ docForceSingleline $ return patDoc + , docSetBaseY + $ docLines + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> do + let guardPart = singleLineGuardsDoc guardDocs + -- the docForceSingleline might seems superflous, but it + -- helps the alternative resolving impl. + docForceSingleline $ docCols + ColGuardedBody + [ guardPart + , docSeq [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular - $ docForceParSpacing - $ return bodyDoc + , docForceSingleline $ return bodyDoc + -- i am not sure if there is a benefit to using + -- docForceParSpacing additionally here: + -- , docAddBaseY BrIndentRegular $ return bodyDoc ] ] - ] - ++ wherePartMultiLine - ) - ] - ++ -- conservative approach: everything starts on the left. - [ ( True - , docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - >>= \(guardDocs, bodyDoc, _) -> - ( case guardDocs of - [] -> [] - [g] -> - [docSeq [appSep $ docLit $ Text.pack "|", return g]] - (g1:gr) -> - ( docSeq [appSep $ docLit $ Text.pack "|", return g1] - : ( gr - <&> \g -> - docSeq - [appSep $ docLit $ Text.pack ",", return g] - ) - ) - ) - ++ [ docCols - ColOpPrefix - [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - ) - ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each in a separate, single line + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> do + let guardPart = singleLineGuardsDoc guardDocs + -- the docForceSingleline might seems superflous, but it + -- helps the alternative resolving impl. + docForceSingleline $ docCols + ColGuardedBody + [ guardPart + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return bodyDoc + -- i am not sure if there is a benefit to using + -- docForceParSpacing additionally here: + -- , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each with the guard(s) in a single line, body + -- as a paragraph + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> + docSeq + $ ( case guardDocs of + [] -> [] + [g] -> + [ docForceSingleline + $ docSeq [appSep $ docLit $ Text.pack "|", return g] + ] + gs -> + [ docForceSingleline + $ docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) + ] + ) + ++ [ docSeparator + , docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular + $ docForceParSpacing + $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each with the guard(s) in a single line, body + -- in a new line as a paragraph + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + >>= \(guardDocs, bodyDoc, _) -> + ( case guardDocs of + [] -> [] + [g] -> + [ docForceSingleline + $ docSeq [appSep $ docLit $ Text.pack "|", return g] + ] + gs -> + [ docForceSingleline + $ docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) + ] + ) + ++ [ docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular + $ docForceParSpacing + $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- conservative approach: everything starts on the left. + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + >>= \(guardDocs, bodyDoc, _) -> + ( case guardDocs of + [] -> [] + [g] -> + [docSeq [appSep $ docLit $ Text.pack "|", return g]] + (g1:gr) -> + ( docSeq [appSep $ docLit $ Text.pack "|", return g1] + : ( gr + <&> \g -> + docSeq + [appSep $ docLit $ Text.pack ",", return g] + ) + ) + ) + ++ [ docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index a5402ea..3240798 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -123,51 +123,46 @@ layoutExpr lexpr@(L _ expr) = do _ -> docSeq headDoc <- docSharedWrapper layoutExpr headE paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs - docAltFilter - [ -- foo x y - ( True - , colsOrSequence + runFilteredAlternative $ do + -- foo x y + addAlternative + $ colsOrSequence $ appSep (docForceSingleline headDoc) : spacifyDocs (docForceSingleline <$> paramDocs) - ) - , -- foo x - -- y - ( allowFreeIndent - , docSeq - [ appSep (docForceSingleline headDoc) - , docSetBaseY - $ docAddBaseY BrIndentRegular - $ docLines - $ (docForceSingleline <$> paramDocs) - ] - ) - , -- foo - -- x - -- y - ( True - , docSetParSpacing + -- foo x + -- y + addAlternativeCond allowFreeIndent + $ docSeq + [ appSep (docForceSingleline headDoc) + , docSetBaseY + $ docAddBaseY BrIndentRegular + $ docLines + $ (docForceSingleline <$> paramDocs) + ] + -- foo + -- x + -- y + addAlternative + $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docForceSingleline headDoc) ( docNonBottomSpacing $ docLines paramDocs ) - ) - , -- ( multi - -- line - -- function - -- ) - -- x - -- y - ( True - , docAddBaseY BrIndentRegular + -- ( multi + -- line + -- function + -- ) + -- x + -- y + addAlternative + $ docAddBaseY BrIndentRegular $ docPar headDoc ( docNonBottomSpacing $ docLines paramDocs ) - ) - ] HsApp exp1 exp2 -> do -- TODO: if expDoc1 is some literal, we may want to create a docCols here. expDoc1 <- docSharedWrapper layoutExpr exp1 @@ -243,39 +238,37 @@ layoutExpr lexpr@(L _ expr) = do | occNameString occname == "$" -> True (_, L _ (HsApp _ (L _ HsVar{}))) -> False _ -> True - docAltFilter - [ ( not hasComments + runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + [ appSep $ docForceSingleline leftOperandDoc , docSeq - [ appSep $ docForceSingleline leftOperandDoc - , docSeq - $ (appListDocs <&> \(od, ed) -> docSeq - [ appSep $ docForceSingleline od - , appSep $ docForceSingleline ed - ] - ) - , appSep $ docForceSingleline opLastDoc - , (if allowPar then docForceParSpacing else docForceSingleline) - expLastDoc - ] - ) + $ (appListDocs <&> \(od, ed) -> docSeq + [ appSep $ docForceSingleline od + , appSep $ docForceSingleline ed + ] + ) + , appSep $ docForceSingleline opLastDoc + , (if allowPar then docForceParSpacing else docForceSingleline) + expLastDoc + ] -- this case rather leads to some unfortunate layouting than to anything -- useful; disabling for now. (it interfers with cols stuff.) - -- , docSetBaseY - -- - $ docPar + -- addAlternative + -- $ docSetBaseY + -- $ docPar -- leftOperandDoc -- ( 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]] -- ) - , (otherwise - , docPar + addAlternative $ + docPar leftOperandDoc ( docLines $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] ) - ) - ] OpApp expLeft expOp _ expRight -> do expDocLeft <- docSharedWrapper layoutExpr expLeft expDocOp <- docSharedWrapper layoutExpr expOp @@ -285,42 +278,42 @@ layoutExpr lexpr@(L _ expr) = do | occNameString occname == "$" -> True (_, L _ (HsApp _ (L _ HsVar{}))) -> False _ -> True - docAltFilter - $ [ -- one-line - (,) True - $ docSeq - [ appSep $ docForceSingleline expDocLeft - , appSep $ docForceSingleline expDocOp - , docForceSingleline expDocRight - ] - -- , -- line + freely indented block for right expression - -- docSeq - -- [ appSep $ docForceSingleline expDocLeft - -- , appSep $ docForceSingleline expDocOp - -- , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight - -- ] - , -- two-line - (,) True - $ docAddBaseY BrIndentRegular - $ docPar - expDocLeft - ( docForceSingleline - $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight] - ) - , -- one-line + par - (,) allowPar - $ docSeq - [ appSep $ docForceSingleline expDocLeft - , appSep $ docForceSingleline expDocOp - , docForceParSpacing expDocRight - ] - , -- more lines - (,) True - $ docAddBaseY BrIndentRegular - $ docPar - expDocLeft - (docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight]) - ] + runFilteredAlternative $ do + -- one-line + addAlternative + $ docSeq + [ appSep $ docForceSingleline expDocLeft + , appSep $ docForceSingleline expDocOp + , docForceSingleline expDocRight + ] + -- -- line + freely indented block for right expression + -- addAlternative + -- $ docSeq + -- [ appSep $ docForceSingleline expDocLeft + -- , appSep $ docForceSingleline expDocOp + -- , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight + -- ] + -- two-line + addAlternative + $ docAddBaseY BrIndentRegular + $ docPar + expDocLeft + ( docForceSingleline + $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight] + ) + -- one-line + par + addAlternativeCond allowPar + $ docSeq + [ appSep $ docForceSingleline expDocLeft + , appSep $ docForceSingleline expDocOp + , docForceParSpacing expDocRight + ] + -- more lines + addAlternative + $ docAddBaseY BrIndentRegular + $ docPar + expDocLeft + (docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight]) NegApp op _ -> do opDoc <- docSharedWrapper layoutExpr op docSeq $ [ docLit $ Text.pack "-" @@ -380,24 +373,21 @@ layoutExpr lexpr@(L _ expr) = do , closeLit ] ] - FirstLast e1 ems eN -> - docAltFilter - [ (,) (not hasComments) - $ docCols ColTuple - ( [docSeq [openLit, docForceSingleline e1]] - ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e]) - ++ [docSeq [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN), closeLit]] - ) - , (,) True - $ let - start = docCols ColTuples - [appSep $ openLit, e1] - linesM = ems <&> \d -> - docCols ColTuples [docCommaSep, d] - lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] - end = closeLit - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] - ] + FirstLast e1 ems eN -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docCols ColTuple + $ [docSeq [openLit, docForceSingleline e1]] + ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e]) + ++ [docSeq [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN), closeLit]] + addAlternative $ + let + start = docCols ColTuples + [appSep $ openLit, e1] + linesM = ems <&> \d -> + docCols ColTuples [docCommaSep, d] + lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] + end = closeLit + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do cExpDoc <- docSharedWrapper layoutExpr cExp binderDoc <- docLit $ Text.pack "->" @@ -432,10 +422,10 @@ layoutExpr lexpr@(L _ expr) = do _ -> BrIndentSpecial 3 -- TODO: some of the alternatives (especially last and last-but-one) -- overlap. - docAltFilter - [ -- if _ then _ else _ - (,) (not hasComments) - $ docSeq + runFilteredAlternative $ do + -- if _ then _ else _ + addAlternativeCond (not hasComments) + $ docSeq [ appSep $ docLit $ Text.pack "if" , appSep $ docForceSingleline ifExprDoc , appSep $ docLit $ Text.pack "then" @@ -443,106 +433,105 @@ layoutExpr lexpr@(L _ expr) = do , appSep $ docLit $ Text.pack "else" , docForceSingleline elseExprDoc ] - , -- 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 - ( docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc - ]) - (docLines - [ docAddBaseY BrIndentRegular - $ docNodeAnnKW lexpr (Just AnnThen) - $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] + -- either + -- if expr + -- then foo + -- bar + -- else foo + -- bar + -- or + -- if expr + -- then + -- stuff + -- else + -- stuff + -- note that this has par-spacing + addAlternative + $ docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + ( docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc + ]) + (docLines + [ docAddBaseY BrIndentRegular + $ docNodeAnnKW lexpr (Just AnnThen) + $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + ] , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - ] - , docAddBaseY BrIndentRegular - $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] + $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] + ]) + -- 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 + addAlternative + $ docAddBaseY BrIndentRegular + $ docPar + ( docAddBaseY maySpecialIndent + $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc + ]) + (docLines + [ docAddBaseY BrIndentRegular + $ docNodeAnnKW lexpr (Just AnnThen) + $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + ] , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - ]) - , -- 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 maySpecialIndent + $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] + ]) + addAlternative + $ docSetBaseY + $ docLines + [ docAddBaseY maySpecialIndent $ docSeq [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc - ]) - (docLines - [ docAddBaseY BrIndentRegular - $ docNodeAnnKW lexpr (Just AnnThen) - $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - ] - , docAddBaseY BrIndentRegular - $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - ]) - , (,) True - $ docSetBaseY - $ docLines - [ docAddBaseY maySpecialIndent - $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc + ] + , docNodeAnnKW lexpr (Just AnnThen) + $ docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc ] - , docNodeAnnKW lexpr (Just AnnThen) - $ docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - ] HsMultiIf _ cases -> do - clauseDocs <- cases `forM` layoutGrhs - binderDoc <- docLit $ Text.pack "->" + clauseDocs <- cases `forM` layoutGrhs + binderDoc <- docLit $ Text.pack "->" hasComments <- hasAnyCommentsBelow lexpr docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "if") (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments) HsLet binds exp1 -> do - expDoc1 <- docSharedWrapper layoutExpr exp1 + expDoc1 <- docSharedWrapper layoutExpr exp1 -- We jump through some ugly hoops here to ensure proper sharing. mBindDocs <- mapM (fmap (fmap return) . docWrapNodeRest lexpr . return) =<< layoutLocalBinds binds @@ -590,7 +579,7 @@ layoutExpr lexpr@(L _ expr) = do ] ] ] - Just bindDocs@(_:_) -> docAltFilter + Just bindDocs@(_:_) -> runFilteredAlternative $ do --either -- let -- a = b @@ -604,43 +593,39 @@ layoutExpr lexpr@(L _ expr) = do -- c = d -- in -- fooooooooooooooooooo - [ ( indentPolicy == IndentPolicyLeft - , docLines - [ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ bindDocs) - , docSeq - [ docLit $ Text.pack "in " - , docAddBaseY BrIndentRegular $ expDoc1 - ] + addAlternativeCond (indentPolicy == IndentPolicyLeft) + $ docLines + [ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ bindDocs) + , docSeq + [ docLit $ Text.pack "in " + , docAddBaseY BrIndentRegular $ expDoc1 ] - ) - , ( indentPolicy /= IndentPolicyLeft - , docLines - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ docLines $ bindDocs - ] - , docSeq - [ appSep $ docLit $ Text.pack "in " - , docSetBaseY $ expDoc1 - ] + ] + addAlternativeCond (indentPolicy /= IndentPolicyLeft) + $ docLines + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , docSetBaseAndIndent $ docLines $ bindDocs ] - ) - , ( True - , docLines - [ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ bindDocs) - , docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "in") - (docSetBaseY $ expDoc1) + , docSeq + [ appSep $ docLit $ Text.pack "in " + , docSetBaseY $ expDoc1 ] - ) - ] + ] + addAlternative + $ docLines + [ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ bindDocs) + , docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "in") + (docSetBaseY $ expDoc1) + ] _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] -- docSeq [appSep $ docLit "let in", expDoc1] HsDo DoExpr (L _ stmts) _ -> do @@ -660,11 +645,11 @@ layoutExpr lexpr@(L _ expr) = do HsDo x (L _ stmts) _ | case x of { ListComp -> True ; MonadComp -> True ; _ -> False } -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts hasComments <- hasAnyCommentsBelow lexpr - docAltFilter - [ (,) (not hasComments) - $ docSeq + runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq [ docNodeAnnKW lexpr Nothing $ appSep $ docLit @@ -678,8 +663,8 @@ layoutExpr lexpr@(L _ expr) = do $ fmap docForceSingleline $ List.init stmtDocs , docLit $ Text.pack " ]" ] - , (,) True - $ let + addAlternative $ + let start = docCols ColListComp [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "[" @@ -694,12 +679,11 @@ layoutExpr lexpr@(L _ expr) = do docCols ColListComp [docCommaSep, d] end = docLit $ Text.pack "]" in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] - ] HsDo{} -> do -- TODO unknownNodeError "HsDo{} no comp" lexpr ExplicitList _ _ elems@(_:_) -> do - elemDocs <- elems `forM` docSharedWrapper layoutExpr + elemDocs <- elems `forM` docSharedWrapper layoutExpr hasComments <- hasAnyCommentsBelow lexpr case splitFirstLast elemDocs of FirstLastEmpty -> docSeq @@ -721,23 +705,21 @@ layoutExpr lexpr@(L _ expr) = do , docLit $ Text.pack "]" ] ] - FirstLast e1 ems eN -> - docAltFilter - [ (,) (not hasComments) + FirstLast e1 ems eN -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) $ docSeq $ [docLit $ Text.pack "["] ++ List.intersperse docCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN])) ++ [docLit $ Text.pack "]"] - , (,) True - $ let - start = docCols ColList - [appSep $ docLit $ Text.pack "[", e1] - linesM = ems <&> \d -> - docCols ColList [docCommaSep, d] - lineN = docCols ColList [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] - ] + addAlternative $ + let + start = docCols ColList + [appSep $ docLit $ Text.pack "[", e1] + linesM = ems <&> \d -> + docCols ColList [docCommaSep, d] + lineN = docCols ColList [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] + end = docLit $ Text.pack "]" + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] ExplicitList _ _ [] -> docLit $ Text.pack "[]" ExplicitPArr{} -> do @@ -870,67 +852,65 @@ layoutExpr lexpr@(L _ expr) = do return $ case ambName of Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) - docAltFilter + runFilteredAlternative $ do -- container { fieldA = blub, fieldB = blub } - [ ( True - , docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline rExprDoc - , appSep $ docLit $ Text.pack "{" - , appSep $ docSeq $ List.intersperse docCommaSep - $ rFs <&> \case - (lfield, fieldStr, Just fieldDoc) -> - docWrapNode lfield $ docSeq - [ appSep $ docLit fieldStr - , appSep $ docLit $ Text.pack "=" - , docForceSingleline fieldDoc - ] - (lfield, fieldStr, Nothing) -> - docWrapNode lfield $ docLit fieldStr - , docLit $ Text.pack "}" - ] - ) + addAlternative + $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline rExprDoc + , appSep $ docLit $ Text.pack "{" + , appSep $ docSeq $ List.intersperse docCommaSep + $ rFs <&> \case + (lfield, fieldStr, Just fieldDoc) -> + docWrapNode lfield $ docSeq + [ appSep $ docLit fieldStr + , appSep $ docLit $ Text.pack "=" + , docForceSingleline fieldDoc + ] + (lfield, fieldStr, Nothing) -> + docWrapNode lfield $ docLit fieldStr + , docLit $ Text.pack "}" + ] -- hanging single-line fields -- container { fieldA = blub -- , fieldB = blub -- } - , ( indentPolicy /= IndentPolicyLeft - , docSeq - [ docNodeAnnKW lexpr Nothing $ appSep rExprDoc - , docSetBaseY $ docLines $ let - line1 = docCols ColRecUpdate - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n - , case rF1e of - Just x -> docWrapNodeRest rF1f $ docSeq - [ appSep $ docLit $ Text.pack "=" + addAlternativeCond (indentPolicy /= IndentPolicyLeft) + $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep rExprDoc + , docSetBaseY $ docLines $ let + line1 = docCols ColRecUpdate + [ appSep $ docLit $ Text.pack "{" + , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n + , case rF1e of + Just x -> docWrapNodeRest rF1f $ docSeq + [ appSep $ docLit $ Text.pack "=" + , docForceSingleline x + ] + Nothing -> docEmpty + ] + lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate + [ docCommaSep + , appSep $ docLit $ fText + , case fDoc of + Just x -> docSeq [ appSep $ docLit $ Text.pack "=" , docForceSingleline x ] - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate - [ docCommaSep - , appSep $ docLit $ fText - , case fDoc of - Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docForceSingleline x - ] - Nothing -> docEmpty - ] - lineN = docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - , docLit $ Text.pack "}" - ] - in [line1] ++ lineR ++ [lineN] - ] - ) - -- non-hanging with expressions placed to the right of the names - -- container - -- { fieldA = blub - -- , fieldB = potentially - -- multiline - -- } - , ( True - , docSetParSpacing + Nothing -> docEmpty + ] + lineN = docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + , docLit $ Text.pack "}" + ] + in [line1] ++ lineR ++ [lineN] + ] + -- non-hanging with expressions placed to the right of the names + -- container + -- { fieldA = blub + -- , fieldB = potentially + -- multiline + -- } + addAlternative + $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docNodeAnnKW lexpr Nothing $ rExprDoc) @@ -971,8 +951,6 @@ layoutExpr lexpr@(L _ expr) = do ] in [line1] ++ lineR ++ [lineN] ) - ) - ] #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ ExprWithTySig exp1 (HsWC _ (HsIB _ typ1 _)) -> do #else /* ghc-8.0 */ diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index bc277bc..61af2da 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -46,18 +46,15 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of IEThingWith _ (IEWildcard _) _ _ -> docSeq [ien, docLit $ Text.pack "(..)"] IEThingWith _ _ ns _ -> do hasComments <- hasAnyCommentsBelow lie - docAltFilter - [ ( not hasComments - , docSeq + runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq $ [ien, docLit $ Text.pack "("] ++ intersperse docCommaSep (map nameDoc ns) ++ [docParenR] - ) - , (otherwise - , docAddBaseY BrIndentRegular + addAlternative + $ docAddBaseY BrIndentRegular $ docPar ien (layoutItems (splitFirstLast ns)) - ) - ] where nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] @@ -122,24 +119,20 @@ layoutLLIEs enableSingleline llies = do ieDs <- layoutAnnAndSepLLIEs llies hasComments <- hasAnyCommentsBelow llies case ieDs of - [] -> docAltFilter - [ (not hasComments, docLit $ Text.pack "()") - , ( hasComments - , docPar (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) - docParenR - ) - ] - (ieDsH:ieDsT) -> docAltFilter - [ ( not hasComments && enableSingleline - , docSeq + [] -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) $ + docLit $ Text.pack "()" + addAlternativeCond hasComments $ + docPar (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) + docParenR + (ieDsH:ieDsT) -> runFilteredAlternative $ do + addAlternativeCond (not hasComments && enableSingleline) + $ docSeq $ [docLit (Text.pack "(")] ++ (docForceSingleline <$> ieDs) ++ [docParenR] - ) - , ( otherwise - , docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) + addAlternative + $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) $ docLines $ ieDsT ++ [docParenR] - ) - ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 04925bd..7eb3e27 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -98,25 +98,21 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of [] -> if hasComments then docPar (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) - (docEnsureIndent (BrIndentSpecial hidDocColDiff) $ docParenR) + (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] -- ..[hiding].( b ) - [ieD] -> docAltFilter - [ ( not hasComments - , docSeq - [ hidDoc - , docParenLSep - , docForceSingleline $ ieD - , docSeparator - , docParenR - ] - ) - , ( otherwise - , docPar - (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) - (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) - ) - ] + [ieD] -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + [ hidDoc + , docParenLSep + , docForceSingleline ieD + , docSeparator + , docParenR + ] + addAlternative $ docPar + (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) + (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) -- ..[hiding].( b -- , b' -- ) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index e9c9aa3..b959b28 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -38,25 +38,27 @@ layoutModule lmod@(L _ mod') = case mod' of [ docNodeAnnKW lmod Nothing docEmpty -- A pseudo node that serves merely to force documentation -- before the node - , docNodeMoveToKWDP lmod AnnModule $ docAltFilter - [ (,) allowSingleLineExportList $ docForceSingleline $ docSeq - [ appSep $ docLit $ Text.pack "module" - , appSep $ docLit tn - , docWrapNode lmod $ appSep $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs True x - , docLit $ Text.pack "where" - ] - , (,) otherwise $ docLines - [ docAddBaseY BrIndentRegular $ docPar - (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] - ) - (docWrapNode lmod $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs False x - ) - , docLit $ Text.pack "where" - ] - ] + , docNodeMoveToKWDP lmod AnnModule $ runFilteredAlternative $ do + addAlternativeCond allowSingleLineExportList $ + docForceSingleline + $ docSeq + [ appSep $ docLit $ Text.pack "module" + , appSep $ docLit tn + , docWrapNode lmod $ appSep $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs True x + , docLit $ Text.pack "where" + ] + addAlternative + $ docLines + [ docAddBaseY BrIndentRegular $ docPar + (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] + ) + (docWrapNode lmod $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs False x + ) + , docLit $ Text.pack "where" + ] ] : map layoutImport imports diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index b8814cd..4128aea 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -71,46 +71,40 @@ layoutStmt lstmt@(L _ stmt) = do (docLit $ Text.pack "let") (docSetBaseAndIndent $ return bindDoc) ] - Just bindDocs -> docAltFilter - [ -- let aaa = expra - -- bbb = exprb - -- ccc = exprc - ( indentPolicy /= IndentPolicyLeft - , docSeq - [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ docLines $ return <$> bindDocs - ] - ) - , -- let - -- aaa = expra - -- bbb = exprb - -- ccc = exprc - ( True - , docAddBaseY BrIndentRegular $ docPar + Just bindDocs -> runFilteredAlternative $ do + -- let aaa = expra + -- bbb = exprb + -- ccc = exprc + addAlternativeCond (indentPolicy /= IndentPolicyLeft) + $ docSeq + [ appSep $ docLit $ Text.pack "let" + , docSetBaseAndIndent $ docLines $ return <$> bindDocs + ] + -- let + -- aaa = expra + -- bbb = exprb + -- ccc = exprc + addAlternative $ + docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") (docSetBaseAndIndent $ docLines $ return <$> bindDocs) - ) + RecStmt stmts _ _ _ _ _ _ _ _ _ -> runFilteredAlternative $ do + -- rec stmt1 + -- stmt2 + -- stmt3 + addAlternativeCond (indentPolicy /= IndentPolicyLeft) + $ docSeq + [ docLit (Text.pack "rec") + , docSeparator + , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts ] - RecStmt stmts _ _ _ _ _ _ _ _ _ -> docAltFilter - [ -- rec stmt1 - -- stmt2 - -- stmt3 - ( indentPolicy /= IndentPolicyLeft - , docSeq - [ docLit (Text.pack "rec") - , docSeparator - , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts - ] - ) - , -- rec - -- stmt1 - -- stmt2 - -- stmt3 - ( True - , docAddBaseY BrIndentRegular - $ docPar (docLit (Text.pack "rec")) (docLines $ layoutStmt <$> stmts) - ) - ] + -- rec + -- stmt1 + -- stmt2 + -- stmt3 + addAlternative + $ docAddBaseY BrIndentRegular + $ docPar (docLit (Text.pack "rec")) (docLines $ layoutStmt <$> stmts) BodyStmt expr _ _ _ -> do expDoc <- docSharedWrapper layoutExpr expr docAddBaseY BrIndentRegular $ expDoc diff --git a/stack.yaml b/stack.yaml index 1939eac..44e8d17 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-11.0 +resolver: lts-11.1 packages: - . From 0dad5051df3aa3a0ca208f590b8503ad2b11374f Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Fri, 30 Mar 2018 10:50:44 +0100 Subject: [PATCH 04/11] Remove redundant '$'s --- src/Language/Haskell/Brittany/Internal.hs | 4 +- .../Brittany/Internal/LayouterBasics.hs | 30 ++++---- .../Brittany/Internal/Layouters/Expr.hs | 68 +++++++++---------- .../Brittany/Internal/Layouters/Pattern.hs | 12 ++-- 4 files changed, 57 insertions(+), 57 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 561390f..e6a3c72 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -93,8 +93,8 @@ parsePrintModule configRaw inputText = runExceptT $ do cppCheckFunc (hackTransform $ Text.unpack inputText) case parseResult of - Left err -> throwE $ [ErrorInput err] - Right x -> pure $ x + Left err -> throwE [ErrorInput err] + Right x -> pure x (errsWarns, outputTextL) <- do let omitCheck = config diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index ec9d505..43b4b09 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -119,7 +119,7 @@ processDefault x = do -- the module (header). This would remove the need for this hack! case str of "\n" -> return () - _ -> mTell $ Text.Builder.fromString $ str + _ -> mTell $ Text.Builder.fromString str -- | Use ExactPrint's output for this node; add a newly generated inline comment -- at insertion position (meant to point out to the user that this node is @@ -174,7 +174,7 @@ briDocByExactInlineOnly infoStr ast = do False t let errorAction = do - mTell $ [ErrorUnknownNode infoStr ast] + mTell [ErrorUnknownNode infoStr ast] docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" case (fallbackMode, Text.lines exactPrinted) of @@ -589,7 +589,7 @@ instance DocWrapable a => DocWrapable [a] where docWrapNode ast bdsm = do bds <- bdsm case bds of - [] -> return $ [] -- TODO: this might be bad. maybe. then again, not really. well. + [] -> return [] -- TODO: this might be bad. maybe. then again, not really. well. [bd] -> do bd' <- docWrapNode ast (return bd) return [bd'] @@ -601,23 +601,23 @@ instance DocWrapable a => DocWrapable [a] where docWrapNodePrior ast bdsm = do bds <- bdsm case bds of - [] -> return $ [] + [] -> return [] (bd1:bdR) -> do bd1' <- docWrapNodePrior ast (return bd1) - return $ (bd1':bdR) + return (bd1':bdR) docWrapNodeRest ast bdsm = do bds <- bdsm case reverse bds of - [] -> return $ [] + [] -> return [] (bdN:bdR) -> do bdN' <- docWrapNodeRest ast (return bdN) - return $ reverse $ (bdN':bdR) + 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. + 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) @@ -629,14 +629,14 @@ instance DocWrapable a => DocWrapable (Seq a) where docWrapNodePrior ast bdsm = do bds <- bdsm case Seq.viewl bds of - Seq.EmptyL -> return $ Seq.empty + 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 + Seq.EmptyR -> return Seq.empty bdR Seq.:> bdN -> do bdN' <- docWrapNodeRest ast (return bdN) return $ bdR Seq.|> bdN' @@ -647,19 +647,19 @@ instance DocWrapable ([BriDocNumbered], BriDocNumbered, a) where if null bds then do bd' <- docWrapNode ast (return bd) - return $ (bds, bd', x) + return (bds, bd', x) else do bds' <- docWrapNodePrior ast (return bds) bd' <- docWrapNodeRest ast (return bd) - return $ (bds', bd', x) + return (bds', bd', x) docWrapNodePrior ast stuffM = do (bds, bd, x) <- stuffM bds' <- docWrapNodePrior ast (return bds) - return $ (bds', bd, x) + return (bds', bd, x) docWrapNodeRest ast stuffM = do (bds, bd, x) <- stuffM bd' <- docWrapNodeRest ast (return bd) - return $ (bds, bd', x) + return (bds, bd', x) @@ -685,7 +685,7 @@ docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd unknownNodeError :: Data.Data.Data ast => String -> ast -> ToBriDocM BriDocNumbered unknownNodeError infoStr ast = do - mTell $ [ErrorUnknownNode infoStr ast] + mTell [ErrorUnknownNode infoStr ast] docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" spacifyDocs :: [ToBriDocM BriDocNumbered] -> [ToBriDocM BriDocNumbered] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 3240798..c185482 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -61,7 +61,7 @@ layoutExpr lexpr@(L _ expr) = do bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body let funcPatternPartLine = docCols ColCasePattern - $ (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) + (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) docAlt [ -- single line docSeq @@ -313,12 +313,12 @@ layoutExpr lexpr@(L _ expr) = do $ docAddBaseY BrIndentRegular $ docPar expDocLeft - (docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight]) + (docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight]) NegApp op _ -> do opDoc <- docSharedWrapper layoutExpr op - docSeq $ [ docLit $ Text.pack "-" - , opDoc - ] + docSeq [ docLit $ Text.pack "-" + , opDoc + ] HsPar innerExp -> do innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp docAlt @@ -357,7 +357,7 @@ layoutExpr lexpr@(L _ expr) = do case splitFirstLast argDocs of FirstLastEmpty -> docSeq [ openLit - , docNodeAnnKW lexpr (Just AnnOpenP) $ closeLit + , docNodeAnnKW lexpr (Just AnnOpenP) closeLit ] FirstLastSingleton e -> docAlt [ docCols ColTuple @@ -382,12 +382,12 @@ layoutExpr lexpr@(L _ expr) = do addAlternative $ let start = docCols ColTuples - [appSep $ openLit, e1] + [appSep openLit, e1] linesM = ems <&> \d -> docCols ColTuples [docCommaSep, d] lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] end = closeLit - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do cExpDoc <- docSharedWrapper layoutExpr cExp binderDoc <- docLit $ Text.pack "->" @@ -551,9 +551,9 @@ layoutExpr lexpr@(L _ expr) = do Just [bindDoc] -> docAlt [ docSeq [ appSep $ docLit $ Text.pack "let" - , appSep $ docForceSingleline $ bindDoc + , appSep $ docForceSingleline bindDoc , appSep $ docLit $ Text.pack "in" - , docForceSingleline $ expDoc1 + , docForceSingleline expDoc1 ] , docLines [ docAlt @@ -565,7 +565,7 @@ layoutExpr lexpr@(L _ expr) = do , docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ bindDoc) + (docSetBaseAndIndent bindDoc) ] , docAlt [ docSeq @@ -575,7 +575,7 @@ layoutExpr lexpr@(L _ expr) = do , docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "in") - (docSetBaseY $ expDoc1) + (docSetBaseY expDoc1) ] ] ] @@ -598,21 +598,21 @@ layoutExpr lexpr@(L _ expr) = do [ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ bindDocs) + (docSetBaseAndIndent $ docLines bindDocs) , docSeq [ docLit $ Text.pack "in " - , docAddBaseY BrIndentRegular $ expDoc1 + , docAddBaseY BrIndentRegular expDoc1 ] ] addAlternativeCond (indentPolicy /= IndentPolicyLeft) $ docLines [ docSeq [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ docLines $ bindDocs + , docSetBaseAndIndent $ docLines bindDocs ] , docSeq [ appSep $ docLit $ Text.pack "in " - , docSetBaseY $ expDoc1 + , docSetBaseY expDoc1 ] ] addAlternative @@ -700,7 +700,7 @@ layoutExpr lexpr@(L _ expr) = do [ docSeq [ docLit $ Text.pack "[" , docSeparator - , docSetBaseY $ docNodeAnnKW lexpr (Just AnnOpenS) $ e + , docSetBaseY $ docNodeAnnKW lexpr (Just AnnOpenS) e ] , docLit $ Text.pack "]" ] @@ -739,20 +739,20 @@ layoutExpr lexpr@(L _ expr) = do fExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutExpr fExpr - return $ (fieldl, lrdrNameToText lnameF, fExpDoc) + return (fieldl, lrdrNameToText lnameF, fExpDoc) let line1 appender wrapper = [ appender $ docLit $ Text.pack "{" - , docWrapNodePrior fd1l $ appSep $ docLit $ fd1n + , docWrapNodePrior fd1l $ appSep $ docLit fd1n , case fd1e of Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docWrapNodeRest fd1l $ wrapper $ x + , docWrapNodeRest fd1l $ wrapper x ] Nothing -> docEmpty ] let lineR wrapper = fdr <&> \(lfield, fText, fDoc) -> [ docCommaSep - , appSep $ docLit $ fText + , appSep $ docLit fText , case fDoc of Just x -> docWrapNode lfield $ docSeq [ appSep $ docLit $ Text.pack "=" @@ -766,14 +766,14 @@ layoutExpr lexpr@(L _ expr) = do ] docAlt [ docSeq - $ [docNodeAnnKW lexpr Nothing $ nameDoc, docSeparator] + $ [docNodeAnnKW lexpr Nothing nameDoc, docSeparator] ++ line1 id docForceSingleline ++ join (lineR docForceSingleline) ++ lineN , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docNodeAnnKW lexpr Nothing $ nameDoc) + (docNodeAnnKW lexpr Nothing nameDoc) ( docNonBottomSpacing $ docLines $ [docCols ColRecUpdate $ line1 appSep (docAddBaseY BrIndentRegular)] @@ -790,20 +790,20 @@ layoutExpr lexpr@(L _ expr) = do fExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutExpr fExpr - return $ (fieldl, lrdrNameToText lnameF, fExpDoc) + return (fieldl, lrdrNameToText lnameF, fExpDoc) let line1 appender wrapper = [ appender $ docLit $ Text.pack "{" - , docWrapNodePrior fd1l $ appSep $ docLit $ fd1n + , docWrapNodePrior fd1l $ appSep $ docLit fd1n , case fd1e of Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docWrapNodeRest fd1l $ wrapper $ x + , docWrapNodeRest fd1l $ wrapper x ] Nothing -> docEmpty ] let lineR wrapper = fdr <&> \(lfield, fText, fDoc) -> [ docCommaSep - , appSep $ docLit $ fText + , appSep $ docLit fText , case fDoc of Just x -> docWrapNode lfield $ docSeq [ appSep $ docLit $ Text.pack "=" @@ -821,7 +821,7 @@ layoutExpr lexpr@(L _ expr) = do ] docAlt [ docSeq - $ [docNodeAnnKW lexpr Nothing $ nameDoc, docSeparator] + $ [docNodeAnnKW lexpr Nothing nameDoc, docSeparator] ++ line1 id docForceSingleline ++ join (lineR docForceSingleline) ++ lineDot @@ -829,7 +829,7 @@ layoutExpr lexpr@(L _ expr) = do , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docNodeAnnKW lexpr Nothing $ nameDoc) + (docNodeAnnKW lexpr Nothing nameDoc) ( docNonBottomSpacing $ docLines $ [docCols ColRecUpdate $ line1 appSep (docAddBaseY BrIndentRegular)] @@ -880,7 +880,7 @@ layoutExpr lexpr@(L _ expr) = do , docSetBaseY $ docLines $ let line1 = docCols ColRecUpdate [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n + , docWrapNodePrior rF1f $ appSep $ docLit rF1n , case rF1e of Just x -> docWrapNodeRest rF1f $ docSeq [ appSep $ docLit $ Text.pack "=" @@ -890,7 +890,7 @@ layoutExpr lexpr@(L _ expr) = do ] lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate [ docCommaSep - , appSep $ docLit $ fText + , appSep $ docLit fText , case fDoc of Just x -> docSeq [ appSep $ docLit $ Text.pack "=" , docForceSingleline x @@ -913,14 +913,14 @@ layoutExpr lexpr@(L _ expr) = do $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docNodeAnnKW lexpr Nothing $ rExprDoc) + (docNodeAnnKW lexpr Nothing rExprDoc) (docNonBottomSpacing $ docLines $ let expressionWrapper = if indentPolicy == IndentPolicyLeft then docForceParSpacing else docSetBaseY line1 = docCols ColRecUpdate [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n + , docWrapNodePrior rF1f $ appSep $ docLit rF1n , docWrapNodeRest rF1f $ case rF1e of Just x -> docAlt [ docSeq [ appSep $ docLit $ Text.pack "=" @@ -934,7 +934,7 @@ layoutExpr lexpr@(L _ expr) = do lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate [ docCommaSep - , appSep $ docLit $ fText + , appSep $ docLit fText , case fDoc of Just x -> docAlt [ docSeq [ appSep $ docLit $ Text.pack "=" diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 51bb03a..d506239 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -94,14 +94,14 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of fExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutPat fPat - return $ (lrdrNameToText lnameF, fExpDoc) + return (lrdrNameToText lnameF, fExpDoc) fmap Seq.singleton $ docSeq [ appSep $ docLit t , appSep $ docLit $ Text.pack "{" , docSeq $ List.intersperse docCommaSep $ fds <&> \case (fieldName, Just fieldDoc) -> docSeq - [ appSep $ docLit $ fieldName + [ appSep $ docLit fieldName , appSep $ docLit $ Text.pack "=" , fieldDoc >>= colsWrapPat ] @@ -123,13 +123,13 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of fExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutPat fPat - return $ (lrdrNameToText lnameF, fExpDoc) + return (lrdrNameToText lnameF, fExpDoc) fmap Seq.singleton $ docSeq [ appSep $ docLit t , appSep $ docLit $ Text.pack "{" , docSeq $ fds >>= \case (fieldName, Just fieldDoc) -> - [ appSep $ docLit $ fieldName + [ appSep $ docLit fieldName , appSep $ docLit $ Text.pack "=" , fieldDoc >>= colsWrapPat , docCommaSep @@ -167,7 +167,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of docAddBaseY BrIndentRegular $ docSeq [ appSep $ return xN , appSep $ docLit $ Text.pack "::" - , docForceSingleline $ tyDoc + , docForceSingleline tyDoc ] return $ xR Seq.|> xN' ListPat elems _ _ -> @@ -205,7 +205,7 @@ wrapPatPrepend wrapPatPrepend pat prepElem = do patDocs <- layoutPat pat case Seq.viewl patDocs of - Seq.EmptyL -> return $ Seq.empty + Seq.EmptyL -> return Seq.empty x1 Seq.:< xR -> do x1' <- docSeq [prepElem, return x1] return $ x1' Seq.<| xR From 226da07815eaa0cc38ab8fd7e8da031907cbaf9f Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Fri, 30 Mar 2018 10:51:37 +0100 Subject: [PATCH 05/11] Improve vertical alignment --- .../Brittany/Internal/Layouters/Expr.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index c185482..f414b3c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -106,7 +106,7 @@ layoutExpr lexpr@(L _ expr) = do #else /* ghc-8.0 */ HsLamCase _ (MG lmatches@(L _ matches) _ _ _) -> do #endif - binderDoc <- docLit $ Text.pack "->" + binderDoc <- docLit $ Text.pack "->" funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "\\case") @@ -114,8 +114,8 @@ layoutExpr lexpr@(L _ expr) = do HsApp exp1@(L _ HsApp{}) exp2 -> do let gather :: [LHsExpr RdrName] -> LHsExpr RdrName -> (LHsExpr RdrName, [LHsExpr RdrName]) gather list = \case - (L _ (HsApp l r)) -> gather (r:list) l - x -> (x, list) + L _ (HsApp l r) -> gather (r:list) l + x -> (x, list) let (headE, paramEs) = gather [exp2] exp1 let colsOrSequence = case headE of L _ (HsVar (L _ (Unqual occname))) -> @@ -230,8 +230,8 @@ layoutExpr lexpr@(L _ expr) = do | xD <- docSharedWrapper layoutExpr x , yD <- docSharedWrapper layoutExpr y ] - opLastDoc <- docSharedWrapper layoutExpr expOp - expLastDoc <- docSharedWrapper layoutExpr expRight + opLastDoc <- docSharedWrapper layoutExpr expOp + expLastDoc <- docSharedWrapper layoutExpr expRight hasComments <- hasAnyCommentsBelow lexpr let allowPar = case (expOp, expRight) of (L _ (HsVar (L _ (Unqual occname))), _) @@ -1090,10 +1090,10 @@ litBriDoc = \case HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsRat (FL t _) _type -> BDFLit $ Text.pack t - HsFloatPrim (FL t _) -> BDFLit $ Text.pack t - HsDoublePrim (FL t _) -> BDFLit $ Text.pack t + HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsRat (FL t _) _type -> BDFLit $ Text.pack t + HsFloatPrim (FL t _) -> BDFLit $ Text.pack t + HsDoublePrim (FL t _) -> BDFLit $ Text.pack t _ -> error "litBriDoc: literal with no SourceText" overLitValBriDoc :: OverLitVal -> BriDocFInt From 545eff9e4f1448191187c795fefc29e272f2f25a Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Fri, 30 Mar 2018 10:52:22 +0100 Subject: [PATCH 06/11] Remove redundant parens --- src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index f414b3c..7f0d8e9 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -137,7 +137,7 @@ layoutExpr lexpr@(L _ expr) = do , docSetBaseY $ docAddBaseY BrIndentRegular $ docLines - $ (docForceSingleline <$> paramDocs) + $ docForceSingleline <$> paramDocs ] -- foo -- x @@ -243,11 +243,10 @@ layoutExpr lexpr@(L _ expr) = do $ docSeq [ appSep $ docForceSingleline leftOperandDoc , docSeq - $ (appListDocs <&> \(od, ed) -> docSeq + $ appListDocs <&> \(od, ed) -> docSeq [ appSep $ docForceSingleline od , appSep $ docForceSingleline ed ] - ) , appSep $ docForceSingleline opLastDoc , (if allowPar then docForceParSpacing else docForceSingleline) expLastDoc @@ -1056,7 +1055,7 @@ layoutExpr lexpr@(L _ expr) = do docLit $ Text.pack "_" EAsPat asName asExpr -> do docSeq - [ docLit $ (lrdrNameToText asName) <> Text.pack "@" + [ docLit $ lrdrNameToText asName <> Text.pack "@" , layoutExpr asExpr ] EViewPat{} -> do From 631d9e181da713eee9c18a7f3bbf535dee53d925 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Fri, 30 Mar 2018 10:52:44 +0100 Subject: [PATCH 07/11] Replace 'fmap f $' with 'f <$>' --- src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs | 2 +- .../Haskell/Brittany/Internal/Layouters/Pattern.hs | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 7f0d8e9..a7848eb 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -659,7 +659,7 @@ layoutExpr lexpr@(L _ expr) = do $ List.last stmtDocs , appSep $ docLit $ Text.pack "|" , docSeq $ List.intersperse docCommaSep - $ fmap docForceSingleline $ List.init stmtDocs + $ docForceSingleline <$> List.init stmtDocs , docLit $ Text.pack " ]" ] addAlternative $ diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index d506239..120c2b6 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -95,7 +95,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of then return Nothing else Just <$> docSharedWrapper layoutPat fPat return (lrdrNameToText lnameF, fExpDoc) - fmap Seq.singleton $ docSeq + Seq.singleton <$> docSeq [ appSep $ docLit t , appSep $ docLit $ Text.pack "{" , docSeq $ List.intersperse docCommaSep @@ -112,7 +112,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of ConPatIn lname (RecCon (HsRecFields [] (Just 0))) -> do -- Abc { .. } -> expr let t = lrdrNameToText lname - fmap Seq.singleton $ docSeq + Seq.singleton <$> docSeq [ appSep $ docLit t , docLit $ Text.pack "{..}" ] @@ -124,7 +124,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of then return Nothing else Just <$> docSharedWrapper layoutPat fPat return (lrdrNameToText lnameF, fExpDoc) - fmap Seq.singleton $ docSeq + Seq.singleton <$> docSeq [ appSep $ docLit t , appSep $ docLit $ Text.pack "{" , docSeq $ fds >>= \case @@ -193,7 +193,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of -- else -- VarPat n -> return $ stringLayouter lpat $ rdrNameToText n -- endif - _ -> fmap return $ briDocByExactInlineOnly "some unknown pattern" lpat + _ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList From 7a602296734728b9a41814e394715708cf8ca2ad Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Fri, 30 Mar 2018 10:53:08 +0100 Subject: [PATCH 08/11] Fix some hlint hints --- src/Language/Haskell/Brittany/Internal/LayouterBasics.hs | 4 ++-- src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 43b4b09..48730c7 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -264,8 +264,8 @@ extractAllComments ann = ) filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns -filterAnns ast anns = - Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) anns +filterAnns ast = + Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool hasAnyCommentsBelow ast@(L l _) = do diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 120c2b6..bf09e52 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -216,7 +216,7 @@ wrapPatListy -> String -> ToBriDocM (Seq BriDocNumbered) wrapPatListy elems start end = do - elemDocs <- Seq.fromList elems `forM` \e -> layoutPat e >>= colsWrapPat + elemDocs <- Seq.fromList elems `forM` (layoutPat >=> colsWrapPat) sDoc <- docLit $ Text.pack start eDoc <- docLit $ Text.pack end case Seq.viewl elemDocs of From 049f286e6faa7b2bf150c986e7ce81ed0bcca6b0 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Mon, 2 Apr 2018 22:47:07 +0100 Subject: [PATCH 09/11] Add .hlint.yaml --- .hlint.yaml | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 .hlint.yaml diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 0000000..6fecf6a --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,24 @@ +# HLint configuration file +# https://github.com/ndmitchell/hlint +########################## + +# This file contains a template configuration file, which is typically +# placed as .hlint.yaml in the root of your project + +# Specify additional command line arguments + +- arguments: + [ "--cpp-include=srcinc" + , "--language=GADTs" + , "--language=LambdaCase" + , "--language=MultiWayIf" + , "--language=KindSignatures" + , "--cross" + , "--threads=0" + ] + +- ignore: {name: "Use camelCase"} +- ignore: {name: "Redundant as"} +- ignore: {name: "Redundant do"} +- ignore: {name: "Redundant return"} +- ignore: {name: "Redundant guard", whithin: "lrdrNameToTextAnn"} From 9bd3bfbe4c150540ad351410879e105f649f8637 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Tue, 3 Apr 2018 22:49:06 +0100 Subject: [PATCH 10/11] Review suggestions --- .../Brittany/Internal/LayouterBasics.hs | 5 --- .../Brittany/Internal/Layouters/Decl.hs | 19 +++++----- .../Haskell/Brittany/Internal/Layouters/IE.hs | 37 ++++++++++--------- 3 files changed, 29 insertions(+), 32 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 48730c7..191581c 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -14,7 +14,6 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docLit , docAlt , CollectAltM - , addAlternativeCondM , addAlternativeCond , addAlternative , runFilteredAlternative @@ -426,10 +425,6 @@ docAlt l = allocateNode . BDFAlt =<< sequence l newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a) deriving (Functor, Applicative, Monad) -addAlternativeCondM :: Bool -> CollectAltM (ToBriDocM BriDocNumbered) -> CollectAltM () -addAlternativeCondM cond doc = - addAlternativeCond cond =<< doc - addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM () addAlternativeCond cond doc = when cond (addAlternative doc) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index d27c385..babcab1 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -308,21 +308,22 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ++ (List.intersperse docCommaSep (docForceSingleline . return <$> gs) ) + wherePart = case mWhereDocs of + Nothing -> Just docEmpty + Just [w] -> Just $ docSeq + [ docSeparator + , appSep $ docLit $ Text.pack "where" + , docSetIndentLevel $ docForceSingleline $ return w + ] + _ -> Nothing indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + runFilteredAlternative $ do - let wherePart = case mWhereDocs of - Nothing -> Just docEmpty - Just [w] -> Just $ docSeq - [ docSeparator - , appSep $ docLit $ Text.pack "where" - , docSetIndentLevel $ docForceSingleline $ return w - ] - _ -> Nothing case clauseDocs of [(guards, body, _bodyRaw)] -> do let guardPart = singleLineGuardsDoc guards @@ -385,7 +386,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ] ++ wherePartMultiLine - _ -> return () + _ -> return () -- no alternatives exclusively when `length clauseDocs /= 1` case mPatDoc of Nothing -> return () diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 61af2da..2ba66a0 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -118,21 +118,22 @@ layoutLLIEs :: Bool -> Located [LIE RdrName] -> ToBriDocM BriDocNumbered layoutLLIEs enableSingleline llies = do ieDs <- layoutAnnAndSepLLIEs llies hasComments <- hasAnyCommentsBelow llies - case ieDs of - [] -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) $ - docLit $ Text.pack "()" - addAlternativeCond hasComments $ - docPar (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) - docParenR - (ieDsH:ieDsT) -> runFilteredAlternative $ do - addAlternativeCond (not hasComments && enableSingleline) - $ docSeq - $ [docLit (Text.pack "(")] - ++ (docForceSingleline <$> ieDs) - ++ [docParenR] - addAlternative - $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) - $ docLines - $ ieDsT - ++ [docParenR] + runFilteredAlternative $ + case ieDs of + [] -> do + addAlternativeCond (not hasComments) $ + docLit $ Text.pack "()" + addAlternativeCond hasComments $ + docPar (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) + docParenR + (ieDsH:ieDsT) -> do + addAlternativeCond (not hasComments && enableSingleline) + $ docSeq + $ [docLit (Text.pack "(")] + ++ (docForceSingleline <$> ieDs) + ++ [docParenR] + addAlternative + $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) + $ docLines + $ ieDsT + ++ [docParenR] From 7ffa58976f01bcdad5de58f49746c5b1e5760016 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Tue, 3 Apr 2018 22:55:57 +0100 Subject: [PATCH 11/11] Clean up duplicate ghc-options from cabal file --- brittany.cabal | 3 --- 1 file changed, 3 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 7c6b574..c40c43e 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -244,7 +244,6 @@ test-suite unittests , ghc-boot-th , hspec >=2.4.1 && <2.5 } - ghc-options: -Wall main-is: TestMain.hs other-modules: TestUtils AsymptoticPerfTests @@ -314,7 +313,6 @@ test-suite littests , filepath , parsec >=3.1.11 && <3.2 } - ghc-options: -Wall main-is: Main.hs other-modules: hs-source-dirs: src-literatetests @@ -355,7 +353,6 @@ test-suite libinterfacetests , transformers , hspec >=2.4.1 && <2.5 } - ghc-options: -Wall main-is: Main.hs other-modules: hs-source-dirs: src-libinterfacetests