From 43b97cd282d03a15fd3634b0beba8cd5306256b0 Mon Sep 17 00:00:00 2001 From: WorldSEnder Date: Thu, 15 Oct 2020 15:05:05 +0200 Subject: [PATCH 1/3] implement #21 : splitting on datatypeOne code action per datatype constructor is produced.test cases for splittingdon't suggest constructors with hash by defaultsuggesting I# for Int probably is not what you want99% of the timealso reuse tyDataCons, tacnameuse 'algebraicTyCon' as filter for now --- plugins/tactics/src/Ide/Plugin/Tactic.hs | 47 ++++++++++++------- plugins/tactics/src/Ide/Plugin/Tactic/GHC.hs | 8 ++++ .../tactics/src/Ide/Plugin/Tactic/Tactics.hs | 23 +++++++-- .../src/Ide/Plugin/Tactic/TestTypes.hs | 2 + stack.yaml | 1 + test/functional/Tactic.hs | 23 +++++++++ test/testdata/tactic/GoldenSplitPair.hs | 2 + .../tactic/GoldenSplitPair.hs.expected | 2 + test/testdata/tactic/T2.hs | 12 +++++ test/testdata/tactic/T3.hs | 4 +- 10 files changed, 102 insertions(+), 22 deletions(-) create mode 100644 test/testdata/tactic/GoldenSplitPair.hs create mode 100644 test/testdata/tactic/GoldenSplitPair.hs.expected diff --git a/plugins/tactics/src/Ide/Plugin/Tactic.hs b/plugins/tactics/src/Ide/Plugin/Tactic.hs index 82b91d942b..b6bc18f318 100644 --- a/plugins/tactics/src/Ide/Plugin/Tactic.hs +++ b/plugins/tactics/src/Ide/Plugin/Tactic.hs @@ -25,6 +25,7 @@ import Data.Coerce import Data.Generics.Aliases (mkQ) import Data.Generics.Schemes (everything) import Data.List +import qualified Data.Foldable as F import qualified Data.Map as M import Data.Maybe import Data.Monoid @@ -101,6 +102,10 @@ commandProvider Auto = provide Auto "" commandProvider Intros = filterGoalType isFunction $ provide Intros "" +commandProvider Split = + filterGoalType (isJust . algebraicTyCon) $ + foldMapGoalType (F.fold . tyDataCons) $ \dc -> + provide Split $ T.pack $ occNameString $ getOccName dc commandProvider Destruct = filterBindingType destructFilter $ \occ _ -> provide Destruct $ T.pack $ occNameString occ @@ -119,11 +124,12 @@ commandProvider HomomorphismLambdaCase = ------------------------------------------------------------------------------ -- | A mapping from tactic commands to actual tactics for refinery. -commandTactic :: TacticCommand -> OccName -> TacticsM () +commandTactic :: TacticCommand -> String -> TacticsM () commandTactic Auto = const auto commandTactic Intros = const intros -commandTactic Destruct = destruct -commandTactic Homomorphism = homo +commandTactic Split = splitDataCon' . mkDataOcc +commandTactic Destruct = destruct . mkVarOcc +commandTactic Homomorphism = homo . mkVarOcc commandTactic DestructLambdaCase = const destructLambdaCase commandTactic HomomorphismLambdaCase = const homoLambdaCase @@ -194,6 +200,14 @@ requireExtension ext tp dflags plId uri range jdg = False -> pure [] +------------------------------------------------------------------------------ +-- | Create a 'TacticProvider' for each occurance of an 'a' in the foldable container +-- extracted from the goal type. Useful instantiations for 't' include 'Maybe' or '[]'. +foldMapGoalType :: Foldable t => (Type -> t a) -> (a -> TacticProvider) -> TacticProvider +foldMapGoalType f tpa dflags plId uri range jdg = + foldMap tpa (f $ unCType $ jGoal jdg) dflags plId uri range jdg + + ------------------------------------------------------------------------------ -- | Restrict a 'TacticProvider', making sure it appears only when the given -- predicate holds for the goal. @@ -280,7 +294,7 @@ judgementForHole state nfp range = do -tacticCmd :: (OccName -> TacticsM ()) -> CommandFunction TacticParams +tacticCmd :: (String -> TacticsM ()) -> CommandFunction TacticParams tacticCmd tac lf state (TacticParams uri range var_name) | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = fromMaybeT (Right Null, Nothing) $ do @@ -289,19 +303,18 @@ tacticCmd tac lf state (TacticParams uri range var_name) pm <- MaybeT $ useAnnotatedSource "tacticsCmd" state nfp x <- lift $ timeout 2e8 $ case runTactic ctx jdg - $ tac - $ mkVarOcc - $ T.unpack var_name of - Left err -> - pure $ (, Nothing) - $ Left - $ ResponseError InvalidRequest (T.pack $ show err) Nothing - Right (_, ext) -> do - let g = graft (RealSrcSpan span) ext - response = transform dflags (clientCapabilities lf) uri g pm - pure $ case response of - Right res -> (Right Null , Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams res)) - Left err -> (Left $ ResponseError InternalError (T.pack err) Nothing, Nothing) + $ tac + $ T.unpack var_name of + Left err -> + pure $ (, Nothing) + $ Left + $ ResponseError InvalidRequest (T.pack $ show err) Nothing + Right (_, ext) -> do + let g = graft (RealSrcSpan span) ext + response = transform dflags (clientCapabilities lf) uri g pm + pure $ case response of + Right res -> (Right Null , Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams res)) + Left err -> (Left $ ResponseError InternalError (T.pack err) Nothing, Nothing) pure $ case x of Just y -> y Nothing -> (, Nothing) diff --git a/plugins/tactics/src/Ide/Plugin/Tactic/GHC.hs b/plugins/tactics/src/Ide/Plugin/Tactic/GHC.hs index 7f89e4c0c9..2f24fe7f81 100644 --- a/plugins/tactics/src/Ide/Plugin/Tactic/GHC.hs +++ b/plugins/tactics/src/Ide/Plugin/Tactic/GHC.hs @@ -7,6 +7,7 @@ module Ide.Plugin.Tactic.GHC where import Data.Maybe (isJust) import Development.IDE.GHC.Compat import OccName +import DataCon import TcType import TyCoRep import Type @@ -106,3 +107,10 @@ getPatName (fromPatCompat -> p0) = #endif _ -> Nothing +------------------------------------------------------------------------------ +-- | What data-constructor, if any, does the type have? +tyDataCons :: Type -> Maybe [DataCon] +tyDataCons g = do + (tc, _) <- splitTyConApp_maybe g + pure $ tyConDataCons tc + diff --git a/plugins/tactics/src/Ide/Plugin/Tactic/Tactics.hs b/plugins/tactics/src/Ide/Plugin/Tactic/Tactics.hs index 4fcccbb61b..0b13eef533 100644 --- a/plugins/tactics/src/Ide/Plugin/Tactic/Tactics.hs +++ b/plugins/tactics/src/Ide/Plugin/Tactic/Tactics.hs @@ -194,10 +194,9 @@ split :: TacticsM () split = tracing "split(user)" $ do jdg <- goal let g = jGoal jdg - case splitTyConApp_maybe $ unCType g of - Nothing -> throwError $ GoalMismatch "split" g - Just (tc, _) -> do - let dcs = tyConDataCons tc + case tyDataCons $ unCType g of + Nothing -> throwError $ GoalMismatch "split(user)" g + Just dcs -> do choice $ fmap splitDataCon dcs @@ -235,6 +234,22 @@ splitDataCon dc = tracing ("splitDataCon:" <> show dc) $ rule $ \jdg -> do Nothing -> throwError $ GoalMismatch "splitDataCon" g +------------------------------------------------------------------------------ +-- | Attempt to instantiate the named data constructor to solve the goal. +splitDataCon' :: OccName -> TacticsM () +splitDataCon' dcn = do + let tacname = "splitDataCon'(" ++ unsafeRender dcn ++ ")" + jdg <- goal + let g = jGoal jdg + case tyDataCons $ unCType g of + Nothing -> throwError $ GoalMismatch tacname g + Just dcs -> do + let mdc = find ((== dcn) . getOccName) dcs + case mdc of + Nothing -> throwError $ GoalMismatch tacname g + Just dc -> splitDataCon dc + + ------------------------------------------------------------------------------ -- | @matching f@ takes a function from a judgement to a @Tactic@, and -- then applies the resulting @Tactic@. diff --git a/plugins/tactics/src/Ide/Plugin/Tactic/TestTypes.hs b/plugins/tactics/src/Ide/Plugin/Tactic/TestTypes.hs index 2ea4b8d06c..431e71c4d1 100644 --- a/plugins/tactics/src/Ide/Plugin/Tactic/TestTypes.hs +++ b/plugins/tactics/src/Ide/Plugin/Tactic/TestTypes.hs @@ -11,6 +11,7 @@ import qualified Data.Text as T data TacticCommand = Auto | Intros + | Split | Destruct | Homomorphism | DestructLambdaCase @@ -21,6 +22,7 @@ data TacticCommand tacticTitle :: TacticCommand -> T.Text -> T.Text tacticTitle Auto _ = "Attempt to fill hole" tacticTitle Intros _ = "Introduce lambda" +tacticTitle Split cname = "Introduce constructor " <> cname tacticTitle Destruct var = "Case split on " <> var tacticTitle Homomorphism var = "Homomorphic case split on " <> var tacticTitle DestructLambdaCase _ = "Lambda case split" diff --git a/stack.yaml b/stack.yaml index 1a0b67c2b2..93a47a3472 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,6 +4,7 @@ packages: - . - ./ghcide/ - ./hls-plugin-api +- ./plugins/tactics ghc-options: "$everything": -haddock diff --git a/test/functional/Tactic.hs b/test/functional/Tactic.hs index 97ef227056..f33225fede 100644 --- a/test/functional/Tactic.hs +++ b/test/functional/Tactic.hs @@ -21,6 +21,7 @@ import Language.Haskell.LSP.Types (ApplyWorkspaceEditRequest, Position import Test.Hls.Util import Test.Tasty import Test.Tasty.HUnit +import Test.Tasty.ExpectedFailure (ignoreTestBecause) import System.FilePath import System.Directory (doesFileExist) import Control.Monad (unless) @@ -80,6 +81,27 @@ tests = testGroup "T3.hs" 7 13 [ (id, DestructLambdaCase, "") ] + , ignoreTestBecause "Not implemented, see isovector/haskell-language-server#31" $ mkTest + "Splits Int with I# when -XMagicHash is enabled" + "T3.hs" 10 14 + [ (id, Split, "I#") + ] + , mkTest + "Produces datatype split action for single-constructor types" + "T2.hs" 16 14 + [ (id, Split, "T") + ] + , mkTest + "Produces datatype split action for multiple constructors" + "T2.hs" 21 15 + [ (id, Split, "T21") + , (id, Split, "T22") + ] + , mkTest + "Doesn't suggest MagicHash constructors without -XMagicHash" + "T2.hs" 24 14 + [ (not, Split, "I#") + ] , mkTest "Doesn't suggest lambdacase without -XLambdaCase" "T2.hs" 11 25 @@ -101,6 +123,7 @@ tests = testGroup , goldenTest "GoldenGADTDestruct.hs" 7 17 Destruct "gadt" , goldenTest "GoldenGADTAuto.hs" 7 13 Auto "" , goldenTest "GoldenSwapMany.hs" 2 12 Auto "" + , goldenTest "GoldenSplitPair.hs" 2 11 Split "(,)" ] diff --git a/test/testdata/tactic/GoldenSplitPair.hs b/test/testdata/tactic/GoldenSplitPair.hs new file mode 100644 index 0000000000..826c7a6609 --- /dev/null +++ b/test/testdata/tactic/GoldenSplitPair.hs @@ -0,0 +1,2 @@ +thePair :: (Int, Int) +thePair = _ diff --git a/test/testdata/tactic/GoldenSplitPair.hs.expected b/test/testdata/tactic/GoldenSplitPair.hs.expected new file mode 100644 index 0000000000..7c6501413c --- /dev/null +++ b/test/testdata/tactic/GoldenSplitPair.hs.expected @@ -0,0 +1,2 @@ +thePair :: (Int, Int) +thePair = (_, _) diff --git a/test/testdata/tactic/T2.hs b/test/testdata/tactic/T2.hs index 20b1644a8f..c42d50d8da 100644 --- a/test/testdata/tactic/T2.hs +++ b/test/testdata/tactic/T2.hs @@ -10,3 +10,15 @@ foo = _ dontSuggestLambdaCase :: Either a b -> Int dontSuggestLambdaCase = _ +data T = T !(Int, Int) + +suggestCon :: T +suggestCon = _ + +data T2 = T21 Int | T22 Int Int + +suggestCons :: T2 +suggestCons = _ + +suggestInt :: Int +suggestInt = _ diff --git a/test/testdata/tactic/T3.hs b/test/testdata/tactic/T3.hs index 1bb42a9b02..f6f46a6aff 100644 --- a/test/testdata/tactic/T3.hs +++ b/test/testdata/tactic/T3.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase, MagicHash #-} suggestHomomorphicLC :: Either a b -> Either a b suggestHomomorphicLC = _ @@ -6,3 +6,5 @@ suggestHomomorphicLC = _ suggestLC :: Either a b -> Int suggestLC = _ +suggestInt :: Int +suggestInt = _ From f41f88f90f13a727b2554642b1e59f3ff2c1010b Mon Sep 17 00:00:00 2001 From: WorldSEnder Date: Tue, 20 Oct 2020 21:10:03 +0200 Subject: [PATCH 2/3] suggested circleci fix --- plugins/tactics/hls-tactics-plugin.cabal | 1 + .../tactics/src/Ide/Plugin/Tactic/Debug.hs | 25 ++++++++++++++++++- 2 files changed, 25 insertions(+), 1 deletion(-) diff --git a/plugins/tactics/hls-tactics-plugin.cabal b/plugins/tactics/hls-tactics-plugin.cabal index 9abb2b549d..9803d806b2 100644 --- a/plugins/tactics/hls-tactics-plugin.cabal +++ b/plugins/tactics/hls-tactics-plugin.cabal @@ -75,6 +75,7 @@ library , syb , text , transformers + , deepseq 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..6c528da4e3 100644 --- a/plugins/tactics/src/Ide/Plugin/Tactic/Debug.hs +++ b/plugins/tactics/src/Ide/Plugin/Tactic/Debug.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeApplications #-} + module Ide.Plugin.Tactic.Debug ( unsafeRender , unsafeRender' @@ -9,17 +13,36 @@ module Ide.Plugin.Tactic.Debug , traceMX ) where +import Control.DeepSeq +import Control.Exception import Debug.Trace import DynFlags (unsafeGlobalDynFlags) import Outputable hiding ((<>)) +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 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 @GHC_EXCEPTION $ evaluate $ deepseq z z + pure $ either (const "") id res +{-# NOINLINE unsafeRender' #-} traceMX :: (Monad m, Show a) => String -> a -> m () traceMX str a = traceM $ mappend ("!!!" <> str <> ": ") $ show a From dea8b5aa0903973c9fdc0b74ba23504784029b6f Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Tue, 20 Oct 2020 13:18:08 -0700 Subject: [PATCH 3/3] Add random delays --- test/functional/Tactic.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/test/functional/Tactic.hs b/test/functional/Tactic.hs index f33225fede..e2d1d2c84d 100644 --- a/test/functional/Tactic.hs +++ b/test/functional/Tactic.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumDecimals #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} @@ -25,6 +26,7 @@ import Test.Tasty.ExpectedFailure (ignoreTestBecause) import System.FilePath import System.Directory (doesFileExist) import Control.Monad (unless) +import Control.Concurrent (threadDelay) ------------------------------------------------------------------------------ @@ -157,6 +159,7 @@ goldenTest :: FilePath -> Int -> Int -> TacticCommand -> Text -> TestTree goldenTest input line col tc occ = testCase (input <> " (golden)") $ do runSession hlsCommand fullCaps tacticPath $ do + liftIO $ threadDelay (length input * 1e6) doc <- openDoc input "haskell" actions <- getCodeActions doc $ pointRange line col Just (CACodeAction (CodeAction {_command = Just c}))