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"} 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 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.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 5fb5c8d..191581c 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,10 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docEmpty , docLit , docAlt - , docAltFilter + , CollectAltM + , addAlternativeCond + , addAlternative + , runFilteredAlternative , docLines , docCols , docSeq @@ -60,6 +65,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 @@ -111,7 +118,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 @@ -166,7 +173,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 @@ -256,8 +263,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 @@ -297,10 +304,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 +315,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 +367,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 +382,7 @@ allocNodeIndex = do -- $ (,) i2 -- $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) -- $ bd --- +-- -- docPar :: MonadMultiState NodeAllocIndex m -- => m BriDocNumbered -- -> m BriDocNumbered @@ -384,13 +391,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 @@ -415,8 +422,20 @@ 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) + +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 @@ -565,7 +584,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'] @@ -577,23 +596,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) @@ -605,14 +624,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' @@ -623,19 +642,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) @@ -661,7 +680,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/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 400d422..babcab1 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -308,258 +308,237 @@ 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 - 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 + + 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 () -- no alternatives exclusively when `length clauseDocs /= 1` + + 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..a7848eb 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 @@ -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))) -> @@ -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 @@ -235,47 +230,44 @@ 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))), _) | 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,47 +277,47 @@ 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 "-" - , opDoc - ] + docSeq [ docLit $ Text.pack "-" + , opDoc + ] HsPar innerExp -> do innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp docAlt @@ -364,7 +356,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 @@ -380,24 +372,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 +421,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 +432,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 @@ -562,9 +550,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 @@ -576,7 +564,7 @@ layoutExpr lexpr@(L _ expr) = do , docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ bindDoc) + (docSetBaseAndIndent bindDoc) ] , docAlt [ docSeq @@ -586,11 +574,11 @@ layoutExpr lexpr@(L _ expr) = do , docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "in") - (docSetBaseY $ expDoc1) + (docSetBaseY expDoc1) ] ] ] - Just bindDocs@(_:_) -> docAltFilter + Just bindDocs@(_:_) -> runFilteredAlternative $ do --either -- let -- a = b @@ -604,43 +592,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 +644,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 @@ -675,11 +659,11 @@ 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 " ]" ] - , (,) True - $ let + addAlternative $ + let start = docCols ColListComp [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "[" @@ -694,12 +678,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 @@ -716,28 +699,26 @@ 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 "]" ] ] - 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 @@ -757,20 +738,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 "=" @@ -784,14 +765,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)] @@ -808,20 +789,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 "=" @@ -839,7 +820,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 @@ -847,7 +828,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)] @@ -870,77 +851,75 @@ 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) + (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 "=" @@ -954,7 +933,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 "=" @@ -971,8 +950,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 */ @@ -1078,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 @@ -1112,10 +1089,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 diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index bc277bc..2ba66a0 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] @@ -121,25 +118,22 @@ layoutLLIEs :: Bool -> Located [LIE RdrName] -> ToBriDocM BriDocNumbered 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]) + runFilteredAlternative $ + case ieDs of + [] -> do + addAlternativeCond (not hasComments) $ + docLit $ Text.pack "()" + addAlternativeCond hasComments $ + docPar (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) docParenR - ) - ] - (ieDsH:ieDsT) -> docAltFilter - [ ( not hasComments && enableSingleline - , docSeq - $ [docLit (Text.pack "(")] - ++ (docForceSingleline <$> ieDs) - ++ [docParenR] - ) - , ( otherwise - , docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) - $ docLines - $ ieDsT - ++ [docParenR] - ) - ] + (ieDsH:ieDsT) -> do + addAlternativeCond (not hasComments && enableSingleline) + $ docSeq + $ [docLit (Text.pack "(")] + ++ (docForceSingleline <$> ieDs) + ++ [docParenR] + 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/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 51bb03a..bf09e52 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) - fmap Seq.singleton $ docSeq + return (lrdrNameToText lnameF, fExpDoc) + 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 ] @@ -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 "{..}" ] @@ -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) - fmap Seq.singleton $ docSeq + return (lrdrNameToText lnameF, fExpDoc) + 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 _ _ -> @@ -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 @@ -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 @@ -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 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/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs index 0ed9b6c..646ebb7 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 ) @@ -306,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 b0896b8..b454890 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 @@ -222,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.. 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: - .