From c6ad57e33028dcd962a5f81e47a0a91d3ad295fe Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 30 Mar 2020 19:59:25 +0200 Subject: [PATCH 1/9] Start implementing sort/uniq on imports/exports --- .../Haskell/Brittany/Internal/Layouters/IE.hs | 123 +++++++++++++----- 1 file changed, 93 insertions(+), 30 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index f2c36de..7e7eff1 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -11,15 +11,14 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types -import GHC ( unLoc - , runGhc - , GenLocated(L) - , moduleNameString - , AnnKeywordId(..) - , Located - ) +import GHC ( unLoc + , GenLocated(L) + , moduleNameString + , AnnKeywordId(..) + , Located + , runGhc + ) import HsSyn -import Name import HsImpExp import FieldLabel import qualified FastString @@ -70,18 +69,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] @@ -137,7 +137,13 @@ layoutAnnAndSepLLIEs :: Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered] layoutAnnAndSepLLIEs 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 = layoutIE <$> sortedLies ieCommaDocs <- docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of FirstLastEmpty -> [] @@ -145,6 +151,39 @@ 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] + | 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 + thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs + 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: @@ -163,22 +202,46 @@ layoutLLIEs :: Bool -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered layoutLLIEs enableSingleline llies = do ieDs <- layoutAnnAndSepLLIEs 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 _ _ ) -> Text.pack "IEModuleContents" + L _ (IEGroup _ _ _ ) -> Text.pack "IEGroup" + L _ (IEDoc _ _ ) -> Text.pack "IEDoc" + L _ (IEDocNamed _ _ ) -> Text.pack "IEDocNamed" + L _ (XIE _ ) -> Text.pack "XIE" From 63de13b0b484588b9d5a15836298101c37af6fbe Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 5 Apr 2020 15:27:33 +0200 Subject: [PATCH 2/9] Fix misworded comment --- src/Language/Haskell/Brittany/Internal.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 1d9266f..09c5d9d 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -647,10 +647,10 @@ layoutBriDoc briDoc = do 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_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 From 614bf3424dcd737d8f50b1a3531ad0744bb36076 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 5 Apr 2020 15:30:12 +0200 Subject: [PATCH 3/9] Minor refactoring --- .../Haskell/Brittany/Internal/Backend.hs | 12 ++++--- .../Haskell/Brittany/Internal/BackendUtils.hs | 32 +++++++++++-------- .../Brittany/Internal/LayouterBasics.hs | 5 ++- 3 files changed, 29 insertions(+), 20 deletions(-) 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/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 From 5a65ed2356983fddd26f14e6f7cc9ce40f3f82ec Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 5 Apr 2020 15:32:05 +0200 Subject: [PATCH 4/9] Comment out / Explain TODO on unused code --- .../Brittany/Internal/ExactPrintUtils.hs | 97 ++++++++++--------- 1 file changed, 49 insertions(+), 48 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 0273d85..9e22ed2 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 @@ -189,54 +188,56 @@ 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 - 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 () - -moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b) - => GHC.Located a -> GHC.Located b -> ExactPrint.Transform () -moveTrailingComments astFrom astTo = do - let - k1 = ExactPrint.mkAnnKey astFrom - k2 = ExactPrint.mkAnnKey astTo - moveComments ans = ans' - where - an1 = Data.Maybe.fromJust $ Map.lookup k1 ans - an2 = Data.Maybe.fromJust $ Map.lookup k2 ans - cs1f = ExactPrint.annFollowingComments an1 - cs2f = ExactPrint.annFollowingComments an2 - (comments, nonComments) = flip breakEither (ExactPrint.annsDP an1) - $ \case - (ExactPrint.AnnComment com, dp) -> Left (com, dp) - x -> Right x - an1' = an1 - { ExactPrint.annsDP = nonComments - , ExactPrint.annFollowingComments = [] - } - an2' = an2 - { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments - } - ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans - - ExactPrint.modifyAnnsT moveComments +-- moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b) +-- => GHC.Located a -> GHC.Located b -> ExactPrint.Transform () +-- moveTrailingComments astFrom astTo = do +-- let +-- k1 = ExactPrint.mkAnnKey astFrom +-- k2 = ExactPrint.mkAnnKey astTo +-- moveComments ans = ans' +-- where +-- an1 = Data.Maybe.fromJust $ Map.lookup k1 ans +-- an2 = Data.Maybe.fromJust $ Map.lookup k2 ans +-- cs1f = ExactPrint.annFollowingComments an1 +-- cs2f = ExactPrint.annFollowingComments an2 +-- (comments, nonComments) = flip breakEither (ExactPrint.annsDP an1) +-- $ \case +-- (ExactPrint.AnnComment com, dp) -> Left (com, dp) +-- x -> Right x +-- an1' = an1 +-- { ExactPrint.annsDP = nonComments +-- , ExactPrint.annFollowingComments = [] +-- } +-- an2' = an2 +-- { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments +-- } +-- ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans +-- +-- ExactPrint.modifyAnnsT moveComments -- | split a set of annotations in a module into a map from top-level module -- elements to the relevant annotations. Avoids quadratic behaviour a trivial From eb7a4811fda78117040d82862e466b461280e15b Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 5 Apr 2020 15:36:46 +0200 Subject: [PATCH 5/9] Implement sorting of import statements --- src/Language/Haskell/Brittany/Internal.hs | 30 ++-- .../Haskell/Brittany/Internal/Layouters/IE.hs | 36 +++-- .../Brittany/Internal/Layouters/Import.hs | 11 +- .../Brittany/Internal/Layouters/Module.hs | 149 +++++++++++++++++- 4 files changed, 193 insertions(+), 33 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 09c5d9d..dd263fa 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -645,24 +645,32 @@ layoutBriDoc briDoc = do anns :: ExactPrint.Anns <- mAsk - let state = LayoutState - { _lstate_baseYs = [0] - , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left + 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 - } + , _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/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 7e7eff1..c27b6c2 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 , AnnKeywordId(..) , Located , runGhc + , ModuleName ) import HsSyn import HsImpExp @@ -126,6 +128,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of | otherwise -> name #endif +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. @@ -134,8 +137,8 @@ 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 sortedLies = [ items @@ -143,7 +146,9 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do $ List.sortOn lieToText lies , items <- mergeGroup group ] - let ieDocs = layoutIE <$> sortedLies + let ieDocs = fmap layoutIE $ case shouldSort of + ShouldSortItems -> sortedLies + KeepItemsUnsorted -> lies ieCommaDocs <- docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of FirstLastEmpty -> [] @@ -157,6 +162,7 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do 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 @@ -167,7 +173,12 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do 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 @@ -198,9 +209,9 @@ 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 @@ -240,8 +251,11 @@ lieToText = \case -- 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 _ _ ) -> Text.pack "IEModuleContents" - L _ (IEGroup _ _ _ ) -> Text.pack "IEGroup" - L _ (IEDoc _ _ ) -> Text.pack "IEDoc" - L _ (IEDocNamed _ _ ) -> Text.pack "IEDocNamed" - L _ (XIE _ ) -> Text.pack "XIE" + 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 bcce106..fc150b9 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -17,6 +17,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 @@ -41,8 +42,8 @@ prepModName :: e -> e prepModName = id #endif -layoutImport :: ToBriDoc ImportDecl -layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of +layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered +layoutImport importD = case importD of #if MIN_VERSION_ghc(8,6,0) ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do #else @@ -92,14 +93,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 f899e08..f75fd38 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" @@ -25,8 +27,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 @@ -48,7 +58,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" ] @@ -57,13 +67,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 HsSyn.GhcPs + } + +instance Show ImportStatementRecord where + show r = "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show + (length $ commentsAfter r) + +transformToCommentedImport + :: [LImportDecl HsSyn.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 HsSyn.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) From 93ea6542cc8b8b2a9af59602f123e5a03588a281 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 7 Apr 2020 15:01:08 +0200 Subject: [PATCH 6/9] Fix existing tests for new import layouter behaviour --- src-literatetests/10-tests.blt | 71 ++++++++++----------- src-literatetests/14-extensions.blt | 2 +- src-literatetests/30-tests-context-free.blt | 34 +++++----- 3 files changed, 53 insertions(+), 54 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index b1ccfb6..84a638c 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 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 18649a1..07c94dc 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) From 1e5b8ada4ea9fa45cf3e36907e848a2f47d435d3 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 7 Apr 2020 15:18:27 +0200 Subject: [PATCH 7/9] Fix ghc version compat --- .../Haskell/Brittany/Internal/Layouters/IE.hs | 39 +++++++++++++++++++ .../Brittany/Internal/Layouters/Module.hs | 13 +++++-- 2 files changed, 48 insertions(+), 4 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index c27b6c2..c215fa5 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -168,11 +168,19 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do -- (because I don't know what a wildcard means if it is not already a -- IEThingAll). isProperIEThing :: LIE GhcPs -> Bool +#if MIN_VERSION_ghc(8,6,0) /* 8.6+ */ isProperIEThing = \case L _ (IEThingAbs _ _wn) -> True L _ (IEThingAll _ _wn) -> True L _ (IEThingWith _ _wn NoIEWildcard _ _) -> True _ -> False +#else /* 8.0 8.2 8.4 */ + isProperIEThing = \case + L _ (IEThingAbs _wn) -> True + L _ (IEThingAll _wn) -> True + L _ (IEThingWith _wn NoIEWildcard _ _) -> True + _ -> False +#endif isIEVar :: LIE GhcPs -> Bool isIEVar = \case L _ IEVar{} -> True @@ -183,6 +191,7 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do thingFolder _ l2@(L _ IEThingAll{}) = l2 thingFolder l1 ( L _ IEThingAbs{}) = l1 thingFolder (L _ IEThingAbs{}) l2 = l2 +#if MIN_VERSION_ghc(8,6,0) /* 8.6+ */ thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2)) = L l @@ -192,6 +201,16 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do (consItems1 ++ consItems2) (fieldLbls1 ++ fieldLbls2) ) +#else /* 8.0 8.2 8.4 */ + thingFolder (L l (IEThingWith wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ consItems2 fieldLbls2)) + = L + l + (IEThingWith wn + NoIEWildcard + (consItems1 ++ consItems2) + (fieldLbls1 ++ fieldLbls2) + ) +#endif thingFolder _ _ = error "thingFolder should be exhaustive because we have a guard above" @@ -234,15 +253,21 @@ layoutLLIEs enableSingleline shouldSort llies = do -- | 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. +#if MIN_VERSION_ghc(8,2,0) wrappedNameToText :: LIEWrappedName RdrName -> Text wrappedNameToText = \case L _ (IEName n) -> lrdrNameToText n L _ (IEPattern n) -> lrdrNameToText n L _ (IEType n) -> lrdrNameToText n +#else +wrappedNameToText :: Located RdrName -> Text +wrappedNameToText = lrdrNameToText +#endif -- | 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 +#if MIN_VERSION_ghc(8,6,0) /* 8.6+ */ lieToText = \case L _ (IEVar _ wn ) -> wrappedNameToText wn L _ (IEThingAbs _ wn ) -> wrappedNameToText wn @@ -256,6 +281,20 @@ lieToText = \case L _ (IEDoc _ _ ) -> Text.pack "@IEDoc" L _ (IEDocNamed _ _ ) -> Text.pack "@IEDocNamed" L _ (XIE _ ) -> Text.pack "@XIE" +#else /* 8.0 8.2 8.4 */ +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" +#endif where moduleNameToText :: Located ModuleName -> Text moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index f75fd38..675acf5 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -18,7 +18,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 @@ -95,7 +100,7 @@ instance Show CommentedImport where data ImportStatementRecord = ImportStatementRecord { commentsBefore :: [(Comment, DeltaPos)] , commentsAfter :: [(Comment, DeltaPos)] - , importStatement :: ImportDecl HsSyn.GhcPs + , importStatement :: ImportDecl GhcPs } instance Show ImportStatementRecord where @@ -103,7 +108,7 @@ instance Show ImportStatementRecord where (length $ commentsAfter r) transformToCommentedImport - :: [LImportDecl HsSyn.GhcPs] -> ToBriDocM [CommentedImport] + :: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport] transformToCommentedImport is = do nodeWithAnnotations <- is `forM` \i@(L _ rawImport) -> do annotionMay <- astAnn i @@ -113,7 +118,7 @@ transformToCommentedImport is = do replicate (y - 1) EmptyLine ++ [IndependentComment (c, DP (1, x))] accumF :: [(Comment, DeltaPos)] - -> (Maybe Annotation, ImportDecl HsSyn.GhcPs) + -> (Maybe Annotation, ImportDecl GhcPs) -> ([(Comment, DeltaPos)], [CommentedImport]) accumF accConnectedComm (annMay, decl) = case annMay of Nothing -> From 9efed95d50ce21290540b7fea2d41fbec2fcb680 Mon Sep 17 00:00:00 2001 From: Joe Hermaszewski Date: Fri, 20 Nov 2020 23:03:59 +0800 Subject: [PATCH 8/9] Add tests for import sorting --- src-literatetests/10-tests.blt | 23 +++++++++++++++++++++++ src-literatetests/Main.hs | 4 ++++ 2 files changed, 27 insertions(+) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 84a638c..806dd47 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -1294,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/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 From 8a88e1062520cd8fef5c5a1eda4f35ec39944f6c Mon Sep 17 00:00:00 2001 From: Joe Hermaszewski Date: Fri, 11 Dec 2020 17:08:57 +0800 Subject: [PATCH 9/9] Drop CPP for no-longer-supported GHC versions --- .../Haskell/Brittany/Internal/Layouters/IE.hs | 40 +------------------ 1 file changed, 1 insertion(+), 39 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 8405d4d..2a722d1 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -134,19 +134,11 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do -- (because I don't know what a wildcard means if it is not already a -- IEThingAll). isProperIEThing :: LIE GhcPs -> Bool -#if MIN_VERSION_ghc(8,6,0) /* 8.6+ */ isProperIEThing = \case L _ (IEThingAbs _ _wn) -> True L _ (IEThingAll _ _wn) -> True L _ (IEThingWith _ _wn NoIEWildcard _ _) -> True _ -> False -#else /* 8.0 8.2 8.4 */ - isProperIEThing = \case - L _ (IEThingAbs _wn) -> True - L _ (IEThingAll _wn) -> True - L _ (IEThingWith _wn NoIEWildcard _ _) -> True - _ -> False -#endif isIEVar :: LIE GhcPs -> Bool isIEVar = \case L _ IEVar{} -> True @@ -157,7 +149,6 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do thingFolder _ l2@(L _ IEThingAll{}) = l2 thingFolder l1 ( L _ IEThingAbs{}) = l1 thingFolder (L _ IEThingAbs{}) l2 = l2 -#if MIN_VERSION_ghc(8,6,0) /* 8.6+ */ thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2)) = L l @@ -167,16 +158,6 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do (consItems1 ++ consItems2) (fieldLbls1 ++ fieldLbls2) ) -#else /* 8.0 8.2 8.4 */ - thingFolder (L l (IEThingWith wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ consItems2 fieldLbls2)) - = L - l - (IEThingWith wn - NoIEWildcard - (consItems1 ++ consItems2) - (fieldLbls1 ++ fieldLbls2) - ) -#endif thingFolder _ _ = error "thingFolder should be exhaustive because we have a guard above" @@ -219,21 +200,16 @@ layoutLLIEs enableSingleline shouldSort llies = do -- | 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. -#if MIN_VERSION_ghc(8,2,0) wrappedNameToText :: LIEWrappedName RdrName -> Text wrappedNameToText = \case L _ (IEName n) -> lrdrNameToText n L _ (IEPattern n) -> lrdrNameToText n L _ (IEType n) -> lrdrNameToText n -#else -wrappedNameToText :: Located RdrName -> Text -wrappedNameToText = lrdrNameToText -#endif + -- | 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 -#if MIN_VERSION_ghc(8,6,0) /* 8.6+ */ lieToText = \case L _ (IEVar _ wn ) -> wrappedNameToText wn L _ (IEThingAbs _ wn ) -> wrappedNameToText wn @@ -247,20 +223,6 @@ lieToText = \case L _ (IEDoc _ _ ) -> Text.pack "@IEDoc" L _ (IEDocNamed _ _ ) -> Text.pack "@IEDocNamed" L _ (XIE _ ) -> Text.pack "@XIE" -#else /* 8.0 8.2 8.4 */ -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" -#endif where moduleNameToText :: Located ModuleName -> Text moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name)