From 87fa910b7cfa0390e4918277e03c75dafd167bfc Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Sat, 13 Mar 2021 13:26:05 -0800 Subject: [PATCH 1/2] Use ConLikes instead of DataCons --- .../hls-tactics-plugin/src/Wingman/CodeGen.hs | 59 +++++++++++-------- .../src/Wingman/CodeGen/Utils.hs | 28 +++++---- plugins/hls-tactics-plugin/src/Wingman/GHC.hs | 7 ++- .../src/Wingman/Judgements.hs | 27 ++++----- .../src/Wingman/KnownStrategies/QuickCheck.hs | 3 +- .../src/Wingman/LanguageServer.hs | 20 +++---- .../src/Wingman/Machinery.hs | 2 +- .../hls-tactics-plugin/src/Wingman/Tactics.hs | 17 ++++-- .../hls-tactics-plugin/src/Wingman/Types.hs | 6 +- .../test/CodeAction/AutoSpec.hs | 1 + .../test/CodeAction/DestructSpec.hs | 1 + .../test/golden/AutoPatSynUse.hs | 8 +++ .../test/golden/AutoPatSynUse.hs.expected | 8 +++ .../test/golden/LayoutSplitPatSyn.hs | 10 ++++ .../test/golden/LayoutSplitPatSyn.hs.expected | 11 ++++ 15 files changed, 138 insertions(+), 70 deletions(-) create mode 100644 plugins/hls-tactics-plugin/test/golden/AutoPatSynUse.hs create mode 100644 plugins/hls-tactics-plugin/test/golden/AutoPatSynUse.hs.expected create mode 100644 plugins/hls-tactics-plugin/test/golden/LayoutSplitPatSyn.hs create mode 100644 plugins/hls-tactics-plugin/test/golden/LayoutSplitPatSyn.hs.expected diff --git a/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs b/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs index dac32fb2ed..69fb4b6443 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs @@ -9,6 +9,8 @@ module Wingman.CodeGen ) where +import PatSyn +import ConLike import Control.Lens ((%~), (<>~), (&)) import Control.Monad.Except import Control.Monad.State @@ -36,7 +38,7 @@ import Wingman.Types destructMatches - :: (DataCon -> Judgement -> Rule) + :: (ConLike -> Judgement -> Rule) -- ^ How to construct each match -> Maybe OccName -- ^ Scrutinee @@ -54,47 +56,49 @@ destructMatches f scrut t jdg = do case dcs of [] -> throwError $ GoalMismatch "destruct" g _ -> fmap unzipTrace $ for dcs $ \dc -> do - let ev = mapMaybe mkEvidence $ dataConInstArgTys dc apps + let con = RealDataCon dc + ev = mapMaybe mkEvidence $ dataConInstArgTys dc apps -- We explicitly do not need to add the method hypothesis to -- #syn_scoped method_hy = foldMap evidenceToHypothesis ev - args = dataConInstOrigArgTys' dc apps + args = conLikeInstOrigArgTys' con apps modify $ appEndo $ foldMap (Endo . evidenceToSubst) ev subst <- gets ts_unifier names <- mkManyGoodNames (hyNamesInScope hy) args - let hy' = patternHypothesis scrut dc jdg + let hy' = patternHypothesis scrut con jdg $ zip names $ coerce args j = fmap (CType . substTyAddInScope subst . unCType) $ introduce hy' $ introduce method_hy $ withNewGoal g jdg - ext <- f dc j + ext <- f con j pure $ ext & #syn_trace %~ rose ("match " <> show dc <> " {" <> intercalate ", " (fmap show names) <> "}") . pure & #syn_scoped <>~ hy' - & #syn_val %~ match [mkDestructPat dc names] . unLoc + & #syn_val %~ match [mkDestructPat con names] . unLoc ------------------------------------------------------------------------------ -- | Produces a pattern for a data con and the names of its fields. -mkDestructPat :: DataCon -> [OccName] -> Pat GhcPs -mkDestructPat dcon names - | isTupleDataCon dcon = +mkDestructPat :: ConLike -> [OccName] -> Pat GhcPs +mkDestructPat con names + | RealDataCon dcon <- con + , isTupleDataCon dcon = tuple pat_args | otherwise = - infixifyPatIfNecessary dcon $ + infixifyPatIfNecessary con $ conP - (coerceName $ dataConName dcon) + (coerceName $ conLikeName con) pat_args where pat_args = fmap bvar' names -infixifyPatIfNecessary :: DataCon -> Pat GhcPs -> Pat GhcPs +infixifyPatIfNecessary :: ConLike -> Pat GhcPs -> Pat GhcPs infixifyPatIfNecessary dcon x - | dataConIsInfix dcon = + | conLikeIsInfix dcon = case x of ConPatIn op (PrefixCon [lhs, rhs]) -> ConPatIn op $ InfixCon lhs rhs @@ -113,8 +117,8 @@ unzipTrace = sequenceA -- -- NOTE: The behaviour depends on GHC's 'dataConInstOrigArgTys'. -- We need some tweaks if the compiler changes the implementation. -dataConInstOrigArgTys' - :: DataCon +conLikeInstOrigArgTys' + :: ConLike -- ^ 'DataCon'structor -> [Type] -- ^ /Universally/ quantified type arguments to a result type. @@ -123,21 +127,30 @@ dataConInstOrigArgTys' -- For example, for @MkMyGADT :: b -> MyGADT a c@, we -- must pass @[a, c]@ as this argument but not @b@, as @b@ is an existential. -> [Type] - -- ^ Types of arguments to the DataCon with returned type is instantiated with the second argument. -dataConInstOrigArgTys' con uniTys = - let exvars = dataConExTys con - in dataConInstOrigArgTys con $ + -- ^ Types of arguments to the ConLike with returned type is instantiated with the second argument. +conLikeInstOrigArgTys' con uniTys = + let exvars = conLikeExTys con + in conLikeInstOrigArgTys con $ uniTys ++ fmap mkTyVarTy exvars -- Rationale: At least in GHC <= 8.10, 'dataConInstOrigArgTys' -- unifies the second argument with DataCon's universals followed by existentials. -- If the definition of 'dataConInstOrigArgTys' changes, -- this place must be changed accordingly. + +conLikeExTys :: ConLike -> [TyCoVar] +conLikeExTys (RealDataCon d) = dataConExTys d +conLikeExTys (PatSynCon p) = patSynExTys p + +patSynExTys :: PatSyn -> [TyCoVar] +patSynExTys ps = patSynExTyVars ps + + ------------------------------------------------------------------------------ -- | Combinator for performing case splitting, and running sub-rules on the -- resulting matches. -destruct' :: (DataCon -> Judgement -> Rule) -> HyInfo CType -> Judgement -> Rule +destruct' :: (ConLike -> Judgement -> Rule) -> HyInfo CType -> Judgement -> Rule destruct' f hi jdg = do when (isDestructBlacklisted jdg) $ throwError NoApplicableTactic let term = hi_name hi @@ -156,7 +169,7 @@ destruct' f hi jdg = do ------------------------------------------------------------------------------ -- | Combinator for performign case splitting, and running sub-rules on the -- resulting matches. -destructLambdaCase' :: (DataCon -> Judgement -> Rule) -> Judgement -> Rule +destructLambdaCase' :: (ConLike -> Judgement -> Rule) -> Judgement -> Rule destructLambdaCase' f jdg = do when (isDestructBlacklisted jdg) $ throwError NoApplicableTactic let g = jGoal jdg @@ -171,11 +184,11 @@ destructLambdaCase' f jdg = do -- | Construct a data con with subgoals for each field. buildDataCon :: Judgement - -> DataCon -- ^ The data con to build + -> ConLike -- ^ The data con to build -> [Type] -- ^ Type arguments for the data con -> RuleM (Synthesized (LHsExpr GhcPs)) buildDataCon jdg dc tyapps = do - let args = dataConInstOrigArgTys' dc tyapps + let args = conLikeInstOrigArgTys' dc tyapps ext <- fmap unzipTrace $ traverse ( \(arg, n) -> diff --git a/plugins/hls-tactics-plugin/src/Wingman/CodeGen/Utils.hs b/plugins/hls-tactics-plugin/src/Wingman/CodeGen/Utils.hs index 3e2db09729..22237904b9 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/CodeGen/Utils.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/CodeGen/Utils.hs @@ -1,5 +1,6 @@ module Wingman.CodeGen.Utils where +import ConLike (ConLike(RealDataCon), conLikeName) import Data.List import DataCon import Development.IDE.GHC.Compat @@ -13,25 +14,32 @@ import Wingman.GHC (getRecordFields) ------------------------------------------------------------------------------ -- | Make a data constructor with the given arguments. -mkCon :: DataCon -> [Type] -> [LHsExpr GhcPs] -> LHsExpr GhcPs -mkCon dcon apps (fmap unLoc -> args) - | dcon == nilDataCon +mkCon :: ConLike -> [Type] -> [LHsExpr GhcPs] -> LHsExpr GhcPs +mkCon con apps (fmap unLoc -> args) + | RealDataCon dcon <- con + , dcon == nilDataCon , [ty] <- apps , ty `eqType` charTy = noLoc $ string "" - | isTupleDataCon dcon = + + | RealDataCon dcon <- con + , isTupleDataCon dcon = noLoc $ tuple args - | dataConIsInfix dcon + + | RealDataCon dcon <- con + , dataConIsInfix dcon , (lhs : rhs : args') <- args = - noLoc $ foldl' (@@) (op lhs (coerceName dcon_name) rhs) args' - | Just fields <- getRecordFields dcon + noLoc $ foldl' (@@) (op lhs (coerceName con_name) rhs) args' + + | Just fields <- getRecordFields con , length fields >= 2 = -- record notation is unnatural on single field ctors - noLoc $ recordConE (coerceName dcon_name) $ do + noLoc $ recordConE (coerceName con_name) $ do (arg, (field, _)) <- zip args fields pure (coerceName field, arg) + | otherwise = - noLoc $ foldl' (@@) (bvar' $ occName dcon_name) args + noLoc $ foldl' (@@) (bvar' $ occName con_name) args where - dcon_name = dataConName dcon + con_name = conLikeName con coerceName :: HasOccName a => a -> RdrNameStr diff --git a/plugins/hls-tactics-plugin/src/Wingman/GHC.hs b/plugins/hls-tactics-plugin/src/Wingman/GHC.hs index d4105f3555..75b0d080ec 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/GHC.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/GHC.hs @@ -24,6 +24,7 @@ import TysWiredIn (charTyCon, doubleTyCon, floatTyCon, intTyCon) import Unique import Var import Wingman.Types +import ConLike tcTyVar_maybe :: Type -> Maybe Var @@ -106,12 +107,12 @@ freshTyvars t = do ------------------------------------------------------------------------------ -- | Given a datacon, extract its record fields' names and types. Returns -- nothing if the datacon is not a record. -getRecordFields :: DataCon -> Maybe [(OccName, CType)] +getRecordFields :: ConLike -> Maybe [(OccName, CType)] getRecordFields dc = - case dataConFieldLabels dc of + case conLikeFieldLabels dc of [] -> Nothing lbls -> for lbls $ \lbl -> do - (_, ty) <- dataConFieldType_maybe dc $ flLabel lbl + let ty = conLikeFieldType dc $ flLabel lbl pure (mkVarOccFS $ flLabel lbl, CType ty) diff --git a/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs b/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs index 26d6bf4b23..ed1122d4ae 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs @@ -1,17 +1,17 @@ module Wingman.Judgements where +import ConLike (ConLike) import Control.Arrow -import Control.Lens hiding (Context) +import Control.Lens hiding (Context) import Data.Bool import Data.Char import Data.Coerce -import Data.Generics.Product (field) -import Data.Map (Map) -import qualified Data.Map as M +import Data.Generics.Product (field) +import Data.Map (Map) +import qualified Data.Map as M import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as S -import DataCon (DataCon) +import Data.Set (Set) +import qualified Data.Set as S import Development.IDE.Spans.LocalBindings import OccName import SrcLoc @@ -163,7 +163,7 @@ findPositionVal jdg defn pos = listToMaybe $ do ------------------------------------------------------------------------------ -- | Helper function for determining the ancestry list for -- 'filterSameTypeFromOtherPositions'. -findDconPositionVals :: Judgement' a -> DataCon -> Int -> [OccName] +findDconPositionVals :: Judgement' a -> ConLike -> Int -> [OccName] findDconPositionVals jdg dcon pos = do (name, hi) <- M.toList $ hyByName $ jHypothesis jdg case hi_provenance hi of @@ -178,7 +178,7 @@ findDconPositionVals jdg dcon pos = do -- given position for the datacon. Used to ensure recursive functions like -- 'fmap' preserve the relative ordering of their arguments by eliminating any -- other term which might match. -filterSameTypeFromOtherPositions :: DataCon -> Int -> Judgement -> Judgement +filterSameTypeFromOtherPositions :: ConLike -> Int -> Judgement -> Judgement filterSameTypeFromOtherPositions dcon pos jdg = let hy = hyByName . jHypothesis @@ -230,7 +230,7 @@ extremelyStupid__definingFunction = patternHypothesis :: Maybe OccName - -> DataCon + -> ConLike -> Judgement' a -> [(OccName, a)] -> Hypothesis a @@ -369,13 +369,6 @@ isTopLevel TopLevelArgPrv{} = True isTopLevel _ = False ------------------------------------------------------------------------------- --- | Was this term defined by the user? -isUserProv :: Provenance -> Bool -isUserProv UserPrv{} = True -isUserProv _ = False - - ------------------------------------------------------------------------------ -- | Is this a local function argument, pattern match or user val? isLocalHypothesis :: Provenance -> Bool diff --git a/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies/QuickCheck.hs b/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies/QuickCheck.hs index 50eb2d791e..c2383c0fbf 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies/QuickCheck.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies/QuickCheck.hs @@ -1,5 +1,6 @@ module Wingman.KnownStrategies.QuickCheck where +import ConLike (ConLike(RealDataCon)) import Control.Monad.Except (MonadError (throwError)) import Data.Bool (bool) import Data.Generics (everything, mkQ) @@ -76,7 +77,7 @@ data Generator = Generator mkGenerator :: TyCon -> [Type] -> DataCon -> Generator mkGenerator tc apps dc = do let dc_expr = var' $ occName $ dataConName dc - args = dataConInstOrigArgTys' dc apps + args = conLikeInstOrigArgTys' (RealDataCon dc) apps num_recursive_calls = sum $ fmap (bool 0 1 . doesTypeContain tc) args mkArbitrary = mkArbitraryCall tc num_recursive_calls Generator num_recursive_calls $ case args of diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index d8f19c689e..a7724570c5 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -31,7 +31,7 @@ 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 (mkAppTys, tupleDataCon, consDataCon, substTyAddInScope) +import GhcPlugins (tupleDataCon, consDataCon, substTyAddInScope) import Ide.Plugin.Config (PluginConfig (plcConfig)) import qualified Ide.Plugin.Config as Plugin import Language.LSP.Server (MonadLsp, sendNotification) @@ -236,7 +236,7 @@ buildPatHy prov (fromPatCompatTc -> p0) = -- Desugar lists into cons ListPat _ [] -> pure mempty ListPat x@(ListPatTc ty _) (p : ps) -> - mkDerivedConHypothesis prov consDataCon [ty] + mkDerivedConHypothesis prov (RealDataCon consDataCon) [ty] [ (0, p) , (1, toPatCompatTc $ ListPat x ps) ] @@ -244,17 +244,17 @@ buildPatHy prov (fromPatCompatTc -> p0) = TuplePat tys pats boxity -> mkDerivedConHypothesis prov - (tupleDataCon boxity $ length pats) + (RealDataCon $ tupleDataCon boxity $ length pats) tys $ zip [0.. ] pats - ConPatOut (L _ (RealDataCon dc)) args _ _ _ f _ -> + ConPatOut (L _ con) args _ _ _ f _ -> case f of PrefixCon l_pgt -> - mkDerivedConHypothesis prov dc args $ zip [0..] l_pgt + mkDerivedConHypothesis prov con args $ zip [0..] l_pgt InfixCon pgt pgt5 -> - mkDerivedConHypothesis prov dc args $ zip [0..] [pgt, pgt5] + mkDerivedConHypothesis prov con args $ zip [0..] [pgt, pgt5] RecCon r -> - mkDerivedRecordHypothesis prov dc args r + mkDerivedRecordHypothesis prov con args r #if __GLASGOW_HASKELL__ >= 808 SigPat _ p _ -> buildPatHy prov p #endif @@ -268,7 +268,7 @@ buildPatHy prov (fromPatCompatTc -> p0) = -- | Like 'mkDerivedConHypothesis', but for record patterns. mkDerivedRecordHypothesis :: Provenance - -> DataCon -- ^ Destructing constructor + -> ConLike -- ^ Destructing constructor -> [Type] -- ^ Applied type variables -> HsRecFields GhcTc (PatCompat GhcTc) -> State Int (Hypothesis CType) @@ -300,7 +300,7 @@ mkFakeVar = do -- build a sub-hypothesis for the pattern match. mkDerivedConHypothesis :: Provenance - -> DataCon -- ^ Destructing constructor + -> ConLike -- ^ Destructing constructor -> [Type] -- ^ Applied type variables -> [(Int, PatCompat GhcTc)] -- ^ Patterns, and their order in the data con -> State Int (Hypothesis CType) @@ -324,7 +324,7 @@ mkDerivedConHypothesis prov dc args ps = do -- way to get the real one. It's probably OK though, since we're generating -- this term with a disallowed provenance, and it doesn't actually exist -- anyway. - $ mkAppTys (dataConUserType dc) args + $ conLikeResTy dc args ------------------------------------------------------------------------------ diff --git a/plugins/hls-tactics-plugin/src/Wingman/Machinery.hs b/plugins/hls-tactics-plugin/src/Wingman/Machinery.hs index 49054e7ad3..6dd9d18ff6 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Machinery.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Machinery.hs @@ -166,7 +166,7 @@ scoreSolution ext goal holes initial_scope = hyByName $ jEntireHypothesis goal intro_vals = M.keysSet $ hyByName $ syn_scoped ext used_vals = S.intersection intro_vals $ syn_used_vals ext - used_user_vals = filter (isUserProv . hi_provenance) + used_user_vals = filter (isLocalHypothesis . hi_provenance) $ mapMaybe (flip M.lookup initial_scope) $ S.toList $ syn_used_vals ext diff --git a/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs b/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs index 7b1b88f571..858b24aa59 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs @@ -3,6 +3,7 @@ module Wingman.Tactics , runTactic ) where +import ConLike (ConLike(RealDataCon)) import Control.Applicative (Alternative(empty)) import Control.Lens ((&), (%~), (<>~)) import Control.Monad (unless) @@ -231,12 +232,12 @@ requireNewHoles m = do ------------------------------------------------------------------------------ --- | Attempt to instantiate the given data constructor to solve the goal. +-- | Attempt to instantiate the given ConLike to solve the goal. -- --- INVARIANT: Assumes the give datacon is appropriate to construct the type +-- INVARIANT: Assumes the given ConLike is appropriate to construct the type -- with. -splitDataCon :: DataCon -> TacticsM () -splitDataCon dc = +splitConLike :: ConLike -> TacticsM () +splitConLike dc = requireConcreteHole $ tracing ("splitDataCon:" <> show dc) $ rule $ \jdg -> do let g = jGoal jdg case splitTyConApp_maybe $ unCType g of @@ -244,6 +245,14 @@ splitDataCon dc = buildDataCon (unwhitelistingSplit jdg) dc apps Nothing -> throwError $ GoalMismatch "splitDataCon" g +------------------------------------------------------------------------------ +-- | Attempt to instantiate the given data constructor to solve the goal. +-- +-- INVARIANT: Assumes the given datacon is appropriate to construct the type +-- with. +splitDataCon :: DataCon -> TacticsM () +splitDataCon = splitConLike . RealDataCon + ------------------------------------------------------------------------------ -- | Perform a case split on each top-level argument. Used to implement the diff --git a/plugins/hls-tactics-plugin/src/Wingman/Types.hs b/plugins/hls-tactics-plugin/src/Wingman/Types.hs index 63bf13b175..2f28f8d3d0 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Types.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Types.hs @@ -14,6 +14,7 @@ module Wingman.Types , Range ) where +import ConLike (ConLike) import Control.Lens hiding (Context, (.=)) import Control.Monad.Reader import Control.Monad.State @@ -149,6 +150,9 @@ instance Show (LHsSigType GhcPs) where instance Show TyCon where show = unsafeRender +instance Show ConLike where + show = unsafeRender + ------------------------------------------------------------------------------ -- | The state that should be shared between subgoals. Extracts move towards @@ -237,7 +241,7 @@ data PatVal = PatVal , pv_ancestry :: Set OccName -- ^ The set of values which had to be destructed to discover this term. -- Always contains the scrutinee. - , pv_datacon :: Uniquely DataCon + , pv_datacon :: Uniquely ConLike -- ^ The datacon which introduced this term. , pv_position :: Int -- ^ The position of this binding in the datacon's arguments. diff --git a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs index b9edee25a1..84cd06a507 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs @@ -48,6 +48,7 @@ spec = do autoTest 4 19 "FmapJoinInLet.hs" autoTest 9 12 "AutoEndo.hs" autoTest 2 16 "AutoEmptyString.hs" + autoTest 7 35 "AutoPatSynUse.hs" failing "flaky in CI" $ autoTest 2 11 "GoldenApplicativeThen.hs" diff --git a/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs index e5c6636b3a..7d3b33ef2f 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs @@ -33,4 +33,5 @@ spec = do destructTest "a" 4 7 "LayoutSplitIn.hs" destructTest "a" 4 31 "LayoutSplitViewPat.hs" destructTest "a" 7 17 "LayoutSplitPattern.hs" + destructTest "a" 8 26 "LayoutSplitPatSyn.hs" diff --git a/plugins/hls-tactics-plugin/test/golden/AutoPatSynUse.hs b/plugins/hls-tactics-plugin/test/golden/AutoPatSynUse.hs new file mode 100644 index 0000000000..25a44666e7 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/AutoPatSynUse.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PatternSynonyms #-} + +pattern JustSingleton :: a -> Maybe [a] +pattern JustSingleton a <- Just [a] + +amIASingleton :: Maybe [a] -> Maybe a +amIASingleton (JustSingleton a) = _ + diff --git a/plugins/hls-tactics-plugin/test/golden/AutoPatSynUse.hs.expected b/plugins/hls-tactics-plugin/test/golden/AutoPatSynUse.hs.expected new file mode 100644 index 0000000000..8addba654f --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/AutoPatSynUse.hs.expected @@ -0,0 +1,8 @@ +{-# LANGUAGE PatternSynonyms #-} + +pattern JustSingleton :: a -> Maybe [a] +pattern JustSingleton a <- Just [a] + +amIASingleton :: Maybe [a] -> Maybe a +amIASingleton (JustSingleton a) = Just a + diff --git a/plugins/hls-tactics-plugin/test/golden/LayoutSplitPatSyn.hs b/plugins/hls-tactics-plugin/test/golden/LayoutSplitPatSyn.hs new file mode 100644 index 0000000000..0497bb7244 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/LayoutSplitPatSyn.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PatternSynonyms #-} + +pattern JustSingleton :: a -> Maybe [a] +pattern JustSingleton a <- Just [a] + + +test :: Maybe [Bool] -> Maybe Bool +test (JustSingleton a) = _ + + diff --git a/plugins/hls-tactics-plugin/test/golden/LayoutSplitPatSyn.hs.expected b/plugins/hls-tactics-plugin/test/golden/LayoutSplitPatSyn.hs.expected new file mode 100644 index 0000000000..550b8f9296 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/LayoutSplitPatSyn.hs.expected @@ -0,0 +1,11 @@ +{-# LANGUAGE PatternSynonyms #-} + +pattern JustSingleton :: a -> Maybe [a] +pattern JustSingleton a <- Just [a] + + +test :: Maybe [Bool] -> Maybe Bool +test (JustSingleton False) = _ +test (JustSingleton True) = _ + + From a6272fc60751d7b56220293f9d155d9dd4f17df1 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Sat, 13 Mar 2021 13:28:55 -0800 Subject: [PATCH 2/2] Cleanup some imports --- plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs | 2 +- plugins/hls-tactics-plugin/src/Wingman/GHC.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs b/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs index 69fb4b6443..91a000ff05 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs @@ -9,7 +9,6 @@ module Wingman.CodeGen ) where -import PatSyn import ConLike import Control.Lens ((%~), (<>~), (&)) import Control.Monad.Except @@ -27,6 +26,7 @@ import GHC.SourceGen.Binds import GHC.SourceGen.Expr import GHC.SourceGen.Overloaded import GHC.SourceGen.Pat +import PatSyn import Type hiding (Var) import Wingman.CodeGen.Utils import Wingman.GHC diff --git a/plugins/hls-tactics-plugin/src/Wingman/GHC.hs b/plugins/hls-tactics-plugin/src/Wingman/GHC.hs index 75b0d080ec..eeead45836 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/GHC.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/GHC.hs @@ -3,6 +3,7 @@ module Wingman.GHC where +import ConLike import Control.Monad.State import Data.Function (on) import Data.Functor ((<&>)) @@ -24,7 +25,6 @@ import TysWiredIn (charTyCon, doubleTyCon, floatTyCon, intTyCon) import Unique import Var import Wingman.Types -import ConLike tcTyVar_maybe :: Type -> Maybe Var