@@ -4,78 +4,176 @@
44
55-- | Manipulations on import lists.
66module Ormolu.Imports
7− ( sortImports,
7+ ( normalizeImports,
88 )
99where
1010
1111import Data.Bifunctor
1212import Data.Char (isAlphaNum)
1313import Data.Function (on)
14−import Data.Generics (gcompare)
15−import Data.List (nubBy, sortBy)
14+import Data.List (foldl', nubBy, sortBy, sortOn)
15+import Data.Map.Strict (Map)
16+import qualified Data.Map.Strict as M
17+import FastString (FastString)
1618import GHC hiding (GhcPs, IE)
1719import GHC.Hs.Extension
1820import GHC.Hs.ImpExp (IE (..))
1921import Ormolu.Utils (notImplemented, showOutputable)
2022
21−-- | Sort imports by module name. This also sorts explicit import lists for
22−-- each declaration.
23−sortImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs]
24−sortImports = sortBy compareIdecl . fmap (fmap sortImportLists)
23+-- | Sort and normalize imports.
24+normalizeImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs]
25+normalizeImports =
26+ fmap snd
27+ . M.toAscList
28+ . M.fromListWith combineImports
29+ . fmap (\x -> (importId x, g x))
2530 where
26− sortImportLists :: ImportDecl GhcPs -> ImportDecl GhcPs
27− sortImportLists = \case
28− ImportDecl {..} ->
31+ g (L l ImportDecl {..}) =
32+ L
33+ l
2934 ImportDecl
30− { ideclHiding = second (fmap sortLies) <$> ideclHiding,
35+ { ideclHiding = second (fmap normalizeLies) <$> ideclHiding,
3136 ..
3237 }
33− XImportDecl x -> noExtCon x
38+ g _ = notImplemented "XImportDecl"
3439
35−-- | Compare two @'LImportDecl' 'GhcPs'@ things.
36−compareIdecl :: LImportDecl GhcPs -> LImportDecl GhcPs -> Ordering
37−compareIdecl (L _ m0) (L _ m1) =
38− case (isPrelude n0, isPrelude n1) of
39− (False, False) -> n0 `compare` n1
40− (True, False) -> GT
41− (False, True) -> LT
42− (True, True) -> m0 `gcompare` m1
40+-- | Combine two import declarations. It should be assumed that 'ImportId's
41+-- are equal.
42+combineImports ::
43+ LImportDecl GhcPs ->
44+ LImportDecl GhcPs ->
45+ LImportDecl GhcPs
46+combineImports (L lx ImportDecl {..}) (L _ y) =
47+ L
48+ lx
49+ ImportDecl
50+ { ideclHiding = case (ideclHiding, GHC.ideclHiding y) of
51+ (Just (hiding, L l' xs), Just (_, L _ ys)) ->
52+ Just (hiding, (L l' (normalizeLies (xs ++ ys))))
53+ _ -> Nothing,
54+ ..
55+ }
56+combineImports _ _ = notImplemented "XImportDecl"
57+
58+-- | Import id, a collection of all things that justify having a separate
59+-- import entry. This is used for merging of imports. If two imports have
60+-- the same 'ImportId' they can be merged.
61+data ImportId = ImportId
62+ { importIsPrelude :: Bool,
63+ importIdName :: ModuleName,
64+ importPkgQual :: Maybe FastString,
65+ importSource :: Bool,
66+ importSafe :: Bool,
67+ importQualified :: Bool,
68+ importImplicit :: Bool,
69+ importAs :: Maybe ModuleName,
70+ importHiding :: Maybe Bool
71+ }
72+ deriving (Eq, Ord)
73+
74+-- | Obtain an 'ImportId' for a given import.
75+importId :: LImportDecl GhcPs -> ImportId
76+importId (L _ ImportDecl {..}) =
77+ ImportId
78+ { importIsPrelude = isPrelude,
79+ importIdName = moduleName,
80+ importPkgQual = sl_fs <$> ideclPkgQual,
81+ importSource = ideclSource,
82+ importSafe = ideclSafe,
83+ importQualified = case ideclQualified of
84+ QualifiedPre -> True
85+ QualifiedPost -> True
86+ NotQualified -> False,
87+ importImplicit = ideclImplicit,
88+ importAs = unLoc <$> ideclAs,
89+ importHiding = fst <$> ideclHiding
90+ }
4391 where
44− n0 = unLoc (ideclName m0)
45− n1 = unLoc (ideclName m1)
46− isPrelude = (== "Prelude") . moduleNameString
92+ isPrelude = moduleNameString moduleName == "Prelude"
93+ moduleName = unLoc ideclName
94+importId _ = notImplemented "XImportDecl"
4795
48−-- | Sort located import or export, dropping duplicates.
49−sortLies :: [LIE GhcPs] -> [LIE GhcPs]
50−sortLies =
51− nubBy (\x y -> compareLIE x y == EQ)
52− . sortBy compareLIE
53− . fmap (fmap sortThings)
96+-- | Normalize a collection of import\/export items.
97+normalizeLies :: [LIE GhcPs] -> [LIE GhcPs]
98+normalizeLies = sortOn (getIewn . unLoc) . M.elems . foldl' combine M.empty
99+ where
100+ combine ::
101+ Map IEWrappedNameOrd (LIE GhcPs) ->
102+ LIE GhcPs ->
103+ Map IEWrappedNameOrd (LIE GhcPs)
104+ combine m (L new_l new) =
105+ let wname = getIewn new
106+ normalizeWNames =
107+ nubBy (\x y -> compareLIewn x y == EQ) . sortBy compareLIewn
108+ alter = \case
109+ Nothing -> Just . L new_l $
110+ case new of
111+ IEThingWith NoExtField n wildcard g flbl ->
112+ IEThingWith NoExtField n wildcard (normalizeWNames g) flbl
113+ other -> other
114+ Just old ->
115+ let f = \case
116+ IEVar NoExtField n -> IEVar NoExtField n
117+ IEThingAbs NoExtField _ -> new
118+ IEThingAll NoExtField n -> IEThingAll NoExtField n
119+ IEThingWith NoExtField n wildcard g flbl ->
120+ case new of
121+ IEVar NoExtField _ ->
122+ error "Ormolu.Imports broken presupposition"
123+ IEThingAbs NoExtField _ ->
124+ IEThingWith NoExtField n wildcard g flbl
125+ IEThingAll NoExtField n' ->
126+ IEThingAll NoExtField n'
127+ IEThingWith NoExtField n' wildcard' g' flbl' ->
128+ let combinedWildcard =
129+ case (wildcard, wildcard') of
130+ (IEWildcard _, _) -> IEWildcard 0
131+ (_, IEWildcard _) -> IEWildcard 0
132+ _ -> NoIEWildcard
133+ in IEThingWith
134+ NoExtField
135+ n'
136+ combinedWildcard
137+ (normalizeWNames (g <> g'))
138+ flbl'
139+ IEModuleContents NoExtField _ -> notImplemented "IEModuleContents"
140+ IEGroup NoExtField _ _ -> notImplemented "IEGroup"
141+ IEDoc NoExtField _ -> notImplemented "IEDoc"
142+ IEDocNamed NoExtField _ -> notImplemented "IEDocNamed"
143+ XIE x -> noExtCon x
144+ IEModuleContents NoExtField _ -> notImplemented "IEModuleContents"
145+ IEGroup NoExtField _ _ -> notImplemented "IEGroup"
146+ IEDoc NoExtField _ -> notImplemented "IEDoc"
147+ IEDocNamed NoExtField _ -> notImplemented "IEDocNamed"
148+ XIE x -> noExtCon x
149+ in Just (f <$> old)
150+ in M.alter alter wname m
54151
55−-- | Sort imports\/exports inside of 'IEThingWith'.
56−sortThings :: IE GhcPs -> IE GhcPs
57−sortThings = \case
58− IEThingWith NoExtField x w xs fl ->
59− IEThingWith NoExtField x w (sortBy (compareIewn `on` unLoc) xs) fl
60− other -> other
152+-- | A wrapper for @'IEWrappedName' 'RdrName'@ that allows us to define an
153+-- 'Ord' instance for it.
154+newtype IEWrappedNameOrd = IEWrappedNameOrd (IEWrappedName RdrName)
155+ deriving (Eq)
61156
62−-- | Compare a pair of located imports or exports.
63−compareLIE :: LIE GhcPs -> LIE GhcPs -> Ordering
64−compareLIE = compareIewn `on` getIewn . unLoc
157+instance Ord IEWrappedNameOrd where
158+ compare (IEWrappedNameOrd x) (IEWrappedNameOrd y) = compareIewn x y
65159
66160-- | Project @'IEWrappedName' 'RdrName'@ from @'IE' 'GhcPs'@.
67−getIewn :: IE GhcPs -> IEWrappedName RdrName
161+getIewn :: IE GhcPs -> IEWrappedNameOrd
68162getIewn = \case
69− IEVar NoExtField x -> unLoc x
70− IEThingAbs NoExtField x -> unLoc x
71− IEThingAll NoExtField x -> unLoc x
72− IEThingWith NoExtField x _ _ _ -> unLoc x
163+ IEVar NoExtField x -> IEWrappedNameOrd (unLoc x)
164+ IEThingAbs NoExtField x -> IEWrappedNameOrd (unLoc x)
165+ IEThingAll NoExtField x -> IEWrappedNameOrd (unLoc x)
166+ IEThingWith NoExtField x _ _ _ -> IEWrappedNameOrd (unLoc x)
73167 IEModuleContents NoExtField _ -> notImplemented "IEModuleContents"
74168 IEGroup NoExtField _ _ -> notImplemented "IEGroup"
75169 IEDoc NoExtField _ -> notImplemented "IEDoc"
76170 IEDocNamed NoExtField _ -> notImplemented "IEDocNamed"
77171 XIE x -> noExtCon x
78172
173+-- | Like 'compareIewn' for located wrapped names.
174+compareLIewn :: LIEWrappedName RdrName -> LIEWrappedName RdrName -> Ordering
175+compareLIewn = compareIewn `on` unLoc
176+
79177-- | Compare two @'IEWrapppedName' 'RdrName'@ things.
80178compareIewn :: IEWrappedName RdrName -> IEWrappedName RdrName -> Ordering
81179compareIewn (IEName x) (IEName y) = unLoc x `compareRdrName` unLoc y