diff --git a/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs b/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs index 3d9d89896d..de2ef33911 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs +++ b/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" ] diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index 57ecb60904..fb084d0351 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/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. diff --git a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs index b376176816..a0bda1a865 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs +++ b/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 diff --git a/plugins/hls-tactics-plugin/src/Wingman/Types.hs b/plugins/hls-tactics-plugin/src/Wingman/Types.hs index 3077e6d1b3..bb38c15d3a 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Types.hs +++ b/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 } ------------------------------------------------------------------------------ diff --git a/plugins/hls-tactics-plugin/test/golden/KnownCounterfactualSemigroup.hs.expected b/plugins/hls-tactics-plugin/test/golden/KnownCounterfactualSemigroup.hs.expected index beb49829f1..6ad86685f6 100644 --- a/plugins/hls-tactics-plugin/test/golden/KnownCounterfactualSemigroup.hs.expected +++ b/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) diff --git a/plugins/hls-tactics-plugin/test/golden/KnownThetaSemigroup.hs.expected b/plugins/hls-tactics-plugin/test/golden/KnownThetaSemigroup.hs.expected index 9ed929c47c..0d63d0f95f 100644 --- a/plugins/hls-tactics-plugin/test/golden/KnownThetaSemigroup.hs.expected +++ b/plugins/hls-tactics-plugin/test/golden/KnownThetaSemigroup.hs.expected @@ -1,5 +1,5 @@ data Semi a = Semi a instance Semigroup a => Semigroup (Semi a) where - (<>) (Semi a6) (Semi a) = Semi ((<>) a6 a) + (<>) (Semi a4) (Semi a) = Semi ((<>) a4 a)