diff options
24 files changed, 453 insertions, 37 deletions
diff --git a/compiler/GHC/Driver/Plugins.hs b/compiler/GHC/Driver/Plugins.hs index 42cefd17fd..83d41a6695 100644 --- a/compiler/GHC/Driver/Plugins.hs +++ b/compiler/GHC/Driver/Plugins.hs @@ -35,6 +35,10 @@ module GHC.Driver.Plugins ( -- - access to loaded interface files with 'interfaceLoadAction' -- , keepRenamedSource + -- ** Defaulting plugins + -- | Defaulting plugins can add candidate types to the defaulting + -- mechanism. + , DefaultingPlugin -- ** Hole fit plugins -- | hole fit plugins allow plugins to change the behavior of valid hole -- fit suggestions @@ -94,6 +98,9 @@ data Plugin = Plugin { , tcPlugin :: TcPlugin -- ^ An optional typechecker plugin, which may modify the -- behaviour of the constraint solver. + , defaultingPlugin :: DefaultingPlugin + -- ^ An optional defaulting plugin, which may specify the + -- additional type-defaulting rules. , holeFitPlugin :: HoleFitPlugin -- ^ An optional plugin to handle hole fits, which may re-order -- or change the list of valid hole fits and refinement hole fits. @@ -195,6 +202,7 @@ instance Monoid PluginRecompile where type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] type TcPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.TcPlugin +type DefaultingPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.DefaultingPlugin type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile @@ -213,6 +221,7 @@ defaultPlugin :: Plugin defaultPlugin = Plugin { installCoreToDos = const return , tcPlugin = const Nothing + , defaultingPlugin = const Nothing , holeFitPlugin = const Nothing , driverPlugin = const return , pluginRecompile = impurePlugin diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index e420bd1c23..f474c3383d 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -3151,19 +3151,26 @@ discardMsg = text "(Some bindings suppressed;" <+> text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)" ----------------------- -warnDefaulting :: [Ct] -> Type -> TcM () -warnDefaulting wanteds default_ty +warnDefaulting :: TcTyVar -> [Ct] -> Type -> TcM () +warnDefaulting the_tv wanteds default_ty = do { warn_default <- woptM Opt_WarnTypeDefaults ; env0 <- tcInitTidyEnv ; let tidy_env = tidyFreeTyCoVars env0 $ tyCoVarsOfCtsList (listToBag wanteds) tidy_wanteds = map (tidyCt tidy_env) wanteds + tidy_tv = lookupVarEnv (snd tidy_env) the_tv (loc, ppr_wanteds) = pprWithArising tidy_wanteds warn_msg = - hang (hsep [ text "Defaulting the following" - , text "constraint" <> plural tidy_wanteds - , text "to type" - , quotes (ppr default_ty) ]) + hang (hsep $ [ text "Defaulting" ] + ++ + (case tidy_tv of + Nothing -> [] + Just tv -> [text "the type variable" + , quotes (ppr tv)]) + ++ + [ text "to type" + , quotes (ppr default_ty) + , text "in the following constraint" <> plural tidy_wanteds ]) 2 ppr_wanteds ; let diag = TcRnUnknownMessage $ diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 578adf730a..0cf68fcb35 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -204,7 +204,9 @@ tcRnModule hsc_env mod_sum save_rn_syntax (text "Renamer/typechecker"<+>brackets (ppr this_mod)) (const ()) $ initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $ - withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $ + withTcPlugins hsc_env $ + withDefaultingPlugins hsc_env $ + withHoleFitPlugins hsc_env $ tcRnModuleTcRnM hsc_env mod_sum parsedModule pair @@ -2033,7 +2035,8 @@ runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a) -- Initialise the tcg_inst_env with instances from all home modules. -- This mimics the more selective call to hptInstances in tcRnImports runTcInteractive hsc_env thing_inside - = initTcInteractive hsc_env $ withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $ + = initTcInteractive hsc_env $ withTcPlugins hsc_env $ + withDefaultingPlugins hsc_env $ withHoleFitPlugins hsc_env $ do { traceTc "setInteractiveContext" $ vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt)) , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts) @@ -3086,12 +3089,12 @@ Type Checker Plugins withTcPlugins :: HscEnv -> TcM a -> TcM a withTcPlugins hsc_env m = - case getTcPlugins hsc_env of + case catMaybes $ mapPlugins hsc_env tcPlugin of [] -> m -- Common fast case plugins -> do ev_binds_var <- newTcEvBinds (solvers, rewriters, stops) <- - unzip3 `fmap` mapM (startPlugin ev_binds_var) plugins + unzip3 `fmap` mapM (start_plugin ev_binds_var) plugins let rewritersUniqFM :: UniqFM TyCon [TcPluginRewriter] !rewritersUniqFM = sequenceUFMList rewriters @@ -3105,19 +3108,33 @@ withTcPlugins hsc_env m = Left _ -> failM Right res -> return res where - startPlugin ev_binds_var (TcPlugin start solve rewrite stop) = + start_plugin ev_binds_var (TcPlugin start solve rewrite stop) = do s <- runTcPluginM start return (solve s ev_binds_var, rewrite s, stop s) -getTcPlugins :: HscEnv -> [GHC.Tc.Utils.Monad.TcPlugin] -getTcPlugins hsc_env = catMaybes $ mapPlugins hsc_env (\p args -> tcPlugin p args) - +withDefaultingPlugins :: HscEnv -> TcM a -> TcM a +withDefaultingPlugins hsc_env m = + do case catMaybes $ mapPlugins hsc_env defaultingPlugin of + [] -> m -- Common fast case + plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins + -- This ensures that dePluginStop is called even if a type + -- error occurs during compilation + eitherRes <- tryM $ do + updGblEnv (\e -> e { tcg_defaulting_plugins = plugins }) m + mapM_ runTcPluginM stops + case eitherRes of + Left _ -> failM + Right res -> return res + where + start_plugin (DefaultingPlugin start fill stop) = + do s <- runTcPluginM start + return (fill s, stop s) withHoleFitPlugins :: HscEnv -> TcM a -> TcM a withHoleFitPlugins hsc_env m = - case getHfPlugins hsc_env of + case catMaybes $ mapPlugins hsc_env holeFitPlugin of [] -> m -- Common fast case - plugins -> do (plugins,stops) <- unzip `fmap` mapM startPlugin plugins + plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins -- This ensures that hfPluginStop is called even if a type -- error occurs during compilation. eitherRes <- tryM $ @@ -3127,14 +3144,10 @@ withHoleFitPlugins hsc_env m = Left _ -> failM Right res -> return res where - startPlugin (HoleFitPluginR init plugin stop) = + start_plugin (HoleFitPluginR init plugin stop) = do ref <- init return (plugin ref, stop ref) -getHfPlugins :: HscEnv -> [HoleFitPluginR] -getHfPlugins hsc_env = - catMaybes $ mapPlugins hsc_env (\p args -> holeFitPlugin p args) - runRenamerPlugin :: TcGblEnv -> HsGroup GhcRn diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs index 276c0b284b..74a53ff348 100644 --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -2592,6 +2592,17 @@ applyDefaultingRules wanteds = do { info@(default_tys, _) <- getDefaultInfo ; wanteds <- TcS.zonkWC wanteds + ; tcg_env <- TcS.getGblEnv + ; let plugins = tcg_defaulting_plugins tcg_env + + ; plugin_defaulted <- if null plugins then return [] else + do { + ; traceTcS "defaultingPlugins {" (ppr wanteds) + ; defaultedGroups <- mapM (run_defaulting_plugin wanteds) plugins + ; traceTcS "defaultingPlugins }" (ppr defaultedGroups) + ; return defaultedGroups + } + ; let groups = findDefaultableGroups info wanteds ; traceTcS "applyDefaultingRules {" $ @@ -2603,7 +2614,20 @@ applyDefaultingRules wanteds ; traceTcS "applyDefaultingRules }" (ppr something_happeneds) - ; return (or something_happeneds) } + ; return $ or something_happeneds || or plugin_defaulted } + where run_defaulting_plugin wanteds p = + do { groups <- runTcPluginTcS (p wanteds) + ; defaultedGroups <- + filterM (\g -> disambigGroup + (deProposalCandidates g) + (deProposalTyVar g, deProposalCts g)) + groups + ; traceTcS "defaultingPlugin " $ ppr defaultedGroups + ; case defaultedGroups of + [] -> return False + _ -> return True + } + findDefaultableGroups :: ( [Type] @@ -2665,8 +2689,7 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds ------------------------------ disambigGroup :: [Type] -- The default types - -> (TcTyVar, [Ct]) -- All classes of the form (C a) - -- sharing same type variable + -> (TcTyVar, [Ct]) -- All constraints sharing same type variable -> TcS Bool -- True <=> something happened, reflected in ty_binds disambigGroup [] _ @@ -2680,7 +2703,7 @@ disambigGroup (default_ty:default_tys) group@(the_tv, wanteds) ; if success then -- Success: record the type variable binding, and return do { unifyTyVar the_tv default_ty - ; wrapWarnTcS $ warnDefaulting wanteds default_ty + ; wrapWarnTcS $ warnDefaulting the_tv wanteds default_ty ; traceTcS "disambigGroup succeeded }" (ppr default_ty) ; return True } else @@ -2694,7 +2717,8 @@ disambigGroup (default_ty:default_tys) group@(the_tv, wanteds) = do { lcl_env <- TcS.getLclEnv ; tc_lvl <- TcS.getTcLevel ; let loc = mkGivenLoc tc_lvl UnkSkol lcl_env - ; wanted_evs <- mapM (newWantedEvVarNC loc . substTy subst . ctPred) + -- Equality constraints are possible due to type defaulting plugins + ; wanted_evs <- mapM (newWantedNC loc . substTy subst . ctPred) wanteds ; fmap isEmptyWC $ solveSimpleWanteds $ listToBag $ diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index 39ff861153..d3c4b44211 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -82,6 +82,10 @@ module GHC.Tc.Types( TcPluginSolver, TcPluginRewriter, TcPluginM(runTcPluginM), unsafeTcPluginTcM, + -- Defaulting plugin + DefaultingPlugin(..), DefaultingProposal(..), + FillDefaulting, DefaultingPluginResult, + -- Role annotations RoleAnnotEnv, emptyRoleAnnotEnv, mkRoleAnnotEnv, lookupRoleAnnot, getRoleAnnots, @@ -621,6 +625,9 @@ data TcGblEnv -- ^ A collection of all the user-defined type-checking plugins for rewriting -- type family applications, collated by their type family 'TyCon's. + tcg_defaulting_plugins :: [FillDefaulting], + -- ^ A list of user-defined plugins for type defaulting plugins. + tcg_hf_plugins :: [HoleFitPlugin], -- ^ A list of user-defined plugins for hole fit suggestions. @@ -1767,6 +1774,36 @@ data TcPluginRewriteResult , tcRewriterNewWanteds :: [Ct] } +-- | A collection of candidate default types for a type variable. +data DefaultingProposal + = DefaultingProposal + { deProposalTyVar :: TcTyVar + -- ^ The type variable to default. + , deProposalCandidates :: [Type] + -- ^ Candidate types to default the type variable to. + , deProposalCts :: [Ct] + -- ^ The constraints against which defaults are checked. + } + +instance Outputable DefaultingProposal where + ppr p = text "DefaultingProposal" + <+> ppr (deProposalTyVar p) + <+> ppr (deProposalCandidates p) + <+> ppr (deProposalCts p) + +type DefaultingPluginResult = [DefaultingProposal] +type FillDefaulting = WantedConstraints -> TcPluginM DefaultingPluginResult + +-- | A plugin for controlling defaulting. +data DefaultingPlugin = forall s. DefaultingPlugin + { dePluginInit :: TcPluginM s + -- ^ Initialize plugin, when entering type-checker. + , dePluginRun :: s -> FillDefaulting + -- ^ Default some types + , dePluginStop :: s -> TcPluginM () + -- ^ Clean up after the plugin, when exiting the type-checker. + } + {- ********************************************************************* * * Role annotations diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 1c5e79013d..6b876d3121 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -351,6 +351,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_dependent_files = dependent_files_var, tcg_tc_plugin_solvers = [], tcg_tc_plugin_rewriters = emptyUFM, + tcg_defaulting_plugins = [], tcg_hf_plugins = [], tcg_top_loc = loc, tcg_static_wc = static_wc_var, diff --git a/docs/users_guide/9.4.1-notes.rst b/docs/users_guide/9.4.1-notes.rst index aae0c065d7..ce70b8e98d 100644 --- a/docs/users_guide/9.4.1-notes.rst +++ b/docs/users_guide/9.4.1-notes.rst @@ -9,6 +9,11 @@ Compiler - New :ghc-flag:`-Wredundant-strictness-flags` that checks for strictness flags (``!``) applied to unlifted types, which are always strict. +- A new type of plugin: defaulting plugins. These plugins can propose + defaults for ambiguous variables that would otherwise cause errors + just like the built-in defaulting mechanism. + + ``base`` library ~~~~~~~~~~~~~~~~ diff --git a/docs/users_guide/extending_ghc.rst b/docs/users_guide/extending_ghc.rst index 309fa6c912..ef9b584f04 100644 --- a/docs/users_guide/extending_ghc.rst +++ b/docs/users_guide/extending_ghc.rst @@ -1275,6 +1275,64 @@ The output is as follows: | ^^^^^^^^^^^^^ +.. _defaulting-plugins: + +Defaulting plugins +~~~~~~~~~~~~~~~~~~ + +Defaulting plugins are called when ambiguous variables might otherwise cause +errors, in the same way as the built-in defaulting mechanism. + +A defaulting plugin can propose potential ways to fill an ambiguous variable +according to whatever criteria you would like. GHC will verify that those +proposals will not lead to type errors in a context that you declare. + +Defaulting plugins have a single access point in the `GHC.Tc.Types` module + +:: + + -- | A collection of candidate default types for a type variable. + data DefaultingProposal + = DefaultingProposal + { deProposalTyVar :: TcTyVar + -- ^ The type variable to default. + , deProposalCandidates :: [Type] + -- ^ Candidate types to default the type variable to. + , deProposalCts :: [Ct] + -- ^ The constraints against which defaults are checked. + } + + type DefaultingPluginResult = [DefaultingProposal] + type FillDefaulting = WantedConstraints -> TcPluginM DefaultingPluginResult + + -- | A plugin for controlling defaulting. + data DefaultingPlugin = forall s. DefaultingPlugin + { dePluginInit :: TcPluginM s + -- ^ Initialize plugin, when entering type-checker. + , dePluginRun :: s -> FillDefaulting + -- ^ Default some types + , dePluginStop :: s -> TcPluginM () + -- ^ Clean up after the plugin, when exiting the type-checker. + } + + +The plugin gets a combination of wanted constraints which can be most easily +broken down into simple wanted constraints with ``approximateWC``. The result of +running the plugin should be a ``DefaultingPluginResult``, a list of types that +should be attempted for a given type variable that is ambiguous in a given +context. GHC will check if one of the proposals is acceptable in the given +context and then default to it. The most robust context to provide is the list +of all wanted constraints that mention the variable you are defaulting. If you +leave out a constraint, the default will be accepted, and then potentially +result in a type checker error if it is incompatible with one of the constraints +you left out. This can be a useful way of forcing a default and reporting errors +to the user. + +There is an example of defaulting lifted types in the GHC test suite. In the +`testsuite/tests/plugins/` directory see `defaulting-plugin/` for the +implementation, `test-defaulting-plugin.hs` for an example of when defaulting +happens, and `test-defaulting-plugin-fail.hs` for an example of when defaults +don't fit and aren't applied. .. _plugin_recompilation: diff --git a/testsuite/tests/ghc-api/apirecomp001/apirecomp001.stderr b/testsuite/tests/ghc-api/apirecomp001/apirecomp001.stderr index 2487a3da5b..b8fcd66a02 100644 --- a/testsuite/tests/ghc-api/apirecomp001/apirecomp001.stderr +++ b/testsuite/tests/ghc-api/apirecomp001/apirecomp001.stderr @@ -4,7 +4,7 @@ B.hs:4:1: warning: [-Wmissing-signatures (in -Wall)] answer_to_live_the_universe_and_everything :: Int B.hs:5:13: warning: [-Wtype-defaults (in -Wall)] - • Defaulting the following constraints to type ‘Integer’ + • Defaulting the type variable ‘a0’ to type ‘Integer’ in the following constraints (Num a0) arising from the literal ‘1’ at B.hs:5:13 (Enum a0) arising from the arithmetic sequence ‘1 .. 23 * 2’ at B.hs:5:12-20 @@ -20,7 +20,7 @@ B.hs:4:1: warning: [-Wmissing-signatures (in -Wall)] answer_to_live_the_universe_and_everything :: Int B.hs:5:13: warning: [-Wtype-defaults (in -Wall)] - • Defaulting the following constraints to type ‘Integer’ + • Defaulting the type variable ‘a0’ to type ‘Integer’ in the following constraints (Num a0) arising from the literal ‘1’ at B.hs:5:13 (Enum a0) arising from the arithmetic sequence ‘1 .. 23 * 2’ at B.hs:5:12-20 diff --git a/testsuite/tests/parser/should_compile/T2245.stderr b/testsuite/tests/parser/should_compile/T2245.stderr index ca38eec5ac..d5b8280494 100644 --- a/testsuite/tests/parser/should_compile/T2245.stderr +++ b/testsuite/tests/parser/should_compile/T2245.stderr @@ -12,7 +12,7 @@ T2245.hs:5:10: warning: [-Wmissing-methods (in -Wdefault)] • In the instance declaration for ‘Fractional T’ T2245.hs:7:27: warning: [-Wtype-defaults (in -Wall)] - • Defaulting the following constraints to type ‘T’ + • Defaulting the type variable ‘b0’ to type ‘T’ in the following constraints (Ord b0) arising from a use of ‘<’ at T2245.hs:7:27 (Fractional b0) arising from the literal ‘1e400’ at T2245.hs:7:29-33 diff --git a/testsuite/tests/parser/should_compile/T515.stderr b/testsuite/tests/parser/should_compile/T515.stderr index 580b8e722a..99ba2b24a5 100644 --- a/testsuite/tests/parser/should_compile/T515.stderr +++ b/testsuite/tests/parser/should_compile/T515.stderr @@ -3,7 +3,7 @@ T515.lhs:6:3: warning: [-Wmissing-signatures (in -Wall)] Top-level binding with no type signature: a :: Integer T515.lhs:6:7: warning: [-Wtype-defaults (in -Wall)] - • Defaulting the following constraint to type ‘Integer’ + • Defaulting the type variable ‘a0’ to type ‘Integer’ in the following constraint Num a0 arising from the literal ‘1’ • In the expression: 1 In an equation for ‘a’: a = 1 @@ -12,7 +12,7 @@ T515.lhs:7:3: warning: [-Wmissing-signatures (in -Wall)] Top-level binding with no type signature: b :: Integer T515.lhs:7:7: warning: [-Wtype-defaults (in -Wall)] - • Defaulting the following constraint to type ‘Integer’ + • Defaulting the type variable ‘a0’ to type ‘Integer’ in the following constraint Num a0 arising from the literal ‘2’ • In the expression: 2 In an equation for ‘b’: b = 2 diff --git a/testsuite/tests/plugins/Makefile b/testsuite/tests/plugins/Makefile index c00b26684b..6716aecbfb 100644 --- a/testsuite/tests/plugins/Makefile +++ b/testsuite/tests/plugins/Makefile @@ -163,3 +163,12 @@ T20218: T20218b: "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) T20218b.hs -package-db simple-plugin/pkg.T20218b/local.package.conf -fplugin Simple.ReplacePlugin -package simple-plugin -v0 ./T20218b + +.PHONY: test-defaulting-plugin +test-defaulting-plugin: + "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -v0 test-defaulting-plugin.hs -package-db defaulting-plugin/pkg.test-defaulting-plugin/local.package.conf + +.PHONY: test-defaulting-plugin-fail +test-defaulting-plugin-fail: + -"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -v0 test-defaulting-plugin-fail.hs -package-db defaulting-plugin/pkg.test-defaulting-plugin-fail/local.package.conf + diff --git a/testsuite/tests/plugins/all.T b/testsuite/tests/plugins/all.T index 0fc41ec039..2146a2aa43 100644 --- a/testsuite/tests/plugins/all.T +++ b/testsuite/tests/plugins/all.T @@ -241,6 +241,7 @@ test('plugin-recomp-change-2', ], makefile_test, []) + test('T20417', [extra_files(['plugin-recomp/', 'plugin-recomp-test.hs']), only_ways([config.ghc_plugin_way]), @@ -248,6 +249,7 @@ test('T20417', ], makefile_test, []) + test('T20218', [extra_files(['simple-plugin/']), only_ways([config.ghc_plugin_way]), pre_cmd('$MAKE -s --no-print-directory -C simple-plugin package.T20218 TOP={top}'), @@ -261,3 +263,15 @@ test('T20218b', pre_cmd('$MAKE -s --no-print-directory -C simple-plugin package.T20218b TOP={top}') ], makefile_test, []) + +test('test-defaulting-plugin', + [extra_files(['defaulting-plugin/']), + only_ways([config.ghc_plugin_way]), + pre_cmd('$MAKE -s --no-print-directory -C defaulting-plugin package.test-defaulting-plugin TOP={top}')], + makefile_test, []) + +test('test-defaulting-plugin-fail', + [extra_files(['defaulting-plugin/']), + only_ways([config.ghc_plugin_way]), + pre_cmd('$MAKE -s --no-print-directory -C defaulting-plugin package.test-defaulting-plugin-fail TOP={top}')], + makefile_test, []) diff --git a/testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs b/testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs new file mode 100644 index 0000000000..62071b9cfb --- /dev/null +++ b/testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE MultiParamTypeClasses, KindSignatures, FlexibleInstances, DataKinds, PatternSynonyms, StandaloneDeriving, GeneralizedNewtypeDeriving, PolyKinds #-} +{-# OPTIONS -Wno-orphans #-} +module DefaultLifted(DefaultType,plugin) where +import GHC.Plugins +import GHC.Tc.Types.Constraint +import GHC.Tc.Plugin +import GHC.Core.InstEnv +import GHC.Tc.Solver (approximateWC) +import GHC.Unit.Finder (findPluginModule) +import GHC.Driver.Config.Finder (initFinderOpts) +import Data.List +import GHC.Tc.Types +import qualified Data.Map as M +import Control.Monad (liftM2) +import GHC.Tc.Utils.TcType + +class DefaultType x (y :: x) + +instance Eq Type where + (==) = eqType +instance Ord Type where + compare = nonDetCmpType +instance Semigroup (TcPluginM [a]) where + (<>) = liftM2 (++) +instance Monoid (TcPluginM [a]) where + mempty = pure mempty + +plugin :: Plugin +plugin = defaultPlugin { + defaultingPlugin = install, + pluginRecompile = purePlugin + } + +install :: p -> Maybe GHC.Tc.Types.DefaultingPlugin +install _ = Just $ DefaultingPlugin { dePluginInit = initialize + , dePluginRun = run + , dePluginStop = stop + } + +pattern FoundModule :: Module -> FindResult +pattern FoundModule a <- Found _ a +fr_mod :: a -> a +fr_mod = id + +lookupModule :: ModuleName -- ^ Name of the module + -> TcPluginM Module +lookupModule mod_nm = do + hsc_env <- getTopEnv + let dflags = hsc_dflags hsc_env + let fopts = initFinderOpts dflags + let fc = hsc_FC hsc_env + let units = hsc_units hsc_env + let home_unit = hsc_home_unit hsc_env + -- found_module <- findPluginModule fc fopts units home_unit mod_name + found_module <- tcPluginIO $ findPluginModule fc fopts units home_unit mod_nm + case found_module of + FoundModule h -> return (fr_mod h) + _ -> do + found_module' <- findImportedModule mod_nm $ Just $ fsLit "this" + case found_module' of + FoundModule h -> return (fr_mod h) + _ -> panicDoc "Unable to resolve module looked up by plugin: " + (ppr mod_nm) + +data PluginState = PluginState { defaultClassName :: Name } + +-- | Find a 'Name' in a 'Module' given an 'OccName' +lookupName :: Module -> OccName -> TcPluginM Name +lookupName md occ = lookupOrig md occ + +solveDefaultType :: PluginState -> [Ct] -> TcPluginM DefaultingPluginResult +solveDefaultType _ [] = return [] +solveDefaultType state wanteds = do + envs <- getInstEnvs + insts <- classInstances envs <$> tcLookupClass (defaultClassName state) + let defaults = + foldl' (\m inst -> + case is_tys inst of + [matchty, replacety] -> M.insertWith (++) matchty [replacety] m + _ -> error "Unsupported defaulting type") + M.empty insts + let groups = + foldl' (\m wanted -> + foldl' (\m' var -> M.insertWith (++) var [wanted] m') + m + (filter (isVariableDefaultable defaults) $ tyCoVarsOfCtList wanted)) + M.empty wanteds + M.foldMapWithKey (\var cts -> + case M.lookup (tyVarKind var) defaults of + Nothing -> error "Bug, we already checked that this variable has a default" + Just deftys -> do + pure [DefaultingProposal var deftys cts]) + groups + where isVariableDefaultable defaults v = isAmbiguousTyVar v && M.member (tyVarKind v) defaults + +lookupDefaultTypes :: TcPluginM PluginState +lookupDefaultTypes = do + md <- lookupModule (mkModuleName "DefaultLifted") + name <- lookupName md (mkTcOcc "DefaultType") + pure $ PluginState { defaultClassName = name } + +initialize :: TcPluginM PluginState +initialize = do + lookupDefaultTypes + +run :: PluginState -> WantedConstraints -> TcPluginM DefaultingPluginResult +run s ws = do + solveDefaultType s (ctsElts $ approximateWC False ws) + +stop :: Monad m => p -> m () +stop _ = do + return () diff --git a/testsuite/tests/plugins/defaulting-plugin/Makefile b/testsuite/tests/plugins/defaulting-plugin/Makefile new file mode 100644 index 0000000000..7ce5b78e75 --- /dev/null +++ b/testsuite/tests/plugins/defaulting-plugin/Makefile @@ -0,0 +1,18 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +clean.%: + rm -rf pkg.$* + +HERE := $(abspath .) +$(eval $(call canonicalise,HERE)) + +package.%: + $(MAKE) -s --no-print-directory clean.$* + mkdir pkg.$* + "$(TEST_HC)" -outputdir pkg.$* --make -v0 -o pkg.$*/setup Setup.hs + "$(GHC_PKG)" init pkg.$*/local.package.conf + pkg.$*/setup configure --distdir pkg.$*/dist -v0 $(CABAL_PLUGIN_BUILD) --prefix="$(HERE)/pkg.$*/install" --with-compiler="$(TEST_HC)" $(if $(findstring YES,$(HAVE_PROFILING)), --enable-library-profiling) --with-hc-pkg="$(GHC_PKG)" --package-db=pkg.$*/local.package.conf + pkg.$*/setup build --distdir pkg.$*/dist -v0 + pkg.$*/setup install --distdir pkg.$*/dist -v0 diff --git a/testsuite/tests/plugins/defaulting-plugin/Setup.hs b/testsuite/tests/plugins/defaulting-plugin/Setup.hs new file mode 100644 index 0000000000..e8ef27dbba --- /dev/null +++ b/testsuite/tests/plugins/defaulting-plugin/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/testsuite/tests/plugins/defaulting-plugin/defaulting-plugin.cabal b/testsuite/tests/plugins/defaulting-plugin/defaulting-plugin.cabal new file mode 100644 index 0000000000..a8f69ab7a0 --- /dev/null +++ b/testsuite/tests/plugins/defaulting-plugin/defaulting-plugin.cabal @@ -0,0 +1,10 @@ +name: defaulting-plugin +cabal-version: >=1.24 +build-type: Simple +version: 0.1.0.0 + +library + default-language: Haskell2010 + build-depends: base, ghc, containers + exposed-modules: DefaultLifted + ghc-options: -Wall diff --git a/testsuite/tests/plugins/test-defaulting-plugin-fail.hs b/testsuite/tests/plugins/test-defaulting-plugin-fail.hs new file mode 100644 index 0000000000..c751f3f5c1 --- /dev/null +++ b/testsuite/tests/plugins/test-defaulting-plugin-fail.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE MultiParamTypeClasses, KindSignatures, FlexibleInstances, DataKinds, PolyKinds, RankNTypes, AllowAmbiguousTypes, TypeOperators, TypeFamilies, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fplugin DefaultLifted -fwarn-type-defaults #-} + +-- Tests defaulting plugins +module Main where +import GHC.TypeLits +import Data.Proxy +import DefaultLifted + +instance DefaultType Nat 4 +instance DefaultType Nat 2 +instance DefaultType Nat 0 + +q :: forall (a :: Nat). (KnownNat a) => Integer +q = natVal (Proxy :: Proxy a) + +w :: forall (a :: Nat). (KnownNat a, 2 <= a) => Integer +w = natVal (Proxy :: Proxy a) + +e :: forall (a :: Nat). (KnownNat a, 5 <= a) => Integer +e = natVal (Proxy :: Proxy a) + +main :: IO () +main = do + print $ q + w + e diff --git a/testsuite/tests/plugins/test-defaulting-plugin-fail.stderr b/testsuite/tests/plugins/test-defaulting-plugin-fail.stderr new file mode 100644 index 0000000000..c9843437b4 --- /dev/null +++ b/testsuite/tests/plugins/test-defaulting-plugin-fail.stderr @@ -0,0 +1,5 @@ +test-defaulting-plugin-fail.hs:25:19: + Cannot satisfy: 5 <= a0 + In the second argument of ‘(+)’, namely ‘e’ + In the second argument of ‘($)’, namely ‘q + w + e’ + In a stmt of a 'do' block: print $ q + w + e diff --git a/testsuite/tests/plugins/test-defaulting-plugin.hs b/testsuite/tests/plugins/test-defaulting-plugin.hs new file mode 100644 index 0000000000..fce4e96a8a --- /dev/null +++ b/testsuite/tests/plugins/test-defaulting-plugin.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE MultiParamTypeClasses, KindSignatures, FlexibleInstances, DataKinds, PolyKinds, RankNTypes, AllowAmbiguousTypes, TypeOperators, TypeFamilies, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fplugin DefaultLifted -fwarn-type-defaults #-} + +-- Tests defaulting plugins +module Main where +import GHC.TypeLits +import Data.Proxy +import DefaultLifted + +instance DefaultType Nat 4 +instance DefaultType Nat 2 +instance DefaultType Nat 0 + +class MyClass (a :: Nat) (b :: Nat) where + mc :: (KnownNat a, KnownNat b) => Proxy a -> Proxy b -> Integer + +instance MyClass a b where + mc a b = natVal a + natVal b + +q :: forall (a :: Nat). (KnownNat a) => Integer +q = natVal (Proxy :: Proxy a) + +w :: forall (a :: Nat). (KnownNat a, 2 <= a) => Integer +w = natVal (Proxy :: Proxy a) + +main :: IO () +main = do + print $ q + w + print $ mc Proxy Proxy diff --git a/testsuite/tests/plugins/test-defaulting-plugin.stderr b/testsuite/tests/plugins/test-defaulting-plugin.stderr new file mode 100644 index 0000000000..5108d5c805 --- /dev/null +++ b/testsuite/tests/plugins/test-defaulting-plugin.stderr @@ -0,0 +1,37 @@ + +test-defaulting-plugin.hs:28:11: warning: [-Wtype-defaults (in -Wall)] + Defaulting the type variable ‘a0’ to type ‘0’ in the following constraint + KnownNat a0 arising from a use of ‘q’ + In the first argument of ‘(+)’, namely ‘q’ + In the second argument of ‘($)’, namely ‘q + w’ + In a stmt of a 'do' block: print $ q + w + +test-defaulting-plugin.hs:28:15: warning: [-Wtype-defaults (in -Wall)] + Defaulting the type variable ‘a0’ to type ‘2’ in the following constraints + (KnownNat a0) + arising from a use of ‘w’ at test-defaulting-plugin.hs:28:15 + (GHC.TypeError.Assert + (Data.Type.Ord.OrdCond (CmpNat 2 a0) 'True 'True 'False) + (TypeError ...)) + arising from a use of ‘w’ at test-defaulting-plugin.hs:28:15 + In the second argument of ‘(+)’, namely ‘w’ + In the second argument of ‘($)’, namely ‘q + w’ + In a stmt of a 'do' block: print $ q + w + +test-defaulting-plugin.hs:29:11: warning: [-Wtype-defaults (in -Wall)] + Defaulting the type variable ‘b0’ to type ‘0’ in the following constraint + KnownNat b0 arising from a use of ‘mc’ + In the second argument of ‘($)’, namely ‘mc Proxy Proxy’ + In a stmt of a 'do' block: print $ mc Proxy Proxy + In the expression: + do print $ q + w + print $ mc Proxy Proxy + +test-defaulting-plugin.hs:29:11: warning: [-Wtype-defaults (in -Wall)] + Defaulting the type variable ‘a0’ to type ‘0’ in the following constraint + KnownNat a0 arising from a use of ‘mc’ + In the second argument of ‘($)’, namely ‘mc Proxy Proxy’ + In a stmt of a 'do' block: print $ mc Proxy Proxy + In the expression: + do print $ q + w + print $ mc Proxy Proxy diff --git a/testsuite/tests/typecheck/should_compile/T10971a.stderr b/testsuite/tests/typecheck/should_compile/T10971a.stderr index 800dc84efa..ff06f84bff 100644 --- a/testsuite/tests/typecheck/should_compile/T10971a.stderr +++ b/testsuite/tests/typecheck/should_compile/T10971a.stderr @@ -3,7 +3,7 @@ T10971a.hs:7:1: warning: [-Wmissing-signatures (in -Wall)] Top-level binding with no type signature: f :: [a] -> Int T10971a.hs:7:11: warning: [-Wtype-defaults (in -Wall)] - • Defaulting the following constraint to type ‘[]’ + • Defaulting the type variable ‘t0’ to type ‘[]’ in the following constraint Foldable t0 arising from a use of ‘length’ • In the expression: length x In the expression: \ x -> length x @@ -18,7 +18,7 @@ T10971a.hs:8:6: warning: [-Wname-shadowing (in -Wall)] defined at T10971a.hs:7:1 T10971a.hs:8:13: warning: [-Wtype-defaults (in -Wall)] - • Defaulting the following constraint to type ‘[]’ + • Defaulting the type variable ‘t0’ to type ‘[]’ in the following constraint Traversable t0 arising from a use of ‘fmapDefault’ • In the expression: fmapDefault f x In the expression: \ f x -> fmapDefault f x @@ -33,7 +33,7 @@ T10971a.hs:9:6: warning: [-Wname-shadowing (in -Wall)] defined at T10971a.hs:7:1 T10971a.hs:9:14: warning: [-Wtype-defaults (in -Wall)] - • Defaulting the following constraints to type ‘[]’ + • Defaulting the type variable ‘t0’ to type ‘[]’ in the following constraints (Traversable t0) arising from a use of ‘fmapDefault’ at T10971a.hs:9:14-24 (Foldable t0) arising from a use of ‘length’ at T10971a.hs:9:31-36 diff --git a/testsuite/tests/typecheck/should_fail/tcfail204.stderr b/testsuite/tests/typecheck/should_fail/tcfail204.stderr index a1ab99c445..8fb0f1efc5 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail204.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail204.stderr @@ -1,6 +1,6 @@ tcfail204.hs:10:7: error: [-Wtype-defaults (in -Wall), -Werror=type-defaults] - • Defaulting the following constraints to type ‘Double’ + • Defaulting the type variable ‘a0’ to type ‘Double’ in the following constraints (RealFrac a0) arising from a use of ‘ceiling’ at tcfail204.hs:10:7-13 (Fractional a0) diff --git a/testsuite/tests/warnings/should_compile/PluralS.stderr b/testsuite/tests/warnings/should_compile/PluralS.stderr index 0276c3a59d..d8a6f76957 100644 --- a/testsuite/tests/warnings/should_compile/PluralS.stderr +++ b/testsuite/tests/warnings/should_compile/PluralS.stderr @@ -1,13 +1,13 @@ PluralS.hs:15:17: warning: [-Wtype-defaults (in -Wall)] - • Defaulting the following constraint to type ‘Integer’ + • Defaulting the type variable ‘a0’ to type ‘Integer’ in the following constraint Num a0 arising from the literal ‘123’ • In the first argument of ‘seq’, namely ‘123’ In the expression: 123 `seq` () In an equation for ‘defaultingNum’: defaultingNum = 123 `seq` () PluralS.hs:17:24: warning: [-Wtype-defaults (in -Wall)] - • Defaulting the following constraints to type ‘Integer’ + • Defaulting the type variable ‘a0’ to type ‘Integer’ in the following constraints (Show a0) arising from a use of ‘show’ at PluralS.hs:17:24-27 (Num a0) arising from the literal ‘123’ at PluralS.hs:17:29-31 • In the expression: show 123 |