From b01de47aab4dcda0135b22a3bdb31f1ff8c6936d Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Mon, 19 Oct 2020 22:09:59 -0700
Subject: [PATCH 1/5] Fix a bug preventing split of split

---
 hie.yaml.stack                                |  4 ++
 plugins/tactics/hls-tactics-plugin.cabal      | 22 +++++++
 .../tactics/src/Ide/Plugin/Tactic/Debug.hs    | 17 +++++-
 .../tactics/src/Ide/Plugin/Tactic/Tactics.hs  |  6 +-
 plugins/tactics/test/AutoTupleSpec.hs         | 58 +++++++++++++++++++
 plugins/tactics/test/Main.hs                  |  1 +
 test/functional/Tactic.hs                     |  1 +
 test/testdata/tactic/GoldenBigTuple.hs        |  4 ++
 .../tactic/GoldenBigTuple.hs.expected         |  5 ++
 9 files changed, 114 insertions(+), 4 deletions(-)
 create mode 100644 plugins/tactics/test/AutoTupleSpec.hs
 create mode 100644 plugins/tactics/test/Main.hs
 create mode 100644 test/testdata/tactic/GoldenBigTuple.hs
 create mode 100644 test/testdata/tactic/GoldenBigTuple.hs.expected

diff --git a/hie.yaml.stack b/hie.yaml.stack
index 1c5362b45f..69c94ea0cc 100644
--- a/hie.yaml.stack
+++ b/hie.yaml.stack
@@ -21,9 +21,13 @@ cradle:
 
             - path: "./plugins/default/src"
               component: "haskell-language-server:exe:haskell-language-server"
+
             - path: "./plugins/tactics/src"
               component: "hls-tactics-plugin:lib:hls-tactics-plugin"
 
+            - path: "./plugins/tactics/test"
+              component: "hls-tactics-plugin:test:tests"
+
             - path: "./exe/Arguments.hs"
               component: "haskell-language-server:exe:haskell-language-server"
 
diff --git a/plugins/tactics/hls-tactics-plugin.cabal b/plugins/tactics/hls-tactics-plugin.cabal
index 9abb2b549d..7fecc860c4 100644
--- a/plugins/tactics/hls-tactics-plugin.cabal
+++ b/plugins/tactics/hls-tactics-plugin.cabal
@@ -75,6 +75,28 @@ library
     , syb
     , text
     , transformers
+    , deepseq
 
   default-language: Haskell2010
 
+test-suite tests
+  type: exitcode-stdio-1.0
+  main-is: Main.hs
+  other-modules:
+    AutoTupleSpec
+  hs-source-dirs:
+      test
+  ghc-options: -Wall -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      QuickCheck
+    , base
+    , checkers
+    , hspec
+    , mtl
+    , hls-tactics-plugin
+    , hls-plugin-api
+    , hie-bios
+    , ghc
+    , containers
+  default-language: Haskell2010
+
diff --git a/plugins/tactics/src/Ide/Plugin/Tactic/Debug.hs b/plugins/tactics/src/Ide/Plugin/Tactic/Debug.hs
index ba91a7c1cb..797bc25880 100644
--- a/plugins/tactics/src/Ide/Plugin/Tactic/Debug.hs
+++ b/plugins/tactics/src/Ide/Plugin/Tactic/Debug.hs
@@ -1,3 +1,6 @@
+{-# LANGUAGE BangPatterns     #-}
+{-# LANGUAGE TypeApplications #-}
+
 module Ide.Plugin.Tactic.Debug
   ( unsafeRender
   , unsafeRender'
@@ -9,17 +12,29 @@ module Ide.Plugin.Tactic.Debug
   , traceMX
   ) where
 
+import Control.DeepSeq
+import Control.Exception
 import Debug.Trace
 import DynFlags (unsafeGlobalDynFlags)
 import Outputable hiding ((<>))
+import PlainPanic (PlainGhcException)
+import System.IO.Unsafe (unsafePerformIO)
+
 
 ------------------------------------------------------------------------------
 -- | Print something
 unsafeRender :: Outputable a => a -> String
 unsafeRender = unsafeRender' . ppr
 
+
 unsafeRender' :: SDoc -> String
-unsafeRender' = showSDoc unsafeGlobalDynFlags
+unsafeRender' sdoc = unsafePerformIO $ do
+  let z = showSDoc unsafeGlobalDynFlags sdoc
+  -- We might not have unsafeGlobalDynFlags (like during testing), in which
+  -- case GHC panics. Instead of crashing, let's just fail to print.
+  !res <- try @PlainGhcException $ evaluate $ deepseq z z
+  pure $ either (const "<unsafeRender'>") id res
+{-# NOINLINE unsafeRender' #-}
 
 traceMX :: (Monad m, Show a) => String -> a -> m ()
 traceMX str a = traceM $ mappend ("!!!" <> str <> ": ") $ show a
diff --git a/plugins/tactics/src/Ide/Plugin/Tactic/Tactics.hs b/plugins/tactics/src/Ide/Plugin/Tactic/Tactics.hs
index 4fcccbb61b..f00a1087cb 100644
--- a/plugins/tactics/src/Ide/Plugin/Tactic/Tactics.hs
+++ b/plugins/tactics/src/Ide/Plugin/Tactic/Tactics.hs
@@ -217,9 +217,9 @@ splitAuto = tracing "split(auto)" $ do
         True -> choice $ fmap splitDataCon dcs
         False -> do
           choice $ flip fmap dcs $ \dc -> pruning (splitDataCon dc) $ \jdgs ->
-            case any (/= jGoal jdg) $ fmap jGoal jdgs of
-              False -> Nothing
-              True  -> Just $ UnhelpfulSplit $ nameOccName $ dataConName dc
+            case null jdgs || any (/= jGoal jdg) (fmap jGoal jdgs) of
+              True  -> Nothing
+              False -> Just $ UnhelpfulSplit $ nameOccName $ dataConName dc
 
 
 ------------------------------------------------------------------------------
diff --git a/plugins/tactics/test/AutoTupleSpec.hs b/plugins/tactics/test/AutoTupleSpec.hs
new file mode 100644
index 0000000000..d7bcaace8b
--- /dev/null
+++ b/plugins/tactics/test/AutoTupleSpec.hs
@@ -0,0 +1,58 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module AutoTupleSpec where
+
+import           Data.Either (isRight)
+import qualified Data.Map as M
+import           Ide.Plugin.Tactic.Debug
+import           Ide.Plugin.Tactic.Judgements (mkFirstJudgement)
+import           Ide.Plugin.Tactic.Machinery
+import           Ide.Plugin.Tactic.Types
+import           OccName (mkVarOcc)
+import           Test.Hspec
+import           Test.QuickCheck
+import           Type (mkTyVarTy)
+import           TysPrim (alphaTyVars)
+import           TysWiredIn (mkBoxedTupleTy)
+import Ide.Plugin.Tactic.Tactics (auto')
+
+
+instance Show Type where
+  show = unsafeRender
+
+
+spec :: Spec
+spec = describe "auto for tuple" $ do
+  it "should always be able to discover an auto solution" $ do
+    property $ do
+      -- Pick some number of variables
+      n <- choose (1, 7)
+      let vars = fmap mkTyVarTy $ take n alphaTyVars
+      -- Pick a random ordering
+      in_vars  <- shuffle vars
+      -- Randomly associate them into tuple types
+      in_type  <- mkBoxedTupleTy
+                . fmap mkBoxedTupleTy
+              <$> randomGroups in_vars
+      out_type <- mkBoxedTupleTy
+                . fmap mkBoxedTupleTy
+              <$> randomGroups vars
+      pure $
+          -- We should always be able to find a solution
+          runTactic
+            (Context [] [])
+            (mkFirstJudgement
+              (M.singleton (mkVarOcc "x") $ CType in_type)
+              True
+              mempty
+              out_type)
+            (auto' $ n * 2) `shouldSatisfy` isRight
+
+
+randomGroups :: [a] -> Gen [[a]]
+randomGroups [] = pure []
+randomGroups as = do
+  n <- choose (1, length as)
+  (:) <$> pure (take n as)
+      <*> randomGroups (drop n as)
+
diff --git a/plugins/tactics/test/Main.hs b/plugins/tactics/test/Main.hs
new file mode 100644
index 0000000000..9bc8683d3c
--- /dev/null
+++ b/plugins/tactics/test/Main.hs
@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Main #-}
diff --git a/test/functional/Tactic.hs b/test/functional/Tactic.hs
index 38594eae61..161fd4830b 100644
--- a/test/functional/Tactic.hs
+++ b/test/functional/Tactic.hs
@@ -100,6 +100,7 @@ tests = testGroup
   , goldenTest "GoldenFmapTree.hs"          4 11 Auto ""
   , goldenTest "GoldenGADTDestruct.hs"      7 17 Destruct "gadt"
   , goldenTest "GoldenGADTAuto.hs"          7 13 Auto ""
+  , goldenTest "GoldenBigTuple.hs"          4 12 Auto ""
   ]
 
 
diff --git a/test/testdata/tactic/GoldenBigTuple.hs b/test/testdata/tactic/GoldenBigTuple.hs
new file mode 100644
index 0000000000..1ede521a5f
--- /dev/null
+++ b/test/testdata/tactic/GoldenBigTuple.hs
@@ -0,0 +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 = _
diff --git a/test/testdata/tactic/GoldenBigTuple.hs.expected b/test/testdata/tactic/GoldenBigTuple.hs.expected
new file mode 100644
index 0000000000..1466f65cab
--- /dev/null
+++ b/test/testdata/tactic/GoldenBigTuple.hs.expected
@@ -0,0 +1,5 @@
+-- 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) })

From 20b7965ce1ef45bdaef9ad85cc42200b41865b7a Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Tue, 20 Oct 2020 11:05:20 -0700
Subject: [PATCH 2/5] CPP differentiate between Panic types

---
 plugins/tactics/src/Ide/Plugin/Tactic/Debug.hs | 12 ++++++++++--
 1 file changed, 10 insertions(+), 2 deletions(-)

diff --git a/plugins/tactics/src/Ide/Plugin/Tactic/Debug.hs b/plugins/tactics/src/Ide/Plugin/Tactic/Debug.hs
index 797bc25880..6c528da4e3 100644
--- a/plugins/tactics/src/Ide/Plugin/Tactic/Debug.hs
+++ b/plugins/tactics/src/Ide/Plugin/Tactic/Debug.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns     #-}
+{-# LANGUAGE CPP              #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Ide.Plugin.Tactic.Debug
@@ -17,9 +18,16 @@ import Control.Exception
 import Debug.Trace
 import DynFlags (unsafeGlobalDynFlags)
 import Outputable hiding ((<>))
-import PlainPanic (PlainGhcException)
 import System.IO.Unsafe (unsafePerformIO)
 
+#if __GLASGOW_HASKELL__ >= 808
+import PlainPanic (PlainGhcException)
+type GHC_EXCEPTION = PlainGhcException
+#else
+import Panic (GhcException)
+type GHC_EXCEPTION = GhcException
+#endif
+
 
 ------------------------------------------------------------------------------
 -- | Print something
@@ -32,7 +40,7 @@ unsafeRender' sdoc = unsafePerformIO $ do
   let z = showSDoc unsafeGlobalDynFlags sdoc
   -- We might not have unsafeGlobalDynFlags (like during testing), in which
   -- case GHC panics. Instead of crashing, let's just fail to print.
-  !res <- try @PlainGhcException $ evaluate $ deepseq z z
+  !res <- try @GHC_EXCEPTION $ evaluate $ deepseq z z
   pure $ either (const "<unsafeRender'>") id res
 {-# NOINLINE unsafeRender' #-}
 

From 9a4d5e5430d63ae27edaa3ea5e7ad395f9a5a504 Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Tue, 20 Oct 2020 11:43:17 -0700
Subject: [PATCH 3/5] Add the hls-tactics-tests to CI

---
 .circleci/config.yml | 9 +++++++++
 1 file changed, 9 insertions(+)

diff --git a/.circleci/config.yml b/.circleci/config.yml
index fbd50f1df9..d571f61acf 100644
--- a/.circleci/config.yml
+++ b/.circleci/config.yml
@@ -72,6 +72,15 @@ defaults: &defaults
         command: stack --stack-yaml=${STACK_FILE} test haskell-language-server --dump-logs --test-arguments="-j1"
         no_output_timeout: 120m
 
+    - run:
+        name: Test hls-tactics-plugin
+        # Tasty by default will run all the tests in parallel. Which should
+        # work ok, but given that these CircleCI runners aren't the beefiest
+        # machine can cause some flakiness. So pass -j1 to Tasty (NOT Stack) to
+        # tell it to go slow and steady.
+        command: stack --stack-yaml=${STACK_FILE} test hls-tactics-plugin:test:tests --dump-logs --test-arguments="-j1"
+        no_output_timeout: 30m
+
     - store_test_results:
         path: test-results
 

From 5c1f3a7bd474e2c9438d6c5a06bd0ed0795e96d5 Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Tue, 20 Oct 2020 12:18:16 -0700
Subject: [PATCH 4/5] Fix big tuple test

---
 test/testdata/tactic/GoldenBigTuple.hs.expected | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

diff --git a/test/testdata/tactic/GoldenBigTuple.hs.expected b/test/testdata/tactic/GoldenBigTuple.hs.expected
index 1466f65cab..36a7141036 100644
--- a/test/testdata/tactic/GoldenBigTuple.hs.expected
+++ b/test/testdata/tactic/GoldenBigTuple.hs.expected
@@ -1,5 +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)) })

From 26aff7dfc46be78428b0ab58e86510819032eabe Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Tue, 20 Oct 2020 12:28:39 -0700
Subject: [PATCH 5/5] Don't trace tactic solutions in runTactic

---
 plugins/tactics/src/Ide/Plugin/Tactic.hs      |  5 +++--
 .../src/Ide/Plugin/Tactic/Machinery.hs        | 19 +++++++++----------
 .../tactics/src/Ide/Plugin/Tactic/Types.hs    |  9 +++++++++
 plugins/tactics/test/AutoTupleSpec.hs         |  2 +-
 4 files changed, 22 insertions(+), 13 deletions(-)

diff --git a/plugins/tactics/src/Ide/Plugin/Tactic.hs b/plugins/tactics/src/Ide/Plugin/Tactic.hs
index 82b91d942b..5750835ef7 100644
--- a/plugins/tactics/src/Ide/Plugin/Tactic.hs
+++ b/plugins/tactics/src/Ide/Plugin/Tactic.hs
@@ -296,8 +296,9 @@ tacticCmd tac lf state (TacticParams uri range var_name)
               pure $ (, Nothing)
                 $ Left
                 $ ResponseError InvalidRequest (T.pack $ show err) Nothing
-            Right (_, ext) -> do
-              let g = graft (RealSrcSpan span) ext
+            Right rtr -> do
+              traceMX "solns" $ rtr_other_solns rtr
+              let g = graft (RealSrcSpan span) $ 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/plugins/tactics/src/Ide/Plugin/Tactic/Machinery.hs b/plugins/tactics/src/Ide/Plugin/Tactic/Machinery.hs
index 972cb8a574..f34aff5abd 100644
--- a/plugins/tactics/src/Ide/Plugin/Tactic/Machinery.hs
+++ b/plugins/tactics/src/Ide/Plugin/Tactic/Machinery.hs
@@ -63,7 +63,7 @@ runTactic
     :: Context
     -> Judgement
     -> TacticsM ()       -- ^ Tactic to use
-    -> Either [TacticError] (Trace, LHsExpr GhcPs)
+    -> Either [TacticError] RunTacticResults
 runTactic ctx jdg t =
     let skolems = tyCoVarsOfTypeWellScoped $ unCType $ jGoal jdg
         tacticState = defaultTacticState { ts_skolems = skolems }
@@ -73,16 +73,15 @@ runTactic ctx jdg t =
           $ runTacticT t jdg tacticState of
       (errs, []) -> Left $ take 50 $ errs
       (_, fmap assoc23 -> solns) -> do
-        let sorted = sortBy (comparing $ Down . uncurry scoreSolution . snd) $ solns
-        -- TODO(sandy): remove this trace sometime
-        traceM
-            $ mappend "!!!solns: "
-            $ intercalate "\n"
-            $ reverse
-            $ take 5
-            $ fmap (show . fst) sorted
+        let sorted =
+              sortBy (comparing $ Down . uncurry scoreSolution . snd) solns
         case sorted of
-          (res : _) -> Right $ fst res
+          (((tr, ext), _) : _) ->
+            Right
+              . RunTacticResults tr ext
+              . reverse
+              . fmap fst
+              $ take 5 sorted
           -- guaranteed to not be empty
           _ -> Left []
 
diff --git a/plugins/tactics/src/Ide/Plugin/Tactic/Types.hs b/plugins/tactics/src/Ide/Plugin/Tactic/Types.hs
index 5cfd62b5a6..4d1b802697 100644
--- a/plugins/tactics/src/Ide/Plugin/Tactic/Types.hs
+++ b/plugins/tactics/src/Ide/Plugin/Tactic/Types.hs
@@ -219,3 +219,12 @@ rose :: (Eq a, Monoid a) => a -> [Rose a] -> Rose a
 rose a [Rose (Node a' rs)] | a' == mempty = Rose $ Node a rs
 rose a rs = Rose $ Node a $ coerce rs
 
+
+------------------------------------------------------------------------------
+-- | The results of 'Ide.Plugin.Tactic.Machinery.runTactic'
+data RunTacticResults = RunTacticResults
+  { rtr_trace       :: Trace
+  , rtr_extract     :: LHsExpr GhcPs
+  , rtr_other_solns :: [(Trace, LHsExpr GhcPs)]
+  } deriving Show
+
diff --git a/plugins/tactics/test/AutoTupleSpec.hs b/plugins/tactics/test/AutoTupleSpec.hs
index d7bcaace8b..efe37bf09a 100644
--- a/plugins/tactics/test/AutoTupleSpec.hs
+++ b/plugins/tactics/test/AutoTupleSpec.hs
@@ -7,6 +7,7 @@ import qualified Data.Map as M
 import           Ide.Plugin.Tactic.Debug
 import           Ide.Plugin.Tactic.Judgements (mkFirstJudgement)
 import           Ide.Plugin.Tactic.Machinery
+import           Ide.Plugin.Tactic.Tactics (auto')
 import           Ide.Plugin.Tactic.Types
 import           OccName (mkVarOcc)
 import           Test.Hspec
@@ -14,7 +15,6 @@ import           Test.QuickCheck
 import           Type (mkTyVarTy)
 import           TysPrim (alphaTyVars)
 import           TysWiredIn (mkBoxedTupleTy)
-import Ide.Plugin.Tactic.Tactics (auto')
 
 
 instance Show Type where