Fix importing type operators

ghcide/src/Development/IDE/Plugin/CodeAction.hs

@@ -1557,10 +1557,13 @@ importStyles IdentInfo {parent, rendered, isDatacon}
   | otherwise
   = ImportTopLevel rendered :| []
 
+-- | Used for adding new imports
 renderImportStyle :: ImportStyle -> T.Text
-renderImportStyle (ImportTopLevel x)    = x
+renderImportStyle (ImportTopLevel x)   = x
+renderImportStyle (ImportViaParent x p@(T.uncons -> Just ('(', _))) = "type " <> p <> "(" <> x <> ")"
 renderImportStyle (ImportViaParent x p) = p <> "(" <> x <> ")"
 
+-- | Used for extending import lists
 unImportStyle :: ImportStyle -> (Maybe String, String)
 unImportStyle (ImportTopLevel x)    = (Nothing, T.unpack x)
 unImportStyle (ImportViaParent x y) = (Just $ T.unpack y, T.unpack x)

ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs

@@ -35,7 +35,7 @@ import           Development.IDE.GHC.ExactPrint        (ASTElement (parseAST),
 import           Development.IDE.Spans.Common
 import           FieldLabel                            (flLabel)
 import           GHC.Exts                              (IsList (fromList))
-import           GhcPlugins                            (sigPrec)
+import           GhcPlugins                            (mkRdrUnqual, sigPrec)
 import           Language.Haskell.GHC.ExactPrint
 import           Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP),
                                                         KeywordId (G), mkAnnKey)
@@ -200,44 +200,48 @@ extendImport mparent identifier lDecl@(L l _) =
   Rewrite l $ \df -> do
     case mparent of
       Just parent -> extendImportViaParent df parent identifier lDecl
-      _           -> extendImportTopLevel df identifier lDecl
+      _           -> extendImportTopLevel identifier lDecl
 
--- | Add an identifier to import list
+-- | Add an identifier or a data type to import list
 --
 -- extendImportTopLevel "foo" AST:
 --
 -- import A --> Error
 -- import A (foo) --> Error
 -- import A (bar) --> import A (bar, foo)
-extendImportTopLevel :: DynFlags -> String -> LImportDecl GhcPs -> TransformT (Either String) (LImportDecl GhcPs)
-extendImportTopLevel df idnetifier (L l it@ImportDecl{..})
+extendImportTopLevel ::
+  -- | rendered
+  String ->
+  LImportDecl GhcPs ->
+  TransformT (Either String) (LImportDecl GhcPs)
+extendImportTopLevel thing (L l it@ImportDecl{..})
   | Just (hide, L l' lies) <- ideclHiding
     , hasSibling <- not $ null lies = do
     src <- uniqueSrcSpanT
     top <- uniqueSrcSpanT
-    rdr <- liftParseAST df idnetifier
+    let rdr = L src $ mkRdrUnqual $ mkVarOcc thing
 
     let alreadyImported =
           showNameWithoutUniques (occName (unLoc rdr))
             `elem` map (showNameWithoutUniques @OccName) (listify (const True) lies)
     when alreadyImported $
-      lift (Left $ idnetifier <> " already imported")
+      lift (Left $ thing <> " already imported")
 
     let lie = L src $ IEName rdr
         x = L top $ IEVar noExtField lie
     if x `elem` lies
-      then lift (Left $ idnetifier <> " already imported")
+      then lift (Left $ thing <> " already imported")
       else do
         when hasSibling $
           addTrailingCommaT (last lies)
         addSimpleAnnT x (DP (0, if hasSibling then 1 else 0)) []
-        addSimpleAnnT rdr dp00 $ unqalDP $ hasParen idnetifier
+        addSimpleAnnT rdr dp00 [(G AnnVal, dp00)]
         -- Parens are attachted to `lies`, so if `lies` was empty previously,
         -- we need change the ann key from `[]` to `:` to keep parens and other anns.
         unless hasSibling $
           transferAnn (L l' lies) (L l' [x]) id
         return $ L l it{ideclHiding = Just (hide, L l' $ lies ++ [x])}
-extendImportTopLevel _ _ _ = lift $ Left "Unable to extend the import list"
+extendImportTopLevel _ _ = lift $ Left "Unable to extend the import list"
 
 -- | Add an identifier with its parent to import list
 --
@@ -249,7 +253,14 @@ extendImportTopLevel _ _ _ = lift $ Left "Unable to extend the import list"
 -- import A () --> import A (Bar(Cons))
 -- import A (Foo, Bar) --> import A (Foo, Bar(Cons))
 -- import A (Foo, Bar()) --> import A (Foo, Bar(Cons))
-extendImportViaParent :: DynFlags -> String -> String -> LImportDecl GhcPs -> TransformT (Either String) (LImportDecl GhcPs)
+extendImportViaParent ::
+  DynFlags ->
+  -- | parent (already parenthesized if needs)
+  String ->
+  -- | rendered child
+  String ->
+  LImportDecl GhcPs ->
+  TransformT (Either String) (LImportDecl GhcPs)
 extendImportViaParent df parent child (L l it@ImportDecl{..})
   | Just (hide, L l' lies) <- ideclHiding = go hide l' [] lies
  where
@@ -260,8 +271,8 @@ extendImportViaParent df parent child (L l it@ImportDecl{..})
     -- ThingAbs ie => ThingWith ie child
     | parent == unIEWrappedName ie = do
       srcChild <- uniqueSrcSpanT
-      childRdr <- liftParseAST df child
-      let childLIE = L srcChild $ IEName childRdr
+      let childRdr = L srcChild $ mkRdrUnqual $ mkVarOcc child
+          childLIE = L srcChild $ IEName childRdr
           x :: LIE GhcPs = L ll' $ IEThingWith noExtField absIE NoIEWildcard [childLIE] []
       -- take anns from ThingAbs, and attatch parens to it
       transferAnn lAbs x $ \old -> old{annsDP = annsDP old ++ [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, dp00)]}
@@ -273,7 +284,7 @@ extendImportViaParent df parent child (L l it@ImportDecl{..})
       , hasSibling <- not $ null lies' =
       do
         srcChild <- uniqueSrcSpanT
-        childRdr <- liftParseAST df child
+        let childRdr = L srcChild $ mkRdrUnqual $ mkVarOcc child
 
         let alreadyImported =
               showNameWithoutUniques (occName (unLoc childRdr))
@@ -284,7 +295,7 @@ extendImportViaParent df parent child (L l it@ImportDecl{..})
         when hasSibling $
           addTrailingCommaT (last lies')
         let childLIE = L srcChild $ IEName childRdr
-        addSimpleAnnT childRdr (DP (0, if hasSibling then 1 else 0)) $ unqalDP $ hasParen child
+        addSimpleAnnT childRdr (DP (0, if hasSibling then 1 else 0)) [(G AnnVal, dp00)]
         return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [L l'' (IEThingWith noExtField twIE NoIEWildcard (lies' ++ [childLIE]) [])] ++ xs)}
   go hide l' pre (x : xs) = go hide l' (x : pre) xs
   go hide l' pre []
@@ -294,14 +305,18 @@ extendImportViaParent df parent child (L l it@ImportDecl{..})
       srcParent <- uniqueSrcSpanT
       srcChild <- uniqueSrcSpanT
       parentRdr <- liftParseAST df parent
-      childRdr <- liftParseAST df child
+      let childRdr = L srcChild $ mkRdrUnqual $ mkVarOcc child
+          isParentOperator = hasParen parent
       when hasSibling $
         addTrailingCommaT (head pre)
-      let parentLIE = L srcParent $ IEName parentRdr
+      let parentLIE = L srcParent $ (if isParentOperator then IEType else IEName) parentRdr
           childLIE = L srcChild $ IEName childRdr
           x :: LIE GhcPs = L l'' $ IEThingWith noExtField parentLIE NoIEWildcard [childLIE] []
-      addSimpleAnnT parentRdr (DP (0, if hasSibling then 1 else 0)) $ unqalDP $ hasParen parent
-      addSimpleAnnT childRdr (DP (0, 0)) $ unqalDP $ hasParen child
+      -- Add AnnType for the parent if it's parenthesized (type operator)
+      when isParentOperator $
+        addSimpleAnnT parentLIE (DP (0, 0)) [(G AnnType, DP (0, 0))]
+      addSimpleAnnT parentRdr (DP (0, if hasSibling then 1 else 0)) $ unqalDP 1 isParentOperator
+      addSimpleAnnT childRdr (DP (0, 0)) [(G AnnVal, dp00)]
       addSimpleAnnT x (DP (0, 0)) [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, DP (0, 0))]
       -- Parens are attachted to `pre`, so if `pre` was empty previously,
       -- we need change the ann key from `[]` to `:` to keep parens and other anns.
@@ -317,10 +332,10 @@ hasParen :: String -> Bool
 hasParen ('(' : _) = True
 hasParen _         = False
 
-unqalDP :: Bool -> [(KeywordId, DeltaPos)]
-unqalDP paren =
+unqalDP :: Int -> Bool -> [(KeywordId, DeltaPos)]
+unqalDP c paren =
   ( if paren
-      then \x -> (G AnnOpenP, dp00) : x : [(G AnnCloseP, dp00)]
+      then \x -> (G AnnOpenP, DP (0, c)) : x : [(G AnnCloseP, dp00)]
       else pure
   )
     (G AnnVal, dp00)
@@ -364,7 +379,7 @@ extendHiding symbol (L l idecls) mlies df = do
       , (G AnnCloseP, DP (0, 0))
       ]
   addSimpleAnnT x (DP (0, 0)) []
-  addSimpleAnnT rdr dp00 $ unqalDP $ isOperator $ unLoc rdr
+  addSimpleAnnT rdr dp00 $ unqalDP 0 $ isOperator $ unLoc rdr
   if hasSibling
     then when hasSibling $ do
       addTrailingCommaT x

ghcide/src/Development/IDE/Types/Exports.hs

@@ -56,21 +56,30 @@ instance NFData IdentInfo where
         -- deliberately skip the rendered field
         rnf name `seq` rnf parent `seq` rnf isDatacon `seq` rnf moduleNameText
 
+-- | Render an identifier as imported or exported style.
+-- TODO: pattern synonym
+renderIEWrapped :: Name -> Text
+renderIEWrapped n
+  | isTcOcc occ && isSymOcc occ = "type " <> pack (printName n)
+  | otherwise = pack $ printName n
+  where
+    occ = occName n
+
 mkIdentInfos :: Text -> AvailInfo -> [IdentInfo]
 mkIdentInfos mod (Avail n) =
-    [IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n) mod]
+    [IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) Nothing (isDataConName n) mod]
 mkIdentInfos mod (AvailTC parent (n:nn) flds)
     -- Following the GHC convention that parent == n if parent is exported
     | n == parent
-    = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) (isDataConName n) mod
+    = [ IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) (Just $! parentP) (isDataConName n) mod
         | n <- nn ++ map flSelector flds
       ] ++
-      [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n) mod]
+      [ IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) Nothing (isDataConName n) mod]
     where
         parentP = pack $ printName parent
 
 mkIdentInfos mod (AvailTC _ nn flds)
-    = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n) mod
+    = [ IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) Nothing (isDataConName n) mod
         | n <- nn ++ map flSelector flds
       ]
 

ghcide/test/exe/Main.hs

@@ -1380,13 +1380,33 @@ extendImportTests = testGroup "extend import actions"
                     , "x = Refl"
                     ])
             (Range (Position 3 17) (Position 3 18))
-            ["Add (:~:)(Refl) to the import list of Data.Type.Equality"]
+            ["Add type (:~:)(Refl) to the import list of Data.Type.Equality"]
             (T.unlines
                     [ "module ModuleA where"
                     , "import Data.Type.Equality ((:~:) (Refl))"
                     , "x :: (:~:) [] []"
                     , "x = Refl"
                     ])
+        , expectFailBecause "importing pattern synonyms is unsupported"
+          $ testSession "extend import list with pattern synonym" $ template
+            [("ModuleA.hs", T.unlines 
+                    [ "{-# LANGUAGE PatternSynonyms #-}"
+                      , "module ModuleA where"
+                      , "pattern Some x = Just x"
+                    ])
+            ]
+            ("ModuleB.hs", T.unlines
+                    [ "module ModuleB where"
+                    , "import A ()"
+                    , "k (Some x) = x"
+                    ])
+            (Range (Position 2 3) (Position 2 7))
+            ["Add pattern Some to the import list of A"]
+            (T.unlines
+                    [ "module ModuleB where"
+                    , "import A (pattern Some)"
+                    , "k (Some x) = x"
+                    ])
         ]
       where
         codeActionTitle CodeAction{_title=x} = x
@@ -1549,6 +1569,7 @@ suggestImportTests = testGroup "suggest import actions"
     , test True []          "f = (&) [] id"               []                "import Data.Function ((&))"
     , test True []          "f = (.|.)"                   []                "import Data.Bits (Bits((.|.)))"
     , test True []          "f = (.|.)"                   []                "import Data.Bits ((.|.))"
+    , test True []          "f :: a ~~ b"                 []                "import Data.Type.Equality (type (~~))"
     , test True
       ["qualified Data.Text as T"
       ]                     "f = T.putStrLn"              []                "import qualified Data.Text.IO as T"
@@ -1563,15 +1584,17 @@ suggestImportTests = testGroup "suggest import actions"
       , "qualified Data.Data as T"
       ]                     "f = T.putStrLn"              []                "import qualified Data.Text.IO as T"
     ]
+    , expectFailBecause "importing pattern synonyms is unsupported" $ test True [] "k (Some x) = x" [] "import B (pattern Some)"
   ]
   where
     test = test' False
     wantWait = test' True True
     test' waitForCheckProject wanted imps def other newImp = testSessionWithExtraFiles "hover" (T.unpack def) $ \dir -> do
       let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other
           after  = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other
-          cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo]}}"
+          cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo, B]}}"
       liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle
+      liftIO $ writeFileUTF8 (dir </> "B.hs") $ unlines ["{-# LANGUAGE PatternSynonyms #-}", "module B where", "pattern Some x = Just x"]
       doc <- createDoc "Test.hs" "haskell" before
       waitForProgressDone
       _diags <- waitForDiagnostics
@@ -3987,7 +4010,7 @@ nonLocalCompletionTests =
             ["module A where", "import Data.Type.Equality ()", "f = Ref"]
             (Position 2 8)
             "Refl"
-            ["module A where", "import Data.Type.Equality ((:~:) (Refl))", "f = Ref"]
+            ["module A where", "import Data.Type.Equality (type (:~:) (Refl))", "f = Ref"]
         ]
       , testGroup "Record completion"
         [ completionCommandTest