diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for brittany +## 0.13.1.0 -- December 2020 + +* #330: Started sorting imports. Thanks @expipiplus1! + ## 0.13.0.0 -- December 2020 * #324: Added support for GHC 8.10. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -70,7 +70,7 @@ - via `nix`: ~~~.sh - nix build -f release.nix # or 'nix-build -f release.nix' + nix build nix-env -i ./result ~~~ @@ -101,6 +101,20 @@ ~~~~.sh aura -A brittany ~~~~ + +# Development tips + +## Run a hoogle server + +To host a local Hoogle server with all of Brittany's dependencies run: + +```sh +echo brittany.cabal | + $(nix-build '' --no-link -A entr)/bin/entr -r -- \ + sh -c "nix-shell --run 'hoogle server --local'" +``` + +This will watch `brittany.cabal` for changes and restart the server when new dependencies are added there. # Editor Integration diff --git a/brittany.cabal b/brittany.cabal --- a/brittany.cabal +++ b/brittany.cabal @@ -1,5 +1,5 @@ name: brittany -version: 0.13.0.0 +version: 0.13.1.0 synopsis: Haskell source code formatter description: { See . diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -1088,38 +1088,38 @@ 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 - , that - , will + , line + , list , not - , quite - , fit , onA + , quite , single - , line - , anymore + , that + , will + , 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 @@ ) #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 +import TestJustAbitToLongModuleNameLikeTh + hiding ( abc , def , ghci , jklm ) -import TestJustAbitToLongModuleNameLikeTh - hiding ( abc +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 @@ -- 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 --- a/src-literatetests/14-extensions.blt +++ b/src-literatetests/14-extensions.blt @@ -78,8 +78,8 @@ {-# 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 --- a/src-literatetests/30-tests-context-free.blt +++ b/src-literatetests/30-tests-context-free.blt @@ -753,27 +753,27 @@ 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 - , that - , will + , line + , list , not - , quite - , fit , onA + , quite , single - , line - , anymore + , that + , will + , 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 @@ ) #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 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -159,6 +159,10 @@ (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 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -636,24 +636,32 @@ 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 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -156,7 +156,9 @@ 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 @@ } 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 @@ -- 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 @@ 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 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -28,6 +28,7 @@ , layoutMoveToCommentPos , layoutIndentRestorePostComment , moveToExactAnn + , moveToY , ppmMoveToExactLoc , layoutWritePriorComments , layoutWritePostComments @@ -469,20 +470,23 @@ -- 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 --- 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 @@ 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 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -73,6 +73,8 @@ , hasAnyRegularCommentsRest , hasAnnKeywordComment , hasAnnKeyword + , astAnn + , allocNodeIndex ) where @@ -575,7 +577,8 @@ 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 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -2,6 +2,7 @@ ( layoutIE , layoutLLIEs , layoutAnnAndSepLLIEs + , SortItemsFlag(..) ) where @@ -17,6 +18,7 @@ , moduleNameString , AnnKeywordId(..) , Located + , ModuleName ) #if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ import GHC.Hs @@ -50,18 +52,19 @@ : 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 @@ 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 @@ -- 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,7 +122,46 @@ 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: -- (item, item, ..., item) @@ -124,26 +175,54 @@ -- () -- 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 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -21,6 +21,7 @@ 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 @@ 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 @@ 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 --- 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 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 @@ 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 @@ , 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 @@ [ 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)