Splice export modifications precisely when using CPP (#4981)

* Extract shared line helpers into Development.IDE.Core.Text

* Add export-list CPP detection to hls-exactprint-utils

* Splice text when using CPP in export lists

* Update CODEOWNERS for hls-export-plugin

Author: crtschin

CODEOWNERS

@@ -23,6 +23,7 @@
 /plugins/hls-explicit-fixity-plugin
 /plugins/hls-explicit-imports-plugin
 /plugins/hls-explicit-record-fields-plugin @ozkutuk
+/plugins/hls-export-plugin @crtschin
 /plugins/hls-fourmolu-plugin @georgefst
 /plugins/hls-gadt-plugin @July541
 /plugins/hls-hlint-plugin @eddiemundo

ghcide/ghcide.cabal

@@ -142,6 +142,7 @@ library
     Development.IDE.Core.RuleTypes
     Development.IDE.Core.Service
     Development.IDE.Core.Shake
+    Development.IDE.Core.Text
     Development.IDE.Core.Tracing
     Development.IDE.Core.UseStale
     Development.IDE.Core.WorkerThread

ghcide/src/Development/IDE/Core/Text.hs

@@ -0,0 +1,19 @@
+module Development.IDE.Core.Text
+  ( takeLineRange
+  , lineAt
+  ) where
+
+import           Data.Maybe                 (listToMaybe)
+import           Data.Text                  (Text)
+import           Data.Text.Utf16.Rope.Mixed (Rope)
+import qualified Data.Text.Utf16.Rope.Mixed as Rope
+
+-- | The lines of @rope@ over the 0-based inclusive line range @[from, to]@.
+takeLineRange :: Word -> Word -> Rope -> [Text]
+takeLineRange from to rope
+  | to < from = []
+  | otherwise = Rope.lines $ fst $ Rope.splitAtLine (to - from + 1) $ snd $ Rope.splitAtLine from rope
+
+-- | The 0-based line @n@ of @rope@, if it has one.
+lineAt :: Word -> Rope -> Maybe Text
+lineAt n = listToMaybe . takeLineRange n n

ghcide/src/Development/IDE/Plugin/Completions/Logic.hs

@@ -40,6 +40,7 @@ import qualified Data.HashSet                             as HashSet
 import           Data.Ord                                 (Down (Down))
 import qualified Data.Set                                 as Set
 import           Development.IDE.Core.PositionMapping
+import           Development.IDE.Core.Text                (lineAt)
 import           Development.IDE.GHC.Compat               hiding (isQual, ppr)
 import qualified Development.IDE.GHC.Compat               as GHC
 import           Development.IDE.GHC.Compat.Util
@@ -876,8 +877,7 @@ getCompletionPrefixFromRope pos@(Position l c) ropetext =
             lastMaybe = headMaybe . reverse
 
         -- grab the entire line the cursor is at
-        curLine <- headMaybe $ Rope.lines
-                             $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) ropetext
+        curLine <- lineAt (fromIntegral l) ropetext
         let beforePos = T.take (fromIntegral c) curLine
         -- the word getting typed, after previous space and before cursor
         curWord <-

haskell-language-server.cabal

@@ -1771,11 +1771,15 @@ library hls-exactprint-utils
   import: defaults, pedantic, warnings
   exposed-modules:
     Development.IDE.GHC.ExactPrint.Annotation
+    Development.IDE.GHC.ExactPrint.CPP
   hs-source-dirs:     hls-exactprint-utils/src
   build-depends:
     , ghc
     , ghc-exactprint
     , ghcide          == 2.14.0.0
+    , lsp             >=2.8
+    , text
+    , text-rope
   default-extensions:
       CPP
 
@@ -1805,6 +1809,7 @@ library hls-export-plugin
   build-depends:
     , containers
     , ghc
+    , ghc-boot-th
     , ghc-exactprint
     , ghcide          == 2.14.0.0
     , haskell-language-server:hls-exactprint-utils
@@ -1813,6 +1818,7 @@ library hls-export-plugin
     , lsp >=2.8
     , stm
     , text
+    , text-rope
   default-extensions:
     , DataKinds
     , LambdaCase

hls-exactprint-utils/src/Development/IDE/GHC/ExactPrint/CPP.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Development.IDE.GHC.ExactPrint.CPP
+  ( spanHasCpp
+  , isCppDirective
+  ) where
+
+import           Data.Text                   (Text)
+import qualified Data.Text                   as T
+import           Data.Text.Utf16.Rope.Mixed  (Rope)
+import           Development.IDE.Core.Text   (takeLineRange)
+import           Language.LSP.Protocol.Types (Position (..), Range (..))
+
+-- | Whether the source over @range@ holds a CPP directive.
+spanHasCpp :: Maybe Rope -> Range -> Bool
+spanHasCpp Nothing _ = False
+spanHasCpp (Just rope) (Range (Position l0 _) (Position l1 _)) =
+  any isCppDirective (takeLineRange (fromIntegral l0) (fromIntegral l1) rope)
+
+-- | Whether a line is a CPP directive. In a source compiled with CPP a directive
+-- is the only line whose first non-space character is @#@.
+isCppDirective :: Text -> Bool
+isCppDirective = T.isPrefixOf "#" . T.stripStart

plugins/hls-export-plugin/src/Ide/Plugin/Export.hs

@@ -5,14 +5,17 @@ module Ide.Plugin.Export (descriptor) where
 import           Control.Concurrent.STM           (atomically)
 import           Control.Lens
 import           Control.Monad.IO.Class           (liftIO)
+import           Data.Maybe                       (isJust, isNothing)
 import           Data.Text                        (Text)
 import qualified Data.Text                        as T
+import           Data.Text.Utf16.Rope.Mixed       (Rope)
 import           Development.IDE
 import           Development.IDE.Core.PluginUtils (runActionE, useE)
 import           Development.IDE.Core.Shake       (getDiagnostics)
 import           Development.IDE.GHC.Compat
 import           Development.IDE.GHC.Compat.Error (_TcRnUnusedTopBind,
                                                    msgEnvelopeErrorL)
+import qualified GHC.LanguageExtensions.Type      as LangExt (Extension (..))
 import           Ide.Plugin.Error                 (getNormalizedFilePathE)
 import           Ide.Plugin.Export.Cursor
 import           Ide.Plugin.Export.ExactPrint
@@ -35,17 +38,27 @@ quickCodeActionHandlers :: PluginMethodHandler IdeState Method_TextDocumentCodeA
 quickCodeActionHandlers state _plId (CodeActionParams _ _ doc range _) = do
   let uri = doc ^. L.uri
   nfp <- getNormalizedFilePathE uri
-  pm <- runActionE "Export.GetParsedModuleWithComments" state (useE GetParsedModuleWithComments nfp)
-  let ps = pm_parsed_source pm
-  case (isExplicit ps, locateUnderCursor (range ^. L.start) ps) of
-    (True, Just under) -> do
+  (ps, isCpp, mUnder, msrc) <- runActionE "Export.getInputs" state $ do
+    pm <- useE GetParsedModuleWithComments nfp
+    let ps = pm_parsed_source pm
+        isCpp = xopt LangExt.Cpp (ms_hspp_opts (pm_mod_summary pm))
+        mUnder = if isExplicit ps then locateUnderCursor (range ^. L.start) ps else Nothing
+    -- Only a CPP module about to be offered an action needs the buffer (to find
+    -- directives in the export list), so skip the fetch otherwise.
+    msrc <- if isJust mUnder && isCpp then snd <$> useE GetFileContents nfp else pure Nothing
+    pure (ps, isCpp, mUnder, msrc)
+  case mUnder of
+    -- A CPP module whose buffer we could not read may have directives in the
+    -- export list that a reprint would silently erase. Withhold rather than risk
+    -- it.
+    Just under | not (isCpp && isNothing msrc) -> do
       -- The names GHC flags as defined-but-unused. Attach the action to the
       -- unused diagnostics as well.
       unusedDiags <- liftIO $ unusedTopBindDiagnostics state nfp
       pure . InL . map InR $
         [ ca
         | Just (verb, title, edits) <-
-            [ addAction under ps
+            [ addAction msrc under ps
             ]
         , let fixes = [ d | d <- unusedDiags, locateUnderCursor (d ^. L.range . L.start) ps == Just under ]
               ca = mkAction (verb <> " `" <> title <> "`")
@@ -63,14 +76,14 @@ unusedTopBindDiagnostics state nfp = do
     isUnusedTopBind =
       has (fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnUnusedTopBind)
 
-addAction :: UnderCursor -> ParsedSource -> Maybe (Text, Text, [TextEdit])
-addAction under ps = case under of
+addAction :: Maybe Rope -> UnderCursor -> ParsedSource -> Maybe (Text, Text, [TextEdit])
+addAction msrc under ps = case under of
   Decl flavor n
     | n `isExported` ps -> Nothing
-    | otherwise -> ("Export", T.pack (printRdrName n),) <$> addExport ps (mkExportIE flavor n)
+    | otherwise -> ("Export", T.pack (printRdrName n),) <$> addExport msrc ps (mkExportIE flavor n)
   Constructor t c
     | c `isExported` ps -> Nothing
     | otherwise ->
         ("Export", T.pack (printRdrName t) <> "(" <> T.pack (printRdrName c) <> ")",)
-          <$> addConstructorExport t c ps
+          <$> addConstructorExport msrc t c ps
   Header -> Nothing

plugins/hls-export-plugin/src/Ide/Plugin/Export/ExactPrint.hs

@@ -9,13 +9,13 @@ module Ide.Plugin.Export.ExactPrint
   , appendIE
   , addCtorUnderParent
   , printExportList
-  , toDeltaExportList
+  , printIE
+  , freshCtorEntry
   ) where
 
 import           Control.Lens                              (_last, over)
 import           Data.Bifunctor                            (first)
 import           Data.List.NonEmpty                        (NonEmpty (..))
-import qualified Data.List.NonEmpty                        as NE
 import           Data.Text                                 (Text)
 import qualified Data.Text                                 as T
 import           Development.IDE.GHC.Compat
@@ -40,7 +40,6 @@ import           GHC                                       (DeltaPos (..),
 
 import           Language.Haskell.GHC.ExactPrint           (addComma,
                                                             exactPrint,
-                                                            makeDeltaAst,
                                                             setEntryDP)
 
 #if MIN_VERSION_ghc(9,11,0)
@@ -167,9 +166,8 @@ mkTypeWithIE parent ctors =
     Nothing
 #endif
   where
-    children = case NE.toList ctors of
-      []     -> [] -- impossible
-      (c:cs) -> mkIEName c : map (\x -> first addComma (mkIEName x)) cs
+    children = mkIEName c : map (first addComma . mkIEName) cs
+    c :| cs = ctors
 
 -- | Map over an @IEThingWith@'s listed constructors, a no-op for any other item.
 overThingWithChildren :: ([LIEWrappedName GhcPs] -> [LIEWrappedName GhcPs]) -> IE GhcPs -> IE GhcPs
@@ -226,58 +224,70 @@ separatorComma items =
 
 -- | 'Nothing' iff @ctor@ is already exported (via @T(..)@ or @T(...,ctor,...)@).
 addCtorUnderParent ::
-  RdrName {- ^ parent -} ->
-  RdrName {- ^ ctor -} ->
+  -- | parent
+  RdrName ->
+  -- | ctor
+  RdrName ->
   LExportList ->
   Maybe LExportList
 addCtorUnderParent parent ctor lst@(L l items) =
-  case findParent items of
-    ParentNotFound -> Just $ appendIE (mkTypeWithIE parent (ctor :| [])) lst
-    FoundIEThingAll -> Nothing
-    FoundIEThingWith CtorPresent -> Nothing
-    FoundIEThingWith CtorAbsent -> Just (L l (map (transformParent extendThingWith) items))
-    FoundIEThingAbs ->
-      let upgraded = unLoc (mkTypeWithIE parent (ctor :| []))
-      in Just (L l (map (transformParent (const upgraded)) items))
+  case ctorExportEdit parent ctor items of
+    AlreadyExported -> Nothing
+    AppendParent    -> Just (appendIE newThing lst)
+    UpgradeBare     -> Just (L l (map (transformParent (const (unLoc newThing))) items))
+    AddChild        -> Just (L l (map (transformParent (addCtorChildren ctor)) items))
   where
-    parentFS = rdrNameFS parent
-    ctorFS = rdrNameFS ctor
-
-    ctorPresence cs
-      | any ((== ctorFS) . lieWrappedNameFS) cs = CtorPresent
-      | otherwise = CtorAbsent
-
-    findParent [] = ParentNotFound
-    findParent (L _ ie : rest)
-      | parentNameIs parentFS ie =
-          case ie of
-            IEThingAll{} -> FoundIEThingAll
-            IEThingAbs{} -> FoundIEThingAbs
-            _ | Just cs <- ieThingWithChildren ie -> FoundIEThingWith (ctorPresence cs)
-              | otherwise                         -> findParent rest
-      | otherwise = findParent rest
-
+    newThing = mkTypeWithIE parent (ctor :| [])
     transformParent f (L itemLoc ie)
-      | parentNameIs parentFS ie = L itemLoc (f ie)
+      | parentNameIs (rdrNameFS parent) ie = L itemLoc (f ie)
       | otherwise = L itemLoc ie
 
-    extendThingWith :: IE GhcPs -> IE GhcPs
-    extendThingWith = overThingWithChildren $ \cs ->
-      let hasSibling = not (null cs)
-          newChild = setEntryDP (mkIEName ctor) (SameLine (if hasSibling then 1 else 0))
-      in (if hasSibling then map (first ensureTrailingComma) cs else cs) ++ [newChild]
+-- | Append @ctor@ to an @IEThingWith@'s children, reusing the sibling separator
+-- comma. No-op for other items.
+addCtorChildren :: RdrName -> IE GhcPs -> IE GhcPs
+addCtorChildren ctor = overThingWithChildren $ \cs ->
+  let hasSibling = not (null cs)
+      newChild = setEntryDP (mkIEName ctor) (SameLine (if hasSibling then 1 else 0))
+   in (if hasSibling then map (first ensureTrailingComma) cs else cs) ++ [newChild]
 
 printExportList :: LExportList -> Text
 printExportList l = T.pack (exactPrint (setEntryDP l (SameLine 0)))
 
-toDeltaExportList :: LExportList -> LExportList
-toDeltaExportList = makeDeltaAst
+-- | Exactprint a single item, without the surrounding list layout. The
+-- trailing separator comma counts as layout: dropping it keeps a spliced item
+-- from carrying a stray comma into text that already supplies its own.
+printIE :: LIE GhcPs -> Text
+printIE item = T.pack (exactPrint (setEntryDP (first removeTrailingCommaAnn item) (SameLine 0)))
 
-data FindParentResult
-  = ParentNotFound
-  | FoundIEThingAll
-  | FoundIEThingWith CtorPresence
-  | FoundIEThingAbs
+-- | A fresh @T(ctor)@ export entry rendered as text, or 'Nothing' if @ctor@ is
+-- already exported in the parsed list. Under CPP this adds a standalone entry so
+-- the splice never reprints an existing @T(...)@ span, which can straddle a
+-- directive.
+freshCtorEntry :: RdrName -> RdrName -> [LIE GhcPs] -> Maybe Text
+freshCtorEntry parent ctor items = case ctorExportEdit parent ctor items of
+  AlreadyExported -> Nothing
+  _               -> Just (printIE (mkTypeWithIE parent (ctor :| [])))
 
-data CtorPresence = CtorAbsent | CtorPresent
-  deriving Eq
+-- | How to add @ctor@ to an export list so its parent type @T@ exports it.
+data CtorEdit
+  = AlreadyExported  -- ^ @T(..)@ or @T(..., ctor, ...)@, nothing to do
+  | AppendParent     -- ^ no entry for @T@ yet, add a fresh @T(ctor)@
+  | UpgradeBare      -- ^ replace the bare @T@ entry with @T(ctor)@
+  | AddChild         -- ^ add @ctor@ to the existing @T(...)@ entry
+
+-- | Decide how @ctor@ should be added under @parent@, classifying the first
+-- matching export item by its constructor-carrying shape.
+ctorExportEdit :: RdrName -> RdrName -> [LIE GhcPs] -> CtorEdit
+ctorExportEdit parent ctor = go
+  where
+    parentFS = rdrNameFS parent
+    ctorFS = rdrNameFS ctor
+    go [] = AppendParent
+    go (L _ ie : rest)
+      | parentNameIs parentFS ie = case ie of
+          IEThingAll {} -> AlreadyExported
+          IEThingAbs {} -> UpgradeBare
+          _ | Just cs <- ieThingWithChildren ie ->
+                if any ((== ctorFS) . lieWrappedNameFS) cs then AlreadyExported else AddChild
+            | otherwise -> go rest
+      | otherwise = go rest

plugins/hls-export-plugin/src/Ide/Plugin/Export/Exports.hs

@@ -5,11 +5,15 @@ module Ide.Plugin.Export.Exports
   , addConstructorExport
   ) where
 
-import           Data.Maybe                   (isJust)
+import           Data.Maybe                         (isJust)
+import           Data.Text                          (Text)
+import           Data.Text.Utf16.Rope.Mixed         (Rope)
 import           Development.IDE.GHC.Compat
-import           Development.IDE.GHC.Error    (srcSpanToRange)
+import           Development.IDE.GHC.Error          (srcSpanToRange)
+import           Development.IDE.GHC.ExactPrint.CPP (spanHasCpp)
 import           Ide.Plugin.Export.ExactPrint
 import           Ide.Plugin.Export.Utils
+import           Language.Haskell.GHC.ExactPrint    (makeDeltaAst)
 import           Language.LSP.Protocol.Types
 
 isExplicit :: ParsedSource -> Bool
@@ -24,15 +28,39 @@ isExported n ps = case hsmodExports (unLoc ps) of
     nFS = rdrNameFS n
     covers ie = parentNameIs nFS ie || isInIE nFS ie
 
-replaceExportList :: ParsedSource -> (LExportList -> Maybe LExportList) -> Maybe [TextEdit]
-replaceExportList ps f = do
+-- | Extract the export list and pick an edit strategy: splice surgically when
+-- the span holds a CPP directive, otherwise reprint the whole transformed list.
+withExportList
+  :: Maybe Rope
+  -> ParsedSource
+  -> (LExportList -> Maybe LExportList)          -- ^ reprint transform
+  -> (Range -> LExportList -> Maybe [TextEdit])  -- ^ list holds a directive
+  -> Maybe [TextEdit]
+withExportList msrc ps reprint onCpp = do
   exports <- hsmodExports (unLoc ps)
-  newList <- f (toDeltaExportList exports)
-  r <- srcSpanToRange (getLoc exports)
-  Just [TextEdit r (printExportList newList)]
+  full <- srcSpanToRange (getLoc exports)
+  if spanHasCpp msrc full
+    then onCpp full exports
+    else do
+      newList <- reprint (makeDeltaAst exports)
+      Just [TextEdit full (printExportList newList)]
 
-addExport :: ParsedSource -> LIE GhcPs -> Maybe [TextEdit]
-addExport ps item = replaceExportList ps (Just . appendIE item)
+addExport :: Maybe Rope -> ParsedSource -> LIE GhcPs -> Maybe [TextEdit]
+addExport msrc ps item =
+  withExportList msrc ps (Just . appendIE item) $ \full _ ->
+    Just [insertAfterOpen full (printIE item)]
 
-addConstructorExport :: RdrName -> RdrName -> ParsedSource -> Maybe [TextEdit]
-addConstructorExport parent ctor ps = replaceExportList ps (addCtorUnderParent parent ctor)
+addConstructorExport :: Maybe Rope -> RdrName -> RdrName -> ParsedSource -> Maybe [TextEdit]
+addConstructorExport msrc parent ctor ps =
+  withExportList msrc ps (addCtorUnderParent parent ctor) $ \full exports ->
+    (\txt -> [insertAfterOpen full txt]) <$> freshCtorEntry parent ctor (unLoc exports)
+
+-- | Splice @itemTxt@ in right after the opening paren with a trailing comma,
+-- @( <itemTxt>, <existing> )@. Valid in every CPP branch: a first item needs no
+-- leading separator and a trailing comma is always legal.
+insertAfterOpen :: Range -> Text -> TextEdit
+insertAfterOpen (Range (Position sl sc) _) itemTxt =
+  TextEdit (Range pos pos) (" " <> itemTxt <> ",")
+  where
+    -- `sc` is the column of `(`, so insert just past it.
+    pos = Position sl (sc + 1)