wip

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

@@ -47,7 +47,8 @@ module Development.IDE.GHC.ExactPrint
       ExceptStringT (..),
       TransformT,
       Log(..),
-      insertAtStart',
+      prependDecl,
+      prependDeclToWhereDecls,
     )
 where
 
@@ -115,6 +116,8 @@ import GHC.Types.SrcLoc (generatedSrcSpan)
 import GHC (Anchor(..))
 import GHC (AnchorOperation(..))
 import GHC (realSrcSpan)
+import GHC (EpAnnComments(..))
+import Debug.Trace (traceShowM, trace, traceM)
 #endif
 
 #if MIN_VERSION_ghc(9,2,0)
@@ -509,6 +512,62 @@ insertAtStart' old newDecl = do
             d
       in newDecl' : secondDecl' : ds
     insertDeclAtStart _ d ds = d : ds
+
+prependDeclToWhereDecls decl newWhereDecl = do
+  traceShowM "tag2"
+  ds <- balanceCommentsList =<< hsDecls decl
+  traceShowM "tag3"
+  let ds' = prependDecl (wrapDecl newWhereDecl) ds
+  traceShowM "tag4"
+  replaceDecls decl ds'
+
+prependDecl :: LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
+prependDecl ldecl = \case
+   [] -> [setEntryDP ldecl (DifferentLine 1 2)]
+   ld1:lds -> ldecl':ld1'':lds
+     where
+       (ancOp, ld1'') = case ld1 of
+         L (SrcSpanAnn (EpAnn d1Anc d1Ann (EpaComments (L (Anchor c1Rss cAnc) c1:restCs))) ss) d1 ->
+           -- NOTE cannot use setEntryDP to simply assign `DL 1 0` here because when there is no prior decl, the
+           --      DeltaPos on the declaration is absolute instead of relative, and so we must manually update the
+           --      DeltaPos to be relative (since there is about to be a prior declaration).
+           let ld1' = L
+                 (SrcSpanAnn
+                   (EpAnn
+                     (setAnchorDp d1Anc $ DifferentLine 1 0)
+                     d1Ann
+                     (EpaCommentsBalanced (L (Anchor c1Rss $ MovedAnchor $ DifferentLine 1 0) c1:restCs) []))
+                   ss)
+                 d1
+           in (cAnc, ld1')
+         (L (SrcSpanAnn (EpAnn d1Anc d1Ann (EpaCommentsBalanced (L (Anchor c1Rss cAnc) c1:restCs) d1AfterCs)) ss) d1) ->
+           -- NOTE cannot use setEntryDP to simply assign `DL 1 0` here because when there is no prior decl, the
+           --      DeltaPos on the declaration is absolute instead of relative, and so we must manually update the
+           --      DeltaPos to be relative (since there is about to be a prior declaration).
+           let ld1' = L
+                 (SrcSpanAnn
+                   (EpAnn
+                     (setAnchorDp d1Anc $ DifferentLine 1 0)
+                     d1Ann
+                     (EpaCommentsBalanced (L (Anchor c1Rss $ MovedAnchor $ DifferentLine 1 0) c1:restCs) d1AfterCs))
+                   ss)
+                 d1
+           in (cAnc, ld1')
+         (L (SrcSpanAnn (EpAnn (Anchor d1Rss d1AncOp) d1Ann epaCs@(EpaComments [])) ss) d1) ->
+           let ld1' = L (SrcSpanAnn (EpAnn (Anchor d1Rss $ MovedAnchor $ DifferentLine 1 0) d1Ann epaCs) ss) d1
+           in (d1AncOp, ld1')
+         (L (SrcSpanAnn (EpAnn (Anchor d1Rss d1AncOp) d1Ann epaCs@(EpaCommentsBalanced [] _)) ss) d1) ->
+           let ld1' = L (SrcSpanAnn (EpAnn (Anchor d1Rss $ MovedAnchor $ DifferentLine 1 0) d1Ann epaCs) ss) d1
+           in (d1AncOp, ld1')
+         L (SrcSpanAnn EpAnnNotUsed _) _ -> trace "tag6" error "Unexpected EpAnnNotUsed"
+       ldecl' = setEntryDP ldecl (maybe (trace "tag7" error "what to do with UnchangedAnchor?") id $ getAnchorOpDp ancOp)
+
+setAnchorDp :: Anchor -> DeltaPos -> Anchor
+setAnchorDp (Anchor rss _) dp = Anchor rss (MovedAnchor dp)
+
+getAnchorOpDp :: AnchorOperation -> Maybe DeltaPos
+getAnchorOpDp (MovedAnchor dp) = Just dp
+getAnchorOpDp UnchangedAnchor = Nothing
 #endif
 
 graftSmallestDeclsWithM ::

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

@@ -110,6 +110,8 @@ import           GHC                                               (AddEpAnn (Ad
                                                                     EpaLocation (..),
                                                                     LEpaComment,
                                                                     LocatedA)
+import Debug.Trace
+import Control.Lens (bimap)
 
 #else
 import           Language.Haskell.GHC.ExactPrint.Types             (Annotation (annsDP),
@@ -1008,7 +1010,7 @@ addAsLastArgument (ParsedModule _ parsedSource _ _) range name _typ =
 
 -- TODO use typ to initialise type signature
 addToWhere :: ParsedModule -> Range -> T.Text -> Maybe T.Text -> Either ResponseError [(T.Text, [TextEdit])]
-addToWhere (ParsedModule _ parsedSource _ _) range name _typ = do
+addToWhere (ParsedModule _ parsedSource _ _) range name _typ = bimap traceShowId id $ do
   let mkUnqual name = noLocA $ mkRdrUnqual $ mkVarOcc $ T.unpack name
       equalAnn dp = AddEpAnn AnnEqual (EpaDelta dp [])
       addArg = modifySmallestDeclWithM (flip spanContainsRangeOrErr range) $ \case
@@ -1027,8 +1029,9 @@ addToWhere (ParsedModule _ parsedSource _ _) range name _typ = do
                     newDeclMatch =
                       noLocA (Match newDeclMatchAnn (FunRhs (mkUnqual name) Prefix SrcStrict) [] grhss)
                     newDeclMg = MG NoExtField (L (noAnnSrcSpanDP0 declMatchSrcSpan) [newDeclMatch]) Generated
-                    newDecl = ValD xVal (FunBind NoExtField (mkUnqual name) newDeclMg [])
-                hoistTransform (Right . runIdentity) $ insertAtStart' match newDecl
+                    newDecl = (FunBind NoExtField (mkUnqual name) newDeclMg [])
+                traceShowM "tag1"
+                prependDeclToWhereDecls match (noLocA newDecl)
               else pure match
           let decl' = L locDecl (ValD xVal (FunBind xFunBind idFunBind mg' coreFunBind))
           pure [decl']

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

@@ -2380,8 +2380,8 @@ addFunctionArgumentTests =
 addToWhereTests :: TestTree
 addToWhereTests =
   testGroup
-    "add to where"
-  [ testSession "insert new where" $ do
+    "add_to_where"
+  [ testSession "insert_new_where" $ do
       let foo =
             [ "module Foo where"
             , ""
@@ -2458,9 +2458,8 @@ addToWhereTests =
             , "bar = 1"
             , ""
             , "foo True = _select [True]"
-            , " where"
-            , "  _select = _"
-            , "  baz = 2"
+            , " where _select = _"
+            , "       baz = 2"
             , "foo False = False"
             ]
       docB <- createDoc "ModuleB.hs" "haskell" (T.unlines foo)
@@ -2489,7 +2488,7 @@ addToWhereTests =
             , ""
             , "foo True = _select [True]"
             , "  where"
-            , "    _select = _"
+            , "  _select = _"
             , "foo False = False"
             ]
       docB <- createDoc "ModuleB.hs" "haskell" (T.unlines foo)
@@ -2518,7 +2517,7 @@ addToWhereTests =
             , ""
             , "foo True = _select [True]"
             , "  where"
-            , "    _select = _"
+            , "  _select = _"
             , "foo False = False"
             ]
       docB <- createDoc "ModuleB.hs" "haskell" (T.unlines foo)
@@ -2552,21 +2551,21 @@ addToWhereTests =
       executeCodeAction action
       contentAfterAction <- documentContents docB
       liftIO $ contentAfterAction @?= T.unlines foo'
-  , testSession "untyped error" $ do
+  , testSession "untyped_error" $ do
       let foo =
             [ "module Foo where"
             , ""
-            , "foo = bar"
+            , "foo = new_def"
             , "  where"
             , "    -- hi"
             , "    baz = 2"
             ]
           foo' =
             [ "module Foo where"
             , ""
-            , "foo = bar"
+            , "foo = new_def"
             , "  where"
-            , "    bar = _"
+            , "    new_def = _"
             , "    "
             , "        -- hibaz = 2"
             ]
@@ -2575,7 +2574,7 @@ addToWhereTests =
       InR action@CodeAction { _title = actionTitle } : _
                     <- filter (\(InR CodeAction{_title=x}) -> "Add to " `isPrefixOf` T.unpack x ) <$>
                      getCodeActions docB (R 2 0 2 50)
-      liftIO $ actionTitle @?= "Add to where ‘bar’"
+      liftIO $ actionTitle @?= "Add to where ‘new_def’"
       executeCodeAction action
       contentAfterAction <- documentContents docB
       liftIO $ contentAfterAction @?= T.unlines foo'