From e4c2a890d77886b1cf92961391cd01a5c84d5bf3 Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Mon, 5 Apr 2021 06:31:22 -0700
Subject: [PATCH 1/9] Derive mempty from in class methods

---
 .../hls-tactics-plugin/src/Wingman/Context.hs | 36 +++++++++++++++++-
 plugins/hls-tactics-plugin/src/Wingman/GHC.hs | 37 +++++++++++++++++++
 .../src/Wingman/KnownStrategies.hs            | 17 ++++++++-
 .../src/Wingman/LanguageServer.hs             | 31 ++++++++++------
 .../hls-tactics-plugin/src/Wingman/Tactics.hs | 20 ++++++++++
 .../hls-tactics-plugin/src/Wingman/Types.hs   | 27 +++++++++++++-
 6 files changed, 150 insertions(+), 18 deletions(-)

diff --git a/plugins/hls-tactics-plugin/src/Wingman/Context.hs b/plugins/hls-tactics-plugin/src/Wingman/Context.hs
index e148fcd1b8..bd3d16bc81 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/Context.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/Context.hs
@@ -8,10 +8,19 @@ import OccName
 import TcRnTypes
 import Wingman.FeatureSet (FeatureSet)
 import Wingman.Types
+import InstEnv (InstMatch, lookupInstEnv, InstEnvs(..))
+import GhcPlugins (ExternalPackageState (eps_inst_env))
+import Data.Maybe (listToMaybe)
 
 
-mkContext :: FeatureSet -> [(OccName, CType)] -> TcGblEnv -> Context
-mkContext features locals tcg = Context
+mkContext
+    :: FeatureSet
+    -> [(OccName, CType)]
+    -> TcGblEnv
+    -> ExternalPackageState
+    -> KnownThings
+    -> Context
+mkContext features locals tcg eps kt = Context
   { ctxDefiningFuncs = locals
   , ctxModuleFuncs = fmap splitId
                    . (getFunBindId =<<)
@@ -19,6 +28,12 @@ mkContext features locals tcg = Context
                    . bagToList
                    $ tcg_binds tcg
   , ctxFeatureSet = features
+  , ctxInstEnvs =
+      InstEnvs
+        (eps_inst_env eps)
+        (tcg_inst_env tcg)
+        (tcVisibleOrphanMods tcg)
+  , ctxKnownThings = kt
   }
 
 
@@ -37,3 +52,20 @@ getFunBindId _ = []
 getCurrentDefinitions :: MonadReader Context m => m [(OccName, CType)]
 getCurrentDefinitions = asks ctxDefiningFuncs
 
+
+getKnownThing :: MonadReader Context m => (KnownThings -> a) -> m a
+getKnownThing f = asks $ f . ctxKnownThings
+
+
+getKnownInstance :: MonadReader Context m => (KnownThings -> Class) -> [Type] -> m (Maybe InstMatch)
+getKnownInstance f tys = do
+  cls <- getKnownThing f
+  getInstance cls tys
+
+
+getInstance :: MonadReader Context m => Class -> [Type] -> m (Maybe InstMatch)
+getInstance cls tys = do
+  env <- asks ctxInstEnvs
+  let (res, _, _) = lookupInstEnv False env cls tys
+  pure $ listToMaybe res
+
diff --git a/plugins/hls-tactics-plugin/src/Wingman/GHC.hs b/plugins/hls-tactics-plugin/src/Wingman/GHC.hs
index eeead45836..1e19984c50 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/GHC.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/GHC.hs
@@ -4,7 +4,9 @@
 module Wingman.GHC where
 
 import           ConLike
+import           Control.Applicative (empty)
 import           Control.Monad.State
+import           Control.Monad.Trans.Maybe (MaybeT(..))
 import           Data.Function (on)
 import           Data.Functor ((<&>))
 import           Data.List (isPrefixOf)
@@ -14,10 +16,14 @@ import           Data.Set (Set)
 import qualified Data.Set as S
 import           Data.Traversable
 import           DataCon
+import           Development.IDE (HscEnvEq (hscEnv))
+import           Development.IDE.Core.Compile (lookupName)
 import           Development.IDE.GHC.Compat
 import           GHC.SourceGen (case', lambda, match)
 import           Generics.SYB (Data, everything, everywhere, listify, mkQ, mkT)
+import           GhcPlugins (extractModule, GlobalRdrElt (gre_name))
 import           OccName
+import           TcRnMonad
 import           TcType
 import           TyCoRep
 import           Type
@@ -294,3 +300,34 @@ unXPat (XPat (L _ pat)) = unXPat pat
 #endif
 unXPat pat              = pat
 
+
+knownThings :: TcGblEnv -> HscEnvEq -> MaybeT IO KnownThings
+knownThings tcg hscenv= do
+  let cls = knownClass tcg hscenv
+  KnownThings
+    <$> cls (mkClsOcc "Semigroup")
+    <*> cls (mkClsOcc "Monoid")
+
+
+knownClass :: TcGblEnv -> HscEnvEq -> OccName -> MaybeT IO Class
+knownClass = knownThing $ \case
+  ATyCon tc -> tyConClass_maybe tc
+  _         -> Nothing
+
+
+knownThing :: (TyThing -> Maybe a) -> TcGblEnv -> HscEnvEq -> OccName -> MaybeT IO a
+knownThing f tcg hscenv occ = do
+  let modul = extractModule tcg
+      rdrenv = tcg_rdr_env tcg
+
+  case lookupOccEnv rdrenv occ of
+    Nothing -> empty
+    Just elts -> do
+      mvar <- lift $ lookupName (hscEnv hscenv) modul $ gre_name $ head elts
+      case mvar of
+        Just tt -> liftMaybe $ f tt
+        _ -> empty
+
+liftMaybe :: Monad m => Maybe a -> MaybeT m a
+liftMaybe a = MaybeT $ pure a
+
diff --git a/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs b/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs
index 21eb5b3359..c05dd1e351 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs
@@ -1,18 +1,21 @@
 module Wingman.KnownStrategies where
 
 import Control.Monad.Error.Class
-import OccName (mkVarOcc)
+import OccName (mkVarOcc, mkMethodOcc)
 import Refinery.Tactic
-import Wingman.Context (getCurrentDefinitions)
+import Wingman.Context (getCurrentDefinitions, getKnownInstance)
 import Wingman.KnownStrategies.QuickCheck (deriveArbitrary)
 import Wingman.Machinery (tracing)
 import Wingman.Tactics
 import Wingman.Types
+import Wingman.Judgements (jGoal)
+import Data.Foldable (for_)
 
 
 knownStrategies :: TacticsM ()
 knownStrategies = choice
   [ known "fmap" deriveFmap
+  , known "mempty" deriveMempty
   , known "arbitrary" deriveArbitrary
   ]
 
@@ -35,3 +38,13 @@ deriveFmap = do
     , recursion
     ]
 
+
+deriveMempty :: TacticsM ()
+deriveMempty = do
+  split
+  g <- goal
+  minst <- getKnownInstance kt_monoid [unCType $ jGoal g]
+  for_ minst $ \inst ->
+    applyMethod inst $ mkVarOcc "mempty"
+
+
diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs
index 417cc0e4ea..0eed1ed2c3 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs
@@ -28,17 +28,17 @@ import           Development.IDE.Spans.LocalBindings (Bindings, getDefiningBindi
 import           Development.Shake (Action, RuleResult)
 import           Development.Shake.Classes (Typeable, Binary, Hashable, NFData)
 import qualified FastString
-import           GhcPlugins (tupleDataCon, consDataCon, substTyAddInScope)
-import           Ide.Types (PluginId)
+import           GhcPlugins (tupleDataCon, consDataCon, substTyAddInScope, ExternalPackageState, HscEnv (hsc_EPS), liftIO)
 import qualified Ide.Plugin.Config as Plugin
-import           Ide.PluginUtils (usePropertyLsp)
 import           Ide.Plugin.Properties
+import           Ide.PluginUtils (usePropertyLsp)
+import           Ide.Types (PluginId)
 import           Language.LSP.Server (MonadLsp, sendNotification)
 import           Language.LSP.Types
 import           OccName
 import           Prelude hiding (span)
 import           SrcLoc (containsSpan)
-import           TcRnTypes (tcg_binds)
+import           TcRnTypes (tcg_binds, TcGblEnv)
 import           Wingman.Context
 import           Wingman.FeatureSet
 import           Wingman.GHC
@@ -46,6 +46,8 @@ import           Wingman.Judgements
 import           Wingman.Judgements.Theta
 import           Wingman.Range
 import           Wingman.Types
+import Development.IDE (hscEnv)
+import Data.IORef (readIORef)
 
 
 tacticDesc :: T.Text -> T.Text
@@ -127,9 +129,13 @@ judgementForHole state nfp range features = do
     HAR _ hf _ _ HieFresh -> do
       (binds, _) <- runStaleIde state nfp GetBindings
       (tcmod, _) <- runStaleIde state nfp TypeCheck
+      (hscenv, _) <- runStaleIde state nfp GhcSessionDeps
       (rss, g)   <- liftMaybe $ getSpanAndTypeAtHole amapping range hf
       resulting_range <- liftMaybe $ toCurrentRange amapping $ realSrcSpanToRange rss
-      let (jdg, ctx) = mkJudgementAndContext features g binds rss tcmod
+      eps <- liftIO $ readIORef $ hsc_EPS $ hscEnv hscenv
+      let tcg = tmrTypechecked tcmod
+      kt <- knownThings tcg hscenv
+      let (jdg, ctx) = mkJudgementAndContext features g binds rss tcg eps kt
       dflags <- getIdeDynflags state nfp
       pure (resulting_range, jdg, ctx, dflags)
 
@@ -139,15 +145,18 @@ mkJudgementAndContext
     -> Type
     -> Bindings
     -> RealSrcSpan
-    -> TcModuleResult
+    -> TcGblEnv
+    -> ExternalPackageState
+    -> KnownThings
     -> (Judgement, Context)
-mkJudgementAndContext features g binds rss tcmod = do
-      let tcg = tmrTypechecked tcmod
-          tcs = tcg_binds tcg
+mkJudgementAndContext features g binds rss tcg eps kt = do
+      let tcs = tcg_binds tcg
           ctx = mkContext features
                   (mapMaybe (sequenceA . (occName *** coerce))
                     $ getDefiningBindings binds rss)
                   tcg
+                  eps
+                  kt
           top_provs = getRhsPosVals rss tcs
           local_hy = spliceProvenance top_provs
                    $ hypothesisFromBindings rss binds
@@ -182,9 +191,6 @@ getSpanAndTypeAtHole amapping range hf = do
         pure (nodeSpan ast', ty)
 
 
-liftMaybe :: Monad m => Maybe a -> MaybeT m a
-liftMaybe a = MaybeT $ pure a
-
 
 ------------------------------------------------------------------------------
 -- | Combine two (possibly-overlapping) hypotheses; using the provenance from
@@ -364,3 +370,4 @@ mkShowMessageParams ufm = ShowMessageParams (ufmSeverity ufm) $ T.pack $ show uf
 
 showLspMessage :: MonadLsp cfg m => ShowMessageParams -> m ()
 showLspMessage = sendNotification SWindowShowMessage
+
diff --git a/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs b/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs
index 3f91497e95..24a56a280f 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs
@@ -34,6 +34,8 @@ import           Wingman.Judgements
 import           Wingman.Machinery
 import           Wingman.Naming
 import           Wingman.Types
+import InstEnv (InstMatch, ClsInst (is_cls, is_dfun))
+import TysPrim (alphaTys)
 
 
 ------------------------------------------------------------------------------
@@ -364,3 +366,21 @@ overAlgebraicTerms =
 allNames :: Judgement -> Set OccName
 allNames = hyNamesInScope . jHypothesis
 
+
+applyMethod :: InstMatch -> OccName -> TacticsM ()
+applyMethod (inst, mapps) method_name = do
+  traceMX "applying method" method_name
+  let cls  = is_cls inst
+  case find ((== method_name) . occName) $ classMethods cls of
+    Just method -> do
+      -- Get the instantiated type of the dictionary
+      let df = piResultTys (idType $ is_dfun inst) $ zipWith fromMaybe alphaTys mapps
+      -- pull off its resulting arguments
+      let (_, apps) = splitAppTys df
+      -- and apply them to the type of the instance
+      let ty = snd $ splitFunTy (piResultTys (idType method) apps)
+      apply $ HyInfo method_name (ClassMethodPrv $ Uniquely cls) $ CType ty
+    Nothing -> do
+      traceMX "no method" $ classMethods cls
+      throwError $ NotInScope method_name
+
diff --git a/plugins/hls-tactics-plugin/src/Wingman/Types.hs b/plugins/hls-tactics-plugin/src/Wingman/Types.hs
index cf5aa9655d..6e882cdc51 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/Types.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/Types.hs
@@ -32,6 +32,7 @@ import           Development.IDE.GHC.Orphans ()
 import           Development.IDE.Types.Location
 import           GHC.Generics
 import           GHC.SourceGen (var)
+import           InstEnv (InstEnvs(..))
 import           OccName
 import           Refinery.Tactic
 import           System.IO.Unsafe (unsafePerformIO)
@@ -394,14 +395,36 @@ data Context = Context
   , ctxModuleFuncs   :: [(OccName, CType)]
     -- ^ Everything defined in the current module
   , ctxFeatureSet    :: FeatureSet
+  , ctxKnownThings   :: KnownThings
+  , ctxInstEnvs      :: InstEnvs
+  }
+
+instance Show Context where
+  show (Context {..}) = mconcat
+    [ "Context "
+    , showsPrec 10 ctxDefiningFuncs ""
+    , showsPrec 10 ctxModuleFuncs ""
+    , showsPrec 10 ctxFeatureSet ""
+    ]
+
+
+data KnownThings = KnownThings
+  { kt_semigroup :: Class
+  , kt_monoid    :: Class
   }
-  deriving stock (Eq, Ord, Show)
 
 
 ------------------------------------------------------------------------------
 -- | An empty context
 emptyContext :: Context
-emptyContext  = Context mempty mempty mempty
+emptyContext
+  = Context
+      { ctxDefiningFuncs = mempty
+      , ctxModuleFuncs = mempty
+      , ctxFeatureSet = mempty
+      , ctxKnownThings = error "empty known things from emptyContext"
+      , ctxInstEnvs = InstEnvs mempty mempty mempty
+      }
 
 
 newtype Rose a = Rose (Tree a)

From 7eeb2a0f5630ff5f3108abbfcf03ad2c0dcdd8e7 Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Mon, 5 Apr 2021 07:07:28 -0700
Subject: [PATCH 2/9] Derive semigroup too

---
 .../src/Wingman/KnownStrategies.hs            | 24 +++++++++++++++--
 .../hls-tactics-plugin/src/Wingman/Tactics.hs | 26 ++++++++++++++++---
 2 files changed, 44 insertions(+), 6 deletions(-)

diff --git a/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs b/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs
index c05dd1e351..f0df6cd261 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs
@@ -16,6 +16,8 @@ knownStrategies :: TacticsM ()
 knownStrategies = choice
   [ known "fmap" deriveFmap
   , known "mempty" deriveMempty
+  , known "<>" deriveMappend
+  , known "mappend" deriveMappend
   , known "arbitrary" deriveArbitrary
   ]
 
@@ -39,12 +41,30 @@ deriveFmap = do
     ]
 
 
+deriveMappend :: TacticsM ()
+deriveMappend = do
+  try intros
+  destructAll
+  split
+  g <- goal
+  minst <- getKnownInstance kt_semigroup [unCType $ jGoal g]
+  for_ minst $ \inst -> do
+    restrictPositionForApplication
+      (applyMethod inst $ mkVarOcc "<>")
+      assumption
+  try $
+    restrictPositionForApplication
+      (applyByName $ mkVarOcc "<>")
+      assumption
+
+
 deriveMempty :: TacticsM ()
 deriveMempty = do
   split
   g <- goal
   minst <- getKnownInstance kt_monoid [unCType $ jGoal g]
-  for_ minst $ \inst ->
-    applyMethod inst $ mkVarOcc "mempty"
+  for_ minst $ \inst -> do
+    applyMethod inst (mkVarOcc "mempty" )
+  try assumption
 
 
diff --git a/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs b/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs
index 24a56a280f..5560b50b1a 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs
@@ -22,11 +22,13 @@ import           Development.IDE.GHC.Compat
 import           GHC.Exts
 import           GHC.SourceGen.Expr
 import           GHC.SourceGen.Overloaded
+import           InstEnv (InstMatch, ClsInst (is_cls, is_dfun))
 import           Name (occNameString, occName)
 import           Refinery.Tactic
 import           Refinery.Tactic.Internal
 import           TcType
 import           Type hiding (Var)
+import           TysPrim (alphaTys)
 import           Wingman.CodeGen
 import           Wingman.Context
 import           Wingman.GHC
@@ -34,8 +36,7 @@ import           Wingman.Judgements
 import           Wingman.Machinery
 import           Wingman.Naming
 import           Wingman.Types
-import InstEnv (InstMatch, ClsInst (is_cls, is_dfun))
-import TysPrim (alphaTys)
+import Data.Functor ((<&>))
 
 
 ------------------------------------------------------------------------------
@@ -82,6 +83,16 @@ recursion = requireConcreteHole $ tracing "recursion" $ do
       <@> fmap (localTactic assumption . filterPosition name) [0..]
 
 
+restrictPositionForApplication :: TacticsM () -> TacticsM () -> TacticsM ()
+restrictPositionForApplication f app = do
+  -- NOTE(sandy): Safe use of head; context is guaranteed to have a defining
+  -- binding
+  name <- head . fmap fst <$> getCurrentDefinitions
+  f <@>
+    fmap
+      (localTactic app . filterPosition name) [0..]
+
+
 ------------------------------------------------------------------------------
 -- | Introduce a lambda binding every variable.
 intros :: TacticsM ()
@@ -369,7 +380,6 @@ allNames = hyNamesInScope . jHypothesis
 
 applyMethod :: InstMatch -> OccName -> TacticsM ()
 applyMethod (inst, mapps) method_name = do
-  traceMX "applying method" method_name
   let cls  = is_cls inst
   case find ((== method_name) . occName) $ classMethods cls of
     Just method -> do
@@ -381,6 +391,14 @@ applyMethod (inst, mapps) method_name = do
       let ty = snd $ splitFunTy (piResultTys (idType method) apps)
       apply $ HyInfo method_name (ClassMethodPrv $ Uniquely cls) $ CType ty
     Nothing -> do
-      traceMX "no method" $ classMethods cls
       throwError $ NotInScope method_name
 
+
+applyByName :: OccName -> TacticsM ()
+applyByName name = do
+  g <- goal
+  for_ (unHypothesis (jHypothesis g)) $ \hi ->
+    case hi_name hi == name of
+      True -> try $ apply hi
+      False -> pure ()
+

From b2802872d47f2c56998800af441e3344aca61d3f Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Mon, 5 Apr 2021 09:00:28 -0700
Subject: [PATCH 3/9] Add tests

---
 .../hls-tactics-plugin/test/CodeAction/AutoSpec.hs  | 11 ++++++++++-
 .../test/golden/KnownBigSemigroup.hs                |  7 +++++++
 .../test/golden/KnownBigSemigroup.hs.expected       | 13 +++++++++++++
 .../test/golden/KnownCounterfactualSemigroup.hs     |  7 +++++++
 .../golden/KnownCounterfactualSemigroup.hs.expected |  8 ++++++++
 .../test/golden/KnownMissingMonoid.hs               |  8 ++++++++
 .../test/golden/KnownMissingMonoid.hs.expected      |  8 ++++++++
 .../test/golden/KnownMissingSemigroup.hs            |  5 +++++
 .../test/golden/KnownMissingSemigroup.hs.expected   |  5 +++++
 .../hls-tactics-plugin/test/golden/KnownMonoid.hs   |  8 ++++++++
 .../test/golden/KnownMonoid.hs.expected             |  8 ++++++++
 .../test/golden/KnownPolyMonoid.hs                  |  8 ++++++++
 .../test/golden/KnownPolyMonoid.hs.expected         |  8 ++++++++
 .../test/golden/KnownThetaSemigroup.hs              |  5 +++++
 .../test/golden/KnownThetaSemigroup.hs.expected     |  5 +++++
 15 files changed, 113 insertions(+), 1 deletion(-)
 create mode 100644 plugins/hls-tactics-plugin/test/golden/KnownBigSemigroup.hs
 create mode 100644 plugins/hls-tactics-plugin/test/golden/KnownBigSemigroup.hs.expected
 create mode 100644 plugins/hls-tactics-plugin/test/golden/KnownCounterfactualSemigroup.hs
 create mode 100644 plugins/hls-tactics-plugin/test/golden/KnownCounterfactualSemigroup.hs.expected
 create mode 100644 plugins/hls-tactics-plugin/test/golden/KnownMissingMonoid.hs
 create mode 100644 plugins/hls-tactics-plugin/test/golden/KnownMissingMonoid.hs.expected
 create mode 100644 plugins/hls-tactics-plugin/test/golden/KnownMissingSemigroup.hs
 create mode 100644 plugins/hls-tactics-plugin/test/golden/KnownMissingSemigroup.hs.expected
 create mode 100644 plugins/hls-tactics-plugin/test/golden/KnownMonoid.hs
 create mode 100644 plugins/hls-tactics-plugin/test/golden/KnownMonoid.hs.expected
 create mode 100644 plugins/hls-tactics-plugin/test/golden/KnownPolyMonoid.hs
 create mode 100644 plugins/hls-tactics-plugin/test/golden/KnownPolyMonoid.hs.expected
 create mode 100644 plugins/hls-tactics-plugin/test/golden/KnownThetaSemigroup.hs
 create mode 100644 plugins/hls-tactics-plugin/test/golden/KnownThetaSemigroup.hs.expected

diff --git a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs
index 2b12243f6c..906c350631 100644
--- a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs
+++ b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs
@@ -39,7 +39,6 @@ spec = do
     autoTest  2  8 "GoldenShowMapChar.hs"
     autoTest  7  8 "GoldenSuperclass.hs"
     autoTest  2 12 "GoldenSafeHead.hs"
-    autoTest 25 13 "GoldenArbitrary.hs"
     autoTest  2 12 "FmapBoth.hs"
     autoTest  7  8 "RecordCon.hs"
     autoTest  6  8 "NewtypeRecord.hs"
@@ -68,6 +67,16 @@ spec = do
     autoTest  6 10 "AutoThetaRefl.hs"
     autoTest  6  8 "AutoThetaReflDestruct.hs"
 
+  describe "known" $ do
+    autoTest 25 13 "GoldenArbitrary.hs"
+    autoTest  6 10 "KnownBigSemigroup.hs"
+    autoTest  4 10 "KnownThetaSemigroup.hs"
+    autoTest  6 10 "KnownCounterfactualSemigroup.hs"
+    autoTest  4 10 "KnownMissingSemigroup.hs"
+    autoTest  7 12 "KnownMonoid.hs"
+    autoTest  7 12 "KnownPolyMonoid.hs"
+    autoTest  7 12 "KnownMissingMonoid.hs"
+
 
   describe "messages" $ do
     mkShowMessageTest allFeatures Auto "" 2 8 "MessageForallA.hs" TacticErrors
diff --git a/plugins/hls-tactics-plugin/test/golden/KnownBigSemigroup.hs b/plugins/hls-tactics-plugin/test/golden/KnownBigSemigroup.hs
new file mode 100644
index 0000000000..49ea10b8b4
--- /dev/null
+++ b/plugins/hls-tactics-plugin/test/golden/KnownBigSemigroup.hs
@@ -0,0 +1,7 @@
+import Data.Monoid
+
+data Big a = Big [Bool] (Sum Int) String (Endo a) Any
+
+instance Semigroup (Big a) where
+  (<>) = _
+
diff --git a/plugins/hls-tactics-plugin/test/golden/KnownBigSemigroup.hs.expected b/plugins/hls-tactics-plugin/test/golden/KnownBigSemigroup.hs.expected
new file mode 100644
index 0000000000..995c5b0f42
--- /dev/null
+++ b/plugins/hls-tactics-plugin/test/golden/KnownBigSemigroup.hs.expected
@@ -0,0 +1,13 @@
+import Data.Monoid
+
+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)
+
diff --git a/plugins/hls-tactics-plugin/test/golden/KnownCounterfactualSemigroup.hs b/plugins/hls-tactics-plugin/test/golden/KnownCounterfactualSemigroup.hs
new file mode 100644
index 0000000000..11e53f4191
--- /dev/null
+++ b/plugins/hls-tactics-plugin/test/golden/KnownCounterfactualSemigroup.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+data Semi = Semi [String] Int
+
+instance Semigroup Int => Semigroup Semi where
+  (<>) = _
+
diff --git a/plugins/hls-tactics-plugin/test/golden/KnownCounterfactualSemigroup.hs.expected b/plugins/hls-tactics-plugin/test/golden/KnownCounterfactualSemigroup.hs.expected
new file mode 100644
index 0000000000..beb49829f1
--- /dev/null
+++ b/plugins/hls-tactics-plugin/test/golden/KnownCounterfactualSemigroup.hs.expected
@@ -0,0 +1,8 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+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)
+
diff --git a/plugins/hls-tactics-plugin/test/golden/KnownMissingMonoid.hs b/plugins/hls-tactics-plugin/test/golden/KnownMissingMonoid.hs
new file mode 100644
index 0000000000..7c6bfc5ccd
--- /dev/null
+++ b/plugins/hls-tactics-plugin/test/golden/KnownMissingMonoid.hs
@@ -0,0 +1,8 @@
+data Mono a = Monoid [String] a
+
+instance Semigroup (Mono a) where
+  (<>) = undefined
+
+instance Monoid (Mono a) where
+  mempty = _
+
diff --git a/plugins/hls-tactics-plugin/test/golden/KnownMissingMonoid.hs.expected b/plugins/hls-tactics-plugin/test/golden/KnownMissingMonoid.hs.expected
new file mode 100644
index 0000000000..430db91cba
--- /dev/null
+++ b/plugins/hls-tactics-plugin/test/golden/KnownMissingMonoid.hs.expected
@@ -0,0 +1,8 @@
+data Mono a = Monoid [String] a
+
+instance Semigroup (Mono a) where
+  (<>) = undefined
+
+instance Monoid (Mono a) where
+  mempty = Monoid mempty _
+
diff --git a/plugins/hls-tactics-plugin/test/golden/KnownMissingSemigroup.hs b/plugins/hls-tactics-plugin/test/golden/KnownMissingSemigroup.hs
new file mode 100644
index 0000000000..1193c14a3b
--- /dev/null
+++ b/plugins/hls-tactics-plugin/test/golden/KnownMissingSemigroup.hs
@@ -0,0 +1,5 @@
+data Semi = Semi [String] Int
+
+instance Semigroup Semi where
+  (<>) = _
+
diff --git a/plugins/hls-tactics-plugin/test/golden/KnownMissingSemigroup.hs.expected b/plugins/hls-tactics-plugin/test/golden/KnownMissingSemigroup.hs.expected
new file mode 100644
index 0000000000..07d9a235ec
--- /dev/null
+++ b/plugins/hls-tactics-plugin/test/golden/KnownMissingSemigroup.hs.expected
@@ -0,0 +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) _
+
diff --git a/plugins/hls-tactics-plugin/test/golden/KnownMonoid.hs b/plugins/hls-tactics-plugin/test/golden/KnownMonoid.hs
new file mode 100644
index 0000000000..0667bee28c
--- /dev/null
+++ b/plugins/hls-tactics-plugin/test/golden/KnownMonoid.hs
@@ -0,0 +1,8 @@
+data Mono = Monoid [String]
+
+instance Semigroup Mono where
+  (<>) = undefined
+
+instance Monoid Mono where
+  mempty = _
+
diff --git a/plugins/hls-tactics-plugin/test/golden/KnownMonoid.hs.expected b/plugins/hls-tactics-plugin/test/golden/KnownMonoid.hs.expected
new file mode 100644
index 0000000000..6ad1e2bf92
--- /dev/null
+++ b/plugins/hls-tactics-plugin/test/golden/KnownMonoid.hs.expected
@@ -0,0 +1,8 @@
+data Mono = Monoid [String]
+
+instance Semigroup Mono where
+  (<>) = undefined
+
+instance Monoid Mono where
+  mempty = Monoid mempty
+
diff --git a/plugins/hls-tactics-plugin/test/golden/KnownPolyMonoid.hs b/plugins/hls-tactics-plugin/test/golden/KnownPolyMonoid.hs
new file mode 100644
index 0000000000..8ba7bc6d98
--- /dev/null
+++ b/plugins/hls-tactics-plugin/test/golden/KnownPolyMonoid.hs
@@ -0,0 +1,8 @@
+data Mono a = Monoid [String] a
+
+instance Semigroup (Mono a) where
+  (<>) = undefined
+
+instance Monoid a => Monoid (Mono a) where
+  mempty = _
+
diff --git a/plugins/hls-tactics-plugin/test/golden/KnownPolyMonoid.hs.expected b/plugins/hls-tactics-plugin/test/golden/KnownPolyMonoid.hs.expected
new file mode 100644
index 0000000000..317f2e770b
--- /dev/null
+++ b/plugins/hls-tactics-plugin/test/golden/KnownPolyMonoid.hs.expected
@@ -0,0 +1,8 @@
+data Mono a = Monoid [String] a
+
+instance Semigroup (Mono a) where
+  (<>) = undefined
+
+instance Monoid a => Monoid (Mono a) where
+  mempty = Monoid mempty mempty
+
diff --git a/plugins/hls-tactics-plugin/test/golden/KnownThetaSemigroup.hs b/plugins/hls-tactics-plugin/test/golden/KnownThetaSemigroup.hs
new file mode 100644
index 0000000000..f5e38276fe
--- /dev/null
+++ b/plugins/hls-tactics-plugin/test/golden/KnownThetaSemigroup.hs
@@ -0,0 +1,5 @@
+data Semi a = Semi a
+
+instance Semigroup a => Semigroup (Semi a) where
+  (<>) = _
+
diff --git a/plugins/hls-tactics-plugin/test/golden/KnownThetaSemigroup.hs.expected b/plugins/hls-tactics-plugin/test/golden/KnownThetaSemigroup.hs.expected
new file mode 100644
index 0000000000..9ed929c47c
--- /dev/null
+++ b/plugins/hls-tactics-plugin/test/golden/KnownThetaSemigroup.hs.expected
@@ -0,0 +1,5 @@
+data Semi a = Semi a
+
+instance Semigroup a => Semigroup (Semi a) where
+  (<>) (Semi a6) (Semi a) = Semi ((<>) a6 a)
+

From d75c88c4128cb06259e0121be0d30abbf2a3ae3b Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Mon, 5 Apr 2021 09:03:52 -0700
Subject: [PATCH 4/9] Add tests that check instances defined in the current
 module

---
 .../hls-tactics-plugin/test/CodeAction/AutoSpec.hs    |  1 +
 .../test/golden/KnownModuleInstanceSemigroup.hs       | 11 +++++++++++
 .../golden/KnownModuleInstanceSemigroup.hs.expected   | 11 +++++++++++
 3 files changed, 23 insertions(+)
 create mode 100644 plugins/hls-tactics-plugin/test/golden/KnownModuleInstanceSemigroup.hs
 create mode 100644 plugins/hls-tactics-plugin/test/golden/KnownModuleInstanceSemigroup.hs.expected

diff --git a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs
index 906c350631..fc13708f8a 100644
--- a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs
+++ b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs
@@ -72,6 +72,7 @@ spec = do
     autoTest  6 10 "KnownBigSemigroup.hs"
     autoTest  4 10 "KnownThetaSemigroup.hs"
     autoTest  6 10 "KnownCounterfactualSemigroup.hs"
+    autoTest 10 10 "KnownModuleInstanceSemigroup.hs"
     autoTest  4 10 "KnownMissingSemigroup.hs"
     autoTest  7 12 "KnownMonoid.hs"
     autoTest  7 12 "KnownPolyMonoid.hs"
diff --git a/plugins/hls-tactics-plugin/test/golden/KnownModuleInstanceSemigroup.hs b/plugins/hls-tactics-plugin/test/golden/KnownModuleInstanceSemigroup.hs
new file mode 100644
index 0000000000..8a03a029af
--- /dev/null
+++ b/plugins/hls-tactics-plugin/test/golden/KnownModuleInstanceSemigroup.hs
@@ -0,0 +1,11 @@
+data Foo = Foo
+
+instance Semigroup Foo where
+  (<>) _ _ = Foo
+
+
+data Bar = Bar Foo Foo
+
+instance Semigroup Bar where
+  (<>) = _
+
diff --git a/plugins/hls-tactics-plugin/test/golden/KnownModuleInstanceSemigroup.hs.expected b/plugins/hls-tactics-plugin/test/golden/KnownModuleInstanceSemigroup.hs.expected
new file mode 100644
index 0000000000..498cca1a04
--- /dev/null
+++ b/plugins/hls-tactics-plugin/test/golden/KnownModuleInstanceSemigroup.hs.expected
@@ -0,0 +1,11 @@
+data Foo = Foo
+
+instance Semigroup Foo where
+  (<>) _ _ = Foo
+
+
+data Bar = Bar Foo Foo
+
+instance Semigroup Bar where
+  (<>) (Bar f4 f5) (Bar f f3) = Bar ((<>) f4 f) ((<>) f5 f3)
+

From f7225f88414e8001ea48bae189ee565004c4b4ad Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Mon, 5 Apr 2021 09:12:10 -0700
Subject: [PATCH 5/9] Correctly thread theta and lookup instances

---
 .../hls-tactics-plugin/src/Wingman/CodeGen.hs |  3 +-
 .../hls-tactics-plugin/src/Wingman/Context.hs | 65 ++++++++++++++-----
 .../src/Wingman/FeatureSet.hs                 |  1 +
 .../src/Wingman/Judgements/Theta.hs           | 45 +++++++++----
 .../src/Wingman/KnownStrategies.hs            | 31 ++++++---
 .../src/Wingman/LanguageServer.hs             |  3 +-
 .../src/Wingman/Machinery.hs                  |  5 +-
 .../hls-tactics-plugin/src/Wingman/Tactics.hs | 22 +++----
 .../hls-tactics-plugin/src/Wingman/Types.hs   |  3 +
 9 files changed, 119 insertions(+), 59 deletions(-)

diff --git a/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs b/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs
index 632f6e12e7..f0e8e09ab5 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs
@@ -16,7 +16,6 @@ import           Control.Monad.State
 import           Data.Bool (bool)
 import           Data.Generics.Labels ()
 import           Data.List
-import           Data.Maybe (mapMaybe)
 import           Data.Monoid (Endo(..))
 import qualified Data.Set as S
 import           Data.Traversable
@@ -58,7 +57,7 @@ destructMatches f scrut t jdg = do
         [] -> throwError $ GoalMismatch "destruct" g
         _ -> fmap unzipTrace $ for dcs $ \dc -> do
           let con = RealDataCon dc
-              ev = mapMaybe mkEvidence $ dataConInstArgTys dc apps
+              ev = concatMap mkEvidence $ dataConInstArgTys dc apps
               -- We explicitly do not need to add the method hypothesis to
               -- #syn_scoped
               method_hy = foldMap evidenceToHypothesis ev
diff --git a/plugins/hls-tactics-plugin/src/Wingman/Context.hs b/plugins/hls-tactics-plugin/src/Wingman/Context.hs
index bd3d16bc81..00cf39f0dc 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/Context.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/Context.hs
@@ -1,16 +1,21 @@
 module Wingman.Context where
 
-import Bag
-import Control.Arrow
-import Control.Monad.Reader
-import Development.IDE.GHC.Compat
-import OccName
-import TcRnTypes
-import Wingman.FeatureSet (FeatureSet)
-import Wingman.Types
-import InstEnv (InstMatch, lookupInstEnv, InstEnvs(..))
-import GhcPlugins (ExternalPackageState (eps_inst_env))
-import Data.Maybe (listToMaybe)
+import           Bag
+import           Control.Arrow
+import           Control.Monad.Reader
+import           Data.Foldable.Extra (allM)
+import           Data.Maybe (fromMaybe, isJust)
+import qualified Data.Set as S
+import           Development.IDE.GHC.Compat
+import           GhcPlugins (ExternalPackageState (eps_inst_env), piResultTys)
+import           InstEnv (lookupInstEnv, InstEnvs(..), is_dfun)
+import           OccName
+import           TcRnTypes
+import           TcType (tcSplitTyConApp, tcSplitPhiTy)
+import           TysPrim (alphaTys)
+import           Wingman.FeatureSet (FeatureSet)
+import           Wingman.Judgements.Theta
+import           Wingman.Types
 
 
 mkContext
@@ -19,8 +24,9 @@ mkContext
     -> TcGblEnv
     -> ExternalPackageState
     -> KnownThings
+    -> [Evidence]
     -> Context
-mkContext features locals tcg eps kt = Context
+mkContext features locals tcg eps kt ev = Context
   { ctxDefiningFuncs = locals
   , ctxModuleFuncs = fmap splitId
                    . (getFunBindId =<<)
@@ -34,6 +40,7 @@ mkContext features locals tcg eps kt = Context
         (tcg_inst_env tcg)
         (tcVisibleOrphanMods tcg)
   , ctxKnownThings = kt
+  , ctxTheta = evidenceToThetaType ev
   }
 
 
@@ -57,15 +64,41 @@ getKnownThing :: MonadReader Context m => (KnownThings -> a) -> m a
 getKnownThing f = asks $ f . ctxKnownThings
 
 
-getKnownInstance :: MonadReader Context m => (KnownThings -> Class) -> [Type] -> m (Maybe InstMatch)
+getKnownInstance :: MonadReader Context m => (KnownThings -> Class) -> [Type] -> m (Maybe (Class, PredType))
 getKnownInstance f tys = do
   cls <- getKnownThing f
   getInstance cls tys
 
 
-getInstance :: MonadReader Context m => Class -> [Type] -> m (Maybe InstMatch)
+getInstance :: MonadReader Context m => Class -> [Type] -> m (Maybe (Class, PredType))
 getInstance cls tys = do
   env <- asks ctxInstEnvs
-  let (res, _, _) = lookupInstEnv False env cls tys
-  pure $ listToMaybe res
+  let (mres, _, _) = lookupInstEnv False env cls tys
+  case mres of
+    ((inst, mapps) : _) -> do
+      -- Get the instantiated type of the dictionary
+      let df = piResultTys (idType $ is_dfun inst) $ zipWith fromMaybe alphaTys mapps
+      -- pull off its resulting arguments
+      let (theta, df') = tcSplitPhiTy df
+      traceMX "looking for instances" theta
+      allM hasClassInstance theta >>= \case
+        True -> pure $ do
+          traceMX "solved instance for" df'
+          Just (cls, df')
+        False -> pure Nothing
+    _ -> pure Nothing
+
+
+hasClassInstance :: MonadReader Context m => PredType -> m Bool
+hasClassInstance predty = do
+  theta <- asks ctxTheta
+  case S.member (CType predty) theta of
+    True -> do
+      traceMX "cached instance for " predty
+      pure True
+    False -> do
+      let (con, apps) = tcSplitTyConApp predty
+      case tyConClass_maybe con of
+        Nothing -> pure False
+        Just cls -> fmap isJust $ getInstance cls apps
 
diff --git a/plugins/hls-tactics-plugin/src/Wingman/FeatureSet.hs b/plugins/hls-tactics-plugin/src/Wingman/FeatureSet.hs
index a36f2da49a..962e8e5645 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/FeatureSet.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/FeatureSet.hs
@@ -24,6 +24,7 @@ data Feature
   = FeatureDestructAll
   | FeatureUseDataCon
   | FeatureRefineHole
+  | FeatureKnownMonoid
   deriving (Eq, Ord, Show, Read, Enum, Bounded)
 
 
diff --git a/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs b/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs
index ff359eb6bf..2986c6a36b 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs
@@ -7,25 +7,30 @@ module Wingman.Judgements.Theta
   , mkEvidence
   , evidenceToSubst
   , evidenceToHypothesis
+  , evidenceToThetaType
   ) where
 
-import           Data.Maybe (fromMaybe, mapMaybe)
+import           Control.Applicative (empty)
+import           Data.Maybe (fromMaybe, mapMaybe, maybeToList)
 import           Data.Set (Set)
 import qualified Data.Set as S
 import           Development.IDE.GHC.Compat
-import           Generics.SYB hiding (tyConName)
-import           GhcPlugins (mkVarOcc, splitTyConApp_maybe, getTyVar_maybe)
+import           Generics.SYB hiding (tyConName, empty)
+import           GhcPlugins (mkVarOcc, splitTyConApp_maybe, getTyVar_maybe, zipTvSubst)
+import           TcEvidence
+import           TcType (tcTyConAppTyCon_maybe)
+import           TysPrim (eqPrimTyCon)
+import           Wingman.Machinery
+import           Wingman.Types
+
 #if __GLASGOW_HASKELL__ > 806
 import           GhcPlugins (eqTyCon)
+import Class (classTyVars)
+import TcType (substTy)
 #else
 import           GhcPlugins (nameRdrName, tyConName)
 import           PrelNames (eqTyCon_RDR)
 #endif
-import           TcEvidence
-import           TcType (tcTyConAppTyCon_maybe)
-import           TysPrim (eqPrimTyCon)
-import           Wingman.Machinery
-import           Wingman.Types
 
 
 ------------------------------------------------------------------------------
@@ -40,19 +45,29 @@ data Evidence
 
 ------------------------------------------------------------------------------
 -- | Given a 'PredType', pull an 'Evidence' out of it.
-mkEvidence :: PredType -> Maybe Evidence
+mkEvidence :: PredType -> [Evidence]
 mkEvidence (getEqualityTheta -> Just (a, b))
-  = Just $ EqualityOfTypes a b
-mkEvidence inst@(tcTyConAppTyCon_maybe -> Just (isClassTyCon -> True))
-  = Just $ HasInstance inst
-mkEvidence _ = Nothing
+  = pure $ EqualityOfTypes a b
+mkEvidence inst@(tcTyConAppTyCon_maybe -> Just (tyConClass_maybe -> Just cls)) = do
+  (_, apps) <- maybeToList $ splitTyConApp_maybe inst
+  let tvs     = classTyVars cls
+      subst   = zipTvSubst tvs apps
+  sc_ev <- traverse (mkEvidence . substTy subst) $ classSCTheta cls
+  HasInstance inst : sc_ev
+mkEvidence _ = empty
+
+
+evidenceToThetaType :: [Evidence] -> Set CType
+evidenceToThetaType evs = S.fromList $ do
+  HasInstance t <- evs
+  pure $ CType t
 
 
 ------------------------------------------------------------------------------
 -- | Compute all the 'Evidence' implicitly bound at the given 'SrcSpan'.
 getEvidenceAtHole :: SrcSpan -> LHsBinds GhcTc -> [Evidence]
 getEvidenceAtHole dst
-  = mapMaybe mkEvidence
+  = concatMap mkEvidence
   . (everything (<>) $
         mkQ mempty (absBinds dst) `extQ` wrapperBinds dst `extQ` matchBinds dst)
 
@@ -111,6 +126,8 @@ excludeForbiddenMethods = filter (not . flip S.member forbiddenMethods . hi_name
         -- show
       , "showsPrec"
       , "showList"
+        -- monad
+      , "return"
       ]
 
 
diff --git a/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs b/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs
index f0df6cd261..bf8644c22f 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs
@@ -1,7 +1,7 @@
 module Wingman.KnownStrategies where
 
 import Control.Monad.Error.Class
-import OccName (mkVarOcc, mkMethodOcc)
+import OccName (mkVarOcc)
 import Refinery.Tactic
 import Wingman.Context (getCurrentDefinitions, getKnownInstance)
 import Wingman.KnownStrategies.QuickCheck (deriveArbitrary)
@@ -10,18 +10,29 @@ import Wingman.Tactics
 import Wingman.Types
 import Wingman.Judgements (jGoal)
 import Data.Foldable (for_)
+import Wingman.FeatureSet
+import Control.Applicative (empty)
+import Control.Monad.Reader.Class (asks)
 
 
 knownStrategies :: TacticsM ()
 knownStrategies = choice
   [ known "fmap" deriveFmap
   , known "mempty" deriveMempty
-  , known "<>" deriveMappend
-  , known "mappend" deriveMappend
   , known "arbitrary" deriveArbitrary
+  , featureGuard FeatureKnownMonoid $ known "<>" deriveMappend
+  , featureGuard FeatureKnownMonoid $ known "mappend" deriveMappend
   ]
 
 
+featureGuard :: Feature -> TacticsM a -> TacticsM a
+featureGuard feat t = do
+  fs <- asks ctxFeatureSet
+  case hasFeature feat fs of
+    True -> t
+    False -> empty
+
+
 known :: String -> TacticsM () -> TacticsM ()
 known name t = do
   getCurrentDefinitions >>= \case
@@ -47,10 +58,13 @@ deriveMappend = do
   destructAll
   split
   g <- goal
-  minst <- getKnownInstance kt_semigroup [unCType $ jGoal g]
-  for_ minst $ \inst -> do
+  minst <- getKnownInstance kt_semigroup
+         . pure
+         . unCType
+         $ jGoal g
+  for_ minst $ \(cls, df) -> do
     restrictPositionForApplication
-      (applyMethod inst $ mkVarOcc "<>")
+      (applyMethod cls df $ mkVarOcc "<>")
       assumption
   try $
     restrictPositionForApplication
@@ -63,8 +77,7 @@ deriveMempty = do
   split
   g <- goal
   minst <- getKnownInstance kt_monoid [unCType $ jGoal g]
-  for_ minst $ \inst -> do
-    applyMethod inst (mkVarOcc "mempty" )
+  for_ minst $ \(cls, df) -> do
+    applyMethod cls df $ mkVarOcc "mempty"
   try assumption
 
-
diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs
index 0eed1ed2c3..b60eb2a941 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs
@@ -151,16 +151,17 @@ mkJudgementAndContext
     -> (Judgement, Context)
 mkJudgementAndContext features g binds rss tcg eps kt = do
       let tcs = tcg_binds tcg
+          evidence = getEvidenceAtHole (RealSrcSpan rss) tcs
           ctx = mkContext features
                   (mapMaybe (sequenceA . (occName *** coerce))
                     $ getDefiningBindings binds rss)
                   tcg
                   eps
                   kt
+                  evidence
           top_provs = getRhsPosVals rss tcs
           local_hy = spliceProvenance top_provs
                    $ hypothesisFromBindings rss binds
-          evidence = getEvidenceAtHole (RealSrcSpan rss) tcs
           cls_hy = foldMap evidenceToHypothesis evidence
           subst = ts_unifier $ appEndo (foldMap (Endo . evidenceToSubst) evidence) defaultTacticState
        in ( fmap (CType . substTyAddInScope subst . unCType) $ mkFirstJudgement
diff --git a/plugins/hls-tactics-plugin/src/Wingman/Machinery.hs b/plugins/hls-tactics-plugin/src/Wingman/Machinery.hs
index 1fa209c4ce..34dcb449c6 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/Machinery.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/Machinery.hs
@@ -243,10 +243,7 @@ methodHypothesis ty = do
   let methods = classMethods cls
       tvs     = classTyVars cls
       subst   = zipTvSubst tvs apps
-  sc_methods <- fmap join
-              $ traverse (methodHypothesis . substTy subst)
-              $ classSCTheta cls
-  pure $ mappend sc_methods $ methods <&> \method ->
+  pure $ methods <&> \method ->
     let (_, _, ty) = tcSplitSigmaTy $ idType method
     in ( HyInfo (occName method) (ClassMethodPrv $ Uniquely cls) $ CType $ substTy subst ty
        )
diff --git a/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs b/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs
index 5560b50b1a..a6b1a98d0c 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs
@@ -22,13 +22,11 @@ import           Development.IDE.GHC.Compat
 import           GHC.Exts
 import           GHC.SourceGen.Expr
 import           GHC.SourceGen.Overloaded
-import           InstEnv (InstMatch, ClsInst (is_cls, is_dfun))
 import           Name (occNameString, occName)
 import           Refinery.Tactic
 import           Refinery.Tactic.Internal
 import           TcType
 import           Type hiding (Var)
-import           TysPrim (alphaTys)
 import           Wingman.CodeGen
 import           Wingman.Context
 import           Wingman.GHC
@@ -349,6 +347,7 @@ refine = do
 auto' :: Int -> TacticsM ()
 auto' 0 = throwError NoProgress
 auto' n = do
+  traceMX "falling through to auto" n
   let loop = auto' (n - 1)
   try intros
   choice
@@ -378,27 +377,24 @@ allNames :: Judgement -> Set OccName
 allNames = hyNamesInScope . jHypothesis
 
 
-applyMethod :: InstMatch -> OccName -> TacticsM ()
-applyMethod (inst, mapps) method_name = do
-  let cls  = is_cls inst
+applyMethod :: Class -> PredType -> OccName -> TacticsM ()
+applyMethod cls df method_name = do
   case find ((== method_name) . occName) $ classMethods cls of
     Just method -> do
-      -- Get the instantiated type of the dictionary
-      let df = piResultTys (idType $ is_dfun inst) $ zipWith fromMaybe alphaTys mapps
-      -- pull off its resulting arguments
       let (_, apps) = splitAppTys df
-      -- and apply them to the type of the instance
-      let ty = snd $ splitFunTy (piResultTys (idType method) apps)
+      let ty = piResultTys (idType method) apps
       apply $ HyInfo method_name (ClassMethodPrv $ Uniquely cls) $ CType ty
     Nothing -> do
+      traceMX "not in scope" method_name
       throwError $ NotInScope method_name
 
 
 applyByName :: OccName -> TacticsM ()
 applyByName name = do
   g <- goal
-  for_ (unHypothesis (jHypothesis g)) $ \hi ->
+  choice $ (unHypothesis (jHypothesis g)) <&> \hi ->
     case hi_name hi == name of
-      True -> try $ apply hi
-      False -> pure ()
+      True  -> apply hi
+      False -> empty
+
 
diff --git a/plugins/hls-tactics-plugin/src/Wingman/Types.hs b/plugins/hls-tactics-plugin/src/Wingman/Types.hs
index 6e882cdc51..c8fe802310 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/Types.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/Types.hs
@@ -397,6 +397,7 @@ data Context = Context
   , ctxFeatureSet    :: FeatureSet
   , ctxKnownThings   :: KnownThings
   , ctxInstEnvs      :: InstEnvs
+  , ctxTheta         :: Set CType
   }
 
 instance Show Context where
@@ -405,6 +406,7 @@ instance Show Context where
     , showsPrec 10 ctxDefiningFuncs ""
     , showsPrec 10 ctxModuleFuncs ""
     , showsPrec 10 ctxFeatureSet ""
+    , showsPrec 10 ctxTheta ""
     ]
 
 
@@ -424,6 +426,7 @@ emptyContext
       , ctxFeatureSet = mempty
       , ctxKnownThings = error "empty known things from emptyContext"
       , ctxInstEnvs = InstEnvs mempty mempty mempty
+      , ctxTheta = mempty
       }
 
 

From a68b928ced79f651f7e08cfab4936ef001ab0256 Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Mon, 5 Apr 2021 09:32:38 -0700
Subject: [PATCH 6/9] Tidy and haddock

---
 .../hls-tactics-plugin/src/Wingman/Context.hs | 23 +++++++++++++------
 plugins/hls-tactics-plugin/src/Wingman/GHC.hs |  6 +++++
 .../src/Wingman/Judgements/Theta.hs           | 17 +++++++-------
 .../src/Wingman/KnownStrategies.hs            | 14 +++++++++++
 .../src/Wingman/LanguageServer.hs             |  4 ++--
 .../hls-tactics-plugin/src/Wingman/Tactics.hs |  7 ++----
 .../hls-tactics-plugin/src/Wingman/Types.hs   |  2 ++
 7 files changed, 51 insertions(+), 22 deletions(-)

diff --git a/plugins/hls-tactics-plugin/src/Wingman/Context.hs b/plugins/hls-tactics-plugin/src/Wingman/Context.hs
index 00cf39f0dc..ef133d12ad 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/Context.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/Context.hs
@@ -60,16 +60,27 @@ getCurrentDefinitions :: MonadReader Context m => m [(OccName, CType)]
 getCurrentDefinitions = asks ctxDefiningFuncs
 
 
+------------------------------------------------------------------------------
+-- | Extract something from 'KnownThings'.
 getKnownThing :: MonadReader Context m => (KnownThings -> a) -> m a
 getKnownThing f = asks $ f . ctxKnownThings
 
 
+------------------------------------------------------------------------------
+-- | Like 'getInstance', but uses a class from the 'KnownThings'.
 getKnownInstance :: MonadReader Context m => (KnownThings -> Class) -> [Type] -> m (Maybe (Class, PredType))
 getKnownInstance f tys = do
   cls <- getKnownThing f
   getInstance cls tys
 
 
+------------------------------------------------------------------------------
+-- | Determine if there is an instance that exists for the given 'Class' at the
+-- specified types. Deeply checks contexts to ensure the instance is actually
+-- real.
+--
+-- If so, this returns a 'PredType' that corresponds to the type of the
+-- dictionary.
 getInstance :: MonadReader Context m => Class -> [Type] -> m (Maybe (Class, PredType))
 getInstance cls tys = do
   env <- asks ctxInstEnvs
@@ -80,22 +91,20 @@ getInstance cls tys = do
       let df = piResultTys (idType $ is_dfun inst) $ zipWith fromMaybe alphaTys mapps
       -- pull off its resulting arguments
       let (theta, df') = tcSplitPhiTy df
-      traceMX "looking for instances" theta
       allM hasClassInstance theta >>= \case
-        True -> pure $ do
-          traceMX "solved instance for" df'
-          Just (cls, df')
+        True -> pure $ Just (cls, df')
         False -> pure Nothing
     _ -> pure Nothing
 
 
+------------------------------------------------------------------------------
+-- | Like 'getInstance', but only returns whether or not it succeeded. Can fail
+-- fast, and uses a cached Theta from the context.
 hasClassInstance :: MonadReader Context m => PredType -> m Bool
 hasClassInstance predty = do
   theta <- asks ctxTheta
   case S.member (CType predty) theta of
-    True -> do
-      traceMX "cached instance for " predty
-      pure True
+    True -> pure True
     False -> do
       let (con, apps) = tcSplitTyConApp predty
       case tyConClass_maybe con of
diff --git a/plugins/hls-tactics-plugin/src/Wingman/GHC.hs b/plugins/hls-tactics-plugin/src/Wingman/GHC.hs
index 1e19984c50..c8b198dc23 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/GHC.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/GHC.hs
@@ -301,6 +301,8 @@ unXPat (XPat (L _ pat)) = unXPat pat
 unXPat pat              = pat
 
 
+------------------------------------------------------------------------------
+-- | Build a 'KnownThings'.
 knownThings :: TcGblEnv -> HscEnvEq -> MaybeT IO KnownThings
 knownThings tcg hscenv= do
   let cls = knownClass tcg hscenv
@@ -309,12 +311,16 @@ knownThings tcg hscenv= do
     <*> cls (mkClsOcc "Monoid")
 
 
+------------------------------------------------------------------------------
+-- | Like 'knownThing' but specialized to classes.
 knownClass :: TcGblEnv -> HscEnvEq -> OccName -> MaybeT IO Class
 knownClass = knownThing $ \case
   ATyCon tc -> tyConClass_maybe tc
   _         -> Nothing
 
 
+------------------------------------------------------------------------------
+-- | Helper function for defining 'knownThings'.
 knownThing :: (TyThing -> Maybe a) -> TcGblEnv -> HscEnvEq -> OccName -> MaybeT IO a
 knownThing f tcg hscenv occ = do
   let modul = extractModule tcg
diff --git a/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs b/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs
index 2986c6a36b..64bafcfcff 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs
@@ -10,6 +10,7 @@ module Wingman.Judgements.Theta
   , evidenceToThetaType
   ) where
 
+import           Class (classTyVars)
 import           Control.Applicative (empty)
 import           Data.Maybe (fromMaybe, mapMaybe, maybeToList)
 import           Data.Set (Set)
@@ -17,20 +18,18 @@ import qualified Data.Set as S
 import           Development.IDE.GHC.Compat
 import           Generics.SYB hiding (tyConName, empty)
 import           GhcPlugins (mkVarOcc, splitTyConApp_maybe, getTyVar_maybe, zipTvSubst)
-import           TcEvidence
-import           TcType (tcTyConAppTyCon_maybe)
-import           TysPrim (eqPrimTyCon)
-import           Wingman.Machinery
-import           Wingman.Types
-
 #if __GLASGOW_HASKELL__ > 806
 import           GhcPlugins (eqTyCon)
-import Class (classTyVars)
-import TcType (substTy)
 #else
 import           GhcPlugins (nameRdrName, tyConName)
 import           PrelNames (eqTyCon_RDR)
 #endif
+import           TcEvidence
+import           TcType (substTy)
+import           TcType (tcTyConAppTyCon_maybe)
+import           TysPrim (eqPrimTyCon)
+import           Wingman.Machinery
+import           Wingman.Types
 
 
 ------------------------------------------------------------------------------
@@ -57,6 +56,8 @@ mkEvidence inst@(tcTyConAppTyCon_maybe -> Just (tyConClass_maybe -> Just cls)) =
 mkEvidence _ = empty
 
 
+------------------------------------------------------------------------------
+-- | Build a set of 'PredType's from the evidence.
 evidenceToThetaType :: [Evidence] -> Set CType
 evidenceToThetaType evs = S.fromList $ do
   HasInstance t <- evs
diff --git a/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs b/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs
index bf8644c22f..0cd72bd62e 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs
@@ -25,6 +25,8 @@ knownStrategies = choice
   ]
 
 
+------------------------------------------------------------------------------
+-- | Guard a tactic behind a feature.
 featureGuard :: Feature -> TacticsM a -> TacticsM a
 featureGuard feat t = do
   fs <- asks ctxFeatureSet
@@ -52,6 +54,14 @@ deriveFmap = do
     ]
 
 
+------------------------------------------------------------------------------
+-- | We derive mappend by binding the arguments, introducing the constructor,
+-- and then calling mappend recursively. At each recursive call, we filter away
+-- any binding that isn't in an analogous position.
+--
+-- The recursive call first attempts to use an instace in scope. If that fails,
+-- it fals back to trying a theta method from the hypothesis with the correct
+-- name.
 deriveMappend :: TacticsM ()
 deriveMappend = do
   try intros
@@ -72,6 +82,10 @@ deriveMappend = do
       assumption
 
 
+------------------------------------------------------------------------------
+-- | We derive mempty by introducing the constructor, and then trying to
+-- 'mempty' everywhere. This smaller 'mempty' might come from an instance in
+-- scope, or it might come from the hypothesis theta.
 deriveMempty :: TacticsM ()
 deriveMempty = do
   split
diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs
index b60eb2a941..3ce5694a68 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs
@@ -12,12 +12,14 @@ import           Data.Coerce
 import           Data.Functor ((<&>))
 import           Data.Generics.Aliases (mkQ)
 import           Data.Generics.Schemes (everything)
+import           Data.IORef (readIORef)
 import qualified Data.Map as M
 import           Data.Maybe
 import           Data.Monoid
 import qualified Data.Set  as S
 import qualified Data.Text as T
 import           Data.Traversable
+import           Development.IDE (hscEnv)
 import           Development.IDE.Core.PositionMapping
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Service (runAction)
@@ -46,8 +48,6 @@ import           Wingman.Judgements
 import           Wingman.Judgements.Theta
 import           Wingman.Range
 import           Wingman.Types
-import Development.IDE (hscEnv)
-import Data.IORef (readIORef)
 
 
 tacticDesc :: T.Text -> T.Text
diff --git a/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs b/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs
index a6b1a98d0c..f477a2a323 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs
@@ -11,6 +11,7 @@ import           Control.Monad.Except (throwError)
 import           Control.Monad.Reader.Class (MonadReader (ask))
 import           Control.Monad.State.Strict (StateT(..), runStateT)
 import           Data.Foldable
+import           Data.Functor ((<&>))
 import           Data.Generics.Labels ()
 import           Data.List
 import qualified Data.Map as M
@@ -34,7 +35,6 @@ import           Wingman.Judgements
 import           Wingman.Machinery
 import           Wingman.Naming
 import           Wingman.Types
-import Data.Functor ((<&>))
 
 
 ------------------------------------------------------------------------------
@@ -347,7 +347,6 @@ refine = do
 auto' :: Int -> TacticsM ()
 auto' 0 = throwError NoProgress
 auto' n = do
-  traceMX "falling through to auto" n
   let loop = auto' (n - 1)
   try intros
   choice
@@ -384,9 +383,7 @@ applyMethod cls df method_name = do
       let (_, apps) = splitAppTys df
       let ty = piResultTys (idType method) apps
       apply $ HyInfo method_name (ClassMethodPrv $ Uniquely cls) $ CType ty
-    Nothing -> do
-      traceMX "not in scope" method_name
-      throwError $ NotInScope method_name
+    Nothing -> throwError $ NotInScope method_name
 
 
 applyByName :: OccName -> TacticsM ()
diff --git a/plugins/hls-tactics-plugin/src/Wingman/Types.hs b/plugins/hls-tactics-plugin/src/Wingman/Types.hs
index c8fe802310..7955b35f58 100644
--- a/plugins/hls-tactics-plugin/src/Wingman/Types.hs
+++ b/plugins/hls-tactics-plugin/src/Wingman/Types.hs
@@ -410,6 +410,8 @@ instance Show Context where
     ]
 
 
+------------------------------------------------------------------------------
+-- | Things we'd like to look up, that don't exist in TysWiredIn.
 data KnownThings = KnownThings
   { kt_semigroup :: Class
   , kt_monoid    :: Class

From cca94d0851a79f6e8bbaec4f1f32058049888df3 Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Mon, 5 Apr 2021 09:42:46 -0700
Subject: [PATCH 7/9] Add a test that already has destructed the args

---
 plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs       | 1 +
 .../test/golden/KnownDestructedSemigroup.hs                  | 5 +++++
 .../test/golden/KnownDestructedSemigroup.hs.expected         | 5 +++++
 3 files changed, 11 insertions(+)
 create mode 100644 plugins/hls-tactics-plugin/test/golden/KnownDestructedSemigroup.hs
 create mode 100644 plugins/hls-tactics-plugin/test/golden/KnownDestructedSemigroup.hs.expected

diff --git a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs
index fc13708f8a..a53c613a36 100644
--- a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs
+++ b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs
@@ -73,6 +73,7 @@ spec = do
     autoTest  4 10 "KnownThetaSemigroup.hs"
     autoTest  6 10 "KnownCounterfactualSemigroup.hs"
     autoTest 10 10 "KnownModuleInstanceSemigroup.hs"
+    autoTest  4 22 "KnownDestructedSemigroup.hs"
     autoTest  4 10 "KnownMissingSemigroup.hs"
     autoTest  7 12 "KnownMonoid.hs"
     autoTest  7 12 "KnownPolyMonoid.hs"
diff --git a/plugins/hls-tactics-plugin/test/golden/KnownDestructedSemigroup.hs b/plugins/hls-tactics-plugin/test/golden/KnownDestructedSemigroup.hs
new file mode 100644
index 0000000000..ed4182c6d9
--- /dev/null
+++ b/plugins/hls-tactics-plugin/test/golden/KnownDestructedSemigroup.hs
@@ -0,0 +1,5 @@
+data Test a = Test [a]
+
+instance Semigroup (Test a) where
+  Test a <> Test c = _
+
diff --git a/plugins/hls-tactics-plugin/test/golden/KnownDestructedSemigroup.hs.expected b/plugins/hls-tactics-plugin/test/golden/KnownDestructedSemigroup.hs.expected
new file mode 100644
index 0000000000..9515b7fd84
--- /dev/null
+++ b/plugins/hls-tactics-plugin/test/golden/KnownDestructedSemigroup.hs.expected
@@ -0,0 +1,5 @@
+data Test a = Test [a]
+
+instance Semigroup (Test a) where
+  (<>) (Test a) (Test c) = Test ((<>) a c)
+

From 3eb0a1d258b32784ae02774dca40b0b32af6b0ac Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Mon, 5 Apr 2021 21:54:29 -0700
Subject: [PATCH 8/9] Add whitespace invariant test machinery

---
 .../test/CodeAction/AutoSpec.hs               |  4 +-
 plugins/hls-tactics-plugin/test/Utils.hs      | 54 ++++++++++++++++---
 2 files changed, 50 insertions(+), 8 deletions(-)

diff --git a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs
index a53c613a36..e4da91f3c0 100644
--- a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs
+++ b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs
@@ -16,6 +16,7 @@ import Wingman.FeatureSet (allFeatures)
 spec :: Spec
 spec = do
   let autoTest = goldenTest Auto ""
+      autoTestNoWhitespace = goldenTestNoWhitespace Auto ""
 
   describe "golden" $ do
     autoTest 11  8 "AutoSplitGADT.hs"
@@ -69,7 +70,8 @@ spec = do
 
   describe "known" $ do
     autoTest 25 13 "GoldenArbitrary.hs"
-    autoTest  6 10 "KnownBigSemigroup.hs"
+    autoTestNoWhitespace
+              6 10 "KnownBigSemigroup.hs"
     autoTest  4 10 "KnownThetaSemigroup.hs"
     autoTest  6 10 "KnownCounterfactualSemigroup.hs"
     autoTest 10 10 "KnownModuleInstanceSemigroup.hs"
diff --git a/plugins/hls-tactics-plugin/test/Utils.hs b/plugins/hls-tactics-plugin/test/Utils.hs
index 4dae186079..21999d96ba 100644
--- a/plugins/hls-tactics-plugin/test/Utils.hs
+++ b/plugins/hls-tactics-plugin/test/Utils.hs
@@ -8,6 +8,8 @@
 module Utils where
 
 import           Control.Applicative.Combinators (skipManyTill)
+import           Control.DeepSeq (deepseq)
+import qualified Control.Exception as E
 import           Control.Lens hiding (failing, (<.>), (.=))
 import           Control.Monad (unless)
 import           Control.Monad.IO.Class
@@ -19,15 +21,19 @@ import           Data.Maybe
 import           Data.Text (Text)
 import qualified Data.Text.IO as T
 import qualified Ide.Plugin.Config as Plugin
-import           Wingman.FeatureSet (FeatureSet, allFeatures, prettyFeatureSet)
-import           Wingman.LanguageServer (mkShowMessageParams)
-import           Wingman.Types
 import           Language.LSP.Test
 import           Language.LSP.Types
 import           Language.LSP.Types.Lens hiding (actions, applyEdit, capabilities, executeCommand, id, line, message, name, rename, title)
 import           System.Directory (doesFileExist)
 import           System.FilePath
 import           Test.Hspec
+import           Test.Hspec.Formatters (FailureReason(ExpectedButGot))
+import           Test.Tasty.HUnit (Assertion, HUnitFailure(..))
+import           Wingman.FeatureSet (FeatureSet, allFeatures, prettyFeatureSet)
+import           Wingman.LanguageServer (mkShowMessageParams)
+import           Wingman.Types
+import qualified Data.Text as T
+import Data.Function (on)
 
 
 ------------------------------------------------------------------------------
@@ -92,14 +98,15 @@ setFeatureSet features = do
 
 
 mkGoldenTest
-    :: FeatureSet
+    :: (Text -> Text -> Assertion)
+    -> FeatureSet
     -> TacticCommand
     -> Text
     -> Int
     -> Int
     -> FilePath
     -> SpecWith ()
-mkGoldenTest features tc occ line col input =
+mkGoldenTest eq features tc occ line col input =
   it (input <> " (golden)") $ do
     runSession testCommand fullCaps tacticPath $ do
       setFeatureSet features
@@ -116,7 +123,7 @@ mkGoldenTest features tc occ line col input =
       liftIO $ (doesFileExist expected_name >>=) $ flip unless $ do
         T.writeFile expected_name edited
       expected <- liftIO $ T.readFile expected_name
-      liftIO $ edited `shouldBe` expected
+      liftIO $ edited `eq` expected
 
 mkShowMessageTest
     :: FeatureSet
@@ -142,7 +149,40 @@ mkShowMessageTest features tc occ line col input ufm =
 
 
 goldenTest :: TacticCommand -> Text -> Int -> Int -> FilePath -> SpecWith ()
-goldenTest = mkGoldenTest allFeatures
+goldenTest = mkGoldenTest shouldBe allFeatures
+
+goldenTestNoWhitespace :: TacticCommand -> Text -> Int -> Int -> FilePath -> SpecWith ()
+goldenTestNoWhitespace = mkGoldenTest shouldBeIgnoringSpaces allFeatures
+
+
+shouldBeIgnoringSpaces :: Text -> Text -> Assertion
+shouldBeIgnoringSpaces = assertFun f ""
+  where
+    f = (==) `on` T.unwords . T.words
+
+
+assertFun
+    :: Show a
+    => (a -> a -> Bool)
+    -> String -- ^ The message prefix
+    -> a      -- ^ The expected value
+    -> a      -- ^ The actual value
+    -> Assertion
+assertFun eq preface expected actual =
+  unless (eq actual expected) $ do
+    (prefaceMsg
+      `deepseq` expectedMsg
+      `deepseq` actualMsg
+      `deepseq`
+        E.throwIO
+          (HUnitFailure Nothing $ show $ ExpectedButGot prefaceMsg expectedMsg actualMsg))
+  where
+    prefaceMsg
+      | null preface = Nothing
+      | otherwise = Just preface
+    expectedMsg = show expected
+    actualMsg = show actual
+
 
 
 ------------------------------------------------------------------------------

From 4a6141cf5adf6c1887a6e5d2d4e35d475256f5ae Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Mon, 5 Apr 2021 21:55:08 -0700
Subject: [PATCH 9/9] Sort imports

---
 plugins/hls-tactics-plugin/test/Utils.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/plugins/hls-tactics-plugin/test/Utils.hs b/plugins/hls-tactics-plugin/test/Utils.hs
index 21999d96ba..1c1cacbc37 100644
--- a/plugins/hls-tactics-plugin/test/Utils.hs
+++ b/plugins/hls-tactics-plugin/test/Utils.hs
@@ -16,9 +16,11 @@ import           Control.Monad.IO.Class
 import           Data.Aeson
 import           Data.Default (Default (def))
 import           Data.Foldable
+import           Data.Function (on)
 import qualified Data.Map as M
 import           Data.Maybe
 import           Data.Text (Text)
+import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import qualified Ide.Plugin.Config as Plugin
 import           Language.LSP.Test
@@ -32,8 +34,6 @@ import           Test.Tasty.HUnit (Assertion, HUnitFailure(..))
 import           Wingman.FeatureSet (FeatureSet, allFeatures, prettyFeatureSet)
 import           Wingman.LanguageServer (mkShowMessageParams)
 import           Wingman.Types
-import qualified Data.Text as T
-import Data.Function (on)
 
 
 ------------------------------------------------------------------------------