From 1f7da6e203ca73cc20fcf32275f8490c4b6cc555 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Tue, 6 Apr 2021 06:37:00 -0700 Subject: [PATCH 1/4] Use infix notation for operator applications --- plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs | 12 ++++++++++++ plugins/hls-tactics-plugin/src/Wingman/Tactics.hs | 3 +-- .../hls-tactics-plugin/test/CodeAction/AutoSpec.hs | 2 ++ .../hls-tactics-plugin/test/golden/AutoInfixApply.hs | 3 +++ .../test/golden/AutoInfixApply.hs.expected | 3 +++ .../test/golden/AutoInfixApplyMany.hs | 3 +++ .../test/golden/AutoInfixApplyMany.hs.expected | 3 +++ .../test/golden/FmapJoin.hs.expected | 2 +- .../test/golden/FmapJoinInLet.hs.expected | 2 +- 9 files changed, 29 insertions(+), 4 deletions(-) create mode 100644 plugins/hls-tactics-plugin/test/golden/AutoInfixApply.hs create mode 100644 plugins/hls-tactics-plugin/test/golden/AutoInfixApply.hs.expected create mode 100644 plugins/hls-tactics-plugin/test/golden/AutoInfixApplyMany.hs create mode 100644 plugins/hls-tactics-plugin/test/golden/AutoInfixApplyMany.hs.expected diff --git a/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs b/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs index 632f6e12e7..dd89ac4609 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs @@ -10,10 +10,12 @@ module Wingman.CodeGen import ConLike +import Control.Applicative (liftA2) import Control.Lens ((%~), (<>~), (&)) import Control.Monad.Except import Control.Monad.State import Data.Bool (bool) +import Data.Char (isSymbol, isPunctuation) import Data.Generics.Labels () import Data.List import Data.Maybe (mapMaybe) @@ -27,6 +29,7 @@ import GHC.SourceGen.Binds import GHC.SourceGen.Expr import GHC.SourceGen.Overloaded import GHC.SourceGen.Pat +import GhcPlugins (occNameString) import PatSyn import Type hiding (Var) import Wingman.CodeGen.Utils @@ -204,3 +207,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) + | all (liftA2 (||) isSymbol isPunctuation) (occNameString 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 3f91497e95..0c25e27b9a 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs @@ -21,7 +21,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 @@ -193,7 +192,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 2b12243f6c..58fe9ad87a 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs @@ -50,6 +50,8 @@ 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" 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/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 From 58ec7424d902a4df8e0d25a72c2006fe5b777b79 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Tue, 6 Apr 2021 08:00:17 -0700 Subject: [PATCH 2/4] Update tests --- .../test/golden/KnownBigSemigroup.hs.expected | 6 +----- .../test/golden/KnownCounterfactualSemigroup.hs.expected | 2 +- .../test/golden/KnownDestructedSemigroup.hs.expected | 2 +- .../test/golden/KnownMissingSemigroup.hs.expected | 2 +- .../test/golden/KnownModuleInstanceSemigroup.hs.expected | 2 +- .../test/golden/KnownThetaSemigroup.hs.expected | 2 +- 6 files changed, 6 insertions(+), 10 deletions(-) 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 beb49829f1..e5b5c850f9 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_c7 i8) (Semi l_l_c i) - = Semi ((<>) l_l_c7 l_l_c) ((<>) i8 i) + = Semi (l_l_c7 <> l_l_c) (i8 <> 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 9ed929c47c..44291558f2 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 a6) (Semi a) = Semi ((<>) a6 a) + (<>) (Semi a6) (Semi a) = Semi (a6 <> a) From 9782d7be4d52321ec92497d604f0eff9e9c6bf47 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 8 Apr 2021 12:25:01 -0700 Subject: [PATCH 3/4] Add test suggest by Ailrun --- plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs | 1 + plugins/hls-tactics-plugin/test/golden/AutoInfixInfix.hs | 2 ++ .../hls-tactics-plugin/test/golden/AutoInfixInfix.hs.expected | 2 ++ 3 files changed, 5 insertions(+) create mode 100644 plugins/hls-tactics-plugin/test/golden/AutoInfixInfix.hs create mode 100644 plugins/hls-tactics-plugin/test/golden/AutoInfixInfix.hs.expected diff --git a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs index 0d10cf3e82..0c81255756 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs @@ -52,6 +52,7 @@ spec = do 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/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 From eb3ca24c83191f671379474d373a2cb6d439eacf Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 8 Apr 2021 13:15:21 -0700 Subject: [PATCH 4/4] Use isSymOcc --- plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs b/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs index 19fd229823..3e38363369 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs @@ -10,12 +10,10 @@ module Wingman.CodeGen import ConLike -import Control.Applicative (liftA2) import Control.Lens ((%~), (<>~), (&)) import Control.Monad.Except import Control.Monad.State import Data.Bool (bool) -import Data.Char (isSymbol, isPunctuation) import Data.Generics.Labels () import Data.List import Data.Monoid (Endo(..)) @@ -28,7 +26,7 @@ import GHC.SourceGen.Binds import GHC.SourceGen.Expr import GHC.SourceGen.Overloaded import GHC.SourceGen.Pat -import GhcPlugins (occNameString) +import GhcPlugins (isSymOcc) import PatSyn import Type hiding (Var) import Wingman.CodeGen.Utils @@ -211,7 +209,7 @@ buildDataCon should_blacklist jdg dc tyapps = do -- | Make a function application, correctly handling the infix case. mkApply :: OccName -> [HsExpr GhcPs] -> LHsExpr GhcPs mkApply occ (lhs : rhs : more) - | all (liftA2 (||) isSymbol isPunctuation) (occNameString occ) + | isSymOcc occ = noLoc $ foldl' (@@) (op lhs (coerceName occ) rhs) more mkApply occ args = noLoc $ foldl' (@@) (var' occ) args