diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs index 78b68334c6..938443d373 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -18,9 +18,11 @@ module Development.IDE.Plugin.CodeAction.ExactPrint ( 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 Language.LSP.Protocol.Types 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 @@ import GHC (addAnns, ann) #if MIN_VERSION_ghc(9,9,0) import GHC (NoAnn (..)) +import GHC (EpaLocation' (..)) import GHC (EpAnnComments (..)) #endif @@ -306,7 +314,7 @@ extendImportTopLevel thing (L l it@ImportDecl{..}) 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 @@ extendImportViaParent df parent child (L l it@ImportDecl{..}) 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 @@ extendImportViaParent df parent child (L l it@ImportDecl{..}) 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 @@ extendImportViaParent df parent child (L l it@ImportDecl{..}) 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 diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 8c73eab52e..dfa8690ebb 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -116,7 +116,7 @@ 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 #-}", @@ -124,7 +124,7 @@ completionTests = (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 #-}", @@ -132,7 +132,32 @@ completionTests = (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)" ])