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 <atreyu.bbb@gmail.com>

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')
 

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

@@ -3,5 +3,5 @@
 data Semi = Semi [String] Int
 
 instance Semigroup Int => Semigroup Semi where
-  (<>) (Semi ss n) (Semi strs i) = Semi (ss <> strs) (n <> i)
+  (Semi ss n) <> (Semi strs i) = Semi (ss <> strs) (n <> i)
 

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

@@ -1,5 +1,5 @@
 data Test a = Test [a]
 
 instance Semigroup (Test a) where
-  (<>) (Test a) (Test c) = Test (a <> c)
+  (Test a) <> (Test c) = Test (a <> c)
 

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

@@ -1,5 +1,5 @@
 data Semi = Semi [String] Int
 
 instance Semigroup Semi where
-  (<>) (Semi ss n) (Semi strs i) = Semi (ss <> strs) _
+  (Semi ss n) <> (Semi strs i) = Semi (ss <> strs) _
 

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

@@ -7,6 +7,6 @@ instance Semigroup Foo where
 data Bar = Bar Foo Foo
 
 instance Semigroup Bar where
-  (<>) (Bar foo foo') (Bar foo2 foo3)
+  (Bar foo foo') <> (Bar foo2 foo3)
     = Bar (foo <> foo2) (foo' <> foo3)
 

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

@@ -1,5 +1,5 @@
 data Semi a = Semi a
 
 instance Semigroup a => Semigroup (Semi a) where
-  (<>) (Semi a) (Semi a') = Semi (a <> a')
+  (Semi a) <> (Semi a') = Semi (a <> a')
 

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

@@ -0,0 +1,5 @@
+-- keep layout that was written by the user in infix
+foo :: Bool -> a -> a
+False `foo` a = _
+True `foo` a = _
+

plugins/hls-tactics-plugin/test/golden/LayoutInfixKeep.hs

@@ -0,0 +1,4 @@
+-- keep layout that was written by the user in infix
+foo :: Bool -> a -> a
+b `foo` a = _
+

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

@@ -0,0 +1,4 @@
+(-/) :: Bool -> a -> a
+(-/) False a = _
+(-/) True a = _
+

plugins/hls-tactics-plugin/test/golden/LayoutPrefixKeep.hs

@@ -0,0 +1,3 @@
+(-/) :: Bool -> a -> a
+(-/) b a = _
+

stack-8.10.2.yaml

@@ -43,6 +43,7 @@ extra-deps:
   - ghc-exactprint-0.6.4
   - ghc-lib-8.10.4.20210206
   - ghc-lib-parser-8.10.4.20210206
+  - ghc-source-gen-0.4.1.0
   - lsp-1.2.0.0
   - lsp-types-1.2.0.0
   - lsp-test-0.14.0.0

stack-8.10.3.yaml

@@ -43,6 +43,7 @@ extra-deps:
   - ghc-exactprint-0.6.4
   - ghc-lib-8.10.4.20210206
   - ghc-lib-parser-8.10.4.20210206
+  - ghc-source-gen-0.4.1.0
   - heapsize-0.3.0
   - hie-bios-0.7.5
   - implicit-hie-cradle-0.3.0.2

stack-8.10.4.yaml

@@ -41,6 +41,7 @@ extra-deps:
     commit: 8fee87eac97a538dbe81ff1ab18cff10f2f9fa15
   - ghc-check-0.5.0.4
   - ghc-exactprint-0.6.4
+  - ghc-source-gen-0.4.1.0
   - heapsize-0.3.0
   - implicit-hie-cradle-0.3.0.2
   - implicit-hie-0.1.2.5

stack-8.10.5.yaml

@@ -43,6 +43,7 @@ extra-deps:
     commit: 8fee87eac97a538dbe81ff1ab18cff10f2f9fa15
   - ghc-check-0.5.0.4
   - ghc-exactprint-0.6.4
+  - ghc-source-gen-0.4.1.0
   - heapsize-0.3.0
   - implicit-hie-cradle-0.3.0.2
   - implicit-hie-0.1.2.5

stack-8.6.4.yaml

@@ -52,7 +52,7 @@ extra-deps:
   - ghc-lib-8.10.4.20210206
   - ghc-lib-parser-8.10.4.20210206
   - ghc-lib-parser-ex-8.10.0.17
-  - ghc-source-gen-0.4.0.0
+  - ghc-source-gen-0.4.1.0
   - ghc-trace-events-0.1.2.1
   - haddock-api-2.22.0@rev:1
   - haddock-library-1.10.0

stack-8.6.5.yaml

@@ -53,7 +53,7 @@ extra-deps:
   - ghc-lib-8.10.4.20210206
   - ghc-lib-parser-8.10.4.20210206
   - ghc-lib-parser-ex-8.10.0.17
-  - ghc-source-gen-0.4.0.0
+  - ghc-source-gen-0.4.1.0
   - ghc-trace-events-0.1.2.1
   - haddock-api-2.22.0@rev:1
   - haddock-library-1.10.0

stack-8.8.3.yaml

@@ -45,6 +45,7 @@ extra-deps:
   - ghc-exactprint-0.6.4
   - ghc-lib-8.10.4.20210206
   - ghc-lib-parser-8.10.4.20210206
+  - ghc-source-gen-0.4.1.0
   - ghc-trace-events-0.1.2.1
   - haskell-src-exts-1.21.1
   - heapsize-0.3.0

stack-8.8.4.yaml

@@ -45,6 +45,7 @@ extra-deps:
   - ghc-exactprint-0.6.4
   - ghc-lib-8.10.4.20210206
   - ghc-lib-parser-8.10.4.20210206
+  - ghc-source-gen-0.4.1.0
   - ghc-trace-events-0.1.2.1
   - haskell-src-exts-1.21.1
   - heapsize-0.3.0

stack-9.0.1.yaml

@@ -41,6 +41,7 @@ extra-deps:
 - ghc-lib-9.0.1.20210324@sha256:c8b9a2541ea3424c8d0e4f80584477d0f35be03f4a47d931152042d5f446c5fc,19279
 - ghc-lib-parser-9.0.1.20210324@sha256:fb680f78d4ab08b5d089a05bda3b84ad857e5edcc2e4ca7c188c0207d369af80
 - ghc-lib-parser-ex-9.0.0.4@sha256:8282b11c3797fc8ba225b245e736cc9a0745d9c48d0f9fea7f9bffb5c9997709,3642
+- ghc-source-gen-0.4.1.0
 - haddock-library-1.10.0@sha256:2a6c239da9225951a5d837e1ce373faeeae60d1345c78dd0a0b0f29df30c4fe9,4098
 - heapsize-0.3.0.1@sha256:0b69aa97a46d819b700ac7b145f3b5493c3565cf2c5b8298682238d405d0326e,1417
 - hiedb-0.4.0.0
@@ -94,6 +95,7 @@ extra-deps:
   commit: ca23431a8dfa013992f9164ccc882a3277361f17
 # https://github.com/diagrams/active/pull/36
 
+
 # benchmark dependency
 - github: HeinrichApfelmus/operational
   commit: 16e19aaf34e286f3d27b3988c61040823ec66537

stack.yaml

@@ -38,6 +38,7 @@ extra-deps:
   - fourmolu-0.3.0.0
   - ghc-api-compat-8.6
   - ghc-exactprint-0.6.4
+  - ghc-source-gen-0.4.1.0
   - heapsize-0.3.0
   - implicit-hie-cradle-0.3.0.2
   - implicit-hie-0.1.2.5