Sorted explicit import

plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs

@@ -18,9 +18,11 @@
 
 import           Control.Monad
 import           Control.Monad.Trans
+import           Control.Applicative                     ((<|>))
 import           Data.Char                              (isAlphaNum)
 import           Data.Data                              (Data)
 import           Data.Generics                          (listify)
+import           Data.List                              (sortOn)
 import qualified Data.Text                              as T
 import           Development.IDE.GHC.Compat             hiding (Annotation)
 import           Development.IDE.GHC.Error
@@ -34,11 +36,16 @@
 
 import           Control.Lens                           (_head, _last, over)
 import           Data.Bifunctor                         (first)
-import           Data.Maybe                             (fromMaybe, mapMaybe)
+import           Data.Maybe                             (fromMaybe, isJust,
+                                                         listToMaybe, mapMaybe)
 import           Development.IDE.Plugin.CodeAction.Util
 import           GHC                                    (AnnContext (..),
                                                          AnnList (..),
-                                                         DeltaPos (SameLine),
+#if !MIN_VERSION_ghc(9,9,0)
+                                                         Anchor (..),
+                                                         AnchorOperation (MovedAnchor),
+#endif
+                                                         DeltaPos (..),
                                                          EpAnn (..),
                                                          IsUnicodeSyntax (NormalSyntax),
                                                          NameAdornment (NameParens),
@@ -67,6 +74,7 @@
 
 #if MIN_VERSION_ghc(9,9,0)
 import           GHC                                    (NoAnn (..))
+import           GHC                                    (EpaLocation' (..))
 import           GHC                                    (EpAnnComments (..))
 #endif
 
@@ -306,7 +314,7 @@
     if x `elem` lies
       then TransformT $ lift (Left $ thing <> " already imported")
       else do
-        let lies' = addCommaInImportList lies x
+        let lies' = addSortedInImportListBy importItemSortKey lies x
         return $ L l it{ideclImportList = Just (hide, L l' lies')}
 extendImportTopLevel _ _ = TransformT $ lift $ Left "Unable to extend the import list"
 
@@ -397,10 +405,8 @@
             lies = L l' $ reverse pre ++ [L l'' thing] ++ xs
         return $ L l it'
     | parent == unIEWrappedName ie = do
-        let hasSibling = not $ null lies'
         srcChild <- uniqueSrcSpanT
         let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child
-        childRdr <- pure $ setEntryDP childRdr $ SameLine $ if hasSibling then 1 else 0
         let alreadyImported =
               printOutputable (occName (unLoc childRdr))
                 `elem` map (printOutputable @OccName) (listify (const True) lies')
@@ -412,12 +418,11 @@
                                                childRdr
         let it' = it{ideclImportList = Just (hide, lies)}
             lies = L l' $ reverse pre ++
-                [L l'' (IEThingWith l''' twIE NoIEWildcard (over _last fixLast lies' ++ [childLIE])
+                [L l'' (IEThingWith l''' twIE NoIEWildcard (addSortedInImportListBy wrappedNameSortKey lies' childLIE)
 #if MIN_VERSION_ghc(9,9,0)
                                     docs
 #endif
                        )] ++ xs
-            fixLast = if hasSibling then first addComma else id
         return $ L l it'
   go hide l' pre (x : xs) = go hide l' (x : pre) xs
   go hide l' pre [] = do
@@ -460,10 +465,123 @@
                                                         Nothing -- TODO preserve docs?
 #endif
 
-          lies' = addCommaInImportList (reverse pre) x
+          lies' = addSortedInImportListBy importItemSortKey (reverse pre) x
       return $ L l it{ideclImportList = Just (hide, L l' lies')}
 extendImportViaParent _ _ _ _ = TransformT $ lift $ Left "Unable to extend the import list via parent"
 
+-- | Insert a new import item, sort the explicit import list, and then render
+-- the whole list in one of two normalized layouts:
+--
+-- * Single-line input stays single-line: @( a, b, c )@
+-- * Multi-line input becomes one-item-per-line:
+--   @( a,\n  b,\n  c )@
+
+addSortedInImportListBy ::
+  Ord key =>
+  (LocatedAn AnnListItem a -> key) ->
+  [LocatedAn AnnListItem a] ->
+  LocatedAn AnnListItem a ->
+  [LocatedAn AnnListItem a]
+addSortedInImportListBy sortKey lies x =
+  normalizeSortedImportList wasMultiLine continuationIndent (sortOn sortKey extended)
+  where
+    extended = addCommaInImportList lies x
+    wasMultiLine = isMultiLineImportList lies
+    continuationIndent = continuationIndentFromImportList lies
+
+-- | Rewrite a sorted import list into a normalized layout.
+-- Commas are assigned after every item except the last .
+normalizeSortedImportList :: Bool -> Int -> [LocatedAn AnnListItem a] -> [LocatedAn AnnListItem a]
+normalizeSortedImportList _ _ [] = []
+normalizeSortedImportList wasMultiLine continuationIndent items =
+  zipWith applyLayout [0 ..] items
+  where
+    lastIndex = length items - 1
+    trailingCommaFor index = index < lastIndex
+
+    applyLayout index =
+      first updateComma . (`setEntryDP` deltaFor index)
+      where
+        updateComma = (if trailingCommaFor index then addComma else id) . removeComma
+
+    deltaFor index
+      | index == 0 = SameLine 0
+      | wasMultiLine = DifferentLine 1 continuationIndent
+      | otherwise = SameLine 1
+
+-- | Detect whether the original import list was multi-line. If any item starts
+-- on a different line from the previous one, we normalize the final result to
+-- the forced one-item-per-line layout.
+isMultiLineImportList :: [LocatedAn AnnListItem a] -> Bool
+isMultiLineImportList = any (isJust . importItemLayout)
+
+continuationIndentFromImportList :: [LocatedAn AnnListItem a] -> Int
+continuationIndentFromImportList = fromMaybe 2 . listToMaybe . mapMaybe importItemLayout
+
+-- | Read layout information from a single import item.
+--
+-- 'Nothing' means the item remains on the same line as the previous one.
+-- 'Just col' means the item starts on a new line with continuation indent
+-- column @col@.
+importItemLayout :: LocatedAn AnnListItem a -> Maybe Int
+#if MIN_VERSION_ghc(9,11,0)
+importItemLayout (L srcAnn _) = case srcAnn of
+  EpAnn anchor _ _ -> continuationIndentFromAnchor anchor
+  EpAnnNotUsed     -> Nothing
+#elif MIN_VERSION_ghc(9,9,0)
+importItemLayout (L srcAnn _) = case srcAnn of
+  EpAnn anchor _ _ -> continuationIndentFromAnchor anchor
+  EpAnnNotUsed     -> Nothing
+#else
+importItemLayout (L srcAnn _) = case ann srcAnn of
+  EpAnn Anchor{anchor_op = MovedAnchor (DifferentLine _ col)} _ _ -> Just col
+  _                                                                -> Nothing
+#endif
+
+#if MIN_VERSION_ghc(9,11,0)
+continuationIndentFromAnchor :: EpaLocation -> Maybe Int
+continuationIndentFromAnchor (EpaDelta _ (DifferentLine _ col) _) = Just col
+continuationIndentFromAnchor _                                    = Nothing
+#elif MIN_VERSION_ghc(9,9,0)
+continuationIndentFromAnchor :: EpaLocation -> Maybe Int
+continuationIndentFromAnchor (EpaDelta (DifferentLine _ col) _) = Just col
+continuationIndentFromAnchor _                                  = Nothing
+#endif
+
+importItemSortKey :: Outputable a => LocatedAn AnnListItem a -> (Bool, T.Text)
+importItemSortKey = sortKeyText . printOutputable . unLoc
+
+wrappedNameSortKey :: LocatedAn AnnListItem (IEWrappedName GhcPs) -> (Bool, T.Text)
+wrappedNameSortKey = sortKeyText . printOutputable . unLoc
+
+-- | Build a lexical sort key for rendered import items.
+--
+-- Strips @type@/@pattern@ prefixes and normalizes operator parens.
+sortKeyText :: T.Text -> (Bool, T.Text)
+sortKeyText raw =
+  let normalized = T.toCaseFold $ normalizeSortText raw
+  in (isSymbolLike normalized, normalized)
+
+normalizeSortText :: T.Text -> T.Text
+normalizeSortText =
+  stripWrappedOperator
+  . dropSortKeyword
+  . T.strip
+  where
+    dropSortKeyword t = fromMaybe t (T.stripPrefix "type " t <|> T.stripPrefix "pattern " t)
+    stripWrappedOperator t
+      | T.any (== ' ') t = t
+      | otherwise = fromMaybe t $ do
+          inner <- T.stripPrefix "(" t
+          T.stripSuffix ")" inner
+
+-- | True when the normalized import item starts like a symbolic name.
+isSymbolLike :: T.Text -> Bool
+isSymbolLike =
+  maybe False (not . isIdentifierLike) . T.find (not . (`elem` ['(', ')']))
+  where
+    isIdentifierLike c = isAlphaNum c || c == '_' || c == '\''
+
 -- Add an item in an import list, taking care of adding comma if needed.
 addCommaInImportList ::
   -- | Initial list

plugins/hls-refactor-plugin/test/Main.hs

@@ -116,23 +116,48 @@ completionTests =
         (Position 3 6)
         "join"
         ["{-# LANGUAGE NoImplicitPrelude #-}",
-        "module A where", "import Control.Monad (msum, join)", "f = joi"]
+        "module A where", "import Control.Monad (join, msum)", "f = joi"]
       , completionCommandTest
         "show imports not in list - multi-line"
         ["{-# LANGUAGE NoImplicitPrelude #-}",
         "module A where", "import Control.Monad (\n    msum)", "f = joi"]
         (Position 4 6)
         "join"
         ["{-# LANGUAGE NoImplicitPrelude #-}",
-        "module A where", "import Control.Monad (\n    msum, join)", "f = joi"]
+        "module A where", "import Control.Monad (join,\n    msum)", "f = joi"]
       , completionCommandTest
         "show imports not in list - names with _"
         ["{-# LANGUAGE NoImplicitPrelude #-}",
         "module A where", "import Control.Monad as M (msum)", "f = M.mapM_"]
         (Position 3 11)
         "mapM_"
         ["{-# LANGUAGE NoImplicitPrelude #-}",
-        "module A where", "import Control.Monad as M (msum, mapM_)", "f = M.mapM_"]
+        "module A where", "import Control.Monad as M (mapM_, msum)", "f = M.mapM_"]
+      , completionSequenceTest
+          "sort repeated auto-imports"
+          [ ("FileTwo.hs", T.unlines
+              [ "module FileTwo (alpha, beta, charlie, delta) where"
+              , ""
+              , "alpha :: Int"
+              , "alpha = 1"
+              , ""
+              , "beta :: Int"
+              , "beta = 1"
+              , ""
+              , "charlie :: Int"
+              , "charlie = 1"
+              , ""
+              , "delta :: Int"
+              , "delta = 1"
+              ])
+          ]
+          ["module Main where", "import FileTwo ()", "e = del * cha * bet * alp", "main :: IO ()", "main = print e"]
+          [ (Position 2 6, "delta")
+          , (Position 2 12, "charlie")
+          , (Position 2 18, "beta")
+          , (Position 2 24, "alpha")
+          ]
+          ["module Main where", "import FileTwo (alpha, beta, charlie, delta)", "e = del * cha * bet * alp", "main :: IO ()", "main = print e"]
       , completionCommandTest
         "show imports not in list - initial empty list"
         ["{-# LANGUAGE NoImplicitPrelude #-}",
@@ -280,6 +305,30 @@ completionCommandTest name src pos wanted expected = testSession name $ do
           expectMessages SMethod_WorkspaceApplyEdit 1 $ \edit ->
             liftIO $ assertFailure $ "Expected no edit but got: " <> show edit
 
+completionSequenceTest :: TestName -> [(FilePath, T.Text)] -> [T.Text] -> [(Position, T.Text)] -> [T.Text] -> TestTree
+completionSequenceTest name setupDocs src steps expected = testSession name $ do
+  for_ setupDocs $ \(path, contents) -> do
+    _ <- createDoc path "haskell" contents
+    pure ()
+  docId <- createDoc "Main.hs" "haskell" (T.unlines src)
+  _ <- waitForDiagnostics
+  for_ steps $ \(pos, wanted) -> do
+    compls <- skipManyTill anyMessage (getCompletions docId pos)
+    let wantedC = mapMaybe (\case
+          CompletionItem {_insertText = Just x, _command = Just cmd}
+            | wanted `T.isPrefixOf` x -> Just cmd
+          _                           -> Nothing
+          ) compls
+    case wantedC of
+      [] ->
+        liftIO $ assertFailure $ "Cannot find completion " <> show wanted <> " in: " <> show [_label | CompletionItem {_label} <- compls]
+      command:_ -> do
+        executeCommand command
+        _ <- skipManyTill anyMessage (getDocumentEdit docId)
+        pure ()
+  modifiedCode <- documentContents docId
+  liftIO $ modifiedCode @?= T.unlines expected
+
 completionNoCommandTest :: TestName -> [T.Text] -> Position -> T.Text -> TestTree
 completionNoCommandTest name src pos wanted = testSession name $ do
   docId <- createDoc "A.hs" "haskell" (T.unlines src)
@@ -1223,7 +1272,7 @@ extendImportTests = testGroup "extend import actions"
             ["Add stuffA to the import list of ModuleA"]
             (T.unlines
                     [ "module ModuleB where"
-                    , "import ModuleA as A (stuffB, stuffA)"
+                    , "import ModuleA as A (stuffA, stuffB)"
                     , "main = print (stuffA, stuffB)"
                     ])
         , testSession "extend single line import with operator" $ template
@@ -1394,7 +1443,7 @@ extendImportTests = testGroup "extend import actions"
             ["Add stuffA to the import list of ModuleA"]
             (T.unlines
                     [ "module ModuleB where"
-                    , "import qualified ModuleA as A (stuffB, stuffA)"
+                    , "import qualified ModuleA as A (stuffA, stuffB)"
                     , "main = print (A.stuffA, A.stuffB)"
                     ])
         , testSession "extend multi line import with value" $ template
@@ -1415,7 +1464,7 @@ extendImportTests = testGroup "extend import actions"
             ["Add stuffA to the import list of ModuleA"]
             (T.unlines
                     [ "module ModuleB where"
-                    , "import ModuleA (stuffB, stuffA"
+                    , "import ModuleA (stuffA, stuffB"
                     , "               )"
                     , "main = print (stuffA, stuffB)"
                     ])
@@ -1437,7 +1486,7 @@ extendImportTests = testGroup "extend import actions"
             ["Add stuffA to the import list of ModuleA"]
             (T.unlines
                     [ "module ModuleB where"
-                    , "import ModuleA (stuffB, stuffA,"
+                    , "import ModuleA (stuffA, stuffB"
                     , "               )"
                     , "main = print (stuffA, stuffB)"
                     ])