From d769f30c156a4cc4a573b8a9d093f0712cfa47be Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 14 Oct 2018 12:44:38 +0200 Subject: [PATCH 1/5] travis: Prevent duplicate compilation --- .travis.yml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/.travis.yml b/.travis.yml index 58a4ab2..fc67cae 100644 --- a/.travis.yml +++ b/.travis.yml @@ -257,8 +257,8 @@ install: cabal --version travis_retry cabal update -v echo 'packages: .' > cabal.project - echo 'package brittany' > cabal.project.local - echo ' ghc-options: -Werror' >> cabal.project.local + echo 'package brittany' > cabal.project.local + echo ' ghc-options: -Werror -with-rtsopts=-N1' >> cabal.project.local rm -f cabal.project.freeze cabal new-build -j$JOBS --enable-test --enable-benchmarks --dep cabal new-build -j$JOBS --disable-tests --disable-benchmarks --dep @@ -271,13 +271,13 @@ script: set -ex case "$BUILD" in stack) - better_wait stack -j$JOBS --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M -RTS -Werror -with-rtsopts -N1" + better_wait stack -j$JOBS --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M -RTS -Werror -with-rtsopts=-N1" ;; cabal) if [ -f configure.ac ]; then autoreconf -i; fi cabal configure --enable-tests --enable-benchmarks -v # -v2 provides useful information for debugging better_wait cabal build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS -Werror" # this builds all libraries and executables (including tests/benchmarks) - time cabal test --ghc-options="-with-rtsopts -N1" + time cabal test --ghc-options="-with-rtsopts=-N1" ;; cabaldist) # cabal check @@ -292,7 +292,7 @@ script: canew) better_wait cabal new-build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS" --disable-tests --disable-benchmarks better_wait cabal new-build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS" --enable-tests --enable-benchmarks - time cabal new-test -j1 --ghc-options="-j1 +RTS -M500M -RTS -with-rtsopts -N1" + time cabal new-test -j1 --ghc-options="-j1 +RTS -M500M -RTS" ;; esac set +ex -- 2.30.2 From e1b43531a869468960fd6535a1a35e7ad3de088d Mon Sep 17 00:00:00 2001 From: Rupert Horlick Date: Sat, 13 Oct 2018 14:31:16 -0400 Subject: [PATCH 2/5] Add type synonym formatting --- src-literatetests/10-tests.blt | 94 ++++++++++++++++ .../Brittany/Internal/Layouters/Decl.hs | 105 +++++++++++++++++- .../Haskell/Brittany/Internal/Prelude.hs | 8 ++ 3 files changed, 206 insertions(+), 1 deletion(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 1597c4b..f2b02d8 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -906,6 +906,100 @@ import qualified Data.List as L -- Test import Test ( test ) + +############################################################################### +############################################################################### +############################################################################### +#group type synonyms +############################################################################### +############################################################################### +############################################################################### + +#test simple-synonym + +type MySynonym = String + +#test parameterised-synonym + +type MySynonym a = [a] + +#test long-function-synonym + +-- | Important comment thrown in +type MySynonym b a + = MySynonym a b -> MySynonym a b -> MyParamType a b -> MyParamType a b + +#test overflowing-function-synonym + +type MySynonym3 b a + = MySynonym a b + -> MySynonym a b + -- ^ RandomComment + -> MyParamType a b + -> MyParamType a b + -> MySynonym2 b a + +#test synonym-with-kind-sig + +type MySynonym (a :: * -> *) + = MySynonym a b + -> MySynonym a b + -> MyParamType a b + -> MyParamType a b + -> MySynonym2 b a + +#test synonym-with-constraint + +type MySynonym a = Num a => a -> Int + +#test synonym-overflowing-with-constraint + +type MySynonym a + = Num a + => AReallyLongTypeName + -> AnotherReallyLongTypeName + -> AThirdTypeNameToOverflow + +#test synonym-forall + +{-# LANGUAGE RankNTypes #-} + +type MySynonym = forall a . [a] + +#test synonym-operator + +type (:+:) a b = (a, b) + +#test synonym-infix + +type a `MySynonym` b = a -> b + +#test synonym-infix-operator + +type a :+: b = (a, b) + +#test synonym-infix-parens + +type (a `Foo` b) c = (a, b, c) + +#test synonym-comments +#pending + +type Foo a -- fancy type comment + = -- strange comment + Int + +#test synonym-type-operators +#pending + +type (a :+: b) = (a, b) + +#test synonym-multi-parens +#pending + +type ((a :+: b) c) = (a, c) + + ############################################################################### ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 2ece967..49fbd12 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -26,7 +26,11 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import Language.Haskell.Brittany.Internal.ExactPrintUtils import Language.Haskell.Brittany.Internal.Utils -import GHC ( runGhc, GenLocated(L), moduleNameString ) +import GHC ( runGhc + , GenLocated(L) + , moduleNameString + , AnnKeywordId (..) + ) import SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc ) import HsSyn import Name @@ -34,6 +38,9 @@ import BasicTypes ( InlinePragma(..) , Activation(..) , InlineSpec(..) , RuleMatchInfo(..) +#if MIN_VERSION_ghc(8,2,0) + , LexicalFixity(..) +#endif ) import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) @@ -43,6 +50,7 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt import Language.Haskell.Brittany.Internal.Layouters.Pattern import Bag ( mapBagM, bagToList, emptyBag ) +import Data.Char (isUpper) @@ -52,6 +60,7 @@ layoutDecl d@(L loc decl) = case decl of ValD bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case Left ns -> docLines $ return <$> ns Right n -> return n + TyClD tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) InstD (TyFamInstD{}) -> do -- this is a (temporary (..)) workaround for "type instance" decls -- that do not round-trip through exactprint properly. @@ -69,6 +78,10 @@ layoutDecl d@(L loc decl) = case decl of _ -> briDocByExactNoComment d +-------------------------------------------------------------------------------- +-- Sig +-------------------------------------------------------------------------------- + layoutSig :: ToBriDoc Sig layoutSig lsig@(L _loc sig) = case sig of #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ @@ -168,6 +181,11 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of ] _ -> unknownNodeError "" lgstmt -- TODO + +-------------------------------------------------------------------------------- +-- HsBind +-------------------------------------------------------------------------------- + layoutBind :: ToBriDocC (HsBindLR GhcPs GhcPs) @@ -595,6 +613,91 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ] ++ wherePartMultiLine + +-------------------------------------------------------------------------------- +-- TyClDecl +-------------------------------------------------------------------------------- + +layoutTyCl :: ToBriDoc TyClDecl +layoutTyCl ltycl@(L _loc tycl) = case tycl of +#if MIN_VERSION_ghc(8,2,0) + SynDecl name vars fixity typ _ -> do + let isInfix = case fixity of + Prefix -> False + Infix -> True +#else + SynDecl name vars typ _ -> do + nameStr <- lrdrNameToTextAnn name + let isInfixTypeOp = case Text.uncons nameStr of + Nothing -> False + Just (c, _) -> not (c == '(' || isUpper c) + isInfix <- (isInfixTypeOp ||) <$> hasAnnKeyword name AnnBackquote +#endif + docWrapNode ltycl $ layoutSynDecl isInfix name (hsq_explicit vars) typ + _ -> briDocByExactNoComment ltycl + +layoutSynDecl + :: Bool + -> Located (IdP GhcPs) + -> [LHsTyVarBndr GhcPs] + -> LHsType GhcPs + -> ToBriDocM BriDocNumbered +layoutSynDecl isInfix name vars typ = do + nameStr <- lrdrNameToTextAnn name + let + lhs = if isInfix + then do + let + (a : b : rest) = vars + -- This isn't quite right, but does give syntactically valid results + hasParens = not $ null rest + docSeq + $ [ appSep $ docLit $ Text.pack "type" + , appSep + . docSeq + $ [ docParenL | hasParens ] + ++ [ appSep $ layoutTyVarBndr a + , appSep $ docLit nameStr + , layoutTyVarBndr b + ] + ++ [ docParenR | hasParens ] + ] + ++ fmap (appSep . layoutTyVarBndr) rest + else + docSeq + $ [appSep $ docLit $ Text.pack "type", appSep $ docLit nameStr] + ++ fmap (appSep . layoutTyVarBndr) vars + typeDoc <- docSharedWrapper layoutType typ + docAlt + [ docSeq [lhs, appSep $ docLit $ Text.pack "=", docForceSingleline typeDoc] + , docAddBaseY BrIndentRegular $ docPar + lhs + (docCols + ColTyOpPrefix + [docLit $ Text.pack "= ", docAddBaseY (BrIndentSpecial 2) typeDoc] + ) + ] + +layoutTyVarBndr :: ToBriDoc HsTyVarBndr +layoutTyVarBndr (L _ bndr) = case bndr of + UserTyVar name -> do + nameStr <- lrdrNameToTextAnn name + docLit nameStr + KindedTyVar name kind -> do + nameStr <- lrdrNameToTextAnn name + docSeq + [ docLit $ Text.pack "(" + , appSep $ docLit nameStr + , appSep . docLit $ Text.pack "::" + , docForceSingleline $ layoutType kind + , docLit $ Text.pack ")" + ] + + +-------------------------------------------------------------------------------- +-- ClsInstDecl +-------------------------------------------------------------------------------- + -- | Layout an @instance@ declaration -- -- Layout signatures and bindings using the corresponding layouters from the diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs index 2d8a038..6b93bf0 100644 --- a/src/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -1,3 +1,8 @@ +#if !MIN_VERSION_ghc(8,4,0) /* ghc-8.0, ghc-8.2 */ +{-# LANGUAGE TypeFamilies #-} +#endif + + module Language.Haskell.Brittany.Internal.Prelude ( module E , module Language.Haskell.Brittany.Internal.Prelude @@ -400,5 +405,8 @@ todo = error "todo" #if !MIN_VERSION_ghc(8,4,0) /* ghc-8.0, ghc-8.2 */ +type family IdP p +type instance IdP GhcPs = RdrName + type GhcPs = RdrName #endif -- 2.30.2 From b249c10054d4c958d20c682028e10c86e274c3ca Mon Sep 17 00:00:00 2001 From: Rupert Horlick Date: Wed, 17 Oct 2018 17:01:31 -0400 Subject: [PATCH 3/5] Deal with parens inside comments on 8.4.3 --- .../Haskell/Brittany/Internal/Backend.hs | 5 ++ .../Haskell/Brittany/Internal/BackendUtils.hs | 12 +++++ .../Brittany/Internal/LayouterBasics.hs | 10 ++++ .../Brittany/Internal/Layouters/Decl.hs | 48 +++++++++++-------- 4 files changed, 56 insertions(+), 19 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 16a9362..6652443 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -19,6 +19,8 @@ import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation ) +import GHC ( AnnKeywordId (..) ) + import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.BackendUtils import Language.Haskell.Brittany.Internal.Utils @@ -173,6 +175,8 @@ layoutBriDocM = \case -- evil hack for CPP: case comment of ('#':_) -> layoutMoveToCommentPos y (-999) + "(" -> pure () + ")" -> layoutMoveToCommentPosX (x - 1) _ -> layoutMoveToCommentPos y x -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline @@ -244,6 +248,7 @@ layoutBriDocM = \case -- evil hack for CPP: case comment of ('#':_) -> layoutMoveToCommentPos y (-999) + ")" -> layoutMoveToCommentPosX (x - 1) _ -> layoutMoveToCommentPos y x -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index a7d8594..56b95bb 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -26,6 +26,7 @@ module Language.Haskell.Brittany.Internal.BackendUtils , layoutAddSepSpace , layoutSetCommentCol , layoutMoveToCommentPos + , layoutMoveToCommentPosX , layoutIndentRestorePostComment , moveToExactAnn , ppmMoveToExactLoc @@ -200,6 +201,17 @@ layoutMoveToCommentPos y x = do Right{} -> lstate_baseY state } +layoutMoveToCommentPosX + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => Int + -> m () +layoutMoveToCommentPosX x = do + traceLocal ("layoutMoveToCommentPosX", x) + state <- mGet + mSet state { _lstate_addSepSpace = Just $ _lstate_indLevelLinger state + x } -- | does _not_ add spaces to again reach the current base column. layoutWriteNewline diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index bfb129a..9f6366e 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -63,6 +63,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docSharedWrapper , hasAnyCommentsBelow , hasAnyCommentsConnected + , hasAnnKeywordComment , hasAnnKeyword ) where @@ -296,6 +297,15 @@ hasAnyCommentsConnected ast = do $ Map.elems $ anns +hasAnnKeywordComment + :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool +hasAnnKeywordComment ast annKeyword = do + anns <- mAsk + pure $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of + Nothing -> False + Just ann -> any hasK (extractAllComments ann) + where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst + hasAnnKeyword :: (Data a, MonadMultiReader (Map AnnKey Annotation) m) => Located a diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 49fbd12..4576e48 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -633,34 +633,41 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of Just (c, _) -> not (c == '(' || isUpper c) isInfix <- (isInfixTypeOp ||) <$> hasAnnKeyword name AnnBackquote #endif - docWrapNode ltycl $ layoutSynDecl isInfix name (hsq_explicit vars) typ + hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP + let parenWrapper = if hasTrailingParen + then appSep . docWrapNodeRest ltycl + else id + docWrapNodePrior ltycl + $ layoutSynDecl isInfix parenWrapper name (hsq_explicit vars) typ _ -> briDocByExactNoComment ltycl layoutSynDecl :: Bool + -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) -> Located (IdP GhcPs) -> [LHsTyVarBndr GhcPs] -> LHsType GhcPs -> ToBriDocM BriDocNumbered -layoutSynDecl isInfix name vars typ = do +layoutSynDecl isInfix parenWrapper name vars typ = do nameStr <- lrdrNameToTextAnn name let lhs = if isInfix then do let (a : b : rest) = vars + hasOwnParens <- hasAnnKeywordComment a AnnOpenP -- This isn't quite right, but does give syntactically valid results - hasParens = not $ null rest - docSeq + let needsParens = not $ null rest || hasOwnParens + parenWrapper . docSeq $ [ appSep $ docLit $ Text.pack "type" , appSep . docSeq - $ [ docParenL | hasParens ] + $ [ docParenL | needsParens ] ++ [ appSep $ layoutTyVarBndr a , appSep $ docLit nameStr , layoutTyVarBndr b ] - ++ [ docParenR | hasParens ] + ++ [ docParenR | needsParens ] ] ++ fmap (appSep . layoutTyVarBndr) rest else @@ -679,19 +686,22 @@ layoutSynDecl isInfix name vars typ = do ] layoutTyVarBndr :: ToBriDoc HsTyVarBndr -layoutTyVarBndr (L _ bndr) = case bndr of - UserTyVar name -> do - nameStr <- lrdrNameToTextAnn name - docLit nameStr - KindedTyVar name kind -> do - nameStr <- lrdrNameToTextAnn name - docSeq - [ docLit $ Text.pack "(" - , appSep $ docLit nameStr - , appSep . docLit $ Text.pack "::" - , docForceSingleline $ layoutType kind - , docLit $ Text.pack ")" - ] +layoutTyVarBndr lbndr@(L _ bndr) = do + needsPriorSpace <- hasAnnKeywordComment lbndr AnnCloseP + docWrapNodePrior lbndr $ case bndr of + UserTyVar name -> do + nameStr <- lrdrNameToTextAnn name + docSeq $ [ docSeparator | needsPriorSpace ] ++ [docLit nameStr] + KindedTyVar name kind -> do + nameStr <- lrdrNameToTextAnn name + docSeq + $ [ docSeparator | needsPriorSpace ] + ++ [ docLit $ Text.pack "(" + , appSep $ docLit nameStr + , appSep . docLit $ Text.pack "::" + , docForceSingleline $ layoutType kind + , docLit $ Text.pack ")" + ] -------------------------------------------------------------------------------- -- 2.30.2 From e7d8b5f1abdd3539c1b2f6bae1f01bfa33f4230d Mon Sep 17 00:00:00 2001 From: Rupert Horlick Date: Fri, 19 Oct 2018 15:32:37 -0400 Subject: [PATCH 4/5] Fix type synonym comments --- src-literatetests/10-tests.blt | 1 - .../Brittany/Internal/LayouterBasics.hs | 33 +++++++++----- .../Brittany/Internal/Layouters/Decl.hs | 45 ++++++++++--------- 3 files changed, 45 insertions(+), 34 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index f2b02d8..83dfc61 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -983,7 +983,6 @@ type a :+: b = (a, b) type (a `Foo` b) c = (a, b, c) #test synonym-comments -#pending type Foo a -- fancy type comment = -- strange comment diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 9f6366e..458f7ed 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -63,6 +63,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docSharedWrapper , hasAnyCommentsBelow , hasAnyCommentsConnected + , hasAnyCommentsPrior , hasAnnKeywordComment , hasAnnKeyword ) @@ -297,13 +298,16 @@ hasAnyCommentsConnected ast = do $ Map.elems $ anns +hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyCommentsPrior ast = astAnn ast <&> \case + Nothing -> False + Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors + hasAnnKeywordComment :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool -hasAnnKeywordComment ast annKeyword = do - anns <- mAsk - pure $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of - Nothing -> False - Just ann -> any hasK (extractAllComments ann) +hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case + Nothing -> False + Just ann -> any hasK (extractAllComments ann) where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst hasAnnKeyword @@ -311,13 +315,18 @@ hasAnnKeyword => Located a -> AnnKeywordId -> m Bool -hasAnnKeyword ast annKeyword = do - anns <- mAsk - let hasK (ExactPrint.Types.G x, _) = x == annKeyword - hasK _ = False - pure $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of - Nothing -> False - Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks +hasAnnKeyword ast annKeyword = astAnn ast <&> \case + Nothing -> False + Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks + where + hasK (ExactPrint.Types.G x, _) = x == annKeyword + hasK _ = False + +astAnn + :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m) + => GHC.Located ast + -> m (Maybe Annotation) +astAnn ast = Map.lookup (ExactPrint.Types.mkAnnKey ast) <$> mAsk -- new BriDoc stuff diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 4576e48..7f37282 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -633,12 +633,13 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of Just (c, _) -> not (c == '(' || isUpper c) isInfix <- (isInfixTypeOp ||) <$> hasAnnKeyword name AnnBackquote #endif - hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP - let parenWrapper = if hasTrailingParen - then appSep . docWrapNodeRest ltycl - else id + -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP + -- let parenWrapper = if hasTrailingParen + -- then appSep . docWrapNodeRest ltycl + -- else id + let wrapNodeRest = docWrapNodeRest ltycl docWrapNodePrior ltycl - $ layoutSynDecl isInfix parenWrapper name (hsq_explicit vars) typ + $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ _ -> briDocByExactNoComment ltycl layoutSynDecl @@ -648,17 +649,16 @@ layoutSynDecl -> [LHsTyVarBndr GhcPs] -> LHsType GhcPs -> ToBriDocM BriDocNumbered -layoutSynDecl isInfix parenWrapper name vars typ = do +layoutSynDecl isInfix wrapNodeRest name vars typ = do nameStr <- lrdrNameToTextAnn name let - lhs = if isInfix + lhs = appSep . wrapNodeRest $ if isInfix then do - let - (a : b : rest) = vars + let (a : b : rest) = vars hasOwnParens <- hasAnnKeywordComment a AnnOpenP - -- This isn't quite right, but does give syntactically valid results + -- This isn't quite right, but does give syntactically valid results let needsParens = not $ null rest || hasOwnParens - parenWrapper . docSeq + docSeq $ [ appSep $ docLit $ Text.pack "type" , appSep . docSeq @@ -672,18 +672,21 @@ layoutSynDecl isInfix parenWrapper name vars typ = do ++ fmap (appSep . layoutTyVarBndr) rest else docSeq - $ [appSep $ docLit $ Text.pack "type", appSep $ docLit nameStr] + $ [ appSep $ docLit $ Text.pack "type" + , appSep $ docWrapNode name $ docLit nameStr + ] ++ fmap (appSep . layoutTyVarBndr) vars - typeDoc <- docSharedWrapper layoutType typ + typeDoc <- docSharedWrapper layoutType typ + hasComments <- hasAnyCommentsConnected typ docAlt - [ docSeq [lhs, appSep $ docLit $ Text.pack "=", docForceSingleline typeDoc] - , docAddBaseY BrIndentRegular $ docPar - lhs - (docCols - ColTyOpPrefix - [docLit $ Text.pack "= ", docAddBaseY (BrIndentSpecial 2) typeDoc] - ) - ] + $ [ docSeq + [lhs, appSep $ docLit $ Text.pack "=", docForceSingleline typeDoc] + | not hasComments + ] + ++ [ docAddBaseY BrIndentRegular $ docPar + lhs + (docCols ColTyOpPrefix [appSep $ docLit $ Text.pack "=", typeDoc]) + ] layoutTyVarBndr :: ToBriDoc HsTyVarBndr layoutTyVarBndr lbndr@(L _ bndr) = do -- 2.30.2 From ad5868eb76cc8865750e19d31980104667d630ee Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 27 Oct 2018 16:04:57 +0200 Subject: [PATCH 5/5] Fix spacing bugs, Clean up implemenation - Normalize spaces on type alias lhs. unnecessary spaces were retained previously, e.g. "type ( ( a :%: b ) c ) = (a , c)" had non-optimal output - Clean up separator usage - Remove backend hacks (to some degree) - Minor reformatting and premature optimization --- .../Haskell/Brittany/Internal/Backend.hs | 12 +++-- .../Haskell/Brittany/Internal/BackendUtils.hs | 35 +++++------- .../Brittany/Internal/Layouters/Decl.hs | 53 +++++++++---------- 3 files changed, 46 insertions(+), 54 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 6652443..1061f0e 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -172,11 +172,13 @@ layoutBriDocM = \case priors `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> do - -- evil hack for CPP: case comment of ('#':_) -> layoutMoveToCommentPos y (-999) + -- ^ evil hack for CPP "(" -> pure () - ")" -> layoutMoveToCommentPosX (x - 1) + ")" -> pure () + -- ^ these two fix the formatting of parens + -- on the lhs of type alias defs _ -> layoutMoveToCommentPos y x -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline @@ -245,10 +247,12 @@ layoutBriDocM = \case Just comments -> do comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> do - -- evil hack for CPP: case comment of ('#':_) -> layoutMoveToCommentPos y (-999) - ")" -> layoutMoveToCommentPosX (x - 1) + -- ^ evil hack for CPP + ")" -> pure () + -- ^ fixes the formatting of parens + -- on the lhs of type alias defs _ -> layoutMoveToCommentPos y x -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index 56b95bb..0a2792c 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -26,7 +26,6 @@ module Language.Haskell.Brittany.Internal.BackendUtils , layoutAddSepSpace , layoutSetCommentCol , layoutMoveToCommentPos - , layoutMoveToCommentPosX , layoutIndentRestorePostComment , moveToExactAnn , ppmMoveToExactLoc @@ -189,30 +188,20 @@ layoutMoveToCommentPos y x = do { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of Left i -> if y == 0 then Left i else Right y Right{} -> Right y - , _lstate_addSepSpace = if Data.Maybe.isJust (_lstate_commentCol state) - then Just $ case _lstate_curYOrAddNewline state of - Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x - Right{} -> _lstate_indLevelLinger state + x - else Just $ if y == 0 then x else _lstate_indLevelLinger state + x - , _lstate_commentCol = Just $ case _lstate_commentCol state of - Just existing -> existing - Nothing -> case _lstate_curYOrAddNewline state of - Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) - Right{} -> lstate_baseY state + , _lstate_addSepSpace = + Just $ if Data.Maybe.isJust (_lstate_commentCol state) + then case _lstate_curYOrAddNewline state of + Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x + Right{} -> _lstate_indLevelLinger state + x + else if y == 0 then x else _lstate_indLevelLinger state + x + , _lstate_commentCol = + Just $ case _lstate_commentCol state of + Just existing -> existing + Nothing -> case _lstate_curYOrAddNewline state of + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> lstate_baseY state } -layoutMoveToCommentPosX - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m - ) - => Int - -> m () -layoutMoveToCommentPosX x = do - traceLocal ("layoutMoveToCommentPosX", x) - state <- mGet - mSet state { _lstate_addSepSpace = Just $ _lstate_indLevelLinger state + x } - -- | does _not_ add spaces to again reach the current base column. layoutWriteNewline :: ( MonadMultiWriter Text.Builder.Builder m diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 7f37282..cf7da4f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -659,46 +659,45 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do -- This isn't quite right, but does give syntactically valid results let needsParens = not $ null rest || hasOwnParens docSeq - $ [ appSep $ docLit $ Text.pack "type" - , appSep - . docSeq - $ [ docParenL | needsParens ] - ++ [ appSep $ layoutTyVarBndr a - , appSep $ docLit nameStr - , layoutTyVarBndr b - ] - ++ [ docParenR | needsParens ] + $ [ docLit $ Text.pack "type" + , docSeparator ] - ++ fmap (appSep . layoutTyVarBndr) rest + ++ [ docParenL | needsParens ] + ++ [ layoutTyVarBndr False a + , docSeparator + , docLit nameStr + , docSeparator + , layoutTyVarBndr False b + ] + ++ [ docParenR | needsParens ] + ++ fmap (layoutTyVarBndr True) rest else docSeq - $ [ appSep $ docLit $ Text.pack "type" - , appSep $ docWrapNode name $ docLit nameStr + $ [ docLit $ Text.pack "type" + , docSeparator + , docWrapNode name $ docLit nameStr ] - ++ fmap (appSep . layoutTyVarBndr) vars + ++ fmap (layoutTyVarBndr True) vars + sharedLhs <- docSharedWrapper id lhs typeDoc <- docSharedWrapper layoutType typ hasComments <- hasAnyCommentsConnected typ - docAlt - $ [ docSeq - [lhs, appSep $ docLit $ Text.pack "=", docForceSingleline typeDoc] - | not hasComments - ] - ++ [ docAddBaseY BrIndentRegular $ docPar - lhs - (docCols ColTyOpPrefix [appSep $ docLit $ Text.pack "=", typeDoc]) - ] + runFilteredAlternative $ do + addAlternativeCond (not hasComments) $ docSeq + [sharedLhs, appSep $ docLit $ Text.pack "=", docForceSingleline typeDoc] + addAlternative $ docAddBaseY BrIndentRegular $ docPar + sharedLhs + (docCols ColTyOpPrefix [appSep $ docLit $ Text.pack "=", typeDoc]) -layoutTyVarBndr :: ToBriDoc HsTyVarBndr -layoutTyVarBndr lbndr@(L _ bndr) = do - needsPriorSpace <- hasAnnKeywordComment lbndr AnnCloseP +layoutTyVarBndr :: Bool -> ToBriDoc HsTyVarBndr +layoutTyVarBndr needsSep lbndr@(L _ bndr) = do docWrapNodePrior lbndr $ case bndr of UserTyVar name -> do nameStr <- lrdrNameToTextAnn name - docSeq $ [ docSeparator | needsPriorSpace ] ++ [docLit nameStr] + docSeq $ [docSeparator | needsSep] ++ [docLit nameStr] KindedTyVar name kind -> do nameStr <- lrdrNameToTextAnn name docSeq - $ [ docSeparator | needsPriorSpace ] + $ [ docSeparator | needsSep ] ++ [ docLit $ Text.pack "(" , appSep $ docLit nameStr , appSep . docLit $ Text.pack "::" -- 2.30.2