diff options
| author | Ian Lynagh <igloo@earth.li> | 2012-04-26 19:45:11 +0100 |
|---|---|---|
| committer | Ian Lynagh <igloo@earth.li> | 2012-04-26 19:45:11 +0100 |
| commit | b643fe08b3c083fd23889ed9413a01928779a9e8 (patch) | |
| tree | 334f23b417c639ad9f2f11529617cc286f38f902 | |
| parent | 9f611ccc52afc979535a27e7e954caa9e0b9a5e7 (diff) | |
| parent | 5bfd8933024cb2120c38e01346b1b47d6dde10cb (diff) | |
| download | haskell-b643fe08b3c083fd23889ed9413a01928779a9e8.tar.gz | |
Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc
26 files changed, 602 insertions, 433 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 812a726d5b..060b63d46e 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -117,7 +117,7 @@ repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec])) repTopDs group = do { let { tv_bndrs = hsSigTvBinders (hs_valds group) ; bndrs = tv_bndrs ++ hsGroupBinders group } ; - ss <- pprTrace "reptop" (ppr bndrs $$ ppr tv_bndrs) $ mkGenSyms bndrs ; + ss <- mkGenSyms bndrs ; -- Bind all the names mainly to avoid repeated use of explicit strings. -- Thus we get diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index f140c8fb09..121b269d64 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -45,7 +45,7 @@ import Var import TcRnMonad import TcType import TcMType -import TcHsSyn ( mkZonkTcTyVar ) +import TcHsSyn ( zonkTcTypeToType, mkEmptyZonkEnv ) import TcUnify import TcEnv @@ -1131,7 +1131,7 @@ zonkTerm = foldTermM (TermFoldM zonkRttiType :: TcType -> TcM Type -- Zonk the type, replacing any unbound Meta tyvars -- by skolems, safely out of Meta-tyvar-land -zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta mkTyVarTy) +zonkRttiType = zonkTcTypeToType (mkEmptyZonkEnv zonk_unbound_meta) where zonk_unbound_meta tv = ASSERT( isTcTyVar tv ) diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index e798b7c479..aef9a325f9 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -63,7 +63,7 @@ import Control.Monad %************************************************************************ %* * - loadSrcInterface, loadOrphanModules, loadHomeInterface + loadSrcInterface, loadOrphanModules, loadInterfaceForName These three are called from TcM-land %* * diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 15e488bd09..92ee0f4a44 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -122,6 +122,11 @@ module GHC ( #endif lookupName, +#ifdef GHCI + -- ** EXPERIMENTAL + setGHCiMonad, +#endif + -- * Abstract syntax elements -- ** Packages @@ -1330,6 +1335,21 @@ isModuleTrusted :: GhcMonad m => Module -> m Bool isModuleTrusted m = withSession $ \hsc_env -> liftIO $ hscCheckSafe hsc_env m noSrcSpan +-- | EXPERIMENTAL: DO NOT USE. +-- +-- Set the monad GHCi lifts user statements into. +-- +-- Checks that a type (in string form) is an instance of the +-- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is, +-- throws an error otherwise. +{-# WARNING setGHCiMonad "This is experimental! Don't use." #-} +setGHCiMonad :: GhcMonad m => String -> m () +setGHCiMonad name = withSession $ \hsc_env -> do + ty <- liftIO $ hscIsGHCiMonad hsc_env name + modifySession $ \s -> + let ic = (hsc_IC s) { ic_monad = ty } + in s { hsc_IC = ic } + getHistorySpan :: GhcMonad m => History -> m SrcSpan getHistorySpan h = withSession $ \hsc_env -> return $ InteractiveEval.getHistorySpan hsc_env h diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 491814f0c5..b3f79605a1 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -62,6 +62,7 @@ module HscMain , hscTcRnGetInfo , hscCheckSafe #ifdef GHCI + , hscIsGHCiMonad , hscGetModuleInterface , hscRnImportDecls , hscTcRnLookupRdrName @@ -311,6 +312,11 @@ hscTcRnGetInfo hsc_env0 name = runInteractiveHsc hsc_env0 $ do ioMsgMaybe' $ tcRnGetInfo hsc_env name #ifdef GHCI +hscIsGHCiMonad :: HscEnv -> String -> IO Name +hscIsGHCiMonad hsc_env name = + let icntxt = hsc_IC hsc_env + in runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env icntxt name + hscGetModuleInterface :: HscEnv -> Module -> IO ModIface hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index e55d78e6fd..82712e2741 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -136,7 +136,7 @@ import Annotations import Class import TyCon import DataCon -import PrelNames ( gHC_PRIM ) +import PrelNames ( gHC_PRIM, ioTyConName ) import Packages hiding ( Version(..) ) import DynFlags import DriverPhases @@ -910,6 +910,9 @@ data InteractiveContext -- ^ The 'DynFlags' used to evaluate interative expressions -- and statements. + ic_monad :: Name, + -- ^ The monad that GHCi is executing in + ic_imports :: [InteractiveImport], -- ^ The GHCi context is extended with these imports -- @@ -973,6 +976,8 @@ hscDeclsWithLocation) and save them in ic_sys_vars. emptyInteractiveContext :: DynFlags -> InteractiveContext emptyInteractiveContext dflags = InteractiveContext { ic_dflags = dflags, + -- IO monad by default + ic_monad = ioTyConName, ic_imports = [], ic_rn_gbl_env = emptyGlobalRdrEnv, ic_tythings = [], diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 9b47edb169..7c01de1c40 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -306,6 +306,9 @@ basicKnownKeyNames , guardMName , liftMName , mzipName + + -- GHCi Sandbox + , ghciIoClassName, ghciStepIoMName ] genericTyConNames :: [Name] @@ -334,7 +337,7 @@ pRELUDE = mkBaseModule_ pRELUDE_NAME gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC, - gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_CSTRING, + gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING, gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, gHC_CONC, gHC_IO, gHC_IO_Exception, @@ -353,6 +356,7 @@ gHC_CLASSES = mkPrimModule (fsLit "GHC.Classes") gHC_BASE = mkBaseModule (fsLit "GHC.Base") gHC_ENUM = mkBaseModule (fsLit "GHC.Enum") +gHC_GHCI = mkBaseModule (fsLit "GHC.GHCi") gHC_SHOW = mkBaseModule (fsLit "GHC.Show") gHC_READ = mkBaseModule (fsLit "GHC.Read") gHC_NUM = mkBaseModule (fsLit "GHC.Num") @@ -971,6 +975,11 @@ datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey +-- GHCi things +ghciIoClassName, ghciStepIoMName :: Name +ghciIoClassName = clsQual gHC_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey +ghciStepIoMName = methName gHC_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey + -- IO things ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName, failIOName :: Name @@ -1179,6 +1188,9 @@ selectorClassKey = mkPreludeClassUnique 41 singIClassNameKey, typeNatLeqClassNameKey :: Unique singIClassNameKey = mkPreludeClassUnique 42 typeNatLeqClassNameKey = mkPreludeClassUnique 43 + +ghciIoClassKey :: Unique +ghciIoClassKey = mkPreludeClassUnique 44 \end{code} %************************************************************************ @@ -1647,6 +1659,10 @@ guardMIdKey = mkPreludeMiscIdUnique 194 liftMIdKey = mkPreludeMiscIdUnique 195 mzipIdKey = mkPreludeMiscIdUnique 196 +-- GHCi +ghciStepIoMClassOpKey :: Unique +ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197 + ---------------- Template Haskell ------------------- -- USES IdUniques 200-499 diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 2834a78ad5..9cb04ff47f 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -19,7 +19,7 @@ module RnEnv ( lookupTypeOccRn, lookupKindOccRn, lookupGlobalOccRn, lookupGlobalOccRn_maybe, - HsSigCtxt(..), lookupLocalDataTcNames, lookupSigOccRn, + HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, lookupFixityRn, lookupTyFixityRn, lookupInstDeclBndr, lookupSubBndrOcc, lookupFamInstName, @@ -238,7 +238,14 @@ lookupExactOcc name = return name | otherwise = do { env <- getGlobalRdrEnv - ; let gres = lookupGRE_Name env name + ; let -- See Note [Splicing Exact names] + main_occ = nameOccName name + demoted_occs = case demoteOccName main_occ of + Just occ -> [occ] + Nothing -> [] + gres = [ gre | occ <- main_occ : demoted_occs + , gre <- lookupGlobalRdrEnv env occ + , gre_name gre == name ] ; case gres of [] -> -- See Note [Splicing Exact names] do { lcl_env <- getLocalRdrEnv @@ -471,6 +478,19 @@ otherwise the type checker will get confused. To do this we need to keep track of all the Names in scope, and the LocalRdrEnv does just that; we consult it with RdrName.inLocalRdrEnvScope. +There is another wrinkle. With TH and -XDataKinds, consider + $( [d| data Nat = Zero + data T = MkT (Proxy 'Zero) |] ) +After splicing, but before renaming we get this: + data Nat_77{tc} = Zero_78{d} + data T_79{tc} = MkT_80{d} (Proxy 'Zero_78{tc}) |] ) +THe occurrence of 'Zero in the data type for T has the right unique, +but it has a TcClsName name-space in its OccName. (This is set by +the ctxt_ns argument of Convert.thRdrName.) When we check that is +in scope in the GlobalRdrEnv, we need to look up the DataName namespace +too. (An alternative would be to make the GlobalRdrEnv also have +a Name -> GRE mapping.) + Note [Usage for sub-bndrs] ~~~~~~~~~~~~~~~~~~~~~~~~~~ If you have this @@ -531,18 +551,23 @@ lookupTypeOccRn rdr_name = do { mb_name <- lookupOccRn_maybe rdr_name ; case mb_name of { Just name -> return name ; - Nothing -> - - do { -- Maybe it's the name of a *data* constructor - data_kinds <- xoptM Opt_DataKinds - ; mb_demoted_name <- case demoteRdrName rdr_name of - Just demoted_rdr -> lookupOccRn_maybe demoted_rdr - Nothing -> return Nothing + Nothing -> lookup_demoted rdr_name } } + +lookup_demoted :: RdrName -> RnM Name +lookup_demoted rdr_name + | Just demoted_rdr <- demoteRdrName rdr_name + -- Maybe it's the name of a *data* constructor + = do { data_kinds <- xoptM Opt_DataKinds + ; mb_demoted_name <- lookupOccRn_maybe demoted_rdr ; case mb_demoted_name of Nothing -> unboundName WL_Any rdr_name Just demoted_name | data_kinds -> return demoted_name - | otherwise -> unboundNameX WL_Any rdr_name suggest_dk }}} + | otherwise -> unboundNameX WL_Any rdr_name suggest_dk } + + | otherwise + = unboundName WL_Any rdr_name + where suggest_dk = ptext (sLit "A data constructor of that name is in scope; did you mean -XDataKinds?") \end{code} @@ -663,28 +688,111 @@ lookupGreRn_help rdr_name lookup ; return (Just gre) } gres -> do { addNameClashErrRn rdr_name gres ; return (Just (head gres)) } } +\end{code} + +%********************************************************* +%* * + Deprecations +%* * +%********************************************************* +Note [Handling of deprecations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* We report deprecations at each *occurrence* of the deprecated thing + (see Trac #5867) + +* We do not report deprectations for locally-definded names. For a + start, we may be exporting a deprecated thing. Also we may use a + deprecated thing in the defn of another deprecated things. We may + even use a deprecated thing in the defn of a non-deprecated thing, + when changing a module's interface. + +* addUsedRdrNames: we do not report deprecations for sub-binders: + - the ".." completion for records + - the ".." in an export item 'T(..)' + - the things exported by a module export 'module M' + +\begin{code} addUsedRdrName :: GlobalRdrElt -> RdrName -> RnM () -- Record usage of imported RdrNames addUsedRdrName gre rdr - | isLocalGRE gre = return () + | isLocalGRE gre = return () -- No call to warnIfDeprecated + -- See Note [Handling of deprecations] | otherwise = do { env <- getGblEnv - ; updMutVar (tcg_used_rdrnames env) + ; warnIfDeprecated gre + ; updMutVar (tcg_used_rdrnames env) (\s -> Set.insert rdr s) } addUsedRdrNames :: [RdrName] -> RnM () -- Record used sub-binders -- We don't check for imported-ness here, because it's inconvenient -- and not stritly necessary. +-- NB: no call to warnIfDeprecated; see Note [Handling of deprecations] addUsedRdrNames rdrs = do { env <- getGblEnv ; updMutVar (tcg_used_rdrnames env) (\s -> foldr Set.insert s rdrs) } ------------------------------- --- GHCi support ------------------------------- +warnIfDeprecated :: GlobalRdrElt -> RnM () +warnIfDeprecated gre@(GRE { gre_name = name, gre_prov = Imported (imp_spec : _) }) + = do { dflags <- getDynFlags + ; when (wopt Opt_WarnWarningsDeprecations dflags) $ + do { iface <- loadInterfaceForName doc name + ; case lookupImpDeprec iface gre of + Just txt -> addWarn (mk_msg txt) + Nothing -> return () } } + where + mk_msg txt = sep [ sep [ ptext (sLit "In the use of") + <+> pprNonVarNameSpace (occNameSpace (nameOccName name)) + <+> quotes (ppr name) + , parens imp_msg <> colon ] + , ppr txt ] + + name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name + imp_mod = importSpecModule imp_spec + imp_msg = ptext (sLit "imported from") <+> ppr imp_mod <> extra + extra | imp_mod == moduleName name_mod = empty + | otherwise = ptext (sLit ", but defined in") <+> ppr name_mod + + doc = ptext (sLit "The name") <+> quotes (ppr name) <+> ptext (sLit "is mentioned explicitly") + +warnIfDeprecated _ = return () -- No deprecations for things defined locally + +lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt +lookupImpDeprec iface gre + = mi_warn_fn iface (gre_name gre) `mplus` -- Bleat if the thing, + case gre_par gre of -- or its parent, is warn'd + ParentIs p -> mi_warn_fn iface p + NoParent -> Nothing +\end{code} + +Note [Used names with interface not loaded] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's (just) possible to to find a used +Name whose interface hasn't been loaded: + +a) It might be a WiredInName; in that case we may not load + its interface (although we could). + +b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger + These are seen as "used" by the renamer (if -XRebindableSyntax) + is on), but the typechecker may discard their uses + if in fact the in-scope fromRational is GHC.Read.fromRational, + (see tcPat.tcOverloadedLit), and the typechecker sees that the type + is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst). + In that obscure case it won't force the interface in. + +In both cases we simply don't permit deprecations; +this is, after all, wired-in stuff. + +%********************************************************* +%* * + GHCi support +%* * +%********************************************************* + +\begin{code} -- A qualified name on the command line can refer to any module at all: we -- try to load the interface if we don't already have it. lookupQualifiedName :: RdrName -> RnM (Maybe Name) @@ -819,30 +927,32 @@ lookupBindGroupOcc ctxt what rdr_name --------------- -lookupLocalDataTcNames :: NameSet -> SDoc -> RdrName -> RnM [Name] --- GHC extension: look up both the tycon and data con --- for con-like things. Used for top-level fixity signatures --- Complain if neither is in scope -lookupLocalDataTcNames bndr_set what rdr_name +lookupLocalTcNames :: NameSet -> SDoc -> RdrName -> RnM [Name] +-- GHC extension: look up both the tycon and data con or variable. +-- Used for top-level fixity signatures. Complain if neither is in scope. +-- See Note [Fixity signature lookup] +lookupLocalTcNames bndr_set what rdr_name | Just n <- isExact_maybe rdr_name -- Special case for (:), which doesn't get into the GlobalRdrEnv = do { n' <- lookupExactOcc n; return [n'] } -- For this we don't need to try the tycon too | otherwise - = do { mb_gres <- mapM (lookupBindGroupOcc (LocalBindCtxt bndr_set) what) - (dataTcOccs rdr_name) - ; let (errs, names) = splitEithers mb_gres - ; when (null names) (addErr (head errs)) -- Bleat about one only - ; return names } + = do { mb_gres <- mapM lookup (dataTcOccs rdr_name) + ; let (errs, names) = splitEithers mb_gres + ; when (null names) $ addErr (head errs) -- Bleat about one only + ; return names } + where + lookup = lookupBindGroupOcc (LocalBindCtxt bndr_set) what dataTcOccs :: RdrName -> [RdrName] --- If the input is a data constructor, return both it and a type --- constructor. This is useful when we aren't sure which we are --- looking at. +-- Return both the given name and the same name promoted to the TcClsName +-- namespace. This is useful when we aren't sure which we are looking at. dataTcOccs rdr_name - | isDataOcc occ = [rdr_name, rdr_name_tc] - | otherwise = [rdr_name] - where - occ = rdrNameOcc rdr_name + | isDataOcc occ || isVarOcc occ + = [rdr_name, rdr_name_tc] + | otherwise + = [rdr_name] + where + occ = rdrNameOcc rdr_name rdr_name_tc = setRdrNameSpace rdr_name tcName \end{code} @@ -853,6 +963,26 @@ dataTcOccs rdr_name %* * %********************************************************* +Note [Fixity signature lookup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A fixity declaration like + + infixr 2 ? + +can refer to a value-level operator, e.g.: + + (?) :: String -> String -> String + +or a type-level operator, like: + + data (?) a b = A a | B b + +so we extend the lookup of the reader name '?' to the TcClsName namespace, as +well as the original namespace. + +The extended lookup is also used in other places, like resolution of +deprecation declarations, and lookup of names in GHCi. + \begin{code} -------------------------------- type FastStringEnv a = UniqFM a -- Keyed by FastString diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 75f7ea2245..69284db86a 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -8,7 +8,7 @@ module RnNames ( rnImports, getLocalNonValBinders, rnExports, extendGlobalRdrEnvRn, gresFromAvails, - reportUnusedNames, finishWarnings, + reportUnusedNames, ) where #include "HsVersions.h" @@ -904,7 +904,11 @@ rnExports explicit_mod exports tcg_env@(TcGblEnv { tcg_mod = this_mod, tcg_rdr_env = rdr_env, tcg_imports = imports }) - = do { + = unsetWOptM Opt_WarnWarningsDeprecations $ + -- Do not report deprecations arising from the export + -- list, to avoid bleating about re-exporting a deprecated + -- thing (especially via 'module Foo' export item) + do { -- If the module header is omitted altogether, then behave -- as if the user had written "module Main(main) where..." -- EXCEPT in interactive mode, when we behave as if he had @@ -1175,96 +1179,6 @@ dupExport_ok n ie1 ie2 single _ = False \end{code} -%********************************************************* -%* * -\subsection{Deprecations} -%* * -%********************************************************* - -\begin{code} -finishWarnings :: DynFlags -> Maybe WarningTxt - -> TcGblEnv -> RnM TcGblEnv --- (a) Report usage of imports that are deprecated or have other warnings --- (b) If the whole module is warned about or deprecated, update tcg_warns --- All this happens only once per module -finishWarnings dflags mod_warn tcg_env - = do { (eps,hpt) <- getEpsAndHpt - ; ifWOptM Opt_WarnWarningsDeprecations $ - mapM_ (check hpt (eps_PIT eps)) all_gres - -- By this time, typechecking is complete, - -- so the PIT is fully populated - - -- Deal with a module deprecation; it overrides all existing warns - ; let new_warns = case mod_warn of - Just txt -> WarnAll txt - Nothing -> tcg_warns tcg_env - ; return (tcg_env { tcg_warns = new_warns }) } - where - used_names = allUses (tcg_dus tcg_env) - -- Report on all deprecated uses; hence allUses - all_gres = globalRdrEnvElts (tcg_rdr_env tcg_env) - - check hpt pit gre@(GRE {gre_name = name, gre_prov = Imported (imp_spec:_)}) - | name `elemNameSet` used_names - , Just deprec_txt <- lookupImpDeprec dflags hpt pit gre - = addWarnAt (importSpecLoc imp_spec) - (sep [ptext (sLit "In the use of") <+> - pprNonVarNameSpace (occNameSpace (nameOccName name)) <+> - quotes (ppr name), - (parens imp_msg) <> colon, - (ppr deprec_txt) ]) - where - name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name - imp_mod = importSpecModule imp_spec - imp_msg = ptext (sLit "imported from") <+> ppr imp_mod <> extra - extra | imp_mod == moduleName name_mod = empty - | otherwise = ptext (sLit ", but defined in") <+> ppr name_mod - - check _ _ _ = return () -- Local, or not used, or not deprectated - -- The Imported pattern-match: don't deprecate locally defined names - -- For a start, we may be exporting a deprecated thing - -- Also we may use a deprecated thing in the defn of another - -- deprecated things. We may even use a deprecated thing in - -- the defn of a non-deprecated thing, when changing a module's - -- interface - -lookupImpDeprec :: DynFlags -> HomePackageTable -> PackageIfaceTable - -> GlobalRdrElt -> Maybe WarningTxt --- The name is definitely imported, so look in HPT, PIT -lookupImpDeprec dflags hpt pit gre - = case lookupIfaceByModule dflags hpt pit mod of - Just iface -> mi_warn_fn iface name `mplus` -- Bleat if the thing, *or - case gre_par gre of - ParentIs p -> mi_warn_fn iface p -- its parent*, is warn'd - NoParent -> Nothing - - Nothing -> Nothing -- See Note [Used names with interface not loaded] - where - name = gre_name gre - mod = ASSERT2( isExternalName name, ppr name ) nameModule name -\end{code} - -Note [Used names with interface not loaded] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -By now all the interfaces should have been loaded, -because reportDeprecations happens after typechecking. -However, it's still (just) possible to to find a used -Name whose interface hasn't been loaded: - -a) It might be a WiredInName; in that case we may not load - its interface (although we could). - -b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger - These are seen as "used" by the renamer (if -XRebindableSyntax) - is on), but the typechecker may discard their uses - if in fact the in-scope fromRational is GHC.Read.fromRational, - (see tcPat.tcOverloadedLit), and the typechecker sees that the type - is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst). - In that obscure case it won't force the interface in. - -In both cases we simply don't permit deprecations; -this is, after all, wired-in stuff. - %********************************************************* %* * diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index ffd2910b45..8c338c810a 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -269,7 +269,7 @@ rnSrcFixityDecls bndr_set fix_decls rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity)) = setSrcSpan name_loc $ -- this lookup will fail if the definition isn't local - do names <- lookupLocalDataTcNames bndr_set what rdr_name + do names <- lookupLocalTcNames bndr_set what rdr_name return [ L loc (FixitySig (L name_loc name) fixity) | name <- names ] what = ptext (sLit "fixity signature") @@ -304,7 +304,7 @@ rnSrcWarnDecls bndr_set decls where rn_deprec (Warning rdr_name txt) -- ensures that the names are defined locally - = do { names <- lookupLocalDataTcNames bndr_set what rdr_name + = do { names <- lookupLocalTcNames bndr_set what rdr_name ; return [(nameOccName name, txt) | name <- names] } what = ptext (sLit "deprecation") diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs index 0601d7b7bf..c0c6478a7b 100644 --- a/compiler/simplCore/FloatIn.lhs +++ b/compiler/simplCore/FloatIn.lhs @@ -354,19 +354,27 @@ For @Case@, the possible ``drop points'' for the \tr{to_drop} bindings are: (a)~inside the scrutinee, (b)~inside one of the alternatives/default [default FVs always {\em first}!]. +Floating case expressions inward was added to fix Trac #5658: strict bindings +not floated in. In particular, this change allows array indexing operations, +which have a single DEFAULT alternative without any binders, to be floated +inward. SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed +scalars also need to be floated inward, but unpacks have a single non-DEFAULT +alternative that binds the elements of the tuple. We now therefore also support +floating in cases with a single alternative that may bind values. + \begin{code} -fiExpr to_drop (_, AnnCase scrut case_bndr _ [(DEFAULT,[],rhs)]) +fiExpr to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)]) | isUnLiftedType (idType case_bndr) , exprOkForSideEffects (deAnnotate scrut) = wrapFloats shared_binds $ fiExpr (case_float : rhs_binds) rhs where - case_float = FB (unitVarSet case_bndr) scrut_fvs - (FloatCase scrut' case_bndr DEFAULT []) + case_float = FB (mkVarSet (case_bndr : alt_bndrs)) scrut_fvs + (FloatCase scrut' case_bndr con alt_bndrs) scrut' = fiExpr scrut_binds scrut [shared_binds, scrut_binds, rhs_binds] = sepBindsByDropPoint False [freeVarsOf scrut, rhs_fvs] to_drop - rhs_fvs = freeVarsOf rhs `delVarSet` case_bndr + rhs_fvs = freeVarsOf rhs `delVarSetList` (case_bndr : alt_bndrs) scrut_fvs = freeVarsOf scrut fiExpr to_drop (_, AnnCase scrut case_bndr ty alts) diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index 9662faecae..c43450cb17 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -254,14 +254,15 @@ addLocalFamInst :: (FamInstEnv,[FamInst]) -> FamInst -> TcM (FamInstEnv, [FamIns addLocalFamInst (home_fie, my_fis) fam_inst -- home_fie includes home package and this module -- my_fies is just the ones from this module - = do { isGHCi <- getIsGHCi + = do { traceTc "addLocalFamInst" (ppr fam_inst) + ; isGHCi <- getIsGHCi -- In GHCi, we *override* any identical instances -- that are also defined in the interactive context - ; let (home_fie', my_fis') - | isGHCi = (deleteFromFamInstEnv home_fie fam_inst, - filterOut (identicalFamInst fam_inst) my_fis) - | otherwise = (home_fie, my_fis) + ; let (home_fie', my_fis') + | isGHCi = ( deleteFromFamInstEnv home_fie fam_inst + , filterOut (identicalFamInst fam_inst) my_fis) + | otherwise = (home_fie, my_fis) -- Load imported instances, so that we report -- overlaps correctly diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs index 9493669e55..c4a2c33ba1 100644 --- a/compiler/typecheck/TcGenGenerics.lhs +++ b/compiler/typecheck/TcGenGenerics.lhs @@ -263,18 +263,20 @@ tc_mkRepTyCon tycon metaDts mod = do { -- `rep0` = GHC.Generics.Rep (type family) rep0 <- tcLookupTyCon repTyConName + ; let -- `tyvars` = [a,b] + tyvars = tyConTyVars tycon + tyvar_args = mkTyVarTys tyvars + + -- `appT` = D a b + appT = [mkTyConApp tycon tyvar_args] + -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * - ; rep0Ty <- tc_mkRepTy tycon metaDts + ; rep0Ty <- tc_mkRepTy tycon tyvar_args metaDts -- `rep_name` is a name we generate for the synonym ; rep_name <- newGlobalBinder mod (mkGenR (nameOccName (tyConName tycon))) (nameSrcSpan (tyConName tycon)) - ; let -- `tyvars` = [a,b] - tyvars = tyConTyVars tycon - - -- `appT` = D a b - appT = [mkTyConApp tycon (mkTyVarTys tyvars)] ; return $ mkSynFamInst rep_name tyvars rep0 appT rep0Ty } @@ -284,13 +286,13 @@ tc_mkRepTyCon tycon metaDts mod = -- Type representation -------------------------------------------------------------------------------- -tc_mkRepTy :: -- The type to generate representation for - TyCon +tc_mkRepTy :: -- The type to generate representation for, and instantiating types + TyCon -> [Type] -- Metadata datatypes to refer to -> MetaTyCons -- Generated representation0 type -> TcM Type -tc_mkRepTy tycon metaDts = +tc_mkRepTy tycon ty_args metaDts = do d1 <- tcLookupTyCon d1TyConName c1 <- tcLookupTyCon c1TyConName @@ -308,7 +310,7 @@ tc_mkRepTy tycon metaDts = mkRec0 a = mkTyConApp rec0 [a] mkPar0 a = mkTyConApp par0 [a] mkD a = mkTyConApp d1 [metaDTyCon, sumP (tyConDataCons a)] - mkC i d a = mkTyConApp c1 [d, prod i (dataConOrigArgTys a) + mkC i d a = mkTyConApp c1 [d, prod i (dataConInstOrigArgTys a ty_args) (null (dataConFieldLabels a))] -- This field has no label mkS True _ a = mkTyConApp s1 [mkTyConTy nS1, a] diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 75dedd0622..a4af0ce7f3 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -26,9 +26,10 @@ module TcHsSyn ( -- re-exported from TcMonad TcId, TcIdSet, - zonkTopDecls, zonkTopExpr, zonkTopLExpr, mkZonkTcTyVar, - zonkId, zonkTopBndrs, - emptyZonkEnv, mkTyVarZonkEnv, zonkTcTypeToType, zonkTcTypeToTypes + zonkTopDecls, zonkTopExpr, zonkTopLExpr, + zonkTopBndrs, zonkTyBndrsX, + emptyZonkEnv, mkEmptyZonkEnv, mkTyVarZonkEnv, + zonkTcTypeToType, zonkTcTypeToTypes ) where #include "HsVersions.h" @@ -37,8 +38,9 @@ import HsSyn import Id import TcRnMonad import PrelNames +import TypeRep -- We can see the representation of types import TcType -import TcMType +import TcMType ( defaultKindVarToStar, zonkQuantifiedTyVar, writeMetaTyVar ) import TcEvidence import TysPrim import TysWiredIn @@ -161,14 +163,6 @@ hsOverLitName (HsIsString {}) = fromStringName %* * %************************************************************************ -\begin{code} --- zonkId is used *during* typechecking just to zonk the Id's type -zonkId :: TcId -> TcM TcId -zonkId id - = zonkTcType (idType id) `thenM` \ ty' -> - returnM (Id.setIdType id ty') -\end{code} - The rest of the zonking is done *after* typechecking. The main zonking pass runs over the bindings @@ -195,7 +189,7 @@ data ZonkEnv = ZonkEnv UnboundTyVarZonker (TyVarEnv TyVar) -- - (IdEnv Var) -- What variables are in scope + (IdEnv Var) -- What variables are in scope -- Maps an Id or EvVar to its zonked version; both have the same Name -- Note that all evidence (coercion variables as well as dictionaries) -- are kept in the ZonkEnv @@ -207,7 +201,10 @@ instance Outputable ZonkEnv where emptyZonkEnv :: ZonkEnv -emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv emptyVarEnv +emptyZonkEnv = mkEmptyZonkEnv zonkTypeZapping + +mkEmptyZonkEnv :: UnboundTyVarZonker -> ZonkEnv +mkEmptyZonkEnv zonker = ZonkEnv zonker emptyVarEnv emptyVarEnv extendIdZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv extendIdZonkEnv (ZonkEnv zonk_ty ty_env id_env) ids @@ -1041,7 +1038,7 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) ; let final_bndrs :: [RuleBndr Var] final_bndrs = map (RuleBndr . noLoc) - (varSetElemsKvsFirst unbound_tkvs) + (varSetElemsKvsFirst unbound_tkvs) ++ new_bndrs ; return $ @@ -1249,37 +1246,58 @@ DV, TODO: followup on this note mentioning new examples I will add to perf/ \begin{code} -mkZonkTcTyVar :: (TcTyVar -> TcM Type) -- What to do for an *mutable Flexi* var - -> (TcTyVar -> Type) -- What to do for an immutable var - -> TcTyVar -> TcM TcType -mkZonkTcTyVar unbound_mvar_fn unbound_ivar_fn - = zonk_tv - where - zonk_tv tv - = ASSERT( isTcTyVar tv ) - case tcTyVarDetails tv of - SkolemTv {} -> return (unbound_ivar_fn tv) - RuntimeUnk {} -> return (unbound_ivar_fn tv) - FlatSkol ty -> zonkType zonk_tv ty +zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType +zonkTyVarOcc env@(ZonkEnv zonk_unbound_tyvar tv_env _) tv + | isTcTyVar tv + = case tcTyVarDetails tv of + SkolemTv {} -> lookup_in_env + RuntimeUnk {} -> lookup_in_env + FlatSkol ty -> zonkTcTypeToType env ty MetaTv _ ref -> do { cts <- readMutVar ref ; case cts of Flexi -> do { kind <- {-# SCC "zonkKind1" #-} - zonkType zonk_tv (tyVarKind tv) - ; unbound_mvar_fn (setTyVarKind tv kind) } - Indirect ty -> do { zty <- zonkType zonk_tv ty + zonkTcTypeToType env (tyVarKind tv) + ; zonk_unbound_tyvar (setTyVarKind tv kind) } + Indirect ty -> do { zty <- zonkTcTypeToType env ty -- Small optimisation: shortern-out indirect steps -- so that the old type may be more easily collected. ; writeMutVar ref (Indirect zty) ; return zty } } + | otherwise + = lookup_in_env + where + lookup_in_env -- Look up in the env just as we do for Ids + = case lookupVarEnv tv_env tv of + Nothing -> return (mkTyVarTy tv) + Just tv' -> return (mkTyVarTy tv') zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type -zonkTcTypeToType (ZonkEnv zonk_unbound_tyvar tv_env _id_env) - = zonkType (mkZonkTcTyVar zonk_unbound_tyvar zonk_bound_tyvar) +zonkTcTypeToType env ty + = go ty where - zonk_bound_tyvar tv -- Look up in the env just as we do for Ids - = case lookupVarEnv tv_env tv of - Nothing -> mkTyVarTy tv - Just tv' -> mkTyVarTy tv' + go (TyConApp tc tys) = do tys' <- mapM go tys + return (TyConApp tc tys') + + go (LitTy n) = return (LitTy n) + + go (FunTy arg res) = do arg' <- go arg + res' <- go res + return (FunTy arg' res') + + go (AppTy fun arg) = do fun' <- go fun + arg' <- go arg + return (mkAppTy fun' arg') + -- NB the mkAppTy; we might have instantiated a + -- type variable to a type constructor, so we need + -- to pull the TyConApp to the top. + + -- The two interesting cases! + go (TyVarTy tv) = zonkTyVarOcc env tv + + go (ForAllTy tv ty) = ASSERT( isImmutableTyVar tv ) do + do { (env', tv') <- zonkTyBndrX env tv + ; ty' <- zonkTcTypeToType env' ty + ; return (ForAllTy tv' ty') } zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type] zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 3ba9fbbff6..0a01029d57 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -24,7 +24,7 @@ module TcHsType ( -- Kind-checking types -- No kind generalisation, no checkValidType - tcHsTyVarBndrs, tcHsTyVarBndrsGen , + tcHsTyVarBndrs, tcHsLiftedType, tcLHsType, tcCheckLHsType, tcHsContext, tcInferApps, tcHsArgTys, @@ -177,8 +177,8 @@ tcHsSigTypeNC ctxt (L loc hs_ty) -- The kind is checked by checkValidType, and isn't necessarily -- of kind * in a Template Haskell quote eg [t| Maybe |] + -- Generalise here: see Note [ generalisation] ; ty <- tcCheckHsTypeAndGen hs_ty kind - -- Generalise here: see Note [Kind generalisation] -- Zonk to expose kind information to checkValidType ; ty <- zonkTcType ty @@ -826,28 +826,9 @@ tcHsTyVarBndr (L _ hs_tv) { kind <- case hs_tv of UserTyVar {} -> newMetaKindVar KindedTyVar _ (HsBSig kind _) -> tcLHsKind kind - ; return (mkTyVar name kind) } } } + ; return (mkTcTyVar name kind (SkolemTv False)) } } } ------------------ -tcHsTyVarBndrsGen :: [LHsTyVarBndr Name] - -> TcM (TcTyVarSet, r) -- Result + free tyvars of thing inside - -> TcM ([TyVar], r) -- Generalised kind variables - -- + zonked tyvars + result result --- tcHsTyVarBndrsGen [(f :: ?k -> *), (a :: ?k)] thing_inside --- Returns with tyvars [(k :: BOX), (f :: k -> *), (a :: k)] -tcHsTyVarBndrsGen hs_tvs thing_inside - = do { traceTc "tcHsTyVarBndrsGen" (ppr hs_tvs) - ; (tvs, (ftvs, res)) <- tcHsTyVarBndrs hs_tvs $ \ tvs -> - do { res <- thing_inside - ; return (tvs, res) } - ; let kinds = map tyVarKind tvs - ; kvs' <- kindGeneralize (tyVarsOfTypes kinds `unionVarSet` - (ftvs `delVarSetList` tvs)) - ; zonked_kinds <- mapM zonkTcKind kinds - ; let tvs' = zipWith setTyVarKind tvs zonked_kinds - -- See Note [Kinds of quantified type variables] - ; traceTc "tcTyVarBndrsGen" (ppr (hs_tvs, kvs', tvs)) - ; return (kvs' ++ tvs', res) } ------------------- kindGeneralize :: TyVarSet -> TcM [KindVar] @@ -856,6 +837,9 @@ kindGeneralize tkvs ; tidy_env <- tcInitTidyEnv ; tkvs <- zonkTyVarsAndFV tkvs ; let kvs_to_quantify = varSetElems (tkvs `minusVarSet` gbl_tvs) + -- Any type varaibles in tkvs will be in scope, + -- and hence in gbl_tvs, so after removing gbl_tvs + -- we should only have kind variables left (_, tidy_kvs_to_quantify) = tidyTyVarBndrs tidy_env kvs_to_quantify -- We do not get a later chance to tidy! @@ -1317,8 +1301,8 @@ tc_lhs_kind (L span ki) = setSrcSpan span (tc_hs_kind ki) -- The main worker tc_hs_kind :: HsKind Name -> TcM Kind -tc_hs_kind k@(HsTyVar _) = tc_app k [] -tc_hs_kind k@(HsAppTy _ _) = tc_app k [] +tc_hs_kind k@(HsTyVar _) = tc_kind_app k [] +tc_hs_kind k@(HsAppTy _ _) = tc_kind_app k [] tc_hs_kind (HsParTy ki) = tc_lhs_kind ki @@ -1343,18 +1327,17 @@ tc_hs_kind (HsTupleTy _ kis) = tc_hs_kind k = panic ("tc_hs_kind: " ++ showPpr k) -- Special case for kind application -tc_app :: HsKind Name -> [LHsKind Name] -> TcM Kind -tc_app (HsAppTy ki1 ki2) kis = tc_app (unLoc ki1) (ki2:kis) -tc_app (HsTyVar tc) kis = - do arg_kis <- mapM tc_lhs_kind kis - tc_var_app tc arg_kis -tc_app ki _ = failWithTc (quotes (ppr ki) <+> +tc_kind_app :: HsKind Name -> [LHsKind Name] -> TcM Kind +tc_kind_app (HsAppTy ki1 ki2) kis = tc_kind_app (unLoc ki1) (ki2:kis) +tc_kind_app (HsTyVar tc) kis = do { arg_kis <- mapM tc_lhs_kind kis + ; tc_kind_var_app tc arg_kis } +tc_kind_app ki _ = failWithTc (quotes (ppr ki) <+> ptext (sLit "is not a kind constructor")) -tc_var_app :: Name -> [Kind] -> TcM Kind +tc_kind_var_app :: Name -> [Kind] -> TcM Kind -- Special case for * and Constraint kinds -- They are kinds already, so we don't need to promote them -tc_var_app name arg_kis +tc_kind_var_app name arg_kis | name == liftedTypeKindTyConName || name == constraintKindTyConName = do { unless (null arg_kis) @@ -1362,39 +1345,48 @@ tc_var_app name arg_kis ; thing <- tcLookup name ; case thing of AGlobal (ATyCon tc) -> return (mkTyConApp tc []) - _ -> panic "tc_var_app 1" } + _ -> panic "tc_kind_var_app 1" } -- General case -tc_var_app name arg_kis = do - (_errs, mb_thing) <- tryTc (tcLookup name) - case mb_thing of - Just (AGlobal (ATyCon tc)) - | isAlgTyCon tc || isTupleTyCon tc -> do - data_kinds <- xoptM Opt_DataKinds - unless data_kinds $ addErr (dataKindsErr name) - case isPromotableTyCon tc of - Just n | n == length arg_kis -> - return (mkTyConApp (buildPromotedTyCon tc) arg_kis) - Just _ -> err tc "is not fully applied" - Nothing -> err tc "is not promotable" - - -- A lexically scoped kind variable - Just (ATyVar _ kind_var) -> return (mkAppTys (mkTyVarTy kind_var) arg_kis) - - -- It is in scope, but not what we expected - Just thing -> wrongThingErr "promoted type" thing name - - -- It is not in scope, but it passed the renamer: staging error - Nothing -> -- ASSERT2 ( isTyConName name, ppr name ) - do env <- getLclEnv - traceTc "tc_var_app" (ppr name $$ ppr (tcl_env env)) - failWithTc (ptext (sLit "Promoted kind") <+> - quotes (ppr name) <+> - ptext (sLit "used in a mutually recursive group")) +tc_kind_var_app name arg_kis + = do { (_errs, mb_thing) <- tryTc (tcLookup name) + ; case mb_thing of + Just (AGlobal (ATyCon tc)) + | isAlgTyCon tc || isTupleTyCon tc + -> do { data_kinds <- xoptM Opt_DataKinds + ; unless data_kinds $ addErr (dataKindsErr name) + ; case isPromotableTyCon tc of + Just n | n == length arg_kis -> + return (mkTyConApp (buildPromotedTyCon tc) arg_kis) + Just _ -> err tc "is not fully applied" + Nothing -> err tc "is not promotable" } + + -- A lexically scoped kind variable + Just (ATyVar _ kind_var) + | not (isKindVar kind_var) + -> failWithTc (ptext (sLit "Type variable") <+> quotes (ppr kind_var) + <+> ptext (sLit "used as a kind")) + | not (null arg_kis) -- Kind variables always have kind BOX, + -- so cannot be applied to anything + -> failWithTc (ptext (sLit "Kind variable") <+> quotes (ppr name) + <+> ptext (sLit "cannot appear in a function position")) + | otherwise + -> return (mkAppTys (mkTyVarTy kind_var) arg_kis) + + -- It is in scope, but not what we expected + Just thing -> wrongThingErr "promoted type" thing name + + -- It is not in scope, but it passed the renamer: staging error + Nothing + -> -- ASSERT2 ( isTyConName name, ppr name ) + do { env <- getLclEnv + ; traceTc "tc_kind_var_app" (ppr name $$ ppr (tcl_env env)) + ; failWithTc (ptext (sLit "Promoted kind") <+> + quotes (ppr name) <+> + ptext (sLit "used in a mutually recursive group")) } } where err tc msg = failWithTc (quotes (ppr tc) <+> ptext (sLit "of kind") <+> quotes (ppr (tyConKind tc)) <+> ptext (sLit msg)) - \end{code} %************************************************************************ diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 6db2692fe1..776689084f 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -386,8 +386,12 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- more errors still ; traceTc "tcDeriving" empty + ; th_stage <- getStage -- See Note [Deriving inside TH brackets ] ; (gbl_env, deriv_inst_info, deriv_binds) - <- tcDeriving tycl_decls inst_decls deriv_decls + <- if isBrackStage th_stage + then return (gbl_env, emptyBag, emptyValBindsOut) + else tcDeriving tycl_decls inst_decls deriv_decls + -- Check that if the module is compiled with -XSafe, there are no -- hand written instances of Typeable as then unsafe casts could be @@ -443,6 +447,23 @@ addFamInsts fam_insts thing_inside things = map ATyCon tycons ++ map ACoAxiom axioms \end{code} +Note [Deriving inside TH brackets] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a declaration bracket + [d| data T = A | B deriving( Show ) |] + +there is really no point in generating the derived code for deriving( +Show) and then type-checking it. This will happen at the call site +anyway, and the type check should never fail! Moreover (Trac #6005) +the scoping of the generated code inside the bracket does not seem to +work out. + +The easy solution is simply not to generate the derived instances at +all. (A less brutal solution would be to generate them with no +bindings.) This will become moot when we shift to the new TH plan, so +the brutal solution will do. + + Note [Instance declaration cycles] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ With -XDataKinds we can get this diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index d4d4952711..3ba80e3b0f 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -59,16 +59,15 @@ module TcMType ( -------------------------------- -- Zonking - zonkType, zonkKind, zonkTcPredType, + zonkTcPredType, skolemiseSigTv, skolemiseUnboundMetaTyVar, zonkTcTyVar, zonkTcTyVars, zonkTyVarsAndFV, zonkQuantifiedTyVar, zonkQuantifiedTyVars, zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcKind, defaultKindVarToStar, zonkCt, zonkCts, - zonkImplication, zonkEvVar, zonkWC, + zonkImplication, zonkEvVar, zonkWC, zonkId, - zonkTcTypeAndSubst, tcGetGlobalTyVars, ) where @@ -491,50 +490,10 @@ zonkTcTyVars :: [TcTyVar] -> TcM [TcType] zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars ----------------- Types -zonkTcType :: TcType -> TcM TcType --- Simply look through all Flexis -zonkTcType ty = zonkType zonkTcTyVar ty - -zonkTcTyVar :: TcTyVar -> TcM TcType --- Simply look through all Flexis -zonkTcTyVar tv - = ASSERT2( isTcTyVar tv, ppr tv ) do - case tcTyVarDetails tv of - SkolemTv {} -> zonk_kind_and_return - RuntimeUnk {} -> zonk_kind_and_return - FlatSkol ty -> zonkTcType ty - MetaTv _ ref -> do { cts <- readMutVar ref - ; case cts of - Flexi -> zonk_kind_and_return - Indirect ty -> zonkTcType ty } - where - zonk_kind_and_return = do { z_tv <- zonkTyVarKind tv - ; return (TyVarTy z_tv) } - zonkTyVarKind :: TyVar -> TcM TyVar zonkTyVarKind tv = do { kind' <- zonkTcKind (tyVarKind tv) ; return (setTyVarKind tv kind') } -zonkTcTypeAndSubst :: TvSubst -> TcType -> TcM TcType --- Zonk, and simultaneously apply a non-necessarily-idempotent substitution -zonkTcTypeAndSubst subst ty = zonkType zonk_tv ty - where - zonk_tv tv - = do { z_tv <- updateTyVarKindM zonkTcKind tv - ; ASSERT ( isTcTyVar tv ) - case tcTyVarDetails tv of - SkolemTv {} -> return (TyVarTy z_tv) - RuntimeUnk {} -> return (TyVarTy z_tv) - FlatSkol ty -> zonkType zonk_tv ty - MetaTv _ ref -> do { cts <- readMutVar ref - ; case cts of - Flexi -> zonk_flexi z_tv - Indirect ty -> zonkType zonk_tv ty } } - zonk_flexi tv - = case lookupTyVar subst tv of - Just ty -> zonkType zonk_tv ty - Nothing -> return (TyVarTy tv) - zonkTcTypes :: [TcType] -> TcM [TcType] zonkTcTypes tys = mapM zonkTcType tys @@ -777,23 +736,25 @@ simplifier knows how to deal with. %************************************************************************ %* * -\subsection{Zonking -- the main work-horses: zonkType, zonkTyVar} +\subsection{Zonking -- the main work-horses: zonkTcType, zonkTcTyVar} %* * %* For internal use only! * %* * %************************************************************************ \begin{code} +-- zonkId is used *during* typechecking just to zonk the Id's type +zonkId :: TcId -> TcM TcId +zonkId id + = do { ty' <- zonkTcType (idType id) + ; return (Id.setIdType id ty') } + -- For unbound, mutable tyvars, zonkType uses the function given to it -- For tyvars bound at a for-all, zonkType zonks them to an immutable -- type variable and zonks the kind too -zonkKind :: (TcTyVar -> TcM Kind) -> TcKind -> TcM Kind -zonkKind = zonkType - -zonkType :: (TcTyVar -> TcM Type) -- What to do with TcTyVars - -> TcType -> TcM Type -zonkType zonk_tc_tyvar ty +zonkTcType :: TcType -> TcM TcType +zonkTcType ty = go ty where go (TyConApp tc tys) = do tys' <- mapM go tys @@ -813,7 +774,7 @@ zonkType zonk_tc_tyvar ty -- to pull the TyConApp to the top. -- The two interesting cases! - go (TyVarTy tyvar) | isTcTyVar tyvar = zonk_tc_tyvar tyvar + go (TyVarTy tyvar) | isTcTyVar tyvar = zonkTcTyVar tyvar | otherwise = TyVarTy <$> updateTyVarKindM go tyvar -- Ordinary (non Tc) tyvars occur inside quantified types @@ -821,6 +782,22 @@ zonkType zonk_tc_tyvar ty ty' <- go ty tyvar' <- updateTyVarKindM go tyvar return (ForAllTy tyvar' ty') + +zonkTcTyVar :: TcTyVar -> TcM TcType +-- Simply look through all Flexis +zonkTcTyVar tv + = ASSERT2( isTcTyVar tv, ppr tv ) do + case tcTyVarDetails tv of + SkolemTv {} -> zonk_kind_and_return + RuntimeUnk {} -> zonk_kind_and_return + FlatSkol ty -> zonkTcType ty + MetaTv _ ref -> do { cts <- readMutVar ref + ; case cts of + Flexi -> zonk_kind_and_return + Indirect ty -> zonkTcType ty } + where + zonk_kind_and_return = do { z_tv <- zonkTyVarKind tv + ; return (TyVarTy z_tv) } \end{code} diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 0128f1809e..94c393ca0c 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -12,6 +12,7 @@ module TcRnDriver ( tcRnLookupRdrName, getModuleInterface, tcRnDeclsi, + isGHCiMonad, #endif tcRnLookupName, tcRnGetInfo, @@ -24,6 +25,7 @@ module TcRnDriver ( import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) #endif +import TypeRep import DynFlags import StaticFlags import HsSyn @@ -150,7 +152,16 @@ tcRnModule hsc_env hsc_src save_rn_syntax tcg_env <- {-# SCC "tcRnImports" #-} tcRnImports hsc_env this_mod (prel_imports ++ import_decls) ; - setGblEnv tcg_env $ do { + + -- If the whole module is warned about or deprecated + -- (via mod_deprec) record that in tcg_warns. If we do thereby add + -- a WarnAll, it will override any subseqent depracations added to tcg_warns + let { tcg_env1 = case mod_deprec of + Just txt -> tcg_env { tcg_warns = WarnAll txt } + Nothing -> tcg_env + } ; + + setGblEnv tcg_env1 $ do { -- Load the hi-boot interface for this module, if any -- We do this now so that the boot_names can be passed @@ -171,16 +182,6 @@ tcRnModule hsc_env hsc_src save_rn_syntax tcRnSrcDecls boot_iface local_decls ; setGblEnv tcg_env $ do { - -- Report the use of any deprecated things - -- We do this *before* processsing the export list so - -- that we don't bleat about re-exporting a deprecated - -- thing (especially via 'module Foo' export item) - -- That is, only uses in the *body* of the module are complained about - traceRn (text "rn3") ; - failIfErrsM ; -- finishWarnings crashes sometimes - -- as a result of typechecker repairs (e.g. unboundNames) - tcg_env <- finishWarnings (hsc_dflags hsc_env) mod_deprec tcg_env ; - -- Process the export list traceRn (text "rn4a: before exports"); tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ; @@ -1286,6 +1287,7 @@ tcUserStmt :: LStmt RdrName -> TcM PlanResult tcUserStmt (L loc (ExprStmt expr _ _ _)) = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) -- Don't try to typecheck if the renamer fails! + ; ghciStep <- getGhciStepIO ; uniq <- newUnique ; let fresh_it = itName uniq loc matches = [mkMatch [] rn_expr emptyLocalBinds] @@ -1295,13 +1297,15 @@ tcUserStmt (L loc (ExprStmt expr _ _ _)) -- free variables, and they in turn may have free type variables -- (if we are at a breakpoint, say). We must put those free vars - -- [let it = expr] let_stmt = L loc $ LetStmt $ HsValBinds $ ValBindsOut [(NonRecursive,unitBag the_bind)] [] + -- [it <- e] - bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it)) rn_expr + bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it)) + (nlHsApp ghciStep rn_expr) (HsVar bindIOName) noSyntaxExpr + -- [; print it] print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) (HsVar thenIOName) noSyntaxExpr placeHolderType @@ -1319,7 +1323,7 @@ tcUserStmt (L loc (ExprStmt expr _ _ _)) -- Plan A do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] ; it_ty <- zonkTcType (idType it_id) - ; when (isUnitTy it_ty) failM + ; when (isUnitTy $ it_ty) failM ; return stuff }, -- Plan B; a naked bind statment @@ -1343,20 +1347,26 @@ tcUserStmt rdr_stmt@(L loc _) ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ; rnDump (ppr rn_stmt) ; + ; ghciStep <- getGhciStepIO + ; let gi_stmt + | (L loc (BindStmt pat expr op1 op2)) <- rn_stmt + = L loc $ BindStmt pat (nlHsApp ghciStep expr) op1 op2 + | otherwise = rn_stmt + ; opt_pr_flag <- doptM Opt_PrintBindResult ; let print_result_plan | opt_pr_flag -- The flag says "print result" - , [v] <- collectLStmtBinders rn_stmt -- One binder - = [mk_print_result_plan rn_stmt v] + , [v] <- collectLStmtBinders gi_stmt -- One binder + = [mk_print_result_plan gi_stmt v] | otherwise = [] -- The plans are: -- [stmt; print v] if one binder and not v::() -- [stmt] otherwise - ; runPlans (print_result_plan ++ [tcGhciStmts [rn_stmt]]) } + ; runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]]) } where - mk_print_result_plan rn_stmt v - = do { stuff@([v_id], _) <- tcGhciStmts [rn_stmt, print_v] + mk_print_result_plan stmt v + = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] ; v_ty <- zonkTcType (idType v_id) ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM ; return stuff } @@ -1411,6 +1421,40 @@ tcGhciStmts stmts return (ids, mkHsDictLet (EvBinds const_binds) $ noLoc (HsDo GhciStmt stmts io_ret_ty)) } + +-- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a) +getGhciStepIO :: TcM (LHsExpr Name) +getGhciStepIO = do + ghciTy <- getGHCiMonad + fresh_a <- newUnique + let a_tv = mkTcTyVarName fresh_a (fsLit "a") + ghciM = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv) + ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv) + stepTy = noLoc $ HsForAllTy Implicit + ([noLoc $ UserTyVar a_tv]) + (noLoc []) + (nlHsFunTy ghciM ioM) + step = noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy + return step + +isGHCiMonad :: HscEnv -> InteractiveContext -> String -> IO (Messages, Maybe Name) +isGHCiMonad hsc_env ictxt ty + = initTcPrintErrors hsc_env iNTERACTIVE $ + setInteractiveContext hsc_env ictxt $ do + rdrEnv <- getGlobalRdrEnv + let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty) + case occIO of + Just [n] -> do + let name = gre_name n + ghciClass <- tcLookupClass ghciIoClassName + userTyCon <- tcLookupTyCon name + let userTy = TyConApp userTyCon [] + _ <- tcLookupInstance ghciClass [userTy] + return name + + Just _ -> failWithTc $ text "Ambigous type!" + Nothing -> failWithTc $ text ("Can't find type:" ++ ty) + \end{code} tcRnExpr just finds the type of an expression diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 0d20be2949..2f821b3aae 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -486,6 +486,9 @@ setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_ins getIsGHCi :: TcRn Bool getIsGHCi = do { mod <- getModule; return (mod == iNTERACTIVE) } +getGHCiMonad :: TcRn Name +getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) } + tcIsHsBoot :: TcRn Bool tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) } diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 6807fc8827..2502a92b65 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -757,17 +757,27 @@ tcFamTyPats fam_tc (HsBSig arg_pats (kvars, tvars)) kind_checker thing_inside -- Kind-check and quantify -- See Note [Quantifying over family patterns] - ; (tkvs, typats) <- tcExtendTyVarEnv (map mkKindSigVar kvars) $ - tcHsTyVarBndrsGen (map (noLoc . UserTyVar) tvars) $ - do { typats <- tcHsArgTys (quotes (ppr fam_tc)) arg_pats arg_kinds - ; kind_checker res_kind - ; return (tyVarsOfTypes typats, typats) } - - ; all_args' <- zonkTcTypeToTypes emptyZonkEnv (fam_arg_kinds ++ typats) - ; res_kind' <- zonkTcTypeToType emptyZonkEnv res_kind - ; traceTc "tcFamPats" (ppr tkvs $$ ppr all_args' $$ ppr res_kind') - ; tcExtendTyVarEnv tkvs $ - thing_inside tkvs all_args' res_kind' } + ; typats <- tcExtendTyVarEnv (map mkKindSigVar kvars) $ + tcHsTyVarBndrs (map (noLoc . UserTyVar) tvars) $ \ _ -> + do { kind_checker res_kind + ; tcHsArgTys (quotes (ppr fam_tc)) arg_pats arg_kinds } + ; let all_args = fam_arg_kinds ++ typats + + -- Find free variables (after zonking) + ; tkvs <- zonkTyVarsAndFV (tyVarsOfTypes all_args) + + -- Turn them into skolems, so that we don't subsequently + -- replace a meta kind var with AnyK + ; qtkvs <- zonkQuantifiedTyVars (varSetElems tkvs) + + -- Zonk the patterns etc into the Type world + ; (ze, qtkvs') <- zonkTyBndrsX emptyZonkEnv qtkvs + ; all_args' <- zonkTcTypeToTypes ze all_args + ; res_kind' <- zonkTcTypeToType ze res_kind + + ; traceTc "tcFamPats" (pprTvBndrs qtkvs' $$ ppr all_args' $$ ppr res_kind') + ; tcExtendTyVarEnv qtkvs' $ + thing_inside qtkvs' all_args' res_kind' } \end{code} Note [Quantifying over family patterns] @@ -810,7 +820,7 @@ Then in the family instance we want to Notice that in the third step we quantify over all the visibly-mentioned type variables (a,b), but also over the implicitly mentioned kind varaibles (k, k'). In this case one is bound explicitly but often there will be -none. The rold of the kind signature (a :: Maybe k) is to add a constraint +none. The role of the kind signature (a :: Maybe k) is to add a constraint that 'a' must have that kind, and to bring 'k' into scope. Note [Associated type instances] @@ -867,18 +877,18 @@ dataDeclChecks tc_name new_or_data stupid_theta cons -- Check that the stupid theta is empty for a GADT-style declaration ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name) - -- Check that a newtype has exactly one constructor - -- Do this before checking for empty data decls, so that - -- we don't suggest -XEmptyDataDecls for newtypes - ; checkTc (new_or_data == DataType || isSingleton cons) + -- Check that a newtype has exactly one constructor + -- Do this before checking for empty data decls, so that + -- we don't suggest -XEmptyDataDecls for newtypes + ; checkTc (new_or_data == DataType || isSingleton cons) (newtypeConError tc_name (length cons)) - -- Check that there's at least one condecl, - -- or else we're reading an hs-boot file, or -XEmptyDataDecls - ; empty_data_decls <- xoptM Opt_EmptyDataDecls - ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? - ; checkTc (not (null cons) || empty_data_decls || is_boot) - (emptyConDeclsErr tc_name) } + -- Check that there's at least one condecl, + -- or else we're reading an hs-boot file, or -XEmptyDataDecls + ; empty_data_decls <- xoptM Opt_EmptyDataDecls + ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? + ; checkTc (not (null cons) || empty_data_decls || is_boot) + (emptyConDeclsErr tc_name) } ----------------------------------- tcConDecls :: NewOrData -> Bool -> TyCon -> ([TyVar], Type) @@ -895,46 +905,50 @@ tcConDecl :: NewOrData tcConDecl new_or_data existential_ok rep_tycon res_tmpl -- Data types con@(ConDecl { con_name = name - , con_qvars = tvs, con_cxt = ctxt - , con_details = details, con_res = res_ty }) + , con_qvars = hs_tvs, con_cxt = hs_ctxt + , con_details = details, con_res = hs_res_ty }) = addErrCtxt (dataConCtxt name) $ do { traceTc "tcConDecl 1" (ppr name) - ; (tvs', (ctxt', arg_tys', res_ty', is_infix, field_lbls, stricts)) - <- tcHsTyVarBndrsGen tvs $ - do { ctxt' <- tcHsContext ctxt + ; (tvs, ctxt, arg_tys, res_ty, is_infix, field_lbls, stricts) + <- tcHsTyVarBndrs hs_tvs $ \ tvs -> + do { ctxt <- tcHsContext hs_ctxt ; details' <- tcConArgs new_or_data details - ; res_ty' <- tcConRes res_ty + ; res_ty <- tcConRes hs_res_ty ; let (is_infix, field_lbls, btys') = details' - (arg_tys', stricts) = unzip btys' - ftvs = tyVarsOfTypes ctxt' `unionVarSet` - tyVarsOfTypes arg_tys' `unionVarSet` - case res_ty' of - ResTyH98 -> emptyVarSet - ResTyGADT ty -> tyVarsOfType ty - ; return (ftvs, (ctxt', arg_tys', res_ty', is_infix, field_lbls, stricts)) } - - - -- Substitute, to account for the kind - -- unifications done by tcHsTyVarBndrsGen - ; traceTc "tcConDecl 2" (ppr name) - ; let ze = mkTyVarZonkEnv tvs' - ; arg_tys' <- zonkTcTypeToTypes ze arg_tys' - ; ctxt' <- zonkTcTypeToTypes ze ctxt' - ; res_ty' <- case res_ty' of - ResTyH98 -> return ResTyH98 - ResTyGADT ty -> ResTyGADT <$> zonkTcTypeToType ze ty + (arg_tys, stricts) = unzip btys' + ; return (tvs, ctxt, arg_tys, res_ty, is_infix, field_lbls, stricts) } + + ; let pretend_res_ty = case res_ty of + ResTyH98 -> unitTy + ResTyGADT ty -> ty + pretend_con_ty = mkSigmaTy tvs ctxt (mkFunTys arg_tys pretend_res_ty) + -- This pretend_con_ty stuff is just a convenient way to get the + -- free kind variables of the type, for kindGeneralize to work on + + -- Generalise the kind variables (returning quantifed TcKindVars) + -- and quanify the type variables (substiting their kinds) + ; kvs <- kindGeneralize (tyVarsOfType pretend_con_ty) + ; tvs <- zonkQuantifiedTyVars tvs + + -- Zonk to Types + ; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv (kvs ++ tvs) + ; arg_tys <- zonkTcTypeToTypes ze arg_tys + ; ctxt <- zonkTcTypeToTypes ze ctxt + ; res_ty <- case res_ty of + ResTyH98 -> return ResTyH98 + ResTyGADT ty -> ResTyGADT <$> zonkTcTypeToType ze ty ; checkTc (existential_ok || conRepresentibleWithH98Syntax con) (badExistential name) - ; let (univ_tvs, ex_tvs, eq_preds, res_ty'') - = rejigConRes res_tmpl tvs' res_ty' + ; let (univ_tvs, ex_tvs, eq_preds, res_ty') + = rejigConRes res_tmpl qtkvs res_ty ; traceTc "tcConDecl 3" (ppr name) ; buildDataCon (unLoc name) is_infix stricts field_lbls - univ_tvs ex_tvs eq_preds ctxt' arg_tys' - res_ty'' rep_tycon + univ_tvs ex_tvs eq_preds ctxt arg_tys + res_ty' rep_tycon -- NB: we put data_tc, the type constructor gotten from the -- constructor type signature into the data constructor; -- that way checkValidDataCon can complain if it's wrong. @@ -1234,6 +1248,7 @@ checkValidTyCon tc = case synTyConRhs tc of SynFamilyTyCon {} -> return () SynonymTyCon ty -> checkValidType syn_ctxt ty + | otherwise = do { -- Check the context on the data decl ; traceTc "cvtc1" (ppr tc) @@ -1309,6 +1324,7 @@ checkValidDataCon tc con ; let tc_tvs = tyConTyVars tc res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs) actual_res_ty = dataConOrigResTy con + ; traceTc "checkValidDataCon" (ppr con $$ ppr tc $$ ppr tc_tvs $$ ppr res_ty_tmpl) ; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs) res_ty_tmpl actual_res_ty)) @@ -1416,9 +1432,9 @@ checkValidClass cls -- type variable. What a mess! check_at_defs (fam_tc, defs) - = do mapM_ (\(ATD _tvs pats rhs _loc) -> checkValidFamInst pats rhs) defs - tcAddDefaultAssocDeclCtxt (tyConName fam_tc) $ - mapM_ (check_loc_at_def fam_tc) defs + = do { mapM_ (\(ATD _tvs pats rhs _loc) -> checkValidFamInst pats rhs) defs + ; tcAddDefaultAssocDeclCtxt (tyConName fam_tc) $ + mapM_ (check_loc_at_def fam_tc) defs } check_loc_at_def fam_tc (ATD _tvs pats _rhs loc) -- Set the location for each of the default declarations diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index d22fbdaca1..6e4d12852e 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -1087,8 +1087,12 @@ unifyKind :: TcKind -- k1 (actual) -> TcM Ordering -- Returns the relation between the kinds -- LT <=> k1 is a sub-kind of k2 -unifyKind (TyVarTy kv1) k2 = uKVar False kv1 k2 -unifyKind k1 (TyVarTy kv2) = uKVar True kv2 k1 +-- unifyKind deals with the top-level sub-kinding story +-- but recurses into the simpler unifyKindEq for any sub-terms +-- The sub-kinding stuff only applies at top level + +unifyKind (TyVarTy kv1) k2 = uKVar False unifyKind EQ kv1 k2 +unifyKind k1 (TyVarTy kv2) = uKVar True unifyKind EQ kv2 k1 unifyKind k1 k2 -- See Note [Expanding synonyms during unification] | Just k1' <- tcView k1 = unifyKind k1' k2 @@ -1103,24 +1107,44 @@ unifyKind k1@(TyConApp kc1 []) k2@(TyConApp kc2 []) unifyKind k1 k2 = do { unifyKindEq k1 k2; return EQ } -- In all other cases, let unifyKindEq do the work -uKVar :: Bool -> MetaKindVar -> TcKind -> TcM Ordering -uKVar isFlipped kv1 k2 - | isMetaTyVar kv1 +uKVar :: Bool -> (TcKind -> TcKind -> TcM a) -> a + -> MetaKindVar -> TcKind -> TcM a +uKVar isFlipped unify_kind eq_res kv1 k2 + | isTcTyVar kv1, isMetaTyVar kv1 -- See Note [Unifying kind variables] = do { mb_k1 <- readMetaTyVar kv1 ; case mb_k1 of - Flexi -> uUnboundKVar kv1 k2 >> return EQ - Indirect k1 -> unifyKind k1 k2 } - | TyVarTy kv2 <- k2, isMetaTyVar kv2 - = uKVar (not isFlipped) kv2 (TyVarTy kv1) - | TyVarTy kv2 <- k2, kv1 == kv2 = return EQ + Flexi -> do { uUnboundKVar kv1 k2; return eq_res } + Indirect k1 -> if isFlipped then unify_kind k2 k1 + else unify_kind k1 k2 } + | TyVarTy kv2 <- k2, kv1 == kv2 + = return eq_res + + | TyVarTy kv2 <- k2, isTcTyVar kv2, isMetaTyVar kv2 + = uKVar (not isFlipped) unify_kind eq_res kv2 (TyVarTy kv1) + | otherwise = if isFlipped then unifyKindMisMatch k2 (TyVarTy kv1) else unifyKindMisMatch (TyVarTy kv1) k2 +{- Note [Unifying kind variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Rather hackily, kind variables can be TyVars not just TcTyVars. +Main reason is in + data instance T (D (x :: k)) = ...con-decls... +Here we bring into scope a kind variable 'k', and use it in the +con-decls. BUT the con-decls will be finished and frozen, and +are not amenable to subsequent substitution, so it makes sense +to have the *final* kind-variable (a KindVar, not a TcKindVar) in +scope. So at least during kind unification we can encounter a +KindVar. + +Hence the isTcTyVar tests before using isMetaTyVar. +-} + --------------------------- unifyKindEq :: TcKind -> TcKind -> TcM () -unifyKindEq (TyVarTy kv1) k2 = uKVarEq False kv1 k2 -unifyKindEq k1 (TyVarTy kv2) = uKVarEq True kv2 k1 +unifyKindEq (TyVarTy kv1) k2 = uKVar False unifyKindEq () kv1 k2 +unifyKindEq k1 (TyVarTy kv2) = uKVar True unifyKindEq () kv2 k1 unifyKindEq (FunTy a1 r1) (FunTy a2 r2) = do { unifyKindEq a1 a2; unifyKindEq r1 r2 } @@ -1135,27 +1159,10 @@ unifyKindEq (TyConApp kc1 k1s) (TyConApp kc2 k2s) unifyKindEq k1 k2 = unifyKindMisMatch k1 k2 ---------------- --- For better error messages, we record whether we've flipped the kinds --- during the process. -uKVarEq :: Bool -> MetaKindVar -> TcKind -> TcM () -uKVarEq isFlipped kv1 k2 - | isMetaTyVar kv1 - = do { mb_k1 <- readMetaTyVar kv1 - ; case mb_k1 of - Flexi -> uUnboundKVar kv1 k2 - Indirect k1 -> unifyKindEq k1 k2 } - | TyVarTy kv2 <- k2, isMetaTyVar kv2 - = uKVarEq (not isFlipped) kv2 (TyVarTy kv1) - | TyVarTy kv2 <- k2, kv1 == kv2 = return () - | otherwise = if isFlipped - then unifyKindMisMatch k2 (TyVarTy kv1) - else unifyKindMisMatch (TyVarTy kv1) k2 - ----------------- uUnboundKVar :: MetaKindVar -> TcKind -> TcM () uUnboundKVar kv1 k2@(TyVarTy kv2) | kv1 == kv2 = return () - | isMetaTyVar kv2 -- Distinct kind variables + | isTcTyVar kv2, isMetaTyVar kv2 -- Distinct kind variables = do { mb_k2 <- readMetaTyVar kv2 ; case mb_k2 of Indirect k2 -> uUnboundKVar kv1 k2 diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index 169198c77a..1360baca6b 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -441,7 +441,8 @@ ppr_forall_co p ty \begin{code} pprCoAxiom :: CoAxiom -> SDoc pprCoAxiom ax - = sep [ ptext (sLit "axiom") <+> ppr ax <+> ppr (co_ax_tvs ax) + = sep [ ptext (sLit "axiom") <+> + sep [ ppr ax, nest 2 (pprTvBndrs (co_ax_tvs ax)) ] , nest 2 (dcolon <+> pprEqPred (Pair (co_ax_lhs ax) (co_ax_rhs ax))) ] \end{code} diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index 88fc947242..8f6e32130f 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -361,7 +361,7 @@ vectTopRhs recFs var expr rhs _globalScalar _isDFun (Just (_, expr')) -- Case (1) = return (inlineMe, False, expr') rhs True False Nothing -- Case (2) - = do { expr' <- vectScalarFun True recFs expr + = do { expr' <- vectScalarFun recFs expr ; return (inlineMe, True, vectorised expr') } rhs True True Nothing -- Case (3) diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs index 36fe910323..0764c3b255 100644 --- a/compiler/vectorise/Vectorise/Exp.hs +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -689,14 +689,13 @@ vectDictExpr (Coercion coe) -- instead they become dictionaries of vectorised methods). We treat them differently, though see -- "Note [Scalar dfuns]" in 'Vectorise'. -- -vectScalarFun :: Bool -- ^ Was the function marked as scalar by the user? - -> [Var] -- ^ Functions names in same recursive binding group +vectScalarFun :: [Var] -- ^ Functions names in same recursive binding group -> CoreExpr -- ^ Expression to be vectorised -> VM VExpr -vectScalarFun forceScalar recFns expr - = vectScalarFunVT forceScalar recFns expr (VITNode VISimple []) - - +vectScalarFun recFns expr + -- this is an external call to vectScalarFun, so we pass a dummy vt tree. The only + -- relevant bit is that the node info is *not* VIEncaps + = vectScalarFunVT True recFns expr (VITNode VISimple []) vectScalarFunVT :: Bool -- ^ Was the function marked as scalar by the user? @@ -715,34 +714,24 @@ vectScalarFunVT forceScalar recFns expr (VITNode vi _) "\n\tresult scalar? : " ++ (show $is_scalar_ty scalarTyCons res_ty) ++ "\n\tscalar body? : " ++ (show $is_scalar scalarVars (is_scalar_ty scalarTyCons) expr) ++ "\n\tuses vars? : " ++ (show $uses scalarVars expr) ++ - "\n\t is encaps? : " ++ (show vi) + "\n\t is encaps? (same as & of all prev cond): " ++ (show vi) ) (ppr expr) ; onlyIfV (ptext (sLit "not a scalar function")) (forceScalar -- user asserts the functions is scalar || - (vi == VIEncaps) -- should only be true if all the foll. cond are hold - || + (vi == VIEncaps)) -- should only be true if all the foll. cond are hold + +{- || all (is_scalar_ty scalarTyCons) arg_tys -- check whether the function is scalar && is_scalar_ty scalarTyCons res_ty && is_scalar scalarVars (is_scalar_ty scalarTyCons) expr && uses scalarVars expr) + -} $ do { traceVt "vectScalarFun - is scalar" (ppr expr) ; mkScalarFun arg_tys res_ty expr } } -{- - ; onlyIfV (ptext (sLit "not a scalar function")) - (forceScalar -- user asserts the functions is scalar - || - all is_primitive_ty arg_tys -- check whether the function is scalar - && is_primitive_ty res_ty - && is_scalar scalarVars (is_scalar_ty scalarTyCons) expr - && uses scalarVars expr - && length arg_tys <= mAX_DPH_SCALAR_ARGS) - $ mkScalarFun arg_tys res_ty expr - } - -} where {- -- !!!FIXME: We would like to allow scalar functions with arguments and results that can be @@ -912,7 +901,7 @@ vectScalarDFun var recFns dict = Var var `mkTyApps` (mkTyVarTys tvs) `mkVarApps` thetaVars scsOps = map (\selId -> varToCoreExpr selId `mkTyApps` tys `mkApps` [dict]) selIds - ; vScsOps <- mapM (\e -> vectorised <$> vectScalarFun True recFns e) scsOps + ; vScsOps <- mapM (\e -> vectorised <$> vectScalarFun recFns e) scsOps -- vectorised applications of the class-dictionary data constructor ; Just vDataCon <- lookupDataCon dataCon @@ -1181,8 +1170,8 @@ vectAlgCase tycon _ty_args scrut bndr ty alts (VITNode _ (scrutVit : altVits)) vectAlgCase tycon _ty_args _scrut _bndr _ty _alts (VITNode _ []) = pprPanic "vectAlgCase (mismatched node information)" (ppr tycon) ----- Sanity check of the {- +---- Sanity check of the tree, for debugging only checkTree :: VITree -> CoreExpr -> Bool checkTree (VITNode _ []) (Type _ty) = True @@ -1234,7 +1234,7 @@ distclean : clean $(call removeFiles,libraries/process/include/HsProcessConfig.h) $(call removeFiles,libraries/unix/include/HsUnixConfig.h) $(call removeFiles,libraries/old-time/include/HsTimeConfig.h) - $(call removeTrees,utils/ghc-pwd/dist) + $(call removeTrees,utils/ghc-pwd/dist-boot) $(call removeTrees,inplace) $(call removeTrees,$(patsubst %, libraries/%/autom4te.cache, $(PACKAGES_STAGE1) $(PACKAGES_STAGE2))) diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 75e8ca0f67..f2331b24cf 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -1720,12 +1720,11 @@ setGHCContextFromGHCiState = do -- the actual exception thrown by checkAdd, using tryBool to -- turn it into a Bool. iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st) - GHC.setContext (maybeAddPrelude iidecls) - where - maybeAddPrelude :: [InteractiveImport] -> [InteractiveImport] - maybeAddPrelude iidecls - | any isPreludeImport iidecls = iidecls - | otherwise = iidecls ++ [implicitPreludeImport] + dflags <- GHC.getSessionDynFlags + GHC.setContext $ + if xopt Opt_ImplicitPrelude dflags && not (any isPreludeImport iidecls) + then iidecls ++ [implicitPreludeImport] + else iidecls -- XXX put prel at the end, so that guessCurrentModule doesn't pick it up. |