From 9038baee1737d106ca72feacd5336f340bf7aed4 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 11 Feb 2021 13:54:23 -0800 Subject: [PATCH 01/18] More tests of overlapping methods --- test/functional/Tactic.hs | 3 +++ test/testdata/tactic/Fgmap.hs | 2 ++ test/testdata/tactic/Fgmap.hs.expected | 2 ++ test/testdata/tactic/FmapJoin.hs | 2 ++ test/testdata/tactic/FmapJoin.hs.expected | 2 ++ test/testdata/tactic/FmapJoinInLet.hs | 4 ++++ test/testdata/tactic/FmapJoinInLet.hs.expected | 4 ++++ 7 files changed, 19 insertions(+) create mode 100644 test/testdata/tactic/Fgmap.hs create mode 100644 test/testdata/tactic/Fgmap.hs.expected create mode 100644 test/testdata/tactic/FmapJoin.hs create mode 100644 test/testdata/tactic/FmapJoin.hs.expected create mode 100644 test/testdata/tactic/FmapJoinInLet.hs create mode 100644 test/testdata/tactic/FmapJoinInLet.hs.expected diff --git a/test/functional/Tactic.hs b/test/functional/Tactic.hs index 6e33a96a90..d46dc8ff29 100644 --- a/test/functional/Tactic.hs +++ b/test/functional/Tactic.hs @@ -117,6 +117,9 @@ tests = testGroup , expectFail "GoldenFish.hs" 5 18 Auto "" , goldenTest "GoldenArbitrary.hs" 25 13 Auto "" , goldenTest "FmapBoth.hs" 2 12 Auto "" + , goldenTest "FmapJoin.hs" 2 14 Auto "" + , goldenTest "Fgmap.hs" 2 9 Auto "" + , goldenTest "FmapJoinInLet.hs" 4 19 Auto "" ] diff --git a/test/testdata/tactic/Fgmap.hs b/test/testdata/tactic/Fgmap.hs new file mode 100644 index 0000000000..de1968474e --- /dev/null +++ b/test/testdata/tactic/Fgmap.hs @@ -0,0 +1,2 @@ +fgmap :: (Functor f, Functor g) => (a -> b) -> (f (g a) -> f (g b)) +fgmap = _ diff --git a/test/testdata/tactic/Fgmap.hs.expected b/test/testdata/tactic/Fgmap.hs.expected new file mode 100644 index 0000000000..98345b23c9 --- /dev/null +++ b/test/testdata/tactic/Fgmap.hs.expected @@ -0,0 +1,2 @@ +fgmap :: (Functor f, Functor g) => (a -> b) -> (f (g a) -> f (g b)) +fgmap = (\ fab fga -> fmap (\ a -> fmap fab a) fga) diff --git a/test/testdata/tactic/FmapJoin.hs b/test/testdata/tactic/FmapJoin.hs new file mode 100644 index 0000000000..98a40133ea --- /dev/null +++ b/test/testdata/tactic/FmapJoin.hs @@ -0,0 +1,2 @@ +fJoin :: (Monad m, Monad f) => f (m (m a)) -> f (m a) +fJoin = fmap _ diff --git a/test/testdata/tactic/FmapJoin.hs.expected b/test/testdata/tactic/FmapJoin.hs.expected new file mode 100644 index 0000000000..733e090b72 --- /dev/null +++ b/test/testdata/tactic/FmapJoin.hs.expected @@ -0,0 +1,2 @@ +fJoin :: (Monad m, Monad f) => f (m (m a)) -> f (m a) +fJoin = fmap (\ mma -> (>>=) mma (\ ma -> ma)) diff --git a/test/testdata/tactic/FmapJoinInLet.hs b/test/testdata/tactic/FmapJoinInLet.hs new file mode 100644 index 0000000000..e6fe6cbd0d --- /dev/null +++ b/test/testdata/tactic/FmapJoinInLet.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +fJoin :: forall f m a. (Monad m, Monad f) => f (m (m a)) -> f (m a) +fJoin = let f = (_ :: m (m a) -> m a) in fmap f diff --git a/test/testdata/tactic/FmapJoinInLet.hs.expected b/test/testdata/tactic/FmapJoinInLet.hs.expected new file mode 100644 index 0000000000..b8bf0cdd07 --- /dev/null +++ b/test/testdata/tactic/FmapJoinInLet.hs.expected @@ -0,0 +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 (\ ma -> ma)) :: m (m a) -> m a) in fmap f From b9b3aefc30befe1e3eae17d62da505279a907fa7 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 11 Feb 2021 15:57:17 -0800 Subject: [PATCH 02/18] Do a simplification pass of the extract --- .../hls-tactics-plugin.cabal | 1 + .../src/Ide/Plugin/Tactic.hs | 1 + .../src/Ide/Plugin/Tactic/Machinery.hs | 3 +- .../src/Ide/Plugin/Tactic/Simplify.hs | 82 +++++++++++++++++++ .../src/Ide/Plugin/Tactic/Types.hs | 3 + test/testdata/tactic/Fgmap.hs.expected | 2 +- test/testdata/tactic/FmapJoin.hs.expected | 2 +- .../testdata/tactic/FmapJoinInLet.hs.expected | 2 +- .../tactic/GoldenIdTypeFam.hs.expected | 2 +- .../tactic/GoldenShowCompose.hs.expected | 2 +- 10 files changed, 94 insertions(+), 6 deletions(-) create mode 100644 plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs diff --git a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal index 393d1f8cd4..23b11e545f 100644 --- a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal +++ b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal @@ -34,6 +34,7 @@ library Ide.Plugin.Tactic.Machinery Ide.Plugin.Tactic.Naming Ide.Plugin.Tactic.Range + Ide.Plugin.Tactic.Simplify Ide.Plugin.Tactic.Tactics Ide.Plugin.Tactic.Types Ide.Plugin.Tactic.TestTypes diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs index 5182161f25..a261080aab 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs @@ -327,6 +327,7 @@ tacticCmd tac lf state (TacticParams uri range var_name) $ ResponseError InvalidRequest (T.pack $ show err) Nothing Right rtr -> do traceMX "solns" $ rtr_other_solns rtr + traceMX "after simplification" $ rtr_extract rtr let g = graft (RealSrcSpan span) $ rtr_extract rtr response = transform dflags (clientCapabilities lf) uri g pm pure $ case response of diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Machinery.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Machinery.hs index dd307da2ca..53be6d0e05 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Machinery.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Machinery.hs @@ -41,6 +41,7 @@ import Refinery.Tactic.Internal import TcType import Type import Unify +import Ide.Plugin.Tactic.Simplify (simplify) substCTy :: TCvSubst -> CType -> CType @@ -97,7 +98,7 @@ runTactic ctx jdg t = case sorted of (((tr, ext), _) : _) -> Right - . RunTacticResults tr ext + . RunTacticResults tr (simplify ext) . reverse . fmap fst $ take 5 sorted diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs new file mode 100644 index 0000000000..92c32ab28e --- /dev/null +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.Tactic.Simplify + ( simplify + ) where + +import Data.Data (Data) +import Data.Generics (everywhere, somewhere, something, listify, extT, mkT, GenericT, mkQ) +import Data.List.Extra (unsnoc) +import Data.Maybe (isJust) +import Development.IDE.GHC.Compat +import GHC.Exts (fromString) +import GHC.SourceGen (var, op) +import GHC.SourceGen.Expr (lambda) + + +pattern Lambda :: [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs +pattern Lambda pats body <- + HsLam _ + (MG {mg_alts = L _ [L _ + (Match { m_pats = pats + , m_grhss = GRHSs {grhssGRHSs = [L _ ( + GRHS _ [] (L _ body))]} + })]}) + where + Lambda [] body = body + Lambda pats body = lambda pats body + + +simplify :: LHsExpr GhcPs -> LHsExpr GhcPs +simplify = head . drop 3 . iterate (everywhere compose . everywhere etaReduce) + + +contains :: Data a => RdrName -> a -> Bool +contains name x = not $ null $ listify ( + \case + ((HsVar _ (L _ a)) :: HsExpr GhcPs) | a == name -> True + _ -> False + ) x + + +etaReduce :: GenericT +etaReduce = mkT $ \case + Lambda + [VarPat _ (L _ pat)] + (HsVar _ (L _ a)) | pat == a -> + var "id" + Lambda + (unsnoc -> Just (pats, (VarPat _ (L _ pat)))) + (HsApp _ (L _ f) (L _ (HsVar _ (L _ a)))) + | pat == a + , not (contains pat f) -> + Lambda pats f + x -> x + + +compose :: GenericT +compose = mkT $ \case + Lambda + (unsnoc -> Just (pats, (VarPat _ (L _ pat)))) + (unroll -> (fs@(_:_), (HsVar _ (L _ a)))) + | pat == a + , not (contains pat fs) -> + Lambda pats (foldr1 (infixCall ".") fs) + x -> x + + +infixCall :: String -> HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs +infixCall s = flip op (fromString s) + + +unroll :: HsExpr GhcPs -> ([HsExpr GhcPs], HsExpr GhcPs) +unroll (HsPar _ (L _ x)) = unroll x +unroll (HsApp _ (L _ f) (L _ a)) = + let (fs, r) = unroll a + in (f : fs, r) +unroll x = ([], x) + diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Types.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Types.hs index ac0ab3dff1..a60049de48 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Types.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Types.hs @@ -70,6 +70,9 @@ instance Show DataCon where instance Show Class where show = unsafeRender +instance Show (HsExpr GhcPs) where + show = unsafeRender + ------------------------------------------------------------------------------ data TacticState = TacticState diff --git a/test/testdata/tactic/Fgmap.hs.expected b/test/testdata/tactic/Fgmap.hs.expected index 98345b23c9..8c0b9a2f4a 100644 --- a/test/testdata/tactic/Fgmap.hs.expected +++ b/test/testdata/tactic/Fgmap.hs.expected @@ -1,2 +1,2 @@ fgmap :: (Functor f, Functor g) => (a -> b) -> (f (g a) -> f (g b)) -fgmap = (\ fab fga -> fmap (\ a -> fmap fab a) fga) +fgmap = (fmap . fmap) diff --git a/test/testdata/tactic/FmapJoin.hs.expected b/test/testdata/tactic/FmapJoin.hs.expected index 733e090b72..d7734b82cb 100644 --- a/test/testdata/tactic/FmapJoin.hs.expected +++ b/test/testdata/tactic/FmapJoin.hs.expected @@ -1,2 +1,2 @@ fJoin :: (Monad m, Monad f) => f (m (m a)) -> f (m a) -fJoin = fmap (\ mma -> (>>=) mma (\ ma -> ma)) +fJoin = fmap (\ mma -> (>>=) mma (id)) diff --git a/test/testdata/tactic/FmapJoinInLet.hs.expected b/test/testdata/tactic/FmapJoinInLet.hs.expected index b8bf0cdd07..e6175f9493 100644 --- a/test/testdata/tactic/FmapJoinInLet.hs.expected +++ b/test/testdata/tactic/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 (\ ma -> ma)) :: 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/test/testdata/tactic/GoldenIdTypeFam.hs.expected b/test/testdata/tactic/GoldenIdTypeFam.hs.expected index ad5697334e..7b3d1beda0 100644 --- a/test/testdata/tactic/GoldenIdTypeFam.hs.expected +++ b/test/testdata/tactic/GoldenIdTypeFam.hs.expected @@ -4,4 +4,4 @@ type family TyFam type instance TyFam = Int tyblah' :: TyFam -> Int -tyblah' = (\ i -> i) +tyblah' = id diff --git a/test/testdata/tactic/GoldenShowCompose.hs.expected b/test/testdata/tactic/GoldenShowCompose.hs.expected index 373ea6af91..e672cc6a02 100644 --- a/test/testdata/tactic/GoldenShowCompose.hs.expected +++ b/test/testdata/tactic/GoldenShowCompose.hs.expected @@ -1,2 +1,2 @@ showCompose :: Show a => (b -> a) -> b -> String -showCompose = (\ fba b -> show (fba b)) +showCompose = (\ fba -> show . fba) From dbf7b46ebc52a460b568a49311b17d3319ce45e0 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 11 Feb 2021 16:00:04 -0800 Subject: [PATCH 03/18] Do less work when simplifiying --- plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs index 92c32ab28e..b4d7ad64e1 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs @@ -32,7 +32,7 @@ pattern Lambda pats body <- simplify :: LHsExpr GhcPs -> LHsExpr GhcPs -simplify = head . drop 3 . iterate (everywhere compose . everywhere etaReduce) +simplify = head . drop 3 . iterate (everywhere $ compose . etaReduce) contains :: Data a => RdrName -> a -> Bool From 2ef7975e68f454a93c8d1a5e900d5aba1c4c74c8 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 11 Feb 2021 16:02:23 -0800 Subject: [PATCH 04/18] Remove unnecessary parens simplification --- .../hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs index b4d7ad64e1..d75da3a3eb 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs @@ -32,7 +32,7 @@ pattern Lambda pats body <- simplify :: LHsExpr GhcPs -> LHsExpr GhcPs -simplify = head . drop 3 . iterate (everywhere $ compose . etaReduce) +simplify = head . drop 3 . iterate (everywhere $ removeParens . compose . etaReduce) contains :: Data a => RdrName -> a -> Bool @@ -69,6 +69,12 @@ compose = mkT $ \case x -> x +removeParens :: GenericT +removeParens = mkT $ \case + HsPar _ (L _ x) | isAtomicHsExpr x -> x + (x :: HsExpr GhcPs) -> x + + infixCall :: String -> HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs infixCall s = flip op (fromString s) From a08773c7f6d5eab1359738c46dc5632813d0f66b Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 11 Feb 2021 16:06:29 -0800 Subject: [PATCH 05/18] Implement simplify as a fold over endos --- .../src/Ide/Plugin/Tactic/Simplify.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs index d75da3a3eb..31f68155b8 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs @@ -12,6 +12,7 @@ import Data.Data (Data) import Data.Generics (everywhere, somewhere, something, listify, extT, mkT, GenericT, mkQ) import Data.List.Extra (unsnoc) import Data.Maybe (isJust) +import Data.Monoid (Endo (..)) import Development.IDE.GHC.Compat import GHC.Exts (fromString) import GHC.SourceGen (var, op) @@ -32,7 +33,15 @@ pattern Lambda pats body <- simplify :: LHsExpr GhcPs -> LHsExpr GhcPs -simplify = head . drop 3 . iterate (everywhere $ removeParens . compose . etaReduce) +simplify = head . drop 3 . iterate (everywhere $ foldEndo + [ etaReduce + , removeParens + , compose + ]) + + +foldEndo :: Foldable t => t (a -> a) -> a -> a +foldEndo = appEndo . foldMap Endo contains :: Data a => RdrName -> a -> Bool From 25171bc4322d2e7cf172cc679b718ae4b1ea7fd8 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 11 Feb 2021 16:09:13 -0800 Subject: [PATCH 06/18] Fix tests --- test/testdata/tactic/FmapJoin.hs.expected | 2 +- test/testdata/tactic/FmapJoinInLet.hs.expected | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/test/testdata/tactic/FmapJoin.hs.expected b/test/testdata/tactic/FmapJoin.hs.expected index d7734b82cb..8064301c89 100644 --- a/test/testdata/tactic/FmapJoin.hs.expected +++ b/test/testdata/tactic/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/test/testdata/tactic/FmapJoinInLet.hs.expected b/test/testdata/tactic/FmapJoinInLet.hs.expected index e6175f9493..a9a9f04f9e 100644 --- a/test/testdata/tactic/FmapJoinInLet.hs.expected +++ b/test/testdata/tactic/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 b47acedfe9b120904a1a27232ee84198e688c59b Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 11 Feb 2021 16:24:22 -0800 Subject: [PATCH 07/18] Haddock for the new module --- .../src/Ide/Plugin/Tactic/Simplify.hs | 59 +++++++++++++------ 1 file changed, 42 insertions(+), 17 deletions(-) diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs index 31f68155b8..b443e67778 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs @@ -19,6 +19,8 @@ import GHC.SourceGen (var, op) import GHC.SourceGen.Expr (lambda) +------------------------------------------------------------------------------ +-- | A pattern over the otherwise (extremely) messy AST for lambdas. pattern Lambda :: [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs pattern Lambda pats body <- HsLam _ @@ -28,32 +30,47 @@ pattern Lambda pats body <- GRHS _ [] (L _ body))]} })]}) where + -- If there are no patterns to bind, just stick in the body Lambda [] body = body Lambda pats body = lambda pats body +------------------------------------------------------------------------------ +-- | Simlify an expression. simplify :: LHsExpr GhcPs -> LHsExpr GhcPs -simplify = head . drop 3 . iterate (everywhere $ foldEndo - [ etaReduce - , removeParens - , compose - ]) - - +simplify + = head + . drop 3 -- Do three passes; this should be good enough for the limited + -- amount of gas we give to auto + . iterate (everywhere $ foldEndo + [ simplifyEtaReduce + , simplifyRemoveParens + , simplifyCompose + ]) + + +------------------------------------------------------------------------------ +-- | Like 'foldMap' but for endomorphisms. foldEndo :: Foldable t => t (a -> a) -> a -> a foldEndo = appEndo . foldMap Endo -contains :: Data a => RdrName -> a -> Bool -contains name x = not $ null $ listify ( +------------------------------------------------------------------------------ +-- | Does this thing contain any references to 'HsVar's with the given +-- 'RdrName'? +containsHsVar :: Data a => RdrName -> a -> Bool +containsHsVar name x = not $ null $ listify ( \case ((HsVar _ (L _ a)) :: HsExpr GhcPs) | a == name -> True _ -> False ) x -etaReduce :: GenericT -etaReduce = mkT $ \case +------------------------------------------------------------------------------ +-- | Perform an eta reduction. For example, transforms @\x -> (f g) x@ into +-- @f g@. +simplifyEtaReduce :: GenericT +simplifyEtaReduce = mkT $ \case Lambda [VarPat _ (L _ pat)] (HsVar _ (L _ a)) | pat == a -> @@ -62,24 +79,29 @@ etaReduce = mkT $ \case (unsnoc -> Just (pats, (VarPat _ (L _ pat)))) (HsApp _ (L _ f) (L _ (HsVar _ (L _ a)))) | pat == a - , not (contains pat f) -> + , not (containsHsVar pat f) -> Lambda pats f x -> x -compose :: GenericT -compose = mkT $ \case +------------------------------------------------------------------------------ +-- | Perform an eta-reducing function composition. For example, transforms +-- @\x -> f (g (h x))@ into @f . g . h@. +simplifyCompose :: GenericT +simplifyCompose = mkT $ \case Lambda (unsnoc -> Just (pats, (VarPat _ (L _ pat)))) (unroll -> (fs@(_:_), (HsVar _ (L _ a)))) | pat == a - , not (contains pat fs) -> + , not (containsHsVar pat fs) -> Lambda pats (foldr1 (infixCall ".") fs) x -> x -removeParens :: GenericT -removeParens = mkT $ \case +------------------------------------------------------------------------------ +-- | Removes unnecessary parentheses on any token that doesn't need them. +simplifyRemoveParens :: GenericT +simplifyRemoveParens = mkT $ \case HsPar _ (L _ x) | isAtomicHsExpr x -> x (x :: HsExpr GhcPs) -> x @@ -88,6 +110,9 @@ infixCall :: String -> HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs infixCall s = flip op (fromString s) +------------------------------------------------------------------------------ +-- | Unrolls a right-associative function application of the form +-- @HsApp f (HsApp g (HsApp h x))@ into @([f, g, h], x)@. unroll :: HsExpr GhcPs -> ([HsExpr GhcPs], HsExpr GhcPs) unroll (HsPar _ (L _ x)) = unroll x unroll (HsApp _ (L _ f) (L _ a)) = From 8ba082b8e01cc1d7edabcb320bdedfba1722aba1 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 11 Feb 2021 16:26:49 -0800 Subject: [PATCH 08/18] Minor note on implementation --- plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs index b443e67778..9513f17f36 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs @@ -79,6 +79,7 @@ simplifyEtaReduce = mkT $ \case (unsnoc -> Just (pats, (VarPat _ (L _ pat)))) (HsApp _ (L _ f) (L _ (HsVar _ (L _ a)))) | pat == a + -- We can only perform this simplifiation if @pat@ is otherwise unused. , not (containsHsVar pat f) -> Lambda pats f x -> x @@ -93,6 +94,7 @@ simplifyCompose = mkT $ \case (unsnoc -> Just (pats, (VarPat _ (L _ pat)))) (unroll -> (fs@(_:_), (HsVar _ (L _ a)))) | pat == a + -- We can only perform this simplifiation if @pat@ is otherwise unused. , not (containsHsVar pat fs) -> Lambda pats (foldr1 (infixCall ".") fs) x -> x From 1302c6d9a7cc1598db2251e8df291201c87d0439 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 11 Feb 2021 16:30:27 -0800 Subject: [PATCH 09/18] Note a TODO --- plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs index 9513f17f36..a6339da7c7 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs @@ -108,6 +108,7 @@ simplifyRemoveParens = mkT $ \case (x :: HsExpr GhcPs) -> x +-- TODO(sandy): Copypasted from CodeGen. Fix before merging infixCall :: String -> HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs infixCall s = flip op (fromString s) From 4a1650f9ab6b4d6b37d8ffa65333cd7c8eef69f2 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 11 Feb 2021 17:14:52 -0800 Subject: [PATCH 10/18] Use PatCompat to unpack patterns --- plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/GHC.hs | 2 +- .../hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs | 7 ++++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/GHC.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/GHC.hs index 5cba1d20b6..c0942aa2a8 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/GHC.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/GHC.hs @@ -112,7 +112,7 @@ lambdaCaseable (splitFunTy_maybe -> Just (arg, res)) = Just $ isJust $ algebraicTyCon res lambdaCaseable _ = Nothing -fromPatCompat :: PatCompat GhcTc -> Pat GhcTc +fromPatCompat :: PatCompat ps -> Pat ps #if __GLASGOW_HASKELL__ == 808 type PatCompat pass = Pat pass fromPatCompat = id diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs index a6339da7c7..30c1df5b6f 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs @@ -17,6 +17,7 @@ import Development.IDE.GHC.Compat import GHC.Exts (fromString) import GHC.SourceGen (var, op) import GHC.SourceGen.Expr (lambda) +import Ide.Plugin.Tactic.GHC (fromPatCompat) ------------------------------------------------------------------------------ @@ -72,11 +73,11 @@ containsHsVar name x = not $ null $ listify ( simplifyEtaReduce :: GenericT simplifyEtaReduce = mkT $ \case Lambda - [VarPat _ (L _ pat)] + [fromPatCompat -> VarPat _ (L _ pat)] (HsVar _ (L _ a)) | pat == a -> var "id" Lambda - (unsnoc -> Just (pats, (VarPat _ (L _ pat)))) + (fmap fromPatCompat -> unsnoc -> Just (pats, (VarPat _ (L _ pat)))) (HsApp _ (L _ f) (L _ (HsVar _ (L _ a)))) | pat == a -- We can only perform this simplifiation if @pat@ is otherwise unused. @@ -91,7 +92,7 @@ simplifyEtaReduce = mkT $ \case simplifyCompose :: GenericT simplifyCompose = mkT $ \case Lambda - (unsnoc -> Just (pats, (VarPat _ (L _ pat)))) + (fmap fromPatCompat -> unsnoc -> Just (pats, (VarPat _ (L _ pat)))) (unroll -> (fs@(_:_), (HsVar _ (L _ a)))) | pat == a -- We can only perform this simplifiation if @pat@ is otherwise unused. From 7ba73ac7441e49ebef4e294cd84a118ce153cbcd Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 11 Feb 2021 17:25:14 -0800 Subject: [PATCH 11/18] Pull out codegen utilities to break a cyclic dependency --- .../hls-tactics-plugin.cabal | 1 + .../src/Ide/Plugin/Tactic/CodeGen.hs | 61 +---------------- .../src/Ide/Plugin/Tactic/CodeGen/Utils.hs | 67 +++++++++++++++++++ .../src/Ide/Plugin/Tactic/Simplify.hs | 6 +- 4 files changed, 72 insertions(+), 63 deletions(-) create mode 100644 plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen/Utils.hs diff --git a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal index 23b11e545f..f6e6b8fd4e 100644 --- a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal +++ b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal @@ -25,6 +25,7 @@ library Ide.Plugin.Tactic Ide.Plugin.Tactic.Auto Ide.Plugin.Tactic.CodeGen + Ide.Plugin.Tactic.CodeGen.Utils Ide.Plugin.Tactic.Context Ide.Plugin.Tactic.Debug Ide.Plugin.Tactic.GHC diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen.hs index 1cab232a7a..785dea0018 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} module Ide.Plugin.Tactic.CodeGen where @@ -18,7 +18,6 @@ import Data.Traversable import DataCon import Development.IDE.GHC.Compat import GHC.Exts -import GHC.SourceGen (RdrNameStr) import GHC.SourceGen.Binds import GHC.SourceGen.Expr import GHC.SourceGen.Overloaded @@ -28,7 +27,7 @@ import Ide.Plugin.Tactic.Judgements import Ide.Plugin.Tactic.Machinery import Ide.Plugin.Tactic.Naming import Ide.Plugin.Tactic.Types -import Name +import Ide.Plugin.Tactic.CodeGen.Utils import Type hiding (Var) @@ -202,57 +201,3 @@ buildDataCon jdg dc apps = do . (rose (show dc) $ pure tr,) $ mkCon dc sgs - -mkCon :: DataCon -> [LHsExpr GhcPs] -> LHsExpr GhcPs -mkCon dcon (fmap unLoc -> args) - | isTupleDataCon dcon = - noLoc $ tuple args - | dataConIsInfix dcon - , (lhs : rhs : args') <- args = - noLoc $ foldl' (@@) (op lhs (coerceName dcon_name) rhs) args' - | otherwise = - noLoc $ foldl' (@@) (bvar' $ occName dcon_name) args - where - dcon_name = dataConName dcon - - - -coerceName :: HasOccName a => a -> RdrNameStr -coerceName = fromString . occNameString . occName - - - ------------------------------------------------------------------------------- --- | Like 'var', but works over standard GHC 'OccName's. -var' :: Var a => OccName -> a -var' = var . fromString . occNameString - - ------------------------------------------------------------------------------- --- | Like 'bvar', but works over standard GHC 'OccName's. -bvar' :: BVar a => OccName -> a -bvar' = bvar . fromString . occNameString - - ------------------------------------------------------------------------------- --- | Get an HsExpr corresponding to a function name. -mkFunc :: String -> HsExpr GhcPs -mkFunc = var' . mkVarOcc - - ------------------------------------------------------------------------------- --- | Get an HsExpr corresponding to a value name. -mkVal :: String -> HsExpr GhcPs -mkVal = var' . mkVarOcc - - ------------------------------------------------------------------------------- --- | Like 'op', but easier to call. -infixCall :: String -> HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs -infixCall s = flip op (fromString s) - - ------------------------------------------------------------------------------- --- | Like '(@@)', but uses a dollar instead of parentheses. -appDollar :: HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs -appDollar = infixCall "$" diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen/Utils.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen/Utils.hs new file mode 100644 index 0000000000..e3551cc660 --- /dev/null +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen/Utils.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.Tactic.CodeGen.Utils where + +import Data.List +import DataCon +import Development.IDE.GHC.Compat +import GHC.Exts +import GHC.SourceGen (RdrNameStr) +import GHC.SourceGen.Overloaded +import Name + + +------------------------------------------------------------------------------ +-- | Make a data constructor with the given arguments. +mkCon :: DataCon -> [LHsExpr GhcPs] -> LHsExpr GhcPs +mkCon dcon (fmap unLoc -> args) + | isTupleDataCon dcon = + noLoc $ tuple args + | dataConIsInfix dcon + , (lhs : rhs : args') <- args = + noLoc $ foldl' (@@) (op lhs (coerceName dcon_name) rhs) args' + | otherwise = + noLoc $ foldl' (@@) (bvar' $ occName dcon_name) args + where + dcon_name = dataConName dcon + + +coerceName :: HasOccName a => a -> RdrNameStr +coerceName = fromString . occNameString . occName + + +------------------------------------------------------------------------------ +-- | Like 'var', but works over standard GHC 'OccName's. +var' :: Var a => OccName -> a +var' = var . fromString . occNameString + + +------------------------------------------------------------------------------ +-- | Like 'bvar', but works over standard GHC 'OccName's. +bvar' :: BVar a => OccName -> a +bvar' = bvar . fromString . occNameString + + +------------------------------------------------------------------------------ +-- | Get an HsExpr corresponding to a function name. +mkFunc :: String -> HsExpr GhcPs +mkFunc = var' . mkVarOcc + + +------------------------------------------------------------------------------ +-- | Get an HsExpr corresponding to a value name. +mkVal :: String -> HsExpr GhcPs +mkVal = var' . mkVarOcc + + +------------------------------------------------------------------------------ +-- | Like 'op', but easier to call. +infixCall :: String -> HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs +infixCall s = flip op (fromString s) + + +------------------------------------------------------------------------------ +-- | Like '(@@)', but uses a dollar instead of parentheses. +appDollar :: HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs +appDollar = infixCall "$" + diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs index 30c1df5b6f..f48d096e7b 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs @@ -17,6 +17,7 @@ import Development.IDE.GHC.Compat import GHC.Exts (fromString) import GHC.SourceGen (var, op) import GHC.SourceGen.Expr (lambda) +import Ide.Plugin.Tactic.CodeGen.Utils import Ide.Plugin.Tactic.GHC (fromPatCompat) @@ -109,11 +110,6 @@ simplifyRemoveParens = mkT $ \case (x :: HsExpr GhcPs) -> x --- TODO(sandy): Copypasted from CodeGen. Fix before merging -infixCall :: String -> HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs -infixCall s = flip op (fromString s) - - ------------------------------------------------------------------------------ -- | Unrolls a right-associative function application of the form -- @HsApp f (HsApp g (HsApp h x))@ into @([f, g, h], x)@. From 0b2cc537cf3ffca16fd7ab3eea29f177702f63ae Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 11 Feb 2021 17:28:17 -0800 Subject: [PATCH 12/18] Re-export utils --- plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen.hs | 5 ++++- .../hls-tactics-plugin/src/Ide/Plugin/Tactic/Machinery.hs | 2 +- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen.hs index 785dea0018..029eb971d3 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen.hs @@ -4,7 +4,10 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -module Ide.Plugin.Tactic.CodeGen where +module Ide.Plugin.Tactic.CodeGen + ( module Ide.Plugin.Tactic.CodeGen + , module Ide.Plugin.Tactic.CodeGen.Utils + ) where import Control.Lens ((+~), (%~), (<>~)) import Control.Monad.Except diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Machinery.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Machinery.hs index 53be6d0e05..787fb6bb7d 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Machinery.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Machinery.hs @@ -33,6 +33,7 @@ import Data.Set (Set) import qualified Data.Set as S import Development.IDE.GHC.Compat import Ide.Plugin.Tactic.Judgements +import Ide.Plugin.Tactic.Simplify (simplify) import Ide.Plugin.Tactic.Types import OccName (HasOccName(occName)) import Refinery.ProofState @@ -41,7 +42,6 @@ import Refinery.Tactic.Internal import TcType import Type import Unify -import Ide.Plugin.Tactic.Simplify (simplify) substCTy :: TCvSubst -> CType -> CType From 58057a0e40a6099be9e3be2dcc3c6857458f2f28 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 11 Feb 2021 17:53:08 -0800 Subject: [PATCH 13/18] No top-level parens for tactics --- ghcide/src/Development/IDE/GHC/ExactPrint.hs | 15 +++++- .../src/Ide/Plugin/Tactic.hs | 11 ++-- test/testdata/tactic/Fgmap.hs.expected | 2 +- test/testdata/tactic/FmapBoth.hs.expected | 4 +- .../tactic/GoldenArbitrary.hs.expected | 54 +++++++++---------- .../tactic/GoldenBigTuple.hs.expected | 2 +- .../tactic/GoldenEitherAuto.hs.expected | 8 +-- .../GoldenEitherHomomorphic.hs.expected | 8 +-- .../tactic/GoldenFmapTree.hs.expected | 8 +-- test/testdata/tactic/GoldenFoldr.hs.expected | 8 +-- .../tactic/GoldenFromMaybe.hs.expected | 8 +-- .../tactic/GoldenGADTAuto.hs.expected | 2 +- .../tactic/GoldenGADTDestruct.hs.expected | 2 +- .../GoldenGADTDestructCoercion.hs.expected | 2 +- .../tactic/GoldenIdentityFunctor.hs.expected | 2 +- test/testdata/tactic/GoldenIntros.hs.expected | 2 +- .../tactic/GoldenJoinCont.hs.expected | 2 +- .../tactic/GoldenListFmap.hs.expected | 8 +-- test/testdata/tactic/GoldenNote.hs.expected | 8 +-- .../tactic/GoldenPureList.hs.expected | 2 +- .../tactic/GoldenSafeHead.hs.expected | 8 +-- .../tactic/GoldenShowCompose.hs.expected | 2 +- .../tactic/GoldenShowMapChar.hs.expected | 2 +- test/testdata/tactic/GoldenSwap.hs.expected | 2 +- .../tactic/GoldenSwapMany.hs.expected | 2 +- 25 files changed, 95 insertions(+), 79 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/ExactPrint.hs b/ghcide/src/Development/IDE/GHC/ExactPrint.hs index b0636174a1..fe34a3b28c 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/ghcide/src/Development/IDE/GHC/ExactPrint.hs @@ -8,6 +8,7 @@ module Development.IDE.GHC.ExactPrint ( Graft(..), graft, + graftWithoutParentheses, graftDecls, graftDeclsWithM, annotate, @@ -179,8 +180,18 @@ graft :: SrcSpan -> Located ast -> Graft (Either String) a -graft dst val = Graft $ \dflags a -> do - (anns, val') <- annotate dflags $ maybeParensAST val +graft dst = graftWithoutParentheses dst . maybeParensAST + +-- | Like 'graft', but trusts that you have correctly inserted the parentheses +-- yourself. If you haven't, the resulting AST will not be valid! +graftWithoutParentheses :: + forall ast a. + (Data a, ASTElement ast) => + SrcSpan -> + Located ast -> + Graft (Either String) a +graftWithoutParentheses dst val = Graft $ \dflags a -> do + (anns, val') <- annotate dflags val modifyAnnsT $ mappend anns pure $ everywhere' diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs index a261080aab..446938ebeb 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs @@ -39,7 +39,7 @@ import Development.IDE.Core.Service (runAction) import Development.IDE.Core.Shake (useWithStale, IdeState (..)) import Development.IDE.GHC.Compat import Development.IDE.GHC.Error (realSrcSpanToRange) -import Development.IDE.GHC.ExactPrint (graft, transform, useAnnotatedSource) +import Development.IDE.GHC.ExactPrint (graft, transform, useAnnotatedSource, maybeParensAST) import Development.IDE.Spans.LocalBindings (getDefiningBindings) import Development.Shake (Action) import DynFlags (xopt) @@ -63,6 +63,8 @@ import Refinery.Tactic (goal) import SrcLoc (containsSpan) import System.Timeout import TcRnTypes (tcg_binds) +import Data.Bool (bool) +import Development.IDE.GHC.ExactPrint (graftWithoutParentheses) descriptor :: PluginId -> PluginDescriptor IdeState @@ -327,8 +329,11 @@ tacticCmd tac lf state (TacticParams uri range var_name) $ ResponseError InvalidRequest (T.pack $ show err) Nothing Right rtr -> do traceMX "solns" $ rtr_other_solns rtr - traceMX "after simplification" $ rtr_extract rtr - let g = graft (RealSrcSpan span) $ rtr_extract rtr + traceMX "simplified" $ rtr_extract rtr + let g = graftWithoutParentheses (RealSrcSpan span) + -- Parenthesize the extract iff we're not in a top level hole + $ bool maybeParensAST id (_jIsTopHole jdg) + $ rtr_extract rtr response = transform dflags (clientCapabilities lf) uri g pm pure $ case response of Right res -> (Right Null , Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams res)) diff --git a/test/testdata/tactic/Fgmap.hs.expected b/test/testdata/tactic/Fgmap.hs.expected index 8c0b9a2f4a..4f4921fa05 100644 --- a/test/testdata/tactic/Fgmap.hs.expected +++ b/test/testdata/tactic/Fgmap.hs.expected @@ -1,2 +1,2 @@ fgmap :: (Functor f, Functor g) => (a -> b) -> (f (g a) -> f (g b)) -fgmap = (fmap . fmap) +fgmap = fmap . fmap diff --git a/test/testdata/tactic/FmapBoth.hs.expected b/test/testdata/tactic/FmapBoth.hs.expected index a513b35a42..3160676e8f 100644 --- a/test/testdata/tactic/FmapBoth.hs.expected +++ b/test/testdata/tactic/FmapBoth.hs.expected @@ -1,4 +1,4 @@ fmapBoth :: (Functor f, Functor g) => (a -> b) -> (f a, g a) -> (f b, g b) -fmapBoth = (\ fab p_faga - -> case p_faga of { (fa, ga) -> (fmap fab fa, fmap fab ga) }) +fmapBoth = \ fab p_faga + -> case p_faga of { (fa, ga) -> (fmap fab fa, fmap fab ga) } diff --git a/test/testdata/tactic/GoldenArbitrary.hs.expected b/test/testdata/tactic/GoldenArbitrary.hs.expected index a3f677d1a1..1d533bef3f 100644 --- a/test/testdata/tactic/GoldenArbitrary.hs.expected +++ b/test/testdata/tactic/GoldenArbitrary.hs.expected @@ -22,31 +22,31 @@ data Obj arbitrary :: Gen Obj -arbitrary = (let - terminal - = [(Square <$> arbitrary) <*> arbitrary, Circle <$> arbitrary, - Polygon <$> arbitrary, pure Empty, pure Full] - in - sized - $ (\ n - -> case n <= 1 of - True -> oneof terminal - False - -> oneof - $ ([(Rotate2 <$> arbitrary) <*> scale (subtract 1) arbitrary, - Complement <$> scale (subtract 1) arbitrary, - (UnionR <$> arbitrary) <*> scale (subtract 1) arbitrary, - ((DifferenceR <$> arbitrary) <*> scale (flip div 2) arbitrary) - <*> scale (flip div 2) arbitrary, - (IntersectR <$> arbitrary) <*> scale (subtract 1) arbitrary, - ((Translate <$> arbitrary) <*> arbitrary) - <*> scale (subtract 1) arbitrary, - ((Scale <$> arbitrary) <*> arbitrary) - <*> scale (subtract 1) arbitrary, - ((Mirror <$> arbitrary) <*> arbitrary) - <*> scale (subtract 1) arbitrary, - (Outset <$> arbitrary) <*> scale (subtract 1) arbitrary, - (Shell <$> arbitrary) <*> scale (subtract 1) arbitrary, - (WithRounding <$> arbitrary) <*> scale (subtract 1) arbitrary] - <> terminal))) +arbitrary = let + terminal + = [(Square <$> arbitrary) <*> arbitrary, Circle <$> arbitrary, + Polygon <$> arbitrary, pure Empty, pure Full] + in + sized + $ (\ n + -> case n <= 1 of + True -> oneof terminal + False + -> oneof + $ ([(Rotate2 <$> arbitrary) <*> scale (subtract 1) arbitrary, + Complement <$> scale (subtract 1) arbitrary, + (UnionR <$> arbitrary) <*> scale (subtract 1) arbitrary, + ((DifferenceR <$> arbitrary) <*> scale (flip div 2) arbitrary) + <*> scale (flip div 2) arbitrary, + (IntersectR <$> arbitrary) <*> scale (subtract 1) arbitrary, + ((Translate <$> arbitrary) <*> arbitrary) + <*> scale (subtract 1) arbitrary, + ((Scale <$> arbitrary) <*> arbitrary) + <*> scale (subtract 1) arbitrary, + ((Mirror <$> arbitrary) <*> arbitrary) + <*> scale (subtract 1) arbitrary, + (Outset <$> arbitrary) <*> scale (subtract 1) arbitrary, + (Shell <$> arbitrary) <*> scale (subtract 1) arbitrary, + (WithRounding <$> arbitrary) <*> scale (subtract 1) arbitrary] + <> terminal)) diff --git a/test/testdata/tactic/GoldenBigTuple.hs.expected b/test/testdata/tactic/GoldenBigTuple.hs.expected index 36a7141036..c750f48356 100644 --- a/test/testdata/tactic/GoldenBigTuple.hs.expected +++ b/test/testdata/tactic/GoldenBigTuple.hs.expected @@ -1,4 +1,4 @@ -- There used to be a bug where we were unable to perform a nested split. The -- more serious regression test of this is 'AutoTupleSpec'. bigTuple :: (a, b, c, d) -> (a, b, (c, d)) -bigTuple = (\ pabcd -> case pabcd of { (a, b, c, d) -> (a, b, (c, d)) }) +bigTuple = \ pabcd -> case pabcd of { (a, b, c, d) -> (a, b, (c, d)) } diff --git a/test/testdata/tactic/GoldenEitherAuto.hs.expected b/test/testdata/tactic/GoldenEitherAuto.hs.expected index 10d633470c..833c250f0b 100644 --- a/test/testdata/tactic/GoldenEitherAuto.hs.expected +++ b/test/testdata/tactic/GoldenEitherAuto.hs.expected @@ -1,5 +1,5 @@ either' :: (a -> c) -> (b -> c) -> Either a b -> c -either' = (\ fac fbc eab - -> case eab of - (Left a) -> fac a - (Right b) -> fbc b) +either' = \ fac fbc eab + -> case eab of + (Left a) -> fac a + (Right b) -> fbc b diff --git a/test/testdata/tactic/GoldenEitherHomomorphic.hs.expected b/test/testdata/tactic/GoldenEitherHomomorphic.hs.expected index 8276908d71..af8e10f357 100644 --- a/test/testdata/tactic/GoldenEitherHomomorphic.hs.expected +++ b/test/testdata/tactic/GoldenEitherHomomorphic.hs.expected @@ -1,5 +1,5 @@ eitherSplit :: a -> Either (a -> b) (a -> c) -> Either b c -eitherSplit = (\ a efabfac - -> case efabfac of - (Left fab) -> Left (fab a) - (Right fac) -> Right (fac a)) +eitherSplit = \ a efabfac + -> case efabfac of + (Left fab) -> Left (fab a) + (Right fac) -> Right (fac a) diff --git a/test/testdata/tactic/GoldenFmapTree.hs.expected b/test/testdata/tactic/GoldenFmapTree.hs.expected index 4e8b97d735..ed608dcbbd 100644 --- a/test/testdata/tactic/GoldenFmapTree.hs.expected +++ b/test/testdata/tactic/GoldenFmapTree.hs.expected @@ -1,7 +1,7 @@ data Tree a = Leaf a | Branch (Tree a) (Tree a) instance Functor Tree where - fmap = (\ fab ta - -> case ta of - (Leaf a) -> Leaf (fab a) - (Branch ta2 ta3) -> Branch (fmap fab ta2) (fmap fab ta3)) + fmap = \ fab ta + -> case ta of + (Leaf a) -> Leaf (fab a) + (Branch ta2 ta3) -> Branch (fmap fab ta2) (fmap fab ta3) diff --git a/test/testdata/tactic/GoldenFoldr.hs.expected b/test/testdata/tactic/GoldenFoldr.hs.expected index 9fde1acaeb..e043416a4d 100644 --- a/test/testdata/tactic/GoldenFoldr.hs.expected +++ b/test/testdata/tactic/GoldenFoldr.hs.expected @@ -1,5 +1,5 @@ foldr2 :: (a -> b -> b) -> b -> [a] -> b -foldr2 = (\ f_b b l_a - -> case l_a of - [] -> b - (a : l_a4) -> f_b a (foldr2 f_b b l_a4)) +foldr2 = \ f_b b l_a + -> case l_a of + [] -> b + (a : l_a4) -> f_b a (foldr2 f_b b l_a4) diff --git a/test/testdata/tactic/GoldenFromMaybe.hs.expected b/test/testdata/tactic/GoldenFromMaybe.hs.expected index 1375967a70..7d08d130e5 100644 --- a/test/testdata/tactic/GoldenFromMaybe.hs.expected +++ b/test/testdata/tactic/GoldenFromMaybe.hs.expected @@ -1,5 +1,5 @@ fromMaybe :: a -> Maybe a -> a -fromMaybe = (\ a ma - -> case ma of - Nothing -> a - (Just a2) -> a2) +fromMaybe = \ a ma + -> case ma of + Nothing -> a + (Just a2) -> a2 diff --git a/test/testdata/tactic/GoldenGADTAuto.hs.expected b/test/testdata/tactic/GoldenGADTAuto.hs.expected index 2159d09f3b..88f33dd2da 100644 --- a/test/testdata/tactic/GoldenGADTAuto.hs.expected +++ b/test/testdata/tactic/GoldenGADTAuto.hs.expected @@ -4,4 +4,4 @@ data CtxGADT a where MkCtxGADT :: (Show a, Eq a) => a -> CtxGADT a ctxGADT :: CtxGADT () -ctxGADT = (MkCtxGADT ()) +ctxGADT = MkCtxGADT () diff --git a/test/testdata/tactic/GoldenGADTDestruct.hs.expected b/test/testdata/tactic/GoldenGADTDestruct.hs.expected index 2243aafdf6..fe8d1a8bd8 100644 --- a/test/testdata/tactic/GoldenGADTDestruct.hs.expected +++ b/test/testdata/tactic/GoldenGADTDestruct.hs.expected @@ -4,4 +4,4 @@ data CtxGADT where MkCtxGADT :: (Show a, Eq a) => a -> CtxGADT ctxGADT :: CtxGADT -> String -ctxGADT gadt = (case gadt of { (MkCtxGADT a) -> _ }) +ctxGADT gadt = case gadt of { (MkCtxGADT a) -> _ } diff --git a/test/testdata/tactic/GoldenGADTDestructCoercion.hs.expected b/test/testdata/tactic/GoldenGADTDestructCoercion.hs.expected index dca8ee9260..e3a3e4ed80 100644 --- a/test/testdata/tactic/GoldenGADTDestructCoercion.hs.expected +++ b/test/testdata/tactic/GoldenGADTDestructCoercion.hs.expected @@ -5,4 +5,4 @@ data E a b where E :: forall a b. (b ~ a, Ord a) => b -> E a [a] ctxGADT :: E a b -> String -ctxGADT gadt = (case gadt of { (E b) -> _ }) +ctxGADT gadt = case gadt of { (E b) -> _ } diff --git a/test/testdata/tactic/GoldenIdentityFunctor.hs.expected b/test/testdata/tactic/GoldenIdentityFunctor.hs.expected index fa0a8b629b..91d1e22d3d 100644 --- a/test/testdata/tactic/GoldenIdentityFunctor.hs.expected +++ b/test/testdata/tactic/GoldenIdentityFunctor.hs.expected @@ -1,3 +1,3 @@ data Ident a = Ident a instance Functor Ident where - fmap = (\ fab ia -> case ia of { (Ident a) -> Ident (fab a) }) + fmap = \ fab ia -> case ia of { (Ident a) -> Ident (fab a) } diff --git a/test/testdata/tactic/GoldenIntros.hs.expected b/test/testdata/tactic/GoldenIntros.hs.expected index 26d8599e4e..8da62d6b9b 100644 --- a/test/testdata/tactic/GoldenIntros.hs.expected +++ b/test/testdata/tactic/GoldenIntros.hs.expected @@ -1,2 +1,2 @@ blah :: Int -> Bool -> (a -> b) -> String -> Int -blah = (\ i b fab l_c -> _) +blah = \ i b fab l_c -> _ diff --git a/test/testdata/tactic/GoldenJoinCont.hs.expected b/test/testdata/tactic/GoldenJoinCont.hs.expected index ebf84d1371..7397859c4d 100644 --- a/test/testdata/tactic/GoldenJoinCont.hs.expected +++ b/test/testdata/tactic/GoldenJoinCont.hs.expected @@ -1,4 +1,4 @@ type Cont r a = ((a -> r) -> r) joinCont :: Cont r (Cont r a) -> Cont r a -joinCont = (\ f_r far -> f_r (\ f_r2 -> f_r2 far)) +joinCont = \ f_r far -> f_r (\ f_r2 -> f_r2 far) diff --git a/test/testdata/tactic/GoldenListFmap.hs.expected b/test/testdata/tactic/GoldenListFmap.hs.expected index 6d183a9578..7ff6fabfce 100644 --- a/test/testdata/tactic/GoldenListFmap.hs.expected +++ b/test/testdata/tactic/GoldenListFmap.hs.expected @@ -1,5 +1,5 @@ fmapList :: (a -> b) -> [a] -> [b] -fmapList = (\ fab l_a - -> case l_a of - [] -> [] - (a : l_a3) -> fab a : fmapList fab l_a3) +fmapList = \ fab l_a + -> case l_a of + [] -> [] + (a : l_a3) -> fab a : fmapList fab l_a3 diff --git a/test/testdata/tactic/GoldenNote.hs.expected b/test/testdata/tactic/GoldenNote.hs.expected index 47a9bd6d92..420ce242a0 100644 --- a/test/testdata/tactic/GoldenNote.hs.expected +++ b/test/testdata/tactic/GoldenNote.hs.expected @@ -1,5 +1,5 @@ note :: e -> Maybe a -> Either e a -note = (\ e ma - -> case ma of - Nothing -> Left e - (Just a) -> Right a) +note = \ e ma + -> case ma of + Nothing -> Left e + (Just a) -> Right a diff --git a/test/testdata/tactic/GoldenPureList.hs.expected b/test/testdata/tactic/GoldenPureList.hs.expected index c02e91622d..fc5bcdc2a3 100644 --- a/test/testdata/tactic/GoldenPureList.hs.expected +++ b/test/testdata/tactic/GoldenPureList.hs.expected @@ -1,2 +1,2 @@ pureList :: a -> [a] -pureList = (\ a -> a : []) +pureList = \ a -> a : [] diff --git a/test/testdata/tactic/GoldenSafeHead.hs.expected b/test/testdata/tactic/GoldenSafeHead.hs.expected index 7a404f1d4e..194b8922c0 100644 --- a/test/testdata/tactic/GoldenSafeHead.hs.expected +++ b/test/testdata/tactic/GoldenSafeHead.hs.expected @@ -1,5 +1,5 @@ safeHead :: [x] -> Maybe x -safeHead = (\ l_x - -> case l_x of - [] -> Nothing - (x : l_x2) -> Just x) +safeHead = \ l_x + -> case l_x of + [] -> Nothing + (x : l_x2) -> Just x diff --git a/test/testdata/tactic/GoldenShowCompose.hs.expected b/test/testdata/tactic/GoldenShowCompose.hs.expected index e672cc6a02..8152b5a0ae 100644 --- a/test/testdata/tactic/GoldenShowCompose.hs.expected +++ b/test/testdata/tactic/GoldenShowCompose.hs.expected @@ -1,2 +1,2 @@ showCompose :: Show a => (b -> a) -> b -> String -showCompose = (\ fba -> show . fba) +showCompose = \ fba -> show . fba diff --git a/test/testdata/tactic/GoldenShowMapChar.hs.expected b/test/testdata/tactic/GoldenShowMapChar.hs.expected index 8750e4e1f4..d4cb942825 100644 --- a/test/testdata/tactic/GoldenShowMapChar.hs.expected +++ b/test/testdata/tactic/GoldenShowMapChar.hs.expected @@ -1,2 +1,2 @@ test :: Show a => a -> (String -> b) -> b -test = (\ a fl_cb -> fl_cb (show a)) +test = \ a fl_cb -> fl_cb (show a) diff --git a/test/testdata/tactic/GoldenSwap.hs.expected b/test/testdata/tactic/GoldenSwap.hs.expected index 57a3a114f4..2560c15acb 100644 --- a/test/testdata/tactic/GoldenSwap.hs.expected +++ b/test/testdata/tactic/GoldenSwap.hs.expected @@ -1,2 +1,2 @@ swap :: (a, b) -> (b, a) -swap = (\ p_ab -> case p_ab of { (a, b) -> (b, a) }) +swap = \ p_ab -> case p_ab of { (a, b) -> (b, a) } diff --git a/test/testdata/tactic/GoldenSwapMany.hs.expected b/test/testdata/tactic/GoldenSwapMany.hs.expected index a37687cc3c..aaffc2d873 100644 --- a/test/testdata/tactic/GoldenSwapMany.hs.expected +++ b/test/testdata/tactic/GoldenSwapMany.hs.expected @@ -1,2 +1,2 @@ swapMany :: (a, b, c, d, e) -> (e, d, c, b, a) -swapMany = (\ pabcde -> case pabcde of { (a, b, c, d, e) -> (e, d, c, b, a) }) +swapMany = \ pabcde -> case pabcde of { (a, b, c, d, e) -> (e, d, c, b, a) } From 89d0cf3b9eb807da83137ced4cf4493fa0ef622e Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 11 Feb 2021 18:01:33 -0800 Subject: [PATCH 14/18] Try a different strategy for generalizing PatCompat --- .../hls-tactics-plugin/src/Ide/Plugin/Tactic/GHC.hs | 12 ++++++++---- .../src/Ide/Plugin/Tactic/Simplify.hs | 8 ++++---- 2 files changed, 12 insertions(+), 8 deletions(-) diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/GHC.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/GHC.hs index c0942aa2a8..d3ef13c8c0 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/GHC.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/GHC.hs @@ -112,13 +112,17 @@ lambdaCaseable (splitFunTy_maybe -> Just (arg, res)) = Just $ isJust $ algebraicTyCon res lambdaCaseable _ = Nothing -fromPatCompat :: PatCompat ps -> Pat ps +-- It's hard to generalize over these since weird type families are involved. +fromPatCompatTc :: PatCompat GhcTc -> Pat GhcTc +fromPatCompatPs :: PatCompat GhcPs -> Pat GhcPs #if __GLASGOW_HASKELL__ == 808 type PatCompat pass = Pat pass -fromPatCompat = id +fromPatCompatTc = id +fromPatCompatPs = id #else type PatCompat pass = LPat pass -fromPatCompat = unLoc +fromPatCompatTc = unLoc +fromPatCompatPs = id #endif ------------------------------------------------------------------------------ @@ -132,7 +136,7 @@ pattern TopLevelRHS name ps body <- [L _ (GRHS _ [] body)] _) getPatName :: PatCompat GhcTc -> Maybe OccName -getPatName (fromPatCompat -> p0) = +getPatName (fromPatCompatTc -> p0) = case p0 of VarPat _ x -> Just $ occName $ unLoc x LazyPat _ p -> getPatName p diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs index f48d096e7b..f54e8d96ef 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs @@ -18,7 +18,7 @@ import GHC.Exts (fromString) import GHC.SourceGen (var, op) import GHC.SourceGen.Expr (lambda) import Ide.Plugin.Tactic.CodeGen.Utils -import Ide.Plugin.Tactic.GHC (fromPatCompat) +import Ide.Plugin.Tactic.GHC (fromPatCompatPs) ------------------------------------------------------------------------------ @@ -74,11 +74,11 @@ containsHsVar name x = not $ null $ listify ( simplifyEtaReduce :: GenericT simplifyEtaReduce = mkT $ \case Lambda - [fromPatCompat -> VarPat _ (L _ pat)] + [fromPatCompatPs -> VarPat _ (L _ pat)] (HsVar _ (L _ a)) | pat == a -> var "id" Lambda - (fmap fromPatCompat -> unsnoc -> Just (pats, (VarPat _ (L _ pat)))) + (fmap fromPatCompatPs -> unsnoc -> Just (pats, (VarPat _ (L _ pat)))) (HsApp _ (L _ f) (L _ (HsVar _ (L _ a)))) | pat == a -- We can only perform this simplifiation if @pat@ is otherwise unused. @@ -93,7 +93,7 @@ simplifyEtaReduce = mkT $ \case simplifyCompose :: GenericT simplifyCompose = mkT $ \case Lambda - (fmap fromPatCompat -> unsnoc -> Just (pats, (VarPat _ (L _ pat)))) + (fmap fromPatCompatPs -> unsnoc -> Just (pats, (VarPat _ (L _ pat)))) (unroll -> (fs@(_:_), (HsVar _ (L _ a)))) | pat == a -- We can only perform this simplifiation if @pat@ is otherwise unused. From ae2cc58ccc1d67cfffd4587e941a768175a15280 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 11 Feb 2021 19:57:13 -0800 Subject: [PATCH 15/18] Could this be the answer we've all been waiting for? --- .../hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs index f54e8d96ef..c125d50876 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs @@ -27,7 +27,7 @@ pattern Lambda :: [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs pattern Lambda pats body <- HsLam _ (MG {mg_alts = L _ [L _ - (Match { m_pats = pats + (Match { m_pats = fmap fromPatCompatPs -> pats , m_grhss = GRHSs {grhssGRHSs = [L _ ( GRHS _ [] (L _ body))]} })]}) @@ -74,11 +74,11 @@ containsHsVar name x = not $ null $ listify ( simplifyEtaReduce :: GenericT simplifyEtaReduce = mkT $ \case Lambda - [fromPatCompatPs -> VarPat _ (L _ pat)] + [VarPat _ (L _ pat)] (HsVar _ (L _ a)) | pat == a -> var "id" Lambda - (fmap fromPatCompatPs -> unsnoc -> Just (pats, (VarPat _ (L _ pat)))) + (unsnoc -> Just (pats, (VarPat _ (L _ pat)))) (HsApp _ (L _ f) (L _ (HsVar _ (L _ a)))) | pat == a -- We can only perform this simplifiation if @pat@ is otherwise unused. @@ -93,7 +93,7 @@ simplifyEtaReduce = mkT $ \case simplifyCompose :: GenericT simplifyCompose = mkT $ \case Lambda - (fmap fromPatCompatPs -> unsnoc -> Just (pats, (VarPat _ (L _ pat)))) + (unsnoc -> Just (pats, (VarPat _ (L _ pat)))) (unroll -> (fs@(_:_), (HsVar _ (L _ a)))) | pat == a -- We can only perform this simplifiation if @pat@ is otherwise unused. From a45ff28d75ab76416bcf348c275ea3ec91d1dd0e Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 11 Feb 2021 18:42:57 -0800 Subject: [PATCH 16/18] Try, try again to compat --- plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/GHC.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/GHC.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/GHC.hs index d3ef13c8c0..efe715d12c 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/GHC.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/GHC.hs @@ -122,7 +122,7 @@ fromPatCompatPs = id #else type PatCompat pass = LPat pass fromPatCompatTc = unLoc -fromPatCompatPs = id +fromPatCompatPs = unLoc #endif ------------------------------------------------------------------------------ From 0f80ddad1c801815fda854c48aedc08982bef304 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Fri, 12 Feb 2021 16:15:50 -0800 Subject: [PATCH 17/18] Reorganize imports --- plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs index 446938ebeb..d2f61d0829 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs @@ -21,6 +21,7 @@ import Control.Monad.Error.Class (MonadError(throwError)) import Control.Monad.Trans import Control.Monad.Trans.Maybe import Data.Aeson +import Data.Bool (bool) import Data.Coerce import Data.Functor ((<&>)) import Data.Generics.Aliases (mkQ) @@ -40,6 +41,7 @@ import Development.IDE.Core.Shake (useWithStale, IdeState (..)) import Development.IDE.GHC.Compat import Development.IDE.GHC.Error (realSrcSpanToRange) import Development.IDE.GHC.ExactPrint (graft, transform, useAnnotatedSource, maybeParensAST) +import Development.IDE.GHC.ExactPrint (graftWithoutParentheses) import Development.IDE.Spans.LocalBindings (getDefiningBindings) import Development.Shake (Action) import DynFlags (xopt) @@ -63,8 +65,6 @@ import Refinery.Tactic (goal) import SrcLoc (containsSpan) import System.Timeout import TcRnTypes (tcg_binds) -import Data.Bool (bool) -import Development.IDE.GHC.ExactPrint (graftWithoutParentheses) descriptor :: PluginId -> PluginDescriptor IdeState From 2e27a800dbc57981b9c0fff9cce3475c7fb0dd48 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Sat, 13 Feb 2021 14:45:28 -0800 Subject: [PATCH 18/18] Fix test --- test/testdata/tactic/RecordCon.hs.expected | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/testdata/tactic/RecordCon.hs.expected b/test/testdata/tactic/RecordCon.hs.expected index 33f74796f5..235efbdbfa 100644 --- a/test/testdata/tactic/RecordCon.hs.expected +++ b/test/testdata/tactic/RecordCon.hs.expected @@ -4,6 +4,6 @@ data MyRecord a = Record } blah :: (a -> Int) -> a -> MyRecord a -blah = (\ fai a -> Record {field1 = a, field2 = fai a}) +blah = \ fai a -> Record {field1 = a, field2 = fai a}