diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index e7c3add..d87e8d9 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -16,12 +16,12 @@ jobs: - ubuntu-18.04 - windows-2019 ghc: - - 8.10.2 + - 8.8.4 cabal: - 3.2.0.0 include: - os: ubuntu-18.04 - ghc: 8.8.4 + ghc: 8.10.2 cabal: 3.2.0.0 - os: ubuntu-18.04 ghc: 8.6.5 @@ -50,7 +50,7 @@ jobs: with: path: output/brittany* name: brittany-${{ matrix.os }}-ghc-${{ matrix.ghc }}-${{ github.sha }} - - if: matrix.os == 'ubuntu-18.04' && matrix.ghc == '8.10.2' + - if: matrix.os == 'ubuntu-18.04' && matrix.ghc == '8.8.4' uses: actions/upload-artifact@v2 with: path: dist-newstyle/sdist/brittany-*.tar.gz diff --git a/.travis.yml b/.travis.yml index 6b223bf..19a5ca9 100644 --- a/.travis.yml +++ b/.travis.yml @@ -69,10 +69,6 @@ matrix: compiler: ": #stack default" addons: {apt: {packages: [libgmp-dev]}} - - env: BUILD=stack ARGS="--stack-yaml stack-8.8.4.yaml" - compiler: ": #stack 8.8.4" - addons: {apt: {packages: [libgmp-dev]}} - - env: BUILD=stack ARGS="--stack-yaml stack-8.6.5.yaml" compiler: ": #stack 8.6.5" addons: {apt: {packages: [libgmp-dev]}} diff --git a/ChangeLog.md b/ChangeLog.md index 77ecfe6..41c1825 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,11 +1,5 @@ # Revision history for brittany -## 0.13.0.0 -- December 2020 - -* #324: Added support for GHC 8.10. - * Dropped support for GHC 8.4, 8.2, and 8.0. - * Thanks @jneira, @bubba, @infinity0, and @expipiplus1! - ## 0.12.2.0 -- November 2020 * #207: Fix newtype indent in associated type family. diff --git a/Makefile b/Makefile index 2d5b809..ca0a962 100644 --- a/Makefile +++ b/Makefile @@ -5,12 +5,7 @@ test: .PHONY: test-all test-all: - $(MAKE) test test-8.8.4 test-8.6.5 - -.PHONY: test-8.8.4 -test-8.8.4: - echo "test 8.8.4" - stack test --stack-yaml stack-8.8.4.yaml --work-dir .stack-work-8.8.4 + $(MAKE) test test-8.6.5 .PHONY: test-8.6.5 test-8.6.5: diff --git a/README.md b/README.md index 7828fd2..eec9c4c 100644 --- a/README.md +++ b/README.md @@ -48,7 +48,7 @@ log the size of the input, but _not_ the full input/output of requests.) # Other usage notes -- Supports GHC versions `8.6`, `8.8`, `8.10`. +- Supports GHC versions `8.6`, `8.8`. - included in stackage with lts>=10.0 (or nightlies dating to >=2017-11-15) - config (file) documentation is lacking. - some config values can not be configured via commandline yet. diff --git a/brittany.cabal b/brittany.cabal index cbc0631..cd541fb 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,5 +1,5 @@ name: brittany -version: 0.13.0.0 +version: 0.12.2.0 synopsis: Haskell source code formatter description: { See . diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index b1ccfb6..806dd47 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -1088,38 +1088,38 @@ import qualified Data.List ( ) import Data.List ( nub ) #test several-elements -import Data.List ( nub - , foldl' +import Data.List ( foldl' , indexElem + , nub ) #test a-ridiculous-amount-of-elements import Test ( Long - , list - , with + , anymore + , fit , items + , line + , list + , not + , onA + , quite + , single , that , will - , not - , quite - , fit - , onA - , single - , line - , anymore + , with ) #test with-things -import Test ( T +import Test ( (+) + , (:!)(..) + , (:*)((:.), T7, t7) + , (:.) + , T , T2() , T3(..) , T4(T4) , T5(T5, t5) , T6((<|>)) - , (+) - , (:.) - , (:.)(..) - , (:.)(T7, (:.), t7) ) #test hiding @@ -1143,56 +1143,55 @@ import Prelude as X ) #test long-module-name-simple -import TestJustShortEnoughModuleNameLikeThisOne ( ) import TestJustAbitToLongModuleNameLikeThisOneIs ( ) +import TestJustShortEnoughModuleNameLikeThisOne ( ) #test long-module-name-as -import TestJustShortEnoughModuleNameLikeThisOn as T import TestJustAbitToLongModuleNameLikeThisOneI as T +import TestJustShortEnoughModuleNameLikeThisOn as T #test long-module-name-hiding -import TestJustShortEnoughModuleNameLike hiding ( ) import TestJustAbitToLongModuleNameLikeTh hiding ( ) +import TestJustShortEnoughModuleNameLike hiding ( ) #test long-module-name-simple-items import MoreThanSufficientlyLongModuleNameWithSome - ( items - , that - , will - , not + ( compact , fit , inA - , compact + , items , layout + , not + , that + , will ) #test long-module-name-hiding-items -import TestJustShortEnoughModuleNameLike hiding ( abc - , def - , ghci - , jklm - ) import TestJustAbitToLongModuleNameLikeTh hiding ( abc , def , ghci , jklm ) +import TestJustShortEnoughModuleNameLike hiding ( abc + , def + , ghci + , jklm + ) #test long-module-name-other -import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff ( ) -import {-# SOURCE #-} safe qualified "qualifiers" AlsoAffe - ( ) - -import {-# SOURCE #-} safe qualified "qualifiers" AlsoAf as T -import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff - as T import {-# SOURCE #-} safe qualified "qualifier" A hiding ( ) import {-# SOURCE #-} safe qualified "qualifiers" A hiding ( ) +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAf as T +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff ( ) +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff + as T +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAffe + ( ) #test import-with-comments -- Test @@ -1295,6 +1294,29 @@ import qualified Data.List as L -- Test import Test ( test ) +#test sorted-imports +import Aaa +import Baa + +#test sorted-import-groups +import Zaa +import Zab + +import Aaa +import Baa + +#test sorted-qualified-imports +import Boo +import qualified Zoo + +#test imports-groups-same-module +import Boo ( a ) + +import Boo ( b ) + +#test sorted-imports-nested +import A.B.C +import A.B.D ############################################################################### ############################################################################### diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt index 81dde02..d794e9c 100644 --- a/src-literatetests/14-extensions.blt +++ b/src-literatetests/14-extensions.blt @@ -78,8 +78,8 @@ module Test (type (++), (++), pattern Foo) where {-# LANGUAGE PatternSynonyms #-} import Test ( type (++) , (++) - , pattern Foo , pattern (:.) + , pattern Foo ) ############################################################################### diff --git a/src-literatetests/30-tests-context-free.blt b/src-literatetests/30-tests-context-free.blt index e439ecf..003a23d 100644 --- a/src-literatetests/30-tests-context-free.blt +++ b/src-literatetests/30-tests-context-free.blt @@ -753,27 +753,27 @@ import qualified Data.List () import Data.List (nub) #test several-elements -import Data.List (nub, foldl', indexElem) +import Data.List (foldl', indexElem, nub) #test a-ridiculous-amount-of-elements import Test ( Long - , list - , with + , anymore + , fit , items + , line + , list + , not + , onA + , quite + , single , that , will - , not - , quite - , fit - , onA - , single - , line - , anymore + , with ) #test with-things -import Test (T, T2(), T3(..), T4(T4), T5(T5, t5), T6((<|>)), (+)) +import Test ((+), T, T2(), T3(..), T4(T4), T5(T5, t5), T6((<|>))) #test hiding import Test hiding () @@ -796,22 +796,22 @@ import Prelude as X ) #test long-module-name-simple -import TestJustShortEnoughModuleNameLikeThisOne () -import TestJustAbitToLongModuleNameLikeThisOneIs () import MoreThanSufficientlyLongModuleNameWithSome - (items, that, will, not, fit, inA, compact, layout) + (compact, fit, inA, items, layout, not, that, will) +import TestJustAbitToLongModuleNameLikeThisOneIs () +import TestJustShortEnoughModuleNameLikeThisOne () #test long-module-name-as -import TestJustShortEnoughModuleNameLikeThisOn as T import TestJustAbitToLongModuleNameLikeThisOneI as T +import TestJustShortEnoughModuleNameLikeThisOn as T #test long-module-name-hiding -import TestJustShortEnoughModuleNameLike hiding () import TestJustAbitToLongModuleNameLikeTh hiding () +import TestJustShortEnoughModuleNameLike hiding () #test long-module-name-simple-items import MoreThanSufficientlyLongModuleNameWithSome - (items, that, will, not, fit, inA, compact, layout) + (compact, fit, inA, items, layout, not, that, will) #test long-module-name-hiding-items import TestJustShortEnoughModuleNameLike hiding (abc, def, ghci, jklm) diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index b733d62..ae469e3 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -159,6 +159,10 @@ main = do (Parsec.noneOf "\r\n") , _ <- Parsec.eof ] + , [ NormalLine mempty + | _ <- Parsec.try $ Parsec.string "" + , _ <- Parsec.eof + ] ] lineMapper :: Text -> InputLine lineMapper line = case Parsec.runParser specialLineParser () "" line of diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 57e6e8f..8489136 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -636,24 +636,32 @@ layoutBriDoc briDoc = do anns :: ExactPrint.Anns <- mAsk - let state = LayoutState - { _lstate_baseYs = [0] - , _lstate_curYOrAddNewline = Right 0 -- important that we use left here - -- because moveToAnn stuff of the - -- first node needs to do its - -- thing properly. - , _lstate_indLevels = [0] - , _lstate_indLevelLinger = 0 - , _lstate_comments = anns - , _lstate_commentCol = Nothing - , _lstate_addSepSpace = Nothing - , _lstate_commentNewlines = 0 - } + let state = LayoutState { _lstate_baseYs = [0] + , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left + -- here because moveToAnn stuff + -- of the first node needs to do + -- its thing properly. + , _lstate_indLevels = [0] + , _lstate_indLevelLinger = 0 + , _lstate_comments = anns + , _lstate_commentCol = Nothing + , _lstate_addSepSpace = Nothing + , _lstate_commentNewlines = 0 + } state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' let remainingComments = - extractAllComments =<< Map.elems (_lstate_comments state') + [ c + | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList + (_lstate_comments state') + -- With the new import layouter, we manually process comments + -- without relying on the backend to consume the comments out of + -- the state/map. So they will end up here, and we need to ignore + -- them. + , ExactPrint.unConName con /= "ImportDecl" + , c <- extractAllComments elemAnns + ] remainingComments `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell) diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 3d29218..234d55e 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -156,7 +156,9 @@ layoutBriDocM = \case BDAnnotationPrior annKey bd -> do state <- mGet let m = _lstate_comments state - let allowMTEL = Data.Either.isRight (_lstate_curYOrAddNewline state) + let moveToExactLocationAction = case _lstate_curYOrAddNewline state of + Left{} -> pure () + Right{} -> moveToExactAnn annKey mAnn <- do let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m mSet $ state @@ -167,8 +169,8 @@ layoutBriDocM = \case } return mAnn case mAnn of - Nothing -> when allowMTEL $ moveToExactAnn annKey - Just [] -> when allowMTEL $ moveToExactAnn annKey + Nothing -> moveToExactLocationAction + Just [] -> moveToExactLocationAction Just priors -> do -- layoutResetSepSpace priors @@ -184,7 +186,7 @@ layoutBriDocM = \case -- layoutMoveToIndentCol y layoutWriteAppendMultiline commentLines -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } - when allowMTEL $ moveToExactAnn annKey + moveToExactLocationAction layoutBriDocM bd BDAnnotationKW annKey keyword bd -> do layoutBriDocM bd @@ -373,7 +375,7 @@ briDocIsMultiLine briDoc = rec briDoc BDSetParSpacing bd -> rec bd BDForceParSpacing bd -> rec bd BDNonBottomSpacing _ bd -> rec bd - BDDebug _ bd -> rec bd + BDDebug _ bd -> rec bd -- In theory -- ========= diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index 2531794..1253f1a 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -28,6 +28,7 @@ module Language.Haskell.Brittany.Internal.BackendUtils , layoutMoveToCommentPos , layoutIndentRestorePostComment , moveToExactAnn + , moveToY , ppmMoveToExactLoc , layoutWritePriorComments , layoutWritePostComments @@ -469,20 +470,23 @@ moveToExactAnn annKey = do -- curY <- mGet <&> _lstate_curY let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann -- mModify $ \state -> state { _lstate_addNewline = Just x } - mModify $ \state -> - let upd = case _lstate_curYOrAddNewline state of - Left i -> if y == 0 then Left i else Right y - Right i -> Right $ max y i - in state - { _lstate_curYOrAddNewline = upd - , _lstate_addSepSpace = if Data.Either.isRight upd - then - _lstate_commentCol state - <|> _lstate_addSepSpace state - <|> Just (lstate_baseY state) - else Nothing - , _lstate_commentCol = Nothing - } + moveToY y + +moveToY :: MonadMultiState LayoutState m => Int -> m () +moveToY y = mModify $ \state -> + let upd = case _lstate_curYOrAddNewline state of + Left i -> if y == 0 then Left i else Right y + Right i -> Right $ max y i + in state + { _lstate_curYOrAddNewline = upd + , _lstate_addSepSpace = if Data.Either.isRight upd + then + _lstate_commentCol state + <|> _lstate_addSepSpace state + <|> Just (lstate_baseY state) + else Nothing + , _lstate_commentCol = Nothing + } -- fixMoveToLineByIsNewline :: MonadMultiState -- LayoutState m => Int -> m Int -- fixMoveToLineByIsNewline x = do diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 29c126f..9992dfd 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -3,7 +3,6 @@ module Language.Haskell.Brittany.Internal.ExactPrintUtils ( parseModule , parseModuleFromString - , commentAnnFixTransform , commentAnnFixTransformGlob , extractToplevelAnns , foldedAnnKeys @@ -204,6 +203,29 @@ commentAnnFixTransformGlob ast = do ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns +-- TODO: this is unused by now, but it contains one detail that +-- commentAnnFixTransformGlob does not include: Moving of comments for +-- "RecordUpd"s. +-- commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform () +-- commentAnnFixTransform modul = SYB.everything (>>) genF modul +-- where +-- genF :: Data.Data.Data a => a -> ExactPrint.Transform () +-- genF = (\_ -> return ()) `SYB.extQ` exprF +-- exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform () +-- exprF lexpr@(L _ expr) = case expr of +-- #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +-- RecordCon _ _ (HsRecFields fs@(_:_) Nothing) -> +-- #else +-- RecordCon _ _ _ (HsRecFields fs@(_:_) Nothing) -> +-- #endif +-- moveTrailingComments lexpr (List.last fs) +-- #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +-- RecordUpd _ _e fs@(_:_) -> +-- #else +-- RecordUpd _e fs@(_:_) _cons _ _ _ -> +-- #endif +-- moveTrailingComments lexpr (List.last fs) +-- _ -> return () commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform () commentAnnFixTransform modul = SYB.everything (>>) genF modul diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index d40fd6e..770cbdd 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -73,6 +73,8 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , hasAnyRegularCommentsRest , hasAnnKeywordComment , hasAnnKeyword + , astAnn + , allocNodeIndex ) where @@ -575,7 +577,8 @@ docSeparator = allocateNode BDFSeparator docAnnotationPrior :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm +docAnnotationPrior annKey bdm = + allocateNode . BDFAnnotationPrior annKey =<< bdm docAnnotationKW :: AnnKey diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 4f7ec0e..2a722d1 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -2,6 +2,7 @@ module Language.Haskell.Brittany.Internal.Layouters.IE ( layoutIE , layoutLLIEs , layoutAnnAndSepLLIEs + , SortItemsFlag(..) ) where @@ -17,6 +18,7 @@ import GHC ( unLoc , moduleNameString , AnnKeywordId(..) , Located + , ModuleName ) #if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ import GHC.Hs @@ -50,18 +52,19 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of : hasAnyCommentsBelow x : map hasAnyCommentsBelow ns ) + let sortedNs = List.sortOn wrappedNameToText ns runFilteredAlternative $ do addAlternativeCond (not hasComments) $ docSeq $ [layoutWrapped lie x, docLit $ Text.pack "("] - ++ intersperse docCommaSep (map nameDoc ns) + ++ intersperse docCommaSep (map nameDoc sortedNs) ++ [docParenR] addAlternative $ docWrapNodeRest lie $ docAddBaseY BrIndentRegular $ docPar (layoutWrapped lie x) - (layoutItems (splitFirstLast ns)) + (layoutItems (splitFirstLast sortedNs)) where nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] @@ -91,6 +94,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of name <- lrdrNameToTextAnn n docLit $ Text.pack "type " <> name +data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted -- Helper function to deal with Located lists of LIEs. -- In particular this will also associate documentation -- from the located list that actually belongs to the last IE. @@ -99,10 +103,18 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of -- handling of the resulting list. Adding parens is -- left to the caller since that is context sensitive layoutAnnAndSepLLIEs - :: Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered] -layoutAnnAndSepLLIEs llies@(L _ lies) = do + :: SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered] +layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do let makeIENode ie = docSeq [docCommaSep, ie] - let ieDocs = layoutIE <$> lies + let sortedLies = + [ items + | group <- Data.List.Extra.groupOn lieToText + $ List.sortOn lieToText lies + , items <- mergeGroup group + ] + let ieDocs = fmap layoutIE $ case shouldSort of + ShouldSortItems -> sortedLies + KeepItemsUnsorted -> lies ieCommaDocs <- docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of FirstLastEmpty -> [] @@ -110,6 +122,45 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do FirstLast ie1 ieMs ieN -> [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN] pure $ fmap pure ieCommaDocs -- returned shared nodes + where + mergeGroup :: [LIE GhcPs] -> [LIE GhcPs] + mergeGroup [] = [] + mergeGroup items@[_] = items + mergeGroup items = if + | all isProperIEThing items -> [List.foldl1' thingFolder items] + | all isIEVar items -> [List.foldl1' thingFolder items] + | otherwise -> items + -- proper means that if it is a ThingWith, it does not contain a wildcard + -- (because I don't know what a wildcard means if it is not already a + -- IEThingAll). + isProperIEThing :: LIE GhcPs -> Bool + isProperIEThing = \case + L _ (IEThingAbs _ _wn) -> True + L _ (IEThingAll _ _wn) -> True + L _ (IEThingWith _ _wn NoIEWildcard _ _) -> True + _ -> False + isIEVar :: LIE GhcPs -> Bool + isIEVar = \case + L _ IEVar{} -> True + _ -> False + thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs + thingFolder l1@(L _ IEVar{} ) _ = l1 + thingFolder l1@(L _ IEThingAll{}) _ = l1 + thingFolder _ l2@(L _ IEThingAll{}) = l2 + thingFolder l1 ( L _ IEThingAbs{}) = l1 + thingFolder (L _ IEThingAbs{}) l2 = l2 + thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2)) + = L + l + (IEThingWith x + wn + NoIEWildcard + (consItems1 ++ consItems2) + (fieldLbls1 ++ fieldLbls2) + ) + thingFolder _ _ = + error "thingFolder should be exhaustive because we have a guard above" + -- Builds a complete layout for the given located -- list of LIEs. The layout provides two alternatives: @@ -124,26 +175,54 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do -- () -- no comments -- ( -- a comment -- ) -layoutLLIEs :: Bool -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered -layoutLLIEs enableSingleline llies = do - ieDs <- layoutAnnAndSepLLIEs llies +layoutLLIEs :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered +layoutLLIEs enableSingleline shouldSort llies = do + ieDs <- layoutAnnAndSepLLIEs shouldSort llies hasComments <- hasAnyCommentsBelow llies - runFilteredAlternative $ - case ieDs of - [] -> do - addAlternativeCond (not hasComments) $ - docLit $ Text.pack "()" - addAlternativeCond hasComments $ - docPar (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) - docParenR - (ieDsH:ieDsT) -> do - addAlternativeCond (not hasComments && enableSingleline) - $ docSeq - $ [docLit (Text.pack "(")] - ++ (docForceSingleline <$> ieDs) - ++ [docParenR] - addAlternative - $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) - $ docLines - $ ieDsT - ++ [docParenR] + runFilteredAlternative $ case ieDs of + [] -> do + addAlternativeCond (not hasComments) $ docLit $ Text.pack "()" + addAlternativeCond hasComments $ docPar + (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) + docParenR + (ieDsH : ieDsT) -> do + addAlternativeCond (not hasComments && enableSingleline) + $ docSeq + $ [docLit (Text.pack "(")] + ++ (docForceSingleline <$> ieDs) + ++ [docParenR] + addAlternative + $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) + $ docLines + $ ieDsT + ++ [docParenR] + +-- | Returns a "fingerprint string", not a full text representation, nor even +-- a source code representation of this syntax node. +-- Used for sorting, not for printing the formatter's output source code. +wrappedNameToText :: LIEWrappedName RdrName -> Text +wrappedNameToText = \case + L _ (IEName n) -> lrdrNameToText n + L _ (IEPattern n) -> lrdrNameToText n + L _ (IEType n) -> lrdrNameToText n + +-- | Returns a "fingerprint string", not a full text representation, nor even +-- a source code representation of this syntax node. +-- Used for sorting, not for printing the formatter's output source code. +lieToText :: LIE GhcPs -> Text +lieToText = \case + L _ (IEVar _ wn ) -> wrappedNameToText wn + L _ (IEThingAbs _ wn ) -> wrappedNameToText wn + L _ (IEThingAll _ wn ) -> wrappedNameToText wn + L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn + -- TODO: These _may_ appear in exports! + -- Need to check, and either put them at the top (for module) or do some + -- other clever thing. + L _ (IEModuleContents _ n) -> moduleNameToText n + L _ (IEGroup _ _ _ ) -> Text.pack "@IEGroup" + L _ (IEDoc _ _ ) -> Text.pack "@IEDoc" + L _ (IEDocNamed _ _ ) -> Text.pack "@IEDocNamed" + L _ (XIE _ ) -> Text.pack "@XIE" + where + moduleNameToText :: Located ModuleName -> Text + moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index cdcd8ed..e23c11b 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -21,6 +21,7 @@ import Name import FieldLabel import qualified FastString import BasicTypes +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import Language.Haskell.Brittany.Internal.Utils @@ -35,8 +36,8 @@ prepPkg rawN = case rawN of prepModName :: Located e -> e prepModName = unLoc -layoutImport :: ToBriDoc ImportDecl -layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of +layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered +layoutImport importD = case importD of ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack @@ -90,14 +91,14 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of hasComments <- hasAnyCommentsBelow llies if compact then docAlt - [ docSeq [hidDoc, docForceSingleline $ layoutLLIEs True llies] + [ docSeq [hidDoc, docForceSingleline $ layoutLLIEs True ShouldSortItems llies] , let makeParIfHiding = if hiding then docAddBaseY BrIndentRegular . docPar hidDoc else id - in makeParIfHiding (layoutLLIEs True llies) + in makeParIfHiding (layoutLLIEs True ShouldSortItems llies) ] else do - ieDs <- layoutAnnAndSepLLIEs llies + ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies docWrapNodeRest llies $ docEnsureIndent (BrIndentSpecial hidDocCol) $ case ieDs of diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index 3839ecd..7887489 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ViewPatterns #-} + module Language.Haskell.Brittany.Internal.Layouters.Module (layoutModule) where #include "prelude.inc" @@ -21,7 +23,12 @@ import FieldLabel import qualified FastString import BasicTypes import Language.Haskell.GHC.ExactPrint as ExactPrint -import Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Types + ( DeltaPos(..) + , deltaRow + , commentContents + ) import Language.Haskell.Brittany.Internal.Utils @@ -30,8 +37,16 @@ import Language.Haskell.Brittany.Internal.Utils layoutModule :: ToBriDoc HsModule layoutModule lmod@(L _ mod') = case mod' of -- Implicit module Main - HsModule Nothing _ imports _ _ _ -> docLines $ map layoutImport imports + HsModule Nothing _ imports _ _ _ -> do + commentedImports <- transformToCommentedImport imports + -- groupify commentedImports `forM_` tellDebugMessShow + docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports) + -- sortedImports <- sortImports imports + -- docLines $ [layoutImport y i | (y, i) <- sortedImports] HsModule (Just n) les imports _ _ _ -> do + commentedImports <- transformToCommentedImport imports + -- groupify commentedImports `forM_` tellDebugMessShow + -- sortedImports <- sortImports imports let tn = Text.pack $ moduleNameString $ unLoc n allowSingleLineExportList <- mAsk <&> _conf_layout @@ -53,7 +68,7 @@ layoutModule lmod@(L _ mod') = case mod' of , appSep $ docLit tn , docWrapNode lmod $ appSep $ case les of Nothing -> docEmpty - Just x -> layoutLLIEs True x + Just x -> layoutLLIEs True KeepItemsUnsorted x , docSeparator , docLit $ Text.pack "where" ] @@ -62,13 +77,140 @@ layoutModule lmod@(L _ mod') = case mod' of [ docAddBaseY BrIndentRegular $ docPar (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] ) - (docSeq [ docWrapNode lmod $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs False x + (docSeq [ + docWrapNode lmod $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs False KeepItemsUnsorted x , docSeparator , docLit $ Text.pack "where" ] ) ] ] - : map layoutImport imports + : (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports] + +data CommentedImport + = EmptyLine + | IndependentComment (Comment, DeltaPos) + | ImportStatement ImportStatementRecord + +instance Show CommentedImport where + show = \case + EmptyLine -> "EmptyLine" + IndependentComment _ -> "IndependentComment" + ImportStatement r -> + "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show + (length $ commentsAfter r) + +data ImportStatementRecord = ImportStatementRecord + { commentsBefore :: [(Comment, DeltaPos)] + , commentsAfter :: [(Comment, DeltaPos)] + , importStatement :: ImportDecl GhcPs + } + +instance Show ImportStatementRecord where + show r = "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show + (length $ commentsAfter r) + +transformToCommentedImport + :: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport] +transformToCommentedImport is = do + nodeWithAnnotations <- is `forM` \i@(L _ rawImport) -> do + annotionMay <- astAnn i + pure (annotionMay, rawImport) + let + convertComment (c, DP (y, x)) = + replicate (y - 1) EmptyLine ++ [IndependentComment (c, DP (1, x))] + accumF + :: [(Comment, DeltaPos)] + -> (Maybe Annotation, ImportDecl GhcPs) + -> ([(Comment, DeltaPos)], [CommentedImport]) + accumF accConnectedComm (annMay, decl) = case annMay of + Nothing -> + ( [] + , [ ImportStatement ImportStatementRecord { commentsBefore = [] + , commentsAfter = [] + , importStatement = decl + } + ] + ) + Just ann -> + let + blanksBeforeImportDecl = deltaRow (annEntryDelta ann) - 1 + (newAccumulator, priorComments') = + List.span ((== 0) . deltaRow . snd) (annPriorComments ann) + go + :: [(Comment, DeltaPos)] + -> [(Comment, DeltaPos)] + -> ([CommentedImport], [(Comment, DeltaPos)], Int) + go acc [] = ([], acc, 0) + go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1) + go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs + go acc ((c1, DP (y, x)) : xs) = + ( (convertComment =<< xs) ++ replicate (y - 1) EmptyLine + , (c1, DP (1, x)) : acc + , 0 + ) + (convertedIndependentComments, beforeComments, initialBlanks) = + if blanksBeforeImportDecl /= 0 + then (convertComment =<< priorComments', [], 0) + else go [] (reverse priorComments') + in + ( newAccumulator + , convertedIndependentComments + ++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine + ++ [ ImportStatement ImportStatementRecord + { commentsBefore = beforeComments + , commentsAfter = accConnectedComm + , importStatement = decl + } + ] + ) + let (finalAcc, finalList) = mapAccumR accumF [] nodeWithAnnotations + pure $ join $ (convertComment =<< finalAcc) : finalList + +sortCommentedImports :: [CommentedImport] -> [CommentedImport] +sortCommentedImports = + unpackImports . mergeGroups . map (fmap (sortGroups)) . groupify + where + unpackImports :: [CommentedImport] -> [CommentedImport] + unpackImports xs = xs >>= \case + l@EmptyLine -> [l] + l@IndependentComment{} -> [l] + ImportStatement r -> + map IndependentComment (commentsBefore r) ++ [ImportStatement r] + mergeGroups + :: [Either CommentedImport [ImportStatementRecord]] -> [CommentedImport] + mergeGroups xs = xs >>= \case + Left x -> [x] + Right y -> ImportStatement <$> y + sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord] + sortGroups = + List.sortOn (moduleNameString . unLoc . ideclName . importStatement) + groupify + :: [CommentedImport] -> [Either CommentedImport [ImportStatementRecord]] + groupify cs = go [] cs + where + go [] = \case + (l@EmptyLine : rest) -> Left l : go [] rest + (l@IndependentComment{} : rest) -> Left l : go [] rest + (ImportStatement r : rest) -> go [r] rest + [] -> [] + go acc = \case + (l@EmptyLine : rest) -> Right (reverse acc) : Left l : go [] rest + (l@IndependentComment{} : rest) -> + Left l : Right (reverse acc) : go [] rest + (ImportStatement r : rest) -> go (r : acc) rest + [] -> [Right (reverse acc)] + +commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered +commentedImportsToDoc = \case + EmptyLine -> docLitS "" + IndependentComment c -> commentToDoc c + ImportStatement r -> + docSeq + ( layoutImport (importStatement r) + : map commentToDoc (commentsAfter r) + ) + where + commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c) diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 785b146..2717de3 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -1 +1,5 @@ -resolver: lts-14.27 +resolver: lts-13.23 + +extra-deps: + - butcher-1.3.2.1 + - multistate-0.8.0.1 diff --git a/stack-8.6.5.yaml.lock b/stack-8.6.5.yaml.lock index e24dcac..a7d341f 100644 --- a/stack-8.6.5.yaml.lock +++ b/stack-8.6.5.yaml.lock @@ -3,10 +3,24 @@ # For more information, please see the documentation at: # https://docs.haskellstack.org/en/stable/lock_files -packages: [] +packages: +- completed: + hackage: butcher-1.3.2.1@sha256:cf479ea83a08f4f59a482e7c023c70714e7c93c1ccd7d53fe076ad3f1a3d2b8d,3115 + pantry-tree: + size: 1197 + sha256: dc4bd6adc5f8bd3589533659b62567da78b6956d7098e561c0523c60fcaa0406 + original: + hackage: butcher-1.3.2.1 +- completed: + hackage: multistate-0.8.0.1@sha256:496ac087a0df3984045d7460b981d5e868a49e160b60a6555f6799e81e58542d,3700 + pantry-tree: + size: 2143 + sha256: 0136d5fcddee0244c3bc73b4ae1b489134a1dd12a8978f437b2be81e98f5d8bd + original: + hackage: multistate-0.8.0.1 snapshots: - completed: - size: 524996 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/27.yaml - sha256: 7ea31a280c56bf36ff591a7397cc384d0dff622e7f9e4225b47d8980f019a0f0 - original: lts-14.27 + size: 498398 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/23.yaml + sha256: 63151ca76f39d5cfbd266ce019236459fdda53fbefd2200aedeb33bcc81f808e + original: lts-13.23 diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml deleted file mode 100644 index d014f95..0000000 --- a/stack-8.8.4.yaml +++ /dev/null @@ -1 +0,0 @@ -resolver: lts-16.25 diff --git a/stack-8.8.4.yaml.lock b/stack-8.8.4.yaml.lock deleted file mode 100644 index 31befa1..0000000 --- a/stack-8.8.4.yaml.lock +++ /dev/null @@ -1,12 +0,0 @@ -# This file was autogenerated by Stack. -# You should not edit this file by hand. -# For more information, please see the documentation at: -# https://docs.haskellstack.org/en/stable/lock_files - -packages: [] -snapshots: -- completed: - size: 533252 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/25.yaml - sha256: 147598b98bdd95ec0409bac125a4f1bff3cd4f8d73334d283d098f66a4bcc053 - original: lts-16.25 diff --git a/stack.yaml b/stack.yaml index 9989a09..7ff28c9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,11 @@ -resolver: nightly-2020-12-09 +resolver: lts-13.25 extra-deps: - - data-tree-print-0.1.0.2 + - multistate-0.8.0.2 + - butcher-1.3.2.3 + - deque-0.4.2.3 + - strict-list-0.1.4 + - ghc-exactprint-0.6.2 + +packages: + - . diff --git a/stack.yaml.lock b/stack.yaml.lock index 91c9355..6a1ae68 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,15 +5,43 @@ packages: - completed: - hackage: data-tree-print-0.1.0.2@sha256:d845e99f322df70e0c06d6743bf80336f5918d5423498528beb0593a2afc1703,1620 + hackage: multistate-0.8.0.2@sha256:fbb0d8ade9ef73c8ed92488f5804d0ebe75d3a9c24bf53452bc3a4f32b34cb2e,3713 pantry-tree: - size: 272 - sha256: b8778eb1b16fddb91b2eed2b25f33a89d1e4f7a533160de4ccbf226f82456135 + size: 2143 + sha256: 1753828d37b456e1e0241766d893b29f385ef7769fa79610f507b747935b77cb original: - hackage: data-tree-print-0.1.0.2 + hackage: multistate-0.8.0.2 +- completed: + hackage: butcher-1.3.2.3@sha256:1b8040eddb6da2a05426bf9f6c56b078e629228d64d7d61fb3daa88802487e1b,3262 + pantry-tree: + size: 1197 + sha256: 6bf3a318bd8689bd1fa7a8084c0d96372768d2dc3e30d9aa58d07741ed6816e6 + original: + hackage: butcher-1.3.2.3 +- completed: + hackage: deque-0.4.2.3@sha256:7cc8ddfc77df351ff9c16e838ccdb4a89f055c80a3111e27eba8d90e8edde7d0,1853 + pantry-tree: + size: 807 + sha256: 7f584c71e9e912935f829cb4667411ae3c3048fcd8b935170fb5a45188019403 + original: + hackage: deque-0.4.2.3 +- completed: + hackage: strict-list-0.1.4@sha256:0fa869e2c21b710b7133e8628169f120fe6299342628edd3d5087ded299bc941,1631 + pantry-tree: + size: 340 + sha256: bbb22fd014867dc48697ddd8598d4a9fb03fa2d58ef79bed94f208a9b6d94224 + original: + hackage: strict-list-0.1.4 +- completed: + hackage: ghc-exactprint-0.6.2@sha256:d822f64351e9a8e03d9bad35c8fdf558d30dc396801b396c52b5d5bffaee9108,8368 + pantry-tree: + size: 85384 + sha256: d904de9c01e58bfa091d7caa09e0423e9d2932b7b3490c4d83140731f4473877 + original: + hackage: ghc-exactprint-0.6.2 snapshots: - completed: - size: 556768 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/12/9.yaml - sha256: bca31ebf05f842be9dd24410eca84f296da1860369a82eb7466f447a76cca762 - original: nightly-2020-12-09 + size: 499461 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/25.yaml + sha256: aed98969628e20615e96b06083c933c7e3354ae56b08b75e607a26569225d6c0 + original: lts-13.25