Decrease Wingman timeout from 3.3 minutes to 2 seconds (configurable) (#1688)

* Decrease timeout from 3.3 minutes to 2 seconds

* Name the magic number

* Restrict more class methods to speed up search

* Make timeout configurable

* Fix tests after the new hypothesis shrink

Author: isovector

plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs

@@ -127,10 +127,23 @@ excludeForbiddenMethods = filter (not . flip S.member forbiddenMethods . hi_name
       [ -- monadfail
         "fail"
         -- show
-      , "showsPrec"
-      , "showList"
+      , "showsPrec", "showList"
+        -- functor
+      , "<$"
+        -- applicative
+      , "liftA2", "<*", "*>"
         -- monad
-      , "return"
+      , "return", ">>"
+        -- alternative
+      , "some", "many"
+        -- foldable
+      , "foldr1", "foldl1", "elem", "maximum", "minimum", "sum", "product"
+        -- traversable
+      , "sequenceA", "mapM", "sequence"
+        -- semigroup
+      , "sconcat", "stimes"
+        -- monoid
+      , "mconcat"
       ]
 
 

plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs

@@ -109,9 +109,13 @@ unsafeRunStaleIde state nfp a = do
 ------------------------------------------------------------------------------
 
 properties :: Properties
-  '[ 'PropertyKey "max_use_ctor_actions" 'TInteger,
-     'PropertyKey "features" 'TString]
+  '[ 'PropertyKey "max_use_ctor_actions" 'TInteger
+   , 'PropertyKey "features" 'TString
+   , 'PropertyKey "timeout_duration" 'TInteger
+   ]
 properties = emptyProperties
+  & defineIntegerProperty #timeout_duration
+    "The timeout for Wingman actions, in seconds" 2
   & defineStringProperty #features
     "Feature set used by Wingman" ""
   & defineIntegerProperty #max_use_ctor_actions
@@ -124,6 +128,7 @@ getTacticConfig pId =
   Config
     <$> (parseFeatureSet <$> usePropertyLsp #features pId properties)
     <*> usePropertyLsp #max_use_ctor_actions pId properties
+    <*> usePropertyLsp #timeout_duration pId properties
 
 ------------------------------------------------------------------------------
 -- | Get the current feature set from the plugin config.

plugins/hls-tactics-plugin/src/Wingman/Plugin.hs

@@ -88,13 +88,14 @@ tacticCmd tac pId state (TacticParams uri range var_name)
   | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
       features <- getFeatureSet pId
       ccs <- getClientCapabilities
+      cfg <- getTacticConfig pId
       res <- liftIO $ runMaybeT $ do
         (range', jdg, ctx, dflags) <- judgementForHole state nfp range features
         let span = fmap (rangeToRealSrcSpan (fromNormalizedFilePath nfp)) range'
         TrackedStale pm pmmap <- runStaleIde state nfp GetAnnotatedParsedSource
         pm_span <- liftMaybe $ mapAgeFrom pmmap span
 
-        timingOut 2e8 $ join $
+        timingOut (cfg_timeout_seconds cfg * seconds) $ join $
           case runTactic ctx jdg $ tac $ mkVarOcc $ T.unpack var_name of
             Left _ -> Left TacticErrors
             Right rtr ->
@@ -118,6 +119,12 @@ tacticCmd _ _ _ _ =
   pure $ Left $ mkErr InvalidRequest "Bad URI"
 
 
+------------------------------------------------------------------------------
+-- | The number of microseconds in a second
+seconds :: Num a => a
+seconds = 1e6
+
+
 timingOut
     :: Int  -- ^ Time in microseconds
     -> a    -- ^ Computation to run

plugins/hls-tactics-plugin/src/Wingman/Types.hs

@@ -77,6 +77,7 @@ tacticTitle = (mappend "Wingman: " .) . go
 data Config = Config
   { cfg_feature_set          :: FeatureSet
   , cfg_max_use_ctor_actions :: Int
+  , cfg_timeout_seconds      :: Int
   }
 
 ------------------------------------------------------------------------------

plugins/hls-tactics-plugin/test/golden/KnownCounterfactualSemigroup.hs.expected

@@ -3,6 +3,6 @@
 data Semi = Semi [String] Int
 
 instance Semigroup Int => Semigroup Semi where
-  (<>) (Semi l_l_c7 i8) (Semi l_l_c i)
-    = Semi ((<>) l_l_c7 l_l_c) ((<>) i8 i)
+  (<>) (Semi l_l_c5 i6) (Semi l_l_c i)
+    = Semi ((<>) l_l_c5 l_l_c) ((<>) i6 i)
 

plugins/hls-tactics-plugin/test/golden/KnownThetaSemigroup.hs.expected

@@ -1,5 +1,5 @@
 data Semi a = Semi a
 
 instance Semigroup a => Semigroup (Semi a) where
-  (<>) (Semi a6) (Semi a) = Semi ((<>) a6 a)
+  (<>) (Semi a4) (Semi a) = Semi ((<>) a4 a)