diff --git a/data/10-structured/module-imports.blt b/data/10-structured/module-imports.blt index 9c333a5..970e1d8 100644 --- a/data/10-structured/module-imports.blt +++ b/data/10-structured/module-imports.blt @@ -183,9 +183,9 @@ import Test ( -- comment ) #test long-bindings -import Test ( longbindingNameThatoverflowsColum +import TestA ( longbindingNameThatoverflowsColum ) -import Test ( Long +import TestB ( Long ( List , Of , Things diff --git a/data/12-features/import-merging.blt b/data/12-features/import-merging.blt new file mode 100644 index 0000000..77a746a --- /dev/null +++ b/data/12-features/import-merging.blt @@ -0,0 +1,45 @@ +#group feature/import-merging + + +#golden merge imports down to constructor-level +import Data.Bool ( Bool(True) ) +import Data.Bool ( Bool(False) ) +#expected +import Data.Bool ( Bool(False, True) ) + +#golden wildcard trumps explicit+hiding +import Data.Map ( Map ) +import Data.Map +import Data.Map hiding ( toList ) +#expected +import Data.Map + +#golden explicit+hiding do not merge for now +import Data.Map ( Map ) +import Data.Map hiding ( toList ) +#expected +import Data.Map ( Map ) +import Data.Map hiding ( toList ) + +#golden hiding+hiding do not merge for now +import Data.Map hiding ( toList ) +import Data.Map hiding ( fromList ) +#expected +import Data.Map hiding ( toList ) +import Data.Map hiding ( fromList ) + +#golden qualified and qualified-as merge but separately +import qualified Data.Map ( toList ) +import qualified Data.Map ( fromList ) +import qualified Data.Map as M + ( Map ) +import qualified Data.Map as M + ( take ) +#expected +import qualified Data.Map ( fromList + , toList + ) +import qualified Data.Map as M + ( Map + , take + ) diff --git a/data/30-tests-context-free.blt b/data/30-tests-context-free.blt index 3f43822..9971af3 100644 --- a/data/30-tests-context-free.blt +++ b/data/30-tests-context-free.blt @@ -848,8 +848,8 @@ import Test ) #test long-bindings -import Test (longbindingNameThatoverflowsColum) -import Test (Long(List, Of, Things)) +import TestA (longbindingNameThatoverflowsColum) +import TestB (Long(List, Of, Things)) #test things-with-with-comments import Test diff --git a/source/library/Language/Haskell/Brittany/Internal/SplitExactModule.hs b/source/library/Language/Haskell/Brittany/Internal/SplitExactModule.hs index 9f1e64b..71110be 100644 --- a/source/library/Language/Haskell/Brittany/Internal/SplitExactModule.hs +++ b/source/library/Language/Haskell/Brittany/Internal/SplitExactModule.hs @@ -47,6 +47,7 @@ import GHC ( AddEpAnn(AddEpAnn) ) , SrcSpanAnn'(SrcSpanAnn) , anchor + , getLoc , ideclName , moduleName , moduleNameString @@ -63,6 +64,7 @@ import GHC.Types.Name.Reader ( RdrName , Unqual ) ) +import GHC.Types.SourceText ( SourceText(NoSourceText) ) import qualified GHC.OldList as List import GHC.Parser.Annotation ( DeltaPos ( DifferentLine @@ -88,16 +90,15 @@ import Language.Haskell.Brittany.Internal.Types extractDeclMap :: GHC.ParsedSource -> Map GHC.RealSrcSpan [String] -extractDeclMap modul = - Map.fromList - [ ( case span of - GHC.RealSrcSpan s _ -> s - GHC.UnhelpfulSpan _ -> error "unexpected UnhelpfulSpan" - , getDeclBindingNames decl - ) - | decl <- decls - , let (L (GHC.SrcSpanAnn _ span) _) = decl - ] +extractDeclMap modul = Map.fromList + [ ( case span of + GHC.RealSrcSpan s _ -> s + GHC.UnhelpfulSpan _ -> error "unexpected UnhelpfulSpan" + , getDeclBindingNames decl + ) + | decl <- decls + , let (L (GHC.SrcSpanAnn _ span) _) = decl + ] where (L _ (GHC.HsModule _ _ _ _ _ decls _ _)) = modul splitModuleDecls :: GHC.ParsedSource -> FinalList ModuleElement ExactPrint.Pos @@ -140,7 +141,7 @@ splitModuleDecls lmod = do spanAfterImports <- do finalYield $ MEExactModuleHead moduleWithoutComments pure - $ maybe (0, 1) (ExactPrint.ss2posEnd) + $ maybe (0, 1) ExactPrint.ss2posEnd $ maximumMay $ [ GHC.anchor a | L a _ <- GHC.priorComments $ case hsModAnn' of @@ -265,7 +266,7 @@ enrichDecls lastSpanEnd = \case data ImportLine = EmptyLines Int | SamelineComment (Int, LEpaComment) - | NewlineComment (Int, LEpaComment) -- indentation and comment + | NewlineComment (Int, LEpaComment) -- indentation and comment | ImportStatement ImportStatementRecord instance Show ImportLine where @@ -274,8 +275,10 @@ instance Show ImportLine where SamelineComment{} -> "SamelineComment" NewlineComment{} -> "NewlineComment" ImportStatement r -> - "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show - (length $ commentsAfter r) + "ImportStatement " + ++ show (length $ commentsBefore r) + ++ " " + ++ show (length $ commentsAfter r) data ImportStatementRecord = ImportStatementRecord { commentsBefore :: [(Int, LEpaComment)] @@ -286,8 +289,10 @@ data ImportStatementRecord = ImportStatementRecord instance Show ImportStatementRecord where show r = - "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show - (length $ commentsAfter r) + "ImportStatement " + ++ show (length $ commentsBefore r) + ++ " " + ++ show (length $ commentsAfter r) transformToImportLine @@ -341,8 +346,9 @@ transformToImportLine startPos is = in flattenDecls is startPos -data Partial = PartialCommsOnly [(Int, LEpaComment)] - | PartialImport ImportStatementRecord +data Partial + = PartialCommsOnly [(Int, LEpaComment)] + | PartialImport ImportStatementRecord groupifyImportLines :: [ImportLine] -> [ImportLine] groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls @@ -404,40 +410,90 @@ groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls sortCommentedImports :: [ImportLine] -> [ImportLine] sortCommentedImports = - -- TODO92 we don't need this unpackImports, it is implied later in the process - mergeGroups . map (fmap (sortGroups)) . groupify + mergeGroups . map (fmap (combineImports . sortGroups)) . groupify where - -- unpackImports :: [ImportLine] -> [ImportLine] - -- unpackImports xs = xs >>= \case - -- l@EmptyLines{} -> [l] - -- l@NewlineComment{} -> [l] - -- l@SamelineComment{} -> [l] - -- ImportStatement r -> - -- map NewlineComment (commentsBefore r) ++ [ImportStatement r] ++ map - -- NewlineComment - -- (commentsAfter r) mergeGroups :: [Either ImportLine [ImportStatementRecord]] -> [ImportLine] mergeGroups xs = xs >>= \case - Left x -> [x] + Left x -> [x] Right y -> ImportStatement <$> y sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord] sortGroups = List.sortOn (moduleNameString . unLoc . ideclName . unLoc . importStatement) + combineImports :: [ImportStatementRecord] -> [ImportStatementRecord] + combineImports = go Nothing + where + go Nothing [] = [] + go (Just r1) [] = [r1] + go Nothing (r2 : rs) = go (Just r2) rs + go (Just r1) (r2 : rs) = case (unpack r1, unpack r2) of + (Nothing, _) -> r1 : go (Just r2) rs + (_, Nothing) -> r1 : go (Just r2) rs + (Just u1, Just u2) -> + let + (modName1, pkg1, src1, safe1, q1, alias1, mllies1) = u1 + (modName2, pkg2, src2, safe2, q2, alias2, mllies2) = u2 + inner1 = GHC.unLoc $ importStatement r1 + mostThingsEqual = + modName1 == modName2 + && pkg1 == pkg2 + && src1 == src2 + && safe1 == safe2 + && ((q1 == GHC.NotQualified) == (q2 == GHC.NotQualified)) + && (unLoc <$> alias1) == (unLoc <$> alias2) + merged explicits = + go + (Just ImportStatementRecord + { commentsBefore = commentsBefore r1 ++ commentsBefore r2 + , importStatement = + L (getLoc $ importStatement r1) GHC.ImportDecl + { GHC.ideclExt = GHC.ideclExt inner1 + , GHC.ideclSourceSrc = NoSourceText + , GHC.ideclName = GHC.ideclName inner1 + , GHC.ideclPkgQual = pkg1 + , GHC.ideclSource = src1 + , GHC.ideclSafe = safe1 + , GHC.ideclQualified = q1 + , GHC.ideclImplicit = False + , GHC.ideclAs = alias1 + , GHC.ideclHiding = explicits + } + , commentsSameline = + (commentsSameline r1 ++ commentsSameline r2) + , commentsAfter = commentsAfter r1 ++ commentsAfter r2 + } + ) + rs + in case (mostThingsEqual, mllies1, mllies2) of + (True, Nothing, _) -> merged Nothing + (True, _, Nothing) -> merged Nothing + (True, Just (False, l1), Just (False, l2)) -> merged + (Just (False, L (getLoc l1) (unLoc l1 ++ unLoc l2))) + _ -> r1 : go (Just r2) rs + unpack x = case unLoc $ importStatement x of + GHC.ImportDecl _ _ (L _ modName) pkg src safe q False alias mllies -> + case mllies of + Nothing -> Just (modName, pkg, src, safe, q, alias, Nothing) + Just (_, (L ann _)) -> case GHC.comments $ GHC.ann ann of + EpaComments [] -> Just (modName, pkg, src, safe, q, alias, mllies) + EpaCommentsBalanced [] [] -> Just + (modName, pkg, src, safe, q, alias, mllies) + _ -> Nothing + _ -> Nothing groupify :: [ImportLine] -> [Either ImportLine [ImportStatementRecord]] groupify cs = go [] cs where go [] = \case - (l@EmptyLines{} : rest) -> Left l : go [] rest - (l@NewlineComment{} : rest) -> Left l : go [] rest + (l@EmptyLines{} : rest) -> Left l : go [] rest + (l@NewlineComment{} : rest) -> Left l : go [] rest (l@SamelineComment{} : rest) -> Left l : go [] rest - (ImportStatement r : rest) -> go [r] rest - [] -> [] + (ImportStatement r : rest) -> go [r] rest + [] -> [] go acc = \case - (l@EmptyLines{} : rest) -> Right (reverse acc) : Left l : go [] rest - (l@NewlineComment{} : rest) -> Left l : Right (reverse acc) : go [] rest + (l@EmptyLines{} : rest) -> Right (reverse acc) : Left l : go [] rest + (l@NewlineComment{} : rest) -> Left l : Right (reverse acc) : go [] rest (l@SamelineComment{} : rest) -> Left l : Right (reverse acc) : go [] rest - (ImportStatement r : rest) -> go (r : acc) rest - [] -> [Right (reverse acc)] + (ImportStatement r : rest) -> go (r : acc) rest + [] -> [Right (reverse acc)] rdrNameToText :: RdrName -> Text -- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr @@ -450,7 +506,7 @@ rdrNameToText (Exact name) = Text.pack $ getOccString name getDeclBindingNames :: GHC.LHsDecl GhcPs -> [String] getDeclBindingNames (L _ decl) = case decl of - GHC.SigD _ (GHC.TypeSig _ ns _) -> - ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) + GHC.SigD _ (GHC.TypeSig _ ns _) -> ns <&> \(L _ n) -> + Text.unpack (rdrNameToText n) GHC.ValD _ (GHC.FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n] _ -> []