Wingman: maintain user-defined fixity for definitions (#1697)

* Pass the discovered node to withSmallest/Largest

* Maintain fixity when doing case split

* New layout tests

* Fix tests

* Fix tests wrt new infrastructure

* Update stack yamls

* Update cabal index state

* Forgot a stack yaml

* New commit to hopefully fix CI

* operational is broken upstream

* I dunno what I'm doing

Co-authored-by: Javier Neira <[email protected]>

Author: isovector

cabal.project

@@ -36,7 +36,7 @@ source-repository-package
 
 write-ghc-environment-files: never
 
-index-state: 2021-06-30T16:00:00Z
+index-state: 2021-07-12T16:00:00Z
 
 constraints:
     -- Diagrams doesn't support optparse-applicative >= 0.16 yet

ghcide/src/Development/IDE/GHC/ExactPrint.hs

@@ -338,7 +338,7 @@ genericGraftWithSmallestM ::
     -- | The type of nodes we'd like to consider when finding the smallest.
     Proxy (Located ast) ->
     SrcSpan ->
-    (DynFlags -> GenericM (TransformT m)) ->
+    (DynFlags -> ast -> GenericM (TransformT m)) ->
     Graft m a
 genericGraftWithSmallestM proxy dst trans = Graft $ \dflags ->
     smallestM (genericIsSubspan proxy dst) (trans dflags)
@@ -351,7 +351,7 @@ genericGraftWithLargestM ::
     -- | The type of nodes we'd like to consider when finding the largest.
     Proxy (Located ast) ->
     SrcSpan ->
-    (DynFlags -> GenericM (TransformT m)) ->
+    (DynFlags -> ast -> GenericM (TransformT m)) ->
     Graft m a
 genericGraftWithLargestM proxy dst trans = Graft $ \dflags ->
     largestM (genericIsSubspan proxy dst) (trans dflags)

ghcide/src/Generics/SYB/GHC.hs

@@ -29,9 +29,9 @@ genericIsSubspan ::
     -- | The type of nodes we'd like to consider.
     Proxy (Located ast) ->
     SrcSpan ->
-    GenericQ (Maybe Bool)
+    GenericQ (Maybe (Bool, ast))
 genericIsSubspan _ dst = mkQ Nothing $ \case
-  (L span _ :: Located ast) -> Just $ dst `isSubspanOf` span
+  (L span ast :: Located ast) -> Just (dst `isSubspanOf` span, ast)
 
 
 -- | Lift a function that replaces a value with several values into a generic
@@ -70,19 +70,19 @@ type GenericMQ r m = forall a. Data a => a -> m (r, a)
 -- with data nodes, so for any given node we can only definitely return an
 -- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is
 -- used.
-smallestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m
+smallestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m
 smallestM q f = fmap snd . go
   where
     go :: GenericMQ Any m
     go x = do
       case q x of
         Nothing -> gmapMQ go x
-        Just True -> do
+        Just (True, a) -> do
           it@(r, x') <- gmapMQ go x
           case r of
             Any True  -> pure it
-            Any False -> fmap (Any True,) $ f x'
-        Just False -> pure (mempty, x)
+            Any False -> fmap (Any True,) $ f a x'
+        Just (False, _) -> pure (mempty, x)
 
 ------------------------------------------------------------------------------
 -- | Apply the given 'GenericM' at every node that passes the 'GenericQ', but
@@ -94,14 +94,14 @@ smallestM q f = fmap snd . go
 -- with data nodes, so for any given node we can only definitely return an
 -- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is
 -- used.
-largestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m
+largestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m
 largestM q f = go
   where
     go :: GenericM m
     go x = do
       case q x of
-        Just True  -> f x
-        Just False -> pure x
+        Just (True, a)  -> f a x
+        Just (False, _) -> pure x
         Nothing    -> gmapM go x
 
 newtype MonadicQuery r m a = MonadicQuery

plugins/hls-tactics-plugin/hls-tactics-plugin.cabal

@@ -76,7 +76,7 @@ library
     , ghc
     , ghc-boot-th
     , ghc-exactprint
-    , ghc-source-gen
+    , ghc-source-gen        ^>=0.4.1
     , ghcide                ^>=1.4
     , hls-graph
     , hls-plugin-api        ^>=1.1

plugins/hls-tactics-plugin/src/Wingman/CaseSplit.hs

@@ -11,7 +11,7 @@ import           Data.Set (Set)
 import qualified Data.Set as S
 import           Development.IDE.GHC.Compat
 import           GHC.Exts (IsString (fromString))
-import           GHC.SourceGen (funBinds, match, wildP)
+import           GHC.SourceGen (funBindsWithFixity, match, wildP)
 import           OccName
 import           Wingman.GHC
 import           Wingman.Types
@@ -72,12 +72,16 @@ rewriteVarPat name rep = everywhere $
 ------------------------------------------------------------------------------
 -- | Construct an 'HsDecl' from a set of 'AgdaMatch'es.
 splitToDecl
-    :: OccName  -- ^ The name of the function
+    :: Maybe LexicalFixity
+    -> OccName  -- ^ The name of the function
     -> [AgdaMatch]
     -> LHsDecl GhcPs
-splitToDecl name ams = noLoc $ funBinds (fromString . occNameString . occName $ name) $ do
-  AgdaMatch pats body <- ams
-  pure $ match pats body
+splitToDecl fixity name ams = do
+  traceX "fixity" fixity $
+    noLoc $
+      funBindsWithFixity fixity (fromString . occNameString . occName $ name) $ do
+        AgdaMatch pats body <- ams
+        pure $ match pats body
 
 
 ------------------------------------------------------------------------------

plugins/hls-tactics-plugin/src/Wingman/Judgements.hs

@@ -375,6 +375,10 @@ jHasBoundArgs
   . jLocalHypothesis
 
 
+jNeedsToBindArgs :: Judgement' CType -> Bool
+jNeedsToBindArgs = isFunTy . unCType . jGoal
+
+
 ------------------------------------------------------------------------------
 -- | Fold a hypothesis into a single mapping from name to info. This
 -- unavoidably will cause duplicate names (things like methods) to shadow one

plugins/hls-tactics-plugin/src/Wingman/Plugin.hs

@@ -31,6 +31,7 @@ import           System.Timeout
 import           Wingman.CaseSplit
 import           Wingman.EmptyCase
 import           Wingman.GHC
+import           Wingman.Judgements (jNeedsToBindArgs)
 import           Wingman.LanguageServer
 import           Wingman.LanguageServer.Metaprogram (hoverProvider)
 import           Wingman.LanguageServer.TacticProviders
@@ -189,20 +190,36 @@ graftHole
     -> Graft (Either String) ParsedSource
 graftHole span rtr
   | _jIsTopHole (rtr_jdg rtr)
-      = genericGraftWithSmallestM (Proxy @(Located [LMatch GhcPs (LHsExpr GhcPs)])) span $ \dflags ->
-        everywhereM'
-          $ mkBindListT $ \ix ->
-            graftDecl dflags span ix $ \name pats ->
-            splitToDecl (occName name)
-          $ iterateSplit
-          $ mkFirstAgda (fmap unXPat pats)
-          $ unLoc
-          $ rtr_extract rtr
+      = genericGraftWithSmallestM
+            (Proxy @(Located [LMatch GhcPs (LHsExpr GhcPs)])) span
+      $ \dflags matches ->
+          everywhereM'
+            $ mkBindListT $ \ix ->
+              graftDecl dflags span ix $ \name pats ->
+              splitToDecl
+                (case not $ jNeedsToBindArgs (rtr_jdg rtr) of
+                   -- If the user has explicitly bound arguments, use the
+                   -- fixity they wrote.
+                   True -> matchContextFixity . m_ctxt . unLoc
+                             =<< listToMaybe matches
+                   -- Otherwise, choose based on the name of the function.
+                   False -> Nothing
+                )
+                (occName name)
+            $ iterateSplit
+            $ mkFirstAgda (fmap unXPat pats)
+            $ unLoc
+            $ rtr_extract rtr
 graftHole span rtr
   = graft span
   $ rtr_extract rtr
 
 
+matchContextFixity :: HsMatchContext p -> Maybe LexicalFixity
+matchContextFixity (FunRhs _ l _) = Just l
+matchContextFixity _ = Nothing
+
+
 ------------------------------------------------------------------------------
 -- | Helper function to route 'mergeFunBindMatches' into the right place in an
 -- AST --- correctly dealing with inserting into instance declarations.

plugins/hls-tactics-plugin/src/Wingman/Types.hs

@@ -154,6 +154,9 @@ instance Show TyCon where
 instance Show ConLike where
   show  = unsafeRender
 
+instance Show LexicalFixity where
+  show  = unsafeRender
+
 
 ------------------------------------------------------------------------------
 -- | The state that should be shared between subgoals. Extracts move towards

plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs

@@ -113,3 +113,7 @@ spec = do
       , (id, DestructLambdaCase, "")
       ]
 
+    -- test layouts that maintain user-written fixities
+    destructTest "b"  3 13 "LayoutInfixKeep"
+    destructTest "b"  2 12 "LayoutPrefixKeep"
+

plugins/hls-tactics-plugin/test/golden/KnownBigSemigroup.expected.hs

@@ -3,7 +3,7 @@ import Data.Monoid
 data Big a = Big [Bool] (Sum Int) String (Endo a) Any
 
 instance Semigroup (Big a) where
-  (<>) (Big bs sum s en any) (Big bs' sum' str en' any')
+  (Big bs sum s en any) <> (Big bs' sum' str en' any')
     = Big
         (bs <> bs') (sum <> sum') (s <> str) (en <> en') (any <> any')