diff --git a/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs b/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs index f0e8e09ab5..3e38363369 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs @@ -26,6 +26,7 @@ import GHC.SourceGen.Binds import GHC.SourceGen.Expr import GHC.SourceGen.Overloaded import GHC.SourceGen.Pat +import GhcPlugins (isSymOcc) import PatSyn import Type hiding (Var) import Wingman.CodeGen.Utils @@ -203,3 +204,12 @@ buildDataCon should_blacklist jdg dc tyapps = do & #syn_trace %~ rose (show dc) . pure & #syn_val %~ mkCon dc tyapps + +------------------------------------------------------------------------------ +-- | Make a function application, correctly handling the infix case. +mkApply :: OccName -> [HsExpr GhcPs] -> LHsExpr GhcPs +mkApply occ (lhs : rhs : more) + | isSymOcc occ + = noLoc $ foldl' (@@) (op lhs (coerceName occ) rhs) more +mkApply occ args = noLoc $ foldl' (@@) (var' occ) args + diff --git a/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs b/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs index e1fad30d46..30f9c953fa 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs @@ -22,7 +22,6 @@ import DataCon import Development.IDE.GHC.Compat import GHC.Exts import GHC.SourceGen.Expr -import GHC.SourceGen.Overloaded import Name (occNameString, occName) import Refinery.Tactic import Refinery.Tactic.Internal @@ -204,7 +203,7 @@ apply hi = requireConcreteHole $ tracing ("apply' " <> show (hi_name hi)) $ do pure $ ext & #syn_used_vals %~ S.insert func - & #syn_val %~ noLoc . foldl' (@@) (var' func) . fmap unLoc + & #syn_val %~ mkApply func . fmap unLoc ------------------------------------------------------------------------------ diff --git a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs index e4da91f3c0..0c81255756 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs @@ -50,6 +50,9 @@ spec = do autoTest 2 16 "AutoEmptyString.hs" autoTest 7 35 "AutoPatSynUse.hs" autoTest 2 28 "AutoZip.hs" + autoTest 2 17 "AutoInfixApply.hs" + autoTest 2 19 "AutoInfixApplyMany.hs" + autoTest 2 25 "AutoInfixInfix.hs" failing "flaky in CI" $ autoTest 2 11 "GoldenApplicativeThen.hs" diff --git a/plugins/hls-tactics-plugin/test/golden/AutoInfixApply.hs b/plugins/hls-tactics-plugin/test/golden/AutoInfixApply.hs new file mode 100644 index 0000000000..4675331aea --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/AutoInfixApply.hs @@ -0,0 +1,3 @@ +test :: (a -> b -> c) -> a -> (a -> b) -> c +test (/:) a f = _ + diff --git a/plugins/hls-tactics-plugin/test/golden/AutoInfixApply.hs.expected b/plugins/hls-tactics-plugin/test/golden/AutoInfixApply.hs.expected new file mode 100644 index 0000000000..367f6e54d9 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/AutoInfixApply.hs.expected @@ -0,0 +1,3 @@ +test :: (a -> b -> c) -> a -> (a -> b) -> c +test (/:) a f = a /: f a + diff --git a/plugins/hls-tactics-plugin/test/golden/AutoInfixApplyMany.hs b/plugins/hls-tactics-plugin/test/golden/AutoInfixApplyMany.hs new file mode 100644 index 0000000000..55a706ab9b --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/AutoInfixApplyMany.hs @@ -0,0 +1,3 @@ +test :: (a -> b -> x -> c) -> a -> (a -> b) -> x -> c +test (/:) a f x = _ + diff --git a/plugins/hls-tactics-plugin/test/golden/AutoInfixApplyMany.hs.expected b/plugins/hls-tactics-plugin/test/golden/AutoInfixApplyMany.hs.expected new file mode 100644 index 0000000000..ce40bf0cd6 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/AutoInfixApplyMany.hs.expected @@ -0,0 +1,3 @@ +test :: (a -> b -> x -> c) -> a -> (a -> b) -> x -> c +test (/:) a f x = (a /: f a) x + diff --git a/plugins/hls-tactics-plugin/test/golden/AutoInfixInfix.hs b/plugins/hls-tactics-plugin/test/golden/AutoInfixInfix.hs new file mode 100644 index 0000000000..729e1a2227 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/AutoInfixInfix.hs @@ -0,0 +1,2 @@ +test :: (a -> b -> c) -> (c -> d -> e) -> a -> (a -> b) -> d -> e +test (/:) (-->) a f x = _ diff --git a/plugins/hls-tactics-plugin/test/golden/AutoInfixInfix.hs.expected b/plugins/hls-tactics-plugin/test/golden/AutoInfixInfix.hs.expected new file mode 100644 index 0000000000..7adea169d1 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/AutoInfixInfix.hs.expected @@ -0,0 +1,2 @@ +test :: (a -> b -> c) -> (c -> d -> e) -> a -> (a -> b) -> d -> e +test (/:) (-->) a f x = (a /: f a) --> x diff --git a/plugins/hls-tactics-plugin/test/golden/FmapJoin.hs.expected b/plugins/hls-tactics-plugin/test/golden/FmapJoin.hs.expected index 8064301c89..ede310d808 100644 --- a/plugins/hls-tactics-plugin/test/golden/FmapJoin.hs.expected +++ b/plugins/hls-tactics-plugin/test/golden/FmapJoin.hs.expected @@ -1,2 +1,2 @@ fJoin :: (Monad m, Monad f) => f (m (m a)) -> f (m a) -fJoin = fmap (\ mma -> (>>=) mma id) +fJoin = fmap (\ mma -> mma >>= id) diff --git a/plugins/hls-tactics-plugin/test/golden/FmapJoinInLet.hs.expected b/plugins/hls-tactics-plugin/test/golden/FmapJoinInLet.hs.expected index a9a9f04f9e..ebdd0a2ebb 100644 --- a/plugins/hls-tactics-plugin/test/golden/FmapJoinInLet.hs.expected +++ b/plugins/hls-tactics-plugin/test/golden/FmapJoinInLet.hs.expected @@ -1,4 +1,4 @@ {-# LANGUAGE ScopedTypeVariables #-} fJoin :: forall f m a. (Monad m, Monad f) => f (m (m a)) -> f (m a) -fJoin = let f = ( (\ mma -> (>>=) mma id) :: m (m a) -> m a) in fmap f +fJoin = let f = ( (\ mma -> mma >>= id) :: m (m a) -> m a) in fmap f diff --git a/plugins/hls-tactics-plugin/test/golden/KnownBigSemigroup.hs.expected b/plugins/hls-tactics-plugin/test/golden/KnownBigSemigroup.hs.expected index 995c5b0f42..b388428aa8 100644 --- a/plugins/hls-tactics-plugin/test/golden/KnownBigSemigroup.hs.expected +++ b/plugins/hls-tactics-plugin/test/golden/KnownBigSemigroup.hs.expected @@ -5,9 +5,5 @@ data Big a = Big [Bool] (Sum Int) String (Endo a) Any instance Semigroup (Big a) where (<>) (Big l_b7 si8 l_c9 ea10 a11) (Big l_b si l_c ea a) = Big - ((<>) l_b7 l_b) - ((<>) si8 si) - ((<>) l_c9 l_c) - ((<>) ea10 ea) - ((<>) a11 a) + (l_b7 <> l_b) (si8 <> si) (l_c9 <> l_c) (ea10 <> ea) (a11 <> a) diff --git a/plugins/hls-tactics-plugin/test/golden/KnownCounterfactualSemigroup.hs.expected b/plugins/hls-tactics-plugin/test/golden/KnownCounterfactualSemigroup.hs.expected index 6ad86685f6..5612a05b7d 100644 --- a/plugins/hls-tactics-plugin/test/golden/KnownCounterfactualSemigroup.hs.expected +++ b/plugins/hls-tactics-plugin/test/golden/KnownCounterfactualSemigroup.hs.expected @@ -4,5 +4,5 @@ data Semi = Semi [String] Int instance Semigroup Int => Semigroup Semi where (<>) (Semi l_l_c5 i6) (Semi l_l_c i) - = Semi ((<>) l_l_c5 l_l_c) ((<>) i6 i) + = Semi (l_l_c5 <> l_l_c) (i6 <> i) diff --git a/plugins/hls-tactics-plugin/test/golden/KnownDestructedSemigroup.hs.expected b/plugins/hls-tactics-plugin/test/golden/KnownDestructedSemigroup.hs.expected index 9515b7fd84..868331fae9 100644 --- a/plugins/hls-tactics-plugin/test/golden/KnownDestructedSemigroup.hs.expected +++ b/plugins/hls-tactics-plugin/test/golden/KnownDestructedSemigroup.hs.expected @@ -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) diff --git a/plugins/hls-tactics-plugin/test/golden/KnownMissingSemigroup.hs.expected b/plugins/hls-tactics-plugin/test/golden/KnownMissingSemigroup.hs.expected index 07d9a235ec..3e1adde221 100644 --- a/plugins/hls-tactics-plugin/test/golden/KnownMissingSemigroup.hs.expected +++ b/plugins/hls-tactics-plugin/test/golden/KnownMissingSemigroup.hs.expected @@ -1,5 +1,5 @@ data Semi = Semi [String] Int instance Semigroup Semi where - (<>) (Semi l_l_c4 i5) (Semi l_l_c i) = Semi ((<>) l_l_c4 l_l_c) _ + (<>) (Semi l_l_c4 i5) (Semi l_l_c i) = Semi (l_l_c4 <> l_l_c) _ diff --git a/plugins/hls-tactics-plugin/test/golden/KnownModuleInstanceSemigroup.hs.expected b/plugins/hls-tactics-plugin/test/golden/KnownModuleInstanceSemigroup.hs.expected index 498cca1a04..9bd4de84a5 100644 --- a/plugins/hls-tactics-plugin/test/golden/KnownModuleInstanceSemigroup.hs.expected +++ b/plugins/hls-tactics-plugin/test/golden/KnownModuleInstanceSemigroup.hs.expected @@ -7,5 +7,5 @@ instance Semigroup Foo where data Bar = Bar Foo Foo instance Semigroup Bar where - (<>) (Bar f4 f5) (Bar f f3) = Bar ((<>) f4 f) ((<>) f5 f3) + (<>) (Bar f4 f5) (Bar f f3) = Bar (f4 <> f) (f5 <> f3) diff --git a/plugins/hls-tactics-plugin/test/golden/KnownThetaSemigroup.hs.expected b/plugins/hls-tactics-plugin/test/golden/KnownThetaSemigroup.hs.expected index 0d63d0f95f..3d85f9f3a6 100644 --- a/plugins/hls-tactics-plugin/test/golden/KnownThetaSemigroup.hs.expected +++ b/plugins/hls-tactics-plugin/test/golden/KnownThetaSemigroup.hs.expected @@ -1,5 +1,5 @@ data Semi a = Semi a instance Semigroup a => Semigroup (Semi a) where - (<>) (Semi a4) (Semi a) = Semi ((<>) a4 a) + (<>) (Semi a4) (Semi a) = Semi (a4 <> a)